*@(#) syctsar5.cobol 11.2 12/14/95
*******************************************************************
*
* Confidential property of Sybase, Inc.
* (c) Copyright Sybase, Inc. 1985 TO 1997.
* All rights reserved.
*
*******************************************************************
******* SYCTSAR5 - Client Language Request APPL - COBOL - CICS **
**
** CICS TRANID: SYR5
** PROGRAM: SYCTSAR5
**
** PURPOSE: Demonstrates Open Client for CICS CALLs.
**
** FUNCTION: Illustrates how to send an RPC request with
** parameters to:
**
** - A SQL Server
** - An Open Server running in a CICS/IMS region.
**
** SQL Server:
**
** If the request is sent to a SQL Server it
** intitiates the stored procedure "SYR2".
**
** Note: The Net-Gateway/MCG product includes a script
** that creates this procedure in a target SQL
** server.
**
** Open Server/CICS or Open Server/IMS:
**
** If the request is sent to an Open Server/CICS or
** IMS region, it initiates the transaction SYR2.
**
** Note: Both Open Server/CICS and IMS products
** include the sample transaction SYR2. This
** is the server side transaction invoked by
** this transaction.
**
** PREREQS: Before running SYCTSAR5, make sure that the server
** you wish to access has an entry in the Connection
** Router Table for that Server and the MCG(s) that
** you wish to use.
**
**
** INPUT: On the input screen, make sure to enter the Server
** name, user id, and password for the target server.
** TRAN NAME is not used for LAN servers.
**
** If the target server is in a CICS or IMS region,
** enter SYR2 in the TRAN NAME field.
**
**
** Open Client CALLs used in this sample:
**
** CSBCTXALLOC allocate a context
** CSBCTXDROP drop a context
** CTBBIND bind a column variable
** CTBCLOSE close a server connection
** CTBCMDALLOC allocate a command
** CTBCMDDROP drop a command
** CTBCOMMAND initiate remote procedure CALL
** CTBCONALLOC allocate a connection
** CTBCONDROP drop a connection
** CTBCONPROPS alter properties of a connection
** CTBCONNECT open a server connection
** CTBDESCRIBE return a description of RESULT data
** CTBDIAG retrieve SQLCODE messages
** CTBEXIT exit client library
** CTBFETCH FETCH RESULT data
** CTBINIT init client library
** CTBPARAM define a command PARAMETER
** CTBRESULTS set up RESULT data
** CTBSEND send a request TO the server
**
** History:
**
** Date BTS# Descrition
** ======= ====== ===============================================
** Feb1795 Create
** Oct1895 99999 Rewrite and add front end to the program
**
******************************************************************
IDENTIFICATION DIVISION.
PROGRAM-ID. SYCTSAR5.
ENVIRONMENT DIVISION.
CONFIGURATION SECTION.
SOURCE-COMPUTER. XYZ.
OBJECT-COMPUTER. XYZ.
DATA DIVISION.
WORKING-STORAGE SECTION.
******************************************************************
** Client Library Cobol Copy Book
******************************************************************
COPY CTPUBLIC.
******************************************************************
** CICS BMS DEFINITIONS
******************************************************************
COPY SYCTBA5.
*****************************************************************
* Standard CICS Attribute and Print Control Chararcter List
*****************************************************************
COPY DFHBMSCA.
******************************************************************
** CICS Standard Attention Identifiers Cobol Copy Book
******************************************************************
COPY DFHAID.
*****************************************************************
* CONSTANTS
*****************************************************************
01 MSG-TEXT-1 PIC X(70) VALUE ' '.
01 MSG-TEXT-2 PIC X(70)
VALUE 'Press Clear To Exit'.
01 PAGE-CNT PIC S9(4) COMP VALUE +0.
01 UTIME PIC S9(15) COMP-3.
01 TMP-DATE PIC X(08).
01 TMP-TIME PIC X(08).
01 ENTER-DATA-SW PIC X(01) VALUE 'N'.
01 C-N PIC X(01) VALUE 'N'.
01 C-Y PIC X(01) VALUE 'Y'.
01 MAX-SCREEN-ROWS PIC S9(4) VALUE +10.
01 RESTYPE PIC S9(9) COMP SYNC VALUE IS 0.
01 NETDRIVER PIC S9(9) COMP SYNC VALUE IS 9999.
01 DATALEN PIC S9(9) COMP SYNC VALUE IS 0.
01 INTARG PIC S9(9) COMP SYNC VALUE IS 0.
01 INDIC PIC S9(9) COMP SYNC VALUE IS 0.
01 CMDSTR PIC X(200) VALUE IS SPACES.
01 STATUS-BIND PIC S9(9) COMP SYNC VALUE IS 0.
01 STATUS-OK PIC S9(9) COMP SYNC VALUE IS 0.
01 BAD-INPUT PIC X(01) VALUE 'N'.
01 NO-MORE-MSGS-SW PIC X(01).
88 NO-MORE-MSGS VALUE 'Y'.
01 NO-ERRORS-SW PIC X(01).
88 NO-ERRORS VALUE 'N'.
01 SWITCHES.
05 SW-RESULTS PIC X(01) VALUE 'Y'.
88 NO-MORE-RESULTS VALUE 'N'.
05 SW-FETCH PIC X(01) VALUE 'Y'.
88 NO-MORE-ROWS VALUE 'N'.
05 SW-DIAG PIC X(01) VALUE 'N'.
88 DIAG-MSGS-INITIALIZED VALUE 'Y'.
01 CS-LIB-MISC-FIELDS.
05 CSL-CMD-HANDLE PIC S9(9) COMP VALUE +0.
05 CSL-CON-HANDLE PIC S9(9) COMP VALUE +0.
05 CSL-CTX-HANDLE PIC S9(9) COMP VALUE +0.
05 CSL-NULL PIC S9(9) COMP VALUE +0.
05 CSL-RC PIC S9(9) COMP VALUE +0.
01 PROPS-FIELDS.
05 PF-SERVER PIC X(30) VALUE IS SPACES.
05 PF-SERVER-SIZE PIC S9(9) COMP VALUE +0.
05 PF-USER PIC X(08) VALUE IS SPACES.
05 PF-USER-SIZE PIC S9(9) COMP VALUE +0.
05 PF-PWD PIC X(08) VALUE IS SPACES.
05 PF-PWD-SIZE PIC S9(9) COMP VALUE +0.
05 PF-TRAN PIC X(08) VALUE IS SPACES.
05 PF-TRAN-SIZE PIC S9(9) COMP VALUE +0.
05 PF-NETDRV PIC X(08) VALUE IS SPACES.
05 PF-DRV-SIZE PIC S9(9) COMP VALUE +0.
05 PF-DEPT PIC X(03) VALUE 'D11'.
05 PF-DEPT-SIZE PIC S9(9) COMP VALUE +3.
05 PF-STRLEN PIC S9(9) COMP.
05 PF-MSGLIMIT PIC S9(9) COMP.
01 PARM1 PIC S9(9) COMP SYNC.
01 PARM2.
49 PLEN-RET PIC S9(4) COMP SYNC.
49 PARR-RET PIC X(3) VALUE IS SPACES.
01 DISP-PARM.
05 FILLER PIC X(1) VALUE IS '('.
05 RETPARM-VAL PIC 99999.
05 RET-PARMMSG PIC X(17) VALUE IS
' row(s) affected)'.
05 FILLER PIC X(50) VALUE IS SPACES.
01 DISP-ROW.
05 ROW1-VAL PIC X(12) VALUE IS SPACES.
05 FILLER PIC X(01) VALUE IS SPACES.
05 ROW2-VAL PIC X(15) VALUE IS SPACES.
05 FILLER PIC X(01) VALUE IS SPACES.
05 ROW3-VAL PIC zz9-.
05 FILLER PIC X(08) VALUE IS SPACES.
05 ROW4-VAL PIC zz.-.
05 FILLER PIC X(06) VALUE IS SPACES.
05 ROW5-VAL.
49 LOW-VAL PIC ZZ,ZZZ.99-.
05 FILLER PIC X(14) VALUE IS SPACES.
01 ROW1-BIND.
49 ROW1-LEN PIC S9(4) COMP SYNC VALUE IS 0.
49 ROW1-TEXT PIC X(12) VALUE IS SPACES.
01 ROW2-BIND.
49 ROW2-LEN PIC S9(4) COMP SYNC VALUE IS 0.
49 ROW2-TEXT PIC X(15) VALUE IS SPACES.
01 ROW3-BIND PIC S9(4) COMP SYNC VALUE IS 0.
01 ROW4-BIND.
49 HIGH4-BIND PIC S9(9) COMP SYNC VALUE IS 0.
49 LOW4-BIND PIC S9(5)V9(4) COMP SYNC
VALUE IS 0.
01 ROW5-BIND.
49 HIGH-BIND PIC S9(9) COMP SYNC VALUE IS 0.
49 LOW-BIND PIC S9(5)V9(4) COMP SYNC
VALUE IS 0.
01 OUTLEN PIC S9(9) COMP SYNC VALUE IS 0.
01 NUMROWS PIC S9(9) COMP SYNC VALUE IS 0.
01 I PIC S9(9) COMP SYNC VALUE IS 0.
01 I1 PIC S9(9) COMP SYNC VALUE IS 0.
01 I2 PIC S9(9) COMP SYNC VALUE IS 0.
01 COPIED PIC S9(9) COMP SYNC VALUE IS 0.
01 COPIED-NULL PIC S9(9) COMP SYNC VALUE IS 0.
01 INDICATOR PIC S9(9) COMP SYNC VALUE IS 0.
01 INDICATOR-NULL PIC S9(9) COMP SYNC VALUE IS 0.
01 DISP-MSG.
05 TEST-CASE PIC X(08) VALUE IS 'SYCTSAR5'.
05 FILLER PIC X(01) VALUE IS SPACES.
05 MSG.
10 SAMP-LIT PIC X(05) VALUE IS 'rc = '.
10 SAMP-RC PIC -Z9.
10 FILLER PIC X(02) VALUE IS ', '.
10 REST-LIT PIC X(12) VALUE IS
'Result Type:'.
10 REST-TYPE PIC Z(3)9.
10 FILLER PIC X(03) VALUE IS SPACES.
10 MSGSTR PIC X(40) VALUE IS SPACES.
01 DATAFMT-PARM.
05 NM-PARM PIC X(132).
05 NMLEN-PARM PIC S9(9) COMP SYNC.
05 DATATYPE-PARM PIC S9(9) COMP SYNC.
05 FORMT-PARM PIC S9(9) COMP SYNC.
05 MAXLENGTH-PARM PIC S9(9) COMP SYNC.
05 SCALE-PARM PIC S9(9) COMP SYNC.
05 PRECISION-PARM PIC S9(9) COMP SYNC.
05 FMTSTATUS-PARM PIC S9(9) COMP SYNC.
05 FMTCOUNT-PARM PIC S9(9) COMP SYNC.
05 USERTYPE-PARM PIC S9(9) COMP SYNC.
05 LOCALE-PARM PIC X(68).
01 DATAFMT-BIND.
05 NM-BIND PIC X(132).
05 NMLEN-BIND PIC S9(9) COMP SYNC.
05 DATATYPE-BIND PIC S9(9) COMP SYNC.
05 FORMT-BIND PIC S9(9) COMP SYNC.
05 MAXLENGTH-BIND PIC S9(9) COMP SYNC.
05 SCALE-BIND PIC S9(9) COMP SYNC.
05 PRECISION-BIND PIC S9(9) COMP SYNC.
05 FMTSTATUS-BIND PIC S9(9) COMP SYNC.
05 FMTCOUNT-BIND PIC S9(9) COMP SYNC.
05 USERTYPE-BIND PIC S9(9) COMP SYNC.
05 LOCALE-BIND PIC X(68).
01 WCOLUMN PIC S9(9) COMP SYNC.
01 DIAG-FIELDS.
05 DF-MSGNO PIC S9(9) COMP VALUE +1.
05 DF-NUM-OF-MSGS PIC S9(9) COMP VALUE +0.
*******************************
** Client Message Structure **
*******************************
01 CLIENT-MSG.
05 CM-SEVERITY PIC S9(9) COMP SYNC.
05 CM-MSGNO PIC S9(9) COMP SYNC.
05 CM-TEXT PIC X(256).
05 CM-TEXT-LEN PIC S9(9) COMP SYNC.
05 CM-OS-MSGNO PIC S9(9) COMP SYNC.
05 CM-OS-MSGTXT PIC X(256).
05 CM-OS-MSGTEXT-LEN PIC S9(9) COMP SYNC.
05 CM-STATUS PIC S9(9) COMP.
01 DISP-CLIENT-MSG-HDR.
05 CLIENT-MSG-HDR PIC X(15) VALUE IS
'Client Message:'.
01 DISP-CLIENT-MSG-1.
05 FILLER PIC X(02) VALUE IS SPACES.
05 CM-SEVERITY-HDR PIC X(09) VALUE IS 'Severity:'.
05 FILLER PIC X(02) VALUE IS SPACES.
05 CM-SEVERITY-DATA PIC Z(8)9.
05 CM-STATUS-HDR PIC X(12) VALUE IS
', Status: '.
05 FILLER PIC X(02) VALUE IS SPACES.
05 CM-STATUS-DATA PIC Z(8)9.
01 DISP-CLIENT-MSG-2.
05 FILLER PIC X(02) VALUE IS SPACES.
05 CM-OC-MSGNO-HDR PIC X(09) VALUE IS 'OC MsgNo:'.
05 FILLER PIC X(02) VALUE IS SPACES.
05 CM-OC-MSGNO-DATA PIC Z(8)9.
01 DISP-CLIENT-MSG-3.
05 FILLER PIC X(02) VALUE IS SPACES.
05 CM-OC-MSG-HDR PIC X(09) VALUE IS 'OC MsgTx:'.
05 FILLER PIC X(02) VALUE IS SPACES.
05 CM-OC-MSG-DATA PIC X(66).
01 DISP-CLIENT-MSG-3A.
05 CM-OC-MSG-DATA-1 PIC X(66).
05 CM-OC-MSG-DATA-2 PIC X(66).
05 CM-OC-MSG-DATA-3 PIC X(66).
05 CM-OC-MSG-DATA-4 PIC X(58).
01 DISP-CLIENT-MSG-3B.
05 FILLER PIC X(13) VALUE IS SPACES.
05 CM-OC-MSG-DATA-X PIC X(66).
01 DISP-EMPTY-CLIENT-MSG-3.
05 FILLER PIC X(02) VALUE IS SPACES.
05 CM-OC-MSG-HDR PIC X(09) VALUE IS 'OC MsgTx:'.
05 FILLER PIC X(02) VALUE IS SPACES.
05 NO-DATA PIC X(11) VALUE IS 'No Message!'.
01 DISP-CLIENT-MSG-4.
05 FILLER PIC X(02) VALUE IS SPACES.
05 CM-OS-MSG-HDR PIC X(09) VALUE IS 'OS MsgNo:'.
05 FILLER PIC X(02) VALUE IS SPACES.
05 CM-OS-MSGNO-DATA PIC Z(8)9.
01 DISP-CLIENT-MSG-5.
05 FILLER PIC X(02) VALUE IS SPACES.
05 CM-OS-MSG-HDR PIC X(09) VALUE IS 'OS MsgTx:'.
05 FILLER PIC X(02) VALUE IS SPACES.
05 CM-OS-MSG-DATA PIC X(66).
01 DISP-CLIENT-MSG-5A.
05 CM-OS-MSG-DATA-1 PIC X(66).
05 CM-OS-MSG-DATA-2 PIC X(66).
05 CM-OS-MSG-DATA-3 PIC X(66).
05 CM-OS-MSG-DATA-4 PIC X(58).
01 DISP-EMPTY-CLIENT-MSG-5.
05 FILLER PIC X(02) VALUE IS SPACES.
05 CM-OS-MSG-HDR PIC X(09) VALUE IS 'OS MsgTx:'.
05 FILLER PIC X(02) VALUE IS SPACES.
05 NO-DATA PIC X(11) VALUE IS 'No Message!'.
*******************************
** Server Message Structure **
*******************************
01 SERVER-MSG.
05 SM-MSGNO PIC S9(9) COMP.
05 SM-STATE PIC S9(9) COMP.
05 SM-SEV PIC S9(9) COMP.
05 SM-TEXT PIC X(256).
05 SM-TEXT-LEN PIC S9(9) COMP.
05 SM-SVRNAME PIC X(256).
05 SM-SVRNAME-LEN PIC S9(9) COMP.
05 SM-PROC PIC X(256).
05 SM-PROC-LEN PIC S9(9) COMP.
05 SM-LINE PIC S9(9) COMP.
05 SM-STATUS PIC S9(9) COMP.
01 DISP-SERVER-MSG-HDR.
05 SERVER-MSG-HDR PIC X(15) VALUE IS
'Server Message:'.
01 DISP-SERVER-MSG-1.
05 FILLER PIC X(02) VALUE IS SPACES.
05 SM-MSG-NO-HDR PIC X(09) VALUE IS
'Message#:'.
05 FILLER PIC X(02) VALUE IS SPACES.
05 SM-MSG-NO-DATA PIC Z(8)9.
05 SM-SEVERITY-HDR PIC X(12) VALUE IS
', Severity:'.
05 FILLER PIC X(02) VALUE IS SPACES.
05 SM-SEVERITY-DATA PIC Z(8)9.
05 SM-STATE-HDR PIC X(12) VALUE IS
', State No:'.
05 FILLER PIC X(02) VALUE IS SPACES.
05 SM-STATE-DATA PIC Z(8)9.
01 DISP-SERVER-MSG-2.
05 FILLER PIC X(02) VALUE IS SPACES.
05 SM-LINE-NO-HDR PIC X(09) VALUE IS
'Line No:'.
05 FILLER PIC X(02) VALUE IS SPACES.
05 SM-LINE-NO-DATA PIC Z(8)9.
05 SM-STATUS-HDR PIC X(12) VALUE IS
', Status :'.
05 FILLER PIC X(02) VALUE IS SPACES.
05 SM-STATUS-DATA PIC Z(8)9.
01 DISP-SERVER-MSG-3.
05 FILLER PIC X(02) VALUE IS SPACES.
05 SM-SVRNAME-HDR PIC X(09) VALUE IS 'Serv Nam:'.
05 FILLER PIC X(02) VALUE IS SPACES.
05 SM-SVRNAME-DATA PIC X(66).
05 FILLER PIC X(03) VALUE IS '...'.
01 DISP-SERVER-MSG-4.
05 FILLER PIC X(02) VALUE IS SPACES.
05 SM-PROC-ID-HDR PIC X(09) VALUE IS 'Proc ID:'.
05 FILLER PIC X(02) VALUE IS SPACES.
05 SM-PROC-ID-DATA PIC X(66).
01 DISP-SERVER-MSG-5.
05 FILLER PIC X(02) VALUE IS SPACES.
05 SM-MSG-HDR PIC X(09) VALUE IS 'Message :'.
05 FILLER PIC X(02) VALUE IS SPACES.
05 SM-MSG-DATA PIC X(66).
01 DISP-SERVER-MSG-5A.
05 SM-MSG-DATA-1 PIC X(66).
05 SM-MSG-DATA-2 PIC X(66).
05 SM-MSG-DATA-3 PIC X(66).
05 SM-MSG-DATA-4 PIC X(58).
01 DISP-SERVER-MSG-5X.
05 FILLER PIC X(13) VALUE IS SPACES.
05 SM-MSG-DATA-X PIC X(66).
01 CICS-FIELDS.
05 CICS-RESPONSE PIC S9(9) COMP.
01 QUERY-FIELDS.
05 QF-LEN PIC S9(4) COMP VALUE +1.
05 QF-MAXLEN PIC S9(4) COMP VALUE +1.
05 QF-ANSWER PIC X(01) VALUE IS SPACES.
******************************************************************
PROCEDURE DIVISION.
******************************************************************
**************************
* CICS Condition Handler *
**************************
EXEC CICS HANDLE CONDITION MAPFAIL(NO-INPUT)
ERROR(ERRORS)
END-EXEC.
********************
* CICS Aid Handler *
********************
EXEC CICS HANDLE AID ANYKEY(NO-INPUT)
CLEAR(GETOUT)
END-EXEC.
**************************
* PROGRAM INITIALIZATION *
**************************
MOVE SPACES TO DISP-ROW.
MOVE C-N TO NO-MORE-MSGS-SW.
MOVE C-N TO NO-ERRORS-SW.
MOVE C-Y TO SW-DIAG.
MOVE LOW-VALUES TO A5PANELO.
MOVE -1 TO SERVERL.
COMPUTE PAGE-CNT = PAGE-CNT + 1.
PERFORM GET-SYSTEM-TIME.
GET-INPUT-AGAIN.
PERFORM DISPLAY-INITIAL-SCREEN.
PERFORM GET-INPUT-DATA.
********************************
* ALLOCATE A CONTEXT STRUCTURE *
********************************
MOVE ZERO TO CSL-CTX-HANDLE.
MOVE LOW-VALUES TO DATAFMT-PARM DATAFMT-BIND DISP-ROW.
CALL 'CSBCTXAL' USING CS-VERSION-50
CSL-RC
CSL-CTX-HANDLE.
IF CSL-RC NOT EQUAL CS-SUCCEED
THEN
MOVE SPACES TO MSGSTR
STRING 'CSBCTXAL failed'
DELIMITED BY SIZE INTO MSGSTR
PERFORM PRINT-MSG
PERFORM ALL-DONE
END-IF.
**********************************
* INTITIALIZE THE CLIENT-LIBRARY *
**********************************
CALL 'CTBINIT' USING CSL-CTX-HANDLE
CSL-RC
CS-VERSION-50.
IF CSL-RC NOT EQUAL CS-SUCCEED
THEN
MOVE SPACES TO MSGSTR
STRING 'CTBINIT failed'
DELIMITED BY SIZE INTO MSGSTR
PERFORM PRINT-MSG
PERFORM ALL-DONE
END-IF.
PERFORM PROCESS-INPUT.
PERFORM QUIT-CLIENT-LIBRARY.
GOBACK.
*========================================================
*== ==
*== Subroutine to get system date/time ==
*== ==
*========================================================
GET-SYSTEM-TIME.
*----------------
EXEC CICS ASKTIME
ABSTIME(UTIME)
END-EXEC.
EXEC CICS FORMATTIME
ABSTIME(UTIME)
DATESEP('/')
MMDDYY(TMP-DATE)
TIME(TMP-TIME)
TIMESEP
END-EXEC.
*========================================================
*== ==
*== Subroutine to display SYD5 initial screen ==
*== ==
*========================================================
DISPLAY-INITIAL-SCREEN.
*----------------------
MOVE TMP-DATE TO SDATEO.
MOVE TMP-TIME TO STIMEO.
MOVE 'SYCTSAR5' TO PROGNMO.
MOVE PAGE-CNT TO SPAGEO.
MOVE MSG-TEXT-1 TO MSG1O.
MOVE MSG-TEXT-2 TO MSG2O.
EXEC CICS SEND MAP('A5PANEL')
MAPSET('SYCTBA5')
CURSOR
FRSET
ERASE
FREEKB
END-EXEC.
*========================================================
*== ==
*== Subroutine to get input data ==
*== ==
*========================================================
GET-INPUT-DATA.
*---------------
EXEC CICS RECEIVE MAP('A5PANEL')
MAPSET('SYCTBA5')
ASIS
END-EXEC.
IF SERVERL = ZERO
THEN
IF PF-SERVER = SPACES
THEN
MOVE 'Please Enter Server Name' TO MSG-TEXT-1
MOVE -1 TO SERVERL
MOVE C-Y TO ENTER-DATA-SW
END-IF
ELSE
MOVE SERVERI TO PF-SERVER
MOVE SERVERL TO PF-SERVER-SIZE
END-IF.
IF USERL = ZERO
THEN
IF PF-USER = SPACES
THEN
MOVE 'Please Enter User-ID' TO MSG-TEXT-1
MOVE -1 TO USERL
MOVE C-Y TO ENTER-DATA-SW
END-IF
ELSE
MOVE USERI TO PF-USER
MOVE USERL TO PF-USER-SIZE
MOVE PF-USER TO USERO
END-IF.
IF PSWDL NOT EQUAL ZERO
THEN
MOVE PSWDI TO PF-PWD
MOVE PSWDL TO PF-PWD-SIZE
END-IF
IF TRANL NOT EQUAL ZERO
THEN
MOVE TRANI TO PF-TRAN
MOVE TRANL TO PF-TRAN-SIZE
END-IF.
IF NETDRVL NOT EQUAL ZERO
THEN
MOVE NETDRVI TO PF-NETDRV
MOVE NETDRVL TO PF-DRV-SIZE
END-IF.
IF ENTER-DATA-SW = C-Y
THEN
MOVE C-N TO ENTER-DATA-SW
PERFORM DISPLAY-INITIAL-SCREEN
PERFORM GET-INPUT-DATA
END-IF.
*========================================================
*== ==
*== Subroutine to process input data ==
*== ==
*========================================================
PROCESS-INPUT.
********************************
* ALLOCATE A CONNECTION HANDLE *
********************************
MOVE ZERO TO CSL-CON-HANDLE.
CALL 'CTBCONAL' USING CSL-CTX-HANDLE
CSL-RC
CSL-CON-HANDLE.
IF CSL-RC NOT EQUAL CS-SUCCEED
THEN
MOVE SPACES TO MSGSTR
STRING 'CTBCONAL failed'
DELIMITED BY SIZE INTO MSGSTR
PERFORM PRINT-MSG
PERFORM ALL-DONE
END-IF.
*******************
* SET THE USER ID *
*******************
CALL 'CTBCONPR' USING CSL-CON-HANDLE
CSL-RC
CS-SET
CS-USERNAME
PF-USER
PF-USER-SIZE
CS-FALSE
OUTLEN.
IF CSL-RC NOT EQUAL CS-SUCCEED
THEN
MOVE SPACES TO MSGSTR
STRING 'CTBCONPR for user-id failed'
DELIMITED BY SIZE INTO MSGSTR
PERFORM PRINT-MSG
PERFORM ALL-DONE
END-IF.
********************
* SET THE PASSWORD *
********************
CALL 'CTBCONPR' USING CSL-CON-HANDLE
CSL-RC
CS-SET
CS-PASSWORD
PF-PWD
PF-PWD-SIZE
CS-FALSE
OUTLEN.
IF CSL-RC NOT EQUAL CS-SUCCEED
THEN
MOVE SPACES TO MSGSTR
STRING 'CTBCONPR for password failed'
DELIMITED BY SIZE INTO MSGSTR
PERFORM PRINT-MSG
PERFORM ALL-DONE
END-IF.
********************
* SET THE TRAN NAME *
********************
IF PF-TRAN-SIZE IS NOT EQUAL TO ZEROES THEN
CALL 'CTBCONPR' USING CSL-CON-HANDLE
CSL-RC
CS-SET
CS-TRANSACTION-NAME
PF-TRAN
PF-TRAN-SIZE
CS-FALSE
OUTLEN
IF CSL-RC NOT EQUAL CS-SUCCEED
THEN
MOVE SPACES TO MSGSTR
STRING 'CTBCONPR for TRAN name failed'
DELIMITED BY SIZE INTO MSGSTR
PERFORM PRINT-MSG
PERFORM ALL-DONE
END-IF
END-IF.
*******************************
* SET THE NET DRIVER PROPERTY *
*******************************
IF PF-NETDRV = SPACES OR PF-NETDRV = 'LU62' X
OR PF-NETDRV = 'lu62'
MOVE CS-LU62 TO NETDRIVER
ELSE
IF PF-NETDRV = 'IBMTCPIP' OR PF-NETDRV = 'ibmtcpip'
MOVE CS-TCPIP TO NETDRIVER
ELSE
IF PF-NETDRV = 'INTERLIN' OR PF-NETDRV = 'interlin'
MOVE CS-INTERLINK TO NETDRIVER
ELSE
IF PF-NETDRV = 'CPIC' OR PF-NETDRV = 'cpic'
MOVE CS-NCPIC TO NETDRIVER
END-IF.
IF PF-DRV-SIZE IS NOT EQUAL TO ZEROES THEN
CALL 'CTBCONPR' USING CSL-CON-HANDLE
CSL-RC
CS-SET
CS-NET-DRIVER
NETDRIVER
CS-UNUSED
CS-FALSE
OUTLEN
IF CSL-RC NOT EQUAL CS-SUCCEED
THEN
MOVE SPACES TO MSGSTR
STRING 'CTBCONPR for network driver failed'
DELIMITED BY SIZE INTO MSGSTR
PERFORM PRINT-MSG
PERFORM ALL-DONE
END-IF
END-IF.
*************************
* CONNECT TO THE SERVER *
*************************
CALL 'CTBCONNE' USING CSL-CON-HANDLE
CSL-RC
PF-SERVER
PF-SERVER-SIZE
CS-FALSE.
IF CSL-RC NOT EQUAL CS-SUCCEED
THEN
MOVE SPACES TO MSGSTR
STRING 'CTBCONNE failed' DELIMITED BY SIZE INTO MSGSTR
PERFORM PRINT-MSG
PERFORM ALL-DONE
END-IF.
IF NO-ERRORS
THEN
PERFORM SEND-PARAM THRU SEND-PARAM-EXIT
END-IF.
**************************************
* PROCESS THE RESULTS OF THE COMMAND *
**************************************
IF NO-ERRORS
THEN
PERFORM RESULTS-PROCESSING UNTIL NO-MORE-RESULTS
PERFORM CLOSE-CONNECTION
END-IF.
PROCESS-INPUT-EXIT.
EXIT.
*========================================================
*== ==
*== Subroutine to allocate, send, and process commands ==
*== ==
*========================================================
SEND-PARAM.
*****************************
* NOW GET A COMMAND HANDLE. *
*****************************
MOVE ZERO TO CSL-CMD-HANDLE.
CALL 'CTBCMDAL' USING CSL-CON-HANDLE
CSL-RC
CSL-CMD-HANDLE.
IF CSL-RC NOT EQUAL CS-SUCCEED
THEN
MOVE SPACES TO MSGSTR
STRING 'CTBCMDAL failed'
DELIMITED BY SIZE INTO MSGSTR
PERFORM PRINT-MSG
PERFORM ALL-DONE
END-IF.
************************************************************
* INITIATE THE STORED PROCEDURE "SYR2". THE DATA WILL BE *
* RETURNED FROM THE TABLE SYBASE.SAMPLETB. THIS CAN EITHER *
* BE A DB2 OR A SQL SERVER TABLE DEPENDING ON WHETHER *
* THE RPC IS SENT TO A CICS REGION OR A SQL SERVER. *
************************************************************
MOVE LOW-VALUES TO CMDSTR.
MOVE 4 TO INTARG.
STRING 'SYR2' DELIMITED BY SIZE INTO CMDSTR.
CALL 'CTBCOMMA' USING CSL-CMD-HANDLE
CSL-RC
CS-RPC-CMD
CMDSTR
INTARG
CS-UNUSED.
IF CSL-RC NOT EQUAL CS-SUCCEED
THEN
MOVE SPACES TO MSGSTR
STRING 'CTBCOMMAND failed'
DELIMITED BY SIZE INTO MSGSTR
PERFORM PRINT-MSG
PERFORM ALL-DONE
END-IF.
*****************************
* SET UP THE RPC PARAMETERS *
*****************************
MOVE '@parm1' TO NM-PARM.
MOVE 6 TO NMLEN-PARM.
MOVE CS-FMT-NULLTERM TO FORMT-PARM.
MOVE CS-RETURN TO FMTSTATUS-PARM.
MOVE CS-INT-TYPE TO DATATYPE-PARM.
MOVE LENGTH OF PARM1 TO DATALEN.
MOVE 0 TO PARM1.
CALL 'CTBPARAM' USING CSL-CMD-HANDLE
CSL-RC
DATAFMT-PARM
PARM1
DATALEN
INDIC.
IF CSL-RC NOT EQUAL CS-SUCCEED
THEN
MOVE SPACES TO MSGSTR
STRING 'CTBPARAM CS-INT-TYPE parm1 failed'
DELIMITED BY SIZE INTO MSGSTR
PERFORM PRINT-MSG
PERFORM ALL-DONE
END-IF.
MOVE '@parm2' TO NM-PARM.
MOVE 6 TO NMLEN-PARM.
MOVE CS-FMT-NULLTERM TO FORMT-PARM.
MOVE CS-INPUTVALUE TO FMTSTATUS-PARM.
MOVE CS-VARCHAR-TYPE TO DATATYPE-PARM.
MOVE PF-DEPT TO PARR-RET.
MOVE PF-DEPT-SIZE TO DATALEN.
MOVE 255 TO MAXLENGTH-PARM.
CALL 'CTBPARAM' USING CSL-CMD-HANDLE
CSL-RC
DATAFMT-PARM
PARM2
DATALEN
INDIC.
IF CSL-RC NOT EQUAL CS-SUCCEED
THEN
MOVE SPACES TO MSGSTR
STRING 'CTBPARAM CS-VARCHAR-TYPE parm2 failed'
DELIMITED BY SIZE INTO MSGSTR
PERFORM PRINT-MSG
PERFORM ALL-DONE
END-IF.
***************************************
* SEND THE COMMAND AND THE PARAMETERS *
***************************************
CALL 'CTBSEND' USING CSL-CMD-HANDLE
CSL-RC.
IF CSL-RC NOT EQUAL CS-SUCCEED
THEN
MOVE SPACES TO MSGSTR
STRING 'CTBSEND failed'
DELIMITED BY SIZE INTO MSGSTR
PERFORM PRINT-MSG
PERFORM ALL-DONE
END-IF.
SEND-PARAM-EXIT.
EXIT.
*========================================================
*== ==
*== Subroutine to process result ==
*== ==
*========================================================
RESULTS-PROCESSING.
***************************
* SET UP THE RESULTS DATA *
***************************
CALL 'CTBRESUL' USING CSL-CMD-HANDLE
CSL-RC
RESTYPE.
**************************************************
* DETERMINE THE OUTCOME OF THE COMMAND EXECUTION *
**************************************************
EVALUATE CSL-RC
WHEN CS-SUCCEED
****************************************************************
* DETERMINE THE TYPE OF RESULT RETURNED BY THE CURRENT REQUEST *
****************************************************************
EVALUATE RESTYPE
***********************
* PROCESS ROW RESULTS *
***********************
WHEN CS-ROW-RESULT
PERFORM RESULT-ROW-PROCESSING
MOVE 'Y' TO SW-FETCH
PERFORM FETCH-ROW-PROCESSING UNTIL NO-MORE-ROWS
*************************************************************
* PROCESS PARAMETER RESULTS - THERE SHOULD BE NO PARAMETERS *
* TO PROCESS *
*************************************************************
WHEN CS-PARAM-RESULT
PERFORM RESULT-PARAM-PROCESSING
MOVE 'Y' TO SW-FETCH
PERFORM FETCH-PARAM-PROCESSING
********************************************************
* PROCESS STATUS RESULTS - THE STORED PROCEDURE RESULT *
* WILL BE PROCESSED IN THIS EXAMPLE *
********************************************************
WHEN CS-STATUS-RESULT
MOVE 'Y' TO SW-FETCH
CALL 'CTBFETCH' USING CSL-CMD-HANDLE
CSL-RC
CS-UNUSED
CS-UNUSED
CS-UNUSED
NUMROWS
IF CSL-RC = CS-FAIL
THEN
MOVE SPACES TO MSGSTR
STRING 'CTBFETCH status failed'
DELIMITED BY SIZE INTO MSGSTR
PERFORM PRINT-MSG
PERFORM ALL-DONE
END-IF
*************************************************************
* PRINT AN ERROR MESSAGE IF THE SERVER ENCOUNTERED AN ERROR *
* WHILE EXECUTING THE REQUEST *
*************************************************************
WHEN CS-CMD-FAIL
STRING
'CTBRESUL failed with CS-CMD-FAIL restype'
DELIMITED BY SIZE INTO MSGSTR
PERFORM PRINT-MSG
******************************************************************
* PRINT A MESSSAGE FOR SUCCESSFUL COMMANDS THAT RETURNED NO DATA *
* (OPTIONAL) *
******************************************************************
WHEN CS-CMD-SUCCEED
STRING
'CTBRESUL returned CS-CMD-SUCCEED restype'
DELIMITED BY SIZE INTO MSGSTR
**********************************************************
* PRINT A MESSSAGE FOR REQUESTS THAT HAVE BEEN PROCESSED *
* SUCCESSFULLY (OPTIONAL) *
**********************************************************
WHEN CS-CMD-DONE
STRING
'CTBRESUL returned CS-CMD-DONE restype'
DELIMITED BY SIZE INTO MSGSTR
WHEN OTHER
STRING
'CTBRESUL returned UNKNOW restype'
DELIMITED BY SIZE INTO MSGSTR
PERFORM PRINT-MSG
MOVE 'N' TO SW-RESULTS
END-EVALUATE
********************************************************
* PRINT AN ERROR MESSAGE IF THE CTBRESULTS CALL FAILED *
********************************************************
WHEN CS-FAIL
MOVE 'N' TO SW-RESULTS
STRING
'CTBRESUL failed with CS-FAIL ret-cd'
DELIMITED BY SIZE INTO MSGSTR
PERFORM PRINT-MSG
*************************************************************
* DROP OUT OF THE RESULTS LOOP IF NO MORE RESULT SETS ARE *
* AVAILABLE FOR PROCESSING OR IF THE RESULTS WERE CANCELLED *
*************************************************************
WHEN CS-END-RESULTS
MOVE 'N' TO SW-RESULTS
WHEN CS-CANCELLED
MOVE 'N' TO SW-RESULTS
WHEN OTHER
MOVE 'N' TO SW-RESULTS
STRING 'CTBRESUL failed with UNKNOWN ret-cd'
DELIMITED BY SIZE INTO MSGSTR
PERFORM PRINT-MSG
END-EVALUATE.
MOVE 0 TO RESTYPE.
*========================================================
*== ==
*== Subroutine to process result rows ==
*== ==
*========================================================
RESULT-ROW-PROCESSING.
*======================
***********************************
* FOR EACH COLUMN BIND THE RESULT *
***********************************
PERFORM BIND-ROW-PROCESSING.
MOVE 1 TO I2.
STRING
'FirstName LastName EducLvl JobCode Salary'
DELIMITED BY SIZE INTO RSLTNO(I2).
MOVE 2 TO I2.
STRING '=========== =============== ======='
DELIMITED BY SIZE
' ======= =========='
DELIMITED BY SIZE
INTO RSLTNO(I2).
*====================================================
*== ==
*== Subroutine to describe the returned parameters ==
*== ==
*====================================================
RESULT-PARAM-PROCESSING.
************************************************
* RETURN A DESCRIPTION OF THE RETURN PARAMETER *
************************************************
MOVE 1 TO I.
CALL 'CTBDESCR' USING CSL-CMD-HANDLE
CSL-RC
I
DATAFMT-BIND.
IF CSL-RC NOT EQUAL CS-SUCCEED
THEN
MOVE SPACES TO MSGSTR
STRING 'CTBDESCR failed'
DELIMITED BY SIZE INTO MSGSTR
PERFORM PRINT-MSG
PERFORM ALL-DONE
END-IF.
*****************************
* BIND THE RETURN PARAMETER *
*****************************
PERFORM BIND-PARAM-PROCESSING.
*========================================================
*== ==
*== Subroutine to fetch row processing ==
*== ==
*========================================================
FETCH-ROW-PROCESSING.
******************
* FETCH THE ROWS *
******************
CALL 'CTBFETCH' USING CSL-CMD-HANDLE
CSL-RC
CS-UNUSED
CS-UNUSED
CS-UNUSED
NUMROWS.
EVALUATE CSL-RC
***********************************************
* MOVE THE ROW DATA TO PRINTABLE DATA FORMATS *
***********************************************
WHEN CS-SUCCEED
COMPUTE I2 EQUAL I2 + 1
MOVE 'Y' TO SW-FETCH
MOVE LOW-BIND TO LOW-VAL
MOVE ROW3-BIND TO ROW3-VAL
MOVE LOW4-BIND TO ROW4-VAL
MOVE ROW1-TEXT TO ROW1-VAL
MOVE ROW2-TEXT TO ROW2-VAL
IF I2 > MAX-SCREEN-ROWS
THEN
MOVE SPACES TO MSG-TEXT-2
STRING 'Please press return to continue!'
DELIMITED BY SIZE INTO MSG1O
PERFORM DISP-DATA
PERFORM CLEAR-SCREEN-DATA
VARYING I2 FROM 1 BY 1
UNTIL I2 > MAX-SCREEN-ROWS
COMPUTE PAGE-CNT = PAGE-CNT + 1
MOVE 1 TO I2
STRING
'FirstName LastName EducLvl'
DELIMITED BY SIZE
' JobCode Salary'
DELIMITED BY SIZE
INTO RSLTNO(I2)
MOVE 2 TO I2
STRING
'=========== =============== ======='
DELIMITED BY SIZE
' ======= =========='
DELIMITED BY SIZE
INTO RSLTNO(I2)
MOVE 3 TO I2
END-IF
MOVE DISP-ROW TO RSLTNO (I2)
MOVE SPACES TO ROW1-TEXT ROW2-TEXT
MOVE SPACES TO ROW1-VAL ROW2-VAL
**********************************************************
* PRINT THE ROWS AFTER ALL ROW DATA HAS BEEN FETCHED *
**********************************************************
WHEN CS-END-DATA
MOVE 'Press Clear To Exit'
TO MSG-TEXT-2
MOVE 'N' TO SW-FETCH
STRING 'All rows processing completed!'
DELIMITED BY SIZE INTO MSG1O
PERFORM DISP-DATA
************************************************************
* DROP OUT OF THE FETCH LOOP IF THE CTBFETCH COMMAND FAILS *
************************************************************
WHEN CS-FAIL
MOVE 'N' TO SW-FETCH
STRING 'CTBFETCH returned CS-FAIL ret-cd'
DELIMITED BY SIZE INTO MSGSTR
PERFORM PRINT-MSG
*************************************************************
* DROP OUT OF THE FETCH LOOP IF A RECOVERABLE COMMAND FAILS *
* WHILE FETCHING A ROW OR IF THE OPERATION WAS CANCELLED *
*************************************************************
WHEN CS-ROW-FAIL
MOVE 'N' TO SW-FETCH
STRING 'CTBFETCH returned CS-ROW-FETCH ret-cd'
DELIMITED BY SIZE INTO MSGSTR
PERFORM PRINT-MSG
WHEN CS-CANCELLED
MOVE 'N' TO SW-FETCH
STRING 'CTBFETCH returned CS-CANCELLED ret-cd'
DELIMITED BY SIZE INTO MSGSTR
PERFORM PRINT-MSG
WHEN OTHER
MOVE 'N' TO SW-FETCH
STRING 'CTBFETCH returned UNKNOWN ret-cd'
DELIMITED BY SIZE INTO MSGSTR
PERFORM PRINT-MSG
END-EVALUATE.
*========================================================
*== ==
*== Subroutine to fetch return parameter ==
*== ==
*========================================================
FETCH-PARAM-PROCESSING.
*=======================
******************************
* FETCH THE RETURN PARAMETER *
******************************
CALL 'CTBFETCH' USING CSL-CMD-HANDLE
CSL-RC
CS-UNUSED
CS-UNUSED
CS-UNUSED
NUMROWS.
IF CSL-RC = CS-FAIL
THEN
MOVE SPACES TO MSGSTR
STRING 'CTBFETCH return parameter failed'
DELIMITED BY SIZE INTO MSGSTR
PERFORM PRINT-MSG
PERFORM ALL-DONE
END-IF.
****************************************************************
* MOVE THE PARAMETER DATA TO A PRINTABLE DATA FORMAT AND PRINT *
* THE DATA *
****************************************************************
COMPUTE I2 EQUAL I2 + 1.
MOVE PARM1 TO RETPARM-VAL.
MOVE DISP-PARM TO RSLTNO (I2).
*========================================================
*== ==
*== Subroutine to bind row processing ==
*== ==
*========================================================
BIND-ROW-PROCESSING.
*******************************************************
* BIND THE COLUMNS RETURNED FROM THE STORED PROCEDURE *
*******************************************************
MOVE 1 TO WCOLUMN.
MOVE CS-VARCHAR-TYPE TO DATATYPE-BIND.
MOVE CS-MAX-CHAR TO MAXLENGTH-BIND.
MOVE CS-FMT-NULLTERM TO FORMT-BIND.
MOVE CS-PARAM-NOTNULL TO INDICATOR-NULL.
MOVE CS-PARAM-NOTNULL TO COPIED-NULL.
CALL 'CTBBIND' USING CSL-CMD-HANDLE
CSL-RC
WCOLUMN
DATAFMT-BIND
ROW1-BIND
COPIED
COPIED-NULL
INDICATOR
INDICATOR-NULL .
IF CSL-RC NOT EQUAL CS-SUCCEED
THEN
MOVE SPACES TO MSGSTR
STRING 'CTBBIND CS-VARCHAR-TYPE column 1 failed'
DELIMITED BY SIZE INTO MSGSTR
PERFORM PRINT-MSG
PERFORM ALL-DONE
END-IF.
MOVE 2 TO WCOLUMN.
CALL 'CTBBIND' USING CSL-CMD-HANDLE
CSL-RC
WCOLUMN
DATAFMT-BIND
ROW2-BIND
COPIED
COPIED-NULL
INDICATOR
INDICATOR-NULL .
IF CSL-RC NOT EQUAL CS-SUCCEED
THEN
MOVE SPACES TO MSGSTR
STRING 'CTBBIND CS-VARCHAR-TYPE column 2 failed'
DELIMITED BY SIZE INTO MSGSTR
PERFORM PRINT-MSG
PERFORM ALL-DONE
END-IF.
MOVE 3 TO WCOLUMN.
MOVE CS-SMALLINT-TYPE TO DATATYPE-BIND.
MOVE LENGTH OF ROW3-BIND TO MAXLENGTH-BIND.
MOVE CS-FMT-UNUSED TO FORMT-BIND.
CALL 'CTBBIND' USING CSL-CMD-HANDLE
CSL-RC
WCOLUMN
DATAFMT-BIND
ROW3-BIND
COPIED
COPIED-NULL
INDICATOR
INDICATOR-NULL .
IF CSL-RC NOT EQUAL CS-SUCCEED
THEN
MOVE SPACES TO MSGSTR
STRING 'CTBBIND CS-SMALLINT-TYPE column 3 failed'
DELIMITED BY SIZE INTO MSGSTR
PERFORM PRINT-MSG
PERFORM ALL-DONE
END-IF.
MOVE 4 TO WCOLUMN.
MOVE LENGTH OF ROW4-BIND TO MAXLENGTH-BIND.
MOVE CS-MONEY-TYPE TO DATATYPE-BIND.
MOVE CS-FMT-UNUSED TO FORMT-BIND.
MOVE CS-SRC-VALUE TO PRECISION-BIND.
MOVE CS-SRC-VALUE TO SCALE-BIND.
CALL 'CTBBIND' USING CSL-CMD-HANDLE
CSL-RC
WCOLUMN
DATAFMT-BIND
ROW4-BIND
COPIED
COPIED-NULL
INDICATOR
INDICATOR-NULL .
IF CSL-RC NOT EQUAL CS-SUCCEED
THEN
MOVE SPACES TO MSGSTR
STRING 'CTBBIND CS-MONEY-TYPE column 4 failed'
DELIMITED BY SIZE INTO MSGSTR
PERFORM PRINT-MSG
PERFORM ALL-DONE
END-IF.
MOVE 5 TO WCOLUMN.
MOVE LENGTH OF ROW5-BIND TO MAXLENGTH-BIND.
CALL 'CTBBIND' USING CSL-CMD-HANDLE
CSL-RC
WCOLUMN
DATAFMT-BIND
ROW5-BIND
COPIED
COPIED-NULL
INDICATOR
INDICATOR-NULL .
IF CSL-RC NOT EQUAL CS-SUCCEED
THEN
MOVE SPACES TO MSGSTR
STRING 'CTBBIND CS-MONEY-TYPE column 5 failed'
DELIMITED BY SIZE INTO MSGSTR
PERFORM PRINT-MSG
PERFORM ALL-DONE
END-IF.
*========================================================
*== ==
*== Subroutine to bind return parameters ==
*== ==
*========================================================
BIND-PARAM-PROCESSING.
*****************************
* BIND THE RETURN PARAMETER *
*****************************
MOVE 1 TO WCOLUMN.
MOVE CS-INT-TYPE TO DATATYPE-BIND.
CALL 'CTBBIND' USING CSL-CMD-HANDLE
CSL-RC
WCOLUMN
DATAFMT-BIND
PARM1
COPIED
COPIED-NULL
INDICATOR
INDICATOR-NULL .
IF CSL-RC NOT EQUAL CS-SUCCEED
THEN
MOVE SPACES TO MSGSTR
STRING 'CTBBIND for return parameter failed'
DELIMITED BY SIZE INTO MSGSTR
PERFORM PRINT-MSG
PERFORM ALL-DONE
END-IF.
*========================================================
*== ==
*== Subroutine to display output ==
*== ==
*========================================================
DISP-DATA.
MOVE TMP-DATE TO SDATEO.
MOVE TMP-TIME TO STIMEO.
MOVE 'SYCTSAR5' TO PROGNMO.
MOVE PAGE-CNT TO SPAGEO.
MOVE DFHBMPRO TO SERVERA.
MOVE PF-SERVER TO SERVERO.
MOVE DFHBMPRO TO USERA.
MOVE PF-USER TO USERO.
MOVE DFHBMPRO TO NETDRVA.
MOVE PF-NETDRV TO NETDRVO.
MOVE DFHBMDAR TO PSWDA.
MOVE PF-PWD TO PSWDO.
MOVE MSG-TEXT-2 TO MSG2O.
********************
* DISPLAY THE DATA *
********************
EXEC CICS SEND MAP('A5PANEL')
MAPSET('SYCTBA5')
CURSOR
FRSET
ERASE
FREEKB
END-EXEC.
EXEC CICS RECEIVE INTO(QF-ANSWER)
LENGTH(QF-LEN)
MAXLENGTH(QF-MAXLEN)
RESP(CICS-RESPONSE)
END-EXEC.
DISP-DATA-EXIT.
EXIT.
*========================================================
*== ==
*== Subroutine to print output messages. ==
*== ==
*========================================================
PRINT-MSG.
MOVE CSL-RC TO SAMP-RC.
MOVE RESTYPE TO REST-TYPE.
IF DIAG-MSGS-INITIALIZED AND BAD-INPUT EQUAL TO C-N
THEN
PERFORM GET-DIAG-MESSAGES
END-IF.
***********************
* DISPLAY THE MESSAGE *
***********************
IF NO-ERRORS
THEN
PERFORM DISP-DATA
END-IF.
MOVE C-Y TO NO-ERRORS-SW.
MOVE SPACES TO MSGSTR.
MOVE ZERO TO SAMP-RC.
MOVE ZERO TO REST-TYPE.
PRINT-MSG-EXIT.
EXIT.
*========================================================
*== ==
*== Subroutine to drop and to deallocate all handlers, ==
*== to close server connection and exit client library ==
*== ==
*========================================================
ALL-DONE.
PERFORM CLOSE-CONNECTION.
PERFORM QUIT-CLIENT-LIBRARY.
STOP RUN.
ALL-DONE-EXIT.
EXIT.
*===========================================================
*== ==
*== Subroutine to perform drop command handler, close ==
*== server connection, and deallocate Connection Handler. ==
*== ==
*===========================================================
CLOSE-CONNECTION.
***************************
* DROP THE COMMAND HANDLE *
***************************
CALL 'CTBCMDDR' USING CSL-CMD-HANDLE
CSL-RC.
IF CSL-RC = CS-FAIL
THEN
MOVE SPACES TO MSGSTR
STRING 'CTBCMDDR failed'
DELIMITED BY SIZE INTO MSGSTR
PERFORM PRINT-MSG
END-IF.
*******************************
* CLOSE THE SERVER CONNECTION *
*******************************
CALL 'CTBCLOSE' USING CSL-CON-HANDLE
CSL-RC
CS-UNUSED.
IF CSL-RC = CS-FAIL
THEN
MOVE SPACES TO MSGSTR
STRING 'CTBCLOSE failed'
DELIMITED BY SIZE INTO MSGSTR
PERFORM PRINT-MSG
END-IF.
*************************************
* DE-ALLOCATE THE CONNECTION HANDLE *
*************************************
CALL 'CTBCONDR' USING CSL-CON-HANDLE
CSL-RC.
IF CSL-RC = CS-FAIL
THEN
MOVE SPACES TO MSGSTR
STRING 'CTBCONDR failed'
DELIMITED BY SIZE INTO MSGSTR
PERFORM PRINT-MSG
END-IF.
CLOSE-CONNECTION-EXIT.
EXIT.
*===================================================
*== ==
*== Subroutine to perform exit client library and ==
*== deallocate context structure. ==
*== ==
*===================================================
QUIT-CLIENT-LIBRARY.
***************************
* EXIT THE CLIENT LIBRARY *
***************************
CALL 'CTBEXIT' USING CSL-CTX-HANDLE
CSL-RC
CS-UNUSED.
IF CSL-RC = CS-FAIL
THEN
MOVE SPACES TO MSGSTR
STRING 'CTBEXIT failed'
DELIMITED BY SIZE INTO MSGSTR
PERFORM PRINT-MSG
END-IF.
*************************************
* DE-ALLOCATE THE CONTEXT STRUCTURE *
*************************************
CALL 'CSBCTXDR' USING CSL-CTX-HANDLE
CSL-RC.
IF CSL-RC = CS-FAIL
THEN
MOVE SPACES TO MSGSTR
STRING 'CSBCTXDR failed'
DELIMITED BY SIZE INTO MSGSTR
PERFORM PRINT-MSG
END-IF.
QUIT-CLIENT-LIBRARY-EXIT.
EXIT.
*====================================================
*== ==
*== Subroutine to retrieve any diagnostic messages ==
*== ==
*====================================================
GET-DIAG-MESSAGES.
************************************
* Disable calls to this subroutine *
************************************
MOVE 'N' TO SW-DIAG.
******************************
* First, get client messages *
******************************
CALL 'CTBDIAG' USING CSL-CON-HANDLE,
CSL-RC,
CS-UNUSED,
CS-STATUS,
CS-CLIENTMSG-TYPE,
CS-UNUSED,
DF-NUM-OF-MSGS.
IF CSL-RC NOT EQUAL CS-SUCCEED
THEN
MOVE SPACES TO MSGSTR
STRING 'CTBDIAG CS-STATUS CS-CLIENTMSG-TYPE failed'
DELIMITED BY SIZE INTO MSGSTR
PERFORM PRINT-MSG
PERFORM ALL-DONE
ELSE
IF DF-NUM-OF-MSGS > 0
THEN
PERFORM RETRIEVE-CLIENT-MSGS
VARYING I FROM 1 BY 1
UNTIL I IS GREATER THAN DF-NUM-OF-MSGS
END-IF
END-IF.
*****************************
* Then, get server messages *
*****************************
CALL 'CTBDIAG' USING CSL-CON-HANDLE,
CSL-RC,
CS-UNUSED,
CS-STATUS,
CS-SERVERMSG-TYPE,
CS-UNUSED,
DF-NUM-OF-MSGS.
IF CSL-RC NOT EQUAL CS-SUCCEED
THEN
STRING 'CTBDIAG CS-STATUS CS-SERVERMSG-TYPE failed'
DELIMITED BY SIZE INTO MSGSTR
PERFORM PRINT-MSG
PERFORM ALL-DONE
ELSE
IF DF-NUM-OF-MSGS > 0
THEN
PERFORM RETRIEVE-SERVER-MSGS
VARYING I FROM 1 BY 1
UNTIL I IS GREATER THAN DF-NUM-OF-MSGS
END-IF
END-IF.
GET-DIAG-MESSAGES-EXIT.
EXIT.
*============================================================
*== ==
*== Subroutine to retrieve diagnostic messages from client ==
*== ==
*============================================================
RETRIEVE-CLIENT-MSGS.
MOVE 1 TO I1.
CALL 'CTBDIAG' USING CSL-CON-HANDLE,
CSL-RC,
CS-UNUSED,
CS-GET,
CS-CLIENTMSG-TYPE,
DF-MSGNO,
CLIENT-MSG.
IF CSL-RC NOT EQUAL CS-SUCCEED
THEN
MOVE SPACES TO MSGSTR
STRING 'CTBDIAG CS-GET CS-CLIENTMSG-TYPE failed'
DELIMITED BY SIZE INTO MSGSTR
PERFORM PRINT-MSG
PERFORM ALL-DONE
END-IF.
************************
* display message text *
************************
MOVE DISP-CLIENT-MSG-HDR TO RSLTNO( I1 ).
MOVE 3 TO I1.
MOVE CM-SEVERITY TO CM-SEVERITY-DATA.
MOVE CM-STATUS TO CM-STATUS-DATA.
MOVE DISP-CLIENT-MSG-1 TO RSLTNO( I1 ).
COMPUTE I1 EQUAL I1 + 1
MOVE CM-MSGNO TO CM-OC-MSGNO-DATA.
MOVE DISP-CLIENT-MSG-2 TO RSLTNO( I1 ).
COMPUTE I1 EQUAL I1 + 1
IF CM-MSGNO NOT EQUAL 0
THEN
MOVE SPACES TO CM-OC-MSG-DATA
MOVE CM-TEXT TO CM-OC-MSG-DATA
MOVE CM-TEXT TO DISP-CLIENT-MSG-3A
MOVE DISP-CLIENT-MSG-3 TO RSLTNO( I1 )
COMPUTE I1 EQUAL I1 + 1
IF CM-TEXT-LEN > 66
THEN
MOVE CM-OC-MSG-DATA-2 TO CM-OC-MSG-DATA-X
MOVE DISP-CLIENT-MSG-3B TO RSLTNO( I1 )
COMPUTE I1 EQUAL I1 + 1
IF CM-TEXT-LEN > 132
THEN
MOVE SPACES TO CM-OC-MSG-DATA-X
MOVE CM-OC-MSG-DATA-3 TO CM-OC-MSG-DATA-X
MOVE DISP-CLIENT-MSG-3B TO RSLTNO( I1 )
COMPUTE I1 EQUAL I1 + 1
IF CM-TEXT-LEN > 198
THEN
MOVE SPACES TO CM-OC-MSG-DATA-X
MOVE CM-OC-MSG-DATA-4 TO CM-OC-MSG-DATA-X
MOVE DISP-CLIENT-MSG-3B TO RSLTNO( I1 )
COMPUTE I1 EQUAL I1 + 1
END-IF
END-IF
END-IF
ELSE
MOVE DISP-EMPTY-CLIENT-MSG-3 TO RSLTNO( I1 )
COMPUTE I1 EQUAL I1 + 1
END-IF.
MOVE CM-OS-MSGNO TO CM-OS-MSGNO-DATA.
MOVE DISP-CLIENT-MSG-4 TO RSLTNO( I1 ).
COMPUTE I1 EQUAL I1 + 1
IF CM-OS-MSGNO NOT EQUAL 0
THEN
MOVE SPACES TO CM-OS-MSG-DATA
MOVE CM-OS-MSGTXT TO CM-OS-MSG-DATA
MOVE SPACES TO DISP-CLIENT-MSG-5A
MOVE CM-OS-MSGTXT TO DISP-CLIENT-MSG-5A
MOVE DISP-CLIENT-MSG-5 TO RSLTNO( I1 )
COMPUTE I1 EQUAL I1 + 1
IF CM-OS-MSGTEXT-LEN > 66
THEN
MOVE SPACES TO CM-OC-MSG-DATA-X
MOVE CM-OS-MSG-DATA-2 TO CM-OC-MSG-DATA-X
MOVE DISP-CLIENT-MSG-3B TO RSLTNO( I1 )
COMPUTE I1 EQUAL I1 + 1
IF CM-OS-MSGTEXT-LEN > 132
THEN
MOVE SPACES TO CM-OC-MSG-DATA-X
MOVE CM-OS-MSG-DATA-3 TO CM-OC-MSG-DATA-X
MOVE DISP-CLIENT-MSG-3B TO RSLTNO( I1 )
COMPUTE I1 EQUAL I1 + 1
IF CM-OS-MSGTEXT-LEN > 198
THEN
MOVE SPACES TO CM-OC-MSG-DATA-X
MOVE CM-OS-MSG-DATA-4 TO CM-OC-MSG-DATA-X
MOVE DISP-CLIENT-MSG-3B TO RSLTNO( I1 )
COMPUTE I1 EQUAL I1 + 1
END-IF
END-IF
END-IF
ELSE
MOVE DISP-EMPTY-CLIENT-MSG-5 TO RSLTNO( I1 )
COMPUTE I1 EQUAL I1 + 1
END-IF.
RETRIEVE-CLIENT-MSGS-EXIT.
EXIT.
*============================================================
*== ==
*== Subroutine to retrieve diagnostic messages from server ==
*== ==
*============================================================
RETRIEVE-SERVER-MSGS.
CALL 'CTBDIAG' USING CSL-CON-HANDLE,
CSL-RC,
CS-UNUSED,
CS-GET,
CS-SERVERMSG-TYPE,
DF-MSGNO,
SERVER-MSG.
IF CSL-RC NOT EQUAL CS-SUCCEED
THEN
MOVE SPACES TO MSGSTR
STRING 'CTBDIAG CS-GET CS-SERVERMSG-TYPE failed'
DELIMITED BY SIZE INTO MSGSTR
PERFORM PRINT-MSG
PERFORM ALL-DONE
END-IF.
************************
* display message text *
************************
MOVE SM-MSGNO TO SM-MSG-NO-DATA.
MOVE SM-SEV TO SM-SEVERITY-DATA.
MOVE SM-STATE TO SM-STATE-DATA.
MOVE SM-LINE TO SM-LINE-NO-DATA.
MOVE SM-STATUS TO SM-STATUS-DATA.
MOVE SPACES TO SM-SVRNAME-DATA.
MOVE SM-SVRNAME TO SM-SVRNAME-DATA.
MOVE SPACES TO SM-PROC-ID-DATA.
MOVE SM-PROC TO SM-PROC-ID-DATA.
MOVE SPACES TO SM-MSG-DATA.
MOVE SM-TEXT TO SM-MSG-DATA.
MOVE SPACES TO DISP-SERVER-MSG-5A.
MOVE SM-TEXT TO DISP-SERVER-MSG-5A.
MOVE DISP-SERVER-MSG-HDR TO RSLTNO (1).
MOVE DISP-SERVER-MSG-1 TO RSLTNO (3).
MOVE DISP-SERVER-MSG-2 TO RSLTNO (4).
MOVE DISP-SERVER-MSG-3 TO RSLTNO (5).
MOVE DISP-SERVER-MSG-4 TO RSLTNO (6).
MOVE DISP-SERVER-MSG-5 TO RSLTNO (7).
IF SM-TEXT-LEN > 66
THEN
MOVE SPACES TO SM-MSG-DATA-X
MOVE SM-MSG-DATA-2 TO SM-MSG-DATA-X
MOVE DISP-SERVER-MSG-5X TO RSLTNO(8)
IF SM-TEXT-LEN > 132
THEN
MOVE SPACES TO SM-MSG-DATA-X
MOVE SM-MSG-DATA-3 TO SM-MSG-DATA-X
MOVE DISP-SERVER-MSG-5X TO RSLTNO(9)
IF SM-TEXT-LEN > 198
THEN
MOVE SPACES TO SM-MSG-DATA-X
MOVE SM-MSG-DATA-4 TO SM-MSG-DATA-X
MOVE DISP-SERVER-MSG-5X TO RSLTNO(10)
END-IF
END-IF
END-IF.
RETRIEVE-SERVER-MSGS-EXIT.
EXIT.
*========================================================
*== ==
*== Subroutine to clear the output screen ==
*== ==
*========================================================
CLEAR-SCREEN-DATA.
MOVE SPACES TO RSLTNO( I2 ).
CLEAR-SCREEN-DATA-EXIT.
EXIT.
*========================================================
*== ==
*== Subroutine to handle MAPFAIL condition ==
*== ==
*========================================================
NO-INPUT.
*---------
MOVE 'Please Enter Input Fields' TO MSG-TEXT-1.
GO TO GET-INPUT-AGAIN.
*========================================================
*== ==
*== Subroutine to handle AID condition ==
*== ==
*========================================================
GETOUT.
*--------
EXEC CICS RETURN END-EXEC.
STOP RUN.
*========================================================
*== ==
*== Subroutine to handle ERROR condition ==
*== ==
*========================================================
ERRORS.
*--------
EXEC CICS DUMP DUMPCODE('ERRS') END-EXEC.
STOP RUN.
