* ------------------------------------------------------------- * IDENTIFICATION DIVISION. * ------------------------------------------------------------- * PROGRAM-ID. Q2VSAM. * ------------------------------------------------------------- * ENVIRONMENT DIVISION. * ------------------------------------------------------------- * INPUT-OUTPUT SECTION. FILE-CONTROL. SELECT KSDS-FILE ASSIGN TO KSDS ORGANIZATION IS INDEXED ACCESS MODE IS RANDOM RECORD KEY IS KSDS-KEY-01 FILE STATUS IS KSDS-STATUS. * ------------------------------------------------------------- * DATA DIVISION. FILE SECTION. FD KSDS-FILE DATA RECORD IS KSDS-REC . 01 KSDS-REC. 05 KSDS-KEY-01 PIC X(12). 05 KSDS-DATA-01 PIC X(500). * ------------------------------------------------------------- * WORKING-STORAGE SECTION. * ------------------------------------------------------------- * * * W00 - General work fields * 01 W00-INPUT-HOBJ PIC S9(9) BINARY. 01 W00-DLQ-HOBJ PIC S9(9) BINARY. 01 W00-RC PIC S9(04) BINARY VALUE ZERO. 01 W00-COUNTER PIC S9(4) BINARY VALUE ZERO. 01 W00-GET-COUNTER PIC S9(4) BINARY VALUE ZERO. 01 W00-DEAD-COUNT PIC S9(4) BINARY VALUE ZERO. 01 W00-DISCARD-COUNT PIC S9(4) BINARY VALUE ZERO. 01 W00-MSGLENGTH PIC S9(9) BINARY VALUE 4096. 01 W00-MSGBUFFER. 05 W00-MSGBUFFER-ARRAY PIC X(4096). 05 W00-ACT REDEFINES W00-MSGBUFFER-ARRAY PIC X(4). 05 FILLER PIC X(4). 05 W00-KEY PIC X(12). 05 W00-RECORD PIC X(500). 01 W00-DATALENGTH PIC S9(9) BINARY VALUE 0. 01 PARM-WTOR. 05 PARM-WTOR-LEN PIC S9(03) BINARY VALUE +8. 05 PARM-WTOR-MSG PIC X(4). 01 PARM-MQERR. 05 PARM-MQERR-LEN PIC S9(03) BINARY VALUE +38. 05 PARM-MQERR-MSG PIC X(34). 01 W00-WTP-MESSAGE PIC X(80). 01 W00-ACTION PIC X(4). 01 W00-JOB-NAME PIC X(8). * * W02 - Data fields derived from the PARM field * 01 W02-QMGR PIC X(48) VALUE SPACES. 01 W02-QUEUE PIC X(48) VALUE SPACES. 01 W02-DLQ PIC X(48) VALUE SPACES. * * W03 - MQ API fields * 01 W03-HCONN PIC S9(9) BINARY. 01 W03-OPTIONS PIC S9(9) BINARY. 01 W03-HOBJ PIC S9(9) BINARY. 01 W03-COMPCODE PIC S9(9) BINARY. 01 W03-REASON PIC S9(9) BINARY. 01 W03-MESSAGE-DATA PIC X(80) VALUE SPACES. 01 W03-OPENOPTIONS PIC S9(9) BINARY. * 01 WS-FLAG1 PIC X VALUE SPACES. 88 WS-DONE VALUE 'Y'. 88 WS-FOREVER VALUE 'X'. * The following copy files define API control blocks. * 01 W05-MQM-OBJECT-DESCRIPTOR. COPY CMQODV. 01 W05-MQM-MESSAGE-DESCRIPTOR. COPY CMQMDV. 01 MQM-GET-MESSAGE-OPTIONS. COPY CMQGMOV. 01 MQM-PUT-MESSAGE-OPTIONS. COPY CMQPMOV. * * Copy file of constants and return codes * 01 W05-MQM-CONSTANTS. COPY CMQV. * * W06 - Return values * 01 W06-CSQ4-OK PIC S9(4) VALUE 0. 01 W06-CSQ4-WARNING PIC S9(4) VALUE 4. 01 W06-CSQ4-ERROR PIC S9(4) VALUE 8. 01 EOF-SYSIN PIC XXX VALUE SPACE. 88 END-OF-FILE-SYSIN VALUE 'EOF'. 01 KSDS-STATUS. 05 KSDS-STATUS-L PIC X. 05 KSDS-STATUS-R PIC X. 01 KSDS-EOF PIC X value 'N'. 01 KSDS-OPEN-FLAG PIC X value 'C'. 01 APPL-RESULT PIC S9(9) comp. 88 APPL-AOK Value 0. 88 APPL-EOF Value 16. 01 IO-STATUS. 05 IO-STAT1 Pic X. 05 IO-STAT2 Pic X. 01 IO-STATUS-04. 05 IO-STATUS-0401 Pic 9 value 0. 05 IO-STATUS-0403 Pic 999 value 0. 01 TWO-BYTES-BINARY Pic 9(4) BINARY. 01 TWO-BYTES-ALPHA redefines TWO-BYTES-BINARY. 05 TWO-BYTES-LEFT Pic X. 05 TWO-BYTES-RIGHT Pic X. * ------------------------------------------------------------- * LINKAGE SECTION. * ------------------------------------------------------------- * 01 PARMDATA. 05 PARM-LEN PIC S9(03) BINARY. 05 PARM-STRING PIC X(100). * * Fields used for extracting jobname * 01 CVT-ADRS USAGE IS POINTER. 01 PSA. 05 FILLER PIC X(16). 05 CVTADDR POINTER. 05 FILLER PIC X(520). 05 PSATOLD POINTER. 01 TCB. 05 FILLER PIC X(12). 05 TCBTIO POINTER. 05 FILLER PIC X(164). 05 TCBJSCBB POINTER. 01 TIOT. 05 TIOCNJOB PIC X(8). 05 TIOCSTPN PIC X(8). 01 CVT. 05 FILLER PIC X(140). 05 ECVTPNTR POINTER. * ------------------------------------------------------------- * PROCEDURE DIVISION USING PARMDATA. * ------------------------------------------------------------- * A-MAIN SECTION. * ------------------------------------------------------------- * SET ADDRESS OF PSA TO NULL SET ADDRESS OF CVT TO CVTADDR. SET ADDRESS OF TCB TO PSATOLD SET ADDRESS OF TIOT TO TCBTIO MOVE TIOCNJOB TO W00-JOB-NAME Perform Process-Parms. Perform KSDS-Open. If IO-STATUS = '97' Perform KSDS-Close Perform KSDS-Open End-If. If KSDS-OPEN-FLAG Not = 'O' stop run end-if. Perform MQCONNECT. IF W02-DLQ not = spaces COMPUTE W03-OPENOPTIONS = MQOO-OUTPUT + MQOO-FAIL-IF-QUIESCING MOVE W02-DLQ TO MQOD-OBJECTNAME Perform MQOPEN-QUEUE MOVE W03-HOBJ to W00-DLQ-HOBJ End-if. COMPUTE W03-OPENOPTIONS = MQOO-INPUT-SHARED + MQOO-FAIL-IF-QUIESCING. MOVE W02-QUEUE TO MQOD-OBJECTNAME. Perform MQOPEN-QUEUE. STRING W02-Queue delimited by spaces ' now open for INPUT. ' delimited by size into W00-WTP-MESSAGE DISPLAY W00-WTP-MESSAGE MOVE W03-HOBJ to W00-INPUT-HOBJ. Initialize W00-Get-Counter. Initialize W00-Counter. Initialize W00-Dead-Count. Initialize W00-Discard-count. SET WS-FOREVER TO TRUE. Perform GET-MESSAGE UNTIL (WS-DONE). A-CLOSE-QUEUE. MOVE W02-QUEUE TO MQOD-OBJECTNAME. Perform MQCLOSE-QUEUE. IF W02-DLQ not = SPACE MOVE W00-DLQ-HOBJ to W03-HOBJ MOVE W02-DLQ TO MQOD-OBJECTNAME Perform MQCLOSE-QUEUE End-if. A-MAIN-DISCONNECT. Perform DISCONNECT. Perform KSDS-CLOSE. Display ' Program Statistics :'. Display ' --------------------'. display ' GET Messages processed = ' W00-Get-Counter. display ' Valid messages = ' W00-Counter. display ' Message written to DLQ = ' W00-Dead-Count. display ' Messages discarded = ' W00-discard-Count. A-MAIN-END. MOVE W00-RC to RETURN-CODE. Display 'Program Q2VSAM ended' STOP RUN. * ------------------------------------------------------------- * KSDS-OPEN Section. * * Open the Key Sequenced Dataset (VSAM) * * ------------------------------------------------------------- * add 8 to ZERO giving APPL-RESULT. open I-O KSDS-FILE if KSDS-STATUS = '00' subtract APPL-RESULT from APPL-RESULT move 'O' to KSDS-OPEN-FLAG else add 12 to ZERO giving APPL-RESULT end-if if APPL-AOK move 'OPEN successful for KSDS' to W00-WTP-MESSAGE DISPLAY W00-WTP-MESSAGE CONTINUE else move 'OPEN Failure for KSDS' to W00-WTP-MESSAGE DISPLAY W00-WTP-MESSAGE move KSDS-STATUS to IO-STATUS display io-Status Perform Z-DISPLAY-IO-STATUS add 12 to ZERO giving RETURN-CODE end-if exit. * --------------------------------------------------------------- KSDS-CLOSE section. * * Close the Key Sequenced Dataset (VSAM) * * ------------------------------------------------------------- * move 'Closing KSDS' to W00-WTP-MESSAGE. DISPLAY W00-WTP-MESSAGE. add 8 to ZERO giving APPL-RESULT. close KSDS-FILE if KSDS-STATUS = '00' subtract APPL-RESULT from APPL-RESULT move 'C' to KSDS-OPEN-FLAG else add 12 to ZERO giving APPL-RESULT end-if if APPL-AOK CONTINUE else move 'CLOSE Failure with KSDS ' to W00-WTP-MESSAGE DISPLAY W00-WTP-MESSAGE move KSDS-STATUS to IO-STATUS Perform Z-DISPLAY-IO-STATUS add 12 to ZERO giving RETURN-CODE STOP RUN end-if exit. * --------------------------------------------------------------- Z-DISPLAY-IO-STATUS Section. * * Display the Status flag for the Key Sequenced dataset (VSAM) * * ------------------------------------------------------------- * if IO-STATUS not NUMERIC or IO-STAT1 = '9' move IO-STAT1 to IO-STATUS-04(1:1) subtract TWO-BYTES-BINARY from TWO-BYTES-BINARY move IO-STAT2 to TWO-BYTES-RIGHT add TWO-BYTES-BINARY to ZERO giving IO-STATUS-0403 move 'File Status is: nnnn' to W00-WTP-MESSAGE move IO-STATUS-04 to W00-WTP-MESSAGE(17:4) DISPLAY W00-WTP-MESSAGE else move '0000' to IO-STATUS-04 move IO-STATUS to IO-STATUS-04(3:2) move 'File Status is: nnnn' to W00-WTP-MESSAGE move IO-STATUS-04 to W00-WTP-MESSAGE(17:4) DISPLAY W00-WTP-MESSAGE end-if exit. * ------------------------------------------------------------- * MQCONNECT Section. * ------------------------------------------------------------- * * * Connect to the specified queue manager. * * ------------------------------------------------------------- * B-CALL-CONNECT. CALL 'MQCONN' USING W02-QMGR W03-HCONN W03-COMPCODE W03-REASON. IF (W03-COMPCODE NOT = MQCC-OK) THEN EVALUATE W03-REASON WHEN MQRC-Q-MGR-QUIESCING DISPLAY 'Queue manager ' PARM-WTOR-MSG ' is quiescing' CALL 'QMGRWAIT' USING PARM-WTOR IF RETURN-CODE = 0 THEN DISPLAY 'Return code=' RETURN-CODE '. Retrying connection' GO TO B-CALL-CONNECT ELSE GO TO A-MAIN-END END-IF WHEN MQRC-Q-MGR-NAME-ERROR MOVE 'Unable to connect to QMGR.' to PARM-MQERR-MSG CALL 'MQERROR' USING PARM-MQERR IF RETURN-CODE = 0 THEN DISPLAY 'Return code=' RETURN-CODE '. Retrying connection' GO TO B-CALL-CONNECT ELSE GO TO A-MAIN-END END-IF WHEN OTHER DISPLAY 'MQCONN to ' PARM-WTOR-MSG ' failed' DISPLAY 'Reason code=' W03-REASON MOVE W06-CSQ4-ERROR TO W00-RC GO TO A-MAIN-END END-EVALUATE END-IF. DISPLAY 'Program now connected to ' PARM-WTOR-MSG. EXIT. * --------------------------------------------------------------- DISCONNECT Section. * --------------------------------------------------------------- * * Disconnect from the queue manager * * ------------------------------------------------------------- * CALL 'MQDISC' USING W03-HCONN W03-COMPCODE W03-REASON. IF (W03-COMPCODE NOT = MQCC-OK) THEN DISPLAY 'MQDISC for failed. Reason code=' W03-REASON MOVE W03-REASON TO W00-RC END-IF. DISPLAY 'Program now disconnected from ' W02-QMGR. EXIT. * --------------------------------------------------------------- GET-MESSAGE Section. * --------------------------------------------------------------- * * Read message from queue section * * ------------------------------------------------------------- * B-RETRY-GET. * * Set MQGMO-OPTIONS * MOVE MQWI-UNLIMITED TO MQGMO-WAITINTERVAL. COMPUTE MQGMO-OPTIONS = MQGMO-WAIT + MQGMO-CONVERT + MQGMO-FAIL-IF-QUIESCING. * MQGMO-ACCEPT-TRUNCATED-MSG + ADD MQGMO-NO-SYNCPOINT TO MQGMO-OPTIONS. MOVE MQMO-MATCH-MSG-ID TO MQGMO-MATCHOPTIONS. * * Clear the Message ID and Correl ID fields * MOVE MQCI-NONE TO MQMD-CORRELID. MOVE MQMI-NONE TO MQMD-MSGID. * DISPLAY 'Get message from ' W02-QUEUE. CALL 'MQGET' USING W03-HCONN W00-INPUT-HOBJ MQMD MQGMO W00-MSGLENGTH W00-MSGBUFFER-ARRAY W00-DATALENGTH W03-COMPCODE W03-REASON * * If get failed then display error message * IF (W03-COMPCODE NOT = MQCC-OK) THEN MOVE W03-REASON TO W00-RC EVALUATE W03-REASON WHEN MQRC-Q-MGR-QUIESCING DISPLAY 'Queue manager ' PARM-WTOR-MSG ' is quiescing' Perform MQCLOSE-QUEUE Perform DISCONNECT CALL 'QMGRWAIT' USING PARM-WTOR IF RETURN-CODE = 0 THEN DISPLAY 'Return code=' RETURN-CODE '. Retrying connection' Perform MQCONNECT Perform MQOPEN-QUEUE GO TO B-RETRY-GET ELSE GO TO A-MAIN-END END-IF WHEN MQRC-NO-MSG-AVAILABLE DISPLAY 'No more messages to process on ' W02-QUEUE GO TO B-EXIT-GET WHEN OTHER STRING 'MQGET from ' delimited by size W02-QUEUE delimited by spaces ' failed.' delimited by size into W00-WTP-MESSAGE DISPLAY W00-WTP-MESSAGE DISPLAY 'Reason Code=' W03-REASON DISPLAY 'Datalength =' W00-DATAlength END-EVALUATE GO TO A-MAIN-DISCONNECT END-IF. MOVE W00-MSGBUFFER(1:4) TO W00-Action. If W00-DATALENGTH = 0 or W00-Action = 'SHUT' then display 'Shutdown message received' SET WS-DONE TO TRUE else * Display 'Message is:' W00-MSGBUFFER(1:W00-DATALENGTH)'<' MOVE W03-REASON TO W00-RC DISPLAY 'Successful read of message from ' W02-QUEUE ADD 1 to W00-GET-COUNTER Perform Check-message END-IF. B-EXIT-GET. EXIT. * ------------------------------------------------------------- * Check-message Section. * ------------------------------------------------------------- * * * Check the message for valid codes etc. * * ------------------------------------------------------------- * MOVE W00-MSGBUFFER(5:512) TO KSDS-REC. display w00-MSGBUFFER(1:600). Display 'Action is ' W00-Action. EVALUATE W00-Action WHEN 'ADD ' Perform KSDS-WRITE WHEN 'UPD ' Perform KSDS-UPDATE WHEN 'DEL ' Perform KSDS-DELETE WHEN 'LIST' Perform KSDS-LISTER WHEN other Display 'Action ignored ' W00-Action IF W02-DLQ Not = spaces Perform Move-to-DLQ else Display 'No Dead Letter Queue - Message discarded' ADD 1 to W00-Discard-COUNT end-if END-EVALUATE. Check-Message-EXIT. INITIALIZE KSDS-REC. INITIALIZE W00-MSGBUFFER-ARRAY. EXIT. * ------------------------------------------------------------- * MQOPEN-QUEUE Section. * ------------------------------------------------------------- * * * Open a Queue * * ------------------------------------------------------------- * B-CALL-MQOPEN. IF (MQOD-OBJECTNAME = 'SYSTEM.DEFAULT.MODEL.QUEUE') THEN DISPLAY 'Create and open dynamic queue ' MQOD-DYNAMICQNAME else DISPLAY 'Opening queue ' MQOD-OBJECTNAME END-IF CALL 'MQOPEN' USING W03-HCONN MQOD W03-OPENOPTIONS W03-HOBJ W03-COMPCODE W03-REASON. * * If open failed display error message and exit * IF (W03-COMPCODE NOT = MQCC-OK) THEN MOVE W03-REASON TO W00-RC EVALUATE W03-REASON WHEN MQRC-UNKNOWN-OBJECT-NAME STRING 'Queue ' delimited by size MQOD-OBJECTNAME delimited by low-values ' not found.' delimited by size into W00-WTP-MESSAGE DISPLAY W00-WTP-MESSAGE WHEN MQRC-Q-MGR-QUIESCING Perform DISCONNECT DISPLAY 'Queue manager ' PARM-WTOR-MSG ' is quiescing' CALL 'QMGRWAIT' USING PARM-WTOR IF RETURN-CODE = 0 THEN DISPLAY 'Return code=' RETURN-CODE '. Retrying connection' Perform MQCONNECT Go TO B-CALL-MQOPEN else go to A-MAIN-END END-IF WHEN OTHER STRING 'MQOPEN for ' delimited by size MQOD-OBJECTNAME delimited by low-values ' Failed.' delimited by size into W00-WTP-MESSAGE DISPLAY W00-WTP-MESSAGE DISPLAY 'Reason Code=' W03-REASON END-EVALUATE GO TO A-MAIN-DISCONNECT END-IF. MOVE W03-REASON TO W00-RC. DISPLAY 'MQOPEN Successful for queue ' MQOD-OBJECTNAME. EXIT. * ------------------------------------------------------------- * MQCLOSE-QUEUE Section. * ------------------------------------------------------------- * * * Close a queue * * ------------------------------------------------------------- * DISPLAY 'Close queue ' MQOD-OBJECTNAME. CALL 'MQCLOSE' USING W03-HCONN W03-HOBJ MQCO-NONE W03-COMPCODE W03-REASON. IF (W03-COMPCODE NOT = MQCC-OK) THEN STRING 'MQCLOSE for ' delimited by size MQOD-OBJECTNAME delimited by spaces ' Failed.' delimited by size into W00-WTP-MESSAGE DISPLAY W00-WTP-MESSAGE DISPLAY 'Reason Code=' W03-REASON MOVE W03-REASON TO W00-RC GO TO A-MAIN-DISCONNECT END-IF. DISPLAY 'MQCLOSE Successful for queue ' MQOD-OBJECTNAME. EXIT. * ------------------------------------------------------------- * KSDS-WRITE Section. * ------------------------------------------------------------- * * * Write a record to a KSDS (VSAM) file * * ------------------------------------------------------------- * if KSDS-OPEN-FLAG = 'C' Perform KSDS-OPEN end-if EXEC CICS WRITE FILE('file') FROM(KSDS_REC) RIDFLD(KSDS_KEY_01) LENGTH(length) END-EXEC. write KSDS-REC EVALUATE KSDS-STATUS WHEN '00' subtract APPL-RESULT from APPL-RESULT ADD 1 to W00-COUNTER WHEN '22' subtract APPL-RESULT from APPL-RESULT Display 'Record already exists' WHEn OTHER add 12 to ZERO giving APPL-RESULT END-EVALUATE if APPL-AOK CONTINUE else move 'WRITE Failure for KSDS ' to W00-WTP-MESSAGE DISPLAY W00-WTP-MESSAGE move KSDS-STATUS to IO-STATUS Perform Z-DISPLAY-IO-STATUS add 12 to ZERO giving RETURN-CODE STOP RUN end-if exit. * ------------------------------------------------------------- * KSDS-UPDATE Section. * ------------------------------------------------------------- * * * Update a record in a KSDS (VSAM) file * * ------------------------------------------------------------- * if KSDS-OPEN-FLAG = 'C' Perform KSDS-OPEN end-if rewrite KSDS-REC if KSDS-STATUS = '00' subtract APPL-RESULT from APPL-RESULT else if KSDS-STATUS = '10' add 16 to ZERO giving APPL-RESULT else add 12 to ZERO giving APPL-RESULT end-if end-if. if APPL-AOK ADD 1 to W00-COUNTER CONTINUE else move 'Update Failure for KSDS' to W00-WTP-MESSAGE DISPLAY W00-WTP-MESSAGE move KSDS-STATUS to IO-STATUS Perform Z-DISPLAY-IO-STATUS add 12 to ZERO giving RETURN-CODE STOP RUN end-if exit. * ------------------------------------------------------------- * KSDS-DELETE Section. * ------------------------------------------------------------- * * * Deletes a record from a KSDS (VSAM) file * * ------------------------------------------------------------- * if KSDS-OPEN-FLAG = 'C' Perform KSDS-OPEN end-if DELETE KSDS-FILE if KSDS-STATUS = '00' subtract APPL-RESULT from APPL-RESULT else if KSDS-STATUS = '10' add 16 to ZERO giving APPL-RESULT else add 12 to ZERO giving APPL-RESULT end-if end-if. if APPL-AOK ADD 1 to W00-COUNTER CONTINUE else move 'Delete Failure for KSDS' to W00-WTP-MESSAGE DISPLAY W00-WTP-MESSAGE move KSDS-STATUS to IO-STATUS Perform Z-DISPLAY-IO-STATUS add 12 to ZERO giving RETURN-CODE STOP RUN end-if exit. * ------------------------------------------------------------- * KSDS-LISTER Section. * ------------------------------------------------------------- * * * Lists a record from a KSDS (VSAM) file * * ------------------------------------------------------------- * move 'N' to KSDS-EOF add 12 to ZERO giving APPL-RESULT read KSDS-FILE evaluate KSDS-STATUS when '00' subtract APPL-RESULT from APPL-RESULT when '23' subtract APPL-RESULT from APPL-RESULT when '10' subtract APPL-RESULT from APPL-RESULT move 'Y' to KSDS-EOF end-evaluate. if APPL-AOK Display KSDS-REC ADD 1 to W00-COUNTER CONTINUE else move 'READ Failure for KSDS' to W00-WTP-MESSAGE DISPLAY W00-WTP-MESSAGE move KSDS-STATUS to IO-STATUS Perform Z-DISPLAY-IO-STATUS add 12 to ZERO giving RETURN-CODE STOP RUN end-if exit. * ------------------------------------------------------------- * Process-Parms Section. * ------------------------------------------------------------- * * * If no data was passed, create a message, print it, and * exit * * ------------------------------------------------------------- * IF PARM-LEN = 0 THEN DISPLAY 'No parms passed to program' MOVE '16' TO W00-RC GO TO A-MAIN-END END-IF. Initialize W02-QUEUE Initialize W02-DLQ * * Separate into the relevant fields any data passed in the * PARM statement * UNSTRING PARM-STRING DELIMITED BY ALL ',' INTO W02-QMGR W02-QUEUE W02-DLQ. * DISPLAY 'Queue manager name passed = ' W02-QMGR. IF W02-QUEUE = SPACES THEN DISPLAY 'No queue name passed to program' MOVE '16' TO W00-RC GO TO A-MAIN-END END-IF. DISPLAY 'Queue name passed = ' W02-QUEUE upon console. IF W02-DLQ = SPACES DISPLAY 'No Dead Letter Queue Specified' upon console ELSE DISPLAY 'Dead Letter Queue = ' W02-DLQ End-if. MOVE W02-QMGR to PARM-WTOR-MSG. exit. * ------------------------------------------------------------- * Move-to-DLQ Section. * ------------------------------------------------------------- * * * Write a poison message to the passed DLQ * * ------------------------------------------------------------- * MOVE MQPER-NOT-PERSISTENT TO MQMD-PERSISTENCE. MOVE MQFMT-STRING TO MQMD-FORMAT. MOVE MQPMO-FAIL-IF-QUIESCING TO MQPMO-OPTIONS. * * Clear the Message ID and Correl ID fields * MOVE MQMI-NONE TO MQMD-MSGID. MOVE MQCI-NONE TO MQMD-CORRELID. * B-RETRY-PUT. DISPLAY 'Putting message to ' W02-DLQ. CALL 'MQPUT' USING W03-HCONN W00-DLQ-HOBJ MQMD MQPMO W00-MSGLENGTH W00-MSGBUFFER W03-COMPCODE W03-REASON * * If put failed then display error message * IF (W03-COMPCODE NOT = MQCC-OK) THEN MOVE W03-REASON TO W00-RC EVALUATE W03-REASON WHEN MQRC-Q-MGR-QUIESCING DISPLAY 'Queue manager ' PARM-WTOR-MSG ' is quiescing' Perform MQCLOSE-QUEUE Perform DISCONNECT CALL 'QMGRWAIT' USING PARM-WTOR IF RETURN-CODE = 0 THEN DISPLAY 'Return code=' RETURN-CODE '. Retrying connection' Perform MQCONNECT Perform MQOPEN-QUEUE GO TO B-RETRY-PUT ELSE GO TO A-MAIN-END END-IF WHEN OTHER DISPLAY 'MQPUT to ' W02-DLQ ' failed' DISPLAY 'Reason Code=' W03-REASON END-EVALUATE GO TO A-MAIN-DISCONNECT END-IF. MOVE W03-REASON TO W00-RC. DISPLAY 'Successful write of message to ' W02-DLQ. ADD 1 to W00-DEAD-COUNT. exit. * --------------------------------------------------------------- * End of program * ---------------------------------------------------------------