|
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 *
* ------------------------------------------------------------- *
¤ Dauer der Verarbeitung: 0.56 Sekunden
(vorverarbeitet)
¤
|
Haftungshinweis
Die Informationen auf dieser Webseite wurden
nach bestem Wissen sorgfältig zusammengestellt. Es wird jedoch weder Vollständigkeit, noch Richtigkeit,
noch Qualität der bereit gestellten Informationen zugesichert.
Bemerkung:
Die farbliche Syntaxdarstellung ist noch experimentell.
|
