Difference between revisions of "UDDS File Displayer"

From MidrangeWiki
Jump to: navigation, search
m
(UDDS)
 
(6 intermediate revisions by the same user not shown)
Line 3: Line 3:
  
 
==UDDS==
 
==UDDS==
The manual that describes the 5250 data stream is 5494 Remote Control Unit, Functions Reference. (topic 15) [http://tn5250.sourceforge.net/resources.html]
+
The manual that describes the 5250 data stream is 5494 Remote Control Unit, Functions Reference. SC30-3533-04 (topic 15) [http://tn5250.sourceforge.net/resources.html]
 +
 
 +
( 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.
Line 11: Line 13:
 
This is a conversion of an old S/38 program that was mostly MOVE and MOVEA and arrays, so it probably still has bugs.
 
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.
+
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 '
 
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 '
Line 531: Line 533:
 
                 RRNA =  %DEC(%SUBST(SCNKEY:1:11):11:0);
 
                 RRNA =  %DEC(%SUBST(SCNKEY:1:11):11:0);
 
               ENDIF;
 
               ENDIF;
                RTN = '0';
 
 
                 AID = '1';
 
                 AID = '1';
 
             ELSE;
 
             ELSE;
Line 621: Line 622:
 
           IF  RTN <> '3';
 
           IF  RTN <> '3';
 
             EXSR      @PCKD;
 
             EXSR      @PCKD;
 +
          ELSE;
 +
            RTN = '0';
 
           ENDIF;
 
           ENDIF;
  
Line 870: Line 873:
 
             NUSA = %TRIM(NUSA) + NU(VX);
 
             NUSA = %TRIM(NUSA) + NU(VX);
 
           ENDFOR;
 
           ENDFOR;
           NUP    = %DEC(NUSA : 60 : 0);
+
           NUP    = %DEC(NUS : 60 : 0);
  
 
         %SUBST(KW : W : Q(Y))  =  %SUBST(NUPA: 61 -Q(Y));
 
         %SUBST(KW : W : Q(Y))  =  %SUBST(NUPA: 61 -Q(Y));
Line 1,823: Line 1,826:
  
 
[[#top]]
 
[[#top]]
 +
 
== WRAPPER CODE ==
 
== WRAPPER CODE ==
 
===DISPR  RPG ===
 
===DISPR  RPG ===

Latest revision as of 13:05, 29 October 2018


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


#top

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


#top

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

       //###################################################//
       //###################################################//


#top

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'


#top

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



#top

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'


#top


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')


#top


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


#top



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


#top


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


#top


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


#top

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


#top

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


#top