Difference between revisions of "UDDS File Displayer"
From MidrangeWiki
(→UDDS) |
(→UDDS) |
||
| Line 3: | Line 3: | ||
==UDDS== | ==UDDS== | ||
| − | The manual that describes the 5250 data stream is 5494 Remote Control Unit, Functions Reference. (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] |
[https://www-05.ibm.com/e-business/linkweb/publications/servlet/pbi.wss?PAG=C11&SSN=16I2K0000952086390&TRL=TXT&WRD=&PBL=SC30-3533-04&LST=ALL&RPP=10&submit=Go] | [https://www-05.ibm.com/e-business/linkweb/publications/servlet/pbi.wss?PAG=C11&SSN=16I2K0000952086390&TRL=TXT&WRD=&PBL=SC30-3533-04&LST=ALL&RPP=10&submit=Go] | ||
| + | |||
| + | IBMs publib site seems to be no longer working and is replaced by a new site, however even though I can get to the site I cant get the IBM Download Director to work as it constantly refuses my connection. | ||
The purpose of this program is to demo an example of a program using UDDS. | The purpose of this program is to demo an example of a program using UDDS. | ||
Revision as of 10:28, 29 September 2016
Contents
UDDS
The manual that describes the 5250 data stream is 5494 Remote Control Unit, Functions Reference. SC30-3533-04 (topic 15) [1] [2]
IBMs publib site seems to be no longer working and is replaced by a new site, however even though I can get to the site I cant get the IBM Download Director to work as it constantly refuses my connection.
The purpose of this program is to demo an example of a program using UDDS.
It shows file data, but is limited to 2048 max rcdlen. You can recode the I specs to get versions that handle bigger records.
This is a conversion of an old S/38 program that was mostly MOVE and MOVEA and arrays, so it probably still has bugs.
It uses a very old S/38 technique of Program Described Display Files. I cant even find any documentation on this technique. I last used it in earnest when we converted S/3 CCP programs to run on the S38. Its really amazing how IBM keeps this backward compatability.
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*
F* REQUIRES FILE TO COMPILE
F* DSPFFD FILE(&LIB/&FILE) OUTPUT(*OUTFILE) OUTFILE(QTEMP/FFD)
F*
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 500
D 5
D 800
DDISP PI
D ALL 1
D RTN 1
D KEYLNG 4
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' READ FROM DISPLAY
D UPDF C 'N'
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;
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;
ELSE;
RTN = '0';
ENDIF;
// 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
// NOTE... ONLY CHANGED FIELD DATA IS RETURNED,
// USE THE BUFFER ADDRESS TO IDENTIFY THE FIELD
// 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(NUS : 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;
// SAVE THE LAST KEY
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 ; // STORE the address of the RRN field
RU = RU + SBA + RBA + ' ';
// FOOTER LINE 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
WRAPPER CODE
DISPR RPG
H OPTIMIZE(*NONE) OPTION(*NODEBUGIO)
H DFTACTGRP(*NO) ACTGRP(*CALLER)
.....
* FILE RELATIONS
* 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)
*
*
*
.....
FACC 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
*
* 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*%%TS SD 20101208 163705 REL-V5R4M0 5722-WDS
A*
A*%%EC
A DSPSIZ(24 80 *DS3)
A PRINT
A CF03(03)
A CF12(12)
A R S01 SFL
A*%%TS SD 20101208 163705 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/ACC)
A S01APLIB R O 4 17REFFLD(QWHFDACP/APLIB QTEMP/ACC)
A S01APACCP R O 4 29REFFLD(QWHFDACP/APACCP QTEMP/ACC)
A S01APUNIQ R O 4 33REFFLD(QWHFDACP/APUNIQ QTEMP/ACC)
A S01APSELO R O 4 37REFFLD(QWHFDACP/APSELO QTEMP/ACC)
A S01APFTYP R O 4 41REFFLD(QWHFDACP/APFTYP QTEMP/ACC)
A S01APJOIN R O 4 45REFFLD(QWHFDACP/APJOIN QTEMP/ACC)
A S01APKEYO R O 4 48REFFLD(QWHFDACP/APKEYO QTEMP/ACC)
A S01APKSEQ R O 4 53REFFLD(QWHFDACP/APKSEQ QTEMP/ACC)
A S01APKSIN R O 4 57REFFLD(QWHFDACP/APKSIN QTEMP/ACC)
A S01APKEYF R O 4 61REFFLD(QWHFDACP/APKEYF QTEMP/ACC)
A R C01 SFLCTL(S01)
A*%%TS SD 20101208 163705 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/ACC)
A 1 51'Lib.'
A C01APBOL R O 1 56REFFLD(QWHFDACP/APBOL QTEMP/ACC)
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 to compile
// 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 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 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 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'
DSPFL CMD
/* TO COMPILE */
/* CRTCMD CMD(*CURLIB/DSPFL) PGM(*LIBL/DSPFLC) SRCFILE(*LIBL/QCMDSRC) */
/* SRCMBR(DSPFL) VLDCKR(DSPFLV) */
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(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')
DSPFLC CLLE
PGM (&FILIB &MBR &RST &REL)
/* DISPLAY A FILE */
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 &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 DSPFLT (&FILEK &TYPE &PHY &PHYLIB)
IF (&TYPE *EQ 'P') DO
CHGVAR &PHY &FILE
CHGVAR &PHYLIB &LIB
ENDDO
/* LOAD THE FILE RELATIONS DATA */
CALL DSPFLR (&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
/* FILE DISPLAY DRIVER */
CALL DSPFLC1 (&FILIB &MBR &RST &RTN &FILE &LIB &FILEF &FILEK)
RCLRSC
END:
CLOF OPNID(&FILE)
MONMSG CPF0000
ENDPGM
DSPFLC1 CLLE
PGM (&FILIB &MBR &RST &RTN &FILE &LIB &FILEF &FILEK)
/* FILE DISPLAYER DRIVER */
/* */
/* THIS CONTAINS A LOOP SO THAT MORE FIELDS CAN BE DISPLAYED */
/* WHEN ALL THE FIELDS DONT FIT ON ONE SCREEN */
/* */
/* */
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 &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 DSPFLCX /* FOR OPNQRYF PARMS FOR RECORD SELECTION */
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)
/* SHOW THE FILE FIELDS */
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)
/* RECORD SELECTION IS REQUESTED */
IF (&QRY ) DO
REMSG:
REQRY: SNDRCVF RCDFMT(SLT)
IF (&IN01 *OR &IN02) GOTO BYQRY
CHGVAR &OPT '*INP'
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'
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
/* CAN ONLY HANDLE FILE WITH RCDLEN UP TO 2048 */
IF ((&RCDLN *GT 0) *AND (&RCDLN *LE 2048)) THEN(DO)
/* SHOW THE FILE DATA */
CALL DISP (&ALL &RTN &KEYL &SCNLV &SCNLVL &SCNKEY)
ENDDO
ELSE (GOTO END)
IF (&QRY ) (DO)
IF (&ACCP *EQ 'K') DO
CLOF INPUTK
MONMSG CPF0000
ENDDO
IF (&ACCP *EQ 'A') DO
CLOF INPUTR
MONMSG CPF0000
ENDDO
ENDDO
/* THIS CONTROLS THE F20 MORE FIELDS FUNCTION */
IF (&RTN *EQ '3') DO
GOTO BYQRYA
ENDDO
/* RETURN TO THE FIELD LIST */
IF (&RTN *EQ '1') DO
CHGVAR &RTN '0'
GOTO RTN
ENDDO
END: ENDPGM
DSPFLCX DSPF
A DSPSIZ(24 80 *DS3)
A PRINT
A CF02(02 'return')
A CF03(01 'exit')
A R SLT
A OVERLAY
A 1 2'Qryslt:'
A QSLT 1509A B 1 12CHECK(LC)
A 20 1'F2-Return '
A R SLTR SFL
A SFLMSGRCD(21)
A MSGKEY SFLMSGKEY
A PGMQ SFLPGMQ
A R SLTC SFLCTL(SLTR )
A OVERLAY
A SFLSIZ(50) SFLPAG(3)
A N20 SFLEND
A N20 SFLDSP
A N20 SFLDSPCTL
A N20 SFLINZ
A 20 SFLCLR
A PGMQ SFLPGMQ
DSPFLR CLLE
PGM (&PHY &PHYLIB &SFILE &SLIB)
/* DISPLAY ACCESS PATHS */
/* REQUIRES A FILE TO COMPILE */
/* DSPDBR FILE(&PHYLIB/&PHY) OUTPUT(*OUTFILE) + */
/* OUTFILE(QTEMP/DSPFDBR) OUTMBR(*FIRST *REPLACE) */
DCL &PHY *CHAR 10
DCL &PHYLIB *CHAR 10
DCL &SFILE *CHAR 10
DCL &SLIB *CHAR 10
DCL &LIB *CHAR 10 'QSYS'
DCLF QTEMP/DSPFDBR
DLTF QTEMP/DSPFDBR
MONMSG CPF0000
CLRPFM QTEMP/DSPFACC
MONMSG CPF0000 EXEC(DO)
CRTDUPOBJ OBJ(QAFDACCP) FROMLIB(&LIB) +
OBJTYPE(*FILE) TOLIB(QTEMP) NEWOBJ(DSPFACC)
MONMSG CPF0000
ENDDO
CLRPFM QTEMP/DSPFSEL
MONMSG CPF0000 EXEC(DO)
CRTDUPOBJ OBJ(QAFDSELO) FROMLIB(&LIB) +
OBJTYPE(*FILE) TOLIB(QTEMP) NEWOBJ(DSPFSEL)
MONMSG CPF0000
ENDDO
DSPDBR FILE(&PHYLIB/&PHY) OUTPUT(*OUTFILE) +
OUTFILE(QTEMP/DSPFDBR) OUTMBR(*FIRST *REPLACE)
CHGPF QTEMP/DSPFDBR LVLCHK(*NO)
NEXT: RCVF
MONMSG CPF0000 EXEC(GOTO END)
IF (&WHREFI *NE ' ') DO
DSPFD FILE(&WHRELI/&WHREFI) TYPE(*ACCPTH) +
OUTPUT(*OUTFILE) OUTFILE(QTEMP/DSPFACC) OUTMBR(*FIRST *ADD)
CHGPF QTEMP/DSPFACC LVLCHK(*NO)
DSPFD FILE(&WHRELI/&WHREFI) TYPE(*SELECT) +
OUTPUT(*OUTFILE) OUTFILE(QTEMP/DSPFSEL) OUTMBR(*FIRST *ADD)
CHGPF QTEMP/DSPFSEL LVLCHK(*NO)
ENDDO
GOTO NEXT
END:
DSPFD FILE(&PHYLIB/&PHY ) TYPE(*ACCPTH) +
OUTPUT(*OUTFILE) OUTFILE(QTEMP/DSPFACC) OUTMBR(*FIRST *ADD)
CHGPF QTEMP/DSPFACC LVLCHK(*NO)
CHGVAR &SFILE ' '
CHGVAR &SLIB ' '
OVRDBF SEL QTEMP/DSPFSEL
OVRDBF ACC QTEMP/DSPFACC
CALL DISPR (&SFILE &SLIB)
DLTOVR *ALL
ENDPGM
DSPFLT CLLE
PGM (&DISF &TYPE &PHY &PHYLIB)
/* NEEDS FILE TO COMPILE */
/* DSPFD (&LIB/&FILE) TYPE(*ACCPTH) OUTPUT(*OUTFILE) OUTFILE(QTEMP/KF) */
/* CHECK FILE TYPE */
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
DSPFLV CLLE
/* COMMAND PARMS VALIDITY CHECKER */
PGM (&FILIB &MBR &RST &REL)
DCL &FILIB *CHAR 20
DCL &FILE *CHAR 10
DCL &LIB *CHAR 10
DCL &MBR *CHAR 10
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 '
CHKOBJ (&LIB/&FILE) OBJTYPE(*FILE) MBR(*NONE) +
AUT( &AUT )
MONMSG (CPF9899 CPF9801 CPF9802 CPF9820 CPF9830) EXEC(DO)
SNDPGMMSG MSG('Not authorised to the file.') +
MSGTYPE(*DIAG)
CHGVAR (&ERROR) '1'
ENDDO
MONMSG (CPF9810) EXEC(DO)
CHGVAR (&MSGDTA) VALUE(' '||&LIB)
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 '
CHKOBJ OBJ(&LIB/&FILE) OBJTYPE(*FILE) MBR(&MBR) +
AUT(&AUT)
MONMSG (CPF9815 ) EXEC(DO)
SNDPGMMSG MSG('Not authorised to the file.') +
MSGTYPE(*DIAG)
CHGVAR (&ERROR) '1'
ENDDO
MONMSG (CPF0000 ) EXEC(DO)
SNDPGMMSG MSG('Not authorised to the file.') +
MSGTYPE(*DIAG)
CHGVAR (&ERROR) '1'
ENDDO
ENDDO
IF (&ERROR) (SNDPGMMSG MSGID(CPF0002) MSGF(QCPFMSG) MSGTYPE(*ESCAPE))
ENDPGM
