CBL XOPTS(ANSI85)
CBL NODYNAM,LIB,OBJECT,RENT,RES,APOST
      * ------------------------------------------------------------- *
       IDENTIFICATION DIVISION.
      * ------------------------------------------------------------- *
       PROGRAM-ID. CSQ4CVB4.
      *REMARKS
      *****************************************************************
      *   @START_COPYRIGHT@                                           *
      *   Statement:     Licensed Materials - Property of IBM         *
      *                                                               *
      *                  5695-137                                     *
      *                  (C) Copyright IBM Corporation. 1993, 1997    *
      *                                                               *
      *   Status:        Version 1 Release 2                          *
      *   @END_COPYRIGHT@                                             *
      *                                                               *
      *  Module Name           : CSQ4CVB4                             *
      *                                                               *
      *  Environment           : CICS/ESA Version 3.3; COBOL II       *
      *                                                               *
      *  CICS Transaction Name : MVB4                                 *
      *                                                               *
      *  Description : Sample program to show the distribution of     *
      *                a query message to a number of queues, whose   *
      *                names are recovered from a namelist, and the   *
      *                notification of the originators reply queue of *
      *                the number of messages forwarded               *
      *                                                               *
      *  Function    : This program provides the distribution process *
      *                function for the credit check sample           *
      *                See IBM MQSeries for MVS/ESA Application       *
      *                Programming Reference for details.             *
      *                                                               *
      *  Restriction : Maximum of 10 queues in Namelist can be used   *
      *                                                               *
      * ************************************************************* *
          EJECT
      * ************************************************************* *
      *                                                               *
      *                     Program logic                             *
      *                     -------------                             *
      *                                                               *
      *  Start  (A-MAIN SECTION)                                      *
      *  -----                                                        *
      *       Check the program is started with data.                 *
      *       If no go to invalid-start-routine                       *
      *       End-if                                                  *
      *       Retrieve input queue name from trigger data             *
      *       Retrieve namelist name from trigger data                *
      *       If no namelist name passed                              *
      *          Use default namelist name                            *
      *       End-if                                                  *
      *                                                               *
      *       Open the input queue                                    *
      *       If open unsuccessful                                    *
      *          Record error and exit from program                   *
      *       End-if                                                  *
      *                                                               *
      *       Get the output queue names from the namelist            *
      *       If number of output queues not equal to zero            *
      *          Open the output queues                               *
      *       End-if                                                  *
      *                                                               *
      *       Set the call parameters                                 *
      *       Get a message from the input queue with wait            *
      *                                                               *
      *       Do while messages are retrieved                         *
      *          Evaluate message received                            *
      *             When expected message type                        *
      *                If number of output queues not equal to zero   *
      *                   Perform PROCESS-QUERY                       *
      *                Else                                           *
      *                   Perform PROCESS-ABNORMAL-QUERY              *
      *                End-if                                         *
      *             When other                                        *
      *                Perform CHECKQ-UNKNOWN-MSG                     *
      *          End-evaluate                                         *
      *          Reset the call parameters                            *
      *          Get the next message from the input queue with wait  *
      *       End-do                                                  *
      *                                                               *
      *       If loop has not ended because no message is available   *
      *          Record the reason                                    *
      *       End-If                                                  *
      *                                                               *
      *       Close the queues                                        *
      *       Return to CICS                                          *
      *                                                               *
      *                                                               *
      *  PROCESS-QUERY SECTION                                        *
      *  ---------------------                                        *
      *       Set messages sent to 1                                  *
      *       Do for each output queue                                *
      *          Put message to queue                                 *
      *          If put successful                                    *
      *             Add one to messages sent                          *
      *          Else                                                 *
      *             Record the error                                  *
      *          End-if                                               *
      *       End-do                                                  *
      *                                                               *
      *       Put propagation message, containing number of messages  *
      *       sent to reply queue                                     *
      *       If put not successful                                   *
      *          Record the error                                     *
      *          Send the message to the dead letter queue            *
      *       End-if                                                  *
      *                                                               *
      *       Return to performing section                            *
      *                                                               *
      *                                                               *
      *  PROCESS-ABNORMAL-QUERY SECTION                               *
      *  ------------------------------                               *
      *       Set messages sent to 1                                  *
      *       Put error message to the reply queue                    *
      *       If put successful                                       *
      *          Add one to messages sent                             *
      *       Else                                                    *
      *          Record the error                                     *
      *          Send the message to the dead letter queue            *
      *       End-if                                                  *
      *                                                               *
      *       Put propagation message, containing number of messages  *
      *       sent to reply queue                                     *
      *       If put not successful                                   *
      *          Record the error                                     *
      *          Send the message to the dead letter queue            *
      *       End-if                                                  *
      *                                                               *
      *       Return to performing section                            *
      *                                                               *
      *                                                               *
      *  GET-QUEUE-NAMES                                              *
      *  ---------------                                              *
      *       Open the namelist (Perform OPEN-NAMELIST)               *
      *       If open unsuccessful                                    *
      *          Return to performing section                         *
      *       End-if                                                  *
      *                                                               *
      *       Inquire number of queues in namelist and their names    *
      *       If too many queus in namelist                           *
      *          Record the error                                     *
      *          Set number of queues to 10                           *
      *       Else if call fails for any other reason                 *
      *          Record the error                                     *
      *          Set number of queues to 0                            *
      *       End-if                                                  *
      *                                                               *
      *       Close the namelist (Perform CLOSE-NAMELIST)             *
      *                                                               *
      *       Return to performing section                            *
      *                                                               *
      *                                                               *
      *  OPEN-NAMELIST                                                *
      *  -------------                                                *
      *       Set the object descriptor and open options to open the  *
      *       namelist for inquiry                                    *
      *                                                               *
      *       Open the namelist                                       *
      *       If open unsuccessful                                    *
      *          Record the error                                     *
      *       End-if                                                  *
      *                                                               *
      *       Return to performing section                            *
      *                                                               *
      *                                                               *
      *  CLOSE-NAMELIST                                               *
      *  --------------                                               *
      *       Close the namelist                                      *
      *       If close unsuccessful                                   *
      *          Record the error                                     *
      *       End-if                                                  *
      *                                                               *
      *       Return to performing section                            *
      *                                                               *
      *                                                               *
      *  OPEN-OUTPUT-QUEUES                                           *
      *  ------------------                                           *
      *       Set the object descriptor and open options to open the  *
      *       queue for output and to pass identity context           *
      *                                                               *
      *       Do until all queues open, stop if any open fails        *
      *          Move queue name to object descriptor                 *
      *          Open the queue                                       *
      *          If open unsuccessful                                 *
      *             Record the error                                  *
      *          End-if                                               *
      *                                                               *
      *       If any open failed                                      *
      *          Update number of queues with the number opened       *
      *       End-if                                                  *
      *                                                               *
      *       Return to performing section                            *
      *                                                               *
      *                                                               *
      *  CLOSE-QUEUES                                                 *
      *  ------------                                                 *
      *       Close the input queue                                   *
      *       If close unsuccessful                                   *
      *          Record the error                                     *
      *       End-if                                                  *
      *                                                               *
      *       Allow the output queues to be closed by the queue       *
      *       manager after the program terminates                    *
      *                                                               *
      *       Return to performing section                            *
      *                                                               *
      *                                                               *
      *  CHECKQ-UNKNOWN-MSG                                           *
      *  ------------------                                           *
      *       Record the error                                        *
      *       Forward the message to the samples dead queue           *
      *                                                               *
      *       Return to performing section                            *
      *                                                               *
      *                                                               *
      *  RECORD-CALL-ERROR                                            *
      *  -----------------                                            *
      *       Get the time from CICS                                  *
      *       Get the time formatted by CICS                          *
      *       Build the output message data                           *
      *                                                               *
      *       Write the call error message to CICS TS queue CSQ4SAMP  *
      *       Write the log error message to CICS TD queue CSML       *
      *                                                               *
      *       Return to performing section                            *
      *                                                               *
      *                                                               *
      *  FORWARD-MSG-TO-DLQ                                           *
      *  ------------------                                           *
      *       Set the object descriptor, open options, and message    *
      *       descriptor to enable the message to be put to the       *
      *       samples dead letter queue                               *
      *                                                               *
      *       If message to be sent is longer than buffer             *
      *          Set message length to send the full buffer           *
      *       End-if                                                  *
      *                                                               *
      *       Put the message (using MQPUT1) to the queue             *
      *       If put successful                                       *
      *          Record the fact                                      *
      *       Else                                                    *
      *          Record the error                                     *
      *       End-if                                                  *
      *                                                               *
      *       Return to performing section                            *
      *                                                               *
      *                                                               *
      *  INVALID-START-ROUTINE                                        *
      *  ---------------------                                        *
      *       Build error message                                     *
      *       Send message                                            *
      *       Return to cics.                                         *
      *                                                               *
      * ************************************************************* *
          EJECT
      * ------------------------------------------------------------- *
       ENVIRONMENT DIVISION.
      * ------------------------------------------------------------- *
      * ------------------------------------------------------------- *
       DATA DIVISION.
      * ------------------------------------------------------------- *
      * ------------------------------------------------------------- *
       WORKING-STORAGE SECTION.
      * ------------------------------------------------------------- *
      *
      *    W00 - General work fields
      *
       01  W00-MESSAGE                 PIC X(70).
       01  W00-STARTCODE               PIC X(02).
       01  W00-WAIT-INTERVAL           PIC S9(9) BINARY VALUE 30000.
       01  W00-INDEX                   PIC S9(9) BINARY.
       01  W00-MSGS-SENT               PIC S9(9) BINARY.
      *
      *    W01 - Queue names
      *
       01  W01-QUEUE-NAMES.
           05  W01-DEAD-QNAME          PIC X(48) VALUE
           'CSQ4SAMP.DEAD.QUEUE                             '.
           05  W01-NAMELIST            PIC X(48) VALUE
           'CSQ4SAMP.B4.NAMELIST                            '.
      *
      *    CSQ4VB8 contains error messages used in this program
      *
       COPY CSQ4VB8.
      *
      *    Messages returned by this program as part of a reply
      *    message (CSQ4BQRM)
      *
       77  W02-MESSAGE-1               PIC X(79)  VALUE
                '****** RESPONSE FROM DISTRIBUTION PROCESS ******'.
      *
       77  W02-MESSAGE-2               PIC X(79)  VALUE
                '****** PROBLEMS WITH FORWARDING QUERIES   ******'.
      *
       77  W02-MESSAGE-3               PIC X(79)  VALUE
                '****** CONTACT SYSTEM SUPPORT             ******'.
      *
      *    W03 - API fields
      *
       01  W03-HCONN                   PIC S9(9) BINARY VALUE ZERO.
       01  W03-OPTIONS                 PIC S9(9) BINARY.
       01  W03-HOBJ-CHECKQ             PIC S9(9) BINARY.
       01  W03-HOBJ-NAMELIST           PIC S9(9) BINARY.
       01  W03-HOBJ-OUTPUT-TABLE.
           05  W03-HOBJ-OUTPUT        PIC S9(9) BINARY OCCURS 10 TIMES.
       01  W03-COMPCODE                PIC S9(9) BINARY.
       01  W03-REASON                  PIC S9(9) BINARY.
       01  W03-DATALEN                 PIC S9(9) BINARY.
       01  W03-BUFFLEN                 PIC S9(9) BINARY.
       01  W03-SELECTORCOUNT           PIC S9(9) BINARY VALUE 2.
       01  W03-INTATTRCOUNT            PIC S9(9) BINARY VALUE 1.
       01  W03-CHARATTRLENGTH          PIC S9(9) BINARY VALUE 480.
       01  W03-CHARATTRS-TABLE.
           05  W03-QUEUE-NAME          PIC X(48) OCCURS 10 TIMES.
       01  W03-SELECTORS-TABLE.
           05  W03-SELECTORS           PIC S9(9) BINARY OCCURS 2 TIMES.
       01  W03-INTATTRS-TABLE.
           05  W03-NUMBER-OF-QUEUES    PIC S9(9) BINARY.
      *
       01  W03-MSG-BUFFER.
           05 W03-CSQ4BQRM.
           COPY CSQ4VB4.
      *
           05 W03-CSQ4BCAQ REDEFINES W03-CSQ4BQRM.
           COPY CSQ4VB3.
      *
       01  W03-PUT-BUFFER.
           05 W03-CSQ4BPGM.
           COPY CSQ4VB5.
      *
      *    API control blocks
      *
       01  W04-MQM-OBJECT-DESCRIPTOR.
           COPY CMQODV.
       01  W04-MQM-MESSAGE-DESCRIPTOR.
           COPY CMQMDV.
       01  W04-MQM-PUT-MESSAGE-OPTIONS.
           COPY CMQPMOV.
       01  W04-MQM-GET-MESSAGE-OPTIONS.
           COPY CMQGMOV.
       01  W04-TRIGGER-MESSAGE.
           COPY CMQTML.
      *
      *    Error message handling fields
      *
       01  W05-TD-MESSAGE-LENGTH    PIC S9(4) BINARY.
       01  W05-TS-MESSAGE-LENGTH    PIC S9(4) BINARY.
       01  W05-ABSTIME              PIC S9(15) COMP-3.
      *
      *
      *    CMQV contains constants (for filling in the control blocks)
      *    and return codes (for testing the result of a call)
      *
       01  W99-MQV.
       COPY CMQV SUPPRESS.
      *
      *    DFHAID contains the constants used for checking for
      *    attention identifiers
      *
       COPY DFHAID SUPPRESS.
      *
      * ------------------------------------------------------------- *
       LINKAGE SECTION.
      * ------------------------------------------------------------- *
      *
       EJECT
      * ------------------------------------------------------------- *
       PROCEDURE DIVISION.
      * ------------------------------------------------------------- *
      * ------------------------------------------------------------- *
       A-MAIN SECTION.
      * ------------------------------------------------------------- *
      *                                                              *
      *  This section initializes and controls the program flow      *
      *                                                              *
      *  After opening the queues, the program enters a loop         *
      *  getting and processing messages.  Once no more messages     *
      *  are available, shown by the program timing out, control is  *
      *  returned to CICS                                            *
      *                                                              *
      * ------------------------------------------------------------ *
      *
      *    Check that the program has been started with data
      *
           EXEC CICS ASSIGN
               STARTCODE(W00-STARTCODE)
           END-EXEC.
      *
           IF W00-STARTCODE NOT = 'SD'
               PERFORM INVALID-START-ROUTINE
      *        No return from INVALID-START-ROUTINE
           END-IF.
      *
      *    Retrieve the trigger data for this transaction
      *
           EXEC CICS RETRIEVE
                     INTO(MQTM)
           END-EXEC.
      *
      *    At this point the data retrieved has the name of the queue
      *    which has caused this program to be triggered
      *
      *    Replace the Namelist name, if one was passed in the trigger
      *    message
      *
           IF MQTM-USERDATA NOT = SPACES
               MOVE MQTM-USERDATA TO W01-NAMELIST
           END-IF.
      *
      *    Open the queue
      *
           MOVE MQOT-Q      TO MQOD-OBJECTTYPE.
           MOVE MQTM-QNAME  TO MQOD-OBJECTNAME.
      *
      *    Initialize options and open the queue for input
      *
           COMPUTE W03-OPTIONS = MQOO-INPUT-SHARED +
                                 MQOO-SAVE-ALL-CONTEXT.
      *
           CALL 'MQOPEN' USING W03-HCONN
                               MQOD
                               W03-OPTIONS
                               W03-HOBJ-CHECKQ
                               W03-COMPCODE
                               W03-REASON.
      *
      *    Test the output from the open, if
      *    not ok then exit program
      *
           IF W03-COMPCODE NOT = MQCC-OK THEN
               MOVE 'MQOPEN'        TO M02-OPERATION
               MOVE MQOD-OBJECTNAME TO M02-OBJECTNAME
               PERFORM RECORD-CALL-ERROR
               GO TO A-MAIN-EXIT.
      *
      *    Get the queue names from the namelist and open them
      *
           PERFORM GET-QUEUE-NAMES.
      *
           IF W03-NUMBER-OF-QUEUES NOT = ZERO
               PERFORM OPEN-OUTPUT-QUEUES
           END-IF.
      *
      *    Now get and process messages
      *
           COMPUTE MQGMO-OPTIONS = MQGMO-WAIT +
                                   MQGMO-ACCEPT-TRUNCATED-MSG +
                                   MQGMO-SYNCPOINT.
      *
           MOVE LENGTH OF W03-MSG-BUFFER TO W03-BUFFLEN.
           MOVE W00-WAIT-INTERVAL        TO MQGMO-WAITINTERVAL.
           MOVE MQMI-NONE                TO MQMD-MSGID.
           MOVE MQCI-NONE                TO MQMD-CORRELID.
      *
      *    Make the first MQGET call outside the loop
      *
           CALL 'MQGET' USING W03-HCONN
                              W03-HOBJ-CHECKQ
                              MQMD
                              MQGMO
                              W03-BUFFLEN
                              W03-MSG-BUFFER
                              W03-DATALEN
                              W03-COMPCODE
                              W03-REASON.
      *
      *    Test the output of the MQGET call using the PERFORM loop
      *    that follows
      *
      *
      *    Loop from here to END-PERFORM until the MQGET call fails.
      *
           PERFORM WITH TEST BEFORE
                   UNTIL W03-COMPCODE = MQCC-FAILED
      *
      *       Process the message received
      *
              EVALUATE TRUE
                  WHEN ACCOUNT-QUERY-MESSAGE
                      IF W03-NUMBER-OF-QUEUES NOT = ZERO
                          PERFORM PROCESS-QUERY
                      ELSE
                          PERFORM ABNORMAL-PROCESS-QUERY
                      END-IF
                  WHEN OTHER
                      PERFORM CHECKQ-UNKNOWN-MSG
              END-EVALUATE
      *
              EXEC CICS SYNCPOINT END-EXEC
      *
      *       Reset parameters for the next call
      *
              MOVE LENGTH OF W03-MSG-BUFFER TO W03-BUFFLEN
              MOVE MQMI-NONE                TO MQMD-MSGID
              MOVE MQCI-NONE                TO MQMD-CORRELID
      *
      *       Get the next message
      *
              CALL 'MQGET' USING W03-HCONN
                                 W03-HOBJ-CHECKQ
                                 MQMD
                                 MQGMO
                                 W03-BUFFLEN
                                 W03-MSG-BUFFER
                                 W03-DATALEN
                                 W03-COMPCODE
                                 W03-REASON
      *
      *       Test the output of the MQGET call at the top of the loop.
      *       Exit the loop if an error occurs
      *
           END-PERFORM.
      *
      *    Test the output of the MQGET call.  If the call failed,
      *    print an error message showing the completion code and
      *    reason code, unless the reason code is NO-MSG-AVAILABLE
      *
           IF (W03-COMPCODE NOT = MQCC-FAILED) OR
              (W03-REASON NOT = MQRC-NO-MSG-AVAILABLE)
               MOVE 'MQGET '    TO M02-OPERATION
               MOVE MQOD-OBJECTNAME   TO M02-OBJECTNAME
               PERFORM RECORD-CALL-ERROR
           END-IF.
      *
           PERFORM CLOSE-QUEUES.
      *
       A-MAIN-EXIT.
      *
      *    Return to CICS
      *
           EXEC CICS RETURN
           END-EXEC.
      *
           GOBACK.
           EJECT
      *
      * ------------------------------------------------------------- *
       PROCESS-QUERY SECTION.
      * ------------------------------------------------------------- *
      *                                                              *
      *  This section forwards the received message (CSQ4BCAQ)       *
      *  message to each output queue.                               *
      *                                                              *
      *  If any of the puts fails the error is recorded but the      *
      *  process continues. For each successful put the count of     *
      *  messages is incremented by one.                             *
      *                                                              *
      *  Then a propagation message is sent to the reply queue*
      *  of the query.                                               *
      *                                                              *
      * ------------------------------------------------------------ *
      *
      *    put message to each of the output queues
      *
           MOVE LENGTH OF CSQ4BCAQ-MSG TO W03-BUFFLEN.
           MOVE 1                      TO W00-MSGS-SENT.
      *
           PERFORM WITH TEST AFTER VARYING W00-INDEX FROM 1 BY 1
               UNTIL (W00-INDEX = W03-NUMBER-OF-QUEUES)
      *
               MOVE MQMT-REQUEST        TO MQMD-MSGTYPE
               MOVE MQRO-PASS-CORREL-ID TO MQMD-REPORT
               MOVE MQMI-NONE           TO MQMD-MSGID
               COMPUTE MQPMO-OPTIONS     = MQPMO-SYNCPOINT +
                                           MQPMO-PASS-IDENTITY-CONTEXT
               MOVE W03-HOBJ-CHECKQ     TO MQPMO-CONTEXT
      *
               CALL 'MQPUT' USING  W03-HCONN
                                   W03-HOBJ-OUTPUT(W00-INDEX)
                                   MQMD
                                   MQPMO
                                   W03-BUFFLEN
                                   W03-MSG-BUFFER
                                   W03-COMPCODE
                                   W03-REASON
      *
               IF W03-COMPCODE NOT = MQCC-OK THEN
                   MOVE 'MQPUT'  TO M02-OPERATION
                   MOVE W03-QUEUE-NAME(W00-INDEX)
                                 TO M02-OBJECTNAME
                   PERFORM RECORD-CALL-ERROR
               ELSE
                   ADD 1 TO W00-MSGS-SENT
               END-IF
           END-PERFORM.
      *
      * put propagation message to reply queue
      *
           MOVE MQOT-Q           TO MQOD-OBJECTTYPE
           MOVE MQMD-REPLYTOQ    TO MQOD-OBJECTNAME.
           MOVE MQMD-REPLYTOQMGR TO MQOD-OBJECTQMGRNAME.
           MOVE MQMT-DATAGRAM    TO MQMD-MSGTYPE.
           MOVE MQRO-NONE        TO MQMD-REPORT.
           MOVE SPACES           TO MQMD-REPLYTOQ.
           MOVE SPACES           TO MQMD-REPLYTOQMGR.
           MOVE MQMI-NONE        TO MQMD-MSGID.
      *
           MOVE LENGTH OF CSQ4BPGM-MSG TO W03-BUFFLEN.
           SET PROPAGATION-MESSAGE     TO TRUE.
           MOVE W00-MSGS-SENT          TO CSQ4BPGM-MSGS-SENT.
      *
           CALL 'MQPUT1' USING W03-HCONN
                               MQOD
                               MQMD
                               MQPMO
                               W03-BUFFLEN
                               W03-PUT-BUFFER
                               W03-COMPCODE
                               W03-REASON.
      *
           IF W03-COMPCODE NOT = MQCC-OK
               MOVE 'MQPUT1'          TO M02-OPERATION
               MOVE MQOD-OBJECTNAME   TO M02-OBJECTNAME
               PERFORM RECORD-CALL-ERROR
               PERFORM FORWARD-MSG-TO-DLQ
           END-IF.
      *
       PROCESS-QUERY-END.
      *
      *    Return to performing section
      *
           EXIT.
           EJECT
      *
      * ------------------------------------------------------------- *
       ABNORMAL-PROCESS-QUERY SECTION.
      * ------------------------------------------------------------- *
      *                                                              *
      *  This section is puts an error message (no queues to send    *
      *  messages on to) and a propagation message to the reply queue*
      *                                                              *
      * ------------------------------------------------------------ *
      *
      *    Put error message to reply queue, as if it were a reply
      *    message
      *
           MOVE LENGTH OF CSQ4BQRM-MSG TO W03-BUFFLEN.
           MOVE 1                      TO W00-MSGS-SENT.
      *
           SET QUERY-RESPONSE-MESSAGE TO TRUE.
           MOVE W02-MESSAGE-1 TO CSQ4BQRM-LINE(1).
           MOVE W02-MESSAGE-2 TO CSQ4BQRM-LINE(2).
           MOVE W02-MESSAGE-3 TO CSQ4BQRM-LINE(3).
      *
           MOVE MQOT-Q           TO MQOD-OBJECTTYPE
           MOVE MQMD-REPLYTOQ    TO MQOD-OBJECTNAME.
           MOVE MQMD-REPLYTOQMGR TO MQOD-OBJECTQMGRNAME.
           MOVE MQMT-REPLY       TO MQMD-MSGTYPE.
           MOVE MQRO-NONE        TO MQMD-REPORT.
           MOVE SPACES           TO MQMD-REPLYTOQ.
           MOVE SPACES           TO MQMD-REPLYTOQMGR.
           MOVE MQMI-NONE        TO MQMD-MSGID.
           COMPUTE MQPMO-OPTIONS = MQPMO-SYNCPOINT +
                                   MQPMO-PASS-IDENTITY-CONTEXT.
           MOVE W03-HOBJ-CHECKQ  TO MQPMO-CONTEXT.
      *
           CALL 'MQPUT1' USING W03-HCONN
                               MQOD
                               MQMD
                               MQPMO
                               W03-BUFFLEN
                               W03-MSG-BUFFER
                               W03-COMPCODE
                               W03-REASON.
      *
           IF W03-COMPCODE NOT = MQCC-OK THEN
               MOVE 'MQPUT1'        TO M02-OPERATION
               MOVE MQOD-OBJECTNAME TO M02-OBJECTNAME
               PERFORM RECORD-CALL-ERROR
               PERFORM FORWARD-MSG-TO-DLQ
           ELSE
               ADD 1 TO W00-MSGS-SENT
           END-IF.
      *
      * put propagation message to reply to queue
      *
           MOVE LENGTH OF CSQ4BPGM-MSG TO W03-BUFFLEN.
           SET PROPAGATION-MESSAGE     TO TRUE.
           MOVE W00-MSGS-SENT          TO CSQ4BPGM-MSGS-SENT.
      *
           MOVE MQMT-DATAGRAM          TO MQMD-MSGTYPE.
           MOVE MQMI-NONE              TO MQMD-MSGID.
      *
           CALL 'MQPUT1' USING W03-HCONN
                               MQOD
                               MQMD
                               MQPMO
                               W03-BUFFLEN
                               W03-PUT-BUFFER
                               W03-COMPCODE
                               W03-REASON.
      *
           IF W03-COMPCODE NOT = MQCC-OK
               MOVE 'MQPUT1'          TO M02-OPERATION
               MOVE MQOD-OBJECTNAME   TO M02-OBJECTNAME
               PERFORM RECORD-CALL-ERROR
               PERFORM FORWARD-MSG-TO-DLQ
           END-IF.
      *
       ABNORMAL-PROCESS-QUERY-END.
      *
      *    Return to performing section
      *
           EXIT.
           EJECT
      *
      * ------------------------------------------------------------- *
       GET-QUEUE-NAMES SECTION.
      * ------------------------------------------------------------- *
      *                                                              *
      * This section inquires about number of queues in a namelist,  *
      * and gets their names. If more than 10 names are in the       *
      * namelist the section records and error and continues using   *
      * the first 10                                                 *
      *                                                              *
      * ------------------------------------------------------------ *
      *
           PERFORM OPEN-NAMELIST.
      *
      *    Test for an error.  If an error occurred, exit
      *
           IF W03-COMPCODE NOT = MQCC-OK
              GO TO GET-QUEUE-NAMES-EXIT
           END-IF.
      *
      *    Initialize the variables for the MQINQ call, all other
      *    variables were initialized at declaration or by opening
      *    the namelist
      *
           MOVE MQIA-NAME-COUNT  TO W03-SELECTORS(1).
           MOVE MQCA-NAMES       TO W03-SELECTORS(2).
      *
      *    Inquire on the attributes
      *
           CALL 'MQINQ' USING W03-HCONN
                              W03-HOBJ-NAMELIST
                              W03-SELECTORCOUNT
                              W03-SELECTORS-TABLE
                              W03-INTATTRCOUNT
                              W03-INTATTRS-TABLE
                              W03-CHARATTRLENGTH
                              W03-CHARATTRS-TABLE
                              W03-COMPCODE
                              W03-REASON.
      *
      *    Test the output from the inquiry:
      *
      *     - If the completion code is not OK, display an error
      *       message showing the completion and reason codes.
      *
      *     - If the completion code is WARNING and the reason code
      *       is CHAR-ATTRS-TOO-SHORT, display an error message and
      *       use the first 10 queue names
      *
           EVALUATE TRUE
               WHEN (W03-COMPCODE = MQCC-WARNING  AND
                     W03-REASON   = MQRC-CHAR-ATTRS-TOO-SHORT)
                   MOVE 'MQINQ NAMELIST' TO M02-OPERATION
                   MOVE MQOD-OBJECTNAME  TO M02-OBJECTNAME
                   PERFORM RECORD-CALL-ERROR
      *
                   MOVE 'TOO MANY NAMES' TO M02-OPERATION
                   PERFORM RECORD-CALL-ERROR
                   MOVE 10               TO W03-NUMBER-OF-QUEUES
               WHEN W03-COMPCODE NOT = MQCC-OK
                   MOVE 0                TO W03-NUMBER-OF-QUEUES
                   MOVE 'MQINQ'          TO M02-OPERATION
                   MOVE MQOD-OBJECTNAME  TO M02-OBJECTNAME
                   PERFORM RECORD-CALL-ERROR
           END-EVALUATE.
      *
      *    Close the namelist
      *
           PERFORM CLOSE-NAMELIST.
      *
       GET-QUEUE-NAMES-EXIT.
      *
      *    Return to performing section
      *
           EXIT.
           EJECT
      *
      * ------------------------------------------------------------- *
       OPEN-NAMELIST SECTION.
      * ------------------------------------------------------------- *
      *                                                              *
      * This section opens the namelist                              *
      *                                                              *
      * ------------------------------------------------------------ *
      *
      *
           MOVE MQOT-NAMELIST  TO MQOD-OBJECTTYPE.
           MOVE W01-NAMELIST   TO MQOD-OBJECTNAME.
           MOVE SPACES         TO MQOD-OBJECTQMGRNAME.
      *
           COMPUTE W03-OPTIONS =  MQOO-INQUIRE.
      *
           CALL 'MQOPEN' USING W03-HCONN
                               MQOD
                               W03-OPTIONS
                               W03-HOBJ-NAMELIST
                               W03-COMPCODE
                               W03-REASON.
      *
           IF W03-COMPCODE NOT = MQCC-OK THEN
               MOVE 'MQOPEN'        TO M02-OPERATION
               MOVE MQOD-OBJECTNAME TO M02-OBJECTNAME
               PERFORM RECORD-CALL-ERROR
               MOVE 0               TO W03-NUMBER-OF-QUEUES
           END-IF.
      *
       OPEN-NAMELIST-EXIT.
      *
      *    Return to performing section
      *
           EXIT.
           EJECT
      *
      * ------------------------------------------------------------- *
       CLOSE-NAMELIST SECTION.
      * ------------------------------------------------------------- *
      *                                                              *
      * This section closes the namelist                             *
      *                                                              *
      * ------------------------------------------------------------ *
      *
           CALL 'MQCLOSE' USING W03-HCONN
                                W03-HOBJ-NAMELIST
                                MQCO-NONE
                                W03-COMPCODE
                                W03-REASON.
      *
           IF W03-COMPCODE NOT = MQCC-OK THEN
               MOVE 'MQCLOSE'       TO M02-OPERATION
               MOVE MQOD-OBJECTNAME TO M02-OBJECTNAME
               PERFORM RECORD-CALL-ERROR
           END-IF.
      *
       CLOSE-NAMELIST-EXIT.
      *
      *    Return to performing section
      *
           EXIT.
           EJECT
      *
      * ------------------------------------------------------------- *
       OPEN-OUTPUT-QUEUES SECTION.
      * ------------------------------------------------------------- *
      *                                                              *
      * This section opens the queues whose names were obtained      *
      * from the namelist                                            *
      *                                                              *
      * ------------------------------------------------------------ *
      *
           MOVE MQOT-Q         TO MQOD-OBJECTTYPE.
           COMPUTE W03-OPTIONS =  MQOO-OUTPUT +
                                  MQOO-PASS-IDENTITY-CONTEXT.
      *
           PERFORM WITH TEST AFTER VARYING W00-INDEX FROM 1 BY 1
               UNTIL (W00-INDEX = W03-NUMBER-OF-QUEUES OR
                      W03-COMPCODE NOT = MQCC-OK )
      *
               MOVE W03-QUEUE-NAME(W00-INDEX) TO MQOD-OBJECTNAME
      *
               CALL 'MQOPEN' USING W03-HCONN
                                   MQOD
                                   W03-OPTIONS
                                   W03-HOBJ-OUTPUT(W00-INDEX)
                                   W03-COMPCODE
                                   W03-REASON
      *
               IF W03-COMPCODE NOT = MQCC-OK THEN
                   MOVE 'MQOPEN'    TO M02-OPERATION
                   MOVE MQOD-OBJECTNAME TO M02-OBJECTNAME
                   PERFORM RECORD-CALL-ERROR
               END-IF
           END-PERFORM.
      *
      *    If all queues have not been opened successfully, set the
      *    number of queues to the number opened
      *
           IF W03-COMPCODE NOT = MQCC-OK
               MOVE W00-INDEX TO W03-NUMBER-OF-QUEUES
           END-IF.
      *
       OPEN-OUTPUT-QUEUES-EXIT.
      *
      *    Return to performing section
      *
           EXIT.
           EJECT
      *
      * ------------------------------------------------------------- *
       CLOSE-QUEUES SECTION.
      * ------------------------------------------------------------- *
      *                                                              *
      * This section closes the inquiry queue.  The output queues,   *
      * from the namelist, are closed by the queue manager on        *
      * termination of the task                                      *
      *                                                              *
      * ------------------------------------------------------------ *
      *
           CALL 'MQCLOSE' USING W03-HCONN
                                W03-HOBJ-CHECKQ
                                MQCO-NONE
                                W03-COMPCODE
                                W03-REASON.
      *
           IF W03-COMPCODE NOT = MQCC-OK
               MOVE 'MQCLOSE'  TO M02-OPERATION
               MOVE MQTM-QNAME TO M02-OBJECTNAME
               PERFORM RECORD-CALL-ERROR
           END-IF.
      *
       CLOSE-QUEUES-EXIT.
      *
      *    Return to performing section
      *
           EXIT.
           EJECT
      *
      * ------------------------------------------------------------- *
       CHECKQ-UNKNOWN-MSG SECTION.
      * ------------------------------------------------------------- *
      *                                                              *
      *  This section handles unexpected messages by recording the   *
      *  error and forwarding the message to the dead queue          *
      *                                                              *
      * ------------------------------------------------------------ *
      *
           MOVE 'UNKNOWN MSG DETECTED' TO M02-OPERATION.
           MOVE MQOD-OBJECTNAME        TO M02-OBJECTNAME.
      *
           PERFORM RECORD-CALL-ERROR.
      *
           PERFORM FORWARD-MSG-TO-DLQ.
      *
       CHECKQ-UNKNOWN-MSG-EXIT.
      *
           EXIT.
           EJECT
      *
      * ------------------------------------------------------------- *
       RECORD-CALL-ERROR SECTION.
      * ------------------------------------------------------------- *
      *                                                              *
      * This section writes an error message to the CICS td queue    *
      * 'CSML' and the CICS ts queue 'CSQ4SAMP'.                     *
      * The failing operation and object name fields are completed   *
      * by the calling application. The remaining fields of the      *
      * message are completed by this routine                        *
      *                                                              *
      * ------------------------------------------------------------ *
      *
           EXEC CICS ASKTIME
               ABSTIME(W05-ABSTIME)
           END-EXEC.
           EXEC CICS FORMATTIME
               ABSTIME(W05-ABSTIME)
               DATE(M02-DATE) DATESEP
               TIME(M02-TIME) TIMESEP
           END-EXEC.
      *
           MOVE EIBTRNID        TO M02-TRANSACTION
                                   M03-TRANSACTION.
           MOVE EIBTASKN        TO M02-TASK-NUMBER
                                   M03-TASK-NUMBER.
           MOVE W03-COMPCODE    TO M02-COMPCODE
           MOVE W03-REASON      TO M02-REASON
           MOVE M02-DATE        TO M03-DATE.
           MOVE M02-TIME        TO M03-TIME.
           MOVE LENGTH OF M02-CALL-ERROR-MSG
                                TO W05-TS-MESSAGE-LENGTH
           MOVE LENGTH OF M03-CSML-ERROR-MSG
                                TO W05-TD-MESSAGE-LENGTH.
      *
           EXEC CICS WRITEQ TS
               QUEUE('CSQ4SAMP')
               FROM (M02-CALL-ERROR-MSG)
               LENGTH(W05-TS-MESSAGE-LENGTH)
           END-EXEC.
      *
           EXEC CICS WRITEQ TD
               QUEUE('CSML')
               FROM (M03-CSML-ERROR-MSG)
               LENGTH(W05-TD-MESSAGE-LENGTH)
           END-EXEC.
      *
       RECORD-CALL-ERROR-EXIT.
      *
      *    Return to performing section
      *
           EXIT.
           EJECT
      *
      * ------------------------------------------------------------- *
       FORWARD-MSG-TO-DLQ SECTION.
      * ------------------------------------------------------------- *
      *                                                              *
      *  This section forwards a message to the samples dead queue.  *
      *  A message is written using RECORD-CALL-ERROR, the content   *
      *  of the message shows whether the message was put to the     *
      *  dead queue successfully                                     *
      *                                                              *
      * ------------------------------------------------------------ *
      *
           MOVE MQOT-Q          TO MQOD-OBJECTTYPE.
           MOVE W01-DEAD-QNAME  TO MQOD-OBJECTNAME.
      *
           MOVE MQPER-PERSISTENCE-AS-Q-DEF TO MQMD-PERSISTENCE.
      *
      *    Use syncpoint option to avoid possible duplicate messages
      *    on dead queue
      *
           COMPUTE MQPMO-OPTIONS =  MQPMO-SYNCPOINT +
                                    MQPMO-PASS-IDENTITY-CONTEXT.
           MOVE W03-HOBJ-CHECKQ  TO MQPMO-CONTEXT.
      *
      *    Send as many bytes of the message as possible
      *
           IF W03-DATALEN IS LESS THAN W03-BUFFLEN
              MOVE W03-DATALEN TO W03-BUFFLEN
           END-IF.
      *
           CALL 'MQPUT1' USING W03-HCONN
                               MQOD
                               MQMD
                               MQPMO
                               W03-BUFFLEN
                               W03-MSG-BUFFER
                               W03-COMPCODE
                               W03-REASON.
      *
           EVALUATE TRUE
               WHEN (W03-COMPCODE = MQCC-OK AND
                       W03-REASON = MQRC-NONE)
                   MOVE 'MSG PUT TO DLQ' TO M02-OPERATION
                   MOVE W01-DEAD-QNAME   TO M02-OBJECTNAME
                   PERFORM RECORD-CALL-ERROR
               WHEN OTHER
                   MOVE 'MQPUT1'        TO M02-OPERATION
                   MOVE W01-DEAD-QNAME  TO M02-OBJECTNAME
                   PERFORM RECORD-CALL-ERROR
           END-EVALUATE.
      *
       FORWARD-MSG-TO-DLQ-EXIT.
      *
      *    Return to performing section
      *
           EXIT.
      *
      * ------------------------------------------------------------- *
       INVALID-START-ROUTINE SECTION.
      * ------------------------------------------------------------- *
      *                                                              *
      * This section sets sends an error message to a terminal if    *
      * the program is started without data.                         *
      *                                                              *
      * ------------------------------------------------------------ *
      *
           MOVE SPACES TO W00-MESSAGE.
           STRING EIBTRNID
                  M04-STARTUP-ERROR
                  DELIMITED BY SIZE INTO W00-MESSAGE.
 
           EXEC CICS SEND
                     TEXT
                     FROM(W00-MESSAGE)
                     FREEKB
                     ERASE
           END-EXEC.
      *
       INVALID-START-ROUTINE-EXIT.
      *
      *    Return to CICS
      *
           EXEC CICS RETURN
           END-EXEC.
      *
      *
      * ------------------------------------------------------------- *
      *                    End of program                             *
      * ------------------------------------------------------------- *