QUERY/iX Reference Manual
> Appendix F USER-DEFINED PROCEDURESProcedures |
||||||||||||||||||||
|
group account systemNative Mode QUERY will search XL files. Compatibility Mode QUERY wll search SL files. To call your defined procedure, replace the print element with the name of the procedure, and replace the print position with a slash (/). Seventeen parameters are automatically passed to the procedure by QUERY. You may provide a single integer parameter for each procedure. To specify a value for a particular call of the procedure, the value should be placed in parenthesis after the name of the procedure. report statement type,procedure name [(user parameter)],/,[statement¶meter]The following statement parameters are allowed with a REPORT statement containing a call to a user-defined procedure: SPACE A SPACE B SKIP A SKIP BFor example:for calling user-defined procedures PROC1 and PROC2: REPORT H1,PROC1(5),/,SPACE A3 H1,ITEM3,50 D1,PROC2,/ D1,ITEM1,10 D2,ITEM2,10 ENDThe following is not allowed: EDIT masks ADD AVERAGE COUNTIf you specify an option that is not allowed, QUERY will issue the following message. A SPECIFIED OPTION IS NOT ALLOWED FOR USER PROCEDURESThere are eight parameters that you can set. These are: CALLAGAIN, PAGE'EJECT, LINEBUF, REGARR, USERSTOR, USERPARAM, DATA'BASE'NAME, and DATA'SET'NAME. The other nine parameters are values returned by QUERY. Within your procedure, you must declare parameters with the same or different names in the following order: LOGICAL CALLAGAIN, 1 word PAGE'EJECT; 1 word INTEGER ARRAY BASE'IDS, 130 words DBBUF, 2051 words DSET'LIST 53 words DATA'BASE'LIST 53 words LINEBUF, 69 words REGARR, 150 words USERSTOR, 64 words USERPARAM, 1 word DATA'BASE'NAME, 13 words DATA'SET'NAME, 8 words INTEGER CALL'NUM, 1 word LINES'LEFT, 1 word PAGENO, 1 word NUM'DSETS 1 word NUM'DBASES; 1 word* The following parameters can be set by you. Parameters
ExamplesThe following examples show two user-defined procedures: MPROC and QPROC. MPROC is shown in four languages and QPROC is shown in two languages. MPROC ProcedureThe following examples show MPROC in SPL, COBOL, PASCAL and FORTRAN. The data base, retrieval, and report are shown for understanding the context of the use of the procedure. The data base is defined as follows: BEGIN DATA BASE ACCTS; PASSWORDS: ITEMS: ACCT-NUM, X6; ORDER-DATE, I2; << DATES ARE STORED AS DOUBLE INTEGERS, >> SHIP-DATE, I2; << IE 84140 IS 1984, 140TH DAY IN YEAR >> DEPT, U4; CARRIER, U4; SETS: NAME: ACCT-MAST, A; ENTRY: ACCT-NUM (2); CAPACITY: 11; NAME: ORDER-D, D; ENTRY: ACCT-NUM (!ACCT-MAST), ORDER-DATE, DEPT; CAPACITY: 11; NAME: SHIP-D, D; ENTRY: ACCT-NUM (!ACCT-MAST), CARRIER, SHIP-DATE; CAPACITY: 11; END.The retrieval and report are defined as follows: >JOIN ORDER-D.ACCT-NUM TO SHIP-D.ACCT-NUM >MU ALL USING SERIAL READ 14 COMPOUND ENTRIES RETRIEVED >XEQ MULTIREPThe XEQ file, MULTIREP, contains: REPORT H1,"REPORT ON ALL ACCOUNT DATES",45,SPACE A2 H2,"ACCOUNT",8 H2,"DEPT",14 H2,"DATE OF ORDER",35 H2,"SHIPPING DATE",55 H2,"CARRIER",65 H3,"-------",8 H3,"----",14 H3,"-------------",35 H3,"-------------",55,SPACE A2 H3,"-------",65 S1,ORDER-DATE S2,ACCT-NUM D1,ACCT-NUM,8,E1 D1,":",9 D1,DEPT,14 D1,CARRIER,65 D1,MPROC,/ G2," ",5 E1,"XXX-XXX" ENDThe output is: REPORT ON ALL ACCOUNT DATES ACCOUNT DEPT DATE OF ORDER SHIPPING DATE CARRIER ------- ---- ------------- ------------- ------- 010-666: 008 WED, DEC 5, 1984 THU, DEC 27, 1984 UPS 010-666: 008 WED, DEC 5, 1984 THU, DEC 27, 1984 UPS 010-666: 008 WED, DEC 5, 1984 THU, DEC 27, 1984 UPS 010-666: 008 WED, DEC 12, 1984 THU, DEC 27, 1984 UPS 010-666: 008 WED, DEC 12, 1984 THU, DEC 27, 1984 UPS 010-666: 008 WED, DEC 12, 1984 THU, DEC 27, 1984 UPS 010-666: 008 WED, DEC 26, 1984 THU, DEC 27, 1984 UPS 010-666: 008 WED, DEC 26, 1984 THU, DEC 27, 1984 UPS 010-666: 008 WED, DEC 26, 1984 THU, DEC 27, 1984 UPS 041-321: 003 WED, DEC 12, 1984 THU, DEC 13, 1984 UPS 055-433: 005 FRI, DEC 14, 1984 FRI, DEC 28, 1984 UPS 055-433: 005 FRI, DEC 14, 1984 FRI, DEC 28, 1984 UPS 055-433: 005 WED, DEC 26, 1984 FRI, DEC 28, 1984 UPS 055-433: 005 WED, DEC 26, 1984 FRI, DEC 28, 1984 UPS SPL - MPROC Procedure<<------------------------------------------------------->> << HAVING USLINIT AND SUBPROGRAM WILL GENERATE A WARNING,>> << YOU WILL NOT WANT TO INITIALIZE THE USL FILE IF YOU >> << ARE COMPILING DIFFERENT SUBPROGRAMS INTO IT. >> <<------------------------------------------------------->> $CONTROL MAP, USLINIT, SUBPROGRAM $CONTROL SEGMENT=MULTISEG <<------------------------------------------------------>> << >> << MPROC >> << >> << EXAMPLE OF A SPL USER-DEFINED PROCEDURE, USED WITH A >> << REPORT STATEMENT. >> << >> <<------------------------------------------------------>> << THIS PROCEDURE TAKES A JULIAN DATE AND CONVERTS IT >> << TO "DAY, MONTH, YEAR" FORMAT BY CALLING THE MPE >> << INTRINSIC FMTCALENDAR. >> <<------------------------------------------------------>> BEGIN <<------------------------------------------>> << MPROC DECLARATION >> <<------------------------------------------>> PROCEDURE MPROC (CALLAGAIN, PAGE'EJECT, BASE'IDS, DBBUF, DSET'LIST, DATA'BASE'LIST, LINEBUF, REGARR, USERSTOR, USERPARAM, DATA'BASE'NAME, DATA'SET'NAME, CALL'NUM, LINES'LEFT, PAGENO, NUM'DSETS, NUM'DBASES); LOGICAL CALLAGAIN, PAGE'EJECT; INTEGER ARRAY BASE'IDS, DBBUF, DSET'LIST, DATA'BASE'LIST, LINEBUF, REGARR, USERSTOR, USERPARAM, DATA'BASE'NAME, DATA'SET'NAME; INTEGER CALL'NUM, LINES'LEFT, PAGENO, NUM'DSETS, NUM'DBASES; BEGIN BYTE ARRAY FMTDATE (0:16), BLINEBUF (*) = LINEBUF; DOUBLE POINTER D'DATE; DOUBLE ARRAY D'DAY (0:0), D'YEAR (0:0); INTEGER ARRAY DAY (*) = D'DAY, YEAR (*) = D'YEAR; DOUBLE HOLD; INTEGER JDATE; INTRINSIC FMTCALENDAR; <<-------------------------------------------------------->> << THERE ARE TWO DATES IN THE DATA BASE TO BE FORMATTED. >> << ONE IS IN THE ORDER-D DATA SET, THE OTHER IS IN THE >> << SHIP-D DATA SET. BECAUSE THE SETS HAVE BEEN JOINED, >> << IT IS POSSIBLE TO GET BOTH DATES AND FORMAT THEM. >> << NOTE: IT IS THE APPLICATION'S RESPONSIBILITY TO KNOW >> << WHERE IN THE DATA BUFFER THE VALUE IS LOCATED. >> <<-------------------------------------------------------->> <<-------------------------------------------------------->> << THE DATE IS IN A TWO WORD INTEGER AND NEEDS TO BE RE- >> << FORMATTED BEFORE PASSING TO FMTCALENDAR. >> <<-------------------------------------------------------->> <<-------------------------------------------------------->> << IF CALL'NUM IS ONE THEN WE CAN ASSUME THE ENTRY IS >> << FROM THE ORDER-D DATA SET, SINCE IT IS THE FIRST DATA >> << SET MENTIONED IN THE JOIN COMMAND. IF CALL'NUM IS NOT >> << ONE THEN WE CAN ASSUME THAT THE PROCEDURE HAS BEEN >> << CALLED AGAIN, AND WE NOW HAVE THE ENTRY FROM THE >> << SHIP-D DATA SET. >> <<-------------------------------------------------------->> IF CALL'NUM =1 THEN << FIRST DATE >> @D'DATE := @DBBUF(3) ELSE << SECOND DATE >> @D'DATE := @DBBUF(5); D'YEAR := D'DATE / 1000D; << ISOLATE YEAR >> HOLD := D'YEAR * 1000D; D'DAY := D'DATE - HOLD; JDATE := DAY (1); << DAY IN BITS 0-6 >> JDATE.(0:7) := YEAR (1); << YEAR IN BITS 7-15 >> FMTCALENDAR (JDATE, FMTDATE); <<-------------------------------------------------------->> << PUT THE FORMATTED DATE INTO THE OUTPUT BUFFER USED BY >> << QUERY FOR THE REPORT OUTPUT LINE. AGAIN, CALL'NUM IS >> << USED TO DETERMINE WHERE IN THE OUTPUT BUFFER TO PLACE >> << THE VALUE. ALSO, IF CALL'NUM IS ONE THEN WE NEED TO >> << SET THE DATA BASE NAME, THE DATA SET NAME, AND THE >> << CALLAGAIN PARAMETERS IN ORDER TO GET THE ENTRY FROM >> << THE SHIP-D DATA SET TO FORMAT THE SHIPPING DATE. >> <<-------------------------------------------------------->> IF CALL'NUM = 1 THEN << ORDER-D DATA SET >> BEGIN MOVE BLINEBUF(18) := FMTDATE, (17); MOVE DATA'BASE'NAME := "ACCTS "; MOVE DATA'SET'NAME := "SHIP-D "; CALLAGAIN := TRUE; END ELSE << SHIP-D DATA SET >> BEGIN MOVE BLINEBUF(38) := FMTDATE, (17); CALLAGAIN := FALSE; END; END; END. COBOL - MPROC Procedure$CONTROL USLINIT, SUBPROGRAM, MAP, DYNAMIC IDENTIFICATION DIVISION. PROGRAM-ID. MPROC. AUTHOR. HP. *------------------------------------------------------* * * * MPROC * * * * EXAMPLE OF A COBOL USER-DEFINED PROCEDURE, USED WITH * * A REPORT STATEMENT. * * * * THIS MUST BE COMPILED WITH THE COBOLII COMPILER. * * * *------------------------------------------------------* * THIS PROCEDURE TAKES A JULIAN DATE AND CONVERTS IT * * TO "DAY, MONTH, YEAR" FORMAT BY CALLING THE MPE * * INTRINSIC FMTCALENDAR. * *------------------------------------------------------* ENVIRONMENT DIVISION. DATA DIVISION. WORKING-STORAGE SECTION. 01 FMTDATE-REC. 05 FMTDATE OCCURS 17 PIC X. 01 I-DAY PIC S9(4) COMP. 01 YEAR PIC S9(4) COMP. 01 HOLD PIC S9(9) COMP. 01 D-JDATE PIC S9(9) COMP. 01 JDATE REDEFINES D-JDATE. 05 I-JDATE OCCURS 2 PIC S9(4) COMP. 01 INDX PIC S9(4) COMP. LINKAGE SECTION. 01 CALLAGAIN PIC S9(4) COMP. 01 PAGE-EJECT PIC S9(4) COMP. 01 BASE-IDS. 05 BASE-ID1 PIC S9(4) COMP. 05 BASE-NAME1 PIC X(24). 05 BASE-ID2 PIC S9(4) COMP. 05 BASE-NAME2 PIC X(24). 05 BASE-ID-OTHERS PIC X(208). 01 DBBUF PIC X(4102). 01 DBBUF-2 REDEFINES DBBUF. 05 FILLER PIC X(6). 05 DBBUFD OCCURS 2 PIC S9(9) COMP. 05 FILLER PIC X(4088). 01 DSET-LIST. 05 DSET OCCURS 53 TIMES PIC S9(4) COMP. 01 DATA-BASE-LIST. 05 DBASE OCCURS 53 TIMES PIC S9(4) COMP. 01 LINEBUF. 05 LINEBUF-70 PIC X(70). 05 LINEBUF-OTHER PIC X(66). 01 BLINEBUF1 REDEFINES LINEBUF. 05 FILLER PIC X(18). 05 BA-LINEBUF1 PIC X(17). 05 FILLER PIC X(101). 01 BLINEBUF2 REDEFINES LINEBUF. 05 FILLER PIC X(38). 05 BA-LINEBUF2 PIC X(17). 05 FILLER PIC X(81). 01 REGARR. 05 REG OCCURS 30 TIMES PIC S9(18) COMP-3. 01 USERSTOR. 05 USERSTOR-70 PIC X(70). 05 USERSTOR-OTHER PIC X(58). 01 USERPARAM PIC S9(4) COMP. 01 DATA-BASE-NAME PIC X(26). 01 DATA-SET-NAME PIC X(16). 01 CALL-NUM PIC S9(4) COMP. 01 LINES-LEFT PIC S9(4) COMP. 01 PAGENO PIC S9(4) COMP. 01 NUM-DSETS PIC S9(4) COMP. 01 NUM-DBASES PIC S9(4) COMP. *---------------------------------------------------------* * MPROC PROCEDURE DIVISION * *---------------------------------------------------------* PROCEDURE DIVISION USING CALLAGAIN, PAGE-EJECT, BASE-IDS, DBBUF, DSET-LIST, DATA-BASE-LIST, LINEBUF, REGARR, USERSTOR, USERPARAM, DATA-BASE-NAME, DATA-SET-NAME, CALL-NUM, LINES-LEFT, PAGENO, NUM-DSETS, NUM-DBASES. BEGIN-MPROC. *--------------------------------------------------------* * THERE ARE TWO DATES IN THE DATA BASE TO BE FORMATTED. * * ONE IS IN THE ORDER-D DATA SET, THE OTHER IS IN THE * * SHIP-D DATA SET. BECAUSE THE SETS HAVE BEEN JOINED, * * IT IS POSSIBLE TO GET BOTH DATES AND FORMAT THEM. * * NOTE: IT IS THE APPLICATION'S RESPONSIBILITY TO KNOW * * WHERE IN THE DATA BUFFER THE VALUE IS LOCATED. * *--------------------------------------------------------* *--------------------------------------------------------* * THE DATE IS IN A TWO WORD INTEGER AND NEEDS TO BE RE- * * FORMATTED BEFORE PASSING TO FMTCALENDAR. * *--------------------------------------------------------* *--------------------------------------------------------* * IF CALL'NUM IS ONE THEN WE CAN ASSUME THE ENTRY IS * * FROM THE ORDER-D DATA SET, SINCE IT IS THE FIRST DATA * * SET MENTIONED IN THE JOIN COMMAND. IF CALL'NUM IS NOT * * ONE THEN WE CAN ASSUME THAT THE PROCEDURE HAS BEEN * * CALLED AGAIN, AND WE NOW HAVE THE ENTRY FROM THE * * SHIP-D DATA SET. * *--------------------------------------------------------* IF CALL-NUM = 1 THEN MOVE 1 TO INDX ELSE MOVE 2 TO INDX. DIVIDE DBBUFD(INDX) BY 1000 GIVING YEAR. MULTIPLY YEAR BY 1000 GIVING HOLD. SUBTRACT HOLD FROM DBBUFD(INDX) GIVING I-DAY. MULTIPLY YEAR BY 512 GIVING D-JDATE. ADD I-DAY TO D-JDATE. CALL INTRINSIC "FMTCALENDAR" USING I-JDATE(2), FMTDATE. *--------------------------------------------------------* * PUT THE FORMATTED DATE INTO THE OUTPUT BUFFER USED BY * * QUERY FOR THE REPORT OUTPUT LINE. AGAIN, CALL'NUM IS * * USED TO DETERMINE WHERE IN THE OUTPUT BUFFER TO PLACE * * THE VALUE. ALSO, IF CALL'NUM IS ONE THEN WE NEED TO * * SET THE DATA BASE NAME, THE DATA SET NAME, AND THE * * CALLAGAIN PARAMETERS IN ORDER TO GET THE ENTRY FROM * * THE SHIP-D DATA SET TO FORMAT THE SHIPPING DATE. * *--------------------------------------------------------* IF CALL-NUM = 1 THEN MOVE FMTDATE-REC TO BA-LINEBUF1 MOVE "ACCTS " TO DATA-BASE-NAME MOVE "SHIP-D " TO DATA-SET-NAME MOVE 1 TO CALLAGAIN ELSE MOVE FMTDATE-REC TO BA-LINEBUF2 MOVE 0 TO CALLAGAIN. GOBACK. COBOL NotesThe call to FMTCALENDAR will generate a 'Questionable' error because the second word of the I-JDATE array is being passed. PASCAL - MPROC Procedure(*-------------------------------------------------------*) (* YOU WILL NOT WANT TO INITIALIZE THE USL FILE IF YOU *) (* ARE COMPILING DIFFERENT SUBPROGRAMS INTO IT. *) (*-------------------------------------------------------*) $CODE_OFFSETS ON; TABLES ON; USLINIT; SUBPROGRAM$ $STANDARD_LEVEL 'HP3000'$ $SEGMENT 'MULTISEG'$ (*------------------------------------------------------*) (* *) (* MPROC *) (* *) (* EXAMPLE OF A PASCAL USER-DEFINED PROCEDURE, USED *) (* WITH A REPORT STATEMENT. *) (* *) (* THE PROCEDURE CONTAINS COMMENT LINES WHICH ONLY *) (* CONTAIN A NUMBER. THESE COMMENTS ARE REFERENCES TO *) (* NOTES ON THE USE OF PASCAL DATA TYPES AND STRUCTURES.*) (* THE NOTES APPEAR AT THE END OF THE PROCEDURE. *) (* *) (*------------------------------------------------------*) (* THIS PROCEDURE TAKES A JULIAN DATE AND CONVERTS IT *) (* TO "DAY, MONTH, YEAR" FORMAT BY CALLING THE MPE *) (* INTRINSIC FMTCALENDAR. *) (*------------------------------------------------------*) PROGRAM PASPROC(INPUT,OUTPUT); TYPE SMALLINT = -32768..32767; DBBUF_REC = RECORD CASE INTEGER OF (* 1 *) 0 : (DBBUF_CHAR : PACKED ARRAY [1..4102] OF CHAR); 1 : (DBBUF_INT : ARRAY [1..2051] OF SMALLINT); END; BASEARRAY = ARRAY [1..130] OF SMALLINT; LISTARRAY = ARRAY [1..53] OF SMALLINT; REGARRAY = ARRAY [1..150] OF SMALLINT; STORARRAY = ARRAY [1..64] OF SMALLINT; LINEARRAY = RECORD (* 2 *) BLINEBUF : PACKED ARRAY [1..138] OF CHAR; END; DBARRAY = RECORD BDB_NAME : PACKED ARRAY [1..26] OF CHAR; END; DSARRAY = RECORD BDS_NAME : PACKED ARRAY [1..16] OF CHAR; END; (* 3 *) PROCEDURE MPROC (VAR CALLAGAIN, PAGE_EJECT: SMALLINT; VAR BASE_IDS: BASEARRAY; VAR DBBUF: DBBUF_REC; VAR DSET_LIST, DATA_BASE_LIST: LISTARRAY; VAR LINEBUF: LINEARRAY; VAR REGARR: REGARRAY; VAR USERSTOR: STORARRAY; VAR USERPARAM: SMALLINT; VAR DATA_BASE_NAME: DBARRAY; VAR DATA_SET_NAME: DSARRAY; VAR CALL_NUM, LINES_LEFT, PAGENO: SMALLINT; VAR NUM_DSETS, NUM_DBASES: SMALLINT); TYPE DAY_REC = RECORD CASE INTEGER OF 0 : (D_DAY : INTEGER); 1 : (DAY : ARRAY [1..2] OF SMALLINT); END; YEAR_REC = RECORD CASE INTEGER OF 0 : (D_YEAR : INTEGER); 1 : (YEAR : ARRAY [1..2] OF SMALLINT); END; JDATE_REC = RECORD CASE INTEGER OF 0 : (DAY_YR : PACKED RECORD YEAR : 0..127; DAY : 0..511; END); 1 : (DATE : SMALLINT); END; VAR FMTDATE : PACKED ARRAY [1..17] OF CHAR; DAY : DAY_REC; YEAR : YEAR_REC; HOLD : INTEGER; JDATE : JDATE_REC; M, N : SMALLINT; HOLD_BUF: RECORD CASE INTEGER OF 0 : (SINGLE_INT : ARRAY [1..2] OF SMALLINT); 1 : (DOUBLE_INT : INTEGER); END; PROCEDURE FMTCALENDAR; INTRINSIC; (*--------------------------------------------------------*) (* THERE ARE TWO DATES IN THE DATA BASE TO BE FORMATTED. *) (* ONE IS IN THE ORDER-D DATA SET, THE OTHER IS IN THE *) (* SHIP-D DATA SET. BECAUSE THE SETS HAVE BEEN JOINED, *) (* IT IS POSSIBLE TO GET BOTH DATES AND FORMAT THEM. *) (* NOTE: IT IS THE APPLICATION'S RESPONSIBILITY TO KNOW *) (* WHERE IN THE DATA BUFFER THE VALUE IS LOCATED. *) (*--------------------------------------------------------*) (*--------------------------------------------------------*) (* THE DATE IS IN A TWO WORD INTEGER AND NEEDS TO BE RE- *) (* FORMATTED BEFORE PASSING TO FMTCALENDAR. *) (*--------------------------------------------------------*) (*--------------------------------------------------------*) (* IF CALL_NUM IS ONE THEN WE CAN ASSUME THE ENTRY IS *) (* FROM THE ORDER-D DATA SET, SINCE IT IS THE FIRST DATA *) (* SET MENTIONED IN THE JOIN COMMAND. IF CALL_NUM IS NOT *) (* ONE THEN WE CAN ASSUME THAT THE PROCEDURE HAS BEEN *) (* CALLED AGAIN, AND WE NOW HAVE THE ENTRY FROM THE *) (* SHIP-D DATA SET. *) (*--------------------------------------------------------*) BEGIN IF CALL_NUM =1 THEN (* FIRST DATE *) BEGIN HOLD_BUF.SINGLE_INT[1] := DBBUF.DBBUF_INT[4]; HOLD_BUF.SINGLE_INT[2] := DBBUF.DBBUF_INT[5]; END ELSE (* SECOND DATE *) BEGIN HOLD_BUF.SINGLE_INT[1] := DBBUF.DBBUF_INT[6]; HOLD_BUF.SINGLE_INT[2] := DBBUF.DBBUF_INT[7]; END; YEAR.D_YEAR := HOLD_BUF.DOUBLE_INT DIV 1000; (* ISOLATE YEAR *) HOLD := YEAR.D_YEAR * 1000; DAY.D_DAY := HOLD_BUF.DOUBLE_INT - HOLD; JDATE.DAY_YR.DAY := DAY.DAY[2]; (* DAY IN BITS 0-6 *) JDATE.DAY_YR.YEAR := YEAR.YEAR[2]; (* YEAR IN BITS 7-15 *) FMTCALENDAR (JDATE.DATE, FMTDATE); (*--------------------------------------------------------*) (* PUT THE FORMATTED DATE INTO THE OUTPUT BUFFER USED BY *) (* QUERY FOR THE REPORT OUTPUT LINE. AGAIN, CALL_NUM IS *) (* USED TO DETERMINE WHERE IN THE OUTPUT BUFFER TO PLACE *) (* THE VALUE. ALSO, IF CALL_NUM IS ONE THEN WE NEED TO *) (* SET THE DATA BASE NAME, THE DATA SET NAME, AND THE *) (* CALLAGAIN PARAMETERS IN ORDER TO GET THE ENTRY FROM *) (* THE SHIP-D DATA SET TO FORMAT THE SHIPPING DATE. *) (*--------------------------------------------------------*) IF CALL_NUM = 1 THEN (* ORDER-D DATA SET *) BEGIN M := 1; FOR N := 19 TO 35 DO BEGIN LINEBUF.BLINEBUF[N] := FMTDATE [M]; M := M + 1; END; DATA_BASE_NAME.BDB_NAME := 'ACCTS '; DATA_SET_NAME.BDS_NAME := 'SHIP-D '; CALLAGAIN := -1; (* 4 *) END ELSE (* SHIP-D DATA SET *) BEGIN M := 1; FOR N := 39 TO 55 DO BEGIN LINEBUF.BLINEBUF[N] := FMTDATE [M]; M := M + 1; END; CALLAGAIN := 0; END; END; BEGIN END. PASCAL Notes(* 1 *) Variant records can be used when it is necessary to access arrays that contain different data types. Variant records are allocated the maximum amount of storage needed for the record. Because of this it is possible to 'overlay' the fields so data can be accessed as different types. For example, DBBUF can now be accessed as character data if DBBUF_CHAR is referenced, or as a single word integer data if DBBUF_INT is referenced. (* 2 *) For proper storage (one character per byte), character data should be in a PACKED ARRAY OF CHAR (PACs). However, PACs have byte addresses and the data passed between QUERY and the user-defined procedure must have word addresses. When a PAC is declared as a field in a RECORD, it has a word address. (* 3 *) QUERY passes all parameters as word addresses. The parameters must be declared as VAR so that indirect addressing is performed, otherwise, the addresses will be taken as values. (* 4 *) When PASCAL assigns TRUE to a BOOLEAN, a one is placed in the left byte of the BOOLEAN value. When SPL tests TRUE or FALSE, it tests for odd or even respectively. The PASCAL TRUE will be considered FALSE. So CALLAGAIN is declared to be a SMALLINT and is assigned the SPL convention of minus one for TRUE and zero for FALSE. Additional CommentsIf you wish to use PASCAL I/O to help debug your procedure you must do it the following way: REWRITE (output, '$STDLIST'); WRITELN (output, 'message'); FORTRAN - MPROC Procedure$CONTROL FREE #-------------------------------------------------------# # YOU WILL NOT WANT TO INITIALIZE THE USL FILE IF YOU # # ARE COMPILING DIFFERENT SUBPROGRAMS INTO IT. # #-------------------------------------------------------# $CONTROL MAP, USLINIT, LOCATION $CONTROL SEGMENT=MULTISEG #------------------------------------------------------# # # # MPROC # # # # EXAMPLE OF A FORTRAN USER-DEFINED PROCEDURE, USED # # WITH A REPORT STATEMENT. # # # #------------------------------------------------------# # THIS PROCEDURE TAKES A JULIAN DATE AND CONVERTS IT # # TO "DAY, MONTH, YEAR" FORMAT BY CALLING THE MPE # # INTRINSIC FMTCALENDAR. # #------------------------------------------------------# # #------------------------------------------# # MPROC DECLARATION # #------------------------------------------# # SUBROUTINE MPROC (CALLAGAIN, PAGEEJECT, BASEIDS, DBBUF, & DSETLIST, DBLIST, LINEBUF, REGARR, & USERSTOR, USERPARAM, DBNAME, & DSNAME, CALLNUM, LINESLEFT, PAGENO, & NUMDSETS, NUMDBASES) # LOGICAL CALLAGAIN, PAGEEJECT INTEGER BASEIDS(130), DBBUF(2051), DSETLIST(53), DBLIST(53) INTEGER LINEBUF(69), REGARR(150), USERSTOR(64) INTEGER USERPARAM INTEGER DBNAME(13), DSNAME(8) INTEGER CALLNUM, LINESLEFT, PAGENO, NUMDSETS, NUMDBASES # # INTEGER FMTDATE (9) CHARACTER BFMTDATE (18) EQUIVALENCE (FMTDATE,BFMTDATE) # INTEGER*4 DHOLD, DDAY, DYEAR, HOLDYR INTEGER DAY(2), YEAR(2), HOLD(2) EQUIVALENCE (DDAY,DAY), (DYEAR,YEAR), (DHOLD,HOLD) # INTEGER INTDBNAME(13), INTDSNAME(8) CHARACTER*26 CHDBNAME CHARACTER*16 CHDSNAME EQUIVALENCE (INTDBNAME,CHDBNAME), (INTDSNAME,CHDSNAME) # LOGICAL JDATE # # SYSTEM INTRINSIC FMTCALENDAR # #--------------------------------------------------------# # THERE ARE TWO DATES IN THE DATA BASE TO BE FORMATTED. # # ONE IS IN THE ORDER-D DATA SET, THE OTHER IS IN THE # # SHIP-D DATA SET. BECAUSE THE SETS HAVE BEEN JOINED, # # IT IS POSSIBLE TO GET BOTH DATES AND FORMAT THEM. # # NOTE: IT IS THE APPLICATION'S RESPONSIBILITY TO KNOW # # WHERE IN THE DATA BUFFER THE VALUE IS LOCATED. # #--------------------------------------------------------# #--------------------------------------------------------# # THE DATE IS IN A TWO WORD INTEGER AND NEEDS TO BE RE- # # FORMATTED BEFORE PASSING TO FMTCALENDAR. # #--------------------------------------------------------# #--------------------------------------------------------# # IF CALLNUM IS ONE THEN WE CAN ASSUME THE ENTRY IS # # FROM THE ORDER-D DATA SET, SINCE IT IS THE FIRST DATA # # SET MENTIONED IN THE JOIN COMMAND. IF CALLNUM IS NOT # # ONE THEN WE CAN ASSUME THAT THE PROCEDURE HAS BEEN # # CALLED AGAIN, AND WE NOW HAVE THE ENTRY FROM THE # # SHIP-D DATA SET. # #--------------------------------------------------------# # IF (CALLNUM .GT. 1) GOTO 100 HOLD(1) = DBBUF(4) HOLD(2) = DBBUF(5) GOTO 200 # 100 HOLD(1) = DBBUF(6) HOLD(2) = DBBUF(7) # 200 DYEAR = DHOLD / 1000 HOLDYR = DYEAR * 1000 DDAY = DHOLD - HOLDYR JDATE[0:7] = BOOL (YEAR(2)) JDATE[7:9] = BOOL (DAY(2)) # DO 225 N = 1, 18 225 BFMTDATE(N) = " " # CALL FMTCALENDAR (JDATE, BFMTDATE) # #--------------------------------------------------------# # PUT THE FORMATTED DATE INTO THE OUTPUT BUFFER USED BY # # QUERY FOR THE REPORT OUTPUT LINE. AGAIN, CALL'NUM IS # # USED TO DETERMINE WHERE IN THE OUTPUT BUFFER TO PLACE # # THE VALUE. ALSO, IF CALL'NUM IS ONE THEN WE NEED TO # # SET THE DATA BASE NAME, THE DATA SET NAME, AND THE # # CALLAGAIN PARAMETERS IN ORDER TO GET THE ENTRY FROM # # THE SHIP-D DATA SET TO FORMAT THE SHIPPING DATE. # #--------------------------------------------------------# # IF (CALLNUM .GT. 1) GOTO 300 M = 1 DO 250 N = 10, 18 LINEBUF(N) = FMTDATE(M) 250 M = M + 1 CHDBNAME = "ACCTS " CHDSNAME = "SHIP-D " M = 1 DO 275 N = 1, 13 DBNAME(N) = INTDBNAME(M) 275 M = M + 1 M = 1 DO 285 N = 1, 8 DSNAME(N) = INTDSNAME(M) 285 M = M + 1 CALLAGAIN = .TRUE. GOTO 400 # 300 M = 1 DO 350 N = 21, 29 LINEBUF(N) = FMTDATE(M) 350 M = M + 1 CALLAGAIN = .FALSE. # 400 RETURN END QPROC ProcedureThe following examples show the QPROC user-defined procedure in two languages: SPL and COBOL. This procedure displays the parameter values when it is called from QUERY. You can interactively change the parameters which can be modified by user-defined procedures. The changes can affect the data returned. The procedure can be terminated before all the report entries have been processed by entering CONTROL-Y at an input prompt. The procedure will terminate after that sequence of parameter prompts is finished and the report command will terminate. SPL - QPROC Procedure$PAGE "QPROC: Program Description." $CONTROL MAP, USLINIT, SUBPROGRAM $CONTROL SEGMENT=QPROC <<***************************************************************>> << >> << Q P R O C >> << >> << SPL Example of QUERY user callable procedure >> << >> <<***************************************************************>> begin INTRINSIC PRINT, ASCII, DASCII, DEBUG, READ, BINARY; PROCEDURE QPROC(CALLAGAIN,PAGE'EJECT,BASE'IDS,DBBUF, DSET'LIST, DATA'BASE'LIST, LINEBUF, REGARR, USERSTOR, USERPARAM, DATA'BASE'NAME, DATA'SET'NAME, CALL'NUM, LINES'LEFT, PAGENO, NUM'DSETS, NUM'DBASES ); LOGICAL CALLAGAIN, PAGE'EJECT; INTEGER ARRAY BASE'IDS, DBBUF, DSET'LIST, DATA'BASE'LIST, LINEBUF, REGARR, USERSTOR, USERPARAM, DATA'BASE'NAME, DATA'SET'NAME; INTEGER CALL'NUM, LINES'LEFT, PAGENO, NUM'DSETS, NUM'DBASES; $PAGE "QPROC: Procedure Global Variables." begin <<-------------------------------------------------------------->> << LOCAL DECLARATIONS >> <<-------------------------------------------------------------->> <<------------------------------------------------>> <<-------- REDEFINE SOME PASSED PARAMETERS ------->> <<------------------------------------------------>> BYTE ARRAY BASE'IDS'B(*)=BASE'IDS; BYTE ARRAY DBBUF'B(*)=DBBUF; <<------------------------------------------------>> <<--------------- NEW LOCAL STORAGE -------------->> <<------------------------------------------------>> INTEGER NUM'CHAR; INTEGER I, J, K, L; << COUNTERS For DO-WHILE/DO-until >> INTEGER REG'INDEX; INTEGER END'PTR; INTEGER START'PTR; INTEGER DEC'PTR; << DECIMAL POINT >> ARRAY BUF(0:50 ); BYTE ARRAY BUF'B(*) = BUF; INTEGER BUF'INDX; ARRAY BUF1(0:50 ); BYTE ARRAY BUF1'B(*) = BUF1; LONG ARRAY TEMP'L(0:1 ); INTEGER ARRAY TEMP'I(*) = TEMP'L; $PAGE "QPROC: Outer block." <<**************************************************************>> << START OF QPROC >> <<**************************************************************>> PRINT( BUF, 0, %60 ); PRINT( BUF, 0, %60 ); ******************************************************************* move BUF'B(0): = " ******** PROCEDURE QPROC *******"; PRINT( BUF, -49, %40 ); <<-------------------------------------------------------------->> << CALL AGAIN >> <<-------------------------------------------------------------->> move BUF : = "-- CALL AGAIN -- (CHANGE to True or False)"; PRINT( BUF, 0, %40 ); PRINT( BUF, -42, %40 ); if CALLAGAIN = TRUE then move BUF := "--TRUE-- "; if CALLAGAIN = FALSE then move BUF := "--FALSE--"; PRINT( BUF, -9, %40 ); I := READ( BUF, -5 ); if I<>0 and (BUF'B = "T" or BUF'B = "t") then CALLAGAIN := TRUE; if I<>0 and (BUF'B = "F" or BUF'B = "f") then CALLAGAIN := FALSE; <<-------------------------------------------------------------->> << PAGE EJECT >> <<-------------------------------------------------------------->> move BUF := "-- PAGE EJECT -- (CHANGE to True or False)"; PRINT( BUF, 0, %40 ); PRINT( BUF, -42, %40 ); if PAGE'EJECT = TRUE then move BUF := "--TRUE-- "; if PAGE'EJECT = FALSE then move BUF := "--FALSE--"; PRINT( BUF, -9, %40 ); I := READ( BUF, -5 ); if I<>0 and (BUF'B = "T" or BUF'B = "t") then PAGE'EJECT:= TRUE; if I<>0 and (BUF'B = "F" or BUF'B = "f") then PAGE'EJECT:= FALSE; <<-------------------------------------------------------------->> << BASE ID'S >> <<-------------------------------------------------------------->> move BUF := "-- BASE ID'S --"; PRINT( BUF, 0, %40 ); PRINT( BUF, -15, %40 ); move BUF'B(0) := (79(" ") ); if BASE'IDS(1) <> %020040 then begin NUM'CHAR := ASCII( BASE'IDS(0), 10, BUF'B ); move BUF'B(NUM'CHAR) := BASE'IDS'B(2), (24 ); if BASE'IDS(14) <> %020040 then begin NUM'CHAR := ASCII( BASE'IDS(13), 10, BUF'B(35) ); move BUF'B(NUM'CHAR+35) := BASE'IDS'B(28), (24 ); end; end; PRINT( BUF, -79, %40 ); $PAGE <<-------------------------------------------------------------->> << DATA BASE RECORD BUFFER >> <<-------------------------------------------------------------->> move BUF := "-- DB BUFFER -- "; PRINT( BUF, 0, %40 ); PRINT( BUF, -15, %40 ); move BUF'B(0) := (79(" ") ); For I := 0 until 10 do ASCII( DBBUF(I), 8, BUF'B(I*7) ); PRINT (BUF, -79, %40 ); move BUF'B(0) := (79(" ") ); For I := 0 step 7 until 70 do begin BUF'B(I+1) := DBBUF'B(I/7*2 ); if BUF'B(I+1)<%40 or BUF'B(I+1)>%176 then BUF'B(I+1):=%40; BUF'B(I+4) := DBBUF'B(I/7*2+1 ); if BUF'B(I+4)<%40 or BUF'B(I+1)>%176 then BUF'B(I+4):=%40; end; PRINT (BUF, -79, %40 ); <<-------------------------------------------------------------->> << LIST OF DATA SETS >> <<-------------------------------------------------------------->> move BUF := "-- DATA SET LIST --"; PRINT( BUF, 0, %40 ); PRINT( BUF, -19, %40 ); move BUF'B(0) := (79(" ") ); J := 0; For I := 0 step 8 until 72 do begin NUM'CHAR := ASCII( DSET'LIST(J), 10, BUF'B(I) ); J := J+1; end; PRINT (BUF, -79, %40 ); <<-------------------------------------------------------------->> << LIST OF DATA BASES >> <<-------------------------------------------------------------->> move BUF := "-- DATA BASE LIST --"; PRINT( BUF, 0, %40 ); PRINT( BUF, -20, %40 ); move BUF'B(0) := (79(" ") ); J := 0; For I := 0 step 8 until 72 do begin NUM'CHAR := ASCII( DATA'BASE'LIST(J), 10, BUF'B(I) );J:=J+1;end; PRINT (BUF, -79, %40 ); <<-------------------------------------------------------------->> << PRINT LINE BUFFER >> <<-------------------------------------------------------------->> move BUF'B:="--LINE BUFFER -- "; PRINT( BUF, 0, %40 ); PRINT( BUF, -16, %40 ); PRINT( LINEBUF, -79, %40 ); I := READ( LINEBUF, -79 ); PRINT'REGARR: $PAGE <<-------------------------------------------------------------->> << ARRAY OF REGISTERS >> << (assume real numbers in registers) >> <<-------------------------------------------------------------->> move BUF := "-- REGISTER ARRAY -- "; PRINT( BUF, 0, %40 ); PRINT( BUF, -20, %40 ); move BUF'B(0) := (79(" ")); J := 0; For I := 0 step 13 until 78 do begin move TEMP'I := REGARR(J), (4 ); NUM'CHAR:=DASCII( FIXR(REAL(TEMP'L)), 10, BUF'B(I) ); J := J + 5; end; PRINT( BUF, -79, %40 ); I := READ( BUF, -79 ); END'PTR := 0; START'PTR := 0; DEC'PTR := 0; BUF'INDX := 0; REG'INDEX := 0; if J = 0 then go to SKIP'REGISTER'LOAD; << SEE BELOW >> <<---------------------------->> <<------- REGISTER LOAD ------>> <<---------------------------->> For J := 0 until I do begin if BUF'B(J) = "," then END'PTR := J; if BUF'B(J) = "," or J = I then begin if DEC'PTR = START'PTR then DEC'PTR := END'PTR; <<NO DECIMAL>> K := BINARY( BUF1'B, BUF'INDX ); if <> then K := 0; TEMP'L := LONG(REAL(K) ); For L:= 1 until (BUF'INDX-(DEC'PTR-START'PTR)) do begin TEMP'L := TEMP'L * .1L0; end; move REGARR(REG'INDEX) := TEMP'I, (4); REG'INDEX := REG'INDEX + 5; BUF'INDX := 0; DEC'PTR := J; end; if BUF'B(J) = "," then START'PTR := J+1; if BUF'B(J) = "," then DEC'PTR := J+1; if BUF'B(J) = "." then DEC'PTR := J; if BUF'B(J) <> "," and BUF'B(J) <> "." then begin move BUF1'B(BUF'INDX) := BUF'B(J), (1); BUF'INDX := BUF'INDX + 1; end; end; SKIP'REGISTER'LOAD: << SKIP REGISTER LOAD >> $PAGE <<-------------------------------------------------------------->> << USER STORE ARRAY >> <<-------------------------------------------------------------->> move BUF := "-- USER STORE -- "; PRINT( BUF, 0, %40 ); PRINT( BUF, -16, %40 ); PRINT( USERSTOR, -79, %40 ); I := READ( USERSTOR, -79 ); <<-------------------------------------------------------------->> << USER PARAMETER >> <<-------------------------------------------------------------->> move BUF := "-- USER PARAMETER -- (INTEGER) "; PRINT( BUF, -30, %40 ); NUM'CHAR := ASCII( USERPARAM, 10, BUF'B ); PRINT( BUF, 0, %40 ); PRINT( BUF, -NUM'CHAR, %40 ); GET'USERPARAM: I := READ( BUF, -7 ); if I <> 0 then begin USERPARAM := BINARY( BUF'B, I ); if <> then begin move BUF := "## DBINARY COULD NOT CONVERT ## "; PRINT( BUF, -31, %40 ); go to GET'USERPARAM; end; end; <<-------------------------------------------------------------->> << DATA BASE NAME >> <<-------------------------------------------------------------->> move BUF := "-- DATA BASE NAME -- "; PRINT( BUF, 0, %40 ); PRINT( BUF, -20, %40 ); PRINT( DATA'BASE'NAME, -26, %40 ); I := READ( DATA'BASE'NAME, -26 ); <<-------------------------------------------------------------->> << DATA SET NAME >> <<-------------------------------------------------------------->> move BUF := "-- DATA SET NAME -- "; PRINT( BUF, 0, %40 ); PRINT( BUF, -20, %40 ); PRINT( DATA'SET'NAME, -16, %40 ); I := READ( DATA'SET'NAME, -16 ); $PAGE <<-------------------------------------------------------------->> << CALL NUMBER >> <<-------------------------------------------------------------->> move BUF := "-- CALL NUMBER -- "; PRINT( BUF, 0, %40 ); PRINT( BUF, -17, %40 ); NUM'CHAR:=ASCII( CALL'NUM, 10, BUF'B ); PRINT( BUF, -NUM'CHAR, %40 ); <<-------------------------------------------------------------->> << LINES LEFT >> <<-------------------------------------------------------------->> move BUF := "-- LINES LEFT -- "; PRINT( BUF, 0, %40 ); PRINT( BUF, -16, %40 ); NUM'CHAR:=ASCII( LINES'LEFT, 10, BUF'B ); PRINT( BUF, -NUM'CHAR, %40 ); <<-------------------------------------------------------------->> << PAGE NUMBER >> <<-------------------------------------------------------------->> move BUF := "-- PAGE NUMBER -- "; PRINT( BUF, 0, %40 ); PRINT( BUF, -17, %40 ); NUM'CHAR:=ASCII( PAGENO, 10, BUF'B ); PRINT( BUF, -NUM'CHAR, %40 ); <<-------------------------------------------------------------->> << NUMBER OF DATA SETS >> <<-------------------------------------------------------------->> move BUF := "-- NUMBER OF DATA SETS -- "; PRINT( BUF, 0, %40 ); PRINT( BUF, -25, %40 ); NUM'CHAR:=ASCII( NUM'DSETS, 10, BUF'B ); PRINT( BUF, -NUM'CHAR, %40 ); <<-------------------------------------------------------------->> << NUMBER OF DATA BASES >> <<-------------------------------------------------------------->> move BUF := "-- NUMBER OF DATA BASES -- "; PRINT( BUF, 0, %40 ); PRINT( BUF, -26, %60 ); << DOUBLE SPACE AFTER LAST LINE >> NUM'CHAR:=ASCII( NUM'DBASES, 10, BUF'B ); PRINT( BUF, -NUM'CHAR, %40 ); end; end. COBOL - QPROC Procedure$CONTROL USLINIT,SUBPROGRAM,DYNAMIC IDENTIFICATION DIVISION. PROGRAM-ID. QPROC. AUTHOR. HP. *************************************************************** * * * Q P R O C * * * * COBOL Example of QUERY user callable procedure * * * *-------------------------------------------------------------* * QPROC requires the use of COBOLII's "Accept free" verb * * and should be compiled using a COBOLII compiler. Numeric * * fields are displayed in zoned format for simplicity of * * the example. * *************************************************************** ENVIRONMENT DIVISION. DATA DIVISION. WORKING-STORAGE SECTION. 01 BUF. 05 BUFX OCCURS 136 TIMES PIC X. 01 REG-NBR PIC S9(4) COMP. LINKAGE SECTION. 01 CALLAGAIN PIC S9(4) COMP. 01 PAGE-EJECT PIC S9(4) COMP. 01 BASE-IDS. 05 BASE-ID1 PIC S9(4) COMP. 05 BASE-NAME1 PIC X(24). 05 BASE-ID2 PIC S9(4) COMP. 05 BASE-NAME2 PIC X(24). 05 BASE-ID-OTHERS PIC X(208). 01 DBBUF. 05 DBBUF-70 PIC X(70). 05 DBBUFI REDEFINES DBBUF-70 OCCURS 35 TIMES PIC S9(4) COMP. 05 DBBUF-OTHER PIC X(4026). 01 DSET-LIST. 05 DSET OCCURS 100 TIMES PIC S9(4) COMP. 01 DATA-BASE-LIST. 05 DBASE OCCURS 100 TIMES PIC S9(4) COMP. 01 LINEBUF. 05 LINEBUF-70 PIC X(70). 05 LINEBUF-OTHER PIC X(66). 01 REGARR. 05 REG OCCURS 30 TIMES PIC S9(18) COMP-3. 01 USERSTOR. 05 USERSTOR-70 PIC X(70). 05 USERSTOR-OTHER PIC X(58). 01 USERPARAM PIC S9(4) COMP. 01 DATA-BASE-NAME PIC X(26). 01 DATA-SET-NAME PIC X(16). 01 CALL-NUM PIC S9(4) COMP. 01 LINES-LEFT PIC S9(4) COMP. 01 PAGENO PIC S9(4) COMP. 01 NUM-DSETS PIC S9(4) COMP. 01 NUM-DBASES PIC S9(4) COMP. $PAGE "QPROC: Procedure Division." *********************************************************** * PROCEDURE DIVISION * *********************************************************** PROCEDURE DIVISION USING CALLAGAIN, PAGE-EJECT, BASE-IDS, DBBUF, DSET-LIST, DATA-BASE-LIST, LINEBUF, REGARR, USERSTOR, USERPARAM, DATA-BASE-NAME, DATA-SET-NAME, CALL-NUM, LINES-LEFT, PAGENO, NUM-DSETS, NUM-DBASES. BEGIN-QPROC. DISPLAY SPACE. DISPLAY SPACE. DISPLAY " ******* PROCEDURE QPROC ******* " *---------------------------------------------------------* * CALL AGAIN * *---------------------------------------------------------* DISPLAY SPACE. DISPLAY "-- CALL AGAIN -- (CHANGE to True or False) ". MOVE SPACE TO BUF. ACCEPT BUF. IF BUFX(1) = "T" OR BUFX(1) = "t" THEN MOVE -1 TO CALLAGAIN. IF BUFX(1) = "F" OR BUFX(1) = "f" THEN MOVE 0 TO CALLAGAIN. *--------------------------------------------------------* * PAGE EJECT * *--------------------------------------------------------* DISPLAY SPACE. DISPLAY "-- PAGE EJECT -- (CHANGE to True or False) ". MOVE SPACE TO BUF. ACCEPT BUF. IF BUFX(1) = "T" OR BUFX(1) = "t" THEN MOVE -1 TO PAGE-EJECT. IF BUFX(1) = "F" OR BUFX(1) = "f" THEN MOVE 0 TO PAGE-EJECT. *--------------------------------------------------------* * BASE ID'S * *--------------------------------------------------------* DISPLAY "-- BASE ID'S --". IF BASE-ID2 = 8224 THEN DISPLAY BASE-ID1, " ", BASE-NAME1 ELSE DISPLAY BASE-ID1, " ", BASE-NAME1, " ", BASE-ID2, " ", BASE-NAME2. *--------------------------------------------------------* * DATA BASE RECORD BUFFER * *--------------------------------------------------------* DISPLAY SPACE. DISPLAY "-- DB BUFFER -- (Decimal and Character)". DISPLAY DBBUFI(1), " ", DBBUFI(2), " ", DBBUFI(3), " ", DBBUFI(4), " ", DBBUFI(5), " ", DBBUFI(6), " ", DBBUFI(7), " ", DBBUFI(8), " ", DBBUFI(9), " ", DBBUFI(10). DISPLAY DBBUF-70. *--------------------------------------------------------* * LIST OF DATA SETS * *--------------------------------------------------------* DISPLAY SPACE. DISPLAY "-- DATA SET LIST--". DISPLAY DSET(1), " ", DSET(2), " ", DSET(3), " ", DSET(4), " ", DSET(5), " ", DSET(6), " ", DSET(7), " ", DSET(8), " ", DSET(9), " ". *--------------------------------------------------------* * LIST OF DATA BASES * *--------------------------------------------------------* DISPLAY SPACE. DISPLAY "-- DATA BASE LIST--". DISPLAY DBASE(1), " ", DBASE(2), " ", DBASE(3), " ", DBASE(4), " ", DBASE(5), " ", DBASE(6), " ", DBASE(7), " ", DBASE(8), " ", DBASE(9), " ". *--------------------------------------------------------* * PRINT LINE BUFFER * *--------------------------------------------------------* DISPLAY SPACE. DISPLAY "-- LINE BUFFER --". DISPLAY LINEBUF-70. ACCEPT LINEBUF. *--------------------------------------------------------* * PRINT REGISTER ARRAY * * (Packed decimal is assumed) * *--------------------------------------------------------* DISPLAY SPACE. DISPLAY-REGISTERS. DISPLAY " ". DISPLAY "-- REGISTER ARRAY -- (0-8 Displayed)". DISPLAY REG(1), " ", REG(2), " ", REG(3), " ". DISPLAY REG(4), " ", REG(5), " ", REG(6), " ". DISPLAY REG(7), " ", REG(8), " ", REG(9), " ". ACCEPT-REGISTERS. DISPLAY "CHANGE A REGISTER (Yes/No)?". MOVE SPACE TO BUF. ACCEPT BUF. IF BUFX(1) = "Y" OR BUFX(1) = "y" THEN DISPLAY "ENTER REGISTER NUMBER (0-29)?" ACCEPT REG-NBR FREE IF REG-NBR > -1 AND REG-NBR < 31 THEN DISPLAY "ENTER VALUE FOR REGISTER" ADD 1 TO REG-NBR ACCEPT REG(REG-NBR) FREE. IF BUFX(1) = "Y" OR BUFX(1) = "y" THEN GO TO DISPLAY-REGISTERS. *--------------------------------------------------------* * USER STORE ARRAY * *--------------------------------------------------------* DISPLAY SPACE. DISPLAY "-- USER STORE --". DISPLAY USERSTOR-70. ACCEPT USERSTOR. *--------------------------------------------------------* * USER PARAMETER * *--------------------------------------------------------* DISPLAY SPACE. DISPLAY "-- USER PARAMETER --". DISPLAY USERPARAM. ACCEPT USERPARAM FREE. *--------------------------------------------------------* * DATA BASE NAME * *--------------------------------------------------------* DISPLAY SPACE. DISPLAY "-- DATA BASE NAME --". DISPLAY DATA-BASE-NAME. MOVE " " TO DATA-BASE-NAME. ACCEPT DATA-BASE-NAME. *--------------------------------------------------------* * DATA SET NAME * *--------------------------------------------------------* DISPLAY SPACE. DISPLAY "-- DATA SET NAME --". DISPLAY DATA-SET-NAME. ACCEPT DATA-SET-NAME. *--------------------------------------------------------* * CALL NUMBER * *--------------------------------------------------------* DISPLAY SPACE. DISPLAY "-- CALL NUMBER --". DISPLAY CALL-NUM. *--------------------------------------------------------* * LINES LEFT * *--------------------------------------------------------* DISPLAY SPACE. DISPLAY "-- LINES LEFT --". DISPLAY LINES-LEFT. *--------------------------------------------------------* * PAGE NUMBER * *--------------------------------------------------------* DISPLAY SPACE. DISPLAY "-- PAGE NUMBER --". DISPLAY PAGENO. *--------------------------------------------------------* * NUMBER OF DATA SETS * *--------------------------------------------------------* DISPLAY SPACE. DISPLAY "-- NUM-DSETS --". DISPLAY NUM-DSETS. *--------------------------------------------------------* * NUMBER OF DATA BASES * *--------------------------------------------------------* DISPLAY SPACE. DISPLAY "-- NUMBER OF DATA BASES --". DISPLAY NUM-DBASES. GOBACK.
|