Difference between revisions of "UDDS File Displayer"
m (typo) |
m (typo) |
||
Line 360: | Line 360: | ||
D X6706 C X'6706' FF NUMERIC | D X6706 C X'6706' FF NUMERIC | ||
D CLRWTD C X'044004112000' INCLUDES ESC CHARS | D CLRWTD C X'044004112000' INCLUDES ESC CHARS | ||
− | D RDDSP C X'0411200804524000' | + | D RDDSP C X'0411200804524000' READ FROM DISPLAY |
D UPDF C 'N' | D UPDF C 'N' | ||
D FFA1 S 1 INZ(X'40') F.FMT 1 ALPH 60 BYP | D FFA1 S 1 INZ(X'40') F.FMT 1 ALPH 60 BYP | ||
Line 1,807: | Line 1,807: | ||
[[#top]] | [[#top]] | ||
− | |||
− | |||
===DISPR RPG === | ===DISPR RPG === |
Revision as of 13:03, 31 January 2011
Contents
UDDS
The manual that describes the 5250 data stream is 5494 Remote Control Unit, Functions Reference. (topic 15) [1]
The purpose of this program is to demo an example of a program using UDDS.
It shows file data, but is limited to 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 backard 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; RTN = '0'; AID = '1'; ELSE; RTN = '0'; READ(E) DISPF; ENDIF; // CF3 EXIT IF AID = X33; LEAVE; ENDIF; // CF2 RETURN IF AID = X32; RTN = '1'; LEAVE; ENDIF; // CF1 HEX A FIELD IF AID = X31; Y = %LOOKUPLE( CURLOC : B ); IF Y > 0; IF KY(Y) <= '1'; EXSR @HXDSP; REHEAD = '1'; EXSR @PUTHED; REHEAD = ' '; ENDIF; ENDIF; ENDIF; // CF20 MORE FIELDS IF AID = XB8; LVX = LVL + 1; IF LV(LVX) <> *BLANK; LVL = LVL +1 ; LVW = LV; SCNLV = TEXT500; SCNLVL = %EDITC(LVL :'X'); SCNKEY = *BLANKS; IF *INU1; SCNKEY = KEYA; ENDIF; IF *INU2; SCNKEY = %EDITC(RRNA:'X'); ENDIF; RTN = '3'; LEAVE; ENDIF; ENDIF; // CF19 PREVIOUS FIELDS IF AID = XB7; LVX = LVL - 1; IF LVX >= 0 ; LVL = LVL - 1 ; LVW = LV; SCNLV = TEXT500; SCNLVL = %EDITC(LVL :'X'); SCNKEY = *BLANKS; IF *INU1; SCNKEY = KEYA; ENDIF; IF *INU2; SCNKEY = %EDITC(RRNA:'X'); ENDIF; RTN = '3'; LEAVE; ENDIF; ENDIF; // 1 ENTER // 4 ROLL DN // 5 ROLL UP IF AID = '1'or AID = '4' or AID = '5'; ELSE; MX = 1; EXSR @ERROR; ENDIF; IF RTN <> '3'; EXSR @PCKD; ENDIF; // 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(NUSA : 60 : 0); %SUBST(KW : W : Q(Y)) = %SUBST(NUPA: 61 -Q(Y)); ENDIF; // BINARY FIELDS IF T(Y) = 'B'; IF Q(Y) = 2 ; BY2 = NU(1) + NU(2); %SUBST(KW : W : 2) = BY2; ENDIF; IF Q(Y) = 4 ; BY4 = NU(1) + NU(2) + NU(3) + NU(4); %SUBST(KW : W : 4) = BY4; ENDIF; ENDIF; ENDSR; // @@@@@@@ SETIN @@@@@@@@@@@@@@@@@@@@@@@@@ BEGSR @SETIN; // SET the FFR indicators to get the Input buffer somewhat aligned with the // actual data. RPG is somewhat tolerant to a difference between the Ispecs // and the actual file size but it can fail on big differences. // INCREMENT OF 32 BYTES SZ(1) = BASE + 16; SZ(2) = SZ(1) + 16; *IN30 = *ON; IF (RLEN > SZ(2)) ; *IN31 = *ON; ENDIF; FOR X = 3 TO 64; SZ(X) = SZ(X-1) + 32; IF (RLEN > SZ(X)) ; *IN(29+X) = *ON; ENDIF; ENDFOR; ENDSR; //@@@@@@@@@@@@@@@@@ @GETF @@@@@@@@@@@@@@@@@ BEGSR @GETF; // GET A DATA RECORD IF (*INU1); IF AID = '1' OR AID = X36 OR AID = X39 OR AID = X3B ; SETLL(E) KEYA INPUTK; READ(E) INPUTK; IF %EOF; SETLL(E) KEYA INPUTK; READP(E) INPUTK; ENDIF; ENDIF; IF AID = '4'; READP(E) INPUTK; ENDIF; IF AID = '5'; READ(E) INPUTK; ENDIF; IF %ERROR; SETLL(E) KEYA INPUTK; READ(E) INPUTK; MX = 7; EXSR @ERROR; EXSR @PUTF ; EXSR @KEYIN; ENDIF; // 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
DISPR RPG
H OPTIMIZE(*NONE) OPTION(*NODEBUGIO) H DFTACTGRP(*NO) ACTGRP(*CALLER) ..... * * 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 // //*************************************************************** // 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); IF K <> 0; WHDFTL = K ; UPDATE QWHDRFFD; ENDIF; 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
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
/* 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