     H DEBUG(*YES)
     T* Data queue server
     O* CRTBNDRPG DFTACTGRP(*NO) ACTGRP(DQ) DBGVIEW(*ALL) BNDDIR(QC2LE)
     /*                                                                    +
      * Copyright (c) 2009 Rory Hewitt                                     +
      * All rights reserved.                                               +
      *                                                                    +
      * Redistribution and use in source and binary forms, with or without +
      * modification, are permitted provided that the following conditions +
      * are met:                                                           +
      * 1. Redistributions of source code must retain the above copyright  +
      *    notice, this list of conditions and the following disclaimer.   +
      * 2. Redistributions in binary form must reproduce the above         +
      *    copyright notice, this list of conditions and the following     +
      *    disclaimer in the documentation and/or other materials provided +
      *    with the distribution.                                          +
      *                                                                    +
      * THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ''AS IS'' +
      * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED  +
      * TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A    +
      * PARTICULAR PURPOSE ARE DISCLAIMED.  IN NO EVENT SHALL THE AUTHOR   +
      * OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,    +
      * SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT   +
      * LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF   +
      * USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED    +
      * AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT        +
      * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN  +
      * ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE    +
      * POSSIBILITY OF SUCH DAMAGE.                                        +
      */
      *=====================================================================
      *
      * This is the data queue server. It is called by the DQ command with
      * one of three action codes:
      *
      *   *START - If this is an interactive job, a job is submitted with
      *   the same parameters, otherwise the specified data queue and
      *   handler are validated and this program goes into a loop waiting
      *   for entries to appear on the data queue, at which point it
      *   performs the processing specified below.
      *
      *   *END - An entry is put onto the data queue with a special value
      *   of '*END' and this program ends.
      *
      *   *SEND - The specified data is put onto the data queue and this
      *   program ends.
      *
      *   If this program is running as a batch server, it waits for data
      *   queue entries to appear. When an entry appears, is is checked.
      *   If it is the special value '*END', this program quits the receive
      *   loop and ends. For any other value, the data queue entry is passed
      *   to the handler program specified when this job was started.
      *
      *=====================================================================

     D ThisProgram     C                   'DQSVR'

      *---------------------------------------------------------------------
      * Copybooks
      *---------------------------------------------------------------------

      /COPY QRPGLESRC,DQCOPY                      

      *---------------------------------------------------------------------
      * Global variables
      *---------------------------------------------------------------------

      * Program Status Data Structure

     D PgmSDS         SDS                  Qualified
     D  MainProc                     10A
     D  Status                        5S 0
     D  PrvSts                        5S 0
     D  Stmt                          8A
     D  Routine                       8A
     D  Parms                         3S 0
     D  ExcpMsg                       7A
     D   ExcpMsgPfx                   3A   Overlay(ExcpMsg)
     D   ExcpMsgNbr                   4A   Overlay(ExcpMsg:*Next)
     D                                4A
     D  WorkArea                     30A
     D  PgmLib                       10A
     D  ExcpData                     80A
     D  ExcpID                        4A
     D  FileErr                      10A
     D                                6A
     D  Date                          8A
     D  Century                       2A
     D  FileErr2                      8A
     D  FileSts                      35A
     D  qJob                         26A
     D    JobName                    10A   Overlay(qJob)
     D    JobUser                    10A   Overlay(qJob:*Next)
     D    JobNbr                      6A   Overlay(qJob:*Next)
     D  JobDate                       6S 0
     D    JobDateC                    6A   Overlay(JobDate)
     D  RunDate                       6S 0
     D    RunDateC                    6A   Overlay(RunDate)
     D  RunTime                       6S 0
     D    RunTimeC                    6A   Overlay(RunTime)
     D  CmpDate                       6S 0
     D    CmpDateC                    6A   Overlay(CmpDate)
     D  CmpTime                       6S 0
     D    CmpTimeC                    6A   Overlay(CmpTime)
     D  CmpLvl                        4A
     D  SrcfName                     10A
     D  SrcfLib                      10A
     D  SrcfMbr                      10A
     D  OwnPgm                       10A
     D  OwnMod                       10A
     D                               76A
     D  SrcID                         5I 0
     D  SrcID2                        5I 0
     D  UsrPrf                       10A
     D                               62A

      * Data queue definitions

     D DataLen         S              5P 0
     D DtaqKey         DS                  Qualified
     D   Len                          3P 0
     D   Val                               Like(DQ_Key)
     D Wait            S              5P 0
     D SenderInfo      DS                  Qualified
     D   BytesRtn                     7P 0
     D   BytesAvail                   7P 0
     D   qJob                        26A
     D     JobName                   10A   Overlay(qJob)
     D     JobUser                   10A   Overlay(qJob:*Next)
     D     JobNbr                     6A   Overlay(qJob:*Next)
     D   CurJobUser                  10A
     D DtaqSeq         S              6A

      * QCMDEXC - Execute Command API

     D CmdStr          S          32702A
     D qcmdexc         PR                  Extpgm('QCMDEXC')
     D   CmdStr                   32702A   Const Options(*Varsize)
     D   CmdStrLen                   15P 5 Const
     D   AllowDBCS                    3A   Const Options(*Nopass)

      * QUSEC - API Error Structure

     D QUSEC           DS                  Qualified
     D  ErrBytesProv                 10I 0 Inz(%size(QUSEC))
     D  ErrBytesAvail                10I 0 Inz
     D  ErrMsgID                      7A
     D                                1
     D  ErrMsgDta                   512A

      * QMHSNDPM - Send Program Message API

     D qmhsndpm        PR                  Extpgm('QMHSNDPM')
     D   Msgid                        7A   Const
     D   qMsgf                       20A   Const
     D   MsgDta                   65535A   Const Options(*Varsize)
     D   MsgDtaLen                   10I 0 Const
     D   MsgType                     10A   Const
     D   CSEntry                   4096A   Const
     D   CSCount                     10I 0 Const
     D   MsgKey                       4A
     D   ApiError                          Like(QUSEC)
     D   CSEntryLen                  10I 0 Const Options(*Nopass)
     D   qCSEntry                    20A   Const Options(*Nopass)
     D   DPMSWT                      10I 0 Const Options(*Nopass)
     D   CSEntryDType                10A   Const Options(*Nopass)
     D   CCSID                       10I 0 Const Options(*Nopass)

      * QMHRCVPM - Receive Program Message API

     D qmhrcvpm        PR                  Extpgm('QMHRCVPM')
     D   MsgInf                   32767A         Options(*Varsize)
     D   MsgInfLen                   10I 0 Const
     D   Format                       8A   Const
     D   CSE                       4096A   Const
     D   CSC                         10I 0 Const
     D   MsgType                     10A   Const
     D   MsgKey                       4A   Const
     D   WaitTime                    10I 0 Const
     D   MsgAction                   10A   Const
     D   ApiError                          Like(QUSEC)
     D   CSELen                      10I 0 Const Options(*Nopass)
     D   CSEQual                     20A   Const Options(*Nopass)
     D   CSEDtaTyp                   10A   Const Options(*Nopass)
     D   CCSID                       10I 0 Const Options(*Nopass)

     D RCVM0100        DS         65535    Qualified
     D   BytesRtn                    10I 0
     D   BytesAvail                  10I 0
     D   MsgSeverity                 10I 0
     D   MsgID                        7A
     D   MsgType                      2A
     D   MsgKey                       4A
     D                                7A
     D   CCSIDCvtSts                 10I 0
     D   RplDtaCCSID                 10I 0
     D   RplDtaLenRtn                10I 0
     D   RplDtaLenAvl                10I 0

      * QUSROBJD - Retrieve Object Description API

     D qusrobjd        PR                  Extpgm('QUSROBJD')
     D   RcvVar                   65535A         Options(*Varsize)
     D   RcvVarLen                   10I 0 Const
     D   Format                       8A   Const
     D   qObj                        20A   Const
     D   ObjType                     10A   Const
     D   ApiError                          Like(QUSEC) Options(*Nopass)

     D OBJD0100        DS                  Qualified
     D   BytesRtn                    10I 0
     D   BytesAvail                  10I 0
     D   ObjName                     10A
     D   ObjLib                      10A
     D   ObjType                     10A
     D   RtnLib                      10A
     D   ASP                         10I 0
     D   ObjOwn                      10A
     D   ObjDmn                       2A
     D   CrtDate                      7A
     D     CrtC                       1A   Overlay(CrtDate)
     D     CrtYY                      2A   Overlay(CrtDate:*Next)
     D     CrtMM                      2A   Overlay(CrtDate:*Next)
     D     CrtDD                      2A   Overlay(CrtDate:*Next)
     D   CrtTime                      6A
     D     CrtHH                      2A   Overlay(CrtTime)
     D     CrtMN                      2A   Overlay(CrtTime:*Next)
     D     CrtSS                      2A   Overlay(CrtTime:*Next)
     D   ChgDate                      7A
     D     ChgC                       1A   Overlay(ChgDate)
     D     ChgYY                      2A   Overlay(ChgDate:*Next)
     D     ChgMM                      2A   Overlay(ChgDate:*Next)
     D     ChgDD                      2A   Overlay(ChgDate:*Next)
     D   ChgTime                      6A
     D     ChgHH                      2A   Overlay(ChgTime)
     D     ChgMN                      2A   Overlay(ChgTime:*Next)
     D     ChgSS                      2A   Overlay(ChgTime:*Next)

      * QSNDDTAQ - Send Data Queue API

     D qsnddtaq        PR                  Extpgm('QSNDDTAQ')
     D   dtaq                        10A   Const
     D   dtaqlib                     10A   Const
     D   dtaqlen                      5P 0 Const
     D   data                     64512A   Const Options(*Varsize)
     D   keylen                       3P 0 Const Options(*Nopass)
     D   keydata                    256A   Const Options(*Nopass:*Varsize)
     D   asyncrqs                    10A   Const Options(*Nopass)

      * QRCVDTAQ - Receive Data Queue API

     D qrcvdtaq        PR                  Extpgm('QRCVDTAQ')
     D  dtaq                         10A   Const
     D  dtaqlib                      10A   Const
     D  datalen                       5P 0
     D  data                      64512A         Options(*Varsize)
     D  wait                          5P 0 Const
     D  keyorder                      2A   Const Options(*Nopass)
     D  keylen                        3P 0 Const Options(*Nopass)
     D  keydata                     256A         Options(*Nopass:*Varsize)
     D  senderinfolen                 3P 0 Const Options(*Nopass)
     D  senderinfo                32767A         Options(*Nopass:*Varsize)
     D  removemessage                10A   Const Options(*Nopass)
     D  receiverlen                   5P 0 Const Options(*Nopass)
     D  ApiError                           Like(QUSEC) Options(*Nopass)

      * QMHRDQD - Retrieve Data Queue Description API

     D qmhqrdqd        PR                  Extpgm('QMHQRDQD')
     D   RcvVar                   32767A         Options(*Varsize)
     D   RcvVarLen                   10I 0 Const
     D   Format                       8A   Const
     D   qDtaq                       20A   Const

     D RDQD0100        DS                  Qualified
     D   BytesRtn                    10I 0
     D   BytesAvail                  10I 0
     D   MsgLen                      10I 0
     D   KeyLen                      10I 0
     D   Sequence                     1A
     D   IncSenderID                  1A
     D   ForceToAux                   1A
     D   Text                        50A
     D                                3A
     D   CurMsgs                     10I 0
     D   MaxMsgs                     10I 0

      * QUSRJOBI - Retrieve Job Information API

     D qusrjobi        PR                  Extpgm('QUSRJOBI')
     D   RcvVar                   32767A         Options(*Varsize)
     D   RcvVarLen                   10I 0 Const
     D   Format                       8A   Const
     D   qJob                        26A   Const
     D   IntJobID                    16A   Const
     D   ApiError                          Like(QUSEC) Options(*Nopass)

     D JOBI0100        DS                  Qualified
     D   BytesRtn                    10I 0 Inz
     D   BytesAvail                  10I 0 Inz(%size(JOBI0100))
     D   JobName                     10A
     D   JobUser                     10A
     D   JobNumber                    6A
     D   JobIntID                    16A
     D   JobStatus                   10A
     D   JobType                      1A
     D   JobSubtype                   1A
     D                                2A
     D   JobRunPty                   10I 0
     D   JobTimeSlice                10I 0
     D   JobDftWait                  10I 0
     D   JobPurge                    10A

      *---------------------------------------------------------------------
      * Internal procedure prototypes
      *---------------------------------------------------------------------

     D sndPgmMsg       PR            10I 0 Extproc('sndPgmMsg')
     D   MsgID                        7A   Const
     D   MsgDta                    3000A   Const Varying
     D   MsgType                     10A   Const

      *---------------------------------------------------------------------
      * Main procedure interface
      *---------------------------------------------------------------------

     D main            PR                  Extpgm(ThisProgram)
     D   p_Action                          Const Like(DQ_Action)
     D   p_qDtaq                           Const Likeds(DQ_qDtaq)
     D   p_DtaqKey                         Const Like(DQ_Key)
     D   p_qHandler                        Const Likeds(DQ_qHandler)
     D   p_Data                            Const Like(DQ_Data)
     D   p_RtnKey                                Like(DQ_Key) Options(*Nopass)

     D main            PI
     D   p_Action                          Const Like(DQ_Action)
     D   p_qDtaq                           Const Likeds(DQ_qDtaq)
     D   p_DtaqKey                         Const Like(DQ_Key)
     D   p_qHandler                        Const Likeds(DQ_qHandler)
     D   p_Data                            Const Like(DQ_Data)
     D   p_RtnKey                                Like(DQ_Key) Options(*Nopass)

      *=====================================================================
      * MAINLINE
      *=====================================================================
      /free

        // Check data queue existence/type
        exsr checkDtaq;

        select;
          when p_Action = DQ_START; // Start server
            exsr Start;
          when p_Action = DQ_END;   // End server
            DQ_Data = p_Action;
            exsr SendDtaq;
          when p_Action = DQ_SEND;  // Send entry
            DQ_Data = p_Data;
            exsr SendDtaq;
          other;
        endsl;

        if %parms > 6;
          p_RtnKey = DtaqKey.Val;
        endif;

        exsr return;

                                // ===========// 
                                // SUBROUTINES// 
                                // ===========// 

        // return: Return to the caller

        begsr return;
          return;
        endsr;

        // Start: Start the data queue processor

        begsr Start;
          exsr checkHandler;       // Check handler exists
          clear JOBI0100; // Check if this job is batch or interactive
          reset QUSEC;
          qusrjobi( JOBI0100 : %len( JOBI0100 ) : 'JOBI0100' : '*' :
                    *blanks : QUSEC );
          if QUSEC.ErrMsgID <> *blanks;
            exsr *pssr;
          endif;
          if JOBI0100.JobType = 'I'; // Interactive call, so submit a job
            exsr submitJob;
          else;
            exsr receiveDtaq;        // or start receiving data
          endif;
        endsr;

        // submitJob: Submit a job to call this program

        begsr submitJob;
          reset QUSEC;
          CmdStr = 'SBMJOB JOB(' + %trim( DQ_qDtaq.Dtaq ) +
                   ') CMD(CALL PGM(' +
                   %trimr( PgmSDS.PgmLib ) + '/' +
                   %trimr( PgmSDS.MainProc ) + ') PARM(''' +
                   p_Action    + ''' ''' +
                   DQ_qDtaq    + ''' ''' +
                   p_DtaqKey   + ''' ''' +
                   DQ_qHandler + ''')) JOBQ(QUSRNOMAX)';
          callp(e) qcmdexc( CmdStr : %len( CmdStr ) );
          if %error;
            sndPgmMsg( 'CPF9898' : 'Unable to start data queue server' :
                       '*ESCAPE' );
            exsr *pssr;
          endif;
          reset RCVM0100;
          reset qusec;
          qmhrcvpm( RCVM0100 : %len( RCVM0100 ) : 'RCVM0100' : '*' :
                    0 : '*LAST' : *blanks : 0 : '*REMOVE' : qusec );
          sndPgmMsg( RCVM0100.MsgID :
                     %subst( RCVM0100 : 49 : RCVM0100.RplDtaLenRtn ) :
                     '*COMP' );
        endsr;

        // checkDtaq: Check the data queue exists and retrieve its details

        begsr checkDtaq;
          // Determine data queue key value/length from parameters
          DtaqSeq = '*KEYED';
          select;
            when p_DtaqKey = '*NONE';    // Unkeyed data queue
              clear DtaqKey;
              DtaqSeq = '*FIFO';
            when p_DtaqKey = '*JOBNBR';  // Keyed by job number (6 bytes)
              DtaqKey.Len = 6;
              DtaqKey.Val = PgmSDS.JobNbr;
            when p_DtaqKey = '*JOBNAME'; // Keyed by job name (10 bytes)
              DtaqKey.Len = 10;
              DtaqKey.Val = PgmSDS.JobName;
            when p_DtaqKey = '*JOBUSER'; // Keyed by job user (10 bytes)
              DtaqKey.Len = 10;
              DtaqKey.Val = PgmSDS.JobUser;
            other;                       // User-specified (up to 16 bytes)
              DtaqKey.Len = %len( %trimr( p_DtaqKey ) );
              DtaqKey.Val = p_DtaqKey;
          endsl;
          DQ_qDtaq = p_qDtaq;
          // Retrieve data queue library name
          reset QUSEC;
          clear OBJD0100;
          qusrobjd( OBJD0100 : %size( OBJD0100 ) : 'OBJD0100' :
                    DQ_qDtaq : '*DTAQ' : QUSEC );
          if QUSEC.ErrMsgId <> *blanks;
            // If data queue doesn't exist, create it
            if QUSEC.ErrMsgId = 'CPF9801';
              // Create in this program's lib if *LIBL specified
              if DQ_qDtaq.Lib = '*LIBL';
                DQ_qDtaq.Lib = PgmSDS.PgmLib;
              endif;
              // Create data queue
              CmdStr = 'CRTDTAQ DTAQ(' +
                       %trim( DQ_qDtaq.Lib ) + '/' +
                       %trim(DQ_qDtaq.Dtaq ) + ') ' +
                       'TYPE(*STD) MAXLEN(5000) ' +
                       'SENDERID(*YES) SIZE(*MAX2GB) AUT(*LIBCRTAUT) ' +
                       'TEXT(''Data Queue Server'')';
              if DtaqKey.Len > 0;
                CmdStr = %trim( CmdStr ) + ' ' +
                         'SEQ(' + %trim( DtaqSeq ) + ') ' +
                         'KEYLEN(' + %char( DtaqKey.Len ) + ')';
              endif;
              qcmdexc( CmdStr : %len( CmdStr ) );
              if %error;
                sndPgmMsg( 'CPF9898' : 'Unable to create data queue' :
                           '*ESCAPE' );
                exsr *pssr;
              endif;
            else;
              exsr *pssr;
            endif;
          else;
            DQ_qDtaq.Lib = OBJD0100.RtnLib;
          endif;
          DQ_sDtaq = %trimr( DQ_qDtaq.Lib ) + '/' + DQ_qDtaq.Dtaq;
          // Retrieve data queue attributes
          reset RDQD0100;
          qmhqrdqd( RDQD0100 : %size( RDQD0100 ) : 'RDQD0100' : DQ_qDtaq );
          // Check key length
          if DtaqKey.Len > RDQD0100.KeyLen or RDQD0100.KeyLen > 16 or
             ( DtaqKey.Len = 0 and RDQD0100.KeyLen > 0 );
            sndPgmMsg( 'CPF9898' : 'Data queue key mismatch' : '*ESCAPE' );
            exsr *pssr;
          else;
            DtaqKey.Len = RDQD0100.KeyLen;
          endif;
          // Check data length
          if RDQD0100.MsgLen > %len( DQ_Data );
            DataLen = %len( DQ_Data );
          else;
            DataLen = RDQD0100.MsgLen;
          endif;
        endsr;

        // checkHandler: Check the handler exists

        begsr checkHandler;
          DQ_qHandler = p_qHandler;
          if DQ_qHandler.Pgm = '*DFTHDLR';
            DQ_qHandler = DQ_QDFTDQHDLR;
          endif;
          reset QUSEC;
          clear OBJD0100;
          qusrobjd( OBJD0100 : %size( OBJD0100 ) : 'OBJD0100' :
                    DQ_qHandler : '*PGM' : QUSEC );
          if QUSEC.ErrMsgId <> *blanks;
            exsr *pssr;
          endif;
          DQ_qHandler.Lib = OBJD0100.RtnLib;
          DQ_sHandler = %trimr( DQ_qHandler.Lib ) + '/' + DQ_qHandler.Pgm;
        endsr;

        // SendDtaq: Send data queue entry

        begsr SendDtaq;
          qsnddtaq( DQ_qDtaq.Dtaq : DQ_qDtaq.Lib : DataLen : DQ_Data :
                    DtaqKey.Len : DtaqKey.Val );
        endsr;

        // ReceiveDtaq: Receive data queue

        begsr ReceiveDtaq;
          sndPgmMsg( *blanks :
                     'Data queue server started for ' + %trimr( DQ_sDtaq ) +
                     ' using handler ' + %trimr( DQ_sHandler ) +
                     ' with key of ''' + %trimr( DtaqKey.Val ) +
                     ''' (length ' + %char( DtaqKey.Len ) + ').' :
                     '*INFO' );
          Wait = -1;
          // Go into loop waiting for entries to appear on data queue
          dou DataLen = 0;
            reset QUSEC;
            qrcvdtaq( DQ_qDtaq.Dtaq : DQ_qDtaq.Lib : DataLen : DQ_Data :
                      Wait : 'EQ' : DtaqKey.Len : DtaqKey.Val :
                      %size( SenderInfo ) : SenderInfo : '*YES' :
                      %size( DQ_Data ) : QUSEC );
            select;
              when QUSEC.ErrMsgId <> *blanks or DataLen = 0; // Error
                exsr *pssr;
              when DQ_Data = DQ_END;                      // End server
                sndPgmMsg( *blanks :
                           'Data queue server ended by job ' +
                           %trimr( SenderInfo.JobNbr ) + '/' +
                           %trimr( SenderInfo.JobUser ) + '/' +
                           %trimr( SenderInfo.JobName ) + '.' :
                     '*INFO' );
                leave;
              other;                                   // Call handler
                exsr callHandler;
            endsl;
          enddo;
        endsr;

        // callHandler: Call the specified handler program

        begsr callHandler;
          clear DQ_RtnCde;
          callp(e) DQHandler( DtaqKey.Val :
                              DQ_Data :
                              SenderInfo.qJob :
                              DQ_RtnCde );
          if %error;
            sndPgmMsg( 'CPF9898' : 'Error calling handler' : '*ESCAPE' );
            exsr *pssr;
          endif;
          select;
            when DQ_RtnCde = '*WARN';
              sndPgmMsg( 'CPF9898' : 'Error in handler' : '*DIAG' );
            when DQ_RtnCde = '*ERROR';
              sndPgmMsg( 'CPF9898' : 'Fatal error in handler' : '*ESCAPE' );
              exsr *pssr;
            other;
          endsl;
        endsr;

        // *PSSR: Error-handling subroutine

        begsr *pssr;
          if QUSEC.ErrMsgID <> *blanks;
            sndPgmMsg( QUSEC.ErrMsgID : QUSEC.ErrMsgDta : '*ESCAPE' );
          endif;
          sndPgmMsg( 'CPF9898' : 'Error in data queue server' : '*ESCAPE' );
        endsr;

      /end-free
      *=====================================================================
      * sndPgmMsg(): Send a message
      *=====================================================================
     P sndPgmMsg       B
     D                 PI            10I 0
     D   P_MsgID                      7A   Const
     D   MsgDta                    3000A   Const Varying
     D   MsgType                     10A   Const
      *---------------------------------------------------------------------
     D qMsgf           DS
     D   Msgf                        10A   Inz('QCPFMSG')
     D   MsgfLib                     10A   Inz('*LIBL')
     D MsgID           S              7A   Inz
     D CSE             S           4096A   Inz
     D CSC             S             10I 0 Inz
     D MsgKey          S              4A   Inz
      *
      *---------------------------------------------------------------------
      /free

        MsgID = P_MsgID;
        select;
          when MsgType = '*DIAG';
            CSE = '*';
            CSC = 2;
          when MsgType = '*RQS';
            CSE = '*EXT';
            CSC = 0;
          when MsgType = '*STS';
            if MsgID = *blanks;
              MsgID = 'CPF9897';
            endif;
            CSE = '*EXT';
            CSC = 0;
          other;
            CSE = '*';
            CSC = 3;
        endsl;

        reset QUSEC;
        qmhsndpm( MsgID : qMsgf : MsgDta : %len( MsgDta ) :
                  MsgType : CSE : CSC : MsgKey : QUSEC );

        return 0;

        begsr *pssr;
          return -1;
        endsr;

      /end-free
     P                 E
      *=====================================================================

