Difference between revisions of "UDDS File Displayer"

From MidrangeWiki
Jump to: navigation, search
(UDDS)
(UDDS)
Line 3: Line 3:
  
 
==UDDS==
 
==UDDS==
The manual that describes the 5250 data stream is 5494 Remote Control Unit, Functions Reference. (topic 15) [http://tn5250.sourceforge.net/resources.html]
+
The manual that describes the 5250 data stream is 5494 Remote Control Unit, Functions Reference. SC30-3533-04 (topic 15) [http://tn5250.sourceforge.net/resources.html]
 
[https://www-05.ibm.com/e-business/linkweb/publications/servlet/pbi.wss?PAG=C11&SSN=16I2K0000952086390&TRL=TXT&WRD=&PBL=SC30-3533-04&LST=ALL&RPP=10&submit=Go]
 
[https://www-05.ibm.com/e-business/linkweb/publications/servlet/pbi.wss?PAG=C11&SSN=16I2K0000952086390&TRL=TXT&WRD=&PBL=SC30-3533-04&LST=ALL&RPP=10&submit=Go]
 +
 +
IBMs publib site seems to be no longer working and is replaced by a new site, however even though I can get to the site I cant get the IBM Download Director to work as it constantly refuses my connection.
  
 
The purpose of this program is to demo an example of a program using UDDS.
 
The purpose of this program is to demo an example of a program using UDDS.

Revision as of 10:28, 29 September 2016


UDDS

The manual that describes the 5250 data stream is 5494 Remote Control Unit, Functions Reference. SC30-3533-04 (topic 15) [1] [2]

IBMs publib site seems to be no longer working and is replaced by a new site, however even though I can get to the site I cant get the IBM Download Director to work as it constantly refuses my connection.

The purpose of this program is to demo an example of a program using UDDS.

It shows file data, but is limited to 2048 max rcdlen. You can recode the I specs to get versions that handle bigger records.

This is a conversion of an old S/38 program that was mostly MOVE and MOVEA and arrays, so it probably still has bugs.

It uses a very old S/38 technique of Program Described Display Files. I cant even find any documentation on this technique. I last used it in earnest when we converted S/3 CCP programs to run on the S38. Its really amazing how IBM keeps this backward compatability.

I am also inculding wrapper programs to make the displayer more useful, but there is no 'make' instruction. I am assuming you know enough about compiling source to figure it out for yourself. Once compiled the command to run it is 'DSPFL yourlib/yourfile '

DISP RPG


     H*eywords++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++Comments+++++++++++ 
     H OPTION(*NODEBUGIO)
     H DFTACTGRP(*NO) ACTGRP(*CALLER) DFTNAME(DISP )
     F*
     F*  LIMITED TO MAXIMUM FILE LENGTH OF 2048
     F*
     F*   REQUIRES FILE TO COMPILE
     F*  DSPFFD  FILE(&LIB/&FILE) OUTPUT(*OUTFILE) OUTFILE(QTEMP/FFD)
     F*
     FFFD       IF   E             DISK
     FDISPF     CF   F  803        WORKSTN
     F*
     F                                     INFDS(INFDS)
     FINPUTK    IF   F32766   800AIDISK    KEYLOC(1)
     F                                     EXTIND(*INU1)
     F                                     INFDS(INFDK)
     FINPUTR    IF   F32766        DISK    EXTIND(*INU2)
     F                                     INFDS(INFDR)

      *
     D A               S            255                                         WORK RU
     D RU              S            255    varying
     D RW              S              1                                         ROW 1 byte binary
     D CL              S              1                                         COL 1 byte binary
     D FNC             S              1
     D OUTLEN          S              2
     D INLEN           S              2
     D IPL             S              5  0
     D ROW             S              3  0
     D XROW            S              3  0
     D COL             S              3  0
     D KEYSOK          S              1
     D LENDSC          S              3  0
     D LENWRK          S              5  0
     D STRX            S              5  0
     D ENDX            S              5  0
     D VX              S              5  0
     D X               S              5  0
     D X1              S              5  0
     D X2              S              5  0
     D XX              S              5  0
     D XP              S              5  0
     D MX              S              5  0
     D ONCE            S              1
     D RBA             S              2
     D LF              S              5  0
     D ST              S              5  0
     D Y               S              5  0
     D Z               S              5  0
     D OFF             S              5  0
     D SUPZ            S              1
     D NUMFLD          S              5  0
     D WX              S              5  0
     D NUMKEY          S              5  0
     D NUMFKY          S              5  0
     D SCRST           S             10
     D SCRSTN          S              1
     D KEYA            S            800
     D RRNA            S             11  0
     D RRN             S             11  0
     D REHEAD          S              1
     D NEWRU           S              1
     D WRTRRN          S              1
     D LVX             S              5  0
     D LVL             S              5  0
     D K1              S              5  0
     D K2              S              5  0
     D Z1              S              5  0
     D W               S              5  0
     D WK2             S              2
     D MSSG            S             32
      *
     D BASE            S              5  0
     D INZ             S              1

     D FILE            S             10
     D LIB             S             10
     D MBR             S             10
     D RCDL            S              5  0
     D ACCTP           S              1
     D RLEN            S              5  0
     D RLENTH          S              5
     D LENF            S              5  0


     D                 DS
     D TEXT500                      500
     D LVW                           10    DIM(50) overlay(TEXT500:1)

     D TEXT800         S            800
     D KW              S            800

     D                 DS
     D WRK11                   1     11
     D NUM11                   1     11S 0

     D                 DS
     D NUSA                    1     60
     D NUS                     1     60S 0
     D                 DS
     D NUPA                    1     60
     D NUP                    29     60P 0

     D WRU             S             61
     D WRX             S             64
     D WRXWRD          C                   '0                              -
     D                                                                     -'
     D WRSWRD          C                   '0                              -
     D                                                                  -'
     D WRV             S             60    varying

     D FLT14           S             14
     D FLT23           S             23

      * SET FILE SIZE INCREMENTS (64 OF THEM)
     D SZ              S              5  0 DIM(64)
     D S               S              5  0 DIM(9000)                            START OF FLD
     D E               S              5  0 DIM(9000)                            END OF FLD
     D Q               S              5  0 DIM(9000)                            BYTES IN FIELD
     D L               S              5  0 DIM(9000)                            LENGTH OF FLD
     D C               S              3  0 DIM(9000)                            DEC DIGITS
     D P               S              3  0 DIM(9000)                            DEC PRECISION
     D B               S              2    DIM(9000) ASCEND                     BUFFER ADD
     D I               S              2    DIM(9000)                            FLD FMT
     D N               S             10    DIM(9000)                            FLD NAME
     D T               S              1    DIM(9000)                            FLD TYPE
     D V               S              1    DIM(9000)                            VARYING
     D KY              S              1    DIM(9000)                            KEYED
     D KE              S             10    DIM(128)                             KEY FLDS
     D R               S              3  0 DIM(9000)                            KEY FLD START
     D K               S              1    DIM(800)                             KEY
     D NA              S              1    DIM(10)                              NAME WORK
     D NU              S              1    DIM(60)                              NUM. WORK
     D LV              S             10    DIM(50)                              SCREEN LEVELS
     D MSG             S             32    DIM(8) CTDATA PERRCD(1)              MESSAGES
     D CNS             S             50    DIM(2) CTDATA PERRCD(1)
     D CRS             S              1    DIM(16) CTDATA PERRCD(16)

     D                 DS
     D  D                      1   2048
     D                                     DIM(2048)                            INCOMING DATA
     D  DA                     1     16
     D  DB                    17     32
     D  DC                    33     64
     D  DD                    65     96
     D  DE                    97    128
     D  DF                   129    160
     D  DG                   161    192
     D  DH                   193    224
     D  DI                   225    256
     D  DJ                   257    288
     D  DK                   289    320
     D  DL                   321    352
     D  DM                   353    384
     D  DN                   385    416
     D  DZ                   417    448
     D  DO                   449    480
     D  DP                   481    512
     D  DQ                   513    544
     D  DR                   545    576
     D  DS                   577    608
     D  DT                   609    640
     D  DU                   641    672
     D  DV                   673    704
     D  DW                   705    736
     D  DX                   737    768
     D  DY                   769    800
     D  D0                   801    832
     D  D1                   833    864
     D  D2                   865    896
     D  D3                   897    928
     D  D4                   929    960
     D  D5                   961    992
     D  D6                   993   1024
     D  DBA                 1025   1056
     D  DCA                 1057   1088
     D  DDA                 1089   1120
     D  DEA                 1121   1152
     D  DFA                 1153   1184
     D  DGA                 1185   1216
     D  DHA                 1217   1248
     D  DIA                 1249   1280
     D  DJA                 1281   1312
     D  DKA                 1313   1344
     D  DLA                 1345   1376
     D  DMA                 1377   1408
     D  DNA                 1409   1440
     D  DOA                 1441   1472
     D  DPA                 1473   1504
     D  DQA                 1505   1536
     D  DRA                 1537   1568
     D  DSA                 1569   1600
     D  DTA                 1601   1632
     D  DUA                 1633   1664
     D  DVA                 1665   1696
     D  DWA                 1697   1728
     D  DXA                 1729   1760
     D  DYA                 1761   1792
     D  DZA                 1793   1824
     D  D0A                 1825   1856
     D  D1A                 1857   1888
     D  D2A                 1889   1920
     D  D3A                 1921   1952
     D  D4A                 1953   1984
     D  D5A                 1985   2016
     D  D6A                 2017   2048
     D                 DS
     D  ID                     1    800
     D                                     DIM(800)                             INCOMING DATA
     D  IDA                    1    800
     D  ID0                    1     80
     D  ID1                   81    160
     D  ID2                  161    240
     D  ID3                  241    320
     D  ID4                  321    400
     D  ID5                  401    480
     D  ID6                  481    560
     D  ID7                  561    640
     D  ID8                  641    720
     D  ID9                  721    800
     D                 DS
     D  BIN                    1      2B 0
     D  HX1                    2      2
     D  HX2                    1      2
     D                 DS
     D  PCK                    1      1P 0
     D  PCK1                   1      1
     D                 DS
     D  SGN                    1      1S 0
     D  SGN1                   1      1

     D                 DS
     D  BIN4                   1      4B 0
     D  BY4                    1      4

     D                 DS
     D  BIN2                   1      2B 0
     D  BY2                    1      2

     D                 DS
     D  FLT4                   1      4F
     D  FL4                    1      4

     D                 DS
     D  FLT8                   1      8F
     D  FL8                    1      8

     D INFDK           DS
     D  F1                    83     92
     D  L1                    93    102
     D  M1                   129    138
     D  R1                   125    126B 0
     D  A1                   160    160
     D  LOP1                 260    260
     D  KEY_LEN              393    394I 0                                      Key length
     D  RN1                  397    400B 0
     D  LKY                  401   1200
     D INFDR           DS
     D  F2                    83     92
     D  L2                    93    102
     D  M2                   129    138
     D  R2                   125    126B 0
     D  A2                   160    160
     D  LOP2                 260    260
     D  RN2                  397    400B 0
     D*
     D INFDS           DS
     D  CURLOC               370    371
     D                 DS
     D KEYLN                   1      4S 0
     D KEYLNA                  1      4

     DDISP             PR
     D                                1
     D                                1
     D                                4
     D                              500
     D                                5
     D                              800
     DDISP             PI
     D   ALL                          1
     D   RTN                          1
     D   KEYLNG                       4
     D   SCNLV                      500
     D   SCNLVL                       5
     D   SCNKEY                     800


     D @LOOP           C                   '1'

     D SND             C                   X'71'                                SEND TO DISP
     D SNR             C                   X'73'                                SND/RCV
     D RED             C                   X'42'                                READ
     D RDM             C                   X'52'                                READ MTD
     D ESC             C                   X'04'                                ESCAPE
     D CLR             C                   X'40'                                CLEAR UNIT
     D CC1             C                   X'00'                                CNTRL CHAR
     D CC2             C                   X'08'                                CNTRL CHAR
     D SBA             C                   X'11'                                SET BUFF ADR
     D IC              C                   X'13'                                INSERT CURS
     D WTD             C                   X'11'                                WRITE TO DSP
     D WER             C                   X'21'                                WRITE ERROR
     D SF              C                   X'1D'                                START FLD
     D ATC             C                   X'20'                                ATTR CHAR
     D ATN             C                   X'24'                                ATTR NUM
     D X00             C                   X'00'
     D X01             C                   X'01'
     D X02             C                   X'02'
     D X03             C                   X'03'
     D X0D             C                   X'0D'
     D X0F             C                   X'0F'
     D X000            C                   X'0000'
     D X1F             C                   X'1F'
     D X20             C                   X'20'                                SCRN ATT NORMAL
     D X22             C                   X'22'                                SCRN ATTR HI
     D X25             C                   X'25'
     D X26             C                   X'26'
     D X31             C                   X'31'                                CMD 1 KEY
     D X32             C                   X'32'                                CMD 2 KEY
     D X33             C                   X'33'                                CMD 3 KEY
     D X36             C                   X'36'                                CMD 6 KEY
     D X37             C                   X'37'                                CMD 7 KEY
     D X38             C                   X'38'                                CMD 8 KEY
     D X39             C                   X'39'                                CMD 9 KEY
     D X3B             C                   X'3B'                                CMD11 KEY
     D XB7             C                   X'B7'                                CMD19 KEY
     D XB8             C                   X'B8'                                CMD20 KEY
     D X40             C                   X'40'
     D X43             C                   X'43'
     D X47             C                   X'47'
     D X60             C                   X'60'
     D X67             C                   X'67'
     D X9F             C                   X'9F'
     D XF0             C                   X'F0'
     D XD0             C                   X'D0'
     D X4000           C                   X'4000'
     D X4800           C                   X'4800'                              FF ALPHA
     D X4F06           C                   X'4F06'                              FF NUMERIC
     D X6000           C                   X'6000'                              FF ALPHA
     D X6706           C                   X'6706'                              FF NUMERIC
     D CLRWTD          C                   X'044004112000'                      INCLUDES ESC CHARS
     D RDDSP           C                   X'0411200804524000'                  READ FROM DISPLAY
     D UPDF            C                   'N'
     D FFA1            S              1    INZ(X'40')                           F.FMT 1 ALPH  60 BYP
     D FFA2            S              1    INZ(X'00')                           F.FMT 2 ALPH
     D FFN1            S              1    INZ(X'47')                           F.FMT 1 NUM   67 BYP
     D FFN2            S              1    INZ(X'06')                           F.FMT 2 NUM
     I*.
     IINPUTK    NS  01
     I                                  1   16  DA
     I                                 17   32  DB                30
     I                                 33   64  DC                31
     I                                 65   96  DD                32
     I                                 97  128  DE                33
     I                                129  160  DF                34
     I                                161  192  DG                35
     I                                193  224  DH                36
     I                                225  256  DI                37
     I                                257  288  DJ                38
     I                                289  320  DK                39
     I                                321  352  DL                40
     I                                353  384  DM                41
     I                                385  416  DN                42
     I                                417  448  DZ                43
     I                                449  480  DO                44
     I                                481  512  DP                45
     I                                513  544  DQ                46
     I                                545  576  DR                47
     I                                577  608  DS                48
     I                                609  640  DT                49
     I                                641  672  DU                50
     I                                673  704  DV                51
     I                                705  736  DW                52
     I                                737  768  DX                53
     I                                769  800  DY                54
     I                                801  832  D0                55
     I                                833  864  D1                56
     I                                865  896  D2                57
     I                                897  928  D3                58
     I                                929  960  D4                59
     I                                961  992  D5                60
     I                                993 1024  D6                61
     I                               1025 1056  DBA               62
     I                               1057 1088  DCA               63
     I                               1089 1120  DDA               64
     I                               1121 1152  DEA               65
     I                               1153 1184  DFA               66
     I                               1185 1216  DGA               67
     I                               1217 1248  DHA               68
     I                               1249 1280  DIA               69
     I                               1281 1312  DJA               70
     I                               1313 1344  DKA               71
     I                               1345 1376  DLA               72
     I                               1377 1408  DMA               73
     I                               1409 1440  DNA               74
     I                               1441 1472  DOA               75
     I                               1473 1504  DPA               76
     I                               1505 1536  DQA               77
     I                               1537 1568  DRA               78
     I                               1569 1600  DSA               79
     I                               1601 1632  DTA               80
     I                               1633 1664  DUA               81
     I                               1665 1696  DVA               82
     I                               1697 1728  DWA               83
     I                               1729 1760  DXA               84
     I                               1761 1792  DYA               85
     I                               1793 1824  DZA               86
     I                               1825 1856  D0A               87
     I                               1857 1888  D1A               88
     I                               1889 1920  D2A               89
     I                               1921 1952  D3A               90
     I                               1953 1984  D4A               91
     I                               1985 2016  D5A               92
     I                               2017 2048  D6A               93
     IINPUTR    NS  01
     I                                  1   16  DA
     I                                 17   32  DB                30
     I                                 33   64  DC                31
     I                                 65   96  DD                32
     I                                 97  128  DE                33
     I                                129  160  DF                34
     I                                161  192  DG                35
     I                                193  224  DH                36
     I                                225  256  DI                37
     I                                257  288  DJ                38
     I                                289  320  DK                39
     I                                321  352  DL                40
     I                                353  384  DM                41
     I                                385  416  DN                42
     I                                417  448  DZ                43
     I                                449  480  DO                44
     I                                481  512  DP                45
     I                                513  544  DQ                46
     I                                545  576  DR                47
     I                                577  608  DS                48
     I                                609  640  DT                49
     I                                641  672  DU                50
     I                                673  704  DV                51
     I                                705  736  DW                52
     I                                737  768  DX                53
     I                                769  800  DY                54
     I                                801  832  D0                55
     I                                833  864  D1                56
     I                                865  896  D2                57
     I                                897  928  D3                58
     I                                929  960  D4                59
     I                                961  992  D5                60
     I                                993 1024  D6                61
     I                               1025 1056  DBA               62
     I                               1057 1088  DCA               63
     I                               1089 1120  DDA               64
     I                               1121 1152  DEA               65
     I                               1153 1184  DFA               66
     I                               1185 1216  DGA               67
     I                               1217 1248  DHA               68
     I                               1249 1280  DIA               69
     I                               1281 1312  DJA               70
     I                               1313 1344  DKA               71
     I                               1345 1376  DLA               72
     I                               1377 1408  DMA               73
     I                               1409 1440  DNA               74
     I                               1441 1472  DOA               75
     I                               1473 1504  DPA               76
     I                               1505 1536  DQA               77
     I                               1537 1568  DRA               78
     I                               1569 1600  DSA               79
     I                               1601 1632  DTA               80
     I                               1633 1664  DUA               81
     I                               1665 1696  DVA               82
     I                               1697 1728  DWA               83
     I                               1729 1760  DXA               84
     I                               1761 1792  DYA               85
     I                               1793 1824  DZA               86
     I                               1825 1856  D0A               87
     I                               1857 1888  D1A               88
     I                               1889 1920  D2A               89
     I                               1921 1952  D3A               90
     I                               1953 1984  D4A               91
     I                               1985 2016  D5A               92
     I                               2017 2048  D6A               93
     IDISPF     NS  02
     I                                  3    3  AID
     I                                  4   83  ID0
     I                                 84  163  ID1               20
     I                                164  243  ID2               21
     I                                244  323  ID3               22
     I                                324  403  ID4               23
     I                                404  483  ID5               24
     I                                484  563  ID6               25
     I                                564  643  ID7               26
     I                                644  723  ID8               27
     I                                724  803  ID9               28


      /FREE
             BASE = 0;

             IF  ONCE  =  ' ';
                EXSR      @INITZ  ;
             ENDIF;

         //   START        TAG
           DOW       @LOOP = @LOOP;

           IF  RTN  = '3';

              IF *INU1;
                KEYA =  SCNKEY;
              ENDIF;
              IF *INU2;
                RRNA =  %DEC(%SUBST(SCNKEY:1:11):11:0);
              ENDIF;
                AID = '1';
            ELSE;
              RTN  = '0';
              READ(E)   DISPF;
           ENDIF;

        //  CF3 EXIT
           IF  AID  = X33;
            LEAVE;
           ENDIF;

        //  CF2 RETURN
           IF  AID  = X32;
            RTN = '1';
            LEAVE;
           ENDIF;

        // CF1 HEX A FIELD
           IF  AID  = X31;
           Y = %LOOKUPLE( CURLOC : B );
           IF Y > 0;
            IF KY(Y) <= '1';
              EXSR      @HXDSP;
              REHEAD  = '1';
              EXSR      @PUTHED;
              REHEAD  = ' ';
             ENDIF;
            ENDIF;
           ENDIF;

        //  CF20 MORE FIELDS
           IF  AID  = XB8;

            LVX   = LVL + 1;
            IF   LV(LVX)  <> *BLANK;
              LVL = LVL +1 ;

              LVW  = LV;
              SCNLV = TEXT500;
              SCNLVL = %EDITC(LVL :'X');

            SCNKEY = *BLANKS;
           IF  *INU1;
                SCNKEY = KEYA;
           ENDIF;
           IF  *INU2;
                SCNKEY = %EDITC(RRNA:'X');
           ENDIF;

               RTN = '3';
               LEAVE;
             ENDIF;
           ENDIF;

       //  CF19 PREVIOUS FIELDS
           IF  AID  = XB7;

            LVX   = LVL - 1;
            IF   LVX     >= 0 ;
              LVL = LVL - 1 ;

              LVW  = LV;
              SCNLV = TEXT500;
              SCNLVL = %EDITC(LVL :'X');

                SCNKEY = *BLANKS;
           IF  *INU1;
                SCNKEY = KEYA;
           ENDIF;
           IF  *INU2;
                SCNKEY = %EDITC(RRNA:'X');
           ENDIF;

               RTN = '3';
               LEAVE;
             ENDIF;
           ENDIF;

          // 1 ENTER
          // 4 ROLL DN
          // 5 ROLL UP
           IF  AID  = '1'or AID = '4' or AID = '5';
           ELSE;
            MX = 1;
            EXSR  @ERROR;
           ENDIF;

          IF  RTN <> '3';
            EXSR      @PCKD;
           ELSE;
            RTN = '0';
          ENDIF;


        //  GET A RECORD, KEY FROM DATA
            EXSR      @SETIN;
            EXSR      @GETF ;
            EXSR      @PUTF ;
            EXSR      @KEYIN;

          ENDDO ;

           *INLR = *ON;

       //   @@@@@@@  @INITZ @@@@@@@@@@@@@@@@@@@@@@@@@@
         BEGSR  @INITZ;
                ONCE   =  '1';
                KEYLNA = KEYLNG  ;
                EXSR      @INIT   ;
                EXSR      @GETFLD ;
                EXSR      @GETADD ;
                EXSR      @PUTHED ;
                EXSR      @KEYIN  ;
                INZ   = '1';
                EXSR      @PCKD   ;
                INZ   = ' ';
         ENDSR;

       //   @@@@@@@  @PCKD  @@@@@@@@@@@@@@@@@@@@@@@@@@

          BEGSR   @PCKD ;

            //  CONVERT  KEY DATA
            IF  *INU1 ;
               EXSR  @CVTKEY;
            ENDIF;
            IF  *INU2 ;
               EXSR  @CVTRRN;
            ENDIF;

          ENDSR;

       //   @@@@@@@  @CVTKEY  @@@@@@@@@@@@@@@@@@@@@@@@

          BEGSR   @CVTKEY;

       // EXTRACT THE KEY FIELD DATA FROM THE INCOMING STRING

         //  NOTE...   ONLY CHANGED FIELD DATA IS RETURNED, 
         //    USE THE BUFFER ADDRESS TO IDENTIFY THE FIELD 
         // FOR EACH KEY FIELD, CHECK IF FIELD WAS MODIFIED, AND IF SO MOVE
         // THE MODIFIED DATA INTO THE COMPOSITE KEY

         K1 = 0;
         K2 = 0;
         W  = 1;

           FOR  Y  = 1  TO NUMKEY ;

       //  MOVE A KEY FIELDS DATA FROM ID ARRAY (SCREEN) TO K ARRAY (KEY FIELDS)

       //  GET SIZE OF FIELD IN BYTES
          IF T(Y)  =  'A';  // ALPHA DATA
           K = ' ';
           K1 = 1;
           K2 = Q(Y);
          ELSE;
           K  = '0';
           K1 =  1;
           K2 = C(Y);
          ENDIF;

       // IF WHOLE KEY INIT WAS REQUESTED BYPASS THE EXTRACT
           IF  INZ  = '1' ;
             KW  = *BLANK;
             EXSR      @PCKMOV;
             ITER;
           ENDIF;

          X  =  1;

          DOW  @LOOP = @LOOP;

       //  NXTSBA
          X  = %LOOKUP(SBA : ID : X );
           IF X = 0;
             LEAVE;
           ENDIF;

       // IS THIS THE FIELD?  CHECK THE BUFFER ADDRESS
         X = X +1;
         IF   B(Y)  <>  %SUBST(IDA : X :2);
          ITER;
         ENDIF;

       //  FOUND A MTD FOR THIS FIELD
         X =  X + 2;

       //  CHECK IF FIELD WAS CLEARED ONLY
         IF  ID(X) = SBA;
             EXSR      @PCKMOV;
             LEAVE ;
         ENDIF;

       //  IF FIELD HAS DECIMALS BUMP X
          IF (T(Y) = 'S' OR T(Y) = 'P' OR T(Y) = 'B') AND
              P(Y) > 0;
              X = X + 1;
          ENDIF;

       //   CHECK IF ONLY BLANKS RETURNED
         IF     %SUBST(IDA : X :K2) = *BLANKS;
             EXSR      @PCKMOV;
             LEAVE;
         ENDIF;

       // EXTRACT THE DATA FROM THE INCOMING STRING
         X1  = X;
         FOR X2  =  1 TO  K2 ;

           IF ID(X1) < ' ';
       // TRAP NULLS CAUSED BY FLD EXIT
             EXSR      @PCKMOV;
             LEAVE;
           ENDIF;

         K(X2)  =  ID(X1);
         X1     =  X1 +1;
         ENDFOR;

        // CONSTRUCT THE ACTUAL KEY WITH PACKED DATA IF REQUIRED
        // INTO ARRAY KW
          EXSR      @PCKMOV;
          LEAVE;
         ENDDO;

         ENDFOR;

         //
          KEYA  = KW;
          CLEAR KW;
        ENDSR ;

       //   @@@@@@@  @CVTRRN  @@@@@@@@@@@@@@@@@@@@@@@@

          BEGSR   @CVTRRN;

        //   RRN

           NUM11 = 0;

          DOW  @LOOP = @LOOP;  //  NOT REALLY A LOOP(SIMULATES GOTO)

       // GET THE FIRST SBA
          X = 1;
          X  = %LOOKUP(SBA : ID : X );
           IF X = 0;
           LEAVE;
           ENDIF;

       // CHECK THE BUFFER ADDRESS MATCHES THE EXPECTED FIELD
         X = X +1;
         IF   B(1)  <>  %SUBST(IDA : X :2);
          LEAVE;
         ENDIF;

       //  FOUND A MTD FOR RRN  FIELD
         X = X +2;

       //CHECK IF FIELD WAS CLEARED ONLY
         IF  ID(X) = SBA;
             LEAVE;
         ENDIF;

       //   CHECK IF ONLY BLANKS RETURNED
         IF     %SUBST(IDA : X :11) = *BLANKS;
             LEAVE;
         ENDIF;


         //  WRK11  OVERLAYS NUM11
         WRK11 = %SUBST(IDA : X :11);

         LEAVE;
         ENDDO;


         RRNA = NUM11;
         IF RRNA < 0;
         RRNA =  1;
         ENDIF;

         ENDSR;

       //   @@@@@@@  @PCKMOV  @@@@@@@@@@@@@@@@@@@@@@@@

         BEGSR  @PCKMOV;
       //
       //   CONVERT  KEY DATA
       //   SET START POSN IN KEY USING OFFSET IN R
        W = R(Y) + 1;

        // ALPHA
          IF  T(Y) = 'A';
           X1  = 1;
           FOR  Z = W   TO W + Q(Y);
             %SUBST(KW : Z : 1) =  K(X1);
             X1 = X1 + 1;
           ENDFOR;
          ENDIF;

        // NUMERIC FIELD
        // RIGHT  ADJUST NUMERIC DATA ,STRIP - . ,CONVERT BLANKS
          IF (T(Y) = 'S' OR T(Y) = 'P' OR T(Y) = 'B');
          NU = '0';

          Z1 = 60;
          FOR Z  =  K2  DOWNTO K1;

          IF K(Z) = '.' OR K(Z) = '-' OR K(Z) = '$';
          ITER;
          ENDIF;

          IF K(Z) = ' ' ;
           NU(Z1) = '0';
          ELSE;
           NU(Z1) = K(Z);
          ENDIF;

            Z1 = Z1 -1;
          ENDFOR;

          ENDIF;

       // SIGNED FIELDS  (END POSN = OFFSET + SIZE)
        IF T(Y)  = 'S';
           NUS = 0;
           FOR VX = 1 TO 60;
             NUSA = %TRIM(NUSA) + NU(VX);
           ENDFOR;
         %SUBST(KW : W : Q(Y)) = %SUBST(NUSA: 61 -Q(Y));

        ENDIF;

       //  PACKED FIELDS
          IF     T(Y)  =  'P';
           NUSA= *BLANKS;
           FOR VX = 1 TO 60;
             NUSA = %TRIM(NUSA) + NU(VX);
           ENDFOR;
           NUP    = %DEC(NUS : 60 : 0);

         %SUBST(KW : W : Q(Y))   =   %SUBST(NUPA: 61 -Q(Y));

        ENDIF;

       //  BINARY FIELDS
        IF   T(Y) =  'B';

         IF  Q(Y) = 2 ;
           BY2  = NU(1) + NU(2);
           %SUBST(KW : W : 2)   =   BY2;
         ENDIF;

         IF  Q(Y) = 4 ;
           BY4  = NU(1) + NU(2) + NU(3) + NU(4);
           %SUBST(KW : W : 4)   =   BY4;
         ENDIF;

        ENDIF;

       ENDSR;


       //   @@@@@@@   SETIN  @@@@@@@@@@@@@@@@@@@@@@@@@
           BEGSR       @SETIN;

        //  SET the FFR indicators to get the Input buffer somewhat aligned with the
        //  actual data.  RPG is somewhat tolerant to a difference between the Ispecs
        //  and the actual file size but it can fail on big differences.
        //  INCREMENT OF 32 BYTES
           SZ(1)  = BASE + 16;
           SZ(2)  = SZ(1) + 16;

           *IN30 = *ON;
            IF (RLEN > SZ(2)) ;
             *IN31  = *ON;
            ENDIF;

           FOR X = 3 TO 64;
           SZ(X) = SZ(X-1) + 32;
            IF (RLEN > SZ(X)) ;
             *IN(29+X) = *ON;
            ENDIF;
           ENDFOR;
        ENDSR;


        //@@@@@@@@@@@@@@@@@  @GETF   @@@@@@@@@@@@@@@@@
           BEGSR  @GETF;
       //   GET A DATA RECORD
          IF  (*INU1);
           IF  AID  = '1' OR AID  = X36 OR
               AID  = X39 OR AID  = X3B ;
             SETLL(E) KEYA  INPUTK;
             READ(E)       INPUTK;
              IF %EOF;
               SETLL(E) KEYA  INPUTK;
               READP(E)       INPUTK;
              ENDIF;
           ENDIF;

           IF  AID  = '4';
            READP(E)  INPUTK;
           ENDIF;

           IF  AID  = '5';
            READ(E)   INPUTK;
           ENDIF;

            IF  %ERROR;
             SETLL(E) KEYA  INPUTK;
             READ(E)       INPUTK;
             MX = 7;
                         EXSR      @ERROR;
                         EXSR      @PUTF ;
                         EXSR      @KEYIN;
            ENDIF;


          //  SAVE THE LAST KEY 
             KEYA = LKY;


             CLEAR KW;
             KW   = LKY;

          ENDIF;

          IF  (*INU2);
           IF  AID  = '1';
             CHAIN(E)  RRNA   INPUTR;
             IF  %ERROR;
              SETLL(E) RRNA  INPUTR;
              READP(E)       INPUTR;
             ENDIF;
           ENDIF;

           IF  AID  = X36;
             CHAIN(E)  RRNA   INPUTR;
           ENDIF;

           IF  AID  = '4';
             READP(E)   INPUTR;
           ENDIF;

           IF  AID  = '5' OR AID = X3B;
             READ(E)   INPUTR;
           ENDIF;

           IF  AID  = X39;
             SETLL(E) *HIVAL INPUTR;
             READP(E)   INPUTR;
           ENDIF;

           IF %ERROR;
             CHAIN  1  INPUTR;
             MX = 7;
             EXSR      @ERROR;
             EXSR      @PUTF ;
             EXSR      @KEYIN;
           ENDIF;
          ENDIF;

          ENDSR;


        //@@@@@@@@@@@@@@@@@  @PUTF   @@@@@@@@@@@@@@@@@
          BEGSR  @PUTF;

        //  WRITE DATA TO THE DISPLAY

             NEWRU  = '1';
             WRTRRN = '1';
            RU    = *ALLX'00';
            CLEAR  RU;        //  initialise Request Unit  255 bytes max
            FOR  XX = 1 TO      NUMFKY; //NUMBER OF DATA ELEMENTS (FLD AND KEY)

             IF NEWRU = '1';
              NEWRU  = '0';
              RU   = ESC + WTD + X20 + X00;
             ENDIF;

             IF WRTRRN = '1';
              WRTRRN = '0';
              RU  = RU + SBA + RBA ;
               SELECT;
                WHEN  *INU1;
                 RRN = RN1;
                WHEN  *INU2;
                 RRN = RN2;
               ENDSL;
              RU = RU + %TRIM(%EDITC(RRN:'Z'));
             ENDIF;

        // BUFFER ADDRESS
             RU  = RU + SBA + B(XX);

        //  PROCESS ALPHA DATA TYPE
             IF  T(XX) = 'A'  OR T(XX) = 'T'  OR T(XX) = 'Z' OR
                 T(XX) = 'L';

              STRX = S(XX);
              ENDX = E(XX);

              IF V(XX) = 'Y';  //VARYING
               VX   = S(XX);
               HX2   = D(VX) + D(VX+1);
               STRX  = S(XX) + 2 ;
               ENDX  = S(XX) + BIN;
              ENDIF;

               FOR Y = STRX  TO ENDX ;
                IF D(Y) >= ' ';
                 RU = RU + D(Y);
                ELSE;
                 RU = RU + X1F ;  //IF NOT DISPLAYABLE REPLACE WITH X'1F'
                ENDIF;
               ENDFOR;
             ENDIF;

        //  PROCESS SIGNED DATA TYPE (not the RRN field)
             IF  T(XX) = 'S' and KY(XX) <> '3';
               NUSA =  *ALL'0';
               WRV  =  *ALLX'00';
               CLEAR WRV;
               FOR Y = S(XX) TO E(XX);
                IF D(Y) >= XD0;
                 WRV    =  WRV + D(Y);
                ENDIF;
               ENDFOR;
               EVAL  NUSA = %SUBST(NUSA : 1 : 60 - %LEN(WRV)) + WRV;
               CLEAR WRU;
               WRU = %TRIM(WRU) + %EDITW(NUS :WRSWRD);
               IF  P(XX) > 0;
                RU  = RU  +
                     %SUBST(WRU :61-C(XX): C(XX)-P(XX)) + '.' +
                     %SUBST(WRU :61-P(XX))    ;
               ELSE;
                RU  = RU  +
                     %SUBST(WRU :61-C(XX));
               ENDIF;
             ENDIF;


        //  PROCESS SIGNED DATA TYPE (the RRN field)
             IF  T(XX) = 'S' and KY(XX) =  '3';
              RRN = RN2;
              RU = RU + %TRIM(%EDITC(RRN:'X'));
             ENDIF;

        //  PROCESS PACKED DATA TYPE
             IF  T(XX) = 'P';
               NUPA =  *ALLX'00';
               WRV  =  *ALLX'00';
               CLEAR WRV;
               FOR Y = S(XX) TO E(XX);
                 WRV    =  WRV + D(Y);
               ENDFOR;

               IF   %BITAND(D(E(XX)) :X0F) = X0F OR
                    %BITAND(D(E(XX)) :X0D) = X0D;

                EVAL  NUPA = %SUBST(NUPA : 1 : 60 - %LEN(WRV)) + WRV;
                CLEAR WRX;
                WRX = %TRIM(WRX) + %EDITW(NUP :WRXWRD);
                IF  P(XX) > 0;
                 RU  = RU  +
                      %SUBST(WRX :64-C(XX): C(XX)-P(XX)) + '.' +
                      %SUBST(WRX :64-P(XX))    ;
                ELSE;
                 RU  = RU  +
                      %SUBST(WRX :64-C(XX));
                ENDIF;
               ELSE;
                 // PACKED FIELD IN ERROR
                RU = RU + X1F;
               ENDIF;

             ENDIF;

        //  PROCESS BINARY DATA TYPE
             IF  T(XX) = 'B';

             ST = S(XX);
              CLEAR NUSA;
              IF  Q(XX) = 2;
               BY2  = D(ST) + D(ST+1);
               NUS  = BIN2;
              ENDIF;
              IF  Q(XX) = 4;
               BY4  = D(ST) + D(ST+1)+ D(ST+2) + D(ST+3);
               NUS  = BIN4;
              ENDIF;

              WRU =  %EDITW(NUS :WRSWRD);
               IF  P(XX) > 0;
                RU  = RU  +
                     %SUBST(WRU :61-C(XX): C(XX)-P(XX)) + '.' +
                     %SUBST(WRU :61-P(XX))    ;
               ELSE;
                RU  = RU  +
                     %SUBST(WRU :61-C(XX));
               ENDIF;
             ENDIF;


        //  PROCESS FLOAT  DATA TYPE
             IF  T(XX) = 'F';

             ST = S(XX);

              IF  Q(XX) = 4;
               FL4   = D(ST) + D(ST+1)+ D(ST+2) + D(ST+3);
               FLT14 =  %EDITFLT(FLT4);
                RU  = RU  + FLT14;
              ENDIF;

              IF  Q(XX) = 8;
               FL8  = D(ST) + D(ST+1)+ D(ST+2) + D(ST+3) +
                      D(ST+4) + D(ST+5)+ D(ST+6) + D(ST+7);
               FLT23 =  %EDITFLT(FLT8);
                RU  = RU  + FLT23;
              ENDIF;

             ENDIF;


           //   SEND A REQUEST UNIT IF GOT ENOUGH DATA

             IF  %LEN(RU) + L(XX + 1) >= 200;
              RU   =  RU + X20;
              BIN  =  %LEN(RU);
              OUTLEN  =  HX2;
              INLEN   =  X000;
              FNC     =  SND;
              A       = RU;
              EXCEPT  DATAO;
              NEWRU  = '1';
              RU    = *ALLX'00';
              CLEAR  RU;
             ENDIF;

            ENDFOR;

             IF  %LEN(RU) > 5 AND %LEN(RU) < 250;
              RU   =  RU + X20;
              BIN  =  %LEN(RU);
              OUTLEN  =  HX2;
              INLEN   =  X000;
              FNC     =  SND;
              A       = RU;
              EXCEPT  DATAO;
             ENDIF;
          ENDSR;


         // @@@@@@@@@@@@@@@    ROWINC  @@@@@@@@@@@@@@@

        // INCREMENT THE ROW
          BEGSR     @ROWINC;
           ROW = ROW + 2;
           IF  ROW > 20;
             MX = 3;
           ENDIF;
          ENDSR;



         // @@@@@@@@@@@@@@@    GETFLD  @@@@@@@@@@@@@@@

        // LOAD FIELD DESCRIPTION ARRAYS
          BEGSR     @GETFLD;
          MX = 0;
          X  = 0;

          IF  (*INU2 = *ON);
           // IF NON KEYED ACCESS SET UP A FIELD TO SHOW THE RRN
             N(1) =  'RRN';
             T(1) =  'S'  ;
             C(1) =  11   ;
             P(1) =  0    ;
             S(1) =  0    ;
             E(1) =  0    ;
             L(1) =  12   ;
             I(1) = X4F06 ;
             KY(1)= '3'   ;
             X    = 1     ;
          ENDIF;

          SCRST = *BLANK;
          SCRSTN = *BLANK;

          LVL  = %DEC(SCNLVL : 5:0);

         TEXT500 = SCNLV ;
         LV      = LVW;

         IF  LVL <> 0;
           SCRST = LV(LVL);
         ENDIF;

          SETLL 1 QWHDRFFD ;

          DOW  @LOOP  = @LOOP;
        //  REREAD  TAG
          READ    QWHDRFFD;
           IF %EOF;
            LEAVE;
           ENDIF;

        //  SELECT OR OMIT
           IF  ALL  <> '1';
           IF  ALL  =  'S' AND WHDFTL = 0; // USING WHDFTL FOR KEY FIELDS
             IF   WHFIOB  <>   'S';
              ITER;
             ENDIF;
           ENDIF;
           IF  ALL  =  'O' AND WHDFTL = 0; // USING WHDFTL FOR KEY FIELDS
             IF   WHFIOB   =   'O';
              ITER;
             ENDIF;
           ENDIF;
           ENDIF;

        //  FIND THE FIRST FIELD TO BE SHOWN (FOR MULTI PAGE FORMATS)
           IF  WHDFTL  <> 0 ;
             ELSE;
             IF SCRST <> ' ' AND SCRSTN = ' ';
               IF WHFLDE =  SCRST;
                 SCRSTN = '1';    //  FOUND THE START
               ELSE;
                 ITER;
               ENDIF;
             ENDIF;
           ENDIF;


          X =  X  + 1;
        // CHECK FOR KEY FIELDS,WILL BE USED TO PLACE THEM IN FRONT
          IF  WHDFTL  <>   0;
              KY(X) = '1';
              WX    = WHDFTL ;
              KE(WX) = WHFLDE;
              IF   NUMKEY <  WHDFTL;
                NUMKEY = WHDFTL;
              ENDIF;
          ENDIF;

             N(X) =  WHFLDE ;               //    NAME
             T(X) =  WHFLDT ;               //    TYPE
             V(X) =  WHVARL ;               //    VARYING
             C(X) =  WHFLDD ;               //    DEC DIGITS
             P(X) =  WHFLDP ;               //    DEC PREC
             S(X) =  WHFOBO ;               //    START
             Q(X) =  WHFLDB ;               //    BTYES
             E(X) =  WHFOBO + WHFLDB -1 ;   //   END

             IF T(X) =  'F' ;               //    FLOAT

               I(X) = FFA1 + FFA2;          //   SCRN FIELD FORMAT ALPHA
               L(X)   = 14;
              IF Q(X) = 8;
               L(X)   = 23;
              ENDIF;

             ELSE;
              IF  WHFLDD  <> 0 ;
               IF  WHFLDP  <> 0 ;
                 L(X) =  WHFLDD +  2  ;      //   LENGTH
               ELSE;
                 L(X) =  WHFLDD +  1  ;      //   LENGTH
               ENDIF;

                 I(X) = FFN1 + FFN2;         //   SCRN FIELD FORMAT NUMERIC

              ELSE;
                 L(X) =    WHFLDB  ;
                 I(X) = FFA1 + FFA2;         //   SCRN FIELD FORMAT ALPHA
              ENDIF;
             ENDIF;

        ENDDO;
        //  NUMBER OF FIELDS
         NUMFLD = X ;

       //  MAKE ROOM FOR KEYS
           IF   NUMKEY  >   0 ;
           X1  = NUMKEY  + NUMFLD;

           FOR  X =  NUMFLD DOWNTO 1;
              KY(X1) = KY(X) ;
              L(X1)  = L(X)  ;
              I(X1)  = I(X)  ;
              N(X1)  = N(X)  ;
              T(X1)  = T(X)  ;
              V(X1)  = V(X)  ;
              C(X1)  = C(X)  ;
              P(X1)  = P(X)  ;
              S(X1)  = S(X)  ;
              E(X1)  = E(X)  ;
              Q(X1)  = Q(X)  ;
              X1     = X1 - 1;
           ENDFOR;

          //  PUT KEY FIELDS AT TOP
          OFF  = 0;
          FOR  X =  1 TO NUMKEY;
          X1 = %LOOKUP(KE(X) : N : NUMKEY+1);

          KY(X) = '2';
          L(X)  = L(X1);
          I(X)  = I(X1);  // FIELD FMT
           SELECT;                // INPUT ENABLE
            WHEN  I(X) = X6000;
                  I(X) = X4800;
            WHEN  I(X) = X6706;
                  I(X) = X4F06;
           ENDSL;
            N(X) =  N(X1);
            T(X) =  T(X1);
            V(X) =  V(X1);
            C(X) =  C(X1);
            P(X) =  P(X1);
            S(X) =  S(X1);
            E(X) =  E(X1);
            Q(X) =  Q(X1);
            R(X) =  OFF;
            OFF  =  OFF + Q(X1);
          ENDFOR;

        ENDIF;
       //  NUMBER OF FIELDS AND KEYS
        NUMFKY = NUMFLD  +  NUMKEY;

        ENDSR;


         // @@@@@@@@@@@@@@@    GETADD  @@@@@@@@@@@@@@@

        // LOAD FIELD BUFFER ADDRESSES
          BEGSR     @GETADD;
          MX = 0;
          X  = 0;
          ROW = 3;
          COL = 1;

          FOR X = 1 TO NUMFKY;

        // IF FINISHED WITH THE KEY FIELDS
        //  INC  ROW FOR 1ST DATA FIELD
          IF KEYSOK = ' ' ;
           IF KY(X) = ' ' OR KY(X) = '1';
             KEYSOK = '1' ;
             ROW    = ROW + 2;
             COL    = 1;
           ENDIF;
          ENDIF;

        //  SET THE BUFFER ADD ON THE LARGER OF THE FIELD TEXT OR THE FIELD SIZE
           LENDSC  = %LEN(%TRIM(N(X)));
           LENWRK  =  L(X);
           IF LENDSC > L(X);
             LENWRK = LENDSC;
           ENDIF;
             LENWRK = LENWRK + 2;

        //   TRAP FIELDS THAT OVERFLOW
             ROW  = ROW  + XROW;
             XROW = %DIV(LENWRK : 80);

             IF (COL + LENWRK) > 78;
              EXSR @ROWINC;
                IF MX = 3;
                 X= X-1;
                 NUMFKY = X;
                 LEAVE;
                ENDIF;
              COL = 1;
             ENDIF;

        // INC COL. FOR FIELD START
           CLEAR  B(X);
           BIN  = ROW;
           B(X) =  %TRIM(B(X)) + HX1;
           BIN  = COL + 1;
           B(X) =  %TRIM(B(X)) + HX1;

        // INC COL. FOR NEXT FIELD
        COL = COL + LENWRK;
             IF COL > 78;
              EXSR @ROWINC;
                IF MX = 3;     // NO ROOM FOR THE FIELD
                 X= X-1;
                 NUMFKY = X;
                 LEAVE;
                ENDIF;
              COL = 1;
             ENDIF;

          ENDFOR;

         //  FIELD LEVEL
          LVX      = LVL + 1;
          LV(LVX)  = N(X);

        ENDSR;


         // @@@@@@@@@@@@@@@    PUTHED  @@@@@@@@@@@@@@@

        //  PUT FIELD HEADINGS
          BEGSR     @PUTHED;


            NEWRU  = '1';

            RU    = *ALLX'00';
            CLEAR  RU;                  //  initialise Request Unit  255 bytes max
            FOR  XX = 1 TO      NUMFKY; //NUMBER OF DATA ELEMENTS (FLD AND KEY)

             IF NEWRU = '1';
              NEWRU  = '0';
              RU  = ESC + WTD + X20 + X00;
             ENDIF;

             RU = RU + SBA;
             BIN = 0;
               // CONVERT DATA BUFADR TO HEADING BUFADR
             HX1 = %SUBST(B(XX) :1:1);
             BIN = BIN - 1;
             RU  = RU + HX1;

             IF  REHEAD = '1'; // ON REDISPLAY OVERRIDE THE ATTR
               BIN = 0;
               HX1 = %SUBST(B(XX) :2:1);
               BIN = BIN -1 ;
               RU  = RU + HX1;
             ELSE;
               RU  = RU + %SUBST(B(XX) :2);
             ENDIF;

             RU = RU + ATC ;

        //  LONG NUMBER FIELDS ,RIGHT ADJUST THE FIELD HEADINGS
             LENDSC  = %LEN(%TRIM(N(XX)));
            IF  T(XX) <> 'A' AND  LENDSC <  (L(XX) -1);
             FOR Y = 1 TO (L(XX) -(LENDSC +1));
              RU = RU + ' ';
             ENDFOR;
            ENDIF;

             RU = RU + %TRIM(N(XX));

              IF %LEN(RU) >= 200;
               BIN    = %LEN(RU);
               OUTLEN = HX2;
               INLEN  = X000;
               FNC    = SND;
               A      = RU;
               EXCEPT DATAO;
               NEWRU  = '1';
               RU    = *ALLX'00';
               CLEAR  RU;
              ENDIF;

            ENDFOR;

              IF %LEN(RU) >  5 AND %LEN(RU) <  200;
               BIN    = %LEN(RU);
               OUTLEN = HX2;
               INLEN  = X000;
               FNC    = SND;
               A      = RU;
               EXCEPT DATAO;
              ENDIF;

           IF REHEAD <> '1';
        //  FORMAT FIELDS


            NEWRU  = '1';
            RU    = *ALLX'00';
            CLEAR  RU;                  //  initialise Request Unit  255 bytes max
            FOR  XX = 1 TO      NUMFKY; //NUMBER OF DATA ELEMENTS (FLD AND KEY)

             IF NEWRU = '1';
              NEWRU  = '0';
              RU   = ESC + WTD + X20 + X00;
             ENDIF;

             RU = RU + SBA +B(XX)+SF + I(XX);

             IF KY(XX) = '1' OR KY(XX) = '2' OR KY(XX) = '3';
               RU = RU + X25;
             ELSE;
               RU = RU + X26;
             ENDIF;

             BIN =  L(XX);
             RU  = RU + HX2;

          // LENGTH OF INPUT FIELDS
             LENF  = LENF + L(XX) + 3;


              IF %LEN(RU) >= 200;
               BIN    = %LEN(RU);
               OUTLEN = HX2;
               INLEN  = X000;
               FNC    = SND;
               A      = RU;
               EXCEPT DATAO;
               NEWRU  = '1';
               RU    = *ALLX'00';
               CLEAR  RU;
              ENDIF;

           ENDFOR;

       //   PUT LAST R/U
              IF %LEN(RU) >  5 AND %LEN(RU) <  200;
               BIN    = %LEN(RU);
               OUTLEN = HX2;
               INLEN  = X000;
               FNC    = SND;
               A      = RU;
               EXCEPT DATAO;
              ENDIF;

        //INC BUFFER ADDRESS FOR ALL FIELDS FOR DATA PUT
            FOR  XP = 1 TO      NUMFKY; //NUMBER OF DATA ELEMENTS (FLD AND KEY)
             HX2   = B(XP);
             BIN   = BIN + 1;
             B(XP) = HX2;
            ENDFOR;
           ENDIF;

        ENDSR;

       //   @@@@@@@   INIT   @@@@@@@@@@@@@@@@@@@@@@@@@
          BEGSR         @INIT;

        CLEAR  KW;

        //  UPDATE
           IF  UPDF  = 'Y';
                FFA1 = X40;
                FFN1 = X47;
           ELSE;
                FFA1 = X60;
                FFN1 = X67;
           ENDIF;

           SELECT;
           WHEN  *INU1 = '1';
                 FILE  =  F1 ;
                 LIB   =  L1 ;
                 MBR   =  M1 ;
                 RCDL  =  R1 ;
                 ACCTP =  A1 ;
           WHEN  *INU2 = '1';
                 FILE  =  F2 ;
                 LIB   =  L2 ;
                 MBR   =  M2 ;
                 RCDL  =  R2 ;
                 ACCTP =  A2 ;
           ENDSL;
            RLEN    =   RCDL  ;
            RLENTH  =   %EDITC(RLEN: 'X') ;
            LENF    =   0     ;


        // Control commands and data are constructed into RUs Request UNITS
        // Each RU is 256 bytes max size.
        // Construct and send as many RUs as needed to format the display.
            RU    = *ALLX'00';
            CLEAR  RU;        //  initialise Request Unit  255 bytes max
            RU   = CLRWTD ;
          //set up the screen headings
            BIN = 1;    // set ROW to 1
            RW  = HX1;
            BIN = 2;    // set COL to 2
            CL  = HX1;
            RU  = RU + SBA + RW + CL + X22 + %TRIM(LIB) + '/' + %TRIM(FILE);
            RU  = RU + ' Mbr ' + %TRIM(MBR) + ' Rcdl ' + %EDITC(RLEN   : 'Z') ;
            RU  = RU + ' RRN '  ;
            BIN = %len(RU) -4;
            RBA = RW + HX1 ;   // STORE the address of the RRN field
            RU  = RU + SBA + RBA + '          ';

       //  FOOTER LINE FUNCTION KEYS
            BIN  = 23;
            RW  = HX1;
            BIN  = 02;
            CL  = HX1;
            IF  UPDF = 'Y';   //  UPDATE IS ON
             RU  = RU + SBA + RW + CL + %TRIM(CNS(2));
            ELSE;
             RU  = RU + SBA + RW + CL + %TRIM(CNS(1));
            ENDIF;

        //  THIS IS A SEND ONLY FUNCTION
           FNC     = SND;
           CLEAR A;
           A       = RU;
           BIN2    = %LEN(RU);
           OUTLEN  = BY2;
           INLEN   = x000;

           EXCEPT    DATAO;

        ENDSR;


       //   @@@@@@@   KEYIN  @@@@@@@@@@@@@@@@@@@@@@@@@
         BEGSR   @KEYIN;
       // ISSUE A READ FROM DISPLAY
           FNC = SNR;
           BIN2   = 8;
           OUTLEN = BY2;
           IPL = LENF + 34;
           BIN2   = IPL;
           INLEN  = BY2;

          // SET FRR INDICATORS TO CONTROL BUFFER OVERFLOW
           FOR X =  1 TO  9;
             IF IPL  >  ( X*80 +3);
              *IN(X+19) = *ON;
             ENDIF;
           ENDFOR;

         RU    = *ALLX'00';
         CLEAR  RU;
         RU   = RDDSP;
         A    = RU;

         EXCEPT DATAI;
         ENDSR;

       //   @@@@@@@   ERROR  @@@@@@@@@@@@@@@@@@@@@@@@@
         BEGSR    @ERROR;

       // SETUP PUT ERROR MESSAGE X'21'
         RU    = *ALLX'00';
         CLEAR RU;

         FNC    =  SNR;
         BIN    = 42;
         OUTLEN = HX2;
         BIN    = LENF + 34;
         IPL    = BIN;
         INLEN  = HX2;

         FOR X         = 1 TO 9;
          IF IPL       > (X * 80 +3) ;
           *IN(X + 19) = *ON;          // SETON FFR 20 - 29 FOR INPUT
          ENDIF;
         ENDFOR;

         RU = ESC + WER + IC + B(1) + ATC + MSG(MX);
         RU = RU + ESC + RDM + X40+ X00;

         A  = RU;
         EXCEPT    DATAI;
         RU    = *ALLX'00';
         CLEAR RU;
         ENDSR;


       //   @@@@@@@    HXDSP @@@@@@@@@@@@@@@@@@@@@@@@@
         BEGSR   @HXDSP;

           RU    = *ALLX'00';
           CLEAR RU;
           Y = %LOOKUPLE( CURLOC : B );
          //
          RU = ESC + WTD + X20 + X00 + SBA;
          BIN = 0;
          HX1 = %SUBST(B(Y) :1:1);
          BIN = BIN - 1;
          RU  = RU + HX1;
          RU  = RU + %SUBST(B(Y) :2:1);

           FOR X = S(Y) TO E(Y);
             BIN = 0;
             HX1 = D(X);
             HX1 = %BITAND(HX1  : XF0);
             Z   = BIN / 16 + 1;
             RU  = RU + CRS(Z);
           ENDFOR;

             RU  = RU + X20;

             RU  = RU + SBA + B(Y);
           FOR X = S(Y) TO E(Y);
             BIN = 0;
             HX1 = D(X);
             HX1 = %BITAND(HX1  : X0F);
             Z   = BIN  + 1;
             RU  = RU + CRS(Z);
           ENDFOR;


          BIN    = %LEN(RU);
          OUTLEN = HX2;
          INLEN  = X000;
          FNC    = SND;
          A       = RU;
          EXCEPT DATAO;
          RU    = *ALLX'00';
          CLEAR  RU;


          EXSR      @KEYIN;
          READ      DISPF;


       //   CLEAR HEADINGS
            RU    = *ALLX'00';
            CLEAR RU;

         RU   = RU + ESC + WTD + X20 + X00 + SBA;
         HX1  = %SUBST(B(Y) :1:1) ;
         BIN  = BIN - 1;
         RU   = RU + HX1 + %SUBST(B(Y):2:1);
          FOR X = S(Y) TO E(Y);
           RU = RU + ' ';
          ENDFOR;
         RU = RU + ' ';

         BIN    = %LEN(RU);
         OUTLEN = HX2;
         INLEN  = X000;
         FNC    = SND;
         A      = RU;
         EXCEPT    DATAO;
         RU    = *ALLX'00';
         CLEAR  RU;

         ENDSR;


      /END-FREE

     ODISPF     E            DATAO
     O                                           K3 'PUT'
     O                       OUTLEN               2
     O                       INLEN
     O                       FNC
     O                       A

     O          E            DATAI
     O                                           K3 'GET'
     O                       OUTLEN               2
     O                       INLEN
     O                       FNC
     O                       A
**
0000 INVALID COMMAND KEY
0001  - A FIELD IS TOO LONG
0002  - TOO MANY FIELDS
0003  - ALPHAS IN PACKED KEY
0004  - MISSING ' IN PACKED KEY
0005  - MISSING DATA IN PCKD KEY
0006  - RECORD NOT FOUND
PRESS RESET TO CONTINUE
**
F1-HEX F2-Return F3-Exit F19-Prev_fld F20-More_fld
F1-HEX F2-Return F3-Exit F19-Prev_fld F20-More_fld
**
0123456789ABCDEF


#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