| products/sources/formale sprachen/Cobol/verschiedene-Autoren/MQ-Series/ |
|
Quellcode-Bibliothek
© Kompilation durch diese Firma
[Weder Korrektheit noch Funktionsfähigkeit der Software werden zugesichert.]
Datei: 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 * * ------------------------------------------------------------- * [ zur Elbe Produktseite wechseln0.82Quellennavigators Analyse erneut starten ] |