* Copyright © Oracle Corporation 1995. All Rights Reserved. IDENTIFICATION DIVISION. ************************************************************** * * PROGRAM-ID. JOBINFO. * * * * * Version: 01 * * Edit: 00 * * Edit date: APR-85 * * Authors: DLE * * CZ * * * ************************************************************** ************************************************************** * P R O G R A M D E S C R I P T I O N * * * * JOBINFO is a COBOL Oracle Rdb preprocessor program used to * * change job related information for existing employees in * * the Oracle Rdb PERSONNEL Database. * * * * Once the EMPLOYEE-ID existence is verified, tasks can * * be selected. Only the information needed to perform * * the selected task is requested, and current information * * is not brought to the screen, in an effort to keep the * * program simple. * * * * Checking for nonexistent DEPARTMENT and JOB codes, * * EMPLOYEE and SUPERVISOR IDs is done with streams * * instead of CONSTRAINTS. No check is done to see if * * the incoming SALARY_AMOUNT is greater than the MAXIMUM * * allowed for the new JOB-CODE. * * * * Deadlock and lock conflict are checked. If they occur * * a ROLLBACK is done, and the information is requested * * again. * * * * Oracle Rdb errors are checked against the Oracle Rdb message files * * the error messages returned are maintained in a user * * message file, PERSMSG.MSG. * * * * * ************************************************************** * * ** * * * (C) Copyright 1981 * * Digital Equipment Corporation, Maynard, Massachusetts * * * * DIGITAL assumes no responsiblity for the use or relia- * * bility of its software on equipment that is not sup- * * plied by DIGITAL. * ************************************************************** DATE-COMPILED. ENVIRONMENT DIVISION. CONFIGURATION SECTION. SOURCE-COMPUTER. VAX-11. OBJECT-COMPUTER. VAX-11. ************************************************************** DATA DIVISION. WORKING-STORAGE SECTION. * Local variables. 01 DISPLAY-VARS. * For starting on LINE 1. 02 L1 PIC 99 VALUE IS 1. * For starting on any line. 02 LINNUM PIC 99 VALUE IS ZEROS. 02 COLNUM PIC 99 VALUE IS 10. 01 INPUT-VARS. * For OPTION selection. 02 ONE PIC 9 VALUE IS 1. 02 TWO PIC 9 VALUE IS 2. 02 THREE PIC 9 VALUE IS 3. 02 FOUR PIC 9 VALUE IS 4. 02 FIVE PIC 9 VALUE IS 5. 02 SIX PIC 9 VALUE IS 6. 02 SEVEN PIC 9 VALUE IS 7. * For user-input information. 02 ID-NUMBER PIC X(5) VALUE IS SPACES. 02 START-DATE PIC X(11) VALUE IS SPACES. 01 INPUT-SALARY PIC X(5). 01 SALARY-REDEFINED REDEFINES INPUT-SALARY PIC S9(5). 01 SALARY-COMP PIC S9(5) USAGE COMP. 01 OPTION PIC 9 VALUE IS ZERO. 01 OPT1 PIC X VALUE IS SPACES. * Local error message variables. 01 ERR-MSG-VARS. 02 WHAT-ERROR PIC X(5) VALUE IS SPACES. 02 WHAT-FETCHED PIC X(5) VALUE IS SPACES. 02 ATEND PIC X(5) VALUE IS "ATEND". 02 IDEND PIC X(5) VALUE IS "IDEND". 02 LOCKD PIC X(5) VALUE IS "LOCKD". 02 PTMSG PIC X(5) VALUE IS "PTMSG". * Working storage variables for fetching database information. 01 WS-FETCH-VARS. 02 CURR-JOB-CODE PIC X(4) VALUE IS SPACES. 02 CURR-DEPT-CODE PIC X(4) VALUE IS SPACES. 02 CURR-SUP-ID PIC X(5) VALUE IS SPACES. 02 NEW-DEPT-CODE PIC X(4) VALUE IS SPACES. 02 NEW-SUP-ID PIC X(5) VALUE IS SPACES. *$BINTIM variables. 01 BINTIMVARS. 02 BINTIMBUF PIC S9(11)V9(7) COMP. 02 BINTIMADR PIC S9(11)V9(7) COMP. *PERSMSG message symbols. Passes via $GETMSG. 01 MSG-FILE-FLAGS. 02 IDNOTFND PIC S9(9) COMP VALUE EXTERNAL PERS_IDNOTFND. 02 JCNOTFND PIC S9(9) COMP VALUE EXTERNAL PERS_JCNOTFND. 02 DCNOTFND PIC S9(9) COMP VALUE EXTERNAL PERS_DCNOTFND. 02 UNEXPATEND PIC S9(9) COMP VALUE EXTERNAL PERS_UNEXPATEND. *RDBVMS Message symbols. 01 RDB$_DEADLOCK PIC S9(9) COMP VALUE EXTERNAL RDB$_DEADLOCK. 01 RDB$_LOCK_CONFLICT PIC S9(9) COMP VALUE EXTERNAL RDB$_LOCK_CONFLICT. *$GETMSG variables. 01 GETMSGVARS. 02 MSG-ID PIC 9(9) COMP. 02 MSG-LEN PIC 9(9) COMP. 02 MSG-TXT PIC X(132). 02 MASK PIC 9(9) COMP VALUE 15. 02 OUT-ARRAY PIC X(4). 01 STATUS-RESULT PIC S9(5) COMP. ************************************************************** * * Record definitions used extracted from the database definitions * in the CDD. Qualification for these FIELDS when used must be * in the format FIELD-NAME IN RECORD_NAME. * ************************************************************** COPY "PERSONNEL.RDB$RELATIONS.JOB_HISTORY" FROM DICTIONARY. COPY "PERSONNEL.RDB$RELATIONS.SALARY_HISTORY" FROM DICTIONARY. ************************************************************** &RDB& DATABASE FILENAME 'RDM$DEMO:PERSONNEL' /************************************************************* * * * M A I N S U B - P R O G R A M L O G I C * * * ************************************************************** PROCEDURE DIVISION. ************************************************************** MAIN-SECTION. PERFORM INITIAL-INPUT THRU INITIAL-INPUT-EXIT. PERFORM DISPLAY-GET-OPTION UNTIL OPTION = SIX OR OPTION = SEVEN. IF OPTION EQUAL SIX THEN STOP RUN ELSE MOVE ZEROS TO OPTION GO TO MAIN-SECTION. INITIAL-INPUT. DISPLAY "" LINE L1 COLUMN 1 ERASE SCREEN. DISPLAY "EMPLOYEE JOB UPDATE PROGRAM" BOLD LINE L1 PLUS 1 COLUMN 22. DISPLAY "" LINE L1 PLUS 2 COLUMN 1 ERASE LINE. DISPLAY " Please enter the Employee-id number for "LINE L1 PLUS 3 COLUMN 1. DISPLAY " the employee record you wish to change."LINE L1 PLUS 3 COLUMN 41. PERFORM GETCHK-EMP-ID THRU GETCHK-EMP-EXIT. IF WHAT-ERROR NOT EQUAL SPACES THEN PERFORM EVAL-WHAT-ERROR THRU EVAL-EXIT GO TO INITIAL-INPUT-EXIT END-IF. INITIAL-INPUT-EXIT. EXIT. GETCHK-EMP-ID. PERFORM INIT-VARS. DISPLAY "EMPLOYEE-ID:" LINE L1 PLUS 5 ERASE LINE. ACCEPT ID-NUMBER PROTECTED REVERSED LINE L1 PLUS 5 COLUMN 13. * * Check to see if the Employee exists. No other transaction can * be performed unless the EMPLOYEE-ID currently exists in the database. * &RDB& START_TRANSACTION READ_ONLY &RDB& ON ERROR PERFORM LOCK-ERROR-CHECK GO TO GETCHK-EMP-EXIT &RDB& END_ERROR &RDB& START_STREAM EMPIDCHK USING &RDB& E IN EMPLOYEES WITH E.EMPLOYEE_ID = ID-NUMBER &RDB& FETCH EMPIDCHK &RDB& ON ERROR PERFORM LOCK-ERROR-CHECK GO TO GETCHK-EMP-EXIT &RDB& END_ERROR &RDB& AT END MOVE IDNOTFND TO MSG-ID MOVE ID-NUMBER TO WHAT-FETCHED MOVE IDEND TO WHAT-ERROR GO TO GETCHK-EMP-EXIT &RDB& END_FETCH &RDB& GET &RDB& ON ERROR PERFORM LOCK-ERROR-CHECK GO TO GETCHK-EMP-EXIT &RDB& END_ERROR &RDB& EMPLOYEE_ID IN JOB_HISTORY = E.EMPLOYEE_ID &RDB& END_GET &RDB& ROLLBACK. GETCHK-EMP-EXIT. EXIT. DISPLAY-GET-OPTION. DISPLAY "" LINE 1 COLUMN 1 ERASE SCREEN. DISPLAY "Record has been located for Employee-id--" UNDERLINED LINE 2 COLUMN 1. DISPLAY ID-NUMBER UNDERLINED LINE 2 COLUMN 47. DISPLAY "" LINE 3 COLUMN 1 ERASE LINE. DISPLAY "Please enter a selection number for " UNDERLINED LINE 4 COLUMN 1. DISPLAY "the task you wish to use." UNDERLINED LINE 4 COLUMN 37. DISPLAY "" LINE 5 COLUMN 1 ERASE LINE. DISPLAY "Select Number 1 for transfer". DISPLAY "Select Number 2 for raise". DISPLAY "Select Number 3 raise/promotion". DISPLAY "Select Number 4 raise/promotion/transfer". DISPLAY "Select Number 5 for termination". DISPLAY "Select Number 6 to exit". DISPLAY "Select Number 7 to enter a new EMPLOYEE-ID". DISPLAY "Enter option:" LINE 14 ERASE LINE. ACCEPT OPTION PROTECTED REVERSED LINE 14 COLUMN 15. EVALUATE OPTION WHEN ONE PERFORM TRANSFER-ONLY THRU TRANSFER-EXIT WHEN TWO PERFORM RAISE-ONLY THRU RAISE-EXIT WHEN THREE PERFORM RAISE-PROMOTION THRU RAISE-PROMOTION-EXIT WHEN FOUR PERFORM RZE-PROM-TRAN THRU RZE-PROM-TRAN-EXIT WHEN FIVE PERFORM TERMINATION-ONLY THRU TERMINATION-EXIT END-EVALUATE. TRANSFER-ONLY. * * TRANSFER-ONLY modifies current JOB_HISTORY, and stores a new JOB_HISTORY. * PERFORM GET-DEPT-NFO. PERFORM CHK-DEPT-NFO THRU CHK-DEPT-NFO-EXIT. IF WHAT-ERROR NOT EQUAL SPACES THEN PERFORM EVAL-WHAT-ERROR THRU EVAL-EXIT GO TO TRANSFER-EXIT END-IF. PERFORM CONVERT-DATE. MOVE BINTIMBUF TO JOB_START IN JOB_HISTORY. PERFORM MODIFY-JOBEND-DATE THRU MODIFY-JOBEND-EXIT. IF WHAT-ERROR NOT EQUAL SPACES THEN PERFORM EVAL-WHAT-ERROR THRU EVAL-EXIT GO TO TRANSFER-EXIT END-IF. MOVE NEW-SUP-ID TO SUPERVISOR_ID IN JOB_HISTORY MOVE CURR-JOB-CODE TO JOB_CODE IN JOB_HISTORY. PERFORM STORE-JOBDEPT THRU STORE-JOBDEPT-EXIT. IF WHAT-ERROR NOT EQUAL SPACES THEN PERFORM EVAL-WHAT-ERROR THRU EVAL-EXIT GO TO TRANSFER-EXIT END-IF. TRANSFER-EXIT. EXIT. RAISE-ONLY. * * RAISE-ONLY modifies SALARY_HISTORY and store a new SALARY_HISTORY. * PERFORM GET-SALARY-NFO. PERFORM CONVERT-DATE. MOVE BINTIMBUF TO SALARY_START IN SALARY_HISTORY. PERFORM MODIFY-SALEND-DATE THRU STORE-SALARY-EXIT. IF WHAT-ERROR NOT EQUAL SPACES THEN PERFORM EVAL-WHAT-ERROR THRU EVAL-EXIT GO TO RAISE-EXIT END-IF. RAISE-EXIT. EXIT. RAISE-PROMOTION. * * RAISE-PROMOTION verifies that the user-entered JOB-CODE exists in the * database. If it does, it modifies current JOB-END date in JOB_HISTORY, * and fetches the current JOB_HISTORY information (whatever is not changing * needed to store the new JOB_HISTORY record. It then modifies current * SALARY-END date in SALARY_HISTORY and stores new SALARY_HISTORY. * PERFORM GET-JOB-NFO. PERFORM CHK-JOB-NFO THRU CHK-JOB-NFO-EXIT. IF WHAT-ERROR NOT EQUAL SPACES THEN PERFORM EVAL-WHAT-ERROR THRU EVAL-EXIT GO TO RAISE-PROMOTION-EXIT END-IF. * Convert date for JOB_HISTORY. PERFORM CONVERT-DATE. MOVE BINTIMBUF TO JOB_START IN JOB_HISTORY. PERFORM GET-SALARY-NFO. PERFORM CONVERT-DATE. MOVE BINTIMBUF TO SALARY_START IN SALARY_HISTORY. * Modify JOB_END date. Fetch current information for new record. PERFORM MODIFY-JOBEND-DATE THRU MODIFY-JOBEND-EXIT. IF WHAT-ERROR NOT EQUAL SPACES THEN PERFORM EVAL-WHAT-ERROR THRU EVAL-EXIT GO TO RAISE-PROMOTION-EXIT END-IF. * Move current information to store new JOB_HISTORY. MOVE CURR-DEPT-CODE TO DEPARTMENT_CODE IN JOB_HISTORY. MOVE CURR-SUP-ID TO SUPERVISOR_ID IN JOB_HISTORY. * Store new JOB_HISTORY. PERFORM STORE-JOBDEPT THRU STORE-JOBDEPT-EXIT. IF WHAT-ERROR NOT EQUAL SPACES THEN PERFORM EVAL-WHAT-ERROR THRU EVAL-EXIT GO TO RAISE-PROMOTION-EXIT END-IF. * Modify existing SALEND_DATE, store new SALARY_HISTORY. PERFORM MODIFY-SALEND-DATE THRU STORE-SALARY-EXIT. IF WHAT-ERROR NOT EQUAL SPACES THEN PERFORM EVAL-WHAT-ERROR THRU EVAL-EXIT GO TO RAISE-PROMOTION-EXIT END-IF. RAISE-PROMOTION-EXIT. EXIT. RZE-PROM-TRAN. * * RZE-PROM-TRAN verifies existence for new JOB_CODE and DEPT_CODE. * Modifies existing JOB_HISTORY, stores new JOB_HISTORY, modifies * existing SALARY_HISTORY, stores new SALARY_HISTORY. * PERFORM GET-JOB-NFO. PERFORM CHK-JOB-NFO THRU CHK-JOB-NFO-EXIT. IF WHAT-ERROR NOT EQUAL SPACES THEN PERFORM EVAL-WHAT-ERROR THRU EVAL-EXIT GO TO RZE-PROM-TRAN-EXIT END-IF. * Convert Date for JOB_HISTORY. PERFORM CONVERT-DATE. MOVE BINTIMBUF TO JOB_START IN JOB_HISTORY. PERFORM GET-DEPT-NFO. PERFORM CHK-DEPT-NFO THRU CHK-DEPT-NFO-EXIT. IF WHAT-ERROR NOT EQUAL SPACES THEN PERFORM EVAL-WHAT-ERROR THRU EVAL-EXIT GO TO RZE-PROM-TRAN-EXIT END-IF. *Get salary information. PERFORM GET-SALARY-NFO. *Convert date for SALARY_HISTORY. PERFORM CONVERT-DATE. MOVE BINTIMBUF TO SALARY_START IN SALARY_HISTORY. PERFORM MODIFY-JOBEND-DATE THRU MODIFY-JOBEND-EXIT. IF WHAT-ERROR NOT EQUAL SPACES THEN PERFORM EVAL-WHAT-ERROR THRU EVAL-EXIT GO TO RZE-PROM-TRAN-EXIT END-IF. PERFORM STORE-JOBDEPT THRU STORE-JOBDEPT-EXIT. IF WHAT-ERROR NOT EQUAL SPACES THEN PERFORM EVAL-WHAT-ERROR THRU EVAL-EXIT GO TO RZE-PROM-TRAN-EXIT END-IF. PERFORM MODIFY-SALEND-DATE THRU STORE-SALARY-EXIT. IF WHAT-ERROR NOT EQUAL SPACES THEN PERFORM EVAL-WHAT-ERROR THRU EVAL-EXIT GO TO RZE-PROM-TRAN-EXIT END-IF. RZE-PROM-TRAN-EXIT. EXIT. TERMINATION-ONLY. * * TERMINATION-ONLY, modifies the EMPLOYEE, JOB_HISTORY, and * SALARY_HISTORY record. * PERFORM MODIFY-EMP-STATUS THRU MODIFY-EMP-EXIT. IF WHAT-ERROR NOT EQUAL SPACES THEN PERFORM EVAL-WHAT-ERROR THRU EVAL-EXIT GO TO TERMINATION-EXIT END-IF. TERMINATION-EXIT. EXIT. GET-JOB-NFO. DISPLAY "" LINE 1 COLUMN 1 ERASE SCREEN. DISPLAY "ENTER NEW JOB CODE: " LINE L1 PLUS 3 ERASE LINE. ACCEPT JOB-CODE IN JOB_HISTORY PROTECTED REVERSED LINE L1 PLUS 3 COLUMN 21. DISPLAY "ENTER NEW JOB START DATE: " LINE L1 PLUS 4 ERASE LINE. ACCEPT START-DATE PROTECTED REVERSED LINE L1 PLUS 4 COLUMN 26. GET-DEPT-NFO. DISPLAY "" LINE 1 COLUMN 1 ERASE SCREEN. DISPLAY "ENTER NEW DEPARTMENT CODE: " LINE L1 PLUS 3 ERASE LINE. ACCEPT DEPARTMENT_CODE OF JOB_HISTORY PROTECTED REVERSED LINE L1 PLUS 3 COLUMN 28. DISPLAY "ENTER DATE FOR TRANSFER: " LINE L1 PLUS 4 ERASE LINE. ACCEPT START-DATE PROTECTED REVERSED LINE L1 PLUS 4 COLUMN 26. GET-SALARY-NFO. DISPLAY "" LINE 1 COLUMN 1 ERASE SCREEN. DISPLAY "ENTER NEW SALARY AMOUNT:" LINE L1 PLUS 3 ERASE LINE. ACCEPT INPUT-SALARY PROTECTED REVERSED LINE L1 PLUS 3 COLUMN 25. MOVE SALARY-REDEFINED TO SALARY-COMP. MOVE SALARY-COMP TO SALARY_AMOUNT IN SALARY_HISTORY. DISPLAY "ENTER NEW SALARY START DATE: " LINE L1 PLUS 4 ERASE LINE. ACCEPT START-DATE PROTECTED REVERSED LINE L1 PLUS 4 COLUMN 31. CHK-JOB-NFO. * Verify that the incoming JOB_CODE exists in the database. PERFORM INIT-VARS. &RDB& START-TRANSACTION READ-ONLY &RDB& ON ERROR PERFORM LOCK-ERROR-CHECK GO TO CHK-JOB-NFO-EXIT &RDB& END_ERROR &RDB& START-STREAM JOBCODE USING &RDB& J IN JOBS WITH J.JOB_CODE = JOB_CODE IN JOB_HISTORY &RDB& ON ERROR PERFORM LOCK-ERROR-CHECK GO TO CHK-JOB-NFO-EXIT &RDB& END_ERROR &RDB& FETCH JOBCODE &RDB& ON ERROR PERFORM LOCK-ERROR-CHECK GO TO CHK-JOB-NFO-EXIT &RDB& END_ERROR &RDB& AT END MOVE JCNOTFND TO MSG-ID MOVE JOB_CODE IN JOB_HISTORY TO WHAT-FETCHED MOVE ATEND TO WHAT-ERROR GO TO CHK-JOB-NFO-EXIT &RDB& END_FETCH &RDB& GET &RDB& ON ERROR PERFORM LOCK-ERROR-CHECK GO TO CHK-JOB-NFO-EXIT &RDB& END_ERROR &RDB& JOB_CODE IN JOB_HISTORY = J.JOB_CODE &RDB& END_GET &RDB& ROLLBACK. CHK-JOB-NFO-EXIT. EXIT. CHK-DEPT-NFO. * Verify that the new DEPARTMENT-CODE exists. Since program needs the new * SUPERVISOR-ID (to store the new JOB_HISTORY record), do that verification * by checking first the DEPARTMENT-CODE in DEPARTMENTS, then crossing * that DEPARTMENT_CODE to JOB_HISTORY and fetching the SUPERVISOR-ID * for that DEPARTMENT. PERFORM INIT-VARS. &RDB& START-TRANSACTION READ-ONLY &RDB& ON ERROR PERFORM LOCK-ERROR-CHECK GO TO CHK-DEPT-NFO-EXIT &RDB& END_ERROR &RDB& START-STREAM DEPTCODE USING &RDB& D IN DEPARTMENTS &RDB& CROSS JH IN JOB_HISTORY &RDB& WITH D.DEPARTMENT_CODE = DEPARTMENT_CODE IN JOB_HISTORY &RDB& AND JH.DEPARTMENT_CODE = D.DEPARTMENT_CODE &RDB& AND JH.JOB_END MISSING &RDB& ON ERROR PERFORM LOCK-ERROR-CHECK GO TO CHK-DEPT-NFO-EXIT &RDB& END_ERROR &RDB& FETCH DEPTCODE &RDB& ON ERROR PERFORM LOCK-ERROR-CHECK GO TO CHK-DEPT-NFO-EXIT &RDB& END_ERROR &RDB& AT END MOVE DCNOTFND TO MSG-ID MOVE DEPARTMENT_CODE IN JOB_HISTORY TO WHAT-FETCHED MOVE ATEND TO WHAT-ERROR GO TO CHK-DEPT-NFO-EXIT &RDB& END_FETCH &RDB& GET &RDB& ON ERROR PERFORM LOCK-ERROR-CHECK GO TO CHK-DEPT-NFO-EXIT &RDB& END_ERROR &RDB& NEW-DEPT-CODE = JH.DEPARTMENT_CODE; &RDB& NEW-SUP-ID = JH.SUPERVISOR_ID &RDB& END_GET &RDB& ROLLBACK. CHK-DEPT-NFO-EXIT. EXIT. MODIFY-JOBEND-DATE. * Modify the current JOB_HISTORY record to include a JOB_END date. * Fetch the current JOB_CODE, DEPARTMENT_CODE, and SUPERVISOR_ID * needed for storing the new JOB_HISTORY record. PERFORM INIT-VARS. &RDB& START-TRANSACTION READ_WRITE RESERVING JOB_HISTORY &RDB& FOR PROTECTED WRITE &RDB& ON ERROR PERFORM LOCK-ERROR-CHECK GO TO MODIFY-JOBEND-EXIT &RDB& END_ERROR &RDB& START_STREAM JOBEND USING JHM IN JOB_HISTORY &RDB& WITH JHM.EMPLOYEE_ID = ID-NUMBER &RDB& AND JHM.JOB_END MISSING &RDB& ON ERROR PERFORM LOCK-ERROR-CHECK GO TO MODIFY-JOBEND-EXIT &RDB& END_ERROR &RDB& FETCH JOBEND &RDB& ON ERROR PERFORM LOCK-ERROR-CHECK GO TO MODIFY-JOBEND-EXIT &RDB& END_ERROR &RDB& AT END MOVE UNEXPATEND TO MSG-ID MOVE ATEND TO WHAT-ERROR GO TO MODIFY-JOBEND-EXIT &RDB& END_FETCH &RDB& GET &RDB& ON ERROR PERFORM LOCK-ERROR-CHECK GO TO MODIFY-JOBEND-EXIT &RDB& END_ERROR &RDB& CURR-JOB-CODE = JHM.JOB_CODE; &RDB& CURR-DEPT-CODE = JHM.DEPARTMENT_CODE; &RDB& CURR-SUP-ID = JHM.SUPERVISOR_ID &RDB& END_GET &RDB& MODIFY JHM USING &RDB& ON ERROR PERFORM LOCK-ERROR-CHECK GO TO MODIFY-JOBEND-EXIT &RDB& END_ERROR &RDB& JHM.JOB_END = JOB_START IN JOB_HISTORY &RDB& END_MODIFY &RDB& END_STREAM JOBEND. MODIFY-JOBEND-EXIT. EXIT. STORE-JOBDEPT. * Store a new JOB_HISTORY Record. PERFORM INIT-VARS. &RDB& STORE JHS IN JOB_HISTORY USING &RDB& ON ERROR PERFORM LOCK-ERROR-CHECK GO TO STORE-JOBDEPT-EXIT &RDB& END_ERROR &RDB& JHS.EMPLOYEE_ID = ID-NUMBER; &RDB& JHS.JOB_CODE = JOB_CODE IN JOB_HISTORY; &RDB& JHS.JOB_START = JOB_START IN JOB_HISTORY; &RDB& JHS.DEPARTMENT_CODE = DEPARTMENT_CODE IN JOB_HISTORY; &RDB& JHS.SUPERVISOR_ID = SUPERVISOR_ID IN JOB_HISTORY; &RDB& END_STORE &RDB& COMMIT. STORE-JOBDEPT-EXIT. EXIT. MODIFY-SALEND-DATE. * Modify the existing SALARY_START date. PERFORM INIT-VARS. &RDB& START_TRANSACTION READ_WRITE &RDB& RESERVING SALARY_HISTORY FOR PROTECTED WRITE &RDB& ON ERROR PERFORM LOCK-ERROR-CHECK GO TO STORE-SALARY-EXIT &RDB& END_ERROR &RDB& FOR SH IN SALARY_HISTORY &RDB& WITH SH.EMPLOYEE_ID = ID-NUMBER &RDB& AND SH.SALARY_END MISSING &RDB& MODIFY SH USING &RDB& ON ERROR PERFORM LOCK-ERROR-CHECK GO TO STORE-SALARY-EXIT &RDB& END_ERROR &RDB& SH.SALARY_END = SALARY_START IN SALARY_HISTORY &RDB& END_MODIFY &RDB& END_FOR. STORE-SALARY. * Store a new SALARY_HISTORY Record. PERFORM INIT-VARS. &RDB& STORE SH IN SALARY_HISTORY USING &RDB& ON ERROR PERFORM LOCK-ERROR-CHECK GO TO STORE-SALARY-EXIT &RDB& END_ERROR &RDB& SH.EMPLOYEE_ID = ID-NUMBER; &RDB& SH.SALARY_AMOUNT = SALARY_AMOUNT IN SALARY_HISTORY; &RDB& SH.SALARY_START = SALARY_START IN SALARY_HISTORY; &RDB& END_STORE &RDB& COMMIT. STORE-SALARY-EXIT. EXIT. MODIFY-EMP-STATUS. * Modify EMPLOYEES, JOB_HISTORY, SALARY_HISTORY. PERFORM INIT-VARS. &RDB& START-TRANSACTION READ_WRITE &RDB& RESERVING EMPLOYEES, JOB_HISTORY, SALARY_HISTORY &RDB& FOR PROTECTED WRITE &RDB& ON ERROR PERFORM LOCK-ERROR-CHECK GO TO MODIFY-EMP-EXIT &RDB& END_ERROR &RDB& FOR E1 IN EMPLOYEES &RDB& WITH E1.EMPLOYEE_ID = ID-NUMBER &RDB& MODIFY E1 USING &RDB& ON ERROR PERFORM LOCK-ERROR-CHECK GO TO MODIFY-EMP-EXIT &RDB& END_ERROR &RDB& E1.STATUS_CODE = 0 &RDB& END_MODIFY &RDB& END_FOR &RDB& FOR JM IN JOB_HISTORY WITH JM.EMPLOYEE_ID = ID-NUMBER &RDB& MODIFY JM USING &RDB& ON ERROR PERFORM LOCK-ERROR-CHECK GO TO MODIFY-EMP-EXIT &RDB& END_ERROR &RDB& JM.JOB_END = JOB_START IN JOB_HISTORY &RDB& END_MODIFY &RDB& END_FOR &RDB& FOR SM IN SALARY_HISTORY WITH SM.EMPLOYEE_ID = ID-NUMBER &RDB& MODIFY SM USING &RDB& ON ERROR PERFORM LOCK-ERROR-CHECK GO TO MODIFY-EMP-EXIT &RDB& END_ERROR &RDB& SM.SALARY_END = JOB_START IN JOB_HISTORY &RDB& END_MODIFY &RDB& END_FOR &RDB& COMMIT. MODIFY-EMP-EXIT. EXIT. ******************************************************************* INIT-VARS. INITIALIZE WHAT-ERROR. INITIALIZE MSG-ID. INITIALIZE STATUS-RESULT. CONVERT-DATE. SET STATUS-RESULT TO SUCCESS. CALL "SYS$BINTIM" USING BY DESCRIPTOR START-DATE BY REFERENCE BINTIMBUF GIVING STATUS-RESULT. IF STATUS-RESULT IS FAILURE THEN CALL "LIB$STOP" USING BY REFERENCE STATUS-RESULT. LOCK-ERROR-CHECK. * Note: * Using equality to check the value of RDB$STATUS assumes that * the severity level of the error symbol (RDB$_DEADLOCK and * RDB$_LOCK_CONFLICT in this case) has not changed. While * this method saves the performance hit of calling the system * service routine LIB$MATCH_COND, the user should be aware * that this check would fail if the severity level changes. * IF RDB$STATUS EQUAL RDB$_DEADLOCK OR RDB$STATUS EQUAL RDB$_LOCK_CONFLICT THEN MOVE LOCKD TO WHAT-ERROR ELSE MOVE PTMSG TO WHAT-ERROR. EVAL-WHAT-ERROR. EVALUATE WHAT-ERROR WHEN LOCKD PERFORM DISPLAY-LOCK-MESSAGE WHEN PTMSG PERFORM DISPLAY-PUTMSG-MESSAGE WHEN ATEND PERFORM DISPLAY-ATEND-MESSAGE WHEN IDEND PERFORM DISPLAY-ATEND-MESSAGE END-EVALUATE. EVAL-EXIT. EXIT. DISPLAY-LOCK-MESSAGE. &RDB& ROLLBACK MOVE SPACES TO ID-NUMBER. DISPLAY "" LINE 1 COLUMN 1 ERASE SCREEN. DISPLAY " A LOCK CONDITION HAS OCCURRED" BOLD LINE L1 PLUS 3 DISPLAY "Please enter RETURN to request new input" BOLD LINE L1 PLUS 4. ACCEPT OPT1. IF OPT1 IS EQUAL SPACES THEN NEXT SENTENCE. DISPLAY-PUTMSG-MESSAGE. MOVE SPACES TO ID-NUMBER. SET STATUS-RESULT TO SUCCESS. DISPLAY "" LINE 1 COLUMN 1 ERASE SCREEN. CALL "SYS$PUTMSG" USING BY REFERENCE RDB$MESSAGE_VECTOR GIVING STATUS-RESULT. IF STATUS-RESULT IS FAILURE THEN &RDB& FINISH CALL "LIB$STOP" USING BY VALUE STATUS-RESULT. &RDB& ROLLBACK DISPLAY "This condition was not expected" BOLD LINE L1 PLUS 2. DISPLAY "Please enter RETURN to request new input" BOLD LINE L1 PLUS 3. ACCEPT OPT1. IF OPT1 IS EQUAL SPACES THEN NEXT SENTENCE. DISPLAY-ATEND-MESSAGE. SET STATUS-RESULT TO SUCCESS. CALL "SYS$GETMSG" USING BY VALUE MSG-ID BY REFERENCE MSG-LEN BY DESCRIPTOR MSG-TXT BY VALUE MASK BY REFERENCE OUT-ARRAY GIVING STATUS-RESULT. IF STATUS-RESULT NOT SUCCESS THEN CALL "LIB$STOP" USING BY VALUE STATUS-RESULT END-IF. DISPLAY "" LINE 1 COLUMN 1 ERASE SCREEN. DISPLAY MSG-TXT(1:MSG-LEN) BOLD LINE L1 PLUS 2. DISPLAY "" LINE L1 PLUS 4 COLUMN 1 ERASE LINE. DISPLAY "Error occurred when attempting to fetch-- " BOLD LINE L1 PLUS 5. DISPLAY WHAT-FETCHED BOLD LINE L1 PLUS 5 COLUMN 43. DISPLAY "for EMPLOYEE-ID-- " BOLD LINE L1 PLUS 7 COLUMN 5. DISPLAY ID-NUMBER BOLD LINE L1 PLUS 7 COLUMN 24. DISPLAY "" LINE L1 PLUS 8 ERASE LINE. &RDB& ROLLBACK IF WHAT-ERROR IS EQUAL IDEND THEN MOVE SPACES TO ID-NUMBER END-IF. DISPLAY "Please enter RETURN to request new input" REVERSED LINE L1 PLUS 8 COLUMN 3. ACCEPT OPT1. IF OPT1 IS EQUAL SPACES THEN NEXT SENTENCE. EXIT-PROGRAM. EXIT.