Difference between revisions of "UDDS File Display/Update"
From MidrangeWiki
(→DISV CLE) |
(→DISF CLE) |
||
| Line 12,734: | Line 12,734: | ||
<pre> | <pre> | ||
| + | |||
| + | /* CHECK FILE TYPE */ | ||
| + | |||
| + | PGM (&DISF &TYPE &PHY &PHYLIB) | ||
| + | |||
| + | |||
| + | DCL &DISF *CHAR 10 | ||
| + | DCL &TYPE *CHAR 1 | ||
| + | DCL &PHY *CHAR 10 | ||
| + | DCL &PHYLIB *CHAR 10 | ||
| + | DCLF KF | ||
| + | |||
| + | OVRDBF FILE(KF) TOFILE(QTEMP/&DISF) | ||
| + | OPNDBF FILE(KF) OPTION(*INP) | ||
| + | RCVF | ||
| + | CHGVAR &TYPE &APFTYP | ||
| + | |||
| + | IF (&TYPE *EQ 'L') DO | ||
| + | CHGVAR &PHY &APBOF | ||
| + | CHGVAR &PHYLIB &APBOL | ||
| + | ENDDO | ||
| + | |||
| + | CLOF OPNID(KF) | ||
| + | ENDPGM | ||
</pre> | </pre> | ||
Revision as of 08:50, 28 October 2018
UDDS UNDER CONSTRUCTION MORE CODE TO BE ADDED SOON
The manual that describes the 5250 data stream is 5494 Remote Control Unit, Functions Reference. SC30-3533-04 (topic 15) [1]
The purpose of this program is to demo an example of a program using UDDS.
It shows file data, but is limited to 6048 max rcdlen.
Use the code below at your own risk, no warranty is expressed or implied or even that the code is functional.
I am also inculding wrapper programs to make the displayer more useful, but there is no 'make' instruction. I am assuming you know enough about compiling source to figure it out for yourself. Once compiled the command to run it is 'DSPFL yourlib/yourfile '
DISP RPG
H*eywords++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++Comments+++++++++++
H OPTION(*NODEBUGIO)
H DFTACTGRP(*NO) ACTGRP(*CALLER) DFTNAME(DISP )
F*
F* LIMITED TO MAXIMUM FILE LENGTH OF 2048
F* TEST
FFFD IF E DISK
FDISPF CF F 803 WORKSTN
F*
F INFDS(INFDS)
FINPUTK IF F32766 800AIDISK KEYLOC(1)
F EXTIND(*INU1)
F INFDS(INFDK)
FINPUTR IF F32766 DISK EXTIND(*INU2)
F INFDS(INFDR)
*
D A S 255 WORK RU
D RU S 255 varying
D RW S 1 ROW 1 byte binary
D CL S 1 COL 1 byte binary
D FNC S 1
D OUTLEN S 2
D INLEN S 2
D IPL S 5 0
D ROW S 3 0
D XROW S 3 0
D COL S 3 0
D KEYSOK S 1
D LENDSC S 3 0
D LENWRK S 5 0
D STRX S 5 0
D ENDX S 5 0
D VX S 5 0
D X S 5 0
D X1 S 5 0
D X2 S 5 0
D XX S 5 0
D XP S 5 0
D MX S 5 0
D ONCE S 1
D RBA S 2
D LF S 5 0
D ST S 5 0
D Y S 5 0
D Z S 5 0
D OFF S 5 0
D SUPZ S 1
D NUMFLD S 5 0
D WX S 5 0
D NUMKEY S 5 0
D NUMFKY S 5 0
D SCRST S 10
D SCRSTN S 1
D KEYA S 800
D RRNA S 11 0
D RRN S 11 0
D REHEAD S 1
D NEWRU S 1
D WRTRRN S 1
D LVX S 5 0
D LVL S 5 0
D K1 S 5 0
D K2 S 5 0
D Z1 S 5 0
D W S 5 0
D WK2 S 2
D MSSG S 32
*
D BASE S 5 0
D INZ S 1
D FILE S 10
D LIB S 10
D MBR S 10
D RCDL S 5 0
D ACCTP S 1
D RLEN S 5 0
D RLENTH S 5
D LENF S 5 0
D DS
D TEXT500 500
D LVW 10 DIM(50) overlay(TEXT500:1)
D TEXT800 S 800
D KW S 800
D DS
D WRK11 1 11
D NUM11 1 11S 0
D DS
D NUSA 1 60
D NUS 1 60S 0
D DS
D NUPA 1 60
D NUP 29 60P 0
D WRU S 61
D WRX S 64
D WRXWRD C '0 -
D -'
D WRSWRD C '0 -
D -'
D WRV S 60 varying
D FLT14 S 14
D FLT23 S 23
* SET FILE SIZE INCREMENTS (64 OF THEM)
D SZ S 5 0 DIM(64)
D S S 5 0 DIM(9000) START OF FLD
D E S 5 0 DIM(9000) END OF FLD
D Q S 5 0 DIM(9000) BYTES IN FIELD
D L S 5 0 DIM(9000) LENGTH OF FLD
D C S 3 0 DIM(9000) DEC DIGITS
D P S 3 0 DIM(9000) DEC PRECISION
D B S 2 DIM(9000) ASCEND BUFFER ADD
D I S 2 DIM(9000) FLD FMT
D N S 10 DIM(9000) FLD NAME
D T S 1 DIM(9000) FLD TYPE
D V S 1 DIM(9000) VARYING
D KY S 1 DIM(9000) KEYED
D KE S 10 DIM(128) KEY FLDS
D R S 3 0 DIM(9000) KEY FLD START
D K S 1 DIM(800) KEY
D NA S 1 DIM(10) NAME WORK
D NU S 1 DIM(60) NUM. WORK
D LV S 10 DIM(50) SCREEN LEVELS
D MSG S 32 DIM(8) CTDATA PERRCD(1) MESSAGES
D CNS S 50 DIM(2) CTDATA PERRCD(1)
D CRS S 1 DIM(16) CTDATA PERRCD(16)
D DS
D D 1 2048
D DIM(2048) INCOMING DATA
D DA 1 16
D DB 17 32
D DC 33 64
D DD 65 96
D DE 97 128
D DF 129 160
D DG 161 192
D DH 193 224
D DI 225 256
D DJ 257 288
D DK 289 320
D DL 321 352
D DM 353 384
D DN 385 416
D DZ 417 448
D DO 449 480
D DP 481 512
D DQ 513 544
D DR 545 576
D DS 577 608
D DT 609 640
D DU 641 672
D DV 673 704
D DW 705 736
D DX 737 768
D DY 769 800
D D0 801 832
D D1 833 864
D D2 865 896
D D3 897 928
D D4 929 960
D D5 961 992
D D6 993 1024
D DBA 1025 1056
D DCA 1057 1088
D DDA 1089 1120
D DEA 1121 1152
D DFA 1153 1184
D DGA 1185 1216
D DHA 1217 1248
D DIA 1249 1280
D DJA 1281 1312
D DKA 1313 1344
D DLA 1345 1376
D DMA 1377 1408
D DNA 1409 1440
D DOA 1441 1472
D DPA 1473 1504
D DQA 1505 1536
D DRA 1537 1568
D DSA 1569 1600
D DTA 1601 1632
D DUA 1633 1664
D DVA 1665 1696
D DWA 1697 1728
D DXA 1729 1760
D DYA 1761 1792
D DZA 1793 1824
D D0A 1825 1856
D D1A 1857 1888
D D2A 1889 1920
D D3A 1921 1952
D D4A 1953 1984
D D5A 1985 2016
D D6A 2017 2048
D DS
D ID 1 800
D DIM(800) INCOMING DATA
D IDA 1 800
D ID0 1 80
D ID1 81 160
D ID2 161 240
D ID3 241 320
D ID4 321 400
D ID5 401 480
D ID6 481 560
D ID7 561 640
D ID8 641 720
D ID9 721 800
D DS
D BIN 1 2B 0
D HX1 2 2
D HX2 1 2
D DS
D PCK 1 1P 0
D PCK1 1 1
D DS
D SGN 1 1S 0
D SGN1 1 1
D DS
D BIN4 1 4B 0
D BY4 1 4
D DS
D BIN2 1 2B 0
D BY2 1 2
D DS
D FLT4 1 4F
D FL4 1 4
D DS
D FLT8 1 8F
D FL8 1 8
D INFDK DS
D F1 83 92
D L1 93 102
D M1 129 138
D R1 125 126B 0
D A1 160 160
D LOP1 260 260
D KEY_LEN 393 394I 0 Key length
D RN1 397 400B 0
D LKY 401 1200
D INFDR DS
D F2 83 92
D L2 93 102
D M2 129 138
D R2 125 126B 0
D A2 160 160
D LOP2 260 260
D RN2 397 400B 0
D*
D INFDS DS
D CURLOC 370 371
D DS
D KEYLN 1 4S 0
D KEYLNA 1 4
DDISP PR
D 1
D 1
D 4
D 1
D 500
D 5
D 800
DDISP PI
D ALL 1
D RTN 1
D KEYLNG 4
D UPDF 1
D SCNLV 500
D SCNLVL 5
D SCNKEY 800
D @LOOP C '1'
D SND C X'71' SEND TO DISP
D SNR C X'73' SND/RCV
D RED C X'42' READ
D RDM C X'52' READ MTD
D ESC C X'04' ESCAPE
D CLR C X'40' CLEAR UNIT
D CC1 C X'00' CNTRL CHAR
D CC2 C X'08' CNTRL CHAR
D SBA C X'11' SET BUFF ADR
D IC C X'13' INSERT CURS
D WTD C X'11' WRITE TO DSP
D WER C X'21' WRITE ERROR
D SF C X'1D' START FLD
D ATC C X'20' ATTR CHAR
D ATN C X'24' ATTR NUM
D X00 C X'00'
D X01 C X'01'
D X02 C X'02'
D X03 C X'03'
D X0D C X'0D'
D X0F C X'0F'
D X000 C X'0000'
D X1F C X'1F'
D X20 C X'20' SCRN ATT NORMAL
D X22 C X'22' SCRN ATTR HI
D X25 C X'25'
D X26 C X'26'
D X31 C X'31' CMD 1 KEY
D X32 C X'32' CMD 2 KEY
D X33 C X'33' CMD 3 KEY
D X36 C X'36' CMD 6 KEY
D X37 C X'37' CMD 7 KEY
D X38 C X'38' CMD 8 KEY
D X39 C X'39' CMD 9 KEY
D X3B C X'3B' CMD11 KEY
D XB7 C X'B7' CMD19 KEY
D XB8 C X'B8' CMD20 KEY
D X40 C X'40'
D X43 C X'43'
D X47 C X'47'
D X60 C X'60'
D X67 C X'67'
D X9F C X'9F'
D XF0 C X'F0'
D XD0 C X'D0'
D X4000 C X'4000'
D X4800 C X'4800' FF ALPHA
D X4F06 C X'4F06' FF NUMERIC
D X6000 C X'6000' FF ALPHA
D X6706 C X'6706' FF NUMERIC
D CLRWTD C X'044004112000' INCLUDES ESC CHARS
D RDDSP C X'0411200804524000' REAB FROM DISPLAY
D FFA1 S 1 INZ(X'40') F.FMT 1 ALPH 60 BYP
D FFA2 S 1 INZ(X'00') F.FMT 2 ALPH
D FFN1 S 1 INZ(X'47') F.FMT 1 NUM 67 BYP
D FFN2 S 1 INZ(X'06') F.FMT 2 NUM
I*.
IINPUTK NS 01
I 1 16 DA
I 17 32 DB 30
I 33 64 DC 31
I 65 96 DD 32
I 97 128 DE 33
I 129 160 DF 34
I 161 192 DG 35
I 193 224 DH 36
I 225 256 DI 37
I 257 288 DJ 38
I 289 320 DK 39
I 321 352 DL 40
I 353 384 DM 41
I 385 416 DN 42
I 417 448 DZ 43
I 449 480 DO 44
I 481 512 DP 45
I 513 544 DQ 46
I 545 576 DR 47
I 577 608 DS 48
I 609 640 DT 49
I 641 672 DU 50
I 673 704 DV 51
I 705 736 DW 52
I 737 768 DX 53
I 769 800 DY 54
I 801 832 D0 55
I 833 864 D1 56
I 865 896 D2 57
I 897 928 D3 58
I 929 960 D4 59
I 961 992 D5 60
I 993 1024 D6 61
I 1025 1056 DBA 62
I 1057 1088 DCA 63
I 1089 1120 DDA 64
I 1121 1152 DEA 65
I 1153 1184 DFA 66
I 1185 1216 DGA 67
I 1217 1248 DHA 68
I 1249 1280 DIA 69
I 1281 1312 DJA 70
I 1313 1344 DKA 71
I 1345 1376 DLA 72
I 1377 1408 DMA 73
I 1409 1440 DNA 74
I 1441 1472 DOA 75
I 1473 1504 DPA 76
I 1505 1536 DQA 77
I 1537 1568 DRA 78
I 1569 1600 DSA 79
I 1601 1632 DTA 80
I 1633 1664 DUA 81
I 1665 1696 DVA 82
I 1697 1728 DWA 83
I 1729 1760 DXA 84
I 1761 1792 DYA 85
I 1793 1824 DZA 86
I 1825 1856 D0A 87
I 1857 1888 D1A 88
I 1889 1920 D2A 89
I 1921 1952 D3A 90
I 1953 1984 D4A 91
I 1985 2016 D5A 92
I 2017 2048 D6A 93
IINPUTR NS 01
I 1 16 DA
I 17 32 DB 30
I 33 64 DC 31
I 65 96 DD 32
I 97 128 DE 33
I 129 160 DF 34
I 161 192 DG 35
I 193 224 DH 36
I 225 256 DI 37
I 257 288 DJ 38
I 289 320 DK 39
I 321 352 DL 40
I 353 384 DM 41
I 385 416 DN 42
I 417 448 DZ 43
I 449 480 DO 44
I 481 512 DP 45
I 513 544 DQ 46
I 545 576 DR 47
I 577 608 DS 48
I 609 640 DT 49
I 641 672 DU 50
I 673 704 DV 51
I 705 736 DW 52
I 737 768 DX 53
I 769 800 DY 54
I 801 832 D0 55
I 833 864 D1 56
I 865 896 D2 57
I 897 928 D3 58
I 929 960 D4 59
I 961 992 D5 60
I 993 1024 D6 61
I 1025 1056 DBA 62
I 1057 1088 DCA 63
I 1089 1120 DDA 64
I 1121 1152 DEA 65
I 1153 1184 DFA 66
I 1185 1216 DGA 67
I 1217 1248 DHA 68
I 1249 1280 DIA 69
I 1281 1312 DJA 70
I 1313 1344 DKA 71
I 1345 1376 DLA 72
I 1377 1408 DMA 73
I 1409 1440 DNA 74
I 1441 1472 DOA 75
I 1473 1504 DPA 76
I 1505 1536 DQA 77
I 1537 1568 DRA 78
I 1569 1600 DSA 79
I 1601 1632 DTA 80
I 1633 1664 DUA 81
I 1665 1696 DVA 82
I 1697 1728 DWA 83
I 1729 1760 DXA 84
I 1761 1792 DYA 85
I 1793 1824 DZA 86
I 1825 1856 D0A 87
I 1857 1888 D1A 88
I 1889 1920 D2A 89
I 1921 1952 D3A 90
I 1953 1984 D4A 91
I 1985 2016 D5A 92
I 2017 2048 D6A 93
IDISPF NS 02
I 3 3 AID
I 4 83 ID0
I 84 163 ID1 20
I 164 243 ID2 21
I 244 323 ID3 22
I 324 403 ID4 23
I 404 483 ID5 24
I 484 563 ID6 25
I 564 643 ID7 26
I 644 723 ID8 27
I 724 803 ID9 28
/FREE
BASE = 0;
IF ONCE = ' ';
EXSR @INITZ ;
ENDIF;
// START TAG
DOW @LOOP = @LOOP;
IF RTN = '3';
IF *INU1;
KEYA = SCNKEY;
ENDIF;
IF *INU2;
RRNA = %DEC(%SUBST(SCNKEY:1:11):11:0);
ENDIF;
RTN = '0';
AID = '1';
ELSE;
RTN = '0';
READ(E) DISPF;
ENDIF;
// CF3 EXIT
IF AID = X33;
LEAVE;
ENDIF;
// CF2 RETURN
IF AID = X32;
RTN = '1';
LEAVE;
ENDIF;
// CF1 HEX A FIELD
IF AID = X31;
Y = %LOOKUPLE( CURLOC : B );
IF Y > 0;
IF KY(Y) <= '1';
EXSR @HXDSP;
REHEAD = '1';
EXSR @PUTHED;
REHEAD = ' ';
ENDIF;
ENDIF;
ENDIF;
// CF20 MORE FIELDS
IF AID = XB8;
LVX = LVL + 1;
IF LV(LVX) <> *BLANK;
LVL = LVL +1 ;
LVW = LV;
SCNLV = TEXT500;
SCNLVL = %EDITC(LVL :'X');
SCNKEY = *BLANKS;
IF *INU1;
SCNKEY = KEYA;
ENDIF;
IF *INU2;
SCNKEY = %EDITC(RRNA:'X');
ENDIF;
RTN = '3';
LEAVE;
ENDIF;
ENDIF;
// CF19 PREVIOUS FIELDS
IF AID = XB7;
LVX = LVL - 1;
IF LVX >= 0 ;
LVL = LVL - 1 ;
LVW = LV;
SCNLV = TEXT500;
SCNLVL = %EDITC(LVL :'X');
SCNKEY = *BLANKS;
IF *INU1;
SCNKEY = KEYA;
ENDIF;
IF *INU2;
SCNKEY = %EDITC(RRNA:'X');
ENDIF;
RTN = '3';
LEAVE;
ENDIF;
ENDIF;
// 1 ENTER
// 4 ROLL DN
// 5 ROLL UP
IF AID = '1'or AID = '4' or AID = '5';
ELSE;
MX = 1;
EXSR @ERROR;
ENDIF;
IF RTN <> '3';
EXSR @PCKD;
ENDIF;
// CONT1 GET A RECORD, KEY FROM DATA
EXSR @SETIN;
EXSR @GETF ;
EXSR @PUTF ;
EXSR @KEYIN;
ENDDO ;
*INLR = *ON;
// @@@@@@@ @INITZ @@@@@@@@@@@@@@@@@@@@@@@@@@
BEGSR @INITZ;
ONCE = '1';
KEYLNA = KEYLNG ;
EXSR @INIT ;
EXSR @GETFLD ;
EXSR @GETADD ;
EXSR @PUTHED ;
EXSR @KEYIN ;
INZ = '1';
EXSR @PCKD ;
INZ = ' ';
ENDSR;
// @@@@@@@ @PCKD @@@@@@@@@@@@@@@@@@@@@@@@@@
BEGSR @PCKD ;
// CONVERT KEY DATA
IF *INU1 ;
EXSR @CVTKEY;
ENDIF;
IF *INU2 ;
EXSR @CVTRRN;
ENDIF;
ENDSR;
// @@@@@@@ @CVTKEY @@@@@@@@@@@@@@@@@@@@@@@@
BEGSR @CVTKEY;
// EXTRACT THE KEY FIELD DATA FROM THE INCOMING STRING
// FOR EACH KEY FIELD, CHECK IF FIELD WAS MODIFIED, AND IF SO MOVE
// THE MODIFIED DATA INTO THE COMPOSITE KEY
K1 = 0;
K2 = 0;
W = 1;
FOR Y = 1 TO NUMKEY ;
// MOVE A KEY FIELDS DATA FROM ID ARRAY (SCREEN) TO K ARRAY (KEY FIELDS)
// GET SIZE OF FIELD IN BYTES
IF T(Y) = 'A'; // ALPHA DATA
K = ' ';
K1 = 1;
K2 = Q(Y);
ELSE;
K = '0';
K1 = 1;
K2 = C(Y);
ENDIF;
// IF WHOLE KEY INIT WAS REQUESTED BYPASS THE EXTRACT
IF INZ = '1' ;
KW = *BLANK;
EXSR @PCKMOV;
ITER;
ENDIF;
X = 1;
DOW @LOOP = @LOOP;
// NXTSBA
X = %LOOKUP(SBA : ID : X );
IF X = 0;
LEAVE;
ENDIF;
// IS THIS THE FIELD? CHECK THE BUFFER ADDRESS
X = X +1;
IF B(Y) <> %SUBST(IDA : X :2);
ITER;
ENDIF;
// FOUND A MTD FOR THIS FIELD
X = X + 2;
// CHECK IF FIELD WAS CLEARED ONLY
IF ID(X) = SBA;
EXSR @PCKMOV;
LEAVE ;
ENDIF;
// IF FIELD HAS DECIMALS BUMP X
IF (T(Y) = 'S' OR T(Y) = 'P' OR T(Y) = 'B') AND
P(Y) > 0;
X = X + 1;
ENDIF;
// CHECK IF ONLY BLANKS RETURNED
IF %SUBST(IDA : X :K2) = *BLANKS;
EXSR @PCKMOV;
LEAVE;
ENDIF;
// EXTRACT THE DATA FROM THE INCOMING STRING
X1 = X;
FOR X2 = 1 TO K2 ;
IF ID(X1) < ' ';
// TRAP NULLS CAUSED BY FLD EXIT
EXSR @PCKMOV;
LEAVE;
ENDIF;
K(X2) = ID(X1);
X1 = X1 +1;
ENDFOR;
// CONSTRUCT THE ACTUAL KEY WITH PACKED DATA IF REQUIRED
// INTO ARRAY KW
EXSR @PCKMOV;
LEAVE;
ENDDO;
ENDFOR;
//
KEYA = KW;
CLEAR KW;
ENDSR ;
// @@@@@@@ @CVTRRN @@@@@@@@@@@@@@@@@@@@@@@@
BEGSR @CVTRRN;
// RRN
NUM11 = 0;
DOW @LOOP = @LOOP; // NOT REALLY A LOOP(SIMULATES GOTO)
// GET THE FIRST SBA
X = 1;
X = %LOOKUP(SBA : ID : X );
IF X = 0;
LEAVE;
ENDIF;
// CHECK THE BUFFER ADDRESS MATCHES THE EXPECTED FIELD
X = X +1;
IF B(1) <> %SUBST(IDA : X :2);
LEAVE;
ENDIF;
// FOUND A MTD FOR RRN FIELD
X = X +2;
//CHECK IF FIELD WAS CLEARED ONLY
IF ID(X) = SBA;
LEAVE;
ENDIF;
// CHECK IF ONLY BLANKS RETURNED
IF %SUBST(IDA : X :11) = *BLANKS;
LEAVE;
ENDIF;
// WRK11 OVERLAYS NUM11
WRK11 = %SUBST(IDA : X :11);
LEAVE;
ENDDO;
RRNA = NUM11;
IF RRNA < 0;
RRNA = 1;
ENDIF;
ENDSR;
// @@@@@@@ @PCKMOV @@@@@@@@@@@@@@@@@@@@@@@@
BEGSR @PCKMOV;
//
// CONVERT KEY DATA
// SET START POSN IN KEY USING OFFSET IN R
W = R(Y) + 1;
// ALPHA
IF T(Y) = 'A';
X1 = 1;
FOR Z = W TO W + Q(Y);
%SUBST(KW : Z : 1) = K(X1);
X1 = X1 + 1;
ENDFOR;
ENDIF;
// NUMERIC FIELD
// RIGHT ADJUST NUMERIC DATA ,STRIP - . ,CONVERT BLANKS
IF (T(Y) = 'S' OR T(Y) = 'P' OR T(Y) = 'B');
NU = '0';
Z1 = 60;
FOR Z = K2 DOWNTO K1;
IF K(Z) = '.' OR K(Z) = '-' OR K(Z) = '$';
ITER;
ENDIF;
IF K(Z) = ' ' ;
NU(Z1) = '0';
ELSE;
NU(Z1) = K(Z);
ENDIF;
Z1 = Z1 -1;
ENDFOR;
ENDIF;
// SIGNED FIELDS (END POSN = OFFSET + SIZE)
IF T(Y) = 'S';
NUS = 0;
FOR VX = 1 TO 60;
NUSA = %TRIM(NUSA) + NU(VX);
ENDFOR;
%SUBST(KW : W : Q(Y)) = %SUBST(NUSA: 61 -Q(Y));
ENDIF;
// PACKED FIELDS
IF T(Y) = 'P';
NUSA= *BLANKS;
FOR VX = 1 TO 60;
NUSA = %TRIM(NUSA) + NU(VX);
ENDFOR;
NUP = %DEC(NUSA : 60 : 0);
%SUBST(KW : W : Q(Y)) = %SUBST(NUPA: 61 -Q(Y));
ENDIF;
// BINARY FIELDS
IF T(Y) = 'B';
IF Q(Y) = 2 ;
BY2 = NU(1) + NU(2);
%SUBST(KW : W : 2) = BY2;
ENDIF;
IF Q(Y) = 4 ;
BY4 = NU(1) + NU(2) + NU(3) + NU(4);
%SUBST(KW : W : 4) = BY4;
ENDIF;
ENDIF;
ENDSR;
// @@@@@@@ SETIN @@@@@@@@@@@@@@@@@@@@@@@@@
BEGSR @SETIN;
// SET the FFR indicators to get the Input buffer somewhat aligned with the
// actual data. RPG is somewhat tolerant to a difference between the Ispecs
// and the actual file size but it can fail on big differences.
// INCREMENT OF 32 BYTES
SZ(1) = BASE + 16;
SZ(2) = SZ(1) + 16;
*IN30 = *ON;
IF (RLEN > SZ(2)) ;
*IN31 = *ON;
ENDIF;
FOR X = 3 TO 64;
SZ(X) = SZ(X-1) + 32;
IF (RLEN > SZ(X)) ;
*IN(29+X) = *ON;
ENDIF;
ENDFOR;
ENDSR;
//@@@@@@@@@@@@@@@@@ @GETF @@@@@@@@@@@@@@@@@
BEGSR @GETF;
// GET A DATA RECORD
IF (*INU1);
IF AID = '1' OR AID = X36 OR
AID = X39 OR AID = X3B ;
SETLL(E) KEYA INPUTK;
READ(E) INPUTK;
IF %EOF;
SETLL(E) KEYA INPUTK;
READP(E) INPUTK;
ENDIF;
ENDIF;
IF AID = '4';
READP(E) INPUTK;
ENDIF;
IF AID = '5';
READ(E) INPUTK;
ENDIF;
IF %ERROR;
SETLL(E) KEYA INPUTK;
READ(E) INPUTK;
MX = 7;
EXSR @ERROR;
EXSR @PUTF ;
EXSR @KEYIN;
ENDIF;
KEYA = LKY;
CLEAR KW;
KW = LKY;
ENDIF;
IF (*INU2);
IF AID = '1';
CHAIN(E) RRNA INPUTR;
IF %ERROR;
SETLL(E) RRNA INPUTR;
READP(E) INPUTR;
ENDIF;
ENDIF;
IF AID = X36;
CHAIN(E) RRNA INPUTR;
ENDIF;
IF AID = '4';
READP(E) INPUTR;
ENDIF;
IF AID = '5' OR AID = X3B;
READ(E) INPUTR;
ENDIF;
IF AID = X39;
SETLL(E) *HIVAL INPUTR;
READP(E) INPUTR;
ENDIF;
IF %ERROR;
CHAIN 1 INPUTR;
MX = 7;
EXSR @ERROR;
EXSR @PUTF ;
EXSR @KEYIN;
ENDIF;
ENDIF;
ENDSR;
//@@@@@@@@@@@@@@@@@ @PUTF @@@@@@@@@@@@@@@@@
BEGSR @PUTF;
// WRITE DATA TO THE DISPLAY
NEWRU = '1';
WRTRRN = '1';
RU = *ALLX'00';
CLEAR RU; // initialise Request Unit 255 bytes max
FOR XX = 1 TO NUMFKY; //NUMBER OF DATA ELEMENTS (FLD AND KEY)
IF NEWRU = '1';
NEWRU = '0';
RU = ESC + WTD + X20 + X00;
ENDIF;
IF WRTRRN = '1';
WRTRRN = '0';
RU = RU + SBA + RBA ;
SELECT;
WHEN *INU1;
RRN = RN1;
WHEN *INU2;
RRN = RN2;
ENDSL;
RU = RU + %TRIM(%EDITC(RRN:'Z'));
ENDIF;
// BUFFER ADDRESS
RU = RU + SBA + B(XX);
// PROCESS ALPHA DATA TYPE
IF T(XX) = 'A' OR T(XX) = 'T' OR T(XX) = 'Z' OR
T(XX) = 'L';
STRX = S(XX);
ENDX = E(XX);
IF V(XX) = 'Y'; //VARYING
VX = S(XX);
HX2 = D(VX) + D(VX+1);
STRX = S(XX) + 2 ;
ENDX = S(XX) + BIN;
ENDIF;
FOR Y = STRX TO ENDX ;
IF D(Y) >= ' ';
RU = RU + D(Y);
ELSE;
RU = RU + X1F ; //IF NOT DISPLAYABLE REPLACE WITH X'1F'
ENDIF;
ENDFOR;
ENDIF;
// PROCESS SIGNED DATA TYPE (not the RRN field)
IF T(XX) = 'S' and KY(XX) <> '3';
NUSA = *ALL'0';
WRV = *ALLX'00';
CLEAR WRV;
FOR Y = S(XX) TO E(XX);
IF D(Y) >= XD0;
WRV = WRV + D(Y);
ENDIF;
ENDFOR;
EVAL NUSA = %SUBST(NUSA : 1 : 60 - %LEN(WRV)) + WRV;
CLEAR WRU;
WRU = %TRIM(WRU) + %EDITW(NUS :WRSWRD);
IF P(XX) > 0;
RU = RU +
%SUBST(WRU :61-C(XX): C(XX)-P(XX)) + '.' +
%SUBST(WRU :61-P(XX)) ;
ELSE;
RU = RU +
%SUBST(WRU :61-C(XX));
ENDIF;
ENDIF;
// PROCESS SIGNED DATA TYPE (the RRN field)
IF T(XX) = 'S' and KY(XX) = '3';
RRN = RN2;
RU = RU + %TRIM(%EDITC(RRN:'X'));
ENDIF;
// PROCESS PACKED DATA TYPE
IF T(XX) = 'P';
NUPA = *ALLX'00';
WRV = *ALLX'00';
CLEAR WRV;
FOR Y = S(XX) TO E(XX);
WRV = WRV + D(Y);
ENDFOR;
IF %BITAND(D(E(XX)) :X0F) = X0F OR
%BITAND(D(E(XX)) :X0D) = X0D;
EVAL NUPA = %SUBST(NUPA : 1 : 60 - %LEN(WRV)) + WRV;
CLEAR WRX;
WRX = %TRIM(WRX) + %EDITW(NUP :WRXWRD);
IF P(XX) > 0;
RU = RU +
%SUBST(WRX :64-C(XX): C(XX)-P(XX)) + '.' +
%SUBST(WRX :64-P(XX)) ;
ELSE;
RU = RU +
%SUBST(WRX :64-C(XX));
ENDIF;
ELSE;
// PACKED FIELD IN ERROR
RU = RU + X1F;
ENDIF;
ENDIF;
// PROCESS BINARY DATA TYPE
IF T(XX) = 'B';
ST = S(XX);
CLEAR NUSA;
IF Q(XX) = 2;
BY2 = D(ST) + D(ST+1);
NUS = BIN2;
ENDIF;
IF Q(XX) = 4;
BY4 = D(ST) + D(ST+1)+ D(ST+2) + D(ST+3);
NUS = BIN4;
ENDIF;
WRU = %EDITW(NUS :WRSWRD);
IF P(XX) > 0;
RU = RU +
%SUBST(WRU :61-C(XX): C(XX)-P(XX)) + '.' +
%SUBST(WRU :61-P(XX)) ;
ELSE;
RU = RU +
%SUBST(WRU :61-C(XX));
ENDIF;
ENDIF;
// PROCESS FLOAT DATA TYPE
IF T(XX) = 'F';
ST = S(XX);
IF Q(XX) = 4;
FL4 = D(ST) + D(ST+1)+ D(ST+2) + D(ST+3);
FLT14 = %EDITFLT(FLT4);
RU = RU + FLT14;
ENDIF;
IF Q(XX) = 8;
FL8 = D(ST) + D(ST+1)+ D(ST+2) + D(ST+3) +
D(ST+4) + D(ST+5)+ D(ST+6) + D(ST+7);
FLT23 = %EDITFLT(FLT8);
RU = RU + FLT23;
ENDIF;
ENDIF;
// SEND A REQUEST UNIT IF GOT ENOUGH DATA
IF %LEN(RU) + L(XX + 1) >= 200;
RU = RU + X20;
BIN = %LEN(RU);
OUTLEN = HX2;
INLEN = X000;
FNC = SND;
A = RU;
EXCEPT DATAO;
NEWRU = '1';
RU = *ALLX'00';
CLEAR RU;
ENDIF;
ENDFOR;
IF %LEN(RU) > 5 AND %LEN(RU) < 250;
RU = RU + X20;
BIN = %LEN(RU);
OUTLEN = HX2;
INLEN = X000;
FNC = SND;
A = RU;
EXCEPT DATAO;
ENDIF;
ENDSR;
// @@@@@@@@@@@@@@@ ROWINC @@@@@@@@@@@@@@@
// INCREMENT THE ROW
BEGSR @ROWINC;
ROW = ROW + 2;
IF ROW > 20;
MX = 3;
ENDIF;
ENDSR;
// @@@@@@@@@@@@@@@ GETFLD @@@@@@@@@@@@@@@
// LOAD FIELD DESCRIPTION ARRAYS
BEGSR @GETFLD;
MX = 0;
X = 0;
IF (*INU2 = *ON);
// IF NON KEYED ACCESS SET UP A FIELD TO SHOW THE RRN
N(1) = 'RRN';
T(1) = 'S' ;
C(1) = 11 ;
P(1) = 0 ;
S(1) = 0 ;
E(1) = 0 ;
L(1) = 12 ;
I(1) = X4F06 ;
KY(1)= '3' ;
X = 1 ;
ENDIF;
SCRST = *BLANK;
SCRSTN = *BLANK;
LVL = %DEC(SCNLVL : 5:0);
TEXT500 = SCNLV ;
LV = LVW;
IF LVL <> 0;
SCRST = LV(LVL);
ENDIF;
SETLL 1 QWHDRFFD ;
DOW @LOOP = @LOOP;
// REREAD TAG
READ QWHDRFFD;
IF %EOF;
LEAVE;
ENDIF;
// SELECT OR OMIT
IF ALL <> '1';
IF ALL = 'S' AND WHDFTL = 0; // USING WHDFTL FOR KEY FIELDS
IF WHFIOB <> 'S';
ITER;
ENDIF;
ENDIF;
IF ALL = 'O' AND WHDFTL = 0; // USING WHDFTL FOR KEY FIELDS
IF WHFIOB = 'O';
ITER;
ENDIF;
ENDIF;
ENDIF;
// FIND THE FIRST FIELD TO BE SHOWN (FOR MULTI PAGE FORMATS)
IF WHDFTL <> 0 ;
ELSE;
IF SCRST <> ' ' AND SCRSTN = ' ';
IF WHFLDE = SCRST;
SCRSTN = '1'; // FOUND THE START
ELSE;
ITER;
ENDIF;
ENDIF;
ENDIF;
X = X + 1;
// CHECK FOR KEY FIELDS,WILL BE USED TO PLACE THEM IN FRONT
IF WHDFTL <> 0;
KY(X) = '1';
WX = WHDFTL ;
KE(WX) = WHFLDE;
IF NUMKEY < WHDFTL;
NUMKEY = WHDFTL;
ENDIF;
ENDIF;
N(X) = WHFLDE ; // NAME
T(X) = WHFLDT ; // TYPE
V(X) = WHVARL ; // VARYING
C(X) = WHFLDD ; // DEC DIGITS
P(X) = WHFLDP ; // DEC PREC
S(X) = WHFOBO ; // START
Q(X) = WHFLDB ; // BTYES
E(X) = WHFOBO + WHFLDB -1 ; // END
IF T(X) = 'F' ; // FLOAT
I(X) = FFA1 + FFA2; // SCRN FIELD FORMAT ALPHA
L(X) = 14;
IF Q(X) = 8;
L(X) = 23;
ENDIF;
ELSE;
IF WHFLDD <> 0 ;
IF WHFLDP <> 0 ;
L(X) = WHFLDD + 2 ; // LENGTH
ELSE;
L(X) = WHFLDD + 1 ; // LENGTH
ENDIF;
I(X) = FFN1 + FFN2; // SCRN FIELD FORMAT NUMERIC
ELSE;
L(X) = WHFLDB ;
I(X) = FFA1 + FFA2; // SCRN FIELD FORMAT ALPHA
ENDIF;
ENDIF;
ENDDO;
// NUMBER OF FIELDS
NUMFLD = X ;
// MAKE ROOM FOR KEYS
IF NUMKEY > 0 ;
X1 = NUMKEY + NUMFLD;
FOR X = NUMFLD DOWNTO 1;
KY(X1) = KY(X) ;
L(X1) = L(X) ;
I(X1) = I(X) ;
N(X1) = N(X) ;
T(X1) = T(X) ;
V(X1) = V(X) ;
C(X1) = C(X) ;
P(X1) = P(X) ;
S(X1) = S(X) ;
E(X1) = E(X) ;
Q(X1) = Q(X) ;
X1 = X1 - 1;
ENDFOR;
// PUT KEY FIELDS AT TOP
OFF = 0;
FOR X = 1 TO NUMKEY;
X1 = %LOOKUP(KE(X) : N : NUMKEY+1);
KY(X) = '2';
L(X) = L(X1);
I(X) = I(X1); // FIELD FMT
SELECT; // INPUT ENABLE
WHEN I(X) = X6000;
I(X) = X4800;
WHEN I(X) = X6706;
I(X) = X4F06;
ENDSL;
N(X) = N(X1);
T(X) = T(X1);
V(X) = V(X1);
C(X) = C(X1);
P(X) = P(X1);
S(X) = S(X1);
E(X) = E(X1);
Q(X) = Q(X1);
R(X) = OFF;
OFF = OFF + Q(X1);
ENDFOR;
ENDIF;
// NUMBER OF FIELDS AND KEYS
NUMFKY = NUMFLD + NUMKEY;
ENDSR;
// @@@@@@@@@@@@@@@ GETADD @@@@@@@@@@@@@@@
// LOAD FIELD BUFFER ADDRESSES
BEGSR @GETADD;
MX = 0;
X = 0;
ROW = 3;
COL = 1;
FOR X = 1 TO NUMFKY;
// IF FINISHED WITH THE KEY FIELDS
// INC ROW FOR 1ST DATA FIELD
IF KEYSOK = ' ' ;
IF KY(X) = ' ' OR KY(X) = '1';
KEYSOK = '1' ;
ROW = ROW + 2;
COL = 1;
ENDIF;
ENDIF;
// SET THE BUFFER ADD ON THE LARGER OF THE FIELD TEXT OR THE FIELD SIZE
LENDSC = %LEN(%TRIM(N(X)));
LENWRK = L(X);
IF LENDSC > L(X);
LENWRK = LENDSC;
ENDIF;
LENWRK = LENWRK + 2;
// TRAP FIELDS THAT OVERFLOW
ROW = ROW + XROW;
XROW = %DIV(LENWRK : 80);
IF (COL + LENWRK) > 78;
EXSR @ROWINC;
IF MX = 3;
X= X-1;
NUMFKY = X;
LEAVE;
ENDIF;
COL = 1;
ENDIF;
// INC COL. FOR FIELD START
CLEAR B(X);
BIN = ROW;
B(X) = %TRIM(B(X)) + HX1;
BIN = COL + 1;
B(X) = %TRIM(B(X)) + HX1;
// INC COL. FOR NEXT FIELD
COL = COL + LENWRK;
IF COL > 78;
EXSR @ROWINC;
IF MX = 3; // NO ROOM FOR THE FIELD
X= X-1;
NUMFKY = X;
LEAVE;
ENDIF;
COL = 1;
ENDIF;
ENDFOR;
// FIELD LEVEL
LVX = LVL + 1;
LV(LVX) = N(X);
ENDSR;
// @@@@@@@@@@@@@@@ PUTHED @@@@@@@@@@@@@@@
// PUT FIELD HEADINGS
BEGSR @PUTHED;
NEWRU = '1';
RU = *ALLX'00';
CLEAR RU; // initialise Request Unit 255 bytes max
FOR XX = 1 TO NUMFKY; //NUMBER OF DATA ELEMENTS (FLD AND KEY)
IF NEWRU = '1';
NEWRU = '0';
RU = ESC + WTD + X20 + X00;
ENDIF;
RU = RU + SBA;
BIN = 0;
// CONVERT DATA BUFADR TO HEADING BUFADR
HX1 = %SUBST(B(XX) :1:1);
BIN = BIN - 1;
RU = RU + HX1;
IF REHEAD = '1'; // ON REDISPLAY OVERRIDE THE ATTR
BIN = 0;
HX1 = %SUBST(B(XX) :2:1);
BIN = BIN -1 ;
RU = RU + HX1;
ELSE;
RU = RU + %SUBST(B(XX) :2);
ENDIF;
RU = RU + ATC ;
// LONG NUMBER FIELDS ,RIGHT ADJUST THE FIELD HEADINGS
LENDSC = %LEN(%TRIM(N(XX)));
IF T(XX) <> 'A' AND LENDSC < (L(XX) -1);
FOR Y = 1 TO (L(XX) -(LENDSC +1));
RU = RU + ' ';
ENDFOR;
ENDIF;
RU = RU + %TRIM(N(XX));
IF %LEN(RU) >= 200;
BIN = %LEN(RU);
OUTLEN = HX2;
INLEN = X000;
FNC = SND;
A = RU;
EXCEPT DATAO;
NEWRU = '1';
RU = *ALLX'00';
CLEAR RU;
ENDIF;
ENDFOR;
IF %LEN(RU) > 5 AND %LEN(RU) < 200;
BIN = %LEN(RU);
OUTLEN = HX2;
INLEN = X000;
FNC = SND;
A = RU;
EXCEPT DATAO;
ENDIF;
IF REHEAD <> '1';
// FORMAT FIELDS
NEWRU = '1';
RU = *ALLX'00';
CLEAR RU; // initialise Request Unit 255 bytes max
FOR XX = 1 TO NUMFKY; //NUMBER OF DATA ELEMENTS (FLD AND KEY)
IF NEWRU = '1';
NEWRU = '0';
RU = ESC + WTD + X20 + X00;
ENDIF;
RU = RU + SBA +B(XX)+SF + I(XX);
IF KY(XX) = '1' OR KY(XX) = '2' OR KY(XX) = '3';
RU = RU + X25;
ELSE;
RU = RU + X26;
ENDIF;
BIN = L(XX);
RU = RU + HX2;
// LENGTH OF INPUT FIELDS
LENF = LENF + L(XX) + 3;
IF %LEN(RU) >= 200;
BIN = %LEN(RU);
OUTLEN = HX2;
INLEN = X000;
FNC = SND;
A = RU;
EXCEPT DATAO;
NEWRU = '1';
RU = *ALLX'00';
CLEAR RU;
ENDIF;
ENDFOR;
// PUT LAST R/U
IF %LEN(RU) > 5 AND %LEN(RU) < 200;
BIN = %LEN(RU);
OUTLEN = HX2;
INLEN = X000;
FNC = SND;
A = RU;
EXCEPT DATAO;
ENDIF;
//INC BUFFER ADDRESS FOR ALL FIELDS FOR DATA PUT
FOR XP = 1 TO NUMFKY; //NUMBER OF DATA ELEMENTS (FLD AND KEY)
HX2 = B(XP);
BIN = BIN + 1;
B(XP) = HX2;
ENDFOR;
ENDIF;
ENDSR;
// @@@@@@@ INIT @@@@@@@@@@@@@@@@@@@@@@@@@
BEGSR @INIT;
CLEAR KW;
// UPDATE
IF UPDF = 'Y';
FFA1 = X40;
FFN1 = X47;
ELSE;
FFA1 = X60;
FFN1 = X67;
ENDIF;
SELECT;
WHEN *INU1 = '1';
FILE = F1 ;
LIB = L1 ;
MBR = M1 ;
RCDL = R1 ;
ACCTP = A1 ;
WHEN *INU2 = '1';
FILE = F2 ;
LIB = L2 ;
MBR = M2 ;
RCDL = R2 ;
ACCTP = A2 ;
ENDSL;
RLEN = RCDL ;
RLENTH = %EDITC(RLEN: 'X') ;
LENF = 0 ;
// Control commands and data are constructed into RUs Request UNITS
// Each RU is 256 bytes max size.
// Construct and send as many RUs as needed to format the display.
RU = *ALLX'00';
CLEAR RU; // initialise Request Unit 255 bytes max
RU = CLRWTD ;
//set up the screen headings
BIN = 1; // set ROW to 1
RW = HX1;
BIN = 2; // set COL to 2
CL = HX1;
RU = RU + SBA + RW + CL + X22 + %TRIM(LIB) + '/' + %TRIM(FILE);
RU = RU + ' Mbr ' + %TRIM(MBR) + ' Rcdl ' + %EDITC(RLEN : 'Z') ;
RU = RU + ' RRN ' ;
BIN = %len(RU) -4;
RBA = RW + HX1 ; // address of the RRN field
RU = RU + SBA + RBA + ' ';
// FUNCTION KEYS
BIN = 23;
RW = HX1;
BIN = 02;
CL = HX1;
IF UPDF = 'Y'; // UPDATE IS ON
RU = RU + SBA + RW + CL + %TRIM(CNS(2));
ELSE;
RU = RU + SBA + RW + CL + %TRIM(CNS(1));
ENDIF;
// THIS IS A SEND ONLY FUNCTION
FNC = SND;
CLEAR A;
A = RU;
BIN2 = %LEN(RU);
OUTLEN = BY2;
INLEN = x000;
EXCEPT DATAO;
ENDSR;
// @@@@@@@ KEYIN @@@@@@@@@@@@@@@@@@@@@@@@@
BEGSR @KEYIN;
// ISSUE A READ FROM DISPLAY
FNC = SNR;
BIN2 = 8;
OUTLEN = BY2;
IPL = LENF + 34;
BIN2 = IPL;
INLEN = BY2;
// SET FRR INDICATORS TO CONTROL BUFFER OVERFLOW
FOR X = 1 TO 9;
IF IPL > ( X*80 +3);
*IN(X+19) = *ON;
ENDIF;
ENDFOR;
RU = *ALLX'00';
CLEAR RU;
RU = RDDSP;
A = RU;
EXCEPT DATAI;
ENDSR;
// @@@@@@@ ERROR @@@@@@@@@@@@@@@@@@@@@@@@@
BEGSR @ERROR;
// SETUP PUT ERROR MESSAGE X'21'
RU = *ALLX'00';
CLEAR RU;
FNC = SNR;
BIN = 42;
OUTLEN = HX2;
BIN = LENF + 34;
IPL = BIN;
INLEN = HX2;
FOR X = 1 TO 9;
IF IPL > (X * 80 +3) ;
*IN(X + 19) = *ON; // SETON FFR 20 - 29 FOR INPUT
ENDIF;
ENDFOR;
RU = ESC + WER + IC + B(1) + ATC + MSG(MX);
RU = RU + ESC + RDM + X40+ X00;
A = RU;
EXCEPT DATAI;
RU = *ALLX'00';
CLEAR RU;
ENDSR;
// @@@@@@@ HXDSP @@@@@@@@@@@@@@@@@@@@@@@@@
BEGSR @HXDSP;
RU = *ALLX'00';
CLEAR RU;
Y = %LOOKUPLE( CURLOC : B );
//
RU = ESC + WTD + X20 + X00 + SBA;
BIN = 0;
HX1 = %SUBST(B(Y) :1:1);
BIN = BIN - 1;
RU = RU + HX1;
RU = RU + %SUBST(B(Y) :2:1);
FOR X = S(Y) TO E(Y);
BIN = 0;
HX1 = D(X);
HX1 = %BITAND(HX1 : XF0);
Z = BIN / 16 + 1;
RU = RU + CRS(Z);
ENDFOR;
RU = RU + X20;
RU = RU + SBA + B(Y);
FOR X = S(Y) TO E(Y);
BIN = 0;
HX1 = D(X);
HX1 = %BITAND(HX1 : X0F);
Z = BIN + 1;
RU = RU + CRS(Z);
ENDFOR;
BIN = %LEN(RU);
OUTLEN = HX2;
INLEN = X000;
FNC = SND;
A = RU;
EXCEPT DATAO;
RU = *ALLX'00';
CLEAR RU;
EXSR @KEYIN;
READ DISPF;
// CLEAR HEADINGS
RU = *ALLX'00';
CLEAR RU;
RU = RU + ESC + WTD + X20 + X00 + SBA;
HX1 = %SUBST(B(Y) :1:1) ;
BIN = BIN - 1;
RU = RU + HX1 + %SUBST(B(Y):2:1);
FOR X = S(Y) TO E(Y);
RU = RU + ' ';
ENDFOR;
RU = RU + ' ';
BIN = %LEN(RU);
OUTLEN = HX2;
INLEN = X000;
FNC = SND;
A = RU;
EXCEPT DATAO;
RU = *ALLX'00';
CLEAR RU;
ENDSR;
/END-FREE
ODISPF E DATAO
O K3 'PUT'
O OUTLEN 2
O INLEN
O FNC
O A
O E DATAI
O K3 'GET'
O OUTLEN 2
O INLEN
O FNC
O A
**
0000 INVALID COMMAND KEY
0001 - A FIELD IS TOO LONG
0002 - TOO MANY FIELDS
0003 - ALPHAS IN PACKED KEY
0004 - MISSING ' IN PACKED KEY
0005 - MISSING DATA IN PCKD KEY
0006 - RECORD NOT FOUND
PRESS RESET TO CONTINUE
**
F1-HEX F2-Return F3-Exit F19-Prev_fld F20-More_fld
F1-HEX F2-Return F3-Exit F19-Prev_fld F20-More_fld
**
0123456789ABCDEF
DISP1 RPG
H*eywords++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++Comments+++++++++++
H OPTION(*NODEBUGIO)
H DFTACTGRP(*NO) ACTGRP(*CALLER) DFTNAME(DISP )
F*
F* LIMITED TO MAXIMUM FILE LENGTH OF 4080
F* TEST
FFFD IF E DISK
FDISPF CF F 803 WORKSTN
F*
F INFDS(INFDS)
FINPUTK IF F32766 800AIDISK KEYLOC(1)
F EXTIND(*INU1)
F INFDS(INFDK)
FINPUTR IF F32766 DISK EXTIND(*INU2)
F INFDS(INFDR)
*
D A S 255 WORK RU
D RU S 255 varying
D RW S 1 ROW 1 byte binary
D CL S 1 COL 1 byte binary
D FNC S 1
D OUTLEN S 2
D INLEN S 2
D IPL S 5 0
D ROW S 3 0
D XROW S 3 0
D COL S 3 0
D KEYSOK S 1
D LENDSC S 3 0
D LENWRK S 5 0
D STRX S 5 0
D ENDX S 5 0
D VX S 5 0
D X S 5 0
D X1 S 5 0
D X2 S 5 0
D XX S 5 0
D XP S 5 0
D MX S 5 0
D ONCE S 1
D RBA S 2
D LF S 5 0
D ST S 5 0
D Y S 5 0
D Z S 5 0
D OFF S 5 0
D SUPZ S 1
D NUMFLD S 5 0
D WX S 5 0
D NUMKEY S 5 0
D NUMFKY S 5 0
D SCRST S 10
D SCRSTN S 1
D KEYA S 800
D RRNA S 11 0
D RRN S 11 0
D REHEAD S 1
D NEWRU S 1
D WRTRRN S 1
D LVX S 5 0
D LVL S 5 0
D K1 S 5 0
D K2 S 5 0
D Z1 S 5 0
D W S 5 0
D WK2 S 2
D MSSG S 32
*
D BASE S 5 0
D INZ S 1
D FILE S 10
D LIB S 10
D MBR S 10
D RCDL S 5 0
D ACCTP S 1
D RLEN S 5 0
D RLENTH S 5
D LENF S 5 0
D DS
D TEXT500 500
D LVW 10 DIM(50) overlay(TEXT500:1)
D TEXT800 S 800
D KW S 800
D DS
D WRK11 1 11
D NUM11 1 11S 0
D DS
D NUSA 1 60
D NUS 1 60S 0
D DS
D NUPA 1 60
D NUP 29 60P 0
D WRU S 61
D WRX S 64
D WRXWRD C '0 -
D -'
D WRSWRD C '0 -
D -'
D WRV S 60 varying
D FLT14 S 14
D FLT23 S 23
* SET FILE SIZE INCREMENTS (64 OF THEM)
D SZ S 5 0 DIM(64)
D S S 5 0 DIM(9000) START OF FLD
D E S 5 0 DIM(9000) END OF FLD
D Q S 5 0 DIM(9000) BYTES IN FIELD
D L S 5 0 DIM(9000) LENGTH OF FLD
D C S 3 0 DIM(9000) DEC DIGITS
D P S 3 0 DIM(9000) DEC PRECISION
D B S 2 DIM(9000) ASCEND BUFFER ADD
D I S 2 DIM(9000) FLD FMT
D N S 10 DIM(9000) FLD NAME
D T S 1 DIM(9000) FLD TYPE
D V S 1 DIM(9000) VARYING
D KY S 1 DIM(9000) KEYED
D KE S 10 DIM(128) KEY FLDS
D R S 3 0 DIM(9000) KEY FLD START
D K S 1 DIM(800) KEY
D NA S 1 DIM(10) NAME WORK
D NU S 1 DIM(60) NUM. WORK
D LV S 10 DIM(50) SCREEN LEVELS
D MSG S 32 DIM(8) CTDATA PERRCD(1) MESSAGES
D CNS S 79 DIM(2) CTDATA PERRCD(1)
D CRS S 1 DIM(16) CTDATA PERRCD(16)
D DS
D D 1 4080
D DIM(4080) INCOMING DATA
D DA 1 2048
D DB 2049 2064
D DC 2065 2096
D DD 2097 2128
D DE 2129 2160
D DF 2161 2192
D DG 2193 2224
D DH 2225 2256
D DI 2257 2288
D DJ 2289 2320
D DK 2321 2352
D DL 2353 2384
D DM 2385 2416
D DN 2417 2448
D DZ 2449 2480
D DO 2481 2512
D DP 2513 2544
D DQ 2545 2576
D DR 2577 2608
D DS 2609 2640
D DT 2641 2672
D DU 2673 2704
D DV 2705 2736
D DW 2737 2768
D DX 2769 2800
D DY 2801 2832
D D0 2833 2864
D D1 2865 2896
D D2 2897 2928
D D3 2929 2960
D D4 2961 2992
D D5 2993 3024
D D6 3025 3056
D DBA 3057 3088
D DCA 3089 3120
D DDA 3121 3152
D DEA 3153 3184
D DFA 3185 3216
D DGA 3217 3248
D DHA 3249 3280
D DIA 3281 3312
D DJA 3313 3344
D DKA 3345 3376
D DLA 3377 3408
D DMA 3409 3440
D DNA 3441 3472
D DOA 3473 3504
D DPA 3505 3536
D DQA 3537 3568
D DRA 3569 3600
D DSA 3601 3632
D DTA 3633 3664
D DUA 3665 3696
D DVA 3697 3728
D DWA 3729 3760
D DXA 3761 3792
D DYA 3793 3824
D DZA 3825 3856
D D0A 3857 3888
D D1A 3889 3920
D D2A 3921 3952
D D3A 3953 3984
D D4A 3985 4016
D D5A 4017 4048
D D6A 4049 4080
D DS
D ID 1 800
D DIM(800) INCOMING DATA
D IDA 1 800
D ID0 1 80
D ID1 81 160
D ID2 161 240
D ID3 241 320
D ID4 321 400
D ID5 401 480
D ID6 481 560
D ID7 561 640
D ID8 641 720
D ID9 721 800
D DS
D BIN 1 2B 0
D HX1 2 2
D HX2 1 2
D DS
D PCK 1 1P 0
D PCK1 1 1
D DS
D SGN 1 1S 0
D SGN1 1 1
D DS
D BIN4 1 4B 0
D BY4 1 4
D DS
D BIN2 1 2B 0
D BY2 1 2
D DS
D FLT4 1 4F
D FL4 1 4
D DS
D FLT8 1 8F
D FL8 1 8
D INFDK DS
D F1 83 92
D L1 93 102
D M1 129 138
D R1 125 126B 0
D A1 160 160
D LOP1 260 260
D KEY_LEN 393 394I 0 Key length
D RN1 397 400B 0
D LKY 401 1200
D INFDR DS
D F2 83 92
D L2 93 102
D M2 129 138
D R2 125 126B 0
D A2 160 160
D LOP2 260 260
D RN2 397 400B 0
D*
D INFDS DS
D CURLOC 370 371
D DS
D KEYLN 1 4S 0
D KEYLNA 1 4
DDISP1 PR
D 1
D 1
D 4
D 1
D 500
D 5
D 800
DDISP1 PI
D ALL 1
D RTN 1
D KEYLNG 4
D UPDF 1
D SCNLV 500
D SCNLVL 5
D SCNKEY 800
D @LOOP C '1'
D SND C X'71' SEND TO DISP
D SNR C X'73' SND/RCV
D RED C X'42' READ
D RDM C X'52' READ MTD
D ESC C X'04' ESCAPE
D CLR C X'40' CLEAR UNIT
D CC1 C X'00' CNTRL CHAR
D CC2 C X'08' CNTRL CHAR
D SBA C X'11' SET BUFF ADR
D IC C X'13' INSERT CURS
D WTD C X'11' WRITE TO DSP
D WER C X'21' WRITE ERROR
D SF C X'1D' START FLD
D ATC C X'20' ATTR CHAR
D ATN C X'24' ATTR NUM
D X00 C X'00'
D X01 C X'01'
D X02 C X'02'
D X03 C X'03'
D X0D C X'0D'
D X0F C X'0F'
D X000 C X'0000'
D X1F C X'1F'
D X20 C X'20' SCRN ATT NORMAL
D X22 C X'22' SCRN ATTR HI
D X25 C X'25'
D X26 C X'26'
D X31 C X'31' CMD 1 KEY
D X32 C X'32' CMD 2 KEY
D X33 C X'33' CMD 3 KEY
D X36 C X'36' CMD 6 KEY
D X37 C X'37' CMD 7 KEY
D X38 C X'38' CMD 8 KEY
D X39 C X'39' CMD 9 KEY
D X3B C X'3B' CMD11 KEY
D XB7 C X'B7' CMD19 KEY
D XB8 C X'B8' CMD20 KEY
D X40 C X'40'
D X43 C X'43'
D X47 C X'47'
D X60 C X'60'
D X67 C X'67'
D X9F C X'9F'
D XF0 C X'F0'
D XD0 C X'D0'
D X4000 C X'4000'
D X4800 C X'4800' FF ALPHA
D X4F06 C X'4F06' FF NUMERIC
D X6000 C X'6000' FF ALPHA
D X6706 C X'6706' FF NUMERIC
D CLRWTD C X'044004112000' INCLUDES ESC CHARS
D RDDSP C X'0411200804524000' REAB FROM DISPLAY
D FFA1 S 1 INZ(X'40') F.FMT 1 ALPH 60 BYP
D FFA2 S 1 INZ(X'00') F.FMT 2 ALPH
D FFN1 S 1 INZ(X'47') F.FMT 1 NUM 67 BYP
D FFN2 S 1 INZ(X'06') F.FMT 2 NUM
I*.
IINPUTK NS 01
I 1 2048 DA
I 2049 2064 DB 30
I 2065 2096 DC 31
I 2097 2128 DD 32
I 2129 2160 DE 33
I 2161 2192 DF 34
I 2193 2224 DG 35
I 2225 2256 DH 36
I 2257 2288 DI 37
I 2289 2320 DJ 38
I 2321 2352 DK 39
I 2353 2384 DL 40
I 2385 2416 DM 41
I 2417 2448 DN 42
I 2449 2480 DZ 43
I 2481 2512 DO 44
I 2513 2544 DP 45
I 2545 2576 DQ 46
I 2577 2608 DR 47
I 2609 2640 DS 48
I 2641 2672 DT 49
I 2673 2704 DU 50
I 2705 2736 DV 51
I 2737 2768 DW 52
I 2769 2800 DX 53
I 2801 2832 DY 54
I 2833 2864 D0 55
I 2865 2896 D1 56
I 2897 2928 D2 57
I 2929 2960 D3 58
I 2961 2992 D4 59
I 2993 3024 D5 60
I 3025 3056 D6 61
I 3057 3088 DBA 62
I 3089 3120 DCA 63
I 3121 3152 DDA 64
I 3153 3184 DEA 65
I 3185 3216 DFA 66
I 3217 3248 DGA 67
I 3249 3280 DHA 68
I 3281 3312 DIA 69
I 3313 3344 DJA 70
I 3345 3376 DKA 71
I 3377 3408 DLA 72
I 3409 3440 DMA 73
I 3441 3472 DNA 74
I 3473 3504 DOA 75
I 3505 3536 DPA 76
I 3537 3568 DQA 77
I 3569 3600 DRA 78
I 3601 3632 DSA 79
I 3633 3664 DTA 80
I 3665 3696 DUA 81
I 3697 3728 DVA 82
I 3729 3760 DWA 83
I 3761 3792 DXA 84
I 3793 3824 DYA 85
I 3825 3856 DZA 86
I 3857 3888 D0A 87
I 3889 3920 D1A 88
I 3921 3952 D2A 89
I 3953 3984 D3A 90
I 3985 4016 D4A 91
I 4017 4048 D5A 92
I 4049 4080 D6A 93
IINPUTR NS 01
I 1 2048 DA
I 2049 2064 DB 30
I 2065 2096 DC 31
I 2097 2128 DD 32
I 2129 2160 DE 33
I 2161 2192 DF 34
I 2193 2224 DG 35
I 2225 2256 DH 36
I 2257 2288 DI 37
I 2289 2320 DJ 38
I 2321 2352 DK 39
I 2353 2384 DL 40
I 2385 2416 DM 41
I 2417 2448 DN 42
I 2449 2480 DZ 43
I 2481 2512 DO 44
I 2513 2544 DP 45
I 2545 2576 DQ 46
I 2577 2608 DR 47
I 2609 2640 DS 48
I 2641 2672 DT 49
I 2673 2704 DU 50
I 2705 2736 DV 51
I 2737 2768 DW 52
I 2769 2800 DX 53
I 2801 2832 DY 54
I 2833 2864 D0 55
I 2865 2896 D1 56
I 2897 2928 D2 57
I 2929 2960 D3 58
I 2961 2992 D4 59
I 2993 3024 D5 60
I 3025 3056 D6 61
I 3057 3088 DBA 62
I 3089 3120 DCA 63
I 3121 3152 DDA 64
I 3153 3184 DEA 65
I 3185 3216 DFA 66
I 3217 3248 DGA 67
I 3249 3280 DHA 68
I 3281 3312 DIA 69
I 3313 3344 DJA 70
I 3345 3376 DKA 71
I 3377 3408 DLA 72
I 3409 3440 DMA 73
I 3441 3472 DNA 74
I 3473 3504 DOA 75
I 3505 3536 DPA 76
I 3537 3568 DQA 77
I 3569 3600 DRA 78
I 3601 3632 DSA 79
I 3633 3664 DTA 80
I 3665 3696 DUA 81
I 3697 3728 DVA 82
I 3729 3760 DWA 83
I 3761 3792 DXA 84
I 3793 3824 DYA 85
I 3825 3856 DZA 86
I 3857 3888 D0A 87
I 3889 3920 D1A 88
I 3921 3952 D2A 89
I 3953 3984 D3A 90
I 3985 4016 D4A 91
I 4017 4048 D5A 92
I 4049 4080 D6A 93
IDISPF NS 02
I 3 3 AID
I 4 83 ID0
I 84 163 ID1 20
I 164 243 ID2 21
I 244 323 ID3 22
I 324 403 ID4 23
I 404 483 ID5 24
I 484 563 ID6 25
I 564 643 ID7 26
I 644 723 ID8 27
I 724 803 ID9 28
/FREE
BASE = 0;
IF ONCE = ' ';
EXSR @INITZ ;
ENDIF;
// START TAG
DOW @LOOP = @LOOP;
IF RTN = '3';
IF *INU1;
KEYA = SCNKEY;
ENDIF;
IF *INU2;
RRNA = %DEC(%SUBST(SCNKEY:1:11):11:0);
ENDIF;
RTN = '0';
AID = '1';
ELSE;
RTN = '0';
READ(E) DISPF;
ENDIF;
// CF3 EXIT
IF AID = X33;
LEAVE;
ENDIF;
// CF2 RETURN
IF AID = X32;
RTN = '1';
LEAVE;
ENDIF;
// CF1 HEX A FIELD
IF AID = X31;
Y = %LOOKUPLE( CURLOC : B );
IF Y > 0;
IF KY(Y) <= '1';
EXSR @HXDSP;
REHEAD = '1';
EXSR @PUTHED;
REHEAD = ' ';
ENDIF;
ENDIF;
ENDIF;
// CF20 MORE FIELDS
IF AID = XB8;
LVX = LVL + 1;
IF LV(LVX) <> *BLANK;
LVL = LVL +1 ;
LVW = LV;
SCNLV = TEXT500;
SCNLVL = %EDITC(LVL :'X');
SCNKEY = *BLANKS;
IF *INU1;
SCNKEY = KEYA;
ENDIF;
IF *INU2;
SCNKEY = %EDITC(RRNA:'X');
ENDIF;
RTN = '3';
LEAVE;
ENDIF;
ENDIF;
// CF19 PREVIOUS FIELDS
IF AID = XB7;
LVX = LVL - 1;
IF LVX >= 0 ;
LVL = LVL - 1 ;
LVW = LV;
SCNLV = TEXT500;
SCNLVL = %EDITC(LVL :'X');
SCNKEY = *BLANKS;
IF *INU1;
SCNKEY = KEYA;
ENDIF;
IF *INU2;
SCNKEY = %EDITC(RRNA:'X');
ENDIF;
RTN = '3';
LEAVE;
ENDIF;
ENDIF;
// 1 ENTER
// 4 ROLL DN
// 5 ROLL UP
IF AID = '1'or AID = '4' or AID = '5';
ELSE;
MX = 1;
EXSR @ERROR;
ENDIF;
IF RTN <> '3';
EXSR @PCKD;
ENDIF;
// CONT1 GET A RECORD, KEY FROM DATA
EXSR @SETIN;
EXSR @GETF ;
EXSR @PUTF ;
EXSR @KEYIN;
ENDDO ;
*INLR = *ON;
// @@@@@@@ @INITZ @@@@@@@@@@@@@@@@@@@@@@@@@@
BEGSR @INITZ;
ONCE = '1';
KEYLNA = KEYLNG ;
EXSR @INIT ;
EXSR @GETFLD ;
EXSR @GETADD ;
EXSR @PUTHED ;
EXSR @KEYIN ;
INZ = '1';
EXSR @PCKD ;
INZ = ' ';
ENDSR;
// @@@@@@@ @PCKD @@@@@@@@@@@@@@@@@@@@@@@@@@
BEGSR @PCKD ;
// CONVERT KEY DATA
IF *INU1 ;
EXSR @CVTKEY;
ENDIF;
IF *INU2 ;
EXSR @CVTRRN;
ENDIF;
ENDSR;
// @@@@@@@ @CVTKEY @@@@@@@@@@@@@@@@@@@@@@@@
BEGSR @CVTKEY;
// EXTRACT THE KEY FIELD DATA FROM THE INCOMING STRING
// FOR EACH KEY FIELD, CHECK IF FIELD WAS MODIFIED, AND IF SO MOVE
// THE MODIFIED DATA INTO THE COMPOSITE KEY
K1 = 0;
K2 = 0;
W = 1;
FOR Y = 1 TO NUMKEY ;
// MOVE A KEY FIELDS DATA FROM ID ARRAY (SCREEN) TO K ARRAY (KEY FIELDS)
// GET SIZE OF FIELD IN BYTES
IF T(Y) = 'A'; // ALPHA DATA
K = ' ';
K1 = 1;
K2 = Q(Y);
ELSE;
K = '0';
K1 = 1;
K2 = C(Y);
ENDIF;
// IF WHOLE KEY INIT WAS REQUESTED BYPASS THE EXTRACT
IF INZ = '1' ;
KW = *BLANK;
EXSR @PCKMOV;
ITER;
ENDIF;
X = 1;
DOW @LOOP = @LOOP;
// NXTSBA
X = %LOOKUP(SBA : ID : X );
IF X = 0;
LEAVE;
ENDIF;
// IS THIS THE FIELD? CHECK THE BUFFER ADDRESS
X = X +1;
IF B(Y) <> %SUBST(IDA : X :2);
ITER;
ENDIF;
// FOUND A MTD FOR THIS FIELD
X = X + 2;
// CHECK IF FIELD WAS CLEARED ONLY
IF ID(X) = SBA;
EXSR @PCKMOV;
LEAVE ;
ENDIF;
// IF FIELD HAS DECIMALS BUMP X
IF (T(Y) = 'S' OR T(Y) = 'P' OR T(Y) = 'B') AND
P(Y) > 0;
X = X + 1;
ENDIF;
// CHECK IF ONLY BLANKS RETURNED
IF %SUBST(IDA : X :K2) = *BLANKS;
EXSR @PCKMOV;
LEAVE;
ENDIF;
// EXTRACT THE DATA FROM THE INCOMING STRING
X1 = X;
FOR X2 = 1 TO K2 ;
IF ID(X1) < ' ';
// TRAP NULLS CAUSED BY FLD EXIT
EXSR @PCKMOV;
LEAVE;
ENDIF;
K(X2) = ID(X1);
X1 = X1 +1;
ENDFOR;
// CONSTRUCT THE ACTUAL KEY WITH PACKED DATA IF REQUIRED
// INTO ARRAY KW
EXSR @PCKMOV;
LEAVE;
ENDDO;
ENDFOR;
//
KEYA = KW;
CLEAR KW;
ENDSR ;
// @@@@@@@ @CVTRRN @@@@@@@@@@@@@@@@@@@@@@@@
BEGSR @CVTRRN;
// RRN
NUM11 = 0;
DOW @LOOP = @LOOP; // NOT REALLY A LOOP(SIMULATES GOTO)
// GET THE FIRST SBA
X = 1;
X = %LOOKUP(SBA : ID : X );
IF X = 0;
LEAVE;
ENDIF;
// CHECK THE BUFFER ADDRESS MATCHES THE EXPECTED FIELD
X = X +1;
IF B(1) <> %SUBST(IDA : X :2);
LEAVE;
ENDIF;
// FOUND A MTD FOR RRN FIELD
X = X +2;
//CHECK IF FIELD WAS CLEARED ONLY
IF ID(X) = SBA;
LEAVE;
ENDIF;
// CHECK IF ONLY BLANKS RETURNED
IF %SUBST(IDA : X :11) = *BLANKS;
LEAVE;
ENDIF;
// WRK11 OVERLAYS NUM11
WRK11 = %SUBST(IDA : X :11);
LEAVE;
ENDDO;
RRNA = NUM11;
IF RRNA < 0;
RRNA = 1;
ENDIF;
ENDSR;
// @@@@@@@ @PCKMOV @@@@@@@@@@@@@@@@@@@@@@@@
BEGSR @PCKMOV;
//
// CONVERT KEY DATA
// SET START POSN IN KEY USING OFFSET IN R
W = R(Y) + 1;
// ALPHA
IF T(Y) = 'A';
X1 = 1;
FOR Z = W TO W + Q(Y);
%SUBST(KW : Z : 1) = K(X1);
X1 = X1 + 1;
ENDFOR;
ENDIF;
// NUMERIC FIELD
// RIGHT ADJUST NUMERIC DATA ,STRIP - . ,CONVERT BLANKS
IF (T(Y) = 'S' OR T(Y) = 'P' OR T(Y) = 'B');
NU = '0';
Z1 = 60;
FOR Z = K2 DOWNTO K1;
IF K(Z) = '.' OR K(Z) = '-' OR K(Z) = '$';
ITER;
ENDIF;
IF K(Z) = ' ' ;
NU(Z1) = '0';
ELSE;
NU(Z1) = K(Z);
ENDIF;
Z1 = Z1 -1;
ENDFOR;
ENDIF;
// SIGNED FIELDS (END POSN = OFFSET + SIZE)
IF T(Y) = 'S';
NUS = 0;
FOR VX = 1 TO 60;
NUSA = %TRIM(NUSA) + NU(VX);
ENDFOR;
%SUBST(KW : W : Q(Y)) = %SUBST(NUSA: 61 -Q(Y));
ENDIF;
// PACKED FIELDS
IF T(Y) = 'P';
NUSA= *BLANKS;
FOR VX = 1 TO 60;
NUSA = %TRIM(NUSA) + NU(VX);
ENDFOR;
NUP = %DEC(NUSA : 60 : 0);
%SUBST(KW : W : Q(Y)) = %SUBST(NUPA: 61 -Q(Y));
ENDIF;
// BINARY FIELDS
IF T(Y) = 'B';
IF Q(Y) = 2 ;
BY2 = NU(1) + NU(2);
%SUBST(KW : W : 2) = BY2;
ENDIF;
IF Q(Y) = 4 ;
BY4 = NU(1) + NU(2) + NU(3) + NU(4);
%SUBST(KW : W : 4) = BY4;
ENDIF;
ENDIF;
ENDSR;
// @@@@@@@ SETIN @@@@@@@@@@@@@@@@@@@@@@@@@
BEGSR @SETIN;
// SET the FFR indicators to get the Input buffer somewhat aligned with the
// actual data. RPG is somewhat tolerant to a difference between the Ispecs
// and the actual file size but it can fail on big differences.
// INCREMENT OF 32 BYTES
SZ(1) = BASE + 16;
SZ(2) = SZ(1) + 16;
*IN30 = *ON;
IF (RLEN > SZ(2)) ;
*IN31 = *ON;
ENDIF;
FOR X = 3 TO 64;
SZ(X) = SZ(X-1) + 32;
IF (RLEN > SZ(X)) ;
*IN(29+X) = *ON;
ENDIF;
ENDFOR;
ENDSR;
//@@@@@@@@@@@@@@@@@ @GETF @@@@@@@@@@@@@@@@@
BEGSR @GETF;
// GET A DATA RECORD
IF (*INU1);
IF AID = '1' OR AID = X36 OR
AID = X39 OR AID = X3B ;
SETLL(E) KEYA INPUTK;
READ(E) INPUTK;
IF %EOF;
SETLL(E) KEYA INPUTK;
READP(E) INPUTK;
ENDIF;
ENDIF;
IF AID = '4';
READP(E) INPUTK;
ENDIF;
IF AID = '5';
READ(E) INPUTK;
ENDIF;
IF %ERROR;
SETLL(E) KEYA INPUTK;
READ(E) INPUTK;
MX = 7;
EXSR @ERROR;
EXSR @PUTF ;
EXSR @KEYIN;
ENDIF;
KEYA = LKY;
CLEAR KW;
KW = LKY;
ENDIF;
IF (*INU2);
IF AID = '1';
CHAIN(E) RRNA INPUTR;
IF %ERROR;
SETLL(E) RRNA INPUTR;
READP(E) INPUTR;
ENDIF;
ENDIF;
IF AID = X36;
CHAIN(E) RRNA INPUTR;
ENDIF;
IF AID = '4';
READP(E) INPUTR;
ENDIF;
IF AID = '5' OR AID = X3B;
READ(E) INPUTR;
ENDIF;
IF AID = X39;
SETLL(E) *HIVAL INPUTR;
READP(E) INPUTR;
ENDIF;
IF %ERROR;
CHAIN 1 INPUTR;
MX = 7;
EXSR @ERROR;
EXSR @PUTF ;
EXSR @KEYIN;
ENDIF;
ENDIF;
ENDSR;
//@@@@@@@@@@@@@@@@@ @PUTF @@@@@@@@@@@@@@@@@
BEGSR @PUTF;
// WRITE DATA TO THE DISPLAY
NEWRU = '1';
WRTRRN = '1';
RU = *ALLX'00';
CLEAR RU; // initialise Request Unit 255 bytes max
FOR XX = 1 TO NUMFKY; //NUMBER OF DATA ELEMENTS (FLD AND KEY)
IF NEWRU = '1';
NEWRU = '0';
RU = ESC + WTD + X20 + X00;
ENDIF;
IF WRTRRN = '1';
WRTRRN = '0';
RU = RU + SBA + RBA ;
SELECT;
WHEN *INU1;
RRN = RN1;
WHEN *INU2;
RRN = RN2;
ENDSL;
RU = RU + %TRIM(%EDITC(RRN:'Z'));
ENDIF;
// BUFFER ADDRESS
RU = RU + SBA + B(XX);
// PROCESS ALPHA DATA TYPE
IF T(XX) = 'A' OR T(XX) = 'T' OR T(XX) = 'Z' OR
T(XX) = 'L';
STRX = S(XX);
ENDX = E(XX);
IF V(XX) = 'Y'; //VARYING
VX = S(XX);
HX2 = D(VX) + D(VX+1);
STRX = S(XX) + 2 ;
ENDX = S(XX) + BIN;
ENDIF;
FOR Y = STRX TO ENDX ;
IF D(Y) >= ' ';
RU = RU + D(Y);
ELSE;
RU = RU + X1F ; //IF NOT DISPLAYABLE REPLACE WITH X'1F'
ENDIF;
ENDFOR;
ENDIF;
// PROCESS SIGNED DATA TYPE (not the RRN field)
IF T(XX) = 'S' and KY(XX) <> '3';
NUSA = *ALL'0';
WRV = *ALLX'00';
CLEAR WRV;
FOR Y = S(XX) TO E(XX);
IF D(Y) >= XD0;
WRV = WRV + D(Y);
ENDIF;
ENDFOR;
EVAL NUSA = %SUBST(NUSA : 1 : 60 - %LEN(WRV)) + WRV;
CLEAR WRU;
WRU = %TRIM(WRU) + %EDITW(NUS :WRSWRD);
IF P(XX) > 0;
RU = RU +
%SUBST(WRU :61-C(XX): C(XX)-P(XX)) + '.' +
%SUBST(WRU :61-P(XX)) ;
ELSE;
RU = RU +
%SUBST(WRU :61-C(XX));
ENDIF;
ENDIF;
// PROCESS SIGNED DATA TYPE (the RRN field)
IF T(XX) = 'S' and KY(XX) = '3';
RRN = RN2;
RU = RU + %TRIM(%EDITC(RRN:'X'));
ENDIF;
// PROCESS PACKED DATA TYPE
IF T(XX) = 'P';
NUPA = *ALLX'00';
WRV = *ALLX'00';
CLEAR WRV;
FOR Y = S(XX) TO E(XX);
WRV = WRV + D(Y);
ENDFOR;
IF %BITAND(D(E(XX)) :X0F) = X0F OR
%BITAND(D(E(XX)) :X0D) = X0D;
EVAL NUPA = %SUBST(NUPA : 1 : 60 - %LEN(WRV)) + WRV;
CLEAR WRX;
WRX = %TRIM(WRX) + %EDITW(NUP :WRXWRD);
IF P(XX) > 0;
RU = RU +
%SUBST(WRX :64-C(XX): C(XX)-P(XX)) + '.' +
%SUBST(WRX :64-P(XX)) ;
ELSE;
RU = RU +
%SUBST(WRX :64-C(XX));
ENDIF;
ELSE;
// PACKED FIELD IN ERROR
RU = RU + X1F;
ENDIF;
ENDIF;
// PROCESS BINARY DATA TYPE
IF T(XX) = 'B';
ST = S(XX);
CLEAR NUSA;
IF Q(XX) = 2;
BY2 = D(ST) + D(ST+1);
NUS = BIN2;
ENDIF;
IF Q(XX) = 4;
BY4 = D(ST) + D(ST+1)+ D(ST+2) + D(ST+3);
NUS = BIN4;
ENDIF;
WRU = %EDITW(NUS :WRSWRD);
IF P(XX) > 0;
RU = RU +
%SUBST(WRU :61-C(XX): C(XX)-P(XX)) + '.' +
%SUBST(WRU :61-P(XX)) ;
ELSE;
RU = RU +
%SUBST(WRU :61-C(XX));
ENDIF;
ENDIF;
// PROCESS FLOAT DATA TYPE
IF T(XX) = 'F';
ST = S(XX);
IF Q(XX) = 4;
FL4 = D(ST) + D(ST+1)+ D(ST+2) + D(ST+3);
FLT14 = %EDITFLT(FLT4);
RU = RU + FLT14;
ENDIF;
IF Q(XX) = 8;
FL8 = D(ST) + D(ST+1)+ D(ST+2) + D(ST+3) +
D(ST+4) + D(ST+5)+ D(ST+6) + D(ST+7);
FLT23 = %EDITFLT(FLT8);
RU = RU + FLT23;
ENDIF;
ENDIF;
// SEND A REQUEST UNIT IF GOT ENOUGH DATA
IF %LEN(RU) + L(XX + 1) >= 200;
RU = RU + X20;
BIN = %LEN(RU);
OUTLEN = HX2;
INLEN = X000;
FNC = SND;
A = RU;
EXCEPT DATAO;
NEWRU = '1';
RU = *ALLX'00';
CLEAR RU;
ENDIF;
ENDFOR;
IF %LEN(RU) > 5 AND %LEN(RU) < 250;
RU = RU + X20;
BIN = %LEN(RU);
OUTLEN = HX2;
INLEN = X000;
FNC = SND;
A = RU;
EXCEPT DATAO;
ENDIF;
ENDSR;
// @@@@@@@@@@@@@@@ ROWINC @@@@@@@@@@@@@@@
// INCREMENT THE ROW
BEGSR @ROWINC;
ROW = ROW + 2;
IF ROW > 20;
MX = 3;
ENDIF;
ENDSR;
// @@@@@@@@@@@@@@@ GETFLD @@@@@@@@@@@@@@@
// LOAD FIELD DESCRIPTION ARRAYS
BEGSR @GETFLD;
MX = 0;
X = 0;
IF (*INU2 = *ON);
// IF NON KEYED ACCESS SET UP A FIELD TO SHOW THE RRN
N(1) = 'RRN';
T(1) = 'S' ;
C(1) = 11 ;
P(1) = 0 ;
S(1) = 0 ;
E(1) = 0 ;
L(1) = 12 ;
I(1) = X4F06 ;
KY(1)= '3' ;
X = 1 ;
ENDIF;
SCRST = *BLANK;
SCRSTN = *BLANK;
LVL = %DEC(SCNLVL : 5:0);
TEXT500 = SCNLV ;
LV = LVW;
IF LVL <> 0;
SCRST = LV(LVL);
ENDIF;
SETLL 1 QWHDRFFD ;
DOW @LOOP = @LOOP;
// REREAD TAG
READ QWHDRFFD;
IF %EOF;
LEAVE;
ENDIF;
// SELECT OR OMIT
IF ALL <> '1';
IF ALL = 'S' AND WHDFTL = 0; // USING WHDFTL FOR KEY FIELDS
IF WHFIOB <> 'S';
ITER;
ENDIF;
ENDIF;
IF ALL = 'O' AND WHDFTL = 0; // USING WHDFTL FOR KEY FIELDS
IF WHFIOB = 'O';
ITER;
ENDIF;
ENDIF;
ENDIF;
// FIND THE FIRST FIELD TO BE SHOWN (FOR MULTI PAGE FORMATS)
IF WHDFTL <> 0 ;
ELSE;
IF SCRST <> ' ' AND SCRSTN = ' ';
IF WHFLDE = SCRST;
SCRSTN = '1'; // FOUND THE START
ELSE;
ITER;
ENDIF;
ENDIF;
ENDIF;
X = X + 1;
// CHECK FOR KEY FIELDS,WILL BE USED TO PLACE THEM IN FRONT
IF WHDFTL <> 0;
KY(X) = '1';
WX = WHDFTL ;
KE(WX) = WHFLDE;
IF NUMKEY < WHDFTL;
NUMKEY = WHDFTL;
ENDIF;
ENDIF;
N(X) = WHFLDE ; // NAME
T(X) = WHFLDT ; // TYPE
V(X) = WHVARL ; // VARYING
C(X) = WHFLDD ; // DEC DIGITS
P(X) = WHFLDP ; // DEC PREC
S(X) = WHFOBO ; // START
Q(X) = WHFLDB ; // BTYES
E(X) = WHFOBO + WHFLDB -1 ; // END
IF T(X) = 'F' ; // FLOAT
I(X) = FFA1 + FFA2; // SCRN FIELD FORMAT ALPHA
L(X) = 14;
IF Q(X) = 8;
L(X) = 23;
ENDIF;
ELSE;
IF WHFLDD <> 0 ;
IF WHFLDP <> 0 ;
L(X) = WHFLDD + 2 ; // LENGTH
ELSE;
L(X) = WHFLDD + 1 ; // LENGTH
ENDIF;
I(X) = FFN1 + FFN2; // SCRN FIELD FORMAT NUMERIC
ELSE;
L(X) = WHFLDB ;
I(X) = FFA1 + FFA2; // SCRN FIELD FORMAT ALPHA
ENDIF;
ENDIF;
ENDDO;
// NUMBER OF FIELDS
NUMFLD = X ;
// MAKE ROOM FOR KEYS
IF NUMKEY > 0 ;
X1 = NUMKEY + NUMFLD;
FOR X = NUMFLD DOWNTO 1;
KY(X1) = KY(X) ;
L(X1) = L(X) ;
I(X1) = I(X) ;
N(X1) = N(X) ;
T(X1) = T(X) ;
V(X1) = V(X) ;
C(X1) = C(X) ;
P(X1) = P(X) ;
S(X1) = S(X) ;
E(X1) = E(X) ;
Q(X1) = Q(X) ;
X1 = X1 - 1;
ENDFOR;
// PUT KEY FIELDS AT TOP
OFF = 0;
FOR X = 1 TO NUMKEY;
X1 = %LOOKUP(KE(X) : N : NUMKEY+1);
KY(X) = '2';
L(X) = L(X1);
I(X) = I(X1); // FIELD FMT
SELECT; // INPUT ENABLE
WHEN I(X) = X6000;
I(X) = X4800;
WHEN I(X) = X6706;
I(X) = X4F06;
ENDSL;
N(X) = N(X1);
T(X) = T(X1);
V(X) = V(X1);
C(X) = C(X1);
P(X) = P(X1);
S(X) = S(X1);
E(X) = E(X1);
Q(X) = Q(X1);
R(X) = OFF;
OFF = OFF + Q(X1);
ENDFOR;
ENDIF;
// NUMBER OF FIELDS AND KEYS
NUMFKY = NUMFLD + NUMKEY;
ENDSR;
// @@@@@@@@@@@@@@@ GETADD @@@@@@@@@@@@@@@
// LOAD FIELD BUFFER ADDRESSES
BEGSR @GETADD;
MX = 0;
X = 0;
ROW = 3;
COL = 1;
FOR X = 1 TO NUMFKY;
// IF FINISHED WITH THE KEY FIELDS
// INC ROW FOR 1ST DATA FIELD
IF KEYSOK = ' ' ;
IF KY(X) = ' ' OR KY(X) = '1';
KEYSOK = '1' ;
ROW = ROW + 2;
COL = 1;
ENDIF;
ENDIF;
// SET THE BUFFER ADD ON THE LARGER OF THE FIELD TEXT OR THE FIELD SIZE
LENDSC = %LEN(%TRIM(N(X)));
LENWRK = L(X);
IF LENDSC > L(X);
LENWRK = LENDSC;
ENDIF;
LENWRK = LENWRK + 2;
// TRAP FIELDS THAT OVERFLOW
ROW = ROW + XROW;
XROW = %DIV(LENWRK : 80);
IF (COL + LENWRK) > 78;
EXSR @ROWINC;
IF MX = 3;
X= X-1;
NUMFKY = X;
LEAVE;
ENDIF;
COL = 1;
ENDIF;
// INC COL. FOR FIELD START
CLEAR B(X);
BIN = ROW;
B(X) = %TRIM(B(X)) + HX1;
BIN = COL + 1;
B(X) = %TRIM(B(X)) + HX1;
// INC COL. FOR NEXT FIELD
COL = COL + LENWRK;
IF COL > 78;
EXSR @ROWINC;
IF MX = 3; // NO ROOM FOR THE FIELD
X= X-1;
NUMFKY = X;
LEAVE;
ENDIF;
COL = 1;
ENDIF;
ENDFOR;
// FIELD LEVEL
LVX = LVL + 1;
LV(LVX) = N(X);
ENDSR;
// @@@@@@@@@@@@@@@ PUTHED @@@@@@@@@@@@@@@
// PUT FIELD HEADINGS
BEGSR @PUTHED;
NEWRU = '1';
RU = *ALLX'00';
CLEAR RU; // initialise Request Unit 255 bytes max
FOR XX = 1 TO NUMFKY; //NUMBER OF DATA ELEMENTS (FLD AND KEY)
IF NEWRU = '1';
NEWRU = '0';
RU = ESC + WTD + X20 + X00;
ENDIF;
RU = RU + SBA;
BIN = 0;
// CONVERT DATA BUFADR TO HEADING BUFADR
HX1 = %SUBST(B(XX) :1:1);
BIN = BIN - 1;
RU = RU + HX1;
IF REHEAD = '1'; // ON REDISPLAY OVERRIDE THE ATTR
BIN = 0;
HX1 = %SUBST(B(XX) :2:1);
BIN = BIN -1 ;
RU = RU + HX1;
ELSE;
RU = RU + %SUBST(B(XX) :2);
ENDIF;
RU = RU + ATC ;
// LONG NUMBER FIELDS ,RIGHT ADJUST THE FIELD HEADINGS
LENDSC = %LEN(%TRIM(N(XX)));
IF T(XX) <> 'A' AND LENDSC < (L(XX) -1);
FOR Y = 1 TO (L(XX) -(LENDSC +1));
RU = RU + ' ';
ENDFOR;
ENDIF;
RU = RU + %TRIM(N(XX));
IF %LEN(RU) >= 200;
BIN = %LEN(RU);
OUTLEN = HX2;
INLEN = X000;
FNC = SND;
A = RU;
EXCEPT DATAO;
NEWRU = '1';
RU = *ALLX'00';
CLEAR RU;
ENDIF;
ENDFOR;
IF %LEN(RU) > 5 AND %LEN(RU) < 200;
BIN = %LEN(RU);
OUTLEN = HX2;
INLEN = X000;
FNC = SND;
A = RU;
EXCEPT DATAO;
ENDIF;
IF REHEAD <> '1';
// FORMAT FIELDS
NEWRU = '1';
RU = *ALLX'00';
CLEAR RU; // initialise Request Unit 255 bytes max
FOR XX = 1 TO NUMFKY; //NUMBER OF DATA ELEMENTS (FLD AND KEY)
IF NEWRU = '1';
NEWRU = '0';
RU = ESC + WTD + X20 + X00;
ENDIF;
RU = RU + SBA +B(XX)+SF + I(XX);
IF KY(XX) = '1' OR KY(XX) = '2' OR KY(XX) = '3';
RU = RU + X25;
ELSE;
RU = RU + X26;
ENDIF;
BIN = L(XX);
RU = RU + HX2;
// LENGTH OF INPUT FIELDS
LENF = LENF + L(XX) + 3;
IF %LEN(RU) >= 200;
BIN = %LEN(RU);
OUTLEN = HX2;
INLEN = X000;
FNC = SND;
A = RU;
EXCEPT DATAO;
NEWRU = '1';
RU = *ALLX'00';
CLEAR RU;
ENDIF;
ENDFOR;
// PUT LAST R/U
IF %LEN(RU) > 5 AND %LEN(RU) < 200;
BIN = %LEN(RU);
OUTLEN = HX2;
INLEN = X000;
FNC = SND;
A = RU;
EXCEPT DATAO;
ENDIF;
//INC BUFFER ADDRESS FOR ALL FIELDS FOR DATA PUT
FOR XP = 1 TO NUMFKY; //NUMBER OF DATA ELEMENTS (FLD AND KEY)
HX2 = B(XP);
BIN = BIN + 1;
B(XP) = HX2;
ENDFOR;
ENDIF;
ENDSR;
// @@@@@@@ INIT @@@@@@@@@@@@@@@@@@@@@@@@@
BEGSR @INIT;
CLEAR KW;
// UPDATE
IF UPDF = 'Y';
FFA1 = X40;
FFN1 = X47;
ELSE;
FFA1 = X60;
FFN1 = X67;
ENDIF;
SELECT;
WHEN *INU1 = '1';
FILE = F1 ;
LIB = L1 ;
MBR = M1 ;
RCDL = R1 ;
ACCTP = A1 ;
WHEN *INU2 = '1';
FILE = F2 ;
LIB = L2 ;
MBR = M2 ;
RCDL = R2 ;
ACCTP = A2 ;
ENDSL;
RLEN = RCDL ;
RLENTH = %EDITC(RLEN: 'X') ;
LENF = 0 ;
// Control commands and data are constructed into RUs Request UNITS
// Each RU is 256 bytes max size.
// Construct and send as many RUs as needed to format the display.
RU = *ALLX'00';
CLEAR RU; // initialise Request Unit 255 bytes max
RU = CLRWTD ;
//set up the screen headings
BIN = 1; // set ROW to 1
RW = HX1;
BIN = 2; // set COL to 2
CL = HX1;
RU = RU + SBA + RW + CL + X22 + %TRIM(LIB) + '/' + %TRIM(FILE);
RU = RU + ' Mbr ' + %TRIM(MBR) + ' Rcdl ' + %EDITC(RLEN : 'Z') ;
RU = RU + ' RRN ' ;
BIN = %len(RU) -4;
RBA = RW + HX1 ; // address of the RRN field
RU = RU + SBA + RBA + ' ';
// FUNCTION KEYS
BIN = 23;
RW = HX1;
BIN = 02;
CL = HX1;
IF UPDF = 'Y'; // UPDATE IS ON
RU = RU + SBA + RW + CL + %TRIM(CNS(2));
ELSE;
RU = RU + SBA + RW + CL + %TRIM(CNS(1));
ENDIF;
// THIS IS A SEND ONLY FUNCTION
FNC = SND;
CLEAR A;
A = RU;
BIN2 = %LEN(RU);
OUTLEN = BY2;
INLEN = x000;
EXCEPT DATAO;
ENDSR;
// @@@@@@@ KEYIN @@@@@@@@@@@@@@@@@@@@@@@@@
BEGSR @KEYIN;
// ISSUE A READ FROM DISPLAY
FNC = SNR;
BIN2 = 8;
OUTLEN = BY2;
IPL = LENF + 34;
BIN2 = IPL;
INLEN = BY2;
// SET FRR INDICATORS TO CONTROL BUFFER OVERFLOW
FOR X = 1 TO 9;
IF IPL > ( X*80 +3);
*IN(X+19) = *ON;
ENDIF;
ENDFOR;
RU = *ALLX'00';
CLEAR RU;
RU = RDDSP;
A = RU;
EXCEPT DATAI;
ENDSR;
// @@@@@@@ ERROR @@@@@@@@@@@@@@@@@@@@@@@@@
BEGSR @ERROR;
// SETUP PUT ERROR MESSAGE X'21'
RU = *ALLX'00';
CLEAR RU;
FNC = SNR;
BIN = 42;
OUTLEN = HX2;
BIN = LENF + 34;
IPL = BIN;
INLEN = HX2;
FOR X = 1 TO 9;
IF IPL > (X * 80 +3) ;
*IN(X + 19) = *ON; // SETON FFR 20 - 29 FOR INPUT
ENDIF;
ENDFOR;
RU = ESC + WER + IC + B(1) + ATC + MSG(MX);
RU = RU + ESC + RDM + X40+ X00;
A = RU;
EXCEPT DATAI;
RU = *ALLX'00';
CLEAR RU;
ENDSR;
// @@@@@@@ HXDSP @@@@@@@@@@@@@@@@@@@@@@@@@
BEGSR @HXDSP;
RU = *ALLX'00';
CLEAR RU;
Y = %LOOKUPLE( CURLOC : B );
//
RU = ESC + WTD + X20 + X00 + SBA;
BIN = 0;
HX1 = %SUBST(B(Y) :1:1);
BIN = BIN - 1;
RU = RU + HX1;
RU = RU + %SUBST(B(Y) :2:1);
FOR X = S(Y) TO E(Y);
BIN = 0;
HX1 = D(X);
HX1 = %BITAND(HX1 : XF0);
Z = BIN / 16 + 1;
RU = RU + CRS(Z);
ENDFOR;
RU = RU + X20;
RU = RU + SBA + B(Y);
FOR X = S(Y) TO E(Y);
BIN = 0;
HX1 = D(X);
HX1 = %BITAND(HX1 : X0F);
Z = BIN + 1;
RU = RU + CRS(Z);
ENDFOR;
BIN = %LEN(RU);
OUTLEN = HX2;
INLEN = X000;
FNC = SND;
A = RU;
EXCEPT DATAO;
RU = *ALLX'00';
CLEAR RU;
EXSR @KEYIN;
READ DISPF;
// CLEAR HEADINGS
RU = *ALLX'00';
CLEAR RU;
RU = RU + ESC + WTD + X20 + X00 + SBA;
HX1 = %SUBST(B(Y) :1:1) ;
BIN = BIN - 1;
RU = RU + HX1 + %SUBST(B(Y):2:1);
FOR X = S(Y) TO E(Y);
RU = RU + ' ';
ENDFOR;
RU = RU + ' ';
BIN = %LEN(RU);
OUTLEN = HX2;
INLEN = X000;
FNC = SND;
A = RU;
EXCEPT DATAO;
RU = *ALLX'00';
CLEAR RU;
ENDSR;
/END-FREE
ODISPF E DATAO
O K3 'PUT'
O OUTLEN 2
O INLEN
O FNC
O A
O E DATAI
O K3 'GET'
O OUTLEN 2
O INLEN
O FNC
O A
**
0000 INVALID COMMAND KEY
0001 - A FIELD IS TOO LONG
0002 - TOO MANY FIELDS
0003 - ALPHAS IN PACKED KEY
0004 - MISSING ' IN PACKED KEY
0005 - MISSING DATA IN PCKD KEY
0006 - RECORD NOT FOUND
PRESS RESET TO CONTINUE
**
F1-HEX F2-Return F3-Exit F19-Prev_fld F20-More_fld
F1-HEX F2-Return F3-Exit F19-Prev_fld F20-More_fld
**
0123456789ABCDEF
DISP2 RPG
H*eywords++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++Comments+++++++++++
H OPTION(*NODEBUGIO)
H DFTACTGRP(*NO) ACTGRP(*CALLER) DFTNAME(DISP )
F*
F* LIMITED TO MAXIMUM FILE LENGTH OF 6080
F* REQUIRES FILE QTEMP/FFD TO COMPILE
F* use cmd DSPFFD FILE(&LIB/&FILE) OUTPUT(*OUTFILE) OUTFILE(QTEMP/FFD)
FFFD IF E DISK
FDISPF CF F 803 WORKSTN
F*
F INFDS(INFDS)
FINPUTK IF F32766 800AIDISK KEYLOC(1)
F EXTIND(*INU1)
F INFDS(INFDK)
FINPUTR IF F32766 DISK EXTIND(*INU2)
F INFDS(INFDR)
*
D A S 255 WORK RU
D RU S 255 varying
D RW S 1 ROW 1 byte binary
D CL S 1 COL 1 byte binary
D FNC S 1
D OUTLEN S 2
D INLEN S 2
D IPL S 5 0
D ROW S 3 0
D XROW S 3 0
D COL S 3 0
D KEYSOK S 1
D LENDSC S 3 0
D LENWRK S 5 0
D STRX S 5 0
D ENDX S 5 0
D VX S 5 0
D X S 5 0
D X1 S 5 0
D X2 S 5 0
D XX S 5 0
D XP S 5 0
D MX S 5 0
D ONCE S 1
D RBA S 2
D LF S 5 0
D ST S 5 0
D Y S 5 0
D Z S 5 0
D OFF S 5 0
D SUPZ S 1
D NUMFLD S 5 0
D WX S 5 0
D NUMKEY S 5 0
D NUMFKY S 5 0
D SCRST S 10
D SCRSTN S 1
D KEYA S 800
D RRNA S 11 0
D RRN S 11 0
D REHEAD S 1
D NEWRU S 1
D WRTRRN S 1
D LVX S 5 0
D LVL S 5 0
D K1 S 5 0
D K2 S 5 0
D Z1 S 5 0
D W S 5 0
D WK2 S 2
D MSSG S 32
*
D BASE S 5 0
D INZ S 1
D FILE S 10
D LIB S 10
D MBR S 10
D RCDL S 5 0
D ACCTP S 1
D RLEN S 5 0
D RLENTH S 5
D LENF S 5 0
D DS
D TEXT500 500
D LVW 10 DIM(50) overlay(TEXT500:1)
D TEXT800 S 800
D KW S 800
D DS
D WRK11 1 11
D NUM11 1 11S 0
D DS
D NUSA 1 60
D NUS 1 60S 0
D DS
D NUPA 1 60
D NUP 29 60P 0
D WRU S 61
D WRX S 64
D WRXWRD C '0 -
D -'
D WRSWRD C '0 -
D -'
D WRV S 60 varying
D FLT14 S 14
D FLT23 S 23
* SET FILE SIZE INCREMENTS (64 OF THEM)
D SZ S 5 0 DIM(64)
D S S 5 0 DIM(9000) START OF FLD
D E S 5 0 DIM(9000) END OF FLD
D Q S 5 0 DIM(9000) BYTES IN FIELD
D L S 5 0 DIM(9000) LENGTH OF FLD
D C S 3 0 DIM(9000) DEC DIGITS
D P S 3 0 DIM(9000) DEC PRECISION
D B S 2 DIM(9000) ASCEND BUFFER ADD
D I S 2 DIM(9000) FLD FMT
D N S 10 DIM(9000) FLD NAME
D T S 1 DIM(9000) FLD TYPE
D V S 1 DIM(9000) VARYING
D KY S 1 DIM(9000) KEYED
D KE S 10 DIM(128) KEY FLDS
D R S 3 0 DIM(9000) KEY FLD START
D K S 1 DIM(800) KEY
D NA S 1 DIM(10) NAME WORK
D NU S 1 DIM(60) NUM. WORK
D LV S 10 DIM(50) SCREEN LEVELS
D MSG S 32 DIM(8) CTDATA PERRCD(1) MESSAGES
D CNS S 50 DIM(2) CTDATA PERRCD(1)
D CRS S 1 DIM(16) CTDATA PERRCD(16)
D DS
D D 1 6080
D DIM(6080) INCOMING DATA
D DA 1 4048
D DB 4049 4064
D DC 4065 4096
D DD 4097 4128
D DE 4129 4160
D DF 4161 4192
D DG 4193 4224
D DH 4225 4256
D DI 4257 4288
D DJ 4289 4320
D DK 4321 4352
D DL 4353 4384
D DM 4385 4416
D DN 4417 4448
D DZ 4449 4480
D DO 4481 4512
D DP 4513 4544
D DQ 4545 4576
D DR 4577 4608
D DS 4609 4640
D DT 4641 4672
D DU 4673 4704
D DV 4705 4736
D DW 4737 4768
D DX 4769 4800
D DY 4801 4832
D D0 4833 4864
D D1 4865 4896
D D2 4897 4928
D D3 4929 4960
D D4 4961 4992
D D5 4993 5024
D D6 5025 5056
D DBA 5057 5088
D DCA 5089 5120
D DDA 5121 5152
D DEA 5153 5184
D DFA 5185 5216
D DGA 5217 5248
D DHA 5249 5280
D DIA 5281 5312
D DJA 5313 5344
D DKA 5345 5376
D DLA 5377 5408
D DMA 5409 5440
D DNA 5441 5472
D DOA 5473 5504
D DPA 5505 5536
D DQA 5537 5568
D DRA 5569 5600
D DSA 5601 5632
D DTA 5633 5664
D DUA 5665 5696
D DVA 5697 5728
D DWA 5729 5760
D DXA 5761 5792
D DYA 5793 5824
D DZA 5825 5856
D D0A 5857 5888
D D1A 5889 5920
D D2A 5921 5952
D D3A 5953 5984
D D4A 5985 6016
D D5A 6017 6048
D D6A 6049 6080
D DS
D ID 1 800
D DIM(800) INCOMING DATA
D IDA 1 800
D ID0 1 80
D ID1 81 160
D ID2 161 240
D ID3 241 320
D ID4 321 400
D ID5 401 480
D ID6 481 560
D ID7 561 640
D ID8 641 720
D ID9 721 800
D DS
D BIN 1 2B 0
D HX1 2 2
D HX2 1 2
D DS
D PCK 1 1P 0
D PCK1 1 1
D DS
D SGN 1 1S 0
D SGN1 1 1
D DS
D BIN4 1 4B 0
D BY4 1 4
D DS
D BIN2 1 2B 0
D BY2 1 2
D DS
D FLT4 1 4F
D FL4 1 4
D DS
D FLT8 1 8F
D FL8 1 8
D INFDK DS
D F1 83 92
D L1 93 102
D M1 129 138
D R1 125 126B 0
D A1 160 160
D LOP1 260 260
D KEY_LEN 393 394I 0 Key length
D RN1 397 400B 0
D LKY 401 1200
D INFDR DS
D F2 83 92
D L2 93 102
D M2 129 138
D R2 125 126B 0
D A2 160 160
D LOP2 260 260
D RN2 397 400B 0
D*
D INFDS DS
D CURLOC 370 371
D DS
D KEYLN 1 4S 0
D KEYLNA 1 4
DDISP2 PR
D 1
D 1
D 4
D 1
D 500
D 5
D 800
DDISP2 PI
D ALL 1
D RTN 1
D KEYLNG 4
D UPDF 1
D SCNLV 500
D SCNLVL 5
D SCNKEY 800
D @LOOP C '1'
D SND C X'71' SEND TO DISP
D SNR C X'73' SND/RCV
D RED C X'42' READ
D RDM C X'52' READ MTD
D ESC C X'04' ESCAPE
D CLR C X'40' CLEAR UNIT
D CC1 C X'00' CNTRL CHAR
D CC2 C X'08' CNTRL CHAR
D SBA C X'11' SET BUFF ADR
D IC C X'13' INSERT CURS
D WTD C X'11' WRITE TO DSP
D WER C X'21' WRITE ERROR
D SF C X'1D' START FLD
D ATC C X'20' ATTR CHAR
D ATN C X'24' ATTR NUM
D X00 C X'00'
D X01 C X'01'
D X02 C X'02'
D X03 C X'03'
D X0D C X'0D'
D X0F C X'0F'
D X000 C X'0000'
D X1F C X'1F'
D X20 C X'20' SCRN ATT NORMAL
D X22 C X'22' SCRN ATTR HI
D X25 C X'25'
D X26 C X'26'
D X31 C X'31' CMD 1 KEY
D X32 C X'32' CMD 2 KEY
D X33 C X'33' CMD 3 KEY
D X36 C X'36' CMD 6 KEY
D X37 C X'37' CMD 7 KEY
D X38 C X'38' CMD 8 KEY
D X39 C X'39' CMD 9 KEY
D X3B C X'3B' CMD11 KEY
D XB7 C X'B7' CMD19 KEY
D XB8 C X'B8' CMD20 KEY
D X40 C X'40'
D X43 C X'43'
D X47 C X'47'
D X60 C X'60'
D X67 C X'67'
D X9F C X'9F'
D XF0 C X'F0'
D XD0 C X'D0'
D X4000 C X'4000'
D X4800 C X'4800' FF ALPHA
D X4F06 C X'4F06' FF NUMERIC
D X6000 C X'6000' FF ALPHA
D X6706 C X'6706' FF NUMERIC
D CLRWTD C X'044004112000' INCLUDES ESC CHARS
D RDDSP C X'0411200804524000' REAB FROM DISPLAY
D FFA1 S 1 INZ(X'40') F.FMT 1 ALPH 60 BYP
D FFA2 S 1 INZ(X'00') F.FMT 2 ALPH
D FFN1 S 1 INZ(X'47') F.FMT 1 NUM 67 BYP
D FFN2 S 1 INZ(X'06') F.FMT 2 NUM
I*.
IINPUTK NS 01
I 1 4048 DA
I 4049 4064 DB 30
I 4065 4096 DC 31
I 4097 4128 DD 32
I 4129 4160 DE 33
I 4161 4192 DF 34
I 4193 4224 DG 35
I 4225 4256 DH 36
I 4257 4288 DI 37
I 4289 4320 DJ 38
I 4321 4352 DK 39
I 4353 4384 DL 40
I 4385 4416 DM 41
I 4417 4448 DN 42
I 4449 4480 DZ 43
I 4481 4512 DO 44
I 4513 4544 DP 45
I 4545 4576 DQ 46
I 4577 4608 DR 47
I 4609 4640 DS 48
I 4641 4672 DT 49
I 4673 4704 DU 50
I 4705 4736 DV 51
I 4737 4768 DW 52
I 4769 4800 DX 53
I 4801 4832 DY 54
I 4833 4864 D0 55
I 4865 4896 D1 56
I 4897 4928 D2 57
I 4929 4960 D3 58
I 4961 4992 D4 59
I 4993 5024 D5 60
I 5025 5056 D6 61
I 5057 5088 DBA 62
I 5089 5120 DCA 63
I 5121 5152 DDA 64
I 5153 5184 DEA 65
I 5185 5216 DFA 66
I 5217 5248 DGA 67
I 5249 5280 DHA 68
I 5281 5312 DIA 69
I 5313 5344 DJA 70
I 5345 5376 DKA 71
I 5377 5408 DLA 72
I 5409 5440 DMA 73
I 5441 5472 DNA 74
I 5473 5504 DOA 75
I 5505 5536 DPA 76
I 5537 5568 DQA 77
I 5569 5600 DRA 78
I 5601 5632 DSA 79
I 5633 5664 DTA 80
I 5665 5696 DUA 81
I 5697 5728 DVA 82
I 5729 5760 DWA 83
I 5761 5792 DXA 84
I 5793 5824 DYA 85
I 5825 5856 DZA 86
I 5857 5888 D0A 87
I 5889 5920 D1A 88
I 5921 5952 D2A 89
I 5953 5984 D3A 90
I 5985 6016 D4A 91
I 6017 6048 D5A 92
I 6049 6080 D6A 93
IINPUTR NS 01
I 1 4048 DA
I 4049 4064 DB 30
I 4065 4096 DC 31
I 4097 4128 DD 32
I 4129 4160 DE 33
I 4161 4192 DF 34
I 4193 4224 DG 35
I 4225 4256 DH 36
I 4257 4288 DI 37
I 4289 4320 DJ 38
I 4321 4352 DK 39
I 4353 4384 DL 40
I 4385 4416 DM 41
I 4417 4448 DN 42
I 4449 4480 DZ 43
I 4481 4512 DO 44
I 4513 4544 DP 45
I 4545 4576 DQ 46
I 4577 4608 DR 47
I 4609 4640 DS 48
I 4641 4672 DT 49
I 4673 4704 DU 50
I 4705 4736 DV 51
I 4737 4768 DW 52
I 4769 4800 DX 53
I 4801 4832 DY 54
I 4833 4864 D0 55
I 4865 4896 D1 56
I 4897 4928 D2 57
I 4929 4960 D3 58
I 4961 4992 D4 59
I 4993 5024 D5 60
I 5025 5056 D6 61
I 5057 5088 DBA 62
I 5089 5120 DCA 63
I 5121 5152 DDA 64
I 5153 5184 DEA 65
I 5185 5216 DFA 66
I 5217 5248 DGA 67
I 5249 5280 DHA 68
I 5281 5312 DIA 69
I 5313 5344 DJA 70
I 5345 5376 DKA 71
I 5377 5408 DLA 72
I 5409 5440 DMA 73
I 5441 5472 DNA 74
I 5473 5504 DOA 75
I 5505 5536 DPA 76
I 5537 5568 DQA 77
I 5569 5600 DRA 78
I 5601 5632 DSA 79
I 5633 5664 DTA 80
I 5665 5696 DUA 81
I 5697 5728 DVA 82
I 5729 5760 DWA 83
I 5761 5792 DXA 84
I 5793 5824 DYA 85
I 5825 5856 DZA 86
I 5857 5888 D0A 87
I 5889 5920 D1A 88
I 5921 5952 D2A 89
I 5953 5984 D3A 90
I 5985 6016 D4A 91
I 6017 6048 D5A 92
I 6049 6080 D6A 93
IDISPF NS 02
I 3 3 AID
I 4 83 ID0
I 84 163 ID1 20
I 164 243 ID2 21
I 244 323 ID3 22
I 324 403 ID4 23
I 404 483 ID5 24
I 484 563 ID6 25
I 564 643 ID7 26
I 644 723 ID8 27
I 724 803 ID9 28
/FREE
BASE = 0;
IF ONCE = ' ';
EXSR @INITZ ;
ENDIF;
// START TAG
DOW @LOOP = @LOOP;
IF RTN = '3';
IF *INU1;
KEYA = SCNKEY;
ENDIF;
IF *INU2;
RRNA = %DEC(%SUBST(SCNKEY:1:11):11:0);
ENDIF;
RTN = '0';
AID = '1';
ELSE;
RTN = '0';
READ(E) DISPF;
ENDIF;
// CF3 EXIT
IF AID = X33;
LEAVE;
ENDIF;
// CF2 RETURN
IF AID = X32;
RTN = '1';
LEAVE;
ENDIF;
// CF1 HEX A FIELD
IF AID = X31;
Y = %LOOKUPLE( CURLOC : B );
IF Y > 0;
IF KY(Y) <= '1';
EXSR @HXDSP;
REHEAD = '1';
EXSR @PUTHED;
REHEAD = ' ';
ENDIF;
ENDIF;
ENDIF;
// CF20 MORE FIELDS
IF AID = XB8;
LVX = LVL + 1;
IF LV(LVX) <> *BLANK;
LVL = LVL +1 ;
LVW = LV;
SCNLV = TEXT500;
SCNLVL = %EDITC(LVL :'X');
SCNKEY = *BLANKS;
IF *INU1;
SCNKEY = KEYA;
ENDIF;
IF *INU2;
SCNKEY = %EDITC(RRNA:'X');
ENDIF;
RTN = '3';
LEAVE;
ENDIF;
ENDIF;
// CF19 PREVIOUS FIELDS
IF AID = XB7;
LVX = LVL - 1;
IF LVX >= 0 ;
LVL = LVL - 1 ;
LVW = LV;
SCNLV = TEXT500;
SCNLVL = %EDITC(LVL :'X');
SCNKEY = *BLANKS;
IF *INU1;
SCNKEY = KEYA;
ENDIF;
IF *INU2;
SCNKEY = %EDITC(RRNA:'X');
ENDIF;
RTN = '3';
LEAVE;
ENDIF;
ENDIF;
// 1 ENTER
// 4 ROLL DN
// 5 ROLL UP
IF AID = '1'or AID = '4' or AID = '5';
ELSE;
MX = 1;
EXSR @ERROR;
ENDIF;
IF RTN <> '3';
EXSR @PCKD;
ENDIF;
// CONT1 GET A RECORD, KEY FROM DATA
EXSR @SETIN;
EXSR @GETF ;
EXSR @PUTF ;
EXSR @KEYIN;
ENDDO ;
*INLR = *ON;
// @@@@@@@ @INITZ @@@@@@@@@@@@@@@@@@@@@@@@@@
BEGSR @INITZ;
ONCE = '1';
KEYLNA = KEYLNG ;
EXSR @INIT ;
EXSR @GETFLD ;
EXSR @GETADD ;
EXSR @PUTHED ;
EXSR @KEYIN ;
INZ = '1';
EXSR @PCKD ;
INZ = ' ';
ENDSR;
// @@@@@@@ @PCKD @@@@@@@@@@@@@@@@@@@@@@@@@@
BEGSR @PCKD ;
// CONVERT KEY DATA
IF *INU1 ;
EXSR @CVTKEY;
ENDIF;
IF *INU2 ;
EXSR @CVTRRN;
ENDIF;
ENDSR;
// @@@@@@@ @CVTKEY @@@@@@@@@@@@@@@@@@@@@@@@
BEGSR @CVTKEY;
// EXTRACT THE KEY FIELD DATA FROM THE INCOMING STRING
// FOR EACH KEY FIELD, CHECK IF FIELD WAS MODIFIED, AND IF SO MOVE
// THE MODIFIED DATA INTO THE COMPOSITE KEY
K1 = 0;
K2 = 0;
W = 1;
FOR Y = 1 TO NUMKEY ;
// MOVE A KEY FIELDS DATA FROM ID ARRAY (SCREEN) TO K ARRAY (KEY FIELDS)
// GET SIZE OF FIELD IN BYTES
IF T(Y) = 'A'; // ALPHA DATA
K = ' ';
K1 = 1;
K2 = Q(Y);
ELSE;
K = '0';
K1 = 1;
K2 = C(Y);
ENDIF;
// IF WHOLE KEY INIT WAS REQUESTED BYPASS THE EXTRACT
IF INZ = '1' ;
KW = *BLANK;
EXSR @PCKMOV;
ITER;
ENDIF;
X = 1;
DOW @LOOP = @LOOP;
// NXTSBA
X = %LOOKUP(SBA : ID : X );
IF X = 0;
LEAVE;
ENDIF;
// IS THIS THE FIELD? CHECK THE BUFFER ADDRESS
X = X +1;
IF B(Y) <> %SUBST(IDA : X :2);
ITER;
ENDIF;
// FOUND A MTD FOR THIS FIELD
X = X + 2;
// CHECK IF FIELD WAS CLEARED ONLY
IF ID(X) = SBA;
EXSR @PCKMOV;
LEAVE ;
ENDIF;
// IF FIELD HAS DECIMALS BUMP X
IF (T(Y) = 'S' OR T(Y) = 'P' OR T(Y) = 'B') AND
P(Y) > 0;
X = X + 1;
ENDIF;
// CHECK IF ONLY BLANKS RETURNED
IF %SUBST(IDA : X :K2) = *BLANKS;
EXSR @PCKMOV;
LEAVE;
ENDIF;
// EXTRACT THE DATA FROM THE INCOMING STRING
X1 = X;
FOR X2 = 1 TO K2 ;
IF ID(X1) < ' ';
// TRAP NULLS CAUSED BY FLD EXIT
EXSR @PCKMOV;
LEAVE;
ENDIF;
K(X2) = ID(X1);
X1 = X1 +1;
ENDFOR;
// CONSTRUCT THE ACTUAL KEY WITH PACKED DATA IF REQUIRED
// INTO ARRAY KW
EXSR @PCKMOV;
LEAVE;
ENDDO;
ENDFOR;
//
KEYA = KW;
CLEAR KW;
ENDSR ;
// @@@@@@@ @CVTRRN @@@@@@@@@@@@@@@@@@@@@@@@
BEGSR @CVTRRN;
// RRN
NUM11 = 0;
DOW @LOOP = @LOOP; // NOT REALLY A LOOP(SIMULATES GOTO)
// GET THE FIRST SBA
X = 1;
X = %LOOKUP(SBA : ID : X );
IF X = 0;
LEAVE;
ENDIF;
// CHECK THE BUFFER ADDRESS MATCHES THE EXPECTED FIELD
X = X +1;
IF B(1) <> %SUBST(IDA : X :2);
LEAVE;
ENDIF;
// FOUND A MTD FOR RRN FIELD
X = X +2;
//CHECK IF FIELD WAS CLEARED ONLY
IF ID(X) = SBA;
LEAVE;
ENDIF;
// CHECK IF ONLY BLANKS RETURNED
IF %SUBST(IDA : X :11) = *BLANKS;
LEAVE;
ENDIF;
// WRK11 OVERLAYS NUM11
WRK11 = %SUBST(IDA : X :11);
LEAVE;
ENDDO;
RRNA = NUM11;
IF RRNA < 0;
RRNA = 1;
ENDIF;
ENDSR;
// @@@@@@@ @PCKMOV @@@@@@@@@@@@@@@@@@@@@@@@
BEGSR @PCKMOV;
//
// CONVERT KEY DATA
// SET START POSN IN KEY USING OFFSET IN R
W = R(Y) + 1;
// ALPHA
IF T(Y) = 'A';
X1 = 1;
FOR Z = W TO W + Q(Y);
%SUBST(KW : Z : 1) = K(X1);
X1 = X1 + 1;
ENDFOR;
ENDIF;
// NUMERIC FIELD
// RIGHT ADJUST NUMERIC DATA ,STRIP - . ,CONVERT BLANKS
IF (T(Y) = 'S' OR T(Y) = 'P' OR T(Y) = 'B');
NU = '0';
Z1 = 60;
FOR Z = K2 DOWNTO K1;
IF K(Z) = '.' OR K(Z) = '-' OR K(Z) = '$';
ITER;
ENDIF;
IF K(Z) = ' ' ;
NU(Z1) = '0';
ELSE;
NU(Z1) = K(Z);
ENDIF;
Z1 = Z1 -1;
ENDFOR;
ENDIF;
// SIGNED FIELDS (END POSN = OFFSET + SIZE)
IF T(Y) = 'S';
NUS = 0;
FOR VX = 1 TO 60;
NUSA = %TRIM(NUSA) + NU(VX);
ENDFOR;
%SUBST(KW : W : Q(Y)) = %SUBST(NUSA: 61 -Q(Y));
ENDIF;
// PACKED FIELDS
IF T(Y) = 'P';
NUSA= *BLANKS;
FOR VX = 1 TO 60;
NUSA = %TRIM(NUSA) + NU(VX);
ENDFOR;
NUP = %DEC(NUSA : 60 : 0);
%SUBST(KW : W : Q(Y)) = %SUBST(NUPA: 61 -Q(Y));
ENDIF;
// BINARY FIELDS
IF T(Y) = 'B';
IF Q(Y) = 2 ;
BY2 = NU(1) + NU(2);
%SUBST(KW : W : 2) = BY2;
ENDIF;
IF Q(Y) = 4 ;
BY4 = NU(1) + NU(2) + NU(3) + NU(4);
%SUBST(KW : W : 4) = BY4;
ENDIF;
ENDIF;
ENDSR;
// @@@@@@@ SETIN @@@@@@@@@@@@@@@@@@@@@@@@@
BEGSR @SETIN;
// SET the FFR indicators to get the Input buffer somewhat aligned with the
// actual data. RPG is somewhat tolerant to a difference between the Ispecs
// and the actual file size but it can fail on big differences.
// INCREMENT OF 32 BYTES
SZ(1) = BASE + 16;
SZ(2) = SZ(1) + 16;
*IN30 = *ON;
IF (RLEN > SZ(2)) ;
*IN31 = *ON;
ENDIF;
FOR X = 3 TO 64;
SZ(X) = SZ(X-1) + 32;
IF (RLEN > SZ(X)) ;
*IN(29+X) = *ON;
ENDIF;
ENDFOR;
ENDSR;
//@@@@@@@@@@@@@@@@@ @GETF @@@@@@@@@@@@@@@@@
BEGSR @GETF;
// GET A DATA RECORD
IF (*INU1);
IF AID = '1' OR AID = X36 OR
AID = X39 OR AID = X3B ;
SETLL(E) KEYA INPUTK;
READ(E) INPUTK;
IF %EOF;
SETLL(E) KEYA INPUTK;
READP(E) INPUTK;
ENDIF;
ENDIF;
IF AID = '4';
READP(E) INPUTK;
ENDIF;
IF AID = '5';
READ(E) INPUTK;
ENDIF;
IF %ERROR;
SETLL(E) KEYA INPUTK;
READ(E) INPUTK;
MX = 7;
EXSR @ERROR;
EXSR @PUTF ;
EXSR @KEYIN;
ENDIF;
KEYA = LKY;
CLEAR KW;
KW = LKY;
ENDIF;
IF (*INU2);
IF AID = '1';
CHAIN(E) RRNA INPUTR;
IF %ERROR;
SETLL(E) RRNA INPUTR;
READP(E) INPUTR;
ENDIF;
ENDIF;
IF AID = X36;
CHAIN(E) RRNA INPUTR;
ENDIF;
IF AID = '4';
READP(E) INPUTR;
ENDIF;
IF AID = '5' OR AID = X3B;
READ(E) INPUTR;
ENDIF;
IF AID = X39;
SETLL(E) *HIVAL INPUTR;
READP(E) INPUTR;
ENDIF;
IF %ERROR;
CHAIN 1 INPUTR;
MX = 7;
EXSR @ERROR;
EXSR @PUTF ;
EXSR @KEYIN;
ENDIF;
ENDIF;
ENDSR;
//@@@@@@@@@@@@@@@@@ @PUTF @@@@@@@@@@@@@@@@@
BEGSR @PUTF;
// WRITE DATA TO THE DISPLAY
NEWRU = '1';
WRTRRN = '1';
RU = *ALLX'00';
CLEAR RU; // initialise Request Unit 255 bytes max
FOR XX = 1 TO NUMFKY; //NUMBER OF DATA ELEMENTS (FLD AND KEY)
IF NEWRU = '1';
NEWRU = '0';
RU = ESC + WTD + X20 + X00;
ENDIF;
IF WRTRRN = '1';
WRTRRN = '0';
RU = RU + SBA + RBA ;
SELECT;
WHEN *INU1;
RRN = RN1;
WHEN *INU2;
RRN = RN2;
ENDSL;
RU = RU + %TRIM(%EDITC(RRN:'Z'));
ENDIF;
// BUFFER ADDRESS
RU = RU + SBA + B(XX);
// PROCESS ALPHA DATA TYPE
IF T(XX) = 'A' OR T(XX) = 'T' OR T(XX) = 'Z' OR
T(XX) = 'L';
STRX = S(XX);
ENDX = E(XX);
IF V(XX) = 'Y'; //VARYING
VX = S(XX);
HX2 = D(VX) + D(VX+1);
STRX = S(XX) + 2 ;
ENDX = S(XX) + BIN;
ENDIF;
FOR Y = STRX TO ENDX ;
IF D(Y) >= ' ';
RU = RU + D(Y);
ELSE;
RU = RU + X1F ; //IF NOT DISPLAYABLE REPLACE WITH X'1F'
ENDIF;
ENDFOR;
ENDIF;
// PROCESS SIGNED DATA TYPE (not the RRN field)
IF T(XX) = 'S' and KY(XX) <> '3';
NUSA = *ALL'0';
WRV = *ALLX'00';
CLEAR WRV;
FOR Y = S(XX) TO E(XX);
IF D(Y) >= XD0;
WRV = WRV + D(Y);
ENDIF;
ENDFOR;
EVAL NUSA = %SUBST(NUSA : 1 : 60 - %LEN(WRV)) + WRV;
CLEAR WRU;
WRU = %TRIM(WRU) + %EDITW(NUS :WRSWRD);
IF P(XX) > 0;
RU = RU +
%SUBST(WRU :61-C(XX): C(XX)-P(XX)) + '.' +
%SUBST(WRU :61-P(XX)) ;
ELSE;
RU = RU +
%SUBST(WRU :61-C(XX));
ENDIF;
ENDIF;
// PROCESS SIGNED DATA TYPE (the RRN field)
IF T(XX) = 'S' and KY(XX) = '3';
RRN = RN2;
RU = RU + %TRIM(%EDITC(RRN:'X'));
ENDIF;
// PROCESS PACKED DATA TYPE
IF T(XX) = 'P';
NUPA = *ALLX'00';
WRV = *ALLX'00';
CLEAR WRV;
FOR Y = S(XX) TO E(XX);
WRV = WRV + D(Y);
ENDFOR;
IF %BITAND(D(E(XX)) :X0F) = X0F OR
%BITAND(D(E(XX)) :X0D) = X0D;
EVAL NUPA = %SUBST(NUPA : 1 : 60 - %LEN(WRV)) + WRV;
CLEAR WRX;
WRX = %TRIM(WRX) + %EDITW(NUP :WRXWRD);
IF P(XX) > 0;
RU = RU +
%SUBST(WRX :64-C(XX): C(XX)-P(XX)) + '.' +
%SUBST(WRX :64-P(XX)) ;
ELSE;
RU = RU +
%SUBST(WRX :64-C(XX));
ENDIF;
ELSE;
// PACKED FIELD IN ERROR
RU = RU + X1F;
ENDIF;
ENDIF;
// PROCESS BINARY DATA TYPE
IF T(XX) = 'B';
ST = S(XX);
CLEAR NUSA;
IF Q(XX) = 2;
BY2 = D(ST) + D(ST+1);
NUS = BIN2;
ENDIF;
IF Q(XX) = 4;
BY4 = D(ST) + D(ST+1)+ D(ST+2) + D(ST+3);
NUS = BIN4;
ENDIF;
WRU = %EDITW(NUS :WRSWRD);
IF P(XX) > 0;
RU = RU +
%SUBST(WRU :61-C(XX): C(XX)-P(XX)) + '.' +
%SUBST(WRU :61-P(XX)) ;
ELSE;
RU = RU +
%SUBST(WRU :61-C(XX));
ENDIF;
ENDIF;
// PROCESS FLOAT DATA TYPE
IF T(XX) = 'F';
ST = S(XX);
IF Q(XX) = 4;
FL4 = D(ST) + D(ST+1)+ D(ST+2) + D(ST+3);
FLT14 = %EDITFLT(FLT4);
RU = RU + FLT14;
ENDIF;
IF Q(XX) = 8;
FL8 = D(ST) + D(ST+1)+ D(ST+2) + D(ST+3) +
D(ST+4) + D(ST+5)+ D(ST+6) + D(ST+7);
FLT23 = %EDITFLT(FLT8);
RU = RU + FLT23;
ENDIF;
ENDIF;
// SEND A REQUEST UNIT IF GOT ENOUGH DATA
IF %LEN(RU) + L(XX + 1) >= 200;
RU = RU + X20;
BIN = %LEN(RU);
OUTLEN = HX2;
INLEN = X000;
FNC = SND;
A = RU;
EXCEPT DATAO;
NEWRU = '1';
RU = *ALLX'00';
CLEAR RU;
ENDIF;
ENDFOR;
IF %LEN(RU) > 5 AND %LEN(RU) < 250;
RU = RU + X20;
BIN = %LEN(RU);
OUTLEN = HX2;
INLEN = X000;
FNC = SND;
A = RU;
EXCEPT DATAO;
ENDIF;
ENDSR;
// @@@@@@@@@@@@@@@ ROWINC @@@@@@@@@@@@@@@
// INCREMENT THE ROW
BEGSR @ROWINC;
ROW = ROW + 2;
IF ROW > 20;
MX = 3;
ENDIF;
ENDSR;
// @@@@@@@@@@@@@@@ GETFLD @@@@@@@@@@@@@@@
// LOAD FIELD DESCRIPTION ARRAYS
BEGSR @GETFLD;
MX = 0;
X = 0;
IF (*INU2 = *ON);
// IF NON KEYED ACCESS SET UP A FIELD TO SHOW THE RRN
N(1) = 'RRN';
T(1) = 'S' ;
C(1) = 11 ;
P(1) = 0 ;
S(1) = 0 ;
E(1) = 0 ;
L(1) = 12 ;
I(1) = X4F06 ;
KY(1)= '3' ;
X = 1 ;
ENDIF;
SCRST = *BLANK;
SCRSTN = *BLANK;
LVL = %DEC(SCNLVL : 5:0);
TEXT500 = SCNLV ;
LV = LVW;
IF LVL <> 0;
SCRST = LV(LVL);
ENDIF;
SETLL 1 QWHDRFFD ;
DOW @LOOP = @LOOP;
// REREAD TAG
READ QWHDRFFD;
IF %EOF;
LEAVE;
ENDIF;
// SELECT OR OMIT
IF ALL <> '1';
IF ALL = 'S' AND WHDFTL = 0; // USING WHDFTL FOR KEY FIELDS
IF WHFIOB <> 'S';
ITER;
ENDIF;
ENDIF;
IF ALL = 'O' AND WHDFTL = 0; // USING WHDFTL FOR KEY FIELDS
IF WHFIOB = 'O';
ITER;
ENDIF;
ENDIF;
ENDIF;
// FIND THE FIRST FIELD TO BE SHOWN (FOR MULTI PAGE FORMATS)
IF WHDFTL <> 0 ;
ELSE;
IF SCRST <> ' ' AND SCRSTN = ' ';
IF WHFLDE = SCRST;
SCRSTN = '1'; // FOUND THE START
ELSE;
ITER;
ENDIF;
ENDIF;
ENDIF;
X = X + 1;
// CHECK FOR KEY FIELDS,WILL BE USED TO PLACE THEM IN FRONT
IF WHDFTL <> 0;
KY(X) = '1';
WX = WHDFTL ;
KE(WX) = WHFLDE;
IF NUMKEY < WHDFTL;
NUMKEY = WHDFTL;
ENDIF;
ENDIF;
N(X) = WHFLDE ; // NAME
T(X) = WHFLDT ; // TYPE
V(X) = WHVARL ; // VARYING
C(X) = WHFLDD ; // DEC DIGITS
P(X) = WHFLDP ; // DEC PREC
S(X) = WHFOBO ; // START
Q(X) = WHFLDB ; // BTYES
E(X) = WHFOBO + WHFLDB -1 ; // END
IF T(X) = 'F' ; // FLOAT
I(X) = FFA1 + FFA2; // SCRN FIELD FORMAT ALPHA
L(X) = 14;
IF Q(X) = 8;
L(X) = 23;
ENDIF;
ELSE;
IF WHFLDD <> 0 ;
IF WHFLDP <> 0 ;
L(X) = WHFLDD + 2 ; // LENGTH
ELSE;
L(X) = WHFLDD + 1 ; // LENGTH
ENDIF;
I(X) = FFN1 + FFN2; // SCRN FIELD FORMAT NUMERIC
ELSE;
L(X) = WHFLDB ;
I(X) = FFA1 + FFA2; // SCRN FIELD FORMAT ALPHA
ENDIF;
ENDIF;
ENDDO;
// NUMBER OF FIELDS
NUMFLD = X ;
// MAKE ROOM FOR KEYS
IF NUMKEY > 0 ;
X1 = NUMKEY + NUMFLD;
FOR X = NUMFLD DOWNTO 1;
KY(X1) = KY(X) ;
L(X1) = L(X) ;
I(X1) = I(X) ;
N(X1) = N(X) ;
T(X1) = T(X) ;
V(X1) = V(X) ;
C(X1) = C(X) ;
P(X1) = P(X) ;
S(X1) = S(X) ;
E(X1) = E(X) ;
Q(X1) = Q(X) ;
X1 = X1 - 1;
ENDFOR;
// PUT KEY FIELDS AT TOP
OFF = 0;
FOR X = 1 TO NUMKEY;
X1 = %LOOKUP(KE(X) : N : NUMKEY+1);
KY(X) = '2';
L(X) = L(X1);
I(X) = I(X1); // FIELD FMT
SELECT; // INPUT ENABLE
WHEN I(X) = X6000;
I(X) = X4800;
WHEN I(X) = X6706;
I(X) = X4F06;
ENDSL;
N(X) = N(X1);
T(X) = T(X1);
V(X) = V(X1);
C(X) = C(X1);
P(X) = P(X1);
S(X) = S(X1);
E(X) = E(X1);
Q(X) = Q(X1);
R(X) = OFF;
OFF = OFF + Q(X1);
ENDFOR;
ENDIF;
// NUMBER OF FIELDS AND KEYS
NUMFKY = NUMFLD + NUMKEY;
ENDSR;
// @@@@@@@@@@@@@@@ GETADD @@@@@@@@@@@@@@@
// LOAD FIELD BUFFER ADDRESSES
BEGSR @GETADD;
MX = 0;
X = 0;
ROW = 3;
COL = 1;
FOR X = 1 TO NUMFKY;
// IF FINISHED WITH THE KEY FIELDS
// INC ROW FOR 1ST DATA FIELD
IF KEYSOK = ' ' ;
IF KY(X) = ' ' OR KY(X) = '1';
KEYSOK = '1' ;
ROW = ROW + 2;
COL = 1;
ENDIF;
ENDIF;
// SET THE BUFFER ADD ON THE LARGER OF THE FIELD TEXT OR THE FIELD SIZE
LENDSC = %LEN(%TRIM(N(X)));
LENWRK = L(X);
IF LENDSC > L(X);
LENWRK = LENDSC;
ENDIF;
LENWRK = LENWRK + 2;
// TRAP FIELDS THAT OVERFLOW
ROW = ROW + XROW;
XROW = %DIV(LENWRK : 80);
IF (COL + LENWRK) > 78;
EXSR @ROWINC;
IF MX = 3;
X= X-1;
NUMFKY = X;
LEAVE;
ENDIF;
COL = 1;
ENDIF;
// INC COL. FOR FIELD START
CLEAR B(X);
BIN = ROW;
B(X) = %TRIM(B(X)) + HX1;
BIN = COL + 1;
B(X) = %TRIM(B(X)) + HX1;
// INC COL. FOR NEXT FIELD
COL = COL + LENWRK;
IF COL > 78;
EXSR @ROWINC;
IF MX = 3; // NO ROOM FOR THE FIELD
X= X-1;
NUMFKY = X;
LEAVE;
ENDIF;
COL = 1;
ENDIF;
ENDFOR;
// FIELD LEVEL
LVX = LVL + 1;
LV(LVX) = N(X);
ENDSR;
// @@@@@@@@@@@@@@@ PUTHED @@@@@@@@@@@@@@@
// PUT FIELD HEADINGS
BEGSR @PUTHED;
NEWRU = '1';
RU = *ALLX'00';
CLEAR RU; // initialise Request Unit 255 bytes max
FOR XX = 1 TO NUMFKY; //NUMBER OF DATA ELEMENTS (FLD AND KEY)
IF NEWRU = '1';
NEWRU = '0';
RU = ESC + WTD + X20 + X00;
ENDIF;
RU = RU + SBA;
BIN = 0;
// CONVERT DATA BUFADR TO HEADING BUFADR
HX1 = %SUBST(B(XX) :1:1);
BIN = BIN - 1;
RU = RU + HX1;
IF REHEAD = '1'; // ON REDISPLAY OVERRIDE THE ATTR
BIN = 0;
HX1 = %SUBST(B(XX) :2:1);
BIN = BIN -1 ;
RU = RU + HX1;
ELSE;
RU = RU + %SUBST(B(XX) :2);
ENDIF;
RU = RU + ATC ;
// LONG NUMBER FIELDS ,RIGHT ADJUST THE FIELD HEADINGS
LENDSC = %LEN(%TRIM(N(XX)));
IF T(XX) <> 'A' AND LENDSC < (L(XX) -1);
FOR Y = 1 TO (L(XX) -(LENDSC +1));
RU = RU + ' ';
ENDFOR;
ENDIF;
RU = RU + %TRIM(N(XX));
IF %LEN(RU) >= 200;
BIN = %LEN(RU);
OUTLEN = HX2;
INLEN = X000;
FNC = SND;
A = RU;
EXCEPT DATAO;
NEWRU = '1';
RU = *ALLX'00';
CLEAR RU;
ENDIF;
ENDFOR;
IF %LEN(RU) > 5 AND %LEN(RU) < 200;
BIN = %LEN(RU);
OUTLEN = HX2;
INLEN = X000;
FNC = SND;
A = RU;
EXCEPT DATAO;
ENDIF;
IF REHEAD <> '1';
// FORMAT FIELDS
NEWRU = '1';
RU = *ALLX'00';
CLEAR RU; // initialise Request Unit 255 bytes max
FOR XX = 1 TO NUMFKY; //NUMBER OF DATA ELEMENTS (FLD AND KEY)
IF NEWRU = '1';
NEWRU = '0';
RU = ESC + WTD + X20 + X00;
ENDIF;
RU = RU + SBA +B(XX)+SF + I(XX);
IF KY(XX) = '1' OR KY(XX) = '2' OR KY(XX) = '3';
RU = RU + X25;
ELSE;
RU = RU + X26;
ENDIF;
BIN = L(XX);
RU = RU + HX2;
// LENGTH OF INPUT FIELDS
LENF = LENF + L(XX) + 3;
IF %LEN(RU) >= 200;
BIN = %LEN(RU);
OUTLEN = HX2;
INLEN = X000;
FNC = SND;
A = RU;
EXCEPT DATAO;
NEWRU = '1';
RU = *ALLX'00';
CLEAR RU;
ENDIF;
ENDFOR;
// PUT LAST R/U
IF %LEN(RU) > 5 AND %LEN(RU) < 200;
BIN = %LEN(RU);
OUTLEN = HX2;
INLEN = X000;
FNC = SND;
A = RU;
EXCEPT DATAO;
ENDIF;
//INC BUFFER ADDRESS FOR ALL FIELDS FOR DATA PUT
FOR XP = 1 TO NUMFKY; //NUMBER OF DATA ELEMENTS (FLD AND KEY)
HX2 = B(XP);
BIN = BIN + 1;
B(XP) = HX2;
ENDFOR;
ENDIF;
ENDSR;
// @@@@@@@ INIT @@@@@@@@@@@@@@@@@@@@@@@@@
BEGSR @INIT;
CLEAR KW;
// UPDATE
IF UPDF = 'Y';
FFA1 = X40;
FFN1 = X47;
ELSE;
FFA1 = X60;
FFN1 = X67;
ENDIF;
SELECT;
WHEN *INU1 = '1';
FILE = F1 ;
LIB = L1 ;
MBR = M1 ;
RCDL = R1 ;
ACCTP = A1 ;
WHEN *INU2 = '1';
FILE = F2 ;
LIB = L2 ;
MBR = M2 ;
RCDL = R2 ;
ACCTP = A2 ;
ENDSL;
RLEN = RCDL ;
RLENTH = %EDITC(RLEN: 'X') ;
LENF = 0 ;
// Control commands and data are constructed into RUs Request UNITS
// Each RU is 256 bytes max size.
// Construct and send as many RUs as needed to format the display.
RU = *ALLX'00';
CLEAR RU; // initialise Request Unit 255 bytes max
RU = CLRWTD ;
//set up the screen headings
BIN = 1; // set ROW to 1
RW = HX1;
BIN = 2; // set COL to 2
CL = HX1;
RU = RU + SBA + RW + CL + X22 + %TRIM(LIB) + '/' + %TRIM(FILE);
RU = RU + ' Mbr ' + %TRIM(MBR) + ' Rcdl ' + %EDITC(RLEN : 'Z') ;
RU = RU + ' RRN ' ;
BIN = %len(RU) -4;
RBA = RW + HX1 ; // address of the RRN field
RU = RU + SBA + RBA + ' ';
// FUNCTION KEYS
BIN = 23;
RW = HX1;
BIN = 02;
CL = HX1;
IF UPDF = 'Y'; // UPDATE IS ON
RU = RU + SBA + RW + CL + %TRIM(CNS(2));
ELSE;
RU = RU + SBA + RW + CL + %TRIM(CNS(1));
ENDIF;
// THIS IS A SEND ONLY FUNCTION
FNC = SND;
CLEAR A;
A = RU;
BIN2 = %LEN(RU);
OUTLEN = BY2;
INLEN = x000;
EXCEPT DATAO;
ENDSR;
// @@@@@@@ KEYIN @@@@@@@@@@@@@@@@@@@@@@@@@
BEGSR @KEYIN;
// ISSUE A READ FROM DISPLAY
FNC = SNR;
BIN2 = 8;
OUTLEN = BY2;
IPL = LENF + 34;
BIN2 = IPL;
INLEN = BY2;
// SET FRR INDICATORS TO CONTROL BUFFER OVERFLOW
FOR X = 1 TO 9;
IF IPL > ( X*80 +3);
*IN(X+19) = *ON;
ENDIF;
ENDFOR;
RU = *ALLX'00';
CLEAR RU;
RU = RDDSP;
A = RU;
EXCEPT DATAI;
ENDSR;
// @@@@@@@ ERROR @@@@@@@@@@@@@@@@@@@@@@@@@
BEGSR @ERROR;
// SETUP PUT ERROR MESSAGE X'21'
RU = *ALLX'00';
CLEAR RU;
FNC = SNR;
BIN = 42;
OUTLEN = HX2;
BIN = LENF + 34;
IPL = BIN;
INLEN = HX2;
FOR X = 1 TO 9;
IF IPL > (X * 80 +3) ;
*IN(X + 19) = *ON; // SETON FFR 20 - 29 FOR INPUT
ENDIF;
ENDFOR;
RU = ESC + WER + IC + B(1) + ATC + MSG(MX);
RU = RU + ESC + RDM + X40+ X00;
A = RU;
EXCEPT DATAI;
RU = *ALLX'00';
CLEAR RU;
ENDSR;
// @@@@@@@ HXDSP @@@@@@@@@@@@@@@@@@@@@@@@@
BEGSR @HXDSP;
RU = *ALLX'00';
CLEAR RU;
Y = %LOOKUPLE( CURLOC : B );
//
RU = ESC + WTD + X20 + X00 + SBA;
BIN = 0;
HX1 = %SUBST(B(Y) :1:1);
BIN = BIN - 1;
RU = RU + HX1;
RU = RU + %SUBST(B(Y) :2:1);
FOR X = S(Y) TO E(Y);
BIN = 0;
HX1 = D(X);
HX1 = %BITAND(HX1 : XF0);
Z = BIN / 16 + 1;
RU = RU + CRS(Z);
ENDFOR;
RU = RU + X20;
RU = RU + SBA + B(Y);
FOR X = S(Y) TO E(Y);
BIN = 0;
HX1 = D(X);
HX1 = %BITAND(HX1 : X0F);
Z = BIN + 1;
RU = RU + CRS(Z);
ENDFOR;
BIN = %LEN(RU);
OUTLEN = HX2;
INLEN = X000;
FNC = SND;
A = RU;
EXCEPT DATAO;
RU = *ALLX'00';
CLEAR RU;
EXSR @KEYIN;
READ DISPF;
// CLEAR HEADINGS
RU = *ALLX'00';
CLEAR RU;
RU = RU + ESC + WTD + X20 + X00 + SBA;
HX1 = %SUBST(B(Y) :1:1) ;
BIN = BIN - 1;
RU = RU + HX1 + %SUBST(B(Y):2:1);
FOR X = S(Y) TO E(Y);
RU = RU + ' ';
ENDFOR;
RU = RU + ' ';
BIN = %LEN(RU);
OUTLEN = HX2;
INLEN = X000;
FNC = SND;
A = RU;
EXCEPT DATAO;
RU = *ALLX'00';
CLEAR RU;
ENDSR;
/END-FREE
ODISPF E DATAO
O K3 'PUT'
O OUTLEN 2
O INLEN
O FNC
O A
O E DATAI
O K3 'GET'
O OUTLEN 2
O INLEN
O FNC
O A
**
0000 INVALID COMMAND KEY
0001 - A FIELD IS TOO LONG
0002 - TOO MANY FIELDS
0003 - ALPHAS IN PACKED KEY
0004 - MISSING ' IN PACKED KEY
0005 - MISSING DATA IN PCKD KEY
0006 - RECORD NOT FOUND
PRESS RESET TO CONTINUE
**
F1-HEX F2-Return F3-Exit F19-Prev_fld F20-More_fld
F1-HEX F2-Return F3-Exit F19-Prev_fld F20-More_fld
**
0123456789ABCDEF
DUSP RPG
H*eywords++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++Comments+++++++++++
H OPTION(*NODEBUGIO)
H DFTACTGRP(*NO) ACTGRP(*CALLER) DFTNAME(DISP )
F*
F* LIMITED TO MAXIMUM FILE LENGTH OF 2048
F* REQUIRES FILE QTEMP/FFD TO COMPILE
F* use cmd DSPFFD FILE(&LIB/&FILE) OUTPUT(*OUTFILE) OUTFILE(QTEMP/FFD)
FFFD IF E DISK
FDISPF CF F 803 WORKSTN
F*
F INFDS(INFDS)
FINPUTK UF A F32766 800AIDISK KEYLOC(1)
F EXTIND(*INU1)
F INFDS(INFDK)
FINPUTR UF A F32766 DISK EXTIND(*INU2)
F INFDS(INFDR)
*
D A S 255 WORK RU
D RU S 255 varying
D RW S 1 ROW 1 byte binary
D CL S 1 COL 1 byte binary
D FNC S 1
D OUTLEN S 2
D INLEN S 2
D IPL S 5 0
D ROW S 3 0
D XROW S 3 0
D COL S 3 0
D KEYSOK S 1
D LENDSC S 3 0
D LENWRK S 5 0
D STRX S 5 0
D ENDX S 5 0
D VX S 5 0
D X S 5 0
D X1 S 5 0
D X2 S 5 0
D XX S 5 0
D XP S 5 0
D MX S 5 0
D ONCE S 1
D RBA S 2
D LF S 5 0
D ST S 5 0
D Y S 5 0
D Z S 5 0
D OFF S 5 0
D CGKY S 1
D UPDDONE S 1
D SUPZ S 1
D NUMFLD S 5 0
D WX S 5 0
D NUMKEY S 5 0
D NUMFKY S 5 0
D SCRST S 10
D SCRSTN S 1
D KEYA S 800
D RRNA S 11 0
D RRN S 11 0
D REHEAD S 1
D NEWRU S 1
D WRTRRN S 1
D LVX S 5 0
D LVL S 5 0
D K1 S 5 0
D K2 S 5 0
D Z1 S 5 0
D W S 5 0
D WK2 S 2
D MSSG S 32
*
D BASE S 5 0
D INZ S 1
D FILE S 10
D LIB S 10
D MBR S 10
D RCDL S 5 0
D ACCTP S 1
D RLEN S 5 0
D RLENTH S 5
D LENF S 5 0
D DS
D TEXT500 500
D LVW 10 DIM(50) overlay(TEXT500:1)
D TEXT800 S 800
D KW S 800
D DS
D WRK11 1 11
D NUM11 1 11S 0
D DS
D NUSA 1 60
D NUS 1 60S 0
D DS
D NUPA 1 60
D NUP 29 60P 0
D WRU S 61
D WRX S 64
D WRXWRD C '0 -
D -'
D WRSWRD C '0 -
D -'
D WRV S 60 varying
D FLT14 S 14
D FLT23 S 23
* SET FILE SIZE INCREMENTS (64 OF THEM)
D SZ S 5 0 DIM(64)
D S S 5 0 DIM(9000) START OF FLD
D E S 5 0 DIM(9000) END OF FLD
D Q S 5 0 DIM(9000) BYTES IN FIELD
D L S 5 0 DIM(9000) LENGTH OF FLD
D C S 3 0 DIM(9000) DEC DIGITS
D P S 3 0 DIM(9000) DEC PRECISION
D B S 2 DIM(9000) ASCEND BUFFER ADD
D I S 2 DIM(9000) FLD FMT
D N S 10 DIM(9000) FLD NAME
D T S 1 DIM(9000) FLD TYPE
D V S 1 DIM(9000) VARYING
D KY S 1 DIM(9000) KEYED
D KE S 10 DIM(128) KEY FLDS
D R S 3 0 DIM(9000) KEY FLD START
D K S 1 DIM(800) KEY
D NA S 1 DIM(10) NAME WORK
D NU S 1 DIM(60) NUM. WORK
D LV S 10 DIM(50) SCREEN LEVELS
D MSG S 32 DIM(8) CTDATA PERRCD(1) MESSAGES
D CNS S 79 DIM(2) CTDATA PERRCD(1)
D CRS S 1 DIM(16) CTDATA PERRCD(16)
D DS
D DATA 1 2048
D D 1 2048
D DIM(2048) INCOMING DATA
D DA 1 16
D DB 17 32
D DC 33 64
D DD 65 96
D DE 97 128
D DF 129 160
D DG 161 192
D DH 193 224
D DI 225 256
D DJ 257 288
D DK 289 320
D DL 321 352
D DM 353 384
D DN 385 416
D DZ 417 448
D DO 449 480
D DP 481 512
D DQ 513 544
D DR 545 576
D DS 577 608
D DT 609 640
D DU 641 672
D DV 673 704
D DW 705 736
D DX 737 768
D DY 769 800
D D0 801 832
D D1 833 864
D D2 865 896
D D3 897 928
D D4 929 960
D D5 961 992
D D6 993 1024
D DBA 1025 1056
D DCA 1057 1088
D DDA 1089 1120
D DEA 1121 1152
D DFA 1153 1184
D DGA 1185 1216
D DHA 1217 1248
D DIA 1249 1280
D DJA 1281 1312
D DKA 1313 1344
D DLA 1345 1376
D DMA 1377 1408
D DNA 1409 1440
D DOA 1441 1472
D DPA 1473 1504
D DQA 1505 1536
D DRA 1537 1568
D DSA 1569 1600
D DTA 1601 1632
D DUA 1633 1664
D DVA 1665 1696
D DWA 1697 1728
D DXA 1729 1760
D DYA 1761 1792
D DZA 1793 1824
D D0A 1825 1856
D D1A 1857 1888
D D2A 1889 1920
D D3A 1921 1952
D D4A 1953 1984
D D5A 1985 2016
D D6A 2017 2048
D DS
D ID 1 800
D DIM(800) INCOMING DATA
D IDA 1 800
D ID0 1 80
D ID1 81 160
D ID2 161 240
D ID3 241 320
D ID4 321 400
D ID5 401 480
D ID6 481 560
D ID7 561 640
D ID8 641 720
D ID9 721 800
D DS
D BIN 1 2B 0
D HX1 2 2
D HX2 1 2
D DS
D PCK 1 1P 0
D PCK1 1 1
D DS
D SGN 1 1S 0
D SGN1 1 1
D DS
D BIN4 1 4B 0
D BY4 1 4
D DS
D BIN2 1 2B 0
D BY2 1 2
D DS
D FLT4 1 4F
D FL4 1 4
D DS
D FLT8 1 8F
D FL8 1 8
D INFDK DS
D F1 83 92
D L1 93 102
D M1 129 138
D R1 125 126B 0
D A1 160 160
D LOP1 260 260
D KEY_LEN 393 394I 0 Key length
D RN1 397 400B 0
D LKY 401 1200
D INFDR DS
D F2 83 92
D L2 93 102
D M2 129 138
D R2 125 126B 0
D A2 160 160
D LOP2 260 260
D RN2 397 400B 0
D*
D INFDS DS
D CURLOC 370 371
D DS
D KEYLN 1 4S 0
D KEYLNA 1 4
DDUSP PR
D 1
D 1
D 4
D 1
D 500
D 5
D 800
DDUSP PI
D ALL 1
D RTN 1
D KEYLNG 4
D UPDF 1
D SCNLV 500
D SCNLVL 5
D SCNKEY 800
D @LOOP C '1'
D @FALSE C '0'
D @TRUE C '1'
D SND C X'71' SEND TO DISP
D SNR C X'73' SND/RCV
D RED C X'42' READ
D RDM C X'52' READ MTD
D ESC C X'04' ESCAPE
D CLR C X'40' CLEAR UNIT
D CC1 C X'00' CNTRL CHAR
D CC2 C X'08' CNTRL CHAR
D SBA C X'11' SET BUFF ADR
D IC C X'13' INSERT CURS
D WTD C X'11' WRITE TO DSP
D WER C X'21' WRITE ERROR
D SF C X'1D' START FLD
D ATC C X'20' ATTR CHAR
D ATN C X'24' ATTR NUM
D X00 C X'00'
D X01 C X'01'
D X02 C X'02'
D X03 C X'03'
D X0D C X'0D'
D X0F C X'0F'
D X000 C X'0000'
D X1F C X'1F'
D X20 C X'20' SCRN ATT NORMAL
D X22 C X'22' SCRN ATTR HI
D X25 C X'25'
D X26 C X'26'
D X31 C X'31' CMD 1 KEY
D X32 C X'32' CMD 2 KEY
D X33 C X'33' CMD 3 KEY
D X36 C X'36' CMD 6 KEY
D X37 C X'37' CMD 7 KEY
D X38 C X'38' CMD 8 KEY
D X39 C X'39' CMD 9 KEY
D X3B C X'3B' CMD11 KEY
D XB7 C X'B7' CMD19 KEY
D XB8 C X'B8' CMD20 KEY
D X40 C X'40'
D X43 C X'43'
D X47 C X'47'
D X60 C X'60'
D X67 C X'67'
D X9F C X'9F'
D XF0 C X'F0'
D XD0 C X'D0'
D X4000 C X'4000'
D X4800 C X'4800' FF ALPHA
D X4F06 C X'4F06' FF NUMERIC
D X6000 C X'6000' FF ALPHA
D X6706 C X'6706' FF NUMERIC
D CLRWTD C X'044004112000' INCLUDES ESC CHARS
D RDDSP C X'0411200804524000' REAB FROM DISPLAY
D FFA1 S 1 INZ(X'40') F.FMT 1 ALPH 60 BYP
D FFA2 S 1 INZ(X'00') F.FMT 2 ALPH
D FFN1 S 1 INZ(X'47') F.FMT 1 NUM 67 BYP
D FFN2 S 1 INZ(X'06') F.FMT 2 NUM
I*.
IINPUTK NS 01
I 1 16 DA
I 17 32 DB 30
I 33 64 DC 31
I 65 96 DD 32
I 97 128 DE 33
I 129 160 DF 34
I 161 192 DG 35
I 193 224 DH 36
I 225 256 DI 37
I 257 288 DJ 38
I 289 320 DK 39
I 321 352 DL 40
I 353 384 DM 41
I 385 416 DN 42
I 417 448 DZ 43
I 449 480 DO 44
I 481 512 DP 45
I 513 544 DQ 46
I 545 576 DR 47
I 577 608 DS 48
I 609 640 DT 49
I 641 672 DU 50
I 673 704 DV 51
I 705 736 DW 52
I 737 768 DX 53
I 769 800 DY 54
I 801 832 D0 55
I 833 864 D1 56
I 865 896 D2 57
I 897 928 D3 58
I 929 960 D4 59
I 961 992 D5 60
I 993 1024 D6 61
I 1025 1056 DBA 62
I 1057 1088 DCA 63
I 1089 1120 DDA 64
I 1121 1152 DEA 65
I 1153 1184 DFA 66
I 1185 1216 DGA 67
I 1217 1248 DHA 68
I 1249 1280 DIA 69
I 1281 1312 DJA 70
I 1313 1344 DKA 71
I 1345 1376 DLA 72
I 1377 1408 DMA 73
I 1409 1440 DNA 74
I 1441 1472 DOA 75
I 1473 1504 DPA 76
I 1505 1536 DQA 77
I 1537 1568 DRA 78
I 1569 1600 DSA 79
I 1601 1632 DTA 80
I 1633 1664 DUA 81
I 1665 1696 DVA 82
I 1697 1728 DWA 83
I 1729 1760 DXA 84
I 1761 1792 DYA 85
I 1793 1824 DZA 86
I 1825 1856 D0A 87
I 1857 1888 D1A 88
I 1889 1920 D2A 89
I 1921 1952 D3A 90
I 1953 1984 D4A 91
I 1985 2016 D5A 92
I 2017 2048 D6A 93
IINPUTR NS 01
I 1 16 DA
I 17 32 DB 30
I 33 64 DC 31
I 65 96 DD 32
I 97 128 DE 33
I 129 160 DF 34
I 161 192 DG 35
I 193 224 DH 36
I 225 256 DI 37
I 257 288 DJ 38
I 289 320 DK 39
I 321 352 DL 40
I 353 384 DM 41
I 385 416 DN 42
I 417 448 DZ 43
I 449 480 DO 44
I 481 512 DP 45
I 513 544 DQ 46
I 545 576 DR 47
I 577 608 DS 48
I 609 640 DT 49
I 641 672 DU 50
I 673 704 DV 51
I 705 736 DW 52
I 737 768 DX 53
I 769 800 DY 54
I 801 832 D0 55
I 833 864 D1 56
I 865 896 D2 57
I 897 928 D3 58
I 929 960 D4 59
I 961 992 D5 60
I 993 1024 D6 61
I 1025 1056 DBA 62
I 1057 1088 DCA 63
I 1089 1120 DDA 64
I 1121 1152 DEA 65
I 1153 1184 DFA 66
I 1185 1216 DGA 67
I 1217 1248 DHA 68
I 1249 1280 DIA 69
I 1281 1312 DJA 70
I 1313 1344 DKA 71
I 1345 1376 DLA 72
I 1377 1408 DMA 73
I 1409 1440 DNA 74
I 1441 1472 DOA 75
I 1473 1504 DPA 76
I 1505 1536 DQA 77
I 1537 1568 DRA 78
I 1569 1600 DSA 79
I 1601 1632 DTA 80
I 1633 1664 DUA 81
I 1665 1696 DVA 82
I 1697 1728 DWA 83
I 1729 1760 DXA 84
I 1761 1792 DYA 85
I 1793 1824 DZA 86
I 1825 1856 D0A 87
I 1857 1888 D1A 88
I 1889 1920 D2A 89
I 1921 1952 D3A 90
I 1953 1984 D4A 91
I 1985 2016 D5A 92
I 2017 2048 D6A 93
IDISPF NS 02
I 3 3 AID
I 4 83 ID0
I 84 163 ID1 20
I 164 243 ID2 21
I 244 323 ID3 22
I 324 403 ID4 23
I 404 483 ID5 24
I 484 563 ID6 25
I 564 643 ID7 26
I 644 723 ID8 27
I 724 803 ID9 28
/FREE
BASE = 0;
IF ONCE = ' ';
EXSR @INITZ ;
ENDIF;
// START TAG
DOW @LOOP = @LOOP;
IF RTN = '3';
IF *INU1;
KEYA = SCNKEY;
ENDIF;
IF *INU2;
RRNA = %DEC(%SUBST(SCNKEY:1:11):11:0);
ENDIF;
RTN = '0';
AID = '1';
ELSE;
RTN = '0';
READ(E) DISPF;
ENDIF;
// CF3 EXIT
IF AID = X33;
LEAVE;
ENDIF;
// CF2 RETURN
IF AID = X32;
RTN = '1';
LEAVE;
ENDIF;
// CF1 HEX A FIELD
IF AID = X31;
Y = %LOOKUPLE( CURLOC : B );
IF Y > 0;
IF KY(Y) <= '1';
EXSR @HXDSP;
REHEAD = '1';
EXSR @PUTHED;
REHEAD = ' ';
ENDIF;
ENDIF;
ENDIF;
// CF20 MORE FIELDS
IF AID = XB8;
LVX = LVL + 1;
IF LV(LVX) <> *BLANK;
LVL = LVL +1 ;
LVW = LV;
SCNLV = TEXT500;
SCNLVL = %EDITC(LVL :'X');
SCNKEY = *BLANKS;
IF *INU1;
SCNKEY = KEYA;
ENDIF;
IF *INU2;
SCNKEY = %EDITC(RRNA:'X');
ENDIF;
RTN = '3';
LEAVE;
ENDIF;
ENDIF;
// CF19 PREVIOUS FIELDS
IF AID = XB7;
LVX = LVL - 1;
IF LVX >= 0 ;
LVL = LVL - 1 ;
LVW = LV;
SCNLV = TEXT500;
SCNLVL = %EDITC(LVL :'X');
SCNKEY = *BLANKS;
IF *INU1;
SCNKEY = KEYA;
ENDIF;
IF *INU2;
SCNKEY = %EDITC(RRNA:'X');
ENDIF;
RTN = '3';
LEAVE;
ENDIF;
ENDIF;
// 1 ENTER 4 ROLL DN 5 ROLL UP
// F6 = X36 F9 = X39 F11 = X3B
IF AID = '1'or AID = '4' or AID = '5' or
AID = X36 or AID = X39 or AID = X3B;
ELSE;
MX = 1; // INVALID KEY
EXSR @ERROR;
ENDIF;
// UPDATE MODE
IF UPDF = 'Y';
UPDDONE = @FALSE;
// F6
IF *INU1 AND AID = X36 AND
(LOP1 = X01 OR LOP1 = X03);
EXSR @UPD;
EXCEPT UPDATREC;
UPDDONE = @TRUE;
ENDIF;
IF *INU2 AND AID = X36 AND
(LOP2 = X01 OR LOP2 = X02);
EXSR @UPD;
EXCEPT UPDATREC;
UPDDONE = @TRUE;
ENDIF;
// F9
IF AID = X39;
EXSR @UPD;
EXCEPT ADDREC;
UPDDONE = @TRUE;
ENDIF;
// F11
IF *INU1 AND AID = X3B AND
(LOP1 = X01 OR LOP1 = X03);
EXCEPT DELREC;
UPDDONE = @TRUE;
ENDIF;
IF *INU2 AND AID = X3B AND
(LOP2 = X01 OR LOP2 = X02);
EXCEPT DELREC;
UPDDONE = @TRUE;
ENDIF;
ENDIF;
IF RTN = '3' OR UPDDONE = @TRUE;
ELSE;
EXSR @PCKD;
ENDIF;
// CONT1 GET A RECORD, KEY FROM DATA
EXSR @SETIN;
EXSR @GETF ;
EXSR @PUTF ;
EXSR @KEYIN;
ENDDO ;
*INLR = *ON;
// @@@@@@@ @INITZ @@@@@@@@@@@@@@@@@@@@@@@@@@
BEGSR @INITZ;
ONCE = '1';
KEYLNA = KEYLNG ;
EXSR @INIT ;
EXSR @GETFLD ;
EXSR @GETADD ;
EXSR @PUTHED ;
EXSR @KEYIN ;
INZ = '1';
EXSR @PCKD ;
INZ = ' ';
ENDSR;
// @@@@@@@ @PCKD @@@@@@@@@@@@@@@@@@@@@@@@@@
BEGSR @PCKD ;
// CONVERT KEY DATA
IF *INU1 ;
EXSR @CVTKEY;
ENDIF;
IF *INU2 ;
EXSR @CVTRRN;
ENDIF;
ENDSR;
// @@@@@@@ @CVTKEY @@@@@@@@@@@@@@@@@@@@@@@@
BEGSR @CVTKEY;
// EXTRACT THE KEY FIELD DATA FROM THE INCOMING STRING
// FOR EACH KEY FIELD, CHECK IF FIELD WAS MODIFIED, AND IF SO MOVE
// THE MODIFIED DATA INTO THE COMPOSITE KEY
K1 = 0;
K2 = 0;
W = 1;
FOR Y = 1 TO NUMKEY ;
// MOVE A KEY FIELDS DATA FROM ID ARRAY (SCREEN) TO K ARRAY (KEY FIELDS)
// GET SIZE OF FIELD IN BYTES
IF T(Y) = 'A'; // ALPHA DATA
K = ' ';
K1 = 1;
K2 = Q(Y);
ELSE;
K = '0';
K1 = 1;
K2 = C(Y);
ENDIF;
// IF WHOLE KEY INIT WAS REQUESTED BYPASS THE EXTRACT
IF INZ = '1' ;
KW = *BLANK;
EXSR @PCKMOV;
ITER;
ENDIF;
X = 1;
DOW @LOOP = @LOOP;
// NXTSBA
X = %LOOKUP(SBA : ID : X );
IF X = 0;
LEAVE;
ENDIF;
// IS THIS THE FIELD? CHECK THE BUFFER ADDRESS
X = X +1;
IF B(Y) <> %SUBST(IDA : X :2);
ITER;
ENDIF;
// FOUND A MTD FOR THIS FIELD
X = X + 2;
// CHECK IF FIELD WAS CLEARED ONLY
IF ID(X) = SBA;
EXSR @PCKMOV;
LEAVE ;
ENDIF;
// IF FIELD HAS DECIMALS BUMP X
IF (T(Y) = 'S' OR T(Y) = 'P' OR T(Y) = 'B') AND
P(Y) > 0;
X = X + 1;
ENDIF;
// CHECK IF ONLY BLANKS RETURNED
IF %SUBST(IDA : X :K2) = *BLANKS;
EXSR @PCKMOV;
LEAVE;
ENDIF;
// EXTRACT THE DATA FROM THE INCOMING STRING
X1 = X;
FOR X2 = 1 TO K2 ;
IF ID(X1) < ' ';
// TRAP NULLS CAUSED BY FLD EXIT
EXSR @PCKMOV;
LEAVE;
ENDIF;
K(X2) = ID(X1);
X1 = X1 +1;
ENDFOR;
// CONSTRUCT THE ACTUAL KEY WITH PACKED DATA IF REQUIRED
// INTO ARRAY KW
EXSR @PCKMOV;
LEAVE;
ENDDO;
ENDFOR;
//
KEYA = KW;
CLEAR KW;
ENDSR ;
// @@@@@@@ @CVTRRN @@@@@@@@@@@@@@@@@@@@@@@@
BEGSR @CVTRRN;
// RRN
NUM11 = 0;
DOW @LOOP = @LOOP; // NOT REALLY A LOOP(SIMULATES GOTO)
// GET THE FIRST SBA
X = 1;
X = %LOOKUP(SBA : ID : X );
IF X = 0;
LEAVE;
ENDIF;
// CHECK THE BUFFER ADDRESS MATCHES THE EXPECTED FIELD
X = X +1;
IF B(1) <> %SUBST(IDA : X :2);
ITER;
ENDIF;
// FOUND A MTD FOR RRN FIELD
X = X +2;
//CHECK IF FIELD WAS CLEARED ONLY
IF ID(X) = SBA;
LEAVE;
ENDIF;
// CHECK IF ONLY BLANKS RETURNED
IF %SUBST(IDA : X :11) = *BLANKS;
LEAVE;
ENDIF;
// WRK11 OVERLAYS NUM11
WRK11 = %SUBST(IDA : X :11);
LEAVE;
ENDDO;
RRNA = NUM11;
IF RRNA < 0;
RRNA = 1;
ENDIF;
ENDSR;
// @@@@@@@ @PCKMOV @@@@@@@@@@@@@@@@@@@@@@@@
BEGSR @PCKMOV;
//
// CONVERT KEY DATA
// SET START POSN IN KEY USING OFFSET IN R
X1 = %LOOKUP(N(Y) : N );
W = R(X1) + 1;
// ALPHA
IF T(Y) = 'A';
X1 = 1;
FOR Z = W TO W + Q(Y);
%SUBST(KW : Z : 1) = K(X1);
X1 = X1 + 1;
ENDFOR;
ENDIF;
// NUMERIC FIELD
// RIGHT ADJUST NUMERIC DATA ,STRIP - . ,CONVERT BLANKS
IF (T(Y) = 'S' OR T(Y) = 'P' OR T(Y) = 'B');
NU = '0';
Z1 = 60;
FOR Z = K2 DOWNTO K1;
IF K(Z) = '.' OR K(Z) = '-' OR K(Z) = '$';
ITER;
ENDIF;
IF K(Z) = ' ' ;
NU(Z1) = '0';
ELSE;
NU(Z1) = K(Z);
ENDIF;
Z1 = Z1 -1;
ENDFOR;
ENDIF;
// SIGNED FIELDS (END POSN = OFFSET + SIZE)
IF T(Y) = 'S';
NUS = 0;
FOR VX = 1 TO 60;
NUSA = %TRIM(NUSA) + NU(VX);
ENDFOR;
%SUBST(KW : W : Q(Y)) = %SUBST(NUSA: 61 -Q(Y));
ENDIF;
// PACKED FIELDS
IF T(Y) = 'P';
NUSA= *BLANKS;
FOR VX = 1 TO 60;
NUSA = %TRIM(NUSA) + NU(VX);
ENDFOR;
NUP = %DEC(NUSA : 60 : 0);
%SUBST(KW : W : Q(Y)) = %SUBST(NUPA: 61 -Q(Y));
ENDIF;
// BINARY FIELDS
IF T(Y) = 'B';
IF Q(Y) = 2 ;
BY2 = NU(1) + NU(2);
%SUBST(KW : W : 2) = BY2;
ENDIF;
IF Q(Y) = 4 ;
BY4 = NU(1) + NU(2) + NU(3) + NU(4);
%SUBST(KW : W : 4) = BY4;
ENDIF;
ENDIF;
ENDSR;
// @@@@@@@ SETIN @@@@@@@@@@@@@@@@@@@@@@@@@
BEGSR @SETIN;
// SET the FFR indicators to get the Input buffer somewhat aligned with the
// actual data. RPG is somewhat tolerant to a difference between the Ispecs
// and the actual file size but it can fail on big differences.
// INCREMENT OF 32 BYTES
SZ(1) = BASE + 16;
SZ(2) = SZ(1) + 16;
*IN30 = *ON;
IF (RLEN > SZ(2)) ;
*IN31 = *ON;
ENDIF;
FOR X = 3 TO 64;
SZ(X) = SZ(X-1) + 32;
IF (RLEN > SZ(X)) ;
*IN(29+X) = *ON;
ENDIF;
ENDFOR;
ENDSR;
//@@@@@@@@@@@@@@@@@ @GETF @@@@@@@@@@@@@@@@@
BEGSR @GETF;
// GET A DATA RECORD
IF (*INU1);
IF AID = '1' OR AID = X36 OR
AID = X39 OR AID = X3B ;
SETLL(E) KEYA INPUTK;
READ(E) INPUTK;
IF %EOF;
SETLL(E) KEYA INPUTK;
READP(E) INPUTK;
ENDIF;
ENDIF;
IF AID = '4';
READP(E) INPUTK;
ENDIF;
IF AID = '5';
READ(E) INPUTK;
ENDIF;
IF %ERROR;
SETLL(E) KEYA INPUTK;
READ(E) INPUTK;
MX = 7;
EXSR @ERROR;
EXSR @PUTF ;
EXSR @KEYIN;
ENDIF;
KEYA = LKY;
CLEAR KW;
KW = LKY;
ENDIF;
IF (*INU2);
IF AID = '1';
CHAIN(E) RRNA INPUTR;
IF %ERROR;
SETLL(E) RRNA INPUTR;
READP(E) INPUTR;
ENDIF;
ENDIF;
IF AID = X36;
CHAIN(E) RRNA INPUTR;
ENDIF;
IF AID = '4';
READP(E) INPUTR;
ENDIF;
IF AID = '5' OR AID = X3B;
READ(E) INPUTR;
ENDIF;
IF AID = X39;
SETLL(E) *HIVAL INPUTR;
READP(E) INPUTR;
ENDIF;
IF %ERROR;
CHAIN 1 INPUTR;
MX = 7;
EXSR @ERROR;
EXSR @PUTF ;
EXSR @KEYIN;
ENDIF;
ENDIF;
ENDSR;
//@@@@@@@@@@@@@@@@@ @PUTF @@@@@@@@@@@@@@@@@
BEGSR @PUTF;
// WRITE DATA TO THE DISPLAY
NEWRU = '1';
WRTRRN = '1';
RU = *ALLX'00';
CLEAR RU; // initialise Request Unit 255 bytes max
FOR XX = 1 TO NUMFKY; //NUMBER OF DATA ELEMENTS (FLD AND KEY)
IF NEWRU = '1';
NEWRU = '0';
RU = ESC + WTD + X20 + X00;
ENDIF;
IF WRTRRN = '1';
WRTRRN = '0';
RU = RU + SBA + RBA ;
SELECT;
WHEN *INU1;
RRN = RN1;
WHEN *INU2;
RRN = RN2;
ENDSL;
RU = RU + %TRIM(%EDITC(RRN:'Z'));
ENDIF;
// BUFFER ADDRESS
RU = RU + SBA + B(XX);
// PROCESS ALPHA DATA TYPE
IF T(XX) = 'A' OR T(XX) = 'T' OR T(XX) = 'Z' OR
T(XX) = 'L';
STRX = S(XX);
ENDX = E(XX);
IF V(XX) = 'Y'; //VARYING
VX = S(XX);
HX2 = D(VX) + D(VX+1);
STRX = S(XX) + 2 ;
ENDX = S(XX) + BIN;
ENDIF;
FOR Y = STRX TO ENDX ;
IF D(Y) >= ' ';
RU = RU + D(Y);
ELSE;
RU = RU + X1F ; //IF NOT DISPLAYABLE REPLACE WITH X'1F'
ENDIF;
ENDFOR;
ENDIF;
// PROCESS SIGNED DATA TYPE (not the RRN field)
IF T(XX) = 'S' and KY(XX) <> '3';
NUSA = *ALL'0';
WRV = *ALLX'00';
CLEAR WRV;
FOR Y = S(XX) TO E(XX);
IF D(Y) >= XD0;
WRV = WRV + D(Y);
ENDIF;
ENDFOR;
EVAL NUSA = %SUBST(NUSA : 1 : 60 - %LEN(WRV)) + WRV;
CLEAR WRU;
WRU = %TRIM(WRU) + %EDITW(NUS :WRSWRD);
IF P(XX) > 0;
RU = RU +
%SUBST(WRU :61-C(XX): C(XX)-P(XX)) + '.' +
%SUBST(WRU :61-P(XX)) ;
ELSE;
RU = RU +
%SUBST(WRU :61-C(XX));
ENDIF;
ENDIF;
// PROCESS SIGNED DATA TYPE (the RRN field)
IF T(XX) = 'S' and KY(XX) = '3';
RRN = RN2;
RU = RU + %TRIM(%EDITC(RRN:'X'));
ENDIF;
// PROCESS PACKED DATA TYPE
IF T(XX) = 'P';
NUPA = *ALLX'00';
WRV = *ALLX'00';
CLEAR WRV;
FOR Y = S(XX) TO E(XX);
WRV = WRV + D(Y);
ENDFOR;
IF %BITAND(D(E(XX)) :X0F) = X0F OR
%BITAND(D(E(XX)) :X0D) = X0D;
EVAL NUPA = %SUBST(NUPA : 1 : 60 - %LEN(WRV)) + WRV;
CLEAR WRX;
WRX = %TRIM(WRX) + %EDITW(NUP :WRXWRD);
IF P(XX) > 0;
RU = RU +
%SUBST(WRX :64-C(XX): C(XX)-P(XX)) + '.' +
%SUBST(WRX :64-P(XX)) ;
ELSE;
RU = RU +
%SUBST(WRX :64-C(XX));
ENDIF;
ELSE;
// PACKED FIELD IN ERROR
RU = RU + X1F;
ENDIF;
ENDIF;
// PROCESS BINARY DATA TYPE
IF T(XX) = 'B';
ST = S(XX);
CLEAR NUSA;
IF Q(XX) = 2;
BY2 = D(ST) + D(ST+1);
NUS = BIN2;
ENDIF;
IF Q(XX) = 4;
BY4 = D(ST) + D(ST+1)+ D(ST+2) + D(ST+3);
NUS = BIN4;
ENDIF;
WRU = %EDITW(NUS :WRSWRD);
IF P(XX) > 0;
RU = RU +
%SUBST(WRU :61-C(XX): C(XX)-P(XX)) + '.' +
%SUBST(WRU :61-P(XX)) ;
ELSE;
RU = RU +
%SUBST(WRU :61-C(XX));
ENDIF;
ENDIF;
// PROCESS FLOAT DATA TYPE
IF T(XX) = 'F';
ST = S(XX);
IF Q(XX) = 4;
FL4 = D(ST) + D(ST+1)+ D(ST+2) + D(ST+3);
FLT14 = %EDITFLT(FLT4);
RU = RU + FLT14;
ENDIF;
IF Q(XX) = 8;
FL8 = D(ST) + D(ST+1)+ D(ST+2) + D(ST+3) +
D(ST+4) + D(ST+5)+ D(ST+6) + D(ST+7);
FLT23 = %EDITFLT(FLT8);
RU = RU + FLT23;
ENDIF;
ENDIF;
// SEND A REQUEST UNIT IF GOT ENOUGH DATA
IF %LEN(RU) + L(XX + 1) >= 200;
RU = RU + X20;
BIN = %LEN(RU);
OUTLEN = HX2;
INLEN = X000;
FNC = SND;
A = RU;
EXCEPT DATAO;
NEWRU = '1';
RU = *ALLX'00';
CLEAR RU;
ENDIF;
ENDFOR;
IF %LEN(RU) > 5 AND %LEN(RU) < 250;
RU = RU + X20;
BIN = %LEN(RU);
OUTLEN = HX2;
INLEN = X000;
FNC = SND;
A = RU;
EXCEPT DATAO;
ENDIF;
ENDSR;
// @@@@@@@@@@@@@@@ ROWINC @@@@@@@@@@@@@@@
// INCREMENT THE ROW
BEGSR @ROWINC;
ROW = ROW + 2;
IF ROW > 20;
MX = 3;
ENDIF;
ENDSR;
// @@@@@@@@@@@@@@@ GETFLD @@@@@@@@@@@@@@@
// LOAD FIELD DESCRIPTION ARRAYS
BEGSR @GETFLD;
MX = 0;
X = 0;
IF (*INU2 = *ON);
// IF NON KEYED ACCESS SET UP A FIELD TO SHOW THE RRN
N(1) = 'RRN';
T(1) = 'S' ;
C(1) = 11 ;
P(1) = 0 ;
S(1) = 0 ;
E(1) = 0 ;
L(1) = 12 ;
I(1) = X4F06 ;
KY(1)= '3' ;
X = 1 ;
ENDIF;
SCRST = *BLANK;
SCRSTN = *BLANK;
LVL = %DEC(SCNLVL : 5:0);
TEXT500 = SCNLV ;
LV = LVW;
IF LVL <> 0;
SCRST = LV(LVL);
ENDIF;
SETLL 1 QWHDRFFD ;
DOW @LOOP = @LOOP;
// REREAD TAG
READ QWHDRFFD;
IF %EOF;
LEAVE;
ENDIF;
// SELECT OR OMIT
IF ALL <> '1';
IF ALL = 'S' AND WHDFTL = 0; // USING WHDFTL FOR KEY FIELDS
IF WHFIOB <> 'S';
ITER;
ENDIF;
ENDIF;
IF ALL = 'O' AND WHDFTL = 0; // USING WHDFTL FOR KEY FIELDS
IF WHFIOB = 'O';
ITER;
ENDIF;
ENDIF;
ENDIF;
// FIND THE FIRST FIELD TO BE SHOWN (FOR MULTI PAGE FORMATS)
IF WHDFTL <> 0 ;
ELSE;
IF SCRST <> ' ' AND SCRSTN = ' ';
IF WHFLDE = SCRST;
SCRSTN = '1'; // FOUND THE START
ELSE;
ITER;
ENDIF;
ENDIF;
ENDIF;
X = X + 1;
// CHECK FOR KEY FIELDS,WILL BE USED TO PLACE THEM IN FRONT
IF WHDFTL <> 0;
KY(X) = '1';
WX = WHDFTL ;
KE(WX) = WHFLDE;
IF NUMKEY < WHDFTL;
NUMKEY = WHDFTL;
ENDIF;
ENDIF;
N(X) = WHFLDE ; // NAME
T(X) = WHFLDT ; // TYPE
V(X) = WHVARL ; // VARYING
C(X) = WHFLDD ; // DEC DIGITS
P(X) = WHFLDP ; // DEC PREC
S(X) = WHFOBO ; // START
Q(X) = WHFLDB ; // BTYES
E(X) = WHFOBO + WHFLDB -1 ; // END
IF T(X) = 'F' ; // FLOAT
I(X) = FFA1 + FFA2; // SCRN FIELD FORMAT ALPHA
L(X) = 14;
IF Q(X) = 8;
L(X) = 23;
ENDIF;
ELSE;
IF WHFLDD <> 0 ;
IF WHFLDP <> 0 ;
L(X) = WHFLDD + 2 ; // LENGTH
ELSE;
L(X) = WHFLDD + 1 ; // LENGTH
ENDIF;
I(X) = FFN1 + FFN2; // SCRN FIELD FORMAT NUMERIC
ELSE;
L(X) = WHFLDB ;
I(X) = FFA1 + FFA2; // SCRN FIELD FORMAT ALPHA
ENDIF;
ENDIF;
ENDDO;
// NUMBER OF FIELDS
NUMFLD = X ;
// MAKE ROOM FOR KEYS
IF NUMKEY > 0 ;
X1 = NUMKEY + NUMFLD;
FOR X = NUMFLD DOWNTO 1;
KY(X1) = KY(X) ;
L(X1) = L(X) ;
I(X1) = I(X) ;
N(X1) = N(X) ;
T(X1) = T(X) ;
V(X1) = V(X) ;
C(X1) = C(X) ;
P(X1) = P(X) ;
S(X1) = S(X) ;
E(X1) = E(X) ;
Q(X1) = Q(X) ;
X1 = X1 - 1;
ENDFOR;
// PUT KEY FIELDS AT TOP
OFF = 0;
FOR X = 1 TO NUMKEY;
X1 = %LOOKUP(KE(X) : N : NUMKEY+1);
KY(X) = '2';
L(X) = L(X1);
I(X) = I(X1); // FIELD FMT
SELECT; // INPUT ENABLE
WHEN I(X) = X6000;
I(X) = X4800;
WHEN I(X) = X6706;
I(X) = X4F06;
ENDSL;
N(X) = N(X1);
T(X) = T(X1);
V(X) = V(X1);
C(X) = C(X1);
P(X) = P(X1);
S(X) = S(X1);
E(X) = E(X1);
Q(X) = Q(X1);
R(X) = OFF;
OFF = OFF + Q(X1);
ENDFOR;
ENDIF;
// NUMBER OF FIELDS AND KEYS
NUMFKY = NUMFLD + NUMKEY;
ENDSR;
// @@@@@@@@@@@@@@@ GETADD @@@@@@@@@@@@@@@
// LOAD FIELD BUFFER ADDRESSES
BEGSR @GETADD;
MX = 0;
X = 0;
ROW = 3;
COL = 1;
FOR X = 1 TO NUMFKY;
// IF FINISHED WITH THE KEY FIELDS
// INC ROW FOR 1ST DATA FIELD
IF KEYSOK = ' ' ;
IF KY(X) = ' ' OR KY(X) = '1';
KEYSOK = '1' ;
ROW = ROW + 2;
COL = 1;
ENDIF;
ENDIF;
// SET THE BUFFER ADD ON THE LARGER OF THE FIELD TEXT OR THE FIELD SIZE
LENDSC = %LEN(%TRIM(N(X)));
LENWRK = L(X);
IF LENDSC > L(X);
LENWRK = LENDSC;
ENDIF;
LENWRK = LENWRK + 2;
// TRAP FIELDS THAT OVERFLOW
ROW = ROW + XROW;
XROW = %DIV(LENWRK : 80);
IF (COL + LENWRK) > 78;
EXSR @ROWINC;
IF MX = 3;
X= X-1;
NUMFKY = X;
LEAVE;
ENDIF;
COL = 1;
ENDIF;
// INC COL. FOR FIELD START
CLEAR B(X);
BIN = ROW;
B(X) = %TRIM(B(X)) + HX1;
BIN = COL + 1;
B(X) = %TRIM(B(X)) + HX1;
// INC COL. FOR NEXT FIELD
COL = COL + LENWRK;
IF COL > 78;
EXSR @ROWINC;
IF MX = 3; // NO ROOM FOR THE FIELD
X= X-1;
NUMFKY = X;
LEAVE;
ENDIF;
COL = 1;
ENDIF;
ENDFOR;
// FIELD LEVEL
LVX = LVL + 1;
LV(LVX) = N(X);
ENDSR;
// @@@@@@@@@@@@@@@ PUTHED @@@@@@@@@@@@@@@
// PUT FIELD HEADINGS
BEGSR @PUTHED;
NEWRU = '1';
RU = *ALLX'00';
CLEAR RU; // initialise Request Unit 255 bytes max
FOR XX = 1 TO NUMFKY; //NUMBER OF DATA ELEMENTS (FLD AND KEY)
IF NEWRU = '1';
NEWRU = '0';
RU = ESC + WTD + X20 + X00;
ENDIF;
RU = RU + SBA;
BIN = 0;
// CONVERT DATA BUFADR TO HEADING BUFADR
HX1 = %SUBST(B(XX) :1:1);
BIN = BIN - 1;
RU = RU + HX1;
IF REHEAD = '1'; // ON REDISPLAY OVERRIDE THE ATTR
BIN = 0;
HX1 = %SUBST(B(XX) :2:1);
BIN = BIN -1 ;
RU = RU + HX1;
ELSE;
RU = RU + %SUBST(B(XX) :2);
ENDIF;
RU = RU + ATC ;
// LONG NUMBER FIELDS ,RIGHT ADJUST THE FIELD HEADINGS
LENDSC = %LEN(%TRIM(N(XX)));
IF T(XX) <> 'A' AND LENDSC < (L(XX) -1);
FOR Y = 1 TO (L(XX) -(LENDSC +1));
RU = RU + ' ';
ENDFOR;
ENDIF;
RU = RU + %TRIM(N(XX));
IF %LEN(RU) >= 200;
BIN = %LEN(RU);
OUTLEN = HX2;
INLEN = X000;
FNC = SND;
A = RU;
EXCEPT DATAO;
NEWRU = '1';
RU = *ALLX'00';
CLEAR RU;
ENDIF;
ENDFOR;
IF %LEN(RU) > 5 AND %LEN(RU) < 200;
BIN = %LEN(RU);
OUTLEN = HX2;
INLEN = X000;
FNC = SND;
A = RU;
EXCEPT DATAO;
ENDIF;
IF REHEAD <> '1';
// FORMAT FIELDS
NEWRU = '1';
RU = *ALLX'00';
CLEAR RU; // initialise Request Unit 255 bytes max
FOR XX = 1 TO NUMFKY; //NUMBER OF DATA ELEMENTS (FLD AND KEY)
IF NEWRU = '1';
NEWRU = '0';
RU = ESC + WTD + X20 + X00;
ENDIF;
RU = RU + SBA +B(XX)+SF + I(XX);
IF KY(XX) = '1' OR KY(XX) = '2' OR KY(XX) = '3';
RU = RU + X25;
ELSE;
RU = RU + X26;
ENDIF;
BIN = L(XX);
RU = RU + HX2;
// LENGTH OF INPUT FIELDS
LENF = LENF + L(XX) + 3;
IF %LEN(RU) >= 200;
BIN = %LEN(RU);
OUTLEN = HX2;
INLEN = X000;
FNC = SND;
A = RU;
EXCEPT DATAO;
NEWRU = '1';
RU = *ALLX'00';
CLEAR RU;
ENDIF;
ENDFOR;
// PUT LAST R/U
IF %LEN(RU) > 5 AND %LEN(RU) < 200;
BIN = %LEN(RU);
OUTLEN = HX2;
INLEN = X000;
FNC = SND;
A = RU;
EXCEPT DATAO;
ENDIF;
//INC BUFFER ADDRESS FOR ALL FIELDS FOR DATA PUT
FOR XP = 1 TO NUMFKY; //NUMBER OF DATA ELEMENTS (FLD AND KEY)
HX2 = B(XP);
BIN = BIN + 1;
B(XP) = HX2;
ENDFOR;
ENDIF;
ENDSR;
// @@@@@@@ INIT @@@@@@@@@@@@@@@@@@@@@@@@@
BEGSR @INIT;
CLEAR KW;
// UPDATE
IF UPDF = 'Y';
FFA1 = X40;
FFN1 = X47;
ELSE;
FFA1 = X60;
FFN1 = X67;
ENDIF;
SELECT;
WHEN *INU1 = '1';
FILE = F1 ;
LIB = L1 ;
MBR = M1 ;
RCDL = R1 ;
ACCTP = A1 ;
WHEN *INU2 = '1';
FILE = F2 ;
LIB = L2 ;
MBR = M2 ;
RCDL = R2 ;
ACCTP = A2 ;
ENDSL;
RLEN = RCDL ;
RLENTH = %EDITC(RLEN: 'X') ;
LENF = 0 ;
// Control commands and data are constructed into RUs Request UNITS
// Each RU is 256 bytes max size.
// Construct and send as many RUs as needed to format the display.
RU = *ALLX'00';
CLEAR RU; // initialise Request Unit 255 bytes max
RU = CLRWTD ;
//set up the screen headings
BIN = 1; // set ROW to 1
RW = HX1;
BIN = 2; // set COL to 2
CL = HX1;
RU = RU + SBA + RW + CL + X22 + %TRIM(LIB) + '/' + %TRIM(FILE);
RU = RU + ' Mbr ' + %TRIM(MBR) + ' Rcdl ' + %EDITC(RLEN : 'Z') ;
RU = RU + ' RRN ' ;
BIN = %len(RU) -4;
RBA = RW + HX1 ; // address of the RRN field
RU = RU + SBA + RBA + ' ';
// FUNCTION KEYS
BIN = 23;
RW = HX1;
BIN = 02;
CL = HX1;
IF UPDF = 'Y'; // UPDATE IS ON
RU = RU + SBA + RW + CL + %TRIM(CNS(2));
ELSE;
RU = RU + SBA + RW + CL + %TRIM(CNS(1));
ENDIF;
// THIS IS A SEND ONLY FUNCTION
FNC = SND;
CLEAR A;
A = RU;
BIN2 = %LEN(RU);
OUTLEN = BY2;
INLEN = x000;
EXCEPT DATAO;
ENDSR;
// @@@@@@@ KEYIN @@@@@@@@@@@@@@@@@@@@@@@@@
BEGSR @KEYIN;
// ISSUE A READ FROM DISPLAY
FNC = SNR;
BIN2 = 8;
OUTLEN = BY2;
IPL = LENF + 34;
BIN2 = IPL;
INLEN = BY2;
// SET FRR INDICATORS TO CONTROL BUFFER OVERFLOW
FOR X = 1 TO 9;
IF IPL > ( X*80 +3);
*IN(X+19) = *ON;
ENDIF;
ENDFOR;
RU = *ALLX'00';
CLEAR RU;
RU = RDDSP;
A = RU;
EXCEPT DATAI;
ENDSR;
// @@@@@@@ ERROR @@@@@@@@@@@@@@@@@@@@@@@@@
BEGSR @ERROR;
// SETUP PUT ERROR MESSAGE X'21'
RU = *ALLX'00';
CLEAR RU;
FNC = SNR;
BIN = 42;
OUTLEN = HX2;
BIN = LENF + 34;
IPL = BIN;
INLEN = HX2;
FOR X = 1 TO 9;
IF IPL > (X * 80 +3) ;
*IN(X + 19) = *ON; // SETON FFR 20 - 29 FOR INPUT
ENDIF;
ENDFOR;
RU = ESC + WER + IC + B(1) + ATC + MSG(MX);
RU = RU + ESC + RDM + X40+ X00;
A = RU;
EXCEPT DATAI;
RU = *ALLX'00';
CLEAR RU;
ENDSR;
// @@@@@@@ HXDSP @@@@@@@@@@@@@@@@@@@@@@@@@
BEGSR @HXDSP;
RU = *ALLX'00';
CLEAR RU;
Y = %LOOKUPLE( CURLOC : B );
//
RU = ESC + WTD + X20 + X00 + SBA;
BIN = 0;
HX1 = %SUBST(B(Y) :1:1);
BIN = BIN - 1;
RU = RU + HX1;
RU = RU + %SUBST(B(Y) :2:1);
FOR X = S(Y) TO E(Y);
BIN = 0;
HX1 = D(X);
HX1 = %BITAND(HX1 : XF0);
Z = BIN / 16 + 1;
RU = RU + CRS(Z);
ENDFOR;
RU = RU + X20;
RU = RU + SBA + B(Y);
FOR X = S(Y) TO E(Y);
BIN = 0;
HX1 = D(X);
HX1 = %BITAND(HX1 : X0F);
Z = BIN + 1;
RU = RU + CRS(Z);
ENDFOR;
BIN = %LEN(RU);
OUTLEN = HX2;
INLEN = X000;
FNC = SND;
A = RU;
EXCEPT DATAO;
RU = *ALLX'00';
CLEAR RU;
EXSR @KEYIN;
READ DISPF;
// CLEAR HEADINGS
RU = *ALLX'00';
CLEAR RU;
RU = RU + ESC + WTD + X20 + X00 + SBA;
HX1 = %SUBST(B(Y) :1:1) ;
BIN = BIN - 1;
RU = RU + HX1 + %SUBST(B(Y):2:1);
FOR X = S(Y) TO E(Y);
RU = RU + ' ';
ENDFOR;
RU = RU + ' ';
BIN = %LEN(RU);
OUTLEN = HX2;
INLEN = X000;
FNC = SND;
A = RU;
EXCEPT DATAO;
RU = *ALLX'00';
CLEAR RU;
ENDSR;
// @@@@@@@ UPD @@@@@@@@@@@@@@@@@@@@@@@@@
BEGSR @UPD;
// CONVERT DATA FOR OUTPUT
// FOR EACH FIELD, CHECK IF FIELD WAS MODIFIED, AND IF SO MOVE
// THE MODIFIED DATA INTO THE OUTPUT ARRAY
K1 = 0;
K2 = 0;
W = 1;
CGKY = *BLANK; // KEY CHANGED
KW = KEYA;
FOR Y = 1 TO NUMFKY ;
IF KY(Y) > '1';
ITER;
ENDIF;
// MOVE A KEY FIELDS DATA FROM ID ARRAY (SCREEN) TO K ARRAY
// GET SIZE OF FIELD IN BYTES
IF T(Y) = 'A'; // ALPHA DATA
K = ' ';
K1 = 1;
K2 = Q(Y);
ELSE;
K = '0';
K1 = 1;
K2 = C(Y);
ENDIF;
X = 1;
DOW @LOOP = @LOOP;
// NXTSBA
X = %LOOKUP(SBA : ID : X );
IF X = 0;
LEAVE;
ENDIF;
// IS THIS THE FIELD? CHECK THE BUFFER ADDRESS
X = X +1;
IF B(Y) <> %SUBST(IDA : X :2);
ITER;
ENDIF;
// FOUND A MTD FOR THIS FIELD
// CHECK IF FIELD WAS CLEARED ONLY
DOW @LOOP = @LOOP; // not a loop
X = X + 2;
IF ID(X) = SBA;
LEAVE;
ENDIF;
// IF FIELD HAS DECIMALS BUMP X
IF (T(Y) = 'S' OR T(Y) = 'P' OR T(Y) = 'B') AND
P(Y) > 0;
X = X + 1;
ENDIF;
// CHECK IF ONLY BLANKS RETURNED
IF %SUBST(IDA : X :K2) = *BLANKS;
LEAVE;
ENDIF;
// MOVE DATA TO WORK ARRAY K
X1 = X;
FOR X2 = 1 TO K2;
IF ID(X1) < ' ';
LEAVE;
ENDIF;
K(X2) = ID(X1);
X1 = X1 + 1;
ENDFOR;
LEAVE;
ENDDO;
// * SET START POSN
W = S(Y);
// ALPHA
IF T(Y) = 'A' and V(XX) <> 'Y';
FOR Z = K1 to K2;
D(W) = K(Z);
W = W + 1;
ENDFOR;
ENDIF;
IF T(Y) = 'A' and V(XX) = 'Y'; //VARYING
// the data start is in S(Y)
// the data is in array K
// get the length of the data cvt to bin and stik in pos 1 2
// put the rest in pos 3 onwards
ENDIF;
// NUMERIC FIELD
// RIGHT ADJUST NUMERIC DATA ,STRIP - . ,CONVERT BLANKS
IF (T(Y) = 'S' OR T(Y) = 'P' OR T(Y) = 'B');
NU = '0';
Z1 = 60;
FOR Z = K2 DOWNTO K1;
IF K(Z) = '.' OR K(Z) = '-' OR K(Z) = '$';
ITER;
ENDIF;
IF K(Z) = ' ' ;
NU(Z1) = '0';
ELSE;
NU(Z1) = K(Z);
ENDIF;
Z1 = Z1 -1;
ENDFOR;
ENDIF;
// SIGNED FIELDS (END POSN = OFFSET + SIZE)
IF T(Y) = 'S';
NUSA= *BLANKS;
FOR VX = 1 TO 60;
NUSA = %TRIM(NUSA) + NU(VX);
ENDFOR;
%SUBST(DATA : W : Q(Y)) = %SUBST(NUSA: 61 -Q(Y));
ENDIF;
// PACKED FIELDS
IF T(Y) = 'P';
NUSA= *BLANKS;
FOR VX = 1 TO 60;
NUSA = %TRIM(NUSA) + NU(VX);
ENDFOR;
NUP = %DEC(NUSA : 60 : 0);
%SUBST(DATA : W : Q(Y)) = %SUBST(NUPA: 61 -Q(Y));
ENDIF;
// BINARY FIELDS
IF T(Y) = 'B';
IF Q(Y) = 2 ;
BY2 = NU(1) + NU(2);
%SUBST(DATA : W : 2) = BY2;
ENDIF;
IF Q(Y) = 4 ;
BY4 = NU(1) + NU(2) + NU(3) + NU(4);
%SUBST(DATA : W : 4) = BY4;
ENDIF;
ENDIF;
// UPDATE KEY IF NECESSARY
IF KY(Y) = '1';
CGKY = '1';
EXSR @PCKMOV;
ENDIF;
ENDDO;
ENDFOR;
IF CGKY = '1';
KEYA = KW;
ENDIF;
ENDSR;
/END-FREE
OINPUTK E U1 UPDATREC
O DA 16
O 30 DB
O 31 DC
O 32 DD
O 33 DE
O 34 DF
O 35 DG
O 36 DH
O 37 DI
O 38 DJ
O 39 DK
O 40 DL
O 41 DM
O 42 DN
O 43 DZ
O 44 DO
O 45 DP
O 46 DQ
O 47 DR
O 48 DS
O 49 DT
O 50 DU
O 51 DV
O 52 DW
O 53 DX
O 54 DY
O 55 D0
O 56 D1
O 57 D2
O 58 D3
O 59 D4
O 60 D5
O 61 D6
O 62 DBA
O 63 DCA
O 64 DDA
O 65 DEA
O 66 DFA
O 67 DGA
O 68 DHA
O 69 DIA
O 70 DJA
O 71 DKA
O 72 DLA
O 73 DMA
O 74 DNA
O 75 DOA
O 76 DPA
O 77 DQA
O 78 DRA
O 79 DSA
O 80 DTA
O 81 DUA
O 82 DVA
O 83 DWA
O 84 DXA
O 85 DYA
O 86 DZA
O 87 D0A
O 88 D1A
O 89 D2A
O 90 D3A
O 91 D4A
O 92 D5A
O 93 D6A
OINPUTR E U2 UPDATREC
O DA 16
O 30 DB
O 31 DC
O 32 DD
O 33 DE
O 34 DF
O 35 DG
O 36 DH
O 37 DI
O 38 DJ
O 39 DK
O 40 DL
O 41 DM
O 42 DN
O 43 DZ
O 44 DO
O 45 DP
O 46 DQ
O 47 DR
O 48 DS
O 49 DT
O 50 DU
O 51 DV
O 52 DW
O 53 DX
O 54 DY
O 55 D0
O 56 D1
O 57 D2
O 58 D3
O 59 D4
O 60 D5
O 61 D6
O 62 DBA
O 63 DCA
O 64 DDA
O 65 DEA
O 66 DFA
O 67 DGA
O 68 DHA
O 69 DIA
O 70 DJA
O 71 DKA
O 72 DLA
O 73 DMA
O 74 DNA
O 75 DOA
O 76 DPA
O 77 DQA
O 78 DRA
O 79 DSA
O 80 DTA
O 81 DUA
O 82 DVA
O 83 DWA
O 84 DXA
O 85 DYA
O 86 DZA
O 87 D0A
O 88 D1A
O 89 D2A
O 90 D3A
O 91 D4A
O 92 D5A
O 93 D6A
OINPUTK EADD U1 ADDREC
O DA 16
O 30 DB
O 31 DC
O 32 DD
O 33 DE
O 34 DF
O 35 DG
O 36 DH
O 37 DI
O 38 DJ
O 39 DK
O 40 DL
O 41 DM
O 42 DN
O 43 DZ
O 44 DO
O 45 DP
O 46 DQ
O 47 DR
O 48 DS
O 49 DT
O 50 DU
O 51 DV
O 52 DW
O 53 DX
O 54 DY
O 55 D0
O 56 D1
O 57 D2
O 58 D3
O 59 D4
O 60 D5
O 61 D6
O 62 DBA
O 63 DCA
O 64 DDA
O 65 DEA
O 66 DFA
O 67 DGA
O 68 DHA
O 69 DIA
O 70 DJA
O 71 DKA
O 72 DLA
O 73 DMA
O 74 DNA
O 75 DOA
O 76 DPA
O 77 DQA
O 78 DRA
O 79 DSA
O 80 DTA
O 81 DUA
O 82 DVA
O 83 DWA
O 84 DXA
O 85 DYA
O 86 DZA
O 87 D0A
O 88 D1A
O 89 D2A
O 90 D3A
O 91 D4A
O 92 D5A
O 93 D6A
OINPUTR EADD U2 ADDREC
O DA 16
O 30 DB
O 31 DC
O 32 DD
O 33 DE
O 34 DF
O 35 DG
O 36 DH
O 37 DI
O 38 DJ
O 39 DK
O 40 DL
O 41 DM
O 42 DN
O 43 DZ
O 44 DO
O 45 DP
O 46 DQ
O 47 DR
O 48 DS
O 49 DT
O 50 DU
O 51 DV
O 52 DW
O 53 DX
O 54 DY
O 55 D0
O 56 D1
O 57 D2
O 58 D3
O 59 D4
O 60 D5
O 61 D6
O 62 DBA
O 63 DCA
O 64 DDA
O 65 DEA
O 66 DFA
O 67 DGA
O 68 DHA
O 69 DIA
O 70 DJA
O 71 DKA
O 72 DLA
O 73 DMA
O 74 DNA
O 75 DOA
O 76 DPA
O 77 DQA
O 78 DRA
O 79 DSA
O 80 DTA
O 81 DUA
O 82 DVA
O 83 DWA
O 84 DXA
O 85 DYA
O 86 DZA
O 87 D0A
O 88 D1A
O 89 D2A
O 90 D3A
O 91 D4A
O 92 D5A
O 93 D6A
OINPUTK EDEL U1 DELREC
OINPUTR EDEL U2 DELREC
ODISPF E DATAO
O K3 'PUT'
O OUTLEN 2
O INLEN
O FNC
O A
O E DATAI
O K3 'GET'
O OUTLEN 2
O INLEN
O FNC
O A
**
0000 INVALID COMMAND KEY
0001 - A FIELD IS TOO LONG
0002 - TOO MANY FIELDS
0003 - ALPHAS IN PACKED KEY
0004 - MISSING ' IN PACKED KEY
0005 - MISSING DATA IN PCKD KEY
0006 - RECORD NOT FOUND
PRESS RESET TO CONTINUE
**
F1-HEX F2-Return F3-Exit F19-Prev_fld F20-More_fld
F1-HEX F2-Return F3-Exit F6-Update F9-Add F11-Del F19-Prev_fld F20-More_fld
**
0123456789ABCDEF
DUSP1 RPG
H*eywords++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++Comments+++++++++++
H OPTION(*NODEBUGIO)
H DFTACTGRP(*NO) ACTGRP(*CALLER) DFTNAME(DISP )
F*
F* LIMITED TO MAXIMUM FILE LENGTH OF 4080
F* REQUIRES FILE QTEMP/FFD TO COMPILE
F* use cmd DSPFFD FILE(&LIB/&FILE) OUTPUT(*OUTFILE) OUTFILE(QTEMP/FFD)
FFFD IF E DISK
FDISPF CF F 803 WORKSTN
F*
F INFDS(INFDS)
FINPUTK UF A F32766 800AIDISK KEYLOC(1)
F EXTIND(*INU1)
F INFDS(INFDK)
FINPUTR UF A F32766 DISK EXTIND(*INU2)
F INFDS(INFDR)
*
D A S 255 WORK RU
D RU S 255 varying
D RW S 1 ROW 1 byte binary
D CL S 1 COL 1 byte binary
D FNC S 1
D OUTLEN S 2
D INLEN S 2
D IPL S 5 0
D ROW S 3 0
D XROW S 3 0
D COL S 3 0
D KEYSOK S 1
D LENDSC S 3 0
D LENWRK S 5 0
D STRX S 5 0
D ENDX S 5 0
D VX S 5 0
D X S 5 0
D X1 S 5 0
D X2 S 5 0
D XX S 5 0
D XP S 5 0
D MX S 5 0
D ONCE S 1
D RBA S 2
D LF S 5 0
D ST S 5 0
D Y S 5 0
D Z S 5 0
D OFF S 5 0
D CGKY S 1
D UPDDONE S 1
D SUPZ S 1
D NUMFLD S 5 0
D WX S 5 0
D NUMKEY S 5 0
D NUMFKY S 5 0
D SCRST S 10
D SCRSTN S 1
D KEYA S 800
D RRNA S 11 0
D RRN S 11 0
D REHEAD S 1
D NEWRU S 1
D WRTRRN S 1
D LVX S 5 0
D LVL S 5 0
D K1 S 5 0
D K2 S 5 0
D Z1 S 5 0
D W S 5 0
D WK2 S 2
D MSSG S 32
*
D BASE S 5 0
D INZ S 1
D FILE S 10
D LIB S 10
D MBR S 10
D RCDL S 5 0
D ACCTP S 1
D RLEN S 5 0
D RLENTH S 5
D LENF S 5 0
D DS
D TEXT500 500
D LVW 10 DIM(50) overlay(TEXT500:1)
D TEXT800 S 800
D KW S 800
D DS
D WRK11 1 11
D NUM11 1 11S 0
D DS
D NUSA 1 60
D NUS 1 60S 0
D DS
D NUPA 1 60
D NUP 29 60P 0
D WRU S 61
D WRX S 64
D WRXWRD C '0 -
D -'
D WRSWRD C '0 -
D -'
D WRV S 60 varying
D FLT14 S 14
D FLT23 S 23
* SET FILE SIZE INCREMENTS (64 OF THEM)
D SZ S 5 0 DIM(64)
D S S 5 0 DIM(9000) START OF FLD
D E S 5 0 DIM(9000) END OF FLD
D Q S 5 0 DIM(9000) BYTES IN FIELD
D L S 5 0 DIM(9000) LENGTH OF FLD
D C S 3 0 DIM(9000) DEC DIGITS
D P S 3 0 DIM(9000) DEC PRECISION
D B S 2 DIM(9000) ASCEND BUFFER ADD
D I S 2 DIM(9000) FLD FMT
D N S 10 DIM(9000) FLD NAME
D T S 1 DIM(9000) FLD TYPE
D V S 1 DIM(9000) VARYING
D KY S 1 DIM(9000) KEYED
D KE S 10 DIM(128) KEY FLDS
D R S 3 0 DIM(9000) KEY FLD START
D K S 1 DIM(800) KEY
D NA S 1 DIM(10) NAME WORK
D NU S 1 DIM(60) NUM. WORK
D LV S 10 DIM(50) SCREEN LEVELS
D MSG S 32 DIM(8) CTDATA PERRCD(1) MESSAGES
D CNS S 79 DIM(2) CTDATA PERRCD(1)
D CRS S 1 DIM(16) CTDATA PERRCD(16)
D DS
D D 1 4080
D DIM(4080) INCOMING DATA
D DA 1 2048
D DIM(2048)
D DB 2049 2064
D DC 2065 2096
D DD 2097 2128
D DE 2129 2160
D DF 2161 2192
D DG 2193 2224
D DH 2225 2256
D DI 2257 2288
D DJ 2289 2320
D DK 2321 2352
D DL 2353 2384
D DM 2385 2416
D DN 2417 2448
D DZ 2449 2480
D DO 2481 2512
D DP 2513 2544
D DQ 2545 2576
D DR 2577 2608
D DS 2609 2640
D DT 2641 2672
D DU 2673 2704
D DV 2705 2736
D DW 2737 2768
D DX 2769 2800
D DY 2801 2832
D D0 2833 2864
D D1 2865 2896
D D2 2897 2928
D D3 2929 2960
D D4 2961 2992
D D5 2993 3024
D D6 3025 3056
D DBA 3057 3088
D DCA 3089 3120
D DDA 3121 3152
D DEA 3153 3184
D DFA 3185 3216
D DGA 3217 3248
D DHA 3249 3280
D DIA 3281 3312
D DJA 3313 3344
D DKA 3345 3376
D DLA 3377 3408
D DMA 3409 3440
D DNA 3441 3472
D DOA 3473 3504
D DPA 3505 3536
D DQA 3537 3568
D DRA 3569 3600
D DSA 3601 3632
D DTA 3633 3664
D DUA 3665 3696
D DVA 3697 3728
D DWA 3729 3760
D DXA 3761 3792
D DYA 3793 3824
D DZA 3825 3856
D D0A 3857 3888
D D1A 3889 3920
D D2A 3921 3952
D D3A 3953 3984
D D4A 3985 4016
D D5A 4017 4048
D D6A 4049 4080
D DS
D ID 1 800
D DIM(800) INCOMING DATA
D IDA 1 800
D ID0 1 80
D ID1 81 160
D ID2 161 240
D ID3 241 320
D ID4 321 400
D ID5 401 480
D ID6 481 560
D ID7 561 640
D ID8 641 720
D ID9 721 800
D DS
D BIN 1 2B 0
D HX1 2 2
D HX2 1 2
D DS
D PCK 1 1P 0
D PCK1 1 1
D DS
D SGN 1 1S 0
D SGN1 1 1
D DS
D BIN4 1 4B 0
D BY4 1 4
D DS
D BIN2 1 2B 0
D BY2 1 2
D DS
D FLT4 1 4F
D FL4 1 4
D DS
D FLT8 1 8F
D FL8 1 8
D INFDK DS
D F1 83 92
D L1 93 102
D M1 129 138
D R1 125 126B 0
D A1 160 160
D LOP1 260 260
D KEY_LEN 393 394I 0 Key length
D RN1 397 400B 0
D LKY 401 1200
D INFDR DS
D F2 83 92
D L2 93 102
D M2 129 138
D R2 125 126B 0
D A2 160 160
D LOP2 260 260
D RN2 397 400B 0
D*
D INFDS DS
D CURLOC 370 371
D DS
D KEYLN 1 4S 0
D KEYLNA 1 4
DDUSP PR
D 1
D 1
D 4
D 1
D 500
D 5
D 800
DDUSP PI
D ALL 1
D RTN 1
D KEYLNG 4
D UPDF 1
D SCNLV 500
D SCNLVL 5
D SCNKEY 800
D @LOOP C '1'
D @FALSE C '0'
D @TRUE C '1'
D SND C X'71' SEND TO DISP
D SNR C X'73' SND/RCV
D RED C X'42' READ
D RDM C X'52' READ MTD
D ESC C X'04' ESCAPE
D CLR C X'40' CLEAR UNIT
D CC1 C X'00' CNTRL CHAR
D CC2 C X'08' CNTRL CHAR
D SBA C X'11' SET BUFF ADR
D IC C X'13' INSERT CURS
D WTD C X'11' WRITE TO DSP
D WER C X'21' WRITE ERROR
D SF C X'1D' START FLD
D ATC C X'20' ATTR CHAR
D ATN C X'24' ATTR NUM
D X00 C X'00'
D X01 C X'01'
D X02 C X'02'
D X03 C X'03'
D X0D C X'0D'
D X0F C X'0F'
D X000 C X'0000'
D X1F C X'1F'
D X20 C X'20' SCRN ATT NORMAL
D X22 C X'22' SCRN ATTR HI
D X25 C X'25'
D X26 C X'26'
D X31 C X'31' CMD 1 KEY
D X32 C X'32' CMD 2 KEY
D X33 C X'33' CMD 3 KEY
D X36 C X'36' CMD 6 KEY
D X37 C X'37' CMD 7 KEY
D X38 C X'38' CMD 8 KEY
D X39 C X'39' CMD 9 KEY
D X3B C X'3B' CMD11 KEY
D XB7 C X'B7' CMD19 KEY
D XB8 C X'B8' CMD20 KEY
D X40 C X'40'
D X43 C X'43'
D X47 C X'47'
D X60 C X'60'
D X67 C X'67'
D X9F C X'9F'
D XF0 C X'F0'
D XD0 C X'D0'
D X4000 C X'4000'
D X4800 C X'4800' FF ALPHA
D X4F06 C X'4F06' FF NUMERIC
D X6000 C X'6000' FF ALPHA
D X6706 C X'6706' FF NUMERIC
D CLRWTD C X'044004112000' INCLUDES ESC CHARS
D RDDSP C X'0411200804524000' READ FROM DISPLAY
D FFA1 S 1 INZ(X'40') F.FMT 1 ALPH 60 BYP
D FFA2 S 1 INZ(X'00') F.FMT 2 ALPH
D FFN1 S 1 INZ(X'47') F.FMT 1 NUM 67 BYP
D FFN2 S 1 INZ(X'06') F.FMT 2 NUM
I*.
IINPUTK NS 01
I 1 2048 DA
I 2049 2064 DB 30
I 2065 2096 DC 31
I 2097 2128 DD 32
I 2129 2160 DE 33
I 2161 2192 DF 34
I 2193 2224 DG 35
I 2225 2256 DH 36
I 2257 2288 DI 37
I 2289 2320 DJ 38
I 2321 2352 DK 39
I 2353 2384 DL 40
I 2385 2416 DM 41
I 2417 2448 DN 42
I 2449 2480 DZ 43
I 2481 2512 DO 44
I 2513 2544 DP 45
I 2545 2576 DQ 46
I 2577 2608 DR 47
I 2609 2640 DS 48
I 2641 2672 DT 49
I 2673 2704 DU 50
I 2705 2736 DV 51
I 2737 2768 DW 52
I 2769 2800 DX 53
I 2801 2832 DY 54
I 2833 2864 D0 55
I 2865 2896 D1 56
I 2897 2928 D2 57
I 2929 2960 D3 58
I 2961 2992 D4 59
I 2993 3024 D5 60
I 3025 3056 D6 61
I 3057 3088 DBA 62
I 3089 3120 DCA 63
I 3121 3152 DDA 64
I 3153 3184 DEA 65
I 3185 3216 DFA 66
I 3217 3248 DGA 67
I 3249 3280 DHA 68
I 3281 3312 DIA 69
I 3313 3344 DJA 70
I 3345 3376 DKA 71
I 3377 3408 DLA 72
I 3409 3440 DMA 73
I 3441 3472 DNA 74
I 3473 3504 DOA 75
I 3505 3536 DPA 76
I 3537 3568 DQA 77
I 3569 3600 DRA 78
I 3601 3632 DSA 79
I 3633 3664 DTA 80
I 3665 3696 DUA 81
I 3697 3728 DVA 82
I 3729 3760 DWA 83
I 3761 3792 DXA 84
I 3793 3824 DYA 85
I 3825 3856 DZA 86
I 3857 3888 D0A 87
I 3889 3920 D1A 88
I 3921 3952 D2A 89
I 3953 3984 D3A 90
I 3985 4016 D4A 91
I 4017 4048 D5A 92
I 4049 4080 D6A 93
IINPUTR NS 01
I 1 2048 DA
I 2049 2064 DB 30
I 2065 2096 DC 31
I 2097 2128 DD 32
I 2129 2160 DE 33
I 2161 2192 DF 34
I 2193 2224 DG 35
I 2225 2256 DH 36
I 2257 2288 DI 37
I 2289 2320 DJ 38
I 2321 2352 DK 39
I 2353 2384 DL 40
I 2385 2416 DM 41
I 2417 2448 DN 42
I 2449 2480 DZ 43
I 2481 2512 DO 44
I 2513 2544 DP 45
I 2545 2576 DQ 46
I 2577 2608 DR 47
I 2609 2640 DS 48
I 2641 2672 DT 49
I 2673 2704 DU 50
I 2705 2736 DV 51
I 2737 2768 DW 52
I 2769 2800 DX 53
I 2801 2832 DY 54
I 2833 2864 D0 55
I 2865 2896 D1 56
I 2897 2928 D2 57
I 2929 2960 D3 58
I 2961 2992 D4 59
I 2993 3024 D5 60
I 3025 3056 D6 61
I 3057 3088 DBA 62
I 3089 3120 DCA 63
I 3121 3152 DDA 64
I 3153 3184 DEA 65
I 3185 3216 DFA 66
I 3217 3248 DGA 67
I 3249 3280 DHA 68
I 3281 3312 DIA 69
I 3313 3344 DJA 70
I 3345 3376 DKA 71
I 3377 3408 DLA 72
I 3409 3440 DMA 73
I 3441 3472 DNA 74
I 3473 3504 DOA 75
I 3505 3536 DPA 76
I 3537 3568 DQA 77
I 3569 3600 DRA 78
I 3601 3632 DSA 79
I 3633 3664 DTA 80
I 3665 3696 DUA 81
I 3697 3728 DVA 82
I 3729 3760 DWA 83
I 3761 3792 DXA 84
I 3793 3824 DYA 85
I 3825 3856 DZA 86
I 3857 3888 D0A 87
I 3889 3920 D1A 88
I 3921 3952 D2A 89
I 3953 3984 D3A 90
I 3985 4016 D4A 91
I 4017 4048 D5A 92
I 4049 4080 D6A 93
IDISPF NS 02
I 3 3 AID
I 4 83 ID0
I 84 163 ID1 20
I 164 243 ID2 21
I 244 323 ID3 22
I 324 403 ID4 23
I 404 483 ID5 24
I 484 563 ID6 25
I 564 643 ID7 26
I 644 723 ID8 27
I 724 803 ID9 28
/FREE
BASE = 2048;
IF ONCE = ' ';
EXSR @INITZ ;
ENDIF;
// START TAG
DOW @LOOP = @LOOP;
IF RTN = '3';
IF *INU1;
KEYA = SCNKEY;
ENDIF;
IF *INU2;
RRNA = %DEC(%SUBST(SCNKEY:1:11):11:0);
ENDIF;
RTN = '0';
AID = '1';
ELSE;
RTN = '0';
READ(E) DISPF;
ENDIF;
// CF3 EXIT
IF AID = X33;
LEAVE;
ENDIF;
// CF2 RETURN
IF AID = X32;
RTN = '1';
LEAVE;
ENDIF;
// CF1 HEX A FIELD
IF AID = X31;
Y = %LOOKUPLE( CURLOC : B );
IF Y > 0;
IF KY(Y) <= '1';
EXSR @HXDSP;
REHEAD = '1';
EXSR @PUTHED;
REHEAD = ' ';
ENDIF;
ENDIF;
ENDIF;
// CF20 MORE FIELDS
IF AID = XB8;
LVX = LVL + 1;
IF LV(LVX) <> *BLANK;
LVL = LVL +1 ;
LVW = LV;
SCNLV = TEXT500;
SCNLVL = %EDITC(LVL :'X');
SCNKEY = *BLANKS;
IF *INU1;
SCNKEY = KEYA;
ENDIF;
IF *INU2;
SCNKEY = %EDITC(RRNA:'X');
ENDIF;
RTN = '3';
LEAVE;
ENDIF;
ENDIF;
// CF19 PREVIOUS FIELDS
IF AID = XB7;
LVX = LVL - 1;
IF LVX >= 0 ;
LVL = LVL - 1 ;
LVW = LV;
SCNLV = TEXT500;
SCNLVL = %EDITC(LVL :'X');
SCNKEY = *BLANKS;
IF *INU1;
SCNKEY = KEYA;
ENDIF;
IF *INU2;
SCNKEY = %EDITC(RRNA:'X');
ENDIF;
RTN = '3';
LEAVE;
ENDIF;
ENDIF;
// 1 ENTER 4 ROLL DN 5 ROLL UP
// F6 = X36 F9 = X39 F11 = X3B
IF AID = '1'or AID = '4' or AID = '5' or
AID = X36 or AID = X39 or AID = X3B;
ELSE;
MX = 1; // INVALID KEY
EXSR @ERROR;
ENDIF;
// UPDATE MODE
IF UPDF = 'Y';
UPDDONE = @FALSE;
// F6
IF *INU1 AND AID = X36 AND
(LOP1 = X01 OR LOP1 = X03);
EXSR @UPD;
EXCEPT UPDATREC;
UPDDONE = @TRUE;
ENDIF;
IF *INU2 AND AID = X36 AND
(LOP2 = X01 OR LOP2 = X02);
EXSR @UPD;
EXCEPT UPDATREC;
UPDDONE = @TRUE;
ENDIF;
// F9
IF AID = X39;
EXSR @UPD;
EXCEPT ADDREC;
UPDDONE = @TRUE;
ENDIF;
// F11
IF *INU1 AND AID = X3B AND
(LOP1 = X01 OR LOP1 = X03);
EXCEPT DELREC;
UPDDONE = @TRUE;
ENDIF;
IF *INU2 AND AID = X3B AND
(LOP2 = X01 OR LOP2 = X02);
EXCEPT DELREC;
UPDDONE = @TRUE;
ENDIF;
ENDIF;
IF RTN = '3' OR UPDDONE = @TRUE;
ELSE;
EXSR @PCKD;
ENDIF;
// CONT1 GET A RECORD, KEY FROM DATA
EXSR @SETIN;
EXSR @GETF ;
EXSR @PUTF ;
EXSR @KEYIN;
ENDDO ;
*INLR = *ON;
// @@@@@@@ @INITZ @@@@@@@@@@@@@@@@@@@@@@@@@@
BEGSR @INITZ;
ONCE = '1';
KEYLNA = KEYLNG ;
EXSR @INIT ;
EXSR @GETFLD ;
EXSR @GETADD ;
EXSR @PUTHED ;
EXSR @KEYIN ;
INZ = '1';
EXSR @PCKD ;
INZ = ' ';
ENDSR;
// @@@@@@@ @PCKD @@@@@@@@@@@@@@@@@@@@@@@@@@
BEGSR @PCKD ;
// CONVERT KEY DATA
IF *INU1 ;
EXSR @CVTKEY;
ENDIF;
IF *INU2 ;
EXSR @CVTRRN;
ENDIF;
ENDSR;
// @@@@@@@ @CVTKEY @@@@@@@@@@@@@@@@@@@@@@@@
BEGSR @CVTKEY;
// EXTRACT THE KEY FIELD DATA FROM THE INCOMING STRING
// FOR EACH KEY FIELD, CHECK IF FIELD WAS MODIFIED, AND IF SO MOVE
// THE MODIFIED DATA INTO THE COMPOSITE KEY
K1 = 0;
K2 = 0;
W = 1;
FOR Y = 1 TO NUMKEY ;
// MOVE A KEY FIELDS DATA FROM ID ARRAY (SCREEN) TO K ARRAY (KEY FIELDS)
// GET SIZE OF FIELD IN BYTES
IF T(Y) = 'A'; // ALPHA DATA
K = ' ';
K1 = 1;
K2 = Q(Y);
ELSE;
K = '0';
K1 = 1;
K2 = C(Y);
ENDIF;
// IF WHOLE KEY INIT WAS REQUESTED BYPASS THE EXTRACT
IF INZ = '1' ;
KW = *BLANK;
EXSR @PCKMOV;
ITER;
ENDIF;
X = 1;
DOW @LOOP = @LOOP;
// NXTSBA
X = %LOOKUP(SBA : ID : X );
IF X = 0;
LEAVE;
ENDIF;
// IS THIS THE FIELD? CHECK THE BUFFER ADDRESS
X = X +1;
IF B(Y) <> %SUBST(IDA : X :2);
ITER;
ENDIF;
// FOUND A MTD FOR THIS FIELD
X = X + 2;
// CHECK IF FIELD WAS CLEARED ONLY
IF ID(X) = SBA;
EXSR @PCKMOV;
LEAVE ;
ENDIF;
// IF FIELD HAS DECIMALS BUMP X
IF (T(Y) = 'S' OR T(Y) = 'P' OR T(Y) = 'B') AND
P(Y) > 0;
X = X + 1;
ENDIF;
// CHECK IF ONLY BLANKS RETURNED
IF %SUBST(IDA : X :K2) = *BLANKS;
EXSR @PCKMOV;
LEAVE;
ENDIF;
// EXTRACT THE DATA FROM THE INCOMING STRING
X1 = X;
FOR X2 = 1 TO K2 ;
IF ID(X1) < ' ';
// TRAP NULLS CAUSED BY FLD EXIT
EXSR @PCKMOV;
LEAVE;
ENDIF;
K(X2) = ID(X1);
X1 = X1 +1;
ENDFOR;
// CONSTRUCT THE ACTUAL KEY WITH PACKED DATA IF REQUIRED
// INTO ARRAY KW
EXSR @PCKMOV;
LEAVE;
ENDDO;
ENDFOR;
//
KEYA = KW;
CLEAR KW;
ENDSR ;
// @@@@@@@ @CVTRRN @@@@@@@@@@@@@@@@@@@@@@@@
BEGSR @CVTRRN;
// RRN
NUM11 = 0;
DOW @LOOP = @LOOP; // NOT REALLY A LOOP(SIMULATES GOTO)
// GET THE FIRST SBA
X = 1;
X = %LOOKUP(SBA : ID : X );
IF X = 0;
LEAVE;
ENDIF;
// CHECK THE BUFFER ADDRESS MATCHES THE EXPECTED FIELD
X = X +1;
IF B(1) <> %SUBST(IDA : X :2);
ITER;
ENDIF;
// FOUND A MTD FOR RRN FIELD
X = X +2;
//CHECK IF FIELD WAS CLEARED ONLY
IF ID(X) = SBA;
LEAVE;
ENDIF;
// CHECK IF ONLY BLANKS RETURNED
IF %SUBST(IDA : X :11) = *BLANKS;
LEAVE;
ENDIF;
// WRK11 OVERLAYS NUM11
WRK11 = %SUBST(IDA : X :11);
LEAVE;
ENDDO;
RRNA = NUM11;
IF RRNA < 0;
RRNA = 1;
ENDIF;
ENDSR;
// @@@@@@@ @PCKMOV @@@@@@@@@@@@@@@@@@@@@@@@
BEGSR @PCKMOV;
//
// CONVERT KEY DATA
// SET START POSN IN KEY USING OFFSET IN R
X1 = %LOOKUP(N(Y) : N );
W = R(X1) + 1;
// ALPHA
IF T(Y) = 'A';
X1 = 1;
FOR Z = W TO W + Q(Y);
%SUBST(KW : Z : 1) = K(X1);
X1 = X1 + 1;
ENDFOR;
ENDIF;
// NUMERIC FIELD
// RIGHT ADJUST NUMERIC DATA ,STRIP - . ,CONVERT BLANKS
IF (T(Y) = 'S' OR T(Y) = 'P' OR T(Y) = 'B');
NU = '0';
Z1 = 60;
FOR Z = K2 DOWNTO K1;
IF K(Z) = '.' OR K(Z) = '-' OR K(Z) = '$';
ITER;
ENDIF;
IF K(Z) = ' ' ;
NU(Z1) = '0';
ELSE;
NU(Z1) = K(Z);
ENDIF;
Z1 = Z1 -1;
ENDFOR;
ENDIF;
// SIGNED FIELDS (END POSN = OFFSET + SIZE)
IF T(Y) = 'S';
NUS = 0;
FOR VX = 1 TO 60;
NUSA = %TRIM(NUSA) + NU(VX);
ENDFOR;
%SUBST(KW : W : Q(Y)) = %SUBST(NUSA: 61 -Q(Y));
ENDIF;
// PACKED FIELDS
IF T(Y) = 'P';
NUSA= *BLANKS;
FOR VX = 1 TO 60;
NUSA = %TRIM(NUSA) + NU(VX);
ENDFOR;
NUP = %DEC(NUSA : 60 : 0);
%SUBST(KW : W : Q(Y)) = %SUBST(NUPA: 61 -Q(Y));
ENDIF;
// BINARY FIELDS
IF T(Y) = 'B';
IF Q(Y) = 2 ;
BY2 = NU(1) + NU(2);
%SUBST(KW : W : 2) = BY2;
ENDIF;
IF Q(Y) = 4 ;
BY4 = NU(1) + NU(2) + NU(3) + NU(4);
%SUBST(KW : W : 4) = BY4;
ENDIF;
ENDIF;
ENDSR;
// @@@@@@@ SETIN @@@@@@@@@@@@@@@@@@@@@@@@@
BEGSR @SETIN;
// SET the FFR indicators to get the Input buffer somewhat aligned with the
// actual data. RPG is somewhat tolerant to a difference between the Ispecs
// and the actual file size but it can fail on big differences.
// INCREMENT OF 32 BYTES
SZ(1) = BASE + 16;
SZ(2) = SZ(1) + 16;
*IN30 = *ON;
IF (RLEN > SZ(2)) ;
*IN31 = *ON;
ENDIF;
FOR X = 3 TO 64;
SZ(X) = SZ(X-1) + 32;
IF (RLEN > SZ(X)) ;
*IN(29+X) = *ON;
ENDIF;
ENDFOR;
ENDSR;
//@@@@@@@@@@@@@@@@@ @GETF @@@@@@@@@@@@@@@@@
BEGSR @GETF;
// GET A DATA RECORD
IF (*INU1);
IF AID = '1' OR AID = X36 OR
AID = X39 OR AID = X3B ;
SETLL(E) KEYA INPUTK;
READ(E) INPUTK;
IF %EOF;
SETLL(E) KEYA INPUTK;
READP(E) INPUTK;
ENDIF;
ENDIF;
IF AID = '4';
READP(E) INPUTK;
ENDIF;
IF AID = '5';
READ(E) INPUTK;
ENDIF;
IF %ERROR;
SETLL(E) KEYA INPUTK;
READ(E) INPUTK;
MX = 7;
EXSR @ERROR;
EXSR @PUTF ;
EXSR @KEYIN;
ENDIF;
KEYA = LKY;
CLEAR KW;
KW = LKY;
ENDIF;
IF (*INU2);
IF AID = '1';
CHAIN(E) RRNA INPUTR;
IF %ERROR;
SETLL(E) RRNA INPUTR;
READP(E) INPUTR;
ENDIF;
ENDIF;
IF AID = X36;
CHAIN(E) RRNA INPUTR;
ENDIF;
IF AID = '4';
READP(E) INPUTR;
ENDIF;
IF AID = '5' OR AID = X3B;
READ(E) INPUTR;
ENDIF;
IF AID = X39;
SETLL(E) *HIVAL INPUTR;
READP(E) INPUTR;
ENDIF;
IF %ERROR;
CHAIN 1 INPUTR;
MX = 7;
EXSR @ERROR;
EXSR @PUTF ;
EXSR @KEYIN;
ENDIF;
ENDIF;
ENDSR;
//@@@@@@@@@@@@@@@@@ @PUTF @@@@@@@@@@@@@@@@@
BEGSR @PUTF;
// WRITE DATA TO THE DISPLAY
NEWRU = '1';
WRTRRN = '1';
RU = *ALLX'00';
CLEAR RU; // initialise Request Unit 255 bytes max
FOR XX = 1 TO NUMFKY; //NUMBER OF DATA ELEMENTS (FLD AND KEY)
IF NEWRU = '1';
NEWRU = '0';
RU = ESC + WTD + X20 + X00;
ENDIF;
IF WRTRRN = '1';
WRTRRN = '0';
RU = RU + SBA + RBA ;
SELECT;
WHEN *INU1;
RRN = RN1;
WHEN *INU2;
RRN = RN2;
ENDSL;
RU = RU + %TRIM(%EDITC(RRN:'Z'));
ENDIF;
// BUFFER ADDRESS
RU = RU + SBA + B(XX);
// PROCESS ALPHA DATA TYPE
IF T(XX) = 'A' OR T(XX) = 'T' OR T(XX) = 'Z' OR
T(XX) = 'L';
STRX = S(XX);
ENDX = E(XX);
IF V(XX) = 'Y'; //VARYING
VX = S(XX);
HX2 = D(VX) + D(VX+1);
STRX = S(XX) + 2 ;
ENDX = S(XX) + BIN;
ENDIF;
FOR Y = STRX TO ENDX ;
IF D(Y) >= ' ';
RU = RU + D(Y);
ELSE;
RU = RU + X1F ; //IF NOT DISPLAYABLE REPLACE WITH X'1F'
ENDIF;
ENDFOR;
ENDIF;
// PROCESS SIGNED DATA TYPE (not the RRN field)
IF T(XX) = 'S' and KY(XX) <> '3';
NUSA = *ALL'0';
WRV = *ALLX'00';
CLEAR WRV;
FOR Y = S(XX) TO E(XX);
IF D(Y) >= XD0;
WRV = WRV + D(Y);
ENDIF;
ENDFOR;
EVAL NUSA = %SUBST(NUSA : 1 : 60 - %LEN(WRV)) + WRV;
CLEAR WRU;
WRU = %TRIM(WRU) + %EDITW(NUS :WRSWRD);
IF P(XX) > 0;
RU = RU +
%SUBST(WRU :61-C(XX): C(XX)-P(XX)) + '.' +
%SUBST(WRU :61-P(XX)) ;
ELSE;
RU = RU +
%SUBST(WRU :61-C(XX));
ENDIF;
ENDIF;
// PROCESS SIGNED DATA TYPE (the RRN field)
IF T(XX) = 'S' and KY(XX) = '3';
RRN = RN2;
RU = RU + %TRIM(%EDITC(RRN:'X'));
ENDIF;
// PROCESS PACKED DATA TYPE
IF T(XX) = 'P';
NUPA = *ALLX'00';
WRV = *ALLX'00';
CLEAR WRV;
FOR Y = S(XX) TO E(XX);
WRV = WRV + D(Y);
ENDFOR;
IF %BITAND(D(E(XX)) :X0F) = X0F OR
%BITAND(D(E(XX)) :X0D) = X0D;
EVAL NUPA = %SUBST(NUPA : 1 : 60 - %LEN(WRV)) + WRV;
CLEAR WRX;
WRX = %TRIM(WRX) + %EDITW(NUP :WRXWRD);
IF P(XX) > 0;
RU = RU +
%SUBST(WRX :64-C(XX): C(XX)-P(XX)) + '.' +
%SUBST(WRX :64-P(XX)) ;
ELSE;
RU = RU +
%SUBST(WRX :64-C(XX));
ENDIF;
ELSE;
// PACKED FIELD IN ERROR
RU = RU + X1F;
ENDIF;
ENDIF;
// PROCESS BINARY DATA TYPE
IF T(XX) = 'B';
ST = S(XX);
CLEAR NUSA;
IF Q(XX) = 2;
BY2 = D(ST) + D(ST+1);
NUS = BIN2;
ENDIF;
IF Q(XX) = 4;
BY4 = D(ST) + D(ST+1)+ D(ST+2) + D(ST+3);
NUS = BIN4;
ENDIF;
WRU = %EDITW(NUS :WRSWRD);
IF P(XX) > 0;
RU = RU +
%SUBST(WRU :61-C(XX): C(XX)-P(XX)) + '.' +
%SUBST(WRU :61-P(XX)) ;
ELSE;
RU = RU +
%SUBST(WRU :61-C(XX));
ENDIF;
ENDIF;
// PROCESS FLOAT DATA TYPE
IF T(XX) = 'F';
ST = S(XX);
IF Q(XX) = 4;
FL4 = D(ST) + D(ST+1)+ D(ST+2) + D(ST+3);
FLT14 = %EDITFLT(FLT4);
RU = RU + FLT14;
ENDIF;
IF Q(XX) = 8;
FL8 = D(ST) + D(ST+1)+ D(ST+2) + D(ST+3) +
D(ST+4) + D(ST+5)+ D(ST+6) + D(ST+7);
FLT23 = %EDITFLT(FLT8);
RU = RU + FLT23;
ENDIF;
ENDIF;
// SEND A REQUEST UNIT IF GOT ENOUGH DATA
IF %LEN(RU) + L(XX + 1) >= 200;
RU = RU + X20;
BIN = %LEN(RU);
OUTLEN = HX2;
INLEN = X000;
FNC = SND;
A = RU;
EXCEPT DATAO;
NEWRU = '1';
RU = *ALLX'00';
CLEAR RU;
ENDIF;
ENDFOR;
IF %LEN(RU) > 5 AND %LEN(RU) < 250;
RU = RU + X20;
BIN = %LEN(RU);
OUTLEN = HX2;
INLEN = X000;
FNC = SND;
A = RU;
EXCEPT DATAO;
ENDIF;
ENDSR;
// @@@@@@@@@@@@@@@ ROWINC @@@@@@@@@@@@@@@
// INCREMENT THE ROW
BEGSR @ROWINC;
ROW = ROW + 2;
IF ROW > 20;
MX = 3;
ENDIF;
ENDSR;
// @@@@@@@@@@@@@@@ GETFLD @@@@@@@@@@@@@@@
// LOAD FIELD DESCRIPTION ARRAYS
BEGSR @GETFLD;
MX = 0;
X = 0;
IF (*INU2 = *ON);
// IF NON KEYED ACCESS SET UP A FIELD TO SHOW THE RRN
N(1) = 'RRN';
T(1) = 'S' ;
C(1) = 11 ;
P(1) = 0 ;
S(1) = 0 ;
E(1) = 0 ;
L(1) = 12 ;
I(1) = X4F06 ;
KY(1)= '3' ;
X = 1 ;
ENDIF;
SCRST = *BLANK;
SCRSTN = *BLANK;
LVL = %DEC(SCNLVL : 5:0);
TEXT500 = SCNLV ;
LV = LVW;
IF LVL <> 0;
SCRST = LV(LVL);
ENDIF;
SETLL 1 QWHDRFFD ;
DOW @LOOP = @LOOP;
// REREAD TAG
READ QWHDRFFD;
IF %EOF;
LEAVE;
ENDIF;
// SELECT OR OMIT
IF ALL <> '1';
IF ALL = 'S' AND WHDFTL = 0; // USING WHDFTL FOR KEY FIELDS
IF WHFIOB <> 'S';
ITER;
ENDIF;
ENDIF;
IF ALL = 'O' AND WHDFTL = 0; // USING WHDFTL FOR KEY FIELDS
IF WHFIOB = 'O';
ITER;
ENDIF;
ENDIF;
ENDIF;
// FIND THE FIRST FIELD TO BE SHOWN (FOR MULTI PAGE FORMATS)
IF WHDFTL <> 0 ;
ELSE;
IF SCRST <> ' ' AND SCRSTN = ' ';
IF WHFLDE = SCRST;
SCRSTN = '1'; // FOUND THE START
ELSE;
ITER;
ENDIF;
ENDIF;
ENDIF;
X = X + 1;
// CHECK FOR KEY FIELDS,WILL BE USED TO PLACE THEM IN FRONT
IF WHDFTL <> 0;
KY(X) = '1';
WX = WHDFTL ;
KE(WX) = WHFLDE;
IF NUMKEY < WHDFTL;
NUMKEY = WHDFTL;
ENDIF;
ENDIF;
N(X) = WHFLDE ; // NAME
T(X) = WHFLDT ; // TYPE
V(X) = WHVARL ; // VARYING
C(X) = WHFLDD ; // DEC DIGITS
P(X) = WHFLDP ; // DEC PREC
S(X) = WHFOBO ; // START
Q(X) = WHFLDB ; // BTYES
E(X) = WHFOBO + WHFLDB -1 ; // END
IF T(X) = 'F' ; // FLOAT
I(X) = FFA1 + FFA2; // SCRN FIELD FORMAT ALPHA
L(X) = 14;
IF Q(X) = 8;
L(X) = 23;
ENDIF;
ELSE;
IF WHFLDD <> 0 ;
IF WHFLDP <> 0 ;
L(X) = WHFLDD + 2 ; // LENGTH
ELSE;
L(X) = WHFLDD + 1 ; // LENGTH
ENDIF;
I(X) = FFN1 + FFN2; // SCRN FIELD FORMAT NUMERIC
ELSE;
L(X) = WHFLDB ;
I(X) = FFA1 + FFA2; // SCRN FIELD FORMAT ALPHA
ENDIF;
ENDIF;
ENDDO;
// NUMBER OF FIELDS
NUMFLD = X ;
// MAKE ROOM FOR KEYS
IF NUMKEY > 0 ;
X1 = NUMKEY + NUMFLD;
FOR X = NUMFLD DOWNTO 1;
KY(X1) = KY(X) ;
L(X1) = L(X) ;
I(X1) = I(X) ;
N(X1) = N(X) ;
T(X1) = T(X) ;
V(X1) = V(X) ;
C(X1) = C(X) ;
P(X1) = P(X) ;
S(X1) = S(X) ;
E(X1) = E(X) ;
Q(X1) = Q(X) ;
X1 = X1 - 1;
ENDFOR;
// PUT KEY FIELDS AT TOP
OFF = 0;
FOR X = 1 TO NUMKEY;
X1 = %LOOKUP(KE(X) : N : NUMKEY+1);
KY(X) = '2';
L(X) = L(X1);
I(X) = I(X1); // FIELD FMT
SELECT; // INPUT ENABLE
WHEN I(X) = X6000;
I(X) = X4800;
WHEN I(X) = X6706;
I(X) = X4F06;
ENDSL;
N(X) = N(X1);
T(X) = T(X1);
V(X) = V(X1);
C(X) = C(X1);
P(X) = P(X1);
S(X) = S(X1);
E(X) = E(X1);
Q(X) = Q(X1);
R(X) = OFF;
OFF = OFF + Q(X1);
ENDFOR;
ENDIF;
// NUMBER OF FIELDS AND KEYS
NUMFKY = NUMFLD + NUMKEY;
ENDSR;
// @@@@@@@@@@@@@@@ GETADD @@@@@@@@@@@@@@@
// LOAD FIELD BUFFER ADDRESSES
BEGSR @GETADD;
MX = 0;
X = 0;
ROW = 3;
COL = 1;
FOR X = 1 TO NUMFKY;
// IF FINISHED WITH THE KEY FIELDS
// INC ROW FOR 1ST DATA FIELD
IF KEYSOK = ' ' ;
IF KY(X) = ' ' OR KY(X) = '1';
KEYSOK = '1' ;
ROW = ROW + 2;
COL = 1;
ENDIF;
ENDIF;
// SET THE BUFFER ADD ON THE LARGER OF THE FIELD TEXT OR THE FIELD SIZE
LENDSC = %LEN(%TRIM(N(X)));
LENWRK = L(X);
IF LENDSC > L(X);
LENWRK = LENDSC;
ENDIF;
LENWRK = LENWRK + 2;
// TRAP FIELDS THAT OVERFLOW
ROW = ROW + XROW;
XROW = %DIV(LENWRK : 80);
IF (COL + LENWRK) > 78;
EXSR @ROWINC;
IF MX = 3;
X= X-1;
NUMFKY = X;
LEAVE;
ENDIF;
COL = 1;
ENDIF;
// INC COL. FOR FIELD START
CLEAR B(X);
BIN = ROW;
B(X) = %TRIM(B(X)) + HX1;
BIN = COL + 1;
B(X) = %TRIM(B(X)) + HX1;
// INC COL. FOR NEXT FIELD
COL = COL + LENWRK;
IF COL > 78;
EXSR @ROWINC;
IF MX = 3; // NO ROOM FOR THE FIELD
X= X-1;
NUMFKY = X;
LEAVE;
ENDIF;
COL = 1;
ENDIF;
ENDFOR;
// FIELD LEVEL
LVX = LVL + 1;
LV(LVX) = N(X);
ENDSR;
// @@@@@@@@@@@@@@@ PUTHED @@@@@@@@@@@@@@@
// PUT FIELD HEADINGS
BEGSR @PUTHED;
NEWRU = '1';
RU = *ALLX'00';
CLEAR RU; // initialise Request Unit 255 bytes max
FOR XX = 1 TO NUMFKY; //NUMBER OF DATA ELEMENTS (FLD AND KEY)
IF NEWRU = '1';
NEWRU = '0';
RU = ESC + WTD + X20 + X00;
ENDIF;
RU = RU + SBA;
BIN = 0;
// CONVERT DATA BUFADR TO HEADING BUFADR
HX1 = %SUBST(B(XX) :1:1);
BIN = BIN - 1;
RU = RU + HX1;
IF REHEAD = '1'; // ON REDISPLAY OVERRIDE THE ATTR
BIN = 0;
HX1 = %SUBST(B(XX) :2:1);
BIN = BIN -1 ;
RU = RU + HX1;
ELSE;
RU = RU + %SUBST(B(XX) :2);
ENDIF;
RU = RU + ATC ;
// LONG NUMBER FIELDS ,RIGHT ADJUST THE FIELD HEADINGS
LENDSC = %LEN(%TRIM(N(XX)));
IF T(XX) <> 'A' AND LENDSC < (L(XX) -1);
FOR Y = 1 TO (L(XX) -(LENDSC +1));
RU = RU + ' ';
ENDFOR;
ENDIF;
RU = RU + %TRIM(N(XX));
IF %LEN(RU) >= 200;
BIN = %LEN(RU);
OUTLEN = HX2;
INLEN = X000;
FNC = SND;
A = RU;
EXCEPT DATAO;
NEWRU = '1';
RU = *ALLX'00';
CLEAR RU;
ENDIF;
ENDFOR;
IF %LEN(RU) > 5 AND %LEN(RU) < 200;
BIN = %LEN(RU);
OUTLEN = HX2;
INLEN = X000;
FNC = SND;
A = RU;
EXCEPT DATAO;
ENDIF;
IF REHEAD <> '1';
// FORMAT FIELDS
NEWRU = '1';
RU = *ALLX'00';
CLEAR RU; // initialise Request Unit 255 bytes max
FOR XX = 1 TO NUMFKY; //NUMBER OF DATA ELEMENTS (FLD AND KEY)
IF NEWRU = '1';
NEWRU = '0';
RU = ESC + WTD + X20 + X00;
ENDIF;
RU = RU + SBA +B(XX)+SF + I(XX);
IF KY(XX) = '1' OR KY(XX) = '2' OR KY(XX) = '3';
RU = RU + X25;
ELSE;
RU = RU + X26;
ENDIF;
BIN = L(XX);
RU = RU + HX2;
// LENGTH OF INPUT FIELDS
LENF = LENF + L(XX) + 3;
IF %LEN(RU) >= 200;
BIN = %LEN(RU);
OUTLEN = HX2;
INLEN = X000;
FNC = SND;
A = RU;
EXCEPT DATAO;
NEWRU = '1';
RU = *ALLX'00';
CLEAR RU;
ENDIF;
ENDFOR;
// PUT LAST R/U
IF %LEN(RU) > 5 AND %LEN(RU) < 200;
BIN = %LEN(RU);
OUTLEN = HX2;
INLEN = X000;
FNC = SND;
A = RU;
EXCEPT DATAO;
ENDIF;
//INC BUFFER ADDRESS FOR ALL FIELDS FOR DATA PUT
FOR XP = 1 TO NUMFKY; //NUMBER OF DATA ELEMENTS (FLD AND KEY)
HX2 = B(XP);
BIN = BIN + 1;
B(XP) = HX2;
ENDFOR;
ENDIF;
ENDSR;
// @@@@@@@ INIT @@@@@@@@@@@@@@@@@@@@@@@@@
BEGSR @INIT;
CLEAR KW;
// UPDATE
IF UPDF = 'Y';
FFA1 = X40;
FFN1 = X47;
ELSE;
FFA1 = X60;
FFN1 = X67;
ENDIF;
SELECT;
WHEN *INU1 = '1';
FILE = F1 ;
LIB = L1 ;
MBR = M1 ;
RCDL = R1 ;
ACCTP = A1 ;
WHEN *INU2 = '1';
FILE = F2 ;
LIB = L2 ;
MBR = M2 ;
RCDL = R2 ;
ACCTP = A2 ;
ENDSL;
RLEN = RCDL ;
RLENTH = %EDITC(RLEN: 'X') ;
LENF = 0 ;
// Control commands and data are constructed into RUs Request UNITS
// Each RU is 256 bytes max size.
// Construct and send as many RUs as needed to format the display.
RU = *ALLX'00';
CLEAR RU; // initialise Request Unit 255 bytes max
RU = CLRWTD ;
//set up the screen headings
BIN = 1; // set ROW to 1
RW = HX1;
BIN = 2; // set COL to 2
CL = HX1;
RU = RU + SBA + RW + CL + X22 + %TRIM(LIB) + '/' + %TRIM(FILE);
RU = RU + ' Mbr ' + %TRIM(MBR) + ' Rcdl ' + %EDITC(RLEN : 'Z') ;
RU = RU + ' RRN ' ;
BIN = %len(RU) -4;
RBA = RW + HX1 ; // address of the RRN field
RU = RU + SBA + RBA + ' ';
// FUNCTION KEYS
BIN = 23;
RW = HX1;
BIN = 02;
CL = HX1;
IF UPDF = 'Y'; // UPDATE IS ON
RU = RU + SBA + RW + CL + %TRIM(CNS(2));
ELSE;
RU = RU + SBA + RW + CL + %TRIM(CNS(1));
ENDIF;
// THIS IS A SEND ONLY FUNCTION
FNC = SND;
CLEAR A;
A = RU;
BIN2 = %LEN(RU);
OUTLEN = BY2;
INLEN = x000;
EXCEPT DATAO;
ENDSR;
// @@@@@@@ KEYIN @@@@@@@@@@@@@@@@@@@@@@@@@
BEGSR @KEYIN;
// ISSUE A READ FROM DISPLAY
FNC = SNR;
BIN2 = 8;
OUTLEN = BY2;
IPL = LENF + 34;
BIN2 = IPL;
INLEN = BY2;
// SET FRR INDICATORS TO CONTROL BUFFER OVERFLOW
FOR X = 1 TO 9;
IF IPL > ( X*80 +3);
*IN(X+19) = *ON;
ENDIF;
ENDFOR;
RU = *ALLX'00';
CLEAR RU;
RU = RDDSP;
A = RU;
EXCEPT DATAI;
ENDSR;
// @@@@@@@ ERROR @@@@@@@@@@@@@@@@@@@@@@@@@
BEGSR @ERROR;
// SETUP PUT ERROR MESSAGE X'21'
RU = *ALLX'00';
CLEAR RU;
FNC = SNR;
BIN = 42;
OUTLEN = HX2;
BIN = LENF + 34;
IPL = BIN;
INLEN = HX2;
FOR X = 1 TO 9;
IF IPL > (X * 80 +3) ;
*IN(X + 19) = *ON; // SETON FFR 20 - 29 FOR INPUT
ENDIF;
ENDFOR;
RU = ESC + WER + IC + B(1) + ATC + MSG(MX);
RU = RU + ESC + RDM + X40+ X00;
A = RU;
EXCEPT DATAI;
RU = *ALLX'00';
CLEAR RU;
ENDSR;
// @@@@@@@ HXDSP @@@@@@@@@@@@@@@@@@@@@@@@@
BEGSR @HXDSP;
RU = *ALLX'00';
CLEAR RU;
Y = %LOOKUPLE( CURLOC : B );
//
RU = ESC + WTD + X20 + X00 + SBA;
BIN = 0;
HX1 = %SUBST(B(Y) :1:1);
BIN = BIN - 1;
RU = RU + HX1;
RU = RU + %SUBST(B(Y) :2:1);
FOR X = S(Y) TO E(Y);
BIN = 0;
HX1 = D(X);
HX1 = %BITAND(HX1 : XF0);
Z = BIN / 16 + 1;
RU = RU + CRS(Z);
ENDFOR;
RU = RU + X20;
RU = RU + SBA + B(Y);
FOR X = S(Y) TO E(Y);
BIN = 0;
HX1 = D(X);
HX1 = %BITAND(HX1 : X0F);
Z = BIN + 1;
RU = RU + CRS(Z);
ENDFOR;
BIN = %LEN(RU);
OUTLEN = HX2;
INLEN = X000;
FNC = SND;
A = RU;
EXCEPT DATAO;
RU = *ALLX'00';
CLEAR RU;
EXSR @KEYIN;
READ DISPF;
// CLEAR HEADINGS
RU = *ALLX'00';
CLEAR RU;
RU = RU + ESC + WTD + X20 + X00 + SBA;
HX1 = %SUBST(B(Y) :1:1) ;
BIN = BIN - 1;
RU = RU + HX1 + %SUBST(B(Y):2:1);
FOR X = S(Y) TO E(Y);
RU = RU + ' ';
ENDFOR;
RU = RU + ' ';
BIN = %LEN(RU);
OUTLEN = HX2;
INLEN = X000;
FNC = SND;
A = RU;
EXCEPT DATAO;
RU = *ALLX'00';
CLEAR RU;
ENDSR;
// @@@@@@@ UPD @@@@@@@@@@@@@@@@@@@@@@@@@
BEGSR @UPD;
// CONVERT DATA FOR OUTPUT
// FOR EACH FIELD, CHECK IF FIELD WAS MODIFIED, AND IF SO MOVE
// THE MODIFIED DATA INTO THE OUTPUT ARRAY
K1 = 0;
K2 = 0;
W = 1;
CGKY = *BLANK; // KEY CHANGED
KW = KEYA;
FOR Y = 1 TO NUMFKY ;
IF KY(Y) > '1';
ITER;
ENDIF;
// MOVE A KEY FIELDS DATA FROM ID ARRAY (SCREEN) TO K ARRAY
// GET SIZE OF FIELD IN BYTES
IF T(Y) = 'A'; // ALPHA DATA
K = ' ';
K1 = 1;
K2 = Q(Y);
ELSE;
K = '0';
K1 = 1;
K2 = C(Y);
ENDIF;
X = 1;
DOW @LOOP = @LOOP;
// NXTSBA
X = %LOOKUP(SBA : ID : X );
IF X = 0;
LEAVE;
ENDIF;
// IS THIS THE FIELD? CHECK THE BUFFER ADDRESS
X = X +1;
IF B(Y) <> %SUBST(IDA : X :2);
ITER;
ENDIF;
// FOUND A MTD FOR THIS FIELD
// CHECK IF FIELD WAS CLEARED ONLY
DOW @LOOP = @LOOP; // not a loop
X = X + 2;
IF ID(X) = SBA;
LEAVE;
ENDIF;
// IF FIELD HAS DECIMALS BUMP X
IF (T(Y) = 'S' OR T(Y) = 'P' OR T(Y) = 'B') AND
P(Y) > 0;
X = X + 1;
ENDIF;
// CHECK IF ONLY BLANKS RETURNED
IF %SUBST(IDA : X :K2) = *BLANKS;
LEAVE;
ENDIF;
// MOVE DATA TO WORK ARRAY K
X1 = X;
FOR X2 = 1 TO K2;
IF ID(X1) < ' ';
LEAVE;
ENDIF;
K(X2) = ID(X1);
X1 = X1 + 1;
ENDFOR;
LEAVE;
ENDDO;
// * SET START POSN
W = S(Y);
// ALPHA
IF T(Y) = 'A' and V(XX) <> 'Y';
FOR Z = K1 to K2;
D(W) = K(Z);
W = W + 1;
ENDFOR;
ENDIF;
IF T(Y) = 'A' and V(XX) = 'Y'; //VARYING
// the data start is in S(Y)
// the data is in array K
// get the length of the data cvt to bin and stik in pos 1 2
// put the rest in pos 3 onwards
ENDIF;
// NUMERIC FIELD
// RIGHT ADJUST NUMERIC DATA ,STRIP - . ,CONVERT BLANKS
IF (T(Y) = 'S' OR T(Y) = 'P' OR T(Y) = 'B');
NU = '0';
Z1 = 60;
FOR Z = K2 DOWNTO K1;
IF K(Z) = '.' OR K(Z) = '-' OR K(Z) = '$';
ITER;
ENDIF;
IF K(Z) = ' ' ;
NU(Z1) = '0';
ELSE;
NU(Z1) = K(Z);
ENDIF;
Z1 = Z1 -1;
ENDFOR;
ENDIF;
// SIGNED FIELDS (END POSN = OFFSET + SIZE)
IF T(Y) = 'S';
NUSA= *BLANKS;
FOR VX = 1 TO 60;
NUSA = %TRIM(NUSA) + NU(VX);
ENDFOR;
%SUBST(DATA : W : Q(Y)) = %SUBST(NUSA: 61 -Q(Y));
ENDIF;
// PACKED FIELDS
IF T(Y) = 'P';
NUSA= *BLANKS;
FOR VX = 1 TO 60;
NUSA = %TRIM(NUSA) + NU(VX);
ENDFOR;
NUP = %DEC(NUSA : 60 : 0);
%SUBST(DATA : W : Q(Y)) = %SUBST(NUPA: 61 -Q(Y));
ENDIF;
// BINARY FIELDS
IF T(Y) = 'B';
IF Q(Y) = 2 ;
BY2 = NU(1) + NU(2);
%SUBST(DATA : W : 2) = BY2;
ENDIF;
IF Q(Y) = 4 ;
BY4 = NU(1) + NU(2) + NU(3) + NU(4);
%SUBST(DATA : W : 4) = BY4;
ENDIF;
ENDIF;
// UPDATE KEY IF NECESSARY
IF KY(Y) = '1';
CGKY = '1';
EXSR @PCKMOV;
ENDIF;
ENDDO;
ENDFOR;
IF CGKY = '1';
KEYA = KW;
ENDIF;
ENDSR;
/END-FREE
OINPUTK E U1 UPDATREC
O DA
O 30 DB
O 31 DC
O 32 DD
O 33 DE
O 34 DF
O 35 DG
O 36 DH
O 37 DI
O 38 DJ
O 39 DK
O 40 DL
O 41 DM
O 42 DN
O 43 DZ
O 44 DO
O 45 DP
O 46 DQ
O 47 DR
O 48 DS
O 49 DT
O 50 DU
O 51 DV
O 52 DW
O 53 DX
O 54 DY
O 55 D0
O 56 D1
O 57 D2
O 58 D3
O 59 D4
O 60 D5
O 61 D6
O 62 DBA
O 63 DCA
O 64 DDA
O 65 DEA
O 66 DFA
O 67 DGA
O 68 DHA
O 69 DIA
O 70 DJA
O 71 DKA
O 72 DLA
O 73 DMA
O 74 DNA
O 75 DOA
O 76 DPA
O 77 DQA
O 78 DRA
O 79 DSA
O 80 DTA
O 81 DUA
O 82 DVA
O 83 DWA
O 84 DXA
O 85 DYA
O 86 DZA
O 87 D0A
O 88 D1A
O 89 D2A
O 90 D3A
O 91 D4A
O 92 D5A
O 93 D6A
OINPUTR E U2 UPDATREC
O DA
O 30 DB
O 31 DC
O 32 DD
O 33 DE
O 34 DF
O 35 DG
O 36 DH
O 37 DI
O 38 DJ
O 39 DK
O 40 DL
O 41 DM
O 42 DN
O 43 DZ
O 44 DO
O 45 DP
O 46 DQ
O 47 DR
O 48 DS
O 49 DT
O 50 DU
O 51 DV
O 52 DW
O 53 DX
O 54 DY
O 55 D0
O 56 D1
O 57 D2
O 58 D3
O 59 D4
O 60 D5
O 61 D6
O 62 DBA
O 63 DCA
O 64 DDA
O 65 DEA
O 66 DFA
O 67 DGA
O 68 DHA
O 69 DIA
O 70 DJA
O 71 DKA
O 72 DLA
O 73 DMA
O 74 DNA
O 75 DOA
O 76 DPA
O 77 DQA
O 78 DRA
O 79 DSA
O 80 DTA
O 81 DUA
O 82 DVA
O 83 DWA
O 84 DXA
O 85 DYA
O 86 DZA
O 87 D0A
O 88 D1A
O 89 D2A
O 90 D3A
O 91 D4A
O 92 D5A
O 93 D6A
OINPUTK EADD U1 ADDREC
O DA
O 30 DB
O 31 DC
O 32 DD
O 33 DE
O 34 DF
O 35 DG
O 36 DH
O 37 DI
O 38 DJ
O 39 DK
O 40 DL
O 41 DM
O 42 DN
O 43 DZ
O 44 DO
O 45 DP
O 46 DQ
O 47 DR
O 48 DS
O 49 DT
O 50 DU
O 51 DV
O 52 DW
O 53 DX
O 54 DY
O 55 D0
O 56 D1
O 57 D2
O 58 D3
O 59 D4
O 60 D5
O 61 D6
O 62 DBA
O 63 DCA
O 64 DDA
O 65 DEA
O 66 DFA
O 67 DGA
O 68 DHA
O 69 DIA
O 70 DJA
O 71 DKA
O 72 DLA
O 73 DMA
O 74 DNA
O 75 DOA
O 76 DPA
O 77 DQA
O 78 DRA
O 79 DSA
O 80 DTA
O 81 DUA
O 82 DVA
O 83 DWA
O 84 DXA
O 85 DYA
O 86 DZA
O 87 D0A
O 88 D1A
O 89 D2A
O 90 D3A
O 91 D4A
O 92 D5A
O 93 D6A
OINPUTR EADD U2 ADDREC
O DA
O 30 DB
O 31 DC
O 32 DD
O 33 DE
O 34 DF
O 35 DG
O 36 DH
O 37 DI
O 38 DJ
O 39 DK
O 40 DL
O 41 DM
O 42 DN
O 43 DZ
O 44 DO
O 45 DP
O 46 DQ
O 47 DR
O 48 DS
O 49 DT
O 50 DU
O 51 DV
O 52 DW
O 53 DX
O 54 DY
O 55 D0
O 56 D1
O 57 D2
O 58 D3
O 59 D4
O 60 D5
O 61 D6
O 62 DBA
O 63 DCA
O 64 DDA
O 65 DEA
O 66 DFA
O 67 DGA
O 68 DHA
O 69 DIA
O 70 DJA
O 71 DKA
O 72 DLA
O 73 DMA
O 74 DNA
O 75 DOA
O 76 DPA
O 77 DQA
O 78 DRA
O 79 DSA
O 80 DTA
O 81 DUA
O 82 DVA
O 83 DWA
O 84 DXA
O 85 DYA
O 86 DZA
O 87 D0A
O 88 D1A
O 89 D2A
O 90 D3A
O 91 D4A
O 92 D5A
O 93 D6A
OINPUTK EDEL U1 DELREC
OINPUTR EDEL U2 DELREC
ODISPF E DATAO
O K3 'PUT'
O OUTLEN 2
O INLEN
O FNC
O A
O E DATAI
O K3 'GET'
O OUTLEN 2
O INLEN
O FNC
O A
**
0000 INVALID COMMAND KEY
0001 - A FIELD IS TOO LONG
0002 - TOO MANY FIELDS
0003 - ALPHAS IN PACKED KEY
0004 - MISSING ' IN PACKED KEY
0005 - MISSING DATA IN PCKD KEY
0006 - RECORD NOT FOUND
PRESS RESET TO CONTINUE
**
F1-HEX F2-Return F3-Exit F19-Prev_fld F20-More_fld
F1-HEX F2-Return F3-Exit F6-Update F9-Add F11-Del F19-Prev_fld F20-More_fld
**
0123456789ABCDEF
DUSP2 RPG
H*eywords++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++Comments+++++++++++
H OPTION(*NODEBUGIO)
H DFTACTGRP(*NO) ACTGRP(*CALLER) DFTNAME(DISP )
F*
F* LIMITED TO MAXIMUM FILE LENGTH OF 6080
F* REQUIRES FILE QTEMP/FFD TO COMPILE
F* use cmd DSPFFD FILE(&LIB/&FILE) OUTPUT(*OUTFILE) OUTFILE(QTEMP/FFD)
FFFD IF E DISK
FDISPF CF F 803 WORKSTN
F*
F INFDS(INFDS)
FINPUTK UF A F32766 800AIDISK KEYLOC(1)
F EXTIND(*INU1)
F INFDS(INFDK)
FINPUTR UF A F32766 DISK EXTIND(*INU2)
F INFDS(INFDR)
*
D A S 255 WORK RU
D RU S 255 varying
D RW S 1 ROW 1 byte binary
D CL S 1 COL 1 byte binary
D FNC S 1
D OUTLEN S 2
D INLEN S 2
D IPL S 5 0
D ROW S 3 0
D XROW S 3 0
D COL S 3 0
D KEYSOK S 1
D LENDSC S 3 0
D LENWRK S 5 0
D STRX S 5 0
D ENDX S 5 0
D VX S 5 0
D X S 5 0
D X1 S 5 0
D X2 S 5 0
D XX S 5 0
D XP S 5 0
D MX S 5 0
D ONCE S 1
D RBA S 2
D LF S 5 0
D ST S 5 0
D Y S 5 0
D Z S 5 0
D OFF S 5 0
D CGKY S 1
D UPDDONE S 1
D SUPZ S 1
D NUMFLD S 5 0
D WX S 5 0
D NUMKEY S 5 0
D NUMFKY S 5 0
D SCRST S 10
D SCRSTN S 1
D KEYA S 800
D RRNA S 11 0
D RRN S 11 0
D REHEAD S 1
D NEWRU S 1
D WRTRRN S 1
D LVX S 5 0
D LVL S 5 0
D K1 S 5 0
D K2 S 5 0
D Z1 S 5 0
D W S 5 0
D WK2 S 2
D MSSG S 32
*
D BASE S 5 0
D INZ S 1
D FILE S 10
D LIB S 10
D MBR S 10
D RCDL S 5 0
D ACCTP S 1
D RLEN S 5 0
D RLENTH S 5
D LENF S 5 0
D DS
D TEXT500 500
D LVW 10 DIM(50) overlay(TEXT500:1)
D TEXT800 S 800
D KW S 800
D DS
D WRK11 1 11
D NUM11 1 11S 0
D DS
D NUSA 1 60
D NUS 1 60S 0
D DS
D NUPA 1 60
D NUP 29 60P 0
D WRU S 61
D WRX S 64
D WRXWRD C '0 -
D -'
D WRSWRD C '0 -
D -'
D WRV S 60 varying
D FLT14 S 14
D FLT23 S 23
* SET FILE SIZE INCREMENTS (64 OF THEM)
D SZ S 5 0 DIM(64)
D S S 5 0 DIM(9000) START OF FLD
D E S 5 0 DIM(9000) END OF FLD
D Q S 5 0 DIM(9000) BYTES IN FIELD
D L S 5 0 DIM(9000) LENGTH OF FLD
D C S 3 0 DIM(9000) DEC DIGITS
D P S 3 0 DIM(9000) DEC PRECISION
D B S 2 DIM(9000) ASCEND BUFFER ADD
D I S 2 DIM(9000) FLD FMT
D N S 10 DIM(9000) FLD NAME
D T S 1 DIM(9000) FLD TYPE
D V S 1 DIM(9000) VARYING
D KY S 1 DIM(9000) KEYED
D KE S 10 DIM(128) KEY FLDS
D R S 3 0 DIM(9000) KEY FLD START
D K S 1 DIM(800) KEY
D NA S 1 DIM(10) NAME WORK
D NU S 1 DIM(60) NUM. WORK
D LV S 10 DIM(50) SCREEN LEVELS
D MSG S 32 DIM(8) CTDATA PERRCD(1) MESSAGES
D CNS S 79 DIM(2) CTDATA PERRCD(1)
D CRS S 1 DIM(16) CTDATA PERRCD(16)
D DS
D D 1 6080
D DIM(6080) INCOMING DATA
D DA 1 4048
D DIM(4048)
D DB 4049 4064
D DC 4065 4096
D DD 4097 4128
D DE 4129 4160
D DF 4161 4192
D DG 4193 4224
D DH 4225 4256
D DI 4257 4288
D DJ 4289 4320
D DK 4321 4352
D DL 4353 4384
D DM 4385 4416
D DN 4417 4448
D DZ 4449 4480
D DO 4481 4512
D DP 4513 4544
D DQ 4545 4576
D DR 4577 4608
D DS 4609 4640
D DT 4641 4672
D DU 4673 4704
D DV 4705 4736
D DW 4737 4768
D DX 4769 4800
D DY 4801 4832
D D0 4833 4864
D D1 4865 4896
D D2 4897 4928
D D3 4929 4960
D D4 4961 4992
D D5 4993 5024
D D6 5025 5056
D DBA 5057 5088
D DCA 5089 5120
D DDA 5121 5152
D DEA 5153 5184
D DFA 5185 5216
D DGA 5217 5248
D DHA 5249 5280
D DIA 5281 5312
D DJA 5313 5344
D DKA 5345 5376
D DLA 5377 5408
D DMA 5409 5440
D DNA 5441 5472
D DOA 5473 5504
D DPA 5505 5536
D DQA 5537 5568
D DRA 5569 5600
D DSA 5601 5632
D DTA 5633 5664
D DUA 5665 5696
D DVA 5697 5728
D DWA 5729 5760
D DXA 5761 5792
D DYA 5793 5824
D DZA 5825 5856
D D0A 5857 5888
D D1A 5889 5920
D D2A 5921 5952
D D3A 5953 5984
D D4A 5985 6016
D D5A 6017 6048
D D6A 6049 6080
D DS
D ID 1 800
D DIM(800) INCOMING DATA
D IDA 1 800
D ID0 1 80
D ID1 81 160
D ID2 161 240
D ID3 241 320
D ID4 321 400
D ID5 401 480
D ID6 481 560
D ID7 561 640
D ID8 641 720
D ID9 721 800
D DS
D BIN 1 2B 0
D HX1 2 2
D HX2 1 2
D DS
D PCK 1 1P 0
D PCK1 1 1
D DS
D SGN 1 1S 0
D SGN1 1 1
D DS
D BIN4 1 4B 0
D BY4 1 4
D DS
D BIN2 1 2B 0
D BY2 1 2
D DS
D FLT4 1 4F
D FL4 1 4
D DS
D FLT8 1 8F
D FL8 1 8
D INFDK DS
D F1 83 92
D L1 93 102
D M1 129 138
D R1 125 126B 0
D A1 160 160
D LOP1 260 260
D KEY_LEN 393 394I 0 Key length
D RN1 397 400B 0
D LKY 401 1200
D INFDR DS
D F2 83 92
D L2 93 102
D M2 129 138
D R2 125 126B 0
D A2 160 160
D LOP2 260 260
D RN2 397 400B 0
D*
D INFDS DS
D CURLOC 370 371
D DS
D KEYLN 1 4S 0
D KEYLNA 1 4
DDUSP PR
D 1
D 1
D 4
D 1
D 500
D 5
D 800
DDUSP PI
D ALL 1
D RTN 1
D KEYLNG 4
D UPDF 1
D SCNLV 500
D SCNLVL 5
D SCNKEY 800
D @LOOP C '1'
D @FALSE C '0'
D @TRUE C '1'
D SND C X'71' SEND TO DISP
D SNR C X'73' SND/RCV
D RED C X'42' READ
D RDM C X'52' READ MTD
D ESC C X'04' ESCAPE
D CLR C X'40' CLEAR UNIT
D CC1 C X'00' CNTRL CHAR
D CC2 C X'08' CNTRL CHAR
D SBA C X'11' SET BUFF ADR
D IC C X'13' INSERT CURS
D WTD C X'11' WRITE TO DSP
D WER C X'21' WRITE ERROR
D SF C X'1D' START FLD
D ATC C X'20' ATTR CHAR
D ATN C X'24' ATTR NUM
D X00 C X'00'
D X01 C X'01'
D X02 C X'02'
D X03 C X'03'
D X0D C X'0D'
D X0F C X'0F'
D X000 C X'0000'
D X1F C X'1F'
D X20 C X'20' SCRN ATT NORMAL
D X22 C X'22' SCRN ATTR HI
D X25 C X'25'
D X26 C X'26'
D X31 C X'31' CMD 1 KEY
D X32 C X'32' CMD 2 KEY
D X33 C X'33' CMD 3 KEY
D X36 C X'36' CMD 6 KEY
D X37 C X'37' CMD 7 KEY
D X38 C X'38' CMD 8 KEY
D X39 C X'39' CMD 9 KEY
D X3B C X'3B' CMD11 KEY
D XB7 C X'B7' CMD19 KEY
D XB8 C X'B8' CMD20 KEY
D X40 C X'40'
D X43 C X'43'
D X47 C X'47'
D X60 C X'60'
D X67 C X'67'
D X9F C X'9F'
D XF0 C X'F0'
D XD0 C X'D0'
D X4000 C X'4000'
D X4800 C X'4800' FF ALPHA
D X4F06 C X'4F06' FF NUMERIC
D X6000 C X'6000' FF ALPHA
D X6706 C X'6706' FF NUMERIC
D CLRWTD C X'044004112000' INCLUDES ESC CHARS
D RDDSP C X'0411200804524000' READ FROM DISPLAY
D FFA1 S 1 INZ(X'40') F.FMT 1 ALPH 60 BYP
D FFA2 S 1 INZ(X'00') F.FMT 2 ALPH
D FFN1 S 1 INZ(X'47') F.FMT 1 NUM 67 BYP
D FFN2 S 1 INZ(X'06') F.FMT 2 NUM
I*.
0038 IINPUTK NS 01
0039 I 1 4048 DA
0040 I 4049 4064 DB 30
0041 I 4065 4096 DC 31
0042 I 4097 4128 DD 32
0043 I 4129 4160 DE 33
0044 I 4161 4192 DF 34
0045 I 4193 4224 DG 35
0046 I 4225 4256 DH 36
0047 I 4257 4288 DI 37
0048 I 4289 4320 DJ 38
0049 I 4321 4352 DK 39
0050 I 4353 4384 DL 40
0051 I 4385 4416 DM 41
0052 I 4417 4448 DN 42
0053 I 4449 4480 DZ 43
0054 I 4481 4512 DO 44
0055 I 4513 4544 DP 45
0056 I 4545 4576 DQ 46
0057 I 4577 4608 DR 47
0058 I 4609 4640 DS 48
0059 I 4641 4672 DT 49
0060 I 4673 4704 DU 50
0061 I 4705 4736 DV 51
0062 I 4737 4768 DW 52
0063 I 4769 4800 DX 53
0064 I 4801 4832 DY 54
0065 I 4833 4864 D0 55
0066 I 4865 4896 D1 56
0067 I 4897 4928 D2 57
0068 I 4929 4960 D3 58
0069 I 4961 4992 D4 59
0070 I 4993 5024 D5 60
0071 I 5025 5056 D6 61
0072 I 5057 5088 DBA 62
0073 I 5089 5120 DCA 63
0074 I 5121 5152 DDA 64
0075 I 5153 5184 DEA 65
0076 I 5185 5216 DFA 66
0077 I 5217 5248 DGA 67
0078 I 5249 5280 DHA 68
0079 I 5281 5312 DIA 69
0080 I 5313 5344 DJA 70
0081 I 5345 5376 DKA 71
0082 I 5377 5408 DLA 72
0083 I 5409 5440 DMA 73
0084 I 5441 5472 DNA 74
0085 I 5473 5504 DOA 75
0086 I 5505 5536 DPA 76
0087 I 5537 5568 DQA 77
0088 I 5569 5600 DRA 78
0089 I 5601 5632 DSA 79
0090 I 5633 5664 DTA 80
0091 I 5665 5696 DUA 81
0092 I 5697 5728 DVA 82
0093 I 5729 5760 DWA 83
0094 I 5761 5792 DXA 84
0095 I 5793 5824 DYA 85
0096 I 5825 5856 DZA 86
0097 I 5857 5888 D0A 87
0098 I 5889 5920 D1A 88
0099 I 5921 5952 D2A 89
0100 I 5953 5984 D3A 90
0101 I 5985 6016 D4A 91
0102 I 6017 6048 D5A 92
0103 I 6049 6080 D6A 93
0104 IINPUTR NS 01
0105 I 1 4048 DA
0106 I 4049 4064 DB 30
0107 I 4065 4096 DC 31
0108 I 4097 4128 DD 32
0109 I 4129 4160 DE 33
0110 I 4161 4192 DF 34
0111 I 4193 4224 DG 35
0112 I 4225 4256 DH 36
0113 I 4257 4288 DI 37
0114 I 4289 4320 DJ 38
0115 I 4321 4352 DK 39
0116 I 4353 4384 DL 40
0117 I 4385 4416 DM 41
0118 I 4417 4448 DN 42
0119 I 4449 4480 DZ 43
0120 I 4481 4512 DO 44
0121 I 4513 4544 DP 45
0122 I 4545 4576 DQ 46
0123 I 4577 4608 DR 47
0124 I 4609 4640 DS 48
0125 I 4641 4672 DT 49
0126 I 4673 4704 DU 50
0127 I 4705 4736 DV 51
0128 I 4737 4768 DW 52
0129 I 4769 4800 DX 53
0130 I 4801 4832 DY 54
0131 I 4833 4864 D0 55
0132 I 4865 4896 D1 56
0133 I 4897 4928 D2 57
0134 I 4929 4960 D3 58
0135 I 4961 4992 D4 59
0136 I 4993 5024 D5 60
0137 I 5025 5056 D6 61
0138 I 5057 5088 DBA 62
0139 I 5089 5120 DCA 63
0140 I 5121 5152 DDA 64
0141 I 5153 5184 DEA 65
0142 I 5185 5216 DFA 66
0143 I 5217 5248 DGA 67
0144 I 5249 5280 DHA 68
0145 I 5281 5312 DIA 69
0146 I 5313 5344 DJA 70
0147 I 5345 5376 DKA 71
0148 I 5377 5408 DLA 72
0149 I 5409 5440 DMA 73
0150 I 5441 5472 DNA 74
0151 I 5473 5504 DOA 75
0152 I 5505 5536 DPA 76
0153 I 5537 5568 DQA 77
0154 I 5569 5600 DRA 78
0155 I 5601 5632 DSA 79
0156 I 5633 5664 DTA 80
0157 I 5665 5696 DUA 81
0158 I 5697 5728 DVA 82
0159 I 5729 5760 DWA 83
0160 I 5761 5792 DXA 84
0161 I 5793 5824 DYA 85
0162 I 5825 5856 DZA 86
0163 I 5857 5888 D0A 87
0164 I 5889 5920 D1A 88
0165 I 5921 5952 D2A 89
0166 I 5953 5984 D3A 90
0167 I 5985 6016 D4A 91
0168 I 6017 6048 D5A 92
0169 I 6049 6080 D6A 93
IDISPF NS 02
I 3 3 AID
I 4 83 ID0
I 84 163 ID1 20
I 164 243 ID2 21
I 244 323 ID3 22
I 324 403 ID4 23
I 404 483 ID5 24
I 484 563 ID6 25
I 564 643 ID7 26
I 644 723 ID8 27
I 724 803 ID9 28
/FREE
BASE = 4048;
IF ONCE = ' ';
EXSR @INITZ ;
ENDIF;
// START TAG
DOW @LOOP = @LOOP;
IF RTN = '3';
IF *INU1;
KEYA = SCNKEY;
ENDIF;
IF *INU2;
RRNA = %DEC(%SUBST(SCNKEY:1:11):11:0);
ENDIF;
RTN = '0';
AID = '1';
ELSE;
RTN = '0';
READ(E) DISPF;
ENDIF;
// CF3 EXIT
IF AID = X33;
LEAVE;
ENDIF;
// CF2 RETURN
IF AID = X32;
RTN = '1';
LEAVE;
ENDIF;
// CF1 HEX A FIELD
IF AID = X31;
Y = %LOOKUPLE( CURLOC : B );
IF Y > 0;
IF KY(Y) <= '1';
EXSR @HXDSP;
REHEAD = '1';
EXSR @PUTHED;
REHEAD = ' ';
ENDIF;
ENDIF;
ENDIF;
// CF20 MORE FIELDS
IF AID = XB8;
LVX = LVL + 1;
IF LV(LVX) <> *BLANK;
LVL = LVL +1 ;
LVW = LV;
SCNLV = TEXT500;
SCNLVL = %EDITC(LVL :'X');
SCNKEY = *BLANKS;
IF *INU1;
SCNKEY = KEYA;
ENDIF;
IF *INU2;
SCNKEY = %EDITC(RRNA:'X');
ENDIF;
RTN = '3';
LEAVE;
ENDIF;
ENDIF;
// CF19 PREVIOUS FIELDS
IF AID = XB7;
LVX = LVL - 1;
IF LVX >= 0 ;
LVL = LVL - 1 ;
LVW = LV;
SCNLV = TEXT500;
SCNLVL = %EDITC(LVL :'X');
SCNKEY = *BLANKS;
IF *INU1;
SCNKEY = KEYA;
ENDIF;
IF *INU2;
SCNKEY = %EDITC(RRNA:'X');
ENDIF;
RTN = '3';
LEAVE;
ENDIF;
ENDIF;
// 1 ENTER 4 ROLL DN 5 ROLL UP
// F6 = X36 F9 = X39 F11 = X3B
IF AID = '1'or AID = '4' or AID = '5' or
AID = X36 or AID = X39 or AID = X3B;
ELSE;
MX = 1; // INVALID KEY
EXSR @ERROR;
ENDIF;
// UPDATE MODE
IF UPDF = 'Y';
UPDDONE = @FALSE;
// F6
IF *INU1 AND AID = X36 AND
(LOP1 = X01 OR LOP1 = X03);
EXSR @UPD;
EXCEPT UPDATREC;
UPDDONE = @TRUE;
ENDIF;
IF *INU2 AND AID = X36 AND
(LOP2 = X01 OR LOP2 = X02);
EXSR @UPD;
EXCEPT UPDATREC;
UPDDONE = @TRUE;
ENDIF;
// F9
IF AID = X39;
EXSR @UPD;
EXCEPT ADDREC;
UPDDONE = @TRUE;
ENDIF;
// F11
IF *INU1 AND AID = X3B AND
(LOP1 = X01 OR LOP1 = X03);
EXCEPT DELREC;
UPDDONE = @TRUE;
ENDIF;
IF *INU2 AND AID = X3B AND
(LOP2 = X01 OR LOP2 = X02);
EXCEPT DELREC;
UPDDONE = @TRUE;
ENDIF;
ENDIF;
IF RTN = '3' OR UPDDONE = @TRUE;
ELSE;
EXSR @PCKD;
ENDIF;
// CONT1 GET A RECORD, KEY FROM DATA
EXSR @SETIN;
EXSR @GETF ;
EXSR @PUTF ;
EXSR @KEYIN;
ENDDO ;
*INLR = *ON;
// @@@@@@@ @INITZ @@@@@@@@@@@@@@@@@@@@@@@@@@
BEGSR @INITZ;
ONCE = '1';
KEYLNA = KEYLNG ;
EXSR @INIT ;
EXSR @GETFLD ;
EXSR @GETADD ;
EXSR @PUTHED ;
EXSR @KEYIN ;
INZ = '1';
EXSR @PCKD ;
INZ = ' ';
ENDSR;
// @@@@@@@ @PCKD @@@@@@@@@@@@@@@@@@@@@@@@@@
BEGSR @PCKD ;
// CONVERT KEY DATA
IF *INU1 ;
EXSR @CVTKEY;
ENDIF;
IF *INU2 ;
EXSR @CVTRRN;
ENDIF;
ENDSR;
// @@@@@@@ @CVTKEY @@@@@@@@@@@@@@@@@@@@@@@@
BEGSR @CVTKEY;
// EXTRACT THE KEY FIELD DATA FROM THE INCOMING STRING
// FOR EACH KEY FIELD, CHECK IF FIELD WAS MODIFIED, AND IF SO MOVE
// THE MODIFIED DATA INTO THE COMPOSITE KEY
K1 = 0;
K2 = 0;
W = 1;
FOR Y = 1 TO NUMKEY ;
// MOVE A KEY FIELDS DATA FROM ID ARRAY (SCREEN) TO K ARRAY (KEY FIELDS)
// GET SIZE OF FIELD IN BYTES
IF T(Y) = 'A'; // ALPHA DATA
K = ' ';
K1 = 1;
K2 = Q(Y);
ELSE;
K = '0';
K1 = 1;
K2 = C(Y);
ENDIF;
// IF WHOLE KEY INIT WAS REQUESTED BYPASS THE EXTRACT
IF INZ = '1' ;
KW = *BLANK;
EXSR @PCKMOV;
ITER;
ENDIF;
X = 1;
DOW @LOOP = @LOOP;
// NXTSBA
X = %LOOKUP(SBA : ID : X );
IF X = 0;
LEAVE;
ENDIF;
// IS THIS THE FIELD? CHECK THE BUFFER ADDRESS
X = X +1;
IF B(Y) <> %SUBST(IDA : X :2);
ITER;
ENDIF;
// FOUND A MTD FOR THIS FIELD
X = X + 2;
// CHECK IF FIELD WAS CLEARED ONLY
IF ID(X) = SBA;
EXSR @PCKMOV;
LEAVE ;
ENDIF;
// IF FIELD HAS DECIMALS BUMP X
IF (T(Y) = 'S' OR T(Y) = 'P' OR T(Y) = 'B') AND
P(Y) > 0;
X = X + 1;
ENDIF;
// CHECK IF ONLY BLANKS RETURNED
IF %SUBST(IDA : X :K2) = *BLANKS;
EXSR @PCKMOV;
LEAVE;
ENDIF;
// EXTRACT THE DATA FROM THE INCOMING STRING
X1 = X;
FOR X2 = 1 TO K2 ;
IF ID(X1) < ' ';
// TRAP NULLS CAUSED BY FLD EXIT
EXSR @PCKMOV;
LEAVE;
ENDIF;
K(X2) = ID(X1);
X1 = X1 +1;
ENDFOR;
// CONSTRUCT THE ACTUAL KEY WITH PACKED DATA IF REQUIRED
// INTO ARRAY KW
EXSR @PCKMOV;
LEAVE;
ENDDO;
ENDFOR;
//
KEYA = KW;
CLEAR KW;
ENDSR ;
// @@@@@@@ @CVTRRN @@@@@@@@@@@@@@@@@@@@@@@@
BEGSR @CVTRRN;
// RRN
NUM11 = 0;
DOW @LOOP = @LOOP; // NOT REALLY A LOOP(SIMULATES GOTO)
// GET THE FIRST SBA
X = 1;
X = %LOOKUP(SBA : ID : X );
IF X = 0;
LEAVE;
ENDIF;
// CHECK THE BUFFER ADDRESS MATCHES THE EXPECTED FIELD
X = X +1;
IF B(1) <> %SUBST(IDA : X :2);
ITER;
ENDIF;
// FOUND A MTD FOR RRN FIELD
X = X +2;
//CHECK IF FIELD WAS CLEARED ONLY
IF ID(X) = SBA;
LEAVE;
ENDIF;
// CHECK IF ONLY BLANKS RETURNED
IF %SUBST(IDA : X :11) = *BLANKS;
LEAVE;
ENDIF;
// WRK11 OVERLAYS NUM11
WRK11 = %SUBST(IDA : X :11);
LEAVE;
ENDDO;
RRNA = NUM11;
IF RRNA < 0;
RRNA = 1;
ENDIF;
ENDSR;
// @@@@@@@ @PCKMOV @@@@@@@@@@@@@@@@@@@@@@@@
BEGSR @PCKMOV;
//
// CONVERT KEY DATA
// SET START POSN IN KEY USING OFFSET IN R
X1 = %LOOKUP(N(Y) : N );
W = R(X1) + 1;
// ALPHA
IF T(Y) = 'A';
X1 = 1;
FOR Z = W TO W + Q(Y);
%SUBST(KW : Z : 1) = K(X1);
X1 = X1 + 1;
ENDFOR;
ENDIF;
// NUMERIC FIELD
// RIGHT ADJUST NUMERIC DATA ,STRIP - . ,CONVERT BLANKS
IF (T(Y) = 'S' OR T(Y) = 'P' OR T(Y) = 'B');
NU = '0';
Z1 = 60;
FOR Z = K2 DOWNTO K1;
IF K(Z) = '.' OR K(Z) = '-' OR K(Z) = '$';
ITER;
ENDIF;
IF K(Z) = ' ' ;
NU(Z1) = '0';
ELSE;
NU(Z1) = K(Z);
ENDIF;
Z1 = Z1 -1;
ENDFOR;
ENDIF;
// SIGNED FIELDS (END POSN = OFFSET + SIZE)
IF T(Y) = 'S';
NUS = 0;
FOR VX = 1 TO 60;
NUSA = %TRIM(NUSA) + NU(VX);
ENDFOR;
%SUBST(KW : W : Q(Y)) = %SUBST(NUSA: 61 -Q(Y));
ENDIF;
// PACKED FIELDS
IF T(Y) = 'P';
NUSA= *BLANKS;
FOR VX = 1 TO 60;
NUSA = %TRIM(NUSA) + NU(VX);
ENDFOR;
NUP = %DEC(NUSA : 60 : 0);
%SUBST(KW : W : Q(Y)) = %SUBST(NUPA: 61 -Q(Y));
ENDIF;
// BINARY FIELDS
IF T(Y) = 'B';
IF Q(Y) = 2 ;
BY2 = NU(1) + NU(2);
%SUBST(KW : W : 2) = BY2;
ENDIF;
IF Q(Y) = 4 ;
BY4 = NU(1) + NU(2) + NU(3) + NU(4);
%SUBST(KW : W : 4) = BY4;
ENDIF;
ENDIF;
ENDSR;
// @@@@@@@ SETIN @@@@@@@@@@@@@@@@@@@@@@@@@
BEGSR @SETIN;
// SET the FFR indicators to get the Input buffer somewhat aligned with the
// actual data. RPG is somewhat tolerant to a difference between the Ispecs
// and the actual file size but it can fail on big differences.
// INCREMENT OF 32 BYTES
SZ(1) = BASE + 16;
SZ(2) = SZ(1) + 16;
*IN30 = *ON;
IF (RLEN > SZ(2)) ;
*IN31 = *ON;
ENDIF;
FOR X = 3 TO 64;
SZ(X) = SZ(X-1) + 32;
IF (RLEN > SZ(X)) ;
*IN(29+X) = *ON;
ENDIF;
ENDFOR;
ENDSR;
//@@@@@@@@@@@@@@@@@ @GETF @@@@@@@@@@@@@@@@@
BEGSR @GETF;
// GET A DATA RECORD
IF (*INU1);
IF AID = '1' OR AID = X36 OR
AID = X39 OR AID = X3B ;
SETLL(E) KEYA INPUTK;
READ(E) INPUTK;
IF %EOF;
SETLL(E) KEYA INPUTK;
READP(E) INPUTK;
ENDIF;
ENDIF;
IF AID = '4';
READP(E) INPUTK;
ENDIF;
IF AID = '5';
READ(E) INPUTK;
ENDIF;
IF %ERROR;
SETLL(E) KEYA INPUTK;
READ(E) INPUTK;
MX = 7;
EXSR @ERROR;
EXSR @PUTF ;
EXSR @KEYIN;
ENDIF;
KEYA = LKY;
CLEAR KW;
KW = LKY;
ENDIF;
IF (*INU2);
IF AID = '1';
CHAIN(E) RRNA INPUTR;
IF %ERROR;
SETLL(E) RRNA INPUTR;
READP(E) INPUTR;
ENDIF;
ENDIF;
IF AID = X36;
CHAIN(E) RRNA INPUTR;
ENDIF;
IF AID = '4';
READP(E) INPUTR;
ENDIF;
IF AID = '5' OR AID = X3B;
READ(E) INPUTR;
ENDIF;
IF AID = X39;
SETLL(E) *HIVAL INPUTR;
READP(E) INPUTR;
ENDIF;
IF %ERROR;
CHAIN 1 INPUTR;
MX = 7;
EXSR @ERROR;
EXSR @PUTF ;
EXSR @KEYIN;
ENDIF;
ENDIF;
ENDSR;
//@@@@@@@@@@@@@@@@@ @PUTF @@@@@@@@@@@@@@@@@
BEGSR @PUTF;
// WRITE DATA TO THE DISPLAY
NEWRU = '1';
WRTRRN = '1';
RU = *ALLX'00';
CLEAR RU; // initialise Request Unit 255 bytes max
FOR XX = 1 TO NUMFKY; //NUMBER OF DATA ELEMENTS (FLD AND KEY)
IF NEWRU = '1';
NEWRU = '0';
RU = ESC + WTD + X20 + X00;
ENDIF;
IF WRTRRN = '1';
WRTRRN = '0';
RU = RU + SBA + RBA ;
SELECT;
WHEN *INU1;
RRN = RN1;
WHEN *INU2;
RRN = RN2;
ENDSL;
RU = RU + %TRIM(%EDITC(RRN:'Z'));
ENDIF;
// BUFFER ADDRESS
RU = RU + SBA + B(XX);
// PROCESS ALPHA DATA TYPE
IF T(XX) = 'A' OR T(XX) = 'T' OR T(XX) = 'Z' OR
T(XX) = 'L';
STRX = S(XX);
ENDX = E(XX);
IF V(XX) = 'Y'; //VARYING
VX = S(XX);
HX2 = D(VX) + D(VX+1);
STRX = S(XX) + 2 ;
ENDX = S(XX) + BIN;
ENDIF;
FOR Y = STRX TO ENDX ;
IF D(Y) >= ' ';
RU = RU + D(Y);
ELSE;
RU = RU + X1F ; //IF NOT DISPLAYABLE REPLACE WITH X'1F'
ENDIF;
ENDFOR;
ENDIF;
// PROCESS SIGNED DATA TYPE (not the RRN field)
IF T(XX) = 'S' and KY(XX) <> '3';
NUSA = *ALL'0';
WRV = *ALLX'00';
CLEAR WRV;
FOR Y = S(XX) TO E(XX);
IF D(Y) >= XD0;
WRV = WRV + D(Y);
ENDIF;
ENDFOR;
EVAL NUSA = %SUBST(NUSA : 1 : 60 - %LEN(WRV)) + WRV;
CLEAR WRU;
WRU = %TRIM(WRU) + %EDITW(NUS :WRSWRD);
IF P(XX) > 0;
RU = RU +
%SUBST(WRU :61-C(XX): C(XX)-P(XX)) + '.' +
%SUBST(WRU :61-P(XX)) ;
ELSE;
RU = RU +
%SUBST(WRU :61-C(XX));
ENDIF;
ENDIF;
// PROCESS SIGNED DATA TYPE (the RRN field)
IF T(XX) = 'S' and KY(XX) = '3';
RRN = RN2;
RU = RU + %TRIM(%EDITC(RRN:'X'));
ENDIF;
// PROCESS PACKED DATA TYPE
IF T(XX) = 'P';
NUPA = *ALLX'00';
WRV = *ALLX'00';
CLEAR WRV;
FOR Y = S(XX) TO E(XX);
WRV = WRV + D(Y);
ENDFOR;
IF %BITAND(D(E(XX)) :X0F) = X0F OR
%BITAND(D(E(XX)) :X0D) = X0D;
EVAL NUPA = %SUBST(NUPA : 1 : 60 - %LEN(WRV)) + WRV;
CLEAR WRX;
WRX = %TRIM(WRX) + %EDITW(NUP :WRXWRD);
IF P(XX) > 0;
RU = RU +
%SUBST(WRX :64-C(XX): C(XX)-P(XX)) + '.' +
%SUBST(WRX :64-P(XX)) ;
ELSE;
RU = RU +
%SUBST(WRX :64-C(XX));
ENDIF;
ELSE;
// PACKED FIELD IN ERROR
RU = RU + X1F;
ENDIF;
ENDIF;
// PROCESS BINARY DATA TYPE
IF T(XX) = 'B';
ST = S(XX);
CLEAR NUSA;
IF Q(XX) = 2;
BY2 = D(ST) + D(ST+1);
NUS = BIN2;
ENDIF;
IF Q(XX) = 4;
BY4 = D(ST) + D(ST+1)+ D(ST+2) + D(ST+3);
NUS = BIN4;
ENDIF;
WRU = %EDITW(NUS :WRSWRD);
IF P(XX) > 0;
RU = RU +
%SUBST(WRU :61-C(XX): C(XX)-P(XX)) + '.' +
%SUBST(WRU :61-P(XX)) ;
ELSE;
RU = RU +
%SUBST(WRU :61-C(XX));
ENDIF;
ENDIF;
// PROCESS FLOAT DATA TYPE
IF T(XX) = 'F';
ST = S(XX);
IF Q(XX) = 4;
FL4 = D(ST) + D(ST+1)+ D(ST+2) + D(ST+3);
FLT14 = %EDITFLT(FLT4);
RU = RU + FLT14;
ENDIF;
IF Q(XX) = 8;
FL8 = D(ST) + D(ST+1)+ D(ST+2) + D(ST+3) +
D(ST+4) + D(ST+5)+ D(ST+6) + D(ST+7);
FLT23 = %EDITFLT(FLT8);
RU = RU + FLT23;
ENDIF;
ENDIF;
// SEND A REQUEST UNIT IF GOT ENOUGH DATA
IF %LEN(RU) + L(XX + 1) >= 200;
RU = RU + X20;
BIN = %LEN(RU);
OUTLEN = HX2;
INLEN = X000;
FNC = SND;
A = RU;
EXCEPT DATAO;
NEWRU = '1';
RU = *ALLX'00';
CLEAR RU;
ENDIF;
ENDFOR;
IF %LEN(RU) > 5 AND %LEN(RU) < 250;
RU = RU + X20;
BIN = %LEN(RU);
OUTLEN = HX2;
INLEN = X000;
FNC = SND;
A = RU;
EXCEPT DATAO;
ENDIF;
ENDSR;
// @@@@@@@@@@@@@@@ ROWINC @@@@@@@@@@@@@@@
// INCREMENT THE ROW
BEGSR @ROWINC;
ROW = ROW + 2;
IF ROW > 20;
MX = 3;
ENDIF;
ENDSR;
// @@@@@@@@@@@@@@@ GETFLD @@@@@@@@@@@@@@@
// LOAD FIELD DESCRIPTION ARRAYS
BEGSR @GETFLD;
MX = 0;
X = 0;
IF (*INU2 = *ON);
// IF NON KEYED ACCESS SET UP A FIELD TO SHOW THE RRN
N(1) = 'RRN';
T(1) = 'S' ;
C(1) = 11 ;
P(1) = 0 ;
S(1) = 0 ;
E(1) = 0 ;
L(1) = 12 ;
I(1) = X4F06 ;
KY(1)= '3' ;
X = 1 ;
ENDIF;
SCRST = *BLANK;
SCRSTN = *BLANK;
LVL = %DEC(SCNLVL : 5:0);
TEXT500 = SCNLV ;
LV = LVW;
IF LVL <> 0;
SCRST = LV(LVL);
ENDIF;
SETLL 1 QWHDRFFD ;
DOW @LOOP = @LOOP;
// REREAD TAG
READ QWHDRFFD;
IF %EOF;
LEAVE;
ENDIF;
// SELECT OR OMIT
IF ALL <> '1';
IF ALL = 'S' AND WHDFTL = 0; // USING WHDFTL FOR KEY FIELDS
IF WHFIOB <> 'S';
ITER;
ENDIF;
ENDIF;
IF ALL = 'O' AND WHDFTL = 0; // USING WHDFTL FOR KEY FIELDS
IF WHFIOB = 'O';
ITER;
ENDIF;
ENDIF;
ENDIF;
// FIND THE FIRST FIELD TO BE SHOWN (FOR MULTI PAGE FORMATS)
IF WHDFTL <> 0 ;
ELSE;
IF SCRST <> ' ' AND SCRSTN = ' ';
IF WHFLDE = SCRST;
SCRSTN = '1'; // FOUND THE START
ELSE;
ITER;
ENDIF;
ENDIF;
ENDIF;
X = X + 1;
// CHECK FOR KEY FIELDS,WILL BE USED TO PLACE THEM IN FRONT
IF WHDFTL <> 0;
KY(X) = '1';
WX = WHDFTL ;
KE(WX) = WHFLDE;
IF NUMKEY < WHDFTL;
NUMKEY = WHDFTL;
ENDIF;
ENDIF;
N(X) = WHFLDE ; // NAME
T(X) = WHFLDT ; // TYPE
V(X) = WHVARL ; // VARYING
C(X) = WHFLDD ; // DEC DIGITS
P(X) = WHFLDP ; // DEC PREC
S(X) = WHFOBO ; // START
Q(X) = WHFLDB ; // BTYES
E(X) = WHFOBO + WHFLDB -1 ; // END
IF T(X) = 'F' ; // FLOAT
I(X) = FFA1 + FFA2; // SCRN FIELD FORMAT ALPHA
L(X) = 14;
IF Q(X) = 8;
L(X) = 23;
ENDIF;
ELSE;
IF WHFLDD <> 0 ;
IF WHFLDP <> 0 ;
L(X) = WHFLDD + 2 ; // LENGTH
ELSE;
L(X) = WHFLDD + 1 ; // LENGTH
ENDIF;
I(X) = FFN1 + FFN2; // SCRN FIELD FORMAT NUMERIC
ELSE;
L(X) = WHFLDB ;
I(X) = FFA1 + FFA2; // SCRN FIELD FORMAT ALPHA
ENDIF;
ENDIF;
ENDDO;
// NUMBER OF FIELDS
NUMFLD = X ;
// MAKE ROOM FOR KEYS
IF NUMKEY > 0 ;
X1 = NUMKEY + NUMFLD;
FOR X = NUMFLD DOWNTO 1;
KY(X1) = KY(X) ;
L(X1) = L(X) ;
I(X1) = I(X) ;
N(X1) = N(X) ;
T(X1) = T(X) ;
V(X1) = V(X) ;
C(X1) = C(X) ;
P(X1) = P(X) ;
S(X1) = S(X) ;
E(X1) = E(X) ;
Q(X1) = Q(X) ;
X1 = X1 - 1;
ENDFOR;
// PUT KEY FIELDS AT TOP
OFF = 0;
FOR X = 1 TO NUMKEY;
X1 = %LOOKUP(KE(X) : N : NUMKEY+1);
KY(X) = '2';
L(X) = L(X1);
I(X) = I(X1); // FIELD FMT
SELECT; // INPUT ENABLE
WHEN I(X) = X6000;
I(X) = X4800;
WHEN I(X) = X6706;
I(X) = X4F06;
ENDSL;
N(X) = N(X1);
T(X) = T(X1);
V(X) = V(X1);
C(X) = C(X1);
P(X) = P(X1);
S(X) = S(X1);
E(X) = E(X1);
Q(X) = Q(X1);
R(X) = OFF;
OFF = OFF + Q(X1);
ENDFOR;
ENDIF;
// NUMBER OF FIELDS AND KEYS
NUMFKY = NUMFLD + NUMKEY;
ENDSR;
// @@@@@@@@@@@@@@@ GETADD @@@@@@@@@@@@@@@
// LOAD FIELD BUFFER ADDRESSES
BEGSR @GETADD;
MX = 0;
X = 0;
ROW = 3;
COL = 1;
FOR X = 1 TO NUMFKY;
// IF FINISHED WITH THE KEY FIELDS
// INC ROW FOR 1ST DATA FIELD
IF KEYSOK = ' ' ;
IF KY(X) = ' ' OR KY(X) = '1';
KEYSOK = '1' ;
ROW = ROW + 2;
COL = 1;
ENDIF;
ENDIF;
// SET THE BUFFER ADD ON THE LARGER OF THE FIELD TEXT OR THE FIELD SIZE
LENDSC = %LEN(%TRIM(N(X)));
LENWRK = L(X);
IF LENDSC > L(X);
LENWRK = LENDSC;
ENDIF;
LENWRK = LENWRK + 2;
// TRAP FIELDS THAT OVERFLOW
ROW = ROW + XROW;
XROW = %DIV(LENWRK : 80);
IF (COL + LENWRK) > 78;
EXSR @ROWINC;
IF MX = 3;
X= X-1;
NUMFKY = X;
LEAVE;
ENDIF;
COL = 1;
ENDIF;
// INC COL. FOR FIELD START
CLEAR B(X);
BIN = ROW;
B(X) = %TRIM(B(X)) + HX1;
BIN = COL + 1;
B(X) = %TRIM(B(X)) + HX1;
// INC COL. FOR NEXT FIELD
COL = COL + LENWRK;
IF COL > 78;
EXSR @ROWINC;
IF MX = 3; // NO ROOM FOR THE FIELD
X= X-1;
NUMFKY = X;
LEAVE;
ENDIF;
COL = 1;
ENDIF;
ENDFOR;
// FIELD LEVEL
LVX = LVL + 1;
LV(LVX) = N(X);
ENDSR;
// @@@@@@@@@@@@@@@ PUTHED @@@@@@@@@@@@@@@
// PUT FIELD HEADINGS
BEGSR @PUTHED;
NEWRU = '1';
RU = *ALLX'00';
CLEAR RU; // initialise Request Unit 255 bytes max
FOR XX = 1 TO NUMFKY; //NUMBER OF DATA ELEMENTS (FLD AND KEY)
IF NEWRU = '1';
NEWRU = '0';
RU = ESC + WTD + X20 + X00;
ENDIF;
RU = RU + SBA;
BIN = 0;
// CONVERT DATA BUFADR TO HEADING BUFADR
HX1 = %SUBST(B(XX) :1:1);
BIN = BIN - 1;
RU = RU + HX1;
IF REHEAD = '1'; // ON REDISPLAY OVERRIDE THE ATTR
BIN = 0;
HX1 = %SUBST(B(XX) :2:1);
BIN = BIN -1 ;
RU = RU + HX1;
ELSE;
RU = RU + %SUBST(B(XX) :2);
ENDIF;
RU = RU + ATC ;
// LONG NUMBER FIELDS ,RIGHT ADJUST THE FIELD HEADINGS
LENDSC = %LEN(%TRIM(N(XX)));
IF T(XX) <> 'A' AND LENDSC < (L(XX) -1);
FOR Y = 1 TO (L(XX) -(LENDSC +1));
RU = RU + ' ';
ENDFOR;
ENDIF;
RU = RU + %TRIM(N(XX));
IF %LEN(RU) >= 200;
BIN = %LEN(RU);
OUTLEN = HX2;
INLEN = X000;
FNC = SND;
A = RU;
EXCEPT DATAO;
NEWRU = '1';
RU = *ALLX'00';
CLEAR RU;
ENDIF;
ENDFOR;
IF %LEN(RU) > 5 AND %LEN(RU) < 200;
BIN = %LEN(RU);
OUTLEN = HX2;
INLEN = X000;
FNC = SND;
A = RU;
EXCEPT DATAO;
ENDIF;
IF REHEAD <> '1';
// FORMAT FIELDS
NEWRU = '1';
RU = *ALLX'00';
CLEAR RU; // initialise Request Unit 255 bytes max
FOR XX = 1 TO NUMFKY; //NUMBER OF DATA ELEMENTS (FLD AND KEY)
IF NEWRU = '1';
NEWRU = '0';
RU = ESC + WTD + X20 + X00;
ENDIF;
RU = RU + SBA +B(XX)+SF + I(XX);
IF KY(XX) = '1' OR KY(XX) = '2' OR KY(XX) = '3';
RU = RU + X25;
ELSE;
RU = RU + X26;
ENDIF;
BIN = L(XX);
RU = RU + HX2;
// LENGTH OF INPUT FIELDS
LENF = LENF + L(XX) + 3;
IF %LEN(RU) >= 200;
BIN = %LEN(RU);
OUTLEN = HX2;
INLEN = X000;
FNC = SND;
A = RU;
EXCEPT DATAO;
NEWRU = '1';
RU = *ALLX'00';
CLEAR RU;
ENDIF;
ENDFOR;
// PUT LAST R/U
IF %LEN(RU) > 5 AND %LEN(RU) < 200;
BIN = %LEN(RU);
OUTLEN = HX2;
INLEN = X000;
FNC = SND;
A = RU;
EXCEPT DATAO;
ENDIF;
//INC BUFFER ADDRESS FOR ALL FIELDS FOR DATA PUT
FOR XP = 1 TO NUMFKY; //NUMBER OF DATA ELEMENTS (FLD AND KEY)
HX2 = B(XP);
BIN = BIN + 1;
B(XP) = HX2;
ENDFOR;
ENDIF;
ENDSR;
// @@@@@@@ INIT @@@@@@@@@@@@@@@@@@@@@@@@@
BEGSR @INIT;
CLEAR KW;
// UPDATE
IF UPDF = 'Y';
FFA1 = X40;
FFN1 = X47;
ELSE;
FFA1 = X60;
FFN1 = X67;
ENDIF;
SELECT;
WHEN *INU1 = '1';
FILE = F1 ;
LIB = L1 ;
MBR = M1 ;
RCDL = R1 ;
ACCTP = A1 ;
WHEN *INU2 = '1';
FILE = F2 ;
LIB = L2 ;
MBR = M2 ;
RCDL = R2 ;
ACCTP = A2 ;
ENDSL;
RLEN = RCDL ;
RLENTH = %EDITC(RLEN: 'X') ;
LENF = 0 ;
// Control commands and data are constructed into RUs Request UNITS
// Each RU is 256 bytes max size.
// Construct and send as many RUs as needed to format the display.
RU = *ALLX'00';
CLEAR RU; // initialise Request Unit 255 bytes max
RU = CLRWTD ;
//set up the screen headings
BIN = 1; // set ROW to 1
RW = HX1;
BIN = 2; // set COL to 2
CL = HX1;
RU = RU + SBA + RW + CL + X22 + %TRIM(LIB) + '/' + %TRIM(FILE);
RU = RU + ' Mbr ' + %TRIM(MBR) + ' Rcdl ' + %EDITC(RLEN : 'Z') ;
RU = RU + ' RRN ' ;
BIN = %len(RU) -4;
RBA = RW + HX1 ; // address of the RRN field
RU = RU + SBA + RBA + ' ';
// FUNCTION KEYS
BIN = 23;
RW = HX1;
BIN = 02;
CL = HX1;
IF UPDF = 'Y'; // UPDATE IS ON
RU = RU + SBA + RW + CL + %TRIM(CNS(2));
ELSE;
RU = RU + SBA + RW + CL + %TRIM(CNS(1));
ENDIF;
// THIS IS A SEND ONLY FUNCTION
FNC = SND;
CLEAR A;
A = RU;
BIN2 = %LEN(RU);
OUTLEN = BY2;
INLEN = x000;
EXCEPT DATAO;
ENDSR;
// @@@@@@@ KEYIN @@@@@@@@@@@@@@@@@@@@@@@@@
BEGSR @KEYIN;
// ISSUE A READ FROM DISPLAY
FNC = SNR;
BIN2 = 8;
OUTLEN = BY2;
IPL = LENF + 34;
BIN2 = IPL;
INLEN = BY2;
// SET FRR INDICATORS TO CONTROL BUFFER OVERFLOW
FOR X = 1 TO 9;
IF IPL > ( X*80 +3);
*IN(X+19) = *ON;
ENDIF;
ENDFOR;
RU = *ALLX'00';
CLEAR RU;
RU = RDDSP;
A = RU;
EXCEPT DATAI;
ENDSR;
// @@@@@@@ ERROR @@@@@@@@@@@@@@@@@@@@@@@@@
BEGSR @ERROR;
// SETUP PUT ERROR MESSAGE X'21'
RU = *ALLX'00';
CLEAR RU;
FNC = SNR;
BIN = 42;
OUTLEN = HX2;
BIN = LENF + 34;
IPL = BIN;
INLEN = HX2;
FOR X = 1 TO 9;
IF IPL > (X * 80 +3) ;
*IN(X + 19) = *ON; // SETON FFR 20 - 29 FOR INPUT
ENDIF;
ENDFOR;
RU = ESC + WER + IC + B(1) + ATC + MSG(MX);
RU = RU + ESC + RDM + X40+ X00;
A = RU;
EXCEPT DATAI;
RU = *ALLX'00';
CLEAR RU;
ENDSR;
// @@@@@@@ HXDSP @@@@@@@@@@@@@@@@@@@@@@@@@
BEGSR @HXDSP;
RU = *ALLX'00';
CLEAR RU;
Y = %LOOKUPLE( CURLOC : B );
//
RU = ESC + WTD + X20 + X00 + SBA;
BIN = 0;
HX1 = %SUBST(B(Y) :1:1);
BIN = BIN - 1;
RU = RU + HX1;
RU = RU + %SUBST(B(Y) :2:1);
FOR X = S(Y) TO E(Y);
BIN = 0;
HX1 = D(X);
HX1 = %BITAND(HX1 : XF0);
Z = BIN / 16 + 1;
RU = RU + CRS(Z);
ENDFOR;
RU = RU + X20;
RU = RU + SBA + B(Y);
FOR X = S(Y) TO E(Y);
BIN = 0;
HX1 = D(X);
HX1 = %BITAND(HX1 : X0F);
Z = BIN + 1;
RU = RU + CRS(Z);
ENDFOR;
BIN = %LEN(RU);
OUTLEN = HX2;
INLEN = X000;
FNC = SND;
A = RU;
EXCEPT DATAO;
RU = *ALLX'00';
CLEAR RU;
EXSR @KEYIN;
READ DISPF;
// CLEAR HEADINGS
RU = *ALLX'00';
CLEAR RU;
RU = RU + ESC + WTD + X20 + X00 + SBA;
HX1 = %SUBST(B(Y) :1:1) ;
BIN = BIN - 1;
RU = RU + HX1 + %SUBST(B(Y):2:1);
FOR X = S(Y) TO E(Y);
RU = RU + ' ';
ENDFOR;
RU = RU + ' ';
BIN = %LEN(RU);
OUTLEN = HX2;
INLEN = X000;
FNC = SND;
A = RU;
EXCEPT DATAO;
RU = *ALLX'00';
CLEAR RU;
ENDSR;
// @@@@@@@ UPD @@@@@@@@@@@@@@@@@@@@@@@@@
BEGSR @UPD;
// CONVERT DATA FOR OUTPUT
// FOR EACH FIELD, CHECK IF FIELD WAS MODIFIED, AND IF SO MOVE
// THE MODIFIED DATA INTO THE OUTPUT ARRAY
K1 = 0;
K2 = 0;
W = 1;
CGKY = *BLANK; // KEY CHANGED
KW = KEYA;
FOR Y = 1 TO NUMFKY ;
IF KY(Y) > '1';
ITER;
ENDIF;
// MOVE A KEY FIELDS DATA FROM ID ARRAY (SCREEN) TO K ARRAY
// GET SIZE OF FIELD IN BYTES
IF T(Y) = 'A'; // ALPHA DATA
K = ' ';
K1 = 1;
K2 = Q(Y);
ELSE;
K = '0';
K1 = 1;
K2 = C(Y);
ENDIF;
X = 1;
DOW @LOOP = @LOOP;
// NXTSBA
X = %LOOKUP(SBA : ID : X );
IF X = 0;
LEAVE;
ENDIF;
// IS THIS THE FIELD? CHECK THE BUFFER ADDRESS
X = X +1;
IF B(Y) <> %SUBST(IDA : X :2);
ITER;
ENDIF;
// FOUND A MTD FOR THIS FIELD
// CHECK IF FIELD WAS CLEARED ONLY
DOW @LOOP = @LOOP; // not a loop
X = X + 2;
IF ID(X) = SBA;
LEAVE;
ENDIF;
// IF FIELD HAS DECIMALS BUMP X
IF (T(Y) = 'S' OR T(Y) = 'P' OR T(Y) = 'B') AND
P(Y) > 0;
X = X + 1;
ENDIF;
// CHECK IF ONLY BLANKS RETURNED
IF %SUBST(IDA : X :K2) = *BLANKS;
LEAVE;
ENDIF;
// MOVE DATA TO WORK ARRAY K
X1 = X;
FOR X2 = 1 TO K2;
IF ID(X1) < ' ';
LEAVE;
ENDIF;
K(X2) = ID(X1);
X1 = X1 + 1;
ENDFOR;
LEAVE;
ENDDO;
// * SET START POSN
W = S(Y);
// ALPHA
IF T(Y) = 'A' and V(XX) <> 'Y';
FOR Z = K1 to K2;
D(W) = K(Z);
W = W + 1;
ENDFOR;
ENDIF;
IF T(Y) = 'A' and V(XX) = 'Y'; //VARYING
// the data start is in S(Y)
// the data is in array K
// get the length of the data cvt to bin and stik in pos 1 2
// put the rest in pos 3 onwards
ENDIF;
// NUMERIC FIELD
// RIGHT ADJUST NUMERIC DATA ,STRIP - . ,CONVERT BLANKS
IF (T(Y) = 'S' OR T(Y) = 'P' OR T(Y) = 'B');
NU = '0';
Z1 = 60;
FOR Z = K2 DOWNTO K1;
IF K(Z) = '.' OR K(Z) = '-' OR K(Z) = '$';
ITER;
ENDIF;
IF K(Z) = ' ' ;
NU(Z1) = '0';
ELSE;
NU(Z1) = K(Z);
ENDIF;
Z1 = Z1 -1;
ENDFOR;
ENDIF;
// SIGNED FIELDS (END POSN = OFFSET + SIZE)
IF T(Y) = 'S';
NUSA= *BLANKS;
FOR VX = 1 TO 60;
NUSA = %TRIM(NUSA) + NU(VX);
ENDFOR;
%SUBST(DATA : W : Q(Y)) = %SUBST(NUSA: 61 -Q(Y));
ENDIF;
// PACKED FIELDS
IF T(Y) = 'P';
NUSA= *BLANKS;
FOR VX = 1 TO 60;
NUSA = %TRIM(NUSA) + NU(VX);
ENDFOR;
NUP = %DEC(NUSA : 60 : 0);
%SUBST(DATA : W : Q(Y)) = %SUBST(NUPA: 61 -Q(Y));
ENDIF;
// BINARY FIELDS
IF T(Y) = 'B';
IF Q(Y) = 2 ;
BY2 = NU(1) + NU(2);
%SUBST(DATA : W : 2) = BY2;
ENDIF;
IF Q(Y) = 4 ;
BY4 = NU(1) + NU(2) + NU(3) + NU(4);
%SUBST(DATA : W : 4) = BY4;
ENDIF;
ENDIF;
// UPDATE KEY IF NECESSARY
IF KY(Y) = '1';
CGKY = '1';
EXSR @PCKMOV;
ENDIF;
ENDDO;
ENDFOR;
IF CGKY = '1';
KEYA = KW;
ENDIF;
ENDSR;
/END-FREE
OINPUTK E U1 UPDATREC
O DA
O 30 DB
O 31 DC
O 32 DD
O 33 DE
O 34 DF
O 35 DG
O 36 DH
O 37 DI
O 38 DJ
O 39 DK
O 40 DL
O 41 DM
O 42 DN
O 43 DZ
O 44 DO
O 45 DP
O 46 DQ
O 47 DR
O 48 DS
O 49 DT
O 50 DU
O 51 DV
O 52 DW
O 53 DX
O 54 DY
O 55 D0
O 56 D1
O 57 D2
O 58 D3
O 59 D4
O 60 D5
O 61 D6
O 62 DBA
O 63 DCA
O 64 DDA
O 65 DEA
O 66 DFA
O 67 DGA
O 68 DHA
O 69 DIA
O 70 DJA
O 71 DKA
O 72 DLA
O 73 DMA
O 74 DNA
O 75 DOA
O 76 DPA
O 77 DQA
O 78 DRA
O 79 DSA
O 80 DTA
O 81 DUA
O 82 DVA
O 83 DWA
O 84 DXA
O 85 DYA
O 86 DZA
O 87 D0A
O 88 D1A
O 89 D2A
O 90 D3A
O 91 D4A
O 92 D5A
O 93 D6A
OINPUTR E U2 UPDATREC
O DA
O 30 DB
O 31 DC
O 32 DD
O 33 DE
O 34 DF
O 35 DG
O 36 DH
O 37 DI
O 38 DJ
O 39 DK
O 40 DL
O 41 DM
O 42 DN
O 43 DZ
O 44 DO
O 45 DP
O 46 DQ
O 47 DR
O 48 DS
O 49 DT
O 50 DU
O 51 DV
O 52 DW
O 53 DX
O 54 DY
O 55 D0
O 56 D1
O 57 D2
O 58 D3
O 59 D4
O 60 D5
O 61 D6
O 62 DBA
O 63 DCA
O 64 DDA
O 65 DEA
O 66 DFA
O 67 DGA
O 68 DHA
O 69 DIA
O 70 DJA
O 71 DKA
O 72 DLA
O 73 DMA
O 74 DNA
O 75 DOA
O 76 DPA
O 77 DQA
O 78 DRA
O 79 DSA
O 80 DTA
O 81 DUA
O 82 DVA
O 83 DWA
O 84 DXA
O 85 DYA
O 86 DZA
O 87 D0A
O 88 D1A
O 89 D2A
O 90 D3A
O 91 D4A
O 92 D5A
O 93 D6A
OINPUTK EADD U1 ADDREC
O DA
O 30 DB
O 31 DC
O 32 DD
O 33 DE
O 34 DF
O 35 DG
O 36 DH
O 37 DI
O 38 DJ
O 39 DK
O 40 DL
O 41 DM
O 42 DN
O 43 DZ
O 44 DO
O 45 DP
O 46 DQ
O 47 DR
O 48 DS
O 49 DT
O 50 DU
O 51 DV
O 52 DW
O 53 DX
O 54 DY
O 55 D0
O 56 D1
O 57 D2
O 58 D3
O 59 D4
O 60 D5
O 61 D6
O 62 DBA
O 63 DCA
O 64 DDA
O 65 DEA
O 66 DFA
O 67 DGA
O 68 DHA
O 69 DIA
O 70 DJA
O 71 DKA
O 72 DLA
O 73 DMA
O 74 DNA
O 75 DOA
O 76 DPA
O 77 DQA
O 78 DRA
O 79 DSA
O 80 DTA
O 81 DUA
O 82 DVA
O 83 DWA
O 84 DXA
O 85 DYA
O 86 DZA
O 87 D0A
O 88 D1A
O 89 D2A
O 90 D3A
O 91 D4A
O 92 D5A
O 93 D6A
OINPUTR EADD U2 ADDREC
O DA
O 30 DB
O 31 DC
O 32 DD
O 33 DE
O 34 DF
O 35 DG
O 36 DH
O 37 DI
O 38 DJ
O 39 DK
O 40 DL
O 41 DM
O 42 DN
O 43 DZ
O 44 DO
O 45 DP
O 46 DQ
O 47 DR
O 48 DS
O 49 DT
O 50 DU
O 51 DV
O 52 DW
O 53 DX
O 54 DY
O 55 D0
O 56 D1
O 57 D2
O 58 D3
O 59 D4
O 60 D5
O 61 D6
O 62 DBA
O 63 DCA
O 64 DDA
O 65 DEA
O 66 DFA
O 67 DGA
O 68 DHA
O 69 DIA
O 70 DJA
O 71 DKA
O 72 DLA
O 73 DMA
O 74 DNA
O 75 DOA
O 76 DPA
O 77 DQA
O 78 DRA
O 79 DSA
O 80 DTA
O 81 DUA
O 82 DVA
O 83 DWA
O 84 DXA
O 85 DYA
O 86 DZA
O 87 D0A
O 88 D1A
O 89 D2A
O 90 D3A
O 91 D4A
O 92 D5A
O 93 D6A
OINPUTK EDEL U1 DELREC
OINPUTR EDEL U2 DELREC
ODISPF E DATAO
O K3 'PUT'
O OUTLEN 2
O INLEN
O FNC
O A
O E DATAI
O K3 'GET'
O OUTLEN 2
O INLEN
O FNC
O A
**
0000 INVALID COMMAND KEY
0001 - A FIELD IS TOO LONG
0002 - TOO MANY FIELDS
0003 - ALPHAS IN PACKED KEY
0004 - MISSING ' IN PACKED KEY
0005 - MISSING DATA IN PCKD KEY
0006 - RECORD NOT FOUND
PRESS RESET TO CONTINUE
**
F1-HEX F2-Return F3-Exit F19-Prev_fld F20-More_fld
F1-HEX F2-Return F3-Exit F6-Update F9-Add F11-Del F19-Prev_fld F20-More_fld
**
0123456789ABCDEF
DISPF DSPF
A DSPSIZ(24 80 *DS3)
A PRINT
A OPENPRT
A HELP
A INDARA
A R PUT USRDFN
A R GET USRDFN
A INVITE
WRAPPER CODE
DSPFF CMD
/* TO COMPILE */
/* CRTCMD CMD(*CURLIB/DSPFF) PGM(*LIBL/DIS) SRCFILE(*LIBL/QCMDSRC) */
/* SRCMBR(DSPFF) VLDCKR(DISV) */
CMD PROMPT('Display file in field format')
PARM KWD(FILE) TYPE(QUAL1) MIN(1) MAX(1) +
PROMPT('File')
PARM KWD(MBR) TYPE(*NAME) DFT(*FIRST) +
SPCVAL((*FILE) (*FIRST)) MIN(0) MAX(1) +
PROMPT('Member')
PARM KWD(UPD ) TYPE(*CHAR) LEN(1) DFT(N) +
RSTD(*YES) VALUES('Y' 'N' 'y' 'n') +
PROMPT('Update data (Y/N)')
PARM KWD(RST ) TYPE(*CHAR) LEN(1) DFT(N) +
RSTD(*YES) VALUES('Y' 'N' 'y' 'n') +
PROMPT('Get DDS again.')
PARM KWD(REL ) TYPE(*CHAR) LEN(1) DFT(N) +
RSTD(*YES) VALUES('Y' 'N' 'y' 'n') +
PROMPT('Show Relations')
QUAL1: QUAL TYPE(*NAME) LEN(10)
QUAL TYPE(*NAME) LEN(10) DFT(*LIBL ) +
SPCVAL(*LIBL ) +
PROMPT('Library name')
DIS CLE
/* Command processing program for DSPFF command */
PGM (&FILIB &MBR &UPD &RST &REL)
DCL &FILIB *CHAR 20
DCL &FILE *CHAR 10
DCL &LIB *CHAR 10
DCL &SFILE *CHAR 10
DCL &SLIB *CHAR 10
DCL &MBR *CHAR 10
DCL &OPT *CHAR 10
DCL &ALL *CHAR 1
DCL &RTN *CHAR 1
DCL &RMBR *CHAR 10
DCL &QRY *LGL
DCL &UPD *LGL
DCL &REL *CHAR 1
DCL &RST *CHAR 1
DCL &RCDL *CHAR 5
DCL &RCDLN *DEC (5 0)
DCL &ACCP *CHAR 1
DCL &OVR *LGL VALUE('0')
DCL &FILEF *CHAR 10
DCL &FILEK *CHAR 10
DCL &ID *CHAR 7
DCL &MF *CHAR 10
DCL &ML *CHAR 10
DCL &TYPE *CHAR 1
DCL &PHY *CHAR 10
DCL &PHYLIB *CHAR 10
RMVLIBLE QTEMP
MONMSG CPF0000
ADDLIBLE QTEMP *FIRST
MONMSG CPF0000 EXEC(GOTO END)
RESET:
CHGVAR &FILE &FILIB
CHGVAR &LIB (%SST(&FILIB 11 10))
IF (&LIB *EQ ' ') (CHGVAR &LIB '*LIBL')
IF (&MBR *EQ '*FILE') (CHGVAR &MBR &FILE)
IF (&MBR *EQ '*FIRST') (DO)
RTVMBRD FILE(&LIB/&FILE) RTNMBR(&RMBR)
CHGVAR &MBR &RMBR
ENDDO
CHGVAR &FILEF ('FF'||(%SST(&FILE 1 8)))
CHGVAR &FILEK ('KF'||(%SST(&FILE 1 8)))
IF (&RST= 'Y') DO
DLTF &FILEF
MONMSG CPF0000
DLTF &FILEK
MONMSG CPF0000
ENDDO
CHKOBJ (QTEMP/&FILEF) *FILE
MONMSG CPF9801 EXEC(DO)
DSPFFD FILE(&LIB/&FILE) OUTPUT(*OUTFILE) OUTFILE(QTEMP/&FILEF)
DSPFD (&LIB/&FILE) TYPE(*ACCPTH) OUTPUT(*OUTFILE) OUTFILE(QTEMP/&FILEK)
CHGVAR &RTN '2'
ENDDO
CHGPF QTEMP/&FILEF LVLCHK(*NO)
CHGPF QTEMP/&FILEK LVLCHK(*NO)
IF (&REL = 'Y' ) DO
CALL DISF (&FILEK &TYPE &PHY &PHYLIB)
IF (&TYPE *EQ 'P') DO
CHGVAR &PHY &FILE
CHGVAR &PHYLIB &LIB
ENDDO
CALL DIS3 (&PHY &PHYLIB &SFILE &SLIB)
IF (&SFILE *NE ' ') DO
IF ((&SFILE *NE &FILE) *OR (&SLIB *NE &LIB)) DO
CHGVAR &FILIB (&SFILE||&SLIB)
CHGVAR &REL '0'
RTVMBRD FILE(&SLIB/&SFILE) RTNMBR(&RMBR)
CHGVAR &MBR &RMBR
IF (&MBR *EQ &FILE) THEN(CHGVAR &MBR '*FILE ')
GOTO RESET
ENDDO
ENDDO
ENDDO
CALL DIS1 (&FILIB &MBR &UPD &RST &RTN &FILE &LIB &FILEF &FILEK)
RCLRSC
END:
CLOF OPNID(&FILE)
MONMSG CPF0000
ENDPGM
DIS1 CLE
/* CALLED BY DIS TO DRIVE SELECTION OF UDDS RPG PROGRAM */
/* FILE DISPLAYER DRIVER */
/* SHOWS A LIST OF FIELDS IN A FILE , ALLOWS SELECTION OF FIELDS */
/* WHEN ALL THE FIELDS DONT FIT ON ONE SCREEN */
/* THIS CONTAINS A LOOP SO THAT MORE FIELDS CAN BE DISPLAYED */
/*
PGM (&FILIB &MBR &UPD &RST &RTN &FILE &LIB &FILEF &FILEK)
DCL &FILIB *CHAR 20
DCL &FILE *CHAR 10
DCL &LIB *CHAR 10
DCL &MBR *CHAR 10
DCL &PRG *CHAR 10
DCL &OPT *CHAR 10
DCL &ALL *CHAR 1
DCL &RTN *CHAR 1
DCL &RMV *CHAR 1
DCL &QRY *LGL
DCL &UPD *CHAR 1
DCL &RST *LGL
DCL &KEYL *CHAR 4
DCL &RCDL *CHAR 5
DCL &RCDLN *DEC (5 0)
DCL &ACCP *CHAR 1
DCL &OVR *LGL VALUE('0')
DCL &FILEF *CHAR 10
DCL &FILEK *CHAR 10
DCL &ID *CHAR 7
DCL &MF *CHAR 10
DCL &ML *CHAR 10
DCL &SCNLV *CHAR 500
DCL &SCNLVL *CHAR 5
DCL &SCNKEY *CHAR 800
DCL &ML *CHAR 10
DCL &MSG *CHAR 80
DCLF DISPX
CHGVAR &PGMQ DIS
CHGVAR &SCNLVL '00000'
OVRDBF FFD QTEMP/&FILEF SECURE(*YES)
OVRDBF KF QTEMP/&FILEK SECURE(*YES)
RTN:
OVRDBF INPUT &LIB/&FILE SHARE(*NO)
CALL DISPY (&ALL &RTN &KEYL &ACCP &QRY &RCDL)
DLTOVR INPUT
MONMSG CPF0000
IF (&RTN *EQ '1') (GOTO END)
IF (&ACCP *EQ 'K') DO
CHGJOB SWS(10XXXXXX)
OVRDBF FILE(INPUTK) TOFILE(&LIB/&FILE) MBR(&MBR) +
SHARE(*YES) SEQONLY(*NO) SECURE(*YES)
IF (&QRY ) DO
REMSG:
REQRY: SNDRCVF RCDFMT(SLT)
IF (&IN01 *OR &IN02) GOTO BYQRY
CHGVAR &OPT '*INP'
IF (&UPD *EQ 'Y') (CHGVAR &OPT '*ALL')
OPNQRYF FILE((INPUTK)) OPTION(&OPT) QRYSLT(&QSLT) +
KEYFLD(*FILE) SEQONLY(*NO)
MONMSG CPF9899 EXEC(DO)
RCVMSG MSGTYPE(*ANY)
SNDF RCDFMT(SLTC)
GOTO REMSG
ENDDO
ENDDO
ENDDO
BYQRY:
IF (&ACCP *EQ 'A') DO
CHGJOB SWS(01XXXXXX)
OVRDBF FILE(INPUTR) TOFILE(&LIB/&FILE) MBR(&MBR) +
SHARE(*YES) SEQONLY(*NO) SECURE(*YES)
IF (&QRY ) DO
REMSGA:
REQRYA: SNDRCVF RCDFMT(SLT)
IF (&IN01 *OR &IN02) GOTO BYQRYA
CHGVAR &OPT '*INP'
IF (&UPD = 'Y') (CHGVAR &OPT '*ALL')
OPNQRYF FILE((INPUTR)) OPTION(&OPT) QRYSLT(&QSLT) +
KEYFLD(*FILE) SEQONLY(*NO)
MONMSG CPF9899 EXEC(DO)
RCVMSG MSGTYPE(*ANY)
SNDF RCDFMT(SLTC)
GOTO REMSGA
CHGVAR VAR(&IN20) VALUE('1')
SDAMSG: RCVMSG RMV(*NO) MSG(&MSG)
IF COND(&MSG ¬= ' ') THEN(DO)
SNDPGMMSG MSG(&MSG)
GOTO SDAMSG
ENDDO
SNDF RCDFMT(SLTC)
GOTO REMSGA
ENDDO
ENDDO
ENDDO
BYQRYA:
CHGVAR &RCDLN &RCDL
IF ( &UPD= 'Y') (DO)
IF ((&RCDLN *GT 0) *AND (&RCDLN *LE 2048)) (CHGVAR &PRG 'DUSP ')
IF ((&RCDLN *GT 2048) *AND (&RCDLN *LE 4048)) (CHGVAR &PRG 'DUSP1')
IF ((&RCDLN *GT 4048) *AND (&RCDLN *LE 6080)) (CHGVAR &PRG 'DUSP2')
ENDDO
IF (&UPD *NE 'Y') (DO)
IF ((&RCDLN *GT 0) *AND (&RCDLN *LE 2048)) (CHGVAR &PRG 'DISP ')
IF ((&RCDLN *GT 2048) *AND (&RCDLN *LE 4048)) (CHGVAR &PRG 'DISP1')
IF ((&RCDLN *GT 4048) *AND (&RCDLN *LE 6080)) (CHGVAR &PRG 'DISP2')
ENDDO
CALL &PRG (&ALL &RTN &KEYL &UPD &SCNLV &SCNLVL &SCNKEY)
IF (&QRY ) (DO)
IF (&ACCP *EQ 'K') DO
CLOF INPUTK
MONMSG CPF0000
ENDDO
IF (&ACCP *EQ 'A') DO
CLOF INPUTR
MONMSG CPF0000
ENDDO
ENDDO
IF (&RTN *EQ '3') DO
GOTO BYQRYA
ENDDO
IF (&RTN *EQ '1') DO
CHGVAR &RTN '0'
GOTO RTN
ENDDO
END: ENDPGM
DIS3 CLE
/* CALL BY DIS TO SHOW FILE RELATIONS / ACCESS PATHS */
PGM (&PHY &PHYLIB &SFILE &SLIB)
/* DISPLAY ACCESS PATHS */
DCL &PHY *CHAR 10
DCL &PHYLIB *CHAR 10
DCL &SFILE *CHAR 10
DCL &SLIB *CHAR 10
DCL &LIB *CHAR 10 'KOLMANNF '
DCLF QTEMP/DBR
DLTF QTEMP/DBR
MONMSG CPF0000
CLRPFM QTEMP/REL
MONMSG CPF0000 EXEC(DO)
CRTDUPOBJ OBJ(QADSPDBR) FROMLIB(&LIB) +
OBJTYPE(*FILE) TOLIB(QTEMP) NEWOBJ(REL)
MONMSG CPF0000
ENDDO
CLRPFM QTEMP/SEL
MONMSG CPF0000 EXEC(DO)
CRTDUPOBJ OBJ(QAFDSELO) FROMLIB(&LIB) +
OBJTYPE(*FILE) TOLIB(QTEMP) NEWOBJ(SEL)
MONMSG CPF0000
ENDDO
DSPDBR FILE(&PHYLIB/&PHY) OUTPUT(*OUTFILE) +
OUTFILE(QTEMP/DBR) OUTMBR(*FIRST *REPLACE)
CHGPF QTEMP/DBR LVLCHK(*NO)
NEXT: RCVF
MONMSG CPF0000 EXEC(GOTO END)
IF (&WHREFI *NE ' ') DO
DSPFD FILE(&WHRELI/&WHREFI) TYPE(*ACCPTH) +
OUTPUT(*OUTFILE) OUTFILE(QTEMP/REL) OUTMBR(*FIRST *ADD)
CHGPF QTEMP/REL LVLCHK(*NO)
DSPFD FILE(&WHRELI/&WHREFI) TYPE(*SELECT) +
OUTPUT(*OUTFILE) OUTFILE(QTEMP/SEL) OUTMBR(*FIRST *ADD)
CHGPF QTEMP/SEL LVLCHK(*NO)
ENDDO
GOTO NEXT
END:
DSPFD FILE(&PHYLIB/&PHY ) TYPE(*ACCPTH) +
OUTPUT(*OUTFILE) OUTFILE(QTEMP/REL) OUTMBR(*FIRST *ADD)
CHGPF QTEMP/REL LVLCHK(*NO)
CHGVAR &SFILE ' '
CHGVAR &SLIB ' '
OVRDBF SEL QTEMP/SEL
OVRDBF REL QTEMP/REL
CALL DISPR (&SFILE &SLIB)
DLTOVR *ALL
ENDPGM
DISV CLE
/* VALIDITY CHECKER FOR DSPFF COMMAND */
PGM (&FILIB &MBR &UPD &RST &REL)
DCL &FILIB *CHAR 20
DCL &FILE *CHAR 10
DCL &LIB *CHAR 10
DCL &MBR *CHAR 10
DCL &UPD *CHAR 1
DCL &RST *CHAR 1
DCL &REL *CHAR 1
DCL &OBJATR *CHAR 10
DCL &AUT *CHAR 8
DCL &MSGDTA *CHAR 40
DCL &ERROR *LGL
CHGVAR &FILE &FILIB
CHGVAR &LIB (%SST(&FILIB 11 10))
IF (&MBR *EQ '*FILE') (CHGVAR &MBR &FILE )
CHGVAR &AUT '*READ '
IF ((&UPD *EQ 'Y') *OR (&UPD *EQ 'y')) (CHGVAR &AUT '*CHANGE')
CHKOBJ (&LIB/&FILE) OBJTYPE(*FILE) MBR(*NONE) +
AUT( &AUT )
MONMSG (CPF9899 CPF9801 CPF9802 CPF9820 CPF9830) EXEC(DO)
/* CHGVAR (&MSGDTA) VALUE(' '||&FILE||&LIB) */
/* SNDPGMMSG MSGID(USR0006) MSGF(*LIBL/QUSERMSG) MSGTYPE(*DIAG) +*/
/* MSGDTA(&MSGDTA) */
SNDPGMMSG MSG('Not authorised to the file.') +
MSGTYPE(*DIAG)
CHGVAR (&ERROR) '1'
ENDDO
MONMSG (CPF9810) EXEC(DO)
CHGVAR (&MSGDTA) VALUE(' '||&LIB)
/* SNDPGMMSG MSGID(USR0008) MSGF(*LIBL/QUSERMSG) MSGTYPE(*DIAG) +*/
/* MSGDTA(&MSGDTA) */
SNDPGMMSG MSG('Not authorised to the file.') +
MSGTYPE(*DIAG)
CHGVAR (&ERROR) '1'
ENDDO
IF (*NOT &ERROR) DO
RTVOBJD OBJ(&LIB/&FILE) OBJTYPE(*FILE) OBJATR(&OBJATR)
CHGVAR &AUT '*READ '
IF ((&UPD *EQ 'Y') *OR (&UPD *EQ 'y')) (CHGVAR &AUT '*CHANGE')
CHKOBJ OBJ(&LIB/&FILE) OBJTYPE(*FILE) MBR(&MBR) +
AUT(&AUT)
MONMSG (CPF9815 ) EXEC(DO)
/* CHGVAR (&MSGDTA) VALUE(' '||&MBR||&FILE||&LIB) */
/* SNDPGMMSG MSGID(USR0007) MSGF(*LIBL/QUSERMSG) MSGTYPE(*DIAG) + */
/* MSGDTA(&MSGDTA) */
SNDPGMMSG MSG('Not authorised to the file.') +
MSGTYPE(*DIAG)
CHGVAR (&ERROR) '1'
ENDDO
MONMSG (CPF0000 ) EXEC(DO)
/* SNDPGMMSG MSGID(USR0022) MSGF(*LIBL/QUSERMSG) MSGTYPE(*DIAG) + */
/* MSGDTA(&MSGDTA) */
SNDPGMMSG MSG('Not authorised to the file.') +
MSGTYPE(*DIAG)
CHGVAR (&ERROR) '1'
ENDDO
ENDDO
IF (&ERROR) (SNDPGMMSG MSGID(CPF0002) MSGF(QCPFMSG) MSGTYPE(*ESCAPE))
ENDPGM
DISF CLE
/* CHECK FILE TYPE */
PGM (&DISF &TYPE &PHY &PHYLIB)
DCL &DISF *CHAR 10
DCL &TYPE *CHAR 1
DCL &PHY *CHAR 10
DCL &PHYLIB *CHAR 10
DCLF KF
OVRDBF FILE(KF) TOFILE(QTEMP/&DISF)
OPNDBF FILE(KF) OPTION(*INP)
RCVF
CHGVAR &TYPE &APFTYP
IF (&TYPE *EQ 'L') DO
CHGVAR &PHY &APBOF
CHGVAR &PHYLIB &APBOL
ENDDO
CLOF OPNID(KF)
ENDPGM
