Quelle csq4cvb2.cob Sprache: unbekannt

Untersuchungsergebnis.cob Download desUnknown {[0] [0] [0]}zum Wurzelverzeichnis wechseln

CBL XOPTS(ANSI85)
CBL NODYNAM,LIB,OBJECT,RENT,RES,APOST
      * ------------------------------------------------------------- *
       IDENTIFICATION DIVISION.
      * ------------------------------------------------------------- *
       PROGRAM-ID. CSQ4CVB2.
      *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           : CSQ4CVB2                             *
      *                                                               *
      *  Environment           : CICS/ESA Version 3.3; COBOL II       *
      *                                                               *
      *  CICS Transaction Name : MVB2                                 *
      *                                                               *
      *  Description : Sample program to show the decomposition of an *
      *                inquiry message to a number of queries, the    *
      *                replies from the queries are received and      *
      *                when all are available a response is built and *
      *                sent to the reply to queue of the inquiry.     *
      *                Part completed inquiries are recovered after   *
      *                the application terminates or after system     *
      *                failure.                                       *
      *                                                               *
      *  Function    : This program provides the credit application   *
      *                manager function for the credit check sample   *
      *                See IBM MQSeries for MVS/ESA Application       *
      *                Programming Reference for details.             *
      *                                                               *
      * ************************************************************* *
         EJECT
      * ************************************************************* *
      *                                                               *
      *                    Program logic                              *
      *                    -------------                              *
      *                                                               *
      *START.                                                         *
      *    check the program is started with data.                    *
      *    if no go to invalid-start-routine                          *
      *    end-if                                                     *
      *    get storage for signal processing.                         *
      *    retrieve trigger data.                                     *
      *    if userdata (amount) passed to program                     *
      *        update threshold amount                                *
      *    end-if                                                     *
      *    open inquiry queue.                                        *
      *    if msg on inquiry queue                                    *
      *        open reply queue (loop through names until o.k.)       *
      *    else                                                       *
      *        open reply queue (name from mqtm-userdata)             *
      *    end-if                                                     *
      *    open waiting queue.                                        *
      *    open checking account queue.                               *
      *    open distribution queue. (change name!)                    *
      *    get browse first msg from waiting queue.                   *
      *    perform until compcode not = ok                            *
      *      evaluate msgtype                                         *
      *        when inquiry msg                                       *
      *          perform irt-add-entry                                *
      *        when response or propagation msg                       *
      *          perform irt-update-entry                             *
      *          if match not found                                   *
      *            perform irt-rebuild-no-match                       *
      *          end-if                                               *
      *        when other                                             *
      *          perform irt-rebuild-unknown-msg                      *
      *      end-evaluate                                             *
      *      get browse next msg from waiting queue                   *
      *    end-perform.                                               *
      *    if unexpected compcode                                     *
      *        exit program.                                          *
      *    perform  main-process until stop-process.                  *
      *    close all queues.                                          *
      *    return to cics.                                            *
      *                                                               *
      * ************************************************************* *
      *MAIN-PROCESS.                                                  *
      *    evaluate                                                   *
      *      when irt table full and inquiryq open                    *
      *        close inquiry queue                                    *
      *      when irt table not full and inquiryq close               *
      *        open inquiry queue                                     *
      *    end-evaluate.                                              *
      *    if irt full                                                *
      *      getwait on reply queue                                   *
      *      evaluate return-codes                                    *
      *        when msg got                                           *
      *          perform process-reply-queue                          *
      *        when no msg                                            *
      *          set flag to stop main-process                        *
      *        when other                                             *
      *          report error                                         *
      *          set flag to call-error                               *
      *      end-evaluate                                             *
      *    else                                                       *
      *      getwait with signal on inquiry queue                     *
      *      evaluate return-codes                                    *
      *        when msg got                                           *
      *          perform process-inquiry-queue                        *
      *        when signal accepted or outstanding                    *
      *          perform process-signal-accepted                      *
      *        when other                                             *
      *          report error                                         *
      *          set flag to call-error                               *
      *      end-evaluate                                             *
      *    end-if.                                                    *
      *    evaluate                                                   *
      *      when calls ok and msg complete                           *
      *        perform send-answer                                    *
      *        if error occured                                       *
      *          rollback uow                                         *
      *          set flag to stop main-process                        *
      *        end-if                                                 *
      *      when calls ok                                            *
      *        syncpoint                                              *
      *      when other                                               *
      *        rollback uow                                           *
      *        set flag to stop main-process                          *
      *    end-evaluate.                                              *
      * ************************************************************* *
      *IRT-ADD-ENTRY.                                                 *
      *    search irt-table                                           *
      *      at end                                                   *
      *         set reply queue trigger control to off                *
      *      when empty entry                                         *
      *         fill entry with data from inquiry msg                 *
      *    end-search.                                                *
      *    if current entries = limit                                 *
      *      set table status to full                                 *
      *    end-if .                                                   *
      *                                                               *
      * ************************************************************* *
      *IRT-UPDATE-ENTRY.                                              *
      *    set update status to ok                                    *
      *    search irt-table                                           *
      *      at end                                                   *
      *         set update status to match not found                  *
      *      when entry msgid = mqmd-correlid                         *
      *         evaluate                                              *
      *           when propagation msg                                *
      *             add/subtract entry counters                       *
      *           when response msg                                   *
      *             add/subtract entry counters                       *
      *         end-evaluate                                          *
      *         if msg complete                                       *
      *           set msg complete flag to true                       *
      *         end-if                                                *
      *                                                               *
      * ************************************************************* *
      *                                                               *
      *IRT-REBUILD-UNKNOWN-MSG.                                       *
      *    report error.                                              *
      *    get msg under cursor.                                      *
      *    if error occured                                           *
      *      report error                                             *
      *      exit this section                                        *
      *    end-if.                                                    *
      *    perform forward-msg-to-dlq.                                *
      *    restore gmo options to browse next                         *
      *                                                               *
      * ************************************************************* *
      *IRT-DELETE-ENTRY.                                              *
      *    initialise irt table entry.                                *
      *    subtract 1 from current entries count.                     *
      *    set irt status to not full.                                *
      *                                                               *
      * ************************************************************* *
      *IRT-REBUILD-NO-MATCH.                                          *
      *    report error.                                              *
      *    get msg under cursor.                                      *
      *    if error occured                                           *
      *      report error                                             *
      *      exit this section                                        *
      *    end-if.                                                    *
      *    perform forward-msg-to-dlq.                                *
      *    restore gmo options to browse next                         *
      *                                                               *
      * ************************************************************* *
      *IRT-NO-MATCH.                                                  *
      *    report error.                                              *
      *                                                               *
      * ************************************************************* *
      *FORWARD-MSG-TO-DLQ.                                            *
      *    mqput1 msg received to dlq.                                *
      *    evaluate return codes                                      *
      *      when ok                                                  *
      *        report that msg has been put to dlq                    *
      *      when other                                               *
      *        report error                                           *
      *    end-evaluate.                                              *
      *                                                               *
      * ************************************************************* *
      *PROCESS-SIGNAL-ACCEPTED.                                       *
      *    perform replyq-getsignal.                                  *
      *    evaluate return codes                                      *
      *      when ok                                                  *
      *        perform process-replyq-msg                             *
      *      when signal accepted or outstanding                      *
      *        perform external-wait                                  *
      *      when other                                               *
      *        report error                                           *
      *        set call-error flag                                    *
      *    end-evaluate.                                              *
      *                                                               *
      * ************************************************************* *
      *EXTERNAL-WAIT.                                                 *
      *    execute cics wait on the two ecbs                          *
      *    if inquiryq ecb posted                                     *
      *      perform test-inquiryq-ecb                                *
      *    else                                                       *
      *      perform test-replyq-ecb                                  *
      *    end-if.                                                    *
      *                                                               *
      * ************************************************************* *
      *TEST-INQUIRYQ-ECB.                                             *
      *    evaluate inquiryq ecb                                      *
      *      when msg arrived                                         *
      *        reset ecb                                              *
      *        perform inquiryq-get                                   *
      *        evaluate return codes                                  *
      *          when ok                                              *
      *            perform process-inquiryq-msg                       *
      *          when no msg                                          *
      *            continue                                           *
      *          when other                                           *
      *            report error                                       *
      *            set call-error flag                                *
      *        end-evaluate                                           *
      *      when wait interval expired                               *
      *        set flag to stop main-process                          *
      *      when wait cancelled                                      *
      *        set flag to stop main-process                          *
      *      when other                                               *
      *        report error                                           *
      *        set call-error flag                                    *
      *    end-evaluate                                               *
      *                                                               *
      * ************************************************************* *
      *TEST-REPLYQ-ECB.                                               *
      *    evaluate replyq ecb                                        *
      *      when msg arrived                                         *
      *        reset ecb                                              *
      *        perform replyq-get                                     *
      *        evaluate return codes                                  *
      *          when ok                                              *
      *            perform process-replyq-msg                         *
      *          when other                                           *
      *            report error                                       *
      *            set call-error flag                                *
      *        end-evaluate                                           *
      *      when wait interval expired                               *
      *        set flag to stop main-process                          *
      *      when wait cancelled                                      *
      *        set flag to stop main-process                          *
      *      when other                                               *
      *        report error                                           *
      *        set call-error flag                                    *
      *    end-evaluate                                               *
      *                                                               *
      * ************************************************************* *
      *INQUIRYQ-GET.                                                  *
      *    mqget msg                                                  *
      *                                                               *
      * ************************************************************* *
      *REPLYQ-GET.                                                    *
      *    mqget msg                                                  *
      *                                                               *
      * ************************************************************* *
      *REPLYQ-GETWAIT.                                                *
      *    mqget wait msg                                             *
      *                                                               *
      * ************************************************************* *
      *PROCESS-REPLYQ-MSG.                                            *
      *    evaluate                                                   *
      *      when response or propagation                             *
      *        perform irt-update-table                               *
      *        if no match                                            *
      *          perform irt-no-match                                 *
      *          perform replyq-unknown-msg                           *
      *        end-if                                                 *
      *      when other                                               *
      *        perform replyq-unknown-msg                             *
      *        exit this section                                      *
      *    end-evaluate.                                              *
      *    mqput msg to waiting queue                                 *
      *    if error occured                                           *
      *      report error                                             *
      *      set call-error flag                                      *
      *    end-if.                                                    *
      *                                                               *
      * ************************************************************* *
      *PROCESS-INQUIRYQ-MSG.                                          *
      *    if not inquiry msg                                         *
      *      perform iquiryq-unknown-msg                              *
      *      exit this section                                        *
      *    end-if.                                                    *
      *    perform irt-add-entry                                      *
      *    mqput msg to waiting queue                                 *
      *    if error occured                                           *
      *      report error                                             *
      *      set call-error flag                                      *
      *      exit this section                                        *
      *    end-if.                                                    *
      *    mqput msg to checking account queue                        *
      *    if error occured                                           *
      *      report error                                             *
      *      set call-error flag                                      *
      *      exit this section                                        *
      *    end-if.                                                    *
      *    if loan figure > threshold amount                          *
      *      mqput to distribution queue                              *
      *      if error occured                                         *
      *        report error                                           *
      *        set call-error flag                                    *
      *        exit this section                                      *
      *      end-if                                                   *
      *                                                               *
      * ************************************************************* *
      *INQUIRYQ-GETSIGNAL.                                            *
      *    mqget with signal                                          *
      *                                                               *
      * ************************************************************* *
      *REPLYQ-GETSIGNAL.                                              *
      *    mqget with signal                                          *
      *                                                               *
      * ************************************************************* *
      *REPLYQ-UNKNOWN-MSG.                                            *
      *    report error                                               *
      *    perform forward-msg-to-dlq.                                *
      *                                                               *
      * ************************************************************* *
      *INQUIRYQ-UNKNOWN-MSG.                                          *
      *    report error                                               *
      *    perform forward-msg-to-dlq.                                *
      *                                                               *
      * ************************************************************* *
      *WAITQ-UNKNOWN-MSG.                                             *
      *    report error                                               *
      *    perform forward-msg-to-dlq.                                *
      *                                                               *
      * ************************************************************* *
      *SEND-ANSWER.                                                   *
      *    perform until all messages retreived or compcode not = ok  *
      *      get msg from waiting queue with correlid.                *
      *      evaluate msgtype                                         *
      *        when inquiry msg                                       *
      *          move data to output msg                              *
      *        when response msg                                      *
      *          move data to output msg                              *
      *        when propagation msg                                   *
      *          continue                                             *
      *        when other                                             *
      *          perform waitq-unknown-msg                            *
      *      end-evaluate                                             *
      *    end-perform.                                               *
      *    if error                                                   *
      *      report error                                             *
      *      set call-error flag                                      *
      *      exit this section                                        *
      *    end-if.                                                    *
      *    reset msg complete flag                                    *
      *    mqput1 answer msg to replytoq                              *
      *    if error occured                                           *
      *      report error                                             *
      *      set call-error flag                                      *
      *      exit this section                                        *
      *    end-if.                                                    *
      *                                                               *
      * ************************************************************* *
      *SET-REPLYQ-TC-OFF.                                             *
      *    mqset tc off                                               *
      *    if error occured                                           *
      *      report error                                             *
      *      set call-error flag                                      *
      *      exit this section                                        *
      *    end-if.                                                    *
      *                                                               *
      * ************************************************************* *
      *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(09) BINARY VALUE 30000.
       01  W00-INPUT-MSG-PRIORITY      PIC S9(09) BINARY.
       01  W00-SUB                     PIC S9(09) BINARY.
       01  W00-INDEX                   PIC S9(09) BINARY.
      *
      *    W01 - Amount
      *
       01  W01-AMOUNT                  PIC X(6)   VALUE '010000'.
      *
      *    Queue names
      *
       01  W02-QUEUE-NAMES.
           05  W02-INQUIRY-QNAME       PIC X(48) VALUE
           'CSQ4SAMP.B2.INQUIRY                             '.
      *
      * The .N in the reply/waiting queue signifies a one digit
      * number 1 to 5.
      * This will be changed in the program.
      *
           05  W02-REPLY-QNAME         PIC X(48) VALUE
           'CSQ4SAMP.B2.REPLY.N                             '.
           05  REDEFINES W02-REPLY-QNAME.
               10                      PIC X(18).
               10 W02-REPLY-QNAME-NUM  PIC 9(01).
               10                      PIC X(29).
           05  W02-WAITING-QNAME       PIC X(48) VALUE
           'CSQ4SAMP.B2.WAITING.N                           '.
           05  REDEFINES W02-WAITING-QNAME.
               10                        PIC X(20).
               10 W02-WAITING-QNAME-NUM  PIC 9(01).
               10                        PIC X(27).
      *
           05  W02-DEAD-QNAME          PIC X(48) VALUE
           'CSQ4SAMP.DEAD.QUEUE                             '.
      *
           05  W02-CHECKACCNT-QNAME    PIC X(48) VALUE
           'CSQ4SAMP.B2.OUTPUT.ALIAS                        '.
      *
           05  W02-DIST-QNAME          PIC X(48) VALUE
           'CSQ4SAMP.B4.MESSAGES                            '.
      *
           05  W02-ANSWER-QNAME        PIC X(48).
           05  W02-ANSWER-QMGRNAME     PIC X(48).
           05  W02-USERIDENTIFIER      PIC X(12).
      *
      *    W03 - MQM API fields
      *
       01  W03-SELECTORCOUNT           PIC S9(9) BINARY VALUE 1.
       01  W03-INTATTRCOUNT            PIC S9(9) BINARY VALUE 1.
       01  W03-CHARATTRLENGTH          PIC S9(9) BINARY VALUE ZERO.
       01  W03-CHARATTRS               PIC X     VALUE LOW-VALUES.
       01  W03-HCONN                   PIC S9(9) BINARY VALUE ZERO.
       01  W03-OPTIONS                 PIC S9(9) BINARY.
       01  W03-HOBJ-REPLYQ             PIC S9(9) BINARY.
       01  W03-HOBJ-INQUIRYQ           PIC S9(9) BINARY.
       01  W03-HOBJ-WAITQ              PIC S9(9) BINARY.
       01  W03-HOBJ-CHECKQ             PIC S9(9) BINARY.
       01  W03-HOBJ-DISTQ              PIC S9(9) BINARY.
       01  W03-COMPCODE                PIC S9(9) BINARY.
       01  W03-REASON                  PIC S9(9) BINARY.
       01  W03-SELECTORS-TABLE.
           05  W03-SELECTORS           PIC S9(9) BINARY OCCURS 2 TIMES.
       01  W03-INTATTRS-TABLE.
           05  W03-INTATTRS            PIC S9(9) BINARY OCCURS 2 TIMES.
       01  W03-DATALEN                 PIC S9(9) BINARY.
       01  W03-BUFFLEN                 PIC S9(9) BINARY.
      *
       01  W03-GET-BUFFER.
           05 W03-CSQ4BQRM.
           COPY CSQ4VB4.
      *
           05 W03-CSQ4BIIM REDEFINES W03-CSQ4BQRM.
           COPY CSQ4VB1.
      *
           05 W03-CSQ4BPGM REDEFINES W03-CSQ4BIIM.
           COPY CSQ4VB5.
      *
       01  W03-PUT-BUFFER.
           05 W03-CSQ4BAM.
           COPY CSQ4VB2.
      *
           05 W03-CSQ4BCAQ REDEFINES W03-CSQ4BAM.
           COPY CSQ4VB3.
      *
      *    API control blocks
      *
       01  MQM-OBJECT-DESCRIPTOR.
           COPY CMQODV.
       01  MQM-MESSAGE-DESCRIPTOR.
           COPY CMQMDV.
       01  MQM-PUT-MESSAGE-OPTIONS.
           COPY CMQPMOV.
       01  MQM-GET-MESSAGE-OPTIONS.
           COPY CMQGMOV.
       01  MQM-TRIGGER-MESSAGE.
           COPY CMQTML.
      *
      *    Fields for ECB handling
      *
       01  W04-ECB-ADDR-LIST-PTR    POINTER.
       01  W04-ECB-PTR              POINTER.
       01  W04-INITIMG              PIC X VALUE LOW-VALUES.
      *
      *    CICS ts queue 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.
      *
      *    main process flags
      *
       01  W06-MAIN-PROCESS-FLAG    PIC 9 VALUE 0.
           88 END-PROCESS VALUE 1.
       01  W06-END-PROCESS          PIC 9 VALUE 1.
      *
       01  W06-INQUIRYQ-STATUS      PIC X(6) VALUE 'CLOSED'.
           88 INQUIRYQ-OPEN   VALUE 'OPEN'.
           88 INQUIRYQ-CLOSED VALUE 'CLOSED'.
      *
       01  W06-CALL-STATUS          PIC X(6) VALUE 'OK'.
           88 CALLS-OK       VALUE 'OK'.
       01  W06-CALL-ERROR           PIC X(6) VALUE 'FAILED'.
      *
       01  W06-MSG-STATUS           PIC 9 VALUE 0.
           88 MSG-COMPLETE     VALUE 1.
           88 MSG-NOT-COMPLETE VALUE 0.
      *
      *    CSQ4VB8 contains error messages used in this program
      *
       COPY CSQ4VB8.
      *
      *    Inquiry Record Table definition and associated fields
      *
       01  IRT-SUB                  PIC S9(9) BINARY.
       01  IRT-STATUS-OK            PIC S9(9) BINARY VALUE ZEROS.
       01  IRT-STATUS-NO-MATCH      PIC S9(9) BINARY VALUE 1.
       01  IRT-UPDATE-STATUS        PIC S9(9) BINARY VALUE ZEROS.
           88 IRT-UPDATE-NO-MATCH VALUE 1.
       01  IRT-MAX-ENTRIES          PIC S9(9) BINARY.
       01  IRT-CURRENT-ENTRIES      PIC S9(9) BINARY VALUE ZEROS.
       01  IRT-TABLE-SET-FULL       PIC S9(9) BINARY VALUE 1.
       01  IRT-TABLE-SET-NOT-FULL   PIC S9(9) BINARY VALUE ZEROS.
       01  IRT-TABLE-STATUS         PIC S9(9) BINARY VALUE ZEROS.
           88 IRT-TABLE-FULL VALUE 1.
      *
      *    Size of IRT-TABLE is set here - to 10 initially
      *
       01  IRT-TABLE.
           05 IRT-TABLE-ELEMENT OCCURS 10 INDEXED BY IRT-INDEX1.
              10 IRT-TABLE-ENTRY.
                 15 IRT-MSGID        PIC X(24).
                 15 IRT-PROPSOUT     PIC S9(9) BINARY.
                 15 IRT-REPLYEXP     PIC S9(9) BINARY.
                 15 IRT-REPLYREC     PIC S9(9) BINARY.
      *
      *    MQV 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.
      * ------------------------------------------------------------- *
       01  L01-ECB-ADDR-LIST.
           05  L01-ECB-ADDR1        POINTER.
           05  L01-ECB-ADDR2        POINTER.
      *
       01  L02-ECBS.
           05  L02-INQUIRY-ECB1     PIC S9(09) BINARY.
           05  L02-REPLY-ECB2       PIC S9(09) BINARY.
       01  REDEFINES L02-ECBS.
           05                       PIC  X(02).
           05  L02-INQUIRY-ECB1-CC  PIC S9(04) BINARY.
           05                       PIC  X(02).
           05  L02-REPLY-ECB2-CC    PIC S9(04) BINARY.
      *
       EJECT
      * ------------------------------------------------------------- *
       PROCEDURE DIVISION.
      * ------------------------------------------------------------- *
      * ------------------------------------------------------------- *
       A-MAIN SECTION.
      * ------------------------------------------------------------- *
      *                                                               *
      *                                                               *
      * ------------------------------------------------------------- *
      *
      *
      *    Initialize IRT and compute number of entries in table
      *
           MOVE LOW-VALUES TO IRT-TABLE.
           COMPUTE IRT-MAX-ENTRIES = LENGTH OF IRT-TABLE /
                                     LENGTH OF IRT-TABLE-ENTRY.
      *
      *    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.
      *
      *    Getmain storage for possible external wait on ecbs
      *
           EXEC CICS GETMAIN
               SET(W04-ECB-ADDR-LIST-PTR)
               FLENGTH(8)
           END-EXEC.
      *
      *    get addressability to storage
      *
           SET ADDRESS OF L01-ECB-ADDR-LIST TO W04-ECB-ADDR-LIST-PTR.
      *
           EXEC CICS GETMAIN
               SET(W04-ECB-PTR)
               FLENGTH(8)
               INITIMG(W04-INITIMG)
           END-EXEC.
      *
      *    get addressability to storage
      *
           SET ADDRESS OF L02-ECBS TO W04-ECB-PTR.
      *
      *    store address's of ebcs into list
      *
           SET L01-ECB-ADDR1 TO ADDRESS OF L02-INQUIRY-ECB1.
           SET L01-ECB-ADDR2 TO ADDRESS OF L02-REPLY-ECB2.
      *
      *    Retrieve the trigger data this transaction was started with
      *
           EXEC CICS RETRIEVE
                     INTO(MQTM)
           END-EXEC.
      *
      *    Get the amount, if one is passed
      *
           IF MQTM-USERDATA NOT = SPACE
               MOVE MQTM-USERDATA TO W01-AMOUNT
           END-IF.
      *
      *    Open the inquiry queue
      *
           PERFORM OPEN-INQUIRYQ.
      *
      *    Test the output from the open.
      *    If not ok write record the error an exit from the program
      *
           IF W03-COMPCODE NOT = MQCC-OK THEN
               GO TO A-MAIN-EXIT
           ELSE
               SET INQUIRYQ-OPEN TO TRUE
           END-IF.
      *
      *    At this point the data retrieved determines the open
      *    queue processing.
      *
      *    If the inquiry-queue has been triggered then
      *        loop trying to open a reply-queue
      *
      *    If a reply-queue has been triggered then open that
      *        particular reply-queue
      *
           IF MQTM-QNAME = W02-INQUIRY-QNAME
               PERFORM OPEN-UNNAMED-REPLY-QUEUE
               IF W03-COMPCODE NOT = MQCC-OK
                   GO TO A-MAIN-EXIT
               END-IF
           ELSE
               PERFORM OPEN-NAMED-REPLY-QUEUE
               IF W03-COMPCODE NOT = MQCC-OK
                   GO TO A-MAIN-EXIT
               ELSE
                   MOVE MQTM-QNAME TO W02-REPLY-QNAME
               END-IF
           END-IF.
      *
      *    Open the Waiting Queue
      *    Use the number from the reply queue - matching pairs
      *
           MOVE MQOT-Q              TO MQOD-OBJECTTYPE.
           MOVE W02-REPLY-QNAME-NUM TO W02-WAITING-QNAME-NUM.
           MOVE W02-WAITING-QNAME   TO MQOD-OBJECTNAME.
      *
      *    Initialize W03-OPTIONS to open the queue for input
      *    exclusive, browse and output
      *
           COMPUTE W03-OPTIONS = MQOO-INPUT-EXCLUSIVE +
                                 MQOO-BROWSE +
                                 MQOO-PASS-IDENTITY-CONTEXT +
                                 MQOO-SAVE-ALL-CONTEXT +
                                 MQOO-OUTPUT.
      *
      *    Open the queue
      *
           CALL 'MQOPEN' USING W03-HCONN
                               MQOD
                               W03-OPTIONS
                               W03-HOBJ-WAITQ
                               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.
      *
      *    Open the Checking Account Queue
      *
           MOVE MQOT-Q               TO MQOD-OBJECTTYPE.
           MOVE W02-CHECKACCNT-QNAME TO MQOD-OBJECTNAME.
      *
      *    Initialize W03-OPTIONS to open the queue for output
      *
           COMPUTE W03-OPTIONS = MQOO-OUTPUT +
                                 MQOO-PASS-IDENTITY-CONTEXT.
      *
      *    Open the queue
      *
           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.
      *
      *    Open the Distribution Queue
      *
      *
           MOVE MQOT-Q         TO MQOD-OBJECTTYPE.
           MOVE W02-DIST-QNAME TO MQOD-OBJECTNAME.
      *
      *    Initialize W03-OPTIONS to open the queue for output
      *
           COMPUTE W03-OPTIONS = MQOO-OUTPUT +
                                 MQOO-PASS-IDENTITY-CONTEXT.
      *
      *    Open the queue
      *
           CALL 'MQOPEN' USING W03-HCONN
                               MQOD
                               W03-OPTIONS
                               W03-HOBJ-DISTQ
                               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.
      *
      *****************************************************************
      *    Rebuild the IRT (Inquiry Record Table)
      *****************************************************************
      *
      *    Initialize the Get Message Options (MQGMO) control block.
      *    (The copy book initializes the remaining fields)
      *
           COMPUTE MQGMO-OPTIONS = MQGMO-NO-WAIT +
                                   MQGMO-BROWSE-FIRST.
           MOVE LENGTH OF W03-GET-BUFFER TO W03-BUFFLEN.
      *
      *    Make the first MQGET call outside the loop
      *    using the BROWSE-FIRST option
      *
           CALL 'MQGET' USING W03-HCONN
                              W03-HOBJ-WAITQ
                              MQMD
                              MQGMO
                              W03-BUFFLEN
                              W03-GET-BUFFER
                              W03-DATALEN
                              W03-COMPCODE
                              W03-REASON.
      *
      *    Test the output of the MQGET call using the PERFORM loop
      *    that follows.
      *
      *    Change the MQGMO Options field to BROWSE-NEXT
      *
           COMPUTE MQGMO-OPTIONS = MQGMO-NO-WAIT +
                                   MQGMO-BROWSE-NEXT.
      *
      *    Loop from here to END-PERFORM until the MQGET call fails
      *
           PERFORM WITH TEST BEFORE
                   UNTIL W03-COMPCODE NOT = MQCC-OK
      *
      *       Perform relevant add/update IRT entry dependent upon
      *       message. If message unknown then put it to deadq
      *
              EVALUATE TRUE
                  WHEN INITIAL-INQUIRY-MESSAGE
                      PERFORM T1-IRT-ADD-ENTRY
                  WHEN QUERY-RESPONSE-MESSAGE OR PROPAGATION-MESSAGE
                      PERFORM T2-IRT-UPDATE-ENTRY
                      IF IRT-UPDATE-NO-MATCH
                          PERFORM T5-IRT-REBUILD-NO-MATCH
                      END-IF
                  WHEN OTHER
                      PERFORM T3-IRT-REBUILD-UNKNOWN-MSG
              END-EVALUATE
      *
      *       Clear MQMD-MSGID and MQMD-CORRELID before the next
      *       MQGET call to ensure that all messages are retrieved
      *
              MOVE MQMI-NONE TO MQMD-MSGID
              MOVE MQCI-NONE TO MQMD-CORRELID
      *
      *       Get the next message
      *
              CALL 'MQGET' USING W03-HCONN
                                 W03-HOBJ-WAITQ
                                 MQMD
                                 MQGMO
                                 W03-BUFFLEN
                                 W03-GET-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.
      *
      *    Note: When the loop reaches the end of the file, the
      *          completion code is MQCC-FAILED and the reason code
      *          is MQRC-NO-MSG-AVAILABLE
      *
           IF ( (W03-COMPCODE NOT = MQCC-FAILED) OR
                (W03-REASON NOT = MQRC-NO-MSG-AVAILABLE) )
               MOVE 'MQGET BROWSE'    TO M02-OPERATION
               MOVE W02-WAITING-QNAME TO M02-OBJECTNAME
               PERFORM RECORD-CALL-ERROR
               GO TO A-MAIN-EXIT.
      *
      *
      *    Loop until wait expired on either or both inquire and
      *    reply queue depending on IRT status. Achieved by setting
      *    flag
      *
           PERFORM MAIN-PROCESS WITH TEST AFTER
              UNTIL END-PROCESS.
      *
           PERFORM CLOSE-QUEUES.
      *
       A-MAIN-EXIT.
      *
      *
      * Return to CICS
      *
           EXEC CICS RETURN
           END-EXEC.
      *
           GOBACK.
           EJECT
      *
      * ------------------------------------------------------------- *
       CLOSE-QUEUES SECTION.
      * ------------------------------------------------------------- *
      *                                                              *
      * This section closes the queues.                              *
      *                                                              *
      * ------------------------------------------------------------ *
      *
           IF INQUIRYQ-OPEN
               PERFORM CLOSE-INQUIRYQ
      *
      *    Close waiting and reply queues, waiting before reply
      *    to avoid problems if multiple instances of the program
      *    are triggered
      *
           CALL 'MQCLOSE' USING W03-HCONN
                                W03-HOBJ-WAITQ
                                MQCO-NONE
                                W03-COMPCODE
                                W03-REASON.
      *
           IF W03-COMPCODE NOT = MQCC-OK
               MOVE 'MQCLOSE'            TO M02-OPERATION
               MOVE W02-WAITING-QNAME    TO M02-OBJECTNAME
               PERFORM RECORD-CALL-ERROR
           END-IF.
      *
           CALL 'MQCLOSE' USING W03-HCONN
                                W03-HOBJ-REPLYQ
                                MQCO-NONE
                                W03-COMPCODE
                                W03-REASON.
      *
           IF W03-COMPCODE NOT = MQCC-OK
               MOVE 'MQCLOSE'            TO M02-OPERATION
               MOVE W02-REPLY-QNAME      TO M02-OBJECTNAME
               PERFORM RECORD-CALL-ERROR
           END-IF.
      *
      *    Close the output queues
      *
           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 W02-CHECKACCNT-QNAME TO M02-OBJECTNAME
               PERFORM RECORD-CALL-ERROR
           END-IF.
      *
           CALL 'MQCLOSE' USING W03-HCONN
                                W03-HOBJ-DISTQ
                                MQCO-NONE
                                W03-COMPCODE
                                W03-REASON.
      *
           IF W03-COMPCODE NOT = MQCC-OK
               MOVE 'MQCLOSE'            TO M02-OPERATION
               MOVE W02-DIST-QNAME       TO M02-OBJECTNAME
               PERFORM RECORD-CALL-ERROR
           END-IF.
      *
       CLOSE-QUEUES-EXIT.
      *
      *    Return to performing section
      *
           EXIT.
           EJECT
      *
      * ------------------------------------------------------------- *
       CLOSE-INQUIRYQ SECTION.
      * ------------------------------------------------------------- *
      *                                                              *
      *  This section closes the inquiry queue                       *
      *                                                              *
      * ------------------------------------------------------------ *
      *
           CALL 'MQCLOSE' USING W03-HCONN
                                W03-HOBJ-INQUIRYQ
                                MQCO-NONE
                                W03-COMPCODE
                                W03-REASON.
      *
            IF W03-COMPCODE NOT = MQCC-OK
                MOVE 'MQCLOSE'            TO M02-OPERATION
                MOVE W02-INQUIRY-QNAME    TO M02-OBJECTNAME
                PERFORM RECORD-CALL-ERROR
            END-IF.
      *
       CLOSE-INQUIRYQ-EXIT.
      *
      *    Return to performing section
      *
           EXIT.
           EJECT
      *
      * ------------------------------------------------------------- *
       MAIN-PROCESS SECTION.
      * ------------------------------------------------------------- *
      *                                                              *
      *  This section performs the main message handling of the      *
      *  program. It is called from a loop in MAIN.                  *
      *                                                              *
      *  The program gets and handles messages, depending on the     *
      *  status of the IRT. When a message is complete, an answer    *
      *  is sent. If an error occurs, it is recorded and END-PROCESS *
      *  is set.                                                     *
      *                                                              *
      * ------------------------------------------------------------ *
      *
      *    Ensure the inquiry queue is open when there is space in
      *    the IRT for a new inquiry and closed when the IRT is full
      *
           EVALUATE TRUE
                WHEN (IRT-TABLE-FULL AND INQUIRYQ-OPEN)
                    PERFORM CLOSE-INQUIRYQ
                    IF W03-COMPCODE = MQCC-OK
                        SET INQUIRYQ-CLOSED TO TRUE
                    ELSE
                        MOVE W06-END-PROCESS TO W06-MAIN-PROCESS-FLAG
                        GO TO MAIN-PROCESS-EXIT
                    END-IF
      *
                WHEN (NOT IRT-TABLE-FULL AND INQUIRYQ-CLOSED)
                    PERFORM OPEN-INQUIRYQ
                    IF W03-COMPCODE = MQCC-OK
                        SET INQUIRYQ-OPEN TO TRUE
                    ELSE
                        MOVE W06-END-PROCESS TO W06-MAIN-PROCESS-FLAG
                        GO TO MAIN-PROCESS-EXIT
                    END-IF
           END-EVALUATE.
      *
      *    If the IRT is full, get messages from the reply queue
      *    only, using get wait
      *
           IF IRT-TABLE-FULL
               PERFORM REPLYQ-GETWAIT
               EVALUATE TRUE
                   WHEN (W03-COMPCODE = MQCC-OK AND
                           W03-REASON = MQRC-NONE)
                       PERFORM PROCESS-REPLYQ-MESSAGE
      *
                   WHEN (W03-COMPCODE = MQCC-FAILED AND
                           W03-REASON = MQRC-NO-MSG-AVAILABLE)
                       MOVE W06-END-PROCESS TO W06-MAIN-PROCESS-FLAG
      *
                   WHEN OTHER
                       MOVE 'MQGET WAIT '   TO M02-OPERATION
                       MOVE W02-REPLY-QNAME TO M02-OBJECTNAME
                       PERFORM RECORD-CALL-ERROR
                       MOVE W06-CALL-ERROR  TO W06-CALL-STATUS
      *
               END-EVALUATE
      *
      *    Else the IRT isn't full,  get messages from both
      *    inquiry and reply queues, using get signal
      *
           ELSE
               PERFORM INQUIRYQ-GETSIGNAL
               EVALUATE TRUE
                   WHEN (W03-COMPCODE = MQCC-OK AND
                           W03-REASON = MQRC-NONE)
                       PERFORM PROCESS-INQUIRYQ-MESSAGE
      *
                   WHEN (W03-COMPCODE = MQCC-WARNING AND
                           W03-REASON = MQRC-SIGNAL-REQUEST-ACCEPTED)
                        OR
                        (W03-COMPCODE = MQCC-FAILED AND
                           W03-REASON = MQRC-SIGNAL-OUTSTANDING)
                       PERFORM PROCESS-SIGNAL-ACCEPTED
      *
                   WHEN OTHER
                       MOVE 'MQGET SIGNAL'  TO M02-OPERATION
                       MOVE MQOD-OBJECTNAME TO M02-OBJECTNAME
                       PERFORM RECORD-CALL-ERROR
                       MOVE W06-CALL-ERROR  TO W06-CALL-STATUS
      *
               END-EVALUATE
           END-IF.
      *
      *    Check whether an inquiry is complete, or whether
      *    problems have occurred
      *
           EVALUATE TRUE
               WHEN (CALLS-OK AND MSG-COMPLETE)
                   PERFORM SEND-ANSWER
                   IF W03-COMPCODE NOT = MQCC-OK
                       MOVE W06-END-PROCESS TO W06-MAIN-PROCESS-FLAG
                       EXEC CICS SYNCPOINT ROLLBACK END-EXEC
                       GO TO MAIN-PROCESS-EXIT
                   END-IF
                   EXEC CICS SYNCPOINT END-EXEC
                   SET MSG-NOT-COMPLETE TO TRUE
                   PERFORM T4-IRT-DELETE-ENTRY
      *
               WHEN CALLS-OK
                   EXEC CICS SYNCPOINT END-EXEC
      *
               WHEN OTHER
                   MOVE W06-END-PROCESS TO W06-MAIN-PROCESS-FLAG
                   EXEC CICS SYNCPOINT ROLLBACK END-EXEC
           END-EVALUATE.
      *
       MAIN-PROCESS-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
      *
      * ------------------------------------------------------------- *
       T1-IRT-ADD-ENTRY SECTION.
      * ------------------------------------------------------------- *
      *                                                              *
      *  This section adds a new entry into the in memory inquiry    *
      *  record table. If the new entry fills the table, table full  *
      *  is set. If the table is already full, there is an internal  *
      *  logic error - so triggering is set off for the replyq to    *
      *  avoid repeated errors.                                      *
      *                                                              *
      * ------------------------------------------------------------ *
      *
           SET IRT-INDEX1 TO 1.
      *
           SEARCH IRT-TABLE-ELEMENT VARYING IRT-INDEX1
               AT END
      *             table is full - therefore a logic
      *             error has occurred. we need to set triggering off
      *             for the replyq so that the transaction does not
      *             get repeatedely started
                   PERFORM SET-REPLYQ-TC-OFF
                   EXEC CICS ABEND
                       ABCODE('TFUL')
                   END-EXEC
      *
               WHEN IRT-MSGID(IRT-INDEX1) = LOW-VALUES
                   ADD 1           TO IRT-CURRENT-ENTRIES
                   MOVE MQMD-MSGID TO IRT-MSGID(IRT-INDEX1)
                   MOVE 1          TO IRT-REPLYEXP(IRT-INDEX1)
                   MOVE ZEROES     TO IRT-REPLYREC(IRT-INDEX1)
                   IF CSQ4BIIM-LOANREQ > W01-AMOUNT
                       MOVE 1      TO IRT-PROPSOUT(IRT-INDEX1)
                   ELSE
                       MOVE ZEROES TO IRT-PROPSOUT(IRT-INDEX1)
                   END-IF
           END-SEARCH.
      *
           IF IRT-CURRENT-ENTRIES = IRT-MAX-ENTRIES
               MOVE IRT-TABLE-SET-FULL TO IRT-TABLE-STATUS.
      *
       T1-IRT-ADD-ENTRY-EXIT.
      *
      *    Return to performing section
      *
           EXIT.
           EJECT
      *
      * ------------------------------------------------------------- *
       T2-IRT-UPDATE-ENTRY SECTION.
      * ------------------------------------------------------------- *
      *                                                              *
      * This IRT update entry routine can be called from the initial *
      * rebuild of IRT at start of program OR during the main loop.  *
      *                                                              *
      * When a matched entry is found the counts are updated         *
      * dependent on type of message.                                *
      *                                                              *
      * If all the replies have been received then the message       *
      * complete flag is set to indicate this.                       *
      *                                                              *
      * ------------------------------------------------------------ *
      *
           SET IRT-INDEX1 TO 1.
           MOVE IRT-STATUS-OK TO IRT-UPDATE-STATUS.
           SEARCH IRT-TABLE-ELEMENT VARYING IRT-INDEX1
      *
               AT END
                   MOVE IRT-STATUS-NO-MATCH TO IRT-UPDATE-STATUS
      *
               WHEN IRT-MSGID(IRT-INDEX1) = MQMD-CORRELID
                   EVALUATE TRUE
                       WHEN PROPAGATION-MESSAGE
                           ADD      1   TO IRT-REPLYREC(IRT-INDEX1)
                           ADD CSQ4BPGM-MSGS-SENT
                                        TO IRT-REPLYEXP(IRT-INDEX1)
                           SUBTRACT 1 FROM IRT-PROPSOUT(IRT-INDEX1)
                       WHEN QUERY-RESPONSE-MESSAGE
                           ADD      1   TO IRT-REPLYREC(IRT-INDEX1)
                   END-EVALUATE
      *
      *            Test whether all responses have been received,
      *            if they have - set message complete
      *
                   IF IRT-REPLYREC(IRT-INDEX1) =
                     IRT-REPLYEXP(IRT-INDEX1) AND
                     IRT-PROPSOUT(IRT-INDEX1) = ZERO
                       SET MSG-COMPLETE TO TRUE
                   ELSE
                       CONTINUE
                   END-IF
           END-SEARCH.
      *
       T2-IRT-UPDATE-ENTRY-EXIT.
      *
      *    Return to performing section
      *
           EXIT.
           EJECT
      *
      * ------------------------------------------------------------- *
       T3-IRT-REBUILD-UNKNOWN-MSG SECTION.
      * ------------------------------------------------------------- *
      *                                                              *
      * This section is called during the initial phase of the       *
      * program when rebuilding the IRT because an 'unknown message  *
      * has been encountered on the 'waiting' queue.                 *
      * This code will remove the message using the message          *
      * under cursor option of MQGET and MQPUT it on the deadletter  *
      * queue.                                                       *
      *                                                              *
      * ------------------------------------------------------------ *
      *
           MOVE 'UNKNOWN MSG DETECTED ON QUEUE' TO M02-OPERATION.
           MOVE W02-WAITING-QNAME               TO M02-OBJECTNAME.
           PERFORM RECORD-CALL-ERROR.
      *
           PERFORM T6-IRT-REBUILD-GET-MSG.
           IF W03-COMPCODE NOT = MQCC-OK
              GO TO T3-RESTORE
           END-IF.
      *
      *    put the message on the dead letter queue
      *
           MOVE W03-HOBJ-WAITQ TO MQPMO-CONTEXT.
           PERFORM FORWARD-MSG-TO-DLQ.
      *
       T3-RESTORE.
      *
      *    Change the MQGMO Options field back to BROWSE-NEXT
      *
           COMPUTE MQGMO-OPTIONS = MQGMO-NO-WAIT +
                                   MQGMO-BROWSE-NEXT.
      *
       T3-IRT-REBUILD-UNKNOWN-EXIT.
      *
      *    Return to performing section
      *
           EXIT.
           EJECT
      *
      * ------------------------------------------------------------- *
       T4-IRT-DELETE-ENTRY SECTION.
      * ------------------------------------------------------------- *
      *                                                              *
      * This section deletes and entry from the IRT                  *
      *                                                              *
      * ------------------------------------------------------------ *
      *
           MOVE LOW-VALUES TO IRT-TABLE-ENTRY(IRT-INDEX1).
           SUBTRACT 1 FROM IRT-CURRENT-ENTRIES.
           MOVE IRT-TABLE-SET-NOT-FULL TO IRT-TABLE-STATUS.
      *
       T4-IRT-DELETE-ENTRY-EXIT.
      *
      *    Return to performing section
      *
           EXIT.
           EJECT
      *
      * ------------------------------------------------------------- *
       T5-IRT-REBUILD-NO-MATCH SECTION.
      * ------------------------------------------------------------- *
      *                                                              *
      * This section gets an unknown message from the waiting queue, *
      * using T6-IRT-REBUILD-GET-MSG, records the error, and puts    *
      * the message to the dead queue.                               *
      *                                                              *
      * ------------------------------------------------------------ *
      *
           MOVE 'MATCH NOT FOUND IN IRT' TO M02-OPERATION.
           MOVE W02-WAITING-QNAME TO M02-OBJECTNAME.
           PERFORM RECORD-CALL-ERROR.
      *
           PERFORM T6-IRT-REBUILD-GET-MSG.
           IF W03-COMPCODE NOT = MQCC-OK
              GO TO T5-RESTORE
           END-IF.
      *
      *    put the message on the dead letter queue
      *
           MOVE W03-HOBJ-WAITQ TO MQPMO-CONTEXT.
           PERFORM FORWARD-MSG-TO-DLQ.
      *
       T5-RESTORE.
      *
      *    Change the MQGMO Options field back to BROWSE-NEXT
      *
           COMPUTE MQGMO-OPTIONS = MQGMO-NO-WAIT +
                                   MQGMO-BROWSE-NEXT.
      *
       T5-IRT-REBUILD-NO-MATCH-EXIT.
      *
      *    Return to performing section
      *
           EXIT.
           EJECT
      *
      * ------------------------------------------------------------- *
       T6-IRT-REBUILD-GET-MSG SECTION.
      * ------------------------------------------------------------- *
      *                                                              *
--> --------------------

--> maximum size reached

--> --------------------

Quelle csq4cvb2.cob Sprache: unbekannt

[ Verzeichnis aufwärts0.173unsichere Verbindung ]