RSP4C is an example of a COBOL II RSP written to handle keyword variables sent to it from the client application.
IDENTIFICATION DIVISION.
PROGRAM-ID. RSP4C.
******************************************************************
* RSP4C - DOCTORED STORED PROCEDURE *
* *
* THIS SAMPLE STORED PROCEDURE WAS WRITTEN TO USE A "STD" *
* OUTPUT PIPE AND KEYWORDS FOR ILLUSTRATION. IT REQUIRES AT *
* LEAST ONE KEYWORD/VALUE BE PASSED TO IT WHEN INVOKED.
*
* *
* USE PROCEDURE RSP4C &FIRSTKEYWORD=FIRSTVALUE ; *
* *
* THIS PROGRAM IS SET UP TO ACCEPT KEYWORDS OF UP TO 15 CHARS *
* IN LENGTH AND UP TO 28 CHARS FOR THE KEYWORD VALUES. ALL *
* KEYWORDS, KEYWORD VALUES, WILL BE RETURNED *
* THROUGH THE OUTPUT PIPE AS VERIFICATION. *
* *
* ALSO: 2 SPECIAL KEYWORDS ARE SET UP TO TEST ERROR MESSAGING *
* THE ERROR CONDITIONS SEND 'E' TO SPSTATUS *
* - ONE USING "MESSAGE" AND ONE USING "STATUS". *
* &ERRORMSG : 'E' TO SPSTATUS, MSG TO SPMSG, CALLS 'MESSAGE' *
* &MESSAGE : 'OK'TO SPSTATUS, MSG TO SPMSG, CALLS 'MESSAGE' *
* &STATUSMSG : 'E' TO SPSTATUS, MSG TO SPCODE, CALLS 'STATUS' *
* &STATNEMSG : 'OK'TO SPSTATUS, MSG TO SPCODE, CALLS 'STATUS' *
* *
******************************************************************
ENVIRONMENT DIVISION.
DATA DIVISION.
WORKING-STORAGE SECTION.
******************************************************************
* POINTERS TO INPUT AND OUTPUT RECORD AREA. *
******************************************************************
01 WS-POINTERS.
10 WS-OUTPUT-POINTER USAGE IS POINTER.
******************************************************************
* SWITCHES FOR RECORD PROCESSING CONTROL. *
******************************************************************
01 WS-SWITCHES.
10 WS-ERROR-MSG-SW PIC X(01) VALUE 'N'.
88 SEND-TEST-ERROR-MSG VALUE 'Y'.
88 NO-MSG-REQUIRED VALUE 'N'.
10 WS-ERROR-STATUS-MSG-SW PIC X(01) VALUE 'N'.
88 SEND-TEST-ERR-STATUS-MSG VALUE 'Y'.
88 NO-STATUS-REQUIRED VALUE 'N'.
10 WS-NOERR-STATUS-MSG-SW PIC X(01) VALUE 'N'.
88 SEND-NOERROR-STATUS-MSG VALUE 'Y'.
88 NO-ERROR-REQUIRED VALUE 'N'.
10 WS-ERROR-HAPPENED-SW PIC X(01) VALUE 'N'.
88 ERROR-HAPPENED VALUE 'Y'.
88 NO-ERROR-YET VALUE 'N'.
******************************************************************
* A NUMBER FOR INCRIMENTING. *
******************************************************************
01 WS-VARIABLES.
05 WS-INCRINUM PIC 99 VALUE ZEROES.
05 WS-DIS-NUM PIC 9(4) VALUE ZEROES.
05 VTABLE-CTR PIC S9(8) COMP VALUE 1.
05 ERROR-CHECK PIC X(15) VALUE
'&ERRORMSG '.
05 STATUS-CHECK PIC X(15) VALUE
'&STATUSMSG '.
05 STATNE-CHECK PIC X(15) VALUE
'&STATNEMSG '.
05 MESSNE-CHECK PIC X(15) VALUE
'&MESSAGE '.
01 MESSAGES.
05 ERROR1-MSG.
07 ERROR1-TEXT1 PIC X(19) VALUE
'ERROR WITH CALL TO '.
07 ERROR1-CALL PIC X(10) VALUE SPACES.|
07 ERROR1-TEXT2 PIC X(14) VALUE
' - SPRC CODE: '.
07 ERROR1-SPRC PIC X(03) VALUE SPACES.
******************************************************************
* OUTPUT RECORD DESCRIPTION. *
******************************************************************
01 WS-OUT-KEYWORD-MSG.
10 FILLER PIC X(55) VALUE
'**--> THE FOLLOWING IS A LIST OF THE KEYWORDS SENT. '.
01 H-TABLE-NAME.
10 H-TABLE-NAME-T OCCURS 15 TIMES.
15 H-T-NAME PIC X.
01 H-TABLE-VALUE.
10 H-TABLE-VALUE-T OCCURS 28 TIMES.
15 H-T-VALUE PIC X.
01 WS-KEYWORD-REC.
10 WS-KEY-MSG-AREA.
15 FILLER PIC X(07) VALUE 'KEYW-> '.
15 WS-KEY-MSG-NUM PIC X(02) VALUE SPACES.
15 FILLER PIC X(01) VALUE ':'.
10 WS-KEYWORD-OUT PIC X(15) VALUE SPACES.
10 FILLER PIC X(02) VALUE '= '.
10 WS-KEY-VALUE-OUT.
15 FILLER PIC X(24) VALUE SPACES.
15 WS-KEY-VAL-LEN PIC X(04) VALUE SPACES.
* THIS SWITCH IS USED FOR TESTING IF RPC CALL
77 RSPRPC-SWITCH PIC S9(4) COMP VALUE 0.
88 RPC-CALL VALUE 0.
01 COMMAREA-POINTER USAGE IS POINTER.
LINKAGE SECTION.
01 DFHCOMMAREA.
05 NOT-USED PIC X(1).
******************************************************************
* THIS IS THE ACTUAL SPAREA POINTER AND DEFINITION *
******************************************************************
01 LWKCOMMAREA.
COPY SPAREAC.
**************************************************************
* THIS IS THE MASK FOR THE KEYWORD VARIABLE TABLE THAT THE
* MAINFRAMECONNECT WILL CREATE FOR YOUR RSP TO PROCESS.
**************************************************************
01 KEYWORD-VTABLE.
10 VTABLE-SIZE PIC S9(8) COMP.
10 VTABLE-ENTRY OCCURS 0 TO 50 TIMES
DEPENDING ON VTABLE-SIZE
INDEXED BY VTABLE-INDEX.
15 VTABLE-NAME USAGE IS POINTER.
15 VTABLE-VALUE USAGE IS POINTER.
15 VTABLE-NAME-LENGTH PIC S9(4) COMP.
15 VTABLE-VALUE-LENGTH PIC S9(4) COMP.
**************************************************************
* THESE ARE THE DATA VARIABLES THAT THE KEYWORDS AND THE
* KEYWORD VALUES WILL BE PLACED INTO FOR ACCESS BY THE RSP.
* IN THIS CASE THE LENGTHS WERE SET TO 15 FOR KEYWORDS AND
* 28 FOR THE KEYWORD VALUE FOR TESTING PURPOSES.
**************************************************************
01 TABLE-NAME PIC X(15).
01 TABLE-VALUE PIC X(28).
01 LS-OUTPUT-REC.
10 LS-OUTPUT-DATA PIC X(55).
*============================================================*
PROCEDURE DIVISION.
*============================================================*
000-MAIN-PROCESSING.
PERFORM 100-INITIALIZE THRU 100-EXIT.
IF NO-ERROR-YET
PERFORM 500-PROCESS-I-O THRU 500-EXIT.
PERFORM 900-WRAP-UP THRU 900-EXIT.
EXEC CICS
RETURN
END-EXEC.
GOBACK.
000-EXIT.
EXIT.
100-INITIALIZE.
******************************************************
* IF THIS IS A RPC CALL, CALL RPSETUP TO INITIALIZE SPAREA
* AND OPEN SERVER (TRANSACTION ROUTER SERVICE)
* IF THIS IS A RSP CALL, SPAREA IS PASSED IN THE COMMAREA.
* (DIRECTCONNECT).
* FOR TRACING, MOVE 'Y' TO SPTRCOPT
******************************************************
MOVE EIBCALEN TO RSPRPC-SWITCH.
IF RPC-CALL
EXEC CICS GETMAIN
SET (COMMAREA-POINTER)
FLENGTH (LENGTH OF LWKCOMMAREA)
END-EXEC
SET ADDRESS OF LWKCOMMAREA TO COMMAREA-POINTER
CALL 'RPSETUP' USING SPAREA
ELSE
SET ADDRESS OF LWKCOMMAREA TO ADDRESS OF DFHCOMMAREA.
******************************************************
MOVE 'OK' TO SPSTATUS.
******************************************************************
* ALLOCATE A BLOCK OF STORAGE TO BE USED FOR THE DATA
* SET POINTER VARIABLE TO ADDRESS OF ALLOCATED STORAGE
******************************************************************
EXEC CICS
GETMAIN SET(WS-OUTPUT-POINTER)
LENGTH(55)
END-EXEC.
SET ADDRESS OF LS-OUTPUT-REC TO WS-OUTPUT-POINTER.
PERFORM 120-OPEN-OUTPUT-PIPE THRU 120-EXIT.
100-EXIT.
EXIT.
120-OPEN-OUTPUT-PIPE.
******************************************************************
* OPEN THE OUTPUT PIPE. *
******************************************************************
MOVE 'STD' TO SPFORMAT.
MOVE 55 TO SPMAXLEN.
MOVE 'OUTPUT' TO SPMODE.
*-------------------------------------------------------*
* AN OPEN PIPE WILL SET UP THE COLUMN INFORMATION, WHICH*
* WILL EVENTUALLY BE SENT TO THE CLIENT....... *
*-------------------------------------------------------*
CALL 'OPENPIPE' USING SPAREA.
******************************************************************
* IF OPEN FAILED, THEN ISSUE AN ERROR MESSAGE. *
******************************************************************
IF SPRC NOT = '000'
SET ERROR-HAPPENED TO TRUE
MOVE 'OPENPIPE' TO ERROR1-CALL
PERFORM 800-ERROR-MESSAGE THRU 800-EXIT.
120-EXIT.
EXIT.
500-PROCESS-I-O.
PERFORM 510-KEYWORD-INPUT-CHECK THRU 510-EXIT.|
IF NO-ERROR-YET
PERFORM 520-PROCESS-KEYWORDS THRU 520-EXIT.
500-EXIT.
EXIT.
510-KEYWORD-INPUT-CHECK.
******************************************************************
* MAKE SURE AT LEAST ONE KEYWORD WAS SENT ALONG WITH PROGRAM *
******************************************************************
MOVE 0 TO WS-INCRINUM.
IF SPVARTAB = NULL
PERFORM 700-LOAD-KEYWORD-ERROR THRU 700-EXIT
GO TO 510-EXIT.
IF VTABLE-SIZE NOT > 0
PERFORM 700-LOAD-KEYWORD-ERROR THRU 700-EXIT
GO TO 510-EXIT.
SET ADDRESS OF KEYWORD-VTABLE TO SPVARTAB.
510-EXIT.
EXIT.
520-PROCESS-KEYWORDS.
PERFORM 522-SEND-KEYWORD-HEADING THRU 522-EXIT.
IF NO-ERROR-YET
PERFORM 524-READ-WRITE-KEYWORDS THRU 524-EXIT.
IF NO-ERROR-YET
PERFORM 548-TEST-FOR-ERR-KEY THRU 548-EXIT.
520-EXIT.
EXIT.
522-SEND-KEYWORD-HEADING.
MOVE WS-OUT-KEYWORD-MSG TO LS-OUTPUT-REC.
MOVE 55 TO SPRECLEN.
SET SPFROM TO ADDRESS OF LS-OUTPUT-REC.
*-------------------------------------------------------*
* PUTPIPE SENDS A RESULT ROW TO THE OUTPUT BUFFER, WHICH*
* WILL EVENTUALLY BE SENT DOWN TO THE CLIENT APPLICATION.*
*-------------------------------------------------------*
CALL 'PUTPIPE' USING SPAREA.
IF SPRC NOT = '000'
SET ERROR-HAPPENED TO TRUE
MOVE 'PUTPIPE ' TO ERROR1-CALL
PERFORM 800-ERROR-MESSAGE THRU 800-EXIT.
522-EXIT.
EXIT.
524-READ-WRITE-KEYWORDS.
******************************************************************
* OBTAIN THE KEYWORD VARIABLES AND DISPLAY THEM DOWN OUTPUT PIPE *
* THE KEYWORD VALUE LENGTH (VTABLE-VALUE-LENGTH(VTABLE-INDEX)) *
* PASSED FROM MAINFRAMECONNECT WILL BE PLACED AT THE LAST FOUR *
* BYTES OF THE KEYWORD VALUE DISPLAY. THIS WILL DEMONSTATE THE *
* WAY MAINFRAMECONNECT DETERMINES THE LENGTH OF THE KEYWORD *
* VALUE MAY NOT MATCH EXACTLY WHAT WAS SENT BECAUSE THE COUNTING *
* STOPS AT THE FIRST SPACE IF THE DATA IS NOT DELIMITED. *
* NOTE THAT THIS DOES NOT MEAN ONLY PART OF THE KEYWORD VALUE *
* DATA WAS SENT - IT ONLY MEANS THE COUNTING STOPS AT THE SPACE *
******************************************************************
PERFORM WITH TEST AFTER
VARYING VTABLE-INDEX FROM 1 BY 1
UNTIL VTABLE-SIZE = VTABLE-INDEX
SET ADDRESS OF TABLE-NAME TO VTABLE-NAME(VTABLE-INDEX)
MOVE TABLE-NAME TO H-TABLE-NAME
MOVE VTABLE-NAME-LENGTH(VTABLE-INDEX)
TO VTABLE-CTR
ADD 1 TO VTABLE-CTR
PERFORM UNTIL VTABLE-CTR > 16
MOVE SPACE TO H-T-NAME (VTABLE-CTR)
ADD 1 TO VTABLE-CTR
END-PERFORM
MOVE H-TABLE-NAME TO WS-KEYWORD-OUT
IF WS-KEYWORD-OUT = ERROR-CHECK
MOVE 'Y' TO WS-ERROR-MSG-SW
END-IF
IF WS-KEYWORD-OUT = STATUS-CHECK
MOVE 'Y' TO WS-ERROR-STATUS-MSG-SW
END-IF
IF WS-KEYWORD-OUT = STATNE-CHECK
MOVE 'Y' TO WS-NOERR-STATUS-MSG-SW
END-IF
IF WS-KEYWORD-OUT = MESSNE-CHECK
MOVE 'THIS IS YOUR NON ERROR MESSAGE TEXT.'
TO SPMSG
MOVE '14' TO SPCODE
CALL 'MESSAGE' USING SPAREA
END-IF
SET ADDRESS OF TABLE-VALUE
TO VTABLE-VALUE(VTABLE-INDEX)
MOVE TABLE-VALUE TO H-TABLE-VALUE
MOVE VTABLE-VALUE-LENGTH(VTABLE-INDEX)
TO VTABLE-CTR, WS-DIS-NUM
ADD 1 TO VTABLE-CTR
PERFORM UNTIL VTABLE-CTR > 29
MOVE SPACE TO H-T-VALUE (VTABLE-CTR)
ADD 1 TO VTABLE-CTR
END-PERFORM
MOVE H-TABLE-VALUE TO WS-KEY-VALUE-OUT
MOVE WS-DIS-NUM TO WS-KEY-VAL-LEN
ADD 1 TO WS-INCRINUM
MOVE WS-INCRINUM TO WS-KEY-MSG-NUM
MOVE WS-KEYWORD-REC TO LS-OUTPUT-REC
SET SPFROM TO ADDRESS OF LS-OUTPUT-REC
MOVE 55 TO SPRECLEN
CALL 'PUTPIPE' USING SPAREA
IF SPRC NOT = '000'
SET ERROR-HAPPENED TO TRUE
MOVE 'PUTPIPE ' TO ERROR1-CALL
PERFORM 800-ERROR-MESSAGE THRU 800-EXIT
END-IF
END-PERFORM.
524-EXIT.
EXIT.
548-TEST-FOR-ERR-KEY.
******************************************************************
* TEST FOR ERROR MESSAGE REQUESTED - SEND ONE IF SO. *
******************************************************************
IF SEND-TEST-ERROR-MSG
MOVE 'N' TO WS-ERROR-MSG-SW
MOVE 'THIS IS YOUR ERROR MESSAGE TEXT.'
TO SPMSG
MOVE 'ERR54321' TO SPCODE
*-------------------------------------------------------*
* MESSAGE WILL WRITE THE 100 BYTE SPMSG TO A MSG BUFFER,*
* WHICH WILL EVENTUALLY BE WRITTEN TO THE CLIENT *
* APPLICATION. *
*-------------------------------------------------------*
CALL 'MESSAGE' USING SPAREA.
IF SPRC NOT = '000'
SET ERROR-HAPPENED TO TRUE.
548-EXIT.
EXIT.
700-LOAD-KEYWORD-ERROR.
******************************************************************
* IF AT LEAST ONE KEYWORD IS NOT SUPPLIED - SEND MSG AND STOP. *
******************************************************************
SET ERROR-HAPPENED TO TRUE.
MOVE '* ERROR - NO KEYWORDS SENT' TO SPMSG.
MOVE 'E' TO SPSTATUS.
*-------------------------------------------------------*
* MESSAGE WILL WRITE THE 100 BYTE SPMSG TO A MSG BUFFER,*
* WHICH WILL EVENTUALLY BE WRITTEN TO THE CLIENT *
* APPLICATION *
*-------------------------------------------------------*
CALL 'MESSAGE' USING SPAREA.
IF SPRC NOT = '000'
SET ERROR-HAPPENED TO TRUE.
700-EXIT.
EXIT.
800-ERROR-MESSAGE.
******************************************************************
* SOMETHING FAILED, SO ISSUE AN ERROR MESSAGE AND GET OUT. *
******************************************************************
MOVE SPRC TO ERROR1-SPRC.
MOVE ERROR1-MSG TO SPMSG.
MOVE 'E' TO SPSTATUS.
*-------------------------------------------------------*
* MESSAGE WILL WRITE THE 100 BYTE SPMSG TO A MSG BUFFER,*
* WHICH WILL EVENTUALLY BE WRITTEN TO THE CLIENT *
* APPLICATION *
*-------------------------------------------------------*
CALL 'MESSAGE' USING SPAREA.
IF SPRC NOT = '000'
SET ERROR-HAPPENED TO TRUE.
800-EXIT.
EXIT.
900-WRAP-UP.
******************************************************************
* CLOSE PIPES - ISSUE STATUS. ******************************************************************
IF NO-ERROR-YET
MOVE 'OUTPUT' TO SPMODE
*-------------------------------------------------------*
*CLOSEPIPE IS LIKE CLOSING A FILE, PLACES AN EOF MARKER*
*-------------------------------------------------------*
CALL 'CLOSPIPE' USING SPAREA
IF SPRC NOT = '000'
SET ERROR-HAPPENED TO TRUE
MOVE 'CLOSPIPE' TO ERROR1-CALL
PERFORM 800-ERROR-MESSAGE THRU 800-EXIT.
IF SEND-TEST-ERR-STATUS-MSG
OR ERROR-HAPPENED
MOVE 'N' TO WS-ERROR-MSG-SW
MOVE 'THIS IS YOUR STATUS MESSAGE TEXT.'
TO SPMSG
MOVE '-321' TO SPCODE
MOVE 'E' TO SPSTATUS
ELSE
IF SEND-NOERROR-STATUS-MSG
MOVE 'N' TO WS-ERROR-MSG-SW
MOVE 'THIS IS YOUR STATUS NOERROR TEXT.'
TO SPMSG
MOVE '12' TO SPCODE
MOVE 'OK' TO SPSTATUS
ELSE
MOVE 'OK' TO SPSTATUS
END-IF.
*-----------------------------------------------------------*
* CALLING STATUS WILL FLUSH ANY RESULTS AND/OR *
* MESSAGES FROM THE BUFFERS, TO THE CLIENT APPLICATION *
*-----------------------------------------------------------*
CALL 'STATUS' USING SPAREA.
IF SPRC NOT = '000'
SET ERROR-HAPPENED TO TRUE
MOVE 'STATUS ' TO ERROR1-CALL
PERFORM 800-ERROR-MESSAGE THRU 800-EXIT
END-IF.
********************************************************
* CLOSE OPEN SERVER
* IF THIS IS AN RPC CALL, PERFORM OPEN SERVER CLOSE
********************************************************
IF RPC-CALL
CALL 'RPDONE' USING SPAREA.
900-EXIT.
EXIT.
