The purpose of this sample program is to demonstrate:
Explicit conversion of a CS-DECIMAL type column on the server to IBM packed decimal
Explicit conversion of a CS-DATETIME column on the server to CHAR DATE format
Explicit conversion of a VARCHAR datatype to CHAR datatype.
This sample program retrieves information from the table SYBASE.NEWTABLE on the target server.
*@(#) syctsap5.cobol 1.2 4/9/96 */
*******************************************************************
*
* Confidential property of Sybase, Inc.
* (c) Copyright Sybase, Inc. 1985 TO 1997.
* All rights reserved.
*
*******************************************************************
******* SYCTSAP5 - Client Language Request APPL - COBOL - CICS **
**
** CICS TRANID: SYP5
**
** PROGRAM: SYCTSAP5
**
** PURPOSE: Demonstrates Open Client for CICS CALLs.
**
** FUNCTION: Illustrates how to send a language request with
** parameters to:
**
** - A SQL Server
**
** Illustrates the explicit conversion of:
** VARCHAR to CHAR data type
** DECIMAL to PACKED DECIMAL data type
** DATETIME to CHAR data type
**
** SQL Server:
**
** If the request is sent to a SQL Server it
** executes the SQL statement:
**
** SELECT FIRSTNME, MILAGE, SERVICEDATE
** FROM SYBASE.NEWTABLE
**
** Note: The Net-Gateway/MCG product includes a script
** that creates this procedure in a target SQL
** server.
**
** PREREQS: Before running SYCTSAP5, 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.
**
** Open Client CALLs used in this sample:
**
** CSBCONVERT convert a datatype from one value to another
** CSBCTXALLOC allocate a context
** CSBCTXDROP drop a context
** CTBBIND bind a column variable
** CTBCLOSE close a server connection
** CTBCONFIG set or retrieve context properties
** 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
** CTBRESINFO return RESULT set info
** CTBSEND send a request TO the server
**
******************************************************************
IDENTIFICATION DIVISION.
PROGRAM-ID. SYCTSAP5.
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 C-N PIC X(01) VALUE 'N'.
01 C-Y PIC X(01) VALUE 'Y'.
01 I1 PIC S9(9) COMP SYNC VALUE IS 0.
01 I2 PIC S9(9) COMP SYNC VALUE IS 0.
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 MAX-SCREEN-ROWS PIC S9(4) VALUE +10.
01 ENTER-DATA-SW PIC X(01) VALUE 'N'.
*****************************************************************
* OPEN CLIENT VARIABLES
*****************************************************************
01 STRLEN PIC S9(9) COMP VALUE +0.
01 OUTLEN PIC S9(9) COMP VALUE +0.
01 RESTYPE PIC S9(9) COMP VALUE +0.
01 NETDRIVER PIC S9(9) COMP VALUE +9999.
**----------------------------------------------------------------
** WORK AREAS
**----------------------------------------------------------------
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 INTERNAL-FIELDS.
05 I PIC S9(9) COMP.
05 CF-FOUR PIC S9(9) COMP VALUE +4.
05 CF-LANG2-SIZE PIC S9(9) COMP VALUE +85.
05 DATA-PACKED370 PIC S9(15)V9(3) COMP-3 VALUE +0.
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-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-STRLEN PIC S9(9) COMP.
05 PF-MSGLIMIT PIC S9(9) COMP.
01 DIAG-FIELDS.
05 DG-MSGNO PIC S9(9) COMP VALUE +1.
05 DG-NUM-OF-MSGS PIC S9(9) COMP VALUE +0.
01 CONFIG-FIELDS.
05 CF-MAXCONNECT PIC S9(9) COMP.
05 CF-OUTLEN PIC S9(9) COMP.
01 FETCH-FIELDS.
05 FF-ROWS-READ PIC S9(9) COMP.
05 FF-ROW-NUM PIC S9(9) COMP VALUE +0.
01 RESINFO-FIELDS.
05 RF-NUMDATA PIC S9(9) COMP.
05 RF-NUMDATA-SIZE PIC S9(9) COMP VALUE +4.
01 OUTPUT-ROW.
05 OR-COL-FIRSTNME-CHAR PIC X(12).
05 SPACE1 PIC X(01) VALUE ' '.
05 OR-COL-MILAGE PIC -9(16).9(2) VALUE '+0'.
05 SPACE1 PIC X(12) VALUE ' '.
05 OR-COL-SERVICEDATE PIC X(25) VALUE ' '.
01 OUTPUT-ROW-STR REDEFINES OUTPUT-ROW PIC X(70).
01 OUTPUT-ROW-SIZE PIC S9(4) COMP VALUE +70.
01 OUTPUT-ROW2.
05 OR2-MESG PIC X(37)
VALUE 'The maximum number of connections is '.
05 OR2-MAXCONNECT PIC ZZZZ9.
05 OR2-PERIOD PIC X(01) VALUE '.'.
01 OUTPUT-ROW-STR2 REDEFINES OUTPUT-ROW2 PIC X(43).
01 OUTPUT-ROW2-SIZE PIC S9(4) COMP VALUE +43.
01 OUTPUT-ROW4.
05 OR4-MESG PIC X(25)
VALUE 'The number of columns is '.
05 OR4-NUMDATA PIC ZZZZ9.
05 OR4-PERIOD PIC X(01) VALUE '.'.
01 OUTPUT-ROW-STR4 REDEFINES OUTPUT-ROW4 PIC X(31).
01 OUTPUT-ROW4-SIZE PIC S9(4) COMP VALUE +31.
01 COLUMN-FIELDS.
05 CF-COL-FIRSTNME.
10 CF-COL-FIRSTNME-LL PIC S9(9) COMP.
10 CF-COL-FIRSTNME-TXT PIC X(12).
05 CF-COL-FIRSTNME-CHAR PIC X(12).
05 CF-COL-MILAGE.
10 CF-COL-MILAGE-PRECISION PIC X(1) VALUE ' '.
10 CF-COL-MILAGE-SCALE PIC X(1) VALUE ' '.
10 CF-COL-MILAGE-NUMBER PIC X(31).
05 CF-COL-MILAGE-DECFORM PIC S9(15)V9(3) COMP-3 VALUE 0.
05 CF-COL-MILAGE-CHAR PIC X(31) VALUE ' '.
05 CF-COL-SERVICEDATE.
10 CF-COL-DATE PIC S9(4) COMP VALUE 0 .
10 CF-COL-TIME PIC S9(4) COMP VALUE 0.
05 CF-COL-SERVICEDATE-BOUND PIC X(25) VALUE ' '.
05 CF-COL-SERVICEDATE-CHAR PIC X(25) VALUE ' '.
05 CF-COL-LEN PIC S9(9) COMP VALUE 0.
05 CF-COL-NULL PIC S9(9) COMP VALUE +0.
05 CF-COL-NUMBER PIC S9(9) COMP VALUE +1.
05 CF-COL-INDICATOR PIC S9(4) COMP VALUE +0.
01 LANG-FIELDS.
05 CF-LANG1 PIC X(20)
VALUE 'Wrong SQL statement'.
05 CF-LANG2 PIC X(85)
VALUE 'SELECT PLANEID , MILAGE,SERVICEDATE=DATEADD(DAY,20
- ',SERVICEDATE) FROM SYBASE.NEWTABLE'.
05 filler PIC X(01) VALUE LOW-VALUE.
01 MSG-FIELDS.
05 MF-CANCELED PIC X(16)
VALUE 'Cancel requested'.
05 MF-CANCELED-SIZE PIC S9(9) COMP VALUE +16.
01 DATAFMT.
05 DF-NAME PIC X(132).
05 DF-NAMELEN PIC S9(9) COMP.
05 DF-DATATYPE PIC S9(9) COMP.
05 DF-FORMAT PIC S9(9) COMP.
05 DF-MAXLENGTH PIC S9(9) COMP.
05 DF-SCALE PIC S9(9) COMP VALUE 15.
05 DF-PRECISION PIC S9(9) COMP VALUE 31.
05 DF-STATUS PIC S9(9) COMP.
05 DF-COUNT PIC S9(9) COMP.
05 DF-USERTYPE PIC S9(9) COMP.
05 DF-LOCALE PIC X(68).
01 DATAFMT2.
05 DF2-NAME PIC X(132).
05 DF2-NAMELEN PIC S9(9) COMP.
05 DF2-DATATYPE PIC S9(9) COMP.
05 DF2-FORMAT PIC S9(9) COMP.
05 DF2-MAXLENGTH PIC S9(9) COMP.
05 DF2-SCALE PIC S9(9) COMP VALUE 3.
05 DF2-PRECISION PIC S9(9) COMP VALUE 18.
05 DF2-STATUS PIC S9(9) COMP.
05 DF2-COUNT PIC S9(9) COMP.
05 DF2-USERTYPE PIC S9(9) COMP.
05 DF2-LOCALE PIC X(68).
01 DISP-MSG.
05 TEST-CASE PIC X(08) VALUE IS 'SYCTSAP5'.
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 DISP-MSG-LEN PIC S9(4) COMP VALUE IS 65.
01 MSG-LEN VALUE +0 PIC S9(4) COMP .
*******************************
** 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 ZERO TO RESTYPE CSL-RC.
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.
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-TRANSACTION.
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 SYT5 initial screen ==
*== ==
*========================================================
DISPLAY-INITIAL-SCREEN.
*----------------------
MOVE TMP-DATE TO SDATEO.
MOVE TMP-TIME TO STIMEO.
MOVE 'SYCTSAP5' 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-TRANSACTION.
*********************************
* 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 TRANname 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.
***********************************
* SETUP retrieval of All Messages *
***********************************
CALL 'CTBDIAG' USING CSL-CON-HANDLE,
CSL-RC,
CS-UNUSED,
CS-INIT,
CS-ALLMSG-TYPE,
CS-UNUSED,
CS-UNUSED.
IF CSL-RC NOT EQUAL CS-SUCCEED
THEN
MOVE SPACES TO MSGSTR
STRING 'CTBDIAG CS-INIT failed' DELIMITED BY SIZE
INTO MSGSTR
PERFORM PRINT-MSG
PERFORM ALL-DONE
END-IF.
*********************************************
* set the upper limit of number of messages *
*********************************************
MOVE 5 TO PF-MSGLIMIT.
CALL 'CTBDIAG' USING CSL-CON-HANDLE,
CSL-RC,
CS-UNUSED,
CS-MSGLIMIT,
CS-ALLMSG-TYPE,
CS-UNUSED,
PF-MSGLIMIT.
IF CSL-RC NOT EQUAL CS-SUCCEED
THEN
MOVE SPACES TO MSGSTR
STRING 'CTBDIAG CS-MSGLIMIT failed' DELIMITED BY SIZE
INTO MSGSTR
PERFORM PRINT-MSG
PERFORM ALL-DONE
END-IF.
************************************************
* CONNECT TO THE SERVER OR THE IMS/CICS REGION *
************************************************
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-COMMAND
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-TRANSACTION-EXIT.
EXIT.
*========================================================
*== ==
*== Subroutine to allocate, send, and process commands ==
*== ==
*========================================================
SEND-COMMAND.
*--------------------------------------------------------------
* find out what the maximum number of connections is
*--------------------------------------------------------------
CALL 'CTBCONFI' USING CSL-CTX-HANDLE,
CSL-RC,
CS-GET,
CS-MAX-CONNECT,
CF-MAXCONNECT,
CF-FOUR,
CS-FALSE,
CF-OUTLEN.
IF CSL-RC NOT EQUAL CS-SUCCEED
THEN
MOVE SPACES TO MSGSTR
STRING 'CTBCONFI CS-GET failed' DELIMITED BY SIZE
INTO MSGSTR
PERFORM PRINT-MSG
PERFORM ALL-DONE
END-IF.
*--------------------------------------------------------------
* allocate a command 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.
*--------------------------------------------------------------
* prepare the language request
*-------------------------------------------------------------
MOVE CF-LANG2-SIZE TO PF-STRLEN.
CALL 'CTBCOMMA' USING CSL-CMD-HANDLE,
CSL-RC,
CS-LANG-CMD,
CF-LANG2,
PF-STRLEN,
CS-UNUSED.
IF CSL-RC NOT EQUAL CS-SUCCEED
THEN
MOVE SPACES TO MSGSTR
STRING 'CTBCOMMA CS-LANG-CMD failed' DELIMITED BY SIZE
INTO MSGSTR
PERFORM PRINT-MSG
PERFORM ALL-DONE
END-IF.
*-------------------------------------------------------------
* send the language request
*-------------------------------------------------------------
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-COMMAND-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
MOVE 'Y' TO SW-FETCH
***************************************************************
* PROCESS STATUS RESULTS - THE STORED PROCEDURE STATUS RESULT *
* WILL NOT BE PROCESSED IN THIS EXAMPLE *
***************************************************************
WHEN CS-STATUS-RESULT
MOVE 'Y' TO SW-FETCH
*************************************************************
* PRINT AN ERROR MESSAGE IF THE SERVER ENCOUNTERED AN ERROR *
* WHILE EXECUTING THE REQUEST *
*************************************************************
WHEN CS-CMD-FAIL
STRING
'CTBRESUL returned CS-CMD-FAIL restype'
DELIMITED BY SIZE INTO MSGSTR
PERFORM PRINT-MSG
*****************************************************************
* PRINT A MESSAGE 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 MESSAGE 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 UNKNOWN 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 returned CS-FAIL ret-code'
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 returned UNKNOWN ret-code'
DELIMITED BY SIZE INTO MSGSTR
PERFORM PRINT-MSG
END-EVALUATE.
MOVE 0 TO RESTYPE.
RESULTS-PROCESSING-EXIT.
EXIT.
*========================================================
*== ==
*== Subroutine to process result rows ==
*== ==
*========================================================
RESULT-ROW-PROCESSING.
CALL 'CTBRESIN' USING CSL-CMD-HANDLE,
CSL-RC,
CS-NUMDATA,
RF-NUMDATA,
RF-NUMDATA-SIZE,
CF-COL-LEN.
IF CSL-RC NOT EQUAL CS-SUCCEED
THEN
MOVE SPACES TO MSGSTR
STRING 'CTBRESINFO failed' DELIMITED BY SIZE
INTO MSGSTR
PERFORM PRINT-MSG
PERFORM ALL-DONE
END-IF.
COMPUTE FF-ROW-NUM = FF-ROW-NUM + 1.
*********************************
* display number of connections *
*********************************
MOVE CF-MAXCONNECT TO OR2-MAXCONNECT.
MOVE OUTPUT-ROW-STR2 TO RSLTNO(FF-ROW-NUM).
COMPUTE FF-ROW-NUM = FF-ROW-NUM + 2.
*********************************
* display the number of columns *
*********************************
MOVE RF-NUMDATA TO OR4-NUMDATA.
MOVE OUTPUT-ROW-STR4 TO RSLTNO(FF-ROW-NUM).
IF RF-NUMDATA NOT EQUAL 3
THEN
STRING 'CTBRESINFO returned wrong # of parms' DELIMITED
BY SIZE INTO MSGSTR
PERFORM PRINT-MSG
PERFORM ALL-DONE
END-IF.
COMPUTE FF-ROW-NUM = FF-ROW-NUM + 2.
**------------------------------------------------------------
** Setup column headings
**------------------------------------------------------------
MOVE ' PLANEID Milage Servic
- 'e Date' TO RSLTNO(FF-ROW-NUM).
COMPUTE FF-ROW-NUM = FF-ROW-NUM + 1.
MOVE '============ =============================== ==========
- '===============' TO RSLTNO(FF-ROW-NUM).
PERFORM BIND-COLUMNS
VARYING I FROM 1 BY 1
UNTIL I IS GREATER THAN RF-NUMDATA.
RESULT-ROW-PROCESSING-EXIT.
EXIT.
*========================================================
*== ==
*== Subroutine to bind each data ==
*== ==
*========================================================
BIND-COLUMNS.
CALL 'CTBDESCR' USING CSL-CMD-HANDLE,
CSL-RC,
I,
DATAFMT.
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.
**--------------------------------------------------------
** We need to bind the data to program variables.
** We don't care about the indicator variable
** so we'll pass NULL for that parameter in OC-BIND().
**--------------------------------------------------------
******************
* ROWs per FETCH *
******************
MOVE 1 TO DF-COUNT
EVALUATE DF-DATATYPE
WHEN CS-DECIMAL-TYPE
MOVE LENGTH OF CF-COL-MILAGE TO DF-MAXLENGTH
CALL 'CTBBIND' USING CSL-CMD-HANDLE,
CSL-RC,
I,
DATAFMT,
CF-COL-MILAGE-NUMBER
CF-COL-LEN,
CS-PARAM-NOTNULL,
CF-COL-INDICATOR,
CS-PARAM-NULL
IF CSL-RC NOT EQUAL CS-SUCCEED
THEN
MOVE SPACES TO MSGSTR
STRING 'CTBBIND CS-DECIMAL-TYPE Filed' DELIMITED
BY SIZE INTO MSGSTR
PERFORM PRINT-MSG
PERFORM ALL-DONE
END-IF
WHEN CS-VARCHAR-TYPE
MOVE LENGTH OF CF-COL-FIRSTNME-TXT TO DF-MAXLENGTH
CALL 'CTBBIND' USING CSL-CMD-HANDLE,
CSL-RC,
I,
DATAFMT,
CF-COL-FIRSTNME,
CF-COL-LEN,
CS-PARAM-NOTNULL,
CF-COL-INDICATOR,
CS-PARAM-NULL
IF CSL-RC NOT EQUAL CS-SUCCEED
THEN
MOVE SPACES TO MSGSTR
STRING 'CTBBIND CS-VARCHAR-TYPE failed' DELIMITED
BY SIZE INTO MSGSTR
PERFORM PRINT-MSG
PERFORM ALL-DONE
END-IF
WHEN CS-DATETIME-TYPE
MOVE LENGTH OF CF-COL-SERVICEDATE-BOUND
TO DF-MAXLENGTH
MOVE LENGTH OF CF-COL-SERVICEDATE-BOUND TO CF-COL-LEN
CALL 'CTBBIND' USING CSL-CMD-HANDLE,
CSL-RC,
I,
DATAFMT,
CF-COL-SERVICEDATE-BOUND,
CF-COL-LEN,
CS-PARAM-NOTNULL,
CF-COL-INDICATOR,
CS-PARAM-NULL
IF CSL-RC NOT EQUAL CS-SUCCEED
THEN
MOVE SPACES TO MSGSTR
STRING 'CTBBIND CS-DATETIME-TYPE failed' DELIMITED
BY SIZE INTO MSGSTR
PERFORM PRINT-MSG
PERFORM ALL-DONE
END-IF.
BIND-COLUMNS-EXIT.
EXIT.
*========================================================
*== ==
*== Subroutine to fetch row processing ==
*== ==
*========================================================
FETCH-ROW-PROCESSING.
CALL 'CTBFETCH' USING CSL-CMD-HANDLE,
CSL-RC,
CS-UNUSED,
CS-UNUSED,
CS-UNUSED,
FF-ROWS-READ.
EVALUATE CSL-RC
WHEN CS-SUCCEED
MOVE 'Y' TO SW-FETCH
MOVE CS-VARCHAR-TYPE TO DF-DATATYPE
MOVE LENGTH OF CF-COL-FIRSTNME-TXT
TO DF-MAXLENGTH
MOVE CS-CHAR-TYPE TO DF2-DATATYPE
MOVE LENGTH OF CF-COL-FIRSTNME-CHAR
TO DF2-MAXLENGTH
CALL 'CSBCONVE' USING CSL-CTX-HANDLE,
CSL-RC,
DATAFMT,
CF-COL-FIRSTNME,
DATAFMT2,
CF-COL-FIRSTNME-CHAR,
CF-COL-LEN
IF CSL-RC NOT EQUAL CS-SUCCEED
THEN
MOVE SPACES TO MSGSTR
STRING 'CSBCONVERT CS-VARCHAR-TYPE failed'
DELIMITED BY SIZE INTO MSGSTR
PERFORM PRINT-MSG
PERFORM ALL-DONE
END-IF
MOVE CS-DECIMAL-TYPE TO DF-DATATYPE
* MOVE LENGTH OF CF-COL-MILAGE-NUMBER
*
MOVE 35 TO DF-MAXLENGTH
MOVE CS-PACKED370-TYPE TO DF2-DATATYPE
MOVE LENGTH OF CF-COL-MILAGE-DECFORM
TO DF2-MAXLENGTH
CALL 'CSBCONVE' USING CSL-CTX-HANDLE,
CSL-RC,
DATAFMT,
CF-COL-MILAGE-NUMBER,
DATAFMT2,
CF-COL-MILAGE-DECFORM,
CF-COL-LEN
IF CSL-RC NOT EQUAL CS-SUCCEED
THEN
MOVE SPACES TO MSGSTR
STRING 'CSBCONVERT from CS_DECIMAL to CS-PACKED
- '370-TYPE FAILED'
DELIMITED BY SIZE INTO MSGSTR
PERFORM PRINT-MSG
PERFORM ALL-DONE
END-IF
MOVE LENGTH OF CF-COL-SERVICEDATE-BOUND
TO DF-MAXLENGTH
MOVE CS-DATETIME-TYPE TO DF-DATATYPE
MOVE CS-CHAR-TYPE TO DF2-DATATYPE
MOVE LENGTH OF CF-COL-SERVICEDATE-CHAR
TO DF2-MAXLENGTH
CALL 'CSBCONVE' USING CSL-CTX-HANDLE,
CSL-RC,
DATAFMT,
CF-COL-SERVICEDATE-BOUND,
DATAFMT2,
CF-COL-SERVICEDATE-CHAR,
CF-COL-LEN
IF CSL-RC NOT EQUAL CS-SUCCEED
THEN
MOVE SPACES TO MSGSTR
STRING 'CSBCONVERT from DATETIME to CS-CHAR f
- 'ailed'
DELIMITED BY SIZE INTO MSGSTR
PERFORM PRINT-MSG
PERFORM ALL-DONE
END-IF
COMPUTE FF-ROW-NUM = FF-ROW-NUM + 1
**************************************
* save ROW RESULTS for later display *
**************************************
MOVE CF-COL-FIRSTNME-CHAR TO
OR-COL-FIRSTNME-CHAR
MOVE CF-COL-MILAGE-DECFORM TO
OR-COL-MILAGE
MOVE CF-COL-SERVICEDATE-CHAR TO
OR-COL-SERVICEDATE
IF FF-ROW-NUM > MAX-SCREEN-ROWS
THEN
STRING 'Please press return for more data.'
DELIMITED BY SIZE INTO MSG1O
PERFORM DISP-DATA
PERFORM CLEAR-SCREEN-DATA
VARYING I2 FROM 1 BY 1
UNTIL I2 > MAX-SCREEN-ROWS
MOVE 1 TO FF-ROW-NUM
**------------------------------------------------------------
** Setup column headings
**------------------------------------------------------------
MOVE ' PLANEID Milage
- ' Service Date '
TO RSLTNO(FF-ROW-NUM)
COMPUTE FF-ROW-NUM = FF-ROW-NUM + 1
MOVE '============ =============================
- '== ========================'
TO RSLTNO(FF-ROW-NUM)
COMPUTE FF-ROW-NUM = FF-ROW-NUM + 1
END-IF
MOVE OUTPUT-ROW-STR TO RSLTNO(FF-ROW-NUM)
MOVE SPACES TO CF-COL-FIRSTNME-TXT
WHEN CS-END-DATA
MOVE SPACES TO MSG1O
MOVE 'N' TO SW-FETCH
STRING 'All rows processing completed!'
DELIMITED BY SIZE INTO MSG1O
PERFORM DISP-DATA
WHEN CS-FAIL
MOVE 'N' TO SW-FETCH
MOVE SPACES TO MSGSTR
STRING 'CTBFETCH returned CS-FAIL ret-code'
DELIMITED BY SIZE INTO MSGSTR
PERFORM PRINT-MSG
WHEN CS-ROW-FAIL
MOVE 'N' TO SW-FETCH
MOVE SPACES TO MSGSTR
STRING 'CTBFETCH returned CS-ROW-FAIL ret-code'
DELIMITED BY SIZE INTO MSGSTR
PERFORM PRINT-MSG
WHEN CS-CANCELLED
MOVE 'N' TO SW-FETCH
MOVE MF-CANCELED TO MSG1O
PERFORM PRINT-MSG
WHEN OTHER
MOVE 'N' TO SW-FETCH
MOVE SPACES TO MSGSTR
STRING 'CTBFETCH returned UNKNOWN ret-code'
DELIMITED BY SIZE INTO MSGSTR
PERFORM PRINT-MSG
END-EVALUATE.
FETCH-ROW-PROCESSING-EXIT.
EXIT.
*========================================================
*== ==
*== Subroutine to tell CICS to send output messages ==
*== ==
*========================================================
DISP-DATA.
*********************************************************
* PRINT ALL THE RETURNED ROWS FROM THE STORED PROCEDURE *
*********************************************************
MOVE TMP-DATE TO SDATEO.
MOVE TMP-TIME TO STIMEO.
MOVE 'SYCTSAP5' 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 LOW-VALUES TO A5PANELO.
MOVE CSL-RC TO SAMP-RC.
MOVE RESTYPE TO REST-TYPE.
IF DIAG-MSGS-INITIALIZED
THEN
PERFORM GET-DIAG-MESSAGES
END-IF.
***********************
* DISPLAY THE MESSAGE *
***********************
MOVE DISP-MSG TO MSG1O.
IF NO-ERRORS
THEN
PERFORM DISP-DATA.
MOVE C-Y TO NO-ERRORS-SW.
MOVE SPACES TO MSGSTR.
MOVE SPACES TO MSG1O.
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,
DG-NUM-OF-MSGS.
IF CSL-RC NOT EQUAL CS-SUCCEED
THEN
MOVE SPACES TO MSGSTR
STRING 'CTBDIAG CS-STATUS CS-CLIENTMSG-TYP fail'
DELIMITED BY SIZE INTO MSGSTR
PERFORM PRINT-MSG
PERFORM ALL-DONE
ELSE
IF DG-NUM-OF-MSGS > 0
THEN
PERFORM RETRIEVE-CLIENT-MSGS
VARYING I FROM 1 BY 1
UNTIL I IS GREATER THAN DG-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,
DG-NUM-OF-MSGS.
IF CSL-RC NOT EQUAL CS-SUCCEED
THEN
STRING 'CTBDIAG CS-STATUS CS-SERVERMSG-TYP fail'
DELIMITED BY SIZE INTO MSGSTR
PERFORM PRINT-MSG
PERFORM ALL-DONE
ELSE
IF DG-NUM-OF-MSGS > 0
THEN
PERFORM RETRIEVE-SERVER-MSGS
VARYING I FROM 1 BY 1
UNTIL I IS GREATER THAN DG-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,
DG-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,
DG-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.
