Difference between revisions of "UDDS File Display/Update"
From MidrangeWiki
m (→DUSP2 RPG) |
m (→DUSP2 RPG) |
||
| Line 10,251: | Line 10,251: | ||
D KEYLNA 1 4 | D KEYLNA 1 4 | ||
| − | + | DDUSP2 PR | |
D 1 | D 1 | ||
D 1 | D 1 | ||
| Line 10,259: | Line 10,259: | ||
D 5 | D 5 | ||
D 800 | D 800 | ||
| − | + | DDUSP2 PI | |
D ALL 1 | D ALL 1 | ||
D RTN 1 | D RTN 1 | ||
Revision as of 10:31, 26 November 2018
UDDS PROGRAMS THAT SHOW FILES FIELDS AND RELATIONS AND ALLOWS UPDATE
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. There are 3 programs first is limited to 2048 last to 6048.
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
F* REQUIRES FILE TO COMPILE
F* 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 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
F* REQUIRES FILE TO COMPILE
F* 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 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 DATA 1 4080
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
DDUSP1 PR
D 1
D 1
D 4
D 1
D 500
D 5
D 800
DDUSP1 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 DATA 1 6080
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
DDUSP2 PR
D 1
D 1
D 4
D 1
D 500
D 5
D 800
DDUSP2 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
DSPFL CMD
/* TO COMPILE */
/* CRTCMD CMD(*CURLIB/DSPFL) PGM(*LIBL/DIS) SRCFILE(*LIBL/QCMDSRC) */
/* SRCMBR(DSPFL) 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 DSPFL 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
DISPR RPG
H OPTIMIZE(*NONE) OPTION(*NODEBUGIO)
H DFTACTGRP(*NO) ACTGRP(*CALLER)
* FILE RELATIONS DISPLAYER
* REQUIRES FILES TO COMPILE
* CRTDUPOBJ OBJ(QAFDSELO) FROMLIB(QSYS)
* OBJTYPE(*FILE) TOLIB(QTEMP) NEWOBJ(SEL)
* CRTDUPOBJ OBJ(QAFDACCP) FROMLIB(QSYS)
* OBJTYPE(*FILE) TOLIB(QTEMP) NEWOBJ(ACC)
*
FREL IF E DISK
FSEL IF E DISK
FDISPRF CF E WORKSTN
F SFILE(S01:RS01)
F SFILE(S02:RS02)
F INFDS(SFINF)
*
*
DDISPR PR
D 10
D 10
DDISPR PI
D SFILE 10
D SLIB 10
// SCREEN LEVELS
D @SCN S 6 DIM(50)
D @NSCN S 6
D @LV S 5 0
D @ERR S LIKE(@TRUE)
D @FILE S 10A INZ('DISPY ')
D WRKSWS S 1
D I S 4B 0
D @TRUE S 1A INZ('1')
D @FALSE S 1A INZ('0')
D @OK S LIKE(@TRUE)
D @LOOP S LIKE(@TRUE)
//
D RS01 S 4S 0
D RS02 S 4S 0
//
// PARMS FOR SFL LOOPING
D SFC01 S LIKE(RS01)
D SFC02 S LIKE(RS01)
// Program Status
D SDS
D PGM 1 10
D WSID 244 253
D USER 254 263
//
//
D SFINF DS
D RRRN 376 377B 0
D SRN 378 379B 0
// MESSAGE DATA
D @DTA1 DS 80
D @DTA2 DS 500
//
D MAIN PR
D @S01BLD PR
D @S01PRC PR
D @S01PRS PR
D @S02BLD PR
D @S02PRC PR
D
D @R9999 PR
D @OPADJ PR 2A
D OPT 2A
/FREE
*INLR = *ON;
MAIN();
//--------------*INZSR-------------------------------//
BEGSR *INZSR;
// Set the TOP level (Exit if user backs up to here)
@LV = 1;
@SCN(@LV) = '*END ';
// Set the Initial Screen to display
@LV = @LV + 1;
@SCN(@LV) = 'S01BLD ';
ENDSR;
/END-FREE
//###################################################//
//*************************************************************
P MAIN B
D MAIN PI
D I S 4B 0
/FREE
EXSR @INZSR;
//
// THIS IS THE CONTROLLING LOOP TO DRIVE THE NEXT PANEL TO DISPLAY
DOW @LOOP = @LOOP;
// GET THE SCREEN NAME FROM THE SCREEN STACK ARRAY
@NSCN = @SCN(@LV);
SELECT;
// SELECT FIELDS FOR DISPLAY
// SFL TO SELECT THE FILE FIELDS
WHEN @NSCN = 'S01BLD';
@S01BLD();
WHEN @NSCN = 'S01PRC';
@S01PRC();
WHEN @NSCN = 'S01PRS';
@S01PRS();
WHEN @NSCN = 'S02BLD';
@S02BLD();
WHEN @NSCN = 'S02PRC';
@S02PRC();
OTHER;
// CATCH ALL (NEVER USED)
@R9999();
LEAVE;
ENDSL;
// CF3 EXIT
IF *IN03 = *ON;
LEAVE;
ENDIF;
// CF12 PREVIOUS
IF *IN12 = *ON;
*IN12 = *OFF;
@LV = @LV -1;
@NSCN = @SCN(@LV);
ENDIF;
// Backed out to last level, Exit
IF @NSCN = '*END';
LEAVE;
ENDIF;
ENDDO;
RETURN;
//--------------*INZSR-------------------------------//
BEGSR @INZSR;
@NSCN = *BLANK;
ENDSR;
//-ENDSR---*INZSR-------------------------------//
/END-FREE
P MAIN E
//###################################################//
//###################################################//
//###################################################//
/space 3
P @S01BLD B
D @S01BLD PI
D WFILE S LIKE(APFILE )
D WLIB S LIKE(APLIB )
// Build/Rebuild the subfile
/FREE
EXSR @INZSR;
EXSR BLD;
// SFL IS BUILT, PROCESS THE SFL CONTROL
@LV = @LV + 1;
@SCN(@LV) = 'S01PRC ' ;
RETURN ;
//-------------- BLD -------------------------------//
BEGSR BLD;
EXSR CLR;
SETLL 1 QWHFDACP;
DOW @LOOP = @LOOP;
READ QWHFDACP;
IF %EOF;
LEAVE;
ENDIF;
EXSR MOV;
//
RS01 = RS01 + 1;
WRITE S01;
ENDDO;
// Position to TOP of subfile
SRS01 = 1;
SFC01 = RS01;
ENDSR;
//-------------- CLR -------------------------------//
BEGSR CLR;
*IN51 = *OFF;
*IN52 = *OFF;
*IN53 = *ON;
WRITE C01;
*IN53 = *OFF;
RS01 = 0 ;
SFC01 = 0 ;
S01FUNC = *BLANK;
ENDSR;
//-------------- MOV -------------------------------//
BEGSR MOV;
C01APBOF = APBOF ;
C01APBOL = APBOL ;
IF APBOF = *BLANK AND APBOL = *BLANK;
C01APBOF = APFILE;
C01APBOL = APLIB;
ENDIF;
// Load the subfile record
IF APFILE = WFILE AND
APLIB = WLIB ;
*IN56 = *ON ;
S01APFILE = *BLANK;
S01APLIB = *BLANK;
S01APACCP = *BLANK;
S01APUNIQ = *BLANK;
S01APSELO = *BLANK;
S01APFTYP = *BLANK;
S01APJOIN = *BLANK;
S01APKEYO = *BLANK;
S01APKSEQ = APKSEQ ;
S01APKSIN = APKSIN ;
S01APKEYF = APKEYF ;
ELSE ;
WFILE = APFILE;
WLIB = APLIB ;
*IN56 = *OFF;
S01APFILE = APFILE ;
S01APLIB = APLIB ;
S01APACCP = APACCP ;
S01APUNIQ = APUNIQ ;
S01APSELO = APSELO ;
S01APFTYP = APFTYP ;
S01APJOIN = APJOIN ;
S01APKEYO = APKEYO ;
S01APKSEQ = APKSEQ ;
S01APKSIN = APKSIN ;
S01APKEYF = APKEYF ;
ENDIF;
ENDSR;
//--------------*INZSR-------------------------------//
BEGSR @INZSR;
@NSCN = *BLANK;
ENDSR;
/END-FREE
P @S01BLD E
//###################################################//
//###################################################//
/space 3
P @S01PRC B
D @S01PRC PI
//
//
D WRKRC S 4S 0
/FREE
EXSR @INZSR;
WRITE R01;
//
DOW @LOOP = @LOOP;
//
// Write SFL Control
IF SFC01 > 0;
*IN51 = *ON;
ENDIF;
*IN52 = *ON;
EXFMT C01;
// Setoff errors
*IN89 = *OFF;
//
// Exit and Previous Screen
IF *IN03 = *ON;
LEAVE;
ENDIF;
IF *IN12 = *ON;
LEAVE;
ENDIF;
// Process the subfile
@LV = @LV + 1;
@SCN(@LV) = 'S01PRS';
LEAVE;
ENDDO;
//
RETURN;
/space 3
//--------------*INZSR-------------------------------//
BEGSR @INZSR;
@NSCN = *BLANK;
ENDSR;
/END-FREE
P @S01PRC E
//###################################################//
//###################################################//
//###################################################//
/space 3
P @S01PRS B
D @S01PRS PI
//
//
D WRKRC S 4S 0
/FREE
EXSR @INZSR;
// Process the subfile
EXSR SFL;
RETURN;
//-------------- SFL -------------------------------//
BEGSR SFL;
// Process the subfile
FOR WRKRC = 1 TO SFC01 + 1 ;
CHAIN WRKRC S01;
IF NOT %FOUND;
// Finished with the subfile
@LV = @LV -1;
LEAVE;
ENDIF;
// GET SELECTED FILE
IF @OPADJ(S01FUNC) = ' X';
SFILE = S01APFILE;
SLIB = S01APLIB ;
*IN03 = '1';
LEAVE;
ENDIF;
// SHOW SELECT RULES
IF @OPADJ(S01FUNC) = ' R';
@LV = @LV + 1;
@SCN(@LV) = 'S02BLD ';
S01FUNC = ' ';
UPDATE S01;
LEAVE;
ENDIF;
ENDFOR;
ENDSR;
//---------------------------------------------------//
//--------------*INZSR-------------------------------//
BEGSR @INZSR;
@NSCN = *BLANK;
ENDSR;
/END-FREE
P @S01PRS E
/space 3
P @S02BLD B
D @S02BLD PI
// Build/Rebuild the subfile
/FREE
EXSR @INZSR;
C02APFILE = S01APFILE ;
C02APLIB = S01APLIB ;
EXSR BLD;
// SFL IS BUILT, PROCESS THE CONTROL
@LV = @LV + 1;
@SCN(@LV) = 'S02PRC ';
RETURN;
//-------------- BLD -------------------------------//
BEGSR BLD;
EXSR CLR;
SETLL 1 QWHFDSO ;
DOW @LOOP = @LOOP;
READ QWHFDSO ;
IF %EOF;
LEAVE;
ENDIF;
If SOFILE = S01APFILE AND
SOLIB = S01APLIB ;
EXSR MOV;
//
RS02 = RS02 + 1;
WRITE S02;
ENDIF;
ENDDO;
// Position to TOP of subfile
SRS02 = 1;
SFC02 = RS02;
ENDSR;
//-------------- CLR -------------------------------//
BEGSR CLR;
*IN51 = *OFF;
*IN52 = *OFF;
*IN53 = *ON;
WRITE C02;
*IN53 = *OFF;
RS02 =0;
SFC02=0;
ENDSR;
//-------------- MOV -------------------------------//
BEGSR MOV;
// Load the subfile record
S02SOFLD = SOFLD ;
S02SORULE = SORULE ;
S02SOCOMP = SOCOMP ;
S02SOVALU = SOVALU ;
ENDSR;
//--------------*INZSR-------------------------------//
BEGSR @INZSR;
@NSCN = *BLANK;
ENDSR;
/END-FREE
P @S02BLD E
//###################################################//
//###################################################//
//###################################################//
/space 3
P @S02PRC B
D @S02PRC PI
//
//
D WRKRC S 4S 0
/FREE
EXSR @INZSR;
WRITE R02;
//
DOW @LOOP = @LOOP;
//
// Write SFL Control
IF SFC02 > 0;
*IN51 = *ON;
ENDIF;
*IN52 = *ON;
EXFMT C02;
//
// Setoff errors
*IN89 = *OFF;
//
// Exit and Previous Screen
@LV = @LV -2;
LEAVE;
// Process the subfile
ENDDO;
//
RETURN;
/space 3
//--------------*INZSR-------------------------------//
BEGSR @INZSR;
@NSCN = *BLANK;
ENDSR;
/END-FREE
P @S02PRC E
//###################################################//
//###################################################//
//###################################################//
P @R9999 B
// Invalid Panel
D @R9999 PI
P @R9999 E
/space 3
//###################################################//
//###################################################//
//###################################################//
P @OPADJ B
// RIGHT ADJ OPTION , zero suppress
D @OPADJ PI 2A
D OPT 2A
/FREE
EVALR OPT = %trimr(OPT);
If %SubSt(OPT:1:1) = '0';
OPT = ' ' + %SubSt(OPT:2:1);
EndIf;
RETURN OPT;
/END-FREE
P @OPADJ E
//###################################################//
//###################################################//
DISPRF DSPF
A*%%TS SD 20101208 163705 KOLMANNF REL-V5R4M0 5722-WDS
A*
* REQUIRES FILES TO COMPILE
* CRTDUPOBJ OBJ(QAFDSELO) FROMLIB(QSYS)
* OBJTYPE(*FILE) TOLIB(QTEMP) NEWOBJ(SEL)
* CRTDUPOBJ OBJ(QAFDACCP) FROMLIB(QSYS)
* OBJTYPE(*FILE) TOLIB(QTEMP) NEWOBJ(ACC)
A*%%EC
A DSPSIZ(24 80 *DS3)
A PRINT
A CF03(03)
A CF12(12)
A R S01 SFL
A*%%TS SD 20101208 163705 KOLMANNF REL-V5R4M0 5722-WDS
A S01FUNC 2A I 4 3
A 55
AO 56 DSPATR(PR)
A S01APFILE R O 4 6REFFLD(QWHFDACP/APFILE QTEMP/REL)
A S01APLIB R O 4 17REFFLD(QWHFDACP/APLIB QTEMP/REL)
A S01APACCP R O 4 29REFFLD(QWHFDACP/APACCP QTEMP/REL)
A S01APUNIQ R O 4 33REFFLD(QWHFDACP/APUNIQ QTEMP/REL)
A S01APSELO R O 4 37REFFLD(QWHFDACP/APSELO QTEMP/REL)
A S01APFTYP R O 4 41REFFLD(QWHFDACP/APFTYP QTEMP/REL)
A S01APJOIN R O 4 45REFFLD(QWHFDACP/APJOIN QTEMP/REL)
A S01APKEYO R O 4 48REFFLD(QWHFDACP/APKEYO QTEMP/REL)
A S01APKSEQ R O 4 53REFFLD(QWHFDACP/APKSEQ QTEMP/REL)
A S01APKSIN R O 4 57REFFLD(QWHFDACP/APKSIN QTEMP/REL)
A S01APKEYF R O 4 61REFFLD(QWHFDACP/APKEYF QTEMP/REL)
A R C01 SFLCTL(S01)
A*%%TS SD 20101208 163705 KOLMANNF REL-V5R4M0 5722-WDS
A SFLSIZ(0019)
A SFLPAG(0018)
A OVERLAY
A 50 SFLEND
A 51 SFLDSP
A 52 SFLDSPCTL
A 53 SFLCLR
A SRS01 4S 0H SFLRCDNBR(CURSOR)
A*
A 1 18'FILE RELATIONS for '
A C01APBOF R O 1 39REFFLD(QWHFDACP/APBOF QTEMP/REL)
A 1 51'Lib.'
A C01APBOL R O 1 56REFFLD(QWHFDACP/APBOL QTEMP/REL)
A 2 32'Uni SEL LIFO ASC Key'
A 3 6'File Library Acc Key OMT -
A TYP J FIFO DSC Sgn Key'
A R R01
A 24 3'F3-Exit'
A 22 3'R - Display Select/Omit rules'
A 23 3'X - Select for display'
*
A R R02
A 24 3'F3-Exit'
A R S02 SFL
A SFLNXTCHG
A S02SOFLD R O 4 4REFFLD(QWHFDSO/SOFLD QTEMP/SEL)
A S02SORULE R O 4 17REFFLD(QWHFDSO/SORULE QTEMP/SEL)
A S02SOCOMP R O 4 22REFFLD(QWHFDSO/SOCOMP QTEMP/SEL)
A S02SOVALU R O 4 28REFFLD(QWHFDSO/SOVALU QTEMP/SEL)
A R C02 SFLCTL(S02 )
A OVERLAY
A 50 SFLEND
A 51 SFLDSP
A 52 SFLDSPCTL
A 53 SFLCLR
A SFLSIZ(0019)
A SFLPAG(0018)
A SRS02 4S 0H SFLRCDNBR(CURSOR)
A*
A 1 6'FILE SELECTS for '
A C02APFILE R O 2 7REFFLD(QWHFDSO/SOFILE QTEMP/SEL)
A 2 20'Lib.'
A C02APLIB R O 2 25REFFLD(QWHFDSO/SOLIB QTEMP/SEL)
A 3 4'Field'
A 3 28'Select/Omit Value'
A 3 16'S/O'
A 3 21'COMP'
DISPY RPG
H OPTIMIZE(*NONE) OPTION(*NODEBUGIO)
H DFTACTGRP(*NO) ACTGRP(*CALLER)
//***************************************************************
//
// PROGRAM ID : DISPY
// Description: DISPLAY A FILES FIELDS FOR SELECTION
// needs files KF FFD to compile use following commands
// DSPFD (&LIB/&FILE) TYPE(*ACCPTH) OUTPUT(*OUTFILE) OUTFILE(QTEMP/KF)
// DSPFFD FILE(&LIB/&FILE) OUTPUT(*OUTFILE) OUTFILE(QTEMP/FFD)
//***************************************************************
// MODIFICATIONS:
// MOD SR DATE MODIFICATION SUMMARY
//
//***************************************************************
//
FKF IF E DISK
FFFD UF E DISK
FINPUT IF F32766 2000AIDISK KEYLOC(1)
F INFDS(INFDS)
FDISPYF CF E WORKSTN
F SFILE(S01:RS01)
F INFDS(SFINF)
//
//
// SCREEN LEVELS
D @SCN S 6 DIM(50)
D @NSCN S 6
D @LV S 5 0
D @ERR S LIKE(@TRUE)
D @FILE S 10A INZ('DISPY ')
D WRKSWS S 1
D I S 4B 0
D @TRUE S 1A INZ('1')
D @FALSE S 1A INZ('0')
D @OK S LIKE(@TRUE)
D @LOOP S LIKE(@TRUE)
//
D RS01 S 4S 0
//
// PARMS FOR SFL LOOPING
D SFC01 S LIKE(RS01)
// Program Status
D SDS
D PGM 1 10
D WSID 244 253
D USER 254 263
//
//
D SFINF DS
D RRRN 376 377B 0
D SRN 378 379B 0
//
D FLD S 10 DIM(9000)
D KEY S 10 DIM(99)
D INFDS DS
D FILE 83 92
D LIB 93 102
D MBR 129 138
D RCDL 125 126B 0
D RCDS 156 159B 0
D ACCTP 160 160
D DS
D WHCOLD 1 60
D WHCHD1 1 20
D WHCHD2 21 40
D WHCHD3 41 60
D DS
D POSN 1 10
D P1 1 10 DIM(10)
D POSNN 11 20
D P2 11 20 DIM(10)
*
// MESSAGE DATA
D @DTA1 DS 80
D @DTA2 DS 500
//
D MAIN PR
D @S01BLD PR
D @S01PRC PR
D @S01PRS PR
D
D @R9999 PR
D @OPADJ PR 2A
D OPT 2A
*
DDISPY PR
D 1
D 1
D 4
D 1
D 1
D 5
DDISPY PI
D ALL 1
D RTN 1
D KEYLNG 4
D ACCP 1
D QRY 1
D RCDLN 5
*
D KEYLN S 4S 0
D RCDLEN S 5S 0
*-------------------------------------------------------------------
* QMHRTVM API (Retrieve Message text)
*-------------------------------------------------------------------
D RtvMsgTxt PR 1024
D RMsgId 7 Const
D RMsgFle 10 Const
D RMsgLib 10 Const
D RMsgLvl 1 Const
D GETROWCOL PR
D 10A const
D 10A const
D 10A const
D 32A const
D 3P 0
D 3P 0
D SysDate PR 8S 0
D SysTime PR 6S 0
D DayOfWeek PR 10I 0
D D value datfmt(*iso)
// Message file names
D cMsgLib C Const('*LIBL ')
D cMsgF1 C Const('MSGF1 ')
D cMsgF2 C Const('MSGF2 ')
D cMsgLvl1 C Const('1')
D cMsgLvl2 C Const('2')
*
IINPUT NS 01
I 1 256 D
/FREE
*INLR = *ON;
MAIN();
//--------------*INZSR-------------------------------//
BEGSR *INZSR;
// Set the TOP level (Exit if user backs up to here)
@LV = 1;
@SCN(@LV) = '*END ';
// Set the Initial Screen to display
@LV = @LV + 1;
@SCN(@LV) = 'S01BLD ';
// DUMMY I/O TO GET NUMBER OF RECORDS IN FILE
READ INPUT;
// SFL IS NOT LOADED
// READ THE LIST OF KEY FIELDS IN THE FILE SO THAT WE CAN LATER MARK THEM
ACCP = ACCTP;
I = 0;
DOW @LOOP = @LOOP;
READ QWHFDACP;
IF %EOF;
LEAVE;
ENDIF;
I = I + 1;
KEY(I) = APKEYF;
ENDDO;
ENDSR;
/END-FREE
//###################################################//
//*************************************************************
P MAIN B
D MAIN PI
D I S 4B 0
/FREE
EXSR @INZSR;
//
// THIS IS THE CONTROLLING LOOP TO DRIVE THE NEXT PANEL TO DISPLAY
DOW @LOOP = @LOOP;
// GET THE SCREEN NAME FROM THE SCREEN STACK ARRAY
@NSCN = @SCN(@LV);
SELECT;
// SELECT FIELDS FOR DISPLAY
// SFL TO SELECT THE FILE FIELDS
WHEN @NSCN = 'S01BLD';
@S01BLD();
WHEN @NSCN = 'S01PRC';
@S01PRC();
WHEN @NSCN = 'S01PRS';
@S01PRS();
OTHER;
// CATCH ALL (NEVER USED)
@R9999();
LEAVE;
ENDSL;
// CF3 EXIT
IF *IN03 = *ON;
LEAVE;
ENDIF;
// CF12 PREVIOUS
IF *IN12 = *ON;
*IN12 = *OFF;
@LV = @LV -1;
@NSCN = @SCN(@LV);
ENDIF;
// Backed out to last level, Exit
IF @NSCN = '*END';
LEAVE;
ENDIF;
ENDDO;
KEYLNG = %EDITC(KEYLN:'X');
RETURN;
//--------------*INZSR-------------------------------//
BEGSR @INZSR;
@NSCN = *BLANK;
RCDLEN = RCDL;
RCDLN = %CHAR(RCDLEN);
// CLEAR FIELD SELECTIONS
IF RTN = '2';
SETLL 1 QWHDRFFD;
DOW @LOOP = @LOOP;
READ QWHDRFFD ;
IF %EOF;
LEAVE;
ENDIF;
WHFIOB = ' ';
UPDATE QWHDRFFD;
ENDDO;
// SET FILE I/O TO FIRST RCD IN FILE
SETLL 1 QWHDRFFD;
RTN = '0';
ELSE;
CHAIN 1 QWHDRFFD;
SETLL 1 QWHDRFFD;
ENDIF;
ENDSR;
//-ENDSR---*INZSR-------------------------------//
/END-FREE
P MAIN E
//###################################################//
//###################################################//
//###################################################//
/space 3
P @S01BLD B
D @S01BLD PI
D SZ DS 6
D LEN1 1 1
D LEN2 2 3
D LEN3 1 3
D COMA 4 4
D DEC1 5 5
D DEC2 5 6
D DS
D K 1 3 0
D KA 2 3
// Build/Rebuild the subfile
/FREE
EXSR @INZSR;
EXSR BLD;
// SFL IS BUILT, PROCESS THE SFL CONTROL
@LV = @LV + 1;
@SCN(@LV) = 'S01PRC ' ;
RETURN ;
//-------------- BLD -------------------------------//
BEGSR BLD;
EXSR CLR;
DOW @LOOP = @LOOP;
READ QWHDRFFD;
IF %EOF;
LEAVE;
ENDIF;
EXSR MOV;
// FLAG THE KEY FIELDS
K = %LOOKUP(WHFLDE :KEY);
WHDFTL = K ;
UPDATE QWHDRFFD;
RS01 = RS01 + 1;
WRITE S01;
ENDDO;
// Position to TOP of subfile
SRS01 = 1;
SFC01 = RS01;
ENDSR;
//-------------- CLR -------------------------------//
BEGSR CLR;
I = 0;
CLEAR FLD;
KEYLN = 0;
*IN51 = *OFF;
*IN52 = *OFF;
*IN53 = *ON;
WRITE C01;
*IN53 = *OFF;
RS01 = 0 ;
SFC01 = 0 ;
S01OPT= *BLANK;
ENDSR;
//-------------- MOV -------------------------------//
BEGSR MOV;
// Load the subfile record
S01OPT = WHFIOB ;
S01WHFLDB = WHFLDB;
S01WHFLDT = WHFLDT;
S01WHFLD = WHFLDE ;
S01SFLD = WHFLDE ;
S01FROM = WHFOBO;
S01TO = WHFLDB + WHFOBO -1 ;
// KEY FIELDS
S01KEYFLD = ' ';
K = %LOOKUP(WHFLDE :KEY);
IF K <> 0;
S01KEYFLD = KA;
IF K < 10;
%SUBST(S01KEYFLD:1:1) = 'K';
ENDIF;
KEYLN = KEYLN + WHFLDB;
ENDIF;
// FORMAT THE FIELD LENGTH
S01SIZE = ' ';
SZ = ' ';
IF WHFLDD = 0;
LEN3 = %SUBST(%EDITC(WHFLDB:'Z'):3:3);
ELSE;
LEN2 = %EDITC(WHFLDD:'Z') ;
COMA = ',';
IF WHFLDP > 9;
DEC2 = %CHAR(WHFLDP);
ELSE;
DEC1 = %CHAR(WHFLDP);
ENDIF;
ENDIF;
IF LEN1 = '0';
LEN1 = ' ';
ENDIF;
S01SIZE = SZ;
S01DESC = WHFTXT;
IF S01DESC= ' ';
S01DESC = WHCOLD ;
ENDIF;
I = I + 1;
FLD(I) = S01WHFLD;
ENDSR;
//--------------*INZSR-------------------------------//
BEGSR @INZSR;
@NSCN = *BLANK;
ENDSR;
/END-FREE
P @S01BLD E
//###################################################//
//###################################################//
/space 3
P @S01PRC B
D @S01PRC PI
//
//
D WRKRC S 4S 0
D C01CHK S LIKE(C01POSN)
/FREE
EXSR @INZSR;
WRITE R01;
//
DOW @LOOP = @LOOP;
//
// Write SFL Control
IF SFC01 > 0;
*IN51 = *ON;
ENDIF;
*IN52 = *ON;
EXFMT C01;
// Setoff errors
*IN89 = *OFF;
//
// Exit and Previous Screen
IF *IN03 = *ON;
RTN = '1';
LEAVE;
ENDIF;
IF *IN12 = *ON;
@LV = @LV -1;
LEAVE;
ENDIF;
// Set up for qry selection and exit
IF *IN06 = *ON;
*IN03 = *ON;
QRY = '1';
LEAVE;
ENDIF;
// POSITION
IF C01POSN <> ' ';
EXSR POS;
ITER;
ENDIF;
// Process the subfile
@LV = @LV + 1;
@SCN(@LV) = 'S01PRS';
LEAVE;
ENDDO;
//
RETURN;
/space 3
//--------------POS -------------------------------//
BEGSR POS;
FOR WRKRC = 1 TO SFC01;
CHAIN WRKRC S01;
IF NOT %FOUND;
LEAVE;
ENDIF;
C01CHK = %SUBST(S01WHFLD :1 : %LEN(%TRIM(C01POSN)));
IF (C01POSN = C01CHK );
SRS01 = WRKRC;
LEAVE;
ENDIF;
ENDFOR;
ENDSR;
//--------------*INZSR-------------------------------//
BEGSR @INZSR;
@NSCN = *BLANK;
C01FILE = FILE;
C01LIB = LIB;
C01MBR = MBR;
C01RCDL = RCDL;
C01ACCTP = ACCTP;
C01WHTEXT = WHTEXT;
C01RCORDS = RCDS;
C01POSN = ' ' ;
C01WHNAME = WHNAME;
ENDSR;
/END-FREE
P @S01PRC E
//###################################################//
//###################################################//
//###################################################//
/space 3
P @S01PRS B
D @S01PRS PI
//
//
D WRKRC S 4S 0
D FX S 5S 0
/FREE
EXSR @INZSR;
// Process the subfile
EXSR SFL;
*IN03 = '1';
RETURN;
//-------------- SFL -------------------------------//
BEGSR SFL;
// Process the subfile
FOR WRKRC = 1 TO SFC01+1;
CHAIN WRKRC S01;
IF NOT %FOUND;
// Finished with the subfile
// RETURN TO REBUILD LEVEL
@LV = @LV -2;
LEAVE;
ENDIF;
// RIGHT ADJUST OPTION
S01OPT = @OPADJ(S01OPT);
// UPDATE SELECTIONS
EXSR UPD;
ENDFOR;
ENDSR;
//---------------------------------------------------//
//--------------UPD ---------------------------------//
BEGSR UPD;
// UPDATE FIELD NAMES AND SELECT FLAG
FX = %LOOKUP(S01SFLD :FLD);
CHAIN FX QWHDRFFD;
WHFLDE = S01WHFLD;
IF @OPADJ(S01OPT) = ' S' OR
@OPADJ(S01OPT) = ' O';
ALL = %TRIM(S01OPT);
WHFIOB = %TRIM(S01OPT);
ENDIF;
IF @OPADJ(S01OPT) = ' ';
WHFIOB = ' ';
ENDIF;
UPDATE QWHDRFFD;
ENDSR;
//--------------*INZSR-------------------------------//
BEGSR @INZSR;
ALL = '1';
@NSCN = *BLANK;
ENDSR;
/END-FREE
P @S01PRS E
//###################################################//
//###################################################//
//###################################################//
P @R9999 B
// Invalid Panel
D @R9999 PI
P @R9999 E
/space 3
//###################################################//
//###################################################//
//###################################################//
P @OPADJ B
// RIGHT ADJ OPTION , zero suppress
D @OPADJ PI 2A
D OPT 2A
/FREE
EVALR OPT = %trimr(OPT);
If %SubSt(OPT:1:1) = '0';
OPT = ' ' + %SubSt(OPT:2:1);
EndIf;
RETURN OPT;
/END-FREE
P @OPADJ E
//###################################################//
//###################################################//
//###################################################//
P RtvMsgTxt B
//************************************************************************
// API Call: QMHRTVM Retrieve Message text
//************************************************************************
// USAGE
// MsgTxt = RtvMsgTxt('MSG0001':cMsgF3:cMsgLib:cMsgLvl1);
D RtvMsgTxt PI 1024
D RMsgId 7 Const
D RMsgFle 10 Const
D RMsgLib 10 Const
D RMsgLvl 1 Const
// Retrieve Message Description API Prototype
D Get_Message PR ExtPgm('QMHRTVM')
D 4000 Options(*VarSize)
D 10I 0 Const
D 8 Const
D 7
D 20 Const
D 32765 Options(*VarSize)
D 10I 0 Const
D 10 Const
D 10 Const
D 8192 Options(*VarSize)
D 10
D 9B 0
D 9B 0
// Define Variables for QMHRTVM API call:
// --------------------------------------
// Return variables
D MessageInfo DS 4000
D Data 1 4000
D OSMSG 65 68B 0
D LMsgR 69 72B 0
D LMsgA 73 76B 0
D OSMSGH 77 80B 0
D LMsgHR 81 84B 0
D LMsgHA 85 88B 0
// Required input variables
D MessageLen S 10I 0
D MessageForm S 8
D MessageIden S 7
D MessageFile S 20
D Replacement S 32765
D ReplaceLen S 10I 0
D ReplaceSub S 10
D ReturnCtl S 10
D RetrieveOpt S 10
D ConvToCCSID S 9B 0
D ReplDtaCCSID S 9B 0
D Return_Text S 1024
D ErrorCode DS Qualified
D BytesProv 4B 0 Inz(0)
D BytesAvail 8B 0 Inz(0)
D ExceptionId 7
D Reserved 1
D ExceptionDta 512
/FREE
// Load API parameter fields
MessageInfo = *blanks;
MessageLen = 4000;
MessageForm = 'RTVM0300';
MessageIden = RMsgId;
MessageFile = RMsgFle + RMsgLib;
Replacement = *blanks;
ReplaceLen = %Len(Replacement);
ReplaceSub = '*YES';
ReturnCtl = '*YES';
RetrieveOpt = '*MSGID';
ConvToCCSID = 0;
ReplDtaCCSID = 0;
// Retrieve message description
Get_Message(MessageInfo :
MessageLen :
MessageForm :
MessageIden :
MessageFile :
Replacement :
ReplaceLen :
ReplaceSub :
ReturnCtl :
ErrorCode :
RetrieveOpt :
ConvToCCSID :
ReplDtaCCSID);
// Process Return variables
Return_Text = *blanks;
// If no errors, determine the correct portion of the message text
If ErrorCode.BytesProv = 0;
Select;
When RMsgLvl = '1';
Return_Text = %Subst(data:OSMSG+1:LMsgA); // Msg Lvl 1
When RMsgLvl = '2';
Return_Text = %Subst(data:OSMSGH+1:LMsgHA); // Msg Lvl 2
EndSl;
Else;
Return_Text = 'Get_Message failed.';
EndIf;
// Return to calling point
Return Return_Text;
/END-FREE
P E
//###################################################//
//###################################################//
//###################################################//
P GETROWCOL B
*
* Retreive a DSPF FIELD Row and Col
* Used for Setting CSRLOC for cursor positioning
* USAGE
* GETROWCOL (FILE :'*LIBL' : FORMAT : FLDNAM : ROW : COL)
*
D GETROWCOL PR
D schFile 10A const
D schLib 10A const
D schFormat 10A const
D schString 32A const
D rtnROW 3P 0
D RtnCOL 3P 0
D GETROWCOL PI
D schFile 10A const
D schLib 10A const
D schFormat 10A const
D schString 32A const
D rtnROW 3P 0
D RtnCOL 3P 0
D QUSCRTUS PR ExtPgm('QUSCRTUS')
D UserSpace 20A CONST
D ExtAttrib 10A CONST
D InitialSize 10I 0 CONST
D InitialVal 1A CONST
D PublicAuth 10A CONST
D Text 50A CONST
D Replace 10A CONST options(*nopass)
D ErrorCode 32767A options(*varsize:*nopass)
D QUSPTRUS PR ExtPgm('QUSPTRUS')
D UserSpace 20A CONST
D Pointer *
D QUSDLTUS PR ExtPgm('QUSDLTUS')
D UserSpace 20A CONST
D ErrorCode 32767A options(*varsize)
D QUSLFLD PR ExtPgm('QUSLFLD')
D UsrSpc 20A const
D Format 8A const
D QualFile 20A const
D RcdFmt 10A const
D UseOvrd 1A const
D ErrorCode 32767A options(*nopass:*varsize)
D ErrorCode ds qualified
D BytesProv 10I 0 inz(0)
D BytesAvail 10I 0 inz(0)
D ListHeader ds based(p_ListHeader)
d ListOffset 10I 0 overlay(ListHeader:125)
d EntryCount 10I 0 overlay(ListHeader:133)
d EntrySize 10I 0 overlay(ListHeader:137)
D Field ds based(p_Field)
D qualified
D Name 10a
D FILLER 438a
d DspRow 10i 0
d DspCol 10i 0
D TEMPSPC C 'GETROWCOL QTEMP'
D x s 10I 0
/free
rtnrow = 999;
rtnrow = 999;
// --------------------------------------------------
// Delete the user space if it exists (ignore errors)
ErrorCode.BytesProv = %size(ErrorCode);
QUSDLTUS( TEMPSPC: ErrorCode );
ErrorCode.BytesProv = 0;
// --------------------------------------------------
// Create a new 128k user space
QUSCRTUS( TEMPSPC : 'SCHTEXT' : 128 * 1024 : x'00'
: '*EXCLUDE' : 'List of fields in file' : '*NO'
: ErrorCode );
// --------------------------------------------------
// Dump list of fields in file to user space
// Invaid data is ignored an 999 returned for row and col
monitor;
QUSLFLD( TEMPSPC : 'FLDL0100' : SchFile + SchLib
: SchFormat : *OFF : ErrorCode );
on-Error;
RETURN;
EndMon;
// --------------------------------------------------
// Get a pointer to the user space
QUSPTRUS( TEMPSPC: p_ListHeader );
// --------------------------------------------------
// Loop through all fields in space, to get the field we need
for x = 0 to (EntryCount - 1);
p_Field = p_ListHeader + ListOffset + (EntrySize * x);
if Field.Name = schString;
rtnRow = Field.DspRow;
rtnCol = Field.DspCol;
leave;
endif;
endfor;
// --------------------------------------------------
// Delete temp user space & end
QUSDLTUS( TEMPSPC: ErrorCode );
return;
/end-free
P E
DISPYF DSPF
A*%%TS SD 20101203 131649 KOLMANNF REL-V5R4M0 5722-WDS
A* 90/01/08 12:52:36 REL-R01M02 5728-PW1
A* 16:33:07 REL-R08M00 5714-UT1
A*%%EC
A DSPSIZ(24 80 *DS3)
A REF(*LIBL/QADSPFFD)
A PRINT
A CA03(03 'End of job')
A CA12(12 'Previous')
A CA04(04 'Add FIELDS')
A CA05(05 'Attr changes')
A CF06(06 'Field Select')
A CA07(07 'Name changes')
A*****
A* 15:04:39 REL-R08M00 5714-UT1
A R S01 SFL
A*%%TS SD 20101203 131649 KOLMANNF REL-V5R4M0 5722-WDS
A 40 SFLNXTCHG
A S01OPT 2A B 7 2
A S01KEYFLD 2A O 7 5DSPATR(HI)
A S01WHFLD R B 7 8REFFLD(WHFLDI)
A 23 DSPATR(HI)
A N23 DSPATR(PR)
A S01WHFLDB R B 7 19REFFLD(WHFLDB)
A EDTCDE(Z)
A 25 DSPATR(HI)
A N25 DSPATR(PR)
A S01SIZE 6A O 7 25
A S01FROM 4Y 0O 7 32EDTCDE(Z)
A S01TO 4Y 0O 7 37EDTCDE(Z)
A S01DESC 35A O 7 44
A S01WHFLDT R B 7 42REFFLD(WHFLDT)
A 25 DSPATR(HI)
A N25 DSPATR(PR)
A S01SFLD R H REFFLD(WHFLDI)
A*****
A*
A R C01 SFLCTL(S01)
A*%%TS SD 20101203 131649 KOLMANNF REL-V5R4M0 5722-WDS
A SFLSIZ(0015)
A SFLPAG(0014)
A 88 CSRLOC(ROW01 COL01)
A OVERLAY
A TEXT('WORK WITH FIELDS')
A 51 SFLDSP
A 52 SFLDSPCTL
A 53 SFLCLR
A 99 SFLEND
A SRS01 4S 0H SFLRCDNBR(CURSOR)
A*
A 89 C01MSG 79 M
A ROW01 3S 0H
A COL01 3S 0H
A 1 3'File'
A C01FILE 10A O 1 8DSPATR(HI)
A 1 20'Lib'
A C01LIB 10A O 1 24DSPATR(HI)
A 1 37'Mbr'
A C01MBR 10A O 1 41DSPATR(HI)
A 1 53'Rcdlen'
A C01RCDL 4S 0O 1 60DSPATR(HI)
A 1 66'Access'
A C01ACCTP 1A O 1 73DSPATR(HI)
A 2 3'Text'
A C01WHTEXT R O 2 9REFFLD(WHTEXT)
A DSPATR(HI)
A 2 60'#Records'
A C01RCORDS 7Y 0O 2 69DSPATR(HI)
A EDTCDE(Z)
A C01POSN 10A I 3 7
A 4 2'Select/Omit (S/O) fields for displ-
A ay.(Default *ALL)'
A 5 11'Use Select Or Omit,not Select with-
A Omit'
A 6 8'Name Bytes Size From To T-
A p Description'
A 4 54'Format'
A C01WHNAME R O 4 61REFFLD(QWHDRFFD/WHNAME)
A DSPATR(HI)
A R R01
A 23 2'F3-Exit F6-Data Sel'
