Re: S0C4 x'4' abend while reading VSAM KSDS file

Hi

Please find the code below , where the enhancement changes done by me
will be prefixed by % symbol , this was the original code when the
program got abended when put into production. Since its official and
due to some security reasons i was reluctant to post the code
previously.

IDENTIFICATION DIVISION.

* THIS PROGRAM WILL READ THE INPUT FILE CONTAINING MQ FORMAT
* RECORDS AND WRITES TO THE MQ SERIES
*
* NOTE: TO COMPILE/LINKEDIT THE PROGRAM IN ENDEVOR
* USE COBPARM CARD WITH NODYNAM COMPILER OPTION
* AND LINKSET CARD TO STATICALLY INCLUDE CSQBSTUB
EJECT
ENVIRONMENT DIVISION.
*
INPUT-OUTPUT SECTION.
FILE-CONTROL.
*
SELECT MQFORM-FILE ASSIGN TO MQFORMFL
FILE STATUS IS WS-MQFORM-STATUS.
SELECT WAITPARM ASSIGN TO UT-S-WAITPARM.

%SELECT DSCCQNMN-FILE ASSIGN TO DSCCQNMN
% ORGANIZATION IS INDEXED
% ACCESS MODE IS RANDOM
% RECORD KEY IS QNMN-ACCT-NBR
% FILE STATUS IS WS-DSCCQNMN-STATUS.
*
DATA DIVISION.
FILE SECTION.
*
FD MQFORM-FILE
RECORDING MODE IS F
BLOCK CONTAINS 0 RECORDS
LABEL RECORDS ARE STANDARD.
*
%01 MQ-INPUT-RECORD.
% 05 MQFORM-RECORD PIC X(750).
% 05 MQ-QUEUE-NAME PIC X(30).
% 05 MQ-DATE PIC X(06).
% 05 FILLER PIC X(14).
*
%FD DSCCQNMN-FILE
% RECORD CONTAINS 100 CHARACTERS
% LABEL RECORDS ARE STANDARD.
%COPY DSCCQNMN.
*
FD WAITPARM
LABEL RECORDS ARE STANDARD
RECORDING MODE IS F
BLOCK CONTAINS 0 RECORDS.
01 WAIT-PARM-REC PIC X(80).

*
WORKING-STORAGE SECTION.
*
01 FILLER PIC X(36) VALUE
'DHMQTEST WORKING STORAGE STARTS HERE'.
*
****************************************************************
*C C O M M O N W O R K A R E A S
****************************************************************
*
01 WS-LITERALS.
05 WS-LIT-QUEUE-NAME PIC X(20)
* VALUE 'HNCDSCVR.LQ.FCMSHIGH'.
VALUE 'HNCDSCVR.LQ.FCMSLOW'.
* VALUE 'HNCDSCVR.LQ.VOLLOW'.
05 WS-LIT-YES PIC X(01) VALUE 'Y'.
05 WS-LIT-NO PIC X(01) VALUE 'N'.
*
01 WS-VARIABLES.
05 WS-CNT PIC 9(07).
05 WS-MQ-CHECK-CNT PIC 9(06).
05 WS-WRITE-CNT PIC 9(07).
05 WS-DISPLAY-CNT PIC 9(02).
05 WS-MQ-FULL PIC X(01).
05 WS-NBR-ATTEMPTS PIC 9(01).
05 WAIT-MODULE PIC X(8) VALUE 'ILBOWAT0'.
05 WS-WAIT-TIME PIC S9(8) COMP.
*
****************************************************************
*C C O N S T A N T S
****************************************************************
*
01 WS-CONSTANTS.
05 WS-ERROR-FLAG PIC X(01) VALUE 'N'.
88 WS-ERROR-FOUND VALUE 'Y'.
05 WS-EOF-FLAG PIC X(01) VALUE 'N'.
88 WS-EOF VALUE 'Y'.
05 WS-FIRST-READ-FLAG PIC X(01) VALUE 'N'.
88 WS-FIRST-RECORD VALUE 'Y'.
05 MQ-CONNECT-FLAG PIC X(01) VALUE 'N'.
88 MQ-CONNECTED VALUE 'Y'.
88 MQ-NOT-CONNECTED VALUE 'N'.
05 WS-ONE PIC S9(01) VALUE +1.

01 STATUS-VARIABLES.
05 WS-MQFORM-STATUS PIC X(02).
88 SUCCESSFUL-IO VALUE '00', '02', '97'.
88 END-OF-FILE VALUE '10'.
88 RECORD-NOT-FOUND VALUE '23'.
05 WS-DSCCQNMN-STATUS PIC X(02).
88 WS-SUCCESSFUL-IO VALUE '00','97'.
88 WS-RECORD-NOT-FOUND VALUE '23'.
****************************************************************
*C E R R O R M E S S A G E S
****************************************************************
*
01 ERROR-MESSAGES.
05 ERROR-OPENING-INPUT-FILE PIC X(58) VALUE
'*** ERROR OPENING INPUT FILE *** '.
05 ERROR-OPENING-DSCCQNMN-FILE PIC X(58) VALUE
'*** ERROR OPENING DSCCQNMN FILE *** '.
05 ERROR-READING-INPUT-FILE PIC X(58) VALUE
'*** ERROR READING INPUT FILE *** '.
05 ERROR-IN-QMGR-NAME PIC X(58) VALUE
'*** QUEUE MANAGER NAME INVALID IN PARM *** '.
05 ERROR-EMPTY-INPUT-FILE PIC X(58) VALUE
'*** INPUT FILE IS EMPTY *** '.
05 MISSING-WAIT-PARM PIC X(58) VALUE
'*** WAIT PARM FILE IS EMPTY *** '.
05 BAD-WAIT-PARMS PIC X(58) VALUE
'*** NON-NUMERIC DATA IN PARM FILE *** '.

01 MQ-DEPTH-MESSAGE.
05 FILLER PIC X(14) VALUE
'### MQ DEPTH: '.
05 WS-DISP-DEPTH PIC Z(8)9.
05 FILLER PIC X(18) VALUE
' RECORDS WRITTEN: '.
05 WS-DISP-WRITTEN PIC Z(8)9.
05 FILLER PIC X(02) VALUE SPACE.
05 WS-HH PIC 99.
05 FILLER PIC X(01) VALUE ':'.
05 WS-MM PIC 99.
05 FILLER PIC X(01) VALUE ':'.
05 WS-SS PIC 99.


01 RETURN-STATUS PIC S9(6) COMP.
01 ERROR-MESSAGE PIC X(58).
01 WS-RETURN-CODE PIC 9(06).
01 WS-CURRENT-TIME PIC 9(08).

01 WS-WAIT-PARMS.
05 WS-RECORDS-TO-SKIP PIC 9(07).
05 FILLER PIC X.
05 WS-SECONDS-TO-WAIT PIC 9(04).
05 FILLER PIC X.
05 WS-MQ-THRESHOLD PIC 9(07).
05 FILLER PIC X(60).
*
****************************************************************
*C M Q V A R I A B L E S
****************************************************************
*
01 MQ-API-VARIABLES.
05 MQM-OPTIONS PIC S9(09) BINARY.
05 MQM-OBJECT-HANDLE PIC S9(09) BINARY.
05 MQM-COMPLETION-CODE PIC S9(09) BINARY.
05 MQM-REASON-CODE PIC S9(09) BINARY.
*
01 WS-QUEUE-MANAGER.
05 WS-Q-MGRNAME PIC X(04).
05 FILLER PIC X(44) VALUE SPACES.
*
** MQ PUT MESSAGE OPTIONS
01 MQM-PUT-MESSAGE-OPTIONS.
COPY CMQPMOV.
*
*** MQ CONSTANTS
01 WS-MQ-CONSTANTS.
COPY CMQV.
COPY DHCCMQC0.
*
*** MQ API CONTROL BLOCKS
01 MQM-OBJECT-DESCRIPTOR.
COPY CMQODV.
*
*** MQ INTERFACE
01 MQ-INTERFACE.
COPY DHCCMQI0.
COPY CMQMDV.
*
*
01 SELECTOR-COUNT PIC S9(9) COMP.
01 INT-ATTR-COUNT PIC S9(9) COMP.
01 INT-ATTRS PIC S9(9) COMP.
01 CHAR-ATTR-LENGTH PIC S9(9) COMP.
01 CHAR-ATTRS PIC X(01).
01 SELECTORS PIC S9(9) COMP.
01 WS-MQ-HCONN PIC S9(9) COMP.
01 DEPTH-LIMIT PIC S9(9) COMP VALUE 200.
01 MQ-DEPTH PIC S9(9) COMP.
*
*01 LK-API-REQ-MESSAGE PIC X(4194304).
%*01 LK-API-REQ-MESSAGE PIC X(750).
% 01 LK-API-REQ-MESSAGE PIC X(800).
*01 LK-API-REQ-MESSAGE PIC X(919).
*01 LK-API-REQ-MESSAGE PIC X(922).
EJECT
*
LINKAGE SECTION.
*
*C THIS IS A PARM FOR THE MQ QUEUE MANAGER
*
01 PARMDATA.
05 FILLER PIC S9(03) BINARY.
05 WS-PARM-QMGR PIC X(04).
*
**************************************************************
PROCEDURE DIVISION USING PARMDATA.
*
1000-MAINLINE SECTION.
****************************************************************
*C THIS SECTION CONTROLS THE MAIN PROCESSING OF THE PROGRAM.
*C IT CALLS SECTIONS TO:
*C - INITIALIZE PROGRAM VARIABLES
*C - READS THE INPUT FILE AND CALLS MQ SERIES
*C - TERMINATE THE PROGRAM.
****************************************************************
*
PERFORM 2000-HOUSEKEEPING THRU 2000-EXIT.

PERFORM 3000-RETRIEVE-ACCEPTED THRU 3000-EXIT
UNTIL WS-EOF OR WS-ERROR-FOUND.

PERFORM 9000-TERMINATION THRU 9000-EXIT.
*
1000-EXIT. GOBACK.
*
2000-HOUSEKEEPING.
**************************************************************
*C THIS SECTION INITIALIZES THE PROGRAM VARIABLES, CONNECTS
*C TO THE MQ MANGR, OPENS THE MQ QUEUE, OPENS THE FILE, AND
*C READS THE FIRST RECORD OF THE INPUT FILE.
**************************************************************
*
INITIALIZE WS-VARIABLES.
*
* ACCEPTS THE PARM FOR MQ MANAGER...
*
IF WS-PARM-QMGR = SPACES OR LOW-VALUES
MOVE ERROR-IN-QMGR-NAME TO ERROR-MESSAGE
MOVE 8 TO WS-RETURN-CODE
SET MQ-NOT-CONNECTED TO TRUE
SET WS-ERROR-FOUND TO TRUE
PERFORM 9100-PROCESS-ERROR THRU 9100-EXIT
GO TO 2000-EXIT
ELSE
MOVE WS-PARM-QMGR TO WS-Q-MGRNAME
END-IF.
*
PERFORM 2100-READ-WAIT-PARMS THRU 2100-EXIT.
IF WS-ERROR-FOUND
GO TO 2000-EXIT
END-IF.
*
*C CALLS MQCONN TO CONNECT TO QUEUE...
*
PERFORM 4000-MQ-CONNECT THRU 4000-EXIT.
*
*C CALLS MQOPEN TO OPEN THE QUEUE...
*
IF MQ-CONNECTED
PERFORM 4100-MQ-OPEN THRU 4100-EXIT
IF WS-ERROR-FOUND
GO TO 2000-EXIT
END-IF
ELSE
GO TO 2000-EXIT
END-IF
*
*C OPENS THE INPUT AND OUTPUT FILE ...
*
OPEN INPUT MQFORM-FILE

IF SUCCESSFUL-IO
NEXT SENTENCE
ELSE
MOVE ERROR-OPENING-INPUT-FILE TO ERROR-MESSAGE
MOVE WS-MQFORM-STATUS TO WS-RETURN-CODE
SET WS-ERROR-FOUND TO TRUE
PERFORM 9100-PROCESS-ERROR THRU 9100-EXIT
GO TO 2000-EXIT
END-IF

*
*C READS FIRST RECORD ...
*
SET WS-FIRST-RECORD
TO TRUE.

PERFORM 4400-READ-INPUT THRU 4400-EXIT.
*
OPEN INPUT DSCCQNMN-FILE

IF WS-SUCCESSFUL-IO
NEXT SENTENCE
ELSE
MOVE ERROR-OPENING-DSCCQNMN-FILE TO ERROR-MESSAGE
MOVE WS-DSCCQNMN-STATUS TO WS-RETURN-CODE
SET WS-ERROR-FOUND TO TRUE
PERFORM 9100-PROCESS-ERROR THRU 9100-EXIT
GO TO 2000-EXIT
END-IF.
2000-EXIT.
EXIT.
*
2100-READ-WAIT-PARMS.
OPEN INPUT WAITPARM.
READ WAITPARM INTO WS-WAIT-PARMS
AT END
MOVE MISSING-WAIT-PARM TO ERROR-MESSAGE
MOVE 8 TO WS-RETURN-CODE
SET WS-ERROR-FOUND TO TRUE
PERFORM 9100-PROCESS-ERROR THRU 9100-EXIT
GO TO 2100-EXIT
END-READ.

IF WS-RECORDS-TO-SKIP NOT NUMERIC OR
WS-SECONDS-TO-WAIT NOT NUMERIC OR
WS-MQ-THRESHOLD NOT NUMERIC
MOVE BAD-WAIT-PARMS TO ERROR-MESSAGE
MOVE 8 TO WS-RETURN-CODE
SET WS-ERROR-FOUND TO TRUE
PERFORM 9100-PROCESS-ERROR THRU 9100-EXIT
END-IF.

CLOSE WAITPARM.
2100-EXIT.
EXIT.
*
3000-RETRIEVE-ACCEPTED.
**************************************************************
*C THIS SECTION PROCESSES EACH ACCEPTED EXTERNAL FILE RECORD,
*C BUILDS THE API SEGMENTS, AND THEN PERFORMS CALLS TO MQ.
**************************************************************
*

* INITIALIZE LK-API-REQ-MESSAGE
% INITIALIZE DSCCQNMN-RECORD
% MOVE MQFORM-RECORD(5:16) TO QNMN-ACCT-NBR
% PERFORM 3300-READ-DSCCQNMN THRU 3300-EXIT
% MOVE MQ-INPUT-RECORD TO LK-API-REQ-MESSAGE
MOVE ZEROES TO WS-NBR-ATTEMPTS
MOVE 'Y' TO WS-MQ-FULL

PERFORM 4200-MQ-PUT THRU 4200-EXIT
UNTIL WS-MQ-FULL = 'N'
IF WS-ERROR-FOUND
GO TO 3000-EXIT
END-IF.

ADD +1 TO WS-MQ-CHECK-CNT.
IF WS-MQ-CHECK-CNT > WS-RECORDS-TO-SKIP
MOVE ZERO TO WS-MQ-CHECK-CNT
PERFORM 3100-GET-MQ-DEPTH THRU 3100-EXIT
PERFORM UNTIL MQ-DEPTH < WS-MQ-THRESHOLD
OR WS-ERROR-FOUND
PERFORM 6000-WAIT-PARA THRU 6000-EXIT
PERFORM 3100-GET-MQ-DEPTH THRU 3100-EXIT
END-PERFORM
END-IF.

IF NOT WS-EOF AND NOT WS-ERROR-FOUND
PERFORM 4400-READ-INPUT THRU 4400-EXIT
ELSE
CONTINUE
END-IF.

3000-EXIT.
EXIT.
*
3100-GET-MQ-DEPTH.
************** MQINQ PARAMETERS: **************************
* WS-MQ-HCONN - CONNECTION HANDLE, IS RETURNED FROM MQ CONNECT
* MQ-OBJECT-HANDLE - OBJECT HANDLE, RETURNED FROM MQ OPEN
* SELECTOR-COUNT - NUMBER OF ALL ATTRIBUTES TO BE RETURNED
* SELECTORS-TABLE - LIST OF ALL ATTRIBUTES TO BE RETURNED
* INT-ATTR-COUNT - NUMBER OF INTEGER ATTRIBUTES
* INT-ATTR-TABLE - LIST OF INTEGER ATTRIBUTES
* CHAR-ATTR-LENGTH - LENGTH OF THE BUFFER WITH CHAR ATTRIBS
* CHAR-ATTRS - THIS IS THE BUFFER WITH CHAR ATTRIBS
* MQM-COMPLETION-CODE
* MQM-REASON-CODE
*************************************************************
* MOVE CONNECTION HANDLE, RECEIVED IN MQ CONNECT
MOVE MQ-HCONN TO WS-MQ-HCONN.
* WE ARE REQUESTING ONE QUEUE ATTRIBUTE:
MOVE 1 TO SELECTOR-COUNT.
* THIS IS 1 INTEGER ATTRIBUTE: CURRENT MQ DEPTH
MOVE 1 TO INT-ATTR-COUNT.
MOVE MQIA-CURRENT-Q-DEPTH TO SELECTORS.
MOVE 0 TO CHAR-ATTR-LENGTH

CALL 'MQINQ' USING
00020000
WS-MQ-HCONN,
00030000
MQ-OBJECT-HANDLE,
00040000
SELECTOR-COUNT,
00050000
SELECTORS,
00060000
INT-ATTR-COUNT,
00070000
INT-ATTRS,
00080000
CHAR-ATTR-LENGTH,
00090000
CHAR-ATTRS,
00100000
MQM-COMPLETION-CODE,
00110000
MQM-REASON-CODE.
00110000

IF (MQM-COMPLETION-CODE NOT = MQCC-OK) THEN
SET WS-ERROR-FOUND TO TRUE
MOVE INQUIRE-ERROR-MESSAGE TO ERROR-MESSAGE
MOVE MQM-REASON-CODE TO WS-RETURN-CODE
PERFORM 9100-PROCESS-ERROR THRU 9100-EXIT
ELSE
MOVE INT-ATTRS TO MQ-DEPTH
PERFORM 3200-DISPLAY-DEPTH-MSG THRU 3200-EXIT
END-IF.
3100-EXIT.
EXIT.

3200-DISPLAY-DEPTH-MSG.
MOVE MQ-DEPTH TO WS-DISP-DEPTH.
MOVE WS-WRITE-CNT TO WS-DISP-WRITTEN.
ACCEPT WS-CURRENT-TIME FROM TIME.
MOVE WS-CURRENT-TIME(1:2) TO WS-HH.
MOVE WS-CURRENT-TIME(3:2) TO WS-MM.
MOVE WS-CURRENT-TIME(5:2) TO WS-SS.
DISPLAY MQ-DEPTH-MESSAGE.
3200-EXIT.
EXIT.

% 3300-READ-DSCCQNMN.
%****************************************************************
%* THIS SECTION READS THE DSCCQNMN FILE TO GET THE LAST QUEUE
%* NAME AND THE DATE FOR THE CORRESPONDING ACCOUNT NUMBER.
%****************************************************************
*
% MOVE '3300-READ-DSCCQNMN' TO ERROR-MESSAGE.


% READ DSCCQNMN-FILE
% IF WS-SUCCESSFUL-IO
% MOVE QNMN-QUEUE-NAME TO MQ-QUEUE-NAME
% MOVE QNMN-DATE TO MQ-DATE
% ELSE
% IF WS-RECORD-NOT-FOUND
% MOVE SPACES TO MQ-QUEUE-NAME
% MOVE SPACES TO MQ-DATE
% ELSE
% SET WS-ERROR-FOUND TO TRUE
% MOVE WS-DSCCQNMN-STATUS TO WS-RETURN-CODE
% MOVE '**3300-READ-DSCCQNMN FAILED**'
% TO ERROR-MESSAGE
% PERFORM 9100-PROCESS-ERROR THRU 9100-EXIT
% END-IF
% END-IF.
%3300-EXIT.
% EXIT.

4000-MQ-CONNECT SECTION.
****************************************************************
*C THIS SECTION CONNECTS TO THE QUEUE.
****************************************************************
*
MOVE WS-QUEUE-MANAGER TO MQ-TARGET-QUEUE.
MOVE MQ-CONNECT TO MQ-FUNCTION-ID.

PERFORM 5000-EXECUTE-REQUEST THRU 5000-EXIT

IF MQ-RETURN-CODE = ZERO
SET MQ-CONNECTED TO TRUE
ELSE
SET WS-ERROR-FOUND TO TRUE
MOVE CONNECT-ERROR-MESSAGE TO ERROR-MESSAGE
MOVE MQ-RETURN-CODE TO WS-RETURN-CODE
PERFORM 9100-PROCESS-ERROR THRU 9100-EXIT
END-IF.
*
4000-EXIT.
EXIT.
*
4100-MQ-OPEN.
****************************************************************
*C THIS SECTION OPENS THE MQ QUEUE 50MQ THRU F8MQ, WHICHEVER
*C ARE BEING USED.
****************************************************************
*
MOVE ZERO TO MQ-RETURN-CODE.
MOVE MQ-OPEN-OUT TO MQ-FUNCTION-ID.
MOVE WS-LIT-NO TO MQ-OPT-SYNCPOINT.
MOVE WS-LIT-NO TO MQ-OPT-CHAR-CONVERSION.
MOVE MQ-CONTEXT-ALL TO MQ-OPT-CONTEXT.
MOVE ZERO TO MQ-OBJECT-HANDLE.
MOVE WS-LIT-QUEUE-NAME TO MQ-TARGET-QUEUE.
DISPLAY 'MQ-TARGET-QUEUE : ' MQ-TARGET-QUEUE
*
*C CALL MQOPEN TO OPEN THE INPUT QUEUE
*
PERFORM 5000-EXECUTE-REQUEST THRU 5000-EXIT

IF MQ-RETURN-CODE NOT = ZERO
SET WS-ERROR-FOUND TO TRUE
MOVE OPEN-ERROR-MESSAGE TO ERROR-MESSAGE
MOVE MQ-RETURN-CODE TO WS-RETURN-CODE
PERFORM 9100-PROCESS-ERROR THRU 9100-EXIT
END-IF.
*
4100-EXIT.
EXIT.
*
4200-MQ-PUT.
****************************************************************
*C THIS SECTION MOVES THE APPLICATION DATA TO THE MQ QUEUE.
*C IT ALSO BUILDS THE MSGID WITH A LENGTH OF 24 BYTES.
*C IT USES FORMAT EXTFIL-KEY + LASTNAME(2-BYTE) +
*C FIRSTNAME(2-BYTE)+QUEUE USED(1 BYTE)+DATE(MMDD)+(TIME)SS.
*C MSGID SERVES AS INPUT AND OUTPUT TO MQ TO UNIQUELY IDENTIFY
*C THE MESSAGE. IT IS PASSED BACK AND SAVED OFF IN A WS FIELD
*C WS-OUTPUT-RECORD TO BE THE VSAM KEY.
****************************************************************
*
MOVE ZERO TO MQ-RETURN-CODE.
MOVE 'N' TO WS-MQ-FULL
MOVE MQ-PUT TO MQ-FUNCTION-ID.
MOVE WS-LIT-NO TO MQ-OPT-SYNCPOINT.
MOVE WS-LIT-NO TO MQ-OPT-CHAR-CONVERSION.
MOVE MQ-CONTEXT-ALL TO MQ-OPT-CONTEXT.
* MOVE MQMT-REQUEST TO MQMD-MSGTYPE.
* MOVE MQPER-PERSISTENT TO MQMD-PERSISTENCE.
MOVE MQPER-NOT-PERSISTENT TO MQMD-PERSISTENCE.

*
MOVE LENGTH OF MQFORM-RECORD TO MQ-MESSAGE-LEN.

PERFORM 5000-EXECUTE-REQUEST THRU 5000-EXIT

IF MQ-RETURN-CODE NOT = ZERO AND
WS-MQ-FULL = 'N'
SET WS-ERROR-FOUND TO TRUE
MOVE PUT-ERROR-MESSAGE TO ERROR-MESSAGE
MOVE MQ-RETURN-CODE TO WS-RETURN-CODE
PERFORM 9100-PROCESS-ERROR THRU 9100-EXIT
* ELSE
* IF WS-NBR-ATTEMPTS > 5
* SET WS-ERROR-FOUND TO TRUE
* MOVE PUT-ERROR-MESSAGE TO ERROR-MESSAGE
* MOVE MQ-RETURN-CODE TO WS-RETURN-CODE
* PERFORM 9100-PROCESS-ERROR THRU 9100-EXIT
* MOVE 'N' TO WS-MQ-FULL
* END-IF
END-IF.
*
4200-EXIT.
EXIT.
*
4300-MQ-CLOSE.
*********************************************************
*C THIS SECTION CLOSES THE MQ QUEUE.
*********************************************************
*
MOVE MQ-CLOSE TO MQ-FUNCTION-ID.

PERFORM 5000-EXECUTE-REQUEST THRU 5000-EXIT

IF MQ-RETURN-CODE NOT = ZERO
SET WS-ERROR-FOUND TO TRUE
MOVE CLOSE-ERROR-MESSAGE TO ERROR-MESSAGE
MOVE MQ-RETURN-CODE TO WS-RETURN-CODE
PERFORM 9100-PROCESS-ERROR THRU 9100-EXIT
END-IF.
*
4300-EXIT.
EXIT.
*
4400-READ-INPUT.
*********************************************************
*C THIS SECTION READS THE INPUT FILE.
*********************************************************
*
READ MQFORM-FILE.
IF SUCCESSFUL-IO
MOVE WS-LIT-NO TO WS-FIRST-READ-FLAG
ADD 1 TO WS-CNT
ELSE
IF END-OF-FILE
SET WS-EOF TO TRUE
IF WS-FIRST-RECORD
MOVE ERROR-EMPTY-INPUT-FILE TO ERROR-MESSAGE
MOVE WS-MQFORM-STATUS TO WS-RETURN-CODE
PERFORM 9100-PROCESS-ERROR THRU 9100-EXIT
END-IF
ELSE
SET WS-ERROR-FOUND TO TRUE
MOVE ERROR-READING-INPUT-FILE TO ERROR-MESSAGE
MOVE WS-MQFORM-STATUS TO WS-RETURN-CODE
PERFORM 9100-PROCESS-ERROR THRU 9100-EXIT
END-IF.
*
4400-EXIT.
EXIT.
*
5000-EXECUTE-REQUEST.
****************************************************************
*C PURPOSE:
*C - DETERMINE WHAT ACTION TO TAKE BASED UPON THE
*C MQ FUNCTION ID
****************************************************************

EVALUATE MQ-FUNCTION-ID

WHEN MQ-OPEN-OUT
IF MQ-OBJECT-HANDLE = ZERO
PERFORM 5100-GENERIC-OPEN THRU 5100-EXIT
ELSE
CONTINUE
END-IF
WHEN MQ-PUT
PERFORM 5200-PUT-RESP-MSG-TO-Q THRU 5200-EXIT

WHEN MQ-CLOSE
PERFORM 5300-GENERIC-CLOSE THRU 5300-EXIT

WHEN MQ-CONNECT
PERFORM 5400-CONNECT THRU 5400-EXIT

WHEN MQ-DISCONNECT
PERFORM 5500-DISCONNECT THRU 5500-EXIT
END-EVALUATE.
*
5000-EXIT.
EXIT.
*
5100-GENERIC-OPEN.
****************************************************************
*C PURPOSE:
*C - OPENS A QUEUE FOR INPUT
****************************************************************

PERFORM 5150-SET-MQ-OPTIONS THRU 5150-EXIT.

CALL 'MQOPEN' USING MQ-HCONN,
MQM-OBJECT-DESCRIPTOR,
MQM-OPTIONS,
MQM-OBJECT-HANDLE,
MQM-COMPLETION-CODE,
MQM-REASON-CODE.

DISPLAY '************** CALL TO MQOPEN *****************'
DISPLAY 'MQM-OBJECT-HANDLE: ' MQM-OBJECT-HANDLE.
DISPLAY 'MQM-REASON-CODE: ' MQM-REASON-CODE.

IF MQM-COMPLETION-CODE = MQCC-OK
MOVE ZERO
TO MQ-RETURN-CODE
MOVE MQM-OBJECT-HANDLE
TO MQ-OBJECT-HANDLE
ELSE
IF MQM-REASON-CODE = MQRC-Q-MGR-QUIESCING
OR MQM-REASON-CODE = MQRC-Q-MGR-STOPPING
MOVE QUEUE-MANAGER-STOPPING
TO MQ-RETURN-CODE
ELSE
MOVE MQM-REASON-CODE
TO MQ-RETURN-CODE
END-IF
END-IF.
*
5100-EXIT.
EXIT.
*
5150-SET-MQ-OPTIONS.
****************************************************************
*C PURPOSE:
*C - TO SET THE OPTIONS FOR MQOPEN
****************************************************************

MOVE MQOT-Q
TO MQOD-OBJECTTYPE.
MOVE MQ-TARGET-QUEUE
TO MQOD-OBJECTNAME.
MOVE WS-QUEUE-MANAGER
TO MQOD-OBJECTQMGRNAME.

COMPUTE MQM-OPTIONS = MQOO-OUTPUT
+ MQOO-FAIL-IF-QUIESCING
+ MQOO-INQUIRE.

IF MQ-OPT-CONTEXT = MQ-CONTEXT-IDENTITY
COMPUTE MQM-OPTIONS = MQM-OPTIONS
+ MQOO-SET-IDENTITY-CONTEXT
+ MQOO-PASS-IDENTITY-CONTEXT
ELSE
IF MQ-OPT-CONTEXT = MQ-CONTEXT-ALL
ADD MQOO-SET-ALL-CONTEXT
TO MQM-OPTIONS
END-IF
END-IF.
*
5150-EXIT.
EXIT.
*
5200-PUT-RESP-MSG-TO-Q.
****************************************************************
*C PURPOSE:
*C - TO SEND A MESSAGE FROM THE MAINFRAME TO ACAPS
****************************************************************

COMPUTE MQPMO-OPTIONS = MQPMO-FAIL-IF-QUIESCING.

IF MQ-OPT-CONTEXT = MQ-CONTEXT-IDENTITY
COMPUTE MQPMO-OPTIONS = MQPMO-OPTIONS
+ MQPMO-SET-IDENTITY-CONTEXT
+ MQPMO-PASS-IDENTITY-CONTEXT
ELSE
IF MQ-OPT-CONTEXT = MQ-CONTEXT-ALL
ADD MQPMO-SET-ALL-CONTEXT
TO MQPMO-OPTIONS
ELSE
CONTINUE
END-IF
END-IF.

IF MQ-OPT-SYNCPOINT = WS-LIT-YES
CONTINUE
ELSE
COMPUTE MQPMO-OPTIONS = MQPMO-OPTIONS
+ MQPMO-NO-SYNCPOINT
END-IF.

CALL 'MQPUT' USING MQ-HCONN,
MQ-OBJECT-HANDLE,
MQMD,
MQPMO,
MQ-MESSAGE-LEN,
LK-API-REQ-MESSAGE,
MQM-COMPLETION-CODE,
MQM-REASON-CODE.

IF MQM-COMPLETION-CODE = MQCC-OK
MOVE ZERO
TO MQ-RETURN-CODE
ADD 1 TO WS-WRITE-CNT
* WS-DISPLAY-CNT
* IF WS-DISPLAY-CNT > 10
* DISPLAY 'QUEUE FULL - WAITING ' WS-NBR-ATTEMPTS
* DISPLAY 'WS-WRITE-CNT : ' WS-WRITE-CNT
* PERFORM 6000-WAIT-PARA THRU 6000-EXIT
* MOVE 0 TO WS-DISPLAY-CNT
* END-IF
ELSE
EVALUATE MQM-REASON-CODE
WHEN MQRC-Q-MGR-QUIESCING
MOVE QUEUE-MANAGER-STOPPING
TO MQ-RETURN-CODE
WHEN MQRC-Q-MGR-STOPPING
MOVE QUEUE-MANAGER-STOPPING
TO MQ-RETURN-CODE
WHEN MQRC-Q-FULL
ADD 1 TO WS-NBR-ATTEMPTS
DISPLAY 'QUEUE FULL - WAITING ' WS-NBR-ATTEMPTS
DISPLAY 'WS-WRITE-CNT : ' WS-WRITE-CNT
PERFORM 6000-WAIT-PARA THRU 6000-EXIT
MOVE 'Y' TO WS-MQ-FULL
WHEN OTHER
MOVE MQM-REASON-CODE
TO MQ-RETURN-CODE
END-EVALUATE
END-IF.
*
5200-EXIT.
EXIT.
*
5300-GENERIC-CLOSE.
****************************************************************
*C PURPOSE:
*C - TO CLOSE A QUEUE
****************************************************************
*
DISPLAY '************** CALL TO MQCLOSE ****************'
DISPLAY 'MQM-OBJECT-HANDLE: ' MQ-OBJECT-HANDLE.

MOVE ZEROES
TO MQM-OPTIONS.

CALL 'MQCLOSE' USING MQ-HCONN,
MQ-OBJECT-HANDLE,
MQM-OPTIONS,
MQM-COMPLETION-CODE,
MQM-REASON-CODE.

DISPLAY 'MQM-REASON-CODE: ' MQM-REASON-CODE.

IF MQM-COMPLETION-CODE = MQCC-OK
MOVE ZERO
TO MQ-RETURN-CODE
ELSE
EVALUATE MQM-REASON-CODE
WHEN MQRC-Q-MGR-QUIESCING
MOVE QUEUE-MANAGER-STOPPING
TO MQ-RETURN-CODE
WHEN MQRC-Q-MGR-STOPPING
MOVE QUEUE-MANAGER-STOPPING
TO MQ-RETURN-CODE
WHEN OTHER
MOVE MQM-REASON-CODE
TO MQ-RETURN-CODE
END-EVALUATE
END-IF.

5300-EXIT.
EXIT.
*
5400-CONNECT.
****************************************************************
*C PURPOSE:
*C - CONNECTS TO THE MQ QUEUE MANAGER
****************************************************************

CALL 'MQCONN' USING MQ-TARGET-QUEUE,
MQ-HCONN,
MQM-COMPLETION-CODE,
MQM-REASON-CODE.

DISPLAY '************** CALL TO MQCONN *****************'
DISPLAY 'MQM-REASON-CODE: ' MQM-REASON-CODE.

IF MQM-COMPLETION-CODE = MQCC-OK
MOVE ZERO TO MQ-RETURN-CODE
ELSE
MOVE MQM-REASON-CODE TO MQ-RETURN-CODE
END-IF.

5400-EXIT.
EXIT.
*
5500-DISCONNECT.
****************************************************************
*C PURPOSE:
*C - DISCONNECT FROM THE MQ QUEUE MANAGER
****************************************************************

CALL 'MQDISC' USING MQ-HCONN,
MQM-COMPLETION-CODE,
MQM-REASON-CODE.

DISPLAY '************** CALL TO MQDISC *****************'
DISPLAY 'MQM-REASON-CODE: ' MQM-REASON-CODE.

IF MQM-COMPLETION-CODE = MQCC-OK
MOVE ZERO TO MQ-RETURN-CODE
ELSE
MOVE MQM-REASON-CODE TO MQ-RETURN-CODE
END-IF.

5500-EXIT.
EXIT.
*
6000-WAIT-PARA.
* MOVE +180 TO WS-SECONDS-TO-WAIT.
* MOVE +5 TO WS-SECONDS-TO-WAIT.

MOVE WS-SECONDS-TO-WAIT TO WS-WAIT-TIME
CALL 'ILBOWAT0' USING WS-WAIT-TIME.

6000-EXIT.
EXIT.

9000-TERMINATION.
**************************************************************
*C THIS SECTION PERFORMS A CLOSE ON THE MQ QUEUES,
*C A DISCONNECT FROM THE QUEUE MANAGER, AND CLOSES THE
*C PROGRAM FILES.
**************************************************************
*
IF MQ-CONNECTED
PERFORM 4300-MQ-CLOSE THRU 4300-EXIT

MOVE MQ-DISCONNECT TO MQ-FUNCTION-ID
PERFORM 5000-EXECUTE-REQUEST THRU 5000-EXIT

IF MQ-RETURN-CODE = ZERO
CONTINUE
ELSE
SET WS-ERROR-FOUND TO TRUE
MOVE DISCONNECT-ERROR-MESSAGE
TO ERROR-MESSAGE
MOVE MQ-RETURN-CODE TO WS-RETURN-CODE
PERFORM 9100-PROCESS-ERROR THRU 9100-EXIT
END-IF
ELSE
NEXT SENTENCE
END-IF.

CLOSE DSCCQNMN-FILE.
CLOSE MQFORM-FILE.
DISPLAY 'NUMBER OF RECORDS READ FROM INPUT : ' WS-CNT
DISPLAY 'NUMBER OF RECORDS WRITTEN IN MQ : ' WS-WRITE-CNT

IF WS-ERROR-FOUND
MOVE '08' TO RETURN-CODE.
*
9000-EXIT.
EXIT.
*
9100-PROCESS-ERROR.
****************************************************************
*C THIS SECTION DISPLAYS THE ERROR MESSAGE TO SYSOUT
****************************************************************
*
DISPLAY ERROR-MESSAGE.
DISPLAY 'RETURN CODE: ' WS-RETURN-CODE.
*
9100-EXIT.
EXIT.
*

Thanks
.

Relevant Pages