The following program receives one of two keywords, @ERRORMSG or @WARNMSG and other keywords, and then replies with the keywords and data.
This application replaces the sample remote stored procedure
RSP4C for MDI-heritage customers. For information about RSP4C, see
the Mainframe Connect Server Option Programmer’s Reference for Remote Stored Procedures.
IDENTIFICATION DIVISION.
PROGRAM-ID. SYCCSAY2.
DATE-WRITTEN. 12/17/96.
DATE-COMPILED.
******************************************************************
**
** (c) 1995 by Sybase, Inc. All Rights Reserved
******************************************************************
******************************************************************
** PROGRAM: SYCCSAY2
**
** THIS PROGRAM IS A THE OPEN SERVER VERSION OF RSP4C.
** It will receive one of 2 Keywords @ERRORMSG or @WARNMSG and
** Other Keywords. Will reply with the keywords and data.
** If @ERRORMSG AND/OR @WARNMSG are 'Y' that type of message
** will be returned...
** exec syy2 @WARNMSG=Y,@ERRORMSG=Y.........
******************************************************************
ENVIRONMENT DIVISION.
DATA DIVISION.
WORKING-STORAGE SECTION.
******************************************************************
* COPY IN THE OS SERVER LIBRARYS
******************************************************************
COPY SYGWCOB.
******************************************************************
*OPEN SERVER WORK VARIBLES FOR OS CALL TO USE ...
******************************************************************
01 WS-GWL-WORK-VARIBLES.
05 GWL-PROC POINTER.
05 GWL-INIT-HANDLE POINTER.
05 GWL-RC PIC S9(9) COMP.
05 GWL-INFPRM-ID PIC S9(9) COMP.
05 GWL-INFPRM-TYPE PIC S9(9) COMP.
05 GWL-INFPRM-DATA-L PIC S9(9) COMP.
05 GWL-INFPRM-MAX-DATA-L PIC S9(9) COMP.
05 GWL-INFPRM-STATUS PIC S9(9) COMP.
05 GWL-INFPRM-NAME PIC X(30).
05 GWL-INFPRM-NAME-L PIC S9(9) COMP.
05 GWL-INFPRM-USER-DATA PIC S9(9) COMP.
05 GWL-INFUDT-USER-TYPE PIC S9(9) COMP.
05 GWL-STATUS-NR PIC S9(9) COMP.
05 GWL-STATUS-DONE PIC S9(9) COMP.
05 GWL-STATUS-COUNT PIC S9(9) COMP.
05 GWL-STATUS-COMM PIC S9(9) COMP.
05 GWL-COMM-STATE PIC S9(9) COMP.
05 GWL-STATUS-RETURN-CODE PIC S9(9) COMP.
05 GWL-STATUS-SUBCODE PIC S9(9) COMP.
05 GWL-NUMPRM-PARMS PIC S9(9) COMP.
05 GWL-RCVPRM-DATA-L PIC S9(9) COMP.
05 GWL-SETPRM-ID PIC S9(9) COMP.
05 GWL-SETPRM-TYPE PIC S9(9) COMP.
05 GWL-SETPRM-DATA-L PIC S9(9) COMP.
05 GWL-SETPRM-USER-DATA PIC S9(9) COMP.
05 GWL-CONVRT-SCALE PIC S9(9) COMP VALUE 2.
05 GWL-SETBCD-SCALE PIC S9(9) COMP VALUE 0.
05 GWL-INFBCD-LENGTH PIC S9(9) COMP.
05 GWL-INFBCD-SCALE PIC S9(9) COMP.
05 GWL-RETURN-ROWS PIC S9(9) COMP VALUE +0.
05 SNA-CONN-NAME PIC X(8) VALUE SPACES.
05 SNA-SUBC PIC S9(9) COMP.
05 WRK-DONE-STATUS PIC S9(9) COMP.
05 GWL-ACTUAL-LEN PIC S9(9) COMP.
05 GWL-TRAN-LEN PIC S9(9) COMP.
05 GWL-MSG-LEN PIC S9(9) COMP.
05 WS-NUMPRM-PARMS PIC S9(9) COMP.
05 GWL-REQUEST-TYP PIC S9(9) COMP.
05 GWL-RPC-NAME PIC X(30) VALUE SPACES.
05 GWL-COMM-STATE PIC S9(9) COMP.
05 I PIC S9(9) COMP.
05 WS-ERROR-MSG PIC S9(9) COMP VALUE ZERO.
05 WS-ERROR-SEV PIC S9(9) COMP VALUE ZERO.
01 DESCRIPTION-FIELDS.
05 COLUMN-NUMBER PIC S9(09) COMP VALUE +0.
05 HOST-TYPE PIC S9(09) COMP VALUE +0.
05 HOST-LEN PIC S9(09) COMP VALUE +0.
05 COLUMN-LEN PIC S9(09) COMP VALUE +0.
05 COLUMN-NAME-LEN PIC S9(09) COMP VALUE +0.
05 WS-ZERO PIC S9(09) COMP VALUE +0.
01 WS-MSG-WORK-VARS.
05 MSG-NR PIC S9(9) COMP VALUE +9999.
01 WS-INPUT-LEN PIC S9(9) COMP VALUE +55.
01 WS-INPUT-DATA PIC X(55) VALUE SPACES.
01 WS-LENGTH PIC S9(9) COMP VALUE ZERO.
01 WS-WARNMSG PIC X(8) VALUE '@WARNMSG'.
01 WS-WARNMSG-ID PIC S9(9) COMP VALUE ZERO.
01 WS-WARNMSG-88 PIC X(1) VALUE 'N'.
88 WARNING-MSG VALUE 'Y'.
01 WS-ERRORMSG PIC X(9) VALUE '@ERRORMSG'.
01 WS-ERRORMSG-ID PIC S9(9) COMP VALUE ZERO.
01 WS-ERRORMSG-88 PIC X(1) VALUE 'N'.
88 ERROR-MSG VALUE 'Y'.
01 WS-OUTPUT-DATA PIC X(55) VALUE SPACES.
01 WS-OUTPUT-COL-NAME PIC X(13)
VALUE 'OUTPUT_COLUMN'.
01 WS-QUEUE-NAME.
05 WS-TRANID PIC X(4) VALUE 'SYY2'.
05 WS-TRMID PIC X(4) VALUE SPACES.
01 CICSRC PIC S9(8) COMP.
01 CICSRC-DIS PIC S9(8).
******************************************************************
* MESSAGES *
******************************************************************
01 WS-MSG.
05 FILLER PIC X(17)
VALUE 'ERROR IN OS CALL '.
05 WS-MSG-FUNC PIC X(10).
05 FILLER PIC X(04)
VALUE 'RC='.
05 WS-MSG-RC PIC S9(9).
05 FILLER PIC X(18)
VALUE ' SUBCODE ERROR = '.
05 MSG-SUBC PIC 9(9) VALUE 0.
05 WS-MSG-TEXT PIC X(50) VALUE SPACES.
01 WS-HOLD-MSG PIC X(107) VALUE SPACES.
01 WS-WARN-MSG PIC X(107) VALUE
'THIS IS A WARNING MESSAGE........'.
01 WS-ERR-MSG PIC X(107) VALUE
'THIS IS A ERROR MESSAGE........'.
01 WORK-SRVIN-INFO.
05 WK-INFO-TBL-ID PIC S9(8) COMP.
05 WK-INFO-TBL-NAME PIC X(30).
05 WK-INFO-TBL-VALUE PIC X(10).
LINKAGE SECTION.
**************************************************************
* THE LINKAGE SECTION DEFINES MASKS FOR DATA AREAS THAT ARE
* PASSED BETWEEN THIS PROGRAM.
**************************************************************
01 DFHCOMMAREA PIC X(1).
PROCEDURE DIVISION.
000-MAIN-PROCESSING.
PERFORM 100-INITIALIZE THRU 100-EXIT.
PERFORM 200-PROCESS-INPUT THRU 200-EXIT.
PERFORM 300-PROCESS-OUTPUT THRU 300-EXIT.
PERFORM 900-ALL-DONE THRU 900-EXIT.
GOBACK.
000-EXIT.
EXIT.
100-INITIALIZE.
******************************************************
* INTIALIZED THE TDS CONNECTION AND CONFIRM THAT IT
* WAS AN RPC CALL, ........
******************************************************
*==> INITIAL QUEUE NAME <===*
MOVE EIBTRMID TO WS-TRMID.
*==> ESTABLISH GATEWAY ENVIRONMENT <===*
CALL 'TDINIT' USING DFHEIBLK, GWL-RC, GWL-INIT-HANDLE.
IF GWL-RC NOT = TDS-OK THEN
PERFORM 910-ERR-PROCESS THRU 910-EXIT
END-IF.
*==> ACCEPT CLIENT REQUEST <===*
CALL 'TDACCEPT' USING GWL-PROC, GWL-RC, GWL-INIT-HANDLE,
SNA-CONN-NAME, SNA-SUBC.
IF GWL-RC NOT = TDS-OK THEN
PERFORM 910-ERR-PROCESS THRU 910-EXIT
END-IF.
*==> TO MAKE SURE WE WERE STARTED BY RPC REQUEST... <===*
CALL 'TDINFRPC' USING GWL-PROC, GWL-RC,
GWL-REQUEST-TYP, GWL-RPC-NAME,
GWL-COMM-STATE.
IF GWL-RC NOT = TDS-OK OR
GWL-REQUEST-TYP NOT = TDS-RPC-EVENT
THEN
MOVE GWL-RC TO WS-MSG-RC
MOVE 'TDINFRPC' TO WS-MSG-FUNC
PERFORM 920-SEND-MESSAGE THRU 920-EXIT
PERFORM 910-ERR-PROCESS THRU 910-EXIT
END-IF.
100-EXIT.
EXIT.
200-PROCESS-INPUT.
****************************************************************
* RECEIVE THE INPUT PARAMETER INTO HOST VARIBLE, SEND ROW DATA *
* BACK DOWN TO CLIENT *
****************************************************************
*---> Find out how many parms are being passed <---*
CALL 'TDNUMPRM' USING GWL-PROC, GWL-NUMPRM-PARMS.
*---> NO PARMS, pump back a message <---*
IF GWL-NUMPRM-PARMS < +1 THEN
MOVE 'At least one parm is needed'
TO WS-MSG-TEXT
MOVE GWL-RC TO WS-MSG-RC
MOVE 'TDNUMPRM' TO WS-MSG-FUNC
MOVE WS-MSG TO WS-HOLD-MSG
MOVE TDS-ERROR-MSG TO WS-ERROR-MSG
MOVE TDS-ERROR-SEV TO WS-ERROR-SEV
PERFORM 920-SEND-MESSAGE THRU 920-EXIT
PERFORM 910-ERR-PROCESS THRU 910-EXIT
END-IF.
*---> TEST TO SEE IF THE KEYWORDS "WARNMSG" AND <---*
*---> OR ERRORMSG WHERE SENT.... <---*
MOVE LENGTH OF WS-WARNMSG TO WS-LENGTH.
CALL 'TDLOCPRM' USING GWL-PROC, WS-WARNMSG-ID,
WS-WARNMSG, WS-LENGTH.
MOVE LENGTH OF WS-ERRORMSG TO WS-LENGTH.
CALL 'TDLOCPRM' USING GWL-PROC, WS-ERRORMSG-ID,
WS-ERRORMSG, WS-LENGTH.
*---> SAVE THE NUMBER OF PARMS FOR THE LOOP <---*
MOVE GWL-NUMPRM-PARMS TO WS-NUMPRM-PARMS.
*---> LOOP THRU THE PARMS AND WRITE TO TEMP STORAGE <----*
PERFORM VARYING GWL-NUMPRM-PARMS FROM 1 BY 1
UNTIL GWL-NUMPRM-PARMS > WS-NUMPRM-PARMS
PERFORM 210-GET-PARM THRU 210-EXIT
PERFORM 220-WRITE-TS THRU 220-EXIT
END-PERFORM.
200-EXIT.
EXIT.
210-GET-PARM.
****************************************************************
* *---> Get that parm info into the host varible <---* *
****************************************************************
CALL 'TDRCVPRM' USING GWL-PROC, GWL-RC,
GWL-NUMPRM-PARMS,
WS-INPUT-DATA,
TDSCHAR,
WS-INPUT-LEN,
GWL-ACTUAL-LEN
IF GWL-RC NOT = TDS-OK THEN
MOVE GWL-RC TO WS-MSG-RC
MOVE 'TDRCVPRM' TO WS-MSG-FUNC
MOVE WS-MSG TO WS-HOLD-MSG
MOVE TDS-ERROR-MSG TO WS-ERROR-MSG
MOVE TDS-ERROR-SEV TO WS-ERROR-SEV
PERFORM 920-SEND-MESSAGE THRU 920-EXIT
PERFORM 910-ERR-PROCESS THRU 910-EXIT
END-IF.
210-EXIT.
EXIT.
220-WRITE-TS.
****************************************************************
* *---> WRITE PARMS TO TEMP STORAGE, LATER RETURN PARMS <---* *
* *---> BACK DOWN TO CLIENT AS OUTPUT <---* *
****************************************************************
EXEC CICS
WRITEQ TS QUEUE(WS-QUEUE-NAME)
FROM (WS-INPUT-DATA)
LENGTH(LENGTH OF WS-INPUT-DATA)
RESP (CICSRC)
END-EXEC.
IF CICSRC NOT = DFHRESP(NORMAL)
MOVE CICSRC TO CICSRC-DIS
MOVE CICSRC-DIS TO WS-MSG-RC
MOVE 'WRITEQ' TO WS-MSG-FUNC
MOVE WS-MSG TO WS-HOLD-MSG
MOVE TDS-ERROR-MSG TO WS-ERROR-MSG
MOVE TDS-ERROR-SEV TO WS-ERROR-SEV
PERFORM 920-SEND-MESSAGE THRU 920-EXIT
PERFORM 910-ERR-PROCESS THRU 910-EXIT
END-IF.
220-EXIT.
EXIT.
300-PROCESS-OUTPUT.
****************************************************************
* READ TEMP STORAGE QUEUE AND SEND ROWS TO CLIENT *
****************************************************************
PERFORM 310-DEFINE-OUTPUT THRU 310-EXIT.
PERFORM VARYING I FROM 1 BY 1 UNTIL I > WS-NUMPRM-PARMS
PERFORM 320-READQ-TS THRU 320-EXIT
PERFORM 330-SEND-ROW THRU 330-EXIT
END-PERFORM.
*---> PROCESS WARNMSG AND/OR ERRORMSG AFTER SENDING ROWS. <---*
IF WARNING-MSG
THEN
MOVE TDS-INFO-MSG TO WS-ERROR-MSG
MOVE TDS-INFO-SEV TO WS-ERROR-SEV
MOVE WS-WARN-MSG TO WS-HOLD-MSG
PERFORM 920-SEND-MESSAGE THRU 920-EXIT
END-IF.
IF ERROR-MSG
THEN
MOVE TDS-ERROR-MSG TO WS-ERROR-MSG
MOVE TDS-ERROR-SEV TO WS-ERROR-SEV
MOVE WS-ERR-MSG TO WS-HOLD-MSG
PERFORM 920-SEND-MESSAGE THRU 920-EXIT
END-IF.
300-EXIT.
EXIT.
310-DEFINE-OUTPUT.
****************************************************************
* DEFINE THE OUTPUT COLUM AS CHAR OF 55 BYTES *
****************************************************************
MOVE +1 TO COLUMN-NUMBER.
MOVE LENGTH OF WS-OUTPUT-DATA TO HOST-LEN
COLUMN-LEN.
MOVE LENGTH OF WS-OUTPUT-COL-NAME TO COLUMN-NAME-LEN.
CALL 'TDESCRIB' USING GWL-PROC,
GWL-RC,
COLUMN-NUMBER,
TDSCHAR,
HOST-LEN,
WS-OUTPUT-DATA,
TDS-ZERO,
TDS-FALSE,
TDSCHAR,
COLUMN-LEN,
WS-OUTPUT-COL-NAME,
COLUMN-NAME-LEN.
IF GWL-RC NOT = TDS-OK THEN
MOVE GWL-RC TO WS-MSG-RC
MOVE 'TDESCRIB' TO WS-MSG-FUNC
MOVE WS-MSG TO WS-HOLD-MSG
MOVE TDS-ERROR-MSG TO WS-ERROR-MSG
MOVE TDS-ERROR-SEV TO WS-ERROR-SEV
PERFORM 920-SEND-MESSAGE THRU 920-EXIT
PERFORM 910-ERR-PROCESS THRU 910-EXIT
END-IF.
310-EXIT.
EXIT.
320-READQ-TS.
****************************************************************
* READ THE INPUT TEMP STORAGE QUEUE
****************************************************************
EXEC CICS
READQ TS QUEUE(WS-QUEUE-NAME)
INTO (WS-OUTPUT-DATA)
LENGTH(LENGTH OF WS-OUTPUT-DATA)
NEXT
RESP (CICSRC)
END-EXEC.
IF CICSRC NOT = DFHRESP(NORMAL)
MOVE CICSRC TO CICSRC-DIS
MOVE CICSRC-DIS TO WS-MSG-RC
MOVE 'READQ' TO WS-MSG-FUNC
MOVE WS-MSG TO WS-HOLD-MSG
MOVE TDS-ERROR-MSG TO WS-ERROR-MSG
PERFORM 920-SEND-MESSAGE THRU 920-EXIT
PERFORM 910-ERR-PROCESS THRU 910-EXIT
END-IF.
*---> PROCESS WARNMSG AND/OR ERRORMSG PARMS IF YES... <---*
IF WS-WARNMSG-ID = I AND WS-OUTPUT-DATA = 'Y'
MOVE 'Y' TO WS-WARNMSG-88.
IF WS-ERRORMSG-ID = I AND WS-OUTPUT-DATA = 'Y'
MOVE 'Y' TO WS-ERRORMSG-88.
320-EXIT.
EXIT.
330-SEND-ROW.
****************************************************************
* SEND ROW OF DATA TO CLIENT....
*****************************************************************
CALL 'TDSNDROW' USING GWL-PROC, GWL-RC
IF GWL-RC NOT = TDS-OK
THEN
MOVE GWL-RC TO WS-MSG-RC
MOVE 'TDSNDROW' TO WS-MSG-FUNC
MOVE WS-MSG TO WS-HOLD-MSG
MOVE TDS-ERROR-MSG TO WS-ERROR-MSG
MOVE TDS-ERROR-SEV TO WS-ERROR-SEV
PERFORM 920-SEND-MESSAGE THRU 920-EXIT
PERFORM 910-ERR-PROCESS THRU 910-EXIT
END-IF.
330-EXIT.
EXIT.
EJECT
900-ALL-DONE.
******************************************************************
* CLOSE CONNECTION TO CLIENT AND RETURN TO CICS... *
******************************************************************
CALL 'TDSNDDON' USING GWL-PROC, GWL-RC, WRK-DONE-STATUS,
GWL-RETURN-ROWS, TDS-ZERO, TDS-ENDRPC.
IF GWL-RC NOT = TDS-OK THEN
PERFORM 980-CICS-DUMP THRU 980-EXIT
PERFORM 990-CICS-RETURN THRU 990-EXIT
END-IF.
CALL 'TDFREE' USING GWL-PROC, GWL-RC.
EXEC CICS
DELETEQ TS QUEUE(WS-QUEUE-NAME)
RESP (CICSRC)
END-EXEC.
IF CICSRC NOT = DFHRESP(NORMAL)
MOVE CICSRC TO CICSRC-DIS
MOVE CICSRC-DIS TO WS-MSG-RC
MOVE 'DELETEQ' TO WS-MSG-FUNC
MOVE WS-MSG TO WS-HOLD-MSG
MOVE TDS-ERROR-MSG TO WS-ERROR-MSG
MOVE TDS-ERROR-SEV TO WS-ERROR-SEV
PERFORM 920-SEND-MESSAGE THRU 920-EXIT
PERFORM 910-ERR-PROCESS THRU 910-EXIT
END-IF.
PERFORM 990-CICS-RETURN THRU 990-EXIT.
900-EXIT.
EXIT.
910-ERR-PROCESS.
******************************************************************
* PERFORM ALL-DONE IN A ERROR STATE *
******************************************************************
MOVE ZERO TO GWL-RETURN-ROWS.
MOVE TDS-DONE-ERROR TO WRK-DONE-STATUS.
PERFORM 900-ALL-DONE THRU 900-EXIT.
910-EXIT.
EXIT.
920-SEND-MESSAGE.
*-----------------------------------------------------------------
SEND-ERROR-MESSAGE.
*-----------------------------------------------------------------
MOVE 'N' TO SEND-DONE-SW.
MOVE TDS-ERROR-MSG TO MSG-TYPE.
MOVE LENGTH OF MSG-RPC TO MSG-RPC-L.
* Ensure we're in right state to send a message
CALL 'TDSTATUS' USING GWL-PROC, GWL-RC,
GWL-STATUS-NR,
GWL-STATUS-DONE,
GWL-STATUS-COUNT,
GWL-STATUS-COMM,
GWL-STATUS-RETURN-CODE,
GWL-STATUS-SUBCODE.
IF (GWL-RC = TDS-OK AND
GWL-STATUS-COMM = TDS-RECEIVE) THEN
CALL 'TDSNDMSG' USING GWL-PROC, GWL-RC,
MSG-TYPE, MSG-NR,
MSG-SEVERITY,
TDS-ZERO,
TDS-ZERO,
MSG-RPC, MSG-RPC-L,
MSG-TEXT, MSG-TEXT-L
END-IF.
920-EXIT.
EXIT.
980-CICS-DUMP.
******************************************************************
* CAUSE A CICS TRANSACTION DUMP USUALLY BECAUSE SOMETHING IS BAD *
******************************************************************
EXEC CICS
DUMP DUMPCODE('SYY2') NOHANDLE
END-EXEC.
980-EXIT.
EXIT.
990-CICS-RETURN.
******************************************************************
* RETURN TO CICS... *
******************************************************************
EXEC CICS
RETURN
END-EXEC.
990-EXIT.
EXIT.
