DSN8SCM
FUNCTION = THIS MODULE DISPLAYS AN APPLICATION SELECTION PANEL.
IDENTIFICATION DIVISION.
*------------------------
PROGRAM-ID. DSN8SCM.
******* DSN8SCM - ISPF COBOL CONNECTION MANAGER ****************
* *
* MODULE NAME = DSN8SCM *
* *
* DESCRIPTIVE *
* NAME = DB2 SAMPLE APPLICATION *
* ISPF DB2 CONNECTION MANAGER *
* ISPF/TSO *
* COBOL *
* *
*COPYRIGHT = 5615-DB2 (C) COPYRIGHT IBM CORP 1982, 2013 *
*SEE COPYRIGHT INSTRUCTIONS *
*LICENSED MATERIALS - PROPERTY OF IBM *
* *
*STATUS = VERSION 11 *
* *
* FUNCTION = THIS MODULE DISPLAYS AN APPLICATION *
* SELECTION PANEL. THE SELECTED APPLICATION *
* IS INVOKED USING THE CALL ATTACH FACILITY. *
* *
* NOTES = NONE *
* *
* MODULE TYPE = *
* PROCESSOR = DB2 PREPROCESSOR, COBOL COMPILER *
* MODULE SIZE = SEE LINKEDIT *
* ATTRIBUTES = REUSABLE *
* *
* ENTRY POINT = DSN8SCMN *
* PURPOSE = SEE FUNCTION *
* LINKAGE = ISPF *
* *
* INPUT = PARAMETERS EXPLICITLY PASSED TO THIS PRGRAM: *
* *
* SYMBOLIC LABEL/NAME = NONE *
* DESCRIPTION = NOT APPLICABLE *
* *
* OUTPUT = PARAMETERS EXPLICITLY RETURNED: *
* *
* SYMBOLIC LABEL/NAME = NONE *
* DESCRIPTION = NOT APPLICABLE *
* *
* EXIT-NORMAL = RETURN CODE 0 *
* *
* EXIT-ERROR = *
* *
* RETURN CODE = NONE *
* *
* ABEND CODES = NONE *
* *
* ERROR *
* MESSAGES = *
* *
* DSN8080E APPLICATION TERMINATED WITH CALL ATTACH *
* REASON CODE ........ *
* DSN8081E RESULTS FROM THE CALL ATTACH TRANSLATE *
* SERVICE *
* DSN8082E THE DISCONNECT TERMINATED WITH REASON *
* CODE ........ *
* DSN8083E AN UNKNOWN SERVICE ............ WAS *
* REQUESTED *
* *
* THE VALUES REPRESENTED BY PERIODS ARE VALUES FILLED IN *
* AT THE TIME OF ERROR *
* *
* EXTERNAL *
* REFERENCES = *
* ROUTINES/ *
* SERVICES = ISPLINK - ISPF SERVICES *
* *
* DATA-AREAS = NONE *
* *
* CONTROL *
* BLOCKS = NONE *
* *
* TABLES = NONE *
* *
* CHANGE *
* ACTIVITY = NONE *
* *
* *
* *PSEUDOCODE* *
* *
* DECLARATIONS *
* INITIALIZATION *
* DO UNTIL EXIT *
* DISPLAY APPLICATION SELECTION PANEL *
* IF END IS REQUESTED THEN *
* --DO *
* | EXIT = YES *
* | IF CONNECT THEN *
* | --DO *
* | | DISCONNECT FROM DB2 *
* | | IF DISCONNECT FAILED THEN *
* | | DISPLAY LINE MODE MESSAGE *
* | --END *
* --END *
* IF ^EXIT THEN *
* --DO *
* | IF (CONNECTED TO DB2)&(SSID ^= CONNECTED SSID) THEN *
* | --DO *
* | | DISCONNECT FROM DB2 *
* | | IF DISCONNECT SUCCESSFUL THEN *
* | | | CONNECTED = NO *
* | | ELSE *
* | | --DO *
* | | | CONTINUE = NO *
* | | | PUT REASON CODE OUT *
* | | --END *
* | --END *
* | IF (^CONNECTED TO DB2) & (CONTINUE) THEN *
* | --DO *
* | | CONNECTION TO DB2 *
* | | IF CONNECTION IS SUCCESSFUL THEN *
* | | --DO *
* | | | SAVE CONNECTED SSID *
* | | | CONTINUE = YES *
* | | | CONNECT = YES *
* | | --END *
* | | ELSE *
* | | --DO *
* | | | CONTINUE = NO *
* | | | PUT OUT REASON CODE *
* | | --END *
* | --END *
* | IF CONTINUE THEN *
* | --DO *
* | | OPEN *
* | | IF OPEN IS SUCCESSFUL THEN *
* | | CONTINUE = YES *
* | | ELSE *
* | | --DO *
* | | | TRANSLATE *
* | | | CONTINUE = NO *
* | | | PUT OUT REASON CODE AND SQLCA *
* | | --END *
* | --END *
* | IF CONTINUE THEN *
* | --DO *
* | | ISPLINK TO THE APPLICATION PROGRAM *
* | | IF BAD RETURN THEN *
* | | --DO *
* | | | SPECIFY 'ABRT' AS THE TERMINATION OPTION *
* | | | PUT REASON CODE OUT *
* | | --END *
* | | ELSE *
* | | SPECIFY 'SYNC' AS THE TERMINATION OPTION *
* | --END *
* | IF CONTINUE THEN *
* | --DO *
* | | CLOSE *
* | | IF CLOSE FAILS THEN *
* | | IF CAF-RESET THEN *
* | | CONNECTED = NO *
* | | PUT REASON CODE OUT *
* | --END *
* --END *
* END *
****************************************************************
/
ENVIRONMENT DIVISION.
*------------------------
INPUT-OUTPUT SECTION.
FILE-CONTROL.
SELECT MSGOUT ASSIGN TO UT-S-SYSPRINT.
DATA DIVISION.
*------------------------
FILE SECTION.
FD MSGOUT
RECORD CONTAINS 71 CHARACTERS
LABEL RECORDS ARE OMITTED.
01 MSGREC PIC X(71).
WORKING-STORAGE SECTION.
77 COIBM PIC X(54) VALUE
'COPYRIGHT = 5740-XYR (C) COPYRIGHT IBM CORP 1982, 1987'.
****************************************************************
* CONDITION CHECKING FLAGS *
****************************************************************
77 YES-IND PIC X(01) VALUE 'Y'.
77 NO-IND PIC X(01) VALUE 'N'.
****************************************************************
* REASON CODE WHEN CAF HAS CLEANED UP- AFTER DB2 DOWN SITUATION*
****************************************************************
77 CAF-RESET PIC X(08) VALUE '00C10824'.
****************************************************************
* ERROR MESSAGE *
****************************************************************
77 MSG1 PIC X(51)
VALUE 'APPLICATION TERMINATED WITH CALL ATTACH REASON CODE'.
****************************************************************
* ISPF DIALOG VARIABLES LENGTH DECLARATIONS *
****************************************************************
77 SSID-LEN PIC 9(06) VALUE 4 COMP.
77 PROG-LEN PIC 9(06) VALUE 8 COMP.
77 PLAN-LEN PIC 9(06) VALUE 8 COMP.
77 RETC-LEN PIC 9(06) VALUE 8 COMP.
77 REAS-LEN PIC 9(06) VALUE 8 COMP.
77 MSGS-LEN PIC 9(06) VALUE 71 COMP.
77 SQCA-LEN PIC 9(06) VALUE 136 COMP.
77 TECB-LEN PIC 9(06) VALUE 4 COMP.
77 SECB-LEN PIC 9(06) VALUE 4 COMP.
77 TERM-LEN PIC 9(06) VALUE 4 COMP.
77 ACTN-LEN PIC 9(06) VALUE 12 COMP.
77 SERV-LEN PIC 9(06) VALUE 12 COMP.
****************************************************************
* ISPF DIALOG VARIABLE NAMES *
****************************************************************
77 SSID-NAME PIC X(08) VALUE 'DSN8SSID'.
77 PROG-NAME PIC X(08) VALUE 'DSN8PROG'.
77 PLAN-NAME PIC X(08) VALUE 'DSN8PLAN'.
77 RETC-NAME PIC X(08) VALUE 'DSN8RETC'.
77 REAS-NAME PIC X(08) VALUE 'DSN8REAS'.
77 MSGS-NAME PIC X(08) VALUE 'DSN8MSGS'.
77 SQCA-NAME PIC X(08) VALUE 'DSN8SQCA'.
77 TECB-NAME PIC X(08) VALUE 'DSN8TECB'.
77 SECB-NAME PIC X(08) VALUE 'DSN8SECB'.
77 TERM-NAME PIC X(08) VALUE 'DSN8TERM'.
77 ACTN-NAME PIC X(08) VALUE 'DSN8ACTN'.
77 SERV-NAME PIC X(08) VALUE 'DSN8SERV'.
/
****************************************************************
* CAF SERVICES DECLARATIONS *
****************************************************************
* CAF FUNCTIONS
77 CONN-FUNCTION PIC X(12) VALUE 'CONNECT '.
77 OPEN-FUNCTION PIC X(12) VALUE 'OPEN '.
77 CLOS-FUNCTION PIC X(12) VALUE 'CLOSE '.
77 DISC-FUNCTION PIC X(12) VALUE 'DISCONNECT '.
77 XLAT-FUNCTION PIC X(12) VALUE 'TRANSLATE '.
* CAF 'INVALID FUNCTION' ERROR NUMBER
77 BADFN-NUM PIC X(08) VALUE 'DSN8083E'.
* CAF 'CLOSE THREAD' TERMINATION OPTIONS
77 SYNC-VALUE PIC X(04) VALUE 'SYNC'.
77 ABRT-VALUE PIC X(04) VALUE 'ABRT'.
****************************************************************
* ISPF DIALOG SERVICES DECLARATIONS *
****************************************************************
* DEFINE MODIFIERS FOR ISPF CALLS
77 I-CHAR PIC X(08) VALUE 'CHAR '.
77 I-FIXED PIC X(08) VALUE 'FIXED '.
* PANEL DECLARATION
77 MAINMENU PIC X(08) VALUE 'DSN8SSM '.
* ISPF DIALOG SERVICE TYPES DECLARATIONS
77 I-VDEFINE PIC X(08) VALUE 'VDEFINE '.
77 I-VGET PIC X(08) VALUE 'VGET '.
77 I-VPUT PIC X(08) VALUE 'VPUT '.
77 I-DISPLAY PIC X(08) VALUE 'DISPLAY '.
77 I-SELECT PIC X(08) VALUE 'SELECT '.
* CALL-ATTACH INTERFACE PARAMETER FOR SELECT FUNCTION
01 PGMCC.
02 FILLER PIC X(11) VALUE 'PGM(DSN8CC)'.
01 PGMCC-LEN PIC 9(06) VALUE 11 COMP.
* APPLICATION PROGRAM PARAMETER FOR SELECT FUNCTION
01 APPLPGM.
02 FILLER PIC X(04) VALUE 'PGM('.
02 APPLNAME PIC X(08) VALUE SPACES.
02 FILLER PIC X(01) VALUE ')'.
01 APPL-LEN PIC 9(06) VALUE 13 COMP.
/
****************************************************************
* LOCAL VARIABLES FOR ISPF VARIABLES *
****************************************************************
01 SSID PIC X(04) VALUE SPACES.
01 FUNC PIC X(01) VALUE SPACES.
01 PROG PIC X(08) VALUE SPACES.
01 PLAN PIC X(08) VALUE SPACES.
01 RETC PIC 9(06) VALUE 0 COMP.
01 REAS PIC X(08) VALUE SPACES.
01 TECB PIC 9(06) VALUE 0 COMP.
01 SECB PIC 9(06) VALUE 0 COMP.
01 TERM PIC X(04) VALUE SPACES.
01 ACTN PIC X(12) VALUE SPACES.
01 MSGS.
02 MSG-NUM PIC X(08) VALUE SPACES.
02 FILLER PIC X(01) VALUE SPACES.
02 MSG-TEXT PIC X(51) VALUE SPACES.
02 FILLER PIC X(01) VALUE SPACES.
02 REASON-CODE PIC X(08) VALUE SPACES.
02 FILLER PIC X(02) VALUE SPACES.
****************************************************************
* PROGRAM LOGIC FLAGS *
****************************************************************
01 CONNFLAG PIC X(01).
01 EXITFLAG PIC X(01).
01 CONTFLAG PIC X(01).
****************************************************************
* CAF ERROR NUMBER *
****************************************************************
01 ERR-NUM PIC X(08) VALUE 'DSN8080E'.
****************************************************************
* SQLCA DECLARATION *
****************************************************************
EXEC SQL INCLUDE SQLCA END-EXEC.
****************************************************************
* INTERNAL WORKING VARIABLE DECLARATIONS *
****************************************************************
* RETURN CODE FROM CALLS
* SUBSYSTEM ID OF CURRENT CONNECTION
01 CONN-SSID PIC X(04) VALUE SPACES.
* BLANK AND DEFAULT SUBSYSTEM ID
01 BLNK-SSID PIC X(04) VALUE ' '.
01 DFLT-SSID PIC X(04) VALUE 'DSN '.
* CONVERSION VARIABLE USED IN PRINTING THE SQLCA
01 CONV PIC S9(15) COMP-3.
/
****************************************************************
* ERROR MESSAGES *
****************************************************************
01 DISC-MSG.
02 DISC-NUM PIC X(09) VALUE ' DSN8082E'.
02 FILLER PIC X(03) VALUE SPACES.
02 FILLER PIC X(42)
VALUE 'THE DISCONNECT TERMINATED WITH REASON CODE'.
02 FILLER PIC X(01) VALUE SPACES.
02 DISC-REAS PIC X(08) VALUE SPACES.
02 FILLER PIC X(08) VALUE SPACES.
01 TRAN-MSG.
02 TRAN-NUM PIC X(09) VALUE ' DSN8081E'.
02 FILLER PIC X(03) VALUE SPACES.
02 FILLER PIC X(46)
VALUE 'RESULTS FROM THE CALL ATTACH TRANSLATE SERVICE'.
02 FILLER PIC X(13) VALUE SPACES.
01 BADFN-MSG.
02 FILLER PIC X(19)
VALUE 'AN UNKNOWN SERVICE '.
02 SERV PIC X(12) VALUE SPACES.
02 FILLER PIC X(14) VALUE ' WAS REQUESTED'.
02 FILLER PIC X(26) VALUE SPACES.
****************************************************************
* SQLCA OUTPUT FORMAT LINES *
****************************************************************
01 SQLCA-LINE1.
02 FILLER PIC X(05) VALUE SPACES.
02 SQLCAID-NAME PIC X(13) VALUE 'SQLCAID = '.
02 SQLCAID-VALUE PIC X(08).
02 FILLER PIC X(14) VALUE SPACES.
02 SQLCABC-NAME PIC X(13) VALUE 'SQLABC = '.
02 SQLCABC-VALUE PIC Z(15).
02 FILLER PIC X(03) VALUE SPACES.
01 SQLCA-LINE2.
02 FILLER PIC X(05) VALUE SPACES.
02 SQLCODE-NAME PIC X(13) VALUE 'SQLCODE = '.
02 SQLCODE-VALUE PIC +(15).
02 FILLER PIC X(07) VALUE SPACES.
02 SQLERRML-NAME PIC X(13) VALUE 'SQLERRML = '.
02 SQLERRML-VALUE PIC Z(15).
02 FILLER PIC X(03) VALUE SPACES.
01 SQLCA-LINE3.
02 FILLER PIC X(05) VALUE SPACES.
02 SQLERRMC-NAME PIC X(13) VALUE 'SQLERRMC = '.
02 FILLER PIC X(53) VALUE SPACES.
01 SQLCA-LINE4.
02 FILLER PIC X(01) VALUE SPACES.
02 SQLERRMC-VALUE PIC X(70).
01 SQLCA-LINE5.
02 FILLER PIC X(05) VALUE SPACES.
02 SQLERRP-NAME PIC X(13) VALUE 'SQLERRP = '.
02 SQLERRP-VALUE PIC X(08).
02 FILLER PIC X(14) VALUE SPACES.
02 SQLERRD1-NAME PIC X(13) VALUE 'SQLERRD(1) = '.
02 SQLERRD1-VALUE PIC Z(14)9.
02 FILLER PIC X(03) VALUE SPACES.
01 SQLCA-LINE6.
02 FILLER PIC X(05) VALUE SPACES.
02 SQLERRD2-NAME PIC X(13) VALUE 'SQLERRD(2) = '.
02 SQLERRD2-VALUE PIC Z(14)9.
02 FILLER PIC X(07) VALUE SPACES.
02 SQLERRD3-NAME PIC X(13) VALUE 'SQLERRD(3) = '.
02 SQLERRD3-VALUE PIC Z(14)9.
02 FILLER PIC X(03) VALUE SPACES.
01 SQLCA-LINE7.
02 FILLER PIC X(05) VALUE SPACES.
02 SQLERRD4-NAME PIC X(13) VALUE 'SQLERRD(4) = '.
02 SQLERRD4-VALUE PIC Z(14)9.
02 FILLER PIC X(07) VALUE SPACES.
02 SQLERRD5-NAME PIC X(13) VALUE 'SQLERRD(5) = '.
02 SQLERRD5-VALUE PIC Z(14)9.
02 FILLER PIC X(03) VALUE SPACES.
01 SQLCA-LINE8.
02 FILLER PIC X(05) VALUE SPACES.
02 SQLERRD6-NAME PIC X(13) VALUE 'SQLERRD(6) = '.
02 SQLERRD6-VALUE PIC Z(14)9.
02 FILLER PIC X(07) VALUE SPACES.
02 SQLWARN0-NAME PIC X(13) VALUE 'SQLWARN0 = '.
02 SQLWARN0-VALUE PIC X.
02 FILLER PIC X(17) VALUE SPACES.
01 SQLCA-LINE9.
02 FILLER PIC X(05) VALUE SPACES.
02 SQLWARN1-NAME PIC X(13) VALUE 'SQLWARN1 = '.
02 SQLWARN1-VALUE PIC X.
02 FILLER PIC X(21) VALUE SPACES.
02 SQLWARN2-NAME PIC X(13) VALUE 'SQLWARN2 = '.
02 SQLWARN2-VALUE PIC X.
02 FILLER PIC X(17) VALUE SPACES.
01 SQLCA-LINE10.
02 FILLER PIC X(05) VALUE SPACES.
02 SQLWARN3-NAME PIC X(13) VALUE 'SQLWARN3 = '.
02 SQLWARN3-VALUE PIC X.
02 FILLER PIC X(21) VALUE SPACES.
02 SQLWARN4-NAME PIC X(13) VALUE 'SQLWARN4 = '.
02 SQLWARN4-VALUE PIC X.
02 FILLER PIC X(17) VALUE SPACES.
01 SQLCA-LINE11.
02 FILLER PIC X(05) VALUE SPACES.
02 SQLWARN5-NAME PIC X(13) VALUE 'SQLWARN5 = '.
02 SQLWARN5-VALUE PIC X.
02 FILLER PIC X(21) VALUE SPACES.
02 SQLWARN6-NAME PIC X(13) VALUE 'SQLWARN6 = '.
02 SQLWARN6-VALUE PIC X.
02 FILLER PIC X(17) VALUE SPACES.
01 SQLCA-LINE12.
02 FILLER PIC X(05) VALUE SPACES.
02 SQLWARN7-NAME PIC X(13) VALUE 'SQLWARN7 = '.
02 SQLWARN7-VALUE PIC X.
02 FILLER PIC X(21) VALUE SPACES.
02 SQLWARN8-NAME PIC X(13) VALUE 'SQLWARN8 = '.
02 SQLWARN8-VALUE PIC X.
02 FILLER PIC X(17) VALUE SPACES.
01 SQLCA-LINE13.
02 FILLER PIC X(05) VALUE SPACES.
02 SQLWARN9-NAME PIC X(13) VALUE 'SQLWARN9 = '.
02 SQLWARN9-VALUE PIC X.
02 FILLER PIC X(21) VALUE SPACES.
02 SQLWARNA-NAME PIC X(13) VALUE 'SQLWARNA = '.
02 SQLWARNA-VALUE PIC X.
02 FILLER PIC X(17) VALUE SPACES.
01 SQLCA-LINE14.
02 FILLER PIC X(05) VALUE SPACES.
02 SQLSTATE-NAME PIC X(13) VALUE 'SQLSTATE = '.
02 SQLSTATE-VALUE PIC X(05).
02 FILLER PIC X(48) VALUE SPACES.
****************************************************************
* LINKAGE SECTION *
****************************************************************
LINKAGE SECTION.
PROCEDURE DIVISION.
*---------------------
/
****************************************************************
* DEFINE DIALOG VARIABLES USED IN THIS APPLICATION PROGRAM *
****************************************************************
CALL 'ISPLINK' USING I-VDEFINE SSID-NAME SSID I-CHAR
SSID-LEN.
CALL 'ISPLINK' USING I-VDEFINE PROG-NAME PROG I-CHAR
PROG-LEN.
CALL 'ISPLINK' USING I-VDEFINE PLAN-NAME PLAN I-CHAR
PLAN-LEN.
CALL 'ISPLINK' USING I-VDEFINE MSGS-NAME MSGS I-CHAR
MSGS-LEN.
CALL 'ISPLINK' USING I-VDEFINE RETC-NAME RETC I-FIXED
RETC-LEN.
CALL 'ISPLINK' USING I-VDEFINE REAS-NAME REAS I-CHAR
REAS-LEN.
CALL 'ISPLINK' USING I-VDEFINE SQCA-NAME SQLCA I-CHAR
SQCA-LEN.
CALL 'ISPLINK' USING I-VDEFINE TECB-NAME TECB I-FIXED
TECB-LEN.
CALL 'ISPLINK' USING I-VDEFINE SECB-NAME SECB I-FIXED
SECB-LEN.
CALL 'ISPLINK' USING I-VDEFINE TERM-NAME TERM I-CHAR
TERM-LEN.
CALL 'ISPLINK' USING I-VDEFINE ACTN-NAME ACTN I-CHAR
ACTN-LEN.
CALL 'ISPLINK' USING I-VDEFINE SERV-NAME SERV I-CHAR
SERV-LEN.
****************************************************************
* INITIALIZATION *
****************************************************************
OPEN OUTPUT MSGOUT.
MOVE NO-IND TO CONNFLAG.
MOVE NO-IND TO EXITFLAG.
CALL 'ISPLINK' USING I-VGET SSID-NAME.
IF SSID = BLNK-SSID THEN
MOVE DFLT-SSID TO SSID.
MOVE SPACES TO MSGS.
****************************************************************
* DO WHILE EXIT HAS NOT BEEN SPECIFIED *
****************************************************************
MAIN-LOOP.
PERFORM CAF-PROCESS UNTIL EXITFLAG = YES-IND.
CLOSE MSGOUT.
STOP RUN.
/
****************************************************************
* DISPLAYING THE PANEL *
****************************************************************
CAF-PROCESS.
MOVE YES-IND TO CONTFLAG.
* **SET MSG FIELD ON PANEL
CALL 'ISPLINK' USING I-VPUT MSGS-NAME.
* **DISPLAY SELECTION MENU
CALL 'ISPLINK' USING I-DISPLAY MAINMENU.
* **IF EXIT PRESSED THEN
IF RETURN-CODE = 8 THEN
MOVE YES-IND TO EXITFLAG
* **DISCONNECT
IF CONNFLAG IS EQUAL TO YES-IND THEN
MOVE DISC-FUNCTION TO ACTN
CALL 'ISPLINK' USING I-VPUT ACTN-NAME
CALL 'ISPLINK' USING I-SELECT PGMCC-LEN PGMCC
CALL 'ISPLINK' USING I-VGET RETC-NAME
* **IF DISCONNECT ERROR
IF RETC > 0 THEN
CALL 'ISPLINK' USING I-VGET REAS-NAME
MOVE REAS TO DISC-REAS
* **WRITE ERROR MSG
WRITE MSGREC FROM DISC-MSG.
* **ELSE APPL. SELECTED
IF EXITFLAG IS EQUAL TO NO-IND THEN
* **GET SSID NAME
CALL 'ISPLINK' USING I-VGET SSID-NAME
* **MAKE CONNECTIONS
* **AND CALL APPL.
PERFORM SERVICE-CHECKS
* **IF RC = 11
IF RETC = 11 THEN
CALL 'ISPLINK' USING I-VGET SERV-NAME
* **SET BAD FN MSG
MOVE BADFN-NUM TO MSG-NUM
MOVE BADFN-MSG TO MSG-TEXT.
/
****************************************************************
* DETERMINING WHICH CALL ATTACH SERVICES TO BE PERFORMED *
****************************************************************
SERVICE-CHECKS.
* **DIFFERENT SUBSYSTEM?
IF CONNFLAG = YES-IND AND SSID IS NOT = CONN-SSID THEN
PERFORM SUBSYSTEM-PROCESS.
* **NEED TO CONNECT?
IF CONNFLAG = NO-IND AND CONTFLAG = YES-IND THEN
PERFORM CONNECT-PROCESS.
* **OPEN THREAD
IF CONTFLAG = YES-IND THEN
PERFORM OPEN-PROCESS.
* **CALL THE APPLICATION
IF CONTFLAG = YES-IND THEN
PERFORM APPL-PROCESS.
* **CLOSE THREAD
IF CONTFLAG = YES-IND THEN
PERFORM CLOSE-PROCESS.
/
****************************************************************
* DISCONNECT FROM CURRENT SUBSYSTEM *
****************************************************************
SUBSYSTEM-PROCESS.
* **DISCONNECT
MOVE DISC-FUNCTION TO ACTN.
CALL 'ISPLINK' USING I-VPUT ACTN-NAME.
CALL 'ISPLINK' USING I-SELECT PGMCC-LEN PGMCC.
* **GET RETURN CODE
CALL 'ISPLINK' USING I-VGET RETC-NAME
* **IF DISCONNECT OK
IF RETC = 0 THEN
* **NOT CONNECTED
MOVE NO-IND TO CONNFLAG
* **CLEAR MSG
MOVE SPACES TO MSGS
* **ELSE DISCONNECT ERROR
ELSE
MOVE NO-IND TO CONTFLAG
* **GET REASON CODE
CALL 'ISPLINK' USING I-VGET REAS-NAME
* **SET ERROR MSG
MOVE REAS TO REASON-CODE
MOVE DISC-MSG TO MSGS.
/
****************************************************************
* CONNECT TO A SUBSYSTEM *
****************************************************************
CONNECT-PROCESS.
MOVE CONN-FUNCTION TO ACTN.
CALL 'ISPLINK' USING I-VPUT ACTN-NAME.
CALL 'ISPLINK' USING I-VPUT TECB-NAME.
CALL 'ISPLINK' USING I-VPUT SECB-NAME.
* **CALL CONNECT SERVICE
CALL 'ISPLINK' USING I-SELECT PGMCC-LEN PGMCC.
* **GET RETURN CODE
CALL 'ISPLINK' USING I-VGET RETC-NAME
* **IF NO ERROR
IF RETC = 0 THEN
* **SAVE CONNECTED SSID
MOVE SSID TO CONN-SSID
MOVE YES-IND TO CONTFLAG
MOVE YES-IND TO CONNFLAG
* **CLEAR MSG FIELD
MOVE SPACES TO MSGS
* **ELSE BAD CONNECTION
ELSE
MOVE NO-IND TO CONTFLAG
* **GET REASON
CALL 'ISPLINK' USING I-VGET REAS-NAME
MOVE REAS TO REASON-CODE
* **SET MSG
MOVE ERR-NUM TO MSG-NUM
MOVE MSG1 TO MSG-TEXT.
/
****************************************************************
* CREATE A THREAD FOR THE APPLICATION *
****************************************************************
OPEN-PROCESS.
MOVE OPEN-FUNCTION TO ACTN.
CALL 'ISPLINK' USING I-VPUT ACTN-NAME.
* **CALL OPEN FUNCTION
CALL 'ISPLINK' USING I-SELECT PGMCC-LEN PGMCC.
* **GET RETURN CODE
CALL 'ISPLINK' USING I-VGET RETC-NAME
* **IF NO ERROR
IF RETC = 0 THEN
* **THREAD OPENED
MOVE YES-IND TO CONTFLAG
MOVE SPACES TO MSGS
* **ELSE BAD OPEN
ELSE
* **GET REASON
CALL 'ISPLINK' USING I-VGET REAS-NAME
MOVE REAS TO REASON-CODE
* **SET ERROR MSG
MOVE MSG1 TO MSG-TEXT
MOVE ERR-NUM TO MSG-NUM
* **GET SQLCA
CALL 'ISPLINK' USING I-VPUT SQCA-NAME
MOVE XLAT-FUNCTION TO ACTN
CALL 'ISPLINK' USING I-VPUT ACTN-NAME
CALL 'ISPLINK' USING I-SELECT PGMCC-LEN PGMCC
* **WRITE TRANSLATE MSG
WRITE MSGREC FROM TRAN-MSG
MOVE SPACES TO MSGREC
WRITE MSGREC
CALL 'ISPLINK' USING I-VGET SQCA-NAME
****************************************************************
* MOVE SQLCA FIELD NAMES INTO THE SQLCA OUTPUT RECORDS *
****************************************************************
MOVE SQLCAID TO SQLCAID-VALUE
MOVE SQLCABC TO CONV
MOVE CONV TO SQLCABC-VALUE
MOVE SQLCODE TO CONV
MOVE CONV TO SQLCODE-VALUE
MOVE SQLERRML TO CONV
MOVE CONV TO SQLERRML-VALUE
MOVE SQLERRMC TO SQLERRMC-VALUE
MOVE SQLERRP TO SQLERRP-VALUE
MOVE SQLERRD (1) TO CONV
MOVE CONV TO SQLERRD1-VALUE
MOVE SQLERRD (2) TO CONV
MOVE CONV TO SQLERRD2-VALUE
MOVE SQLERRD (3) TO CONV
MOVE CONV TO SQLERRD3-VALUE
MOVE SQLERRD (4) TO CONV
MOVE CONV TO SQLERRD4-VALUE
MOVE SQLERRD (5) TO CONV
MOVE CONV TO SQLERRD5-VALUE
MOVE SQLERRD (6) TO CONV
MOVE CONV TO SQLERRD6-VALUE
MOVE SQLWARN0 TO SQLWARN0-VALUE
MOVE SQLWARN1 TO SQLWARN1-VALUE
MOVE SQLWARN2 TO SQLWARN2-VALUE
MOVE SQLWARN3 TO SQLWARN3-VALUE
MOVE SQLWARN4 TO SQLWARN4-VALUE
MOVE SQLWARN5 TO SQLWARN5-VALUE
MOVE SQLWARN6 TO SQLWARN6-VALUE
MOVE SQLWARN7 TO SQLWARN7-VALUE
MOVE SQLWARN8 TO SQLWARN8-VALUE
MOVE SQLWARN9 TO SQLWARN9-VALUE
MOVE SQLWARNA TO SQLWARNA-VALUE
MOVE SQLSTATE TO SQLSTATE-VALUE
****************************************************************
* WRITE OUT THE SQLCA INFORMATION *
****************************************************************
WRITE MSGREC FROM SQLCA-LINE1
WRITE MSGREC FROM SQLCA-LINE2
WRITE MSGREC FROM SQLCA-LINE3
WRITE MSGREC FROM SQLCA-LINE4
WRITE MSGREC FROM SQLCA-LINE5
WRITE MSGREC FROM SQLCA-LINE6
WRITE MSGREC FROM SQLCA-LINE7
WRITE MSGREC FROM SQLCA-LINE8
WRITE MSGREC FROM SQLCA-LINE9
WRITE MSGREC FROM SQLCA-LINE10
WRITE MSGREC FROM SQLCA-LINE11
WRITE MSGREC FROM SQLCA-LINE12
WRITE MSGREC FROM SQLCA-LINE13
WRITE MSGREC FROM SQLCA-LINE14
MOVE NO-IND TO CONTFLAG.
/
****************************************************************
* LINK TO THE APPLICATION *
****************************************************************
APPL-PROCESS.
CALL 'ISPLINK' USING I-VGET PROG-NAME.
MOVE PROG TO APPLNAME.
CALL 'ISPLINK' USING I-SELECT APPL-LEN APPLPGM.
* **GET RETURN CODE
MOVE RETURN-CODE TO RETC
* **IF RC = 0 (OK?)
IF RETC = 0 THEN
* **SET SYNC FOR CLOSE
MOVE SYNC-VALUE TO TERM
* **CLEAR MSG
MOVE SPACES TO MSGS
* **ELSE (ERROR)
ELSE
* **SET ABORT FOR CLOSE
MOVE ABRT-VALUE TO TERM.
* **STORE TERMINATION CODE
CALL 'ISPLINK' USING I-VPUT TERM-NAME.
* **DID APPL SET A MSG?
CALL 'ISPLINK' USING I-VGET MSGS-NAME.
/
****************************************************************
* TERMINATE THE THREAD *
****************************************************************
CLOSE-PROCESS.
MOVE CLOS-FUNCTION TO ACTN.
CALL 'ISPLINK' USING I-VPUT ACTN-NAME.
* **CALL CLOSE FUNCTION
CALL 'ISPLINK' USING I-SELECT PGMCC-LEN PGMCC.
* **GET RETURN CODE
CALL 'ISPLINK' USING I-VGET RETC-NAME
* **IF BAD CLOSE
IF RETC > 0 THEN
CALL 'ISPLINK' USING I-VGET REAS-NAME
* **OK IF IT IS JUST
* **CAF CLEANING UP
* **FROM DB2 DOWN
* **SITUATION
IF REAS = CAF-RESET THEN
MOVE NO-IND TO CONNFLAG
MOVE SPACES TO MSGS
* **ELSE SET MSG
* **TO DISPLAY
* **REASON CODE
MOVE REAS TO REASON-CODE
MOVE MSG1 TO MSG-TEXT
MOVE ERR-NUM TO MSG-NUM
* **ELSE GOOD CLOSE
ELSE
MOVE SPACES TO MSGS.