IDENTIFICATION DIVISION.
PROGRAM-ID. CSARESCK.
***************************************************************** * SAMPLE CSA PROGRAM TO ILLUSTRATE ESTABLISHING A * ConnectION TO SQL SERVER, EXECUTING A SQL REQUEST THAT HAS * SEVERAL INSERT STATEMENTS - ONE OF WHICH IS BAD - AND THEN * SCROLLING THROUGH THE GETMSG AND RESCHECK FEATURES TO DETER- * MINE WHICH SQL COMMAND(S) RECEIVED AN ERROR. * * NOTE: THIS APPROACH FOR BATCHING SQL COMMANDS ONLY WORKS IN * SITUATIONS WHERE SQL SERVER DOES NOT RECEIVE AN ERROR SEVERE * ENOUGH TO CAUSE A ROLLBACK TRANSACTION (IN WHICH CASE THE CSA * WILL ONLY RECEIVE ONE ERROR MESSAGE FOR THE ENTIRE BATCH OF * COMMANDS). IF A ROLLBACK TRANSACTION DOES NOT OCCUR, THEN * SQL SERVER WILL RETURN A SUCCESS/FAILURE MESSAGE FOR EACH OF * THE BATCHED SQL COMMANDS. * * TRANSID IN PCT: CRES PROGRAM NAME IN PPT: CSARESCK *****************************************************************
ENVIRONMENT DIVISION.
DATA DIVISION.
WORKING-STORAGE SECTION.
***************************************************************** * POINTERS. *****************************************************************
01 WS-POINTERS.
05 SPAREA-PTR POINTER.
05 SQLDA-PTR POINTER.
05 SQL-REQ-PTR POINTER.
***************************************************************** * COUNTERS AND VARIOUS INTEGERS. *****************************************************************
01 WS-VARIABLES.
05 CICSRC PIC S9(8) COMP VALUE +0.
05 RESCHECK-CNT PIC 9(3) VALUE ZEROES.
05 SPSTATUS-CNT PIC 9(3) VALUE ZEROES.
***************************************************************** * ATTACHMENT DEFINITION NAME. *****************************************************************
O1 ATTACH-NAME PIC X(08) VALUE 'MDIAWONG'.
***************************************************************** * SWITCH FOR RESCHECK READS - * THE IDEA IS TO KEEP CALLING RESCHECK UNTIL YOU'VE RECEIVED * SPACES IN SPSTATUS TWICE IN A ROW - THEN YOU'RE DONE. *****************************************************************
01 WS-SWITCHES.
03 WS-RESCHECK-DONE-SW PIC X VALUE 'N'.
88 RESCHECK-DONE VALUE 'Y'.
88 RESCHECK-NOT-DONE VALUE 'N'.
88 LAST-SPSTATUS-SPACES VALUE ' '.
***************************************************************** * SQL STATEMENT TO EXECUTE. *****************************************************************
01 MULTI-INSERT-STMT.
03 INSERT-1.
05 FILLER PIC X(30) VALUE
'INSERT INTO TESTABLE VALUES ('.
05 FILLER PIC X(01) VALUE QUOTE.
05 FILLER PIC X(03) VALUE '001'.
05 FILLER PIC X(01) VALUE QUOTE.
05 FILLER PIC X(02) VALUE ', '.
05 FILLER PIC X(01) VALUE QUOTE.
05 FILLER PIC X(16) VALUE
'RECORD NUMBER 01'.
05 FILLER PIC X(01) VALUE QUOTE.
05 FILLER PIC X(02) VALUE ', '.
05 FILLER PIC X(01) VALUE QUOTE.
05 FILLER PIC X(10) VALUE
'FIRST RECD'.
05 FILLER PIC X(01) VALUE QUOTE.
05 FILLER PIC X(04) VALUE ') '.
05 FILLER PIC X(1975) VALUE SPACES.
03 INSERT-2.
05 FILLER PIC X(30) VALUE
'INSERT INTO TESTABLE VALUES ('.
05 FILLER PIC X(01) VALUE QUOTE.
05 FILLER PIC X(03) VALUE '002'.
05 FILLER PIC X(01) VALUE QUOTE.
05 FILLER PIC X(02) VALUE ', '.
05 FILLER PIC X(01) VALUE QUOTE.
05 FILLER PIC X(16) VALUE
'RECORD NUMBER 02'.
05 FILLER PIC X(01) VALUE QUOTE.
05 FILLER PIC X(02) VALUE ', '.
05 FILLER PIC X(01) VALUE QUOTE.
05 FILLER PIC X(10) VALUE
'SECOND REC'.
05 FILLE PIC X(01) VALUE QUOTE.
05 FILLER PIC X(04) VALUE ') ; '.
03 INSERT-3-DUP.
05 FILLER PIC X(30) VALUE
'INSERT INTO TESTABLE VALUES ('.
05 FILLER PIC X(01) VALUE QUOTE.
05 FILLER PIC X(03) VALUE '002'.
05 FILLER PIC X(01) VALUE QUOTE.
05 FILLER PIC X(02) VALUE ', '.
05 FILLER PIC X(01) VALUE QUOTE.
05 FILLER PIC X(16) VALUE
'RECORD NUMBER 03'.
05 FILLER PIC X(01) VALUE QUOTE.
05 FILLER PIC X(02) VALUE ', '.
05 FILLER PIC X(01) VALUE QUOTE.
05 FILLER PIC X(10) VALUE
'THIRD RECD'.
05 FILLER PIC X(01) VALUE QUOTE.
05 FILLER PIC X(04) VALUE ') ; '.
03 INSERT-4.
05 FILLER PIC X(30) VALUE
'INSERT INTO TESTABLE VALUES ('.
05 FILLER PIC X(01) VALUE QUOTE.
05 FILLER PIC X(03) VALUE '004'.
05 FILLER PIC X(01) VALUE QUOTE.
05 FILLER PIC X(02) VALUE ', '.
05 FILLER PIC X(01) VALUE QUOTE.
05 FILLER PIC X(16) VALUE
'RECORD NUMBER 04'.
05 FILLER PIC X(01) VALUE QUOTE.
05 FILLER PIC X(02) VALUE ', '.
05 FILLER PIC X(01) VALUE QUOTE.
05 FILLER PIC X(10) VALUE
'FOURTH REC'.
'05 FILLER PIC X(01) VALUE QUOTE.
'05 FILLER PIC X(04) VALUE ') ; '.
03 INSERT-5-DUP.
05 FILLER PIC X(30) VALUE
'INSERT INTO TESTABLE VALUES ('.
05 FILLER PIC X(01) VALUE QUOTE.
05 FILLER PIC X(03) VALUE '004'.
05 FILLER PIC X(01) VALUE QUOTE.
05 FILLER PIC X(02) VALUE ', '.
05 FILLER PIC X(01) VALUE QUOTE.
05 FILLER PIC X(16) VALUE
'RECORD NUMBER 05'.
05 FILLER PIC X(01) VALUE QUOTE.
05 FILLER PIC X(02) VALUE ', '.
05 FILLER PIC X(01) VALUE QUOTE.
05 FILLER PIC X(10) VALUE
'FIFTH RECD'.
05 FILLER PIC X(01) VALUE QUOTE.
05 FILLER PIC X(04) VALUE ') ; '.
03 INSERT-6.
05 FILLER PIC X(30) VALUE
'INSERT INTO TESTABLE VALUES ('.
05 FILLER PIC X(01) VALUE QUOTE.
05 FILLER PIC X(03) VALUE '006'.
05 FILLER PIC X(01) VALUE QUOTE.
05 FILLER PIC X(02) VALUE ', '.
05 FILLER PIC X(01) VALUE QUOTE.
05 FILLER PIC X(16) VALUE
'RECORD NUMBER 06'.
05 FILLER PIC X(01) VALUE QUOTE.
05 FILLER PIC X(02) VALUE ', '.
05 FILLER PIC X(01) VALUE QUOTE.
05 FILLER PIC X(10) VALUE
'SIXTH RECD'.
05 FILLER PIC X(01) VALUE QUOTE.
05 FILLER PIC X(04) VALUE ') ; '.
03 INSERT-7-DUP.
05 FILLER PIC X(30) VALUE
'INSERT INTO TESTABLE VALUES ('.
05 FILLER PIC X(01) VALUE QUOTE.
05 FILLER PIC X(03) VALUE '006'.
05 FILLER PIC X(01) VALUE QUOTE.
05 FILLER PIC X(02) VALUE ', '.
05 FILLER PIC X(01) VALUE QUOTE.
05 FILLER PIC X(16) VALUE
'RECORD NUMBER 07'.
05 FILLER PIC X(01) VALUE QUOTE.
05 FILLER PIC X(02) VALUE ', '.
05 FILLER PIC X(01) VALUE QUOTE.
05 FILLER PIC X(10) VALUE
'7TH RECD'.
05 FILLER PIC X(01) VALUE QUOTE.
05 FILLER PIC X(04) VALUE ') ; '.
03 INSERT-8.
05 FILLER PIC X(30) VALUE
'INSERT INTO TESTABLE VALUES ('.
05 FILLER PIC X(01) VALUE QUOTE.
05 FILLER PIC X(03) VALUE '008'.
05 FILLER PIC X(01) VALUE QUOTE.
05 FILLER PIC X(02) VALUE ', '.
05 FILLER PIC X(01) VALUE QUOTE.
05 FILLER PIC X(16) VALUE
'RECORD NUMBER 08'.
05 FILLER PIC X(01) VALUE QUOTE.
05 FILLER PIC X(02) VALUE ', '.
05 FILLER PIC X(01) VALUE QUOTE.
05 FILLER PIC X(10) VALUE
'LAST RECD'.
05 FILLER PIC X(01) VALUE QUOTE.
05 FILLER PIC X(04) VALUE ') ; '.
*****************************************************************
* FLAGS.
*****************************************************************
01 WS-INIT-SPAREA-SW PIC X(01) VALUE '0'.
88 INIT-SPAREA-OK VALUE '1'.
88 INIT-SPAREA-BAD VALUE '0'.
01 WS-ATTACH-SW PIC X(01) VALUE '0'.
88 ATTACH-OK VALUE '1'.
88 ATTACH-BAD VALUE '0'.
***************************************************************** * ERROR MESSAGES. *****************************************************************
01 WS-STUB-ERROR-MSG.
03 FILLER PIC X(09)
VALUE 'CALL TO: '
03 WS-STUB-NAME PIC X(08) VALUE SPACES.
03 FILLER PIC X(18)
VALUE ' - RECEIVED SPRC: '
03 WS-STUB-SPRC PIC X(03) VALUE '000'.
03 FILLER PIC X(03) VALUE ' - '.
03 WS-STUB-SPMSG PIC X(100) VALUE SPACES.
01 WS-RESCHECK-LAST-MSG.
03 FILLER PIC X(30)
VALUE '- FINAL RESCHECK READ COUNT : '.
03 WS-RESCHECK-COUNT PIC 9(03) VALUE ZEROES.
01 WS-RESCHECK-MSG.
03 FILLER PIC X(33)
VALUE 'RESCHECK NON-BLANK STATUS - REC: '.
03 WS-RESCHECK-NUMBER PIC 9(03) VALUE ZEROES.
03 FILLER PIC X(16)
VALUE ' - SPSTATUS IS: '.
03 WS-SPSTATUS-OUT PIC X(02) VALUE SPACES.
03 FILLER PIC X(11)
VALUE ' - SPCODE: '.
03 WS-SPCODE-OUT PIC X(03) VALUE SPACES.
03 FILLER PIC X(09)
VALUE ' - SPRC: '.
03 WS-SPRC-OUT PIC X(03) VALUE SPACE.
03 FILLER PIC X(10)
VALUE ' - SPIND: '.
03 WS-SPIND-OUT PIC X(01) VALUE SPACE.
LINKAGE SECTION.
01 STORED-PROC-AREA.
COPY SPAREAC.
*****************************************************************
* SQL REQUEST BUFFER THAT WILL BE PASSED TO THE REMOTE SERVER VIA
* REQEXEC CALL. IT CONSISTS OF A HALFWORD LENGTH FIELD, AND THE
* ACTUAL REQUEST STATEMENT.
*****************************************************************
01 SQL-BUFFER.
03 SQL-LENGTH PIC S9(4) COMP.
03 SQL-REQUEST PIC X(3000).
*==============================================================* PROCEDURE DIVISION. *==============================================================*
0000-MAIN-PROCESSING.
PERFORM 1000-SPAREA-INIT.
IF INIT-SPAREA-OK
PERFORM 2000-ATTACH-TO-SERVER.
PERFORM 5000-EXEC-SQL-REQUEST
PERFORM 6000-RESCHECK-REARCH
UNTIL RESCHECK-DONE
PERFORM 7000-CLOSE-DETACH
PERFORM 9000-FINAL-COUNT
END-IF.
0000-GET-OUT-NOW.
EXEC CICS
RETURN
END-EXEC.
0000-EXIT.
EXIT.
***************************************************************** * GET AN SPAREA, AND CALL CSA TO INITIALIZE IT. *****************************************************************
1000-SPAREA-INIT.
EXEC CICS
DELETEQ TS QUEUE('CSEXQUE2') RESP(CICSRC)
END-EXEC.
EXEC CICS
GETMAIN SET(SPAREA-PTR)
LENGTH(LENGTH OF SPAREA)
NOSUSPEND
RESP(CICSRC)
END-EXEC.
IF CICSRC = DFHRESP(NORMAL)
SET ADDRESS OF STORED-PROC-AREA TO SPAREA-PTR
MOVE 'Y' TO SPTRCOPT
CALL 'CSSETUP' USING SPAREA
IF SPRC = '000'
SET INIT-SPAREA-OK TO TRUE
ELSE
MOVE 'CSSETUP' TO WS-STUB-NAME
PERFORM 6900-STUB-CALL-ERROR THRU 6900-EXIT
GO TO 0000-GET-OUT-NOW
END-IF
END-IF.
1000-EXIT.
EXIT.
***************************************************************** * CALL CSA TO ATTACH TO REMOTE SERVER. *****************************************************************
2000-ATTACH-TO-SERVER.
MOVE ATTACH-NAME TO SPATTACH.
CALL 'ATTACH' USING SPAREA.
IF SPRC = '000'
SET ATTACH-OK TO TRUE
ELSE
MOVE 'ATTACH' TO WS-STUB-NAME
PERFORM 6900-STUB-CALL-ERROR THRU 6900-EXIT
GO TO 0000-GET-OUT-NOW
END-IF.
2000-EXIT.
EXIT.
***************************************************************** * EXECUTE THE SQL REQUEST AGAINST THE REMOTE SERVER. *****************************************************************
5000-EXEC-SQL-REQUEST.
EXEC CICS
GETMAIN SET(SQL-REQ-PTR)
LENGTH(LENGTH OF SQL-BUFFER)
NOSUSPEND RESP(CICSRC)
END-EXEC.
SET ADDRESS OF SQL-BUFFER TO SQL-REQ-PTR.
SET SPSQL TO SQL-REQ-PTR.
IF CICSRC = DFHRESP(NORMAL)
MOVE MULTI-INSERT-STMT TO SQL-REQUEST
MOVE LENGTH OF MULTI-INSERT-STMT TO SQL-LENGTH
CALL 'REQEXEC' USING SPAREA
END-IF.
5000-EXIT.
EXIT.
***************************************************************** * CHECK RESCHECK TO LOCATE SQL STATEMENT IN ERROR. *****************************************************************
6000-RESCHECK-REARCH.
ADD 1 TO RESCHECK-CNT.
IF SPSTATUS NOT = ' '
MOVE 'N' TO WS-RESCHECK-DONE-SW
ADD 1 TO SPSTATUS-CNT
MOVE SPSTATUS-CNT TO WS-RESCHECK-NUMBER
MOVE SPSTATUS TO WS-SPSTATUS-OUT
MOVE SPCODE TO WS-SPCODE-OUT
MOVE SPRC TO WS-SPRC-OUT
MOVE SPIND TO WS-SPIND-OUT
EXEC CICS
WRITEQ TS QUEUE('CSEXQUE2')
FROM(WS-RESCHECK-MSG) NOSUSPEND
RESP(CICSRC)
END-EXEC
IF SPIND NOT = SPACES
PERFORM 6500-GET-MESSAGES UNTIL SPIND NOT = 'M'
END-IF
ELSE
IF LAST-SPSTATUS-SPACES
MOVE 'Y' TO WS-RESCHECK-DONE-SW
ELSE
MOVE ' ' TO WS-RESCHECK-DONE-SW
END-IF
END-IF.
IF NOT RESCHECK-DONE
CALL 'RESCHECK' USING SPAREA.
6000-EXIT.
EXIT.
*****************************************************************
* RETRIEVE ANY OUTSTANDING MESSAGES FOR A REQUEST.
*****************************************************************
6500-GET-MESSAGES.
CALL 'GETMSG' USING SPAREA.
IF SPMSG NOT = SPACES
EXEC CICS
WRITEQ TS QUEUE('CSEXQUE2')
FROM(SPMSG) NOSUSPEND
RESP(CICSRC)
END-EXEC
END-IF.
6500-EXIT.
EXIT.
***************************************************************** * FORMAT AND WRITE STUB-CALL ERROR INFO TO TS QUEUE. *****************************************************************
6900-STUB-CALL-ERROR.
MOVE SPRC TO WS-STUB-SPRC.
MOVE SPMSG TO WS-STUB-SPMSG.
EXEC CICS
WRITEQ TS QUEUE('CSEXQUE2')
FROM(WS-STUB-ERROR-MSG) NOSUSPEND
RESP(CICSRC)
END-EXEC.
6900-EXIT.
EXIT.
***************************************************************** * FORMAT AND WRITE STUB-CALL ERROR INFO TO TS QUEUE. *****************************************************************
7000-CLOSE-DETACH.
CALL 'DETACH' USING SPAREA.
IF SPRC NOT = '000'
MOVE 'DETACH' TO WS-STUB-NAME
PERFORM 6900-STUB-CALL-ERROR THRU 6900-EXIT
GO TO 0000-GET-OUT-NOW
END-IF.
7000-EXIT.
EXIT.
***************************************************************** * SEND THE FINAL RESCHECK READ NUMBER TO TEMP STORAGE QUE *****************************************************************
9000-FINAL-COUNT.
MOVE RESCHECK-CNT TO WS-RESCHECK-COUNT.
EXEC CICS
WRITEQ TS QUEUE('CSEXQUE2')
FROM(WS-RESCHECK-LAST-MSG) NOSUSPEND
RESP(CICSRC)
END-EXEC.
9000-EXIT.
EXIT.
*===============================================================* * END OF PROGRAM. *===============================================================*
