DSN8IP3
THIS MODULE LISTS EMPLOYEE PHONE NUMBERS AND UPDATES THEM IF DESIRED.
DSN8IP3: PROC(IOPCB_ADDR,ALTPCB_ADDR) OPTIONS (MAIN);
/**********************************************************************
* *
* MODULE NAME = DSN8IP3 *
* *
* DESCRIPTIVE NAME = DB2 SAMPLE APPLICATION *
* PHONE APPLICATION *
* IMS *
* PL/I *
* *
* COPYRIGHT = 5665-DB2 (C) COPYRIGHT IBM CORP 1982, 1991 *
* SEE COPYRIGHT INSTRUCTIONS *
* LICENSED MATERIALS - PROPERTY OF IBM *
* *
* STATUS = VERSION 2 RELEASE 3, LEVEL 0 *
* *
* FUNCTION = THIS MODULE LISTS EMPLOYEE PHONE NUMBERS AND *
* UPDATES THEM IF DESIRED. *
* *
* NOTES = *
* DEPENDENCIES = TWO MFS MAPS ARE REQUIRED: *
* DSN8IPL AND DSN8IPN *
* RESTRICTIONS = NONE *
* *
* MODULE TYPE = PL/I PROC OPTIONS(MAIN) *
* PROCESSOR = DB2 PRECOMPILER, PL/I OPTIMIZER *
* MODULE SIZE = SEE LINKEDIT *
* ATTRIBUTES = REENTRANT *
* *
* ENTRY POINT = DSN8IP3 *
* PURPOSE = SEE FUNCTION *
* LINKAGE = INVOKED FROM IMS *
* *
* INPUT = PARAMETERS EXPLICITLY PASSED TO THIS FUNCTION: *
* INPUT-MESSAGE: *
* *
* SYMBOLIC LABEL/NAME = DSN8IPNO *
* DESCRIPTION = PHONE MENU 1 (SELECT) *
* *
* SYMBOLIC LABEL/NAME = DSN8IPLO *
* DESCRIPTION = PHONE MENU 2 (UPDATE) *
* *
* SYMBOLIC LABEL/NAME = VPHONE *
* DESCRIPTION = VIEW OF TELEPHONE INFORMATION *
* *
* SYMBOLIC LABEL/NAME = VEMPLP *
* DESCRIPTION = VIEW OF EMPLOYEE INFORMATION *
* *
* OUTPUT = PARAMETERS EXPLICITLY RETURNED: *
* OUTPUT-MESSAGE: *
* *
* SYMBOLIC LABEL/NAME = DSN8IPNO *
* DESCRIPTION = PHONE MENU 1 (SELECT) *
* *
* SYMBOLIC LABEL/NAME = DSN8IPLO *
* DESCRIPTION = PHONE MENU 2 (UPDATE) *
* *
* EXIT-NORMAL = RETURN CODE 0 NORMAL COMPLETION *
* *
* EXIT-ERROR = *
* *
* RETURN CODE = NONE *
* *
* ABEND CODES = NONE *
* *
* ERROR-MESSAGES = *
* DSN8004I - EMPLOYEE SUCCESSFULLY UPDATED *
* DSN8007E - EMPLOYEE DOES NOT EXIST, UPDATE NOT DONE *
* DSN8008I - NO EMPLOYEE FOUND IN TABLE *
* DSN8058I - PRESS PA1 FOR NEXT PAGE / ENTER FOR *
* SELECTION MENU *
* DSN8060E - SQL ERROR, RETURN CODE IS: *
* DSN8064E - INVALID DL/I STC-CODE ON GU MSG *
* DSN8065E - INVALID DL/I STC-CODE ON ISRT MSG *
* *
* EXTERNAL REFERENCES = *
* ROUTINES/SERVICES = *
* DSN8MPG - ERROR MESSAGE ROUTINE *
* *
* DATA-AREAS = *
* IN_MESSAGE - MFS INPUT *
* OUT_MESSAGE - MFS OUTPUT *
* *
* CONTROL-BLOCKS = *
* SQLCA - SQL COMMUNICATION AREA *
* *
* TABLES = NONE *
* *
* *
* CHANGE-ACTIVITY = NONE *
* *
* *
* *PSEUDOCODE* *
* *
* PROCEDURE *
* CALL DLI GU INPUT MESSAGE. *
* IF STATUS CODE NOT OK THEN SEND ERROR MESSAGE , *
* PGM-STOP. *
* *
* CASE (ACTION) *
* *
* SUBCASE ('L') *
* IF LASTNAME IS '*' THEN *
* LIST ALL EMPLOYEES *
* PREPARE OUTPUT_MESSAGE *
* CALL DLI ISRT OUTPUT_MESSAGE *
* ELSE *
* IF LASTNAME CONTAINS '%' THEN *
* LIST EMPLOYEES GENERIC *
* PREPARE OUTPUT_MESSAGE *
* CALL DLI ISRT OUTPUT_MESSAGE *
* ELSE *
* LIST EMPLOYEES SPECIFIC *
* PREPARE OUTPUT_MESSAGE *
* CALL DLI ISRT OUTPUT_MESSAGE *
* ENDSUB *
* *
* SUBCASE ('U') *
* DO WHILE INPUT PHONE_NO ^= BLANK *
* UPDATE PHONE_NO FOR EMPLOYEE *
* END *
* PREPARE OUTPUT_MESSSAGE *
* CALL DLI ISRT OUTPUT MESSAGE *
* OTHERWISE *
* UNFORMATTED SCREEN *
* PREPARE OUTPUT_MESSSAGE *
* CALL DLI ISRT OUTPUT MESSAGE *
* ENDSUB *
* *
* ENDCASE *
* *
* IF SQL OR DL/I ERROR HAS OCCURRED THEN *
* ROLLBACK *
* PGM-STOP. *
* END. *
* *
*-------------------------------------------------------------------*/
1/*********************************************************************/
/* DECLARATION FOR INPUT: MODNAME DSN8IPNI/DSN8IPLI */
/*********************************************************************/
0DCL 1 IN_MESSAGE STATIC,
2 LL BIN FIXED (31),
2 ZZ CHAR (2),
2 TC_CODE CHAR (7),
2 ACTION CHAR (1),
2 MESSAGE CHAR (500);
0DCL 1 INPUT_1 BASED(ADDR(MESSAGE)),
2 LNAME CHAR (15),
2 FNAME CHAR (12);
0DCL 1 INPUT_2 (15) BASED(ADDR(MESSAGE)),
2 NEWNO CHAR (4),
2 ENO CHAR (6);
-/*********************************************************************/
/* DECLARATION FOR OUTPUT: MODNAME DSN8IPNO/DSN8IPLO */
/*********************************************************************/
0DCL 1 OUT_MESSAGE STATIC,
2 LL BIN FIXED (31),
2 ZZ BIN FIXED (15) INIT (0),
2 ERROR CHAR (79),
2 OUTPUT CHAR (1095);
0DCL 1 OUTPUT_1 BASED(ADDR(OUTPUT)),
2 LASTNAME CHAR (15),
2 FIRSTNAME CHAR (12);
0DCL 1 OUTPUT_2 (15) BASED(ADDR(OUTPUT)),
2 FIRSTNAME CHAR (12),
2 MIDDLEINITIAL CHAR (1),
2 LASTNAME CHAR (15),
2 PHONENUMBER CHAR (4),
2 EMPLOYEENUMBER CHAR (6),
2 DEPTNUMBER CHAR (3),
2 DEPTNAME CHAR (32); /* 32 TO FIT ON ONE LINE */
DCL CHAR_SQLCODE CHAR (14);
DCL 1 CHAR_SQLSTR BASED(ADDR(CHAR_SQLCODE)),
2 CHAR_BLNK CHAR(4),
2 CHAR_SQLCOD CHAR(10);
0/*********************************************************************/
/* DECLARATION FOR IO / ALTPCB MASK */
/*********************************************************************/
0DCL (IOPCB_ADDR,ALTPCB_ADDR) POINTER;
0DCL 1 IOPCB BASED (IOPCB_ADDR),
2 IOLTERM CHAR (8),
2 FILLER CHAR (2),
2 STC_CODE CHAR (2);
0DCL 1 ALTPCB BASED (ALTPCB_ADDR),
2 ALTLTERM CHAR (8),
2 FILLER CHAR (2),
2 STC_CODE CHAR (2);
0/*********************************************************************/
/* DECLARATION FOR PGM-LOGIC */
/*********************************************************************/
0DCL ONE BIN FIXED (31) INIT (1) STATIC;
DCL THREE BIN FIXED (31) INIT (3) STATIC;
DCL FOUR BIN FIXED (31) INIT (4) STATIC;
0DCL GU_FKT CHAR (4) INIT ('GU ') STATIC;
DCL ISRT_FKT CHAR (4) INIT ('ISRT') STATIC;
DCL CHNG_FKT CHAR (4) INIT ('CHNG') STATIC;
DCL ROLL_FKT CHAR (4) INIT ('ROLL') STATIC;
0DCL MODNAME CHAR (8) STATIC;
DCL FIRST BIT (1) STATIC;
DCL EMPLOYEE_NO CHAR (6) STATIC;
DCL PHONE_NO CHAR (4) STATIC;
0DCL (I,M,ITAB) BIN FIXED(15);
0DCL (ADDR,INDEX,SUBSTR) BUILTIN;
0DCL TRANSLATE BUILTIN;
0DCL SYSPRINT EXTERNAL PRINT FILE;
0DCL PLITDLI EXTERNAL ENTRY;
0DCL DSN8MPG EXTERNAL ENTRY;
/********************************************************/
/* ** FIELDS SENT TO MESSAGE ROUTINE */
/********************************************************/
DCL MODULE CHAR (07) INIT ('DSN8IP3');
DCL OUTMSG CHAR (69);
1/*********************************************************************/
/* DECLARATION FOR SQL */
/*********************************************************************/
0EXEC SQL INCLUDE SQLCA; /* SQL COMMUNICATION AREA */
/* SQL DECLARATION FOR VIEW PHONE */
EXEC SQL DECLARE VPHONE TABLE
(LASTNAME VARCHAR(15) ,
FIRSTNAME VARCHAR(12) ,
MIDDLEINITIAL CHAR(1) ,
PHONENUMBER CHAR(4) ,
EMPLOYEENUMBER CHAR(6) ,
DEPTNUMBER CHAR(3) NOT NULL,
DEPTNAME VARCHAR(36) NOT NULL);
/* STUCTURE FOR PHONE RECORD */
DCL 1 PPHONE,
2 LASTNAME CHAR (15) VAR,
2 FIRSTNAME CHAR (12) VAR,
2 MIDDLEINITIAL CHAR (1),
2 PHONENUMBER CHAR (4),
2 EMPLOYEENUMBER CHAR (6),
2 DEPTNUMBER CHAR (3),
2 DEPTNAME CHAR (36) VAR;
/* SQL DECLARATION FOR VIEW VEMPLP*/
EXEC SQL DECLARE VEMPLP TABLE
(EMPLOYEENUMBER CHAR(6) ,
PHONENUMBER CHAR(4));
/* STRUCTURE FOR PEMPLP RECORD */
DCL 1 PEMP,
2 EMPLOYEENUMBER CHAR (6),
2 PHONENUMBER CHAR (4);
1/*********************************************************************/
/* SQL CURSORS */
/*********************************************************************/
EXEC SQL DECLARE TELE1 CURSOR FOR
SELECT *
FROM VPHONE;
EXEC SQL DECLARE TELE2 CURSOR FOR
SELECT *
FROM VPHONE
WHERE LASTNAME LIKE :INPUT_1.LNAME
AND FIRSTNAME LIKE :INPUT_1.FNAME;
EXEC SQL DECLARE TELE3 CURSOR FOR
SELECT *
FROM VPHONE
WHERE LASTNAME = :INPUT_1.LNAME
AND FIRSTNAME LIKE :INPUT_1.FNAME;
1/*********************************************************************/
/* SQL RETURN CODE HANDLING */
/*********************************************************************/
EXEC SQL WHENEVER SQLERROR GOTO P3_DBERROR;
EXEC SQL WHENEVER SQLWARNING GOTO P3_DBERROR;
EXEC SQL WHENEVER NOT FOUND CONTINUE;
/*********************************************************************/
/* MAIN PROGRAM ROUTINE */
/*********************************************************************/
/*INITIALIZATIONS */
0P3_START:
IN_MESSAGE = ''; /* SCREEN INPUT */
OUT_MESSAGE = ''; /* SCREEN OUTPUT */
OUT_MESSAGE.LL = 83; /* LINE LENGTH */
MODNAME = 'DSN8IPNO'; /* MODULE NAME */
FIRST = '1'B;
ITAB = 0; /* COUNTER */
0 CALL PLITDLI (THREE,GU_FKT,IOPCB,IN_MESSAGE);
/* IF INVALID DL/I */
/* STC-CODE ON GU MSG */
/* PRINT ERROR MESSAGE*/
0 IF IOPCB.STC_CODE ^= ' ' THEN
DO;
CALL DSN8MPG (MODULE, '064E', OUTMSG);
ERROR = OUTMSG||IOPCB.STC_CODE;
CALL P3_SEND;
END;
/*********************************************************************/
/* SELECT ACTION */
/*********************************************************************/
0 SELECT (ACTION);
WHEN ('L') DO; /* ACTION - LIST */
/**************************************************************/
/* REDISPLAY SELECTION SCREEN IF NO CRITERIA ENTERED */
/**************************************************************/
0 IF INPUT_1.LNAME = ' ' &
INPUT_1.FNAME = ' ' THEN
DO;
CALL P3_SEND;
GOTO P3_END;
END;
MODNAME = 'DSN8IPLO'; /* SELECT "LISTING" PANEL */
/*********************************************************************/
/* LIST ALL EMPLOYEES */
/*********************************************************************/
0 IF INPUT_1.LNAME = '*' THEN /* LIST ALL EMPLOYEES */
DO;
EXEC SQL OPEN TELE1; /* OPEN CURSOR */
EXEC SQL FETCH TELE1 /* GET FIRST RECORD */
INTO :PPHONE;
0 IF SQLCODE = 100 THEN /* NO EMPLOYEES FOUND */
DO; /* PRINT ERROR MESSAGE*/
MODNAME = 'DSN8IPNO';
CALL DSN8MPG (MODULE, '008I', OUTMSG);
ERROR = OUTMSG;
CALL P3_SEND;
GOTO P3_SELECT_20;
END;
CALL P3_PREPARE_SCREEN; /* LIST FIRST EMPLOYEE*/
P3_SELECT_10:
EXEC SQL FETCH TELE1 /* GET NEXT RECORD */
INTO :PPHONE;
0 IF SQLCODE = 100 THEN /* FINISHED ? */
DO;
ERROR = '';
CALL P3_SEND;
GOTO P3_SELECT_20;
END;
CALL P3_PREPARE_SCREEN; /* LIST EMPLOYEE */
GOTO P3_SELECT_10; /* CONTINUE */
P3_SELECT_20:
EXEC SQL CLOSE TELE1; /* CLOSE CURSOR */
GOTO P3_END;
END; /* END IF */
/*********************************************************************/
/* LIST GENERIC EMPLOYEES */
/*********************************************************************/
ELSE DO; /* SELECT EMPLOYEES BY NAME*/
/* SEARCH ON PART OF NAME? */
IF INPUT_1.LNAME = ' ' THEN /* IS NAME BLANK*/
INPUT_1.LNAME = '%%%%%%%%%%%%%%%'; /* SET PATTERN */
IF INDEX(INPUT_1.LNAME,'%') > 0 THEN
DO;
/* YES, SEARCH ON */
/* PART OF LAST NAME */
/* (OPT. PART FIRST NAME) */
/* TRANSLATE IT */
INPUT_1.LNAME = TRANSLATE(INPUT_1.LNAME,'%',' ');
INPUT_1.FNAME = TRANSLATE(INPUT_1.FNAME,'%',' ');
EXEC SQL OPEN TELE2; /* OPEN CURSOR */
EXEC SQL FETCH TELE2 /* GET FIRST RECORD */
INTO :PPHONE;
0 IF SQLCODE = 100 THEN /* NO EMPLOYEES FOUND */
DO; /* PRINT ERROR MESSAGE */
MODNAME = 'DSN8IPNO';
CALL DSN8MPG (MODULE, '008I', OUTMSG);
ERROR = OUTMSG;
CALL P3_SEND;
GOTO P3_SELECT_40;
END;
CALL P3_PREPARE_SCREEN; /* LIST FIRST EMPLOYEE */
P3_SELECT_30:
EXEC SQL FETCH TELE2 /* GET NEXT RECORD */
INTO :PPHONE;
0 IF SQLCODE = 100 THEN /* FINISHED? */
DO;
ERROR = '';
CALL P3_SEND;
GOTO P3_SELECT_40;
END;
CALL P3_PREPARE_SCREEN; /* LIST EMPLOYEE */
GOTO P3_SELECT_30; /* CONTINUE */
P3_SELECT_40:
EXEC SQL CLOSE TELE2; /* CLOSE CURSOR */
GOTO P3_END;
END; /* END IF */
/*********************************************************************/
/* LIST SPECIFIC EMPLOYEE(S) */
/*********************************************************************/
ELSE DO; /* NO - SEARCH ON LAST NAME*/
/*AND OPTIONALLY FIRST NAME*/
INPUT_1.FNAME = TRANSLATE(INPUT_1.FNAME,'%',' ');
EXEC SQL OPEN TELE3; /* OPEN CURSOR */
EXEC SQL FETCH TELE3 /* GET FIRST RECORD */
INTO :PPHONE;
0 IF SQLCODE = 100 THEN /* EMPLOYEE NOT FOUND */
DO; /* PRINT ERROR MESSAGE */
MODNAME = 'DSN8IPNO';
CALL DSN8MPG (MODULE, '008I', OUTMSG);
ERROR = OUTMSG;
CALL P3_SEND;
GOTO P3_SELECT_60;
END;
CALL P3_PREPARE_SCREEN; /* LIST FIRST EMPLOYEE */
P3_SELECT_50:
EXEC SQL FETCH TELE3 /* GET NEXT RECORD */
INTO :PPHONE;
0 IF SQLCODE = 100 THEN /* FINISHED ? */
DO;
ERROR = '';
CALL P3_SEND;
GOTO P3_SELECT_60;
END;
CALL P3_PREPARE_SCREEN; /* LIST EMPLOYEE */
GOTO P3_SELECT_50; /* CONTINUE */
P3_SELECT_60:
EXEC SQL CLOSE TELE3; /* CLOSE CURSOR */
END; /* END IF */
END; /* END IF */
END; /* END WHEN */
/* CHANGE ERROR HANDLING */
/* FOR UPDATE */
EXEC SQL WHENEVER SQLERROR CONTINUE;
EXEC SQL WHENEVER SQLWARNING CONTINUE;
/*********************************************************************/
/* UPDATE PHONE NUMBERS FOR EMPLOYEES */
/*********************************************************************/
0 WHEN ('U') DO; /* TELEPHONE UPDATE */
OUT_MESSAGE.LL = 110;
MODNAME = 'DSN8IPNO';
/* FIND WHICH NUMBERS HAVE */
/* BEEN UPDATED */
ERROR = ''; /* SET IN CASE NO UPDATES */
0 DO I = 1 TO 15;
IF INPUT_2.NEWNO(I) = ' ' THEN; /* NO UPDATE ON THIS LINE */
ELSE DO; /* PERFORM UPDATE */
EMPLOYEE_NO = INPUT_2.ENO(I);
PHONE_NO = INPUT_2.NEWNO(I);
0 EXEC SQL UPDATE VEMPLP
SET PHONENUMBER = :PHONE_NO
WHERE EMPLOYEENUMBER = :EMPLOYEE_NO;
/* UPDATE SUCCESSFUL */
/* PRINT CONFIRMATION */
/* MESSAGE */
0 IF SQLCODE = 0 THEN
DO;
0 CALL DSN8MPG (MODULE, '004I', OUTMSG);
ERROR = OUTMSG;
END;
/* UPDATE FAILED */
/* PRINT ERROR MESSAGE */
ELSE
DO;
CALL DSN8MPG (MODULE, '007E', OUTMSG);
ERROR = OUTMSG;
GOTO P3_DBERROR2;
END;
END; /* END IF */
END; /* END WHEN */
0 CALL P3_SEND;
END;
0 OTHERWISE /* UNFORMATTED SCREEN */
DO;
OUT_MESSAGE.LL = 110;
MODNAME = 'DSN8IPNO';
CALL P3_SEND;
END;
END; /* END SELECT */
0 GOTO P3_END;
1/*********************************************************************/
/* SQL ERROR HANDLING */
/*********************************************************************/
0P3_DBERROR:
CALL DSN8MPG (MODULE, '060E', OUTMSG);
CHAR_SQLCODE = SQLCODE;
ERROR = OUTMSG||CHAR_SQLCOD;
PUT DATA (ERROR,SQLWARN0); /*PRINT ERROR MESSAGE */
0P3_DBERROR2:
0 CALL PLITDLI (THREE,CHNG_FKT,ALTPCB,IOLTERM);
0 IF ALTPCB.STC_CODE ^= ' ' THEN; /* PERFORM ROLLBACK */
ELSE CALL PLITDLI (FOUR,ISRT_FKT,ALTPCB,OUT_MESSAGE,MODNAME);
0 CALL PLITDLI (ONE,ROLL_FKT);
0 GOTO P3_END;
1/*********************************************************************/
/* PRINT INFORMATION ON SCREEN */
/*********************************************************************/
1P3_PREPARE_SCREEN:
PROC;
/*IF ANOTHER PAGE */
IF ITAB = 15 THEN /* PRINT SCROLLING MESSAGE */
DO;
CALL DSN8MPG (MODULE, '058I', OUTMSG);
ERROR = OUTMSG;
CALL P3_SEND;
ITAB = 0; /* INITIALIZE COUNTER */
OUT_MESSAGE.LL = 83; /* INITIALIZE LINE LENGTH */
END;
ITAB = ITAB + 1; /* INCREMENT COUNTER */
/* MOVE DATA TO OUTPUT AREA*/
OUTPUT_2 (ITAB) = PPHONE , BY NAME;
OUT_MESSAGE.LL = OUT_MESSAGE.LL + 73;
RETURN;
END P3_PREPARE_SCREEN;
1P3_SEND:
PROC;
IF FIRST THEN
DO;
CALL PLITDLI (FOUR,ISRT_FKT,IOPCB,OUT_MESSAGE,MODNAME);
FIRST = '0'B;
END;
ELSE CALL PLITDLI (THREE,ISRT_FKT,IOPCB,OUT_MESSAGE);
0 IF IOPCB.STC_CODE = ' ' THEN RETURN;
/* INVALID DL/I STC-CODE ON ISRT MSG*/
/* PRINT ERROR MESSAGE */
CALL DSN8MPG (MODULE, '065E', OUTMSG);
0 ERROR = OUTMSG||IOPCB.STC_CODE;
0 CALL PLITDLI (THREE,CHNG_FKT,ALTPCB,IOLTERM);
0 IF ALTPCB.STC_CODE ^= ' ' THEN; /* PERFORM ROLLBACK */
ELSE CALL PLITDLI (FOUR,ISRT_FKT,ALTPCB,OUT_MESSAGE,MODNAME);
0 CALL PLITDLI (ONE,ROLL_FKT);
RETURN;
/******************************************************************/
0END P3_SEND; /* END OF PROGRAM */
0P3_END:
END DSN8IP3;