Difference between revisions of "UDDS File Display/Update"

From MidrangeWiki
Jump to: navigation, search
Line 19: Line 19:
  
 
<pre>
 
<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
 +
    FFFD      IF  E            DISK
 +
    FDISPF    CF  F  803        WORKSTN
 +
    F*
 +
    F                                    INFDS(INFDS)
 +
    FINPUTK    IF  F32766  800AIDISK    KEYLOC(1)
 +
    F                                    EXTIND(*INU1)
 +
    F                                    INFDS(INFDK)
 +
    FINPUTR    IF  F32766        DISK    EXTIND(*INU2)
 +
    F                                    INFDS(INFDR)
 +
 +
      *
 +
    D A              S            255                                        WORK RU
 +
    D RU              S            255    varying
 +
    D RW              S              1                                        ROW 1 byte binary
 +
    D CL              S              1                                        COL 1 byte binary
 +
    D FNC            S              1
 +
    D OUTLEN          S              2
 +
    D INLEN          S              2
 +
    D IPL            S              5  0
 +
    D ROW            S              3  0
 +
    D XROW            S              3  0
 +
    D COL            S              3  0
 +
    D KEYSOK          S              1
 +
    D LENDSC          S              3  0
 +
    D LENWRK          S              5  0
 +
    D STRX            S              5  0
 +
    D ENDX            S              5  0
 +
    D VX              S              5  0
 +
    D X              S              5  0
 +
    D X1              S              5  0
 +
    D X2              S              5  0
 +
    D XX              S              5  0
 +
    D XP              S              5  0
 +
    D MX              S              5  0
 +
    D ONCE            S              1
 +
    D RBA            S              2
 +
    D LF              S              5  0
 +
    D ST              S              5  0
 +
    D Y              S              5  0
 +
    D Z              S              5  0
 +
    D OFF            S              5  0
 +
    D SUPZ            S              1
 +
    D NUMFLD          S              5  0
 +
    D WX              S              5  0
 +
    D NUMKEY          S              5  0
 +
    D NUMFKY          S              5  0
 +
    D SCRST          S            10
 +
    D SCRSTN          S              1
 +
    D KEYA            S            800
 +
    D RRNA            S            11  0
 +
    D RRN            S            11  0
 +
    D REHEAD          S              1
 +
    D NEWRU          S              1
 +
    D WRTRRN          S              1
 +
    D LVX            S              5  0
 +
    D LVL            S              5  0
 +
    D K1              S              5  0
 +
    D K2              S              5  0
 +
    D Z1              S              5  0
 +
    D W              S              5  0
 +
    D WK2            S              2
 +
    D MSSG            S            32
 +
      *
 +
    D BASE            S              5  0
 +
    D INZ            S              1
 +
 +
    D FILE            S            10
 +
    D LIB            S            10
 +
    D MBR            S            10
 +
    D RCDL            S              5  0
 +
    D ACCTP          S              1
 +
    D RLEN            S              5  0
 +
    D RLENTH          S              5
 +
    D LENF            S              5  0
 +
 +
 +
    D                DS
 +
    D TEXT500                      500
 +
    D LVW                          10    DIM(50) overlay(TEXT500:1)
 +
 +
    D TEXT800        S            800
 +
    D KW              S            800
 +
 +
    D                DS
 +
    D WRK11                  1    11
 +
    D NUM11                  1    11S 0
 +
 +
    D                DS
 +
    D NUSA                    1    60
 +
    D NUS                    1    60S 0
 +
    D                DS
 +
    D NUPA                    1    60
 +
    D NUP                    29    60P 0
 +
 +
    D WRU            S            61
 +
    D WRX            S            64
 +
    D WRXWRD          C                  '0                              -
 +
    D                                                                    -'
 +
    D WRSWRD          C                  '0                              -
 +
    D                                                                  -'
 +
    D WRV            S            60    varying
 +
 +
    D FLT14          S            14
 +
    D FLT23          S            23
 +
 +
      * SET FILE SIZE INCREMENTS (64 OF THEM)
 +
    D SZ              S              5  0 DIM(64)
 +
    D S              S              5  0 DIM(9000)                            START OF FLD
 +
    D E              S              5  0 DIM(9000)                            END OF FLD
 +
    D Q              S              5  0 DIM(9000)                            BYTES IN FIELD
 +
    D L              S              5  0 DIM(9000)                            LENGTH OF FLD
 +
    D C              S              3  0 DIM(9000)                            DEC DIGITS
 +
    D P              S              3  0 DIM(9000)                            DEC PRECISION
 +
    D B              S              2    DIM(9000) ASCEND                    BUFFER ADD
 +
    D I              S              2    DIM(9000)                            FLD FMT
 +
    D N              S            10    DIM(9000)                            FLD NAME
 +
    D T              S              1    DIM(9000)                            FLD TYPE
 +
    D V              S              1    DIM(9000)                            VARYING
 +
    D KY              S              1    DIM(9000)                            KEYED
 +
    D KE              S            10    DIM(128)                            KEY FLDS
 +
    D R              S              3  0 DIM(9000)                            KEY FLD START
 +
    D K              S              1    DIM(800)                            KEY
 +
    D NA              S              1    DIM(10)                              NAME WORK
 +
    D NU              S              1    DIM(60)                              NUM. WORK
 +
    D LV              S            10    DIM(50)                              SCREEN LEVELS
 +
    D MSG            S            32    DIM(8) CTDATA PERRCD(1)              MESSAGES
 +
    D CNS            S            50    DIM(2) CTDATA PERRCD(1)
 +
    D CRS            S              1    DIM(16) CTDATA PERRCD(16)
 +
 +
    D                DS
 +
    D  D                      1  2048
 +
    D                                    DIM(2048)                            INCOMING DATA
 +
    D  DA                    1    16
 +
    D  DB                    17    32
 +
    D  DC                    33    64
 +
    D  DD                    65    96
 +
    D  DE                    97    128
 +
    D  DF                  129    160
 +
    D  DG                  161    192
 +
    D  DH                  193    224
 +
    D  DI                  225    256
 +
    D  DJ                  257    288
 +
    D  DK                  289    320
 +
    D  DL                  321    352
 +
    D  DM                  353    384
 +
    D  DN                  385    416
 +
    D  DZ                  417    448
 +
    D  DO                  449    480
 +
    D  DP                  481    512
 +
    D  DQ                  513    544
 +
    D  DR                  545    576
 +
    D  DS                  577    608
 +
    D  DT                  609    640
 +
    D  DU                  641    672
 +
    D  DV                  673    704
 +
    D  DW                  705    736
 +
    D  DX                  737    768
 +
    D  DY                  769    800
 +
    D  D0                  801    832
 +
    D  D1                  833    864
 +
    D  D2                  865    896
 +
    D  D3                  897    928
 +
    D  D4                  929    960
 +
    D  D5                  961    992
 +
    D  D6                  993  1024
 +
    D  DBA                1025  1056
 +
    D  DCA                1057  1088
 +
    D  DDA                1089  1120
 +
    D  DEA                1121  1152
 +
    D  DFA                1153  1184
 +
    D  DGA                1185  1216
 +
    D  DHA                1217  1248
 +
    D  DIA                1249  1280
 +
    D  DJA                1281  1312
 +
    D  DKA                1313  1344
 +
    D  DLA                1345  1376
 +
    D  DMA                1377  1408
 +
    D  DNA                1409  1440
 +
    D  DOA                1441  1472
 +
    D  DPA                1473  1504
 +
    D  DQA                1505  1536
 +
    D  DRA                1537  1568
 +
    D  DSA                1569  1600
 +
    D  DTA                1601  1632
 +
    D  DUA                1633  1664
 +
    D  DVA                1665  1696
 +
    D  DWA                1697  1728
 +
    D  DXA                1729  1760
 +
    D  DYA                1761  1792
 +
    D  DZA                1793  1824
 +
    D  D0A                1825  1856
 +
    D  D1A                1857  1888
 +
    D  D2A                1889  1920
 +
    D  D3A                1921  1952
 +
    D  D4A                1953  1984
 +
    D  D5A                1985  2016
 +
    D  D6A                2017  2048
 +
    D                DS
 +
    D  ID                    1    800
 +
    D                                    DIM(800)                            INCOMING DATA
 +
    D  IDA                    1    800
 +
    D  ID0                    1    80
 +
    D  ID1                  81    160
 +
    D  ID2                  161    240
 +
    D  ID3                  241    320
 +
    D  ID4                  321    400
 +
    D  ID5                  401    480
 +
    D  ID6                  481    560
 +
    D  ID7                  561    640
 +
    D  ID8                  641    720
 +
    D  ID9                  721    800
 +
    D                DS
 +
    D  BIN                    1      2B 0
 +
    D  HX1                    2      2
 +
    D  HX2                    1      2
 +
    D                DS
 +
    D  PCK                    1      1P 0
 +
    D  PCK1                  1      1
 +
    D                DS
 +
    D  SGN                    1      1S 0
 +
    D  SGN1                  1      1
 +
 +
    D                DS
 +
    D  BIN4                  1      4B 0
 +
    D  BY4                    1      4
 +
 +
    D                DS
 +
    D  BIN2                  1      2B 0
 +
    D  BY2                    1      2
 +
 +
    D                DS
 +
    D  FLT4                  1      4F
 +
    D  FL4                    1      4
 +
 +
    D                DS
 +
    D  FLT8                  1      8F
 +
    D  FL8                    1      8
 +
 +
    D INFDK          DS
 +
    D  F1                    83    92
 +
    D  L1                    93    102
 +
    D  M1                  129    138
 +
    D  R1                  125    126B 0
 +
    D  A1                  160    160
 +
    D  LOP1                260    260
 +
    D  KEY_LEN              393    394I 0                                      Key length
 +
    D  RN1                  397    400B 0
 +
    D  LKY                  401  1200
 +
    D INFDR          DS
 +
    D  F2                    83    92
 +
    D  L2                    93    102
 +
    D  M2                  129    138
 +
    D  R2                  125    126B 0
 +
    D  A2                  160    160
 +
    D  LOP2                260    260
 +
    D  RN2                  397    400B 0
 +
    D*
 +
    D INFDS          DS
 +
    D  CURLOC              370    371
 +
    D                DS
 +
    D KEYLN                  1      4S 0
 +
    D KEYLNA                  1      4
 +
 +
    DDISP            PR
 +
    D                                1
 +
    D                                1
 +
    D                                4
 +
    D                                1
 +
    D                              500
 +
    D                                5
 +
    D                              800
 +
    DDISP            PI
 +
    D  ALL                          1
 +
    D  RTN                          1
 +
    D  KEYLNG                      4
 +
    D  UPDF                        1
 +
    D  SCNLV                      500
 +
    D  SCNLVL                      5
 +
    D  SCNKEY                    800
 +
 +
 +
    D @LOOP          C                  '1'
 +
 +
    D SND            C                  X'71'                                SEND TO DISP
 +
    D SNR            C                  X'73'                                SND/RCV
 +
    D RED            C                  X'42'                                READ
 +
    D RDM            C                  X'52'                                READ MTD
 +
    D ESC            C                  X'04'                                ESCAPE
 +
    D CLR            C                  X'40'                                CLEAR UNIT
 +
    D CC1            C                  X'00'                                CNTRL CHAR
 +
    D CC2            C                  X'08'                                CNTRL CHAR
 +
    D SBA            C                  X'11'                                SET BUFF ADR
 +
    D IC              C                  X'13'                                INSERT CURS
 +
    D WTD            C                  X'11'                                WRITE TO DSP
 +
    D WER            C                  X'21'                                WRITE ERROR
 +
    D SF              C                  X'1D'                                START FLD
 +
    D ATC            C                  X'20'                                ATTR CHAR
 +
    D ATN            C                  X'24'                                ATTR NUM
 +
    D X00            C                  X'00'
 +
    D X01            C                  X'01'
 +
    D X02            C                  X'02'
 +
    D X03            C                  X'03'
 +
    D X0D            C                  X'0D'
 +
    D X0F            C                  X'0F'
 +
    D X000            C                  X'0000'
 +
    D X1F            C                  X'1F'
 +
    D X20            C                  X'20'                                SCRN ATT NORMAL
 +
    D X22            C                  X'22'                                SCRN ATTR HI
 +
    D X25            C                  X'25'
 +
    D X26            C                  X'26'
 +
    D X31            C                  X'31'                                CMD 1 KEY
 +
    D X32            C                  X'32'                                CMD 2 KEY
 +
    D X33            C                  X'33'                                CMD 3 KEY
 +
    D X36            C                  X'36'                                CMD 6 KEY
 +
    D X37            C                  X'37'                                CMD 7 KEY
 +
    D X38            C                  X'38'                                CMD 8 KEY
 +
    D X39            C                  X'39'                                CMD 9 KEY
 +
    D X3B            C                  X'3B'                                CMD11 KEY
 +
    D XB7            C                  X'B7'                                CMD19 KEY
 +
    D XB8            C                  X'B8'                                CMD20 KEY
 +
    D X40            C                  X'40'
 +
    D X43            C                  X'43'
 +
    D X47            C                  X'47'
 +
    D X60            C                  X'60'
 +
    D X67            C                  X'67'
 +
    D X9F            C                  X'9F'
 +
    D XF0            C                  X'F0'
 +
    D XD0            C                  X'D0'
 +
    D X4000          C                  X'4000'
 +
    D X4800          C                  X'4800'                              FF ALPHA
 +
    D X4F06          C                  X'4F06'                              FF NUMERIC
 +
    D X6000          C                  X'6000'                              FF ALPHA
 +
    D X6706          C                  X'6706'                              FF NUMERIC
 +
    D CLRWTD          C                  X'044004112000'                      INCLUDES ESC CHARS
 +
    D RDDSP          C                  X'0411200804524000'                  REAB FROM DISPLAY
 +
    D FFA1            S              1    INZ(X'40')                          F.FMT 1 ALPH  60 BYP
 +
    D FFA2            S              1    INZ(X'00')                          F.FMT 2 ALPH
 +
    D FFN1            S              1    INZ(X'47')                          F.FMT 1 NUM  67 BYP
 +
    D FFN2            S              1    INZ(X'06')                          F.FMT 2 NUM
 +
    I*.
 +
    IINPUTK    NS  01
 +
    I                                  1  16  DA
 +
    I                                17  32  DB                30
 +
    I                                33  64  DC                31
 +
    I                                65  96  DD                32
 +
    I                                97  128  DE                33
 +
    I                                129  160  DF                34
 +
    I                                161  192  DG                35
 +
    I                                193  224  DH                36
 +
    I                                225  256  DI                37
 +
    I                                257  288  DJ                38
 +
    I                                289  320  DK                39
 +
    I                                321  352  DL                40
 +
    I                                353  384  DM                41
 +
    I                                385  416  DN                42
 +
    I                                417  448  DZ                43
 +
    I                                449  480  DO                44
 +
    I                                481  512  DP                45
 +
    I                                513  544  DQ                46
 +
    I                                545  576  DR                47
 +
    I                                577  608  DS                48
 +
    I                                609  640  DT                49
 +
    I                                641  672  DU                50
 +
    I                                673  704  DV                51
 +
    I                                705  736  DW                52
 +
    I                                737  768  DX                53
 +
    I                                769  800  DY                54
 +
    I                                801  832  D0                55
 +
    I                                833  864  D1                56
 +
    I                                865  896  D2                57
 +
    I                                897  928  D3                58
 +
    I                                929  960  D4                59
 +
    I                                961  992  D5                60
 +
    I                                993 1024  D6                61
 +
    I                              1025 1056  DBA              62
 +
    I                              1057 1088  DCA              63
 +
    I                              1089 1120  DDA              64
 +
    I                              1121 1152  DEA              65
 +
    I                              1153 1184  DFA              66
 +
    I                              1185 1216  DGA              67
 +
    I                              1217 1248  DHA              68
 +
    I                              1249 1280  DIA              69
 +
    I                              1281 1312  DJA              70
 +
    I                              1313 1344  DKA              71
 +
    I                              1345 1376  DLA              72
 +
    I                              1377 1408  DMA              73
 +
    I                              1409 1440  DNA              74
 +
    I                              1441 1472  DOA              75
 +
    I                              1473 1504  DPA              76
 +
    I                              1505 1536  DQA              77
 +
    I                              1537 1568  DRA              78
 +
    I                              1569 1600  DSA              79
 +
    I                              1601 1632  DTA              80
 +
    I                              1633 1664  DUA              81
 +
    I                              1665 1696  DVA              82
 +
    I                              1697 1728  DWA              83
 +
    I                              1729 1760  DXA              84
 +
    I                              1761 1792  DYA              85
 +
    I                              1793 1824  DZA              86
 +
    I                              1825 1856  D0A              87
 +
    I                              1857 1888  D1A              88
 +
    I                              1889 1920  D2A              89
 +
    I                              1921 1952  D3A              90
 +
    I                              1953 1984  D4A              91
 +
    I                              1985 2016  D5A              92
 +
    I                              2017 2048  D6A              93
 +
    IINPUTR    NS  01
 +
    I                                  1  16  DA
 +
    I                                17  32  DB                30
 +
    I                                33  64  DC                31
 +
    I                                65  96  DD                32
 +
    I                                97  128  DE                33
 +
    I                                129  160  DF                34
 +
    I                                161  192  DG                35
 +
    I                                193  224  DH                36
 +
    I                                225  256  DI                37
 +
    I                                257  288  DJ                38
 +
    I                                289  320  DK                39
 +
    I                                321  352  DL                40
 +
    I                                353  384  DM                41
 +
    I                                385  416  DN                42
 +
    I                                417  448  DZ                43
 +
    I                                449  480  DO                44
 +
    I                                481  512  DP                45
 +
    I                                513  544  DQ                46
 +
    I                                545  576  DR                47
 +
    I                                577  608  DS                48
 +
    I                                609  640  DT                49
 +
    I                                641  672  DU                50
 +
    I                                673  704  DV                51
 +
    I                                705  736  DW                52
 +
    I                                737  768  DX                53
 +
    I                                769  800  DY                54
 +
    I                                801  832  D0                55
 +
    I                                833  864  D1                56
 +
    I                                865  896  D2                57
 +
    I                                897  928  D3                58
 +
    I                                929  960  D4                59
 +
    I                                961  992  D5                60
 +
    I                                993 1024  D6                61
 +
    I                              1025 1056  DBA              62
 +
    I                              1057 1088  DCA              63
 +
    I                              1089 1120  DDA              64
 +
    I                              1121 1152  DEA              65
 +
    I                              1153 1184  DFA              66
 +
    I                              1185 1216  DGA              67
 +
    I                              1217 1248  DHA              68
 +
    I                              1249 1280  DIA              69
 +
    I                              1281 1312  DJA              70
 +
    I                              1313 1344  DKA              71
 +
    I                              1345 1376  DLA              72
 +
    I                              1377 1408  DMA              73
 +
    I                              1409 1440  DNA              74
 +
    I                              1441 1472  DOA              75
 +
    I                              1473 1504  DPA              76
 +
    I                              1505 1536  DQA              77
 +
    I                              1537 1568  DRA              78
 +
    I                              1569 1600  DSA              79
 +
    I                              1601 1632  DTA              80
 +
    I                              1633 1664  DUA              81
 +
    I                              1665 1696  DVA              82
 +
    I                              1697 1728  DWA              83
 +
    I                              1729 1760  DXA              84
 +
    I                              1761 1792  DYA              85
 +
    I                              1793 1824  DZA              86
 +
    I                              1825 1856  D0A              87
 +
    I                              1857 1888  D1A              88
 +
    I                              1889 1920  D2A              89
 +
    I                              1921 1952  D3A              90
 +
    I                              1953 1984  D4A              91
 +
    I                              1985 2016  D5A              92
 +
    I                              2017 2048  D6A              93
 +
    IDISPF    NS  02
 +
    I                                  3    3  AID
 +
    I                                  4  83  ID0
 +
    I                                84  163  ID1              20
 +
    I                                164  243  ID2              21
 +
    I                                244  323  ID3              22
 +
    I                                324  403  ID4              23
 +
    I                                404  483  ID5              24
 +
    I                                484  563  ID6              25
 +
    I                                564  643  ID7              26
 +
    I                                644  723  ID8              27
 +
    I                                724  803  ID9              28
 +
 +
 +
      /FREE
 +
            BASE = 0;
 +
 +
            IF  ONCE  =  ' ';
 +
                EXSR      @INITZ  ;
 +
            ENDIF;
 +
 +
        //  START        TAG
 +
          DOW      @LOOP = @LOOP;
 +
 +
          IF  RTN  = '3';
 +
 +
              IF *INU1;
 +
                KEYA =  SCNKEY;
 +
              ENDIF;
 +
              IF *INU2;
 +
                RRNA =  %DEC(%SUBST(SCNKEY:1:11):11:0);
 +
              ENDIF;
 +
                RTN = '0';
 +
                AID = '1';
 +
            ELSE;
 +
              RTN  = '0';
 +
              READ(E)  DISPF;
 +
          ENDIF;
 +
 +
        //  CF3 EXIT
 +
          IF  AID  = X33;
 +
            LEAVE;
 +
          ENDIF;
 +
 +
        //  CF2 RETURN
 +
          IF  AID  = X32;
 +
            RTN = '1';
 +
            LEAVE;
 +
          ENDIF;
 +
 +
        // CF1 HEX A FIELD
 +
          IF  AID  = X31;
 +
          Y = %LOOKUPLE( CURLOC : B );
 +
          IF Y > 0;
 +
            IF KY(Y) <= '1';
 +
              EXSR      @HXDSP;
 +
              REHEAD  = '1';
 +
              EXSR      @PUTHED;
 +
              REHEAD  = ' ';
 +
            ENDIF;
 +
            ENDIF;
 +
          ENDIF;
 +
 +
        //  CF20 MORE FIELDS
 +
          IF  AID  = XB8;
 +
 +
            LVX  = LVL + 1;
 +
            IF  LV(LVX)  <> *BLANK;
 +
              LVL = LVL +1 ;
 +
 +
              LVW  = LV;
 +
              SCNLV = TEXT500;
 +
              SCNLVL = %EDITC(LVL :'X');
 +
 +
            SCNKEY = *BLANKS;
 +
          IF  *INU1;
 +
                SCNKEY = KEYA;
 +
          ENDIF;
 +
          IF  *INU2;
 +
                SCNKEY = %EDITC(RRNA:'X');
 +
          ENDIF;
 +
 +
              RTN = '3';
 +
              LEAVE;
 +
            ENDIF;
 +
          ENDIF;
 +
 +
      //  CF19 PREVIOUS FIELDS
 +
          IF  AID  = XB7;
 +
 +
            LVX  = LVL - 1;
 +
            IF  LVX    >= 0 ;
 +
              LVL = LVL - 1 ;
 +
 +
              LVW  = LV;
 +
              SCNLV = TEXT500;
 +
              SCNLVL = %EDITC(LVL :'X');
 +
 +
                SCNKEY = *BLANKS;
 +
          IF  *INU1;
 +
                SCNKEY = KEYA;
 +
          ENDIF;
 +
          IF  *INU2;
 +
                SCNKEY = %EDITC(RRNA:'X');
 +
          ENDIF;
 +
 +
              RTN = '3';
 +
              LEAVE;
 +
            ENDIF;
 +
          ENDIF;
 +
 +
          // 1 ENTER
 +
          // 4 ROLL DN
 +
          // 5 ROLL UP
 +
          IF  AID  = '1'or AID = '4' or AID = '5';
 +
          ELSE;
 +
            MX = 1;
 +
            EXSR  @ERROR;
 +
          ENDIF;
 +
 +
          IF  RTN <> '3';
 +
            EXSR      @PCKD;
 +
          ENDIF;
 +
 +
 +
        // CONT1  GET A RECORD, KEY FROM DATA
 +
            EXSR      @SETIN;
 +
            EXSR      @GETF ;
 +
            EXSR      @PUTF ;
 +
            EXSR      @KEYIN;
 +
 +
          ENDDO ;
 +
 +
          *INLR = *ON;
 +
 +
      //  @@@@@@@  @INITZ @@@@@@@@@@@@@@@@@@@@@@@@@@
 +
        BEGSR  @INITZ;
 +
                ONCE  =  '1';
 +
                KEYLNA = KEYLNG  ;
 +
                EXSR      @INIT  ;
 +
                EXSR      @GETFLD ;
 +
                EXSR      @GETADD ;
 +
                EXSR      @PUTHED ;
 +
                EXSR      @KEYIN  ;
 +
                INZ  = '1';
 +
                EXSR      @PCKD  ;
 +
                INZ  = ' ';
 +
        ENDSR;
 +
 +
      //  @@@@@@@  @PCKD  @@@@@@@@@@@@@@@@@@@@@@@@@@
 +
 +
          BEGSR  @PCKD ;
 +
 +
            //  CONVERT  KEY DATA
 +
            IF  *INU1 ;
 +
              EXSR  @CVTKEY;
 +
            ENDIF;
 +
            IF  *INU2 ;
 +
              EXSR  @CVTRRN;
 +
            ENDIF;
 +
 +
          ENDSR;
 +
 +
      //  @@@@@@@  @CVTKEY  @@@@@@@@@@@@@@@@@@@@@@@@
 +
 +
          BEGSR  @CVTKEY;
 +
 +
      // EXTRACT THE KEY FIELD DATA FROM THE INCOMING STRING
 +
 +
        // FOR EACH KEY FIELD, CHECK IF FIELD WAS MODIFIED, AND IF SO MOVE
 +
        // THE MODIFIED DATA INTO THE COMPOSITE KEY
 +
 +
        K1 = 0;
 +
        K2 = 0;
 +
        W  = 1;
 +
 +
          FOR  Y  = 1  TO NUMKEY ;
 +
 +
      //  MOVE A KEY FIELDS DATA FROM ID ARRAY (SCREEN) TO K ARRAY (KEY FIELDS)
 +
 +
      //  GET SIZE OF FIELD IN BYTES
 +
          IF T(Y)  =  'A';  // ALPHA DATA
 +
          K = ' ';
 +
          K1 = 1;
 +
          K2 = Q(Y);
 +
          ELSE;
 +
          K  = '0';
 +
          K1 =  1;
 +
          K2 = C(Y);
 +
          ENDIF;
 +
 +
      // IF WHOLE KEY INIT WAS REQUESTED BYPASS THE EXTRACT
 +
          IF  INZ  = '1' ;
 +
            KW  = *BLANK;
 +
            EXSR      @PCKMOV;
 +
            ITER;
 +
          ENDIF;
 +
 +
          X  =  1;
 +
 +
          DOW  @LOOP = @LOOP;
 +
 +
      //  NXTSBA
 +
          X  = %LOOKUP(SBA : ID : X );
 +
          IF X = 0;
 +
            LEAVE;
 +
          ENDIF;
 +
 +
      // IS THIS THE FIELD?  CHECK THE BUFFER ADDRESS
 +
        X = X +1;
 +
        IF  B(Y)  <>  %SUBST(IDA : X :2);
 +
          ITER;
 +
        ENDIF;
 +
 +
      //  FOUND A MTD FOR THIS FIELD
 +
        X =  X + 2;
 +
 +
      //  CHECK IF FIELD WAS CLEARED ONLY
 +
        IF  ID(X) = SBA;
 +
            EXSR      @PCKMOV;
 +
            LEAVE ;
 +
        ENDIF;
 +
 +
      //  IF FIELD HAS DECIMALS BUMP X
 +
          IF (T(Y) = 'S' OR T(Y) = 'P' OR T(Y) = 'B') AND
 +
              P(Y) > 0;
 +
              X = X + 1;
 +
          ENDIF;
 +
 +
      //  CHECK IF ONLY BLANKS RETURNED
 +
        IF    %SUBST(IDA : X :K2) = *BLANKS;
 +
            EXSR      @PCKMOV;
 +
            LEAVE;
 +
        ENDIF;
 +
 +
      // EXTRACT THE DATA FROM THE INCOMING STRING
 +
        X1  = X;
 +
        FOR X2  =  1 TO  K2 ;
 +
 +
          IF ID(X1) < ' ';
 +
      // TRAP NULLS CAUSED BY FLD EXIT
 +
            EXSR      @PCKMOV;
 +
            LEAVE;
 +
          ENDIF;
 +
 +
        K(X2)  =  ID(X1);
 +
        X1    =  X1 +1;
 +
        ENDFOR;
 +
 +
        // CONSTRUCT THE ACTUAL KEY WITH PACKED DATA IF REQUIRED
 +
        // INTO ARRAY KW
 +
          EXSR      @PCKMOV;
 +
          LEAVE;
 +
        ENDDO;
 +
 +
        ENDFOR;
 +
 +
        //
 +
          KEYA  = KW;
 +
          CLEAR KW;
 +
        ENDSR ;
 +
 +
      //  @@@@@@@  @CVTRRN  @@@@@@@@@@@@@@@@@@@@@@@@
 +
 +
          BEGSR  @CVTRRN;
 +
 +
        //  RRN
 +
 +
          NUM11 = 0;
 +
 +
          DOW  @LOOP = @LOOP;  //  NOT REALLY A LOOP(SIMULATES GOTO)
 +
 +
      // GET THE FIRST SBA
 +
          X = 1;
 +
          X  = %LOOKUP(SBA : ID : X );
 +
          IF X = 0;
 +
          LEAVE;
 +
          ENDIF;
 +
 +
      // CHECK THE BUFFER ADDRESS MATCHES THE EXPECTED FIELD
 +
        X = X +1;
 +
        IF  B(1)  <>  %SUBST(IDA : X :2);
 +
          LEAVE;
 +
        ENDIF;
 +
 +
      //  FOUND A MTD FOR RRN  FIELD
 +
        X = X +2;
 +
 +
      //CHECK IF FIELD WAS CLEARED ONLY
 +
        IF  ID(X) = SBA;
 +
            LEAVE;
 +
        ENDIF;
 +
 +
      //  CHECK IF ONLY BLANKS RETURNED
 +
        IF    %SUBST(IDA : X :11) = *BLANKS;
 +
            LEAVE;
 +
        ENDIF;
 +
 +
 +
        //  WRK11  OVERLAYS NUM11
 +
        WRK11 = %SUBST(IDA : X :11);
 +
 +
        LEAVE;
 +
        ENDDO;
 +
 +
 +
        RRNA = NUM11;
 +
        IF RRNA < 0;
 +
        RRNA =  1;
 +
        ENDIF;
 +
 +
        ENDSR;
 +
 +
      //  @@@@@@@  @PCKMOV  @@@@@@@@@@@@@@@@@@@@@@@@
 +
 +
        BEGSR  @PCKMOV;
 +
      //
 +
      //  CONVERT  KEY DATA
 +
      //  SET START POSN IN KEY USING OFFSET IN R
 +
        W = R(Y) + 1;
 +
 +
        // ALPHA
 +
          IF  T(Y) = 'A';
 +
          X1  = 1;
 +
          FOR  Z = W  TO W + Q(Y);
 +
            %SUBST(KW : Z : 1) =  K(X1);
 +
            X1 = X1 + 1;
 +
          ENDFOR;
 +
          ENDIF;
 +
 +
        // NUMERIC FIELD
 +
        // RIGHT  ADJUST NUMERIC DATA ,STRIP - . ,CONVERT BLANKS
 +
          IF (T(Y) = 'S' OR T(Y) = 'P' OR T(Y) = 'B');
 +
          NU = '0';
 +
 +
          Z1 = 60;
 +
          FOR Z  =  K2  DOWNTO K1;
 +
 +
          IF K(Z) = '.' OR K(Z) = '-' OR K(Z) = '$';
 +
          ITER;
 +
          ENDIF;
 +
 +
          IF K(Z) = ' ' ;
 +
          NU(Z1) = '0';
 +
          ELSE;
 +
          NU(Z1) = K(Z);
 +
          ENDIF;
 +
 +
            Z1 = Z1 -1;
 +
          ENDFOR;
 +
 +
          ENDIF;
 +
 +
      // SIGNED FIELDS  (END POSN = OFFSET + SIZE)
 +
        IF T(Y)  = 'S';
 +
          NUS = 0;
 +
          FOR VX = 1 TO 60;
 +
            NUSA = %TRIM(NUSA) + NU(VX);
 +
          ENDFOR;
 +
        %SUBST(KW : W : Q(Y)) = %SUBST(NUSA: 61 -Q(Y));
 +
 +
        ENDIF;
 +
 +
      //  PACKED FIELDS
 +
          IF    T(Y)  =  'P';
 +
          NUSA= *BLANKS;
 +
          FOR VX = 1 TO 60;
 +
            NUSA = %TRIM(NUSA) + NU(VX);
 +
          ENDFOR;
 +
          NUP    = %DEC(NUSA : 60 : 0);
 +
 +
        %SUBST(KW : W : Q(Y))  =  %SUBST(NUPA: 61 -Q(Y));
 +
 +
        ENDIF;
 +
 +
      //  BINARY FIELDS
 +
        IF  T(Y) =  'B';
 +
 +
        IF  Q(Y) = 2 ;
 +
          BY2  = NU(1) + NU(2);
 +
          %SUBST(KW : W : 2)  =  BY2;
 +
        ENDIF;
 +
 +
        IF  Q(Y) = 4 ;
 +
          BY4  = NU(1) + NU(2) + NU(3) + NU(4);
 +
          %SUBST(KW : W : 4)  =  BY4;
 +
        ENDIF;
 +
 +
        ENDIF;
 +
 +
      ENDSR;
 +
 +
 +
      //  @@@@@@@  SETIN  @@@@@@@@@@@@@@@@@@@@@@@@@
 +
          BEGSR      @SETIN;
 +
 +
        //  SET the FFR indicators to get the Input buffer somewhat aligned with the
 +
        //  actual data.  RPG is somewhat tolerant to a difference between the Ispecs
 +
        //  and the actual file size but it can fail on big differences.
 +
        //  INCREMENT OF 32 BYTES
 +
          SZ(1)  = BASE + 16;
 +
          SZ(2)  = SZ(1) + 16;
 +
 +
          *IN30 = *ON;
 +
            IF (RLEN > SZ(2)) ;
 +
            *IN31  = *ON;
 +
            ENDIF;
 +
 +
          FOR X = 3 TO 64;
 +
          SZ(X) = SZ(X-1) + 32;
 +
            IF (RLEN > SZ(X)) ;
 +
            *IN(29+X) = *ON;
 +
            ENDIF;
 +
          ENDFOR;
 +
        ENDSR;
 +
 +
 +
        //@@@@@@@@@@@@@@@@@  @GETF  @@@@@@@@@@@@@@@@@
 +
          BEGSR  @GETF;
 +
      //  GET A DATA RECORD
 +
          IF  (*INU1);
 +
          IF  AID  = '1' OR AID  = X36 OR
 +
              AID  = X39 OR AID  = X3B ;
 +
            SETLL(E) KEYA  INPUTK;
 +
            READ(E)      INPUTK;
 +
              IF %EOF;
 +
              SETLL(E) KEYA  INPUTK;
 +
              READP(E)      INPUTK;
 +
              ENDIF;
 +
          ENDIF;
 +
 +
          IF  AID  = '4';
 +
            READP(E)  INPUTK;
 +
          ENDIF;
 +
 +
          IF  AID  = '5';
 +
            READ(E)  INPUTK;
 +
          ENDIF;
 +
 +
            IF  %ERROR;
 +
            SETLL(E) KEYA  INPUTK;
 +
            READ(E)      INPUTK;
 +
            MX = 7;
 +
                        EXSR      @ERROR;
 +
                        EXSR      @PUTF ;
 +
                        EXSR      @KEYIN;
 +
            ENDIF;
 +
 +
            KEYA = LKY;
 +
 +
 +
            CLEAR KW;
 +
            KW  = LKY;
 +
 +
          ENDIF;
 +
 +
          IF  (*INU2);
 +
          IF  AID  = '1';
 +
            CHAIN(E)  RRNA  INPUTR;
 +
            IF  %ERROR;
 +
              SETLL(E) RRNA  INPUTR;
 +
              READP(E)      INPUTR;
 +
            ENDIF;
 +
          ENDIF;
 +
 +
          IF  AID  = X36;
 +
            CHAIN(E)  RRNA  INPUTR;
 +
          ENDIF;
 +
 +
          IF  AID  = '4';
 +
            READP(E)  INPUTR;
 +
          ENDIF;
 +
 +
          IF  AID  = '5' OR AID = X3B;
 +
            READ(E)  INPUTR;
 +
          ENDIF;
 +
 +
          IF  AID  = X39;
 +
            SETLL(E) *HIVAL INPUTR;
 +
            READP(E)  INPUTR;
 +
          ENDIF;
 +
 +
          IF %ERROR;
 +
            CHAIN  1  INPUTR;
 +
            MX = 7;
 +
            EXSR      @ERROR;
 +
            EXSR      @PUTF ;
 +
            EXSR      @KEYIN;
 +
          ENDIF;
 +
          ENDIF;
 +
 +
          ENDSR;
 +
 +
 +
        //@@@@@@@@@@@@@@@@@  @PUTF  @@@@@@@@@@@@@@@@@
 +
          BEGSR  @PUTF;
 +
 +
        //  WRITE DATA TO THE DISPLAY
 +
 +
            NEWRU  = '1';
 +
            WRTRRN = '1';
 +
            RU    = *ALLX'00';
 +
            CLEAR  RU;        //  initialise Request Unit  255 bytes max
 +
            FOR  XX = 1 TO      NUMFKY; //NUMBER OF DATA ELEMENTS (FLD AND KEY)
 +
 +
            IF NEWRU = '1';
 +
              NEWRU  = '0';
 +
              RU  = ESC + WTD + X20 + X00;
 +
            ENDIF;
 +
 +
            IF WRTRRN = '1';
 +
              WRTRRN = '0';
 +
              RU  = RU + SBA + RBA ;
 +
              SELECT;
 +
                WHEN  *INU1;
 +
                RRN = RN1;
 +
                WHEN  *INU2;
 +
                RRN = RN2;
 +
              ENDSL;
 +
              RU = RU + %TRIM(%EDITC(RRN:'Z'));
 +
            ENDIF;
 +
 +
        // BUFFER ADDRESS
 +
            RU  = RU + SBA + B(XX);
 +
 +
        //  PROCESS ALPHA DATA TYPE
 +
            IF  T(XX) = 'A'  OR T(XX) = 'T'  OR T(XX) = 'Z' OR
 +
                T(XX) = 'L';
 +
 +
              STRX = S(XX);
 +
              ENDX = E(XX);
 +
 +
              IF V(XX) = 'Y';  //VARYING
 +
              VX  = S(XX);
 +
              HX2  = D(VX) + D(VX+1);
 +
              STRX  = S(XX) + 2 ;
 +
              ENDX  = S(XX) + BIN;
 +
              ENDIF;
 +
 +
              FOR Y = STRX  TO ENDX ;
 +
                IF D(Y) >= ' ';
 +
                RU = RU + D(Y);
 +
                ELSE;
 +
                RU = RU + X1F ;  //IF NOT DISPLAYABLE REPLACE WITH X'1F'
 +
                ENDIF;
 +
              ENDFOR;
 +
            ENDIF;
 +
 +
        //  PROCESS SIGNED DATA TYPE (not the RRN field)
 +
            IF  T(XX) = 'S' and KY(XX) <> '3';
 +
              NUSA =  *ALL'0';
 +
              WRV  =  *ALLX'00';
 +
              CLEAR WRV;
 +
              FOR Y = S(XX) TO E(XX);
 +
                IF D(Y) >= XD0;
 +
                WRV    =  WRV + D(Y);
 +
                ENDIF;
 +
              ENDFOR;
 +
              EVAL  NUSA = %SUBST(NUSA : 1 : 60 - %LEN(WRV)) + WRV;
 +
              CLEAR WRU;
 +
              WRU = %TRIM(WRU) + %EDITW(NUS :WRSWRD);
 +
              IF  P(XX) > 0;
 +
                RU  = RU  +
 +
                    %SUBST(WRU :61-C(XX): C(XX)-P(XX)) + '.' +
 +
                    %SUBST(WRU :61-P(XX))    ;
 +
              ELSE;
 +
                RU  = RU  +
 +
                    %SUBST(WRU :61-C(XX));
 +
              ENDIF;
 +
            ENDIF;
 +
 +
 +
        //  PROCESS SIGNED DATA TYPE (the RRN field)
 +
            IF  T(XX) = 'S' and KY(XX) =  '3';
 +
              RRN = RN2;
 +
              RU = RU + %TRIM(%EDITC(RRN:'X'));
 +
            ENDIF;
 +
 +
        //  PROCESS PACKED DATA TYPE
 +
            IF  T(XX) = 'P';
 +
              NUPA =  *ALLX'00';
 +
              WRV  =  *ALLX'00';
 +
              CLEAR WRV;
 +
              FOR Y = S(XX) TO E(XX);
 +
                WRV    =  WRV + D(Y);
 +
              ENDFOR;
 +
 +
              IF  %BITAND(D(E(XX)) :X0F) = X0F OR
 +
                    %BITAND(D(E(XX)) :X0D) = X0D;
 +
 +
                EVAL  NUPA = %SUBST(NUPA : 1 : 60 - %LEN(WRV)) + WRV;
 +
                CLEAR WRX;
 +
                WRX = %TRIM(WRX) + %EDITW(NUP :WRXWRD);
 +
                IF  P(XX) > 0;
 +
                RU  = RU  +
 +
                      %SUBST(WRX :64-C(XX): C(XX)-P(XX)) + '.' +
 +
                      %SUBST(WRX :64-P(XX))    ;
 +
                ELSE;
 +
                RU  = RU  +
 +
                      %SUBST(WRX :64-C(XX));
 +
                ENDIF;
 +
              ELSE;
 +
                // PACKED FIELD IN ERROR
 +
                RU = RU + X1F;
 +
              ENDIF;
 +
 +
            ENDIF;
 +
 +
        //  PROCESS BINARY DATA TYPE
 +
            IF  T(XX) = 'B';
 +
 +
            ST = S(XX);
 +
              CLEAR NUSA;
 +
              IF  Q(XX) = 2;
 +
              BY2  = D(ST) + D(ST+1);
 +
              NUS  = BIN2;
 +
              ENDIF;
 +
              IF  Q(XX) = 4;
 +
              BY4  = D(ST) + D(ST+1)+ D(ST+2) + D(ST+3);
 +
              NUS  = BIN4;
 +
              ENDIF;
 +
 +
              WRU =  %EDITW(NUS :WRSWRD);
 +
              IF  P(XX) > 0;
 +
                RU  = RU  +
 +
                    %SUBST(WRU :61-C(XX): C(XX)-P(XX)) + '.' +
 +
                    %SUBST(WRU :61-P(XX))    ;
 +
              ELSE;
 +
                RU  = RU  +
 +
                    %SUBST(WRU :61-C(XX));
 +
              ENDIF;
 +
            ENDIF;
 +
 +
 +
        //  PROCESS FLOAT  DATA TYPE
 +
            IF  T(XX) = 'F';
 +
 +
            ST = S(XX);
 +
 +
              IF  Q(XX) = 4;
 +
              FL4  = D(ST) + D(ST+1)+ D(ST+2) + D(ST+3);
 +
              FLT14 =  %EDITFLT(FLT4);
 +
                RU  = RU  + FLT14;
 +
              ENDIF;
 +
 +
              IF  Q(XX) = 8;
 +
              FL8  = D(ST) + D(ST+1)+ D(ST+2) + D(ST+3) +
 +
                      D(ST+4) + D(ST+5)+ D(ST+6) + D(ST+7);
 +
              FLT23 =  %EDITFLT(FLT8);
 +
                RU  = RU  + FLT23;
 +
              ENDIF;
 +
 +
            ENDIF;
 +
 +
 +
          //  SEND A REQUEST UNIT IF GOT ENOUGH DATA
 +
 +
            IF  %LEN(RU) + L(XX + 1) >= 200;
 +
              RU  =  RU + X20;
 +
              BIN  =  %LEN(RU);
 +
              OUTLEN  =  HX2;
 +
              INLEN  =  X000;
 +
              FNC    =  SND;
 +
              A      = RU;
 +
              EXCEPT  DATAO;
 +
              NEWRU  = '1';
 +
              RU    = *ALLX'00';
 +
              CLEAR  RU;
 +
            ENDIF;
 +
 +
            ENDFOR;
 +
 +
            IF  %LEN(RU) > 5 AND %LEN(RU) < 250;
 +
              RU  =  RU + X20;
 +
              BIN  =  %LEN(RU);
 +
              OUTLEN  =  HX2;
 +
              INLEN  =  X000;
 +
              FNC    =  SND;
 +
              A      = RU;
 +
              EXCEPT  DATAO;
 +
            ENDIF;
 +
          ENDSR;
 +
 +
 +
        // @@@@@@@@@@@@@@@    ROWINC  @@@@@@@@@@@@@@@
 +
 +
        // INCREMENT THE ROW
 +
          BEGSR    @ROWINC;
 +
          ROW = ROW + 2;
 +
          IF  ROW > 20;
 +
            MX = 3;
 +
          ENDIF;
 +
          ENDSR;
 +
 +
 +
 +
        // @@@@@@@@@@@@@@@    GETFLD  @@@@@@@@@@@@@@@
 +
 +
        // LOAD FIELD DESCRIPTION ARRAYS
 +
          BEGSR    @GETFLD;
 +
          MX = 0;
 +
          X  = 0;
 +
 +
          IF  (*INU2 = *ON);
 +
          // IF NON KEYED ACCESS SET UP A FIELD TO SHOW THE RRN
 +
            N(1) =  'RRN';
 +
            T(1) =  'S'  ;
 +
            C(1) =  11  ;
 +
            P(1) =  0    ;
 +
            S(1) =  0    ;
 +
            E(1) =  0    ;
 +
            L(1) =  12  ;
 +
            I(1) = X4F06 ;
 +
            KY(1)= '3'  ;
 +
            X    = 1    ;
 +
          ENDIF;
 +
 +
          SCRST = *BLANK;
 +
          SCRSTN = *BLANK;
 +
 +
          LVL  = %DEC(SCNLVL : 5:0);
 +
 +
        TEXT500 = SCNLV ;
 +
        LV      = LVW;
 +
 +
        IF  LVL <> 0;
 +
          SCRST = LV(LVL);
 +
        ENDIF;
 +
 +
          SETLL 1 QWHDRFFD ;
 +
 +
          DOW  @LOOP  = @LOOP;
 +
        //  REREAD  TAG
 +
          READ    QWHDRFFD;
 +
          IF %EOF;
 +
            LEAVE;
 +
          ENDIF;
 +
 +
        //  SELECT OR OMIT
 +
          IF  ALL  <> '1';
 +
          IF  ALL  =  'S' AND WHDFTL = 0; // USING WHDFTL FOR KEY FIELDS
 +
            IF  WHFIOB  <>  'S';
 +
              ITER;
 +
            ENDIF;
 +
          ENDIF;
 +
          IF  ALL  =  'O' AND WHDFTL = 0; // USING WHDFTL FOR KEY FIELDS
 +
            IF  WHFIOB  =  'O';
 +
              ITER;
 +
            ENDIF;
 +
          ENDIF;
 +
          ENDIF;
 +
 +
        //  FIND THE FIRST FIELD TO BE SHOWN (FOR MULTI PAGE FORMATS)
 +
          IF  WHDFTL  <> 0 ;
 +
            ELSE;
 +
            IF SCRST <> ' ' AND SCRSTN = ' ';
 +
              IF WHFLDE =  SCRST;
 +
                SCRSTN = '1';    //  FOUND THE START
 +
              ELSE;
 +
                ITER;
 +
              ENDIF;
 +
            ENDIF;
 +
          ENDIF;
 +
 +
 +
          X =  X  + 1;
 +
        // CHECK FOR KEY FIELDS,WILL BE USED TO PLACE THEM IN FRONT
 +
          IF  WHDFTL  <>  0;
 +
              KY(X) = '1';
 +
              WX    = WHDFTL ;
 +
              KE(WX) = WHFLDE;
 +
              IF  NUMKEY <  WHDFTL;
 +
                NUMKEY = WHDFTL;
 +
              ENDIF;
 +
          ENDIF;
 +
 +
            N(X) =  WHFLDE ;              //    NAME
 +
            T(X) =  WHFLDT ;              //    TYPE
 +
            V(X) =  WHVARL ;              //    VARYING
 +
            C(X) =  WHFLDD ;              //    DEC DIGITS
 +
            P(X) =  WHFLDP ;              //    DEC PREC
 +
            S(X) =  WHFOBO ;              //    START
 +
            Q(X) =  WHFLDB ;              //    BTYES
 +
            E(X) =  WHFOBO + WHFLDB -1 ;  //  END
 +
 +
            IF T(X) =  'F' ;              //    FLOAT
 +
 +
              I(X) = FFA1 + FFA2;          //  SCRN FIELD FORMAT ALPHA
 +
              L(X)  = 14;
 +
              IF Q(X) = 8;
 +
              L(X)  = 23;
 +
              ENDIF;
 +
 +
            ELSE;
 +
              IF  WHFLDD  <> 0 ;
 +
              IF  WHFLDP  <> 0 ;
 +
                L(X) =  WHFLDD +  2  ;      //  LENGTH
 +
              ELSE;
 +
                L(X) =  WHFLDD +  1  ;      //  LENGTH
 +
              ENDIF;
 +
 +
                I(X) = FFN1 + FFN2;        //  SCRN FIELD FORMAT NUMERIC
 +
 +
              ELSE;
 +
                L(X) =    WHFLDB  ;
 +
                I(X) = FFA1 + FFA2;        //  SCRN FIELD FORMAT ALPHA
 +
              ENDIF;
 +
            ENDIF;
 +
 +
        ENDDO;
 +
        //  NUMBER OF FIELDS
 +
        NUMFLD = X ;
 +
 +
      //  MAKE ROOM FOR KEYS
 +
          IF  NUMKEY  >  0 ;
 +
          X1  = NUMKEY  + NUMFLD;
 +
 +
          FOR  X =  NUMFLD DOWNTO 1;
 +
              KY(X1) = KY(X) ;
 +
              L(X1)  = L(X)  ;
 +
              I(X1)  = I(X)  ;
 +
              N(X1)  = N(X)  ;
 +
              T(X1)  = T(X)  ;
 +
              V(X1)  = V(X)  ;
 +
              C(X1)  = C(X)  ;
 +
              P(X1)  = P(X)  ;
 +
              S(X1)  = S(X)  ;
 +
              E(X1)  = E(X)  ;
 +
              Q(X1)  = Q(X)  ;
 +
              X1    = X1 - 1;
 +
          ENDFOR;
 +
 +
          //  PUT KEY FIELDS AT TOP
 +
          OFF  = 0;
 +
          FOR  X =  1 TO NUMKEY;
 +
          X1 = %LOOKUP(KE(X) : N : NUMKEY+1);
 +
 +
          KY(X) = '2';
 +
          L(X)  = L(X1);
 +
          I(X)  = I(X1);  // FIELD FMT
 +
          SELECT;                // INPUT ENABLE
 +
            WHEN  I(X) = X6000;
 +
                  I(X) = X4800;
 +
            WHEN  I(X) = X6706;
 +
                  I(X) = X4F06;
 +
          ENDSL;
 +
            N(X) =  N(X1);
 +
            T(X) =  T(X1);
 +
            V(X) =  V(X1);
 +
            C(X) =  C(X1);
 +
            P(X) =  P(X1);
 +
            S(X) =  S(X1);
 +
            E(X) =  E(X1);
 +
            Q(X) =  Q(X1);
 +
            R(X) =  OFF;
 +
            OFF  =  OFF + Q(X1);
 +
          ENDFOR;
 +
 +
        ENDIF;
 +
      //  NUMBER OF FIELDS AND KEYS
 +
        NUMFKY = NUMFLD  +  NUMKEY;
 +
 +
        ENDSR;
 +
 +
 +
        // @@@@@@@@@@@@@@@    GETADD  @@@@@@@@@@@@@@@
 +
 +
        // LOAD FIELD BUFFER ADDRESSES
 +
          BEGSR    @GETADD;
 +
          MX = 0;
 +
          X  = 0;
 +
          ROW = 3;
 +
          COL = 1;
 +
 +
          FOR X = 1 TO NUMFKY;
 +
 +
        // IF FINISHED WITH THE KEY FIELDS
 +
        //  INC  ROW FOR 1ST DATA FIELD
 +
          IF KEYSOK = ' ' ;
 +
          IF KY(X) = ' ' OR KY(X) = '1';
 +
            KEYSOK = '1' ;
 +
            ROW    = ROW + 2;
 +
            COL    = 1;
 +
          ENDIF;
 +
          ENDIF;
 +
 +
        //  SET THE BUFFER ADD ON THE LARGER OF THE FIELD TEXT OR THE FIELD SIZE
 +
          LENDSC  = %LEN(%TRIM(N(X)));
 +
          LENWRK  =  L(X);
 +
          IF LENDSC > L(X);
 +
            LENWRK = LENDSC;
 +
          ENDIF;
 +
            LENWRK = LENWRK + 2;
 +
 +
        //  TRAP FIELDS THAT OVERFLOW
 +
            ROW  = ROW  + XROW;
 +
            XROW = %DIV(LENWRK : 80);
 +
 +
            IF (COL + LENWRK) > 78;
 +
              EXSR @ROWINC;
 +
                IF MX = 3;
 +
                X= X-1;
 +
                NUMFKY = X;
 +
                LEAVE;
 +
                ENDIF;
 +
              COL = 1;
 +
            ENDIF;
 +
 +
        // INC COL. FOR FIELD START
 +
          CLEAR  B(X);
 +
          BIN  = ROW;
 +
          B(X) =  %TRIM(B(X)) + HX1;
 +
          BIN  = COL + 1;
 +
          B(X) =  %TRIM(B(X)) + HX1;
 +
 +
        // INC COL. FOR NEXT FIELD
 +
        COL = COL + LENWRK;
 +
            IF COL > 78;
 +
              EXSR @ROWINC;
 +
                IF MX = 3;    // NO ROOM FOR THE FIELD
 +
                X= X-1;
 +
                NUMFKY = X;
 +
                LEAVE;
 +
                ENDIF;
 +
              COL = 1;
 +
            ENDIF;
 +
 +
          ENDFOR;
 +
 +
        //  FIELD LEVEL
 +
          LVX      = LVL + 1;
 +
          LV(LVX)  = N(X);
 +
 +
        ENDSR;
 +
 +
 +
        // @@@@@@@@@@@@@@@    PUTHED  @@@@@@@@@@@@@@@
 +
 +
        //  PUT FIELD HEADINGS
 +
          BEGSR    @PUTHED;
 +
 +
 +
            NEWRU  = '1';
 +
 +
            RU    = *ALLX'00';
 +
            CLEAR  RU;                  //  initialise Request Unit  255 bytes max
 +
            FOR  XX = 1 TO      NUMFKY; //NUMBER OF DATA ELEMENTS (FLD AND KEY)
 +
 +
            IF NEWRU = '1';
 +
              NEWRU  = '0';
 +
              RU  = ESC + WTD + X20 + X00;
 +
            ENDIF;
 +
 +
            RU = RU + SBA;
 +
            BIN = 0;
 +
              // CONVERT DATA BUFADR TO HEADING BUFADR
 +
            HX1 = %SUBST(B(XX) :1:1);
 +
            BIN = BIN - 1;
 +
            RU  = RU + HX1;
 +
 +
            IF  REHEAD = '1'; // ON REDISPLAY OVERRIDE THE ATTR
 +
              BIN = 0;
 +
              HX1 = %SUBST(B(XX) :2:1);
 +
              BIN = BIN -1 ;
 +
              RU  = RU + HX1;
 +
            ELSE;
 +
              RU  = RU + %SUBST(B(XX) :2);
 +
            ENDIF;
 +
 +
            RU = RU + ATC ;
 +
 +
        //  LONG NUMBER FIELDS ,RIGHT ADJUST THE FIELD HEADINGS
 +
            LENDSC  = %LEN(%TRIM(N(XX)));
 +
            IF  T(XX) <> 'A' AND  LENDSC <  (L(XX) -1);
 +
            FOR Y = 1 TO (L(XX) -(LENDSC +1));
 +
              RU = RU + ' ';
 +
            ENDFOR;
 +
            ENDIF;
 +
 +
            RU = RU + %TRIM(N(XX));
 +
 +
              IF %LEN(RU) >= 200;
 +
              BIN    = %LEN(RU);
 +
              OUTLEN = HX2;
 +
              INLEN  = X000;
 +
              FNC    = SND;
 +
              A      = RU;
 +
              EXCEPT DATAO;
 +
              NEWRU  = '1';
 +
              RU    = *ALLX'00';
 +
              CLEAR  RU;
 +
              ENDIF;
 +
 +
            ENDFOR;
 +
 +
              IF %LEN(RU) >  5 AND %LEN(RU) <  200;
 +
              BIN    = %LEN(RU);
 +
              OUTLEN = HX2;
 +
              INLEN  = X000;
 +
              FNC    = SND;
 +
              A      = RU;
 +
              EXCEPT DATAO;
 +
              ENDIF;
 +
 +
          IF REHEAD <> '1';
 +
        //  FORMAT FIELDS
 +
 +
 +
            NEWRU  = '1';
 +
            RU    = *ALLX'00';
 +
            CLEAR  RU;                  //  initialise Request Unit  255 bytes max
 +
            FOR  XX = 1 TO      NUMFKY; //NUMBER OF DATA ELEMENTS (FLD AND KEY)
 +
 +
            IF NEWRU = '1';
 +
              NEWRU  = '0';
 +
              RU  = ESC + WTD + X20 + X00;
 +
            ENDIF;
 +
 +
            RU = RU + SBA +B(XX)+SF + I(XX);
 +
 +
            IF KY(XX) = '1' OR KY(XX) = '2' OR KY(XX) = '3';
 +
              RU = RU + X25;
 +
            ELSE;
 +
              RU = RU + X26;
 +
            ENDIF;
 +
 +
            BIN =  L(XX);
 +
            RU  = RU + HX2;
 +
 +
          // LENGTH OF INPUT FIELDS
 +
            LENF  = LENF + L(XX) + 3;
 +
 +
 +
              IF %LEN(RU) >= 200;
 +
              BIN    = %LEN(RU);
 +
              OUTLEN = HX2;
 +
              INLEN  = X000;
 +
              FNC    = SND;
 +
              A      = RU;
 +
              EXCEPT DATAO;
 +
              NEWRU  = '1';
 +
              RU    = *ALLX'00';
 +
              CLEAR  RU;
 +
              ENDIF;
 +
 +
          ENDFOR;
 +
 +
      //  PUT LAST R/U
 +
              IF %LEN(RU) >  5 AND %LEN(RU) <  200;
 +
              BIN    = %LEN(RU);
 +
              OUTLEN = HX2;
 +
              INLEN  = X000;
 +
              FNC    = SND;
 +
              A      = RU;
 +
              EXCEPT DATAO;
 +
              ENDIF;
 +
 +
        //INC BUFFER ADDRESS FOR ALL FIELDS FOR DATA PUT
 +
            FOR  XP = 1 TO      NUMFKY; //NUMBER OF DATA ELEMENTS (FLD AND KEY)
 +
            HX2  = B(XP);
 +
            BIN  = BIN + 1;
 +
            B(XP) = HX2;
 +
            ENDFOR;
 +
          ENDIF;
 +
 +
        ENDSR;
 +
 +
      //  @@@@@@@  INIT  @@@@@@@@@@@@@@@@@@@@@@@@@
 +
          BEGSR        @INIT;
 +
 +
        CLEAR  KW;
 +
 +
        //  UPDATE
 +
          IF  UPDF  = 'Y';
 +
                FFA1 = X40;
 +
                FFN1 = X47;
 +
          ELSE;
 +
                FFA1 = X60;
 +
                FFN1 = X67;
 +
          ENDIF;
 +
 +
          SELECT;
 +
          WHEN  *INU1 = '1';
 +
                FILE  =  F1 ;
 +
                LIB  =  L1 ;
 +
                MBR  =  M1 ;
 +
                RCDL  =  R1 ;
 +
                ACCTP =  A1 ;
 +
          WHEN  *INU2 = '1';
 +
                FILE  =  F2 ;
 +
                LIB  =  L2 ;
 +
                MBR  =  M2 ;
 +
                RCDL  =  R2 ;
 +
                ACCTP =  A2 ;
 +
          ENDSL;
 +
            RLEN    =  RCDL  ;
 +
            RLENTH  =  %EDITC(RLEN: 'X') ;
 +
            LENF    =  0    ;
 +
 +
 +
        // Control commands and data are constructed into RUs Request UNITS
 +
        // Each RU is 256 bytes max size.
 +
        // Construct and send as many RUs as needed to format the display.
 +
            RU    = *ALLX'00';
 +
            CLEAR  RU;        //  initialise Request Unit  255 bytes max
 +
            RU  = CLRWTD ;
 +
          //set up the screen headings
 +
            BIN = 1;    // set ROW to 1
 +
            RW  = HX1;
 +
            BIN = 2;    // set COL to 2
 +
            CL  = HX1;
 +
            RU  = RU + SBA + RW + CL + X22 + %TRIM(LIB) + '/' + %TRIM(FILE);
 +
            RU  = RU + ' Mbr ' + %TRIM(MBR) + ' Rcdl ' + %EDITC(RLEN  : 'Z') ;
 +
            RU  = RU + ' RRN '  ;
 +
            BIN = %len(RU) -4;
 +
            RBA = RW + HX1 ;  // address of the RRN field
 +
            RU  = RU + SBA + RBA + '          ';
 +
 +
      // FUNCTION KEYS
 +
            BIN  = 23;
 +
            RW  = HX1;
 +
            BIN  = 02;
 +
            CL  = HX1;
 +
            IF  UPDF = 'Y';  //  UPDATE IS ON
 +
            RU  = RU + SBA + RW + CL + %TRIM(CNS(2));
 +
            ELSE;
 +
            RU  = RU + SBA + RW + CL + %TRIM(CNS(1));
 +
            ENDIF;
 +
 +
        //  THIS IS A SEND ONLY FUNCTION
 +
          FNC    = SND;
 +
          CLEAR A;
 +
          A      = RU;
 +
          BIN2    = %LEN(RU);
 +
          OUTLEN  = BY2;
 +
          INLEN  = x000;
 +
 +
          EXCEPT    DATAO;
 +
 +
        ENDSR;
 +
 +
 +
      //  @@@@@@@  KEYIN  @@@@@@@@@@@@@@@@@@@@@@@@@
 +
        BEGSR  @KEYIN;
 +
      // ISSUE A READ FROM DISPLAY
 +
          FNC = SNR;
 +
          BIN2  = 8;
 +
          OUTLEN = BY2;
 +
          IPL = LENF + 34;
 +
          BIN2  = IPL;
 +
          INLEN  = BY2;
 +
 +
          // SET FRR INDICATORS TO CONTROL BUFFER OVERFLOW
 +
          FOR X =  1 TO  9;
 +
            IF IPL  >  ( X*80 +3);
 +
              *IN(X+19) = *ON;
 +
            ENDIF;
 +
          ENDFOR;
 +
 +
        RU    = *ALLX'00';
 +
        CLEAR  RU;
 +
        RU  = RDDSP;
 +
        A    = RU;
 +
 +
        EXCEPT DATAI;
 +
        ENDSR;
 +
 +
      //  @@@@@@@  ERROR  @@@@@@@@@@@@@@@@@@@@@@@@@
 +
        BEGSR    @ERROR;
 +
 +
      // SETUP PUT ERROR MESSAGE X'21'
 +
        RU    = *ALLX'00';
 +
        CLEAR RU;
 +
 +
        FNC    =  SNR;
 +
        BIN    = 42;
 +
        OUTLEN = HX2;
 +
        BIN    = LENF + 34;
 +
        IPL    = BIN;
 +
        INLEN  = HX2;
 +
 +
        FOR X        = 1 TO 9;
 +
          IF IPL      > (X * 80 +3) ;
 +
          *IN(X + 19) = *ON;          // SETON FFR 20 - 29 FOR INPUT
 +
          ENDIF;
 +
        ENDFOR;
 +
 +
        RU = ESC + WER + IC + B(1) + ATC + MSG(MX);
 +
        RU = RU + ESC + RDM + X40+ X00;
 +
 +
        A  = RU;
 +
        EXCEPT    DATAI;
 +
        RU    = *ALLX'00';
 +
        CLEAR RU;
 +
        ENDSR;
 +
 +
 +
      //  @@@@@@@    HXDSP @@@@@@@@@@@@@@@@@@@@@@@@@
 +
        BEGSR  @HXDSP;
 +
 +
          RU    = *ALLX'00';
 +
          CLEAR RU;
 +
          Y = %LOOKUPLE( CURLOC : B );
 +
          //
 +
          RU = ESC + WTD + X20 + X00 + SBA;
 +
          BIN = 0;
 +
          HX1 = %SUBST(B(Y) :1:1);
 +
          BIN = BIN - 1;
 +
          RU  = RU + HX1;
 +
          RU  = RU + %SUBST(B(Y) :2:1);
 +
 +
          FOR X = S(Y) TO E(Y);
 +
            BIN = 0;
 +
            HX1 = D(X);
 +
            HX1 = %BITAND(HX1  : XF0);
 +
            Z  = BIN / 16 + 1;
 +
            RU  = RU + CRS(Z);
 +
          ENDFOR;
 +
 +
            RU  = RU + X20;
 +
 +
            RU  = RU + SBA + B(Y);
 +
          FOR X = S(Y) TO E(Y);
 +
            BIN = 0;
 +
            HX1 = D(X);
 +
            HX1 = %BITAND(HX1  : X0F);
 +
            Z  = BIN  + 1;
 +
            RU  = RU + CRS(Z);
 +
          ENDFOR;
 +
 +
 +
          BIN    = %LEN(RU);
 +
          OUTLEN = HX2;
 +
          INLEN  = X000;
 +
          FNC    = SND;
 +
          A      = RU;
 +
          EXCEPT DATAO;
 +
          RU    = *ALLX'00';
 +
          CLEAR  RU;
 +
 +
 +
          EXSR      @KEYIN;
 +
          READ      DISPF;
 +
 +
 +
      //  CLEAR HEADINGS
 +
            RU    = *ALLX'00';
 +
            CLEAR RU;
 +
 +
        RU  = RU + ESC + WTD + X20 + X00 + SBA;
 +
        HX1  = %SUBST(B(Y) :1:1) ;
 +
        BIN  = BIN - 1;
 +
        RU  = RU + HX1 + %SUBST(B(Y):2:1);
 +
          FOR X = S(Y) TO E(Y);
 +
          RU = RU + ' ';
 +
          ENDFOR;
 +
        RU = RU + ' ';
 +
 +
        BIN    = %LEN(RU);
 +
        OUTLEN = HX2;
 +
        INLEN  = X000;
 +
        FNC    = SND;
 +
        A      = RU;
 +
        EXCEPT    DATAO;
 +
        RU    = *ALLX'00';
 +
        CLEAR  RU;
 +
 +
        ENDSR;
 +
 +
 +
      /END-FREE
 +
 +
    ODISPF    E            DATAO
 +
    O                                          K3 'PUT'
 +
    O                      OUTLEN              2
 +
    O                      INLEN
 +
    O                      FNC
 +
    O                      A
 +
 +
    O          E            DATAI
 +
    O                                          K3 'GET'
 +
    O                      OUTLEN              2
 +
    O                      INLEN
 +
    O                      FNC
 +
    O                      A
 +
**
 +
0000 INVALID COMMAND KEY
 +
0001  - A FIELD IS TOO LONG
 +
0002  - TOO MANY FIELDS
 +
0003  - ALPHAS IN PACKED KEY
 +
0004  - MISSING ' IN PACKED KEY
 +
0005  - MISSING DATA IN PCKD KEY
 +
0006  - RECORD NOT FOUND
 +
PRESS RESET TO CONTINUE
 +
**
 +
F1-HEX F2-Return F3-Exit F19-Prev_fld F20-More_fld
 +
F1-HEX F2-Return F3-Exit F19-Prev_fld F20-More_fld
 +
**
 +
0123456789ABCDEF
 +
 
</pre>
 
</pre>
  

Revision as of 12:20, 27 October 2018


UDDS

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


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

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

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


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

DISP RPG

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

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

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


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

     D TEXT800         S            800
     D KW              S            800

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

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

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

     D FLT14           S             14
     D FLT23           S             23

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

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

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

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

     D                 DS
     D  FLT4                   1      4F
     D  FL4                    1      4

     D                 DS
     D  FLT8                   1      8F
     D  FL8                    1      8

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

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


     D @LOOP           C                   '1'

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


      /FREE
             BASE = 0;

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

         //   START        TAG
           DOW       @LOOP = @LOOP;

           IF  RTN  = '3';

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

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

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

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

        //  CF20 MORE FIELDS
           IF  AID  = XB8;

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

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

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

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

       //  CF19 PREVIOUS FIELDS
           IF  AID  = XB7;

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

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

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

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

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

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


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

          ENDDO ;

           *INLR = *ON;

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

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

          BEGSR   @PCKD ;

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

          ENDSR;

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

          BEGSR   @CVTKEY;

       // EXTRACT THE KEY FIELD DATA FROM THE INCOMING STRING

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

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

           FOR  Y  = 1  TO NUMKEY ;

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

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

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

          X  =  1;

          DOW  @LOOP = @LOOP;

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

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

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

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

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

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

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

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

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

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

         ENDFOR;

         //
          KEYA  = KW;
          CLEAR KW;
        ENDSR ;

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

          BEGSR   @CVTRRN;

        //   RRN

           NUM11 = 0;

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

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

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

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

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

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


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

         LEAVE;
         ENDDO;


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

         ENDSR;

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

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

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

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

          Z1 = 60;
          FOR Z  =  K2  DOWNTO K1;

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

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

            Z1 = Z1 -1;
          ENDFOR;

          ENDIF;

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

        ENDIF;

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

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

        ENDIF;

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

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

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

        ENDIF;

       ENDSR;


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

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

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

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


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

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

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

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

             KEYA = LKY;


             CLEAR KW;
             KW   = LKY;

          ENDIF;

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

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

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

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

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

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

          ENDSR;


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

        //  WRITE DATA TO THE DISPLAY

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

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

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

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

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

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

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

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

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


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

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

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

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

             ENDIF;

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

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

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


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

             ST = S(XX);

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

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

             ENDIF;


           //   SEND A REQUEST UNIT IF GOT ENOUGH DATA

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

            ENDFOR;

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


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

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



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

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

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

          SCRST = *BLANK;
          SCRSTN = *BLANK;

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

         TEXT500 = SCNLV ;
         LV      = LVW;

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

          SETLL 1 QWHDRFFD ;

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

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

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


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

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

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

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

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

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

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

        ENDDO;
        //  NUMBER OF FIELDS
         NUMFLD = X ;

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

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

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

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

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

        ENDSR;


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

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

          FOR X = 1 TO NUMFKY;

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

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

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

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

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

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

          ENDFOR;

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

        ENDSR;


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

        //  PUT FIELD HEADINGS
          BEGSR     @PUTHED;


            NEWRU  = '1';

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

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

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

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

             RU = RU + ATC ;

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

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

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

            ENDFOR;

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

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


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

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

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

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

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

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


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

           ENDFOR;

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

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

        ENDSR;

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

        CLEAR  KW;

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

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


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

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

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

           EXCEPT    DATAO;

        ENDSR;


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

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

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

         EXCEPT DATAI;
         ENDSR;

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

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

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

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

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

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


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

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

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

             RU  = RU + X20;

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


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


          EXSR      @KEYIN;
          READ      DISPF;


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

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

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

         ENDSR;


      /END-FREE

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

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


#top

DISPF DSPF

     A                                      DSPSIZ(24 80 *DS3)
     A                                      PRINT
     A                                      OPENPRT
     A                                      HELP
     A                                      INDARA
     A          R PUT                       USRDFN
     A          R GET                       USRDFN
     A                                      INVITE


#top

WRAPPER CODE

DISPR RPG







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