175 lines
6.3 KiB
Plaintext
175 lines
6.3 KiB
Plaintext
|
SUBROUTINE U0192(proc, ibn, pib, sib, ip, obn, pob, sob)
|
||
|
|
*******************************************************************************
|
||
|
|
*
|
||
|
|
* This user exit provides output formatting.
|
||
|
|
*
|
||
|
|
* Module %M% Version %I% Date %H%
|
||
|
|
*
|
||
|
|
* (c) Copyright 1998 Ardent Software Inc. - All Rights Reserved
|
||
|
|
* This is unpublished proprietary source code of Ardent Software Inc.
|
||
|
|
* The copyright notice above does not evidence any actual or intended
|
||
|
|
* publication of such source code.
|
||
|
|
*
|
||
|
|
*******************************************************************************
|
||
|
|
*
|
||
|
|
* Maintenence log - insert most recent change descriptions at top
|
||
|
|
*
|
||
|
|
* Date.... GTAR# WHO Description.........................................
|
||
|
|
* 10/14/98 23801 SAP Change copyrights.
|
||
|
|
* 07/25/88 - - Maintenence log purged at 5.2.1, see release 5.1.10.
|
||
|
|
*
|
||
|
|
*******************************************************************************
|
||
|
|
* This user exit provides output formatting.
|
||
|
|
* there are two kinds of format items, those which control spacing and those
|
||
|
|
* which output data. The data may be constants or data read and (optionally)
|
||
|
|
* converted.
|
||
|
|
******************************************************************************
|
||
|
|
|
||
|
|
DIM parse(200)
|
||
|
|
line = ""
|
||
|
|
output = ""
|
||
|
|
DIM words(10)
|
||
|
|
linefeed = CHAR(10)
|
||
|
|
pflag = 0
|
||
|
|
LOOP
|
||
|
|
REMOVE line FROM proc SETTING x
|
||
|
|
format = TRIM( line )
|
||
|
|
WHILE format[1,4] # "-> T" DO
|
||
|
|
BEGIN CASE
|
||
|
|
* 'Xnn' places nn blanks on the output
|
||
|
|
CASE format[1,1] = "X"
|
||
|
|
IF format[2,2] MATCHES '1n0n' THEN
|
||
|
|
output := SPACE(format[2,2])
|
||
|
|
END
|
||
|
|
* Snn places nn line feeds in the output
|
||
|
|
CASE format[1,1] = "S"
|
||
|
|
IF format[2,2] MATCHES '1n0n' THEN
|
||
|
|
output := STR( linefeed, format[2,2])
|
||
|
|
END
|
||
|
|
* 'P' places a form feed in the output, resets the current
|
||
|
|
* page and line counters and blanks out the heading
|
||
|
|
CASE format = "P"
|
||
|
|
output := CHAR(12)
|
||
|
|
PRINTER RESET
|
||
|
|
CASE format = "L"
|
||
|
|
PRINTER ON
|
||
|
|
pflag = 1
|
||
|
|
CASE format[1,1] = "H"
|
||
|
|
MATPARSE words FROM format," "
|
||
|
|
IF words(1)[2,2] MATCHES "1n0n" THEN
|
||
|
|
pad = words(1)[2,2]
|
||
|
|
IF LEN(output) < pad THEN
|
||
|
|
output := SPACE(pad - len(output))
|
||
|
|
END ELSE
|
||
|
|
output = output[1,pad]
|
||
|
|
END
|
||
|
|
END
|
||
|
|
pos = LEN(words(1))
|
||
|
|
string = format[pos+2,99999]
|
||
|
|
CALL $INDIRECT( temp, pib, sib, pob, sob, obn, string)
|
||
|
|
output := temp
|
||
|
|
|
||
|
|
|
||
|
|
CASE format[1,1] = "V" or format[1,1] = "*"
|
||
|
|
* The V format gets and PRINTs a value
|
||
|
|
* the format of the format code is...
|
||
|
|
* Vnn file-ref item-ref field-ref
|
||
|
|
* The references may be explicit or indirect through the
|
||
|
|
* primary input buffer or either output buffer.
|
||
|
|
* See your 'PROC' manual for a discussion of indirect references.
|
||
|
|
* The * format behaves much like a V format with the exception
|
||
|
|
* that the amc specification is a reference to a named value
|
||
|
|
* and that the conversion in the dictionary is applied to the data
|
||
|
|
* before they are printed.
|
||
|
|
MATPARSE words FROM format," "
|
||
|
|
* take care of nn
|
||
|
|
pos = 2
|
||
|
|
IF words(1)[2,2] MATCHES '1n0n' THEN
|
||
|
|
IF LEN(output) < words(1)[2,2] THEN
|
||
|
|
output := SPACE(words(1)[2,2])
|
||
|
|
END ELSE
|
||
|
|
output = output[1,words(1)[2,2]]
|
||
|
|
END
|
||
|
|
END
|
||
|
|
|
||
|
|
* now resolve fileref
|
||
|
|
fileref = words(pos)
|
||
|
|
pos += 1
|
||
|
|
CALL $INDIRECT( temp, pib, sib, pob, sob, obn, fileref)
|
||
|
|
fileref = temp
|
||
|
|
filename = temp
|
||
|
|
IF temp = "DICT" THEN
|
||
|
|
fileref = words(pos)
|
||
|
|
pos += 1
|
||
|
|
CALL $INDIRECT( temp, pib, sib, pob, sob, obn, fileref)
|
||
|
|
fileref = temp
|
||
|
|
Dstr = "DICT"
|
||
|
|
END ELSE
|
||
|
|
IF temp[1,1] = "*" THEN
|
||
|
|
Dstr = "DICT"
|
||
|
|
END ELSE
|
||
|
|
Dstr = ""
|
||
|
|
END
|
||
|
|
END
|
||
|
|
|
||
|
|
* now resolve itemref
|
||
|
|
itemref = words(pos)
|
||
|
|
pos += 1
|
||
|
|
CALL $INDIRECT( temp, pib, sib, pob, sob, obn, itemref)
|
||
|
|
itemref = temp
|
||
|
|
|
||
|
|
* now resolve amcref
|
||
|
|
amcref = words(pos)
|
||
|
|
CALL $INDIRECT( temp, pib, sib, pob, sob, obn, amcref)
|
||
|
|
amcref = temp
|
||
|
|
* if we are a V item we're almost there, if a * item we have to go
|
||
|
|
* to the dict
|
||
|
|
* first do some stuff common to both kinds (like get the data)
|
||
|
|
|
||
|
|
OPEN Dstr,fileref TO fvU0192 ELSE
|
||
|
|
PRINT "unable to open ":Dstr:" ":fileref
|
||
|
|
RETURN
|
||
|
|
END
|
||
|
|
READ record FROM fvU0192,itemref ELSE
|
||
|
|
PRINT "unable to read ":itemref:" FROM ":fileref
|
||
|
|
RETURN
|
||
|
|
END
|
||
|
|
|
||
|
|
|
||
|
|
IF format[1,1] = "*" THEN
|
||
|
|
OPEN "DICT",filename TO fvdU0192 ELSE
|
||
|
|
PRINT "1UNABLE TO OPEN DICT ":filename
|
||
|
|
RETURN
|
||
|
|
END
|
||
|
|
|
||
|
|
READ drec FROM fvdU0192,amcref ELSE
|
||
|
|
PRINT "UNABLE TO READ DICT ":fileref:" ":amcref
|
||
|
|
RETURN
|
||
|
|
END
|
||
|
|
IF drec<1>[1,1] = "D" THEN
|
||
|
|
conv = drec<3>
|
||
|
|
* microdata only returns first value
|
||
|
|
loc = drec<2>
|
||
|
|
output := oconv(record<loc,1>,conv)
|
||
|
|
END ELSE
|
||
|
|
* had best be an I descriptor
|
||
|
|
@RECORD = record
|
||
|
|
temp = ITYPE(drec)
|
||
|
|
output:=oconv(temp,drec<3>)
|
||
|
|
END
|
||
|
|
END ELSE
|
||
|
|
output := record<amcref>
|
||
|
|
END
|
||
|
|
|
||
|
|
END CASE
|
||
|
|
IF x = 0 THEN proc = "-> T" ;* handle bad endfile condition (mr2369)
|
||
|
|
REPEAT
|
||
|
|
IF format[5,1] = "+" THEN
|
||
|
|
PRINT output:
|
||
|
|
END ELSE
|
||
|
|
PRINT output
|
||
|
|
END
|
||
|
|
IF pflag THEN PRINTER off
|
||
|
|
RETURN
|
||
|
|
END
|