001000$CONTROL NOLIST 001100****************************************************************** 001200* P R O L O G S T A N D A R D M A C R O S 001300* 001400* *** NATIVE MODE VERSION *** 001500* 001600* (to ANSI 85 standards) 001700* 001800* All these macros are dependent on the linkage area called 001900* COMMON-LINKAGE. (copy COMAREA in STANDARD) 002000* 002100****************************************************************** 002200* AMENDMENT HISTORY: 002300* 002400* 1) Add macro %DAYOFWEEK. 002500* 02/07/86 - Tony Marston 002600* 002700* 2) Amend KSAM macros to move -RECSIZE to KSAM-RECSIZE so 002800* that the correct value gets reported in the event of an 002900* error. 003000* 16/07/86 - Tony Marston 003100* 003200* 3) Amend date macros to test for zero/blank values. 003300* 17/07/86 - Tony Marston 003400* 003500* 4) Amend all IMAGE macros to move !3-DSET to IMAGE-DSET instead 003600* of "!3" (in the event of an error), as it hid a problem 003700* where !3-DSET became corrupted for some reason. 003800* 31/7/86 - Tony Marston 003900* 004000* 5) Added macros %BNUMBER1, %BNUMBER2, %BNUMBER4. 004100* 04/08/86 - Tony Marston 004200* 004300* 6) Amended %CONFIRMDATA macro to check for errors detected by 004400* a call to VFIELDEDITS - this still leaves the "CONFIRM" key 004500* available to the user, but treats it as the ENTER key so that 004600* the program returns to the previous %ACCEPTENTER. 004700* 11/09/86 - Tony Marston 004800* 004900* 7) Amended %CKLOCK macro to allow for KSAM-LOCK-FAILURE - this 005000* condition must now be tested for by the program code. 005100* 01/10/86 - Tony Marston 005200* 005300* 8) Added macro %BNUMBER3. 005400* 14/10/86 - Tony Marston 005500* 005600* 9) Added macro %USELECT 005700* 13/01/87 - Tony Marston 005800* 005900* 10) Amended %CKLOCK macro to put msg 010095 into VIEW-WINDOW 006000* in the event of a lock failure. 006100* 16/01/87 - Tony Marston 006200* 006300* 11) Changed name of %AUTOREAD to %SFAUTOREAD so that it would 006400* not be used instead of %VAUTOREAD by mistake. 006500* 05/02/87 - Tony Marston 006600* 006700* 12) Amended %CONFIRMDATA macro to include parameter for the 006800* revalidation point should the user press ENTER instead of 006900* a function key. 007000* Added %DBFETCHLAST macro to get the last record on a chain. 007100* Added %DBOPEN5 macro for read-only access. 007200* Added %BATCHINIT macro to initialise batch program linkage. 007300* 06/02/87 - Tony Marston 007400* 007500* 13) Amended %VPUTBUFFER to test for a non-zero value in 007600* VIEW-NUMERRS before it executes, otherwise it overrides any 007700* error flags which have been set. 007800* Amended %CONFIRMDATA to test for NO-VEDIT-ERRORS before 007900* loading the function key label. 008000* 04/03/87 - Tony Marston 008100* 008200* 14) Indented the %IMAGEERR, %KSAMERR and %VPLUSERR macros. 008300* For most IMAGE macros the intrinsic name and mode have been 008400* combined into a single move statement to reduce the lines 008500* of object code produced. 008600* 10/04/87 - Tony Marston 008700* 008800* 15) Changed IMAGE macros so that moves to IMAGE-DSET, -ITEM and 008900* -ARGUMENT are only performed in the event of an error. 009000* Also added a macro for DBMEMO. 009100* 22/04/87 - Tony Marston 009200* 009300* 16) Changed %CONFIRMDATA macro to test for VEDIT-ERRORS before 009400* doing anything else - if there are errore then control will 009500* be passed immediately back to the validation paragraph. 009600* 02/09/87 - Tony Marston 009700* 009800* 17) Removed call to VOPENFORMF from %VOPENFORM macro and all 009900* code from %VCLOSEFORM macro. The user form must now be 010000* opened with the %OPENUSERFORM macro and must not be closed, 010100* as any attempt to reopen may cause a DLSIZE error. 010200* 19/10/87 - Tony Marston 010300* 010400* 18) Added the %UWEEK macro to give the week number associated 010500* with a date. 010600* 01/12/87 - Tony Marston 010700* 010800* 19) Replaced all moves to VIEW-SHOWCONTROL by %SETABIT so that 010900* other bits are not accidentally set to zero. 011000* 07/12/87 - Tony Marston 011100* 011200* 20) Added macro %DEBUG to provide a program trace. 011300* 22/02/88 - Tony Marston 011400* 011500* 21) Added macro %DBLOGGING (used in %DBOPEN) to test if logging 011600* is turned on and to set a flag accordingly. 011700* Changed %DBBEBGIN and %DBEND to test this flag. 011800* 23/02/88 - Tony Marston 011900* 012000* 22) Changed macros to add END-IF to COBOL85 standards 012100* 23/02/88 - Steve Adams 012200* 012300* 23) Changed %COMMANDERR as UERROR will now decode the error 012400* number into text and include it in the error report. 012500* Added macros %OPENUSERMSG and %OPENUSERHELP. 012600* Changed macros %OPENUSERFORM, %VCLOSEFORM. 012700* %VOPENFORM is now redundant. 012800* 04/03/88 - Tony Marston 012900* 013000* 24) Added macro %SGVCHANGEFIELD. 013100* 12/04/88 - Tony Marston 013200* 013300* 25) Added macros for use with message (MSG) files. 013400* 25/04/88 - Tony Marston 013500* 013600* 26) Changed %ED macro so that "WITH DEBUGGING MODE" is included 013700* if compiler switch X1=ON (this is automatically set to ON 013800* by the FIJI TESTCOMP jobstream). 013900* 16/05/88 - Tony Marston 014000* 014100* 27) Added macro %FINDJCW. 014200* 06/06/88 - Tony Marston 014300* 014400* 28) Added several SYMBOLIC characters to the SPECIAL-NAMES 014500* paragraph of the CONFIGURATION SECTION. 014600* 19/07/88 - Tony Marston 014700* 014800* 29) Changed the %DEBUG macro to include the program name as an 014900* optional parameter, so that the displays from different 015000* subprograms can be easily identified. 015100* 04/08/88 - Tony Marston 015200* 015300* 30) Changed macros %OPENUSERFORM and %VCLOSEFORM to remove 015400* reference to field VIEW-USER-FORM. 015500* Tony Marston - 24/11/88 015600* 015700* 31) Added macros %BYTEADDRESS and %WORDADDRESS to obtain the 015800* byte/word address of a data item for use by certain 015900* intrinsics. 016000* Tony Marston - 15/12/88 016100* 016200* 32) Added macro %CLOSEUSERMSG for the message catalog. 016300* Added macros %VTURNOFF and %VTURNON. 016400* Tony Marston - 28/02/89 016500* 016600* 33) Changed function key labels from text to numbers - the text 016700* will now be retrieved from the message catalog by UVPLUS. 016800* Tony Marston - 01/03/89 016900* 017000* 34) Added the %CLEARFKEYLABELS macro. 017100* Tony Marston - 02/03/89 017200* 017300* 35) Changed the %CKUNLOCK macro so that it will not fail if no 017400* lock currently exists. 017500* Tony Marston - 12/05/89 017600* 017700* 36) Changed %MSGFILEOPENW to check file number before opening. 017800* Changed %MSGFILECLOSE to check file number before closing, 017900* and to reset file number after closing. 018000* Added %MSGFILEDEFINE2 which does not have areas for the file 018100* name and number, enabling these to be appended to the 018200* USER-LINKAGE area. 018300* Tony Marston - 17/05/89 018400* 018500* 37) Added !1-RECORD-LIMIT to %MSGFILEDEFINE area, and changed 018600* %MSGFILECOUNTERS to retrieve the value. This will enable a 018700* full file to be detected before adding a record. 018800* Also changed the %MSGFILEERROR macro as the calls to FCHECK 018900* and FERRMSG are now in routine UERROR. 019000* Added macro %MPEFILEERROR (same as %MSGFILEERROR). 019100* Tony Marston - 01/06/89 019200* 019300* 38) Preparation for NATIVE MODE versions. 019400* %DEBUG macro is now conditional on compiler switch X1. 019500* Moved %WHO macro to INITCOMA copy library. 019600* Moved open of STDLIST & STDIN from INITCOMA to %BATCHINIT. 019700* Added %READUSERMSG macro (for message catalogs). 019800* Tony Marston - 18/09/89 019900* 020000****************************************************************** 020100* 39) AMENDED FOR NATIVE MODE USAGE, as follows:- 020200* Changed %OPENUSERMSG to call the CATOPEN intrinsic 020300* Changed %READUSERMSG to call the CATREAD intrinsic. 020400* Changed %CLOSEUSERMSG to call the CATCLOSE intrinsic. 020500* Changed %ULEFT, %URIGHT, %UCENTER, %UPSHIFT to use an 020600* intermediate output area called UTEXT-OUTPUT. 020700* Changed %SETABIT, %UNSETABIT, %TESTABIT to use an 020800* intermediate area called BIT-INPUT-WORD. 020900* Changed %VGETBUFFER, %VPUTBUFFER to use VIEW-X-DBUFLEN 021000* instead of VIEW-DBUFLEN. 021100* Tony Marston - 18/09/89 021200* 021300* 40) Added code to set MENU-ERROR-TYPE before calling UERROR. 021400* Tony Marston - 25/10/89 021500* 021600* 41) Amended %VOPENTERM to test that file is not already open. 021700* Tony Marston - 07/11/89 021800* 021900* 42) Amended %BATCHINIT to set BATCH-MODE to TRUE. 022000* Amended %TOJULIAN, %TOGREGORIAN, %UWEEK macros to include 022100* COMMON/USER-LINKAGE in parameter list. Removed %UDATEERR 022200* macro from %TOJULIAN macro to allow calling program to 022300* detect errors without an immediate abort. 022400* Amended %CONFIRMDATA macro to set VIEW-CONFIRM-KEY. 022500* Tony Marston - 24/11/89 022600* 022700* 43) Added areas WEEK1-CONTAINS and DAY1-OF-WEEK for UWEEK 022800* routine. DAYOFWEEK macro is redundant as this is done 022900* automatically by %TOJULIAN. 023000* Tony Marston - 01/12/89 023100* 023200* 44) Added macro %WEEKENDING to provide the week-ending date. 023300* Tony Marston - 05/12/89 023400* 023500* 45) Added macro %DOWNSHIFT. 023600* Tony Marston - 08/01/90 023700* 023800* 46) Added macros %USCREENOUT and %USCREENIN. 023900* Tony Marston - 16/01/90 024000* 024100* 47) Changed %COMMAND macro to call HPCICOMMAND. 024200* Tony Marston - 12/02/90 024300* 024400* 48) Removed error checking from %MSGFILECLOSE. 024500* Tony Marston - 13/02/90 024600* 024700* 49) Changed %DBMEMO to check for logging being turned on. 024800* Tony Marston - 14/02/90 024900* 025000* 50) Added the %USOUNDEX macro. 025100* Tony Marston - 21/02/90 025200* 025300* 51) Added macro %MSGFILEOPENW2 which will not abort if the 025400* call to FOPEN fails - this checking must be done separately 025500* within the user program. 025600* Tony Marston - 01/03/91 025700* 025800* 52) Changed the %DMY2YMD and %MDY2YMD macros to allow any 025900* delimiter, not just the "/". 026000* Tony Marston - 12/03/91 026100* 026200* 53) Added macros GETMENUTRAN/USER/PRINTER 026300* Tony Marston - 03/05/91 026400* 026500* 54) Amended %DBBEGIN/%DBEND macros to ignore the check for 026600* logging being turned on when compiled in development mode. 026700* Tony Marston - 08/08/91 026800* 026900* 55) Added macro %MPEFILESTATUS to decode FILE-STATUS when this 027000* is used with the COBOL "SELECT" clause. 027100* Tony Marston - 19/02/92 027200* 027300****************************************************************** 027400$PAGE 027500* 027600* Macros for call to COMMAND intrinsic and COMMANDERR 027700* 027800$COMMENT %COMMAND(commandname#). 027900$DEFINE %COMMAND = 028000 028100 STRING !1 028200 C-R DELIMITED BY SIZE INTO COMMAND-TEXT 028300 END-STRING 028400 CALL INTRINSIC "HPCICOMMAND" USING COMMAND-TEXT, 028500 CMND-ERROR, 028600 CMND-ERR-PARM, 028700 \2\# 028800* 028900$COMMENT %COMMANDERR(Para#). 029000$DEFINE %COMMANDERR = 029100 IF COMMAND-CIERR 029200 MOVE "!1" TO MENU-SECTION 029300 SET ERROR-TYPE-COMMAND TO TRUE 029400 CALL "UERROR" USING COMMON-LINKAGE, USER-LINKAGE 029500 END-IF# 029600* 029700****************************************************************** 029800* 029900* Macro for undefined program error 030000* 030100$COMMENT %SYSTEMERR(Para#). 030200* This macro requires the following: 030300* MOVE "message" TO VIEW-WINDOW 030400* MOVE errornumber TO MENU-SYSTEM-ERROR 030500$DEFINE %SYSTEMERR = 030600 MOVE "!1" TO MENU-SECTION 030700 SET ERROR-TYPE-SYSTEM TO TRUE 030800 CALL "UERROR" USING COMMON-LINKAGE, USER-LINKAGE# 030900* 031000****************************************************************** 031100$COMMENT %MPEFILEERROR(Para#,Filename#,Filenum#). 031200* Produce error report for a file accessed via the intrinsics 031300$DEFINE %MPEFILEERROR = 031400 MOVE "!1" TO MENU-SECTION 031500 MOVE !2 TO MPE-FILE-NAME 031600 MOVE !3 TO MPE-FILE-NUM 031700 SET ERROR-TYPE-FILE TO TRUE 031800 CALL "UERROR" USING COMMON-LINKAGE, USER-LINKAGE# 031900* 032000$COMMENT %MPEFILESTATUS(Para#,Filename#,Filestatus#). 032100* Produce error report for a file accessed via COBOL verbs 032200$DEFINE %MPEFILESTATUS = 032300 MOVE "!1" TO MENU-SECTION 032400 MOVE !2 TO MPE-FILE-NAME 032500 MOVE !3 TO MPE-FILE-STATUS 032600 SET ERROR-TYPE-FILE TO TRUE 032700 CALL "UERROR" USING COMMON-LINKAGE, USER-LINKAGE# 032800* 032900$PAGE 033000****************************************************************** 033100* Macro for generating a SOUNDEX key 033200****************************************************************** 033300$COMMENT %SOUNDEX(String#,Key#). 033400$DEFINE %SOUNDEX = 033500 MOVE !1 TO UTEXT-INPUT 033600 CALL "USOUNDEX" USING COMMON-LINKAGE 033700 !2# 033800* 033900$COMMENT %UPAUSE(Para#,Seconds#). 034000* 034100* Cause the program to pause for a number of seconds 034200* 034300$DEFINE %UPAUSE = 034400 MOVE "!1" TO MENU-SECTION 034500 MOVE !2 TO UPAUSE-SECONDS 034600 CALL "UPAUSE" USING UPAUSE-SECONDS, 034700 UPAUSE-STATUS 034800 IF UPAUSE-STATUS NOT = ZERO 034900 MOVE "Error found in UPAUSE routine" TO VIEW-WINDOW 035000 MOVE "UPAUSE" TO MENU-UTIL-ENTRY-POINT 035100 MOVE UPAUSE-STATUS TO MENU-SYSTEM-ERROR 035200 SET ERROR-TYPE-SYSTEM TO TRUE 035300 CALL "UERROR" USING COMMON-LINKAGE, USER-LINKAGE 035400 END-IF# 035500* 035600$COMMENT %TIMESTAMP(HHMMSS#,HH:MM:SS#) 035700* 035800* Convert a time from HHMMSS TO HH:MM:SS (display) 035900* 036000$DEFINE %TIMESTAMP = 036100 MOVE !1 TO DATE-TIME 036200 MOVE SPACES TO !2 036300 IF DATE-TIME NOT = ZERO 036400 STRING DT-3-4 ":" DT-5-6 ":" DT-7-8 036500 DELIMITED BY SIZE 036600 INTO !2 036700 END-STRING 036800 END-IF# 036900* 037000$PAGE 037100$COMMENT %PUTJCW(jcwname#,value#) 037200$DEFINE %PUTJCW = 037300 MOVE "!1" TO JCW-NAME 037400 MOVE !2 TO JCW-VALUE 037500 CALL INTRINSIC "PUTJCW" USING JCW-NAME, 037600 JCW-VALUE, 037700 JCW-STATUS# 037800* 037900$COMMENT %FINDJCW(jcwname#) 038000$DEFINE %FINDJCW = 038100 MOVE "!1" TO JCW-NAME 038200 MOVE ZERO TO JCW-VALUE 038300 CALL INTRINSIC "FINDJCW" USING JCW-NAME, 038400 JCW-VALUE, 038500 JCW-STATUS# 038600* 038700$COMMENT %BYTEADDRESS(Item#,Address#) 038800$DEFINE %BYTEADDRESS = 038900 CALL INTRINSIC ".LOC." USING @!1, 039000 GIVING !2# 039100* 039200$COMMENT %WORDADDRESS(Item#,Address#) 039300$DEFINE %WORDADDRESS = 039400 CALL INTRINSIC ".LOC." USING !1, 039500 GIVING !2# 039600* 039700$COMMENT %USCREENOUT(Para#) 039800* Transfer data to a temporary file (between START and FINISH) 039900* USCREEN-START/FINISH must both be PIC S9(9) COMP. 040000$DEFINE %USCREENOUT = 040100 MOVE "!1" TO MENU-SECTION 040200 CALL "USCREENOUT" USING COMMON-LINKAGE, 040300 USER-LINKAGE, 040400 USCREEN-START, 040500 USCREEN-FINISH# 040600* 040700$COMMENT %USCREENIN(Para#) 040800* Restore data from a temporary file (between START and FINISH) 040900* USCREEN-START/FINISH must both be PIC S9(9) COMP. 041000$DEFINE %USCREENIN = 041100 MOVE "!1" TO MENU-SECTION 041200 CALL "USCREENIN" USING COMMON-LINKAGE, 041300 USER-LINKAGE, 041400 USCREEN-START, 041500 USCREEN-FINISH# 041600* 041700$PAGE 041800****************************************************************** 041900* Macros for accessing the PROMEN database from a son process 042000****************************************************************** 042100* 042200$COMMENT %GETMENUTRAN(Para#,Tran-code#) 042300* Retrieve an entry from dataset M-TRAN 042400$DEFINE %GETMENUTRAN = 042500 MOVE !2 TO MC-TRAN-CODE 042600 CALL "GET-MENU-TRAN" USING COMMON-LINKAGE, 042700 USER-LINKAGE, 042800 M-TRAN-DATA# 042900* 043000$COMMENT %GETMENUUSER(Para#,User-id#) 043100* Retrieve an entry from dataset M-USER 043200$DEFINE %GETMENUUSER = 043300 MOVE !2 TO USER OF MD-USER 043400 CALL "GET-MENU-USER" USING COMMON-LINKAGE, 043500 USER-LINKAGE, 043600 M-USER-DATA# 043700* 043800$COMMENT %GETMENUPRINTER(Para#,Printer-id#) 043900* Retrieve an entry from dataset M-PRINTER 044000$DEFINE %GETMENUPRINTER = 044100 MOVE !2 TO ME-PRINTER-ID 044200 CALL "GET-MENU-PRINTER" USING COMMON-LINKAGE, 044300 USER-LINKAGE, 044400 M-PRINTER-DATA# 044500* 044600$PAGE 044700****************************************************************** 044800* Macros for date conversions 044900****************************************************************** 045000* 045100$COMMENT %DMY2YMD(Indate#,Outdate#). 045200* Change date from DD/MM/YY to YYYYMMDD 045300$DEFINE %DMY2YMD = 045400 IF !1 = SPACES 045500 MOVE ZERO TO !2 045600 ELSE 045700 MOVE !1(1:2) TO DT-7-8 045800 MOVE !1(4:2) TO DT-5-6 045900 MOVE !1(7:2) TO DT-3-4 046000 IF DT-3-4 > 50 046100 MOVE 19 TO DT-1-2 046200 ELSE 046300 MOVE 20 TO DT-1-2 046400 END-IF 046500 MOVE DATE-TIME TO !2 046600 END-IF# 046700* 046800$COMMENT %MDY2YMD(Indate#,Outdate#). 046900* Change date from MM/DD/YY to YYYYMMDD 047000$DEFINE %MDY2YMD = 047100 MOVE !1(1:2) TO DT-5-6 047200 MOVE !1(4:2) TO DT-7-8 047300 MOVE !1(7:2) TO DT-3-4 047400 IF DT-3-4 > 50 047500 MOVE 19 TO DT-1-2 047600 ELSE 047700 MOVE 20 TO DT-1-2 047800 END-IF 047900 MOVE DATE-TIME TO !2# 048000* 048100$COMMENT %YMD2DMY(Indate#,Outdate#). 048200* Changes date from YYYYMMDD to DD/MM/YY 048300$DEFINE %YMD2DMY = 048400 MOVE !1 TO DATE-TIME 048500 MOVE SPACES TO !2 048600 IF DATE-TIME NOT = ZERO 048700 STRING DT-7-8, "/", DT-5-6, "/", DT-3-4 048800 DELIMITED BY SIZE 048900 INTO !2 049000 END-STRING 049100 END-IF# 049200* 049300$COMMENT %YMD2DDMMMYY(Indate#,Outdate#). 049400* Changes date from YYYYMMDD to DDMMMYY (eg: 27JUN85) 049500$DEFINE %YMD2DDMMMYY = 049600 MOVE SPACES TO !2 049700 MOVE !1 TO DATE-TIME 049800 IF DATE-TIME NOT = ZERO 049900 MOVE MONTH-NAME(DT-5-6) TO NAME-OF-MONTH 050000 STRING DT-7-8 NAME-OF-MONTH DT-3-4 DELIMITED BY SIZE 050100 INTO !2 050200 END-STRING 050300 END-IF# 050400* 050500$PAGE 050600****************************************************************** 050700* Macros for GREGORIAN/JULIAN date conversion 050800****************************************************************** 050900* 051000$COMMENT %UDATEERR(Para#). 051100$DEFINE %UDATEERR = 051200 IF UDATE-STATUS NOT = ZERO 051300 MOVE "!1" TO MENU-SECTION 051400 MOVE UDATE-STATUS TO MENU-SYSTEM-ERROR 051500 MOVE "UDATE" TO MENU-UTIL-ENTRY-POINT 051600 SET ERROR-TYPE-SYSTEM TO TRUE 051700 CALL "UERROR" USING COMMON-LINKAGE, USER-LINKAGE 051800 END-IF# 051900* 052000$PREPROCESSOR DELIMITER=~ 052100* 052200$COMMENT %TOJULIAN(Para#,Date#). 052300* Convert date from YYYYMMDD to DDDDDDDDD 052400* Also puts value in UDATE-DAY-OF-WEEK 052500$DEFINE %TOJULIAN = 052600 MOVE !2 TO GREGORIAN-DATE 052700 CALL "TOJULIAN" USING COMMON-LINKAGE, USER-LINKAGE~ 052800* 052900$COMMENT %TOGREGORIAN(Para#,Days#). 053000* Convert date from DDDDDDDDD to YYYYMMDD 053100$DEFINE %TOGREGORIAN = 053200 MOVE !2 TO JULIAN-DAYS 053300 CALL "TOGREGORIAN" USING COMMON-LINKAGE, USER-LINKAGE 053400 %UDATEERR(!1#)~ 053500* 053600$COMMENT %DAYOFWEEK(Para#,Date#) 053700* Identifies the weekday (in UDATE-DAY-OF-WEEK) from a date 053800$DEFINE %DAYOFWEEK = 053900 %TOJULIAN(!1#,!2#) 054000 %UDATEERR(!1#)~ 054100* 054200$COMMENT %UWEEK(Para#,Date#,PIC S9(4) COMP#) 054300* Identifies the week number (YYWW) from a date 054400$DEFINE %UWEEK = 054500 MOVE !2 TO GREGORIAN-DATE 054600 CALL "UWEEK" USING COMMON-LINKAGE, USER-LINKAGE, 054700 !3 054800 %UDATEERR(!1#)~ 054900* 055000$COMMENT %WEEKENDING(Para#,Input Date#,Output Date#). 055100* Changes GREGORIAN-DATE to its equivalent week-ending date 055200$DEFINE %WEEKENDING = 055300 MOVE !2 TO GREGORIAN-DATE 055400 CALL "WEEKENDING" USING COMMON-LINKAGE, USER-LINKAGE 055500 %UDATEERR(!1#) 055600 MOVE GREGORIAN-DATE TO !3~ 055700* 055800$PREPROCESSOR DELIMITER=# 055900* 056000$PAGE 056100****************************************************************** 056200* Macros for converting numeric values on a VPLUS screen 056300****************************************************************** 056400* 056500$COMMENT %UNUMBER1(Input#,S9(4) COMP#). 056600* 056700* changes edited numeric to S9(4) COMP 056800* 056900$DEFINE %UNUMBER1 = 057000 MOVE !1 TO UNUMBER-INPUT 057100 CALL "UNUMBER1" USING UNUMBER-INPUT 057200 !2# 057300* 057400$COMMENT %UNUMBER2(Input#,S9(9) COMP#). 057500* 057600* changes edited numeric to S9(9) COMP 057700* 057800$DEFINE %UNUMBER2 = 057900 MOVE !1 TO UNUMBER-INPUT 058000 CALL "UNUMBER2" USING UNUMBER-INPUT 058100 !2# 058200* 058300$COMMENT %UNUMBER4(Input#,S9(18) COMP#). 058400* 058500* changes edited numeric to S9(18) COMP 058600* 058700$DEFINE %UNUMBER4 = 058800 MOVE !1 TO UNUMBER-INPUT 058900 CALL "UNUMBER4" USING UNUMBER-INPUT 059000 !2# 059100* 059200$COMMENT %UNUMBERP8(Input#,S9(7) COMP-3#). 059300* 059400* changes edited numeric to S9(7) COMP-3 059500* 059600$DEFINE %UNUMBERP8 = 059700 MOVE !1 TO UNUMBER-INPUT 059800 CALL "UNUMBERP8" USING UNUMBER-INPUT 059900 !2# 060000* 060100$COMMENT %UNUMBERP12(Input#,S9(11) COMP-3#). 060200* 060300* changes edited numeric to S9(11) COMP-3 060400* 060500$DEFINE %UNUMBERP12 = 060600 MOVE !1 TO UNUMBER-INPUT 060700 CALL "UNUMBERP12" USING UNUMBER-INPUT 060800 !2# 060900* 061000$PAGE 061100****************************************************************** 061200* Macros for converting numeric values from non-VPLUS sources. 061300* These use routine BNUMBER - the batch version of UNUMBER 061400****************************************************************** 061500* 061600$COMMENT %BNUMBER1(Input#,S9(4) COMP#,Decimals#) 061700$DEFINE %BNUMBER1 = 061800 MOVE !1 TO UNUMBER-INPUT 061900 MOVE 0!3 TO UNUMBER-DECIMALS 062000 CALL "BNUMBER1" USING UNUMBER-INPUT 062100 !2 062200 UNUMBER-DECIMALS 062300 UNUMBER-STATUS# 062400* 062500$COMMENT %BNUMBER2(Input#,S9(9) COMP#,Decimals#) 062600$DEFINE %BNUMBER2 = 062700 MOVE !1 TO UNUMBER-INPUT 062800 MOVE 0!3 TO UNUMBER-DECIMALS 062900 CALL "BNUMBER2" USING UNUMBER-INPUT 063000 !2 063100 UNUMBER-DECIMALS 063200 UNUMBER-STATUS# 063300* 063400$COMMENT %BNUMBER3(Input#,S9(11) COMP-3#,Decimals#) 063500$DEFINE %BNUMBER3 = 063600 MOVE !1 TO UNUMBER-INPUT 063700 MOVE 0!3 TO UNUMBER-DECIMALS 063800 CALL "BNUMBER3" USING UNUMBER-INPUT 063900 !2 064000 UNUMBER-DECIMALS 064100 UNUMBER-STATUS# 064200* 064300$COMMENT %BNUMBER4(Input#,S9(18) COMP#,Decimals#) 064400$DEFINE %BNUMBER4 = 064500 MOVE !1 TO UNUMBER-INPUT 064600 MOVE 0!3 TO UNUMBER-DECIMALS 064700 CALL "BNUMBER4" USING UNUMBER-INPUT 064800 !2 064900 UNUMBER-DECIMALS 065000 UNUMBER-STATUS# 065100* 065200$PAGE 065300****************************************************************** 065400* Macros for manipulating strings of text 065500****************************************************************** 065600* 065700$COMMENT %UCENTER(Length#,Output-area#) 065800* Center contents of UTEXT-INPUT in output-area 065900* This macro requires the following:- 066000* MOVE input TO UTEXT-INPUT 066100$DEFINE %UCENTER = 066200 MOVE !1 TO UTEXT-LENGTH 066300 CALL "UCENTER" USING UTEXT-INPUT, 066400 UTEXT-OUTPUT, 066500 UTEXT-LENGTH 066600 MOVE UTEXT-OUTPUT TO !2# 066700* 066800$COMMENT %ULEFT(Length#,Output-area#) 066900* Left-justify contents of UTEXT-INPUT into output-area 067000* This macro requires the following:- 067100* MOVE input TO UTEXT-INPUT 067200$DEFINE %ULEFT = 067300 MOVE !1 TO UTEXT-LENGTH 067400 CALL "ULEFT" USING UTEXT-INPUT, 067500 UTEXT-OUTPUT, 067600 UTEXT-LENGTH 067700 MOVE UTEXT-OUTPUT TO !2# 067800* 067900$COMMENT %URIGHT(Length#,Output-area#) 068000* Right-justify contents of UTEXT-INPUT into output-area 068100* This macro requires the following:- 068200* MOVE input TO UTEXT-INPUT 068300$DEFINE %URIGHT = 068400 MOVE !1 TO UTEXT-LENGTH 068500 CALL "URIGHT" USING UTEXT-INPUT, 068600 UTEXT-OUTPUT, 068700 UTEXT-LENGTH 068800 MOVE UTEXT-OUTPUT TO !2# 068900* 069000$COMMENT %UPSHIFT(Length#,Output-area#) 069100* Upshift contents of UTEXT-INPUT into output-area 069200* This macro requires the following:- 069300* MOVE input TO UTEXT-INPUT 069400$DEFINE %UPSHIFT = 069500 MOVE !1 TO UTEXT-LENGTH 069600 CALL "UPSHIFT" USING UTEXT-INPUT, 069700 UTEXT-OUTPUT, 069800 UTEXT-LENGTH 069900 MOVE UTEXT-OUTPUT TO !2(1:UTEXT-LENGTH)# 070000* 070100$COMMENT %DOWNSHIFT(Length#,Output-area#) 070200* Downshift contents of UTEXT-INPUT into output-area 070300* This macro requires the following:- 070400* MOVE input TO UTEXT-INPUT 070500$DEFINE %DOWNSHIFT = 070600 MOVE !1 TO UTEXT-LENGTH 070700 CALL "DOWNSHIFT" USING UTEXT-INPUT, 070800 UTEXT-OUTPUT, 070900 UTEXT-LENGTH 071000 MOVE UTEXT-OUTPUT TO !2(1:UTEXT-LENGTH)# 071100* 071200$PAGE 071300****************************************************************** 071400* Macros for manipulating individual bits 071500****************************************************************** 071600* 071700$COMMENT %SETABIT(Target-word#,Bit-number#) 071800* 071900* Sets bit in 072000* 072100$DEFINE %SETABIT = 072200 MOVE !1 TO BIT-INPUT-WORD 072300 MOVE !2 TO BIT-NUMBER 072400 CALL "SETABIT" USING BIT-INPUT-WORD, 072500 BIT-NUMBER, 072600 BIT-RESULT 072700 MOVE BIT-INPUT-WORD TO !1# 072800* 072900$COMMENT %UNSETABIT(Target-word#,Bit-number#) 073000* 073100* Unsets bit in 073200* 073300$DEFINE %UNSETABIT = 073400 MOVE !1 TO BIT-INPUT-WORD 073500 MOVE !2 TO BIT-NUMBER 073600 CALL "UNSETABIT" USING BIT-INPUT-WORD, 073700 BIT-NUMBER, 073800 BIT-RESULT 073900 MOVE BIT-INPUT-WORD TO !1# 074000* 074100$COMMENT %TESTABIT(Target-word#,Bit-number#) 074200* 074300* Examines bit in , result in BIT-RESULT 074400* 074500$DEFINE %TESTABIT = 074600 MOVE !1 TO BIT-INPUT-WORD 074700 MOVE !2 TO BIT-NUMBER 074800 CALL "TESTABIT" USING BIT-INPUT-WORD, 074900 BIT-NUMBER, 075000 BIT-RESULT# 075100* 075200$PAGE 075300****************************************************************** 075400* Macros for calls to KSAM procedures 075500* 075600* KSAM file definitions. 075700* The file must have the following definitions: 075800* filename-FILETABLE 075900* filename-RECORD 076000* filename-RECSIZE 076100****************************************************************** 076200 076300$PREPROCESSOR DELIMITER=~ 076400* 076500$COMMENT %KSAMERR(Para#,File#). 076600* KSAM error handler 076700$DEFINE %KSAMERR = 076800 MOVE "!1" TO MENU-SECTION 076900 MOVE !2-FILETABLE TO KSAM-FILETABLE 077000 MOVE !2-RECSIZE TO KSAM-RECSIZE 077100 SET ERROR-TYPE-KSAM TO TRUE 077200 CALL "UERROR" USING COMMON-LINKAGE, USER-LINKAGE~ 077300* 077400$COMMENT %CKSTART(Para#,file#,relop#,key#,keyloc#,keylen#). 077500* Position record pointer in preperation for a 077600* sequential read ( like a dbfind ) 077700* On return check for KSAM-NO-RECORD 077800$DEFINE %CKSTART = 077900 MOVE KSAM-RELOP-!3 TO KSAM-RELOP 078000 MOVE !4 TO KSAM-KEY 078100 MOVE !5 TO KSAM-KEYLOC 078200 MOVE !6 TO KSAM-KEYLEN 078300 CALL "CKSTART" USING !2-FILETABLE 078400 KSAM-STATUS 078500 KSAM-RELOP 078600 KSAM-KEY 078700 KSAM-KEYLOC 078800 KSAM-KEYLEN 078900 IF NOT (KSAM-OK OR KSAM-NO-RECORD) 079000 %KSAMERR(!1#,!2#) 079100 END-IF~ 079200* 079300$COMMENT %CKREAD(Para#,file#). 079400* Sequential read. 079500* On return check for KSAM-END-OF-FILE 079600$DEFINE %CKREAD = 079700 CALL "CKREAD" USING !2-FILETABLE 079800 KSAM-STATUS 079900 !2-RECORD 080000 !2-RECSIZE 080100 IF NOT (KSAM-OK OR KSAM-END-OF-FILE) 080200 %KSAMERR(!1#,!2#) 080300 END-IF~ 080400* 080500$COMMENT %CKLOCK(Para#,file#). 080600* Lock the ksam file 080700$DEFINE %CKLOCK = 080800 CALL "CKLOCK" USING !2-FILETABLE 080900 KSAM-STATUS 081000 KSAM-LOCK 081100 IF KSAM-OK OR KSAM-LOCK-FAILURE 081200 MOVE !2-FILETABLE TO KSAM-FILETABLE 081300 IF KSAM-LOCK-FAILURE 081400 MOVE "010095" TO VIEW-WINDOW 081500 ADD 1 TO VIEW-NUMERRS 081600 END-IF 081700 ELSE 081800 %KSAMERR(!1#,!2#) 081900 END-IF~ 082000* 082100$COMMENT %CKDELETE(Para#,file#). 082200* Delete a previously read record 082300* The file must have been locked prior to the read 082400$DEFINE %CKDELETE = 082500 CALL "CKDELETE" USING !2-FILETABLE 082600 KSAM-STATUS 082700 IF NOT KSAM-OK 082800 %KSAMERR(!1#,!2#) 082900 END-IF~ 083000* 083100$COMMENT %CKUNLOCK(Para#,File#). 083200* Unlock a ksam file 083300$DEFINE %CKUNLOCK = 083400 CALL "CKUNLOCK" USING !2-FILETABLE 083500 KSAM-STATUS 083600 IF NOT (KSAM-OK OR KSAM-NO-PREVIOUS-LOCK) 083700 %KSAMERR(!1#,!2#) 083800 END-IF~ 083900* 084000$COMMENT %CKREADBYKEY(Para#,file#,key#,keyloc#,keylen#). 084100* Read a record by the key 084200* On return check for KSAM-NO-RECORD 084300$DEFINE %CKREADBYKEY = 084400 MOVE !3 TO KSAM-KEY 084500 MOVE !4 TO KSAM-KEYLOC 084600 MOVE !5 TO KSAM-KEYLEN 084700 CALL "CKREADBYKEY" USING !2-FILETABLE 084800 KSAM-STATUS 084900 !2-RECORD 085000 KSAM-KEY 085100 KSAM-KEYLOC 085200 !2-RECSIZE 085300 IF NOT (KSAM-OK OR KSAM-NO-RECORD) 085400 %KSAMERR(!1#,!2#) 085500 END-IF~ 085600* 085700$COMMENT %CKREWRITE(Para#,File#). 085800* Rewrite a record 085900$DEFINE %CKREWRITE = 086000 CALL "CKREWRITE" USING !2-FILETABLE 086100 KSAM-STATUS 086200 !2-RECORD 086300 !2-RECSIZE 086400 IF NOT KSAM-OK 086500 %KSAMERR(!1#,!2#) 086600 END-IF~ 086700* 086800$COMMENT %CKWRITE(Para#,File#). 086900* Write a ksam record 087000$DEFINE %CKWRITE = 087100 CALL "CKWRITE" USING !2-FILETABLE 087200 KSAM-STATUS 087300 !2-RECORD 087400 !2-RECSIZE 087500 IF NOT KSAM-OK 087600 %KSAMERR(!1#,!2#) 087700 END-IF~ 087800* 087900$COMMENT %CKOPEN(Para#,File#). 088000$DEFINE %CKOPEN = 088100 IF !2-FILE-CLOSED 088200 CALL "CKOPEN" USING !2-FILETABLE 088300 KSAM-STATUS 088400 IF NOT KSAM-OK 088500 %KSAMERR(!1#,!2#) 088600 END-IF 088700 MOVE "Y" TO !2-FILE-FLAG 088800* Establish the record size * 088900 CALL INTRINSIC "FFILEINFO" USING !2-FILENUMBER 089000 \4\ 089100 !2-RECSIZE 089200 IF !2-RECSIZE < 0 089300 MULTIPLY -1 BY !2-RECSIZE 089400 ELSE 089500 MULTIPLY 2 BY !2-RECSIZE 089600 END-IF 089700 END-IF~ 089800* 089900$COMMENT %CKOPENSHR(Para#,File#). 090000$DEFINE %CKOPENSHR = 090100 IF !2-FILE-CLOSED 090200 CALL "CKOPENSHR" USING !2-FILETABLE 090300 KSAM-STATUS 090400 IF NOT KSAM-OK 090500 %KSAMERR(!1#,!2#) 090600 END-IF 090700 MOVE "Y" TO !2-FILE-FLAG 090800* Establish the record size * 090900 CALL INTRINSIC "FFILEINFO" USING !2-FILENUMBER 091000 \4\ 091100 !2-RECSIZE 091200 IF !2-RECSIZE < 0 091300 MULTIPLY -1 BY !2-RECSIZE 091400 ELSE 091500 MULTIPLY 2 BY !2-RECSIZE 091600 END-IF 091700 END-IF~ 091800* 091900$COMMENT %CKCLOSE(Para#,File#). 092000$DEFINE %CKCLOSE = 092100 IF !2-FILE-OPEN 092200 CALL "CKUNLOCK" USING !2-FILETABLE 092300 KSAM-STATUS 092400 CALL "CKCLOSE" USING !2-FILETABLE 092500 KSAM-STATUS 092600 MOVE "N" TO !2-FILE-FLAG 092700 END-IF~ 092800* 092900$PREPROCESSOR DELIMITER=# 093000* 093100$PAGE 093200****************************************************************** 093300* VPLUS macro definitions 093400****************************************************************** 093500* 093600$COMMENT %VPLUSERR(Para#). 093700* VPLUS error handler 093800$DEFINE %VPLUSERR = 093900 IF VPLUS-ERROR 094000 MOVE "!1" TO MENU-SECTION 094100 SET ERROR-TYPE-VPLUS TO TRUE 094200 CALL "UERROR" USING COMMON-LINKAGE, USER-LINKAGE 094300 END-IF# 094400* 094500$PREPROCESSOR DELIMITER=~ 094600* 094700$COMMENT %VAUTOREAD(Para#) 094800* Simulate pressing of the ENTER key 094900$DEFINE %VAUTOREAD = 095000 %SETABIT(VIEW-OPTIONS#,14#) 095100 CALL "VREADFIELDS" USING VIEW-COMAREA 095200 %UNSETABIT(VIEW-OPTIONS#,14#) 095300 %VPLUSERR(!1#)~ 095400* 095500$COMMENT %VGETBUFFER(Para#,Buffername#). 095600* Move VPLUS data buffer into program's working storage 095700$DEFINE %VGETBUFFER = 095800 MOVE VIEW-DBUFLEN TO VIEW-X-DBUFLEN 095900 CALL "VGETBUFFER" USING VIEW-COMAREA 096000 !2 096100 VIEW-X-DBUFLEN 096200 %VPLUSERR(!1#)~ 096300* 096400$COMMENT %VPUTBUFFER(Para#,Buffername#). 096500* Move program's data buffer to the VPLUS screen buffer 096600$DEFINE %VPUTBUFFER = 096700 IF NO-VEDIT-ERRORS 096800 MOVE VIEW-DBUFLEN TO VIEW-X-DBUFLEN 096900 CALL "VPUTBUFFER" USING VIEW-COMAREA 097000 !2 097100 VIEW-X-DBUFLEN 097200 %VPLUSERR(!1#) 097300 END-IF~ 097400* 097500$COMMENT %VSETKEYLABELS(Para#) 097600* Load key labels into VPLUS area 097700$DEFINE %VSETKEYLABELS = 097800 CALL "VSETKEYLABELS" USING VIEW-COMAREA 097900 VIEW-FORM-OR-GLOBAL 098000 VIEW-NUMBER-OF-LABELS 098100 VIEW-LABELS 098200 %VPLUSERR(!1#)~ 098300* 098400$COMMENT %VCLOSETERM(Para#). 098500$DEFINE %VCLOSETERM = 098600 IF VIEW-TERMFILE-OPEN 098700 MOVE ZERO TO VIEW-STATUS 098800 CALL "VCLOSETERM" USING VIEW-COMAREA 098900 %VPLUSERR(!1#) 099000 MOVE "N" TO VIEW-TERMFILE-FLAG 099100 END-IF~ 099200* 099300$COMMENT %VOPENTERM(Para#). 099400$DEFINE %VOPENTERM = 099500 IF NOT VIEW-TERMFILE-OPEN 099600 CALL "VOPENTERM" USING VIEW-COMAREA 099700 VIEW-TERMFILE 099800 %VPLUSERR(!1#) 099900 MOVE "Y" TO VIEW-TERMFILE-FLAG 100000 END-IF~ 100100* 100200$COMMENT %VTURNOFF(Para#) 100300* Turn block-mode off 100400$DEFINE %VTURNOFF = 100500 CALL "VTURNOFF" USING VIEW-COMAREA 100600 %VPLUSERR(!1#) 100700 MOVE "N" TO VIEW-TERMFILE-FLAG~ 100800* 100900$COMMENT %VTURNON(Para#) 101000* Turn block-mode on 101100$DEFINE %VTURNON = 101200 CALL "VTURNON" USING VIEW-COMAREA 101300 VIEW-TERMFILE 101400 %VPLUSERR(!1#) 101500 MOVE "Y" TO VIEW-TERMFILE-FLAG~ 101600* 101700$COMMENT %OPENUSERFORM(Para#,Name#) 101800$DEFINE %OPENUSERFORM = 101900 IF NOT VIEW-FORMFILE-OPEN 102000 MOVE !2-FORMFILE-NAME TO VIEW-FORMFILE 102100 %VPLUSOPEN(!1#) 102200 END-IF~ 102300* 102400$COMMENT %VCLOSEFORM(Para#) 102500$DEFINE %VCLOSEFORM = 102600 IF VIEW-FORMFILE-OPEN 102700 MOVE ZERO TO VIEW-STATUS 102800 CALL "VCLOSEFORMF" USING VIEW-COMAREA 102900 MOVE "N" TO VIEW-FORMFILE-FLAG 103000 END-IF~ 103100* 103200****************************************************************** 103300* The following macros call various VPLUS intrinsics in 103400* standardised combinations. Please refer to the utility 103500* subprogram UVPLUS for more detailed documentation. 103600****************************************************************** 103700* 103800$COMMENT %BLINKMSG(Para#). 103900* This macro requires the following: 104000* MOVE "message" TO VIEW-WINDOW 104100$DEFINE %BLINKMSG = 104200 MOVE "!1" TO MENU-SECTION 104300 CALL "SE-BLINK-MESSAGE" USING COMMON-LINKAGE, USER-LINKAGE~ 104400* 104500$COMMENT %SAVINITFORM(Para#,Formname#). 104600* Load and initialise a new form 104700$DEFINE %SAVINITFORM = 104800 MOVE "!1" TO MENU-SECTION 104900 MOVE "!2" TO VIEW-NFNAME 105000 CALL "SA-VINITFORM" USING COMMON-LINKAGE, USER-LINKAGE~ 105100* 105200$COMMENT %ACCEPTENTER(Para#). 105300* Show current form and accept any key, perform editing if 105400* the ENTER key is pressed. 105500* This routine will reposition the cursor if a field name is 105600* put into VIEW-FIELD-NAME. 105700$DEFINE %ACCEPTENTER = 105800 MOVE "!1" TO MENU-SECTION 105900 CALL "SB1-ACCEPT-ENTER-KEY" USING COMMON-LINKAGE 106000 USER-LINKAGE~ 106100* 106200$COMMENT %ACCEPTFUNCTION(Para#). 106300* Show current form and accept any key except the ENTER key 106400$DEFINE %ACCEPTFUNCTION = 106500 MOVE "!1" TO MENU-SECTION 106600 CALL "SB2-ACCEPT-FUNCTION-KEY" USING COMMON-LINKAGE 106700 USER-LINKAGE~ 106800* 106900$COMMENT %SCVSETERROR(Para#). 107000* This macro requires the following: 107100* MOVE "fieldname" TO VIEW-FIELD-NAME 107200* MOVE "message" TO VIEW-WINDOW 107300$DEFINE %SCVSETERROR = 107400 MOVE "!1" TO MENU-SECTION 107500 CALL "SC-VSETERROR" USING COMMON-LINKAGE, USER-LINKAGE~ 107600* 107700$COMMENT %CONFIRMDATA(Para#,Fkey#,Revalidate#) 107800* If VIEW-WINDOW is left blank a default message will be used 107900* If the ENTER key is pressed the screen must be revalidated 108000$DEFINE %CONFIRMDATA = 108100 IF VEDIT-ERRORS 108200 MOVE SPACES TO VIEW-LABEL(!2) 108300 GO TO !3 108400 END-IF 108500 IF VIEW-WINDOW = SPACES 108600******** "Is this data correct? Press f!2 to confirm" 108700 MOVE "010070;!2" TO VIEW-WINDOW 108800 END-IF 108900**** MOVE " CONFIRM" TO VIEW-LABEL(!2) 109000 MOVE "015140" TO VIEW-LABEL(!2) 109100 MOVE !2 TO VIEW-CONFIRM-KEY 109200 %ACCEPTENTER(!1#) 109300 IF ENTER-KEY OR VEDIT-ERRORS 109400 MOVE SPACES TO VIEW-LABEL(!2) 109500 GO TO !3 109600 END-IF~ 109700* 109800$COMMENT %CONFIRMDELETE(Para#,Fkey#) 109900* If VIEW-WINDOW is left blank a default message will be used. 110000$DEFINE %CONFIRMDELETE = 110100 IF VIEW-WINDOW = SPACES 110200******** "Press f!2 to confirm deletion" 110300 MOVE "010075;!2" TO VIEW-WINDOW 110400 END-IF 110500**** MOVE " DELETE " TO VIEW-LABEL(!2) 110600 MOVE "015160" TO VIEW-LABEL(!2) 110700 %ACCEPTFUNCTION(!1#)~ 110800* 110900$COMMENT %SDVPUTFIELD(Para#). 111000* This macro requires the following: 111100* MOVE "fieldname" TO VIEW-FIELD-NAME 111200* MOVE "data" TO VIEW-FIELD-DATA 111300$DEFINE %SDVPUTFIELD = 111400 MOVE "!1" TO MENU-SECTION 111500 CALL "SD-VPUTFIELD" USING COMMON-LINKAGE, USER-LINKAGE~ 111600* 111700$COMMENT %SFAUTOREAD(Para#) 111800* Process the form as if the ENTER key had been pressed. 111900* Also calls VFIELDEDITS and VFINISHFORM. 112000$DEFINE %SFAUTOREAD = 112100 MOVE "!1" TO MENU-SECTION 112200 CALL "SF-VAUTOREAD" USING COMMON-LINKAGE, USER-LINKAGE~ 112300* 112400$COMMENT %SGVCHANGEFIELD(Para#) 112500* This macro requires the following: 112600* MOVE "xxx" TO VIEW-FIELD-NAME 112700* MOVE 1/2/3 TO VIEW-CHANGEFIELD-ENTRIES 112800* MOVE n TO VIEW-CHNGFLD-TYPE(n) 112900* MOVE "xxx" TO VIEW-CHNGFLD-SPEC(n) 113000$DEFINE %SGVCHANGEFIELD = 113100 MOVE "!1" TO MENU-SECTION 113200 CALL "SG-VCHANGEFIELD" USING COMMON-LINKAGE, USER-LINKAGE~ 113300* 113400$COMMENT %VPLUSOPEN(Para#). 113500* opens the terminal and formfile 113600$DEFINE %VPLUSOPEN = 113700 MOVE "!1" TO MENU-SECTION 113800 CALL "SY-VPLUS-OPEN" USING COMMON-LINKAGE, USER-LINKAGE~ 113900* 114000$COMMENT %VPLUSCLOSE(Para#) 114100* closes the terminal and formfile 114200$DEFINE %VPLUSCLOSE = 114300 MOVE "!1" TO MENU-SECTION 114400 CALL "SZ-VPLUS-CLOSE" USING COMMON-LINKAGE, USER-LINKAGE~ 114500* 114600$COMMENT %USELECT(Reprompt#,Exit#) 114700* Call USELECT to process D-OTHER-OPTIONS dataset 114800$DEFINE %USELECT = 114900 CALL "USELECT" USING COMMON-LINKAGE, USER-LINKAGE 115000 IF MENU-AUTO-SELECT = SPACES 115100 GO TO !1 115200 ELSE 115300 GO TO !2 115400 END-IF~ 115500* 115600$PREPROCESSOR DELIMITER=# 115700 115800$PAGE 115900****************************************************************** 116000* Macro definitions for calls to IMAGE procedures 116100****************************************************************** 116200* 116300$COMMENT %IMAGEERR(Para#,Base#,Call#). 116400* IMAGE error handler 116500$DEFINE %IMAGEERR = 116600 MOVE "!1" TO MENU-SECTION 116700 MOVE !2-BASE-NAME TO IMAGE-BASE-NAME 116800 MOVE "!3 " TO IMAGE-CALL 116900 SET ERROR-TYPE-IMAGE TO TRUE 117000 CALL "UERROR" USING COMMON-LINKAGE, USER-LINKAGE# 117100* 117200$PREPROCESSOR DELIMITER=~ 117300* 117400$COMMENT %DBBEGIN(Para#,Base#). 117500$DEFINE %DBBEGIN = 117600$IF X1=ON 117700 SET !2-BASE-LOGGING-ON TO TRUE 117800$IF 117900 IF !2-BASE-LOGGING-ON 118000 MOVE MENU-OPERATOR TO IMAGE-TEXT-OPERATOR 118100 MOVE MENU-COMPANY TO IMAGE-TEXT-COMPANY 118200 MOVE MENU-SELECTION TO IMAGE-TEXT-ENTRY-POINT 118300 MOVE 13 TO IMAGE-TEXTLEN 118400 CALL "DBBEGIN" USING !2-BASE-NAME 118500 IMAGE-TEXT 118600 IMAGE-MODE-1 118700 IMAGE-STATUS 118800 IMAGE-TEXTLEN 118900 IF IMAGE-ERROR 119000 %IMAGEERR(!1#,!2#,DBBEGIN1#) 119100 END-IF 119200 END-IF~ 119300* 119400$COMMENT %DBCLOSE(Base#). 119500$DEFINE %DBCLOSE = 119600 IF !1-BASE-OPEN 119700 CALL "DBUNLOCK" USING !1-BASE-NAME 119800 IMAGE-DUMMY-FIELD 119900 IMAGE-MODE-1 120000 IMAGE-STATUS 120100 CALL "DBCLOSE" USING !1-BASE-NAME 120200 IMAGE-DUMMY-FIELD 120300 IMAGE-MODE-1 120400 IMAGE-STATUS 120500 MOVE "N" TO !1-BASE-FLAG 120600 END-IF~ 120700* 120800$COMMENT %DBCLOSE3(Para#,Base#,Dset#). 120900* 121000* DBCLOSE3 = rewind dataset prior to serial read 121100* 121200$DEFINE %DBCLOSE3 = 121300 CALL "DBCLOSE" USING !2-BASE-NAME 121400 !3-DSET 121500 IMAGE-MODE-3 121600 IMAGE-STATUS 121700 IF IMAGE-ERROR 121800 MOVE !3-DSET TO IMAGE-DSET 121900 %IMAGEERR(!1#,!2#,DBCLOSE3#) 122000 END-IF~ 122100* 122200$COMMENT %DBDELETE(Para#,Base#,Dset#) 122300$DEFINE %DBDELETE = 122400 CALL "DBDELETE" USING !2-BASE-NAME 122500 !3-DSET 122600 IMAGE-MODE-1 122700 IMAGE-STATUS 122800 IF IMAGE-ERROR 122900 MOVE !3-DSET TO IMAGE-DSET 123000 %IMAGEERR(!1#,!2#,DBDELETE1#) 123100 END-IF~ 123200* 123300$COMMENT %DBEND(Para#,Base#). 123400$DEFINE %DBEND = 123500$IF X1=ON 123600 SET !2-BASE-LOGGING-ON TO TRUE 123700$IF 123800 IF !2-BASE-LOGGING-ON 123900 MOVE ZERO TO IMAGE-TEXTLEN 124000 CALL "DBEND" USING !2-BASE-NAME 124100 IMAGE-DUMMY-FIELD 124200 IMAGE-MODE-2 124300 IMAGE-STATUS 124400 IMAGE-TEXTLEN 124500 IF IMAGE-ERROR 124600 %IMAGEERR(!1#,!2#,DBEND2#) 124700 END-IF 124800 END-IF~ 124900* 125000$COMMENT %DBFIND(Para#,Base#,Dset#,Item#,Arg#) 125100$DEFINE %DBFIND = 125200 MOVE "!4" TO IMAGE-ITEM 125300 MOVE !5 TO IMAGE-ARGUMENT 125400 CALL "DBFIND" USING !2-BASE-NAME 125500 !3-DSET 125600 IMAGE-MODE-1 125700 IMAGE-STATUS 125800 IMAGE-ITEM 125900 IMAGE-ARGUMENT 126000 IF NOT (IMAGE-OK OR IMAGE-NO-ENTRY) 126100 MOVE !3-DSET TO IMAGE-DSET 126200 %IMAGEERR(!1#,!2#,DBFIND1#) 126300 END-IF~ 126400* 126500$COMMENT %DBFETCH(Para#,Base#,Dset#,Item#,Arg#). 126600* 126700* DBFETCH = DBFIND with DBGET5 (first entry in chain) 126800* 126900$DEFINE %DBFETCH = 127000 %DBFIND(!1#,!2#,!3#,!4#,!5#) 127100 IF IMAGE-OK 127200 %DBGET5(!1#,!2#,!3#) 127300 END-IF~ 127400* 127500$COMMENT %DBFETCHLAST(Para#,Base#,Dset#,Item#,Arg#). 127600* 127700* DBFETCH = DBFIND with DBGET6 (last entry in chain) 127800* 127900$DEFINE %DBFETCHLAST = 128000 %DBFIND(!1#,!2#,!3#,!4#,!5#) 128100 IF IMAGE-OK 128200 %DBGET6(!1#,!2#,!3#) 128300 END-IF~ 128400* 128500$COMMENT %DBGET1(Para#,Base#,Dset#) 128600* 128700* DBGET1 = re-read current record 128800* 128900$DEFINE %DBGET1 = 129000 CALL "DBGET" USING !2-BASE-NAME 129100 !3-DSET 129200 IMAGE-MODE-1 129300 IMAGE-STATUS 129400 !3-LIST 129500 !3-DATA 129600 IMAGE-DUMMY-FIELD 129700 IF NOT (IMAGE-OK OR IMAGE-NO-ENTRY) 129800 MOVE !3-DSET TO IMAGE-DSET 129900 %IMAGEERR(!1#,!2#,DBGET1#) 130000 END-IF 130100 MOVE IMAGE-SAME-LIST TO !3-LIST~ 130200* 130300$COMMENT %DBGET2(Para#,Base#,Dset#) 130400* 130500* DBGET2 = serial read 130600* 130700$DEFINE %DBGET2 = 130800 CALL "DBGET" USING !2-BASE-NAME 130900 !3-DSET 131000 IMAGE-MODE-2 131100 IMAGE-STATUS 131200 !3-LIST 131300 !3-DATA 131400 IMAGE-DUMMY-FIELD 131500 IF NOT (IMAGE-OK OR IMAGE-END-OF-FILE) 131600 MOVE !3-DSET TO IMAGE-DSET 131700 %IMAGEERR(!1#,!2#,DBGET2#) 131800 END-IF 131900 MOVE IMAGE-SAME-LIST TO !3-LIST~ 132000* 132100$COMMENT %DBGET3(Para#,Base#,Dset#). 132200* 132300* DBGET3 = backward serial read 132400* 132500$DEFINE %DBGET3 = 132600 CALL "DBGET" USING !2-BASE-NAME 132700 !3-DSET 132800 IMAGE-MODE-3 132900 IMAGE-STATUS 133000 !3-LIST 133100 !3-DATA 133200 IMAGE-DUMMY-FIELD 133300 IF NOT (IMAGE-OK OR IMAGE-BEG-OF-FILE) 133400 MOVE !3-DSET TO IMAGE-DSET 133500 %IMAGEERR(!1#,!2#,DBGET3#) 133600 END-IF 133700 MOVE IMAGE-SAME-LIST TO !3-LIST~ 133800* 133900$COMMENT %DBGET4(Para#,Base#,Dset#,Arg#). 134000* 134100* DBGET4 = directed read 134200* 134300$DEFINE %DBGET4 = 134400 CALL "DBGET" USING !2-BASE-NAME 134500 !3-DSET 134600 IMAGE-MODE-4 134700 IMAGE-STATUS 134800 !3-LIST 134900 !3-DATA 135000 !4 135100 IF NOT (IMAGE-OK OR IMAGE-NO-ENTRY) 135200 MOVE !3-DSET TO IMAGE-DSET 135300 MOVE !4 TO IMAGE-RECNO OF IMAGE-ARGUMENT 135400 %IMAGEERR(!1#,!2#,DBGET4#) 135500 END-IF 135600 MOVE IMAGE-SAME-LIST TO !3-LIST~ 135700* 135800$COMMENT %DBGET5(Para#,Base#,Dset#). 135900* 136000* DBGET5 = chained read 136100* 136200$DEFINE %DBGET5 = 136300 CALL "DBGET" USING !2-BASE-NAME 136400 !3-DSET 136500 IMAGE-MODE-5 136600 IMAGE-STATUS 136700 !3-LIST 136800 !3-DATA 136900 IMAGE-DUMMY-FIELD 137000 IF NOT (IMAGE-OK OR IMAGE-END-OF-CHAIN) 137100 MOVE !3-DSET TO IMAGE-DSET 137200 %IMAGEERR(!1#,!2#,DBGET5#) 137300 END-IF 137400 MOVE IMAGE-SAME-LIST TO !3-LIST~ 137500* 137600$COMMENT %DBGET6(Para#,Base#,Dset#). 137700* 137800* DBGET6 = backward chained read 137900* 138000$DEFINE %DBGET6 = 138100 CALL "DBGET" USING !2-BASE-NAME 138200 !3-DSET 138300 IMAGE-MODE-6 138400 IMAGE-STATUS 138500 !3-LIST 138600 !3-DATA 138700 IMAGE-DUMMY-FIELD 138800 IF NOT (IMAGE-OK OR IMAGE-BEG-OF-CHAIN) 138900 MOVE !3-DSET TO IMAGE-DSET 139000 %IMAGEERR(!1#,!2#,DBGET6#) 139100 END-IF 139200 MOVE IMAGE-SAME-LIST TO !3-LIST~ 139300* 139400$COMMENT %DBGET5BC(Para#,Base#,Dset#). 139500* 139600* DBGET5 = chained read with check for BROKEN CHAIN 139700* 139800$DEFINE %DBGET5BC = 139900 CALL "DBGET" USING !2-BASE-NAME 140000 !3-DSET 140100 IMAGE-MODE-5 140200 IMAGE-STATUS 140300 !3-LIST 140400 !3-DATA 140500 IMAGE-DUMMY-FIELD 140600 IF NOT (IMAGE-OK OR IMAGE-END-OF-CHAIN 140700 OR IMAGE-BROKEN-CHAIN) 140800 MOVE !3-DSET TO IMAGE-DSET 140900 %IMAGEERR(!1#,!2#,DBGET5#) 141000 END-IF 141100 MOVE IMAGE-SAME-LIST TO !3-LIST~ 141200* 141300$COMMENT %DBGET6BC(Para#,Base#,Dset#). 141400* 141500* DBGET6 = backward chained read with check for BROKEN CHAIN 141600* 141700$DEFINE %DBGET6BC = 141800 CALL "DBGET" USING !2-BASE-NAME 141900 !3-DSET 142000 IMAGE-MODE-6 142100 IMAGE-STATUS 142200 !3-LIST 142300 !3-DATA 142400 IMAGE-DUMMY-FIELD 142500 IF NOT (IMAGE-OK OR IMAGE-BEG-OF-CHAIN 142600 OR IMAGE-BROKEN-CHAIN) 142700 MOVE !3-DSET TO IMAGE-DSET 142800 %IMAGEERR(!1#,!2#,DBGET6#) 142900 END-IF 143000 MOVE IMAGE-SAME-LIST TO !3-LIST~ 143100* 143200$COMMENT %DBGET7(Para#,Base#,Dset#,Arg#) 143300* 143400* DBGET7 = calculated read 143500* 143600$DEFINE %DBGET7 = 143700 MOVE !4 TO IMAGE-ARGUMENT 143800 CALL "DBGET" USING !2-BASE-NAME 143900 !3-DSET 144000 IMAGE-MODE-7 144100 IMAGE-STATUS 144200 !3-LIST 144300 !3-DATA 144400 IMAGE-ARGUMENT 144500 IF NOT (IMAGE-OK OR IMAGE-NO-ENTRY) 144600 MOVE !3-DSET TO IMAGE-DSET 144700 %IMAGEERR(!1#,!2#,DBGET7#) 144800 END-IF 144900 MOVE IMAGE-SAME-LIST TO !3-LIST~ 145000* 145100$COMMENT %DBGET8(Para#,Base#,Dset#,Arg#) 145200* 145300* DBGET8 = prime calculated read 145400* 145500$DEFINE %DBGET8 = 145600 CALL "DBGET" USING !2-BASE-NAME 145700 !3-DSET 145800 IMAGE-MODE-8 145900 IMAGE-STATUS 146000 !3-LIST 146100 !3-DATA 146200 !4 146300 IF NOT (IMAGE-OK OR IMAGE-NO-ENTRY) 146400 MOVE !3-DSET TO IMAGE-DSET 146500 MOVE !4 TO IMAGE-ARGUMENT 146600 %IMAGEERR(!1#,!2#,DBGET8#) 146700 END-IF 146800 MOVE IMAGE-SAME-LIST TO !3-LIST~ 146900* 147000$COMMENT %DBMEMO(Para#,Base#,Text#,Textlen#) 147100* 147200* Add a line of text to the log file (if logging enabled) 147300* 147400$DEFINE %DBMEMO = 147500 IF !2-BASE-LOGGING-ON 147600 MOVE !4 TO IMAGE-TEXTLEN 147700 CALL "DBMEMO" USING !2-BASE-NAME 147800 !3 147900 IMAGE-MODE-1 148000 IMAGE-STATUS 148100 IMAGE-TEXTLEN 148200 IF IMAGE-ERROR 148300 %IMAGEERR(!1#,!2#,DBMEMO1#) 148400 END-IF 148500 END-IF~ 148600* 148700$COMMENT %CAPCHECK(Para#,Base#,Dset#). 148800* 148900* Dataset capacity checking 149000* 149100$DEFINE %CAPCHECK = 149200 MOVE 202 TO IMAGE-MODE 149300 CALL "DBINFO" USING !2-BASE-NAME 149400 !3-DSET 149500 IMAGE-MODE 149600 IMAGE-STATUS 149700 IMAGE-INFOBUF 149800 IF IMAGE-ERROR 149900 MOVE !3-DSET TO IMAGE-DSET 150000 %IMAGEERR(!1#,!2#,DBINFO#) 150100 END-IF 150200 COMPUTE IMAGE-SPARE-CAP = 150300 IMAGE-INFO-CAP - IMAGE-INFO-ENTRIES~ 150400* 150500$COMMENT %DBLOGGING(Para#,Base#). 150600* Find out if IMAGE logging has been turned on for this database. 150700$DEFINE %DBLOGGING = 150800 MOVE 401 TO IMAGE-MODE 150900 CALL "DBINFO" USING !2-BASE-NAME 151000 IMAGE-DUMMY-FIELD 151100 IMAGE-MODE 151200 IMAGE-STATUS 151300 IMAGE-INFOBUF 151400 IF IMAGE-ERROR 151500 %IMAGEERR(!1#,!2#,DBINFO#) 151600 END-IF 151700 IF IMAGE-401-USER-LOG-FLAG = 1 151800 MOVE "Y" TO !2-BASE-LOG-FLAG 151900 ELSE 152000 MOVE "N" TO !2-BASE-LOG-FLAG 152100 END-IF~ 152200* 152300$COMMENT %DBOPEN(Para#,Basename#) 152400* Open database with mode 1 (write access) 152500$DEFINE %DBOPEN = 152600 IF !2-BASE-CLOSED 152700 CALL "DBOPEN" USING !2-BASE-NAME 152800 !2-PASSWORD 152900 IMAGE-MODE-1 153000 IMAGE-STATUS 153100 IF IMAGE-ERROR 153200 MOVE !2-PASSWORD TO IMAGE-PASSWORD 153300 %IMAGEERR(!1#,!2#,DBOPEN1#) 153400 END-IF 153500 MOVE "Y" TO !2-BASE-FLAG 153600 %DBLOGGING(!1#,!2#) 153700 END-IF~ 153800* 153900$COMMENT %DBOPEN5(Para#,Basename#) 154000* Open database with mode 5 (read access) 154100$DEFINE %DBOPEN5 = 154200 IF !2-BASE-CLOSED 154300 CALL "DBOPEN" USING !2-BASE-NAME 154400 !2-PASSWORD 154500 IMAGE-MODE-5 154600 IMAGE-STATUS 154700 IF IMAGE-ERROR 154800 MOVE !2-PASSWORD TO IMAGE-PASSWORD 154900 %IMAGEERR(!1#,!2#,DBOPEN5#) 155000 END-IF 155100 MOVE "Y" TO !2-BASE-FLAG 155200 END-IF~ 155300* 155400$COMMENT %DBPUT(Para#,Base#,Dset#) 155500$DEFINE %DBPUT = 155600 CALL "DBPUT" USING !2-BASE-NAME 155700 !3-DSET 155800 IMAGE-MODE-1 155900 IMAGE-STATUS 156000 !3-LIST 156100 !3-DATA 156200 IF IMAGE-ERROR 156300 MOVE !3-DSET TO IMAGE-DSET 156400 %IMAGEERR(!1#,!2#,DBPUT1#) 156500 END-IF 156600 MOVE IMAGE-SAME-LIST TO !3-LIST~ 156700* 156800$COMMENT %DBUPDATE(Para#,Base#,Dset#). 156900$DEFINE %DBUPDATE = 157000 CALL "DBUPDATE" USING !2-BASE-NAME 157100 !3-DSET 157200 IMAGE-MODE-1 157300 IMAGE-STATUS 157400 !3-LIST 157500 !3-DATA 157600 IF IMAGE-ERROR 157700 MOVE !3-DSET TO IMAGE-DSET 157800 %IMAGEERR(!1#,!2#,DBUPDATE1#) 157900 END-IF~ 158000* 158100$COMMENT %SETLOCK(Number#,Dset#,Item#,Relop#,Value#). 158200$DEFINE %SETLOCK = 158300 MOVE !1 TO IMAGE-NO-OF-LOCKS 158400 MOVE "!2" 158500 TO IMAGE-LOCK-DSET(!1) 158600 MOVE "!3" 158700 TO IMAGE-LOCK-ITEM(!1) 158800 MOVE IMAGE-RELOP-!4 158900 TO IMAGE-LOCK-RELOP(!1) 159000 MOVE !5 159100 TO IMAGE-LOCK-VALUE(!1)~ 159200* 159300$COMMENT %DBLOCK(Para#,Base#) 159400$DEFINE %DBLOCK = 159500 MOVE "!1" TO MENU-SECTION 159600 MOVE !2-BASE-NAME TO IMAGE-BASE-NAME 159700 CALL "UDBLOCK" USING COMMON-LINKAGE, USER-LINKAGE~ 159800* 159900$COMMENT %DBUNLOCK(Para#,Base#) 160000$DEFINE %DBUNLOCK = 160100 CALL "DBUNLOCK" USING !2-BASE-NAME 160200 IMAGE-DUMMY-FIELD 160300 IMAGE-MODE-1 160400 IMAGE-STATUS 160500 IF IMAGE-ERROR 160600 %IMAGEERR(!1#,!2#,DBUNLOCK1#) 160700 END-IF~ 160800* 160900$PAGE 161000****************************************************************** 161100* Macros to open/read/close USERHELP and USERMSG files 161200****************************************************************** 161300* 161400$COMMENT %OPENUSERMSG(Para#,Name#) 161500* Open user message catalog 161600$DEFINE %OPENUSERMSG = 161700 MOVE ZERO TO MENU-MSGCAT-FILENO 161800 MOVE "!2" TO MENU-MSGCAT-FILENAME 161900 CALL INTRINSIC "CATOPEN" USING MENU-MSGCAT-FILENAME 162000 MENU-MSGCAT-STATUS 162100 GIVING MENU-MSGCAT-FILENO~ 162200* 162300$COMMENT %READUSERMSG(Para#,Buffer#,Buflen#) 162400* Read user message catalog 162500$DEFINE %READUSERMSG= 162600 MOVE SPACES TO !2 162700 CALL INTRINSIC "CATREAD" USING MENU-MSGCAT-FILENO 162800 GENMSG-SET 162900 GENMSG-NUM 163000 MENU-MSGCAT-STATUS 163100 !2 163200 \!3\ 163300 GENMSG-PARAM(1) 163400 GENMSG-PARAM(2) 163500 GENMSG-PARAM(3) 163600 GENMSG-PARAM(4) 163700 GENMSG-PARAM(5) 163800 \\ 163900 GIVING GENMSG-LENGTH 164000 MOVE MENU-MSGCAT-STATUS TO GENMSG-ERROR~ 164100* 164200$COMMENT %CLOSEUSERMSG(Para#) 164300* Close user message catalog 164400$DEFINE %CLOSEUSERMSG = 164500 CALL INTRINSIC "CATCLOSE" USING MENU-MSGCAT-FILENO 164600 MENU-MSGCAT-STATUS 164700 MOVE ZERO TO MENU-MSGCAT-FILENO~ 164800* 164900$COMMENT %OPENUSERHELP(Para#,Name#) 165000* Open user help catalog 165100* (note: file is opened/read/closed when HELP is invoked) 165200$DEFINE %OPENUSERHELP = 165300 MOVE "!2" TO MENU-HELPCAT-FILENAME~ 165400* 165500$PREPROCESSOR DELIMITER=# 165600* 165700$PAGE 165800****************************************************************** 165900* Macros for COBOL programs 166000****************************************************************** 166100* 166200$COMMENT %ID(prog-id#,your-name#,date-written#) 166300$DEFINE %ID = 166400$TITLE "***** Author: !2 *** Written: !3 *****" 166500 IDENTIFICATION DIVISION. 166600 166700 PROGRAM-ID. !1. 166800 166900 AUTHOR. !2 167000 Prolog Systems Limited 167010 Century House 167020 Station Way 167030 Cheam 167040 Surrey 167050 SM3 8SW (phone 081-715-1555) 167060 (fax 081-715-1556). 167500 167600 DATE-WRITTEN. !3. 167700 167800 DATE-COMPILED.# 167900* 168000$PREPROCESSOR DELIMITER=~ 168100* 168200$COMMENT %ED. 168300* NOTE: a full stop is required after this macro - this allows 168400* for the inclusion of additional SPECIAL-NAMES parameters. 168500* "WITH DEBUGGING MODE" is implemented if compiler switch X1=ON 168600$DEFINE %ED = 168700 ENVIRONMENT DIVISION. 168800 CONFIGURATION SECTION. 168900 169000$IF X1=ON 169100 SOURCE-COMPUTER. HP3000 WITH DEBUGGING MODE. 169200$IF X1=OFF 169300 SOURCE-COMPUTER. HP3000. 169400$IF 169500 OBJECT-COMPUTER. HP3000. 169600 169700 SPECIAL-NAMES. 169800 CONDITION-CODE IS C-C 169900 TOP IS TOP-OF-PAGE 170000 SYMBOLIC CHARACTERS NULL IS 1 170100 BELL IS 8 170200 C-R IS 14 170300 ESC IS 28 170400 CURRENCY SIGN IS "»"~ 170500 170600$PREPROCESSOR DELIMITER=# 170700* 170800$COMMENT %BATCHINIT(Progname#,Description#) 170900* Initialise common linkage in batch programs 171000$DEFINE %BATCHINIT = 171100 COPY INITCOMA IN STANDARD. 171200 SET BATCH-MODE TO TRUE. 171300 MOVE "BATCH" TO MENU-OPERATOR. 171400 STRING MENU-WHO-USERN DELIMITED BY " " 171500 "." DELIMITED BY SIZE 171600 MENU-WHO-ACCTN DELIMITED BY " " 171700 INTO MENU-USER-NAME 171800 END-STRING. 171900 MOVE "!1" TO MENU-TRANSACTION, 172000 MENU-SELECTION, 172100 MENU-ENTRY-POINT. 172200 MOVE "!2" TO MENU-TITLE-1. 172300 172400* Put current date & time into standard heading 172500 CALL INTRINSIC "CLOCK" GIVING MENU-CLOCK. 172600 CALL INTRINSIC "FMTCLOCK" USING MENU-CLOCK, 172700 MENU-TIME. 172800 CALL INTRINSIC "CALENDAR" GIVING MENU-CALENDAR. 172900 CALL INTRINSIC "FMTCALENDAR" USING MENU-CALENDAR, 173000 MENU-DATE. 173100 173200* Open $STDIN and $STDLIST 173300 CALL INTRINSIC "FOPEN" USING \\, \%614\, \%1\ 173400 GIVING STDLIST-FILENUM. 173500 173600 CALL INTRINSIC "FOPEN" USING \\, \%244\, \\ 173700 GIVING STDIN-FILENUM# 173800 173900* 174000$COMMENT %DEBUG(Progname#) 174100* This requires WITH DEBUGGING MODE in the ENVIRONMENT DIVISION. 174200* It must be inserted after PROCEDURE DIVISION and before the 174300* first section, and will automatically provide a trace of your 174400* program's path through every section and paragraph. 174500* THIS CODE IS NOT EXECUTED UNLESS YOU RUN YOUR PROGRAM WITH 174600* ";PARM=1", therefore recompilations are not necessary. 174700* You are also advised to use ";STDLIST=*LP" on the RUN statement 174800* in order to output the trace to the printer. 174900* NOTE: in live programs do not use debug lines with "D" in col 7. 175000$DEFINE %DEBUG = 175100$IF X1=ON 175200 DECLARATIVES. 175300 DEBUG-SECTION SECTION. 175400 USE FOR DEBUGGING ON ALL PROCEDURES. 175500 DEBUG-00. 175600 DISPLAY "!1=> " DEBUG-NAME 175700 "," DEBUG-LINE 175800 "," DEBUG-CONTENTS. 175900 DEBUG-EXIT. 176000 END DECLARATIVES. 176100$IF# 176200* 176300$PAGE 176400****************************************************************** 176500* * 176600* Macros used in message file processing. * 176700* * 176800****************************************************************** 176900* 177000$COMMENT %MSGFILEDEFINE(Name#). 177100****************************************************************** 177200* Working storage variables for the message file 177300* Record buffer must be appended to this macro call 177400* 177500$DEFINE %MSGFILEDEFINE = 177600 01 !1-FILE-NAME PIC X(09) VALUE "!1". 177700 01 !1-FILE-NUM PIC S9(4) COMP. 177800 01 !1-RECLEN PIC S9(4) COMP. 177900 01 !1-RECORD-COUNT PIC S9(9) COMP. 178000 01 !1-RECORD-LIMIT PIC S9(9) COMP. 178100 01 !1-WRITER-COUNT PIC S9(4) COMP. 178200 01 !1-READER-COUNT PIC S9(4) COMP. 178300 01 !1-FCONTROL-VALUE PIC S9(4) COMP. 178400 01 !1-RECORD.# 178500* 178600$COMMENT %MSGFILEDEFINE2(Name#). 178700****************************************************************** 178800* Working storage variables for the message file without the file 178900* name and number, which must therefore be defined separately (in 179000* USER-LINKAGE, for example). 179100* Record buffer must be appended to this macro call. 179200* 179300$DEFINE %MSGFILEDEFINE2 = 179400 01 !1-RECLEN PIC S9(4) COMP. 179500 01 !1-RECORD-COUNT PIC S9(9) COMP. 179600 01 !1-RECORD-LIMIT PIC S9(9) COMP. 179700 01 !1-WRITER-COUNT PIC S9(4) COMP. 179800 01 !1-READER-COUNT PIC S9(4) COMP. 179900 01 !1-FCONTROL-VALUE PIC S9(4) COMP. 180000 01 !1-RECORD.# 180100* 180200$PREPROCESSOR DELIMITER=~ 180300* 180400$COMMENT %MSGFILEERROR(Para#,File#). 180500****************************************************************** 180600* Process errors for message files 180700* 180800$DEFINE %MSGFILEERROR = 180900 MOVE "!1" TO MENU-SECTION 181000 MOVE !2-FILE-NAME TO MPE-FILE-NAME 181100 MOVE !2-FILE-NUM TO MPE-FILE-NUM 181200 SET ERROR-TYPE-FILE TO TRUE 181300 CALL "UERROR" USING COMMON-LINKAGE, USER-LINKAGE~ 181400* 181500$COMMENT %MSGFILEOPENR(Para#,File#) 181600****************************************************************** 181700* Open message file for read access (single reader only) 181800* 181900$DEFINE %MSGFILEOPENR = 182000 CALL INTRINSIC "FOPEN" USING !2-FILE-NAME, 182100 %30007, 182200 %2200, 182300 GIVING !2-FILE-NUM 182400 IF C-C NOT = 0 182500 %MSGFILEERROR(!1#,!2#) 182600 END-IF 182700**** Get record length (negative = bytes, positive = words) 182800 CALL INTRINSIC "FFILEINFO" USING !2-FILE-NUM, 182900 \4\, 182910 !2-RECLEN 183000 %MSGFILECOUNTERS(!1#,!2#)~ 183100* 183200$COMMENT %MSGFILECOUNTERS(Para#,File#) 183300****************************************************************** 183400* Get number of records, number of readers and writers 183500* 183600$DEFINE %MSGFILECOUNTERS = 183700 CALL INTRINSIC "FFILEINFO" USING !2-FILE-NUM, 183800 \10\, !2-RECORD-COUNT, 183900 \11\, !2-RECORD-LIMIT, 184000 \34\, !2-WRITER-COUNT, 184100 \35\, !2-READER-COUNT~ 184200* 184300$COMMENT %MSGFILECONTROL(Para#,File#,Option#,Value#) 184400****************************************************************** 184500* Call FCONTROL to set option ON or OFF 184600* 184700$DEFINE %MSGFILECONTROL = 184800 MOVE !4 TO !2-FCONTROL-VALUE 184900 CALL INTRINSIC "FCONTROL" USING !2-FILE-NUM, 185000 \!3\, 185100 !2-FCONTROL-VALUE 185200 IF C-C NOT = 0 185300 %MSGFILEERROR(!1#,!2#) 185400 END-IF~ 185500* 185600$COMMENT %MSGFILEOPENW(Para#,File#) 185700****************************************************************** 185800* Open message file for write access (multiple writers) 185900* 186000$DEFINE %MSGFILEOPENW = 186100 IF !2-FILE-NUM = 0 186200 CALL INTRINSIC "FOPEN" USING !2-FILE-NAME, 186300 %30007, 186400 %2203, 186500 GIVING !2-FILE-NUM 186600 IF C-C NOT = 0 186700 %MSGFILEERROR(!1#,!2#) 186800 END-IF 186900******** Get record length (negative = bytes, positive = words) 187000 CALL INTRINSIC "FFILEINFO" USING !2-FILE-NUM, 187100 \4\, 187110 !2-RECLEN 187200 %MSGFILECOUNTERS(!1#,!2#) 187300 END-IF~ 187400* 187500$COMMENT %MSGFILEOPENW2(Para#,File#) 187600****************************************************************** 187700* Open message file for write access (multiple writers) 187800* (This version does not abort on an FOPEN error) 187900$DEFINE %MSGFILEOPENW2 = 188000 IF !2-FILE-NUM = 0 188100 CALL INTRINSIC "FOPEN" USING !2-FILE-NAME, 188200 %30007, 188300 %2203, 188400 GIVING !2-FILE-NUM 188500 IF C-C = 0 188600******** Get record length (negative = bytes, positive = words) 188700 CALL INTRINSIC "FFILEINFO" USING !2-FILE-NUM, 188800 \4\, 188810 !2-RECLEN 188900 %MSGFILECOUNTERS(!1#,!2#) 189000 END-IF 189100 END-IF~ 189200* 189300$COMMENT %MSGFILEWRITE(Para#,File#) 189400****************************************************************** 189500* Write a record to the message file 189600* 189700$DEFINE %MSGFILEWRITE = 189800 CALL INTRINSIC "FWRITE" USING !2-FILE-NUM, 189900 !2-RECORD, 190000 !2-RECLEN, 190100 0 190200 IF C-C NOT = 0 190300 %MSGFILEERROR(!1#,!2#) 190400 END-IF 190500**** Set EOF mark (in case of system failure) 190600 CALL INTRINSIC "FCONTROL" USING !2-FILE-NUM, 190700 6, 190800 !2-FCONTROL-VALUE~ 190900* 191000$COMMENT %MSGFILEREAD(Para#,File#) 191100****************************************************************** 191200* Read a record from the message file 191300* At EOF the data record is filled with HIGH-VALUES 191400* 191500$DEFINE %MSGFILEREAD = 191600 CALL INTRINSIC "FREAD" USING !2-FILE-NUM, 191700 !2-RECORD, 191800 !2-RECLEN 191900 IF C-C > 0 192000 MOVE HIGH-VALUES TO !2-RECORD 192100 ELSE 192200 IF C-C < 0 192300 %MSGFILEERROR(!1#,!2#) 192400 END-IF 192500 END-IF~ 192600* 192700$COMMENT %MSGFILECLOSE(Para#,File#) 192800****************************************************************** 192900* Close the message file 193000* 193100$DEFINE %MSGFILECLOSE = 193200 IF !2-FILE-NUM NOT = ZERO 193300 CALL INTRINSIC "FCLOSE" USING !2-FILE-NUM, 0, 0 193400 MOVE ZERO TO !2-FILE-NUM 193500 END-IF~ 193600* 193700$PREPROCESSOR DELIMITER=# 193800* 193900$CONTROL LIST