Difference between revisions of "UDDS File Display/Update"

From MidrangeWiki
Jump to: navigation, search
(→‎DUSP RPG)
(→‎DUSP1 RPG)
Line 7,676: Line 7,676:
  
 
<pre>
 
<pre>
 +
    H*eywords++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++Comments+++++++++++
 +
    H OPTION(*NODEBUGIO)
 +
    H DFTACTGRP(*NO) ACTGRP(*CALLER) DFTNAME(DISP )
 +
    F*
 +
    F*  LIMITED TO MAXIMUM FILE LENGTH OF 4080
 +
    F*  REQUIRES FILE  QTEMP/FFD  TO COMPILE
 +
    F*  use cmd DSPFFD  FILE(&LIB/&FILE) OUTPUT(*OUTFILE) OUTFILE(QTEMP/FFD)
 +
 +
    FFFD      IF  E            DISK
 +
    FDISPF    CF  F  803        WORKSTN
 +
    F*
 +
    F                                    INFDS(INFDS)
 +
    FINPUTK    UF A F32766  800AIDISK    KEYLOC(1)
 +
    F                                    EXTIND(*INU1)
 +
    F                                    INFDS(INFDK)
 +
    FINPUTR    UF A 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 CGKY            S              1
 +
    D UPDDONE        S              1
 +
    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            79    DIM(2) CTDATA PERRCD(1)
 +
    D CRS            S              1    DIM(16) CTDATA PERRCD(16)
 +
 +
 +
    D                DS
 +
    D  D                      1  4080
 +
    D                                    DIM(4080)                            INCOMING DATA
 +
    D  DA                    1  2048
 +
    D                                    DIM(2048)
 +
    D  DB                  2049  2064
 +
    D  DC                  2065  2096
 +
    D  DD                  2097  2128
 +
    D  DE                  2129  2160
 +
    D  DF                  2161  2192
 +
    D  DG                  2193  2224
 +
    D  DH                  2225  2256
 +
    D  DI                  2257  2288
 +
    D  DJ                  2289  2320
 +
    D  DK                  2321  2352
 +
    D  DL                  2353  2384
 +
    D  DM                  2385  2416
 +
    D  DN                  2417  2448
 +
    D  DZ                  2449  2480
 +
    D  DO                  2481  2512
 +
    D  DP                  2513  2544
 +
    D  DQ                  2545  2576
 +
    D  DR                  2577  2608
 +
    D  DS                  2609  2640
 +
    D  DT                  2641  2672
 +
    D  DU                  2673  2704
 +
    D  DV                  2705  2736
 +
    D  DW                  2737  2768
 +
    D  DX                  2769  2800
 +
    D  DY                  2801  2832
 +
    D  D0                  2833  2864
 +
    D  D1                  2865  2896
 +
    D  D2                  2897  2928
 +
    D  D3                  2929  2960
 +
    D  D4                  2961  2992
 +
    D  D5                  2993  3024
 +
    D  D6                  3025  3056
 +
    D  DBA                3057  3088
 +
    D  DCA                3089  3120
 +
    D  DDA                3121  3152
 +
    D  DEA                3153  3184
 +
    D  DFA                3185  3216
 +
    D  DGA                3217  3248
 +
    D  DHA                3249  3280
 +
    D  DIA                3281  3312
 +
    D  DJA                3313  3344
 +
    D  DKA                3345  3376
 +
    D  DLA                3377  3408
 +
    D  DMA                3409  3440
 +
    D  DNA                3441  3472
 +
    D  DOA                3473  3504
 +
    D  DPA                3505  3536
 +
    D  DQA                3537  3568
 +
    D  DRA                3569  3600
 +
    D  DSA                3601  3632
 +
    D  DTA                3633  3664
 +
    D  DUA                3665  3696
 +
    D  DVA                3697  3728
 +
    D  DWA                3729  3760
 +
    D  DXA                3761  3792
 +
    D  DYA                3793  3824
 +
    D  DZA                3825  3856
 +
    D  D0A                3857  3888
 +
    D  D1A                3889  3920
 +
    D  D2A                3921  3952
 +
    D  D3A                3953  3984
 +
    D  D4A                3985  4016
 +
    D  D5A                4017  4048
 +
    D  D6A                4049  4080
 +
    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
 +
 +
    DDUSP            PR
 +
    D                                1
 +
    D                                1
 +
    D                                4
 +
    D                                1
 +
    D                              500
 +
    D                                5
 +
    D                              800
 +
    DDUSP            PI
 +
    D  ALL                          1
 +
    D  RTN                          1
 +
    D  KEYLNG                      4
 +
    D  UPDF                        1
 +
    D  SCNLV                      500
 +
    D  SCNLVL                      5
 +
    D  SCNKEY                    800
 +
 +
 +
    D @LOOP          C                  '1'
 +
    D @FALSE          C                  '0'
 +
    D @TRUE          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 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 2048  DA
 +
    I                              2049 2064  DB                30
 +
    I                              2065 2096  DC                31
 +
    I                              2097 2128  DD                32
 +
    I                              2129 2160  DE                33
 +
    I                              2161 2192  DF                34
 +
    I                              2193 2224  DG                35
 +
    I                              2225 2256  DH                36
 +
    I                              2257 2288  DI                37
 +
    I                              2289 2320  DJ                38
 +
    I                              2321 2352  DK                39
 +
    I                              2353 2384  DL                40
 +
    I                              2385 2416  DM                41
 +
    I                              2417 2448  DN                42
 +
    I                              2449 2480  DZ                43
 +
    I                              2481 2512  DO                44
 +
    I                              2513 2544  DP                45
 +
    I                              2545 2576  DQ                46
 +
    I                              2577 2608  DR                47
 +
    I                              2609 2640  DS                48
 +
    I                              2641 2672  DT                49
 +
    I                              2673 2704  DU                50
 +
    I                              2705 2736  DV                51
 +
    I                              2737 2768  DW                52
 +
    I                              2769 2800  DX                53
 +
    I                              2801 2832  DY                54
 +
    I                              2833 2864  D0                55
 +
    I                              2865 2896  D1                56
 +
    I                              2897 2928  D2                57
 +
    I                              2929 2960  D3                58
 +
    I                              2961 2992  D4                59
 +
    I                              2993 3024  D5                60
 +
    I                              3025 3056  D6                61
 +
    I                              3057 3088  DBA              62
 +
    I                              3089 3120  DCA              63
 +
    I                              3121 3152  DDA              64
 +
    I                              3153 3184  DEA              65
 +
    I                              3185 3216  DFA              66
 +
    I                              3217 3248  DGA              67
 +
    I                              3249 3280  DHA              68
 +
    I                              3281 3312  DIA              69
 +
    I                              3313 3344  DJA              70
 +
    I                              3345 3376  DKA              71
 +
    I                              3377 3408  DLA              72
 +
    I                              3409 3440  DMA              73
 +
    I                              3441 3472  DNA              74
 +
    I                              3473 3504  DOA              75
 +
    I                              3505 3536  DPA              76
 +
    I                              3537 3568  DQA              77
 +
    I                              3569 3600  DRA              78
 +
    I                              3601 3632  DSA              79
 +
    I                              3633 3664  DTA              80
 +
    I                              3665 3696  DUA              81
 +
    I                              3697 3728  DVA              82
 +
    I                              3729 3760  DWA              83
 +
    I                              3761 3792  DXA              84
 +
    I                              3793 3824  DYA              85
 +
    I                              3825 3856  DZA              86
 +
    I                              3857 3888  D0A              87
 +
    I                              3889 3920  D1A              88
 +
    I                              3921 3952  D2A              89
 +
    I                              3953 3984  D3A              90
 +
    I                              3985 4016  D4A              91
 +
    I                              4017 4048  D5A              92
 +
    I                              4049 4080  D6A              93
 +
    IINPUTR    NS  01
 +
    I                                  1 2048  DA
 +
    I                              2049 2064  DB                30
 +
    I                              2065 2096  DC                31
 +
    I                              2097 2128  DD                32
 +
    I                              2129 2160  DE                33
 +
    I                              2161 2192  DF                34
 +
    I                              2193 2224  DG                35
 +
    I                              2225 2256  DH                36
 +
    I                              2257 2288  DI                37
 +
    I                              2289 2320  DJ                38
 +
    I                              2321 2352  DK                39
 +
    I                              2353 2384  DL                40
 +
    I                              2385 2416  DM                41
 +
    I                              2417 2448  DN                42
 +
    I                              2449 2480  DZ                43
 +
    I                              2481 2512  DO                44
 +
    I                              2513 2544  DP                45
 +
    I                              2545 2576  DQ                46
 +
    I                              2577 2608  DR                47
 +
    I                              2609 2640  DS                48
 +
    I                              2641 2672  DT                49
 +
    I                              2673 2704  DU                50
 +
    I                              2705 2736  DV                51
 +
    I                              2737 2768  DW                52
 +
    I                              2769 2800  DX                53
 +
    I                              2801 2832  DY                54
 +
    I                              2833 2864  D0                55
 +
    I                              2865 2896  D1                56
 +
    I                              2897 2928  D2                57
 +
    I                              2929 2960  D3                58
 +
    I                              2961 2992  D4                59
 +
    I                              2993 3024  D5                60
 +
    I                              3025 3056  D6                61
 +
    I                              3057 3088  DBA              62
 +
    I                              3089 3120  DCA              63
 +
    I                              3121 3152  DDA              64
 +
    I                              3153 3184  DEA              65
 +
    I                              3185 3216  DFA              66
 +
    I                              3217 3248  DGA              67
 +
    I                              3249 3280  DHA              68
 +
    I                              3281 3312  DIA              69
 +
    I                              3313 3344  DJA              70
 +
    I                              3345 3376  DKA              71
 +
    I                              3377 3408  DLA              72
 +
    I                              3409 3440  DMA              73
 +
    I                              3441 3472  DNA              74
 +
    I                              3473 3504  DOA              75
 +
    I                              3505 3536  DPA              76
 +
    I                              3537 3568  DQA              77
 +
    I                              3569 3600  DRA              78
 +
    I                              3601 3632  DSA              79
 +
    I                              3633 3664  DTA              80
 +
    I                              3665 3696  DUA              81
 +
    I                              3697 3728  DVA              82
 +
    I                              3729 3760  DWA              83
 +
    I                              3761 3792  DXA              84
 +
    I                              3793 3824  DYA              85
 +
    I                              3825 3856  DZA              86
 +
    I                              3857 3888  D0A              87
 +
    I                              3889 3920  D1A              88
 +
    I                              3921 3952  D2A              89
 +
    I                              3953 3984  D3A              90
 +
    I                              3985 4016  D4A              91
 +
    I                              4017 4048  D5A              92
 +
    I                              4049 4080  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 = 2048;
 +
 +
            IF  ONCE  =  ' ';
 +
                EXSR      @INITZ  ;
 +
            ENDIF;
 +
 +
        //  START        TAG
 +
          DOW      @LOOP = @LOOP;
 +
 +
          IF  RTN  = '3';
 +
 +
              IF *INU1;
 +
                KEYA =  SCNKEY;
 +
              ENDIF;
 +
              IF *INU2;
 +
                RRNA =  %DEC(%SUBST(SCNKEY:1:11):11:0);
 +
              ENDIF;
 +
                RTN = '0';
 +
                AID = '1';
 +
            ELSE;
 +
              RTN  = '0';
 +
              READ(E)  DISPF;
 +
          ENDIF;
 +
 +
        //  CF3 EXIT
 +
          IF  AID  = X33;
 +
            LEAVE;
 +
          ENDIF;
 +
 +
        //  CF2 RETURN
 +
          IF  AID  = X32;
 +
            RTN = '1';
 +
            LEAVE;
 +
          ENDIF;
 +
 +
        // CF1 HEX A FIELD
 +
          IF  AID  = X31;
 +
          Y = %LOOKUPLE( CURLOC : B );
 +
          IF Y > 0;
 +
            IF KY(Y) <= '1';
 +
              EXSR      @HXDSP;
 +
              REHEAD  = '1';
 +
              EXSR      @PUTHED;
 +
              REHEAD  = ' ';
 +
            ENDIF;
 +
            ENDIF;
 +
          ENDIF;
 +
 +
        //  CF20 MORE FIELDS
 +
          IF  AID  = XB8;
 +
 +
            LVX  = LVL + 1;
 +
            IF  LV(LVX)  <> *BLANK;
 +
              LVL = LVL +1 ;
 +
 +
              LVW  = LV;
 +
              SCNLV = TEXT500;
 +
              SCNLVL = %EDITC(LVL :'X');
 +
 +
            SCNKEY = *BLANKS;
 +
          IF  *INU1;
 +
                SCNKEY = KEYA;
 +
          ENDIF;
 +
          IF  *INU2;
 +
                SCNKEY = %EDITC(RRNA:'X');
 +
          ENDIF;
 +
 +
              RTN = '3';
 +
              LEAVE;
 +
            ENDIF;
 +
          ENDIF;
 +
 +
      //  CF19 PREVIOUS FIELDS
 +
          IF  AID  = XB7;
 +
 +
            LVX  = LVL - 1;
 +
            IF  LVX    >= 0 ;
 +
              LVL = LVL - 1 ;
 +
 +
              LVW  = LV;
 +
              SCNLV = TEXT500;
 +
              SCNLVL = %EDITC(LVL :'X');
 +
 +
                SCNKEY = *BLANKS;
 +
          IF  *INU1;
 +
                SCNKEY = KEYA;
 +
          ENDIF;
 +
          IF  *INU2;
 +
                SCNKEY = %EDITC(RRNA:'X');
 +
          ENDIF;
 +
 +
              RTN = '3';
 +
              LEAVE;
 +
            ENDIF;
 +
          ENDIF;
 +
 +
          // 1 ENTER  4 ROLL DN  5 ROLL UP
 +
          // F6 = X36  F9 = X39  F11 = X3B
 +
          IF  AID  = '1'or AID = '4' or AID = '5' or
 +
              AID  = X36 or AID = X39 or AID = X3B;
 +
          ELSE;
 +
            MX = 1;        // INVALID KEY
 +
            EXSR  @ERROR;
 +
          ENDIF;
 +
 +
          //      UPDATE MODE
 +
          IF  UPDF    = 'Y';
 +
            UPDDONE = @FALSE;
 +
          // F6
 +
            IF *INU1 AND AID = X36 AND
 +
            (LOP1 = X01 OR LOP1 = X03);
 +
              EXSR @UPD;
 +
              EXCEPT UPDATREC;
 +
              UPDDONE = @TRUE;
 +
            ENDIF;
 +
 +
            IF *INU2 AND AID = X36 AND
 +
            (LOP2 = X01 OR LOP2 = X02);
 +
              EXSR @UPD;
 +
              EXCEPT UPDATREC;
 +
              UPDDONE = @TRUE;
 +
            ENDIF;
 +
 +
          // F9
 +
            IF AID = X39;
 +
              EXSR  @UPD;
 +
              EXCEPT ADDREC;
 +
              UPDDONE = @TRUE;
 +
            ENDIF;
 +
 +
          // F11
 +
            IF *INU1 AND AID = X3B AND
 +
            (LOP1 = X01 OR LOP1 = X03);
 +
              EXCEPT DELREC;
 +
              UPDDONE = @TRUE;
 +
              ENDIF;
 +
 +
            IF *INU2 AND AID = X3B AND
 +
            (LOP2 = X01 OR LOP2 = X02);
 +
              EXCEPT DELREC;
 +
              UPDDONE = @TRUE;
 +
              ENDIF;
 +
 +
            ENDIF;
 +
 +
 +
          IF  RTN = '3' OR UPDDONE = @TRUE;
 +
          ELSE;
 +
            EXSR      @PCKD;
 +
          ENDIF;
 +
 +
 +
        // CONT1  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
 +
 +
        // 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);
 +
          ITER;
 +
        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
 +
          X1 = %LOOKUP(N(Y) : N );
 +
          W = R(X1) + 1;
 +
 +
        // ALPHA
 +
          IF  T(Y) = 'A';
 +
          X1  = 1;
 +
          FOR  Z = W  TO W + Q(Y);
 +
            %SUBST(KW : Z : 1) =  K(X1);
 +
            X1 = X1 + 1;
 +
          ENDFOR;
 +
          ENDIF;
 +
 +
        // NUMERIC FIELD
 +
        // RIGHT  ADJUST NUMERIC DATA ,STRIP - . ,CONVERT BLANKS
 +
          IF (T(Y) = 'S' OR T(Y) = 'P' OR T(Y) = 'B');
 +
          NU = '0';
 +
 +
          Z1 = 60;
 +
          FOR Z  =  K2  DOWNTO K1;
 +
 +
          IF K(Z) = '.' OR K(Z) = '-' OR K(Z) = '$';
 +
          ITER;
 +
          ENDIF;
 +
 +
          IF K(Z) = ' ' ;
 +
          NU(Z1) = '0';
 +
          ELSE;
 +
          NU(Z1) = K(Z);
 +
          ENDIF;
 +
 +
            Z1 = Z1 -1;
 +
          ENDFOR;
 +
 +
          ENDIF;
 +
 +
      // SIGNED FIELDS  (END POSN = OFFSET + SIZE)
 +
        IF T(Y)  = 'S';
 +
          NUS = 0;
 +
          FOR VX = 1 TO 60;
 +
            NUSA = %TRIM(NUSA) + NU(VX);
 +
          ENDFOR;
 +
        %SUBST(KW : W : Q(Y)) = %SUBST(NUSA: 61 -Q(Y));
 +
 +
        ENDIF;
 +
 +
      //  PACKED FIELDS
 +
          IF    T(Y)  =  'P';
 +
          NUSA= *BLANKS;
 +
          FOR VX = 1 TO 60;
 +
            NUSA = %TRIM(NUSA) + NU(VX);
 +
          ENDFOR;
 +
          NUP    = %DEC(NUSA : 60 : 0);
 +
 +
        %SUBST(KW : W : Q(Y))  =  %SUBST(NUPA: 61 -Q(Y));
 +
 +
        ENDIF;
 +
 +
      //  BINARY FIELDS
 +
        IF  T(Y) =  'B';
 +
 +
        IF  Q(Y) = 2 ;
 +
          BY2  = NU(1) + NU(2);
 +
          %SUBST(KW : W : 2)  =  BY2;
 +
        ENDIF;
 +
 +
        IF  Q(Y) = 4 ;
 +
          BY4  = NU(1) + NU(2) + NU(3) + NU(4);
 +
          %SUBST(KW : W : 4)  =  BY4;
 +
        ENDIF;
 +
 +
        ENDIF;
 +
 +
      ENDSR;
 +
 +
 +
      //  @@@@@@@  SETIN  @@@@@@@@@@@@@@@@@@@@@@@@@
 +
          BEGSR      @SETIN;
 +
 +
        //  SET the FFR indicators to get the Input buffer somewhat aligned with the
 +
        //  actual data.  RPG is somewhat tolerant to a difference between the Ispecs
 +
        //  and the actual file size but it can fail on big differences.
 +
        //  INCREMENT OF 32 BYTES
 +
          SZ(1)  = BASE + 16;
 +
          SZ(2)  = SZ(1) + 16;
 +
 +
          *IN30 = *ON;
 +
            IF (RLEN > SZ(2)) ;
 +
            *IN31  = *ON;
 +
            ENDIF;
 +
 +
          FOR X = 3 TO 64;
 +
          SZ(X) = SZ(X-1) + 32;
 +
            IF (RLEN > SZ(X)) ;
 +
            *IN(29+X) = *ON;
 +
            ENDIF;
 +
          ENDFOR;
 +
        ENDSR;
 +
 +
 +
        //@@@@@@@@@@@@@@@@@  @GETF  @@@@@@@@@@@@@@@@@
 +
          BEGSR  @GETF;
 +
      //  GET A DATA RECORD
 +
          IF  (*INU1);
 +
          IF  AID  = '1' OR AID  = X36 OR
 +
              AID  = X39 OR AID  = X3B ;
 +
            SETLL(E) KEYA  INPUTK;
 +
            READ(E)      INPUTK;
 +
              IF %EOF;
 +
              SETLL(E) KEYA  INPUTK;
 +
              READP(E)      INPUTK;
 +
              ENDIF;
 +
          ENDIF;
 +
 +
          IF  AID  = '4';
 +
            READP(E)  INPUTK;
 +
          ENDIF;
 +
 +
          IF  AID  = '5';
 +
            READ(E)  INPUTK;
 +
          ENDIF;
 +
 +
            IF  %ERROR;
 +
            SETLL(E) KEYA  INPUTK;
 +
            READ(E)      INPUTK;
 +
            MX = 7;
 +
                        EXSR      @ERROR;
 +
                        EXSR      @PUTF ;
 +
                        EXSR      @KEYIN;
 +
            ENDIF;
 +
 +
            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 ;  // address of the RRN field
 +
            RU  = RU + SBA + RBA + '          ';
 +
 +
      // 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;
 +
 +
 +
 +
      //  @@@@@@@    UPD  @@@@@@@@@@@@@@@@@@@@@@@@@
 +
          BEGSR  @UPD;
 +
 +
        // CONVERT  DATA  FOR OUTPUT
 +
 +
        //  FOR EACH  FIELD, CHECK IF FIELD WAS MODIFIED, AND IF SO MOVE
 +
        // THE MODIFIED DATA INTO THE OUTPUT ARRAY
 +
        K1 = 0;
 +
        K2 = 0;
 +
        W  = 1;
 +
        CGKY = *BLANK;  // KEY CHANGED
 +
        KW  = KEYA;
 +
 +
          FOR  Y  = 1  TO NUMFKY ;
 +
 +
            IF KY(Y) > '1';
 +
            ITER;
 +
            ENDIF;
 +
 +
 +
      //  MOVE A KEY FIELDS DATA FROM ID ARRAY (SCREEN) TO K ARRAY
 +
 +
      //  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;
 +
 +
          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
 +
 +
 +
        // CHECK IF FIELD WAS CLEARED ONLY
 +
          DOW @LOOP = @LOOP; //  not a loop
 +
        X =  X + 2;
 +
        IF  ID(X) = SBA;
 +
          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;
 +
              LEAVE;
 +
          ENDIF;
 +
 +
        // MOVE DATA TO WORK ARRAY K
 +
            X1 = X;
 +
            FOR X2 = 1 TO K2;
 +
 +
            IF ID(X1) < ' ';
 +
              LEAVE;
 +
            ENDIF;
 +
 +
            K(X2) = ID(X1);
 +
            X1 = X1 + 1;
 +
            ENDFOR;
 +
 +
          LEAVE;
 +
        ENDDO;
 +
 +
        // *  SET START POSN
 +
          W =  S(Y);
 +
 +
        // ALPHA
 +
          IF T(Y) =  'A'  and V(XX) <>  'Y';
 +
          FOR Z  =  K1 to K2;
 +
            D(W) =  K(Z);
 +
            W    =  W + 1;
 +
          ENDFOR;
 +
          ENDIF;
 +
 +
        IF T(Y) =  'A' and  V(XX) = 'Y';  //VARYING
 +
 +
        //  the data start is in S(Y)
 +
        //  the data is in array K
 +
        //  get the length of the data cvt to bin and stik in pos 1 2
 +
        //  put the rest in pos 3 onwards
 +
 +
              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';
 +
          NUSA= *BLANKS;
 +
          FOR VX = 1 TO 60;
 +
            NUSA = %TRIM(NUSA) + NU(VX);
 +
          ENDFOR;
 +
        %SUBST(DATA  : W : Q(Y)) = %SUBST(NUSA: 61 -Q(Y));
 +
 +
        ENDIF;
 +
 +
 +
      //  PACKED FIELDS
 +
          IF    T(Y)  =  'P';
 +
          NUSA= *BLANKS;
 +
          FOR VX = 1 TO 60;
 +
            NUSA = %TRIM(NUSA) + NU(VX);
 +
          ENDFOR;
 +
          NUP    = %DEC(NUSA : 60 : 0);
 +
 +
        %SUBST(DATA : 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(DATA : W : 2)  =  BY2;
 +
        ENDIF;
 +
 +
        IF  Q(Y) = 4 ;
 +
          BY4  = NU(1) + NU(2) + NU(3) + NU(4);
 +
          %SUBST(DATA : W : 4)  =  BY4;
 +
        ENDIF;
 +
 +
        ENDIF;
 +
 +
        //  UPDATE KEY IF NECESSARY
 +
        IF  KY(Y)  = '1';
 +
            CGKY = '1';
 +
            EXSR  @PCKMOV;
 +
        ENDIF;
 +
 +
 +
        ENDDO;
 +
        ENDFOR;
 +
 +
 +
          IF  CGKY = '1';
 +
          KEYA = KW;
 +
          ENDIF;
 +
 +
        ENDSR;
 +
 +
 +
 +
      /END-FREE
 +
 +
    OINPUTK    E    U1      UPDATREC
 +
    O                      DA                 
 +
    O              30      DB
 +
    O              31      DC
 +
    O              32      DD
 +
    O              33      DE
 +
    O              34      DF
 +
    O              35      DG
 +
    O              36      DH
 +
    O              37      DI
 +
    O              38      DJ
 +
    O              39      DK
 +
    O              40      DL
 +
    O              41      DM
 +
    O              42      DN
 +
    O              43      DZ
 +
    O              44      DO
 +
    O              45      DP
 +
    O              46      DQ
 +
    O              47      DR
 +
    O              48      DS
 +
    O              49      DT
 +
    O              50      DU
 +
    O              51      DV
 +
    O              52      DW
 +
    O              53      DX
 +
    O              54      DY
 +
    O              55      D0
 +
    O              56      D1
 +
    O              57      D2
 +
    O              58      D3
 +
    O              59      D4
 +
    O              60      D5
 +
    O              61      D6
 +
    O              62      DBA
 +
    O              63      DCA
 +
    O              64      DDA
 +
    O              65      DEA
 +
    O              66      DFA
 +
    O              67      DGA
 +
    O              68      DHA
 +
    O              69      DIA
 +
    O              70      DJA
 +
    O              71      DKA
 +
    O              72      DLA
 +
    O              73      DMA
 +
    O              74      DNA
 +
    O              75      DOA
 +
    O              76      DPA
 +
    O              77      DQA
 +
    O              78      DRA
 +
    O              79      DSA
 +
    O              80      DTA
 +
    O              81      DUA
 +
    O              82      DVA
 +
    O              83      DWA
 +
    O              84      DXA
 +
    O              85      DYA
 +
    O              86      DZA
 +
    O              87      D0A
 +
    O              88      D1A
 +
    O              89      D2A
 +
    O              90      D3A
 +
    O              91      D4A
 +
    O              92      D5A
 +
    O              93      D6A
 +
    OINPUTR    E      U2  UPDATREC
 +
    O                      DA                 
 +
    O              30      DB
 +
    O              31      DC
 +
    O              32      DD
 +
    O              33      DE
 +
    O              34      DF
 +
    O              35      DG
 +
    O              36      DH
 +
    O              37      DI
 +
    O              38      DJ
 +
    O              39      DK
 +
    O              40      DL
 +
    O              41      DM
 +
    O              42      DN
 +
    O              43      DZ
 +
    O              44      DO
 +
    O              45      DP
 +
    O              46      DQ
 +
    O              47      DR
 +
    O              48      DS
 +
    O              49      DT
 +
    O              50      DU
 +
    O              51      DV
 +
    O              52      DW
 +
    O              53      DX
 +
    O              54      DY
 +
    O              55      D0
 +
    O              56      D1
 +
    O              57      D2
 +
    O              58      D3
 +
    O              59      D4
 +
    O              60      D5
 +
    O              61      D6
 +
    O              62      DBA
 +
    O              63      DCA
 +
    O              64      DDA
 +
    O              65      DEA
 +
    O              66      DFA
 +
    O              67      DGA
 +
    O              68      DHA
 +
    O              69      DIA
 +
    O              70      DJA
 +
    O              71      DKA
 +
    O              72      DLA
 +
    O              73      DMA
 +
    O              74      DNA
 +
    O              75      DOA
 +
    O              76      DPA
 +
    O              77      DQA
 +
    O              78      DRA
 +
    O              79      DSA
 +
    O              80      DTA
 +
    O              81      DUA
 +
    O              82      DVA
 +
    O              83      DWA
 +
    O              84      DXA
 +
    O              85      DYA
 +
    O              86      DZA
 +
    O              87      D0A
 +
    O              88      D1A
 +
    O              89      D2A
 +
    O              90      D3A
 +
    O              91      D4A
 +
    O              92      D5A
 +
    O              93      D6A
 +
 +
    OINPUTK    EADD U1      ADDREC
 +
    O                      DA                 
 +
    O              30      DB
 +
    O              31      DC
 +
    O              32      DD
 +
    O              33      DE
 +
    O              34      DF
 +
    O              35      DG
 +
    O              36      DH
 +
    O              37      DI
 +
    O              38      DJ
 +
    O              39      DK
 +
    O              40      DL
 +
    O              41      DM
 +
    O              42      DN
 +
    O              43      DZ
 +
    O              44      DO
 +
    O              45      DP
 +
    O              46      DQ
 +
    O              47      DR
 +
    O              48      DS
 +
    O              49      DT
 +
    O              50      DU
 +
    O              51      DV
 +
    O              52      DW
 +
    O              53      DX
 +
    O              54      DY
 +
    O              55      D0
 +
    O              56      D1
 +
    O              57      D2
 +
    O              58      D3
 +
    O              59      D4
 +
    O              60      D5
 +
    O              61      D6
 +
    O              62      DBA
 +
    O              63      DCA
 +
    O              64      DDA
 +
    O              65      DEA
 +
    O              66      DFA
 +
    O              67      DGA
 +
    O              68      DHA
 +
    O              69      DIA
 +
    O              70      DJA
 +
    O              71      DKA
 +
    O              72      DLA
 +
    O              73      DMA
 +
    O              74      DNA
 +
    O              75      DOA
 +
    O              76      DPA
 +
    O              77      DQA
 +
    O              78      DRA
 +
    O              79      DSA
 +
    O              80      DTA
 +
    O              81      DUA
 +
    O              82      DVA
 +
    O              83      DWA
 +
    O              84      DXA
 +
    O              85      DYA
 +
    O              86      DZA
 +
    O              87      D0A
 +
    O              88      D1A
 +
    O              89      D2A
 +
    O              90      D3A
 +
    O              91      D4A
 +
    O              92      D5A
 +
    O              93      D6A
 +
    OINPUTR    EADD    U2  ADDREC
 +
    O                      DA                 
 +
    O              30      DB
 +
    O              31      DC
 +
    O              32      DD
 +
    O              33      DE
 +
    O              34      DF
 +
    O              35      DG
 +
    O              36      DH
 +
    O              37      DI
 +
    O              38      DJ
 +
    O              39      DK
 +
    O              40      DL
 +
    O              41      DM
 +
    O              42      DN
 +
    O              43      DZ
 +
    O              44      DO
 +
    O              45      DP
 +
    O              46      DQ
 +
    O              47      DR
 +
    O              48      DS
 +
    O              49      DT
 +
    O              50      DU
 +
    O              51      DV
 +
    O              52      DW
 +
    O              53      DX
 +
    O              54      DY
 +
    O              55      D0
 +
    O              56      D1
 +
    O              57      D2
 +
    O              58      D3
 +
    O              59      D4
 +
    O              60      D5
 +
    O              61      D6
 +
    O              62      DBA
 +
    O              63      DCA
 +
    O              64      DDA
 +
    O              65      DEA
 +
    O              66      DFA
 +
    O              67      DGA
 +
    O              68      DHA
 +
    O              69      DIA
 +
    O              70      DJA
 +
    O              71      DKA
 +
    O              72      DLA
 +
    O              73      DMA
 +
    O              74      DNA
 +
    O              75      DOA
 +
    O              76      DPA
 +
    O              77      DQA
 +
    O              78      DRA
 +
    O              79      DSA
 +
    O              80      DTA
 +
    O              81      DUA
 +
    O              82      DVA
 +
    O              83      DWA
 +
    O              84      DXA
 +
    O              85      DYA
 +
    O              86      DZA
 +
    O              87      D0A
 +
    O              88      D1A
 +
    O              89      D2A
 +
    O              90      D3A
 +
    O              91      D4A
 +
    O              92      D5A
 +
    O              93      D6A
 +
 +
    OINPUTK    EDEL U1      DELREC
 +
    OINPUTR    EDEL U2      DELREC
 +
 +
 +
    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 F6-Update F9-Add F11-Del F19-Prev_fld F20-More_fld
 +
**
 +
0123456789ABCDEF
  
 
</pre>
 
</pre>

Revision as of 08:47, 28 October 2018


UDDS UNDER CONSTRUCTION MORE CODE TO BE ADDED SOON

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


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

It shows file data, but is limited to 6048 max rcdlen.

Use the code below at your own risk, no warranty is expressed or implied or even that the code is functional.


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*   TEST
     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                                1
     D                              500
     D                                5
     D                              800
     DDISP             PI
     D   ALL                          1
     D   RTN                          1
     D   KEYLNG                       4
     D   UPDF                         1
     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'                  REAB FROM DISPLAY
     D FFA1            S              1    INZ(X'40')                           F.FMT 1 ALPH  60 BYP
     D FFA2            S              1    INZ(X'00')                           F.FMT 2 ALPH
     D FFN1            S              1    INZ(X'47')                           F.FMT 1 NUM   67 BYP
     D FFN2            S              1    INZ(X'06')                           F.FMT 2 NUM
     I*.
     IINPUTK    NS  01
     I                                  1   16  DA
     I                                 17   32  DB                30
     I                                 33   64  DC                31
     I                                 65   96  DD                32
     I                                 97  128  DE                33
     I                                129  160  DF                34
     I                                161  192  DG                35
     I                                193  224  DH                36
     I                                225  256  DI                37
     I                                257  288  DJ                38
     I                                289  320  DK                39
     I                                321  352  DL                40
     I                                353  384  DM                41
     I                                385  416  DN                42
     I                                417  448  DZ                43
     I                                449  480  DO                44
     I                                481  512  DP                45
     I                                513  544  DQ                46
     I                                545  576  DR                47
     I                                577  608  DS                48
     I                                609  640  DT                49
     I                                641  672  DU                50
     I                                673  704  DV                51
     I                                705  736  DW                52
     I                                737  768  DX                53
     I                                769  800  DY                54
     I                                801  832  D0                55
     I                                833  864  D1                56
     I                                865  896  D2                57
     I                                897  928  D3                58
     I                                929  960  D4                59
     I                                961  992  D5                60
     I                                993 1024  D6                61
     I                               1025 1056  DBA               62
     I                               1057 1088  DCA               63
     I                               1089 1120  DDA               64
     I                               1121 1152  DEA               65
     I                               1153 1184  DFA               66
     I                               1185 1216  DGA               67
     I                               1217 1248  DHA               68
     I                               1249 1280  DIA               69
     I                               1281 1312  DJA               70
     I                               1313 1344  DKA               71
     I                               1345 1376  DLA               72
     I                               1377 1408  DMA               73
     I                               1409 1440  DNA               74
     I                               1441 1472  DOA               75
     I                               1473 1504  DPA               76
     I                               1505 1536  DQA               77
     I                               1537 1568  DRA               78
     I                               1569 1600  DSA               79
     I                               1601 1632  DTA               80
     I                               1633 1664  DUA               81
     I                               1665 1696  DVA               82
     I                               1697 1728  DWA               83
     I                               1729 1760  DXA               84
     I                               1761 1792  DYA               85
     I                               1793 1824  DZA               86
     I                               1825 1856  D0A               87
     I                               1857 1888  D1A               88
     I                               1889 1920  D2A               89
     I                               1921 1952  D3A               90
     I                               1953 1984  D4A               91
     I                               1985 2016  D5A               92
     I                               2017 2048  D6A               93
     IINPUTR    NS  01
     I                                  1   16  DA
     I                                 17   32  DB                30
     I                                 33   64  DC                31
     I                                 65   96  DD                32
     I                                 97  128  DE                33
     I                                129  160  DF                34
     I                                161  192  DG                35
     I                                193  224  DH                36
     I                                225  256  DI                37
     I                                257  288  DJ                38
     I                                289  320  DK                39
     I                                321  352  DL                40
     I                                353  384  DM                41
     I                                385  416  DN                42
     I                                417  448  DZ                43
     I                                449  480  DO                44
     I                                481  512  DP                45
     I                                513  544  DQ                46
     I                                545  576  DR                47
     I                                577  608  DS                48
     I                                609  640  DT                49
     I                                641  672  DU                50
     I                                673  704  DV                51
     I                                705  736  DW                52
     I                                737  768  DX                53
     I                                769  800  DY                54
     I                                801  832  D0                55
     I                                833  864  D1                56
     I                                865  896  D2                57
     I                                897  928  D3                58
     I                                929  960  D4                59
     I                                961  992  D5                60
     I                                993 1024  D6                61
     I                               1025 1056  DBA               62
     I                               1057 1088  DCA               63
     I                               1089 1120  DDA               64
     I                               1121 1152  DEA               65
     I                               1153 1184  DFA               66
     I                               1185 1216  DGA               67
     I                               1217 1248  DHA               68
     I                               1249 1280  DIA               69
     I                               1281 1312  DJA               70
     I                               1313 1344  DKA               71
     I                               1345 1376  DLA               72
     I                               1377 1408  DMA               73
     I                               1409 1440  DNA               74
     I                               1441 1472  DOA               75
     I                               1473 1504  DPA               76
     I                               1505 1536  DQA               77
     I                               1537 1568  DRA               78
     I                               1569 1600  DSA               79
     I                               1601 1632  DTA               80
     I                               1633 1664  DUA               81
     I                               1665 1696  DVA               82
     I                               1697 1728  DWA               83
     I                               1729 1760  DXA               84
     I                               1761 1792  DYA               85
     I                               1793 1824  DZA               86
     I                               1825 1856  D0A               87
     I                               1857 1888  D1A               88
     I                               1889 1920  D2A               89
     I                               1921 1952  D3A               90
     I                               1953 1984  D4A               91
     I                               1985 2016  D5A               92
     I                               2017 2048  D6A               93
     IDISPF     NS  02
     I                                  3    3  AID
     I                                  4   83  ID0
     I                                 84  163  ID1               20
     I                                164  243  ID2               21
     I                                244  323  ID3               22
     I                                324  403  ID4               23
     I                                404  483  ID5               24
     I                                484  563  ID6               25
     I                                564  643  ID7               26
     I                                644  723  ID8               27
     I                                724  803  ID9               28


      /FREE
             BASE = 0;

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

         //   START        TAG
           DOW       @LOOP = @LOOP;

           IF  RTN  = '3';

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

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

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

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

        //  CF20 MORE FIELDS
           IF  AID  = XB8;

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

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

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

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

       //  CF19 PREVIOUS FIELDS
           IF  AID  = XB7;

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

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

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

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

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

          IF  RTN <> '3';
            EXSR      @PCKD;
          ENDIF;


        // CONT1  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

         // FOR EACH KEY FIELD, CHECK IF FIELD WAS MODIFIED, AND IF SO MOVE
         // THE MODIFIED DATA INTO THE COMPOSITE KEY

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

           FOR  Y  = 1  TO NUMKEY ;

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

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

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

          X  =  1;

          DOW  @LOOP = @LOOP;

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

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

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

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

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

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

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

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

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

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

         ENDFOR;

         //
          KEYA  = KW;
          CLEAR KW;
        ENDSR ;

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

          BEGSR   @CVTRRN;

        //   RRN

           NUM11 = 0;

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

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

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

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

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

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


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

         LEAVE;
         ENDDO;


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

         ENDSR;

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

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

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

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

          Z1 = 60;
          FOR Z  =  K2  DOWNTO K1;

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

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

            Z1 = Z1 -1;
          ENDFOR;

          ENDIF;

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

        ENDIF;

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

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

        ENDIF;

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

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

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

        ENDIF;

       ENDSR;


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

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

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

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


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

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

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

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

             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 ;   // address of the RRN field
            RU  = RU + SBA + RBA + '          ';

       // 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


DISP1 RPG




     H*eywords++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++Comments+++++++++++ 
     H OPTION(*NODEBUGIO)
     H DFTACTGRP(*NO) ACTGRP(*CALLER) DFTNAME(DISP )
     F*
     F*  LIMITED TO MAXIMUM FILE LENGTH OF 4080
     F*   TEST
     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             79    DIM(2) CTDATA PERRCD(1)
     D CRS             S              1    DIM(16) CTDATA PERRCD(16)

     D                 DS
     D  D                      1   4080
     D                                     DIM(4080)                            INCOMING DATA
     D  DA                     1   2048
     D  DB                  2049   2064
     D  DC                  2065   2096
     D  DD                  2097   2128
     D  DE                  2129   2160
     D  DF                  2161   2192
     D  DG                  2193   2224
     D  DH                  2225   2256
     D  DI                  2257   2288
     D  DJ                  2289   2320
     D  DK                  2321   2352
     D  DL                  2353   2384
     D  DM                  2385   2416
     D  DN                  2417   2448
     D  DZ                  2449   2480
     D  DO                  2481   2512
     D  DP                  2513   2544
     D  DQ                  2545   2576
     D  DR                  2577   2608
     D  DS                  2609   2640
     D  DT                  2641   2672
     D  DU                  2673   2704
     D  DV                  2705   2736
     D  DW                  2737   2768
     D  DX                  2769   2800
     D  DY                  2801   2832
     D  D0                  2833   2864
     D  D1                  2865   2896
     D  D2                  2897   2928
     D  D3                  2929   2960
     D  D4                  2961   2992
     D  D5                  2993   3024
     D  D6                  3025   3056
     D  DBA                 3057   3088
     D  DCA                 3089   3120
     D  DDA                 3121   3152
     D  DEA                 3153   3184
     D  DFA                 3185   3216
     D  DGA                 3217   3248
     D  DHA                 3249   3280
     D  DIA                 3281   3312
     D  DJA                 3313   3344
     D  DKA                 3345   3376
     D  DLA                 3377   3408
     D  DMA                 3409   3440
     D  DNA                 3441   3472
     D  DOA                 3473   3504
     D  DPA                 3505   3536
     D  DQA                 3537   3568
     D  DRA                 3569   3600
     D  DSA                 3601   3632
     D  DTA                 3633   3664
     D  DUA                 3665   3696
     D  DVA                 3697   3728
     D  DWA                 3729   3760
     D  DXA                 3761   3792
     D  DYA                 3793   3824
     D  DZA                 3825   3856
     D  D0A                 3857   3888
     D  D1A                 3889   3920
     D  D2A                 3921   3952
     D  D3A                 3953   3984
     D  D4A                 3985   4016
     D  D5A                 4017   4048
     D  D6A                 4049   4080
     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

     DDISP1            PR
     D                                1
     D                                1
     D                                4
     D                                1
     D                              500
     D                                5
     D                              800
     DDISP1            PI
     D   ALL                          1
     D   RTN                          1
     D   KEYLNG                       4
     D   UPDF                         1
     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'                  REAB FROM DISPLAY
     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 2048  DA
     I                               2049 2064  DB                30
     I                               2065 2096  DC                31
     I                               2097 2128  DD                32
     I                               2129 2160  DE                33
     I                               2161 2192  DF                34
     I                               2193 2224  DG                35
     I                               2225 2256  DH                36
     I                               2257 2288  DI                37
     I                               2289 2320  DJ                38
     I                               2321 2352  DK                39
     I                               2353 2384  DL                40
     I                               2385 2416  DM                41
     I                               2417 2448  DN                42
     I                               2449 2480  DZ                43
     I                               2481 2512  DO                44
     I                               2513 2544  DP                45
     I                               2545 2576  DQ                46
     I                               2577 2608  DR                47
     I                               2609 2640  DS                48
     I                               2641 2672  DT                49
     I                               2673 2704  DU                50
     I                               2705 2736  DV                51
     I                               2737 2768  DW                52
     I                               2769 2800  DX                53
     I                               2801 2832  DY                54
     I                               2833 2864  D0                55
     I                               2865 2896  D1                56
     I                               2897 2928  D2                57
     I                               2929 2960  D3                58
     I                               2961 2992  D4                59
     I                               2993 3024  D5                60
     I                               3025 3056  D6                61
     I                               3057 3088  DBA               62
     I                               3089 3120  DCA               63
     I                               3121 3152  DDA               64
     I                               3153 3184  DEA               65
     I                               3185 3216  DFA               66
     I                               3217 3248  DGA               67
     I                               3249 3280  DHA               68
     I                               3281 3312  DIA               69
     I                               3313 3344  DJA               70
     I                               3345 3376  DKA               71
     I                               3377 3408  DLA               72
     I                               3409 3440  DMA               73
     I                               3441 3472  DNA               74
     I                               3473 3504  DOA               75
     I                               3505 3536  DPA               76
     I                               3537 3568  DQA               77
     I                               3569 3600  DRA               78
     I                               3601 3632  DSA               79
     I                               3633 3664  DTA               80
     I                               3665 3696  DUA               81
     I                               3697 3728  DVA               82
     I                               3729 3760  DWA               83
     I                               3761 3792  DXA               84
     I                               3793 3824  DYA               85
     I                               3825 3856  DZA               86
     I                               3857 3888  D0A               87
     I                               3889 3920  D1A               88
     I                               3921 3952  D2A               89
     I                               3953 3984  D3A               90
     I                               3985 4016  D4A               91
     I                               4017 4048  D5A               92
     I                               4049 4080  D6A               93
     IINPUTR    NS  01
     I                                  1 2048  DA
     I                               2049 2064  DB                30
     I                               2065 2096  DC                31
     I                               2097 2128  DD                32
     I                               2129 2160  DE                33
     I                               2161 2192  DF                34
     I                               2193 2224  DG                35
     I                               2225 2256  DH                36
     I                               2257 2288  DI                37
     I                               2289 2320  DJ                38
     I                               2321 2352  DK                39
     I                               2353 2384  DL                40
     I                               2385 2416  DM                41
     I                               2417 2448  DN                42
     I                               2449 2480  DZ                43
     I                               2481 2512  DO                44
     I                               2513 2544  DP                45
     I                               2545 2576  DQ                46
     I                               2577 2608  DR                47
     I                               2609 2640  DS                48
     I                               2641 2672  DT                49
     I                               2673 2704  DU                50
     I                               2705 2736  DV                51
     I                               2737 2768  DW                52
     I                               2769 2800  DX                53
     I                               2801 2832  DY                54
     I                               2833 2864  D0                55
     I                               2865 2896  D1                56
     I                               2897 2928  D2                57
     I                               2929 2960  D3                58
     I                               2961 2992  D4                59
     I                               2993 3024  D5                60
     I                               3025 3056  D6                61
     I                               3057 3088  DBA               62
     I                               3089 3120  DCA               63
     I                               3121 3152  DDA               64
     I                               3153 3184  DEA               65
     I                               3185 3216  DFA               66
     I                               3217 3248  DGA               67
     I                               3249 3280  DHA               68
     I                               3281 3312  DIA               69
     I                               3313 3344  DJA               70
     I                               3345 3376  DKA               71
     I                               3377 3408  DLA               72
     I                               3409 3440  DMA               73
     I                               3441 3472  DNA               74
     I                               3473 3504  DOA               75
     I                               3505 3536  DPA               76
     I                               3537 3568  DQA               77
     I                               3569 3600  DRA               78
     I                               3601 3632  DSA               79
     I                               3633 3664  DTA               80
     I                               3665 3696  DUA               81
     I                               3697 3728  DVA               82
     I                               3729 3760  DWA               83
     I                               3761 3792  DXA               84
     I                               3793 3824  DYA               85
     I                               3825 3856  DZA               86
     I                               3857 3888  D0A               87
     I                               3889 3920  D1A               88
     I                               3921 3952  D2A               89
     I                               3953 3984  D3A               90
     I                               3985 4016  D4A               91
     I                               4017 4048  D5A               92
     I                               4049 4080  D6A               93

     IDISPF     NS  02
     I                                  3    3  AID
     I                                  4   83  ID0
     I                                 84  163  ID1               20
     I                                164  243  ID2               21
     I                                244  323  ID3               22
     I                                324  403  ID4               23
     I                                404  483  ID5               24
     I                                484  563  ID6               25
     I                                564  643  ID7               26
     I                                644  723  ID8               27
     I                                724  803  ID9               28


      /FREE
             BASE = 0;

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

         //   START        TAG
           DOW       @LOOP = @LOOP;

           IF  RTN  = '3';

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

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

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

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

        //  CF20 MORE FIELDS
           IF  AID  = XB8;

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

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

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

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

       //  CF19 PREVIOUS FIELDS
           IF  AID  = XB7;

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

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

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

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

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

          IF  RTN <> '3';
            EXSR      @PCKD;
          ENDIF;


        // CONT1  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

         // FOR EACH KEY FIELD, CHECK IF FIELD WAS MODIFIED, AND IF SO MOVE
         // THE MODIFIED DATA INTO THE COMPOSITE KEY

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

           FOR  Y  = 1  TO NUMKEY ;

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

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

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

          X  =  1;

          DOW  @LOOP = @LOOP;

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

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

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

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

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

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

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

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

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

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

         ENDFOR;

         //
          KEYA  = KW;
          CLEAR KW;
        ENDSR ;

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

          BEGSR   @CVTRRN;

        //   RRN

           NUM11 = 0;

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

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

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

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

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

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


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

         LEAVE;
         ENDDO;


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

         ENDSR;

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

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

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

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

          Z1 = 60;
          FOR Z  =  K2  DOWNTO K1;

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

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

            Z1 = Z1 -1;
          ENDFOR;

          ENDIF;

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

        ENDIF;

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

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

        ENDIF;

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

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

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

        ENDIF;

       ENDSR;


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

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

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

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


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

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

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

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

             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 ;   // address of the RRN field
            RU  = RU + SBA + RBA + '          ';

       // 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


DISP2 RPG


     H*eywords++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++Comments+++++++++++ 
     H OPTION(*NODEBUGIO)
     H DFTACTGRP(*NO) ACTGRP(*CALLER) DFTNAME(DISP )
     F*
     F*  LIMITED TO MAXIMUM FILE LENGTH OF 6080
	 
     F*  REQUIRES FILE  QTEMP/FFD  TO COMPILE
     F*  use cmd DSPFFD  FILE(&LIB/&FILE) OUTPUT(*OUTFILE) OUTFILE(QTEMP/FFD)
	 
     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   6080
     D                                     DIM(6080)                            INCOMING DATA
     D  DA                     1   4048
     D  DB                  4049   4064
     D  DC                  4065   4096
     D  DD                  4097   4128
     D  DE                  4129   4160
     D  DF                  4161   4192
     D  DG                  4193   4224
     D  DH                  4225   4256
     D  DI                  4257   4288
     D  DJ                  4289   4320
     D  DK                  4321   4352
     D  DL                  4353   4384
     D  DM                  4385   4416
     D  DN                  4417   4448
     D  DZ                  4449   4480
     D  DO                  4481   4512
     D  DP                  4513   4544
     D  DQ                  4545   4576
     D  DR                  4577   4608
     D  DS                  4609   4640
     D  DT                  4641   4672
     D  DU                  4673   4704
     D  DV                  4705   4736
     D  DW                  4737   4768
     D  DX                  4769   4800
     D  DY                  4801   4832
     D  D0                  4833   4864
     D  D1                  4865   4896
     D  D2                  4897   4928
     D  D3                  4929   4960
     D  D4                  4961   4992
     D  D5                  4993   5024
     D  D6                  5025   5056
     D  DBA                 5057   5088
     D  DCA                 5089   5120
     D  DDA                 5121   5152
     D  DEA                 5153   5184
     D  DFA                 5185   5216
     D  DGA                 5217   5248
     D  DHA                 5249   5280
     D  DIA                 5281   5312
     D  DJA                 5313   5344
     D  DKA                 5345   5376
     D  DLA                 5377   5408
     D  DMA                 5409   5440
     D  DNA                 5441   5472
     D  DOA                 5473   5504
     D  DPA                 5505   5536
     D  DQA                 5537   5568
     D  DRA                 5569   5600
     D  DSA                 5601   5632
     D  DTA                 5633   5664
     D  DUA                 5665   5696
     D  DVA                 5697   5728
     D  DWA                 5729   5760
     D  DXA                 5761   5792
     D  DYA                 5793   5824
     D  DZA                 5825   5856
     D  D0A                 5857   5888
     D  D1A                 5889   5920
     D  D2A                 5921   5952
     D  D3A                 5953   5984
     D  D4A                 5985   6016
     D  D5A                 6017   6048
     D  D6A                 6049   6080
     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

     DDISP2            PR
     D                                1
     D                                1
     D                                4
     D                                1
     D                              500
     D                                5
     D                              800
     DDISP2            PI
     D   ALL                          1
     D   RTN                          1
     D   KEYLNG                       4
     D   UPDF                         1
     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'                  REAB FROM DISPLAY
     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 4048  DA
     I                               4049 4064  DB                30
     I                               4065 4096  DC                31
     I                               4097 4128  DD                32
     I                               4129 4160  DE                33
     I                               4161 4192  DF                34
     I                               4193 4224  DG                35
     I                               4225 4256  DH                36
     I                               4257 4288  DI                37
     I                               4289 4320  DJ                38
     I                               4321 4352  DK                39
     I                               4353 4384  DL                40
     I                               4385 4416  DM                41
     I                               4417 4448  DN                42
     I                               4449 4480  DZ                43
     I                               4481 4512  DO                44
     I                               4513 4544  DP                45
     I                               4545 4576  DQ                46
     I                               4577 4608  DR                47
     I                               4609 4640  DS                48
     I                               4641 4672  DT                49
     I                               4673 4704  DU                50
     I                               4705 4736  DV                51
     I                               4737 4768  DW                52
     I                               4769 4800  DX                53
     I                               4801 4832  DY                54
     I                               4833 4864  D0                55
     I                               4865 4896  D1                56
     I                               4897 4928  D2                57
     I                               4929 4960  D3                58
     I                               4961 4992  D4                59
     I                               4993 5024  D5                60
     I                               5025 5056  D6                61
     I                               5057 5088  DBA               62
     I                               5089 5120  DCA               63
     I                               5121 5152  DDA               64
     I                               5153 5184  DEA               65
     I                               5185 5216  DFA               66
     I                               5217 5248  DGA               67
     I                               5249 5280  DHA               68
     I                               5281 5312  DIA               69
     I                               5313 5344  DJA               70
     I                               5345 5376  DKA               71
     I                               5377 5408  DLA               72
     I                               5409 5440  DMA               73
     I                               5441 5472  DNA               74
     I                               5473 5504  DOA               75
     I                               5505 5536  DPA               76
     I                               5537 5568  DQA               77
     I                               5569 5600  DRA               78
     I                               5601 5632  DSA               79
     I                               5633 5664  DTA               80
     I                               5665 5696  DUA               81
     I                               5697 5728  DVA               82
     I                               5729 5760  DWA               83
     I                               5761 5792  DXA               84
     I                               5793 5824  DYA               85
     I                               5825 5856  DZA               86
     I                               5857 5888  D0A               87
     I                               5889 5920  D1A               88
     I                               5921 5952  D2A               89
     I                               5953 5984  D3A               90
     I                               5985 6016  D4A               91
     I                               6017 6048  D5A               92
     I                               6049 6080  D6A               93
     IINPUTR    NS  01
     I                                  1 4048  DA
     I                               4049 4064  DB                30
     I                               4065 4096  DC                31
     I                               4097 4128  DD                32
     I                               4129 4160  DE                33
     I                               4161 4192  DF                34
     I                               4193 4224  DG                35
     I                               4225 4256  DH                36
     I                               4257 4288  DI                37
     I                               4289 4320  DJ                38
     I                               4321 4352  DK                39
     I                               4353 4384  DL                40
     I                               4385 4416  DM                41
     I                               4417 4448  DN                42
     I                               4449 4480  DZ                43
     I                               4481 4512  DO                44
     I                               4513 4544  DP                45
     I                               4545 4576  DQ                46
     I                               4577 4608  DR                47
     I                               4609 4640  DS                48
     I                               4641 4672  DT                49
     I                               4673 4704  DU                50
     I                               4705 4736  DV                51
     I                               4737 4768  DW                52
     I                               4769 4800  DX                53
     I                               4801 4832  DY                54
     I                               4833 4864  D0                55
     I                               4865 4896  D1                56
     I                               4897 4928  D2                57
     I                               4929 4960  D3                58
     I                               4961 4992  D4                59
     I                               4993 5024  D5                60
     I                               5025 5056  D6                61
     I                               5057 5088  DBA               62
     I                               5089 5120  DCA               63
     I                               5121 5152  DDA               64
     I                               5153 5184  DEA               65
     I                               5185 5216  DFA               66
     I                               5217 5248  DGA               67
     I                               5249 5280  DHA               68
     I                               5281 5312  DIA               69
     I                               5313 5344  DJA               70
     I                               5345 5376  DKA               71
     I                               5377 5408  DLA               72
     I                               5409 5440  DMA               73
     I                               5441 5472  DNA               74
     I                               5473 5504  DOA               75
     I                               5505 5536  DPA               76
     I                               5537 5568  DQA               77
     I                               5569 5600  DRA               78
     I                               5601 5632  DSA               79
     I                               5633 5664  DTA               80
     I                               5665 5696  DUA               81
     I                               5697 5728  DVA               82
     I                               5729 5760  DWA               83
     I                               5761 5792  DXA               84
     I                               5793 5824  DYA               85
     I                               5825 5856  DZA               86
     I                               5857 5888  D0A               87
     I                               5889 5920  D1A               88
     I                               5921 5952  D2A               89
     I                               5953 5984  D3A               90
     I                               5985 6016  D4A               91
     I                               6017 6048  D5A               92
     I                               6049 6080  D6A               93
     IDISPF     NS  02
     I                                  3    3  AID
     I                                  4   83  ID0
     I                                 84  163  ID1               20
     I                                164  243  ID2               21
     I                                244  323  ID3               22
     I                                324  403  ID4               23
     I                                404  483  ID5               24
     I                                484  563  ID6               25
     I                                564  643  ID7               26
     I                                644  723  ID8               27
     I                                724  803  ID9               28


      /FREE
             BASE = 0;

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

         //   START        TAG
           DOW       @LOOP = @LOOP;

           IF  RTN  = '3';

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

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

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

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

        //  CF20 MORE FIELDS
           IF  AID  = XB8;

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

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

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

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

       //  CF19 PREVIOUS FIELDS
           IF  AID  = XB7;

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

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

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

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

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

          IF  RTN <> '3';
            EXSR      @PCKD;
          ENDIF;


        // CONT1  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

         // FOR EACH KEY FIELD, CHECK IF FIELD WAS MODIFIED, AND IF SO MOVE
         // THE MODIFIED DATA INTO THE COMPOSITE KEY

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

           FOR  Y  = 1  TO NUMKEY ;

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

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

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

          X  =  1;

          DOW  @LOOP = @LOOP;

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

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

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

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

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

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

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

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

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

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

         ENDFOR;

         //
          KEYA  = KW;
          CLEAR KW;
        ENDSR ;

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

          BEGSR   @CVTRRN;

        //   RRN

           NUM11 = 0;

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

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

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

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

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

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


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

         LEAVE;
         ENDDO;


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

         ENDSR;

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

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

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

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

          Z1 = 60;
          FOR Z  =  K2  DOWNTO K1;

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

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

            Z1 = Z1 -1;
          ENDFOR;

          ENDIF;

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

        ENDIF;

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

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

        ENDIF;

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

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

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

        ENDIF;

       ENDSR;


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

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

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

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


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

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

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

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

             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 ;   // address of the RRN field
            RU  = RU + SBA + RBA + '          ';

       // 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

DUSP RPG

     H*eywords++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++Comments+++++++++++ 
     H OPTION(*NODEBUGIO)
     H DFTACTGRP(*NO) ACTGRP(*CALLER) DFTNAME(DISP )
     F*
     F*  LIMITED TO MAXIMUM FILE LENGTH OF 2048
     F*  REQUIRES FILE  QTEMP/FFD  TO COMPILE
     F*  use cmd DSPFFD  FILE(&LIB/&FILE) OUTPUT(*OUTFILE) OUTFILE(QTEMP/FFD)
	 
     FFFD       IF   E             DISK
     FDISPF     CF   F  803        WORKSTN
     F*
     F                                     INFDS(INFDS)
     FINPUTK    UF A F32766   800AIDISK    KEYLOC(1)
     F                                     EXTIND(*INU1)
     F                                     INFDS(INFDK)
     FINPUTR    UF A 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 CGKY            S              1
     D UPDDONE         S              1
     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             79    DIM(2) CTDATA PERRCD(1)
     D CRS             S              1    DIM(16) CTDATA PERRCD(16)

     D                 DS
     D  DATA                   1   2048
     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

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


     D @LOOP           C                   '1'
     D @FALSE          C                   '0'
     D @TRUE           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'                  REAB FROM DISPLAY
     D FFA1            S              1    INZ(X'40')                           F.FMT 1 ALPH  60 BYP
     D FFA2            S              1    INZ(X'00')                           F.FMT 2 ALPH
     D FFN1            S              1    INZ(X'47')                           F.FMT 1 NUM   67 BYP
     D FFN2            S              1    INZ(X'06')                           F.FMT 2 NUM
     I*.
     IINPUTK    NS  01
     I                                  1   16  DA
     I                                 17   32  DB                30
     I                                 33   64  DC                31
     I                                 65   96  DD                32
     I                                 97  128  DE                33
     I                                129  160  DF                34
     I                                161  192  DG                35
     I                                193  224  DH                36
     I                                225  256  DI                37
     I                                257  288  DJ                38
     I                                289  320  DK                39
     I                                321  352  DL                40
     I                                353  384  DM                41
     I                                385  416  DN                42
     I                                417  448  DZ                43
     I                                449  480  DO                44
     I                                481  512  DP                45
     I                                513  544  DQ                46
     I                                545  576  DR                47
     I                                577  608  DS                48
     I                                609  640  DT                49
     I                                641  672  DU                50
     I                                673  704  DV                51
     I                                705  736  DW                52
     I                                737  768  DX                53
     I                                769  800  DY                54
     I                                801  832  D0                55
     I                                833  864  D1                56
     I                                865  896  D2                57
     I                                897  928  D3                58
     I                                929  960  D4                59
     I                                961  992  D5                60
     I                                993 1024  D6                61
     I                               1025 1056  DBA               62
     I                               1057 1088  DCA               63
     I                               1089 1120  DDA               64
     I                               1121 1152  DEA               65
     I                               1153 1184  DFA               66
     I                               1185 1216  DGA               67
     I                               1217 1248  DHA               68
     I                               1249 1280  DIA               69
     I                               1281 1312  DJA               70
     I                               1313 1344  DKA               71
     I                               1345 1376  DLA               72
     I                               1377 1408  DMA               73
     I                               1409 1440  DNA               74
     I                               1441 1472  DOA               75
     I                               1473 1504  DPA               76
     I                               1505 1536  DQA               77
     I                               1537 1568  DRA               78
     I                               1569 1600  DSA               79
     I                               1601 1632  DTA               80
     I                               1633 1664  DUA               81
     I                               1665 1696  DVA               82
     I                               1697 1728  DWA               83
     I                               1729 1760  DXA               84
     I                               1761 1792  DYA               85
     I                               1793 1824  DZA               86
     I                               1825 1856  D0A               87
     I                               1857 1888  D1A               88
     I                               1889 1920  D2A               89
     I                               1921 1952  D3A               90
     I                               1953 1984  D4A               91
     I                               1985 2016  D5A               92
     I                               2017 2048  D6A               93
     IINPUTR    NS  01
     I                                  1   16  DA
     I                                 17   32  DB                30
     I                                 33   64  DC                31
     I                                 65   96  DD                32
     I                                 97  128  DE                33
     I                                129  160  DF                34
     I                                161  192  DG                35
     I                                193  224  DH                36
     I                                225  256  DI                37
     I                                257  288  DJ                38
     I                                289  320  DK                39
     I                                321  352  DL                40
     I                                353  384  DM                41
     I                                385  416  DN                42
     I                                417  448  DZ                43
     I                                449  480  DO                44
     I                                481  512  DP                45
     I                                513  544  DQ                46
     I                                545  576  DR                47
     I                                577  608  DS                48
     I                                609  640  DT                49
     I                                641  672  DU                50
     I                                673  704  DV                51
     I                                705  736  DW                52
     I                                737  768  DX                53
     I                                769  800  DY                54
     I                                801  832  D0                55
     I                                833  864  D1                56
     I                                865  896  D2                57
     I                                897  928  D3                58
     I                                929  960  D4                59
     I                                961  992  D5                60
     I                                993 1024  D6                61
     I                               1025 1056  DBA               62
     I                               1057 1088  DCA               63
     I                               1089 1120  DDA               64
     I                               1121 1152  DEA               65
     I                               1153 1184  DFA               66
     I                               1185 1216  DGA               67
     I                               1217 1248  DHA               68
     I                               1249 1280  DIA               69
     I                               1281 1312  DJA               70
     I                               1313 1344  DKA               71
     I                               1345 1376  DLA               72
     I                               1377 1408  DMA               73
     I                               1409 1440  DNA               74
     I                               1441 1472  DOA               75
     I                               1473 1504  DPA               76
     I                               1505 1536  DQA               77
     I                               1537 1568  DRA               78
     I                               1569 1600  DSA               79
     I                               1601 1632  DTA               80
     I                               1633 1664  DUA               81
     I                               1665 1696  DVA               82
     I                               1697 1728  DWA               83
     I                               1729 1760  DXA               84
     I                               1761 1792  DYA               85
     I                               1793 1824  DZA               86
     I                               1825 1856  D0A               87
     I                               1857 1888  D1A               88
     I                               1889 1920  D2A               89
     I                               1921 1952  D3A               90
     I                               1953 1984  D4A               91
     I                               1985 2016  D5A               92
     I                               2017 2048  D6A               93
     IDISPF     NS  02
     I                                  3    3  AID
     I                                  4   83  ID0
     I                                 84  163  ID1               20
     I                                164  243  ID2               21
     I                                244  323  ID3               22
     I                                324  403  ID4               23
     I                                404  483  ID5               24
     I                                484  563  ID6               25
     I                                564  643  ID7               26
     I                                644  723  ID8               27
     I                                724  803  ID9               28


      /FREE
             BASE = 0;

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

         //   START        TAG
           DOW       @LOOP = @LOOP;

           IF  RTN  = '3';

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

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

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

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

        //  CF20 MORE FIELDS
           IF  AID  = XB8;

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

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

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

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

       //  CF19 PREVIOUS FIELDS
           IF  AID  = XB7;

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

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

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

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

          // 1 ENTER  4 ROLL DN  5 ROLL UP
          // F6 = X36  F9 = X39  F11 = X3B
           IF  AID  = '1'or AID = '4' or AID = '5' or
               AID  = X36 or AID = X39 or AID = X3B;
           ELSE;
            MX = 1;         // INVALID KEY
            EXSR  @ERROR;
           ENDIF;

          //       UPDATE MODE
           IF  UPDF    = 'Y';
             UPDDONE = @FALSE;
           // F6
             IF *INU1 AND AID = X36 AND
             (LOP1 = X01 OR LOP1 = X03);
               EXSR @UPD;
               EXCEPT UPDATREC;
               UPDDONE = @TRUE;
             ENDIF;

             IF *INU2 AND AID = X36 AND
             (LOP2 = X01 OR LOP2 = X02);
               EXSR @UPD;
               EXCEPT UPDATREC;
               UPDDONE = @TRUE;
             ENDIF;

           // F9
             IF AID = X39;
               EXSR   @UPD;
               EXCEPT ADDREC;
               UPDDONE = @TRUE;
             ENDIF;

           // F11
             IF *INU1 AND AID = X3B AND
             (LOP1 = X01 OR LOP1 = X03);
               EXCEPT DELREC;
               UPDDONE = @TRUE;
              ENDIF;

             IF *INU2 AND AID = X3B AND
             (LOP2 = X01 OR LOP2 = X02);
               EXCEPT DELREC;
               UPDDONE = @TRUE;
              ENDIF;

             ENDIF;


          IF  RTN = '3' OR UPDDONE = @TRUE;
          ELSE;
            EXSR      @PCKD;
          ENDIF;


        // CONT1  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

         // 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);
          ITER;
         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
          X1 = %LOOKUP(N(Y) : N );
          W = R(X1) + 1;

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

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

          Z1 = 60;
          FOR Z  =  K2  DOWNTO K1;

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

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

            Z1 = Z1 -1;
          ENDFOR;

          ENDIF;

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

        ENDIF;

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

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

        ENDIF;

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

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

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

        ENDIF;

       ENDSR;


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

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

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

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


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

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

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

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

             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 ;   // address of the RRN field
            RU  = RU + SBA + RBA + '          ';

       // 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;



       //   @@@@@@@    UPD   @@@@@@@@@@@@@@@@@@@@@@@@@
          BEGSR  @UPD;

        // CONVERT  DATA  FOR OUTPUT

        //  FOR EACH  FIELD, CHECK IF FIELD WAS MODIFIED, AND IF SO MOVE
        // THE MODIFIED DATA INTO THE OUTPUT ARRAY
         K1 = 0;
         K2 = 0;
         W  = 1;
         CGKY = *BLANK;  // KEY CHANGED
         KW   = KEYA;

           FOR  Y  = 1  TO NUMFKY ;

            IF KY(Y) > '1';
             ITER;
            ENDIF;


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

       //  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;

          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


         // CHECK IF FIELD WAS CLEARED ONLY
          DOW @LOOP = @LOOP; //  not a loop
         X =  X + 2;
         IF  ID(X) = SBA;
          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;
              LEAVE;
          ENDIF;

        // MOVE DATA TO WORK ARRAY K
             X1 = X;
            FOR X2 = 1 TO K2;

             IF ID(X1) < ' ';
              LEAVE;
             ENDIF;

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

          LEAVE;
         ENDDO;

        // *  SET START POSN
          W =   S(Y);

         // ALPHA
          IF T(Y) =  'A'  and V(XX) <>  'Y';
           FOR Z  =  K1 to K2;
             D(W) =  K(Z);
             W    =  W + 1;
           ENDFOR;
          ENDIF;

        IF T(Y) =  'A' and  V(XX) = 'Y';  //VARYING

         //  the data start is in S(Y)
         //  the data is in array K
         //  get the length of the data cvt to bin and stik in pos 1 2
         //  put the rest in pos 3 onwards

              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';
           NUSA= *BLANKS;
           FOR VX = 1 TO 60;
             NUSA = %TRIM(NUSA) + NU(VX);
           ENDFOR;
         %SUBST(DATA  : W : Q(Y)) = %SUBST(NUSA: 61 -Q(Y));

        ENDIF;


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

         %SUBST(DATA : 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(DATA : W : 2)   =   BY2;
         ENDIF;

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

        ENDIF;

         //  UPDATE KEY IF NECESSARY
         IF   KY(Y)  = '1';
            CGKY = '1';
            EXSR  @PCKMOV;
         ENDIF;


         ENDDO;
        ENDFOR;


          IF  CGKY = '1';
           KEYA = KW;
          ENDIF;

        ENDSR;



      /END-FREE

     OINPUTK    E    U1      UPDATREC
     O                       DA                  16
     O               30      DB
     O               31      DC
     O               32      DD
     O               33      DE
     O               34      DF
     O               35      DG
     O               36      DH
     O               37      DI
     O               38      DJ
     O               39      DK
     O               40      DL
     O               41      DM
     O               42      DN
     O               43      DZ
     O               44      DO
     O               45      DP
     O               46      DQ
     O               47      DR
     O               48      DS
     O               49      DT
     O               50      DU
     O               51      DV
     O               52      DW
     O               53      DX
     O               54      DY
     O               55      D0
     O               56      D1
     O               57      D2
     O               58      D3
     O               59      D4
     O               60      D5
     O               61      D6
     O               62      DBA
     O               63      DCA
     O               64      DDA
     O               65      DEA
     O               66      DFA
     O               67      DGA
     O               68      DHA
     O               69      DIA
     O               70      DJA
     O               71      DKA
     O               72      DLA
     O               73      DMA
     O               74      DNA
     O               75      DOA
     O               76      DPA
     O               77      DQA
     O               78      DRA
     O               79      DSA
     O               80      DTA
     O               81      DUA
     O               82      DVA
     O               83      DWA
     O               84      DXA
     O               85      DYA
     O               86      DZA
     O               87      D0A
     O               88      D1A
     O               89      D2A
     O               90      D3A
     O               91      D4A
     O               92      D5A
     O               93      D6A
     OINPUTR    E       U2   UPDATREC
     O                       DA                  16
     O               30      DB
     O               31      DC
     O               32      DD
     O               33      DE
     O               34      DF
     O               35      DG
     O               36      DH
     O               37      DI
     O               38      DJ
     O               39      DK
     O               40      DL
     O               41      DM
     O               42      DN
     O               43      DZ
     O               44      DO
     O               45      DP
     O               46      DQ
     O               47      DR
     O               48      DS
     O               49      DT
     O               50      DU
     O               51      DV
     O               52      DW
     O               53      DX
     O               54      DY
     O               55      D0
     O               56      D1
     O               57      D2
     O               58      D3
     O               59      D4
     O               60      D5
     O               61      D6
     O               62      DBA
     O               63      DCA
     O               64      DDA
     O               65      DEA
     O               66      DFA
     O               67      DGA
     O               68      DHA
     O               69      DIA
     O               70      DJA
     O               71      DKA
     O               72      DLA
     O               73      DMA
     O               74      DNA
     O               75      DOA
     O               76      DPA
     O               77      DQA
     O               78      DRA
     O               79      DSA
     O               80      DTA
     O               81      DUA
     O               82      DVA
     O               83      DWA
     O               84      DXA
     O               85      DYA
     O               86      DZA
     O               87      D0A
     O               88      D1A
     O               89      D2A
     O               90      D3A
     O               91      D4A
     O               92      D5A
     O               93      D6A

     OINPUTK    EADD U1      ADDREC
     O                       DA                  16
     O               30      DB
     O               31      DC
     O               32      DD
     O               33      DE
     O               34      DF
     O               35      DG
     O               36      DH
     O               37      DI
     O               38      DJ
     O               39      DK
     O               40      DL
     O               41      DM
     O               42      DN
     O               43      DZ
     O               44      DO
     O               45      DP
     O               46      DQ
     O               47      DR
     O               48      DS
     O               49      DT
     O               50      DU
     O               51      DV
     O               52      DW
     O               53      DX
     O               54      DY
     O               55      D0
     O               56      D1
     O               57      D2
     O               58      D3
     O               59      D4
     O               60      D5
     O               61      D6
     O               62      DBA
     O               63      DCA
     O               64      DDA
     O               65      DEA
     O               66      DFA
     O               67      DGA
     O               68      DHA
     O               69      DIA
     O               70      DJA
     O               71      DKA
     O               72      DLA
     O               73      DMA
     O               74      DNA
     O               75      DOA
     O               76      DPA
     O               77      DQA
     O               78      DRA
     O               79      DSA
     O               80      DTA
     O               81      DUA
     O               82      DVA
     O               83      DWA
     O               84      DXA
     O               85      DYA
     O               86      DZA
     O               87      D0A
     O               88      D1A
     O               89      D2A
     O               90      D3A
     O               91      D4A
     O               92      D5A
     O               93      D6A
     OINPUTR    EADD    U2   ADDREC
     O                       DA                  16
     O               30      DB
     O               31      DC
     O               32      DD
     O               33      DE
     O               34      DF
     O               35      DG
     O               36      DH
     O               37      DI
     O               38      DJ
     O               39      DK
     O               40      DL
     O               41      DM
     O               42      DN
     O               43      DZ
     O               44      DO
     O               45      DP
     O               46      DQ
     O               47      DR
     O               48      DS
     O               49      DT
     O               50      DU
     O               51      DV
     O               52      DW
     O               53      DX
     O               54      DY
     O               55      D0
     O               56      D1
     O               57      D2
     O               58      D3
     O               59      D4
     O               60      D5
     O               61      D6
     O               62      DBA
     O               63      DCA
     O               64      DDA
     O               65      DEA
     O               66      DFA
     O               67      DGA
     O               68      DHA
     O               69      DIA
     O               70      DJA
     O               71      DKA
     O               72      DLA
     O               73      DMA
     O               74      DNA
     O               75      DOA
     O               76      DPA
     O               77      DQA
     O               78      DRA
     O               79      DSA
     O               80      DTA
     O               81      DUA
     O               82      DVA
     O               83      DWA
     O               84      DXA
     O               85      DYA
     O               86      DZA
     O               87      D0A
     O               88      D1A
     O               89      D2A
     O               90      D3A
     O               91      D4A
     O               92      D5A
     O               93      D6A

     OINPUTK    EDEL U1      DELREC
     OINPUTR    EDEL U2      DELREC


     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 F6-Update F9-Add F11-Del F19-Prev_fld F20-More_fld
**
0123456789ABCDEF

#top

DUSP1 RPG

     H*eywords++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++Comments+++++++++++ 
     H OPTION(*NODEBUGIO)
     H DFTACTGRP(*NO) ACTGRP(*CALLER) DFTNAME(DISP )
     F*
     F*  LIMITED TO MAXIMUM FILE LENGTH OF 4080
     F*  REQUIRES FILE  QTEMP/FFD  TO COMPILE
     F*  use cmd DSPFFD  FILE(&LIB/&FILE) OUTPUT(*OUTFILE) OUTFILE(QTEMP/FFD)
	 
     FFFD       IF   E             DISK
     FDISPF     CF   F  803        WORKSTN
     F*
     F                                     INFDS(INFDS)
     FINPUTK    UF A F32766   800AIDISK    KEYLOC(1)
     F                                     EXTIND(*INU1)
     F                                     INFDS(INFDK)
     FINPUTR    UF A 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 CGKY            S              1
     D UPDDONE         S              1
     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             79    DIM(2) CTDATA PERRCD(1)
     D CRS             S              1    DIM(16) CTDATA PERRCD(16)


     D                 DS
     D  D                      1   4080
     D                                     DIM(4080)                            INCOMING DATA
     D  DA                     1   2048
     D                                     DIM(2048)
     D  DB                  2049   2064
     D  DC                  2065   2096
     D  DD                  2097   2128
     D  DE                  2129   2160
     D  DF                  2161   2192
     D  DG                  2193   2224
     D  DH                  2225   2256
     D  DI                  2257   2288
     D  DJ                  2289   2320
     D  DK                  2321   2352
     D  DL                  2353   2384
     D  DM                  2385   2416
     D  DN                  2417   2448
     D  DZ                  2449   2480
     D  DO                  2481   2512
     D  DP                  2513   2544
     D  DQ                  2545   2576
     D  DR                  2577   2608
     D  DS                  2609   2640
     D  DT                  2641   2672
     D  DU                  2673   2704
     D  DV                  2705   2736
     D  DW                  2737   2768
     D  DX                  2769   2800
     D  DY                  2801   2832
     D  D0                  2833   2864
     D  D1                  2865   2896
     D  D2                  2897   2928
     D  D3                  2929   2960
     D  D4                  2961   2992
     D  D5                  2993   3024
     D  D6                  3025   3056
     D  DBA                 3057   3088
     D  DCA                 3089   3120
     D  DDA                 3121   3152
     D  DEA                 3153   3184
     D  DFA                 3185   3216
     D  DGA                 3217   3248
     D  DHA                 3249   3280
     D  DIA                 3281   3312
     D  DJA                 3313   3344
     D  DKA                 3345   3376
     D  DLA                 3377   3408
     D  DMA                 3409   3440
     D  DNA                 3441   3472
     D  DOA                 3473   3504
     D  DPA                 3505   3536
     D  DQA                 3537   3568
     D  DRA                 3569   3600
     D  DSA                 3601   3632
     D  DTA                 3633   3664
     D  DUA                 3665   3696
     D  DVA                 3697   3728
     D  DWA                 3729   3760
     D  DXA                 3761   3792
     D  DYA                 3793   3824
     D  DZA                 3825   3856
     D  D0A                 3857   3888
     D  D1A                 3889   3920
     D  D2A                 3921   3952
     D  D3A                 3953   3984
     D  D4A                 3985   4016
     D  D5A                 4017   4048
     D  D6A                 4049   4080
     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

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


     D @LOOP           C                   '1'
     D @FALSE          C                   '0'
     D @TRUE           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 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 2048  DA
     I                               2049 2064  DB                30
     I                               2065 2096  DC                31
     I                               2097 2128  DD                32
     I                               2129 2160  DE                33
     I                               2161 2192  DF                34
     I                               2193 2224  DG                35
     I                               2225 2256  DH                36
     I                               2257 2288  DI                37
     I                               2289 2320  DJ                38
     I                               2321 2352  DK                39
     I                               2353 2384  DL                40
     I                               2385 2416  DM                41
     I                               2417 2448  DN                42
     I                               2449 2480  DZ                43
     I                               2481 2512  DO                44
     I                               2513 2544  DP                45
     I                               2545 2576  DQ                46
     I                               2577 2608  DR                47
     I                               2609 2640  DS                48
     I                               2641 2672  DT                49
     I                               2673 2704  DU                50
     I                               2705 2736  DV                51
     I                               2737 2768  DW                52
     I                               2769 2800  DX                53
     I                               2801 2832  DY                54
     I                               2833 2864  D0                55
     I                               2865 2896  D1                56
     I                               2897 2928  D2                57
     I                               2929 2960  D3                58
     I                               2961 2992  D4                59
     I                               2993 3024  D5                60
     I                               3025 3056  D6                61
     I                               3057 3088  DBA               62
     I                               3089 3120  DCA               63
     I                               3121 3152  DDA               64
     I                               3153 3184  DEA               65
     I                               3185 3216  DFA               66
     I                               3217 3248  DGA               67
     I                               3249 3280  DHA               68
     I                               3281 3312  DIA               69
     I                               3313 3344  DJA               70
     I                               3345 3376  DKA               71
     I                               3377 3408  DLA               72
     I                               3409 3440  DMA               73
     I                               3441 3472  DNA               74
     I                               3473 3504  DOA               75
     I                               3505 3536  DPA               76
     I                               3537 3568  DQA               77
     I                               3569 3600  DRA               78
     I                               3601 3632  DSA               79
     I                               3633 3664  DTA               80
     I                               3665 3696  DUA               81
     I                               3697 3728  DVA               82
     I                               3729 3760  DWA               83
     I                               3761 3792  DXA               84
     I                               3793 3824  DYA               85
     I                               3825 3856  DZA               86
     I                               3857 3888  D0A               87
     I                               3889 3920  D1A               88
     I                               3921 3952  D2A               89
     I                               3953 3984  D3A               90
     I                               3985 4016  D4A               91
     I                               4017 4048  D5A               92
     I                               4049 4080  D6A               93
     IINPUTR    NS  01
     I                                  1 2048  DA
     I                               2049 2064  DB                30
     I                               2065 2096  DC                31
     I                               2097 2128  DD                32
     I                               2129 2160  DE                33
     I                               2161 2192  DF                34
     I                               2193 2224  DG                35
     I                               2225 2256  DH                36
     I                               2257 2288  DI                37
     I                               2289 2320  DJ                38
     I                               2321 2352  DK                39
     I                               2353 2384  DL                40
     I                               2385 2416  DM                41
     I                               2417 2448  DN                42
     I                               2449 2480  DZ                43
     I                               2481 2512  DO                44
     I                               2513 2544  DP                45
     I                               2545 2576  DQ                46
     I                               2577 2608  DR                47
     I                               2609 2640  DS                48
     I                               2641 2672  DT                49
     I                               2673 2704  DU                50
     I                               2705 2736  DV                51
     I                               2737 2768  DW                52
     I                               2769 2800  DX                53
     I                               2801 2832  DY                54
     I                               2833 2864  D0                55
     I                               2865 2896  D1                56
     I                               2897 2928  D2                57
     I                               2929 2960  D3                58
     I                               2961 2992  D4                59
     I                               2993 3024  D5                60
     I                               3025 3056  D6                61
     I                               3057 3088  DBA               62
     I                               3089 3120  DCA               63
     I                               3121 3152  DDA               64
     I                               3153 3184  DEA               65
     I                               3185 3216  DFA               66
     I                               3217 3248  DGA               67
     I                               3249 3280  DHA               68
     I                               3281 3312  DIA               69
     I                               3313 3344  DJA               70
     I                               3345 3376  DKA               71
     I                               3377 3408  DLA               72
     I                               3409 3440  DMA               73
     I                               3441 3472  DNA               74
     I                               3473 3504  DOA               75
     I                               3505 3536  DPA               76
     I                               3537 3568  DQA               77
     I                               3569 3600  DRA               78
     I                               3601 3632  DSA               79
     I                               3633 3664  DTA               80
     I                               3665 3696  DUA               81
     I                               3697 3728  DVA               82
     I                               3729 3760  DWA               83
     I                               3761 3792  DXA               84
     I                               3793 3824  DYA               85
     I                               3825 3856  DZA               86
     I                               3857 3888  D0A               87
     I                               3889 3920  D1A               88
     I                               3921 3952  D2A               89
     I                               3953 3984  D3A               90
     I                               3985 4016  D4A               91
     I                               4017 4048  D5A               92
     I                               4049 4080  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 = 2048;

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

         //   START        TAG
           DOW       @LOOP = @LOOP;

           IF  RTN  = '3';

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

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

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

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

        //  CF20 MORE FIELDS
           IF  AID  = XB8;

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

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

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

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

       //  CF19 PREVIOUS FIELDS
           IF  AID  = XB7;

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

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

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

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

          // 1 ENTER  4 ROLL DN  5 ROLL UP
          // F6 = X36  F9 = X39  F11 = X3B
           IF  AID  = '1'or AID = '4' or AID = '5' or
               AID  = X36 or AID = X39 or AID = X3B;
           ELSE;
            MX = 1;         // INVALID KEY
            EXSR  @ERROR;
           ENDIF;

          //       UPDATE MODE
           IF  UPDF    = 'Y';
             UPDDONE = @FALSE;
           // F6
             IF *INU1 AND AID = X36 AND
             (LOP1 = X01 OR LOP1 = X03);
               EXSR @UPD;
               EXCEPT UPDATREC;
               UPDDONE = @TRUE;
             ENDIF;

             IF *INU2 AND AID = X36 AND
             (LOP2 = X01 OR LOP2 = X02);
               EXSR @UPD;
               EXCEPT UPDATREC;
               UPDDONE = @TRUE;
             ENDIF;

           // F9
             IF AID = X39;
               EXSR   @UPD;
               EXCEPT ADDREC;
               UPDDONE = @TRUE;
             ENDIF;

           // F11
             IF *INU1 AND AID = X3B AND
             (LOP1 = X01 OR LOP1 = X03);
               EXCEPT DELREC;
               UPDDONE = @TRUE;
              ENDIF;

             IF *INU2 AND AID = X3B AND
             (LOP2 = X01 OR LOP2 = X02);
               EXCEPT DELREC;
               UPDDONE = @TRUE;
              ENDIF;

             ENDIF;


          IF  RTN = '3' OR UPDDONE = @TRUE;
          ELSE;
            EXSR      @PCKD;
          ENDIF;


        // CONT1  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

         // 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);
          ITER;
         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
          X1 = %LOOKUP(N(Y) : N );
          W = R(X1) + 1;

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

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

          Z1 = 60;
          FOR Z  =  K2  DOWNTO K1;

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

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

            Z1 = Z1 -1;
          ENDFOR;

          ENDIF;

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

        ENDIF;

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

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

        ENDIF;

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

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

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

        ENDIF;

       ENDSR;


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

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

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

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


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

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

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

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

             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 ;   // address of the RRN field
            RU  = RU + SBA + RBA + '          ';

       // 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;



       //   @@@@@@@    UPD   @@@@@@@@@@@@@@@@@@@@@@@@@
          BEGSR  @UPD;

        // CONVERT  DATA  FOR OUTPUT

        //  FOR EACH  FIELD, CHECK IF FIELD WAS MODIFIED, AND IF SO MOVE
        // THE MODIFIED DATA INTO THE OUTPUT ARRAY
         K1 = 0;
         K2 = 0;
         W  = 1;
         CGKY = *BLANK;  // KEY CHANGED
         KW   = KEYA;

           FOR  Y  = 1  TO NUMFKY ;

            IF KY(Y) > '1';
             ITER;
            ENDIF;


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

       //  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;

          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


         // CHECK IF FIELD WAS CLEARED ONLY
          DOW @LOOP = @LOOP; //  not a loop
         X =  X + 2;
         IF  ID(X) = SBA;
          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;
              LEAVE;
          ENDIF;

        // MOVE DATA TO WORK ARRAY K
             X1 = X;
            FOR X2 = 1 TO K2;

             IF ID(X1) < ' ';
              LEAVE;
             ENDIF;

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

          LEAVE;
         ENDDO;

        // *  SET START POSN
          W =   S(Y);

         // ALPHA
          IF T(Y) =  'A'  and V(XX) <>  'Y';
           FOR Z  =  K1 to K2;
             D(W) =  K(Z);
             W    =  W + 1;
           ENDFOR;
          ENDIF;

        IF T(Y) =  'A' and  V(XX) = 'Y';  //VARYING

         //  the data start is in S(Y)
         //  the data is in array K
         //  get the length of the data cvt to bin and stik in pos 1 2
         //  put the rest in pos 3 onwards

              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';
           NUSA= *BLANKS;
           FOR VX = 1 TO 60;
             NUSA = %TRIM(NUSA) + NU(VX);
           ENDFOR;
         %SUBST(DATA  : W : Q(Y)) = %SUBST(NUSA: 61 -Q(Y));

        ENDIF;


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

         %SUBST(DATA : 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(DATA : W : 2)   =   BY2;
         ENDIF;

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

        ENDIF;

         //  UPDATE KEY IF NECESSARY
         IF   KY(Y)  = '1';
            CGKY = '1';
            EXSR  @PCKMOV;
         ENDIF;


         ENDDO;
        ENDFOR;


          IF  CGKY = '1';
           KEYA = KW;
          ENDIF;

        ENDSR;



      /END-FREE

     OINPUTK    E    U1      UPDATREC
     O                       DA                  
     O               30      DB
     O               31      DC
     O               32      DD
     O               33      DE
     O               34      DF
     O               35      DG
     O               36      DH
     O               37      DI
     O               38      DJ
     O               39      DK
     O               40      DL
     O               41      DM
     O               42      DN
     O               43      DZ
     O               44      DO
     O               45      DP
     O               46      DQ
     O               47      DR
     O               48      DS
     O               49      DT
     O               50      DU
     O               51      DV
     O               52      DW
     O               53      DX
     O               54      DY
     O               55      D0
     O               56      D1
     O               57      D2
     O               58      D3
     O               59      D4
     O               60      D5
     O               61      D6
     O               62      DBA
     O               63      DCA
     O               64      DDA
     O               65      DEA
     O               66      DFA
     O               67      DGA
     O               68      DHA
     O               69      DIA
     O               70      DJA
     O               71      DKA
     O               72      DLA
     O               73      DMA
     O               74      DNA
     O               75      DOA
     O               76      DPA
     O               77      DQA
     O               78      DRA
     O               79      DSA
     O               80      DTA
     O               81      DUA
     O               82      DVA
     O               83      DWA
     O               84      DXA
     O               85      DYA
     O               86      DZA
     O               87      D0A
     O               88      D1A
     O               89      D2A
     O               90      D3A
     O               91      D4A
     O               92      D5A
     O               93      D6A
     OINPUTR    E       U2   UPDATREC
     O                       DA                  
     O               30      DB
     O               31      DC
     O               32      DD
     O               33      DE
     O               34      DF
     O               35      DG
     O               36      DH
     O               37      DI
     O               38      DJ
     O               39      DK
     O               40      DL
     O               41      DM
     O               42      DN
     O               43      DZ
     O               44      DO
     O               45      DP
     O               46      DQ
     O               47      DR
     O               48      DS
     O               49      DT
     O               50      DU
     O               51      DV
     O               52      DW
     O               53      DX
     O               54      DY
     O               55      D0
     O               56      D1
     O               57      D2
     O               58      D3
     O               59      D4
     O               60      D5
     O               61      D6
     O               62      DBA
     O               63      DCA
     O               64      DDA
     O               65      DEA
     O               66      DFA
     O               67      DGA
     O               68      DHA
     O               69      DIA
     O               70      DJA
     O               71      DKA
     O               72      DLA
     O               73      DMA
     O               74      DNA
     O               75      DOA
     O               76      DPA
     O               77      DQA
     O               78      DRA
     O               79      DSA
     O               80      DTA
     O               81      DUA
     O               82      DVA
     O               83      DWA
     O               84      DXA
     O               85      DYA
     O               86      DZA
     O               87      D0A
     O               88      D1A
     O               89      D2A
     O               90      D3A
     O               91      D4A
     O               92      D5A
     O               93      D6A

     OINPUTK    EADD U1      ADDREC
     O                       DA                  
     O               30      DB
     O               31      DC
     O               32      DD
     O               33      DE
     O               34      DF
     O               35      DG
     O               36      DH
     O               37      DI
     O               38      DJ
     O               39      DK
     O               40      DL
     O               41      DM
     O               42      DN
     O               43      DZ
     O               44      DO
     O               45      DP
     O               46      DQ
     O               47      DR
     O               48      DS
     O               49      DT
     O               50      DU
     O               51      DV
     O               52      DW
     O               53      DX
     O               54      DY
     O               55      D0
     O               56      D1
     O               57      D2
     O               58      D3
     O               59      D4
     O               60      D5
     O               61      D6
     O               62      DBA
     O               63      DCA
     O               64      DDA
     O               65      DEA
     O               66      DFA
     O               67      DGA
     O               68      DHA
     O               69      DIA
     O               70      DJA
     O               71      DKA
     O               72      DLA
     O               73      DMA
     O               74      DNA
     O               75      DOA
     O               76      DPA
     O               77      DQA
     O               78      DRA
     O               79      DSA
     O               80      DTA
     O               81      DUA
     O               82      DVA
     O               83      DWA
     O               84      DXA
     O               85      DYA
     O               86      DZA
     O               87      D0A
     O               88      D1A
     O               89      D2A
     O               90      D3A
     O               91      D4A
     O               92      D5A
     O               93      D6A
     OINPUTR    EADD    U2   ADDREC
     O                       DA                  
     O               30      DB
     O               31      DC
     O               32      DD
     O               33      DE
     O               34      DF
     O               35      DG
     O               36      DH
     O               37      DI
     O               38      DJ
     O               39      DK
     O               40      DL
     O               41      DM
     O               42      DN
     O               43      DZ
     O               44      DO
     O               45      DP
     O               46      DQ
     O               47      DR
     O               48      DS
     O               49      DT
     O               50      DU
     O               51      DV
     O               52      DW
     O               53      DX
     O               54      DY
     O               55      D0
     O               56      D1
     O               57      D2
     O               58      D3
     O               59      D4
     O               60      D5
     O               61      D6
     O               62      DBA
     O               63      DCA
     O               64      DDA
     O               65      DEA
     O               66      DFA
     O               67      DGA
     O               68      DHA
     O               69      DIA
     O               70      DJA
     O               71      DKA
     O               72      DLA
     O               73      DMA
     O               74      DNA
     O               75      DOA
     O               76      DPA
     O               77      DQA
     O               78      DRA
     O               79      DSA
     O               80      DTA
     O               81      DUA
     O               82      DVA
     O               83      DWA
     O               84      DXA
     O               85      DYA
     O               86      DZA
     O               87      D0A
     O               88      D1A
     O               89      D2A
     O               90      D3A
     O               91      D4A
     O               92      D5A
     O               93      D6A

     OINPUTK    EDEL U1      DELREC
     OINPUTR    EDEL U2      DELREC


     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 F6-Update F9-Add F11-Del F19-Prev_fld F20-More_fld
**
0123456789ABCDEF

#top

DUSP2 RPG

#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

DSPFF CMD

#top

DIS CLE

#top

DIS1 CLE

#top

DIS3 CLE

#top

DISV CLE

#top

DISF CLE

#top

DISPR RPG

#top

DISPRF DSPF

#top

DISPY RPG

#top

DISPYF DSPF

#top

Retrieved from "https://wiki.midrange.com/index.php?title=UDDS_File_Display/Update&oldid=12452"