* Copyright © Oracle Corporation 1995.  All Rights Reserved.
*++
*
* MODIFICATION HISTORY:
*
*   Version 6.0
*	31-May-95 17379 (CUD) Update Oracle Copyright
*   Version 5.0
*	15-Dec-92 09419 (JHD) Adding to DDAL msg doc file
*
*--
IDENTIFICATION DIVISION.
**************************************************************
*                                                            *
PROGRAM-ID. JOBINFOINT.
*                                                            *
*                                                            *
*               Version:        01                           *
*               Edit:           00                           *
*               Edit date:      MAY-85                       *
*               Authors:        DLE                          *
*                                                            *
**************************************************************
**************************************************************
*         P R O G R A M    D E S C R I P T I O N             *
*                                                            *
*  JOBINFOINT is a COBOL Oracle Rdb Interpreter program used    *
*  to change specific job related information for existing   *
*  employees in the Oracle Rdb PERSONNEL Database.              *
*  Only the information needed to perform the task is        *
*  is requested, and current information is not brought      *
*  to the screen in an attempt to keep the program simple.   *
*                                                            *
*  Checking for non-existent DEPARTMENT and JOB codes,       *
*  EMPLOYEE and SUPERVISOR IDs is done using streams         *
*  instead of CONSTRAINT definitions.  Fetching the          *
*  information to check that the new SALARY_AMOUNT is        *
*  less than the MAXIMUM allowed for the new JOB_CODE        *
*  is also done with streams.                                *
*                                                            *
*  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 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.
    02  L1		PIC 99 VALUE IS 1.
    02  COLNUM		PIC 99 VALUE IS 10.
* For OPTION selection.
01 INPUT-VARS.
   02  ANSYES		PIC X(1) VALUE IS "Y".
   02  ANSNO            PIC X(1) VALUE IS "N".
* 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 X VALUE IS SPACES.
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".
    02  MAXSA		PIC X(5) VALUE IS "MAXSA".
* 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.
   02  NEW-SAL-MAX	PIC S9(5) USAGE COMP.
01 RDMS-STRING		PIC X(256) VALUE IS SPACES.
*$BINTIM variables. 
01  BINTIMVARS.
    02  BINTIMBUF	PIC S9(11)V9(7) COMP.
    02  BINTIMADR	PIC S9(11)V9(7) COMP.
*ASCTIM variables.
01  ASCTIMVARS.
    02  FLDLEN		PIC 9999 VALUE IS ZEROS.
    02  ASCDATE		PIC X(11) VALUE IS SPACES.
    
*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.
   02  MAXSALEXC	PIC S9(9) COMP VALUE EXTERNAL PERS_MAXSALEXC.
*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.
01  SS-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.
/*************************************************************
*                                                            *
*        M A I N   S U B - P R O G R A M   L O G I C         *
*                                                            *
**************************************************************
PROCEDURE DIVISION.
MAIN-SECTION.
INV-DB.
    CALL "RDB$INTERPRET" USING BY DESCRIPTOR 
                "DATABASE FILENAME 'RDM$DEMO:PERSONNEL'"
                          GIVING STATUS-RESULT.

    IF STATUS-RESULT IS FAILURE
    THEN
       CALL "RDB$SIGNAL".

* If the error message returned via RDB$SIGNAL has a FATAL severity
* level the program will terminate.  If it is not a FATAL severity 
* level, program execution continues.  RDB$SIGNAL takes no arguments,
* and returns no status.

START-PERFORMS.
* See if user wants to continue. Keep asking til N or n.
    PERFORM DISPLAY-GET-OPTION UNTIL OPTION = ANSNO
	    OR OPTION = "n".
    IF OPTION EQUAL ANSNO OR OPTION EQUAL "n"
    THEN 
       STOP RUN
    ELSE 
       MOVE SPACES TO OPTION.

       GO TO START-PERFORMS.

DISPLAY-GET-OPTION.
* Say what program will do.
    DISPLAY "" LINE 1 COLUMN 1 ERASE SCREEN.
    DISPLAY "EMPLOYEE JOB UPDATE PROGRAM" BOLD LINE L1 PLUS COLUMN 22.
    DISPLAY "" LINE L1 PLUS 2 COLUMN 1 ERASE LINE.
    DISPLAY "This program modifies an employees' record "LINE 
            L1 PLUS 3 COLUMN 1.
    DISPLAY " to show that the employee has received a" LINE 
            L1 PLUS 4 COLUMN 1.
    DISPLAY " raise, promotion and transfer." LINE L1 PLUS 5 COLUMN 1.
    DISPLAY "" LINE L1 PLUS 6 COLUMN 1 ERASE LINE.
    DISPLAY "Do you wish to continue?...(Y or N)" LINE L1 PLUS 7 COLUMN 1.
    ACCEPT OPTION PROTECTED REVERSED LINE L1 PLUS 7 COLUMN 36.
    EVALUATE OPTION
             WHEN ANSYES PERFORM RAISE-PROM-TRAN THRU RAISE-PROM-TRAN-EXIT
             WHEN "y" PERFORM RAISE-PROM-TRAN THRU RAISE-PROM-TRAN-EXIT
    END-EVALUATE.

RAISE-PROM-TRAN.
*
* PERFORMS return to the next executable statement after the conditions
* of the loop are met.   Error flags that may be set during the 
* PERFORM will then be checked.
*
* See if employee-id exists.
    PERFORM GETCHK-EMP-ID THRU GETCHK-EMP-EXIT.
	    IF WHAT-ERROR NOT EQUAL SPACES
            THEN 
               PERFORM EVAL-WHAT-ERROR THRU EVAL-EXIT
               GO RAISE-PROM-TRAN-EXIT
            END-IF.

* Get new department information.  NOTE: this PERFORM will be 
* automatically terminated and return when the next label 
* (after GET-DEPT-NFO) is encountered.
    PERFORM GET-DEPT-NFO.

* See if new department information is valid.  
    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 RAISE-PROM-TRAN-EXIT
            END-IF.

* Get new job information.  NOTE: this PERFORM will be automatically 
* terminated and return when the next label (after GET-JOB-NFO) 
* is encountered.
    PERFORM GET-JOB-NFO.

* See if new job information is valid.
    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-PROM-TRAN-EXIT
            END-IF.
*
* Convert Date from input format to system. NOTE: this PERFORM will
* be automatically terminated and return when the next label 
* (after CONVERT-DATE) is encountered.
*
    PERFORM CONVERT-DATE.
* Control returns here after PERFORM has executed.  BINTIMBUF now
* contains the date in system format and must be moved to JOB_START.
    MOVE BINTIMBUF TO JOB_START IN JOB_HISTORY.
*
* Get salary information. NOTE: this PERFORM will be automatically
* terminated and return when the next label (after GET-SALARY-NFO)
* is encountered.
*
    PERFORM GET-SALARY-NFO. 
* Control returns here after PERFORM has executed.  
* Check new SALARY-AMOUNT.  If larger than maximum allowed for the 
* new JOB-CODE (input by the user), don't want to store a new record,
* but instead return error to user.
    IF SALARY-REDEFINED IS GREATER THAN NEW-SAL-MAX
    THEN
        MOVE MAXSALEXC TO MSG-ID
        MOVE MAXSA TO WHAT-ERROR
        PERFORM EVAL-WHAT-ERROR
        GO TO RAISE-PROM-TRAN-EXIT
    ELSE
        MOVE SALARY-REDEFINED TO SALARY_AMOUNT IN SALARY_HISTORY.
*
* Check START-DATE, if spaces, user said that SALARY-START is the same as 
* JOB-START.  If not, must convert this date also.
*
    IF START-DATE EQUAL SPACES
    THEN
       MOVE JOB_START IN JOB_HISTORY TO SALARY_START IN SALARY_HISTORY
    ELSE
       PERFORM CONVERT-DATE
       MOVE BINTIMBUF TO SALARY_START IN SALARY_HISTORY.

* Things look ok, go modify the current JOB_HISTORY record to have
* a JOB_END date.
*
    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-PROM-TRAN-EXIT
            END-IF.

* Store a new JOB_HISTORY record.
    PERFORM STORE-JOBDEPT THRU STORE-JOBDEPT-EXIT.
	    IF WHAT-ERROR NOT EQUAL SPACES
            THEN 
               PERFORM EVAL-WHAT-ERROR THRU EVAL-EXIT
               GO TO RAISE-PROM-TRAN-EXIT
            END-IF.
*
* Modify current SALARY_HISTORY record to have a SALARY_END date,
* and store a new SALARY_HISTORY record.
*
    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-PROM-TRAN-EXIT
            END-IF.
RAISE-PROM-TRAN-EXIT.
     EXIT.

GETCHK-EMP-ID.
     PERFORM INIT-VARS.
     DISPLAY "" LINE 1 COLUMN 1 ERASE SCREEN.
     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.
     DISPLAY "EMPLOYEE-ID:" LINE L1 PLUS 5.
     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.
* If the employee-id is not found, return a message to the user, else 
* continue.
*
     CALL "RDB$INTERPRET" USING BY DESCRIPTOR 
-         "START-TRANSACTION READ_ONLY RESERVING 
-         "EMPLOYEES FOR PROTECTED READ"
                         GIVING STATUS-RESULT.

      IF STATUS-RESULT IS FAILURE
      THEN
          PERFORM LOCK-ERROR-CHECK
          GO TO GETCHK-EMP-EXIT
      END-IF.

      STRING "START_STREAM EMPIDCHK USING 
-            " E IN EMPLOYEES WITH E.EMPLOYEE_ID=!VAL"
-     DELIMITED BY SIZE INTO RDMS-STRING.

      CALL "RDB$INTERPRET" USING BY DESCRIPTOR
                                    RDMS-STRING
                                    ID-NUMBER
                           GIVING STATUS-RESULT.

      IF STATUS-RESULT IS FAILURE
      THEN
          PERFORM LOCK-ERROR-CHECK
          GO TO GETCHK-EMP-EXIT
      END-IF.

      MOVE SPACES TO RDMS-STRING.

      CALL "RDB$INTERPRET" USING BY DESCRIPTOR "FETCH EMPIDCHK"
                           GIVING STATUS-RESULT.

      IF STATUS-RESULT IS FAILURE
      THEN
         MOVE IDEND TO WHAT-ERROR
         MOVE IDNOTFND TO MSG-ID
         GO TO GETCHK-EMP-EXIT
      END-IF.
* COMMIT will end the stream.
      CALL "RDB$INTERPRET" USING BY DESCRIPTOR "COMMIT"
                           GIVING STATUS-RESULT.

      IF STATUS-RESULT IS FAILURE
      THEN
          CALL "RDB$SIGNAL".
GETCHK-EMP-EXIT.
      EXIT.

GET-DEPT-NFO.
* Ask user for new DEPARTMENT_CODE. Return.
    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 23 COLUMN 28.

GET-JOB-NFO.
* Ask user for new JOB_CODE. Return.
    DISPLAY "" LINE 4 COLUMN 1 ERASE SCREEN.
    DISPLAY "ENTER NEW JOB CODE: " LINE L1 PLUS 5 ERASE LINE.
    ACCEPT JOB-CODE IN JOB_HISTORY PROTECTED
           REVERSED LINE L1 PLUS 5 COLUMN 21.
    DISPLAY "ENTER NEW JOB START DATE: " LINE L1 PLUS 6 ERASE LINE.
    ACCEPT START-DATE PROTECTED REVERSED LINE L1 PLUS 6 COLUMN 26.

GET-SALARY-NFO.
*
* Ask user for new SALARY_AMOUNT, and a new SALARY_START date.  If the
* SALARY_START date is the same as the JOB_START date, the user can
* just enter RETURN.
*
    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 "IF SALARY START DATE IS DIFFERENT " LINE L1 PLUS 4 ERASE LINE.
    DISPLAY "FROM NEW JOB START DATE," LINE L1 PLUS 4 COLUMN 35.
    DISPLAY "ENTER NEW SALARY START DATE: " LINE L1 PLUS 5 ERASE LINE.
    ACCEPT START-DATE PROTECTED REVERSED LINE L1 PLUS 5 COLUMN 31.

CHK-DEPT-NFO.
*
* Verify the new DEPARTMENT-CODE exists.  Program needs the new 
* SUPERVISOR-ID to store the new JOB_HISTORY record, so verify the
* DEPARTMENT-CODE by crossing DEPARTMENT-CODE in DEPARTMENTS (to
* ensure that it is a valid DEPARTMENT_CODE) with DEPARTMENT_CODE 
* in the JOB_HISTORY Relation, specify JOB_END MISSING, and fetch
* the SUPERVISOR-ID for that department, thus verifying that the
* new DEPARTMENT-CODE does exists, and retrieve the employee's
* new SUPERVISOR-ID.  This also saves the user having to already 
* know the new SUPERVISOR-ID.  NOTE: This could be a view.
*
      PERFORM INIT-VARS.

      CALL "RDB$INTERPRET" USING BY DESCRIPTOR 
-          "START-TRANSACTION READ_ONLY RESERVING 
-          "DEPARTMENTS, JOB_HISTORY FOR PROTECTED READ"
                         GIVING STATUS-RESULT.

      IF STATUS-RESULT IS FAILURE
      THEN
         PERFORM LOCK-ERROR-CHECK
         GO TO CHK-DEPT-NFO-EXIT
      END-IF.

      STRING "START-STREAM DEPTCODE USING
-           " D IN DEPARTMENTS CROSS JH IN JOB_HISTORY 
-           " WITH D.DEPARTMENT_CODE = !VAL
-           " AND JH.DEPARTMENT_CODE = D.DEPARTMENT_CODE
-           " AND JH.JOB_END MISSING"
-     DELIMITED BY SIZE INTO RDMS-STRING.

      CALL "RDB$INTERPRET" USING BY DESCRIPTOR
                                    RDMS-STRING 
                                    DEPARTMENT_CODE IN JOB_HISTORY
                           GIVING STATUS-RESULT.

      IF STATUS-RESULT IS FAILURE
      THEN
         PERFORM LOCK-ERROR-CHECK
         GO TO CHK-DEPT-NFO-EXIT
      END-IF.

      CALL "RDB$INTERPRET" USING BY DESCRIPTOR "FETCH DEPTCODE"
                           GIVING STATUS-RESULT.

      IF STATUS-RESULT IS FAILURE
      THEN
	  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
      END-IF.

      MOVE SPACES TO RDMS-STRING.

      STRING "GET 
-            " !VAL = JH.SUPERVISOR_ID
-            " END_GET" DELIMITED BY SIZE INTO RDMS-STRING.

      CALL "RDB$INTERPRET" USING BY DESCRIPTOR 
                                    RDMS-STRING
                                    SUPERVISOR_ID IN JOB_HISTORY
                          GIVING STATUS-RESULT.

      IF STATUS-RESULT IS FAILURE
      THEN
         PERFORM LOCK-ERROR-CHECK
	 GO TO CHK-DEPT-NFO-EXIT
      END-IF.
* COMMIT will close the stream.
      CALL "RDB$INTERPRET" USING BY DESCRIPTOR "COMMIT"
                           GIVING STATUS-RESULT.

      IF STATUS-RESULT IS FAILURE
      THEN
          CALL "RDB$SIGNAL".

CHK-DEPT-NFO-EXIT.
    EXIT.

CHK-JOB-NFO.
*
* Verify that the incoming JOB_CODE exists in the database, 
* and fetch MAXIMUM salary allowed for new JOB_CODE. The maximum 
* salary will be compared against the SALARY_AMOUNT input by 
* the user for this employee.
*
    PERFORM INIT-VARS.

    CALL "RDB$INTERPRET" USING BY DESCRIPTOR 
-        "START-TRANSACTION READ_ONLY RESERVING 
-        "JOBS FOR PROTECTED READ"
                         GIVING STATUS-RESULT.

    IF STATUS-RESULT IS FAILURE
    THEN
         PERFORM LOCK-ERROR-CHECK
         GO TO CHK-JOB-NFO-EXIT
    END-IF.

    STRING "START-STREAM JOBCODE USING
-          " J IN JOBS WITH J.JOB_CODE = !VAL"
-           DELIMITED BY SIZE INTO RDMS-STRING.

    CALL "RDB$INTERPRET" USING BY DESCRIPTOR
                                  RDMS-STRING
                                  JOB_CODE IN JOB_HISTORY
                        GIVING STATUS-RESULT.

      IF STATUS-RESULT IS FAILURE
      THEN
          PERFORM LOCK-ERROR-CHECK
          GO TO CHK-JOB-NFO-EXIT
      END-IF.

      CALL "RDB$INTERPRET" USING BY DESCRIPTOR "FETCH JOBCODE"
                           GIVING STATUS-RESULT.

      IF STATUS-RESULT IS FAILURE
      THEN
         MOVE ATEND TO WHAT-ERROR
         MOVE JCNOTFND TO MSG-ID
         MOVE JOB_CODE IN JOB_HISTORY TO WHAT-FETCHED
         GO TO CHK-JOB-NFO-EXIT
      END-IF.

* Fetch the maximum salary for the new JOB_CODE.
      CALL "RDB$INTERPRET" USING BY DESCRIPTOR 
-                                "GET !VAL = J.MAXIMUM_SALARY; END_GET"
                                 BY DESCRIPTOR NEW-SAL-MAX
                           GIVING STATUS-RESULT.

      IF STATUS-RESULT IS FAILURE
      THEN
          PERFORM LOCK-ERROR-CHECK
          GO TO CHK-JOB-NFO-EXIT
      END-IF.
* COMMIT will close the stream.
      CALL "RDB$INTERPRET" USING BY DESCRIPTOR "COMMIT"
                           GIVING STATUS-RESULT.

      IF STATUS-RESULT IS FAILURE
      THEN
          CALL "RDB$SIGNAL".

CHK-JOB-NFO-EXIT.
    EXIT.

MODIFY-JOBEND-DATE.
*
* Modify the current JOB_HISTORY record to include a JOB_END date.
* Because both JOB_HISTORY and SALARY_HISTORY need the same 
* modification, and as both must be updated or both must not be 
* updated, reserve both relations here.
*
    PERFORM INIT-VARS.

    CALL "RDB$INTERPRET" USING BY DESCRIPTOR 
-        "START-TRANSACTION READ_WRITE RESERVING 
-        "JOB_HISTORY, SALARY_HISTORY FOR PROTECTED WRITE"
                         GIVING STATUS-RESULT.

    IF STATUS-RESULT IS FAILURE
    THEN
       PERFORM LOCK-ERROR-CHECK
       GO TO MODIFY-JOBEND-EXIT
    END-IF.

    STRING "START_STREAM JOBEND USING JHM IN JOB_HISTORY 
-          " WITH JHM.EMPLOYEE_ID = !VAL
-          " AND JHM.JOB_END MISSING" 
-          DELIMITED BY SIZE INTO RDMS-STRING.

    CALL "RDB$INTERPRET" USING BY DESCRIPTOR   
                                  RDMS-STRING
                                  ID-NUMBER
                         GIVING STATUS-RESULT.

    IF STATUS-RESULT IS FAILURE
    THEN
       PERFORM LOCK-ERROR-CHECK
       GO TO MODIFY-JOBEND-EXIT
    END-IF.

    CALL "RDB$INTERPRET" USING BY DESCRIPTOR "FETCH JOBEND"
                         GIVING STATUS-RESULT.

    IF STATUS-RESULT IS FAILURE
    THEN
	MOVE UNEXPATEND TO MSG-ID
	MOVE ATEND TO WHAT-ERROR
	GO TO MODIFY-JOBEND-EXIT
    END-IF.
   
    MOVE SPACES TO RDMS-STRING.

    STRING "MODIFY JHM USING
-          " JHM.JOB_END = !VAL
-          " END_MODIFY" DELIMITED BY SIZE INTO RDMS-STRING.

    CALL "RDB$INTERPRET" USING BY DESCRIPTOR 
                                  RDMS-STRING
                                  JOB_START IN JOB_HISTORY
                         GIVING STATUS-RESULT.

    IF STATUS-RESULT IS FAILURE
    THEN
       PERFORM LOCK-ERROR-CHECK
       GO TO MODIFY-JOBEND-EXIT
    END-IF.
*End the stream, but do not COMMIT until STOREs are finished.
    CALL "RDB$INTERPRET" USING BY DESCRIPTOR "END_STREAM JOBEND"
                         GIVING STATUS-RESULT.

      IF STATUS-RESULT IS FAILURE
      THEN
          CALL "RDB$SIGNAL".

MODIFY-JOBEND-EXIT.
    EXIT.

STORE-JOBDEPT.
*
* Store a new JOB_HISTORY Record. NOTE: this is the same transaction
* started in the MODIFY-JOBEND-DATE PERFORM.
*
    PERFORM INIT-VARS.

    STRING "STORE JHS IN JOB_HISTORY USING
-                 " JHS.EMPLOYEE_ID = !VAL;
-                 " JHS.JOB_CODE = !VAL;
-                 " JHS.JOB_START = !VAL;
-                 " JHS.DEPARTMENT_CODE = !VAL;
-                 " JHS.SUPERVISOR_ID = !VAL;
-                 " END_STORE"
-	 	  DELIMITED BY SIZE INTO RDMS-STRING.

    CALL "RDB$INTERPRET" USING BY DESCRIPTOR
                                  RDMS-STRING
                                  ID-NUMBER
                                  JOB_CODE IN JOB_HISTORY
                                  JOB_START IN JOB_HISTORY
                                  DEPARTMENT_CODE IN JOB_HISTORY
                                  SUPERVISOR_ID IN JOB_HISTORY
                         GIVING STATUS-RESULT.

    IF STATUS-RESULT IS FAILURE
    THEN
       PERFORM LOCK-ERROR-CHECK
       GO TO STORE-JOBDEPT-EXIT
    END-IF.

STORE-JOBDEPT-EXIT.
    EXIT.

MODIFY-SALEND-DATE.
*
* Modify the existing SALARY_END date.  NOTE: this is the same
* transaction started in the MODIFY-JOBEND-DATE PERFORM.
*
    PERFORM INIT-VARS.

    STRING " START-STREAM SALMOD USING
-          " SH IN SALARY_HISTORY WITH SH.EMPLOYEE_ID = !VAL
-          " AND SH.SALARY_END MISSING" 
-          DELIMITED BY SIZE INTO RDMS-STRING.

    CALL "RDB$INTERPRET" USING BY DESCRIPTOR 
                                  RDMS-STRING
                                  ID-NUMBER
                         GIVING STATUS-RESULT.

    IF STATUS-RESULT IS FAILURE
    THEN
       PERFORM LOCK-ERROR-CHECK
       GO TO MODIFY-SALEND-EXIT
    END-IF.

    CALL "RDB$INTERPRET" USING BY DESCRIPTOR "FETCH SALMOD"
                         GIVING STATUS-RESULT.

    IF STATUS-RESULT IS FAILURE
    THEN 
       MOVE UNEXPATEND TO MSG-ID
       MOVE ATEND TO WHAT-ERROR
       GO TO MODIFY-SALEND-EXIT
    END-IF.
  
    MOVE SPACES TO RDMS-STRING.

    STRING "MODIFY SH USING 
-          " SH.SALARY_END = !VAL
-          " END_MODIFY" 
-          DELIMITED BY SIZE INTO RDMS-STRING.

    CALL "RDB$INTERPRET" USING BY DESCRIPTOR 
                                  RDMS-STRING
                                  SALARY_START IN SALARY_HISTORY
                         GIVING STATUS-RESULT.

    IF STATUS-RESULT IS FAILURE
    THEN
       PERFORM LOCK-ERROR-CHECK
       GO TO MODIFY-SALEND-EXIT
    END-IF.
MODIFY-SALEND-EXIT.
    EXIT.

STORE-SALARY.
*
* Store a new SALARY_HISTORY Record. NOTE:  this is the same 
* transaction started in the MODIFY-JOBEND-DATE PERFORM.
*
    PERFORM INIT-VARS.

    STRING "STORE SH IN SALARY_HISTORY USING
-          " SH.EMPLOYEE_ID = !VAL;
-          " SH.SALARY_AMOUNT = !VAL;
-          " SH.SALARY_START = !VAL;
-          " END_STORE" 
-          DELIMITED BY SIZE INTO RDMS-STRING.

    CALL "RDB$INTERPRET" USING BY DESCRIPTOR
                                  RDMS-STRING
                                  ID-NUMBER
                                  SALARY_AMOUNT IN SALARY_HISTORY
                                  SALARY_START IN SALARY_HISTORY
                         GIVING STATUS-RESULT.

    IF STATUS-RESULT IS FAILURE
    THEN
       PERFORM LOCK-ERROR-CHECK
       GO TO STORE-SALARY-EXIT
    END-IF.
*COMMIT will close all streams, and end the transaction.  
    CALL "RDB$INTERPRET" USING BY DESCRIPTOR "COMMIT"
                         GIVING STATUS-RESULT.

      IF STATUS-RESULT IS FAILURE
      THEN
          CALL "RDB$SIGNAL".

STORE-SALARY-EXIT.
    EXIT.

*******************************************************************
INIT-VARS.

    INITIALIZE WHAT-ERROR.
    INITIALIZE MSG-ID.
    INITIALIZE RDMS-STRING.
    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 STATUS-RESULT 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 STATUS-RESULT EQUAL RDB$_DEADLOCK
            OR STATUS-RESULT 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-RDBSIGNAL-MESSAGE
               WHEN ATEND PERFORM GET-PERSMSG-MESSAGE
                          PERFORM DISPLAY-ATEND-MESSAGE
               WHEN IDEND PERFORM GET-PERSMSG-MESSAGE
                          PERFORM DISPLAY-ATEND-MESSAGE
               WHEN MAXSA PERFORM GET-PERSMSG-MESSAGE
                          PERFORM DISPLAY-MAXSAL-MESSAGE
      END-EVALUATE.
EVAL-EXIT.
    EXIT.

DISPLAY-LOCK-MESSAGE.
    CALL "RDB$INTERPRET" USING BY DESCRIPTOR "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-RDBSIGNAL-MESSAGE.
    DISPLAY "" LINE 1 COLUMN 1 ERASE SCREEN.
    DISPLAY "This condition was not expected...program terminating." BOLD 
             LINE L1 PLUS 2.
    CALL "RDB$SIGNAL".
    CALL "RDB$INTERPRET" USING BY DESCRIPTOR "ROLLBACK" 
                         GIVING STATUS-RESULT.
    STOP RUN.

GET-PERSMSG-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 IS FAILURE
    THEN
       CALL "LIB$STOP" USING BY VALUE STATUS-RESULT
    END-IF.

DISPLAY-ATEND-MESSAGE.
    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 verify-- " BOLD
            LINE L1 PLUS 5.
    DISPLAY WHAT-FETCHED BOLD LINE L1 PLUS 5 COLUMN 43.
    DISPLAY "for EMPLOYEE-ID-- " BOLD LINE L1 PLUS 6 COLUMN 5.
    DISPLAY ID-NUMBER BOLD LINE L1 PLUS 6 COLUMN 24.
    DISPLAY "" LINE L1 PLUS 7 ERASE LINE.
    CALL "RDB$INTERPRET" USING BY DESCRIPTOR "ROLLBACK"
                         GIVING STATUS-RESULT.
    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.

DISPLAY-MAXSAL-MESSAGE.
    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 "The SALARY_AMOUNT entered (" BOLD LINE L1 PLUS 5.
    DISPLAY INPUT_SALARY BOLD LINE L1 PLUS 5 COLUMN 27.
    DISPLAY ") exceeds the maximum allowed " BOLD
             LINE L1 PLUS 6 COLUMN 32.
    DISPLAY "for the JOB_CODE (" BOLD LINE L1 PLUS 6.
    DISPLAY JOB_CODE IN JOB_HISTORY BOLD LINE L1 PLUS 7 COLUMN 18.
    DISPLAY ") entered." BOLD LINE L1 PLUS 7 COLUMN 32.
    DISPLAY "" LINE L1 PLUS 8.
    CALL "RDB$INTERPRET" USING BY DESCRIPTOR "ROLLBACK"
                         GIVING STATUS-RESULT.
    DISPLAY "Please enter RETURN to request new input" REVERSED 
                    LINE L1 PLUS 10 COLUMN 3.
    ACCEPT OPT1.
      IF OPT1 IS EQUAL SPACES
      THEN
         NEXT SENTENCE.
EXIT-PROGRAM.
    EXIT.