DSN8SC3
THIS MODULE LISTS EMPLOYEE PHONE NUMBERS AND UPDATES THEM IF DESIRED.
IDENTIFICATION DIVISION. 00000100
*----------------------- 00000200
PROGRAM-ID. DSN8SC3. 00000300
00000400
*---------------------------------------------------------------* 00000500
* * 00000600
* MODULE NAME = DSN8SC3 * 00000700
* * 00000800
* DESCRIPTIVE NAME = DB2 SAMPLE APPLICATION * 00000900
* PHONE APPLICATION * 00001000
* ISPF * 00001100
* COBOL * 00001200
* * 00001300
*COPYRIGHT = 5615-DB2 (C) COPYRIGHT 1982, 2013 IBM CORP. * 00001400
*SEE COPYRIGHT INSTRUCTIONS * 00001500
*LICENSED MATERIALS - PROPERTY OF IBM * 00001600
* * 00001700
*STATUS = STATUS = VERSION 11 * 00001800
* * 00001900
* FUNCTION = THIS MODULE LISTS EMPLOYEE PHONE NUMBERS AND * 00002000
* UPDATES THEM IF DESIRED. * 00002100
* * 00002200
* NOTES = * 00002300
* DEPENDENCIES = TWO ISPF PANELS ARE REQUIRED: * 00002400
* DSN8SSL AND DSN8SSN * 00002500
* RESTRICTIONS = NONE * 00002600
* * 00002700
* MODULE TYPE = VS COBOL II PROGRAM * 00002800
* PROCESSOR = DB2 PRECOMPILER, VS COBOL II * 00002900
* MODULE SIZE = SEE LINKEDIT * 00003000
* ATTRIBUTES = NOT REENTRANT OR REUSABLE * 00003100
* * 00003200
* ENTRY POINT = DSN8SC3 * 00003300
* PURPOSE = SEE FUNCTION * 00003400
* LINKAGE = INVOKED FROM ISPF * 00003500
* * 00003600
* INPUT = PARAMETERS EXPLICITLY PASSED TO THIS FUNCTION: * 00003700
* INPUT-MESSAGE: * 00003800
* * 00003900
* SYMBOLIC LABEL/NAME = DSN8SSL * 00004000
* DESCRIPTION = PHONE MENU 1 (SELECT) * 00004100
* * 00004200
* SYMBOLIC LABEL/NAME = DSN8SSN * 00004300
* DESCRIPTION = PHONE MENU 2 (LIST) * 00004400
* * 00004500
* SYMBOLIC LABEL/NAME = VPHONE * 00004600
* DESCRIPTION = VIEW OF TELEPHONE DATA * 00004700
* * 00004800
* SYMBOLIC LABEL/NAME = VEMPLP * 00004900
* DESCRIPTION = VIEW OF EMPLOYEE DATA * 00005000
* * 00005100
* OUTPUT = PARAMETERS EXPLICITLY RETURNED: * 00005200
* OUTPUT-MESSAGE: * 00005300
* * 00005400
* SYMBOLIC LABEL/NAME = DSN8SSL * 00005500
* DESCRIPTION = PHONE MENU 1 (SELECT) * 00005600
* * 00005700
* SYMBOLIC LABEL/NAME = DSN8SSN * 00005800
* DESCRIPTION = PHONE MENU 2 (LIST) * 00005900
* * 00006000
* EXIT-NORMAL = RETURN CODE 0 NORMAL COMPLETION * 00006100
* * 00006200
* EXIT-ERROR = * 00006300
* * 00006400
* RETURN CODE = NONE * 00006500
* * 00006600
* ABEND CODES = NONE * 00006700
* * 00006800
* * 00006900
* ERROR-MESSAGES = * 00007000
* DSN8004I - EMPLOYEE SUCCESSFULLY UPDATED * 00007100
* DSN8008I - NO EMPLOYEE FOUND IN TABLE * 00007200
* DSN8060E - SQL ERROR, RETURN CODE IS: * 00007300
* DSN8079E - CONNECTION TO DB2 NOT ESTABLISHED * 00007400
* * 00007500
* EXTERNAL REFERENCES = * 00007600
* ROUTINES/SERVICES = * 00007700
* DSN8MCG - ERROR MESSAGE ROUTINE * 00007800
* ISPLINK - ISPF SERVICES ROUTINE * 00007900
* * 00008000
* DATA-AREAS = * 00008100
* NONE * 00008200
* * 00008300
* CONTROL-BLOCKS = * 00008400
* SQLCA - SQL COMMUNICATION AREA * 00008500
* * 00008600
* TABLES = NONE * 00008700
* * 00008800
* * 00008900
* CHANGE-ACTIVITY: * 00009000
* * 00009100
* CHECK SQLERRP FOR NON-BLANKS TO ENSURE CONNECTION V2R3 * 00009200
* HAS BEEN ESTABLISHED. ISSUE 079E IF NOT. * 00009300
* * 00009400
* *PSEUDOCODE* * 00009500
* * 00009600
* SET UP RETURN CODE HANDLING 0000-PROGRAM-START* 00009700
* DO UNTIL NO MORE TERMINAL INPUT * 00009800
* GET PANEL INPUT 1000-MAIN-LOOP * 00009900
* DETERMINE PROCESSING REQUEST 2000-GET-TYPE * 00010000
* -IF "LIST ALL" (*): 3000-LIST-ALL * 00010100
* FETCH FIRST RECORD * 00010200
* CREATE ISPF TABLE * 00010300
* DO UNTIL NO MORE RECORDS: * 00010400
* STORE RECORD IN TABLE 3500-LIST-AND-GET * 00010500
* GET ANOTHER RECORD * 00010600
* -IF "LIST GENERIC" (%): 4000-LIST-GENERIC * 00010700
* FETCH FIRST RECORD * 00010800
* CREATE ISPF TABLE * 00010900
* DO UNTIL NO MORE MATCHING RECORDS: * 00011000
* STORE RECORD IN TABLE 4500-LIST-AND-GET * 00011100
* GET ANOTHER RECORD * 00011200
* -IF "LIST SPECIFIC: 5000-LIST-SPECIFIC* 00011300
* FETCH FIRST RECORD * 00011400
* CREATE ISPF TABLE * 00011500
* DO UNTIL NO MORE MATCHING RECORDS: * 00011600
* STORE RECORD IN TABLE 5500-LIST-AND-GET * 00011700
* GET ANOTHER RECORD * 00011800
* DISPLAY PHONE LIST ON SCREEN 6000-DISPLAY-LIST * 00011900
* IF UPDATE REQUESTED 6500-UPDATE-LOOP * 00012000
* UPDATE PHONE RECORDS 7000-UPDATE * 00012100
*---------------------------------------------------------------* 00012200
ENVIRONMENT DIVISION. 00012300
DATA DIVISION. 00012400
WORKING-STORAGE SECTION. 00012500
*---------------------------------------------------------------* 00012600
77 COIBM PIC X(54) VALUE IS 00012700
'COPYRIGHT = 5740-XYR (C) COPYRIGHT IBM CORP 1982, 1987'. 00012800
77 SEL-EXIT PIC X(01). 00012900
77 DIS-EXIT PIC X(01). 00013000
77 DISPLAY-TABLE PIC X(01). 00013100
77 MORE-CHANGES PIC X(01). 00013200
77 ROWS-CHANGED PIC 9(04). 00013300
77 PERCENT-COUNTER PIC S9(4) COMP. 00013400
77 MODULE PIC X(07) VALUE 'DSN8SC3'. 00013500
77 MSGCODE PIC X(04). 00013600
77 W-BLANK PIC X(01) VALUE ' '. 00013700
77 MSGS-VAR PIC X(08) VALUE 'DSN8MSGS'. 00013800
77 FI-VAR PIC X(08) VALUE 'FNAMEI '. 00013900
77 LI-VAR PIC X(08) VALUE 'LNAMEI '. 00014000
*--------------------------------------------------------------* 00014100
* ISPF DIALOG VARIABLE NAMES * 00014200
*--------------------------------------------------------------* 00014300
EXEC SQL INCLUDE SQLCA END-EXEC. 00014400
01 LNAMEW PIC X(15). 00014500
01 FNAMEW PIC X(12). 00014600
01 LIST-PANEL-VARIABLES. 00014700
03 CH-VAR PIC X(08) VALUE 'ZTDSELS '. 00014800
03 FN-VAR PIC X(08) VALUE 'FNAMED '. 00014900
03 MI-VAR PIC X(08) VALUE 'MINITD '. 00015000
03 LN-VAR PIC X(08) VALUE 'LNAMED '. 00015100
03 PN-VAR PIC X(08) VALUE 'PNOD '. 00015200
03 EN-VAR PIC X(08) VALUE 'ENOD '. 00015300
03 WD-VAR PIC X(08) VALUE 'WDEPTD '. 00015400
03 WN-VAR PIC X(08) VALUE 'WNAMED '. 00015500
03 TABLE-NAME PIC X(08) VALUE 'DSN8TABL'. 00015600
03 SEL-VARS PIC X(20) VALUE IS 00015700
'( FNAMEI LNAMEI ) '. 00015800
03 DIS-VARS PIC X(56) VALUE IS 00015900
'( ZTDSELS FNAMED MINITD LNAMED PNOD ENOD WDEPTD WNAMED )'. 00016000
03 EMP-VARS PIC X(48) VALUE IS 00016100
'( FNAMED MINITD LNAMED PNOD ENOD WDEPTD WNAMED )'. 00016200
01 PANEL-VARIABLE-LENGTHS. 00016300
03 CH-VAR-STG PIC 9(06) COMP VALUE 04. 00016400
03 FN-VAR-STG PIC 9(06) COMP VALUE 12. 00016500
03 MI-VAR-STG PIC 9(06) COMP VALUE 01. 00016600
03 LN-VAR-STG PIC 9(06) COMP VALUE 15. 00016700
03 PN-VAR-STG PIC 9(06) COMP VALUE 04. 00016800
03 EN-VAR-STG PIC 9(06) COMP VALUE 06. 00016900
03 WD-VAR-STG PIC 9(06) COMP VALUE 03. 00017000
03 WN-VAR-STG PIC 9(06) COMP VALUE 36. 00017100
03 FI-VAR-STG PIC 9(06) COMP VALUE 12. 00017200
03 LI-VAR-STG PIC 9(06) COMP VALUE 15. 00017300
03 MSGS-VAR-STG PIC 9(06) COMP VALUE 79. 00017400
*---------------------------------------------------------------* 00017500
* ISPF DIALOG SERVICES DECLARATIONS * 00017600
*---------------------------------------------------------------* 00017700
01 I-VDEFINE PIC X(08) VALUE 'VDEFINE '. 00017800
01 I-VGET PIC X(08) VALUE 'VGET '. 00017900
01 I-VPUT PIC X(08) VALUE 'VPUT '. 00018000
01 I-DISPLAY PIC X(08) VALUE 'DISPLAY '. 00018100
01 I-TBDISPL PIC X(08) VALUE 'TBDISPL '. 00018200
01 I-TBTOP PIC X(08) VALUE 'TBTOP '. 00018300
01 I-TBCREATE PIC X(08) VALUE 'TBCREATE'. 00018400
01 I-TBCLOSE PIC X(08) VALUE 'TBCLOSE '. 00018500
01 I-TBADD PIC X(08) VALUE 'TBADD '. 00018600
01 I-TBPUT PIC X(08) VALUE 'TBPUT '. 00018700
*---------------------------------------------------------------* 00018800
* ISPF CALL MODIFIERS * 00018900
*---------------------------------------------------------------* 00019000
01 I-NOWRITE PIC X(08) VALUE 'NOWRITE '. 00019100
01 I-REPLACE PIC X(08) VALUE 'REPLACE '. 00019200
01 I-CHAR PIC X(08) VALUE 'CHAR '. 00019300
*---------------------------------------------------------------* 00019400
* ISPF PANEL NAMES * 00019500
*---------------------------------------------------------------* 00019600
01 SEL-PANEL PIC X(08) VALUE 'DSN8SSL '. 00019700
01 DIS-PANEL PIC X(08) VALUE 'DSN8SSN '. 00019800
*---------------------------------------------------------------* 00019900
* LOCAL-VARIABLES * 00020000
*---------------------------------------------------------------* 00020100
01 LOCAL-VARIABLES. 00020200
03 LNAMEI PIC X(15) VALUE SPACES. 00020300
03 FNAMEI PIC X(12) VALUE SPACES. 00020400
03 CONVSQL PIC S9(15) COMP-3. 00020500
03 OUTMSG PIC X(69). 00020600
03 TMSG REDEFINES OUTMSG. 00020700
05 TMSGTXT PIC X(46). 00020800
05 FILLER PIC X(23). 00020900
03 MSGS PIC X(79) VALUE SPACES. 00021000
03 MSGS-DETAIL REDEFINES MSGS. 00021100
05 OUT-MESSAGE PIC X(46). 00021200
05 SQL-CODE PIC +(04). 00021300
05 FILLER PIC X(29). 00021400
*---------------------------------------------------------------* 00021500
* EMPLOYEE RECORD - IO AREA * 00021600
*---------------------------------------------------------------* 00021700
01 EMP-RECORD. 00021800
02 EMPLAST PIC X(15). 00021900
02 EMP-FIRST-NAME PIC X(12). 00022000
02 EMP-MIDDLE-INITIAL PIC X(01). 00022100
02 EMPPHONE PIC X(04). 00022200
02 EMPNUMB PIC X(06). 00022300
02 EMP-DEPT-NUMBER PIC X(03). 00022400
02 EMP-DEPTNAME PIC X(36). 00022500
*---------------------------------------------------------------* 00022600
* SQL DECLARATION FOR VIEW PHONE * 00022700
*---------------------------------------------------------------* 00022800
EXEC SQL DECLARE VPHONE TABLE 00022900
(LASTNAME VARCHAR(15) , 00023000
FIRSTNAME VARCHAR(12) , 00023100
MIDDLEINITIAL CHAR(1) , 00023200
PHONENUMBER CHAR(4) , 00023300
EMPLOYEENUMBER CHAR(6) , 00023400
DEPTNUMBER CHAR(3) NOT NULL, 00023500
DEPTNAME VARCHAR(36) NOT NULL) END-EXEC. 00023600
*---------------------------------------------------------------* 00023700
* STRUCTURE FOR PHONE RECORD * 00023800
*---------------------------------------------------------------* 00023900
01 PPHONE. 00024000
02 LAST-NAME PIC X(15). 00024100
02 FIRST-NAME PIC X(12). 00024200
02 MIDDLE-INITIAL PIC X(01). 00024300
02 PHONE-NUMBER PIC X(04). 00024400
02 EMPLOYEE-NUMBER PIC X(06). 00024500
02 DEPT-NUMBER PIC X(03). 00024600
02 DEPTNAME PIC X(36). 00024700
*---------------------------------------------------------------* 00024800
* SQL DECLARATION FOR VIEW VEMPLP * 00024900
*---------------------------------------------------------------* 00025000
EXEC SQL DECLARE VEMPLP TABLE 00025100
(EMPLOYEENUMBER CHAR(6) , 00025200
PHONENUMBER CHAR(4)) END-EXEC. 00025300
*---------------------------------------------------------------* 00025400
* SQL CURSORS * 00025500
*---------------------------------------------------------------* 00025600
EXEC SQL DECLARE TELE1 CURSOR FOR 00025700
SELECT * 00025800
FROM VPHONE 00025900
END-EXEC. 00026000
* 00026100
EXEC SQL DECLARE TELE2 CURSOR FOR 00026200
SELECT * 00026300
FROM VPHONE 00026400
WHERE LASTNAME LIKE :LNAMEW 00026500
AND FIRSTNAME LIKE :FNAMEW 00026600
END-EXEC. 00026700
* 00026800
EXEC SQL DECLARE TELE3 CURSOR FOR 00026900
SELECT * 00027000
FROM VPHONE 00027100
WHERE LASTNAME = :LNAMEW 00027200
AND FIRSTNAME LIKE :FNAMEW 00027300
END-EXEC. 00027400
* 00027500
EJECT 00027600
PROCEDURE DIVISION. 00027700
*---------------------------------------------------------------* 00027800
* SQL RETURN CODE HANDLING * 00027900
*---------------------------------------------------------------* 00028000
EXEC SQL WHENEVER SQLERROR GOTO L8000-P3-DBERROR END-EXEC. 00028100
EXEC SQL WHENEVER SQLWARNING GOTO L8000-P3-DBERROR END-EXEC. 00028200
EXEC SQL WHENEVER NOT FOUND CONTINUE END-EXEC. 00028300
* 00028400
*---------------------------------------------------------------* 00028500
* DEFINE COBOL - SPF VARIABLES * 00028600
*---------------------------------------------------------------* 00028700
0000-PROGRAM-START. 00028800
CALL 'ISPLINK' USING I-VDEFINE, CH-VAR, ROWS-CHANGED, 00028900
I-CHAR, CH-VAR-STG. 00029000
CALL 'ISPLINK' USING I-VDEFINE, FN-VAR, EMP-FIRST-NAME, 00029100
I-CHAR, FN-VAR-STG. 00029200
CALL 'ISPLINK' USING I-VDEFINE, MI-VAR, EMP-MIDDLE-INITIAL, 00029300
I-CHAR, MI-VAR-STG. 00029400
CALL 'ISPLINK' USING I-VDEFINE, LN-VAR, EMPLAST, 00029500
I-CHAR, LN-VAR-STG. 00029600
CALL 'ISPLINK' USING I-VDEFINE, PN-VAR, EMPPHONE, 00029700
I-CHAR, PN-VAR-STG. 00029800
CALL 'ISPLINK' USING I-VDEFINE, EN-VAR, EMPNUMB, 00029900
I-CHAR, EN-VAR-STG. 00030000
CALL 'ISPLINK' USING I-VDEFINE, WD-VAR, EMP-DEPT-NUMBER, 00030100
I-CHAR, WD-VAR-STG. 00030200
CALL 'ISPLINK' USING I-VDEFINE, WN-VAR, EMP-DEPTNAME, 00030300
I-CHAR, WN-VAR-STG. 00030400
CALL 'ISPLINK' USING I-VDEFINE, FI-VAR, FNAMEI, 00030500
I-CHAR, FI-VAR-STG. 00030600
CALL 'ISPLINK' USING I-VDEFINE, LI-VAR, LNAMEI, 00030700
I-CHAR, LI-VAR-STG. 00030800
CALL 'ISPLINK' USING I-VDEFINE, MSGS-VAR, MSGS, 00030900
I-CHAR, MSGS-VAR-STG. 00031000
* 00031100
*---------------------------------------------------------------* 00031200
* MAIN PROGRAM * 00031300
*---------------------------------------------------------------* 00031400
MOVE 'N' TO SEL-EXIT. 00031500
PERFORM 1000-MAIN-LOOP THRU 1000-MAIN-LOOP-EXIT 00031600
UNTIL SEL-EXIT = 'Y'. 00031700
MOVE 0 TO RETURN-CODE. 00031800
GOBACK. 00031900
* 00032000
1000-MAIN-LOOP. 00032100
CALL 'ISPLINK' USING I-DISPLAY, SEL-PANEL. 00032200
MOVE SPACES TO MSGS. 00032300
MOVE SPACES TO OUTMSG. 00032400
IF RETURN-CODE = 8 00032500
MOVE 'Y' TO SEL-EXIT 00032600
ELSE 00032700
MOVE 'N' TO DISPLAY-TABLE 00032800
CALL 'ISPLINK' USING I-VGET, SEL-VARS 00032900
MOVE LNAMEI TO LNAMEW 00033000
MOVE FNAMEI TO FNAMEW 00033100
PERFORM 2000-GET-TYPE THRU 2000-GET-TYPE-EXIT 00033200
IF DISPLAY-TABLE = 'Y' 00033300
PERFORM 6000-DISPLAY-LIST 00033400
THRU 6000-DISPLAY-LIST-EXIT. 00033500
CALL 'ISPLINK' USING I-VPUT MSGS-VAR. 00033600
1000-MAIN-LOOP-EXIT. 00033700
EXIT. 00033800
* 00033900
*---------------------------------------------------------------* 00034000
* DETERMINE PROCESSING REQUEST * 00034100
*---------------------------------------------------------------* 00034200
2000-GET-TYPE. 00034300
IF LNAMEW = '*' 00034400
PERFORM 3000-LIST-ALL 00034500
THRU 3000-LIST-ALL-EXIT 00034600
ELSE 00034700
UNSTRING LNAMEW 00034800
DELIMITED BY SPACE 00034900
INTO LNAMEW 00035000
UNSTRING FNAMEW 00035100
DELIMITED BY SPACE 00035200
INTO FNAMEW 00035300
INSPECT FNAMEW 00035400
REPLACING ALL ' ' BY '%' 00035500
MOVE 0 TO PERCENT-COUNTER 00035600
INSPECT LNAMEW 00035700
TALLYING PERCENT-COUNTER FOR ALL '%' 00035800
IF PERCENT-COUNTER > 0 00035900
INSPECT LNAMEW 00036000
REPLACING ALL ' ' BY '%' 00036100
PERFORM 4000-LIST-GENERIC 00036200
THRU 4000-LIST-GENERIC-EXIT 00036300
ELSE 00036400
PERFORM 5000-LIST-SPECIFIC 00036500
THRU 5000-LIST-SPECIFIC-EXIT. 00036600
2000-GET-TYPE-EXIT. 00036700
EXIT. 00036800
* 00036900
*---------------------------------------------------------------* 00037000
* LIST ALL EMPLOYEES * 00037100
*---------------------------------------------------------------* 00037200
3000-LIST-ALL. 00037300
EXEC SQL OPEN TELE1 END-EXEC. 00037400
MOVE SPACES TO SQLERRP. 00037500
EXEC SQL FETCH TELE1 INTO :PPHONE END-EXEC. 00037600
IF SQLERRP = SPACES 00037700
MOVE '079E' TO MSGCODE 00037800
CALL 'DSN8MCG' USING MODULE, MSGCODE, OUTMSG 00037900
MOVE OUTMSG TO MSGS 00038000
ELSE 00038100
IF SQLCODE = 100 00038200
MOVE '008I' TO MSGCODE 00038300
CALL 'DSN8MCG' USING MODULE, MSGCODE, OUTMSG 00038400
MOVE OUTMSG TO MSGS 00038500
ELSE 00038600
MOVE 'Y' TO DISPLAY-TABLE 00038700
CALL 'ISPLINK' USING I-TBCREATE, TABLE-NAME, 00038800
W-BLANK, EMP-VARS, I-NOWRITE, I-REPLACE 00038900
PERFORM 3500-LIST-AND-GET 00039000
THRU 3500-LIST-AND-GET-EXIT 00039100
UNTIL SQLCODE NOT EQUAL 0. 00039200
EXEC SQL CLOSE TELE1 END-EXEC. 00039300
3000-LIST-ALL-EXIT. 00039400
EXIT. 00039500
* 00039600
3500-LIST-AND-GET. 00039700
MOVE PPHONE TO EMP-RECORD. 00039800
CALL 'ISPLINK' USING I-TBADD, TABLE-NAME. 00039900
EXEC SQL FETCH TELE1 INTO :PPHONE END-EXEC. 00040000
3500-LIST-AND-GET-EXIT. 00040100
EXIT. 00040200
* 00040300
*---------------------------------------------------------------* 00040400
* GENERIC LIST OF EMPLOYEES * 00040500
*---------------------------------------------------------------* 00040600
4000-LIST-GENERIC. 00040700
EXEC SQL OPEN TELE2 END-EXEC. 00040800
MOVE SPACES TO SQLERRP. 00040900
EXEC SQL FETCH TELE2 INTO :PPHONE END-EXEC. 00041000
IF SQLERRP = SPACES 00041100
MOVE '079E' TO MSGCODE 00041200
CALL 'DSN8MCG' USING MODULE, MSGCODE, OUTMSG 00041300
MOVE OUTMSG TO MSGS 00041400
ELSE 00041500
IF SQLCODE = 100 00041600
MOVE '008I' TO MSGCODE 00041700
CALL 'DSN8MCG' USING MODULE, MSGCODE, OUTMSG 00041800
MOVE OUTMSG TO MSGS 00041900
ELSE 00042000
MOVE 'Y' TO DISPLAY-TABLE 00042100
CALL 'ISPLINK' USING I-TBCREATE, TABLE-NAME, W-BLANK,00042200
EMP-VARS, I-NOWRITE, I-REPLACE 00042300
PERFORM 4500-LIST-AND-GET 00042400
THRU 4500-LIST-AND-GET-EXIT 00042500
UNTIL SQLCODE NOT EQUAL 0. 00042600
EXEC SQL CLOSE TELE2 END-EXEC. 00042700
4000-LIST-GENERIC-EXIT. 00042800
EXIT. 00042900
* 00043000
4500-LIST-AND-GET. 00043100
MOVE PPHONE TO EMP-RECORD. 00043200
CALL 'ISPLINK' USING I-TBADD, TABLE-NAME. 00043300
EXEC SQL FETCH TELE2 INTO :PPHONE END-EXEC. 00043400
4500-LIST-AND-GET-EXIT. 00043500
EXIT. 00043600
*---------------------------------------------------------------* 00043700
* SPECIFIC LIST OF EMPLOYEES * 00043800
*---------------------------------------------------------------* 00043900
5000-LIST-SPECIFIC. 00044000
EXEC SQL OPEN TELE3 END-EXEC. 00044100
MOVE SPACES TO SQLERRP. 00044200
EXEC SQL FETCH TELE3 INTO :PPHONE END-EXEC. 00044300
IF SQLERRP = SPACES 00044400
MOVE '079E' TO MSGCODE 00044500
CALL 'DSN8MCG' USING MODULE, MSGCODE, OUTMSG 00044600
MOVE OUTMSG TO MSGS 00044700
ELSE 00044800
IF SQLCODE = 100 00044900
MOVE '008I' TO MSGCODE 00045000
CALL 'DSN8MCG' USING MODULE, MSGCODE, OUTMSG 00045100
MOVE OUTMSG TO MSGS 00045200
ELSE 00045300
MOVE 'Y' TO DISPLAY-TABLE 00045400
CALL 'ISPLINK' USING I-TBCREATE, TABLE-NAME, 00045500
W-BLANK, EMP-VARS, I-NOWRITE, I-REPLACE 00045600
PERFORM 5500-LIST-AND-GET 00045700
THRU 5500-LIST-AND-GET-EXIT 00045800
UNTIL SQLCODE NOT EQUAL 0. 00045900
EXEC SQL CLOSE TELE3 END-EXEC. 00046000
5000-LIST-SPECIFIC-EXIT. 00046100
EXIT. 00046200
* 00046300
5500-LIST-AND-GET. 00046400
MOVE PPHONE TO EMP-RECORD. 00046500
CALL 'ISPLINK' USING I-TBADD, TABLE-NAME. 00046600
EXEC SQL FETCH TELE3 INTO :PPHONE END-EXEC. 00046700
5500-LIST-AND-GET-EXIT. 00046800
EXIT. 00046900
* 00047000
*---------------------------------------------------------------* 00047100
* DISPLAY EMPLOYEE PHONE NUMBERS * 00047200
*---------------------------------------------------------------* 00047300
6000-DISPLAY-LIST. 00047400
EXEC SQL WHENEVER SQLERROR CONTINUE END-EXEC. 00047500
EXEC SQL WHENEVER SQLWARNING CONTINUE END-EXEC. 00047600
CALL 'ISPLINK' USING I-TBTOP, TABLE-NAME. 00047700
CALL 'ISPLINK' USING I-TBDISPL, TABLE-NAME, DIS-PANEL. 00047800
IF RETURN-CODE NOT EQUAL 8 00047900
CALL 'ISPLINK' USING I-VGET, DIS-VARS 00048000
PERFORM 6500-UPDATE-LOOP THRU 6500-UPDATE-LOOP-EXIT. 00048100
6000-DISPLAY-LIST-EXIT. 00048200
EXIT. 00048300
* 00048400
*---------------------------------------------------------------* 00048500
* DETERMINE IF UPDATE HAS BEEN REQUESTED * 00048600
*---------------------------------------------------------------* 00048700
6500-UPDATE-LOOP. 00048800
IF ROWS-CHANGED > 0 00048900
MOVE 'Y' TO MORE-CHANGES 00049000
PERFORM 7000-UPDATE THRU 7000-UPDATE-EXIT 00049100
UNTIL MORE-CHANGES = 'N'. 00049200
CALL 'ISPLINK' USING I-TBCLOSE, TABLE-NAME. 00049300
6500-UPDATE-LOOP-EXIT. 00049400
EXIT. 00049500
* 00049600
*---------------------------------------------------------------* 00049700
* UPDATE EMPLOYEE PHONE NUMBERS * 00049800
*---------------------------------------------------------------* 00049900
7000-UPDATE. 00050000
EXEC SQL UPDATE VEMPLP 00050100
SET PHONENUMBER = :EMPPHONE 00050200
WHERE EMPLOYEENUMBER = :EMPNUMB END-EXEC. 00050300
IF SQLCODE NOT EQUAL 0 00050400
MOVE '060E' TO MSGCODE 00050500
CALL 'DSN8MCG' USING MODULE, MSGCODE, OUTMSG 00050600
MOVE OUTMSG TO TMSG 00050700
MOVE TMSGTXT TO OUT-MESSAGE 00050800
MOVE SQLCODE TO CONVSQL 00050900
MOVE CONVSQL TO SQL-CODE 00051000
EXEC SQL ROLLBACK END-EXEC 00051100
MOVE 'N' TO MORE-CHANGES 00051200
ELSE 00051300
MOVE '004I' TO MSGCODE 00051400
CALL 'DSN8MCG' USING MODULE, MSGCODE, OUTMSG 00051500
MOVE OUTMSG TO MSGS 00051600
CALL 'ISPLINK' USING I-TBPUT, TABLE-NAME 00051700
IF ROWS-CHANGED > 1 00051800
CALL 'ISPLINK' USING I-TBDISPL, TABLE-NAME 00051900
CALL 'ISPLINK' USING I-VGET, DIS-VARS 00052000
ELSE MOVE 'N' TO MORE-CHANGES. 00052100
7000-UPDATE-EXIT. 00052200
EXIT. 00052300
* 00052400
*---------------------------------------------------------------* 00052500
* DB2 ERROR PROCESSING * 00052600
*---------------------------------------------------------------* 00052700
L8000-P3-DBERROR. 00052800
MOVE '060E' TO MSGCODE. 00052900
CALL 'DSN8MCG' USING MODULE, MSGCODE, OUTMSG. 00053000
MOVE OUTMSG TO TMSG. 00053100
MOVE TMSGTXT TO OUT-MESSAGE. 00053200
MOVE SQLCODE TO CONVSQL. 00053300
MOVE CONVSQL TO SQL-CODE. 00053400
CALL 'ISPLINK' USING I-VPUT, MSGS-VAR. 00053500
GOBACK. 00053600