Quelle csq4cvb4.cob Sprache: Cobol

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                             *
      * ------------------------------------------------------------- *

quality98%

¤ Dauer der Verarbeitung: 0.42 Sekunden (vorverarbeitet) ¤

Wurzel

Suchen

Beweissystem der NASA

Beweissystem Isabelle

NIST Cobol Testsuite

Cephes Mathematical Library

Wiener Entwicklungsmethode

Haftungshinweis

Die Informationen auf dieser Webseite wurden nach bestem Wissen sorgfältig zusammengestellt. Es wird jedoch weder Vollständigkeit, noch Richtigkeit, noch Qualität der bereit gestellten Informationen zugesichert.

Bemerkung:

Die farbliche Syntaxdarstellung ist noch experimentell.