 |
» |
|
|
|
|  | |
This appendix documents a feature of the QUERY subsystem which is
used primarily by the programmer or data base administrator.
QUERY allows you to specify your own procedure(s) which will enable a
report to read or write from another data base, data set, or file,
modify registers, or perform other specialized tasks not provided
by QUERY.
The name of the user-defined procedure cannot be the name of any data
item in the data sets referenced by the retrieval command. User-defined procedures can be called from either a header, group,
total, or detail statement within the REPORT command, and can be
written in SPL, COBOL, FORTRAN or PASCAL. Note that programming
errors in user-defined procedures will cause QUERY to terminate. The
procedure must be stored
in one of the segmented libraries. These libraries
are searched in the following order: 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:
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 PROCEDURES
|
There 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 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 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.
|
|
