* Copyright © Oracle Corporation 1995. All Rights Reserved. IDENTIFICATION DIVISION. ********************************************************************* * * PROGRAM-ID. SEGSTR. * * * * * Version: 01 * * Edit: 00 * * Edit date: May-1985 * * Authors: ET * * * ********************************************************************* ********************************************************************* * P R O G R A M D E S C R I P T I O N * * * * * * SETSTR is a COBOL RDB/VMS program that adds resume information * * for an existing employee to the PERSONNEL Database. Once the * * EMPLOYEE-ID is verified, a process is SPAWNED to edit a file * * for the resume information to be input. When the user exits * * out of that file, the information is read and stored into the * * RESUMES relation in the PERSONNEL database. * * Errors are checked against the RDB/VMS error symbols, but a * * user message file (PERSMSG) is used to output error text. * * * * * ********************************************************************* * * ** * * * DATE-COMPILED. ENVIRONMENT DIVISION. CONFIGURATION SECTION. SOURCE-COMPUTER. VAX-11. OBJECT-COMPUTER. VAX-11. INPUT-OUTPUT SECTION. FILE-CONTROL. SELECT RESDAT ASSIGN TO "RESNFO.TMP". ********************************************************************* DATA DIVISION. FILE SECTION. * RESDAT will contain the employee resume information input * by the user. Once the information is stored in the database, * this file will be deleted. * FD RESDAT LABEL RECORDS ARE OMITTED. 01 RES_REC PIC X(80). WORKING-STORAGE SECTION. * 01 RESUME_INFO. 05 E-ID PIC X(5). 05 RESUME_SEGMENT PIC X(134). *Resume template file and edit command for SPAWN. 01 RESNFO. 03 EDIT-CMD PIC X(5) VALUE 'EDIT '. 03 TEMPLATE PIC X(10) VALUE 'RESNFO.TMP'. *Command to SPAWN to delete the file. 01 DELRESFIL. 03 DEL-CMD PIC X(4) VALUE 'DEL '. 03 RESFIL PIC X(12) VALUE 'RESNFO.TMP;*'. *User input variables. 01 INPUT-VARS. 02 ID-NUMBER PIC X(5) VALUE IS SPACES. 02 OPTION PIC X(1) VALUE IS SPACES. 02 ANSYES PIC X(1) VALUE IS "Y". 02 ANSNO PIC X(1) VALUE IS "N". *Display vars. 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. *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 IDEND PIC X(5) VALUE IS "IDEND". 02 NOSTO PIC X(5) VALUE IS "NOSTO". 02 LOCKD PIC X(5) VALUE IS "LOCKD". 02 PTMSG PIC X(5) VALUE IS "PTMSG". *GETMSG variables. 01 GETMSGVAS. 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). *RDB 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. *PERSMSG message symbols. 01 MSG-FILE-FLAGS. 02 IDNOTFND PIC S9(9) COMP VALUE EXTERNAL PERS_IDNOTFND. 02 UNEXPATEND PIC S9(9) COMP VALUE EXTERNAL PERS_UNEXPATEND. 01 STATUS-RESULT PIC S9(9) COMP. 01 CTR PIC 999 VALUE IS ZEROS. ********************************************************************* COPY "PERSONNEL.RDB$RELATIONS.RESUMES" FROM DICTIONARY. ********************************************************************* &RDB& DATABASE FILENAME "RDM$DEMO:PERSONNEL" ********************************************************************* PROCEDURE DIVISION. MAIN-SECTION. 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 MAIN-SECTION. DISPLAY-GET-OPTION. * Give options, and ask if user wants to continue or quit. DISPLAY "" LINE L1 COLUMN 1 ERASE SCREEN. DISPLAY "EMPLOYEE RESUME PROGRAM" BOLD LINE L1 PLUS 2 COLUMN 22. DISPLAY "" LINE L1 PLUS 3 ERASE LINE. DISPLAY "This program adds resume information for an " LINE L1 PLUS 4. DISPLAY "existing employee to the PERSONNEL database." LINE L1 PLUS 5. DISPLAY "Do you wish to continue?...(Y or N)" LINE L1 PLUS 6. ACCEPT OPTION PROTECTED REVERSED LINE L1 PLUS 6 COLUMN 36. EVALUATE OPTION WHEN ANSYES PERFORM EMPRESNFO THRU EMPRESEXIT WHEN "y" PERFORM EMPRESNFO THRU EMPRESEXIT END-EVALUATE. EMPRESNFO. * User said to continue, ask for the employee-id they want to access. DISPLAY " Please enter the Employee-id number for " LINE L1 PLUS 8 COLUMN 1. DISPLAY "the employee whose resume you wish to add." LINE L1 PLUS 9 COLUMN 1. PERFORM INIT-VARS. DISPLAY "EMPLOYEE-ID:" LINE L1 PLUS 10 ERASE LINE. ACCEPT ID-NUMBER PROTECTED REVERSED LINE L1 PLUS 10 COLUMN 13. * Verify employee-id existence. PERFORM CHKEMPID THRU CHKEMPEXIT. * Check results. IF WHAT-ERROR NOT EQUAL SPACES THEN PERFORM EVAL-WHAT-ERROR THRU EVAL-EXIT GO TO EMPRESEXIT END-IF. * Employee has been located in the employees relation. DISPLAY "" LINE 1 ERASE SCREEN. DISPLAY " The employee record has been located, EDT will" LINE L1 PLUS 2. DISPLAY " now be called for you to input the resume." LINE L1 PLUS 3. DISPLAY " Please EXIT EDT when finished." LINE L1 PLUS 4. * Spawn and call EDT. PERFORM GETRESNFO THRU GETRESEXIT. IF WHAT-ERROR NOT EQUAL SPACES THEN GO TO EMPRESEXIT END-IF. * User done with file, go see about storing information. PERFORM STORERES THRU STOREXIT. IF WHAT-ERROR NOT EQUAL SPACES THEN PERFORM EVAL-WHAT-ERROR THRU EVAL-EXIT GO TO EMPRESEXIT END-IF. * Spawn and delete the tmp file used to input resume information. PERFORM RESDEL THRU RESDELEXIT. EMPRESEXIT. EXIT. CHKEMPID. * * Check to see if the Employee exists. No other transaction can * be performed unless the EMPLOYEE-ID currently exists in the database. * Return an message to the user if the employee does not exist, continue * if employee does exist. * &RDB& START_TRANSACTION READ_ONLY RESERVING EMPLOYEES FOR SHARED READ &RDB& ON ERROR PERFORM LOCK-ERROR-CHECK GO TO CHKEMPEXIT &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 CHKEMPEXIT &RDB& END_ERROR &RDB& AT END MOVE IDNOTFND TO MSG-ID MOVE IDEND TO WHAT-ERROR GO TO CHKEMPEXIT &RDB& END_FETCH &RDB& GET &RDB& ON ERROR PERFORM LOCK-ERROR-CHECK GO TO CHKEMPEXIT &RDB& END_ERROR &RDB& EMPLOYEE_ID IN RESUMES = E.EMPLOYEE_ID &RDB& END_GET * ROLLBACK will close the stream. &RDB& ROLLBACK. CHKEMPEXIT. EXIT. GETRESNFO. * SPAWN a subprocess (RESSUB), and edit a template file (RESNFO.TMP;1) * to input the resume information. CALL 'LIB$SPAWN' USING BY DESCRIPTOR RESNFO BY VALUE 0 0 0 BY DESCRIPTOR 'RESSUB' BY VALUE 0 0 0 0 0 GIVING STATUS-RESULT. IF STATUS-RESULT IS FAILURE THEN CALL "LIB$STOP" USING BY VALUE STATUS-RESULT. GETRESEXIT. EXIT. STORERES. * User has finished with file. Read the file with the resume information and * move into a segmented string. PERFORM INIT-VARS. &RDB& START_TRANSACTION READ_WRITE &RDB& ON ERROR PERFORM LOCK-ERROR-CHECK GO TO STOREXIT &RDB& END_ERROR &RDB& CREATE_SEGMENTED_STRING RS_HANDLE &RDB& ON ERROR PERFORM LOCK-ERROR-CHECK GO TO STOREXIT &RDB& END_ERROR *Open file containing resume information. OPEN INPUT RESDAT. READRES. MOVE SPACES TO RES_REC. READ RESDAT AT END GO TO READ-DONE. &RDB& STORE L IN RS_HANDLE &RDB& USING &RDB& ON ERROR PERFORM LOCK-ERROR-CHECK GO TO STOREXIT &RDB& END_ERROR &rdb& L.RDB$VALUE = RES_REC &RDB& END_STORE ADD 1 TO CTR. GO TO READRES. READ-DONE. *Close segmented string and store segmented string before *handle RS_HANDLE is used again. &RDB& END_SEGMENTED_STRING RS_HANDLE IF CTR EQUAL ZERO THEN MOVE NOSTO TO WHAT-ERROR GO TO STOREXIT END-IF. &RDB& STORE R IN RESUMES &RDB& USING &RDB& ON ERROR PERFORM LOCK-ERROR-CHECK GO TO STOREXIT &RDB& END_ERROR &RDB& R.EMPLOYEE_ID = ID-NUMBER; &RDB& R.RESUME = RS_HANDLE &RDB& END_STORE &RDB& COMMIT &RDB& FINISH. STOREXIT. EXIT. RESDEL. * SPAWN a subprocess (DERES), and delete the file created with the resume * information. CALL 'LIB$SPAWN' USING BY DESCRIPTOR DELRESFIL BY VALUE 0 0 0 BY DESCRIPTOR 'DERES' BY VALUE 0 0 0 0 0 GIVING STATUS-RESULT. IF STATUS-RESULT IS FAILURE THEN CALL "LIB$STOP" USING BY VALUE STATUS-RESULT. RESDELEXIT. EXIT. ***************************************************************************** INIT-VARS. INITIALIZE WHAT-ERROR. INITIALIZE MSG-ID. INITIALIZE 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 NOSTO PERFORM DISPLAY-NOSTO-MESSAGE WHEN IDEND PERFORM DISPLAY-ATEND-MESSAGE END-EVALUATE. EVAL-EXIT. EXIT. DISPLAY-NOSTO-MESSAGE. &RDB& ROLLBACK DISPLAY "" LINE 1 COLUMN 1 ERASE SCREEN. DISPLAY "No STORE occurred, Program terminating." BOLD LINE L1 PLUS 2. STOP RUN. 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 OPTION. IF OPTION 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 OPTION. IF OPTION 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 the record " BOLD LINE L1 PLUS 5. 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 8 ERASE LINE. &RDB& ROLLBACK DISPLAY "Please enter RETURN to request new input" REVERSED LINE L1 PLUS 8 COLUMN 3. ACCEPT OPTION. IF OPTION IS EQUAL SPACES THEN NEXT SENTENCE. EXIT-PROGRAM. EXIT.