Difference between revisions of "UDDS File Displayer"
From MidrangeWiki
(→UDDS) |
(→UDDS) |
||
| Line 4: | Line 4: | ||
==UDDS== | ==UDDS== | ||
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] | ||
| − | |||
| − | ( regarding the Functions Reference Manual IBMs publib site seems to be no longer working | + | ( regarding the Functions Reference Manual IBMs publib site seems to be no longer working. So the only reference left is in Sourceforge. |
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. | ||
Latest revision as of 13:05, 29 October 2018
Contents
UDDS
The manual that describes the 5250 data stream is 5494 Remote Control Unit, Functions Reference. SC30-3533-04 (topic 15) [1]
( regarding the Functions Reference Manual IBMs publib site seems to be no longer working. So the only reference left is in Sourceforge.
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
