Difference between revisions of "UDDS File Display/Update"

From MidrangeWiki
Jump to: navigation, search
(Created page with "--")
 
m (DIS1 CL files with NULL fields cant be processed)
 
(36 intermediate revisions by the same user not shown)
Line 1: Line 1:
--
+
__FORCETOC__
 +
 
 +
 
 +
==UDDS PROGRAMS THAT SHOW FILES FIELDS AND RELATIONS AND ALLOWS UPDATE ==
 +
The manual that describes the 5250 data stream is 5494 Remote Control Unit, Functions Reference. SC30-3533-04 (topic 15) [http://tn5250.sourceforge.net/resources.html]
 +
 
 +
 
 +
The 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.  There are 3 programs first is limited to 2048 last to 6048.
 +
 
 +
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.
 +
The COMPILE CL will create the objects once you have copied the source code into a source file.
 +
 
 +
Once compiled the command to run it is  'DSPFL  yourlib/yourfile '
 +
 
 +
 
 +
===DISP  RPG===
 +
 
 +
<pre>
 +
    H*eywords++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++Comments+++++++++++
 +
    H OPTION(*NODEBUGIO)
 +
    H DFTACTGRP(*NO) ACTGRP(*CALLER) DFTNAME(DISP )
 +
    F*
 +
    F*  LIMITED TO MAXIMUM FILE LENGTH OF 2048
 +
    F*  TEST
 +
    F*  REQUIRES FILE TO COMPILE
 +
    F*  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  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;
 +
 
 +
              SELECT;
 +
                WHEN  *INU1;
 +
                RRN = RN1;
 +
                WHEN  *INU2;
 +
                RRN = RN2;
 +
              ENDSL;
 +
 
 +
        // IF GOT RECORDS WRITE DATA TO THE DISPLAY
 +
 
 +
            NEWRU  = '1';
 +
            WRTRRN = '1';
 +
            RU    = *ALLX'00';
 +
            CLEAR  RU;        //  initialise Request Unit  255 bytes max
 +
 
 +
          IF RRN > 0    ;
 +
            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 ;
 +
              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;
 +
          ENDIF;
 +
 
 +
            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
 +
</pre>
 +
 
 +
[[#top]]
 +
 
 +
===DISP1  RPG===
 +
 
 +
<pre>
 +
    H*eywords++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++Comments+++++++++++
 +
    H OPTION(*NODEBUGIO)
 +
    H DFTACTGRP(*NO) ACTGRP(*CALLER) DFTNAME(DISP )
 +
    F*
 +
    F*  LIMITED TO MAXIMUM FILE LENGTH OF 4080
 +
    F*  TEST
 +
    F*  REQUIRES FILE TO COMPILE
 +
    F*  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            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;
 +
 
 +
              SELECT;
 +
                WHEN  *INU1;
 +
                RRN = RN1;
 +
                WHEN  *INU2;
 +
                RRN = RN2;
 +
              ENDSL;
 +
        // IF GOT RECORDS WRITE DATA TO THE DISPLAY
 +
 
 +
            NEWRU  = '1';
 +
            WRTRRN = '1';
 +
            RU    = *ALLX'00';
 +
            CLEAR  RU;        //  initialise Request Unit  255 bytes max
 +
 
 +
          IF RRN > 0    ;
 +
            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 ;
 +
              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;
 +
          ENDIF;
 +
 
 +
            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
 +
 
 +
</pre>
 +
 
 +
[[#top]]
 +
 
 +
===DISP2  RPG===
 +
 
 +
<pre>
 +
    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;
 +
 
 +
              SELECT;
 +
                WHEN  *INU1;
 +
                RRN = RN1;
 +
                WHEN  *INU2;
 +
                RRN = RN2;
 +
              ENDSL;
 +
 
 +
        // IF GOT RECORDS WRITE DATA TO THE DISPLAY
 +
 
 +
            NEWRU  = '1';
 +
            WRTRRN = '1';
 +
            RU    = *ALLX'00';
 +
            CLEAR  RU;        //  initialise Request Unit  255 bytes max
 +
 
 +
          IF RRN > 0    ;
 +
            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 ;
 +
              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;
 +
          ENDIF;
 +
 
 +
            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
 +
 
 +
</pre>
 +
 
 +
[[#top]]
 +
 
 +
===DUSP  RPG===
 +
 
 +
<pre>
 +
    H*eywords++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++Comments+++++++++++
 +
    H OPTION(*NODEBUGIO)
 +
    H DFTACTGRP(*NO) ACTGRP(*CALLER) DFTNAME(DUSP )
 +
    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 DISBIN          PR                  extpgm('DISBIN')
 +
    D  NUM                          15P 0
 +
    D  BAN2                          2
 +
    D  BAN4                          4
 +
    D  BINTYP                        1    CONST
 +
 
 +
      *
 +
    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 NUC            S            15P 0
 +
    D BAN2            S              2
 +
    D BAN4            S              4
 +
 
 +
    D                DS
 +
    D NUFA                    1    60A
 +
    D NUF                    1    23A
 +
    D NUF1                    1    14A
 +
 
 +
    D                DS
 +
    D result8                        8F
 +
    D NUFW8                  1      8A
 +
 
 +
    D                DS
 +
    D result4                        4F
 +
    D NUFW4                  1      4A
 +
 
 +
    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
 +
DCL V
 +
 
 +
      /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
 +
        SELECT;
 +
          WHEN  T(Y)  =  'A';  // ALPHA DATA
 +
          K = ' ';
 +
          K1 = 1;
 +
          K2 = Q(Y);
 +
          WHEN  T(Y)  =  'F';  // FLOAT
 +
          K  = '0';
 +
          K1 =  1;
 +
          K2 = L(Y);
 +
          OTHER;
 +
          K  = '0';
 +
          K1 =  1;
 +
          K2 = C(Y);
 +
        ENDSL;
 +
 
 +
 
 +
      // 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;
 +
 
 +
              SELECT;
 +
                WHEN  *INU1;
 +
                RRN = RN1;
 +
                WHEN  *INU2;
 +
                RRN = RN2;
 +
              ENDSL;
 +
        // IF GOT RECORDS WRITE DATA TO THE DISPLAY
 +
 
 +
            NEWRU  = '1';
 +
            WRTRRN = '1';
 +
            RU    = *ALLX'00';
 +
            CLEAR  RU;        //  initialise Request Unit  255 bytes max
 +
 
 +
          IF RRN > 0    ;
 +
            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 ;
 +
              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;
 +
          ENDIF;
 +
 
 +
            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
 +
        SELECT;
 +
          WHEN  T(Y)  =  'A';  // ALPHA DATA
 +
          K = ' ';
 +
          K1 = 1;
 +
          K2 = Q(Y);
 +
          WHEN  T(Y)  =  'F';  // FLOAT
 +
          K  = '0';
 +
          K1 =  1;
 +
          K2 = L(Y);
 +
          OTHER;
 +
          K  = '0';
 +
          K1 =  1;
 +
          K2 = C(Y);
 +
        ENDSL;
 +
 
 +
          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 stick 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';
 +
 
 +
          NUSA= *BLANKS;
 +
          FOR VX = 1 TO 60;
 +
            NUSA = %TRIM(NUSA) + NU(VX);
 +
          ENDFOR;
 +
            NUC  = NUS;
 +
 
 +
        IF  Q(Y) = 2 ;
 +
              DISBIN  ( NUC : BAN2 : BAN4  : '2');
 +
            %SUBST(DATA : W : 2)  =  BAN2;
 +
        ENDIF;
 +
 
 +
        IF  Q(Y) = 4 ;
 +
              DISBIN  ( NUC : BAN2 : BAN4  : '4');
 +
            %SUBST(DATA : W : 4)  =  BAN4;
 +
        ENDIF;
 +
 
 +
        ENDIF;
 +
 
 +
 
 +
      //  FLOAT FIELDS
 +
        IF  T(Y) =  'F';
 +
 
 +
        IF  Q(Y) = 4;
 +
          NUFA= *BLANKS;
 +
          FOR VX = 1 TO 14;
 +
            NUFA = %TRIM(NUFA) + K(VX);
 +
          ENDFOR;
 +
 
 +
          result4 = %float(NUF1);
 +
        %SUBST(DATA : W : 4)  =  NUFW4;
 +
 
 +
        ENDIF;
 +
 
 +
 
 +
        IF  Q(Y) = 8;
 +
          NUFA= *BLANKS;
 +
          FOR VX = 1 TO 23;
 +
            NUFA = %TRIM(NUFA) + K(VX);
 +
          ENDFOR;
 +
 
 +
          result8 = %float(NUF);
 +
          %SUBST(DATA : W : 8)  =  NUFW8;
 +
 
 +
        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
 +
 
 +
 
 +
</pre>
 +
 
 +
[[#top]]
 +
 
 +
===DUSP1  RPG===
 +
 
 +
<pre>
 +
    H*eywords++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++Comments+++++++++++
 +
    H OPTION(*NODEBUGIO)
 +
    H DFTACTGRP(*NO) ACTGRP(*CALLER) DFTNAME(DUSP1 )
 +
    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 DISBIN          PR                  extpgm('DISBIN')
 +
    D  NUM                          15P 0
 +
    D  BAN2                          2
 +
    D  BAN4                          4
 +
    D  BINTYP                        1    CONST
 +
 
 +
      *
 +
    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 NUC            S            15P 0
 +
    D BAN2            S              2
 +
DCL  D BAN4            S              4
 +
 
 +
    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  4080
 +
    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
 +
 
 +
    DDUSP1            PR
 +
    D                                1
 +
    D                                1
 +
    D                                4
 +
    D                                1
 +
    D                              500
 +
    D                                5
 +
    D                              800
 +
    DDUSP1            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;
 +
 
 +
              SELECT;
 +
                WHEN  *INU1;
 +
                RRN = RN1;
 +
                WHEN  *INU2;
 +
                RRN = RN2;
 +
              ENDSL;
 +
        // IF GOT RECORDS WRITE DATA TO THE DISPLAY
 +
 
 +
            NEWRU  = '1';
 +
            WRTRRN = '1';
 +
            RU    = *ALLX'00';
 +
            CLEAR  RU;        //  initialise Request Unit  255 bytes max
 +
 
 +
          IF RRN > 0    ;
 +
            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 ;
 +
              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;
 +
          ENDIF;
 +
 
 +
            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';
 +
 
 +
          NUSA= *BLANKS;
 +
          FOR VX = 1 TO 60;
 +
            NUSA = %TRIM(NUSA) + NU(VX);
 +
          ENDFOR;
 +
            NUC  = NUS;
 +
 
 +
        IF  Q(Y) = 2 ;
 +
              DISBIN  ( NUC : BAN2 : BAN4  : '2');
 +
            %SUBST(DATA : W : 2)  =  BAN2;
 +
        ENDIF;
 +
 
 +
        IF  Q(Y) = 4 ;
 +
              DISBIN  ( NUC : BAN2 : BAN4  : '4');
 +
            %SUBST(DATA : W : 4)  =  BAN4;
 +
        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>
 +
 
 +
[[#top]]
 +
 
 +
===DUSP2  RPG===
 +
 
 +
<pre>
 +
    H*eywords++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++Comments+++++++++++
 +
    H OPTION(*NODEBUGIO)
 +
    H DFTACTGRP(*NO) ACTGRP(*CALLER) DFTNAME(DUSP2 )
 +
    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    UF A F32766  800AIDISK    KEYLOC(1)
 +
    F                                    EXTIND(*INU1)
 +
    F                                    INFDS(INFDK)
 +
    FINPUTR    UF A F32766        DISK    EXTIND(*INU2)
 +
    F                                    INFDS(INFDR)
 +
 
 +
    D DISBIN          PR                  extpgm('DISBIN')
 +
    D  NUM                          15P 0
 +
    D  BAN2                          2
 +
    D  BAN4                          4
 +
    D  BINTYP                        1    CONST
 +
 
 +
      *
 +
    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 NUC            S            15P 0
 +
    D BAN2            S              2
 +
DCL  D BAN4            S              4
 +
 
 +
 
 +
    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  6080
 +
    D  D                      1  6080
 +
    D                                    DIM(6080)                            INCOMING DATA
 +
    D  DA                    1  4048
 +
    D                                    DIM(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
 +
 
 +
    DDUSP2            PR
 +
    D                                1
 +
    D                                1
 +
    D                                4
 +
    D                                1
 +
    D                              500
 +
    D                                5
 +
    D                              800
 +
    DDUSP2            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*.
 +
 
 +
0038 IINPUTK    NS  01
 +
0039 I                                  1 4048  DA
 +
0040 I                              4049 4064  DB                30
 +
0041 I                              4065 4096  DC                31
 +
0042 I                              4097 4128  DD                32
 +
0043 I                              4129 4160  DE                33
 +
0044 I                              4161 4192  DF                34
 +
0045 I                              4193 4224  DG                35
 +
0046 I                              4225 4256  DH                36
 +
0047 I                              4257 4288  DI                37
 +
0048 I                              4289 4320  DJ                38
 +
0049 I                              4321 4352  DK                39
 +
0050 I                              4353 4384  DL                40
 +
0051 I                              4385 4416  DM                41
 +
0052 I                              4417 4448  DN                42
 +
0053 I                              4449 4480  DZ                43
 +
0054 I                              4481 4512  DO                44
 +
0055 I                              4513 4544  DP                45
 +
0056 I                              4545 4576  DQ                46
 +
0057 I                              4577 4608  DR                47
 +
0058 I                              4609 4640  DS                48
 +
0059 I                              4641 4672  DT                49
 +
0060 I                              4673 4704  DU                50
 +
0061 I                              4705 4736  DV                51
 +
0062 I                              4737 4768  DW                52
 +
0063 I                              4769 4800  DX                53
 +
0064 I                              4801 4832  DY                54
 +
0065 I                              4833 4864  D0                55
 +
0066 I                              4865 4896  D1                56
 +
0067 I                              4897 4928  D2                57
 +
0068 I                              4929 4960  D3                58
 +
0069 I                              4961 4992  D4                59
 +
0070 I                              4993 5024  D5                60
 +
0071 I                              5025 5056  D6                61
 +
0072 I                              5057 5088  DBA              62
 +
0073 I                              5089 5120  DCA              63
 +
0074 I                              5121 5152  DDA              64
 +
0075 I                              5153 5184  DEA              65
 +
0076 I                              5185 5216  DFA              66
 +
0077 I                              5217 5248  DGA              67
 +
0078 I                              5249 5280  DHA              68
 +
0079 I                              5281 5312  DIA              69
 +
0080 I                              5313 5344  DJA              70
 +
0081 I                              5345 5376  DKA              71
 +
0082 I                              5377 5408  DLA              72
 +
0083 I                              5409 5440  DMA              73
 +
0084 I                              5441 5472  DNA              74
 +
0085 I                              5473 5504  DOA              75
 +
0086 I                              5505 5536  DPA              76
 +
0087 I                              5537 5568  DQA              77
 +
0088 I                              5569 5600  DRA              78
 +
0089 I                              5601 5632  DSA              79
 +
0090 I                              5633 5664  DTA              80
 +
0091 I                              5665 5696  DUA              81
 +
0092 I                              5697 5728  DVA              82
 +
0093 I                              5729 5760  DWA              83
 +
0094 I                              5761 5792  DXA              84
 +
0095 I                              5793 5824  DYA              85
 +
0096 I                              5825 5856  DZA              86
 +
0097 I                              5857 5888  D0A              87
 +
0098 I                              5889 5920  D1A              88
 +
0099 I                              5921 5952  D2A              89
 +
0100 I                              5953 5984  D3A              90
 +
0101 I                              5985 6016  D4A              91
 +
0102 I                              6017 6048  D5A              92
 +
0103 I                              6049 6080  D6A              93
 +
0104 IINPUTR    NS  01
 +
0105 I                                  1 4048  DA
 +
0106 I                              4049 4064  DB                30
 +
0107 I                              4065 4096  DC                31
 +
0108 I                              4097 4128  DD                32
 +
0109 I                              4129 4160  DE                33
 +
0110 I                              4161 4192  DF                34
 +
0111 I                              4193 4224  DG                35
 +
0112 I                              4225 4256  DH                36
 +
0113 I                              4257 4288  DI                37
 +
0114 I                              4289 4320  DJ                38
 +
0115 I                              4321 4352  DK                39
 +
0116 I                              4353 4384  DL                40
 +
0117 I                              4385 4416  DM                41
 +
0118 I                              4417 4448  DN                42
 +
0119 I                              4449 4480  DZ                43
 +
0120 I                              4481 4512  DO                44
 +
0121 I                              4513 4544  DP                45
 +
0122 I                              4545 4576  DQ                46
 +
0123 I                              4577 4608  DR                47
 +
0124 I                              4609 4640  DS                48
 +
0125 I                              4641 4672  DT                49
 +
0126 I                              4673 4704  DU                50
 +
0127 I                              4705 4736  DV                51
 +
0128 I                              4737 4768  DW                52
 +
0129 I                              4769 4800  DX                53
 +
0130 I                              4801 4832  DY                54
 +
0131 I                              4833 4864  D0                55
 +
0132 I                              4865 4896  D1                56
 +
0133 I                              4897 4928  D2                57
 +
0134 I                              4929 4960  D3                58
 +
0135 I                              4961 4992  D4                59
 +
0136 I                              4993 5024  D5                60
 +
0137 I                              5025 5056  D6                61
 +
0138 I                              5057 5088  DBA              62
 +
0139 I                              5089 5120  DCA              63
 +
0140 I                              5121 5152  DDA              64
 +
0141 I                              5153 5184  DEA              65
 +
0142 I                              5185 5216  DFA              66
 +
0143 I                              5217 5248  DGA              67
 +
0144 I                              5249 5280  DHA              68
 +
0145 I                              5281 5312  DIA              69
 +
0146 I                              5313 5344  DJA              70
 +
0147 I                              5345 5376  DKA              71
 +
0148 I                              5377 5408  DLA              72
 +
0149 I                              5409 5440  DMA              73
 +
0150 I                              5441 5472  DNA              74
 +
0151 I                              5473 5504  DOA              75
 +
0152 I                              5505 5536  DPA              76
 +
0153 I                              5537 5568  DQA              77
 +
0154 I                              5569 5600  DRA              78
 +
0155 I                              5601 5632  DSA              79
 +
0156 I                              5633 5664  DTA              80
 +
0157 I                              5665 5696  DUA              81
 +
0158 I                              5697 5728  DVA              82
 +
0159 I                              5729 5760  DWA              83
 +
0160 I                              5761 5792  DXA              84
 +
0161 I                              5793 5824  DYA              85
 +
0162 I                              5825 5856  DZA              86
 +
0163 I                              5857 5888  D0A              87
 +
0164 I                              5889 5920  D1A              88
 +
0165 I                              5921 5952  D2A              89
 +
0166 I                              5953 5984  D3A              90
 +
0167 I                              5985 6016  D4A              91
 +
0168 I                              6017 6048  D5A              92
 +
0169 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 = 4048;
 +
 
 +
            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;
 +
 
 +
              SELECT;
 +
                WHEN  *INU1;
 +
                RRN = RN1;
 +
                WHEN  *INU2;
 +
                RRN = RN2;
 +
              ENDSL;
 +
        // IF GOT RECORDS WRITE DATA TO THE DISPLAY
 +
 
 +
            NEWRU  = '1';
 +
            WRTRRN = '1';
 +
            RU    = *ALLX'00';
 +
            CLEAR  RU;        //  initialise Request Unit  255 bytes max
 +
 
 +
          IF RRN > 0    ;
 +
            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 ;
 +
              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;
 +
          ENDIF;
 +
 
 +
            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';
 +
 
 +
        NUSA= *BLANKS;
 +
          FOR VX = 1 TO 60;
 +
            NUSA = %TRIM(NUSA) + NU(VX);
 +
          ENDFOR;
 +
            NUC  = NUS;
 +
 
 +
        IF  Q(Y) = 2 ;
 +
              DISBIN  ( NUC : BAN2 : BAN4  : '2');
 +
            %SUBST(DATA : W : 2)  =  BAN2;
 +
        ENDIF;
 +
 
 +
        IF  Q(Y) = 4 ;
 +
              DISBIN  ( NUC : BAN2 : BAN4  : '4');
 +
            %SUBST(DATA : W : 4)  =  BAN4;
 +
        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>
 +
 
 +
[[#top]]
 +
 
 +
 
 +
===DISPF  DSPF ===
 +
 
 +
<pre>
 +
    A                                      DSPSIZ(24 80 *DS3)
 +
    A                                      PRINT
 +
    A                                      OPENPRT
 +
    A                                      HELP
 +
    A                                      INDARA
 +
    A          R PUT                      USRDFN
 +
    A          R GET                      USRDFN
 +
    A                                      INVITE
 +
</pre>
 +
 
 +
 
 +
[[#top]]
 +
 
 +
== WRAPPER CODE ==
 +
 
 +
===DSPFL    CMD ===
 +
 
 +
<pre>
 +
  /*  TO COMPILE */
 +
  /*  CRTCMD CMD(*CURLIB/DSPFL) PGM(*LIBL/DIS) SRCFILE(*LIBL/QCMDSRC) */
 +
  /*          SRCMBR(DSPFL) VLDCKR(DISV) */
 +
 
 +
            CMD        PROMPT('Display file in field format')
 +
 
 +
            PARM      KWD(FILE) TYPE(QUAL1) MIN(1) MAX(1) +
 +
                          PROMPT('File')
 +
 
 +
            PARM      KWD(MBR) TYPE(*NAME) DFT(*FIRST) +
 +
                          SPCVAL((*FILE) (*FIRST)) MIN(0) MAX(1) +
 +
                          PROMPT('Member')
 +
 
 +
            PARM      KWD(UPD ) TYPE(*CHAR) LEN(1) DFT(N) +
 +
                          RSTD(*YES) VALUES('Y' 'N' 'y' 'n') +
 +
                          PROMPT('Update data (Y/N)')
 +
 
 +
            PARM      KWD(RST ) TYPE(*CHAR) LEN(1) DFT(N) +
 +
                          RSTD(*YES) VALUES('Y' 'N' 'y' 'n') +
 +
                          PROMPT('Get DDS again.')
 +
 
 +
            PARM      KWD(REL ) TYPE(*CHAR) LEN(1) DFT(N) +
 +
                          RSTD(*YES) VALUES('Y' 'N' 'y' 'n') +
 +
                          PROMPT('Show Relations')
 +
 
 +
 
 +
QUAL1:      QUAL      TYPE(*NAME) LEN(10)
 +
            QUAL      TYPE(*NAME) LEN(10) DFT(*LIBL  ) +
 +
                          SPCVAL(*LIBL  ) +
 +
                          PROMPT('Library name')
 +
 
 +
 
 +
</pre>
 +
 
 +
[[#top]]
 +
 
 +
===DIS    CL ===
 +
 
 +
<pre>
 +
 
 +
/* Command processing program for DSPFF command */
 +
 
 +
PGM (&FILIB  &MBR &UPD &RST &REL)
 +
 
 +
DCL &FILIB *CHAR 20
 +
DCL &FILE *CHAR  10
 +
DCL &LIB  *CHAR  10
 +
DCL &SFILE *CHAR  10
 +
DCL &SLIB  *CHAR  10
 +
DCL &MBR  *CHAR  10
 +
DCL &OPT  *CHAR  10
 +
DCL &ALL  *CHAR 1
 +
DCL &RTN  *CHAR 1
 +
DCL &RMBR  *CHAR  10
 +
 
 +
DCL &QRY  *LGL
 +
DCL &UPD  *LGL
 +
DCL &REL  *CHAR 1
 +
DCL &RST  *CHAR 1
 +
 
 +
DCL &RCDL *CHAR 5
 +
DCL &RCDLN *DEC (5 0)
 +
DCL &ACCP *CHAR 1
 +
DCL &OVR  *LGL  VALUE('0')
 +
DCL &FILEF *CHAR  10
 +
DCL &FILEK *CHAR  10
 +
DCL &ID    *CHAR  7
 +
DCL &MF    *CHAR  10
 +
DCL &ML    *CHAR  10
 +
DCL &TYPE  *CHAR  1
 +
DCL &PHY  *CHAR  10
 +
DCL &PHYLIB *CHAR  10
 +
 
 +
RMVLIBLE QTEMP
 +
MONMSG CPF0000
 +
ADDLIBLE QTEMP *FIRST
 +
MONMSG CPF0000 EXEC(GOTO END)
 +
 
 +
RESET:
 +
CHGVAR &FILE  &FILIB
 +
CHGVAR &LIB  (%SST(&FILIB 11 10))
 +
IF (&LIB *EQ ' ')    (CHGVAR &LIB '*LIBL')
 +
IF (&MBR *EQ '*FILE') (CHGVAR &MBR &FILE)
 +
IF (&MBR *EQ '*FIRST') (DO)
 +
RTVMBRD    FILE(&LIB/&FILE) RTNMBR(&RMBR)
 +
CHGVAR &MBR &RMBR
 +
ENDDO
 +
CHGVAR &FILEF ('FF'||(%SST(&FILE 1 8)))
 +
CHGVAR &FILEK ('KF'||(%SST(&FILE 1 8)))
 +
 
 +
IF (&RST= 'Y') DO
 +
DLTF  &FILEF
 +
MONMSG CPF0000
 +
DLTF  &FILEK
 +
MONMSG CPF0000
 +
ENDDO
 +
 
 +
 
 +
CHKOBJ (QTEMP/&FILEF) *FILE
 +
  MONMSG CPF9801 EXEC(DO)
 +
  DSPFFD  FILE(&LIB/&FILE) OUTPUT(*OUTFILE) OUTFILE(QTEMP/&FILEF)
 +
  DSPFD (&LIB/&FILE) TYPE(*ACCPTH) OUTPUT(*OUTFILE) OUTFILE(QTEMP/&FILEK)
 +
  CHGVAR &RTN '2'
 +
ENDDO
 +
 
 +
CHGPF QTEMP/&FILEF LVLCHK(*NO)
 +
CHGPF QTEMP/&FILEK LVLCHK(*NO)
 +
 
 +
IF (&REL = 'Y' ) DO
 +
  CALL DISF  (&FILEK &TYPE &PHY &PHYLIB)
 +
  IF (&TYPE *EQ 'P') DO
 +
    CHGVAR &PHY &FILE
 +
    CHGVAR &PHYLIB &LIB
 +
  ENDDO
 +
CALL  DIS3 (&PHY &PHYLIB &SFILE &SLIB)
 +
IF (&SFILE *NE ' ') DO
 +
  IF ((&SFILE *NE &FILE) *OR (&SLIB *NE &LIB)) DO
 +
  CHGVAR &FILIB (&SFILE||&SLIB)
 +
  CHGVAR &REL '0'
 +
  RTVMBRD    FILE(&SLIB/&SFILE) RTNMBR(&RMBR)
 +
  CHGVAR &MBR &RMBR
 +
  IF (&MBR  *EQ &FILE) THEN(CHGVAR &MBR '*FILE    ')
 +
  GOTO  RESET
 +
  ENDDO
 +
ENDDO
 +
ENDDO
 +
 
 +
CALL  DIS1 (&FILIB  &MBR &UPD &RST &RTN &FILE &LIB &FILEF &FILEK)
 +
 
 +
RCLRSC
 +
 
 +
END:
 +
CLOF  OPNID(&FILE)
 +
MONMSG CPF0000
 +
 
 +
 
 +
 
 +
ENDPGM
 +
 
 +
</pre>
 +
 
 +
[[#top]]
 +
 
 +
===DIS1    CL ===
 +
 
 +
<pre>
 +
/* CALLED BY DIS TO DRIVE SELECTION OF UDDS RPG PROGRAM */
 +
/*  FILE DISPLAYER DRIVER  */
 +
/*  SHOWS A LIST OF FIELDS IN A FILE , ALLOWS SELECTION OF FIELDS  */
 +
 
 +
/*  WHEN ALL THE FIELDS DONT FIT ON ONE SCREEN                */
 +
/*  THIS CONTAINS A LOOP SO THAT MORE FIELDS CAN BE DISPLAYED  */
 +
 
 +
 
 +
PGM (&FILIB  &MBR &UPD &RST &RTN &FILE &LIB &FILEF &FILEK)
 +
 
 +
DCL &FILIB *CHAR 20
 +
DCL &FILE *CHAR  10
 +
DCL &LIB  *CHAR  10
 +
DCL &MBR  *CHAR  10
 +
DCL &PRG  *CHAR  10
 +
DCL &OPT  *CHAR  10
 +
DCL &ALL  *CHAR 1
 +
DCL &RTN  *CHAR 1
 +
DCL &RMV  *CHAR 1
 +
DCL &QRY  *LGL
 +
DCL &UPD  *CHAR 1
 +
DCL &RST  *LGL
 +
DCL &KEYL *CHAR 4
 +
DCL &RCDL *CHAR 5
 +
DCL &RCDLN *DEC (5 0)
 +
DCL &ACCP *CHAR 1
 +
DCL &OVR  *LGL  VALUE('0')
 +
DCL &FILEF *CHAR  10
 +
DCL &FILEK *CHAR  10
 +
DCL &ID    *CHAR  7
 +
DCL &MF    *CHAR  10
 +
DCL &ML    *CHAR  10
 +
DCL &SCNLV *CHAR  500
 +
DCL &SCNLVL *CHAR  5
 +
DCL &SCNKEY *CHAR  800
 +
DCL &JOB  *CHAR  10
 +
DCL &MSG  *CHAR  80
 +
DCLF    DISPX
 +
 
 +
CHGVAR &PGMQ DIS
 +
CHGVAR &SCNLVL '00000'
 +
 
 +
OVRDBF FFD QTEMP/&FILEF SECURE(*YES)
 +
OVRDBF KF  QTEMP/&FILEK SECURE(*YES)
 +
 
 +
 
 +
RTN:
 +
OVRDBF  INPUT  &LIB/&FILE  SHARE(*NO)
 +
CALL  DISPY    (&ALL &RTN &KEYL &ACCP &QRY &RCDL)
 +
            MONMSG    MSGID(CPF5035 CPF5029 RNQ1299 RNX0000) EXEC(DO)
 +
            RTVJOBA    JOB(&JOB)
 +
            SNDBRKMSG  MSG('Cannot handle this file type. Possibly +
 +
                          has NULL data field.') TOMSGQ(&job) +
 +
                          MSGTYPE(*INQ) RPYMSGQ(&job)
 +
 
 +
  goto end
 +
ENDDO
 +
 
 +
DLTOVR  INPUT
 +
MONMSG CPF0000
 +
 
 +
IF (&RTN *EQ '1') (GOTO END)
 +
 
 +
IF (&ACCP *EQ 'K') DO
 +
CHGJOB SWS(10XXXXXX)
 +
OVRDBF    FILE(INPUTK) TOFILE(&LIB/&FILE) MBR(&MBR) +
 +
        SHARE(*YES) SEQONLY(*NO)  SECURE(*YES)
 +
IF (&QRY )  DO
 +
REMSG:
 +
 
 +
REQRY:      SNDRCVF    RCDFMT(SLT)
 +
            IF (&IN01 *OR &IN02) GOTO BYQRY
 +
            CHGVAR &OPT '*INP'
 +
            IF (&UPD *EQ 'Y') (CHGVAR &OPT '*ALL')
 +
            OPNQRYF    FILE((INPUTK)) OPTION(&OPT) QRYSLT(&QSLT) +
 +
                          KEYFLD(*FILE) SEQONLY(*NO)
 +
            MONMSG CPF9899 EXEC(DO)
 +
            RCVMSG    MSGTYPE(*ANY)
 +
            SNDF      RCDFMT(SLTC)
 +
            GOTO REMSG
 +
                                ENDDO
 +
                      ENDDO
 +
              ENDDO
 +
BYQRY:
 +
IF (&ACCP *EQ 'A') DO
 +
            CHGJOB SWS(01XXXXXX)
 +
          OVRDBF    FILE(INPUTR) TOFILE(&LIB/&FILE) MBR(&MBR) +
 +
                          SHARE(*YES) SEQONLY(*NO) SECURE(*YES)
 +
    IF (&QRY )        DO
 +
REMSGA:
 +
 
 +
REQRYA:    SNDRCVF    RCDFMT(SLT)
 +
            IF (&IN01 *OR &IN02) GOTO BYQRYA
 +
            CHGVAR &OPT '*INP'
 +
            IF (&UPD = 'Y') (CHGVAR &OPT '*ALL')
 +
            OPNQRYF    FILE((INPUTR)) OPTION(&OPT) QRYSLT(&QSLT) +
 +
                          KEYFLD(*FILE) SEQONLY(*NO)
 +
            MONMSG CPF9899 EXEC(DO)
 +
                RCVMSG    MSGTYPE(*ANY)
 +
                SNDF      RCDFMT(SLTC)
 +
                GOTO REMSGA
 +
                CHGVAR    VAR(&IN20) VALUE('1')
 +
    SDAMSG:    RCVMSG    RMV(*NO) MSG(&MSG)
 +
                IF        COND(&MSG ¬= ' ') THEN(DO)
 +
                SNDPGMMSG  MSG(&MSG)
 +
                GOTO      SDAMSG
 +
                ENDDO
 +
                SNDF      RCDFMT(SLTC)
 +
                GOTO      REMSGA
 +
                                ENDDO
 +
 
 +
                    ENDDO
 +
            ENDDO
 +
BYQRYA:
 +
CHGVAR &RCDLN &RCDL
 +
 
 +
IF ( &UPD= 'Y') (DO)
 +
IF ((&RCDLN *GT    0) *AND (&RCDLN *LE 2048)) (CHGVAR &PRG 'DUSP ')
 +
IF ((&RCDLN *GT 2048) *AND (&RCDLN *LE 4048)) (CHGVAR &PRG 'DUSP1')
 +
IF ((&RCDLN *GT 4048) *AND (&RCDLN *LE 6080)) (CHGVAR &PRG 'DUSP2')
 +
          ENDDO
 +
IF (&UPD *NE 'Y') (DO)
 +
IF ((&RCDLN *GT    0) *AND (&RCDLN *LE 2048)) (CHGVAR &PRG 'DISP ')
 +
IF ((&RCDLN *GT 2048) *AND (&RCDLN *LE 4048)) (CHGVAR &PRG 'DISP1')
 +
IF ((&RCDLN *GT 4048) *AND (&RCDLN *LE 6080)) (CHGVAR &PRG 'DISP2')
 +
          ENDDO
 +
 
 +
 
 +
CALL  &PRG  (&ALL &RTN &KEYL &UPD &SCNLV  &SCNLVL &SCNKEY)
 +
 
 +
IF (&QRY )  (DO)
 +
  IF (&ACCP *EQ 'K') DO
 +
  CLOF    INPUTK
 +
  MONMSG CPF0000
 +
                  ENDDO
 +
  IF (&ACCP *EQ 'A') DO
 +
  CLOF    INPUTR
 +
  MONMSG CPF0000
 +
                  ENDDO
 +
ENDDO
 +
 
 +
IF (&RTN *EQ '3') DO
 +
  GOTO BYQRYA
 +
  ENDDO
 +
 
 +
IF (&RTN *EQ '1') DO
 +
  CHGVAR &RTN '0'
 +
  GOTO RTN
 +
  ENDDO
 +
 
 +
 
 +
 
 +
END:  ENDPGM
 +
 
 +
</pre>
 +
 
 +
[[#top]]
 +
 
 +
===DIS3    CL ===
 +
 
 +
<pre>
 +
 
 +
/* CALL BY DIS TO SHOW FILE RELATIONS / ACCESS PATHS */
 +
 
 +
PGM  (&PHY &PHYLIB &SFILE &SLIB)
 +
 
 +
/* DISPLAY ACCESS PATHS */
 +
 
 +
DCL &PHY    *CHAR  10
 +
DCL &PHYLIB *CHAR  10
 +
DCL &SFILE  *CHAR  10
 +
DCL &SLIB  *CHAR  10
 +
 
 +
 
 +
DCLF QTEMP/DBR
 +
 
 +
/* CREATE WORK FILES */
 +
CALL  DIS4
 +
 
 +
DLTF QTEMP/DBR
 +
MONMSG CPF0000
 +
 
 +
DSPDBR    FILE(&PHYLIB/&PHY) OUTPUT(*OUTFILE) +
 +
  OUTFILE(QTEMP/DBR) OUTMBR(*FIRST *REPLACE)
 +
CHGPF QTEMP/DBR LVLCHK(*NO)
 +
 
 +
NEXT: RCVF
 +
MONMSG CPF0000 EXEC(GOTO END)
 +
IF (&WHREFI *NE ' ') DO
 +
DSPFD      FILE(&WHRELI/&WHREFI) TYPE(*ACCPTH) +
 +
        OUTPUT(*OUTFILE) OUTFILE(QTEMP/REL) OUTMBR(*FIRST *ADD)
 +
CHGPF QTEMP/REL LVLCHK(*NO)
 +
DSPFD      FILE(&WHRELI/&WHREFI) TYPE(*SELECT) +
 +
        OUTPUT(*OUTFILE) OUTFILE(QTEMP/SEL) OUTMBR(*FIRST *ADD)
 +
CHGPF QTEMP/SEL LVLCHK(*NO)
 +
        ENDDO
 +
GOTO NEXT
 +
 
 +
END:
 +
DSPFD      FILE(&PHYLIB/&PHY  ) TYPE(*ACCPTH) +
 +
        OUTPUT(*OUTFILE) OUTFILE(QTEMP/REL) OUTMBR(*FIRST *ADD)
 +
CHGPF QTEMP/REL LVLCHK(*NO)
 +
 
 +
CHGVAR &SFILE '          '
 +
CHGVAR &SLIB  '          '
 +
 
 +
OVRDBF SEL QTEMP/SEL
 +
OVRDBF REL QTEMP/REL
 +
CALL  DISPR (&SFILE &SLIB)
 +
DLTOVR *ALL
 +
 
 +
ENDPGM
 +
 
 +
</pre>
 +
 
 +
[[#top]]
 +
 
 +
===DIS4    CL ===
 +
 
 +
<pre>
 +
 
 +
/* CALL BY DIS3 TO CREATE WORK FILES */
 +
 
 +
PGM
 +
 
 +
DCL  &LIB *CHAR 10
 +
DCL  &SRCF *CHAR 10
 +
 
 +
RTVDTAARA DTAARA(UDDSSRC *ALL)  RTNVAR(&SRCF)
 +
 
 +
DLTF  QTEMP/XXXXFILE
 +
monmsg cpf0000
 +
CRTPF      FILE(QTEMP/XXXXFILE) RCDLEN(80) OPTION(*NOLIST)
 +
 
 +
DSPFFD  FILE(QTEMP/XXXXFILE) OUTPUT(*OUTFILE) OUTFILE(QTEMP/FFD)
 +
CLRPFM  QTEMP/FFD
 +
DLTF  FILE(QTEMP/FFDL01)
 +
MONMSG CPF0000
 +
 
 +
RTVMBRD FILE(&SRCF) RTNLIB(&LIB)
 +
CRTLF FILE(QTEMP/FFDL01) SRCFILE(&LIB/&SRCF) SRCMBR(FFDL01) +
 +
OPTION(*NOSRC *NOLIST)
 +
 
 +
DLTF  FILE(QTEMP/REL)
 +
MONMSG CPF0000
 +
DLTF  FILE(QTEMP/SEL)
 +
MONMSG CPF0000
 +
DLTF  FILE(QTEMP/DBR)
 +
MONMSG CPF0000
 +
 
 +
DSPFD      FILE(QTEMP/FFD) TYPE(*ACCPTH) +
 +
  OUTPUT(*OUTFILE) OUTFILE(QTEMP/REL) OUTMBR(*FIRST *ADD)
 +
 
 +
DSPFD FILE(QTEMP/FFDL01) TYPE(*SELECT) OUTPUT(*OUTFILE) OUTFILE(QTEMP/SEL)
 +
CLRPFM FILE(QTEMP/REL)
 +
CLRPFM FILE(QTEMP/SEL)
 +
 
 +
DLTF  QTEMP/XXXXFILE
 +
monmsg cpf0000
 +
 
 +
 
 +
ENDPGM
 +
 
 +
</pre>
 +
 
 +
[[#top]]
 +
 
 +
===DISBIN    CL ===
 +
 
 +
<pre>
 +
/* NUMERIC TO BINARY CONVERTER  */
 +
 
 +
 
 +
PGM (&NUM  &BIN2  &BIN4 &BINTYP  )
 +
 
 +
DCL  VAR(&NUM) TYPE(*DEC) LEN(15 0)
 +
DCL VAR(&BINTYP) TYPE(*CHAR) LEN(1)
 +
DCL VAR(&BIN2) TYPE(*CHAR) LEN(2)
 +
DCL VAR(&BIN4) TYPE(*CHAR) LEN(4)
 +
 
 +
IF (&BINTYP = '4') (CHGVAR %BIN(&BIN4) &NUM)
 +
IF (&BINTYP = '2') (CHGVAR %BIN(&BIN2) &NUM)
 +
ENDPGM
 +
 
 +
</pre>
 +
 
 +
[[#top]]
 +
 
 +
===DISF    CL ===
 +
 
 +
<pre>
 +
 
 +
/* CHECK FILE TYPE */
 +
 
 +
PGM (&DISF &TYPE &PHY &PHYLIB)
 +
 
 +
 
 +
DCL  &DISF  *CHAR 10
 +
DCL  &TYPE  *CHAR 1
 +
DCL  &PHY    *CHAR 10
 +
DCL  &PHYLIB *CHAR 10
 +
DCLF KF
 +
 
 +
            OVRDBF    FILE(KF) TOFILE(QTEMP/&DISF)
 +
            OPNDBF    FILE(KF) OPTION(*INP)
 +
            RCVF
 +
            CHGVAR &TYPE &APFTYP
 +
 
 +
            IF (&TYPE *EQ 'L') DO
 +
            CHGVAR &PHY &APBOF
 +
            CHGVAR &PHYLIB &APBOL
 +
            ENDDO
 +
 
 +
            CLOF      OPNID(KF)
 +
ENDPGM
 +
 
 +
</pre>
 +
 
 +
[[#top]]
 +
 
 +
 
 +
 
 +
===DISV    CL ===
 +
 
 +
<pre>
 +
/* VALIDITY CHECKER FOR DSPFL COMMAND */
 +
 
 +
 
 +
PGM (&FILIB  &MBR &UPD &RST &REL)
 +
 
 +
DCL &FILIB  *CHAR 20
 +
DCL &FILE *CHAR  10
 +
DCL &LIB  *CHAR  10
 +
DCL &MBR  *CHAR  10
 +
DCL &UPD  *CHAR  1
 +
DCL &RST  *CHAR  1
 +
DCL &REL  *CHAR  1
 +
DCL &OBJATR *CHAR 10
 +
DCL &AUT    *CHAR  8
 +
 
 +
DCL &MSGDTA *CHAR 40
 +
DCL &ERROR  *LGL
 +
 
 +
CHGVAR &FILE  &FILIB
 +
CHGVAR &LIB  (%SST(&FILIB 11 10))
 +
IF (&MBR *EQ '*FILE') (CHGVAR &MBR  &FILE  )
 +
 
 +
CHGVAR &AUT '*READ  '
 +
IF ((&UPD *EQ 'Y') *OR (&UPD *EQ 'y')) (CHGVAR &AUT '*CHANGE')
 +
 
 +
CHKOBJ  (&LIB/&FILE) OBJTYPE(*FILE) MBR(*NONE)  +
 +
  AUT( &AUT  )
 +
  MONMSG (CPF9899 CPF9801 CPF9802  CPF9820 CPF9830) EXEC(DO)
 +
/*  CHGVAR (&MSGDTA) VALUE('    '||&FILE||&LIB)                  */
 +
/*  SNDPGMMSG MSGID(USR0006) MSGF(*LIBL/QUSERMSG) MSGTYPE(*DIAG) +*/
 +
/*            MSGDTA(&MSGDTA)                                    */
 +
    SNDPGMMSG  MSG('Not authorised to the file.') +
 +
                          MSGTYPE(*DIAG)
 +
    CHGVAR (&ERROR) '1'
 +
  ENDDO
 +
  MONMSG (CPF9810) EXEC(DO)
 +
    CHGVAR (&MSGDTA) VALUE('    '||&LIB)
 +
/*  SNDPGMMSG MSGID(USR0008) MSGF(*LIBL/QUSERMSG) MSGTYPE(*DIAG)  +*/
 +
/*            MSGDTA(&MSGDTA)                                      */
 +
    SNDPGMMSG  MSG('Not authorised to the file.') +
 +
                          MSGTYPE(*DIAG)
 +
    CHGVAR (&ERROR) '1'
 +
  ENDDO
 +
 
 +
 
 +
IF (*NOT &ERROR) DO
 +
 
 +
RTVOBJD    OBJ(&LIB/&FILE) OBJTYPE(*FILE) OBJATR(&OBJATR)
 +
CHGVAR &AUT '*READ  '
 +
IF ((&UPD *EQ 'Y') *OR (&UPD *EQ 'y')) (CHGVAR &AUT '*CHANGE')
 +
 
 +
CHKOBJ    OBJ(&LIB/&FILE) OBJTYPE(*FILE) MBR(&MBR) +
 +
                          AUT(&AUT)
 +
 
 +
  MONMSG (CPF9815 )  EXEC(DO)
 +
/*  CHGVAR (&MSGDTA) VALUE('    '||&MBR||&FILE||&LIB)              */
 +
/*  SNDPGMMSG MSGID(USR0007) MSGF(*LIBL/QUSERMSG) MSGTYPE(*DIAG) + */
 +
/*            MSGDTA(&MSGDTA)                                      */
 +
            SNDPGMMSG  MSG('Not authorised to the file.') +
 +
                          MSGTYPE(*DIAG)
 +
    CHGVAR (&ERROR) '1'
 +
  ENDDO
 +
  MONMSG (CPF0000 )  EXEC(DO)
 +
/*  SNDPGMMSG MSGID(USR0022) MSGF(*LIBL/QUSERMSG) MSGTYPE(*DIAG) + */
 +
/*            MSGDTA(&MSGDTA)                                      */
 +
            SNDPGMMSG  MSG('Not authorised to the file.') +
 +
                          MSGTYPE(*DIAG)
 +
    CHGVAR (&ERROR) '1'
 +
  ENDDO
 +
ENDDO
 +
 
 +
IF (&ERROR)  (SNDPGMMSG MSGID(CPF0002) MSGF(QCPFMSG) MSGTYPE(*ESCAPE))
 +
 
 +
 
 +
 
 +
ENDPGM
 +
 
 +
</pre>
 +
 
 +
[[#top]]
 +
 
 +
 
 +
===DISPR  RPG ===
 +
 
 +
<pre>
 +
    H OPTIMIZE(*NONE) OPTION(*NODEBUGIO)
 +
    H DFTACTGRP(*NO) ACTGRP(*CALLER)
 +
 
 +
      *    FILE RELATIONS DISPLAYER
 +
      * REQUIRES FILES TO COMPILE
 +
      *
 +
 
 +
    FREL      IF  E            DISK
 +
    FSEL      IF  E            DISK
 +
    FDISPRF    CF  E            WORKSTN
 +
    F                                    SFILE(S01:RS01)
 +
    F                                    SFILE(S02:RS02)
 +
    F                                    INFDS(SFINF)
 +
      *
 +
 
 +
      *
 +
    DDISPR            PR
 +
    D                              10
 +
    D                              10
 +
    DDISPR            PI
 +
    D  SFILE                        10
 +
    D  SLIB                        10
 +
 
 +
      //  SCREEN LEVELS
 +
    D @SCN            S              6    DIM(50)
 +
    D @NSCN          S              6
 +
    D @LV            S              5  0
 +
    D @ERR            S                  LIKE(@TRUE)
 +
    D @FILE          S            10A  INZ('DISPY  ')
 +
    D WRKSWS          S              1
 +
    D I              S              4B 0
 +
 
 +
 
 +
    D @TRUE          S              1A  INZ('1')
 +
    D @FALSE          S              1A  INZ('0')
 +
    D @OK            S                  LIKE(@TRUE)
 +
    D @LOOP          S                  LIKE(@TRUE)
 +
 
 +
      //
 +
    D RS01            S              4S 0
 +
    D RS02            S              4S 0
 +
      //
 +
      // PARMS FOR SFL LOOPING
 +
    D SFC01          S                  LIKE(RS01)
 +
    D SFC02          S                  LIKE(RS01)
 +
 
 +
      // Program Status
 +
    D                SDS
 +
    D  PGM                    1    10
 +
    D  WSID                244    253
 +
    D  USER                254    263
 +
      //
 +
      //
 +
    D SFINF          DS
 +
    D  RRRN                376    377B 0
 +
    D  SRN                  378    379B 0
 +
 
 +
      //  MESSAGE DATA
 +
    D @DTA1          DS            80
 +
    D @DTA2          DS          500
 +
      //
 +
    D MAIN            PR
 +
 
 +
    D @S01BLD        PR
 +
    D @S01PRC        PR
 +
    D @S01PRS        PR
 +
    D @S02BLD        PR
 +
    D @S02PRC        PR
 +
    D
 +
    D @R9999          PR
 +
 
 +
    D @OPADJ          PR            2A
 +
    D  OPT                          2A
 +
 
 +
 
 +
      /FREE
 +
            *INLR = *ON;
 +
            MAIN();
 +
 
 +
 
 +
      //--------------*INZSR-------------------------------//
 +
          BEGSR  *INZSR;
 +
 
 +
        //  Set the TOP level (Exit if user backs up to here)
 +
              @LV = 1;
 +
              @SCN(@LV)  = '*END  ';
 +
        //  Set the Initial Screen to display
 +
              @LV = @LV + 1;
 +
              @SCN(@LV) = 'S01BLD ';
 +
 
 +
            ENDSR;
 +
      /END-FREE
 +
      //###################################################//
 +
 
 +
        //*************************************************************
 +
    P    MAIN        B
 +
 
 +
    D MAIN            PI
 +
 
 +
    D I              S              4B 0
 +
 
 +
      /FREE
 +
          EXSR      @INZSR;
 +
      //
 +
      // THIS IS THE CONTROLLING LOOP TO DRIVE THE NEXT PANEL TO DISPLAY
 +
          DOW      @LOOP = @LOOP;
 +
      // GET THE SCREEN NAME FROM THE SCREEN STACK ARRAY
 +
            @NSCN  = @SCN(@LV);
 +
          SELECT;
 +
        //  SELECT FIELDS FOR DISPLAY
 +
 
 +
        // SFL TO SELECT THE FILE FIELDS
 +
          WHEN      @NSCN = 'S01BLD';
 +
                            @S01BLD();
 +
          WHEN      @NSCN = 'S01PRC';
 +
                            @S01PRC();
 +
          WHEN      @NSCN = 'S01PRS';
 +
                            @S01PRS();
 +
          WHEN      @NSCN = 'S02BLD';
 +
                            @S02BLD();
 +
          WHEN      @NSCN = 'S02PRC';
 +
                            @S02PRC();
 +
          OTHER;
 +
            //  CATCH ALL (NEVER USED)
 +
              @R9999();
 +
              LEAVE;
 +
          ENDSL;
 +
 
 +
        //  CF3 EXIT
 +
          IF  *IN03 = *ON;
 +
            LEAVE;
 +
          ENDIF;
 +
 
 +
      //  CF12 PREVIOUS
 +
          IF  *IN12 = *ON;
 +
              *IN12 = *OFF;
 +
              @LV  = @LV -1;
 +
              @NSCN = @SCN(@LV);
 +
          ENDIF;
 +
 
 +
      //  Backed out to last level, Exit
 +
          IF    @NSCN = '*END';
 +
                  LEAVE;
 +
          ENDIF;
 +
 
 +
        ENDDO;
 +
 
 +
        RETURN;
 +
 
 +
      //--------------*INZSR-------------------------------//
 +
          BEGSR  @INZSR;
 +
              @NSCN = *BLANK;
 +
 
 +
          ENDSR;
 +
      //-ENDSR---*INZSR-------------------------------//
 +
      /END-FREE
 +
 
 +
    P    MAIN        E
 +
 
 +
 
 +
      //###################################################//
 +
      //###################################################//
 +
      //###################################################//
 +
      /space 3
 +
    P @S01BLD        B
 +
 
 +
    D @S01BLD        PI
 +
 
 +
    D WFILE          S                  LIKE(APFILE )
 +
    D WLIB            S                  LIKE(APLIB  )
 +
 
 +
          //  Build/Rebuild the subfile
 +
 
 +
      /FREE
 +
          EXSR      @INZSR;
 +
 
 +
          EXSR      BLD;
 +
 
 +
        //  SFL IS BUILT, PROCESS THE SFL CONTROL
 +
          @LV = @LV + 1;
 +
          @SCN(@LV) = 'S01PRC ' ;
 +
            RETURN ;
 +
 
 +
      //--------------  BLD -------------------------------//
 +
          BEGSR    BLD;
 +
 
 +
            EXSR      CLR;
 +
 
 +
 
 +
          SETLL 1    QWHFDACP;
 +
 
 +
          DOW @LOOP = @LOOP;
 +
          READ      QWHFDACP;
 +
          IF %EOF;
 +
          LEAVE;
 +
          ENDIF;
 +
 
 +
 
 +
          EXSR MOV;
 +
          //
 +
          RS01  = RS01 + 1;
 +
          WRITE S01;
 +
        ENDDO;
 +
 
 +
 
 +
        // Position to TOP of subfile
 +
            SRS01 = 1;
 +
            SFC01 = RS01;
 +
          ENDSR;
 +
 
 +
      //--------------  CLR -------------------------------//
 +
          BEGSR  CLR;
 +
 
 +
              *IN51 = *OFF;
 +
              *IN52 = *OFF;
 +
              *IN53 = *ON;
 +
              WRITE    C01;
 +
              *IN53 = *OFF;
 +
              RS01  = 0  ;
 +
              SFC01 = 0  ;
 +
              S01FUNC = *BLANK;
 +
              ENDSR;
 +
 
 +
      //--------------  MOV -------------------------------//
 +
          BEGSR  MOV;
 +
 
 +
            C01APBOF =  APBOF ;
 +
            C01APBOL =  APBOL ;
 +
 
 +
          IF APBOF = *BLANK AND APBOL =  *BLANK;
 +
          C01APBOF = APFILE;
 +
          C01APBOL = APLIB;
 +
          ENDIF;
 +
 
 +
        //  Load the subfile record
 +
 
 +
          IF APFILE = WFILE  AND
 +
            APLIB  = WLIB ;
 +
            *IN56 = *ON ;
 +
                  S01APFILE  =  *BLANK;
 +
                  S01APLIB  =  *BLANK;
 +
                  S01APACCP  =  *BLANK;
 +
                  S01APUNIQ  =  *BLANK;
 +
                  S01APSELO  =  *BLANK;
 +
                  S01APFTYP  =  *BLANK;
 +
                  S01APJOIN  =  *BLANK;
 +
                  S01APKEYO  =  *BLANK;
 +
                  S01APKSEQ  =  APKSEQ ;
 +
                  S01APKSIN  =  APKSIN ;
 +
                  S01APKEYF  =  APKEYF ;
 +
            ELSE      ;
 +
            WFILE = APFILE;
 +
            WLIB  = APLIB ;
 +
            *IN56 = *OFF;
 +
                  S01APFILE  =  APFILE ;
 +
                  S01APLIB  =  APLIB  ;
 +
                  S01APACCP  =  APACCP ;
 +
                  S01APUNIQ  =  APUNIQ ;
 +
                  S01APSELO  =  APSELO ;
 +
                  S01APFTYP  =  APFTYP ;
 +
                  S01APJOIN  =  APJOIN ;
 +
                  S01APKEYO  =  APKEYO ;
 +
                  S01APKSEQ  =  APKSEQ ;
 +
                  S01APKSIN  =  APKSIN ;
 +
                  S01APKEYF  =  APKEYF ;
 +
          ENDIF;
 +
 
 +
          ENDSR;
 +
 
 +
      //--------------*INZSR-------------------------------//
 +
          BEGSR    @INZSR;
 +
              @NSCN = *BLANK;
 +
          ENDSR;
 +
      /END-FREE
 +
 
 +
    P @S01BLD        E
 +
 
 +
      //###################################################//
 +
      //###################################################//
 +
 
 +
      /space 3
 +
    P @S01PRC        B
 +
 
 +
    D @S01PRC        PI
 +
 
 +
          //
 +
          //
 +
    D WRKRC          S              4S 0
 +
 
 +
      /FREE
 +
          EXSR      @INZSR;
 +
 
 +
            WRITE    R01;
 +
      //
 +
            DOW      @LOOP = @LOOP;
 +
 
 +
          //
 +
          // Write SFL Control
 +
            IF        SFC01 > 0;
 +
                *IN51 = *ON;
 +
            ENDIF;
 +
              *IN52 = *ON;
 +
 
 +
 
 +
              EXFMT    C01;
 +
          //  Setoff errors
 +
                *IN89 = *OFF;
 +
          //
 +
          //  Exit and Previous Screen
 +
            IF        *IN03 = *ON;
 +
                LEAVE;
 +
            ENDIF;
 +
            IF        *IN12 = *ON;
 +
                LEAVE;
 +
            ENDIF;
 +
 
 +
 
 +
        //  Process the subfile
 +
              @LV = @LV + 1;
 +
              @SCN(@LV) = 'S01PRS';
 +
              LEAVE;
 +
 
 +
            ENDDO;
 +
      //
 +
            RETURN;
 +
 
 +
      /space 3
 +
 
 +
 
 +
      //--------------*INZSR-------------------------------//
 +
          BEGSR    @INZSR;
 +
              @NSCN = *BLANK;
 +
          ENDSR;
 +
      /END-FREE
 +
    P @S01PRC        E
 +
 
 +
      //###################################################//
 +
      //###################################################//
 +
      //###################################################//
 +
      /space 3
 +
    P @S01PRS        B
 +
 
 +
    D @S01PRS        PI
 +
 
 +
          //
 +
          //
 +
    D WRKRC          S              4S 0
 +
 
 +
      /FREE
 +
 
 +
          EXSR      @INZSR;
 +
 
 +
        //  Process the subfile
 +
          EXSR      SFL;
 +
          RETURN;
 +
 
 +
      //--------------  SFL -------------------------------//
 +
          BEGSR      SFL;
 +
        //  Process the subfile
 +
 
 +
          FOR      WRKRC = 1 TO SFC01 + 1 ;
 +
              CHAIN  WRKRC  S01;
 +
                IF        NOT %FOUND;
 +
        //  Finished with the subfile
 +
                    @LV = @LV -1;
 +
                    LEAVE;
 +
                ENDIF;
 +
 
 +
        //  GET SELECTED FILE
 +
            IF  @OPADJ(S01FUNC) =  ' X';
 +
              SFILE  = S01APFILE;
 +
              SLIB  = S01APLIB ;
 +
              *IN03 = '1';
 +
                LEAVE;
 +
            ENDIF;
 +
 
 +
 
 +
        //  SHOW SELECT RULES
 +
            IF  @OPADJ(S01FUNC) =  ' R';
 +
              @LV = @LV + 1;
 +
              @SCN(@LV) = 'S02BLD ';
 +
                S01FUNC =  '  ';
 +
                UPDATE    S01;
 +
              LEAVE;
 +
            ENDIF;
 +
 
 +
          ENDFOR;
 +
 
 +
          ENDSR;
 +
      //---------------------------------------------------//
 +
 
 +
 
 +
 
 +
      //--------------*INZSR-------------------------------//
 +
          BEGSR    @INZSR;
 +
              @NSCN = *BLANK;
 +
          ENDSR;
 +
 
 +
 
 +
      /END-FREE
 +
    P @S01PRS        E
 +
 
 +
 
 +
      /space 3
 +
    P @S02BLD        B
 +
 
 +
    D @S02BLD        PI
 +
 
 +
          //  Build/Rebuild the subfile
 +
      /FREE
 +
 
 +
          EXSR @INZSR;
 +
 
 +
          C02APFILE  =  S01APFILE ;
 +
          C02APLIB  =  S01APLIB  ;
 +
 
 +
        EXSR BLD;
 +
 
 +
        //  SFL IS BUILT, PROCESS THE CONTROL
 +
          @LV = @LV + 1;
 +
          @SCN(@LV) = 'S02PRC ';
 +
      RETURN;
 +
      //--------------  BLD -------------------------------//
 +
      BEGSR  BLD;
 +
 
 +
        EXSR CLR;
 +
 
 +
 
 +
          SETLL 1    QWHFDSO ;
 +
 
 +
          DOW @LOOP = @LOOP;
 +
 
 +
          READ      QWHFDSO ;
 +
          IF %EOF;
 +
          LEAVE;
 +
          ENDIF;
 +
 
 +
          If SOFILE = S01APFILE  AND
 +
            SOLIB  = S01APLIB ;
 +
          EXSR MOV;
 +
 
 +
          //
 +
          RS02  = RS02 + 1;
 +
          WRITE S02;
 +
          ENDIF;
 +
        ENDDO;
 +
 
 +
        // Position to TOP of subfile
 +
        SRS02 = 1;
 +
        SFC02 = RS02;
 +
        ENDSR;
 +
 
 +
      //--------------  CLR -------------------------------//
 +
        BEGSR  CLR;
 +
          *IN51 = *OFF;
 +
          *IN52 = *OFF;
 +
          *IN53 = *ON;
 +
          WRITE C02;
 +
          *IN53 = *OFF;
 +
          RS02 =0;
 +
          SFC02=0;
 +
 
 +
        ENDSR;
 +
 
 +
      //--------------  MOV -------------------------------//
 +
        BEGSR  MOV;
 +
        //  Load the subfile record
 +
 
 +
          S02SOFLD  = SOFLD  ;
 +
          S02SORULE = SORULE ;
 +
          S02SOCOMP = SOCOMP ;
 +
          S02SOVALU = SOVALU ;
 +
 
 +
 
 +
 
 +
        ENDSR;
 +
 
 +
      //--------------*INZSR-------------------------------//
 +
        BEGSR  @INZSR;
 +
          @NSCN = *BLANK;
 +
        ENDSR;
 +
 
 +
      /END-FREE
 +
    P @S02BLD        E
 +
 
 +
      //###################################################//
 +
      //###################################################//
 +
      //###################################################//
 +
      /space 3
 +
    P @S02PRC        B
 +
 
 +
    D @S02PRC        PI
 +
 
 +
          //
 +
          //
 +
    D WRKRC          S              4S 0
 +
 
 +
      /FREE
 +
 
 +
          EXSR @INZSR;
 +
 
 +
        WRITE R02;
 +
 
 +
      //
 +
      DOW @LOOP = @LOOP;
 +
 
 +
          //
 +
          // Write SFL Control
 +
          IF SFC02 > 0;
 +
            *IN51 = *ON;
 +
          ENDIF;
 +
          *IN52 = *ON;
 +
          EXFMT C02;
 +
          //
 +
          //  Setoff errors
 +
          *IN89 = *OFF;
 +
          //
 +
          //  Exit and Previous Screen
 +
 
 +
          @LV = @LV -2;
 +
            LEAVE;
 +
 
 +
 
 +
        //  Process the subfile
 +
 
 +
      ENDDO;
 +
      //
 +
      RETURN;
 +
 
 +
      /space 3
 +
      //--------------*INZSR-------------------------------//
 +
        BEGSR  @INZSR;
 +
 
 +
          @NSCN = *BLANK;
 +
        ENDSR;
 +
      /END-FREE
 +
    P @S02PRC        E
 +
 
 +
 
 +
      //###################################################//
 +
      //###################################################//
 +
      //###################################################//
 +
 
 +
    P @R9999          B
 +
        //  Invalid Panel
 +
    D @R9999          PI
 +
 
 +
    P @R9999          E
 +
 
 +
 
 +
      /space 3
 +
      //###################################################//
 +
      //###################################################//
 +
      //###################################################//
 +
    P @OPADJ          B
 +
        //  RIGHT ADJ OPTION , zero suppress
 +
 
 +
    D @OPADJ          PI            2A
 +
    D  OPT                          2A
 +
 
 +
      /FREE
 +
        EVALR  OPT  = %trimr(OPT);
 +
        If %SubSt(OPT:1:1) =  '0';
 +
        OPT  = ' ' +  %SubSt(OPT:2:1);
 +
        EndIf;
 +
        RETURN OPT;
 +
      /END-FREE
 +
    P @OPADJ          E
 +
 
 +
      //###################################################//
 +
      //###################################################//
 +
 
 +
</pre>
 +
 
 +
[[#top]]
 +
 
 +
===DISPRF  DSPF  ===
 +
 
 +
<pre>
 +
 
 +
    A*%%TS  SD  20101208  163705  KOLMANNF    REL-V5R4M0  5722-WDS
 +
    A*
 +
      * REQUIRES FILES TO COMPILE
 +
      *  CRTDUPOBJ  OBJ(QAFDSELO) FROMLIB(QSYS)
 +
      *              OBJTYPE(*FILE) TOLIB(QTEMP) NEWOBJ(SEL)
 +
      *  CRTDUPOBJ  OBJ(QAFDACCP) FROMLIB(QSYS)
 +
      *        OBJTYPE(*FILE) TOLIB(QTEMP) NEWOBJ(ACC)
 +
 
 +
 
 +
    A*%%EC
 +
    A                                      DSPSIZ(24 80 *DS3)
 +
    A                                      PRINT
 +
    A                                      CF03(03)
 +
    A                                      CF12(12)
 +
    A          R S01                      SFL
 +
    A*%%TS  SD  20101208  163705  KOLMANNF    REL-V5R4M0  5722-WDS
 +
    A            S01FUNC        2A  I  4  3
 +
    A  55
 +
    AO 56                                  DSPATR(PR)
 +
    A            S01APFILE R        O  4  6REFFLD(QWHFDACP/APFILE QTEMP/REL)
 +
    A            S01APLIB  R        O  4 17REFFLD(QWHFDACP/APLIB QTEMP/REL)
 +
    A            S01APACCP R        O  4 29REFFLD(QWHFDACP/APACCP QTEMP/REL)
 +
    A            S01APUNIQ R        O  4 33REFFLD(QWHFDACP/APUNIQ QTEMP/REL)
 +
    A            S01APSELO R        O  4 37REFFLD(QWHFDACP/APSELO QTEMP/REL)
 +
    A            S01APFTYP R        O  4 41REFFLD(QWHFDACP/APFTYP QTEMP/REL)
 +
    A            S01APJOIN R        O  4 45REFFLD(QWHFDACP/APJOIN QTEMP/REL)
 +
    A            S01APKEYO R        O  4 48REFFLD(QWHFDACP/APKEYO QTEMP/REL)
 +
    A            S01APKSEQ R        O  4 53REFFLD(QWHFDACP/APKSEQ QTEMP/REL)
 +
    A            S01APKSIN R        O  4 57REFFLD(QWHFDACP/APKSIN QTEMP/REL)
 +
    A            S01APKEYF R        O  4 61REFFLD(QWHFDACP/APKEYF QTEMP/REL)
 +
    A          R C01                      SFLCTL(S01)
 +
    A*%%TS  SD  20101208  163705  KOLMANNF    REL-V5R4M0  5722-WDS
 +
    A                                      SFLSIZ(0019)
 +
    A                                      SFLPAG(0018)
 +
    A                                      OVERLAY
 +
    A  50                                  SFLEND
 +
    A  51                                  SFLDSP
 +
    A  52                                  SFLDSPCTL
 +
    A  53                                  SFLCLR
 +
    A            SRS01          4S 0H      SFLRCDNBR(CURSOR)
 +
    A*
 +
    A                                  1 18'FILE RELATIONS for '
 +
    A            C01APBOF  R        O  1 39REFFLD(QWHFDACP/APBOF QTEMP/REL)
 +
    A                                  1 51'Lib.'
 +
    A            C01APBOL  R        O  1 56REFFLD(QWHFDACP/APBOL QTEMP/REL)
 +
    A                                  2 32'Uni SEL        LIFO ASC Key'
 +
    A                                  3  6'File      Library    Acc Key OMT -
 +
    A                                      TYP  J  FIFO DSC Sgn Key'
 +
    A          R R01
 +
    A                                24  3'F3-Exit'
 +
    A                                22  3'R - Display Select/Omit rules'
 +
    A                                23  3'X - Select for display'
 +
      *
 +
    A          R R02
 +
    A                                24  3'F3-Exit'
 +
    A          R S02                      SFL
 +
    A                                      SFLNXTCHG
 +
    A            S02SOFLD  R        O  4  4REFFLD(QWHFDSO/SOFLD QTEMP/SEL)
 +
    A            S02SORULE R        O  4 17REFFLD(QWHFDSO/SORULE QTEMP/SEL)
 +
    A            S02SOCOMP R        O  4 22REFFLD(QWHFDSO/SOCOMP QTEMP/SEL)
 +
    A            S02SOVALU R        O  4 28REFFLD(QWHFDSO/SOVALU QTEMP/SEL)
 +
 
 +
    A          R C02                      SFLCTL(S02 )
 +
    A                                      OVERLAY
 +
    A  50                                  SFLEND
 +
    A  51                                  SFLDSP
 +
    A  52                                  SFLDSPCTL
 +
    A  53                                  SFLCLR
 +
    A                                      SFLSIZ(0019)
 +
    A                                      SFLPAG(0018)
 +
    A            SRS02          4S 0H      SFLRCDNBR(CURSOR)
 +
    A*
 +
    A                                  1  6'FILE SELECTS  for '
 +
    A            C02APFILE R        O  2  7REFFLD(QWHFDSO/SOFILE QTEMP/SEL)
 +
    A                                  2 20'Lib.'
 +
    A            C02APLIB  R        O  2 25REFFLD(QWHFDSO/SOLIB QTEMP/SEL)
 +
    A                                  3  4'Field'
 +
    A                                  3 28'Select/Omit Value'
 +
    A                                  3 16'S/O'
 +
    A                                  3 21'COMP'
 +
 
 +
</pre>
 +
 
 +
[[#top]]
 +
 
 +
 
 +
===DISPY  RPG ===
 +
 
 +
<pre>
 +
    H OPTIMIZE(*NONE) OPTION(*NODEBUGIO)
 +
    H DFTACTGRP(*NO) ACTGRP(*CALLER)
 +
 
 +
      //***************************************************************
 +
      //
 +
      //  PROGRAM ID : DISPY
 +
      //  Description: DISPLAY A FILES FIELDS FOR SELECTION
 +
 
 +
      //    needs files KF  FFD to compile use following commands
 +
      // DSPFD (&LIB/&FILE) TYPE(*ACCPTH) OUTPUT(*OUTFILE) OUTFILE(QTEMP/KF)
 +
      // DSPFFD  FILE(&LIB/&FILE) OUTPUT(*OUTFILE) OUTFILE(QTEMP/FFD)
 +
      //***************************************************************
 +
      // MODIFICATIONS:
 +
      // MOD  SR  DATE    MODIFICATION SUMMARY
 +
      //
 +
      //***************************************************************
 +
      //
 +
    FKF        IF  E            DISK
 +
    FFFD      UF  E            DISK
 +
    FINPUT    IF  F32766  2000AIDISK    KEYLOC(1)
 +
    F                                    INFDS(INFDS)
 +
    FDISPYF    CF  E            WORKSTN
 +
    F                                    SFILE(S01:RS01)
 +
    F                                    INFDS(SFINF)
 +
      //
 +
      //
 +
 
 +
      //  SCREEN LEVELS
 +
    D @SCN            S              6    DIM(50)
 +
    D @NSCN          S              6
 +
    D @LV            S              5  0
 +
    D @ERR            S                  LIKE(@TRUE)
 +
    D @FILE          S            10A  INZ('DISPY  ')
 +
    D WRKSWS          S              1
 +
    D I              S              4B 0
 +
 
 +
 
 +
    D @TRUE          S              1A  INZ('1')
 +
    D @FALSE          S              1A  INZ('0')
 +
    D @OK            S                  LIKE(@TRUE)
 +
    D @LOOP          S                  LIKE(@TRUE)
 +
 
 +
      //
 +
    D RS01            S              4S 0
 +
      //
 +
      // PARMS FOR SFL LOOPING
 +
    D SFC01          S                  LIKE(RS01)
 +
 
 +
      // Program Status
 +
    D                SDS
 +
    D  PGM                    1    10
 +
    D  WSID                244    253
 +
    D  USER                254    263
 +
      //
 +
      //
 +
    D SFINF          DS
 +
    D  RRRN                376    377B 0
 +
    D  SRN                  378    379B 0
 +
 
 +
      //
 +
    D FLD            S            10    DIM(9000)
 +
    D KEY            S            10    DIM(99)
 +
 
 +
    D INFDS          DS
 +
    D  FILE                  83    92
 +
    D  LIB                  93    102
 +
    D  MBR                  129    138
 +
    D  RCDL                125    126B 0
 +
    D  RCDS                156    159B 0
 +
    D  ACCTP                160    160
 +
 
 +
    D                DS
 +
    D  WHCOLD                1    60
 +
    D  WHCHD1                1    20
 +
    D  WHCHD2                21    40
 +
    D  WHCHD3                41    60
 +
 
 +
    D                DS
 +
    D  POSN                  1    10
 +
    D  P1                    1    10    DIM(10)
 +
 
 +
    D  POSNN                11    20
 +
    D  P2                    11    20    DIM(10)
 +
 
 +
 
 +
      *
 +
      //  MESSAGE DATA
 +
    D @DTA1          DS            80
 +
    D @DTA2          DS          500
 +
      //
 +
    D MAIN            PR
 +
 
 +
    D @S01BLD        PR
 +
    D @S01PRC        PR
 +
    D @S01PRS        PR
 +
    D
 +
    D @R9999          PR
 +
 
 +
    D @OPADJ          PR            2A
 +
    D  OPT                          2A
 +
 
 +
      *
 +
    DDISPY            PR
 +
    D                                1
 +
    D                                1
 +
    D                                4
 +
    D                                1
 +
    D                                1
 +
    D                                5
 +
    DDISPY            PI
 +
    D  ALL                          1
 +
    D  RTN                          1
 +
    D  KEYLNG                        4
 +
    D  ACCP                          1
 +
    D  QRY                          1
 +
    D  RCDLN                        5
 +
      *
 +
    D KEYLN          S              4S 0
 +
    D RCDLEN          S              5S 0
 +
      *-------------------------------------------------------------------
 +
      * QMHRTVM API (Retrieve Message text)
 +
      *-------------------------------------------------------------------
 +
    D  RtvMsgTxt      PR          1024
 +
    D  RMsgId                      7    Const
 +
    D  RMsgFle                    10    Const
 +
    D  RMsgLib                    10    Const
 +
    D  RMsgLvl                      1    Const
 +
 
 +
    D GETROWCOL      PR
 +
    D                              10A  const
 +
    D                              10A  const
 +
    D                              10A  const
 +
    D                              32A  const
 +
    D                                3P 0
 +
    D                                3P 0
 +
 
 +
    D SysDate        PR            8S 0
 +
    D SysTime        PR            6S 0
 +
    D DayOfWeek      PR            10I 0
 +
    D                                D  value datfmt(*iso)
 +
      // Message file names
 +
    D  cMsgLib        C                  Const('*LIBL    ')
 +
    D  cMsgF1        C                  Const('MSGF1    ')
 +
    D  cMsgF2        C                  Const('MSGF2    ')
 +
    D  cMsgLvl1      C                  Const('1')
 +
    D  cMsgLvl2      C                  Const('2')
 +
 
 +
      *
 +
    IINPUT    NS  01
 +
    I                                  1  256  D
 +
 
 +
      /FREE
 +
            *INLR = *ON;
 +
            MAIN();
 +
 
 +
 
 +
      //--------------*INZSR-------------------------------//
 +
          BEGSR  *INZSR;
 +
 
 +
        //  Set the TOP level (Exit if user backs up to here)
 +
              @LV = 1;
 +
              @SCN(@LV)  = '*END  ';
 +
        //  Set the Initial Screen to display
 +
              @LV = @LV + 1;
 +
              @SCN(@LV) = 'S01BLD ';
 +
 
 +
      //    DUMMY I/O TO GET NUMBER OF RECORDS IN FILE
 +
            READ      INPUT;
 +
      //  SFL IS NOT LOADED
 +
      //  READ THE LIST OF KEY FIELDS IN THE FILE SO THAT WE CAN LATER MARK THEM
 +
                  ACCP    = ACCTP;
 +
 
 +
              I    =  0;
 +
 
 +
              DOW  @LOOP = @LOOP;
 +
                READ      QWHFDACP;
 +
                IF  %EOF;
 +
                LEAVE;
 +
                ENDIF;
 +
                I = I + 1;
 +
                KEY(I) = APKEYF;
 +
              ENDDO;
 +
            ENDSR;
 +
      /END-FREE
 +
      //###################################################//
 +
 
 +
        //*************************************************************
 +
    P    MAIN        B
 +
 
 +
    D MAIN            PI
 +
 
 +
    D I              S              4B 0
 +
 
 +
      /FREE
 +
          EXSR      @INZSR;
 +
      //
 +
      // THIS IS THE CONTROLLING LOOP TO DRIVE THE NEXT PANEL TO DISPLAY
 +
          DOW      @LOOP = @LOOP;
 +
      // GET THE SCREEN NAME FROM THE SCREEN STACK ARRAY
 +
            @NSCN  = @SCN(@LV);
 +
          SELECT;
 +
        //  SELECT FIELDS FOR DISPLAY
 +
 
 +
        // SFL TO SELECT THE FILE FIELDS
 +
          WHEN      @NSCN = 'S01BLD';
 +
              @S01BLD();
 +
          WHEN      @NSCN = 'S01PRC';
 +
              @S01PRC();
 +
          WHEN      @NSCN = 'S01PRS';
 +
              @S01PRS();
 +
          OTHER;
 +
            //  CATCH ALL (NEVER USED)
 +
              @R9999();
 +
              LEAVE;
 +
          ENDSL;
 +
 
 +
        //  CF3 EXIT
 +
          IF  *IN03 = *ON;
 +
            LEAVE;
 +
          ENDIF;
 +
 
 +
      //  CF12 PREVIOUS
 +
          IF  *IN12 = *ON;
 +
              *IN12 = *OFF;
 +
              @LV  = @LV -1;
 +
              @NSCN    = @SCN(@LV);
 +
          ENDIF;
 +
 
 +
      //  Backed out to last level, Exit
 +
          IF    @NSCN = '*END';
 +
                  LEAVE;
 +
          ENDIF;
 +
 
 +
        ENDDO;
 +
 
 +
        KEYLNG  = %EDITC(KEYLN:'X');
 +
        RETURN;
 +
 
 +
      //--------------*INZSR-------------------------------//
 +
          BEGSR  @INZSR;
 +
              @NSCN = *BLANK;
 +
              RCDLEN = RCDL;
 +
              RCDLN = %CHAR(RCDLEN);
 +
 
 +
      // CLEAR FIELD SELECTIONS
 +
              IF  RTN  =  '2';
 +
                SETLL 1    QWHDRFFD;
 +
              DOW  @LOOP = @LOOP;
 +
                READ      QWHDRFFD ;
 +
                IF  %EOF;
 +
                LEAVE;
 +
                ENDIF;
 +
                  WHFIOB = ' ';
 +
                  UPDATE    QWHDRFFD;
 +
              ENDDO;
 +
 
 +
      // SET FILE I/O TO FIRST RCD IN FILE
 +
                SETLL 1    QWHDRFFD;
 +
                  RTN = '0';
 +
              ELSE;
 +
                CHAIN  1  QWHDRFFD;
 +
                SETLL  1  QWHDRFFD;
 +
              ENDIF;
 +
          ENDSR;
 +
      //-ENDSR---*INZSR-------------------------------//
 +
      /END-FREE
 +
 
 +
    P    MAIN        E
 +
 
 +
 
 +
      //###################################################//
 +
      //###################################################//
 +
      //###################################################//
 +
      /space 3
 +
    P @S01BLD        B
 +
 
 +
    D @S01BLD        PI
 +
 
 +
    D  SZ            DS            6
 +
    D  LEN1                  1      1
 +
    D  LEN2                  2      3
 +
    D  LEN3                  1      3
 +
    D  COMA                  4      4
 +
    D  DEC1                  5      5
 +
    D  DEC2                  5      6
 +
 
 +
    D                DS
 +
    D K                      1      3  0
 +
    D KA                      2      3
 +
 
 +
          //  Build/Rebuild the subfile
 +
 
 +
      /FREE
 +
          EXSR      @INZSR;
 +
 
 +
          EXSR      BLD;
 +
 
 +
        //  SFL IS BUILT, PROCESS THE SFL CONTROL
 +
          @LV = @LV + 1;
 +
          @SCN(@LV) = 'S01PRC ' ;
 +
            RETURN ;
 +
      //--------------  BLD -------------------------------//
 +
          BEGSR    BLD;
 +
 
 +
            EXSR      CLR;
 +
 
 +
          DOW      @LOOP = @LOOP;
 +
 
 +
            READ      QWHDRFFD;
 +
                IF  %EOF;
 +
                LEAVE;
 +
                ENDIF;
 +
            EXSR      MOV;
 +
 
 +
      // FLAG THE KEY FIELDS
 +
                  K = %LOOKUP(WHFLDE :KEY);
 +
                    WHDFTL  = K ;
 +
                    UPDATE    QWHDRFFD;
 +
 
 +
            RS01  = RS01 + 1;
 +
            WRITE    S01;
 +
          ENDDO;
 +
 
 +
        // Position to TOP of subfile
 +
            SRS01 = 1;
 +
            SFC01 = RS01;
 +
          ENDSR;
 +
 
 +
      //--------------  CLR -------------------------------//
 +
          BEGSR  CLR;
 +
              I    =  0;
 +
              CLEAR FLD;
 +
              KEYLN = 0;
 +
 
 +
              *IN51 = *OFF;
 +
              *IN52 = *OFF;
 +
              *IN53 = *ON;
 +
              WRITE    C01;
 +
              *IN53 = *OFF;
 +
              RS01  = 0  ;
 +
              SFC01 = 0  ;
 +
              S01OPT= *BLANK;
 +
              ENDSR;
 +
 
 +
      //--------------  MOV -------------------------------//
 +
          BEGSR  MOV;
 +
        //  Load the subfile record
 +
 
 +
 
 +
            S01OPT  =  WHFIOB ;
 +
            S01WHFLDB  = WHFLDB;
 +
            S01WHFLDT  = WHFLDT;
 +
            S01WHFLD =  WHFLDE ;
 +
            S01SFLD  =  WHFLDE ;
 +
            S01FROM = WHFOBO;
 +
            S01TO  = WHFLDB + WHFOBO -1 ;
 +
 
 +
      //  KEY FIELDS
 +
            S01KEYFLD  = '  ';
 +
              K = %LOOKUP(WHFLDE :KEY);
 +
                  IF K <> 0;
 +
                    S01KEYFLD = KA;
 +
                  IF  K <  10;
 +
                    %SUBST(S01KEYFLD:1:1) = 'K';
 +
                  ENDIF;
 +
                    KEYLN = KEYLN +  WHFLDB;
 +
                  ENDIF;
 +
        //  FORMAT THE FIELD LENGTH
 +
                  S01SIZE  =  '      ';
 +
                  SZ      =  '      ';
 +
                  IF WHFLDD =      0;
 +
                      LEN3  = %SUBST(%EDITC(WHFLDB:'Z'):3:3);
 +
                  ELSE;
 +
                      LEN2  = %EDITC(WHFLDD:'Z') ;
 +
                      COMA = ',';
 +
 
 +
                      IF    WHFLDP >  9;
 +
                        DEC2 = %CHAR(WHFLDP);
 +
                      ELSE;
 +
                        DEC1 = %CHAR(WHFLDP);
 +
                      ENDIF;
 +
                  ENDIF;
 +
                  IF  LEN1 =  '0';
 +
                      LEN1 = ' ';
 +
                  ENDIF;
 +
                  S01SIZE = SZ;
 +
 
 +
                  S01DESC = WHFTXT;
 +
                  IF    S01DESC=  ' ';
 +
                      S01DESC  =  WHCOLD ;
 +
                  ENDIF;
 +
 
 +
                  I = I + 1;
 +
                  FLD(I) =  S01WHFLD;
 +
 
 +
          ENDSR;
 +
 
 +
      //--------------*INZSR-------------------------------//
 +
          BEGSR    @INZSR;
 +
              @NSCN = *BLANK;
 +
          ENDSR;
 +
      /END-FREE
 +
 
 +
    P @S01BLD        E
 +
 
 +
      //###################################################//
 +
      //###################################################//
 +
 
 +
      /space 3
 +
    P @S01PRC        B
 +
 
 +
    D @S01PRC        PI
 +
 
 +
          //
 +
          //
 +
    D WRKRC          S              4S 0
 +
    D C01CHK          S                  LIKE(C01POSN)
 +
 
 +
      /FREE
 +
          EXSR      @INZSR;
 +
 
 +
            WRITE    R01;
 +
 
 +
      //
 +
            DOW      @LOOP = @LOOP;
 +
 
 +
          //
 +
          // Write SFL Control
 +
            IF        SFC01 > 0;
 +
                *IN51 = *ON;
 +
            ENDIF;
 +
              *IN52 = *ON;
 +
              EXFMT    C01;
 +
          //  Setoff errors
 +
                *IN89 = *OFF;
 +
          //
 +
          //  Exit and Previous Screen
 +
            IF        *IN03 = *ON;
 +
              RTN = '1';
 +
                LEAVE;
 +
            ENDIF;
 +
 
 +
            IF        *IN12 = *ON;
 +
                @LV = @LV -1;
 +
                LEAVE;
 +
            ENDIF;
 +
 
 +
          //  Set up for qry selection and exit
 +
            IF        *IN06 = *ON;
 +
              *IN03 = *ON;
 +
              QRY = '1';
 +
              LEAVE;
 +
            ENDIF;
 +
 
 +
        //  POSITION
 +
            IF  C01POSN <> ' ';
 +
              EXSR POS;
 +
              ITER;
 +
            ENDIF;
 +
 
 +
        //  Process the subfile
 +
              @LV = @LV + 1;
 +
              @SCN(@LV) = 'S01PRS';
 +
              LEAVE;
 +
 
 +
            ENDDO;
 +
      //
 +
            RETURN;
 +
 
 +
      /space 3
 +
 
 +
      //--------------POS  -------------------------------//
 +
          BEGSR    POS;
 +
 
 +
 
 +
          FOR      WRKRC = 1 TO SFC01;
 +
              CHAIN  WRKRC  S01;
 +
                IF        NOT %FOUND;
 +
                    LEAVE;
 +
                ENDIF;
 +
 
 +
                C01CHK  = %SUBST(S01WHFLD :1 : %LEN(%TRIM(C01POSN)));
 +
                IF  (C01POSN  = C01CHK  );
 +
                    SRS01  = WRKRC;
 +
                    LEAVE;
 +
                ENDIF;
 +
 
 +
          ENDFOR;
 +
 
 +
 
 +
          ENDSR;
 +
 
 +
 
 +
      //--------------*INZSR-------------------------------//
 +
          BEGSR    @INZSR;
 +
              @NSCN = *BLANK;
 +
 
 +
            C01FILE    =  FILE;
 +
            C01LIB    =  LIB;
 +
            C01MBR    =  MBR;
 +
            C01RCDL    =  RCDL;
 +
            C01ACCTP  =  ACCTP;
 +
            C01WHTEXT  =  WHTEXT;
 +
            C01RCORDS  =  RCDS;
 +
            C01POSN    =  '  ' ;
 +
            C01WHNAME  =  WHNAME;
 +
 
 +
          ENDSR;
 +
      /END-FREE
 +
 
 +
    P @S01PRC        E
 +
 
 +
      //###################################################//
 +
      //###################################################//
 +
      //###################################################//
 +
      /space 3
 +
    P @S01PRS        B
 +
 
 +
    D @S01PRS        PI
 +
 
 +
          //
 +
          //
 +
    D WRKRC          S              4S 0
 +
    D FX              S              5S 0
 +
 
 +
      /FREE
 +
 
 +
          EXSR      @INZSR;
 +
 
 +
        //  Process the subfile
 +
          EXSR      SFL;
 +
          *IN03 = '1';
 +
          RETURN;
 +
 
 +
      //--------------  SFL -------------------------------//
 +
          BEGSR      SFL;
 +
        //  Process the subfile
 +
 
 +
          FOR      WRKRC = 1 TO SFC01+1;
 +
              CHAIN  WRKRC  S01;
 +
                IF        NOT %FOUND;
 +
        //  Finished with the subfile
 +
        //  RETURN TO REBUILD LEVEL
 +
                    @LV = @LV -2;
 +
                    LEAVE;
 +
                ENDIF;
 +
 
 +
        //    RIGHT ADJUST OPTION
 +
              S01OPT  = @OPADJ(S01OPT);
 +
 
 +
        //    UPDATE SELECTIONS
 +
              EXSR UPD;
 +
 
 +
          ENDFOR;
 +
 
 +
          ENDSR;
 +
      //---------------------------------------------------//
 +
 
 +
      //--------------UPD ---------------------------------//
 +
          BEGSR      UPD;
 +
 
 +
      // UPDATE FIELD NAMES AND SELECT FLAG
 +
                FX = %LOOKUP(S01SFLD :FLD);
 +
                CHAIN  FX  QWHDRFFD;
 +
                WHFLDE  =  S01WHFLD;
 +
 
 +
                IF @OPADJ(S01OPT) = ' S' OR
 +
                    @OPADJ(S01OPT) = ' O';
 +
                    ALL    = %TRIM(S01OPT);
 +
                    WHFIOB = %TRIM(S01OPT);
 +
                ENDIF;
 +
 
 +
                IF @OPADJ(S01OPT) = ' ';
 +
                    WHFIOB = ' ';
 +
                ENDIF;
 +
                  UPDATE  QWHDRFFD;
 +
 
 +
          ENDSR;
 +
 
 +
 
 +
      //--------------*INZSR-------------------------------//
 +
          BEGSR    @INZSR;
 +
              ALL  = '1';
 +
              @NSCN = *BLANK;
 +
          ENDSR;
 +
 
 +
 
 +
      /END-FREE
 +
    P @S01PRS        E
 +
 
 +
      //###################################################//
 +
      //###################################################//
 +
      //###################################################//
 +
 
 +
    P @R9999          B
 +
        //  Invalid Panel
 +
    D @R9999          PI
 +
 
 +
    P @R9999          E
 +
 
 +
 
 +
      /space 3
 +
      //###################################################//
 +
      //###################################################//
 +
      //###################################################//
 +
    P @OPADJ          B
 +
        //  RIGHT ADJ OPTION , zero suppress
 +
 
 +
    D @OPADJ          PI            2A
 +
    D  OPT                          2A
 +
 
 +
      /FREE
 +
        EVALR  OPT  = %trimr(OPT);
 +
        If %SubSt(OPT:1:1) =  '0';
 +
        OPT  = ' ' +  %SubSt(OPT:2:1);
 +
        EndIf;
 +
        RETURN OPT;
 +
      /END-FREE
 +
    P @OPADJ          E
 +
 
 +
      //###################################################//
 +
      //###################################################//
 +
      //###################################################//
 +
    P  RtvMsgTxt      B
 +
      //************************************************************************
 +
      // API Call: QMHRTVM Retrieve Message text
 +
      //************************************************************************
 +
 
 +
 
 +
      // USAGE
 +
      // MsgTxt = RtvMsgTxt('MSG0001':cMsgF3:cMsgLib:cMsgLvl1);
 +
 
 +
    D  RtvMsgTxt      PI          1024
 +
    D  RMsgId                      7    Const
 +
    D  RMsgFle                    10    Const
 +
    D  RMsgLib                    10    Const
 +
    D  RMsgLvl                      1    Const
 +
 
 +
      // Retrieve Message Description API Prototype
 +
    D  Get_Message    PR                  ExtPgm('QMHRTVM')
 +
    D                            4000    Options(*VarSize)
 +
    D                              10I 0 Const
 +
    D                                8    Const
 +
    D                                7
 +
    D                              20    Const
 +
    D                            32765    Options(*VarSize)
 +
    D                              10I 0 Const
 +
    D                              10    Const
 +
    D                              10    Const
 +
    D                            8192    Options(*VarSize)
 +
    D                              10
 +
    D                                9B 0
 +
    D                                9B 0
 +
 
 +
      // Define Variables for QMHRTVM API call:
 +
      // --------------------------------------
 +
      // Return variables
 +
    D  MessageInfo    DS          4000
 +
    D  Data                  1  4000
 +
    D  OSMSG                65    68B 0
 +
    D  LMsgR                69    72B 0
 +
    D  LMsgA                73    76B 0
 +
    D  OSMSGH              77    80B 0
 +
    D  LMsgHR              81    84B 0
 +
    D  LMsgHA              85    88B 0
 +
 
 +
      // Required input variables
 +
    D  MessageLen    S            10I 0
 +
    D  MessageForm  S              8
 +
    D  MessageIden  S              7
 +
    D  MessageFile  S            20
 +
    D  Replacement  S          32765
 +
    D  ReplaceLen    S            10I 0
 +
    D  ReplaceSub    S            10
 +
    D  ReturnCtl    S            10
 +
 
 +
    D  RetrieveOpt  S            10
 +
    D  ConvToCCSID  S              9B 0
 +
    D  ReplDtaCCSID  S              9B 0
 +
 
 +
    D  Return_Text  S          1024
 +
 
 +
    D  ErrorCode      DS                  Qualified
 +
    D  BytesProv                    4B 0 Inz(0)
 +
    D  BytesAvail                  8B 0 Inz(0)
 +
    D  ExceptionId                  7
 +
    D  Reserved                    1
 +
    D  ExceptionDta              512
 +
      /FREE
 +
 
 +
        // Load API parameter fields
 +
        MessageInfo  = *blanks;
 +
        MessageLen    = 4000;
 +
        MessageForm  = 'RTVM0300';
 +
        MessageIden  = RMsgId;
 +
        MessageFile  = RMsgFle + RMsgLib;
 +
        Replacement  = *blanks;
 +
        ReplaceLen    = %Len(Replacement);
 +
        ReplaceSub    = '*YES';
 +
        ReturnCtl    = '*YES';
 +
        RetrieveOpt  = '*MSGID';
 +
        ConvToCCSID  = 0;
 +
        ReplDtaCCSID  = 0;
 +
 
 +
        // Retrieve message description
 +
        Get_Message(MessageInfo :
 +
                    MessageLen  :
 +
                    MessageForm :
 +
                    MessageIden :
 +
                    MessageFile :
 +
                    Replacement :
 +
                    ReplaceLen  :
 +
                    ReplaceSub  :
 +
                    ReturnCtl  :
 +
                    ErrorCode  :
 +
                    RetrieveOpt :
 +
                    ConvToCCSID :
 +
                    ReplDtaCCSID);
 +
 
 +
        // Process Return variables
 +
        Return_Text = *blanks;
 +
 
 +
        // If no errors, determine the correct portion of the message text
 +
        If ErrorCode.BytesProv = 0;
 +
          Select;
 +
          When RMsgLvl = '1';
 +
              Return_Text = %Subst(data:OSMSG+1:LMsgA);  // Msg Lvl 1
 +
          When RMsgLvl = '2';
 +
              Return_Text = %Subst(data:OSMSGH+1:LMsgHA);  // Msg Lvl 2
 +
          EndSl;
 +
        Else;
 +
          Return_Text = 'Get_Message failed.';
 +
        EndIf;
 +
 
 +
        // Return to calling point
 +
        Return Return_Text;
 +
 
 +
      /END-FREE
 +
    P                E
 +
 
 +
 
 +
      //###################################################//
 +
      //###################################################//
 +
      //###################################################//
 +
    P GETROWCOL      B
 +
      *
 +
      *    Retreive a DSPF FIELD  Row and Col
 +
      *    Used for Setting  CSRLOC for cursor positioning
 +
      *    USAGE
 +
      *    GETROWCOL  (FILE :'*LIBL' : FORMAT : FLDNAM : ROW : COL)
 +
      *
 +
    D GETROWCOL      PR
 +
    D  schFile                    10A  const
 +
    D  schLib                      10A  const
 +
    D  schFormat                  10A  const
 +
    D  schString                  32A  const
 +
    D  rtnROW                      3P 0
 +
    D  RtnCOL                      3P 0
 +
 
 +
    D GETROWCOL      PI
 +
    D  schFile                    10A  const
 +
    D  schLib                      10A  const
 +
    D  schFormat                  10A  const
 +
    D  schString                  32A  const
 +
    D  rtnROW                      3P 0
 +
    D  RtnCOL                      3P 0
 +
 
 +
    D QUSCRTUS        PR                  ExtPgm('QUSCRTUS')
 +
    D  UserSpace                  20A  CONST
 +
    D  ExtAttrib                  10A  CONST
 +
    D  InitialSize                10I 0 CONST
 +
    D  InitialVal                  1A  CONST
 +
    D  PublicAuth                  10A  CONST
 +
    D  Text                        50A  CONST
 +
    D  Replace                    10A  CONST options(*nopass)
 +
    D  ErrorCode                32767A  options(*varsize:*nopass)
 +
 
 +
    D QUSPTRUS        PR                  ExtPgm('QUSPTRUS')
 +
    D  UserSpace                  20A  CONST
 +
    D  Pointer                      *
 +
 
 +
    D QUSDLTUS        PR                  ExtPgm('QUSDLTUS')
 +
    D  UserSpace                  20A  CONST
 +
    D  ErrorCode                32767A  options(*varsize)
 +
 
 +
    D QUSLFLD        PR                  ExtPgm('QUSLFLD')
 +
    D  UsrSpc                      20A  const
 +
    D  Format                      8A  const
 +
    D  QualFile                    20A  const
 +
    D  RcdFmt                      10A  const
 +
    D  UseOvrd                      1A  const
 +
    D  ErrorCode                32767A  options(*nopass:*varsize)
 +
 
 +
    D ErrorCode      ds                  qualified
 +
    D  BytesProv                  10I 0 inz(0)
 +
    D  BytesAvail                  10I 0 inz(0)
 +
 
 +
    D ListHeader      ds                  based(p_ListHeader)
 +
    d  ListOffset                  10I 0 overlay(ListHeader:125)
 +
    d  EntryCount                  10I 0 overlay(ListHeader:133)
 +
    d  EntrySize                  10I 0 overlay(ListHeader:137)
 +
 
 +
    D Field          ds                  based(p_Field)
 +
    D                                    qualified
 +
    D  Name                        10a
 +
    D  FILLER                      438a
 +
    d  DspRow                      10i 0
 +
    d  DspCol                      10i 0
 +
 
 +
    D TEMPSPC        C                  'GETROWCOL QTEMP'
 +
 
 +
    D x              s            10I 0
 +
 
 +
      /free
 +
 
 +
                  rtnrow =    999;
 +
                  rtnrow =    999;
 +
          // --------------------------------------------------
 +
          // Delete the user space if it exists (ignore errors)
 +
          ErrorCode.BytesProv = %size(ErrorCode);
 +
          QUSDLTUS( TEMPSPC: ErrorCode );
 +
          ErrorCode.BytesProv = 0;
 +
 
 +
          // --------------------------------------------------
 +
          // Create a new 128k user space
 +
          QUSCRTUS( TEMPSPC : 'SCHTEXT' : 128 * 1024  : x'00'
 +
                  : '*EXCLUDE' : 'List of fields in file' : '*NO'
 +
                  : ErrorCode );
 +
 
 +
          // --------------------------------------------------
 +
          // Dump list of fields in file to user space
 +
          // Invaid data is ignored an 999 returned for row and col
 +
          monitor;
 +
          QUSLFLD( TEMPSPC : 'FLDL0100'  : SchFile + SchLib
 +
                  : SchFormat  : *OFF  : ErrorCode );
 +
              on-Error;
 +
                RETURN;
 +
            EndMon;
 +
          // --------------------------------------------------
 +
          // Get a pointer to the user space
 +
          QUSPTRUS( TEMPSPC: p_ListHeader );
 +
 
 +
          // --------------------------------------------------
 +
          // Loop through all fields in space, to get the field we need
 +
          for x = 0 to (EntryCount - 1);
 +
              p_Field = p_ListHeader + ListOffset + (EntrySize * x);
 +
 
 +
              if Field.Name = schString;
 +
                  rtnRow =    Field.DspRow;
 +
                  rtnCol =    Field.DspCol;
 +
                leave;
 +
              endif;
 +
          endfor;
 +
 
 +
          // --------------------------------------------------
 +
          // Delete temp user space & end
 +
          QUSDLTUS( TEMPSPC: ErrorCode );
 +
 
 +
            return;
 +
 
 +
      /end-free
 +
    P                E
 +
 
 +
</pre>
 +
 
 +
[[#top]]
 +
 
 +
===DISPYF  RPG ===
 +
 
 +
<pre>
 +
 
 +
    A*%%TS  SD  20101203  131649  KOLMANNF    REL-V5R4M0  5722-WDS
 +
    A*  90/01/08  12:52:36                REL-R01M02  5728-PW1
 +
    A*            16:33:07                REL-R08M00  5714-UT1
 +
    A*%%EC
 +
    A                                      DSPSIZ(24 80 *DS3)
 +
    A                                      REF(*LIBL/QADSPFFD)
 +
    A                                      PRINT
 +
    A                                      CA03(03 'End of job')
 +
    A                                      CA12(12 'Previous')
 +
    A                                      CA04(04 'Add FIELDS')
 +
    A                                      CA05(05 'Attr changes')
 +
    A                                      CF06(06 'Field Select')
 +
    A                                      CA07(07 'Name changes')
 +
    A*****
 +
    A*            15:04:39                REL-R08M00  5714-UT1
 +
    A          R S01                      SFL
 +
    A*%%TS  SD  20101203  131649  KOLMANNF    REL-V5R4M0  5722-WDS
 +
    A  40                                  SFLNXTCHG
 +
    A            S01OPT        2A  B  7  2
 +
    A            S01KEYFLD      2A  O  7  5DSPATR(HI)
 +
    A            S01WHFLD  R        B  7  8REFFLD(WHFLDI)
 +
    A  23                                  DSPATR(HI)
 +
    A N23                                  DSPATR(PR)
 +
    A            S01WHFLDB R        B  7 19REFFLD(WHFLDB)
 +
    A                                      EDTCDE(Z)
 +
    A  25                                  DSPATR(HI)
 +
    A N25                                  DSPATR(PR)
 +
    A            S01SIZE        6A  O  7 25
 +
    A            S01FROM        4Y 0O  7 32EDTCDE(Z)
 +
    A            S01TO          4Y 0O  7 37EDTCDE(Z)
 +
    A            S01DESC      35A  O  7 44
 +
    A            S01WHFLDT R        B  7 42REFFLD(WHFLDT)
 +
    A  25                                  DSPATR(HI)
 +
    A N25                                  DSPATR(PR)
 +
    A            S01SFLD  R        H      REFFLD(WHFLDI)
 +
    A*****
 +
    A*
 +
    A          R C01                      SFLCTL(S01)
 +
    A*%%TS  SD  20101203  131649  KOLMANNF    REL-V5R4M0  5722-WDS
 +
    A                                      SFLSIZ(0015)
 +
    A                                      SFLPAG(0014)
 +
    A  88                                  CSRLOC(ROW01      COL01)
 +
    A                                      OVERLAY
 +
    A                                      TEXT('WORK WITH FIELDS')
 +
    A  51                                  SFLDSP
 +
    A  52                                  SFLDSPCTL
 +
    A  53                                  SFLCLR
 +
    A  99                                  SFLEND
 +
    A            SRS01          4S 0H      SFLRCDNBR(CURSOR)
 +
    A*
 +
    A  89        C01MSG        79  M
 +
    A            ROW01          3S 0H
 +
    A            COL01          3S 0H
 +
    A                                  1  3'File'
 +
    A            C01FILE      10A  O  1  8DSPATR(HI)
 +
    A                                  1 20'Lib'
 +
    A            C01LIB        10A  O  1 24DSPATR(HI)
 +
    A                                  1 37'Mbr'
 +
    A            C01MBR        10A  O  1 41DSPATR(HI)
 +
    A                                  1 53'Rcdlen'
 +
    A            C01RCDL        4S 0O  1 60DSPATR(HI)
 +
    A                                  1 66'Access'
 +
    A            C01ACCTP      1A  O  1 73DSPATR(HI)
 +
    A                                  2  3'Text'
 +
    A            C01WHTEXT R        O  2  9REFFLD(WHTEXT)
 +
    A                                      DSPATR(HI)
 +
    A                                  2 60'#Records'
 +
    A            C01RCORDS      7Y 0O  2 69DSPATR(HI)
 +
    A                                      EDTCDE(Z)
 +
    A            C01POSN      10A  I  3  7
 +
    A                                  4  2'Select/Omit (S/O) fields for displ-
 +
    A                                      ay.(Default *ALL)'
 +
    A                                  5 11'Use Select Or Omit,not Select with-
 +
    A                                      Omit'
 +
    A                                  6  8'Name      Bytes  Size  From  To T-
 +
    A                                      p  Description'
 +
    A                                  4 54'Format'
 +
    A            C01WHNAME R        O  4 61REFFLD(QWHDRFFD/WHNAME)
 +
    A                                      DSPATR(HI)
 +
    A          R R01
 +
    A                                23  2'F3-Exit F6-Data Sel'
 +
 
 +
</pre>
 +
 
 +
[[#top]]
 +
 
 +
===DISPX  DSPF ===
 +
 
 +
<pre>
 +
    A                                      DSPSIZ(24 80 *DS3)
 +
    A                                      PRINT
 +
    A                                      CF02(02 'return')
 +
    A                                      CF03(01 'exit')
 +
    A          R SLT
 +
    A                                      OVERLAY
 +
    A                                  1  2'Qryslt:'
 +
    A            QSLT        1509A  B  1 12CHECK(LC)
 +
    A                                20  1'F2-Return '
 +
    A          R SLTR                      SFL
 +
    A                                      SFLMSGRCD(21)
 +
    A            MSGKEY                    SFLMSGKEY
 +
    A            PGMQ                      SFLPGMQ
 +
    A          R SLTC                      SFLCTL(SLTR  )
 +
    A                                      OVERLAY
 +
    A                                      SFLSIZ(50) SFLPAG(3)
 +
    A N20                                  SFLEND
 +
    A N20                                  SFLDSP
 +
    A N20                                  SFLDSPCTL
 +
    A N20                                  SFLINZ
 +
    A  20                                  SFLCLR
 +
    A            PGMQ                      SFLPGMQ
 +
 
 +
</pre>
 +
 
 +
[[#top]]
 +
 
 +
===FFDL01 LF ===
 +
 
 +
<pre>
 +
    A          R QWHDRFFD                  PFILE(FFD)
 +
                K WHFILE
 +
 
 +
</pre>
 +
 
 +
[[#top]]
 +
 
 +
 
 +
=== COMPILE CL    ===
 +
 
 +
<pre>
 +
/* COMPILE OBJECTS                    */
 +
/* CRTBNDCL  PGM(KOLMANN/COMPILE) SRCFILE(KOLMANN/UDDSSRC)    */
 +
/*            SRCMBR(COMPILE) OUTPUT(*NONE) REPLACE(*YES)      */
 +
/* call compile ('KOLMANN' 'UDDSSRC')                          */
 +
PGM (&LIB &SRCF)
 +
 
 +
DCL &LIB  *CHAR  10
 +
DCL &SRCF *CHAR  10
 +
 
 +
CRTDTAARA  DTAARA(&LIB/UDDSSRC) TYPE(*CHAR) LEN(10) +
 +
  VALUE(&SRCF) TEXT('SOURCE LIBRARY FOR  UDDS PROGRAMS')
 +
MONMSG CPF0000
 +
 
 +
dltf qtemp/afile
 +
monmsg cpf0000
 +
CRTPF      FILE(QTEMP/AFILE) RCDLEN(80) OPTION(*NOLIST)
 +
 
 +
CRTDSPF    FILE(&LIB/DISPF) SRCFILE(&LIB/&SRCF) +
 +
                          SRCMBR(DISPF) OPTION(*NOLIST *NOSRC) +
 +
                          REPLACE(*YES)
 +
 
 +
 
 +
DSPFFD  FILE(QTEMP/AFILE) OUTPUT(*OUTFILE) OUTFILE(QTEMP/FFD)
 +
DLTF  FILE(QTEMP/FFDL01)
 +
MONMSG CPF0000
 +
CRTLF FILE(QTEMP/FFDL01) SRCFILE(&LIB/&SRCF) SRCMBR(FFDL01) +
 +
OPTION(*NOSRC *NOLIST)
 +
 
 +
DSPFFD  FILE(QTEMP/FFD) OUTPUT(*OUTFILE) OUTFILE(QTEMP/FFFFD)
 +
DSPFD (QTEMP/FFD ) TYPE(*ACCPTH) OUTPUT(*OUTFILE) OUTFILE(QTEMP/KFFFD )
 +
OVRDBF    FILE(KF) TOFILE(QTEMP/KFFFD)
 +
CRTBNDCL  PGM(&LIB/DISF) SRCFILE(&LIB/&SRCF) +
 +
        DBGVIEW(*SOURCE)  SRCMBR(DISF) OUTPUT(*NONE) REPLACE(*YES)
 +
CRTBNDCL  PGM(&LIB/DISV) SRCFILE(&LIB/&SRCF) +
 +
        DBGVIEW(*SOURCE)  SRCMBR(DISV) OUTPUT(*NONE) REPLACE(*YES)
 +
 
 +
CRTBNDRPG  PGM(&LIB/DISPY) SRCFILE(&LIB/&SRCF) +
 +
    SRCMBR(DISPY) DBGVIEW(*SOURCE) OUTPUT(*NONE) REPLACE(*YES)
 +
 
 +
 
 +
DLTF  FILE(QTEMP/REL)
 +
MONMSG CPF0000
 +
DLTF  FILE(QTEMP/SEL)
 +
MONMSG CPF0000
 +
DLTF  FILE(QTEMP/DBR)
 +
MONMSG CPF0000
 +
 
 +
DSPFD      FILE(QTEMP/FFD) TYPE(*ACCPTH) +
 +
  OUTPUT(*OUTFILE) OUTFILE(QTEMP/REL) OUTMBR(*FIRST *ADD)
 +
DSPFD FILE(QTEMP/FFDL01) TYPE(*SELECT) OUTPUT(*OUTFILE) OUTFILE(QTEMP/SEL)
 +
CRTDSPF    FILE(&LIB/DISPRF) SRCFILE(&LIB/&SRCF) +
 +
                          SRCMBR(DISPRF) OPTION(*NOLIST *NOSRC) +
 +
                          REPLACE(*YES)
 +
 
 +
DSPDBR    FILE(QTEMP/FFD) OUTPUT(*OUTFILE) +
 +
  OUTFILE(QTEMP/DBR) OUTMBR(*FIRST *REPLACE)
 +
 
 +
DLTF  FILE(QTEMP/ACC)
 +
MONMSG CPF0000
 +
DSPFD FILE(QTEMP/FFDL01) TYPE(*ACCPTH) OUTPUT(*OUTFILE) OUTFILE(QTEMP/ACC)
 +
 
 +
CRTBNDRPG  PGM(&LIB/DISP) SRCFILE(&LIB/&SRCF) +
 +
  SRCMBR(DISP) DBGVIEW(*SOURCE) OUTPUT(*NONE) REPLACE(*YES)
 +
CRTBNDRPG  PGM(&LIB/DISP1) SRCFILE(&LIB/&SRCF) +
 +
  SRCMBR(DISP1) DBGVIEW(*SOURCE) OUTPUT(*NONE) REPLACE(*YES)
 +
CRTBNDRPG  PGM(&LIB/DISP2) SRCFILE(&LIB/&SRCF) +
 +
  SRCMBR(DISP2) DBGVIEW(*SOURCE) OUTPUT(*NONE) REPLACE(*YES)
 +
 
 +
CRTBNDRPG  PGM(&LIB/DUSP) SRCFILE(&LIB/&SRCF) +
 +
  SRCMBR(DUSP) DBGVIEW(*SOURCE)                REPLACE(*YES)
 +
CRTBNDRPG  PGM(&LIB/DUSP1) SRCFILE(&LIB/&SRCF) +
 +
  SRCMBR(DUSP1) DBGVIEW(*SOURCE) OUTPUT(*NONE) REPLACE(*YES)
 +
CRTBNDRPG  PGM(&LIB/DUSP2) SRCFILE(&LIB/&SRCF) +
 +
  SRCMBR(DUSP2) DBGVIEW(*SOURCE) OUTPUT(*NONE) REPLACE(*YES)
 +
 
 +
CRTBNDCL  PGM(&LIB/DIS) SRCFILE(&LIB/&SRCF) +
 +
      DBGVIEW(*SOURCE)    SRCMBR(DIS) OUTPUT(*NONE) REPLACE(*YES)
 +
CRTBNDCL  PGM(&LIB/DIS3) SRCFILE(&LIB/&SRCF) +
 +
      DBGVIEW(*SOURCE)    SRCMBR(DIS3) OUTPUT(*NONE) REPLACE(*YES)
 +
CRTBNDCL  PGM(&LIB/DIS4) SRCFILE(&LIB/&SRCF) +
 +
      DBGVIEW(*SOURCE)    SRCMBR(DIS4) OUTPUT(*NONE) REPLACE(*YES)
 +
CRTBNDCL  PGM(&LIB/DISBIN) SRCFILE(&LIB/&SRCF) +
 +
      DBGVIEW(*SOURCE)    SRCMBR(DISBIN) OUTPUT(*NONE) REPLACE(*YES)
 +
 
 +
CRTBNDRPG  PGM(&LIB/DISPR) SRCFILE(&LIB/&SRCF) +
 +
    SRCMBR(DISPR) DBGVIEW(*SOURCE) OUTPUT(*NONE) REPLACE(*YES)
 +
 
 +
CRTCMD CMD(&LIB/DSPFL) PGM(*LIBL/DIS) SRCFILE(&LIB/&SRCF)  +
 +
            SRCMBR(DSPFL) VLDCKR(DISV)
 +
 
 +
CRTDSPF    FILE(&LIB/DISPX) SRCFILE(&LIB/&SRCF) +
 +
                          SRCMBR(DISPX) OPTION(*NOLIST *NOSRC) +
 +
                          REPLACE(*YES)
 +
CRTBNDCL  PGM(&LIB/DIS1) SRCFILE(&LIB/&SRCF) +
 +
      DBGVIEW(*SOURCE)  SRCMBR(DIS1) OUTPUT(*NONE) REPLACE(*YES)
 +
 
 +
 
 +
 
 +
ENDPGM
 +
 
 +
 
 +
</pre>
 +
 
 +
[[#top]]
 +
 
 +
=== TESTPF  PF      ===
 +
 
 +
<pre>
 +
    A          R TESTR
 +
    A            ACTIV          1A        TEXT('Active flag (0 - inactive, 1')
 +
    A            CMPNO          3P        TEXT('Company number              ')
 +
    A            PLTNO          2P        TEXT('Plant number                ')
 +
    A            PRDNO        15A        TEXT('Product number              ')
 +
    A            OPBAL        13P 3      TEXT('Opening balance - this perio')
 +
    A            SERVU          5S 2      TEXT('Service level based on units')
 +
    A            QTY            5B 2      TEXT('QTY')
 +
    A            QTYF          17F 4      FLTPCN(*DOUBLE)
 +
    A            CCYYMMDD        L        TEXT('DATE')
 +
    A            HHMMSS          T        TEXT('TIME')
 +
    A            DATTIM          Z        TEXT('DATE TIME')
 +
    A            VTEXT        100A        VARLEN
 +
    A                                      TEXT('VARIABLE TEXT')
 +
    A            DESCP        30A        TEXT('Product description or name ')
 +
 
 +
    A          K ACTIV
 +
    A          K CMPNO
 +
    A          K PRDNO
 +
    A          K OPBAL
 +
    A          K SERVU
 +
 
 +
</pre>
 +
 
 +
[[#top]]
 +
 
 +
=== TESTPF1  PF      ===
 +
 
 +
<pre>
 +
    A          R TESTR
 +
    A            ACTIV          1A        TEXT('Active flag (0 - inactive, 1')
 +
    A            CMPNO          3P        TEXT('Company number              ')
 +
    A            PLTNO          2P        TEXT('Plant number                ')
 +
    A            PRDNO        15A        TEXT('Product number              ')
 +
    A            OPBAL        13P 3      TEXT('Opening balance - this perio')
 +
    A            SERVU          5S 2      TEXT('Service level based on units')
 +
    A            QTY            5B 2      TEXT('QTY')
 +
    A            QTYF          17F 4      FLTPCN(*DOUBLE)
 +
    A            CCYYMMDD        L        TEXT('DATE')
 +
    A            HHMMSS          T        TEXT('TIME')
 +
    A            DATTIM          Z        TEXT('DATE TIME')
 +
    A            VTEXT        100A        VARLEN
 +
    A                                      TEXT('VARIABLE TEXT')
 +
    A            DESCP        30A        TEXT('Product description or name ')
 +
    A            TXT1        500A        TEXT('TXT1  ')
 +
    A            TXT2        500A        TEXT('TXT2  ')
 +
    A            TXT3        500A        TEXT('TXT3  ')
 +
    A            TXT4        500A        TEXT('TXT4  ')
 +
    A          K ACTIV
 +
    A          K CMPNO
 +
    A          K PRDNO
 +
    A          K OPBAL
 +
    A          K SERVU
 +
 
 +
</pre>
 +
 
 +
[[#top]]
 +
 
 +
=== TESTPF2  PF      ===
 +
 
 +
<pre>
 +
 
 +
    A          R TESTR
 +
    A            ACTIV          1A        TEXT('Active flag (0 - inactive, 1')
 +
    A            CMPNO          3P        TEXT('Company number              ')
 +
    A            PLTNO          2P        TEXT('Plant number                ')
 +
    A            PRDNO        15A        TEXT('Product number              ')
 +
    A            OPBAL        13P 3      TEXT('Opening balance - this perio')
 +
    A            SERVU          5S 2      TEXT('Service level based on units')
 +
    A            QTY            5B 2      TEXT('QTY')
 +
    A            QTYF          17F 4      FLTPCN(*DOUBLE)
 +
    A            CCYYMMDD        L        TEXT('DATE')
 +
    A            HHMMSS          T        TEXT('TIME')
 +
    A            DATTIM          Z        TEXT('DATE TIME')
 +
    A            VTEXT        100A        VARLEN
 +
    A                                      TEXT('VARIABLE TEXT')
 +
    A            DESCP        30A        TEXT('Product description or name ')
 +
    A            TXT1        500A        TEXT('TXT1  ')
 +
    A            TXT2        500A        TEXT('TXT2  ')
 +
    A            TXT3        500A        TEXT('TXT3  ')
 +
    A            TXT4        500A        TEXT('TXT4  ')
 +
    A            TXT5        500A        TEXT('TXT5  ')
 +
    A            TXT6        500A        TEXT('TXT6  ')
 +
    A            TXT7        500A        TEXT('TXT7  ')
 +
    A            TXT8        500A        TEXT('TXT8  ')
 +
    A          K ACTIV
 +
    A          K CMPNO
 +
    A          K PRDNO
 +
    A          K OPBAL
 +
    A          K SERVU
 +
 
 +
 
 +
</pre>
 +
 
 +
[[#top]]

Latest revision as of 22:42, 7 December 2018


UDDS PROGRAMS THAT SHOW FILES FIELDS AND RELATIONS AND ALLOWS UPDATE

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. There are 3 programs first is limited to 2048 last to 6048.

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. The COMPILE CL will create the objects once you have copied the source code into a source file.

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
     F*   REQUIRES FILE TO COMPILE
     F*  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   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;

               SELECT;
                WHEN  *INU1;
                 RRN = RN1;
                WHEN  *INU2;
                 RRN = RN2;
               ENDSL;

        // IF GOT RECORDS WRITE DATA TO THE DISPLAY

             NEWRU  = '1';
             WRTRRN = '1';
            RU    = *ALLX'00';
            CLEAR  RU;        //  initialise Request Unit  255 bytes max

          IF RRN > 0    ;
            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 ;
              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;
           ENDIF;

             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
     F*   REQUIRES FILE TO COMPILE
     F*  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             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;

               SELECT;
                WHEN  *INU1;
                 RRN = RN1;
                WHEN  *INU2;
                 RRN = RN2;
               ENDSL;
        // IF GOT RECORDS WRITE DATA TO THE DISPLAY

             NEWRU  = '1';
             WRTRRN = '1';
            RU    = *ALLX'00';
            CLEAR  RU;        //  initialise Request Unit  255 bytes max

          IF RRN > 0    ;
            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 ;
              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;
           ENDIF;

             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;

               SELECT;
                WHEN  *INU1;
                 RRN = RN1;
                WHEN  *INU2;
                 RRN = RN2;
               ENDSL;

        // IF GOT RECORDS WRITE DATA TO THE DISPLAY

             NEWRU  = '1';
             WRTRRN = '1';
            RU    = *ALLX'00';
            CLEAR  RU;        //  initialise Request Unit  255 bytes max

          IF RRN > 0    ;
            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 ;
              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;
          ENDIF;

             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(DUSP )
     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 DISBIN          PR                  extpgm('DISBIN')
     D  NUM                          15P 0
     D  BAN2                          2
     D  BAN4                          4
     D  BINTYP                        1    CONST

      *
     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 NUC             S             15P 0
     D BAN2            S              2
     D BAN4            S              4

     D                 DS
     D NUFA                    1     60A
     D NUF                     1     23A
     D NUF1                    1     14A

     D                 DS
     D result8                        8F
     D NUFW8                   1      8A

     D                 DS
     D result4                        4F
     D NUFW4                   1      4A

     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
DCL V

      /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
         SELECT;
          WHEN  T(Y)  =  'A';  // ALPHA DATA
           K = ' ';
           K1 = 1;
           K2 = Q(Y);
          WHEN  T(Y)  =  'F';  // FLOAT
           K  = '0';
           K1 =  1;
           K2 = L(Y);
          OTHER;
           K  = '0';
           K1 =  1;
           K2 = C(Y);
         ENDSL;


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

               SELECT;
                WHEN  *INU1;
                 RRN = RN1;
                WHEN  *INU2;
                 RRN = RN2;
               ENDSL;
        // IF GOT RECORDS WRITE DATA TO THE DISPLAY

             NEWRU  = '1';
             WRTRRN = '1';
            RU    = *ALLX'00';
            CLEAR  RU;        //  initialise Request Unit  255 bytes max

          IF RRN > 0    ;
            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 ;
              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;
          ENDIF;

             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
         SELECT;
          WHEN  T(Y)  =  'A';  // ALPHA DATA
           K = ' ';
           K1 = 1;
           K2 = Q(Y);
          WHEN  T(Y)  =  'F';  // FLOAT
           K  = '0';
           K1 =  1;
           K2 = L(Y);
          OTHER;
           K  = '0';
           K1 =  1;
           K2 = C(Y);
         ENDSL;

          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 stick 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';

           NUSA= *BLANKS;
           FOR VX = 1 TO 60;
             NUSA = %TRIM(NUSA) + NU(VX);
           ENDFOR;
             NUC  = NUS;

         IF  Q(Y) = 2 ;
              DISBIN  ( NUC : BAN2 : BAN4  : '2');
            %SUBST(DATA : W : 2)   =   BAN2;
         ENDIF;

         IF  Q(Y) = 4 ;
              DISBIN  ( NUC : BAN2 : BAN4  : '4');
            %SUBST(DATA : W : 4)   =   BAN4;
         ENDIF;

        ENDIF;


       //  FLOAT FIELDS
        IF   T(Y) =  'F';

         IF  Q(Y) = 4;
           NUFA= *BLANKS;
           FOR VX = 1 TO 14;
             NUFA = %TRIM(NUFA) + K(VX);
           ENDFOR;

           result4 = %float(NUF1);
         %SUBST(DATA : W : 4)   =   NUFW4;

        ENDIF;


         IF  Q(Y) = 8;
           NUFA= *BLANKS;
           FOR VX = 1 TO 23;
             NUFA = %TRIM(NUFA) + K(VX);
           ENDFOR;

          result8 = %float(NUF);
          %SUBST(DATA : W : 8)   =   NUFW8;

        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(DUSP1 )
     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 DISBIN          PR                  extpgm('DISBIN')
     D  NUM                          15P 0
     D  BAN2                          2
     D  BAN4                          4
     D  BINTYP                        1    CONST

      *
     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 NUC             S             15P 0
     D BAN2            S              2
DCL  D BAN4            S              4

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

     DDUSP1            PR
     D                                1
     D                                1
     D                                4
     D                                1
     D                              500
     D                                5
     D                              800
     DDUSP1            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;

               SELECT;
                WHEN  *INU1;
                 RRN = RN1;
                WHEN  *INU2;
                 RRN = RN2;
               ENDSL;
        // IF GOT RECORDS WRITE DATA TO THE DISPLAY

            NEWRU  = '1';
            WRTRRN = '1';
            RU    = *ALLX'00';
            CLEAR  RU;        //  initialise Request Unit  255 bytes max

          IF RRN > 0    ;
            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 ;
              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;
           ENDIF;

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

           NUSA= *BLANKS;
           FOR VX = 1 TO 60;
             NUSA = %TRIM(NUSA) + NU(VX);
           ENDFOR;
             NUC  = NUS;

         IF  Q(Y) = 2 ;
              DISBIN  ( NUC : BAN2 : BAN4  : '2');
            %SUBST(DATA : W : 2)   =   BAN2;
         ENDIF;

         IF  Q(Y) = 4 ;
              DISBIN  ( NUC : BAN2 : BAN4  : '4');
            %SUBST(DATA : W : 4)   =   BAN4;
         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

     H*eywords++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++Comments+++++++++++
     H OPTION(*NODEBUGIO)
     H DFTACTGRP(*NO) ACTGRP(*CALLER) DFTNAME(DUSP2 )
     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    UF A F32766   800AIDISK    KEYLOC(1)
     F                                     EXTIND(*INU1)
     F                                     INFDS(INFDK)
     FINPUTR    UF A F32766        DISK    EXTIND(*INU2)
     F                                     INFDS(INFDR)

     D DISBIN          PR                  extpgm('DISBIN')
     D  NUM                          15P 0
     D  BAN2                          2
     D  BAN4                          4
     D  BINTYP                        1    CONST

      *
     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 NUC             S             15P 0
     D BAN2            S              2
DCL  D BAN4            S              4


     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   6080
     D  D                      1   6080
     D                                     DIM(6080)                            INCOMING DATA
     D  DA                     1   4048
     D                                     DIM(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

     DDUSP2            PR
     D                                1
     D                                1
     D                                4
     D                                1
     D                              500
     D                                5
     D                              800
     DDUSP2            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*.

0038 IINPUTK    NS  01
0039 I                                  1 4048  DA
0040 I                               4049 4064  DB                30
0041 I                               4065 4096  DC                31
0042 I                               4097 4128  DD                32
0043 I                               4129 4160  DE                33
0044 I                               4161 4192  DF                34
0045 I                               4193 4224  DG                35
0046 I                               4225 4256  DH                36
0047 I                               4257 4288  DI                37
0048 I                               4289 4320  DJ                38
0049 I                               4321 4352  DK                39
0050 I                               4353 4384  DL                40
0051 I                               4385 4416  DM                41
0052 I                               4417 4448  DN                42
0053 I                               4449 4480  DZ                43
0054 I                               4481 4512  DO                44
0055 I                               4513 4544  DP                45
0056 I                               4545 4576  DQ                46
0057 I                               4577 4608  DR                47
0058 I                               4609 4640  DS                48
0059 I                               4641 4672  DT                49
0060 I                               4673 4704  DU                50
0061 I                               4705 4736  DV                51
0062 I                               4737 4768  DW                52
0063 I                               4769 4800  DX                53
0064 I                               4801 4832  DY                54
0065 I                               4833 4864  D0                55
0066 I                               4865 4896  D1                56
0067 I                               4897 4928  D2                57
0068 I                               4929 4960  D3                58
0069 I                               4961 4992  D4                59
0070 I                               4993 5024  D5                60
0071 I                               5025 5056  D6                61
0072 I                               5057 5088  DBA               62
0073 I                               5089 5120  DCA               63
0074 I                               5121 5152  DDA               64
0075 I                               5153 5184  DEA               65
0076 I                               5185 5216  DFA               66
0077 I                               5217 5248  DGA               67
0078 I                               5249 5280  DHA               68
0079 I                               5281 5312  DIA               69
0080 I                               5313 5344  DJA               70
0081 I                               5345 5376  DKA               71
0082 I                               5377 5408  DLA               72
0083 I                               5409 5440  DMA               73
0084 I                               5441 5472  DNA               74
0085 I                               5473 5504  DOA               75
0086 I                               5505 5536  DPA               76
0087 I                               5537 5568  DQA               77
0088 I                               5569 5600  DRA               78
0089 I                               5601 5632  DSA               79
0090 I                               5633 5664  DTA               80
0091 I                               5665 5696  DUA               81
0092 I                               5697 5728  DVA               82
0093 I                               5729 5760  DWA               83
0094 I                               5761 5792  DXA               84
0095 I                               5793 5824  DYA               85
0096 I                               5825 5856  DZA               86
0097 I                               5857 5888  D0A               87
0098 I                               5889 5920  D1A               88
0099 I                               5921 5952  D2A               89
0100 I                               5953 5984  D3A               90
0101 I                               5985 6016  D4A               91
0102 I                               6017 6048  D5A               92
0103 I                               6049 6080  D6A               93
0104 IINPUTR    NS  01
0105 I                                  1 4048  DA
0106 I                               4049 4064  DB                30
0107 I                               4065 4096  DC                31
0108 I                               4097 4128  DD                32
0109 I                               4129 4160  DE                33
0110 I                               4161 4192  DF                34
0111 I                               4193 4224  DG                35
0112 I                               4225 4256  DH                36
0113 I                               4257 4288  DI                37
0114 I                               4289 4320  DJ                38
0115 I                               4321 4352  DK                39
0116 I                               4353 4384  DL                40
0117 I                               4385 4416  DM                41
0118 I                               4417 4448  DN                42
0119 I                               4449 4480  DZ                43
0120 I                               4481 4512  DO                44
0121 I                               4513 4544  DP                45
0122 I                               4545 4576  DQ                46
0123 I                               4577 4608  DR                47
0124 I                               4609 4640  DS                48
0125 I                               4641 4672  DT                49
0126 I                               4673 4704  DU                50
0127 I                               4705 4736  DV                51
0128 I                               4737 4768  DW                52
0129 I                               4769 4800  DX                53
0130 I                               4801 4832  DY                54
0131 I                               4833 4864  D0                55
0132 I                               4865 4896  D1                56
0133 I                               4897 4928  D2                57
0134 I                               4929 4960  D3                58
0135 I                               4961 4992  D4                59
0136 I                               4993 5024  D5                60
0137 I                               5025 5056  D6                61
0138 I                               5057 5088  DBA               62
0139 I                               5089 5120  DCA               63
0140 I                               5121 5152  DDA               64
0141 I                               5153 5184  DEA               65
0142 I                               5185 5216  DFA               66
0143 I                               5217 5248  DGA               67
0144 I                               5249 5280  DHA               68
0145 I                               5281 5312  DIA               69
0146 I                               5313 5344  DJA               70
0147 I                               5345 5376  DKA               71
0148 I                               5377 5408  DLA               72
0149 I                               5409 5440  DMA               73
0150 I                               5441 5472  DNA               74
0151 I                               5473 5504  DOA               75
0152 I                               5505 5536  DPA               76
0153 I                               5537 5568  DQA               77
0154 I                               5569 5600  DRA               78
0155 I                               5601 5632  DSA               79
0156 I                               5633 5664  DTA               80
0157 I                               5665 5696  DUA               81
0158 I                               5697 5728  DVA               82
0159 I                               5729 5760  DWA               83
0160 I                               5761 5792  DXA               84
0161 I                               5793 5824  DYA               85
0162 I                               5825 5856  DZA               86
0163 I                               5857 5888  D0A               87
0164 I                               5889 5920  D1A               88
0165 I                               5921 5952  D2A               89
0166 I                               5953 5984  D3A               90
0167 I                               5985 6016  D4A               91
0168 I                               6017 6048  D5A               92
0169 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 = 4048;

             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;

               SELECT;
                WHEN  *INU1;
                 RRN = RN1;
                WHEN  *INU2;
                 RRN = RN2;
               ENDSL;
        // IF GOT RECORDS WRITE DATA TO THE DISPLAY

             NEWRU  = '1';
             WRTRRN = '1';
            RU    = *ALLX'00';
            CLEAR  RU;        //  initialise Request Unit  255 bytes max

          IF RRN > 0    ;
            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 ;
              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;
          ENDIF;

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

         NUSA= *BLANKS;
           FOR VX = 1 TO 60;
             NUSA = %TRIM(NUSA) + NU(VX);
           ENDFOR;
             NUC  = NUS;

         IF  Q(Y) = 2 ;
              DISBIN  ( NUC : BAN2 : BAN4  : '2');
            %SUBST(DATA : W : 2)   =   BAN2;
         ENDIF;

         IF  Q(Y) = 4 ;
              DISBIN  ( NUC : BAN2 : BAN4  : '4');
            %SUBST(DATA : W : 4)   =   BAN4;
         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


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

DSPFL CMD

  /*   TO COMPILE */
  /*   CRTCMD CMD(*CURLIB/DSPFL) PGM(*LIBL/DIS) SRCFILE(*LIBL/QCMDSRC) */
  /*          SRCMBR(DSPFL) VLDCKR(DISV) */
  
             CMD        PROMPT('Display file in field format')

             PARM       KWD(FILE) TYPE(QUAL1) MIN(1) MAX(1) +
                          PROMPT('File')

             PARM       KWD(MBR) TYPE(*NAME) DFT(*FIRST) +
                          SPCVAL((*FILE) (*FIRST)) MIN(0) MAX(1) +
                          PROMPT('Member')

             PARM       KWD(UPD ) TYPE(*CHAR) LEN(1) DFT(N) +
                          RSTD(*YES) VALUES('Y' 'N' 'y' 'n') +
                          PROMPT('Update data (Y/N)')

             PARM       KWD(RST ) TYPE(*CHAR) LEN(1) DFT(N) +
                          RSTD(*YES) VALUES('Y' 'N' 'y' 'n') +
                          PROMPT('Get DDS again.')

             PARM       KWD(REL ) TYPE(*CHAR) LEN(1) DFT(N) +
                          RSTD(*YES) VALUES('Y' 'N' 'y' 'n') +
                          PROMPT('Show Relations')


 QUAL1:      QUAL       TYPE(*NAME) LEN(10)
             QUAL       TYPE(*NAME) LEN(10) DFT(*LIBL  ) +
                          SPCVAL(*LIBL  ) +
                          PROMPT('Library name')


#top

DIS CL


/* Command processing program for DSPFF command */

PGM (&FILIB  &MBR &UPD &RST &REL)

DCL &FILIB *CHAR 20
DCL &FILE *CHAR  10
DCL &LIB  *CHAR  10
DCL &SFILE *CHAR  10
DCL &SLIB  *CHAR  10
DCL &MBR  *CHAR  10
DCL &OPT  *CHAR  10
DCL &ALL  *CHAR 1
DCL &RTN  *CHAR 1
DCL &RMBR  *CHAR  10

DCL &QRY  *LGL
DCL &UPD  *LGL
DCL &REL  *CHAR 1
DCL &RST  *CHAR 1

DCL &RCDL *CHAR 5
DCL &RCDLN *DEC (5 0)
DCL &ACCP *CHAR 1
DCL &OVR  *LGL  VALUE('0')
DCL &FILEF *CHAR  10
DCL &FILEK *CHAR  10
DCL &ID    *CHAR  7
DCL &MF    *CHAR  10
DCL &ML    *CHAR  10
DCL &TYPE  *CHAR  1
DCL &PHY   *CHAR  10
DCL &PHYLIB *CHAR  10

RMVLIBLE QTEMP
MONMSG CPF0000
ADDLIBLE QTEMP *FIRST
MONMSG CPF0000 EXEC(GOTO END)

RESET:
CHGVAR &FILE  &FILIB
CHGVAR &LIB   (%SST(&FILIB 11 10))
IF (&LIB *EQ ' ')     (CHGVAR &LIB '*LIBL')
IF (&MBR *EQ '*FILE') (CHGVAR &MBR &FILE)
IF (&MBR *EQ '*FIRST') (DO)
 RTVMBRD    FILE(&LIB/&FILE) RTNMBR(&RMBR)
 CHGVAR &MBR &RMBR
ENDDO
CHGVAR &FILEF ('FF'||(%SST(&FILE 1 8)))
CHGVAR &FILEK ('KF'||(%SST(&FILE 1 8)))

IF (&RST= 'Y') DO
DLTF   &FILEF
MONMSG CPF0000
DLTF   &FILEK
MONMSG CPF0000
ENDDO


CHKOBJ (QTEMP/&FILEF) *FILE
  MONMSG CPF9801 EXEC(DO)
  DSPFFD  FILE(&LIB/&FILE) OUTPUT(*OUTFILE) OUTFILE(QTEMP/&FILEF)
  DSPFD (&LIB/&FILE) TYPE(*ACCPTH) OUTPUT(*OUTFILE) OUTFILE(QTEMP/&FILEK)
  CHGVAR &RTN '2'
ENDDO

CHGPF QTEMP/&FILEF LVLCHK(*NO)
CHGPF QTEMP/&FILEK LVLCHK(*NO)

IF (&REL = 'Y' ) DO
  CALL DISF  (&FILEK &TYPE &PHY &PHYLIB)
  IF (&TYPE *EQ 'P') DO
    CHGVAR &PHY &FILE
    CHGVAR &PHYLIB &LIB
   ENDDO
CALL  DIS3 (&PHY &PHYLIB &SFILE &SLIB)
 IF (&SFILE *NE ' ') DO
  IF ((&SFILE *NE &FILE) *OR (&SLIB *NE &LIB)) DO
   CHGVAR &FILIB (&SFILE||&SLIB)
   CHGVAR &REL '0'
   RTVMBRD    FILE(&SLIB/&SFILE) RTNMBR(&RMBR)
   CHGVAR &MBR &RMBR
  IF (&MBR  *EQ &FILE) THEN(CHGVAR &MBR '*FILE     ')
  GOTO  RESET
  ENDDO
 ENDDO
ENDDO

CALL  DIS1 (&FILIB  &MBR &UPD &RST &RTN &FILE &LIB &FILEF &FILEK)

RCLRSC

END:
CLOF  OPNID(&FILE)
MONMSG CPF0000



ENDPGM

#top

DIS1 CL

/* CALLED BY DIS TO DRIVE SELECTION OF UDDS RPG PROGRAM */
/*  FILE DISPLAYER DRIVER  */
/*  SHOWS A LIST OF FIELDS IN A FILE , ALLOWS SELECTION OF FIELDS  */

/*  WHEN ALL THE FIELDS DONT FIT ON ONE SCREEN                 */
/*  THIS CONTAINS A LOOP SO THAT MORE FIELDS CAN BE DISPLAYED  */


PGM (&FILIB  &MBR &UPD &RST &RTN &FILE &LIB &FILEF &FILEK)

DCL &FILIB *CHAR 20
DCL &FILE *CHAR  10
DCL &LIB  *CHAR  10
DCL &MBR  *CHAR  10
DCL &PRG  *CHAR  10
DCL &OPT  *CHAR  10
DCL &ALL  *CHAR 1
DCL &RTN  *CHAR 1
DCL &RMV  *CHAR 1
DCL &QRY  *LGL
DCL &UPD  *CHAR 1
DCL &RST  *LGL
DCL &KEYL *CHAR 4
DCL &RCDL *CHAR 5
DCL &RCDLN *DEC (5 0)
DCL &ACCP *CHAR 1
DCL &OVR  *LGL  VALUE('0')
DCL &FILEF *CHAR  10
DCL &FILEK *CHAR  10
DCL &ID    *CHAR  7
DCL &MF    *CHAR  10
DCL &ML    *CHAR  10
DCL &SCNLV *CHAR  500
DCL &SCNLVL *CHAR  5
DCL &SCNKEY *CHAR  800
DCL &JOB   *CHAR  10
DCL &MSG   *CHAR  80
DCLF    DISPX

CHGVAR &PGMQ DIS
CHGVAR &SCNLVL '00000'

OVRDBF FFD QTEMP/&FILEF SECURE(*YES)
OVRDBF KF  QTEMP/&FILEK SECURE(*YES)


RTN:
OVRDBF   INPUT   &LIB/&FILE   SHARE(*NO)
CALL  DISPY     (&ALL &RTN &KEYL &ACCP &QRY &RCDL)
             MONMSG     MSGID(CPF5035 CPF5029 RNQ1299 RNX0000) EXEC(DO)
             RTVJOBA    JOB(&JOB)
             SNDBRKMSG  MSG('Cannot handle this file type. Possibly +
                          has NULL data field.') TOMSGQ(&job) +
                          MSGTYPE(*INQ) RPYMSGQ(&job)

  goto end
ENDDO

DLTOVR   INPUT
MONMSG CPF0000

IF (&RTN *EQ '1') (GOTO END)

IF (&ACCP *EQ 'K') DO
 CHGJOB SWS(10XXXXXX)
 OVRDBF     FILE(INPUTK) TOFILE(&LIB/&FILE) MBR(&MBR) +
         SHARE(*YES) SEQONLY(*NO)  SECURE(*YES)
IF (&QRY )   DO
 REMSG:

 REQRY:      SNDRCVF    RCDFMT(SLT)
             IF (&IN01 *OR &IN02) GOTO BYQRY
             CHGVAR &OPT '*INP'
             IF (&UPD *EQ 'Y') (CHGVAR &OPT '*ALL')
             OPNQRYF    FILE((INPUTK)) OPTION(&OPT) QRYSLT(&QSLT) +
                          KEYFLD(*FILE) SEQONLY(*NO)
             MONMSG CPF9899 EXEC(DO)
             RCVMSG     MSGTYPE(*ANY)
             SNDF       RCDFMT(SLTC)
             GOTO REMSG
                                ENDDO
                       ENDDO
              ENDDO
BYQRY:
IF (&ACCP *EQ 'A') DO
            CHGJOB SWS(01XXXXXX)
           OVRDBF     FILE(INPUTR) TOFILE(&LIB/&FILE) MBR(&MBR) +
                          SHARE(*YES) SEQONLY(*NO) SECURE(*YES)
     IF (&QRY )         DO
 REMSGA:

 REQRYA:     SNDRCVF    RCDFMT(SLT)
             IF (&IN01 *OR &IN02) GOTO BYQRYA
             CHGVAR &OPT '*INP'
             IF (&UPD = 'Y') (CHGVAR &OPT '*ALL')
             OPNQRYF    FILE((INPUTR)) OPTION(&OPT) QRYSLT(&QSLT) +
                          KEYFLD(*FILE) SEQONLY(*NO)
             MONMSG CPF9899 EXEC(DO)
                RCVMSG     MSGTYPE(*ANY)
                SNDF       RCDFMT(SLTC)
                GOTO REMSGA
                CHGVAR     VAR(&IN20) VALUE('1')
    SDAMSG:     RCVMSG     RMV(*NO) MSG(&MSG)
                IF         COND(&MSG ¬= ' ') THEN(DO)
                SNDPGMMSG  MSG(&MSG)
                GOTO       SDAMSG
                ENDDO
                SNDF       RCDFMT(SLTC)
                GOTO       REMSGA
                                ENDDO

                    ENDDO
            ENDDO
BYQRYA:
CHGVAR &RCDLN &RCDL

IF ( &UPD= 'Y') (DO)
 IF ((&RCDLN *GT    0) *AND (&RCDLN *LE 2048)) (CHGVAR &PRG 'DUSP ')
 IF ((&RCDLN *GT 2048) *AND (&RCDLN *LE 4048)) (CHGVAR &PRG 'DUSP1')
 IF ((&RCDLN *GT 4048) *AND (&RCDLN *LE 6080)) (CHGVAR &PRG 'DUSP2')
           ENDDO
IF (&UPD *NE 'Y') (DO)
 IF ((&RCDLN *GT    0) *AND (&RCDLN *LE 2048)) (CHGVAR &PRG 'DISP ')
 IF ((&RCDLN *GT 2048) *AND (&RCDLN *LE 4048)) (CHGVAR &PRG 'DISP1')
 IF ((&RCDLN *GT 4048) *AND (&RCDLN *LE 6080)) (CHGVAR &PRG 'DISP2')
           ENDDO


 CALL  &PRG  (&ALL &RTN &KEYL &UPD &SCNLV  &SCNLVL &SCNKEY)

IF (&QRY )  (DO)
   IF (&ACCP *EQ 'K') DO
   CLOF     INPUTK
   MONMSG CPF0000
                   ENDDO
   IF (&ACCP *EQ 'A') DO
   CLOF     INPUTR
   MONMSG CPF0000
                   ENDDO
ENDDO

IF (&RTN *EQ '3') DO
  GOTO BYQRYA
  ENDDO

IF (&RTN *EQ '1') DO
  CHGVAR &RTN '0'
  GOTO RTN
  ENDDO



END:  ENDPGM

#top

DIS3 CL


/* CALL BY DIS TO SHOW FILE RELATIONS / ACCESS PATHS */

PGM  (&PHY &PHYLIB &SFILE &SLIB)

/* DISPLAY ACCESS PATHS */

DCL &PHY    *CHAR  10
DCL &PHYLIB *CHAR  10
DCL &SFILE  *CHAR  10
DCL &SLIB   *CHAR  10


DCLF QTEMP/DBR

/* CREATE WORK FILES */
CALL  DIS4

DLTF QTEMP/DBR
MONMSG CPF0000

 DSPDBR     FILE(&PHYLIB/&PHY) OUTPUT(*OUTFILE) +
   OUTFILE(QTEMP/DBR) OUTMBR(*FIRST *REPLACE)
 CHGPF QTEMP/DBR LVLCHK(*NO)

NEXT: RCVF
 MONMSG CPF0000 EXEC(GOTO END)
 IF (&WHREFI *NE ' ') DO
 DSPFD      FILE(&WHRELI/&WHREFI) TYPE(*ACCPTH) +
         OUTPUT(*OUTFILE) OUTFILE(QTEMP/REL) OUTMBR(*FIRST *ADD)
 CHGPF QTEMP/REL LVLCHK(*NO)
 DSPFD      FILE(&WHRELI/&WHREFI) TYPE(*SELECT) +
         OUTPUT(*OUTFILE) OUTFILE(QTEMP/SEL) OUTMBR(*FIRST *ADD)
 CHGPF QTEMP/SEL LVLCHK(*NO)
         ENDDO
GOTO NEXT

END:
 DSPFD      FILE(&PHYLIB/&PHY   ) TYPE(*ACCPTH) +
         OUTPUT(*OUTFILE) OUTFILE(QTEMP/REL) OUTMBR(*FIRST *ADD)
 CHGPF QTEMP/REL LVLCHK(*NO)

CHGVAR &SFILE '          '
CHGVAR &SLIB  '          '

OVRDBF SEL QTEMP/SEL
OVRDBF REL QTEMP/REL
CALL  DISPR (&SFILE &SLIB)
DLTOVR *ALL

ENDPGM

#top

DIS4 CL


/* CALL BY DIS3 TO CREATE WORK FILES */

PGM

DCL  &LIB *CHAR 10
DCL  &SRCF *CHAR 10

RTVDTAARA DTAARA(UDDSSRC *ALL)  RTNVAR(&SRCF)

DLTF  QTEMP/XXXXFILE
monmsg cpf0000
CRTPF      FILE(QTEMP/XXXXFILE) RCDLEN(80) OPTION(*NOLIST)

DSPFFD  FILE(QTEMP/XXXXFILE) OUTPUT(*OUTFILE) OUTFILE(QTEMP/FFD)
CLRPFM  QTEMP/FFD
DLTF   FILE(QTEMP/FFDL01)
MONMSG CPF0000

RTVMBRD FILE(&SRCF) RTNLIB(&LIB)
CRTLF FILE(QTEMP/FFDL01) SRCFILE(&LIB/&SRCF) SRCMBR(FFDL01) +
OPTION(*NOSRC *NOLIST)

DLTF   FILE(QTEMP/REL)
MONMSG CPF0000
DLTF   FILE(QTEMP/SEL)
MONMSG CPF0000
DLTF   FILE(QTEMP/DBR)
MONMSG CPF0000

DSPFD      FILE(QTEMP/FFD) TYPE(*ACCPTH) +
  OUTPUT(*OUTFILE) OUTFILE(QTEMP/REL) OUTMBR(*FIRST *ADD)

DSPFD FILE(QTEMP/FFDL01) TYPE(*SELECT) OUTPUT(*OUTFILE) OUTFILE(QTEMP/SEL)
CLRPFM FILE(QTEMP/REL)
CLRPFM FILE(QTEMP/SEL)

DLTF  QTEMP/XXXXFILE
monmsg cpf0000


ENDPGM

#top

DISBIN CL

/* NUMERIC TO BINARY CONVERTER  */


PGM (&NUM  &BIN2  &BIN4 &BINTYP  )

DCL  VAR(&NUM) TYPE(*DEC) LEN(15 0)
DCL VAR(&BINTYP) TYPE(*CHAR) LEN(1)
DCL VAR(&BIN2) TYPE(*CHAR) LEN(2)
DCL VAR(&BIN4) TYPE(*CHAR) LEN(4)

IF (&BINTYP = '4') (CHGVAR %BIN(&BIN4) &NUM)
IF (&BINTYP = '2') (CHGVAR %BIN(&BIN2) &NUM)
ENDPGM

#top

DISF CL


/* CHECK FILE TYPE */

PGM (&DISF &TYPE &PHY &PHYLIB)


DCL  &DISF   *CHAR 10
DCL  &TYPE   *CHAR 1
DCL  &PHY    *CHAR 10
DCL  &PHYLIB *CHAR 10
DCLF KF

             OVRDBF     FILE(KF) TOFILE(QTEMP/&DISF)
             OPNDBF     FILE(KF) OPTION(*INP)
             RCVF
             CHGVAR &TYPE &APFTYP

             IF (&TYPE *EQ 'L') DO
             CHGVAR &PHY &APBOF
             CHGVAR &PHYLIB &APBOL
             ENDDO

             CLOF       OPNID(KF)
ENDPGM

#top


DISV CL

/* VALIDITY CHECKER FOR DSPFL COMMAND */


PGM (&FILIB   &MBR &UPD &RST &REL)

DCL &FILIB  *CHAR 20
DCL &FILE *CHAR  10
DCL &LIB  *CHAR  10
DCL &MBR  *CHAR  10
DCL &UPD  *CHAR  1
DCL &RST  *CHAR  1
DCL &REL  *CHAR  1
DCL &OBJATR *CHAR 10
DCL &AUT    *CHAR  8

DCL &MSGDTA *CHAR 40
DCL &ERROR  *LGL

CHGVAR &FILE  &FILIB
CHGVAR &LIB   (%SST(&FILIB 11 10))
IF (&MBR *EQ '*FILE') (CHGVAR &MBR  &FILE  )

CHGVAR &AUT '*READ   '
IF ((&UPD *EQ 'Y') *OR (&UPD *EQ 'y')) (CHGVAR &AUT '*CHANGE')

CHKOBJ   (&LIB/&FILE) OBJTYPE(*FILE) MBR(*NONE)  +
  AUT( &AUT   )
  MONMSG (CPF9899 CPF9801 CPF9802  CPF9820 CPF9830) EXEC(DO)
/*  CHGVAR (&MSGDTA) VALUE('    '||&FILE||&LIB)                   */
/*  SNDPGMMSG MSGID(USR0006) MSGF(*LIBL/QUSERMSG) MSGTYPE(*DIAG) +*/
/*            MSGDTA(&MSGDTA)                                     */
    SNDPGMMSG  MSG('Not authorised to the file.') +
                          MSGTYPE(*DIAG)
    CHGVAR (&ERROR) '1'
  ENDDO
  MONMSG (CPF9810) EXEC(DO)
    CHGVAR (&MSGDTA) VALUE('    '||&LIB)
/*  SNDPGMMSG MSGID(USR0008) MSGF(*LIBL/QUSERMSG) MSGTYPE(*DIAG)  +*/
/*            MSGDTA(&MSGDTA)                                      */
    SNDPGMMSG  MSG('Not authorised to the file.') +
                          MSGTYPE(*DIAG)
    CHGVAR (&ERROR) '1'
  ENDDO


IF (*NOT &ERROR) DO

RTVOBJD    OBJ(&LIB/&FILE) OBJTYPE(*FILE) OBJATR(&OBJATR)
CHGVAR &AUT '*READ   '
IF ((&UPD *EQ 'Y') *OR (&UPD *EQ 'y')) (CHGVAR &AUT '*CHANGE')

CHKOBJ     OBJ(&LIB/&FILE) OBJTYPE(*FILE) MBR(&MBR) +
                          AUT(&AUT)

  MONMSG (CPF9815 )  EXEC(DO)
/*  CHGVAR (&MSGDTA) VALUE('    '||&MBR||&FILE||&LIB)              */
/*  SNDPGMMSG MSGID(USR0007) MSGF(*LIBL/QUSERMSG) MSGTYPE(*DIAG) + */
/*            MSGDTA(&MSGDTA)                                      */
             SNDPGMMSG  MSG('Not authorised to the file.') +
                          MSGTYPE(*DIAG)
    CHGVAR (&ERROR) '1'
  ENDDO
  MONMSG (CPF0000 )  EXEC(DO)
/*  SNDPGMMSG MSGID(USR0022) MSGF(*LIBL/QUSERMSG) MSGTYPE(*DIAG) + */
/*            MSGDTA(&MSGDTA)                                      */
             SNDPGMMSG  MSG('Not authorised to the file.') +
                          MSGTYPE(*DIAG)
    CHGVAR (&ERROR) '1'
  ENDDO
ENDDO

IF (&ERROR)   (SNDPGMMSG MSGID(CPF0002) MSGF(QCPFMSG) MSGTYPE(*ESCAPE))



ENDPGM

#top


DISPR RPG

     H OPTIMIZE(*NONE) OPTION(*NODEBUGIO)
     H DFTACTGRP(*NO) ACTGRP(*CALLER)

      *    FILE RELATIONS DISPLAYER
      * REQUIRES FILES TO COMPILE
      *

     FREL       IF   E             DISK
     FSEL       IF   E             DISK
     FDISPRF    CF   E             WORKSTN
     F                                     SFILE(S01:RS01)
     F                                     SFILE(S02:RS02)
     F                                     INFDS(SFINF)
      *

      *
     DDISPR            PR
     D                               10
     D                               10
     DDISPR            PI
     D  SFILE                        10
     D  SLIB                         10

      //  SCREEN LEVELS
     D @SCN            S              6    DIM(50)
     D @NSCN           S              6
     D @LV             S              5  0
     D @ERR            S                   LIKE(@TRUE)
     D @FILE           S             10A   INZ('DISPY  ')
     D WRKSWS          S              1
     D I               S              4B 0


     D @TRUE           S              1A   INZ('1')
     D @FALSE          S              1A   INZ('0')
     D @OK             S                   LIKE(@TRUE)
     D @LOOP           S                   LIKE(@TRUE)

      //
     D RS01            S              4S 0
     D RS02            S              4S 0
      //
      // PARMS FOR SFL LOOPING
     D SFC01           S                   LIKE(RS01)
     D SFC02           S                   LIKE(RS01)

      // Program Status
     D                SDS
     D  PGM                    1     10
     D  WSID                 244    253
     D  USER                 254    263
      //
      //
     D SFINF           DS
     D  RRRN                 376    377B 0
     D  SRN                  378    379B 0

      //  MESSAGE DATA
     D @DTA1           DS            80
     D @DTA2           DS           500
      //
     D MAIN            PR

     D @S01BLD         PR
     D @S01PRC         PR
     D @S01PRS         PR
     D @S02BLD         PR
     D @S02PRC         PR
     D
     D @R9999          PR

     D @OPADJ          PR             2A
     D  OPT                           2A


      /FREE
            *INLR = *ON;
            MAIN();


       //--------------*INZSR-------------------------------//
           BEGSR   *INZSR;

        //  Set the TOP level (Exit if user backs up to here)
              @LV = 1;
              @SCN(@LV)  = '*END  ';
        //  Set the Initial Screen to display
              @LV = @LV + 1;
              @SCN(@LV) = 'S01BLD ';

            ENDSR;
      /END-FREE
       //###################################################//

        //*************************************************************
     P    MAIN         B

     D MAIN            PI

     D I               S              4B 0

      /FREE
          EXSR      @INZSR;
       //
       // THIS IS THE CONTROLLING LOOP TO DRIVE THE NEXT PANEL TO DISPLAY
          DOW       @LOOP = @LOOP;
       // GET THE SCREEN NAME FROM THE SCREEN STACK ARRAY
            @NSCN  = @SCN(@LV);
          SELECT;
         //  SELECT FIELDS FOR DISPLAY

         // SFL TO SELECT THE FILE FIELDS
           WHEN      @NSCN = 'S01BLD';
                             @S01BLD();
           WHEN      @NSCN = 'S01PRC';
                             @S01PRC();
           WHEN      @NSCN = 'S01PRS';
                             @S01PRS();
           WHEN      @NSCN = 'S02BLD';
                             @S02BLD();
           WHEN      @NSCN = 'S02PRC';
                             @S02PRC();
          OTHER;
            //  CATCH ALL (NEVER USED)
              @R9999();
              LEAVE;
          ENDSL;

        //  CF3 EXIT
          IF  *IN03 = *ON;
            LEAVE;
          ENDIF;

       //   CF12 PREVIOUS
          IF  *IN12 = *ON;
               *IN12 = *OFF;
               @LV   = @LV -1;
               @NSCN = @SCN(@LV);
          ENDIF;

       //  Backed out to last level, Exit
          IF     @NSCN = '*END';
                   LEAVE;
          ENDIF;

         ENDDO;

         RETURN;

       //--------------*INZSR-------------------------------//
           BEGSR   @INZSR;
              @NSCN = *BLANK;

          ENDSR;
       //-ENDSR---*INZSR-------------------------------//
      /END-FREE

     P    MAIN         E


       //###################################################//
       //###################################################//
       //###################################################//
      /space 3
     P @S01BLD         B

     D @S01BLD         PI

     D WFILE           S                   LIKE(APFILE )
     D WLIB            S                   LIKE(APLIB  )

          //  Build/Rebuild the subfile

      /FREE
           EXSR      @INZSR;

           EXSR      BLD;

         //  SFL IS BUILT, PROCESS THE SFL CONTROL
           @LV = @LV + 1;
           @SCN(@LV) = 'S01PRC ' ;
            RETURN ;

       //--------------  BLD -------------------------------//
           BEGSR     BLD;

            EXSR      CLR;


          SETLL 1    QWHFDACP;

          DOW @LOOP = @LOOP;
          READ      QWHFDACP;
          IF %EOF;
           LEAVE;
          ENDIF;


          EXSR MOV;
          //
           RS01   = RS01 + 1;
          WRITE S01;
         ENDDO;


         // Position to TOP of subfile
            SRS01 = 1;
            SFC01 = RS01;
           ENDSR;

       //--------------  CLR -------------------------------//
           BEGSR   CLR;

               *IN51 = *OFF;
               *IN52 = *OFF;
               *IN53 = *ON;
               WRITE     C01;
               *IN53 = *OFF;
               RS01  = 0   ;
               SFC01 = 0   ;
               S01FUNC = *BLANK;
               ENDSR;

       //--------------  MOV -------------------------------//
           BEGSR   MOV;

            C01APBOF =  APBOF ;
            C01APBOL =  APBOL ;

           IF APBOF = *BLANK AND APBOL =  *BLANK;
           C01APBOF = APFILE;
           C01APBOL = APLIB;
           ENDIF;

         //  Load the subfile record

          IF APFILE = WFILE  AND
             APLIB  = WLIB ;
             *IN56 = *ON ;
                  S01APFILE  =   *BLANK;
                  S01APLIB   =   *BLANK;
                  S01APACCP  =   *BLANK;
                  S01APUNIQ  =   *BLANK;
                  S01APSELO  =   *BLANK;
                  S01APFTYP  =   *BLANK;
                  S01APJOIN  =   *BLANK;
                  S01APKEYO  =   *BLANK;
                  S01APKSEQ  =   APKSEQ ;
                  S01APKSIN  =   APKSIN ;
                  S01APKEYF  =   APKEYF ;
            ELSE       ;
             WFILE = APFILE;
             WLIB  = APLIB ;
             *IN56 = *OFF;
                  S01APFILE  =   APFILE ;
                  S01APLIB   =   APLIB  ;
                  S01APACCP  =   APACCP ;
                  S01APUNIQ  =   APUNIQ ;
                  S01APSELO  =   APSELO ;
                  S01APFTYP  =   APFTYP ;
                  S01APJOIN  =   APJOIN ;
                  S01APKEYO  =   APKEYO ;
                  S01APKSEQ  =   APKSEQ ;
                  S01APKSIN  =   APKSIN ;
                  S01APKEYF  =   APKEYF ;
          ENDIF;

           ENDSR;

       //--------------*INZSR-------------------------------//
           BEGSR     @INZSR;
               @NSCN = *BLANK;
           ENDSR;
      /END-FREE

     P @S01BLD         E

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

      /space 3
     P @S01PRC         B

     D @S01PRC         PI

          //
          //
     D WRKRC           S              4S 0

      /FREE
           EXSR      @INZSR;

            WRITE     R01;
       //
            DOW       @LOOP = @LOOP;

           //
           // Write SFL Control
             IF        SFC01 > 0;
                *IN51 = *ON;
             ENDIF;
               *IN52 = *ON;


               EXFMT     C01;
           //  Setoff errors
                 *IN89 = *OFF;
           //
           //  Exit and Previous Screen
             IF        *IN03 = *ON;
                LEAVE;
             ENDIF;
             IF        *IN12 = *ON;
                 LEAVE;
             ENDIF;


         //  Process the subfile
               @LV = @LV + 1;
               @SCN(@LV) = 'S01PRS';
               LEAVE;

            ENDDO;
       //
            RETURN;

      /space 3


       //--------------*INZSR-------------------------------//
           BEGSR     @INZSR;
               @NSCN = *BLANK;
           ENDSR;
      /END-FREE
     P @S01PRC         E

       //###################################################//
       //###################################################//
       //###################################################//
      /space 3
     P @S01PRS         B

     D @S01PRS         PI

          //
          //
     D WRKRC           S              4S 0

      /FREE

          EXSR      @INZSR;

         //  Process the subfile
           EXSR      SFL;
           RETURN;

       //--------------  SFL -------------------------------//
           BEGSR      SFL;
        //  Process the subfile

           FOR       WRKRC = 1 TO SFC01 + 1 ;
               CHAIN  WRKRC   S01;
                 IF        NOT %FOUND;
         //  Finished with the subfile
                    @LV = @LV -1;
                    LEAVE;
                 ENDIF;

         //   GET SELECTED FILE
            IF   @OPADJ(S01FUNC) =   ' X';
               SFILE  = S01APFILE;
               SLIB   = S01APLIB ;
               *IN03 = '1';
                LEAVE;
            ENDIF;


         //   SHOW SELECT RULES
            IF   @OPADJ(S01FUNC) =   ' R';
              @LV = @LV + 1;
              @SCN(@LV) = 'S02BLD ';
                 S01FUNC =  '  ';
                 UPDATE    S01;
              LEAVE;
            ENDIF;

           ENDFOR;

           ENDSR;
       //---------------------------------------------------//



       //--------------*INZSR-------------------------------//
           BEGSR     @INZSR;
               @NSCN = *BLANK;
           ENDSR;


      /END-FREE
     P @S01PRS         E


      /space 3
     P @S02BLD         B

     D @S02BLD         PI

          //  Build/Rebuild the subfile
      /FREE

          EXSR @INZSR;

          C02APFILE  =  S01APFILE ;
          C02APLIB   =  S01APLIB  ;

         EXSR BLD;

         //  SFL IS BUILT, PROCESS THE CONTROL
           @LV = @LV + 1;
           @SCN(@LV) = 'S02PRC ';
       RETURN;
       //--------------  BLD -------------------------------//
       BEGSR   BLD;

         EXSR CLR;


          SETLL 1    QWHFDSO ;

          DOW @LOOP = @LOOP;

          READ      QWHFDSO ;
          IF %EOF;
           LEAVE;
          ENDIF;

          If SOFILE = S01APFILE  AND
             SOLIB  = S01APLIB ;
          EXSR MOV;

          //
           RS02   = RS02 + 1;
          WRITE S02;
          ENDIF;
         ENDDO;

         // Position to TOP of subfile
         SRS02 = 1;
         SFC02 = RS02;
         ENDSR;

       //--------------  CLR -------------------------------//
         BEGSR  CLR;
          *IN51 = *OFF;
          *IN52 = *OFF;
          *IN53 = *ON;
          WRITE C02;
          *IN53 = *OFF;
           RS02 =0;
           SFC02=0;

         ENDSR;

       //--------------  MOV -------------------------------//
        BEGSR  MOV;
         //  Load the subfile record

          S02SOFLD  = SOFLD  ;
          S02SORULE = SORULE ;
          S02SOCOMP = SOCOMP ;
          S02SOVALU = SOVALU ;



         ENDSR;

       //--------------*INZSR-------------------------------//
         BEGSR  @INZSR;
           @NSCN = *BLANK;
         ENDSR;

      /END-FREE
     P @S02BLD         E

       //###################################################//
       //###################################################//
       //###################################################//
      /space 3
     P @S02PRC         B

     D @S02PRC         PI

          //
          //
     D WRKRC           S              4S 0

      /FREE

          EXSR @INZSR;

         WRITE R02;

       //
       DOW @LOOP = @LOOP;

           //
           // Write SFL Control
           IF SFC02 > 0;
             *IN51 = *ON;
           ENDIF;
           *IN52 = *ON;
           EXFMT C02;
           //
           //  Setoff errors
           *IN89 = *OFF;
           //
           //  Exit and Previous Screen

           @LV = @LV -2;
             LEAVE;


         //  Process the subfile

       ENDDO;
       //
       RETURN;

      /space 3
       //--------------*INZSR-------------------------------//
         BEGSR  @INZSR;

           @NSCN = *BLANK;
         ENDSR;
      /END-FREE
     P @S02PRC         E


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

     P @R9999          B
        //  Invalid Panel
     D @R9999          PI

     P @R9999          E


      /space 3
       //###################################################//
       //###################################################//
       //###################################################//
     P @OPADJ          B
        //   RIGHT ADJ OPTION , zero suppress

     D @OPADJ          PI             2A
     D  OPT                           2A

      /FREE
         EVALR  OPT   = %trimr(OPT);
         If %SubSt(OPT:1:1) =  '0';
         OPT   = ' ' +  %SubSt(OPT:2:1);
         EndIf;
         RETURN OPT;
      /END-FREE
     P @OPADJ          E

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

#top

DISPRF DSPF


     A*%%TS  SD  20101208  163705  KOLMANNF    REL-V5R4M0  5722-WDS
     A*
      * REQUIRES FILES TO COMPILE
      *   CRTDUPOBJ  OBJ(QAFDSELO) FROMLIB(QSYS)
      *              OBJTYPE(*FILE) TOLIB(QTEMP) NEWOBJ(SEL)
      *   CRTDUPOBJ  OBJ(QAFDACCP) FROMLIB(QSYS)
      *         OBJTYPE(*FILE) TOLIB(QTEMP) NEWOBJ(ACC)


     A*%%EC
     A                                      DSPSIZ(24 80 *DS3)
     A                                      PRINT
     A                                      CF03(03)
     A                                      CF12(12)
     A          R S01                       SFL
     A*%%TS  SD  20101208  163705  KOLMANNF    REL-V5R4M0  5722-WDS
     A            S01FUNC        2A  I  4  3
     A  55
     AO 56                                  DSPATR(PR)
     A            S01APFILE R        O  4  6REFFLD(QWHFDACP/APFILE QTEMP/REL)
     A            S01APLIB  R        O  4 17REFFLD(QWHFDACP/APLIB QTEMP/REL)
     A            S01APACCP R        O  4 29REFFLD(QWHFDACP/APACCP QTEMP/REL)
     A            S01APUNIQ R        O  4 33REFFLD(QWHFDACP/APUNIQ QTEMP/REL)
     A            S01APSELO R        O  4 37REFFLD(QWHFDACP/APSELO QTEMP/REL)
     A            S01APFTYP R        O  4 41REFFLD(QWHFDACP/APFTYP QTEMP/REL)
     A            S01APJOIN R        O  4 45REFFLD(QWHFDACP/APJOIN QTEMP/REL)
     A            S01APKEYO R        O  4 48REFFLD(QWHFDACP/APKEYO QTEMP/REL)
     A            S01APKSEQ R        O  4 53REFFLD(QWHFDACP/APKSEQ QTEMP/REL)
     A            S01APKSIN R        O  4 57REFFLD(QWHFDACP/APKSIN QTEMP/REL)
     A            S01APKEYF R        O  4 61REFFLD(QWHFDACP/APKEYF QTEMP/REL)
     A          R C01                       SFLCTL(S01)
     A*%%TS  SD  20101208  163705  KOLMANNF    REL-V5R4M0  5722-WDS
     A                                      SFLSIZ(0019)
     A                                      SFLPAG(0018)
     A                                      OVERLAY
     A  50                                  SFLEND
     A  51                                  SFLDSP
     A  52                                  SFLDSPCTL
     A  53                                  SFLCLR
     A            SRS01          4S 0H      SFLRCDNBR(CURSOR)
     A*
     A                                  1 18'FILE RELATIONS for '
     A            C01APBOF  R        O  1 39REFFLD(QWHFDACP/APBOF QTEMP/REL)
     A                                  1 51'Lib.'
     A            C01APBOL  R        O  1 56REFFLD(QWHFDACP/APBOL QTEMP/REL)
     A                                  2 32'Uni SEL         LIFO ASC Key'
     A                                  3  6'File       Library    Acc Key OMT -
     A                                      TYP  J  FIFO DSC Sgn Key'
     A          R R01
     A                                 24  3'F3-Exit'
     A                                 22  3'R - Display Select/Omit rules'
     A                                 23  3'X - Select for display'
      *
     A          R R02
     A                                 24  3'F3-Exit'
     A          R S02                       SFL
     A                                      SFLNXTCHG
     A            S02SOFLD  R        O  4  4REFFLD(QWHFDSO/SOFLD QTEMP/SEL)
     A            S02SORULE R        O  4 17REFFLD(QWHFDSO/SORULE QTEMP/SEL)
     A            S02SOCOMP R        O  4 22REFFLD(QWHFDSO/SOCOMP QTEMP/SEL)
     A            S02SOVALU R        O  4 28REFFLD(QWHFDSO/SOVALU QTEMP/SEL)

     A          R C02                       SFLCTL(S02 )
     A                                      OVERLAY
     A  50                                  SFLEND
     A  51                                  SFLDSP
     A  52                                  SFLDSPCTL
     A  53                                  SFLCLR
     A                                      SFLSIZ(0019)
     A                                      SFLPAG(0018)
     A            SRS02          4S 0H      SFLRCDNBR(CURSOR)
     A*
     A                                  1  6'FILE SELECTS   for '
     A            C02APFILE R        O  2  7REFFLD(QWHFDSO/SOFILE QTEMP/SEL)
     A                                  2 20'Lib.'
     A            C02APLIB  R        O  2 25REFFLD(QWHFDSO/SOLIB QTEMP/SEL)
     A                                  3  4'Field'
     A                                  3 28'Select/Omit Value'
     A                                  3 16'S/O'
     A                                  3 21'COMP'

#top


DISPY RPG

     H OPTIMIZE(*NONE) OPTION(*NODEBUGIO)
     H DFTACTGRP(*NO) ACTGRP(*CALLER)

      //***************************************************************
      //
      //  PROGRAM ID : DISPY
      //  Description: DISPLAY A FILES FIELDS FOR SELECTION

      //    needs files KF  FFD to compile use following commands
      // DSPFD (&LIB/&FILE) TYPE(*ACCPTH) OUTPUT(*OUTFILE) OUTFILE(QTEMP/KF)
      // DSPFFD  FILE(&LIB/&FILE) OUTPUT(*OUTFILE) OUTFILE(QTEMP/FFD)
      //***************************************************************
      // MODIFICATIONS:
      // MOD   SR   DATE    MODIFICATION SUMMARY
      //
      //***************************************************************
      //
     FKF        IF   E             DISK
     FFFD       UF   E             DISK
     FINPUT     IF   F32766  2000AIDISK    KEYLOC(1)
     F                                     INFDS(INFDS)
     FDISPYF    CF   E             WORKSTN
     F                                     SFILE(S01:RS01)
     F                                     INFDS(SFINF)
      //
      //

      //  SCREEN LEVELS
     D @SCN            S              6    DIM(50)
     D @NSCN           S              6
     D @LV             S              5  0
     D @ERR            S                   LIKE(@TRUE)
     D @FILE           S             10A   INZ('DISPY  ')
     D WRKSWS          S              1
     D I               S              4B 0


     D @TRUE           S              1A   INZ('1')
     D @FALSE          S              1A   INZ('0')
     D @OK             S                   LIKE(@TRUE)
     D @LOOP           S                   LIKE(@TRUE)

      //
     D RS01            S              4S 0
      //
      // PARMS FOR SFL LOOPING
     D SFC01           S                   LIKE(RS01)

      // Program Status
     D                SDS
     D  PGM                    1     10
     D  WSID                 244    253
     D  USER                 254    263
      //
      //
     D SFINF           DS
     D  RRRN                 376    377B 0
     D  SRN                  378    379B 0

      //
     D FLD             S             10    DIM(9000)
     D KEY             S             10    DIM(99)

     D INFDS           DS
     D  FILE                  83     92
     D  LIB                   93    102
     D  MBR                  129    138
     D  RCDL                 125    126B 0
     D  RCDS                 156    159B 0
     D  ACCTP                160    160

     D                 DS
     D  WHCOLD                 1     60
     D  WHCHD1                 1     20
     D  WHCHD2                21     40
     D  WHCHD3                41     60

     D                 DS
     D  POSN                   1     10
     D  P1                     1     10    DIM(10)

     D  POSNN                 11     20
     D  P2                    11     20    DIM(10)


      *
      //  MESSAGE DATA
     D @DTA1           DS            80
     D @DTA2           DS           500
      //
     D MAIN            PR

     D @S01BLD         PR
     D @S01PRC         PR
     D @S01PRS         PR
     D
     D @R9999          PR

     D @OPADJ          PR             2A
     D  OPT                           2A

      *
     DDISPY            PR
     D                                1
     D                                1
     D                                4
     D                                1
     D                                1
     D                                5
     DDISPY            PI
     D  ALL                           1
     D  RTN                           1
     D  KEYLNG                        4
     D  ACCP                          1
     D  QRY                           1
     D  RCDLN                         5
      *
     D KEYLN           S              4S 0
     D RCDLEN          S              5S 0
      *-------------------------------------------------------------------
      * QMHRTVM API (Retrieve Message text)
      *-------------------------------------------------------------------
     D  RtvMsgTxt      PR          1024
     D   RMsgId                       7    Const
     D   RMsgFle                     10    Const
     D   RMsgLib                     10    Const
     D   RMsgLvl                      1    Const

     D GETROWCOL       PR
     D                               10A   const
     D                               10A   const
     D                               10A   const
     D                               32A   const
     D                                3P 0
     D                                3P 0

     D SysDate         PR             8S 0
     D SysTime         PR             6S 0
     D DayOfWeek       PR            10I 0
     D                                 D   value datfmt(*iso)
       // Message file names
     D  cMsgLib        C                   Const('*LIBL     ')
     D  cMsgF1         C                   Const('MSGF1     ')
     D  cMsgF2         C                   Const('MSGF2     ')
     D  cMsgLvl1       C                   Const('1')
     D  cMsgLvl2       C                   Const('2')

      *
     IINPUT     NS  01
     I                                  1  256  D

      /FREE
            *INLR = *ON;
            MAIN();


       //--------------*INZSR-------------------------------//
           BEGSR   *INZSR;

        //  Set the TOP level (Exit if user backs up to here)
              @LV = 1;
              @SCN(@LV)  = '*END  ';
        //  Set the Initial Screen to display
              @LV = @LV + 1;
              @SCN(@LV) = 'S01BLD ';

       //    DUMMY I/O TO GET NUMBER OF RECORDS IN FILE
             READ      INPUT;
       //   SFL IS NOT LOADED
       //   READ THE LIST OF KEY FIELDS IN THE FILE SO THAT WE CAN LATER MARK THEM
                  ACCP    = ACCTP;

               I     =   0;

               DOW  @LOOP = @LOOP;
                READ      QWHFDACP;
                IF  %EOF;
                 LEAVE;
                ENDIF;
                 I = I + 1;
                 KEY(I) = APKEYF;
               ENDDO;
            ENDSR;
      /END-FREE
       //###################################################//

        //*************************************************************
     P    MAIN         B

     D MAIN            PI

     D I               S              4B 0

      /FREE
          EXSR      @INZSR;
       //
       // THIS IS THE CONTROLLING LOOP TO DRIVE THE NEXT PANEL TO DISPLAY
          DOW       @LOOP = @LOOP;
       // GET THE SCREEN NAME FROM THE SCREEN STACK ARRAY
            @NSCN  = @SCN(@LV);
          SELECT;
         //  SELECT FIELDS FOR DISPLAY

         // SFL TO SELECT THE FILE FIELDS
           WHEN      @NSCN = 'S01BLD';
              @S01BLD();
           WHEN      @NSCN = 'S01PRC';
              @S01PRC();
           WHEN      @NSCN = 'S01PRS';
              @S01PRS();
          OTHER;
            //  CATCH ALL (NEVER USED)
              @R9999();
              LEAVE;
          ENDSL;

        //  CF3 EXIT
          IF  *IN03 = *ON;
            LEAVE;
          ENDIF;

       //   CF12 PREVIOUS
          IF  *IN12 = *ON;
               *IN12 = *OFF;
               @LV   = @LV -1;
               @NSCN    = @SCN(@LV);
          ENDIF;

       //  Backed out to last level, Exit
          IF     @NSCN = '*END';
                   LEAVE;
          ENDIF;

         ENDDO;

         KEYLNG  = %EDITC(KEYLN:'X');
         RETURN;

       //--------------*INZSR-------------------------------//
           BEGSR   @INZSR;
              @NSCN = *BLANK;
              RCDLEN = RCDL;
              RCDLN = %CHAR(RCDLEN);

       // CLEAR FIELD SELECTIONS
              IF  RTN  =  '2';
                SETLL 1    QWHDRFFD;
               DOW  @LOOP = @LOOP;
                READ      QWHDRFFD ;
                IF  %EOF;
                 LEAVE;
                ENDIF;
                   WHFIOB = ' ';
                   UPDATE    QWHDRFFD;
               ENDDO;

       // SET FILE I/O TO FIRST RCD IN FILE
                SETLL 1    QWHDRFFD;
                   RTN = '0';
              ELSE;
                CHAIN  1  QWHDRFFD;
                SETLL  1  QWHDRFFD;
              ENDIF;
          ENDSR;
       //-ENDSR---*INZSR-------------------------------//
      /END-FREE

     P    MAIN         E


       //###################################################//
       //###################################################//
       //###################################################//
      /space 3
     P @S01BLD         B

     D @S01BLD         PI

     D  SZ             DS             6
     D  LEN1                   1      1
     D  LEN2                   2      3
     D  LEN3                   1      3
     D  COMA                   4      4
     D  DEC1                   5      5
     D  DEC2                   5      6

     D                 DS
     D K                       1      3  0
     D KA                      2      3

          //  Build/Rebuild the subfile

      /FREE
           EXSR      @INZSR;

           EXSR      BLD;

         //  SFL IS BUILT, PROCESS THE SFL CONTROL
           @LV = @LV + 1;
           @SCN(@LV) = 'S01PRC ' ;
            RETURN ;
       //--------------  BLD -------------------------------//
           BEGSR     BLD;

            EXSR      CLR;

           DOW       @LOOP = @LOOP;

             READ      QWHDRFFD;
                IF  %EOF;
                 LEAVE;
                ENDIF;
            EXSR      MOV;

       // FLAG THE KEY FIELDS
                  K = %LOOKUP(WHFLDE :KEY);
                     WHDFTL  = K ;
                     UPDATE    QWHDRFFD;

            RS01   = RS01 + 1;
            WRITE     S01;
           ENDDO;

         // Position to TOP of subfile
            SRS01 = 1;
            SFC01 = RS01;
           ENDSR;

       //--------------  CLR -------------------------------//
           BEGSR   CLR;
               I     =  0;
               CLEAR FLD;
               KEYLN = 0;

               *IN51 = *OFF;
               *IN52 = *OFF;
               *IN53 = *ON;
               WRITE     C01;
               *IN53 = *OFF;
               RS01  = 0   ;
               SFC01 = 0   ;
               S01OPT= *BLANK;
               ENDSR;

       //--------------  MOV -------------------------------//
           BEGSR   MOV;
         //  Load the subfile record


             S01OPT   =  WHFIOB ;
             S01WHFLDB  = WHFLDB;
             S01WHFLDT  = WHFLDT;
             S01WHFLD =  WHFLDE ;
             S01SFLD  =  WHFLDE ;
             S01FROM = WHFOBO;
             S01TO   = WHFLDB + WHFOBO -1 ;

       //  KEY FIELDS
             S01KEYFLD   = '  ';
               K = %LOOKUP(WHFLDE :KEY);
                  IF K <> 0;
                     S01KEYFLD = KA;
                   IF   K <  10;
                    %SUBST(S01KEYFLD:1:1) = 'K';
                   ENDIF;
                     KEYLN = KEYLN +  WHFLDB;
                  ENDIF;
        //  FORMAT THE FIELD LENGTH
                  S01SIZE  =  '      ';
                  SZ       =  '      ';
                  IF WHFLDD =       0;
                      LEN3   = %SUBST(%EDITC(WHFLDB:'Z'):3:3);
                   ELSE;
                      LEN2   = %EDITC(WHFLDD:'Z') ;
                      COMA = ',';

                      IF     WHFLDP >  9;
                        DEC2 = %CHAR(WHFLDP);
                      ELSE;
                        DEC1 = %CHAR(WHFLDP);
                      ENDIF;
                  ENDIF;
                  IF   LEN1 =  '0';
                       LEN1 = ' ';
                  ENDIF;
                  S01SIZE = SZ;

                   S01DESC = WHFTXT;
                   IF    S01DESC=   ' ';
                      S01DESC  =  WHCOLD ;
                   ENDIF;

                   I = I + 1;
                   FLD(I) =  S01WHFLD;

           ENDSR;

       //--------------*INZSR-------------------------------//
           BEGSR     @INZSR;
               @NSCN = *BLANK;
           ENDSR;
      /END-FREE

     P @S01BLD         E

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

      /space 3
     P @S01PRC         B

     D @S01PRC         PI

          //
          //
     D WRKRC           S              4S 0
     D C01CHK          S                   LIKE(C01POSN)

      /FREE
           EXSR      @INZSR;

            WRITE     R01;

       //
            DOW       @LOOP = @LOOP;

           //
           // Write SFL Control
             IF        SFC01 > 0;
                *IN51 = *ON;
             ENDIF;
               *IN52 = *ON;
               EXFMT     C01;
           //  Setoff errors
                 *IN89 = *OFF;
           //
           //  Exit and Previous Screen
             IF        *IN03 = *ON;
               RTN = '1';
                LEAVE;
             ENDIF;

             IF        *IN12 = *ON;
                @LV = @LV -1;
                 LEAVE;
             ENDIF;

           //  Set up for qry selection and exit
             IF        *IN06 = *ON;
               *IN03 = *ON;
               QRY = '1';
               LEAVE;
             ENDIF;

         //  POSITION
             IF   C01POSN <> ' ';
               EXSR POS;
               ITER;
             ENDIF;

         //  Process the subfile
               @LV = @LV + 1;
               @SCN(@LV) = 'S01PRS';
               LEAVE;

            ENDDO;
       //
            RETURN;

      /space 3

       //--------------POS   -------------------------------//
           BEGSR     POS;


           FOR       WRKRC = 1 TO SFC01;
               CHAIN  WRKRC   S01;
                 IF        NOT %FOUND;
                    LEAVE;
                 ENDIF;

                 C01CHK  = %SUBST(S01WHFLD :1 : %LEN(%TRIM(C01POSN)));
                 IF   (C01POSN  = C01CHK  );
                    SRS01  = WRKRC;
                    LEAVE;
                 ENDIF;

           ENDFOR;


           ENDSR;


       //--------------*INZSR-------------------------------//
           BEGSR     @INZSR;
               @NSCN = *BLANK;

            C01FILE    =  FILE;
            C01LIB     =  LIB;
            C01MBR     =  MBR;
            C01RCDL    =  RCDL;
            C01ACCTP   =  ACCTP;
            C01WHTEXT  =  WHTEXT;
            C01RCORDS  =  RCDS;
            C01POSN    =  '  ' ;
            C01WHNAME  =  WHNAME;

           ENDSR;
      /END-FREE

     P @S01PRC         E

       //###################################################//
       //###################################################//
       //###################################################//
      /space 3
     P @S01PRS         B

     D @S01PRS         PI

          //
          //
     D WRKRC           S              4S 0
     D FX              S              5S 0

      /FREE

          EXSR      @INZSR;

         //  Process the subfile
           EXSR      SFL;
           *IN03 = '1';
           RETURN;

       //--------------  SFL -------------------------------//
           BEGSR      SFL;
        //  Process the subfile

           FOR       WRKRC = 1 TO SFC01+1;
               CHAIN  WRKRC   S01;
                 IF        NOT %FOUND;
         //  Finished with the subfile
         //  RETURN TO REBUILD LEVEL
                    @LV = @LV -2;
                    LEAVE;
                 ENDIF;

         //     RIGHT ADJUST OPTION
               S01OPT  = @OPADJ(S01OPT);

         //    UPDATE SELECTIONS
               EXSR UPD;

           ENDFOR;

           ENDSR;
       //---------------------------------------------------//

       //--------------UPD ---------------------------------//
           BEGSR      UPD;

       // UPDATE FIELD NAMES AND SELECT FLAG
                 FX = %LOOKUP(S01SFLD :FLD);
                 CHAIN  FX  QWHDRFFD;
                 WHFLDE  =  S01WHFLD;

                 IF @OPADJ(S01OPT) = ' S' OR
                    @OPADJ(S01OPT) = ' O';
                     ALL    = %TRIM(S01OPT);
                     WHFIOB = %TRIM(S01OPT);
                 ENDIF;

                 IF @OPADJ(S01OPT) = ' ';
                     WHFIOB = ' ';
                 ENDIF;
                  UPDATE  QWHDRFFD;

           ENDSR;


       //--------------*INZSR-------------------------------//
           BEGSR     @INZSR;
               ALL   = '1';
               @NSCN = *BLANK;
           ENDSR;


      /END-FREE
     P @S01PRS         E

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

     P @R9999          B
        //  Invalid Panel
     D @R9999          PI

     P @R9999          E


      /space 3
       //###################################################//
       //###################################################//
       //###################################################//
     P @OPADJ          B
        //   RIGHT ADJ OPTION , zero suppress

     D @OPADJ          PI             2A
     D  OPT                           2A

      /FREE
         EVALR  OPT   = %trimr(OPT);
         If %SubSt(OPT:1:1) =  '0';
         OPT   = ' ' +  %SubSt(OPT:2:1);
         EndIf;
         RETURN OPT;
      /END-FREE
     P @OPADJ          E

       //###################################################//
       //###################################################//
       //###################################################//
     P  RtvMsgTxt      B
      //************************************************************************
      // API Call: QMHRTVM Retrieve Message text
      //************************************************************************


       // USAGE
       // MsgTxt = RtvMsgTxt('MSG0001':cMsgF3:cMsgLib:cMsgLvl1);

     D  RtvMsgTxt      PI          1024
     D   RMsgId                       7    Const
     D   RMsgFle                     10    Const
     D   RMsgLib                     10    Const
     D   RMsgLvl                      1    Const

      // Retrieve Message Description API Prototype
     D  Get_Message    PR                  ExtPgm('QMHRTVM')
     D                             4000    Options(*VarSize)
     D                               10I 0 Const
     D                                8    Const
     D                                7
     D                               20    Const
     D                            32765    Options(*VarSize)
     D                               10I 0 Const
     D                               10    Const
     D                               10    Const
     D                             8192    Options(*VarSize)
     D                               10
     D                                9B 0
     D                                9B 0

      // Define Variables for QMHRTVM API call:
      // --------------------------------------
      // Return variables
     D  MessageInfo    DS          4000
     D   Data                  1   4000
     D   OSMSG                65     68B 0
     D   LMsgR                69     72B 0
     D   LMsgA                73     76B 0
     D   OSMSGH               77     80B 0
     D   LMsgHR               81     84B 0
     D   LMsgHA               85     88B 0

      // Required input variables
     D   MessageLen    S             10I 0
     D   MessageForm   S              8
     D   MessageIden   S              7
     D   MessageFile   S             20
     D   Replacement   S          32765
     D   ReplaceLen    S             10I 0
     D   ReplaceSub    S             10
     D   ReturnCtl     S             10

     D   RetrieveOpt   S             10
     D   ConvToCCSID   S              9B 0
     D   ReplDtaCCSID  S              9B 0

     D   Return_Text   S           1024

     D  ErrorCode      DS                  Qualified
     D   BytesProv                    4B 0 Inz(0)
     D   BytesAvail                   8B 0 Inz(0)
     D   ExceptionId                  7
     D   Reserved                     1
     D   ExceptionDta               512
      /FREE

         // Load API parameter fields
         MessageInfo   = *blanks;
         MessageLen    = 4000;
         MessageForm   = 'RTVM0300';
         MessageIden   = RMsgId;
         MessageFile   = RMsgFle + RMsgLib;
         Replacement   = *blanks;
         ReplaceLen    = %Len(Replacement);
         ReplaceSub    = '*YES';
         ReturnCtl     = '*YES';
         RetrieveOpt   = '*MSGID';
         ConvToCCSID   = 0;
         ReplDtaCCSID  = 0;

         // Retrieve message description
         Get_Message(MessageInfo :
                     MessageLen  :
                     MessageForm :
                     MessageIden :
                     MessageFile :
                     Replacement :
                     ReplaceLen  :
                     ReplaceSub  :
                     ReturnCtl   :
                     ErrorCode   :
                     RetrieveOpt :
                     ConvToCCSID :
                     ReplDtaCCSID);

         // Process Return variables
         Return_Text = *blanks;

         // If no errors, determine the correct portion of the message text
         If ErrorCode.BytesProv = 0;
           Select;
           When RMsgLvl = '1';
               Return_Text = %Subst(data:OSMSG+1:LMsgA);   // Msg Lvl 1
           When RMsgLvl = '2';
               Return_Text = %Subst(data:OSMSGH+1:LMsgHA);   // Msg Lvl 2
           EndSl;
         Else;
           Return_Text = 'Get_Message failed.';
         EndIf;

         // Return to calling point
         Return Return_Text;

      /END-FREE
     P                 E


       //###################################################//
       //###################################################//
       //###################################################//
     P GETROWCOL       B
      *
      *    Retreive a DSPF FIELD  Row and Col
      *    Used for Setting  CSRLOC for cursor positioning
      *    USAGE
      *    GETROWCOL  (FILE :'*LIBL' : FORMAT : FLDNAM : ROW : COL)
      *
     D GETROWCOL       PR
     D   schFile                     10A   const
     D   schLib                      10A   const
     D   schFormat                   10A   const
     D   schString                   32A   const
     D   rtnROW                       3P 0
     D   RtnCOL                       3P 0

     D GETROWCOL       PI
     D   schFile                     10A   const
     D   schLib                      10A   const
     D   schFormat                   10A   const
     D   schString                   32A   const
     D   rtnROW                       3P 0
     D   RtnCOL                       3P 0

     D QUSCRTUS        PR                  ExtPgm('QUSCRTUS')
     D   UserSpace                   20A   CONST
     D   ExtAttrib                   10A   CONST
     D   InitialSize                 10I 0 CONST
     D   InitialVal                   1A   CONST
     D   PublicAuth                  10A   CONST
     D   Text                        50A   CONST
     D   Replace                     10A   CONST options(*nopass)
     D   ErrorCode                32767A   options(*varsize:*nopass)

     D QUSPTRUS        PR                  ExtPgm('QUSPTRUS')
     D   UserSpace                   20A   CONST
     D   Pointer                       *

     D QUSDLTUS        PR                  ExtPgm('QUSDLTUS')
     D   UserSpace                   20A   CONST
     D   ErrorCode                32767A   options(*varsize)

     D QUSLFLD         PR                  ExtPgm('QUSLFLD')
     D   UsrSpc                      20A   const
     D   Format                       8A   const
     D   QualFile                    20A   const
     D   RcdFmt                      10A   const
     D   UseOvrd                      1A   const
     D   ErrorCode                32767A   options(*nopass:*varsize)

     D ErrorCode       ds                  qualified
     D   BytesProv                   10I 0 inz(0)
     D   BytesAvail                  10I 0 inz(0)

     D ListHeader      ds                  based(p_ListHeader)
     d   ListOffset                  10I 0 overlay(ListHeader:125)
     d   EntryCount                  10I 0 overlay(ListHeader:133)
     d   EntrySize                   10I 0 overlay(ListHeader:137)

     D Field           ds                  based(p_Field)
     D                                     qualified
     D  Name                         10a
     D  FILLER                      438a
     d  DspRow                       10i 0
     d  DspCol                       10i 0

     D TEMPSPC         C                   'GETROWCOL QTEMP'

     D x               s             10I 0

      /free

                  rtnrow =    999;
                  rtnrow =    999;
           // --------------------------------------------------
           // Delete the user space if it exists (ignore errors)
           ErrorCode.BytesProv = %size(ErrorCode);
           QUSDLTUS( TEMPSPC: ErrorCode );
           ErrorCode.BytesProv = 0;

           // --------------------------------------------------
           // Create a new 128k user space
           QUSCRTUS( TEMPSPC : 'SCHTEXT' : 128 * 1024   : x'00'
                   : '*EXCLUDE' : 'List of fields in file' : '*NO'
                   : ErrorCode );

           // --------------------------------------------------
           // Dump list of fields in file to user space
           // Invaid data is ignored an 999 returned for row and col
           monitor;
           QUSLFLD( TEMPSPC : 'FLDL0100'  : SchFile + SchLib
                  : SchFormat  : *OFF  : ErrorCode );
               on-Error;
                 RETURN;
            EndMon;
           // --------------------------------------------------
           // Get a pointer to the user space
           QUSPTRUS( TEMPSPC: p_ListHeader );

           // --------------------------------------------------
           // Loop through all fields in space, to get the field we need
           for x = 0 to (EntryCount - 1);
               p_Field = p_ListHeader + ListOffset + (EntrySize * x);

               if Field.Name = schString;
                  rtnRow =    Field.DspRow;
                  rtnCol =    Field.DspCol;
                 leave;
               endif;
           endfor;

           // --------------------------------------------------
           // Delete temp user space & end
           QUSDLTUS( TEMPSPC: ErrorCode );

            return;

      /end-free
     P                 E

#top

DISPYF RPG


     A*%%TS  SD  20101203  131649  KOLMANNF    REL-V5R4M0  5722-WDS
     A*  90/01/08  12:52:36                REL-R01M02  5728-PW1
     A*            16:33:07                REL-R08M00  5714-UT1
     A*%%EC
     A                                      DSPSIZ(24 80 *DS3)
     A                                      REF(*LIBL/QADSPFFD)
     A                                      PRINT
     A                                      CA03(03 'End of job')
     A                                      CA12(12 'Previous')
     A                                      CA04(04 'Add FIELDS')
     A                                      CA05(05 'Attr changes')
     A                                      CF06(06 'Field Select')
     A                                      CA07(07 'Name changes')
     A*****
     A*            15:04:39                REL-R08M00  5714-UT1
     A          R S01                       SFL
     A*%%TS  SD  20101203  131649  KOLMANNF    REL-V5R4M0  5722-WDS
     A  40                                  SFLNXTCHG
     A            S01OPT         2A  B  7  2
     A            S01KEYFLD      2A  O  7  5DSPATR(HI)
     A            S01WHFLD  R        B  7  8REFFLD(WHFLDI)
     A  23                                  DSPATR(HI)
     A N23                                  DSPATR(PR)
     A            S01WHFLDB R        B  7 19REFFLD(WHFLDB)
     A                                      EDTCDE(Z)
     A  25                                  DSPATR(HI)
     A N25                                  DSPATR(PR)
     A            S01SIZE        6A  O  7 25
     A            S01FROM        4Y 0O  7 32EDTCDE(Z)
     A            S01TO          4Y 0O  7 37EDTCDE(Z)
     A            S01DESC       35A  O  7 44
     A            S01WHFLDT R        B  7 42REFFLD(WHFLDT)
     A  25                                  DSPATR(HI)
     A N25                                  DSPATR(PR)
     A            S01SFLD   R        H      REFFLD(WHFLDI)
     A*****
     A*
     A          R C01                       SFLCTL(S01)
     A*%%TS  SD  20101203  131649  KOLMANNF    REL-V5R4M0  5722-WDS
     A                                      SFLSIZ(0015)
     A                                      SFLPAG(0014)
     A  88                                  CSRLOC(ROW01      COL01)
     A                                      OVERLAY
     A                                      TEXT('WORK WITH FIELDS')
     A  51                                  SFLDSP
     A  52                                  SFLDSPCTL
     A  53                                  SFLCLR
     A  99                                  SFLEND
     A            SRS01          4S 0H      SFLRCDNBR(CURSOR)
     A*
     A  89        C01MSG        79   M
     A            ROW01          3S 0H
     A            COL01          3S 0H
     A                                  1  3'File'
     A            C01FILE       10A  O  1  8DSPATR(HI)
     A                                  1 20'Lib'
     A            C01LIB        10A  O  1 24DSPATR(HI)
     A                                  1 37'Mbr'
     A            C01MBR        10A  O  1 41DSPATR(HI)
     A                                  1 53'Rcdlen'
     A            C01RCDL        4S 0O  1 60DSPATR(HI)
     A                                  1 66'Access'
     A            C01ACCTP       1A  O  1 73DSPATR(HI)
     A                                  2  3'Text'
     A            C01WHTEXT R        O  2  9REFFLD(WHTEXT)
     A                                      DSPATR(HI)
     A                                  2 60'#Records'
     A            C01RCORDS      7Y 0O  2 69DSPATR(HI)
     A                                      EDTCDE(Z)
     A            C01POSN       10A  I  3  7
     A                                  4  2'Select/Omit (S/O) fields for displ-
     A                                      ay.(Default *ALL)'
     A                                  5 11'Use Select Or Omit,not Select with-
     A                                       Omit'
     A                                  6  8'Name       Bytes  Size  From  To T-
     A                                      p   Description'
     A                                  4 54'Format'
     A            C01WHNAME R        O  4 61REFFLD(QWHDRFFD/WHNAME)
     A                                      DSPATR(HI)
     A          R R01
     A                                 23  2'F3-Exit F6-Data Sel'

#top

DISPX DSPF

     A                                      DSPSIZ(24 80 *DS3)
     A                                      PRINT
     A                                      CF02(02 'return')
     A                                      CF03(01 'exit')
     A          R SLT
     A                                      OVERLAY
     A                                  1  2'Qryslt:'
     A            QSLT        1509A  B  1 12CHECK(LC)
     A                                 20  1'F2-Return '
     A          R SLTR                      SFL
     A                                      SFLMSGRCD(21)
     A            MSGKEY                    SFLMSGKEY
     A            PGMQ                      SFLPGMQ
     A          R SLTC                      SFLCTL(SLTR   )
     A                                      OVERLAY
     A                                      SFLSIZ(50) SFLPAG(3)
     A N20                                  SFLEND
     A N20                                  SFLDSP
     A N20                                  SFLDSPCTL
     A N20                                  SFLINZ
     A  20                                  SFLCLR
     A            PGMQ                      SFLPGMQ

#top

FFDL01 LF

     A          R QWHDRFFD                  PFILE(FFD)
                K WHFILE

#top


COMPILE CL

/* COMPILE OBJECTS                    */
/* CRTBNDCL   PGM(KOLMANN/COMPILE) SRCFILE(KOLMANN/UDDSSRC)     */
/*            SRCMBR(COMPILE) OUTPUT(*NONE) REPLACE(*YES)       */
/* call compile ('KOLMANN' 'UDDSSRC')                           */
PGM (&LIB &SRCF)

DCL &LIB  *CHAR  10
DCL &SRCF *CHAR  10

CRTDTAARA  DTAARA(&LIB/UDDSSRC) TYPE(*CHAR) LEN(10) +
   VALUE(&SRCF) TEXT('SOURCE LIBRARY FOR  UDDS PROGRAMS')
MONMSG CPF0000

dltf qtemp/afile
monmsg cpf0000
CRTPF      FILE(QTEMP/AFILE) RCDLEN(80) OPTION(*NOLIST)

CRTDSPF    FILE(&LIB/DISPF) SRCFILE(&LIB/&SRCF) +
                          SRCMBR(DISPF) OPTION(*NOLIST *NOSRC) +
                          REPLACE(*YES)


DSPFFD  FILE(QTEMP/AFILE) OUTPUT(*OUTFILE) OUTFILE(QTEMP/FFD)
DLTF   FILE(QTEMP/FFDL01)
MONMSG CPF0000
CRTLF FILE(QTEMP/FFDL01) SRCFILE(&LIB/&SRCF) SRCMBR(FFDL01) +
OPTION(*NOSRC *NOLIST)

DSPFFD  FILE(QTEMP/FFD) OUTPUT(*OUTFILE) OUTFILE(QTEMP/FFFFD)
DSPFD (QTEMP/FFD ) TYPE(*ACCPTH) OUTPUT(*OUTFILE) OUTFILE(QTEMP/KFFFD )
OVRDBF     FILE(KF) TOFILE(QTEMP/KFFFD)
CRTBNDCL   PGM(&LIB/DISF) SRCFILE(&LIB/&SRCF) +
        DBGVIEW(*SOURCE)  SRCMBR(DISF) OUTPUT(*NONE) REPLACE(*YES)
CRTBNDCL   PGM(&LIB/DISV) SRCFILE(&LIB/&SRCF) +
        DBGVIEW(*SOURCE)  SRCMBR(DISV) OUTPUT(*NONE) REPLACE(*YES)

 CRTBNDRPG  PGM(&LIB/DISPY) SRCFILE(&LIB/&SRCF) +
    SRCMBR(DISPY) DBGVIEW(*SOURCE) OUTPUT(*NONE) REPLACE(*YES)


DLTF   FILE(QTEMP/REL)
MONMSG CPF0000
DLTF   FILE(QTEMP/SEL)
MONMSG CPF0000
DLTF   FILE(QTEMP/DBR)
MONMSG CPF0000

DSPFD      FILE(QTEMP/FFD) TYPE(*ACCPTH) +
  OUTPUT(*OUTFILE) OUTFILE(QTEMP/REL) OUTMBR(*FIRST *ADD)
DSPFD FILE(QTEMP/FFDL01) TYPE(*SELECT) OUTPUT(*OUTFILE) OUTFILE(QTEMP/SEL)
CRTDSPF    FILE(&LIB/DISPRF) SRCFILE(&LIB/&SRCF) +
                          SRCMBR(DISPRF) OPTION(*NOLIST *NOSRC) +
                          REPLACE(*YES)

DSPDBR     FILE(QTEMP/FFD) OUTPUT(*OUTFILE) +
   OUTFILE(QTEMP/DBR) OUTMBR(*FIRST *REPLACE)

DLTF   FILE(QTEMP/ACC)
MONMSG CPF0000
DSPFD FILE(QTEMP/FFDL01) TYPE(*ACCPTH) OUTPUT(*OUTFILE) OUTFILE(QTEMP/ACC)

CRTBNDRPG  PGM(&LIB/DISP) SRCFILE(&LIB/&SRCF) +
  SRCMBR(DISP) DBGVIEW(*SOURCE) OUTPUT(*NONE) REPLACE(*YES)
CRTBNDRPG  PGM(&LIB/DISP1) SRCFILE(&LIB/&SRCF) +
  SRCMBR(DISP1) DBGVIEW(*SOURCE) OUTPUT(*NONE) REPLACE(*YES)
CRTBNDRPG  PGM(&LIB/DISP2) SRCFILE(&LIB/&SRCF) +
  SRCMBR(DISP2) DBGVIEW(*SOURCE) OUTPUT(*NONE) REPLACE(*YES)

CRTBNDRPG  PGM(&LIB/DUSP) SRCFILE(&LIB/&SRCF) +
  SRCMBR(DUSP) DBGVIEW(*SOURCE)                REPLACE(*YES)
CRTBNDRPG  PGM(&LIB/DUSP1) SRCFILE(&LIB/&SRCF) +
  SRCMBR(DUSP1) DBGVIEW(*SOURCE) OUTPUT(*NONE) REPLACE(*YES)
CRTBNDRPG  PGM(&LIB/DUSP2) SRCFILE(&LIB/&SRCF) +
  SRCMBR(DUSP2) DBGVIEW(*SOURCE) OUTPUT(*NONE) REPLACE(*YES)

CRTBNDCL   PGM(&LIB/DIS) SRCFILE(&LIB/&SRCF) +
      DBGVIEW(*SOURCE)    SRCMBR(DIS) OUTPUT(*NONE) REPLACE(*YES)
CRTBNDCL   PGM(&LIB/DIS3) SRCFILE(&LIB/&SRCF) +
      DBGVIEW(*SOURCE)    SRCMBR(DIS3) OUTPUT(*NONE) REPLACE(*YES)
CRTBNDCL   PGM(&LIB/DIS4) SRCFILE(&LIB/&SRCF) +
      DBGVIEW(*SOURCE)    SRCMBR(DIS4) OUTPUT(*NONE) REPLACE(*YES)
CRTBNDCL   PGM(&LIB/DISBIN) SRCFILE(&LIB/&SRCF) +
      DBGVIEW(*SOURCE)    SRCMBR(DISBIN) OUTPUT(*NONE) REPLACE(*YES)

CRTBNDRPG  PGM(&LIB/DISPR) SRCFILE(&LIB/&SRCF) +
    SRCMBR(DISPR) DBGVIEW(*SOURCE) OUTPUT(*NONE) REPLACE(*YES)

CRTCMD CMD(&LIB/DSPFL) PGM(*LIBL/DIS) SRCFILE(&LIB/&SRCF)  +
             SRCMBR(DSPFL) VLDCKR(DISV)

CRTDSPF    FILE(&LIB/DISPX) SRCFILE(&LIB/&SRCF) +
                          SRCMBR(DISPX) OPTION(*NOLIST *NOSRC) +
                          REPLACE(*YES)
CRTBNDCL   PGM(&LIB/DIS1) SRCFILE(&LIB/&SRCF) +
       DBGVIEW(*SOURCE)   SRCMBR(DIS1) OUTPUT(*NONE) REPLACE(*YES)



ENDPGM


#top

TESTPF PF

     A          R TESTR
     A            ACTIV          1A         TEXT('Active flag (0 - inactive, 1')
     A            CMPNO          3P         TEXT('Company number              ')
     A            PLTNO          2P         TEXT('Plant number                ')
     A            PRDNO         15A         TEXT('Product number              ')
     A            OPBAL         13P 3       TEXT('Opening balance - this perio')
     A            SERVU          5S 2       TEXT('Service level based on units')
     A            QTY            5B 2       TEXT('QTY')
     A            QTYF          17F 4       FLTPCN(*DOUBLE)
     A            CCYYMMDD        L         TEXT('DATE')
     A            HHMMSS          T         TEXT('TIME')
     A            DATTIM          Z         TEXT('DATE TIME')
     A            VTEXT        100A         VARLEN
     A                                      TEXT('VARIABLE TEXT')
     A            DESCP         30A         TEXT('Product description or name ')

     A          K ACTIV
     A          K CMPNO
     A          K PRDNO
     A          K OPBAL
     A          K SERVU

#top

TESTPF1 PF

     A          R TESTR
     A            ACTIV          1A         TEXT('Active flag (0 - inactive, 1')
     A            CMPNO          3P         TEXT('Company number              ')
     A            PLTNO          2P         TEXT('Plant number                ')
     A            PRDNO         15A         TEXT('Product number              ')
     A            OPBAL         13P 3       TEXT('Opening balance - this perio')
     A            SERVU          5S 2       TEXT('Service level based on units')
     A            QTY            5B 2       TEXT('QTY')
     A            QTYF          17F 4       FLTPCN(*DOUBLE)
     A            CCYYMMDD        L         TEXT('DATE')
     A            HHMMSS          T         TEXT('TIME')
     A            DATTIM          Z         TEXT('DATE TIME')
     A            VTEXT        100A         VARLEN
     A                                      TEXT('VARIABLE TEXT')
     A            DESCP         30A         TEXT('Product description or name ')
     A            TXT1         500A         TEXT('TXT1  ')
     A            TXT2         500A         TEXT('TXT2  ')
     A            TXT3         500A         TEXT('TXT3  ')
     A            TXT4         500A         TEXT('TXT4  ')
     A          K ACTIV
     A          K CMPNO
     A          K PRDNO
     A          K OPBAL
     A          K SERVU

#top

TESTPF2 PF


     A          R TESTR
     A            ACTIV          1A         TEXT('Active flag (0 - inactive, 1')
     A            CMPNO          3P         TEXT('Company number              ')
     A            PLTNO          2P         TEXT('Plant number                ')
     A            PRDNO         15A         TEXT('Product number              ')
     A            OPBAL         13P 3       TEXT('Opening balance - this perio')
     A            SERVU          5S 2       TEXT('Service level based on units')
     A            QTY            5B 2       TEXT('QTY')
     A            QTYF          17F 4       FLTPCN(*DOUBLE)
     A            CCYYMMDD        L         TEXT('DATE')
     A            HHMMSS          T         TEXT('TIME')
     A            DATTIM          Z         TEXT('DATE TIME')
     A            VTEXT        100A         VARLEN
     A                                      TEXT('VARIABLE TEXT')
     A            DESCP         30A         TEXT('Product description or name ')
     A            TXT1         500A         TEXT('TXT1  ')
     A            TXT2         500A         TEXT('TXT2  ')
     A            TXT3         500A         TEXT('TXT3  ')
     A            TXT4         500A         TEXT('TXT4  ')
     A            TXT5         500A         TEXT('TXT5  ')
     A            TXT6         500A         TEXT('TXT6  ')
     A            TXT7         500A         TEXT('TXT7  ')
     A            TXT8         500A         TEXT('TXT8  ')
     A          K ACTIV
     A          K CMPNO
     A          K PRDNO
     A          K OPBAL
     A          K SERVU


#top