Difference between revisions of "UDDS File Display/Update"
From MidrangeWiki
| Line 4: | Line 4: | ||
==UDDS UNDER CONSTRUCTION MORE CODE TO BE ADDED SOON == | ==UDDS UNDER CONSTRUCTION MORE CODE TO BE ADDED SOON == | ||
The manual that describes the 5250 data stream is 5494 Remote Control Unit, Functions Reference. SC30-3533-04 (topic 15) [http://tn5250.sourceforge.net/resources.html] | The manual that describes the 5250 data stream is 5494 Remote Control Unit, Functions Reference. SC30-3533-04 (topic 15) [http://tn5250.sourceforge.net/resources.html] | ||
| − | |||
Revision as of 12:37, 27 October 2018
Contents
UDDS UNDER CONSTRUCTION MORE CODE TO BE ADDED SOON
The manual that describes the 5250 data stream is 5494 Remote Control Unit, Functions Reference. SC30-3533-04 (topic 15) [1]
The purpose of this program is to demo an example of a program using UDDS.
It shows file data, but is limited to 6048 max rcdlen.
Use the code below at your own risk, no warranty is expressed or implied or even that the code is functional.
I am also inculding wrapper programs to make the displayer more useful, but there is no 'make' instruction. I am assuming you know enough about compiling source to figure it out for yourself. Once compiled the command to run it is 'DSPFL yourlib/yourfile '
DISP RPG
H*eywords++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++Comments+++++++++++
H OPTION(*NODEBUGIO)
H DFTACTGRP(*NO) ACTGRP(*CALLER) DFTNAME(DISP )
F*
F* LIMITED TO MAXIMUM FILE LENGTH OF 2048
F* TEST
FFFD IF E DISK
FDISPF CF F 803 WORKSTN
F*
F INFDS(INFDS)
FINPUTK IF F32766 800AIDISK KEYLOC(1)
F EXTIND(*INU1)
F INFDS(INFDK)
FINPUTR IF F32766 DISK EXTIND(*INU2)
F INFDS(INFDR)
*
D A S 255 WORK RU
D RU S 255 varying
D RW S 1 ROW 1 byte binary
D CL S 1 COL 1 byte binary
D FNC S 1
D OUTLEN S 2
D INLEN S 2
D IPL S 5 0
D ROW S 3 0
D XROW S 3 0
D COL S 3 0
D KEYSOK S 1
D LENDSC S 3 0
D LENWRK S 5 0
D STRX S 5 0
D ENDX S 5 0
D VX S 5 0
D X S 5 0
D X1 S 5 0
D X2 S 5 0
D XX S 5 0
D XP S 5 0
D MX S 5 0
D ONCE S 1
D RBA S 2
D LF S 5 0
D ST S 5 0
D Y S 5 0
D Z S 5 0
D OFF S 5 0
D SUPZ S 1
D NUMFLD S 5 0
D WX S 5 0
D NUMKEY S 5 0
D NUMFKY S 5 0
D SCRST S 10
D SCRSTN S 1
D KEYA S 800
D RRNA S 11 0
D RRN S 11 0
D REHEAD S 1
D NEWRU S 1
D WRTRRN S 1
D LVX S 5 0
D LVL S 5 0
D K1 S 5 0
D K2 S 5 0
D Z1 S 5 0
D W S 5 0
D WK2 S 2
D MSSG S 32
*
D BASE S 5 0
D INZ S 1
D FILE S 10
D LIB S 10
D MBR S 10
D RCDL S 5 0
D ACCTP S 1
D RLEN S 5 0
D RLENTH S 5
D LENF S 5 0
D DS
D TEXT500 500
D LVW 10 DIM(50) overlay(TEXT500:1)
D TEXT800 S 800
D KW S 800
D DS
D WRK11 1 11
D NUM11 1 11S 0
D DS
D NUSA 1 60
D NUS 1 60S 0
D DS
D NUPA 1 60
D NUP 29 60P 0
D WRU S 61
D WRX S 64
D WRXWRD C '0 -
D -'
D WRSWRD C '0 -
D -'
D WRV S 60 varying
D FLT14 S 14
D FLT23 S 23
* SET FILE SIZE INCREMENTS (64 OF THEM)
D SZ S 5 0 DIM(64)
D S S 5 0 DIM(9000) START OF FLD
D E S 5 0 DIM(9000) END OF FLD
D Q S 5 0 DIM(9000) BYTES IN FIELD
D L S 5 0 DIM(9000) LENGTH OF FLD
D C S 3 0 DIM(9000) DEC DIGITS
D P S 3 0 DIM(9000) DEC PRECISION
D B S 2 DIM(9000) ASCEND BUFFER ADD
D I S 2 DIM(9000) FLD FMT
D N S 10 DIM(9000) FLD NAME
D T S 1 DIM(9000) FLD TYPE
D V S 1 DIM(9000) VARYING
D KY S 1 DIM(9000) KEYED
D KE S 10 DIM(128) KEY FLDS
D R S 3 0 DIM(9000) KEY FLD START
D K S 1 DIM(800) KEY
D NA S 1 DIM(10) NAME WORK
D NU S 1 DIM(60) NUM. WORK
D LV S 10 DIM(50) SCREEN LEVELS
D MSG S 32 DIM(8) CTDATA PERRCD(1) MESSAGES
D CNS S 50 DIM(2) CTDATA PERRCD(1)
D CRS S 1 DIM(16) CTDATA PERRCD(16)
D DS
D D 1 2048
D DIM(2048) INCOMING DATA
D DA 1 16
D DB 17 32
D DC 33 64
D DD 65 96
D DE 97 128
D DF 129 160
D DG 161 192
D DH 193 224
D DI 225 256
D DJ 257 288
D DK 289 320
D DL 321 352
D DM 353 384
D DN 385 416
D DZ 417 448
D DO 449 480
D DP 481 512
D DQ 513 544
D DR 545 576
D DS 577 608
D DT 609 640
D DU 641 672
D DV 673 704
D DW 705 736
D DX 737 768
D DY 769 800
D D0 801 832
D D1 833 864
D D2 865 896
D D3 897 928
D D4 929 960
D D5 961 992
D D6 993 1024
D DBA 1025 1056
D DCA 1057 1088
D DDA 1089 1120
D DEA 1121 1152
D DFA 1153 1184
D DGA 1185 1216
D DHA 1217 1248
D DIA 1249 1280
D DJA 1281 1312
D DKA 1313 1344
D DLA 1345 1376
D DMA 1377 1408
D DNA 1409 1440
D DOA 1441 1472
D DPA 1473 1504
D DQA 1505 1536
D DRA 1537 1568
D DSA 1569 1600
D DTA 1601 1632
D DUA 1633 1664
D DVA 1665 1696
D DWA 1697 1728
D DXA 1729 1760
D DYA 1761 1792
D DZA 1793 1824
D D0A 1825 1856
D D1A 1857 1888
D D2A 1889 1920
D D3A 1921 1952
D D4A 1953 1984
D D5A 1985 2016
D D6A 2017 2048
D DS
D ID 1 800
D DIM(800) INCOMING DATA
D IDA 1 800
D ID0 1 80
D ID1 81 160
D ID2 161 240
D ID3 241 320
D ID4 321 400
D ID5 401 480
D ID6 481 560
D ID7 561 640
D ID8 641 720
D ID9 721 800
D DS
D BIN 1 2B 0
D HX1 2 2
D HX2 1 2
D DS
D PCK 1 1P 0
D PCK1 1 1
D DS
D SGN 1 1S 0
D SGN1 1 1
D DS
D BIN4 1 4B 0
D BY4 1 4
D DS
D BIN2 1 2B 0
D BY2 1 2
D DS
D FLT4 1 4F
D FL4 1 4
D DS
D FLT8 1 8F
D FL8 1 8
D INFDK DS
D F1 83 92
D L1 93 102
D M1 129 138
D R1 125 126B 0
D A1 160 160
D LOP1 260 260
D KEY_LEN 393 394I 0 Key length
D RN1 397 400B 0
D LKY 401 1200
D INFDR DS
D F2 83 92
D L2 93 102
D M2 129 138
D R2 125 126B 0
D A2 160 160
D LOP2 260 260
D RN2 397 400B 0
D*
D INFDS DS
D CURLOC 370 371
D DS
D KEYLN 1 4S 0
D KEYLNA 1 4
DDISP PR
D 1
D 1
D 4
D 1
D 500
D 5
D 800
DDISP PI
D ALL 1
D RTN 1
D KEYLNG 4
D UPDF 1
D SCNLV 500
D SCNLVL 5
D SCNKEY 800
D @LOOP C '1'
D SND C X'71' SEND TO DISP
D SNR C X'73' SND/RCV
D RED C X'42' READ
D RDM C X'52' READ MTD
D ESC C X'04' ESCAPE
D CLR C X'40' CLEAR UNIT
D CC1 C X'00' CNTRL CHAR
D CC2 C X'08' CNTRL CHAR
D SBA C X'11' SET BUFF ADR
D IC C X'13' INSERT CURS
D WTD C X'11' WRITE TO DSP
D WER C X'21' WRITE ERROR
D SF C X'1D' START FLD
D ATC C X'20' ATTR CHAR
D ATN C X'24' ATTR NUM
D X00 C X'00'
D X01 C X'01'
D X02 C X'02'
D X03 C X'03'
D X0D C X'0D'
D X0F C X'0F'
D X000 C X'0000'
D X1F C X'1F'
D X20 C X'20' SCRN ATT NORMAL
D X22 C X'22' SCRN ATTR HI
D X25 C X'25'
D X26 C X'26'
D X31 C X'31' CMD 1 KEY
D X32 C X'32' CMD 2 KEY
D X33 C X'33' CMD 3 KEY
D X36 C X'36' CMD 6 KEY
D X37 C X'37' CMD 7 KEY
D X38 C X'38' CMD 8 KEY
D X39 C X'39' CMD 9 KEY
D X3B C X'3B' CMD11 KEY
D XB7 C X'B7' CMD19 KEY
D XB8 C X'B8' CMD20 KEY
D X40 C X'40'
D X43 C X'43'
D X47 C X'47'
D X60 C X'60'
D X67 C X'67'
D X9F C X'9F'
D XF0 C X'F0'
D XD0 C X'D0'
D X4000 C X'4000'
D X4800 C X'4800' FF ALPHA
D X4F06 C X'4F06' FF NUMERIC
D X6000 C X'6000' FF ALPHA
D X6706 C X'6706' FF NUMERIC
D CLRWTD C X'044004112000' INCLUDES ESC CHARS
D RDDSP C X'0411200804524000' REAB FROM DISPLAY
D FFA1 S 1 INZ(X'40') F.FMT 1 ALPH 60 BYP
D FFA2 S 1 INZ(X'00') F.FMT 2 ALPH
D FFN1 S 1 INZ(X'47') F.FMT 1 NUM 67 BYP
D FFN2 S 1 INZ(X'06') F.FMT 2 NUM
I*.
IINPUTK NS 01
I 1 16 DA
I 17 32 DB 30
I 33 64 DC 31
I 65 96 DD 32
I 97 128 DE 33
I 129 160 DF 34
I 161 192 DG 35
I 193 224 DH 36
I 225 256 DI 37
I 257 288 DJ 38
I 289 320 DK 39
I 321 352 DL 40
I 353 384 DM 41
I 385 416 DN 42
I 417 448 DZ 43
I 449 480 DO 44
I 481 512 DP 45
I 513 544 DQ 46
I 545 576 DR 47
I 577 608 DS 48
I 609 640 DT 49
I 641 672 DU 50
I 673 704 DV 51
I 705 736 DW 52
I 737 768 DX 53
I 769 800 DY 54
I 801 832 D0 55
I 833 864 D1 56
I 865 896 D2 57
I 897 928 D3 58
I 929 960 D4 59
I 961 992 D5 60
I 993 1024 D6 61
I 1025 1056 DBA 62
I 1057 1088 DCA 63
I 1089 1120 DDA 64
I 1121 1152 DEA 65
I 1153 1184 DFA 66
I 1185 1216 DGA 67
I 1217 1248 DHA 68
I 1249 1280 DIA 69
I 1281 1312 DJA 70
I 1313 1344 DKA 71
I 1345 1376 DLA 72
I 1377 1408 DMA 73
I 1409 1440 DNA 74
I 1441 1472 DOA 75
I 1473 1504 DPA 76
I 1505 1536 DQA 77
I 1537 1568 DRA 78
I 1569 1600 DSA 79
I 1601 1632 DTA 80
I 1633 1664 DUA 81
I 1665 1696 DVA 82
I 1697 1728 DWA 83
I 1729 1760 DXA 84
I 1761 1792 DYA 85
I 1793 1824 DZA 86
I 1825 1856 D0A 87
I 1857 1888 D1A 88
I 1889 1920 D2A 89
I 1921 1952 D3A 90
I 1953 1984 D4A 91
I 1985 2016 D5A 92
I 2017 2048 D6A 93
IINPUTR NS 01
I 1 16 DA
I 17 32 DB 30
I 33 64 DC 31
I 65 96 DD 32
I 97 128 DE 33
I 129 160 DF 34
I 161 192 DG 35
I 193 224 DH 36
I 225 256 DI 37
I 257 288 DJ 38
I 289 320 DK 39
I 321 352 DL 40
I 353 384 DM 41
I 385 416 DN 42
I 417 448 DZ 43
I 449 480 DO 44
I 481 512 DP 45
I 513 544 DQ 46
I 545 576 DR 47
I 577 608 DS 48
I 609 640 DT 49
I 641 672 DU 50
I 673 704 DV 51
I 705 736 DW 52
I 737 768 DX 53
I 769 800 DY 54
I 801 832 D0 55
I 833 864 D1 56
I 865 896 D2 57
I 897 928 D3 58
I 929 960 D4 59
I 961 992 D5 60
I 993 1024 D6 61
I 1025 1056 DBA 62
I 1057 1088 DCA 63
I 1089 1120 DDA 64
I 1121 1152 DEA 65
I 1153 1184 DFA 66
I 1185 1216 DGA 67
I 1217 1248 DHA 68
I 1249 1280 DIA 69
I 1281 1312 DJA 70
I 1313 1344 DKA 71
I 1345 1376 DLA 72
I 1377 1408 DMA 73
I 1409 1440 DNA 74
I 1441 1472 DOA 75
I 1473 1504 DPA 76
I 1505 1536 DQA 77
I 1537 1568 DRA 78
I 1569 1600 DSA 79
I 1601 1632 DTA 80
I 1633 1664 DUA 81
I 1665 1696 DVA 82
I 1697 1728 DWA 83
I 1729 1760 DXA 84
I 1761 1792 DYA 85
I 1793 1824 DZA 86
I 1825 1856 D0A 87
I 1857 1888 D1A 88
I 1889 1920 D2A 89
I 1921 1952 D3A 90
I 1953 1984 D4A 91
I 1985 2016 D5A 92
I 2017 2048 D6A 93
IDISPF NS 02
I 3 3 AID
I 4 83 ID0
I 84 163 ID1 20
I 164 243 ID2 21
I 244 323 ID3 22
I 324 403 ID4 23
I 404 483 ID5 24
I 484 563 ID6 25
I 564 643 ID7 26
I 644 723 ID8 27
I 724 803 ID9 28
/FREE
BASE = 0;
IF ONCE = ' ';
EXSR @INITZ ;
ENDIF;
// START TAG
DOW @LOOP = @LOOP;
IF RTN = '3';
IF *INU1;
KEYA = SCNKEY;
ENDIF;
IF *INU2;
RRNA = %DEC(%SUBST(SCNKEY:1:11):11:0);
ENDIF;
RTN = '0';
AID = '1';
ELSE;
RTN = '0';
READ(E) DISPF;
ENDIF;
// CF3 EXIT
IF AID = X33;
LEAVE;
ENDIF;
// CF2 RETURN
IF AID = X32;
RTN = '1';
LEAVE;
ENDIF;
// CF1 HEX A FIELD
IF AID = X31;
Y = %LOOKUPLE( CURLOC : B );
IF Y > 0;
IF KY(Y) <= '1';
EXSR @HXDSP;
REHEAD = '1';
EXSR @PUTHED;
REHEAD = ' ';
ENDIF;
ENDIF;
ENDIF;
// CF20 MORE FIELDS
IF AID = XB8;
LVX = LVL + 1;
IF LV(LVX) <> *BLANK;
LVL = LVL +1 ;
LVW = LV;
SCNLV = TEXT500;
SCNLVL = %EDITC(LVL :'X');
SCNKEY = *BLANKS;
IF *INU1;
SCNKEY = KEYA;
ENDIF;
IF *INU2;
SCNKEY = %EDITC(RRNA:'X');
ENDIF;
RTN = '3';
LEAVE;
ENDIF;
ENDIF;
// CF19 PREVIOUS FIELDS
IF AID = XB7;
LVX = LVL - 1;
IF LVX >= 0 ;
LVL = LVL - 1 ;
LVW = LV;
SCNLV = TEXT500;
SCNLVL = %EDITC(LVL :'X');
SCNKEY = *BLANKS;
IF *INU1;
SCNKEY = KEYA;
ENDIF;
IF *INU2;
SCNKEY = %EDITC(RRNA:'X');
ENDIF;
RTN = '3';
LEAVE;
ENDIF;
ENDIF;
// 1 ENTER
// 4 ROLL DN
// 5 ROLL UP
IF AID = '1'or AID = '4' or AID = '5';
ELSE;
MX = 1;
EXSR @ERROR;
ENDIF;
IF RTN <> '3';
EXSR @PCKD;
ENDIF;
// CONT1 GET A RECORD, KEY FROM DATA
EXSR @SETIN;
EXSR @GETF ;
EXSR @PUTF ;
EXSR @KEYIN;
ENDDO ;
*INLR = *ON;
// @@@@@@@ @INITZ @@@@@@@@@@@@@@@@@@@@@@@@@@
BEGSR @INITZ;
ONCE = '1';
KEYLNA = KEYLNG ;
EXSR @INIT ;
EXSR @GETFLD ;
EXSR @GETADD ;
EXSR @PUTHED ;
EXSR @KEYIN ;
INZ = '1';
EXSR @PCKD ;
INZ = ' ';
ENDSR;
// @@@@@@@ @PCKD @@@@@@@@@@@@@@@@@@@@@@@@@@
BEGSR @PCKD ;
// CONVERT KEY DATA
IF *INU1 ;
EXSR @CVTKEY;
ENDIF;
IF *INU2 ;
EXSR @CVTRRN;
ENDIF;
ENDSR;
// @@@@@@@ @CVTKEY @@@@@@@@@@@@@@@@@@@@@@@@
BEGSR @CVTKEY;
// EXTRACT THE KEY FIELD DATA FROM THE INCOMING STRING
// FOR EACH KEY FIELD, CHECK IF FIELD WAS MODIFIED, AND IF SO MOVE
// THE MODIFIED DATA INTO THE COMPOSITE KEY
K1 = 0;
K2 = 0;
W = 1;
FOR Y = 1 TO NUMKEY ;
// MOVE A KEY FIELDS DATA FROM ID ARRAY (SCREEN) TO K ARRAY (KEY FIELDS)
// GET SIZE OF FIELD IN BYTES
IF T(Y) = 'A'; // ALPHA DATA
K = ' ';
K1 = 1;
K2 = Q(Y);
ELSE;
K = '0';
K1 = 1;
K2 = C(Y);
ENDIF;
// IF WHOLE KEY INIT WAS REQUESTED BYPASS THE EXTRACT
IF INZ = '1' ;
KW = *BLANK;
EXSR @PCKMOV;
ITER;
ENDIF;
X = 1;
DOW @LOOP = @LOOP;
// NXTSBA
X = %LOOKUP(SBA : ID : X );
IF X = 0;
LEAVE;
ENDIF;
// IS THIS THE FIELD? CHECK THE BUFFER ADDRESS
X = X +1;
IF B(Y) <> %SUBST(IDA : X :2);
ITER;
ENDIF;
// FOUND A MTD FOR THIS FIELD
X = X + 2;
// CHECK IF FIELD WAS CLEARED ONLY
IF ID(X) = SBA;
EXSR @PCKMOV;
LEAVE ;
ENDIF;
// IF FIELD HAS DECIMALS BUMP X
IF (T(Y) = 'S' OR T(Y) = 'P' OR T(Y) = 'B') AND
P(Y) > 0;
X = X + 1;
ENDIF;
// CHECK IF ONLY BLANKS RETURNED
IF %SUBST(IDA : X :K2) = *BLANKS;
EXSR @PCKMOV;
LEAVE;
ENDIF;
// EXTRACT THE DATA FROM THE INCOMING STRING
X1 = X;
FOR X2 = 1 TO K2 ;
IF ID(X1) < ' ';
// TRAP NULLS CAUSED BY FLD EXIT
EXSR @PCKMOV;
LEAVE;
ENDIF;
K(X2) = ID(X1);
X1 = X1 +1;
ENDFOR;
// CONSTRUCT THE ACTUAL KEY WITH PACKED DATA IF REQUIRED
// INTO ARRAY KW
EXSR @PCKMOV;
LEAVE;
ENDDO;
ENDFOR;
//
KEYA = KW;
CLEAR KW;
ENDSR ;
// @@@@@@@ @CVTRRN @@@@@@@@@@@@@@@@@@@@@@@@
BEGSR @CVTRRN;
// RRN
NUM11 = 0;
DOW @LOOP = @LOOP; // NOT REALLY A LOOP(SIMULATES GOTO)
// GET THE FIRST SBA
X = 1;
X = %LOOKUP(SBA : ID : X );
IF X = 0;
LEAVE;
ENDIF;
// CHECK THE BUFFER ADDRESS MATCHES THE EXPECTED FIELD
X = X +1;
IF B(1) <> %SUBST(IDA : X :2);
LEAVE;
ENDIF;
// FOUND A MTD FOR RRN FIELD
X = X +2;
//CHECK IF FIELD WAS CLEARED ONLY
IF ID(X) = SBA;
LEAVE;
ENDIF;
// CHECK IF ONLY BLANKS RETURNED
IF %SUBST(IDA : X :11) = *BLANKS;
LEAVE;
ENDIF;
// WRK11 OVERLAYS NUM11
WRK11 = %SUBST(IDA : X :11);
LEAVE;
ENDDO;
RRNA = NUM11;
IF RRNA < 0;
RRNA = 1;
ENDIF;
ENDSR;
// @@@@@@@ @PCKMOV @@@@@@@@@@@@@@@@@@@@@@@@
BEGSR @PCKMOV;
//
// CONVERT KEY DATA
// SET START POSN IN KEY USING OFFSET IN R
W = R(Y) + 1;
// ALPHA
IF T(Y) = 'A';
X1 = 1;
FOR Z = W TO W + Q(Y);
%SUBST(KW : Z : 1) = K(X1);
X1 = X1 + 1;
ENDFOR;
ENDIF;
// NUMERIC FIELD
// RIGHT ADJUST NUMERIC DATA ,STRIP - . ,CONVERT BLANKS
IF (T(Y) = 'S' OR T(Y) = 'P' OR T(Y) = 'B');
NU = '0';
Z1 = 60;
FOR Z = K2 DOWNTO K1;
IF K(Z) = '.' OR K(Z) = '-' OR K(Z) = '$';
ITER;
ENDIF;
IF K(Z) = ' ' ;
NU(Z1) = '0';
ELSE;
NU(Z1) = K(Z);
ENDIF;
Z1 = Z1 -1;
ENDFOR;
ENDIF;
// SIGNED FIELDS (END POSN = OFFSET + SIZE)
IF T(Y) = 'S';
NUS = 0;
FOR VX = 1 TO 60;
NUSA = %TRIM(NUSA) + NU(VX);
ENDFOR;
%SUBST(KW : W : Q(Y)) = %SUBST(NUSA: 61 -Q(Y));
ENDIF;
// PACKED FIELDS
IF T(Y) = 'P';
NUSA= *BLANKS;
FOR VX = 1 TO 60;
NUSA = %TRIM(NUSA) + NU(VX);
ENDFOR;
NUP = %DEC(NUSA : 60 : 0);
%SUBST(KW : W : Q(Y)) = %SUBST(NUPA: 61 -Q(Y));
ENDIF;
// BINARY FIELDS
IF T(Y) = 'B';
IF Q(Y) = 2 ;
BY2 = NU(1) + NU(2);
%SUBST(KW : W : 2) = BY2;
ENDIF;
IF Q(Y) = 4 ;
BY4 = NU(1) + NU(2) + NU(3) + NU(4);
%SUBST(KW : W : 4) = BY4;
ENDIF;
ENDIF;
ENDSR;
// @@@@@@@ SETIN @@@@@@@@@@@@@@@@@@@@@@@@@
BEGSR @SETIN;
// SET the FFR indicators to get the Input buffer somewhat aligned with the
// actual data. RPG is somewhat tolerant to a difference between the Ispecs
// and the actual file size but it can fail on big differences.
// INCREMENT OF 32 BYTES
SZ(1) = BASE + 16;
SZ(2) = SZ(1) + 16;
*IN30 = *ON;
IF (RLEN > SZ(2)) ;
*IN31 = *ON;
ENDIF;
FOR X = 3 TO 64;
SZ(X) = SZ(X-1) + 32;
IF (RLEN > SZ(X)) ;
*IN(29+X) = *ON;
ENDIF;
ENDFOR;
ENDSR;
//@@@@@@@@@@@@@@@@@ @GETF @@@@@@@@@@@@@@@@@
BEGSR @GETF;
// GET A DATA RECORD
IF (*INU1);
IF AID = '1' OR AID = X36 OR
AID = X39 OR AID = X3B ;
SETLL(E) KEYA INPUTK;
READ(E) INPUTK;
IF %EOF;
SETLL(E) KEYA INPUTK;
READP(E) INPUTK;
ENDIF;
ENDIF;
IF AID = '4';
READP(E) INPUTK;
ENDIF;
IF AID = '5';
READ(E) INPUTK;
ENDIF;
IF %ERROR;
SETLL(E) KEYA INPUTK;
READ(E) INPUTK;
MX = 7;
EXSR @ERROR;
EXSR @PUTF ;
EXSR @KEYIN;
ENDIF;
KEYA = LKY;
CLEAR KW;
KW = LKY;
ENDIF;
IF (*INU2);
IF AID = '1';
CHAIN(E) RRNA INPUTR;
IF %ERROR;
SETLL(E) RRNA INPUTR;
READP(E) INPUTR;
ENDIF;
ENDIF;
IF AID = X36;
CHAIN(E) RRNA INPUTR;
ENDIF;
IF AID = '4';
READP(E) INPUTR;
ENDIF;
IF AID = '5' OR AID = X3B;
READ(E) INPUTR;
ENDIF;
IF AID = X39;
SETLL(E) *HIVAL INPUTR;
READP(E) INPUTR;
ENDIF;
IF %ERROR;
CHAIN 1 INPUTR;
MX = 7;
EXSR @ERROR;
EXSR @PUTF ;
EXSR @KEYIN;
ENDIF;
ENDIF;
ENDSR;
//@@@@@@@@@@@@@@@@@ @PUTF @@@@@@@@@@@@@@@@@
BEGSR @PUTF;
// WRITE DATA TO THE DISPLAY
NEWRU = '1';
WRTRRN = '1';
RU = *ALLX'00';
CLEAR RU; // initialise Request Unit 255 bytes max
FOR XX = 1 TO NUMFKY; //NUMBER OF DATA ELEMENTS (FLD AND KEY)
IF NEWRU = '1';
NEWRU = '0';
RU = ESC + WTD + X20 + X00;
ENDIF;
IF WRTRRN = '1';
WRTRRN = '0';
RU = RU + SBA + RBA ;
SELECT;
WHEN *INU1;
RRN = RN1;
WHEN *INU2;
RRN = RN2;
ENDSL;
RU = RU + %TRIM(%EDITC(RRN:'Z'));
ENDIF;
// BUFFER ADDRESS
RU = RU + SBA + B(XX);
// PROCESS ALPHA DATA TYPE
IF T(XX) = 'A' OR T(XX) = 'T' OR T(XX) = 'Z' OR
T(XX) = 'L';
STRX = S(XX);
ENDX = E(XX);
IF V(XX) = 'Y'; //VARYING
VX = S(XX);
HX2 = D(VX) + D(VX+1);
STRX = S(XX) + 2 ;
ENDX = S(XX) + BIN;
ENDIF;
FOR Y = STRX TO ENDX ;
IF D(Y) >= ' ';
RU = RU + D(Y);
ELSE;
RU = RU + X1F ; //IF NOT DISPLAYABLE REPLACE WITH X'1F'
ENDIF;
ENDFOR;
ENDIF;
// PROCESS SIGNED DATA TYPE (not the RRN field)
IF T(XX) = 'S' and KY(XX) <> '3';
NUSA = *ALL'0';
WRV = *ALLX'00';
CLEAR WRV;
FOR Y = S(XX) TO E(XX);
IF D(Y) >= XD0;
WRV = WRV + D(Y);
ENDIF;
ENDFOR;
EVAL NUSA = %SUBST(NUSA : 1 : 60 - %LEN(WRV)) + WRV;
CLEAR WRU;
WRU = %TRIM(WRU) + %EDITW(NUS :WRSWRD);
IF P(XX) > 0;
RU = RU +
%SUBST(WRU :61-C(XX): C(XX)-P(XX)) + '.' +
%SUBST(WRU :61-P(XX)) ;
ELSE;
RU = RU +
%SUBST(WRU :61-C(XX));
ENDIF;
ENDIF;
// PROCESS SIGNED DATA TYPE (the RRN field)
IF T(XX) = 'S' and KY(XX) = '3';
RRN = RN2;
RU = RU + %TRIM(%EDITC(RRN:'X'));
ENDIF;
// PROCESS PACKED DATA TYPE
IF T(XX) = 'P';
NUPA = *ALLX'00';
WRV = *ALLX'00';
CLEAR WRV;
FOR Y = S(XX) TO E(XX);
WRV = WRV + D(Y);
ENDFOR;
IF %BITAND(D(E(XX)) :X0F) = X0F OR
%BITAND(D(E(XX)) :X0D) = X0D;
EVAL NUPA = %SUBST(NUPA : 1 : 60 - %LEN(WRV)) + WRV;
CLEAR WRX;
WRX = %TRIM(WRX) + %EDITW(NUP :WRXWRD);
IF P(XX) > 0;
RU = RU +
%SUBST(WRX :64-C(XX): C(XX)-P(XX)) + '.' +
%SUBST(WRX :64-P(XX)) ;
ELSE;
RU = RU +
%SUBST(WRX :64-C(XX));
ENDIF;
ELSE;
// PACKED FIELD IN ERROR
RU = RU + X1F;
ENDIF;
ENDIF;
// PROCESS BINARY DATA TYPE
IF T(XX) = 'B';
ST = S(XX);
CLEAR NUSA;
IF Q(XX) = 2;
BY2 = D(ST) + D(ST+1);
NUS = BIN2;
ENDIF;
IF Q(XX) = 4;
BY4 = D(ST) + D(ST+1)+ D(ST+2) + D(ST+3);
NUS = BIN4;
ENDIF;
WRU = %EDITW(NUS :WRSWRD);
IF P(XX) > 0;
RU = RU +
%SUBST(WRU :61-C(XX): C(XX)-P(XX)) + '.' +
%SUBST(WRU :61-P(XX)) ;
ELSE;
RU = RU +
%SUBST(WRU :61-C(XX));
ENDIF;
ENDIF;
// PROCESS FLOAT DATA TYPE
IF T(XX) = 'F';
ST = S(XX);
IF Q(XX) = 4;
FL4 = D(ST) + D(ST+1)+ D(ST+2) + D(ST+3);
FLT14 = %EDITFLT(FLT4);
RU = RU + FLT14;
ENDIF;
IF Q(XX) = 8;
FL8 = D(ST) + D(ST+1)+ D(ST+2) + D(ST+3) +
D(ST+4) + D(ST+5)+ D(ST+6) + D(ST+7);
FLT23 = %EDITFLT(FLT8);
RU = RU + FLT23;
ENDIF;
ENDIF;
// SEND A REQUEST UNIT IF GOT ENOUGH DATA
IF %LEN(RU) + L(XX + 1) >= 200;
RU = RU + X20;
BIN = %LEN(RU);
OUTLEN = HX2;
INLEN = X000;
FNC = SND;
A = RU;
EXCEPT DATAO;
NEWRU = '1';
RU = *ALLX'00';
CLEAR RU;
ENDIF;
ENDFOR;
IF %LEN(RU) > 5 AND %LEN(RU) < 250;
RU = RU + X20;
BIN = %LEN(RU);
OUTLEN = HX2;
INLEN = X000;
FNC = SND;
A = RU;
EXCEPT DATAO;
ENDIF;
ENDSR;
// @@@@@@@@@@@@@@@ ROWINC @@@@@@@@@@@@@@@
// INCREMENT THE ROW
BEGSR @ROWINC;
ROW = ROW + 2;
IF ROW > 20;
MX = 3;
ENDIF;
ENDSR;
// @@@@@@@@@@@@@@@ GETFLD @@@@@@@@@@@@@@@
// LOAD FIELD DESCRIPTION ARRAYS
BEGSR @GETFLD;
MX = 0;
X = 0;
IF (*INU2 = *ON);
// IF NON KEYED ACCESS SET UP A FIELD TO SHOW THE RRN
N(1) = 'RRN';
T(1) = 'S' ;
C(1) = 11 ;
P(1) = 0 ;
S(1) = 0 ;
E(1) = 0 ;
L(1) = 12 ;
I(1) = X4F06 ;
KY(1)= '3' ;
X = 1 ;
ENDIF;
SCRST = *BLANK;
SCRSTN = *BLANK;
LVL = %DEC(SCNLVL : 5:0);
TEXT500 = SCNLV ;
LV = LVW;
IF LVL <> 0;
SCRST = LV(LVL);
ENDIF;
SETLL 1 QWHDRFFD ;
DOW @LOOP = @LOOP;
// REREAD TAG
READ QWHDRFFD;
IF %EOF;
LEAVE;
ENDIF;
// SELECT OR OMIT
IF ALL <> '1';
IF ALL = 'S' AND WHDFTL = 0; // USING WHDFTL FOR KEY FIELDS
IF WHFIOB <> 'S';
ITER;
ENDIF;
ENDIF;
IF ALL = 'O' AND WHDFTL = 0; // USING WHDFTL FOR KEY FIELDS
IF WHFIOB = 'O';
ITER;
ENDIF;
ENDIF;
ENDIF;
// FIND THE FIRST FIELD TO BE SHOWN (FOR MULTI PAGE FORMATS)
IF WHDFTL <> 0 ;
ELSE;
IF SCRST <> ' ' AND SCRSTN = ' ';
IF WHFLDE = SCRST;
SCRSTN = '1'; // FOUND THE START
ELSE;
ITER;
ENDIF;
ENDIF;
ENDIF;
X = X + 1;
// CHECK FOR KEY FIELDS,WILL BE USED TO PLACE THEM IN FRONT
IF WHDFTL <> 0;
KY(X) = '1';
WX = WHDFTL ;
KE(WX) = WHFLDE;
IF NUMKEY < WHDFTL;
NUMKEY = WHDFTL;
ENDIF;
ENDIF;
N(X) = WHFLDE ; // NAME
T(X) = WHFLDT ; // TYPE
V(X) = WHVARL ; // VARYING
C(X) = WHFLDD ; // DEC DIGITS
P(X) = WHFLDP ; // DEC PREC
S(X) = WHFOBO ; // START
Q(X) = WHFLDB ; // BTYES
E(X) = WHFOBO + WHFLDB -1 ; // END
IF T(X) = 'F' ; // FLOAT
I(X) = FFA1 + FFA2; // SCRN FIELD FORMAT ALPHA
L(X) = 14;
IF Q(X) = 8;
L(X) = 23;
ENDIF;
ELSE;
IF WHFLDD <> 0 ;
IF WHFLDP <> 0 ;
L(X) = WHFLDD + 2 ; // LENGTH
ELSE;
L(X) = WHFLDD + 1 ; // LENGTH
ENDIF;
I(X) = FFN1 + FFN2; // SCRN FIELD FORMAT NUMERIC
ELSE;
L(X) = WHFLDB ;
I(X) = FFA1 + FFA2; // SCRN FIELD FORMAT ALPHA
ENDIF;
ENDIF;
ENDDO;
// NUMBER OF FIELDS
NUMFLD = X ;
// MAKE ROOM FOR KEYS
IF NUMKEY > 0 ;
X1 = NUMKEY + NUMFLD;
FOR X = NUMFLD DOWNTO 1;
KY(X1) = KY(X) ;
L(X1) = L(X) ;
I(X1) = I(X) ;
N(X1) = N(X) ;
T(X1) = T(X) ;
V(X1) = V(X) ;
C(X1) = C(X) ;
P(X1) = P(X) ;
S(X1) = S(X) ;
E(X1) = E(X) ;
Q(X1) = Q(X) ;
X1 = X1 - 1;
ENDFOR;
// PUT KEY FIELDS AT TOP
OFF = 0;
FOR X = 1 TO NUMKEY;
X1 = %LOOKUP(KE(X) : N : NUMKEY+1);
KY(X) = '2';
L(X) = L(X1);
I(X) = I(X1); // FIELD FMT
SELECT; // INPUT ENABLE
WHEN I(X) = X6000;
I(X) = X4800;
WHEN I(X) = X6706;
I(X) = X4F06;
ENDSL;
N(X) = N(X1);
T(X) = T(X1);
V(X) = V(X1);
C(X) = C(X1);
P(X) = P(X1);
S(X) = S(X1);
E(X) = E(X1);
Q(X) = Q(X1);
R(X) = OFF;
OFF = OFF + Q(X1);
ENDFOR;
ENDIF;
// NUMBER OF FIELDS AND KEYS
NUMFKY = NUMFLD + NUMKEY;
ENDSR;
// @@@@@@@@@@@@@@@ GETADD @@@@@@@@@@@@@@@
// LOAD FIELD BUFFER ADDRESSES
BEGSR @GETADD;
MX = 0;
X = 0;
ROW = 3;
COL = 1;
FOR X = 1 TO NUMFKY;
// IF FINISHED WITH THE KEY FIELDS
// INC ROW FOR 1ST DATA FIELD
IF KEYSOK = ' ' ;
IF KY(X) = ' ' OR KY(X) = '1';
KEYSOK = '1' ;
ROW = ROW + 2;
COL = 1;
ENDIF;
ENDIF;
// SET THE BUFFER ADD ON THE LARGER OF THE FIELD TEXT OR THE FIELD SIZE
LENDSC = %LEN(%TRIM(N(X)));
LENWRK = L(X);
IF LENDSC > L(X);
LENWRK = LENDSC;
ENDIF;
LENWRK = LENWRK + 2;
// TRAP FIELDS THAT OVERFLOW
ROW = ROW + XROW;
XROW = %DIV(LENWRK : 80);
IF (COL + LENWRK) > 78;
EXSR @ROWINC;
IF MX = 3;
X= X-1;
NUMFKY = X;
LEAVE;
ENDIF;
COL = 1;
ENDIF;
// INC COL. FOR FIELD START
CLEAR B(X);
BIN = ROW;
B(X) = %TRIM(B(X)) + HX1;
BIN = COL + 1;
B(X) = %TRIM(B(X)) + HX1;
// INC COL. FOR NEXT FIELD
COL = COL + LENWRK;
IF COL > 78;
EXSR @ROWINC;
IF MX = 3; // NO ROOM FOR THE FIELD
X= X-1;
NUMFKY = X;
LEAVE;
ENDIF;
COL = 1;
ENDIF;
ENDFOR;
// FIELD LEVEL
LVX = LVL + 1;
LV(LVX) = N(X);
ENDSR;
// @@@@@@@@@@@@@@@ PUTHED @@@@@@@@@@@@@@@
// PUT FIELD HEADINGS
BEGSR @PUTHED;
NEWRU = '1';
RU = *ALLX'00';
CLEAR RU; // initialise Request Unit 255 bytes max
FOR XX = 1 TO NUMFKY; //NUMBER OF DATA ELEMENTS (FLD AND KEY)
IF NEWRU = '1';
NEWRU = '0';
RU = ESC + WTD + X20 + X00;
ENDIF;
RU = RU + SBA;
BIN = 0;
// CONVERT DATA BUFADR TO HEADING BUFADR
HX1 = %SUBST(B(XX) :1:1);
BIN = BIN - 1;
RU = RU + HX1;
IF REHEAD = '1'; // ON REDISPLAY OVERRIDE THE ATTR
BIN = 0;
HX1 = %SUBST(B(XX) :2:1);
BIN = BIN -1 ;
RU = RU + HX1;
ELSE;
RU = RU + %SUBST(B(XX) :2);
ENDIF;
RU = RU + ATC ;
// LONG NUMBER FIELDS ,RIGHT ADJUST THE FIELD HEADINGS
LENDSC = %LEN(%TRIM(N(XX)));
IF T(XX) <> 'A' AND LENDSC < (L(XX) -1);
FOR Y = 1 TO (L(XX) -(LENDSC +1));
RU = RU + ' ';
ENDFOR;
ENDIF;
RU = RU + %TRIM(N(XX));
IF %LEN(RU) >= 200;
BIN = %LEN(RU);
OUTLEN = HX2;
INLEN = X000;
FNC = SND;
A = RU;
EXCEPT DATAO;
NEWRU = '1';
RU = *ALLX'00';
CLEAR RU;
ENDIF;
ENDFOR;
IF %LEN(RU) > 5 AND %LEN(RU) < 200;
BIN = %LEN(RU);
OUTLEN = HX2;
INLEN = X000;
FNC = SND;
A = RU;
EXCEPT DATAO;
ENDIF;
IF REHEAD <> '1';
// FORMAT FIELDS
NEWRU = '1';
RU = *ALLX'00';
CLEAR RU; // initialise Request Unit 255 bytes max
FOR XX = 1 TO NUMFKY; //NUMBER OF DATA ELEMENTS (FLD AND KEY)
IF NEWRU = '1';
NEWRU = '0';
RU = ESC + WTD + X20 + X00;
ENDIF;
RU = RU + SBA +B(XX)+SF + I(XX);
IF KY(XX) = '1' OR KY(XX) = '2' OR KY(XX) = '3';
RU = RU + X25;
ELSE;
RU = RU + X26;
ENDIF;
BIN = L(XX);
RU = RU + HX2;
// LENGTH OF INPUT FIELDS
LENF = LENF + L(XX) + 3;
IF %LEN(RU) >= 200;
BIN = %LEN(RU);
OUTLEN = HX2;
INLEN = X000;
FNC = SND;
A = RU;
EXCEPT DATAO;
NEWRU = '1';
RU = *ALLX'00';
CLEAR RU;
ENDIF;
ENDFOR;
// PUT LAST R/U
IF %LEN(RU) > 5 AND %LEN(RU) < 200;
BIN = %LEN(RU);
OUTLEN = HX2;
INLEN = X000;
FNC = SND;
A = RU;
EXCEPT DATAO;
ENDIF;
//INC BUFFER ADDRESS FOR ALL FIELDS FOR DATA PUT
FOR XP = 1 TO NUMFKY; //NUMBER OF DATA ELEMENTS (FLD AND KEY)
HX2 = B(XP);
BIN = BIN + 1;
B(XP) = HX2;
ENDFOR;
ENDIF;
ENDSR;
// @@@@@@@ INIT @@@@@@@@@@@@@@@@@@@@@@@@@
BEGSR @INIT;
CLEAR KW;
// UPDATE
IF UPDF = 'Y';
FFA1 = X40;
FFN1 = X47;
ELSE;
FFA1 = X60;
FFN1 = X67;
ENDIF;
SELECT;
WHEN *INU1 = '1';
FILE = F1 ;
LIB = L1 ;
MBR = M1 ;
RCDL = R1 ;
ACCTP = A1 ;
WHEN *INU2 = '1';
FILE = F2 ;
LIB = L2 ;
MBR = M2 ;
RCDL = R2 ;
ACCTP = A2 ;
ENDSL;
RLEN = RCDL ;
RLENTH = %EDITC(RLEN: 'X') ;
LENF = 0 ;
// Control commands and data are constructed into RUs Request UNITS
// Each RU is 256 bytes max size.
// Construct and send as many RUs as needed to format the display.
RU = *ALLX'00';
CLEAR RU; // initialise Request Unit 255 bytes max
RU = CLRWTD ;
//set up the screen headings
BIN = 1; // set ROW to 1
RW = HX1;
BIN = 2; // set COL to 2
CL = HX1;
RU = RU + SBA + RW + CL + X22 + %TRIM(LIB) + '/' + %TRIM(FILE);
RU = RU + ' Mbr ' + %TRIM(MBR) + ' Rcdl ' + %EDITC(RLEN : 'Z') ;
RU = RU + ' RRN ' ;
BIN = %len(RU) -4;
RBA = RW + HX1 ; // address of the RRN field
RU = RU + SBA + RBA + ' ';
// FUNCTION KEYS
BIN = 23;
RW = HX1;
BIN = 02;
CL = HX1;
IF UPDF = 'Y'; // UPDATE IS ON
RU = RU + SBA + RW + CL + %TRIM(CNS(2));
ELSE;
RU = RU + SBA + RW + CL + %TRIM(CNS(1));
ENDIF;
// THIS IS A SEND ONLY FUNCTION
FNC = SND;
CLEAR A;
A = RU;
BIN2 = %LEN(RU);
OUTLEN = BY2;
INLEN = x000;
EXCEPT DATAO;
ENDSR;
// @@@@@@@ KEYIN @@@@@@@@@@@@@@@@@@@@@@@@@
BEGSR @KEYIN;
// ISSUE A READ FROM DISPLAY
FNC = SNR;
BIN2 = 8;
OUTLEN = BY2;
IPL = LENF + 34;
BIN2 = IPL;
INLEN = BY2;
// SET FRR INDICATORS TO CONTROL BUFFER OVERFLOW
FOR X = 1 TO 9;
IF IPL > ( X*80 +3);
*IN(X+19) = *ON;
ENDIF;
ENDFOR;
RU = *ALLX'00';
CLEAR RU;
RU = RDDSP;
A = RU;
EXCEPT DATAI;
ENDSR;
// @@@@@@@ ERROR @@@@@@@@@@@@@@@@@@@@@@@@@
BEGSR @ERROR;
// SETUP PUT ERROR MESSAGE X'21'
RU = *ALLX'00';
CLEAR RU;
FNC = SNR;
BIN = 42;
OUTLEN = HX2;
BIN = LENF + 34;
IPL = BIN;
INLEN = HX2;
FOR X = 1 TO 9;
IF IPL > (X * 80 +3) ;
*IN(X + 19) = *ON; // SETON FFR 20 - 29 FOR INPUT
ENDIF;
ENDFOR;
RU = ESC + WER + IC + B(1) + ATC + MSG(MX);
RU = RU + ESC + RDM + X40+ X00;
A = RU;
EXCEPT DATAI;
RU = *ALLX'00';
CLEAR RU;
ENDSR;
// @@@@@@@ HXDSP @@@@@@@@@@@@@@@@@@@@@@@@@
BEGSR @HXDSP;
RU = *ALLX'00';
CLEAR RU;
Y = %LOOKUPLE( CURLOC : B );
//
RU = ESC + WTD + X20 + X00 + SBA;
BIN = 0;
HX1 = %SUBST(B(Y) :1:1);
BIN = BIN - 1;
RU = RU + HX1;
RU = RU + %SUBST(B(Y) :2:1);
FOR X = S(Y) TO E(Y);
BIN = 0;
HX1 = D(X);
HX1 = %BITAND(HX1 : XF0);
Z = BIN / 16 + 1;
RU = RU + CRS(Z);
ENDFOR;
RU = RU + X20;
RU = RU + SBA + B(Y);
FOR X = S(Y) TO E(Y);
BIN = 0;
HX1 = D(X);
HX1 = %BITAND(HX1 : X0F);
Z = BIN + 1;
RU = RU + CRS(Z);
ENDFOR;
BIN = %LEN(RU);
OUTLEN = HX2;
INLEN = X000;
FNC = SND;
A = RU;
EXCEPT DATAO;
RU = *ALLX'00';
CLEAR RU;
EXSR @KEYIN;
READ DISPF;
// CLEAR HEADINGS
RU = *ALLX'00';
CLEAR RU;
RU = RU + ESC + WTD + X20 + X00 + SBA;
HX1 = %SUBST(B(Y) :1:1) ;
BIN = BIN - 1;
RU = RU + HX1 + %SUBST(B(Y):2:1);
FOR X = S(Y) TO E(Y);
RU = RU + ' ';
ENDFOR;
RU = RU + ' ';
BIN = %LEN(RU);
OUTLEN = HX2;
INLEN = X000;
FNC = SND;
A = RU;
EXCEPT DATAO;
RU = *ALLX'00';
CLEAR RU;
ENDSR;
/END-FREE
ODISPF E DATAO
O K3 'PUT'
O OUTLEN 2
O INLEN
O FNC
O A
O E DATAI
O K3 'GET'
O OUTLEN 2
O INLEN
O FNC
O A
**
0000 INVALID COMMAND KEY
0001 - A FIELD IS TOO LONG
0002 - TOO MANY FIELDS
0003 - ALPHAS IN PACKED KEY
0004 - MISSING ' IN PACKED KEY
0005 - MISSING DATA IN PCKD KEY
0006 - RECORD NOT FOUND
PRESS RESET TO CONTINUE
**
F1-HEX F2-Return F3-Exit F19-Prev_fld F20-More_fld
F1-HEX F2-Return F3-Exit F19-Prev_fld F20-More_fld
**
0123456789ABCDEF
DISP1 RPG
H*eywords++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++Comments+++++++++++
H OPTION(*NODEBUGIO)
H DFTACTGRP(*NO) ACTGRP(*CALLER) DFTNAME(DISP )
F*
F* LIMITED TO MAXIMUM FILE LENGTH OF 4080
F* TEST
FFFD IF E DISK
FDISPF CF F 803 WORKSTN
F*
F INFDS(INFDS)
FINPUTK IF F32766 800AIDISK KEYLOC(1)
F EXTIND(*INU1)
F INFDS(INFDK)
FINPUTR IF F32766 DISK EXTIND(*INU2)
F INFDS(INFDR)
*
D A S 255 WORK RU
D RU S 255 varying
D RW S 1 ROW 1 byte binary
D CL S 1 COL 1 byte binary
D FNC S 1
D OUTLEN S 2
D INLEN S 2
D IPL S 5 0
D ROW S 3 0
D XROW S 3 0
D COL S 3 0
D KEYSOK S 1
D LENDSC S 3 0
D LENWRK S 5 0
D STRX S 5 0
D ENDX S 5 0
D VX S 5 0
D X S 5 0
D X1 S 5 0
D X2 S 5 0
D XX S 5 0
D XP S 5 0
D MX S 5 0
D ONCE S 1
D RBA S 2
D LF S 5 0
D ST S 5 0
D Y S 5 0
D Z S 5 0
D OFF S 5 0
D SUPZ S 1
D NUMFLD S 5 0
D WX S 5 0
D NUMKEY S 5 0
D NUMFKY S 5 0
D SCRST S 10
D SCRSTN S 1
D KEYA S 800
D RRNA S 11 0
D RRN S 11 0
D REHEAD S 1
D NEWRU S 1
D WRTRRN S 1
D LVX S 5 0
D LVL S 5 0
D K1 S 5 0
D K2 S 5 0
D Z1 S 5 0
D W S 5 0
D WK2 S 2
D MSSG S 32
*
D BASE S 5 0
D INZ S 1
D FILE S 10
D LIB S 10
D MBR S 10
D RCDL S 5 0
D ACCTP S 1
D RLEN S 5 0
D RLENTH S 5
D LENF S 5 0
D DS
D TEXT500 500
D LVW 10 DIM(50) overlay(TEXT500:1)
D TEXT800 S 800
D KW S 800
D DS
D WRK11 1 11
D NUM11 1 11S 0
D DS
D NUSA 1 60
D NUS 1 60S 0
D DS
D NUPA 1 60
D NUP 29 60P 0
D WRU S 61
D WRX S 64
D WRXWRD C '0 -
D -'
D WRSWRD C '0 -
D -'
D WRV S 60 varying
D FLT14 S 14
D FLT23 S 23
* SET FILE SIZE INCREMENTS (64 OF THEM)
D SZ S 5 0 DIM(64)
D S S 5 0 DIM(9000) START OF FLD
D E S 5 0 DIM(9000) END OF FLD
D Q S 5 0 DIM(9000) BYTES IN FIELD
D L S 5 0 DIM(9000) LENGTH OF FLD
D C S 3 0 DIM(9000) DEC DIGITS
D P S 3 0 DIM(9000) DEC PRECISION
D B S 2 DIM(9000) ASCEND BUFFER ADD
D I S 2 DIM(9000) FLD FMT
D N S 10 DIM(9000) FLD NAME
D T S 1 DIM(9000) FLD TYPE
D V S 1 DIM(9000) VARYING
D KY S 1 DIM(9000) KEYED
D KE S 10 DIM(128) KEY FLDS
D R S 3 0 DIM(9000) KEY FLD START
D K S 1 DIM(800) KEY
D NA S 1 DIM(10) NAME WORK
D NU S 1 DIM(60) NUM. WORK
D LV S 10 DIM(50) SCREEN LEVELS
D MSG S 32 DIM(8) CTDATA PERRCD(1) MESSAGES
D CNS S 79 DIM(2) CTDATA PERRCD(1)
D CRS S 1 DIM(16) CTDATA PERRCD(16)
D DS
D D 1 4080
D DIM(4080) INCOMING DATA
D DA 1 2048
D DB 2049 2064
D DC 2065 2096
D DD 2097 2128
D DE 2129 2160
D DF 2161 2192
D DG 2193 2224
D DH 2225 2256
D DI 2257 2288
D DJ 2289 2320
D DK 2321 2352
D DL 2353 2384
D DM 2385 2416
D DN 2417 2448
D DZ 2449 2480
D DO 2481 2512
D DP 2513 2544
D DQ 2545 2576
D DR 2577 2608
D DS 2609 2640
D DT 2641 2672
D DU 2673 2704
D DV 2705 2736
D DW 2737 2768
D DX 2769 2800
D DY 2801 2832
D D0 2833 2864
D D1 2865 2896
D D2 2897 2928
D D3 2929 2960
D D4 2961 2992
D D5 2993 3024
D D6 3025 3056
D DBA 3057 3088
D DCA 3089 3120
D DDA 3121 3152
D DEA 3153 3184
D DFA 3185 3216
D DGA 3217 3248
D DHA 3249 3280
D DIA 3281 3312
D DJA 3313 3344
D DKA 3345 3376
D DLA 3377 3408
D DMA 3409 3440
D DNA 3441 3472
D DOA 3473 3504
D DPA 3505 3536
D DQA 3537 3568
D DRA 3569 3600
D DSA 3601 3632
D DTA 3633 3664
D DUA 3665 3696
D DVA 3697 3728
D DWA 3729 3760
D DXA 3761 3792
D DYA 3793 3824
D DZA 3825 3856
D D0A 3857 3888
D D1A 3889 3920
D D2A 3921 3952
D D3A 3953 3984
D D4A 3985 4016
D D5A 4017 4048
D D6A 4049 4080
D DS
D ID 1 800
D DIM(800) INCOMING DATA
D IDA 1 800
D ID0 1 80
D ID1 81 160
D ID2 161 240
D ID3 241 320
D ID4 321 400
D ID5 401 480
D ID6 481 560
D ID7 561 640
D ID8 641 720
D ID9 721 800
D DS
D BIN 1 2B 0
D HX1 2 2
D HX2 1 2
D DS
D PCK 1 1P 0
D PCK1 1 1
D DS
D SGN 1 1S 0
D SGN1 1 1
D DS
D BIN4 1 4B 0
D BY4 1 4
D DS
D BIN2 1 2B 0
D BY2 1 2
D DS
D FLT4 1 4F
D FL4 1 4
D DS
D FLT8 1 8F
D FL8 1 8
D INFDK DS
D F1 83 92
D L1 93 102
D M1 129 138
D R1 125 126B 0
D A1 160 160
D LOP1 260 260
D KEY_LEN 393 394I 0 Key length
D RN1 397 400B 0
D LKY 401 1200
D INFDR DS
D F2 83 92
D L2 93 102
D M2 129 138
D R2 125 126B 0
D A2 160 160
D LOP2 260 260
D RN2 397 400B 0
D*
D INFDS DS
D CURLOC 370 371
D DS
D KEYLN 1 4S 0
D KEYLNA 1 4
DDISP1 PR
D 1
D 1
D 4
D 1
D 500
D 5
D 800
DDISP1 PI
D ALL 1
D RTN 1
D KEYLNG 4
D UPDF 1
D SCNLV 500
D SCNLVL 5
D SCNKEY 800
D @LOOP C '1'
D SND C X'71' SEND TO DISP
D SNR C X'73' SND/RCV
D RED C X'42' READ
D RDM C X'52' READ MTD
D ESC C X'04' ESCAPE
D CLR C X'40' CLEAR UNIT
D CC1 C X'00' CNTRL CHAR
D CC2 C X'08' CNTRL CHAR
D SBA C X'11' SET BUFF ADR
D IC C X'13' INSERT CURS
D WTD C X'11' WRITE TO DSP
D WER C X'21' WRITE ERROR
D SF C X'1D' START FLD
D ATC C X'20' ATTR CHAR
D ATN C X'24' ATTR NUM
D X00 C X'00'
D X01 C X'01'
D X02 C X'02'
D X03 C X'03'
D X0D C X'0D'
D X0F C X'0F'
D X000 C X'0000'
D X1F C X'1F'
D X20 C X'20' SCRN ATT NORMAL
D X22 C X'22' SCRN ATTR HI
D X25 C X'25'
D X26 C X'26'
D X31 C X'31' CMD 1 KEY
D X32 C X'32' CMD 2 KEY
D X33 C X'33' CMD 3 KEY
D X36 C X'36' CMD 6 KEY
D X37 C X'37' CMD 7 KEY
D X38 C X'38' CMD 8 KEY
D X39 C X'39' CMD 9 KEY
D X3B C X'3B' CMD11 KEY
D XB7 C X'B7' CMD19 KEY
D XB8 C X'B8' CMD20 KEY
D X40 C X'40'
D X43 C X'43'
D X47 C X'47'
D X60 C X'60'
D X67 C X'67'
D X9F C X'9F'
D XF0 C X'F0'
D XD0 C X'D0'
D X4000 C X'4000'
D X4800 C X'4800' FF ALPHA
D X4F06 C X'4F06' FF NUMERIC
D X6000 C X'6000' FF ALPHA
D X6706 C X'6706' FF NUMERIC
D CLRWTD C X'044004112000' INCLUDES ESC CHARS
D RDDSP C X'0411200804524000' REAB FROM DISPLAY
D FFA1 S 1 INZ(X'40') F.FMT 1 ALPH 60 BYP
D FFA2 S 1 INZ(X'00') F.FMT 2 ALPH
D FFN1 S 1 INZ(X'47') F.FMT 1 NUM 67 BYP
D FFN2 S 1 INZ(X'06') F.FMT 2 NUM
I*.
IINPUTK NS 01
I 1 2048 DA
I 2049 2064 DB 30
I 2065 2096 DC 31
I 2097 2128 DD 32
I 2129 2160 DE 33
I 2161 2192 DF 34
I 2193 2224 DG 35
I 2225 2256 DH 36
I 2257 2288 DI 37
I 2289 2320 DJ 38
I 2321 2352 DK 39
I 2353 2384 DL 40
I 2385 2416 DM 41
I 2417 2448 DN 42
I 2449 2480 DZ 43
I 2481 2512 DO 44
I 2513 2544 DP 45
I 2545 2576 DQ 46
I 2577 2608 DR 47
I 2609 2640 DS 48
I 2641 2672 DT 49
I 2673 2704 DU 50
I 2705 2736 DV 51
I 2737 2768 DW 52
I 2769 2800 DX 53
I 2801 2832 DY 54
I 2833 2864 D0 55
I 2865 2896 D1 56
I 2897 2928 D2 57
I 2929 2960 D3 58
I 2961 2992 D4 59
I 2993 3024 D5 60
I 3025 3056 D6 61
I 3057 3088 DBA 62
I 3089 3120 DCA 63
I 3121 3152 DDA 64
I 3153 3184 DEA 65
I 3185 3216 DFA 66
I 3217 3248 DGA 67
I 3249 3280 DHA 68
I 3281 3312 DIA 69
I 3313 3344 DJA 70
I 3345 3376 DKA 71
I 3377 3408 DLA 72
I 3409 3440 DMA 73
I 3441 3472 DNA 74
I 3473 3504 DOA 75
I 3505 3536 DPA 76
I 3537 3568 DQA 77
I 3569 3600 DRA 78
I 3601 3632 DSA 79
I 3633 3664 DTA 80
I 3665 3696 DUA 81
I 3697 3728 DVA 82
I 3729 3760 DWA 83
I 3761 3792 DXA 84
I 3793 3824 DYA 85
I 3825 3856 DZA 86
I 3857 3888 D0A 87
I 3889 3920 D1A 88
I 3921 3952 D2A 89
I 3953 3984 D3A 90
I 3985 4016 D4A 91
I 4017 4048 D5A 92
I 4049 4080 D6A 93
IINPUTR NS 01
I 1 2048 DA
I 2049 2064 DB 30
I 2065 2096 DC 31
I 2097 2128 DD 32
I 2129 2160 DE 33
I 2161 2192 DF 34
I 2193 2224 DG 35
I 2225 2256 DH 36
I 2257 2288 DI 37
I 2289 2320 DJ 38
I 2321 2352 DK 39
I 2353 2384 DL 40
I 2385 2416 DM 41
I 2417 2448 DN 42
I 2449 2480 DZ 43
I 2481 2512 DO 44
I 2513 2544 DP 45
I 2545 2576 DQ 46
I 2577 2608 DR 47
I 2609 2640 DS 48
I 2641 2672 DT 49
I 2673 2704 DU 50
I 2705 2736 DV 51
I 2737 2768 DW 52
I 2769 2800 DX 53
I 2801 2832 DY 54
I 2833 2864 D0 55
I 2865 2896 D1 56
I 2897 2928 D2 57
I 2929 2960 D3 58
I 2961 2992 D4 59
I 2993 3024 D5 60
I 3025 3056 D6 61
I 3057 3088 DBA 62
I 3089 3120 DCA 63
I 3121 3152 DDA 64
I 3153 3184 DEA 65
I 3185 3216 DFA 66
I 3217 3248 DGA 67
I 3249 3280 DHA 68
I 3281 3312 DIA 69
I 3313 3344 DJA 70
I 3345 3376 DKA 71
I 3377 3408 DLA 72
I 3409 3440 DMA 73
I 3441 3472 DNA 74
I 3473 3504 DOA 75
I 3505 3536 DPA 76
I 3537 3568 DQA 77
I 3569 3600 DRA 78
I 3601 3632 DSA 79
I 3633 3664 DTA 80
I 3665 3696 DUA 81
I 3697 3728 DVA 82
I 3729 3760 DWA 83
I 3761 3792 DXA 84
I 3793 3824 DYA 85
I 3825 3856 DZA 86
I 3857 3888 D0A 87
I 3889 3920 D1A 88
I 3921 3952 D2A 89
I 3953 3984 D3A 90
I 3985 4016 D4A 91
I 4017 4048 D5A 92
I 4049 4080 D6A 93
IDISPF NS 02
I 3 3 AID
I 4 83 ID0
I 84 163 ID1 20
I 164 243 ID2 21
I 244 323 ID3 22
I 324 403 ID4 23
I 404 483 ID5 24
I 484 563 ID6 25
I 564 643 ID7 26
I 644 723 ID8 27
I 724 803 ID9 28
/FREE
BASE = 0;
IF ONCE = ' ';
EXSR @INITZ ;
ENDIF;
// START TAG
DOW @LOOP = @LOOP;
IF RTN = '3';
IF *INU1;
KEYA = SCNKEY;
ENDIF;
IF *INU2;
RRNA = %DEC(%SUBST(SCNKEY:1:11):11:0);
ENDIF;
RTN = '0';
AID = '1';
ELSE;
RTN = '0';
READ(E) DISPF;
ENDIF;
// CF3 EXIT
IF AID = X33;
LEAVE;
ENDIF;
// CF2 RETURN
IF AID = X32;
RTN = '1';
LEAVE;
ENDIF;
// CF1 HEX A FIELD
IF AID = X31;
Y = %LOOKUPLE( CURLOC : B );
IF Y > 0;
IF KY(Y) <= '1';
EXSR @HXDSP;
REHEAD = '1';
EXSR @PUTHED;
REHEAD = ' ';
ENDIF;
ENDIF;
ENDIF;
// CF20 MORE FIELDS
IF AID = XB8;
LVX = LVL + 1;
IF LV(LVX) <> *BLANK;
LVL = LVL +1 ;
LVW = LV;
SCNLV = TEXT500;
SCNLVL = %EDITC(LVL :'X');
SCNKEY = *BLANKS;
IF *INU1;
SCNKEY = KEYA;
ENDIF;
IF *INU2;
SCNKEY = %EDITC(RRNA:'X');
ENDIF;
RTN = '3';
LEAVE;
ENDIF;
ENDIF;
// CF19 PREVIOUS FIELDS
IF AID = XB7;
LVX = LVL - 1;
IF LVX >= 0 ;
LVL = LVL - 1 ;
LVW = LV;
SCNLV = TEXT500;
SCNLVL = %EDITC(LVL :'X');
SCNKEY = *BLANKS;
IF *INU1;
SCNKEY = KEYA;
ENDIF;
IF *INU2;
SCNKEY = %EDITC(RRNA:'X');
ENDIF;
RTN = '3';
LEAVE;
ENDIF;
ENDIF;
// 1 ENTER
// 4 ROLL DN
// 5 ROLL UP
IF AID = '1'or AID = '4' or AID = '5';
ELSE;
MX = 1;
EXSR @ERROR;
ENDIF;
IF RTN <> '3';
EXSR @PCKD;
ENDIF;
// CONT1 GET A RECORD, KEY FROM DATA
EXSR @SETIN;
EXSR @GETF ;
EXSR @PUTF ;
EXSR @KEYIN;
ENDDO ;
*INLR = *ON;
// @@@@@@@ @INITZ @@@@@@@@@@@@@@@@@@@@@@@@@@
BEGSR @INITZ;
ONCE = '1';
KEYLNA = KEYLNG ;
EXSR @INIT ;
EXSR @GETFLD ;
EXSR @GETADD ;
EXSR @PUTHED ;
EXSR @KEYIN ;
INZ = '1';
EXSR @PCKD ;
INZ = ' ';
ENDSR;
// @@@@@@@ @PCKD @@@@@@@@@@@@@@@@@@@@@@@@@@
BEGSR @PCKD ;
// CONVERT KEY DATA
IF *INU1 ;
EXSR @CVTKEY;
ENDIF;
IF *INU2 ;
EXSR @CVTRRN;
ENDIF;
ENDSR;
// @@@@@@@ @CVTKEY @@@@@@@@@@@@@@@@@@@@@@@@
BEGSR @CVTKEY;
// EXTRACT THE KEY FIELD DATA FROM THE INCOMING STRING
// FOR EACH KEY FIELD, CHECK IF FIELD WAS MODIFIED, AND IF SO MOVE
// THE MODIFIED DATA INTO THE COMPOSITE KEY
K1 = 0;
K2 = 0;
W = 1;
FOR Y = 1 TO NUMKEY ;
// MOVE A KEY FIELDS DATA FROM ID ARRAY (SCREEN) TO K ARRAY (KEY FIELDS)
// GET SIZE OF FIELD IN BYTES
IF T(Y) = 'A'; // ALPHA DATA
K = ' ';
K1 = 1;
K2 = Q(Y);
ELSE;
K = '0';
K1 = 1;
K2 = C(Y);
ENDIF;
// IF WHOLE KEY INIT WAS REQUESTED BYPASS THE EXTRACT
IF INZ = '1' ;
KW = *BLANK;
EXSR @PCKMOV;
ITER;
ENDIF;
X = 1;
DOW @LOOP = @LOOP;
// NXTSBA
X = %LOOKUP(SBA : ID : X );
IF X = 0;
LEAVE;
ENDIF;
// IS THIS THE FIELD? CHECK THE BUFFER ADDRESS
X = X +1;
IF B(Y) <> %SUBST(IDA : X :2);
ITER;
ENDIF;
// FOUND A MTD FOR THIS FIELD
X = X + 2;
// CHECK IF FIELD WAS CLEARED ONLY
IF ID(X) = SBA;
EXSR @PCKMOV;
LEAVE ;
ENDIF;
// IF FIELD HAS DECIMALS BUMP X
IF (T(Y) = 'S' OR T(Y) = 'P' OR T(Y) = 'B') AND
P(Y) > 0;
X = X + 1;
ENDIF;
// CHECK IF ONLY BLANKS RETURNED
IF %SUBST(IDA : X :K2) = *BLANKS;
EXSR @PCKMOV;
LEAVE;
ENDIF;
// EXTRACT THE DATA FROM THE INCOMING STRING
X1 = X;
FOR X2 = 1 TO K2 ;
IF ID(X1) < ' ';
// TRAP NULLS CAUSED BY FLD EXIT
EXSR @PCKMOV;
LEAVE;
ENDIF;
K(X2) = ID(X1);
X1 = X1 +1;
ENDFOR;
// CONSTRUCT THE ACTUAL KEY WITH PACKED DATA IF REQUIRED
// INTO ARRAY KW
EXSR @PCKMOV;
LEAVE;
ENDDO;
ENDFOR;
//
KEYA = KW;
CLEAR KW;
ENDSR ;
// @@@@@@@ @CVTRRN @@@@@@@@@@@@@@@@@@@@@@@@
BEGSR @CVTRRN;
// RRN
NUM11 = 0;
DOW @LOOP = @LOOP; // NOT REALLY A LOOP(SIMULATES GOTO)
// GET THE FIRST SBA
X = 1;
X = %LOOKUP(SBA : ID : X );
IF X = 0;
LEAVE;
ENDIF;
// CHECK THE BUFFER ADDRESS MATCHES THE EXPECTED FIELD
X = X +1;
IF B(1) <> %SUBST(IDA : X :2);
LEAVE;
ENDIF;
// FOUND A MTD FOR RRN FIELD
X = X +2;
//CHECK IF FIELD WAS CLEARED ONLY
IF ID(X) = SBA;
LEAVE;
ENDIF;
// CHECK IF ONLY BLANKS RETURNED
IF %SUBST(IDA : X :11) = *BLANKS;
LEAVE;
ENDIF;
// WRK11 OVERLAYS NUM11
WRK11 = %SUBST(IDA : X :11);
LEAVE;
ENDDO;
RRNA = NUM11;
IF RRNA < 0;
RRNA = 1;
ENDIF;
ENDSR;
// @@@@@@@ @PCKMOV @@@@@@@@@@@@@@@@@@@@@@@@
BEGSR @PCKMOV;
//
// CONVERT KEY DATA
// SET START POSN IN KEY USING OFFSET IN R
W = R(Y) + 1;
// ALPHA
IF T(Y) = 'A';
X1 = 1;
FOR Z = W TO W + Q(Y);
%SUBST(KW : Z : 1) = K(X1);
X1 = X1 + 1;
ENDFOR;
ENDIF;
// NUMERIC FIELD
// RIGHT ADJUST NUMERIC DATA ,STRIP - . ,CONVERT BLANKS
IF (T(Y) = 'S' OR T(Y) = 'P' OR T(Y) = 'B');
NU = '0';
Z1 = 60;
FOR Z = K2 DOWNTO K1;
IF K(Z) = '.' OR K(Z) = '-' OR K(Z) = '$';
ITER;
ENDIF;
IF K(Z) = ' ' ;
NU(Z1) = '0';
ELSE;
NU(Z1) = K(Z);
ENDIF;
Z1 = Z1 -1;
ENDFOR;
ENDIF;
// SIGNED FIELDS (END POSN = OFFSET + SIZE)
IF T(Y) = 'S';
NUS = 0;
FOR VX = 1 TO 60;
NUSA = %TRIM(NUSA) + NU(VX);
ENDFOR;
%SUBST(KW : W : Q(Y)) = %SUBST(NUSA: 61 -Q(Y));
ENDIF;
// PACKED FIELDS
IF T(Y) = 'P';
NUSA= *BLANKS;
FOR VX = 1 TO 60;
NUSA = %TRIM(NUSA) + NU(VX);
ENDFOR;
NUP = %DEC(NUSA : 60 : 0);
%SUBST(KW : W : Q(Y)) = %SUBST(NUPA: 61 -Q(Y));
ENDIF;
// BINARY FIELDS
IF T(Y) = 'B';
IF Q(Y) = 2 ;
BY2 = NU(1) + NU(2);
%SUBST(KW : W : 2) = BY2;
ENDIF;
IF Q(Y) = 4 ;
BY4 = NU(1) + NU(2) + NU(3) + NU(4);
%SUBST(KW : W : 4) = BY4;
ENDIF;
ENDIF;
ENDSR;
// @@@@@@@ SETIN @@@@@@@@@@@@@@@@@@@@@@@@@
BEGSR @SETIN;
// SET the FFR indicators to get the Input buffer somewhat aligned with the
// actual data. RPG is somewhat tolerant to a difference between the Ispecs
// and the actual file size but it can fail on big differences.
// INCREMENT OF 32 BYTES
SZ(1) = BASE + 16;
SZ(2) = SZ(1) + 16;
*IN30 = *ON;
IF (RLEN > SZ(2)) ;
*IN31 = *ON;
ENDIF;
FOR X = 3 TO 64;
SZ(X) = SZ(X-1) + 32;
IF (RLEN > SZ(X)) ;
*IN(29+X) = *ON;
ENDIF;
ENDFOR;
ENDSR;
//@@@@@@@@@@@@@@@@@ @GETF @@@@@@@@@@@@@@@@@
BEGSR @GETF;
// GET A DATA RECORD
IF (*INU1);
IF AID = '1' OR AID = X36 OR
AID = X39 OR AID = X3B ;
SETLL(E) KEYA INPUTK;
READ(E) INPUTK;
IF %EOF;
SETLL(E) KEYA INPUTK;
READP(E) INPUTK;
ENDIF;
ENDIF;
IF AID = '4';
READP(E) INPUTK;
ENDIF;
IF AID = '5';
READ(E) INPUTK;
ENDIF;
IF %ERROR;
SETLL(E) KEYA INPUTK;
READ(E) INPUTK;
MX = 7;
EXSR @ERROR;
EXSR @PUTF ;
EXSR @KEYIN;
ENDIF;
KEYA = LKY;
CLEAR KW;
KW = LKY;
ENDIF;
IF (*INU2);
IF AID = '1';
CHAIN(E) RRNA INPUTR;
IF %ERROR;
SETLL(E) RRNA INPUTR;
READP(E) INPUTR;
ENDIF;
ENDIF;
IF AID = X36;
CHAIN(E) RRNA INPUTR;
ENDIF;
IF AID = '4';
READP(E) INPUTR;
ENDIF;
IF AID = '5' OR AID = X3B;
READ(E) INPUTR;
ENDIF;
IF AID = X39;
SETLL(E) *HIVAL INPUTR;
READP(E) INPUTR;
ENDIF;
IF %ERROR;
CHAIN 1 INPUTR;
MX = 7;
EXSR @ERROR;
EXSR @PUTF ;
EXSR @KEYIN;
ENDIF;
ENDIF;
ENDSR;
//@@@@@@@@@@@@@@@@@ @PUTF @@@@@@@@@@@@@@@@@
BEGSR @PUTF;
// WRITE DATA TO THE DISPLAY
NEWRU = '1';
WRTRRN = '1';
RU = *ALLX'00';
CLEAR RU; // initialise Request Unit 255 bytes max
FOR XX = 1 TO NUMFKY; //NUMBER OF DATA ELEMENTS (FLD AND KEY)
IF NEWRU = '1';
NEWRU = '0';
RU = ESC + WTD + X20 + X00;
ENDIF;
IF WRTRRN = '1';
WRTRRN = '0';
RU = RU + SBA + RBA ;
SELECT;
WHEN *INU1;
RRN = RN1;
WHEN *INU2;
RRN = RN2;
ENDSL;
RU = RU + %TRIM(%EDITC(RRN:'Z'));
ENDIF;
// BUFFER ADDRESS
RU = RU + SBA + B(XX);
// PROCESS ALPHA DATA TYPE
IF T(XX) = 'A' OR T(XX) = 'T' OR T(XX) = 'Z' OR
T(XX) = 'L';
STRX = S(XX);
ENDX = E(XX);
IF V(XX) = 'Y'; //VARYING
VX = S(XX);
HX2 = D(VX) + D(VX+1);
STRX = S(XX) + 2 ;
ENDX = S(XX) + BIN;
ENDIF;
FOR Y = STRX TO ENDX ;
IF D(Y) >= ' ';
RU = RU + D(Y);
ELSE;
RU = RU + X1F ; //IF NOT DISPLAYABLE REPLACE WITH X'1F'
ENDIF;
ENDFOR;
ENDIF;
// PROCESS SIGNED DATA TYPE (not the RRN field)
IF T(XX) = 'S' and KY(XX) <> '3';
NUSA = *ALL'0';
WRV = *ALLX'00';
CLEAR WRV;
FOR Y = S(XX) TO E(XX);
IF D(Y) >= XD0;
WRV = WRV + D(Y);
ENDIF;
ENDFOR;
EVAL NUSA = %SUBST(NUSA : 1 : 60 - %LEN(WRV)) + WRV;
CLEAR WRU;
WRU = %TRIM(WRU) + %EDITW(NUS :WRSWRD);
IF P(XX) > 0;
RU = RU +
%SUBST(WRU :61-C(XX): C(XX)-P(XX)) + '.' +
%SUBST(WRU :61-P(XX)) ;
ELSE;
RU = RU +
%SUBST(WRU :61-C(XX));
ENDIF;
ENDIF;
// PROCESS SIGNED DATA TYPE (the RRN field)
IF T(XX) = 'S' and KY(XX) = '3';
RRN = RN2;
RU = RU + %TRIM(%EDITC(RRN:'X'));
ENDIF;
// PROCESS PACKED DATA TYPE
IF T(XX) = 'P';
NUPA = *ALLX'00';
WRV = *ALLX'00';
CLEAR WRV;
FOR Y = S(XX) TO E(XX);
WRV = WRV + D(Y);
ENDFOR;
IF %BITAND(D(E(XX)) :X0F) = X0F OR
%BITAND(D(E(XX)) :X0D) = X0D;
EVAL NUPA = %SUBST(NUPA : 1 : 60 - %LEN(WRV)) + WRV;
CLEAR WRX;
WRX = %TRIM(WRX) + %EDITW(NUP :WRXWRD);
IF P(XX) > 0;
RU = RU +
%SUBST(WRX :64-C(XX): C(XX)-P(XX)) + '.' +
%SUBST(WRX :64-P(XX)) ;
ELSE;
RU = RU +
%SUBST(WRX :64-C(XX));
ENDIF;
ELSE;
// PACKED FIELD IN ERROR
RU = RU + X1F;
ENDIF;
ENDIF;
// PROCESS BINARY DATA TYPE
IF T(XX) = 'B';
ST = S(XX);
CLEAR NUSA;
IF Q(XX) = 2;
BY2 = D(ST) + D(ST+1);
NUS = BIN2;
ENDIF;
IF Q(XX) = 4;
BY4 = D(ST) + D(ST+1)+ D(ST+2) + D(ST+3);
NUS = BIN4;
ENDIF;
WRU = %EDITW(NUS :WRSWRD);
IF P(XX) > 0;
RU = RU +
%SUBST(WRU :61-C(XX): C(XX)-P(XX)) + '.' +
%SUBST(WRU :61-P(XX)) ;
ELSE;
RU = RU +
%SUBST(WRU :61-C(XX));
ENDIF;
ENDIF;
// PROCESS FLOAT DATA TYPE
IF T(XX) = 'F';
ST = S(XX);
IF Q(XX) = 4;
FL4 = D(ST) + D(ST+1)+ D(ST+2) + D(ST+3);
FLT14 = %EDITFLT(FLT4);
RU = RU + FLT14;
ENDIF;
IF Q(XX) = 8;
FL8 = D(ST) + D(ST+1)+ D(ST+2) + D(ST+3) +
D(ST+4) + D(ST+5)+ D(ST+6) + D(ST+7);
FLT23 = %EDITFLT(FLT8);
RU = RU + FLT23;
ENDIF;
ENDIF;
// SEND A REQUEST UNIT IF GOT ENOUGH DATA
IF %LEN(RU) + L(XX + 1) >= 200;
RU = RU + X20;
BIN = %LEN(RU);
OUTLEN = HX2;
INLEN = X000;
FNC = SND;
A = RU;
EXCEPT DATAO;
NEWRU = '1';
RU = *ALLX'00';
CLEAR RU;
ENDIF;
ENDFOR;
IF %LEN(RU) > 5 AND %LEN(RU) < 250;
RU = RU + X20;
BIN = %LEN(RU);
OUTLEN = HX2;
INLEN = X000;
FNC = SND;
A = RU;
EXCEPT DATAO;
ENDIF;
ENDSR;
// @@@@@@@@@@@@@@@ ROWINC @@@@@@@@@@@@@@@
// INCREMENT THE ROW
BEGSR @ROWINC;
ROW = ROW + 2;
IF ROW > 20;
MX = 3;
ENDIF;
ENDSR;
// @@@@@@@@@@@@@@@ GETFLD @@@@@@@@@@@@@@@
// LOAD FIELD DESCRIPTION ARRAYS
BEGSR @GETFLD;
MX = 0;
X = 0;
IF (*INU2 = *ON);
// IF NON KEYED ACCESS SET UP A FIELD TO SHOW THE RRN
N(1) = 'RRN';
T(1) = 'S' ;
C(1) = 11 ;
P(1) = 0 ;
S(1) = 0 ;
E(1) = 0 ;
L(1) = 12 ;
I(1) = X4F06 ;
KY(1)= '3' ;
X = 1 ;
ENDIF;
SCRST = *BLANK;
SCRSTN = *BLANK;
LVL = %DEC(SCNLVL : 5:0);
TEXT500 = SCNLV ;
LV = LVW;
IF LVL <> 0;
SCRST = LV(LVL);
ENDIF;
SETLL 1 QWHDRFFD ;
DOW @LOOP = @LOOP;
// REREAD TAG
READ QWHDRFFD;
IF %EOF;
LEAVE;
ENDIF;
// SELECT OR OMIT
IF ALL <> '1';
IF ALL = 'S' AND WHDFTL = 0; // USING WHDFTL FOR KEY FIELDS
IF WHFIOB <> 'S';
ITER;
ENDIF;
ENDIF;
IF ALL = 'O' AND WHDFTL = 0; // USING WHDFTL FOR KEY FIELDS
IF WHFIOB = 'O';
ITER;
ENDIF;
ENDIF;
ENDIF;
// FIND THE FIRST FIELD TO BE SHOWN (FOR MULTI PAGE FORMATS)
IF WHDFTL <> 0 ;
ELSE;
IF SCRST <> ' ' AND SCRSTN = ' ';
IF WHFLDE = SCRST;
SCRSTN = '1'; // FOUND THE START
ELSE;
ITER;
ENDIF;
ENDIF;
ENDIF;
X = X + 1;
// CHECK FOR KEY FIELDS,WILL BE USED TO PLACE THEM IN FRONT
IF WHDFTL <> 0;
KY(X) = '1';
WX = WHDFTL ;
KE(WX) = WHFLDE;
IF NUMKEY < WHDFTL;
NUMKEY = WHDFTL;
ENDIF;
ENDIF;
N(X) = WHFLDE ; // NAME
T(X) = WHFLDT ; // TYPE
V(X) = WHVARL ; // VARYING
C(X) = WHFLDD ; // DEC DIGITS
P(X) = WHFLDP ; // DEC PREC
S(X) = WHFOBO ; // START
Q(X) = WHFLDB ; // BTYES
E(X) = WHFOBO + WHFLDB -1 ; // END
IF T(X) = 'F' ; // FLOAT
I(X) = FFA1 + FFA2; // SCRN FIELD FORMAT ALPHA
L(X) = 14;
IF Q(X) = 8;
L(X) = 23;
ENDIF;
ELSE;
IF WHFLDD <> 0 ;
IF WHFLDP <> 0 ;
L(X) = WHFLDD + 2 ; // LENGTH
ELSE;
L(X) = WHFLDD + 1 ; // LENGTH
ENDIF;
I(X) = FFN1 + FFN2; // SCRN FIELD FORMAT NUMERIC
ELSE;
L(X) = WHFLDB ;
I(X) = FFA1 + FFA2; // SCRN FIELD FORMAT ALPHA
ENDIF;
ENDIF;
ENDDO;
// NUMBER OF FIELDS
NUMFLD = X ;
// MAKE ROOM FOR KEYS
IF NUMKEY > 0 ;
X1 = NUMKEY + NUMFLD;
FOR X = NUMFLD DOWNTO 1;
KY(X1) = KY(X) ;
L(X1) = L(X) ;
I(X1) = I(X) ;
N(X1) = N(X) ;
T(X1) = T(X) ;
V(X1) = V(X) ;
C(X1) = C(X) ;
P(X1) = P(X) ;
S(X1) = S(X) ;
E(X1) = E(X) ;
Q(X1) = Q(X) ;
X1 = X1 - 1;
ENDFOR;
// PUT KEY FIELDS AT TOP
OFF = 0;
FOR X = 1 TO NUMKEY;
X1 = %LOOKUP(KE(X) : N : NUMKEY+1);
KY(X) = '2';
L(X) = L(X1);
I(X) = I(X1); // FIELD FMT
SELECT; // INPUT ENABLE
WHEN I(X) = X6000;
I(X) = X4800;
WHEN I(X) = X6706;
I(X) = X4F06;
ENDSL;
N(X) = N(X1);
T(X) = T(X1);
V(X) = V(X1);
C(X) = C(X1);
P(X) = P(X1);
S(X) = S(X1);
E(X) = E(X1);
Q(X) = Q(X1);
R(X) = OFF;
OFF = OFF + Q(X1);
ENDFOR;
ENDIF;
// NUMBER OF FIELDS AND KEYS
NUMFKY = NUMFLD + NUMKEY;
ENDSR;
// @@@@@@@@@@@@@@@ GETADD @@@@@@@@@@@@@@@
// LOAD FIELD BUFFER ADDRESSES
BEGSR @GETADD;
MX = 0;
X = 0;
ROW = 3;
COL = 1;
FOR X = 1 TO NUMFKY;
// IF FINISHED WITH THE KEY FIELDS
// INC ROW FOR 1ST DATA FIELD
IF KEYSOK = ' ' ;
IF KY(X) = ' ' OR KY(X) = '1';
KEYSOK = '1' ;
ROW = ROW + 2;
COL = 1;
ENDIF;
ENDIF;
// SET THE BUFFER ADD ON THE LARGER OF THE FIELD TEXT OR THE FIELD SIZE
LENDSC = %LEN(%TRIM(N(X)));
LENWRK = L(X);
IF LENDSC > L(X);
LENWRK = LENDSC;
ENDIF;
LENWRK = LENWRK + 2;
// TRAP FIELDS THAT OVERFLOW
ROW = ROW + XROW;
XROW = %DIV(LENWRK : 80);
IF (COL + LENWRK) > 78;
EXSR @ROWINC;
IF MX = 3;
X= X-1;
NUMFKY = X;
LEAVE;
ENDIF;
COL = 1;
ENDIF;
// INC COL. FOR FIELD START
CLEAR B(X);
BIN = ROW;
B(X) = %TRIM(B(X)) + HX1;
BIN = COL + 1;
B(X) = %TRIM(B(X)) + HX1;
// INC COL. FOR NEXT FIELD
COL = COL + LENWRK;
IF COL > 78;
EXSR @ROWINC;
IF MX = 3; // NO ROOM FOR THE FIELD
X= X-1;
NUMFKY = X;
LEAVE;
ENDIF;
COL = 1;
ENDIF;
ENDFOR;
// FIELD LEVEL
LVX = LVL + 1;
LV(LVX) = N(X);
ENDSR;
// @@@@@@@@@@@@@@@ PUTHED @@@@@@@@@@@@@@@
// PUT FIELD HEADINGS
BEGSR @PUTHED;
NEWRU = '1';
RU = *ALLX'00';
CLEAR RU; // initialise Request Unit 255 bytes max
FOR XX = 1 TO NUMFKY; //NUMBER OF DATA ELEMENTS (FLD AND KEY)
IF NEWRU = '1';
NEWRU = '0';
RU = ESC + WTD + X20 + X00;
ENDIF;
RU = RU + SBA;
BIN = 0;
// CONVERT DATA BUFADR TO HEADING BUFADR
HX1 = %SUBST(B(XX) :1:1);
BIN = BIN - 1;
RU = RU + HX1;
IF REHEAD = '1'; // ON REDISPLAY OVERRIDE THE ATTR
BIN = 0;
HX1 = %SUBST(B(XX) :2:1);
BIN = BIN -1 ;
RU = RU + HX1;
ELSE;
RU = RU + %SUBST(B(XX) :2);
ENDIF;
RU = RU + ATC ;
// LONG NUMBER FIELDS ,RIGHT ADJUST THE FIELD HEADINGS
LENDSC = %LEN(%TRIM(N(XX)));
IF T(XX) <> 'A' AND LENDSC < (L(XX) -1);
FOR Y = 1 TO (L(XX) -(LENDSC +1));
RU = RU + ' ';
ENDFOR;
ENDIF;
RU = RU + %TRIM(N(XX));
IF %LEN(RU) >= 200;
BIN = %LEN(RU);
OUTLEN = HX2;
INLEN = X000;
FNC = SND;
A = RU;
EXCEPT DATAO;
NEWRU = '1';
RU = *ALLX'00';
CLEAR RU;
ENDIF;
ENDFOR;
IF %LEN(RU) > 5 AND %LEN(RU) < 200;
BIN = %LEN(RU);
OUTLEN = HX2;
INLEN = X000;
FNC = SND;
A = RU;
EXCEPT DATAO;
ENDIF;
IF REHEAD <> '1';
// FORMAT FIELDS
NEWRU = '1';
RU = *ALLX'00';
CLEAR RU; // initialise Request Unit 255 bytes max
FOR XX = 1 TO NUMFKY; //NUMBER OF DATA ELEMENTS (FLD AND KEY)
IF NEWRU = '1';
NEWRU = '0';
RU = ESC + WTD + X20 + X00;
ENDIF;
RU = RU + SBA +B(XX)+SF + I(XX);
IF KY(XX) = '1' OR KY(XX) = '2' OR KY(XX) = '3';
RU = RU + X25;
ELSE;
RU = RU + X26;
ENDIF;
BIN = L(XX);
RU = RU + HX2;
// LENGTH OF INPUT FIELDS
LENF = LENF + L(XX) + 3;
IF %LEN(RU) >= 200;
BIN = %LEN(RU);
OUTLEN = HX2;
INLEN = X000;
FNC = SND;
A = RU;
EXCEPT DATAO;
NEWRU = '1';
RU = *ALLX'00';
CLEAR RU;
ENDIF;
ENDFOR;
// PUT LAST R/U
IF %LEN(RU) > 5 AND %LEN(RU) < 200;
BIN = %LEN(RU);
OUTLEN = HX2;
INLEN = X000;
FNC = SND;
A = RU;
EXCEPT DATAO;
ENDIF;
//INC BUFFER ADDRESS FOR ALL FIELDS FOR DATA PUT
FOR XP = 1 TO NUMFKY; //NUMBER OF DATA ELEMENTS (FLD AND KEY)
HX2 = B(XP);
BIN = BIN + 1;
B(XP) = HX2;
ENDFOR;
ENDIF;
ENDSR;
// @@@@@@@ INIT @@@@@@@@@@@@@@@@@@@@@@@@@
BEGSR @INIT;
CLEAR KW;
// UPDATE
IF UPDF = 'Y';
FFA1 = X40;
FFN1 = X47;
ELSE;
FFA1 = X60;
FFN1 = X67;
ENDIF;
SELECT;
WHEN *INU1 = '1';
FILE = F1 ;
LIB = L1 ;
MBR = M1 ;
RCDL = R1 ;
ACCTP = A1 ;
WHEN *INU2 = '1';
FILE = F2 ;
LIB = L2 ;
MBR = M2 ;
RCDL = R2 ;
ACCTP = A2 ;
ENDSL;
RLEN = RCDL ;
RLENTH = %EDITC(RLEN: 'X') ;
LENF = 0 ;
// Control commands and data are constructed into RUs Request UNITS
// Each RU is 256 bytes max size.
// Construct and send as many RUs as needed to format the display.
RU = *ALLX'00';
CLEAR RU; // initialise Request Unit 255 bytes max
RU = CLRWTD ;
//set up the screen headings
BIN = 1; // set ROW to 1
RW = HX1;
BIN = 2; // set COL to 2
CL = HX1;
RU = RU + SBA + RW + CL + X22 + %TRIM(LIB) + '/' + %TRIM(FILE);
RU = RU + ' Mbr ' + %TRIM(MBR) + ' Rcdl ' + %EDITC(RLEN : 'Z') ;
RU = RU + ' RRN ' ;
BIN = %len(RU) -4;
RBA = RW + HX1 ; // address of the RRN field
RU = RU + SBA + RBA + ' ';
// FUNCTION KEYS
BIN = 23;
RW = HX1;
BIN = 02;
CL = HX1;
IF UPDF = 'Y'; // UPDATE IS ON
RU = RU + SBA + RW + CL + %TRIM(CNS(2));
ELSE;
RU = RU + SBA + RW + CL + %TRIM(CNS(1));
ENDIF;
// THIS IS A SEND ONLY FUNCTION
FNC = SND;
CLEAR A;
A = RU;
BIN2 = %LEN(RU);
OUTLEN = BY2;
INLEN = x000;
EXCEPT DATAO;
ENDSR;
// @@@@@@@ KEYIN @@@@@@@@@@@@@@@@@@@@@@@@@
BEGSR @KEYIN;
// ISSUE A READ FROM DISPLAY
FNC = SNR;
BIN2 = 8;
OUTLEN = BY2;
IPL = LENF + 34;
BIN2 = IPL;
INLEN = BY2;
// SET FRR INDICATORS TO CONTROL BUFFER OVERFLOW
FOR X = 1 TO 9;
IF IPL > ( X*80 +3);
*IN(X+19) = *ON;
ENDIF;
ENDFOR;
RU = *ALLX'00';
CLEAR RU;
RU = RDDSP;
A = RU;
EXCEPT DATAI;
ENDSR;
// @@@@@@@ ERROR @@@@@@@@@@@@@@@@@@@@@@@@@
BEGSR @ERROR;
// SETUP PUT ERROR MESSAGE X'21'
RU = *ALLX'00';
CLEAR RU;
FNC = SNR;
BIN = 42;
OUTLEN = HX2;
BIN = LENF + 34;
IPL = BIN;
INLEN = HX2;
FOR X = 1 TO 9;
IF IPL > (X * 80 +3) ;
*IN(X + 19) = *ON; // SETON FFR 20 - 29 FOR INPUT
ENDIF;
ENDFOR;
RU = ESC + WER + IC + B(1) + ATC + MSG(MX);
RU = RU + ESC + RDM + X40+ X00;
A = RU;
EXCEPT DATAI;
RU = *ALLX'00';
CLEAR RU;
ENDSR;
// @@@@@@@ HXDSP @@@@@@@@@@@@@@@@@@@@@@@@@
BEGSR @HXDSP;
RU = *ALLX'00';
CLEAR RU;
Y = %LOOKUPLE( CURLOC : B );
//
RU = ESC + WTD + X20 + X00 + SBA;
BIN = 0;
HX1 = %SUBST(B(Y) :1:1);
BIN = BIN - 1;
RU = RU + HX1;
RU = RU + %SUBST(B(Y) :2:1);
FOR X = S(Y) TO E(Y);
BIN = 0;
HX1 = D(X);
HX1 = %BITAND(HX1 : XF0);
Z = BIN / 16 + 1;
RU = RU + CRS(Z);
ENDFOR;
RU = RU + X20;
RU = RU + SBA + B(Y);
FOR X = S(Y) TO E(Y);
BIN = 0;
HX1 = D(X);
HX1 = %BITAND(HX1 : X0F);
Z = BIN + 1;
RU = RU + CRS(Z);
ENDFOR;
BIN = %LEN(RU);
OUTLEN = HX2;
INLEN = X000;
FNC = SND;
A = RU;
EXCEPT DATAO;
RU = *ALLX'00';
CLEAR RU;
EXSR @KEYIN;
READ DISPF;
// CLEAR HEADINGS
RU = *ALLX'00';
CLEAR RU;
RU = RU + ESC + WTD + X20 + X00 + SBA;
HX1 = %SUBST(B(Y) :1:1) ;
BIN = BIN - 1;
RU = RU + HX1 + %SUBST(B(Y):2:1);
FOR X = S(Y) TO E(Y);
RU = RU + ' ';
ENDFOR;
RU = RU + ' ';
BIN = %LEN(RU);
OUTLEN = HX2;
INLEN = X000;
FNC = SND;
A = RU;
EXCEPT DATAO;
RU = *ALLX'00';
CLEAR RU;
ENDSR;
/END-FREE
ODISPF E DATAO
O K3 'PUT'
O OUTLEN 2
O INLEN
O FNC
O A
O E DATAI
O K3 'GET'
O OUTLEN 2
O INLEN
O FNC
O A
**
0000 INVALID COMMAND KEY
0001 - A FIELD IS TOO LONG
0002 - TOO MANY FIELDS
0003 - ALPHAS IN PACKED KEY
0004 - MISSING ' IN PACKED KEY
0005 - MISSING DATA IN PCKD KEY
0006 - RECORD NOT FOUND
PRESS RESET TO CONTINUE
**
F1-HEX F2-Return F3-Exit F19-Prev_fld F20-More_fld
F1-HEX F2-Return F3-Exit F19-Prev_fld F20-More_fld
**
0123456789ABCDEF
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
