IDENTIFICATION DIVISION. PROGRAM-ID. PRFILE. ENVIRONMENT DIVISION. CONFIGURATION SECTION. SPECIAL-NAMES. SYMBOLIC CHARACTERS ZEERO ONE TWO THREE FOUR SIX THIRTEEN FIFTEEN TWENTY-ONE TWENTY-SIX SIXTY-EIGHT SEVENTY-SIX EIGHTY TWO-FIFTY-FOUR ARE 1 2 3 4 5 7 14 16 22 27 69 77 81 255. INPUT-OUTPUT SECTION. FILE-CONTROL. SELECT INFILE ASSIGN TO INFILE. SELECT PR_DISPLAY ASSIGN TO PRT1. SELECT PR_PRINT ASSIGN TO PRT2. DATA DIVISION. FILE SECTION. FD INFILE RECORD IS VARYING IN SIZE FROM 1 TO 5600 CHARACTERS DEPENDING ON WS_RAB_RSZ LABEL RECORDS ARE STANDARD. 01 INFILE-RECORD. 02 INFILE_CHAR PIC X(01) OCCURS 5600 TIMES. FD PR_DISPLAY LABEL RECORDS ARE OMITTED. 01 DISPLAY-LINE PIC X(132). FD PR_PRINT LABEL RECORDS ARE OMITTED. 01 PRINT-LINE PIC X(132). WORKING-STORAGE SECTION. COPY EDCOMAND. 01 WS_FAB. 05 WS_FAB_BID PIC X(01) VALUE THREE. 05 WS_FAB_BLN PIC X(01) VALUE EIGHTY. 05 WS_FAB_IFI PIC 9(04) COMP VALUE ZERO. 05 WS_FAB_FOP PIC 9(09) COMP VALUE ZERO. 05 WS_FAB_STS PIC 9(09) COMP VALUE ZERO. 05 WS_FAB_STV PIC 9(09) COMP VALUE ZERO. 05 WS_FAB_ALQ PIC 9(09) COMP VALUE ZERO. 05 WS_FAB_DEQ PIC 9(04) COMP VALUE ZERO. 05 WS_FAB_FAC PIC X(01) VALUE TWO. 05 WS_FAB_SHR PIC X(01). 05 WS_FAB_CTX PIC 9(09) COMP VALUE ZERO. 05 WS_FAB_RTY PIC X(01). 05 WS_FAB_ORG PIC X(01). 05 WS_FAB_RAT PIC X(01). 05 WS_FAB_RFM PIC X(01). 05 WS_FAB_JNL PIC 9(09) COMP. 05 WS_FAB_XAB POINTER VALUE REFERENCE WS_XAB. 05 WS_FAB_NAM PIC 9(09) COMP VALUE ZERO. 05 WS_FAB_FNA POINTER VALUE REFERENCE WS_FILE_SPEC. 05 WS_FAB_DNA PIC 9(09) COMP VALUE ZERO. 05 WS_FAB_FNS PIC X(01). 05 WS_FAB_DNS PIC X(01). 05 WS_FAB_MRS PIC 9(04). 05 WS_FAB_MRN PIC 9(09) COMP. 05 WS_FAB_BLS PIC 9(04) COMP. 05 WS_FAB_BKS PIC X(01). 05 WS_FAB_FSZ PIC X(01). 05 WS_FAB_DEV PIC 9(09) COMP. 05 WS_FAB_SDC PIC 9(09) COMP. 05 WS_FAB_GBC PIC 9(04) COMP. 05 WS_FAB_DSOMSK PIC X(01). 05 WS_FAB_FILLER PIC X(05). 01 WS_RAB. 05 WS_RAB_BID PIC X(01) VALUE ONE. 05 WS_RAB_BLN PIC X(01) VALUE SIXTY-EIGHT. 05 WS_RAB_ISI PIC 9(04) COMP VALUE ZERO. 05 WS_RAB_ROP PIC 9(09) COMP. 05 WS_RAB_STS PIC 9(09) COMP. 05 WS_RAB_STV PIC 9(09) COMP. 05 WS_RAB_RFA. 10 WS_RAB_RFA_BLOCK_NUMBER PIC 9(09) COMP. 10 WS_RAB_RFA_OFFSET_IN_BLOCK PIC 9(04) COMP. 05 FILLER PIC 9(02). 05 WS_RAB_CTX PIC 9(09) COMP. 05 FILLER PIC X(02). 05 WS_RAB_RAC PIC X(01). 05 WS_RAB_TMO PIC X(01). 05 WS_RAB_USZ PIC 9(04) COMP. 05 WS_RAB_RSZ PIC 9(04) COMP. 05 WS_RAB_UBF PIC 9(09) COMP. 05 WS_RAB_RBF PIC 9(09) COMP. 05 WS_RAB_RHB PIC 9(09) COMP. 05 WS_RAB_K. 10 WS_RAB_KBF POINTER VALUE REFERENCE WS_KEY_BUFFER. 10 WS_RAB_KSZ PIC X(01). 05 WS_RAB_P REDEFINES WS_RAB_K. 10 WS_RAB_PBF PIC 9(09) COMP. 10 WS_RAB_PSZ PIC X(01). 05 WS_RAB_KRF PIC X(01). 05 WS_RAB_MBF PIC X(01). 05 WS_RAB_MBC PIC X(01). 05 WS_RAB_B. 10 WS_RAB_BKT PIC 9(09) COMP. 05 WS_RAB_D REDEFINES WS_RAB_B. 10 WS_RAB_DCT PIC 9(09) COMP. 05 WS_RAB_FAB POINTER VALUE REFERENCE WS_FAB. 05 WS_RAB_XAB PIC 9(09) COMP VALUE 0. 01 WS_XAB. 02 WS_XAB_COD PIC X(01) VALUE TWENTY-ONE. 02 WS_XAB_BLN PIC X(01) VALUE SEVENTY-SIX. 02 FILLER PIC X(02). 02 WS_XAB_NXT PIC S9(09) COMP VALUE ZERO. 02 WS_XAB_IAN PIC X(01). 02 WS_XAB_LAN PIC X(01). 02 WS_XAB_DAN PIC X(01). 02 FILLER PIC X(07). 02 WS_XAB_FLG PIC X(01). 02 WS_XAB_DTP PIC X(01). 02 FILLER PIC X(01). 02 WS_XAB_NUL PIC X(01). 02 FILLER PIC X(01). 02 WS_XAB_REF PIC X(01). 02 FILLER PIC X(02). 02 WS_XAB_IFL PIC 9(04) COMP. 02 WS_XAB_DFL PIC 9(04) COMP. 02 WS_XAB_POS0 PIC 9(04) COMP. 02 WS_XAB_POS1 PIC 9(04) COMP. 02 WS_XAB_POS2 PIC 9(04) COMP. 02 WS_XAB_POS3 PIC 9(04) COMP. 02 WS_XAB_POS4 PIC 9(04) COMP. 02 WS_XAB_POS5 PIC 9(04) COMP. 02 WS_XAB_POS6 PIC 9(04) COMP. 02 WS_XAB_POS7 PIC 9(04) COMP. 02 WS_XAB_SIZ0 PIC X(01). 02 WS_XAB_SIZ1 PIC X(01). 02 WS_XAB_SIZ2 PIC X(01). 02 WS_XAB_SIZ3 PIC X(01). 02 WS_XAB_SIZ4 PIC X(01). 02 WS_XAB_SIZ5 PIC X(01). 02 WS_XAB_SIZ6 PIC X(01). 02 WS_XAB_SIZ7 PIC X(01). 02 FILLER PIC X(02). 02 WS_XAB_KNM POINTER VALUE REFERENCE WS_KEY_NAME. 02 FILLER PIC X(12). 02 WS_XAB_PROLOG PIC X(01). 02 WS_XAB_FILLER PIC X(03). 01 WS_KEY_NAME PIC X(32). 01 WS_KEY_BUFFER PIC X(255). 01 FILLER REDEFINES WS_KEY_BUFFER. 02 WS_REL_REC_NUMBER PIC 9(09) COMP. 02 FILLER PIC X(251). 01 WS_FILE_SPEC PIC X(255). 01 WS_FILE_SPEC_LENGTH PIC S9(09) COMP. 01 WS_STATUS PIC S9(09) COMP. 01 WS_DISPLAY_STATUS PIC 9(09). 01 WS_GET_BUFFER. 02 GET_BUFFER_CHAR PIC X(01) OCCURS 5600 TIMES. 01 WS_UBF_POINTER POINTER VALUE REFERENCE WS_GET_BUFFER. 01 STAT PIC S9(09) COMP. 01 FILLER. 02 FAB$C_IDX PIC S9(04) COMP VALUE 32. 02 FAB$C_REL PIC S9(04) COMP VALUE 16. 02 FAB$C_SEQ PIC S9(04) COMP VALUE 0. 02 LIB$_NOSUCHSYM PIC S9(09) COMP VALUE 001409892. 02 FILE-COUNT PIC 9(01) VALUE 0. 02 GET_FILE PIC X(01) VALUE "N". 02 FILE-TYPE PIC X(01). 88 INDX VALUE "I". 88 SEQ VALUE "S". 88 REL VALUE "R". 02 FAB$V_SHRPUT PIC S9(04) COMP VALUE 1. 02 FAB$V_SHRGET PIC S9(04) COMP VALUE 2. 02 FAB$V_SHRDEL PIC S9(04) COMP VALUE 4. 02 FAB$V_SHRUPD PIC S9(04) COMP VALUE 8. 02 FAB$V_UPI PIC S9(04) COMP VALUE 64. 02 FAB$C_FIX PIC S9(04) COMP VALUE 1. 02 RECORD_FORMAT PIC 9(04). 88 FIX VALUE 1. 88 VAR VALUE 2. 02 RAB$V_KGE PIC S9(09) COMP VALUE 2097152. 02 RAB$V_NLK PIC S9(09) COMP VALUE 1048576. 02 RAB$V_RRL PIC S9(09) COMP VALUE 8. 02 BINARY-WORD PIC S9(04) COMP. 02 FILLER REDEFINES BINARY-WORD. 03 BINARY-VALUE PIC X(01). 03 BINARY-FILLER PIC X(01). 02 ITMLST. 03 FILLER PIC S9(04) COMP VALUE 255. 03 FILLER PIC S9(04) COMP VALUE 2. 03 FILLER POINTER VALUE REFERENCE WS_FILE_SPEC. 03 FILLER POINTER VALUE REFERENCE WS_FILE_SPEC_LENGTH. 03 FILLER PIC S9(09) COMP VALUE 0. 02 FILELST. 03 FILLER PIC S9(04) COMP VALUE 255. 03 FILLER PIC S9(04) COMP VALUE 2. 03 FILLER POINTER VALUE REFERENCE FILE-NAME. 03 FILLER POINTER VALUE REFERENCE FILE-NAME-LENGTH. 03 FILLER PIC S9(09) COMP VALUE 0. 02 USERLST. 03 FILLER PIC S9(04) COMP VALUE 12. 03 FILLER PIC S9(04) COMP VALUE EXTERNAL JPI$_USERNAME. 03 FILLER POINTER VALUE REFERENCE WUSERNAME. 03 FILLER POINTER VALUE REFERENCE USERNAME-LENGTH. 03 FILLER PIC S9(09) COMP VALUE 0. 02 USERNAME-LENGTH PIC S9(04) COMP. 02 WUSERNAME. 03 USER-CHAR PIC X(01) OCCURS 12 TIMES. 02 WS_KEY_OF_REF PIC X(02). 02 KEY-OF-REFERENCE PIC 9(02). 02 WS_MAX_KEY PIC X(255). 02 WS_FIRST_X PIC X(08). 02 WS_FIRST_RECORD PIC 9(08). 02 WS_MAX_X PIC X(08). 02 WS_MAX_RECORD PIC 9(08). 02 KEY-POSITION PIC 9(04). 02 KEY-LENGTH PIC 9(04). 02 HEX-LINE. 03 INFILE-RECNUM PIC 9(08). 03 FILLER PIC X(04). 03 HEX-DCHAR PIC X(02) OCCURS 50 TIMES. 02 ALPHA-LINE. 03 FILLER PIC X(12). 03 FILLER OCCURS 50 TIMES. 04 FILLER PIC X(01). 04 ALPHA-DCHAR PIC X(01). 02 IN-CHAR PIC X(01). 02 SUBX PIC 9(05). 02 HEX-CHAR PIC X(02). 02 OUTPUT-COUNT PIC 9(03). 02 INFILE-REC-COUNT PIC 9(08). 02 LOG-NAME PIC X(04) VALUE "PRT2". 02 LOGNAME-ITMLST. 03 EQUIVNAME-BUFFER-LENGTH PIC S9(04) COMP VALUE 80. 03 FILLER PIC S9(04) COMP VALUE 2. 03 FILLER POINTER VALUE REFERENCE FILE-NAME. 03 FILLER POINTER VALUE REFERENCE FILE-NAME-LENGTH. 03 FILLER PIC S9(09) COMP VALUE 0. 02 PRINT-FLD. 03 FILLER PIC X(19) VALUE "PRINT/DELETE/FORMS=". 03 WIDE_FORM PIC X(20). 03 FILE-NAME PIC X(80). 02 OTHER-QUEUE-PRINT-FLD. 03 FILLER PIC X(19) VALUE "PRINT/DELETE/FORMS=". 03 NARROW_FORM PIC X(20). 03 FILLER PIC X(07) VALUE "/QUEUE=". 03 WHAT_QUE PIC X(31). 03 FILLER PIC X(01) VALUE " ". 03 OQPF-FILE-NAME PIC X(80). 02 FILE-NAME-LENGTH PIC S9(09) COMP VALUE 0. 02 DELETE-FLD. 03 FILLER PIC X(07) VALUE "DELETE ". 03 DELETE-FILE. 04 DELETE-CHAR PIC X(01) OCCURS 80 TIMES. 02 DELETE-NAME-LENGTH PIC S9(09) COMP VALUE 0. 02 REPLY PIC X(31). 88 YEA VALUE "Y" "y" "YES" "yes". 88 NEA VALUE " " "N" "n" "NO" "no". 01 DISPLAY_QUEUE PIC S9(09) COMP VALUE 6. 01 IOSB. 02 FILLER OCCURS 2 TIMES. 03 IOSB-LONGWORD PIC 9(09) COMP. 01 JBC$_NOMOREQUE PIC S9(09) COMP VALUE 295338. 01 QUE_ITMLST. 02 FILLER PIC S9(04) COMP VALUE 31. 02 FILLER PIC S9(04) COMP VALUE 77. 02 FILLER POINTER VALUE REFERENCE SEARCH_NAME. 02 FILLER POINTER VALUE REFERENCE SEARCH_NAME_LENGTH. 02 FILLER PIC S9(04) COMP VALUE 4. 02 FILLER PIC S9(04) COMP VALUE 76. 02 FILLER POINTER VALUE REFERENCE SEARCH_FLAGS. 02 FILLER POINTER VALUE REFERENCE SEARCH_FLAGS_LENGTH. 02 FILLER PIC S9(04) COMP VALUE 31. 02 FILLER PIC S9(04) COMP VALUE 31. 02 FILLER POINTER VALUE REFERENCE FORM_NAME. 02 FILLER POINTER VALUE REFERENCE FORM_NAME_LENGTH. 02 FILLER PIC S9(04) COMP VALUE 31. 02 FILLER PIC S9(04) COMP VALUE 70. 02 FILLER POINTER VALUE REFERENCE QUEUE_NAME. 02 FILLER POINTER VALUE REFERENCE QUEUE_NAME_LENGTH. 02 FILLER PIC S9(04) COMP VALUE 4. 02 FILLER PIC S9(04) COMP VALUE 71. 02 FILLER POINTER VALUE REFERENCE QUEUE_STATUS. 02 FILLER POINTER VALUE REFERENCE QUEUE_STATUS_LENGTH. 02 FILLER PIC S9(09) COMP VALUE 0. 01 SEARCH_NAME PIC X(31). 01 SEARCH_NAME_LENGTH PIC S9(09) COMP VALUE 0. 01 SEARCH_FLAGS PIC 9(09) COMP VALUE 0. 01 SEARCH_FLAGS_LENGTH PIC S9(09) COMP VALUE 0. 01 FORM_NAME PIC X(31). 01 FORM_NAME_LENGTH PIC S9(09) COMP. 01 QUEUE_NAME PIC X(31). 01 QUEUE_NAME_LENGTH PIC S9(09) COMP. 01 QUEUE_STATUS PIC 9(09) COMP. 01 QUEUE_STATUS_LENGTH PIC S9(09) COMP. 01 QTYPE PIC X(05) VALUE " ". 01 QUEUE_OK PIC X(03) VALUE " ". 01 TIMBUF PIC X(13). 01 TBL-IND PIC S9(09) COMP VALUE EXTERNAL LIB$K_CLI_GLOBAL_SYM. 01 SPECIAL-EFFECTS. 02 DWIDE. 03 FILLER PIC S9(04) COMP VALUE 27. 03 FILLER PIC S9(04) COMP VALUE 35. 03 FILLER PIC S9(04) COMP VALUE 54. 02 CLR. 03 FILLER PIC S9(04) COMP VALUE 27. 03 FILLER PIC S9(04) COMP VALUE 91. 03 FILLER PIC S9(04) COMP VALUE 50. 03 FILLER PIC S9(04) COMP VALUE 74. 02 HOME. 03 FILLER PIC S9(04) COMP VALUE 27. 03 FILLER PIC S9(04) COMP VALUE 91. 03 FILLER PIC S9(04) COMP VALUE 48. 03 FILLER PIC S9(04) COMP VALUE 59. 03 FILLER PIC S9(04) COMP VALUE 48. 03 FILLER PIC S9(04) COMP VALUE 72. 02 WBOLD. 03 FILLER PIC S9(04) COMP VALUE 27. 03 FILLER PIC S9(04) COMP VALUE 91. 03 FILLER PIC S9(04) COMP VALUE 49. 03 FILLER PIC S9(04) COMP VALUE 109. 02 SINGLE-WIDTH. 03 FILLER PIC S9(04) COMP VALUE 27. 03 FILLER PIC S9(04) COMP VALUE 35. 03 FILLER PIC S9(04) COMP VALUE 53. 02 DOUBLE-WIDTH. 03 FILLER PIC S9(04) COMP VALUE 27. 03 FILLER PIC S9(04) COMP VALUE 35. 03 FILLER PIC S9(04) COMP VALUE 54. 02 REVERSE. 03 FILLER PIC S9(04) COMP VALUE 27. 03 FILLER PIC S9(04) COMP VALUE 91. 03 FILLER PIC S9(04) COMP VALUE 55. 03 FILLER PIC S9(04) COMP VALUE 109. 02 132-WIDE. 03 FILLER PIC S9(04) COMP VALUE 27. 03 FILLER PIC S9(04) COMP VALUE 91. 03 FILLER PIC S9(04) COMP VALUE 63. 03 FILLER PIC S9(04) COMP VALUE 51. 03 FILLER PIC S9(04) COMP VALUE 104. 02 80-WIDE. 03 FILLER PIC S9(04) COMP VALUE 27. 03 FILLER PIC S9(04) COMP VALUE 91. 03 FILLER PIC S9(04) COMP VALUE 63. 03 FILLER PIC S9(04) COMP VALUE 51. 03 FILLER PIC S9(04) COMP VALUE 108. 02 CLR-ATT. 03 FILLER PIC S9(04) COMP VALUE 27. 03 FILLER PIC S9(04) COMP VALUE 91. 03 FILLER PIC S9(04) COMP VALUE 48. 03 FILLER PIC S9(04) COMP VALUE 109. 02 WHOLE-SCROLL. 03 FILLER PIC S9(04) COMP VALUE 27. 03 FILLER PIC S9(04) COMP VALUE 91. 03 FILLER PIC S9(04) COMP VALUE 48. 03 FILLER PIC S9(04) COMP VALUE 59. 03 FILLER PIC S9(04) COMP VALUE 50. 03 FILLER PIC S9(04) COMP VALUE 52. 03 FILLER PIC S9(04) COMP VALUE 114. 03 FILLER PIC S9(04) COMP VALUE 27. 03 FILLER PIC S9(04) COMP VALUE 91. 03 FILLER PIC S9(04) COMP VALUE 51. 03 FILLER PIC S9(04) COMP VALUE 59. 03 FILLER PIC S9(04) COMP VALUE 48. 03 FILLER PIC S9(04) COMP VALUE 72. 02 BOTTOM-SCROLL. 03 FILLER PIC S9(04) COMP VALUE 27. 03 FILLER PIC S9(04) COMP VALUE 91. 03 FILLER PIC S9(04) COMP VALUE 52. 03 FILLER PIC S9(04) COMP VALUE 59. 03 FILLER PIC S9(04) COMP VALUE 50. 03 FILLER PIC S9(04) COMP VALUE 52. 03 FILLER PIC S9(04) COMP VALUE 114. 03 FILLER PIC S9(04) COMP VALUE 27. 03 FILLER PIC S9(04) COMP VALUE 91. 03 FILLER PIC S9(04) COMP VALUE 51. 03 FILLER PIC S9(04) COMP VALUE 59. 03 FILLER PIC S9(04) COMP VALUE 48. 03 FILLER PIC S9(04) COMP VALUE 72. 02 BOTTOM-SCROLL3. 03 FILLER PIC S9(04) COMP VALUE 27. 03 FILLER PIC S9(04) COMP VALUE 91. 03 FILLER PIC S9(04) COMP VALUE 51. 03 FILLER PIC S9(04) COMP VALUE 59. 03 FILLER PIC S9(04) COMP VALUE 50. 03 FILLER PIC S9(04) COMP VALUE 52. 03 FILLER PIC S9(04) COMP VALUE 114. 03 FILLER PIC S9(04) COMP VALUE 27. 03 FILLER PIC S9(04) COMP VALUE 91. 03 FILLER PIC S9(04) COMP VALUE 51. 03 FILLER PIC S9(04) COMP VALUE 59. 03 FILLER PIC S9(04) COMP VALUE 48. 03 FILLER PIC S9(04) COMP VALUE 72. PROCEDURE DIVISION. BEGIN. OPEN OUTPUT PR_DISPLAY. MOVE " " TO FILE-TYPE. MOVE " " TO WUSERNAME. CALL "SYS$GETJPI" USING BY VALUE 0 BY VALUE 0 BY VALUE 0 BY REFERENCE USERLST BY VALUE 0 BY VALUE 0 BY VALUE 0 GIVING STAT. MOVE 12 TO USERNAME-LENGTH. PERFORM UNTIL USER-CHAR (USERNAME-LENGTH) NOT = " " SUBTRACT 1 FROM USERNAME-LENGTH END-PERFORM. CALL "LIB$GET_SYMBOL" USING BY DESCRIPTOR "FILETYPE" BY DESCRIPTOR FILE-TYPE BY VALUE 0 BY REFERENCE TBL-IND GIVING STAT. CALL "LIB$GET_SYMBOL" USING BY DESCRIPTOR "PRF_COUNT" BY DESCRIPTOR FILE-COUNT BY VALUE 0 BY REFERENCE TBL-IND GIVING STAT. CALL "LIB$GET_SYMBOL" USING BY DESCRIPTOR "WIDE_FORM" BY DESCRIPTOR WIDE_FORM BY VALUE 0 BY REFERENCE TBL-IND GIVING STAT. CALL "LIB$GET_SYMBOL" USING BY DESCRIPTOR "NARROW_FORM" BY DESCRIPTOR NARROW_FORM BY VALUE 0 BY REFERENCE TBL-IND GIVING STAT. CALL "SYS$TRNLNM" USING BY VALUE 0 BY DESCRIPTOR "LNM$PROCESS_TABLE" BY DESCRIPTOR "INFILE" BY VALUE 0 BY REFERENCE ITMLST GIVING STAT. IF STAT IS FAILURE CALL "LIB$STOP" USING BY VALUE STAT. MOVE WS_FILE_SPEC_LENGTH TO BINARY-WORD. MOVE BINARY-VALUE TO WS_FAB_FNS. MOVE " " TO WS_KEY_OF_REF. IF NOT INDX GO TO OPEN-FILE. CALL "LIB$GET_SYMBOL" USING BY DESCRIPTOR "KEY_OF_REF" BY DESCRIPTOR KEY-OF-REFERENCE BY VALUE 0 BY REFERENCE TBL-IND GIVING STAT. IF STAT = LIB$_NOSUCHSYM NEXT SENTENCE ELSE GO TO OPEN-FILE. GET-KEY-OF-REFERENCE. MOVE 0 TO KEY-OF-REFERENCE. DISPLAY " ". DISPLAY "Enter key of reference: [key 0] " WITH NO ADVANCING. ACCEPT WS_KEY_OF_REF. IF WS_KEY_OF_REF = "." GO TO E-O-J. IF WS_KEY_OF_REF = " " NEXT SENTENCE ELSE MOVE WS_KEY_OF_REF TO ENTERED-NUMBER MOVE 00 TO EDIT-COMMAND PERFORM EDIT-RTN THRU EDIT-RTN-EXIT IF GOOD-BAD = "B" DISPLAY " " DISPLAY WBOLD "**** INVALID KEY OF REFERENCE ENTRY ****" CLR-ATT GO TO GET-KEY-OF-REFERENCE ELSE MOVE GOOD-NUMBER TO KEY-OF-REFERENCE. CALL "LIB$SET_SYMBOL" USING BY DESCRIPTOR "KEY_OF_REF" BY DESCRIPTOR KEY-OF-REFERENCE BY REFERENCE TBL-IND GIVING STAT. OPEN-FILE. IF SEQ MOVE FAB$V_SHRGET TO BINARY-WORD MOVE BINARY-VALUE TO WS_FAB_SHR ELSE ADD FAB$V_SHRDEL FAB$V_SHRGET FAB$V_SHRPUT FAB$V_SHRUPD GIVING BINARY-WORD MOVE BINARY-VALUE TO WS_FAB_SHR. MOVE KEY-OF-REFERENCE TO BINARY-WORD. MOVE BINARY-VALUE TO WS_XAB_REF. ******************* O P E N I N G F I L E ******************* CALL "SYS$OPEN" USING BY REFERENCE WS_FAB GIVING WS_STATUS. IF WS_STATUS IS FAILURE MOVE WS_STATUS TO WS_DISPLAY_STATUS IF WS_DISPLAY_STATUS = 100188 DISPLAY " " DISPLAY WBOLD "**** INVALID KEY OF REFERENCE ENTRY ****" CLR-ATT GO TO GET-KEY-OF-REFERENCE ELSE IF WS_DISPLAY_STATUS = 98954 DISPLAY " " DISPLAY WBOLD "***** FILE CURRENTLY LOCKED BY ANOTHER - " USER *****" CLR-ATT DISPLAY " " MOVE "Y" TO GET_FILE CALL "LIB$SET_SYMBOL" USING BY DESCRIPTOR "GET_FILE" BY DESCRIPTOR GET_FILE BY REFERENCE TBL-IND GIVING STAT GO TO E-O-J END-IF IF WS_DISPLAY_STATUS = 98962 DISPLAY " " DISPLAY WBOLD "***** FILE NOT FOUND *****" CLR-ATT DISPLAY " " MOVE "Y" TO GET_FILE CALL "LIB$SET_SYMBOL" USING BY DESCRIPTOR "GET_FILE" BY DESCRIPTOR GET_FILE BY REFERENCE TBL-IND GIVING STAT GO TO E-O-J END-IF IF WS_DISPLAY_STATUS = 100052 DISPLAY " " DISPLAY WBOLD "***** FILENAME SYNTAX ERROR *****" CLR-ATT DISPLAY " " MOVE "Y" TO GET_FILE CALL "LIB$SET_SYMBOL" USING BY DESCRIPTOR "GET_FILE" BY DESCRIPTOR GET_FILE BY REFERENCE TBL-IND GIVING STAT GO TO E-O-J END-IF DISPLAY " OPEN STATUS = " WS_DISPLAY_STATUS CALL "LIB$STOP" USING BY VALUE WS_STATUS. ******************* C O N N E C T R A B ******************* IF REL OR SEQ MOVE FOUR TO WS_RAB_KSZ. IF INDX MOVE WS_XAB_SIZ0 TO WS_RAB_KSZ MOVE KEY-OF-REFERENCE TO BINARY-WORD MOVE BINARY-VALUE TO WS_RAB_KRF ADD RAB$V_KGE RAB$V_NLK RAB$V_RRL GIVING WS_RAB_ROP. CALL "SYS$CONNECT" USING BY REFERENCE WS_RAB GIVING WS_STATUS. IF WS_STATUS IS FAILURE MOVE WS_STATUS TO WS_DISPLAY_STATUS IF WS_DISPLAY_STATUS = 100188 DISPLAY " " DISPLAY WBOLD "**** INVALID KEY OF REFERENCE ENTRY ****" CLR-ATT GO TO GET-KEY-OF-REFERENCE ELSE DISPLAY " OPEN STATUS = " WS_DISPLAY_STATUS CALL "LIB$STOP" USING BY VALUE WS_STATUS. IF REL OR SEQ GO TO GET-RECORD-NUMBERS. ADD 1 WS_XAB_POS0 GIVING KEY-POSITION. MOVE 00 TO BINARY-WORD. MOVE WS_XAB_SIZ0 TO BINARY-VALUE. MOVE BINARY-WORD TO KEY-LENGTH. DISPLAY " ". DISPLAY " Key " KEY-OF-REFERENCE " has a maximum length of " KEY-LENGTH. GET-KEY-VALUES. MOVE " " TO WS_KEY_BUFFER WS_MAX_KEY. DISPLAY " ". DISPLAY "Enter starting key value: [begin] " WITH NO ADVANCING. ACCEPT WS_KEY_BUFFER. IF WS_KEY_BUFFER = "." CALL "SYS$CLOSE" USING BY REFERENCE WS_FAB GIVING WS_STATUS IF WS_STATUS IS FAILURE CALL "LIB$STOP" USING BY VALUE WS_STATUS END-IF GO TO GET-KEY-OF-REFERENCE. DISPLAY " ". DISPLAY "Enter maximum value: [one record] " WITH NO ADVANCING. ACCEPT WS_MAX_KEY. IF WS_MAX_KEY = "." CALL "SYS$CLOSE" USING BY REFERENCE WS_FAB GIVING WS_STATUS IF WS_STATUS IS FAILURE CALL "LIB$STOP" USING BY VALUE WS_STATUS END-IF GO TO GET-KEY-OF-REFERENCE. IF WS_MAX_KEY = " " MOVE WS_KEY_BUFFER TO WS_MAX_KEY. IF WS_KEY_BUFFER = " " AND WS_MAX_KEY = " " CALL "SYS$CLOSE" USING BY REFERENCE WS_FAB GIVING WS_STATUS IF WS_STATUS IS FAILURE CALL "LIB$STOP" USING BY VALUE WS_STATUS END-IF GO TO GET-KEY-OF-REFERENCE. ADD RAB$V_KGE RAB$V_NLK RAB$V_RRL GIVING WS_RAB_ROP. GO TO FILE-READ. GET-RECORD-NUMBERS. MOVE " " TO WS_FIRST_X WS_MAX_X. MOVE 0 TO WS_FIRST_RECORD WS_MAX_RECORD. DISPLAY " ". DISPLAY "Enter starting record number: [begin] " WITH NO ADVANCING. ACCEPT WS_FIRST_X. IF WS_FIRST_X = "." GO TO E-O-J. IF WS_FIRST_X = " " MOVE 1 TO WS_FIRST_RECORD ELSE MOVE WS_FIRST_X TO ENTERED_NUMBER MOVE 00 TO EDIT-COMMAND PERFORM EDIT-RTN THRU EDIT-RTN-EXIT IF GOOD-BAD = "B" DISPLAY " " DISPLAY WBOLD "**** BAD STARTING RECORD NUMBER ENTRY ****" CLR-ATT GO TO GET-RECORD-NUMBERS ELSE MOVE GOOD-NUMBER TO WS_FIRST_RECORD. MOVE WS_FIRST_RECORD TO WS_REL_REC_NUMBER. GET-LAST-RECORD. DISPLAY " ". DISPLAY "Enter maximum value: [one record] " WITH NO ADVANCING. ACCEPT WS_MAX_X. IF WS_MAX_X = "." GO TO E-O-J. IF WS_MAX_X = " " MOVE WS_FIRST_RECORD TO WS_MAX_RECORD ELSE MOVE WS_MAX_X TO ENTERED-NUMBER MOVE 00 TO EDIT-COMMAND PERFORM EDIT-RTN THRU EDIT-RTN-EXIT IF GOOD-BAD = "B" DISPLAY " " DISPLAY WBOLD "**** BAD MAXIMUM RECORD NUMBER ENTRY ****" CLR-ATT GO TO GET-LAST-RECORD ELSE MOVE GOOD-NUMBER TO WS_MAX_RECORD. IF WS_FIRST_RECORD = 0 AND WS_MAX_RECORD = 0 GO TO E-O-J. GO TO FILE-READ. E-O-J. CLOSE PR_DISPLAY. STOP RUN. FILE-READ. ADD 1 TO FILE-COUNT CALL "LIB$SET_SYMBOL" USING BY DESCRIPTOR "PRF_COUNT" BY DESCRIPTOR FILE-COUNT BY REFERENCE TBL-IND GIVING STAT. MOVE " " TO FILE-NAME. STRING "SYS$LOGIN:" WUSERNAME (1:USERNAME-LENGTH) "_PRF_" FILE-COUNT ".LIS" DELIMITED BY SIZE INTO FILE-NAME. CALL "SYS$CRELNM" USING BY VALUE 0 BY DESCRIPTOR "LNM$JOB" BY DESCRIPTOR LOG-NAME BY VALUE 0 BY REFERENCE LOGNAME-ITMLST GIVING STAT. IF STAT IS FAILURE CALL "LIB$STOP" USING BY VALUE STAT. DISPLAY CLR. DISPLAY 132-WIDE. DISPLAY HOME. MOVE WS_UBF_POINTER TO WS_RAB_UBF. MOVE 5600 TO WS_RAB_USZ. MOVE ZEERO TO WS_RAB_RAC. MOVE 00 TO BINARY-WORD. MOVE WS_FAB_RFM TO BINARY-VALUE. MOVE BINARY-WORD TO RECORD_FORMAT. MOVE 1 TO INFILE-REC-COUNT. IF INDX OR REL OR FIX MOVE ONE TO WS_RAB_RAC. IF NOT INDX MOVE WS_FIRST_RECORD TO INFILE-REC-COUNT. OPEN OUTPUT PR_PRINT. ******************* R E A D R E C O R D ******************* READ-REC. CALL "SYS$GET" USING BY REFERENCE WS_RAB GIVING WS_STATUS. MOVE WS_STATUS TO WS_DISPLAY_STATUS. IF WS_DISPLAY_STATUS = 98938 OR WS_DISPLAY_STATUS = 98994 GO TO READ-REC-EXIT. IF WS_STATUS IS FAILURE DISPLAY "GET STATUS = " WS_DISPLAY_STATUS CALL "LIB$STOP" USING BY VALUE WS_STATUS. IF INDX IF WS_GET_BUFFER (KEY-POSITION:KEY-LENGTH) > WS_MAX_KEY (1:KEY-LENGTH) GO TO READ-REC-EXIT. IF REL OR SEQ IF INFILE-REC-COUNT < WS_FIRST_RECORD GO TO READ_REC END-IF IF INFILE-REC-COUNT > WS_MAX_RECORD GO TO READ-REC-EXIT. MOVE " " TO HEX-LINE. MOVE " " TO ALPHA-LINE. MOVE 0 TO OUTPUT-COUNT. MOVE INFILE-REC-COUNT TO INFILE-RECNUM. PERFORM CONVERT-RTN THRU CONVERT-RTN-EXIT VARYING SUBX FROM 1 BY 1 UNTIL SUBX > WS_RAB_RSZ. IF OUTPUT-COUNT NOT = 0 PERFORM PRINT-RTN THRU PRINT-RTN-EXIT. MOVE ZEERO TO WS_RAB_RAC. ADD 1 TO INFILE-REC-COUNT. GO TO READ-REC. READ-REC-EXIT. CLOSE PR_PRINT. CALL "SYS$DELLNM" USING BY DESCRIPTOR "LNM$JOB" BY DESCRIPTOR LOG-NAME BY VALUE 0 GIVING STAT. IF INFILE-REC-COUNT = 0 DISPLAY " " IF INDX DISPLAY " NO RECORDS FOUND FOR KEY VALUES GIVEN. " ELSE DISPLAY " NO RECORDS FOUND FOR RECORD NUMBER RANGE - " GIVEN. " END-IF MOVE "0 00:00:03.00" TO TIMBUF CALL "WASTE_TIME" USING TIMBUF PERFORM DELETE-FILE-RTN THRU DELETE-FILE-EXIT GO TO CLOSE-FILE. ASK-FOR-PRINT-REPLY. MOVE " " TO REPLY. DISPLAY DOUBLE-WIDTH WITH NO ADVANCING. DISPLAY "DO YOU WANT TO PRINT THESE RECORDS? " WITH NO ADVANCING. ACCEPT REPLY. * CALL "SYS$TRNLNM" USING BY VALUE 0 * BY DESCRIPTOR "LNM$PROCESS_TABLE" * BY DESCRIPTOR "PRT2" * BY VALUE 0 * BY REFERENCE FILELST * GIVING STAT. IF YEA CALL "LIB$SPAWN" USING BY DESCRIPTOR PRINT-FLD BY VALUE 0 0 0 0 0 0 0 GIVING STAT IF STAT IS FAILURE CALL "LIB$STOP" USING BY VALUE STAT. IF NEA PERFORM DELETE-FILE-RTN THRU DELETE-FILE-EXIT. IF NOT YEA AND NOT NEA MOVE REPLY TO WHAT_QUE PERFORM QUEUE-CHECK-RTN THRU QUEUE-CHECK-RTN-EXIT IF QUEUE_OK = "NO" DISPLAY " " GO TO ASK-FOR-PRINT-REPLY. CLOSE-FILE. DISPLAY CLR. DISPLAY 80-WIDE. DISPLAY HOME. CALL "SYS$CLOSE" USING BY REFERENCE WS_FAB GIVING WS_STATUS. IF WS_STATUS IS FAILURE CALL "LIB$STOP" USING BY VALUE WS_STATUS. DISPLAY DWIDE " " WBOLD "***** PRINT OF FILE UTILITY *****" CLR-ATT. GO TO OPEN-FILE. CONVERT-RTN. MOVE GET_BUFFER_CHAR (SUBX) TO IN-CHAR. CALL "OTS$CVT_L_TZ" USING BY REFERENCE IN-CHAR BY DESCRIPTOR HEX-CHAR BY VALUE 2 BY VALUE 1 GIVING STAT. IF STAT IS FAILURE CALL "LIB$STOP" USING BY VALUE STAT. ADD 1 TO OUTPUT-COUNT. MOVE HEX-CHAR TO HEX-DCHAR (OUTPUT-COUNT). IF HEX-CHAR < 20 OR HEX-CHAR > "7F" NEXT SENTENCE ELSE MOVE IN-CHAR TO ALPHA-DCHAR (OUTPUT-COUNT). IF OUTPUT-COUNT = 50 PERFORM PRINT-RTN THRU PRINT-RTN-EXIT. CONVERT-RTN-EXIT. EXIT. PRINT-RTN. WRITE PRINT-LINE FROM HEX-LINE AFTER 2. WRITE PRINT-LINE FROM ALPHA-LINE AFTER 1. WRITE DISPLAY-LINE FROM HEX-LINE AFTER 2. WRITE DISPLAY-LINE FROM ALPHA-LINE AFTER 1. MOVE " " TO HEX-LINE. MOVE " " TO ALPHA-LINE. MOVE 0 TO OUTPUT-COUNT. PRINT-RTN-EXIT. EXIT. DELETE-FILE-RTN. MOVE FILE-NAME TO DELETE-FILE. MOVE 80 TO DELETE-NAME-LENGTH. PERFORM UNTIL DELETE-CHAR (DELETE-NAME-LENGTH) NOT = " " SUBTRACT 1 FROM DELETE-NAME-LENGTH END-PERFORM. ADD 1 TO DELETE-NAME-LENGTH. MOVE ";" TO DELETE-CHAR (DELETE-NAME-LENGTH). CALL "LIB$SPAWN" USING BY DESCRIPTOR DELETE-FLD BY VALUE 0 0 0 0 0 0 0 GIVING STAT. IF STAT IS FAILURE CALL "LIB$STOP" USING BY VALUE STAT. DELETE-FILE-EXIT. EXIT. QUEUE-CHECK-RTN. MOVE "NO" TO QUEUE_OK. MOVE 8 TO SEARCH_FLAGS. MOVE "*" TO SEARCH_NAME. START-SEARCHING. CALL "SYS$GETQUIW" USING BY VALUE 0 BY VALUE DISPLAY_QUEUE BY VALUE 0 BY REFERENCE QUE_ITMLST BY REFERENCE IOSB BY VALUE 0 0 GIVING STAT. IF STAT IS FAILURE CALL "LIB$STOP" USING BY VALUE STAT. IF IOSB-LONGWORD (1) = JBC$_NOMOREQUE GO TO QUEUE-CHECK-RTN-EXIT. IF QUEUE_NAME (1:QUEUE_NAME_LENGTH) NOT = WHAT_QUE GO TO START-SEARCHING. MOVE "YES" TO QUEUE_OK. MOVE FILE-NAME TO OQPF-FILE-NAME. CALL "LIB$SPAWN" USING BY DESCRIPTOR OTHER-QUEUE-PRINT-FLD BY VALUE 0 0 0 0 0 0 0 GIVING STAT. IF STAT IS FAILURE CALL "LIB$STOP" USING BY VALUE STAT. GO TO START-SEARCHING. QUEUE-CHECK-RTN-EXIT. EXIT. COPY EDRUTINE.