IDENTIFICATION DIVISION. PROGRAM-ID. COB_SQLM_ZILL_ENTRY_SUB. AUTHOR. Roland Hughes. DATE-WRITTEN. 2005-05-12. DATE-COMPILED. TODAY. ENVIRONMENT DIVISION. INPUT-OUTPUT SECTION. FILE-CONTROL. DATA DIVISION. FILE SECTION. ********** * Data declarations ********** WORKING-STORAGE SECTION. 01 CONSTANTS. 05 KEY_PAD_MODE PIC 9 COMP VALUE 0. 05 ACTION-ADD PIC 9 COMP VALUE 2. 05 ACTION-FIND PIC 9 COMP VALUE 3. 05 ACTION-DELETE PIC 9 COMP VALUE 4. 05 ACTION-UPDATE PIC 9 COMP VALUE 5. 05 ACTION-EXIT PIC 9 COMP VALUE 99. 01 STATUS-VARIABLES. 05 DONE-FLAG PIC X. 88 WE-ARE-DONE VALUE 'Y'. 05 FOUND-FLAG PIC X. 88 NOT-FOUND VALUE 'N'. 88 FOUND VALUE 'Y'. 01 STUFF. 05 SQLCODE PIC S9(9) COMP. 05 WORK-STR PIC X(80). 05 TERMINATOR PIC S9(9) COMP. 05 B-ACTION PIC S99 COMP. 05 WORK-NO PIC Z9. 05 CURRENT-MODE PIC S9 COMP. 88 ADD-MODE VALUE 0. 88 DELETE-MODE VALUE 3. 88 FIND-MODE VALUE 2. 88 INVALID-MODE VALUE -1. 01 SCREEN-REC. 05 DRAW-DT PIC X(8). 05 NO-1 PIC XX. 05 NO-2 PIC XX. 05 NO-3 PIC XX. 05 NO-4 PIC XX. 05 NO-5 PIC XX. 05 MEGA-NO PIC XX. 05 MSG-TXT PIC X(60). 01 SQL-RECORD. 05 DRAW-DT PIC S9(18) COMP. 05 NO-1 PIC 9(2) COMP. 05 NO-2 PIC 9(2) COMP. 05 NO-3 PIC 9(2) COMP. 05 NO-4 PIC 9(2) COMP. 05 NO-5 PIC 9(2) COMP. 05 MEGA-NO PIC 9(2) COMP. 01 DATE-STUFF. 05 LIB-RESULT PIC S9(8) COMP. 05 LIB-RESULT-DISPLAY PIC 9(8). 05 DATE-OUT-CONTEXT PIC S9(8) COMP. 05 DATE-IN-CONTEXT PIC S9(8) COMP. 05 DATE-COMPONENT PIC S9(8) COMP. 05 DATE-OUT-FMT-STR PIC X(12) VALUE '|!Y4!MN0!D0|'. 05 DATE-IN-FMT-STR PIC X(26) VALUE '|!Y4!MN0!D0 !H04!M0!S0!C2|'. 05 DATE-FLAGS PIC S9(8) COMP VALUE 127. 05 DATE-DEFAULTS PIC S9(4) COMP OCCURS 8 TIMES. COPY 'SYS$LIBRARY:SQL_LITERALS.LIB'. * * FMS definitions * COPY 'COBFDVDEF' OF 'MEGA_OBJ:MEGA_TXT.TLB'. LINKAGE SECTION. 01 FMS-STUFF. 05 FMSSTATUS PIC S9(9) COMP. 05 RMSSTATUS PIC S9(9) COMP. 05 TCA PIC X(12). 05 WORKSPACE PIC X(12). PROCEDURE DIVISION USING FMS-STUFF. A000-MAIN. PERFORM B000-HSK. PERFORM B010-USER-INPUT UNTIL WE-ARE-DONE. CALL 'COMMIT_MEGA' USING BY REFERENCE SQLCODE. CALL 'LIB$FREE_DATE_TIME_CONTEXT' USING BY REFERENCE DATE-OUT-CONTEXT GIVING LIB-RESULT. CALL 'LIB$FREE_DATE_TIME_CONTEXT' USING BY REFERENCE DATE-IN-CONTEXT GIVING LIB-RESULT. EXIT PROGRAM. ***** * Paragraph to initialize our data and files. ***** B000-HSK. MOVE SPACES TO STATUS-VARIABLES. CALL 'FDV$SPADA' USING BY REFERENCE KEY_PAD_MODE. CALL 'FDV$CDISP' USING BY DESCRIPTOR 'ZILL_ENTRY2'. MOVE SPACES TO SCREEN-REC. SET ADD-MODE TO TRUE. * * Set up date context for display * MOVE ZERO TO DATE-OUT-CONTEXT. MOVE 1 TO DATE-COMPONENT. CALL 'LIB$INIT_DATE_TIME_CONTEXT' USING BY REFERENCE DATE-OUT-CONTEXT, DATE-COMPONENT, BY DESCRIPTOR DATE-OUT-FMT-STR GIVING LIB-RESULT. * * Set up date context for display * MOVE ZERO TO DATE-IN-CONTEXT. MOVE 2 TO DATE-COMPONENT. CALL 'LIB$INIT_DATE_TIME_CONTEXT' USING BY REFERENCE DATE-IN-CONTEXT, DATE-COMPONENT, BY DESCRIPTOR DATE-IN-FMT-STR GIVING LIB-RESULT. COMPUTE DATE-DEFAULTS(1) = 1970. COMPUTE DATE-DEFAULTS(2) = 1. COMPUTE DATE-DEFAULTS(3) = 1. ***** * Paragraph to handle user interaction. ***** B010-USER-INPUT. MOVE SPACES TO WORK-STR. CALL 'FDV$GETAL' USING BY DESCRIPTOR SCREEN-REC BY REFERENCE TERMINATOR. PERFORM C000-CHECK-TERMINATOR. EVALUATE B-ACTION WHEN ACTION-ADD SET ADD-MODE TO TRUE PERFORM C010-ADD-RECORD WHEN ACTION-FIND SET FIND-MODE TO TRUE PERFORM C020-FIND-RECORD WHEN ACTION-DELETE PERFORM C030-DELETE-RECORD SET DELETE-MODE TO TRUE WHEN ACTION-UPDATE IF FIND-MODE PERFORM C040-UPDATE-RECORD ELSE MOVE 'Must be in find mode to update' TO MSG-TXT PERFORM U000-DISPLAY-ERROR END-IF SET ADD-MODE TO TRUE WHEN ACTION-EXIT SET WE-ARE-DONE TO TRUE END-EVALUATE. ***** * Paragraph to test terminator value and set mode. ***** C000-CHECK-TERMINATOR. EVALUATE TERMINATOR WHEN FDV$K_FK_F7 MOVE ACTION-ADD TO B-ACTION WHEN FDV$K_FK_F8 MOVE ACTION-FIND TO B-ACTION WHEN FDV$K_FK_F9 MOVE ACTION-DELETE TO B-ACTION WHEN FDV$K_FK_F10 MOVE ACTION-EXIT TO B-ACTION WHEN FDV$K_FK_F11 MOVE ACTION-UPDATE TO B-ACTION WHEN OTHER MOVE ACTION-ADD TO B-ACTION END-EVALUATE. ***** * Paragraph to actuall add a record to the indexed file ***** C010-ADD-RECORD. PERFORM D000-RETRIEVE-DATA. IF MEGA_NO IN SQL-RECORD <= 0 MOVE 'must enter all fields' to MSG-TXT PERFORM U000-DISPLAY-ERROR ELSE CALL 'INSERT_DRAW_REC' USING BY REFERENCE SQLCODE, DRAW-DT IN SQL-RECORD, NO-1 IN SQL-RECORD, NO-2 IN SQL-RECORD, NO-3 IN SQL-RECORD, NO-4 IN SQL-RECORD, NO-5 IN SQL-RECORD, MEGA-NO IN SQL-RECORD IF SQLCODE IS NOT EQUAL TO SQLCODE_SUCCESS MOVE 'Error writing record' TO MSG-TXT PERFORM U000-DISPLAY-ERROR CALL 'ROLLBACK_MEGA' USING BY REFERENCE SQLCODE ELSE CALL 'COMMIT_MEGA' USING BY REFERENCE SQLCODE END-IF MOVE SPACES TO SCREEN-REC CALL 'FDV$PUTAL' USING BY DESCRIPTOR SCREEN-REC END-IF. ***** * Paragraph to find a record in the file ***** C020-FIND-RECORD. PERFORM D000-RETRIEVE-DATA. SET FOUND TO TRUE. CALL 'FIND_DRAW_REC' USING BY REFERENCE SQLCODE, DRAW-DT IN SQL-RECORD, NO-1 IN SQL-RECORD, NO-2 IN SQL-RECORD, NO-3 IN SQL-RECORD, NO-4 IN SQL-RECORD, NO-5 IN SQL-RECORD, MEGA-NO IN SQL-RECORD. IF SQLCODE IS NOT EQUAL TO SQLCODE_SUCCESS SET NOT-FOUND TO TRUE MOVE 'Error writing record' TO MSG-TXT PERFORM U000-DISPLAY-ERROR ELSE MOVE SPACES TO SCREEN-REC CALL 'LIB$FORMAT_DATE_TIME' USING BY DESCRIPTOR DRAW-DT IN SCREEN-REC, BY REFERENCE DRAW-DT IN SQL-RECORD, DATE-OUT-CONTEXT, OMITTED, OMITTED GIVING LIB-RESULT MOVE NO_1 IN SQL-RECORD TO WORK-NO MOVE WORK-NO TO NO-1 IN SCREEN-REC MOVE NO_2 IN SQL-RECORD TO WORK-NO MOVE WORK-NO TO NO-2 IN SCREEN-REC MOVE NO_3 IN SQL-RECORD TO WORK-NO MOVE WORK-NO TO NO-3 IN SCREEN-REC MOVE NO_4 IN SQL-RECORD TO WORK-NO MOVE WORK-NO TO NO-4 IN SCREEN-REC MOVE NO_5 IN SQL-RECORD TO WORK-NO MOVE WORK-NO TO NO-5 IN SCREEN-REC MOVE MEGA_NO IN SQL-RECORD TO WORK-NO MOVE WORK-NO TO MEGA-NO IN SCREEN-REC CALL 'FDV$PUTAL' USING BY DESCRIPTOR SCREEN-REC END-IF. ***** * Paragraph to delete a record from the file ***** C030-DELETE-RECORD. IF NOT FIND-MODE MOVE 'Must find before deleting' to MSG-TXT PERFORM U000-DISPLAY-ERROR ELSE CALL 'DELETE_SINGLE_DRAW_REC' USING BY REFERENCE SQLCODE, DRAW-DT IN SQL-RECORD IF SQLCODE IS NOT EQUAL TO SQLCODE_SUCCESS MOVE 'Unable to delete record' TO MSG-TXT PERFORM U000-DISPLAY-ERROR CALL 'ROLLBACK_MEGA' USING BY REFERENCE SQLCODE ELSE CALL 'COMMIT_MEGA' USING BY REFERENCE SQLCODE END-IF MOVE SPACES TO SCREEN-REC CALL 'FDV$PUTAL' USING BY DESCRIPTOR SCREEN-REC END-IF. ***** * Paragraph to update a record on file ***** C040-UPDATE-RECORD. PERFORM D000-RETRIEVE-DATA. CALL 'UPDATE_DRAW_REC' USING BY REFERENCE SQLCODE, DRAW-DT IN SQL-RECORD, NO-1 IN SQL-RECORD, NO-2 IN SQL-RECORD, NO-3 IN SQL-RECORD, NO-4 IN SQL-RECORD, NO-5 IN SQL-RECORD, MEGA-NO IN SQL-RECORD. IF SQLCODE IS NOT EQUAL TO SQLCODE_SUCCESS MOVE 'Unable to update record' TO MSG-TXT PERFORM U000-DISPLAY-ERROR ELSE MOVE SPACES TO SCREEN-REC CALL 'FDV$PUTAL' USING BY DESCRIPTOR SCREEN-REC. ***** * Paragraph to read data from screen buffer ***** D000-RETRIEVE-DATA. CALL 'LIB$CONVERT_DATE_STRING' USING BY DESCRIPTOR DRAW-DT IN SCREEN-REC, BY REFERENCE DRAW-DT IN SQL-RECORD, DATE-IN-CONTEXT, DATE-FLAGS, OMITTED, OMITTED GIVING LIB-RESULT. COMPUTE NO_1 IN SQL-RECORD = 0. COMPUTE NO_2 IN SQL-RECORD = 0. COMPUTE NO_3 IN SQL-RECORD = 0. COMPUTE NO_4 IN SQL-RECORD = 0. COMPUTE NO_5 IN SQL-RECORD = 0. COMPUTE MEGA_NO IN SQL-RECORD = 0. IF NO-1 IN SCREEN-REC IS NUMERIC COMPUTE NO_1 IN SQL-RECORD = FUNCTION NUMVAL( NO-1 IN SCREEN-REC). IF NO-2 IN SCREEN-REC IS NUMERIC COMPUTE NO_2 IN SQL-RECORD = FUNCTION NUMVAL( NO-2 IN SCREEN-REC). IF NO-3 IN SCREEN-REC IS NUMERIC COMPUTE NO_3 IN SQL-RECORD = FUNCTION NUMVAL( NO-3 IN SCREEN-REC). IF NO-4 IN SCREEN-REC IS NUMERIC COMPUTE NO_4 IN SQL-RECORD = FUNCTION NUMVAL( NO-4 IN SCREEN-REC). IF NO-5 IN SCREEN-REC IS NUMERIC COMPUTE NO_5 IN SQL-RECORD = FUNCTION NUMVAL( NO-5 IN SCREEN-REC). IF MEGA-NO IN SCREEN-REC IS NUMERIC COMPUTE MEGA_NO IN SQL-RECORD = FUNCTION NUMVAL( MEGA-NO IN SCREEN-REC). ***** * Utility paragraph to display error messages ***** U000-DISPLAY-ERROR. CALL 'FDV$BELL'. CALL 'FDV$PUT' USING BY DESCRIPTOR MSG-TXT BY DESCRIPTOR 'MSG_TXT'. CALL 'FDV$WAIT'. MOVE SPACES TO MSG-TXT. CALL 'FDV$PUT' USING BY DESCRIPTOR MSG-TXT BY DESCRIPTOR 'MSG_TXT'. END PROGRAM COB_SQLM_ZILL_ENTRY_SUB. ***** * Function to handle drawing range validation ***** IDENTIFICATION DIVISION. PROGRAM-ID. DRAWING_RANGE INITIAL. AUTHOR. Roland Hughes. DATE-WRITTEN. 2005-02-09. DATE-COMPILED. TODAY. ENVIRONMENT DIVISION. INPUT-OUTPUT SECTION. FILE-CONTROL. DATA DIVISION. FILE SECTION. ********** * Data declarations ********** WORKING-STORAGE SECTION. 01 FMS-STRING-FIELDS. 05 FORM-NAME PIC X(31). 05 UAR-VALS PIC X(80). 05 FIELD-NAME PIC X(31). 05 DATA-LINE. 10 FLD-VAL-STR PIC X(2). 10 FILLER PIC X(130). 01 FMS-BINARY-FIELDS. 05 TERMINATOR PIC S9(9) COMP. 05 TCA-PTR PIC S9(9) COMP. 05 WORKSPACE-PTR PIC S9(9) COMP. 05 CURSOR-POS PIC S9(9) COMP. 05 INSERT-OVER PIC S9(9) COMP. 05 HELP-NUM PIC S9(9) COMP. 05 FLD-IDX PIC S9(9) COMP. 05 RETURN-STATUS PIC S9(9) COMP. 01 STUFF. 05 FLD-VAL PIC 99. * * FMS definitions * COPY 'COBFDVDEF' OF 'MEGA_OBJ:MEGA_TXT.TLB'. PROCEDURE DIVISION GIVING RETURN-STATUS. A000-CHECK-RANGE. CALL 'FDV$RETCX' USING BY REFERENCE TCA-PTR BY REFERENCE WORKSPACE-PTR BY DESCRIPTOR FORM-NAME BY DESCRIPTOR UAR-VALS BY REFERENCE CURSOR-POS BY REFERENCE TERMINATOR BY REFERENCE INSERT-OVER BY REFERENCE HELP-NUM. CALL 'FDV$RETFN' USING BY DESCRIPTOR FIELD-NAME BY REFERENCE FLD-IDX. CALL 'FDV$RET' USING BY DESCRIPTOR DATA-LINE BY DESCRIPTOR FIELD-NAME BY REFERENCE FLD-IDX. IF DATA-LINE IS EQUAL TO SPACES MOVE FDV$K_UVAL_FAIL TO RETURN-STATUS ELSE COMPUTE FLD-VAL = FUNCTION NUMVAL( DATA-LINE) IF FLD-VAL >= 1 AND FLD-VAL <= 52 MOVE FDV$K_UVAL_SUC TO RETURN-STATUS ELSE MOVE FDV$K_UVAL_FAIL TO RETURN-STATUS. END PROGRAM DRAWING_RANGE.