DSN8BF3
THIS MODULE LISTS EMPLOYEE PHONE NUMBERS AND UPDATES THEM IF DESIRED.
PROGRAM DSN8B3
**********************************************************************
* *
* MODULE NAME = DSN8BF3, PROGRAM DSN8B3 *
* *
* DESCRIPTIVE NAME = DB2 SAMPLE APPLICATION *
* PHONE APPLICATION *
* BATCH *
* FORTRAN *
* *
* LICENSED MATERIALS - PROPERTY OF IBM *
* 5695-DB2 *
* (C) COPYRIGHT 1982, 1995 IBM CORP. ALL RIGHTS RESERVED. *
* *
* STATUS = VERSION 4 *
* *
* FUNCTION = THIS MODULE LISTS EMPLOYEE PHONE NUMBERS AND *
* UPDATES THEM IF DESIRED. *
* *
* NOTES = NONE *
* *
* *
* MODULE TYPE = FORTRAN PROGRAM *
* PROCESSOR = DB2 PRECOMPILER, VS FORTRAN *
* MODULE SIZE = SEE LINK EDIT *
* ATTRIBUTES = NOT REENTRANT OR REUSABLE *
* *
* ENTRY POINT = DSN8BF3 *
* PURPOSE = SEE FUNCTION *
* LINKAGE = INVOKED FROM DSN RUN *
* INPUT = *
* *
* SYMBOLIC LABEL/NAME = FT05F001 *
* DESCRIPTION = INPUT REQUEST FILE *
* *
* SYMBOLIC LABEL/NAME = VPHONE *
* DESCRIPTION = VIEW OF TELEPHONE INFORMATION *
* *
* OUTPUT = *
* *
* SYMBOLIC LABEL/NAME = FT06F001 *
* DESCRIPTION = = PRINTED REPORT AND RESULTS *
* *
* SYMBOLIC LABEL/NAME = VEMPLP *
* DESCRIPTION = VIEW OF EMPLOYEE INFORMATION *
* *
* *
* EXIT-NORMAL = RETURN CODE 0 NORMAL COMPLETION *
* *
* EXIT-ERROR = *
* *
* RETURN CODE = NONE *
* *
* ABEND CODES = NONE *
* *
* ERROR-MESSAGES = *
* DSN8000I - REQUEST IS: ... *
* DSN8004I - EMPLOYEE SUCCESSFULLY UPDATED *
* DSN8007E - EMPLOYEE DOES NOT EXIST, UPDATE NOT DONE *
* DSN8008I - NO EMPLOYEE FOUND IN TABLE *
* DSN8051I - PROGRAM ENDED *
* DSN8053I - ROLLBACK SUCCESSFUL, ALL UPDATES REMOVED *
* DSN8060E - SQL ERROR, RETURN CODE IS: *
* DSN8061E - ROLLBACK FAILED, RETURN CODE IS: *
* DSN8068E - INVALID REQUEST, SHOULD BE 'L' OR 'U' *
* DSN8075E - MESSAGE FORMAT ERROR, *
* RETURN CODE IS: *
* *
* EXTERNAL REFERENCES = *
* ROUTINES/SERVICES = *
* DSNTIR - TRANSLATE SQLCA INTO MESSAGES *
* *
* DATA-AREAS = NONE *
* *
* CONTROL-BLOCKS = *
* SQLCA - SQL COMMUNICATION AREA *
* *
* TABLES = NONE *
* *
* CHANGE-ACTIVITY = NONE *
* *
* *
* *PSEUDOCODE* *
* *
* PROCEDURE *
* DO WHILE MORE INPUT *
* GET INPUT *
* CREATE REPORT HEADING *
* CASE (ACTION) *
* *
* SUBCASE ('L') *
* IF LASTNAME IS '*' THEN *
* LIST ALL EMPLOYEES *
* ELSE *
* IF LASTNAME CONTAINS '%' THEN *
* LIST EMPLOYEES GENERIC *
* ELSE *
* LIST EMPLOYEES SPECIFIC *
* ENDSUB *
* *
* SUBCASE ('U') *
* UPDATE PHONENUMBER FOR EMPLOYEE *
* WRITE CONFIRMATION MESSAGE *
* *
* OTHERWISE *
* INVALID REQUEST *
* ENDSUB *
* *
* ENDCASE *
* GET NEXT INPUT *
* END *
* *
* IF SQL ERROR OCCURS THEN *
* ROLLBACK *
* END. *
* *
*--------------------------------------------------------------------*
*************************************
* SQL DECLARATION FOR VIEW VPHONE *
*************************************
EXEC SQL DECLARE VPHONE TABLE
C (LASTNAME VARCHAR(15) NOT NULL,
C FIRSTNAME VARCHAR(12) NOT NULL,
C MIDDLEINITIAL CHAR( 1) NOT NULL,
C PHONENUMBER CHAR( 4) ,
C EMPLOYEENUMBER CHAR( 6) NOT NULL,
C DEPTNUMBER CHAR( 3) NOT NULL,
C DEPTNAME VARCHAR(36) NOT NULL)
*************************************
* SQL DECLARATION FOR VIEW VEMPLP *
*************************************
EXEC SQL DECLARE VEMPLP TABLE
C (EMPLOYEENUMBER CHAR( 6) NOT NULL,
C PHONENUMBER CHAR( 4) )
*************************************
* PPHONE FIELDS *
*************************************
CHARACTER * 15 LASTNM
CHARACTER * 12 FIRSTN
CHARACTER * 1 MIDINI
CHARACTER * 4 PHONEN
CHARACTER * 6 EMPNO
CHARACTER * 3 DEPTNO
CHARACTER * 36 DEPTNM
*************************************
* INPUT FIELDS *
*************************************
CHARACTER * 1 ACTION
CHARACTER * 15 LNAME
CHARACTER * 12 FNAME
CHARACTER * 6 ENO
CHARACTER * 4 NEWNO
CHARACTER * 15 LNAMEW
CHARACTER * 12 FNAMEW
*************************************
* SQL CURSORS *
*************************************
EXEC SQL DECLARE TELE1 CURSOR FOR
C SELECT *
C FROM VPHONE
EXEC SQL DECLARE TELE2 CURSOR FOR
C SELECT *
C FROM VPHONE
C WHERE LASTNAME LIKE :LNAMEW
C AND FIRSTNAME LIKE :FNAMEW
EXEC SQL DECLARE TELE3 CURSOR FOR
C SELECT *
C FROM VPHONE
C WHERE LASTNAME = :LNAME
C AND FIRSTNAME LIKE :FNAMEW
*************************************
* SQL RETURN CODES: OK/NOTFOUND *
*************************************
INTEGER OK/0/,NOTFND/100/
*************************************
* REPORT FORMATS AND INPUT *
*************************************
100 FORMAT ('0',A29,A21,A28)
200 FORMAT ('0',A9,7X,A10,3X,A7,1X,A5,2X,A8,
C 1X,A4,1X,A4,/,38X,A6,1X,A6,3X,
C A4,1X,A4,1X,A4,/)
300 FORMAT (' ',A15,1X,A12,4X,A1,4X,A4,3X,A6,3X,
C A3,2X,A36)
400 FORMAT (A1,A15,A12,A6,A4)
500 FORMAT ('0', A)
600 FORMAT ('0', A, I8)
700 FORMAT ('1',A,//,
C 5X,'REQUEST',2X,'LAST NAME',8X,'FIRST NAME',4X,
C 'EMPNO',3X,'NEW XT.NO',/,
C 3X,'--',A1,6X,'--',A15,'--',A12,'--',A6,'--',A4,' --')
800 FORMAT ('1')
*************************************
* MESSAGES *
*************************************
CHARACTER * 30 DSN800
CHARACTER * 48 DSN804
CHARACTER * 60 DSN868
CHARACTER * 59 DSN807
CHARACTER * 45 DSN860
CHARACTER * 59 DSN853
CHARACTER * 51 DSN861
CHARACTER * 45 DSN808
CHARACTER * 64 DSN875
CHARACTER * 32 DSN851
*************************************
* VARIABLES USED WITH DSNTIR *
*************************************
INTEGER ERRLEN /960/
CHARACTER*120 ERRTXT(8)
*************************************
* MISCELLANEOUS VARIABLES *
*************************************
INTEGER I, ICODE
CHARACTER * 15 PERC15
*************************************
* SQL COMMUNICATION AREA *
*************************************
EXEC SQL INCLUDE SQLCA
*************************************
* DATA STATEMENTS *
*************************************
DATA PERC15
C/'%%%%%%%%%%%%%%%'/
DATA DSN800
C/'DSN8000I: DSN8BF3-REQUEST IS:'/
DATA DSN804
C/'DSN8004I: DSN8BF3-EMPLOYEE SUCCESSFULLY UPDATED'/
DATA DSN868
C/'DSN8068E: DSN8BF3-INVALID REQUEST, SHOULD BE ''L'' OR ''U'''/
DATA DSN807
C/'DSN8007E: DSN8BF3-EMPLOYEE DOES NOT EXIST, UPDATE NOT DONE'/
DATA DSN860
C/'DSN8060E: DSN8BF3-SQL ERROR, RETURN CODE IS:'/
DATA DSN853
C/'DSN8053I: DSN8BF3-ROLLBACK SUCCESSFUL, ALL UPDATES REMOVED'/
DATA DSN861
C/'DSN8061E: DSN8BF3-ROLLBACK FAILED, SQLCODE IS:'/
DATA DSN808
C/'DSN8008I: DSN8BF3-NO EMPLOYEE FOUND IN TABLE'/
DATA DSN875
C/'DSN8075E: DSN8BF3-MESSAGE FORMAT ROUTINE ERROR, RETURN CODE IS:
C'/
DATA DSN851
C/'DSN8051I: DSN8BF3-PROGRAM ENDED'/
*************************************
* SQL RETURN CODE HANDLING *
*************************************
EXEC SQL WHENEVER SQLERROR GOTO 4000
EXEC SQL WHENEVER SQLWARNING GOTO 4000
*************************************
* START OF PROGRAM *
*************************************
*************************************
* CONTINUE WHILE MORE INPUT *
*************************************
1000 CONTINUE
*************************************
* GET NEXT INPUT *
*************************************
READ (UNIT=05,FMT=400,END=3000) ACTION, LNAME, FNAME, ENO, NEWNO
WRITE (UNIT=06,FMT=700) DSN800, ACTION, LNAME, FNAME, ENO, NEWNO
WRITE (UNIT=06,FMT=800)
*************************************
* CREATE REPORT HEADING *
* SELECT ACTION *
*************************************
* **CREATE REPORT HEADING
WRITE (UNIT=06,FMT=100) '-----------------------------',
C ' TELEPHONE DIRECTORY ',
C '----------------------------'
WRITE (UNIT=06,FMT=200) 'LAST NAME', 'FIRST NAME', 'INITIAL',
C 'PHONE', 'EMPLOYEE', 'WORK', 'WORK', 'NUMBER',
C 'NUMBER', 'DEPT', 'DEPT', 'NAME'
* **SELECT ACTION
* **LIST EMPLOYEES
IF (ACTION .EQ. 'L') THEN
GOTO 1010
* **PERFORM UPDATE
ELSE IF (ACTION .EQ. 'U') THEN
GOTO 1700
* **INVALID REQUEST
ELSE
GOTO 1800
END IF
1010 CONTINUE
************************************
* ACTION - LIST *
************************************
IF (LNAME .NE. '*') GOTO 1300
***************************************
* LIST ALL EMPLOYEES *
***************************************
* **OPEN CURSOR
EXEC SQL OPEN TELE1
NBRETR = 0
1100 CONTINUE
* **GET EMPLOYEE
EXEC SQL FETCH TELE1 INTO
C :LASTNM,:FIRSTN,:MIDINI,
C :PHONEN,:EMPNO,:DEPTNO,:DEPTNM
IF (SQLCOD .EQ. NOTFND) GO TO 1200
* **LIST ALL EMPLOYEES
NBRETR = NBRETR + 1
WRITE (UNIT=06,FMT=300)
C LASTNM,FIRSTN,MIDINI,
C PHONEN, EMPNO, DEPTNO, DEPTNM
GO TO 1100
* **NO EMPLOYEE FOUND
* **PRINT ERROR MESSAGE
1200 CONTINUE
IF (NBRETR .EQ. 0) WRITE (UNIT=06,FMT=500) DSN808
* **CLOSE CURSOR
EXEC SQL CLOSE TELE1
GO TO 1000
*************************************
* ELSE DETERMINE IF LASTNAME *
* OR FIRSTNAME IS GIVEN *
*************************************
1300 CONTINUE
IPOS=INDEX(LNAME,'%')
********************************************
* REPLACE FIRST BLANK AND FOLLOWING *
* CHARACTERS IN LASTNAME WORK (LNAMEW) *
* WITH CHARACTER % FOR LIKE PREDICATE. *
********************************************
IBLANK=INDEX(LNAME,' ')
IF (IBLANK .GT. 1 ) THEN
LNAMEW = LNAME(1:IBLANK-1)//PERC15(1:15-IBLANK+1)
ELSE IF (IBLANK .EQ. 1) THEN
LNAMEW=PERC15
IPOS = 1
ELSE
END IF
********************************************
* REPLACE FIRST BLANK AND FOLLOWING *
* CHARACTERS IN FIRSTNAME WORK (FNAMEW) *
* WITH CHARACTER % FOR LIKE PREDICATE. *
********************************************
IBLANK=INDEX(FNAME,' ')
IF (IBLANK .GT. 1 ) THEN
FNAMEW = FNAME(1:IBLANK-1)//PERC15(1:12-IBLANK+1)
ELSE IF (IBLANK .EQ. 1) THEN
FNAMEW=PERC15(1:12)
ELSE
END IF
IF (IPOS .LE. 0) GOTO 1600
********************************************
* LIST GENERIC EMPLOYEES *
********************************************
* **OPEN CURSOR
EXEC SQL OPEN TELE2
NBRETR = 0
1400 CONTINUE
* **GET EMPLOYEES
EXEC SQL FETCH TELE2 INTO
C :LASTNM,:FIRSTN,:MIDINI,
C :PHONEN,:EMPNO,:DEPTNO,:DEPTNM
IF (SQLCOD .EQ. NOTFND) GO TO 1500
* **LIST GENERIC EMPLOYEES
NBRETR = NBRETR + 1
WRITE (UNIT=06,FMT=300)
C LASTNM,FIRSTN,MIDINI,
C PHONEN, EMPNO, DEPTNO, DEPTNM
GOTO 1400
* **EMPLOYEE NOT FOUND
* **PRINT ERROR MESSAGE
1500 CONTINUE
IF (NBRETR .EQ. 0) WRITE (UNIT=06,FMT=500) DSN808
* **CLOSE CURSOR
EXEC SQL CLOSE TELE2
GOTO 1000
********************************************
* LIST SPECIFIC EMPLOYEES *
********************************************
1600 CONTINUE
* **OPEN CURSOR
EXEC SQL OPEN TELE3
NBRETR = 0
1620 CONTINUE
* **GET EMPLOYEES
EXEC SQL FETCH TELE3 INTO
C :LASTNM,:FIRSTN,:MIDINI,
C :PHONEN,:EMPNO,:DEPTNO,:DEPTNM
IF (SQLCOD .EQ. NOTFND) GO TO 1640
* **LIST SPECIFIC EMPLOYEES
NBRETR = NBRETR + 1
WRITE (UNIT=06,FMT=300)
C LASTNM,FIRSTN,MIDINI,
C PHONEN, EMPNO, DEPTNO, DEPTNM
GO TO 1620
* **EMPLOYEE NOT FOUND
* **PRINT ERROR MESSAGE
1640 CONTINUE
IF (NBRETR .EQ. 0) WRITE (UNIT=06,FMT=500) DSN808
* **CLOSE CURSOR
EXEC SQL CLOSE TELE3
GO TO 1000
************************************************
* UPDATE PHONE NUMBERS FOR EMPLOYEES *
************************************************
1700 CONTINUE
* **PERFORM UPDATE
EXEC SQL UPDATE VEMPLP
C SET PHONENUMBER = :NEWNO
C WHERE EMPLOYEENUMBER = :ENO
IF (SQLCOD .EQ. OK) THEN
* **UPDATE SUCCESSFUL
* **EMPLOYEE FOUND
* **PRINT CONFIRMATION
* **MESSAGE
WRITE (UNIT=06,FMT=500) DSN804
ELSE
* **UPDATE FAILED
* **EMPLOYEE NOT FOUND
* **PRINT ERROR MESSAGE
WRITE (UNIT=06,FMT=500) DSN807
END IF
GO TO 1000
* ** INVALID REQUEST
* ** PRINT ERROR MESSAGE
1800 CONTINUE
WRITE (UNIT=06,FMT=500) DSN868
GO TO 1000
******************
* END OF LOOP *
* FOR MORE INPUT *
******************
* ** THIS LABEL IS
* ** BRANCHED TO FOR
* ** END OF DATA
3000 CONTINUE
WRITE (UNIT=06,FMT=800)
WRITE (UNIT=06,FMT=500) DSN851
RETURN
*********************************************
* IF SQL ERROR OCCURRED - GET ERROR MESSAGE*
*********************************************
EXEC SQL WHENEVER SQLERROR CONTINUE
EXEC SQL WHENEVER SQLWARNING CONTINUE
EXEC SQL WHENEVER NOT FOUND CONTINUE
4000 CONTINUE
* **SQL ERROR
* **PRINT ERROR MESSAGE
WRITE (UNIT=06,FMT=600) DSN860, SQLCOD
CALL DSNTIR ( ERRLEN, ERRTXT, ICODE )
IF (ICODE .EQ. OK) THEN
DO 4100 I=1, 10
WRITE (UNIT=06,FMT=500) ERRTXT(I)
4100 CONTINUE
ELSE
* **ERROR DETECTED BY
* **MESSAGE FORMAT
* **ROUTINE
* **PRINT ERROR MESSAGE
WRITE (UNIT=06,FMT=600) DSN875, ICODE
END IF
* **PERFORM ROLLBACK
EXEC SQL ROLLBACK
IF (SQLCOD .EQ. OK) THEN
* **ROLLBACK SUCCESSFUL
* **PRINT CONFIRMATION
* **MESSAGE
WRITE (UNIT=06,FMT=500) DSN853
ELSE
* **ROLLBACK FAILED
* **PRINT ERROR MESSAGE
WRITE (UNIT=06,FMT=600) DSN861, SQLCOD
END IF
RETURN
END