C Copyright © Oracle Corporation 1995. All Rights Reserved. SUBROUTINE add_employees C------------------------------------------------ C This subroutine adds a new employee to the C EMPLOYEES relation. C------------------------------------------------ IMPLICIT NONE LOGICAL valid_date,success INTEGER retry_count,number_employees_added,i INTEGER*4 STATUS,birthday(2),SYS$BINTIM,SYS$ASCTIM CHARACTER employee_id*5,last_name*14,first_name*10,middle_initial CHARACTER city*20,state*2,postal_code*5,ascii_date*23,confirm CHARACTER*25 address_data_1,address_data_2 CHARACTER see_all CHARACTER*8 data_base_key,database_key(20) &RDB& DATABASE EXTERNAL pers = FILENAME 'MF_PERSONNEL' &RDB& DBKEY SCOPE IS FINISH WRITE (6,90) 90 FORMAT ('1',T25,'**** ADD EMPLOYEES ****'///) TYPE 110 C------------------------------------------------ C Prompt user for input until user confirms that C input is valid or enters 'exit'. C------------------------------------------------ 110 FORMAT ('$',' Please enter the ID of the new 1Employee or type exit: ') ACCEPT 120, employee_id 120 FORMAT (A) confirm = 'N' DO WHILE ((employee_id.NE.'EXIT ').AND.(employee_id.NE.'exit ')) DO WHILE (confirm .EQ. 'N') TYPE 1000 1000 FORMAT ('$',' Please enter the Employees last name: ') ACCEPT 1010, last_name 1010 FORMAT (A) TYPE 2000 2000 FORMAT ('$',' Please enter the Employees first name: ') ACCEPT 2010, first_name 2010 FORMAT (A) TYPE 3000 3000 FORMAT ('$',' Please enter the Employees middle initial: ') ACCEPT 3010, middle_initial 3010 FORMAT (A) valid_date = .FALSE. C---------------------------------------------------- C Prompt user to input date, keep prompting C until user enters date in proper format. C---------------------------------------------------- DO WHILE (.NOT.(valid_date)) TYPE 4000 4000 FORMAT ('$',' Please enter the Employees 1birthday (dd-MMM-yyyy): ') ACCEPT 4010, ascii_date 4010 FORMAT (A) C---------------------------------------------------- C Use SYS$BINTIM to convert ASCII input to binary C format. C---------------------------------------------------- STATUS = SYS$BINTIM (ascii_date, birthday) IF (.NOT. STATUS) THEN WRITE (6,*) 'Invalid date format' ELSE valid_date = .TRUE. END IF END DO TYPE 5000 5000 FORMAT ('$',' Please enter the Employees street address: ') ACCEPT 5010, address_data_1 5010 FORMAT (A) TYPE 6000 6000 FORMAT ('$',' Please enter the Employees apartment number: ') ACCEPT 6010, address_data_2 6010 FORMAT (A) TYPE 7000 7000 FORMAT ('$',' Please enter city: ') ACCEPT 7010, city 7010 FORMAT (A) TYPE 8000 8000 FORMAT ('$',' Please enter state: ') ACCEPT 8010, state 8010 FORMAT (A) TYPE 9000 9000 FORMAT ('$',' Please enter postal code: ') ACCEPT 9010, postal_code 9010 FORMAT (A) PRINT *, ' ' TYPE 10000 10000 FORMAT ('$',' Have you entered all data correctly? (Y/N): ') ACCEPT 10010, confirm 10010 FORMAT (A) END DO success = .FALSE. retry_count = 0 C----------------------------------------------------------- C The following loop will execute at least once, because C 'success' has just been set to false, and 'retry_count' to C zero. If an error occurs during the START_TRANSACTION C operation, the program will retry the START_TRANSACTION C operation up to 5 times. C------------------------------------------------------------ DO WHILE ((retry_count .LT. 5) .AND. (.NOT. (success))) success = .TRUE. &RDB& START_TRANSACTION READ_WRITE NOWAIT RESERVING &RDB& EMPLOYEES FOR SHARED WRITE &RDB& ON ERROR success = .FALSE. retry_count = retry_count + 1 CALL error_handler(RDB$STATUS,success) IF (success) THEN retry_count = 5 END IF &RDB& END_ERROR END DO success = .FALSE. retry_count = 0 C----------------------------------------------------------- C The following loop will execute at least once, because C 'success' has just been set to false, and 'retry_count' to C zero. If an error occurs during the STORE operation, the C program will retry to STORE operation up to 5 times. C------------------------------------------------------------ DO WHILE ((retry_count .LT. 5) .AND. (.NOT. (success))) success = .TRUE. &RDB& STORE E IN EMPLOYEES USING &RDB& ON ERROR success = .FALSE. retry_count = retry_count + 1 CALL error_handler(RDB$STATUS,success) IF (success) THEN retry_count = 5 END IF &RDB& END_ERROR C-------------------------------------------------------- C Store the values that the user entered in an C EMPLOYEES record. C-------------------------------------------------------- &RDB& E.EMPLOYEE_ID = employee_id; &RDB& E.LAST_NAME = last_name; &RDB& E.FIRST_NAME = first_name; &RDB& E.MIDDLE_INITIAL = middle_initial; &RDB& E.ADDRESS_DATA_1 = address_data_1; &RDB& E.ADDRESS_DATA_2 = address_data_2; &RDB& E.CITY = city; &RDB& E.STATE = state; &RDB& E.POSTAL_CODE = postal_code; &RDB& E.BIRTHDAY = birthday; C------------------------------------------------------- C Get the dbkey associated with the newly stored C EMPLOYEES record. C-------------------------------------------------------- &RDB& GET &RDB& ON ERROR success = .FALSE. &RDB& END_ERROR &RDB& data_base_key = E.RDB$DB_KEY &RDB& END_GET &RDB& END_STORE END DO C--------------------------------------------------------- C If the STORE operation succeeded, increment a counter C by one and add the dbkey to an array of dbkeys. C--------------------------------------------------------- IF (success) THEN number_employees_added = number_employees_added + 1 database_key(number_employees_added) = data_base_key TYPE 11000, last_name, employee_id 11000 FORMAT (/,' Successfully added employee: ',A/ 1 ' with employee_id: ',A// 1 ' Do you want to see the names of all the employees '/ 1 '$ entered during this session (Y/N): ') ACCEPT 11010, see_all 11010 FORMAT (A) C--------------------------------------------------------- C If the user wants to see all the EMPLOYEES records added C during this session, step through the array of dbkeys C to find and print each new employee record. C--------------------------------------------------------- IF (see_all .EQ. 'Y') THEN DO 10 I = 1, number_employees_added &RDB& FOR E IN EMPLOYEES WITH E.RDB$DB_KEY = database_key(i) &RDB& ON ERROR success = .FALSE. CALL error_handler(RDB$STATUS,success) IF (success) THEN retry_count = 5 END IF &RDB& END_ERROR &RDB& GET &RDB& ON ERROR success = .FALSE. &RDB& END_ERROR &RDB& employee_id = E.EMPLOYEE_ID; &RDB& last_name = E.LAST_NAME; &RDB& first_name = E.FIRST_NAME; &RDB& middle_initial = E.MIDDLE_INITIAL; &RDB& address_data_1 = E.ADDRESS_DATA_1; &RDB& address_data_2 = E.ADDRESS_DATA_2; &RDB& city = E.CITY; &RDB& state = E.STATE; &RDB& postal_code = E.POSTAL_CODE; &RDB& birthday = E.BIRTHDAY; &RDB& END_GET &RDB& END_FOR IF (success) THEN C---------------------------------------------------------------- C If the field values were successfully retrieved, C then convert the date field from binary to ASCII format. C The first and last arguments to the call to SYS$ASCTIM are not C required arguments. C--------------------------------------------------------------- CALL SYS$ASCTIM (, ascii_date, birthday, ) TYPE 12000, employee_id, last_name, first_name, 1 middle_initial, address_data_1, 1 address_data_2, city, state, 1 postal_code, ascii_date 12000 FORMAT (// ' Employee_id: ',A/ 1 ' Last name: ',A/ 1 ' First name: ',A/ 1 ' Middle initial: ',A/ 1 ' Address: ',A,' ',A/ 1 ' City: ',A/ 1 ' State: ',A/ 1 ' Postal code: ',A/ 1 ' Birthday: ',A//) success = .TRUE. END IF 10 CONTINUE END IF &RDB& COMMIT ELSE TYPE 13000 13000 FORMAT ('b','Update operation failed') &RDB& ROLLBACK END IF confirm = 'N' PRINT *, ' ' TYPE 14000 14000 FORMAT ('$',' Please enter the ID of the new 1Employee or type exit: ') ACCEPT 14010, employee_id 14010 FORMAT (A) END DO RETURN END