Procedures
MPE documents | |
 Complete PDF | |
| Table of Contents | |
| E0300 Edition 7 ♥ | |
| E1098 Edition 6 |
group
account
system
Native 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 B
For 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
END
The following is not allowed:
EDIT masks
ADD
AVERAGE
COUNT
If 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
- *CALLAGAIN
is a flag telling QUERY to call this procedure again. QUERY will stop calling the procedure only when this parameter is returned FALSE. This flag is for the particular report statement being processed. For example, if D1,PROC,/ + CALLAGAIN = T, then the procedure will be called again from this detail statement until CALLAGAIN is set to false. The default value is FALSE.
- *PAGE'EJECT
is a flag telling QUERY to perform a page eject upon return. If you determine by the LINES'LEFT parameter that there are not enough lines left on the page to perform the desired task, you can assign TRUE to this parameter. In this case, the CALLAGAIN parameter may also be returned and the procedure will be executed on the new page following headers (if any). This parameter can also be used if a page eject is desired after execution. The default value is FALSE.
- BASE'IDS
is the data base name of the data base(s) currently being accessed. Each base id is 26 bytes (13 words) long for a total of 10 base id's. Each name is preceded by the BASE'ID number (1 word) assigned by IMAGE.
- DBBUF
is an array which holds the values of the data items to which you have access for a specific data set for the current entry or compound entry being output. The values of the data set are placed in DBBUF as follows:
If the FIND command, or a SUBSET of a FIND command, was used to select the entries for reporting, then the data set that the FIND or SUBSET command referenced will be used.
If the MULTIFIND command or a SUBSET of a MULTIFIND was used, then the first data set mentioned in the JOIN command is used.
On QUERY version B.01.10 and later, the length of the entry being passed to you is placed in the last word of this array (word 2051). If the entry is a null entry, from a MULTIFIND following a join containing an @ sign, this length will be set to zero and DBBUF will be filled with ASCII nulls.
If you want a different entry from any data set mentioned in the FIND, SUBSET, or JOIN command, set the DATA'BASE'NAME and DATA'SET'NAME parameters with the appropriate names and set the CALLAGAIN parameter to TRUE. The items from the desired data set will be returned to your procedure from QUERY.
- DSET'LIST
contains the data set numbers of those data sets accessed by the FIND, MULTIFIND, or SUBSET command.
- DATA'BASE'LIST
contains the position of the data base name in the parameter BASE'IDS for the corresponding entry in the parameter DSET'LIST. For example:
A zero (0) in DATA'BASE'LIST(2) means that the data set in DSET'LIST(2) belongs to the first data base named in BASE'IDS.
- *LINEBUF
is the buffer that QUERY uses to build each line of REPORT. For each line of output that is generated, those statements corresponding to that line which contain a print element or which call a user procedure that modifies LINEBUF, operate cummulatively on LINEBUF to create the line of output. If LINEBUF has been changed by the procedure, it will print when all report statements of that level have been processed. (For example, it will be printed when all D1 statments have been processed.) On QUERY versions prior to C.00.00, LINEBUFF will print only if there is another statement of the same level that contains a print element.
- *REGARR
contains the 30 registers, with 5 words allocated for each register. You must know the types of the registers that you access. The types used by QUERY are:
P20: uses all five words (right-justified) R2: uses the leftmost 2 words (left-justified) R4: uses the leftmost 4 words (left-justified)The section on registers in the REPORT command description explains how QUERY determines the type of a register.- *USERSTOR
is a global scratch area for user data which is shared by all of your procedures that are referenced in any one report. Not initialized.
- *USERPARAM
is where the value of your parameter is stored. One use of this parameter might be to indicate where in the output buffer to place the value. For example,
D1,PROC,/; D1,PROC (20),/; ...- *DATA'BASE'NAME
is set with the correct data base name if data item values are needed from a data set(s) other than the default data set(s), (see above parameter DBBUF) or data item values are needed for data items not mentioned in the report. The name should be upper case, left-justified and, if necessary, qualified with group and account. The rest of the array should be filled with blanks. The parameter DATA'SET'NAME must also be set. If the specified name is invalid, QUERY will give the message:
NO RETRIEVAL WAS MADE FROM THE DATA BASE XX, WHICH WAS NAMED IN A USER PROCEDURE.
- *DATA'SET'NAME
is set with the correct data set name if data item values are needed from a data set(s) other than the default data set(s) (see above parameter DBBUF), or data item values are needed of data items other than those mentioned in the report. The name should be upper case and left-justified and the rest of the array should be filled with blanks. The parameter DATA'BASE'NAME must also be set. If the specified name is invalid, QUERY will give the following error message:
THE DATA SET XX, NAMED IN A USER PROCEDURE, IS NOT IN DATA BASE YY
- CALL'NUM
is the number of times that a procedure has been called from the same level of report statments. The first time the procedure is called the number will be 1. CALL'NUM is reset to 1 after all the report statements of a particular level are processed. For example (assume CALLAGAIN is always FALSE):
D1,PROC1,1 << call'num = 1 >> D1,PROC2,1 << call'num = 2 >> D1,ITEM,10 D2,ITEM,10 D2,PROC3,1 << call'num = 1 >>- LINES-LEFT
is the number of lines that are left on the page.
- PAGENO
tells which page is currently being output.
- NUM'DSETS
is the number of data sets that are accessed by REPORT.
- NUM'DBASES
is the number of data bases open by the current user of QUERY.
Examples
The following examples show two user-defined procedures: MPROC and QPROC. MPROC is shown in four languages and QPROC is shown in two languages.
MPROC Procedure
The 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 MULTIREP
The 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"
END
The 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 Notes
The 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 Comments
If 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 Procedure
The 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.
|
Appendix F USER-DEFINED PROCEDURES |
Table of Contents |