Difference between revisions of "UDDS File Display/Update"

From MidrangeWiki
Jump to: navigation, search
(Created page with "--")
 
m (DIS1 CL files with NULL fields cant be processed)
 
(36 intermediate revisions by the same user not shown)
Line 1: Line 1:
--
+
__FORCETOC__
 +
 
 +
 
 +
==UDDS PROGRAMS THAT SHOW FILES FIELDS AND RELATIONS AND ALLOWS UPDATE ==
 +
The manual that describes the 5250 data stream is 5494 Remote Control Unit, Functions Reference. SC30-3533-04 (topic 15) [http://tn5250.sourceforge.net/resources.html]
 +
 
 +
 
 +
The purpose of this program is to demo an example of a program using UDDS.
 +
 
 +
It shows file data, but is limited to 6048 max rcdlen.  There are 3 programs first is limited to 2048 last to 6048.
 +
 
 +
Use the code below at your own risk, no warranty is expressed or implied or even that the code is functional.
 +
 
 +
 
 +
I am also inculding wrapper programs to make the displayer more useful.
 +
The COMPILE CL will create the objects once you have copied the source code into a source file.
 +
 
 +
Once compiled the command to run it is  'DSPFL  yourlib/yourfile '
 +
 
 +
 
 +
===DISP  RPG===
 +
 
 +
<pre>
 +
    H*eywords++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++Comments+++++++++++
 +
    H OPTION(*NODEBUGIO)
 +
    H DFTACTGRP(*NO) ACTGRP(*CALLER) DFTNAME(DISP )
 +
    F*
 +
    F*  LIMITED TO MAXIMUM FILE LENGTH OF 2048
 +
    F*  TEST
 +
    F*  REQUIRES FILE TO COMPILE
 +
    F*  DSPFFD  FILE(&LIB/&FILE) OUTPUT(*OUTFILE) OUTFILE(QTEMP/FFD)
 +
 
 +
    FFFD      IF  E            DISK
 +
    FDISPF    CF  F  803        WORKSTN
 +
    F*
 +
    F                                    INFDS(INFDS)
 +
    FINPUTK    IF  F32766  800AIDISK    KEYLOC(1)
 +
    F                                    EXTIND(*INU1)
 +
    F                                    INFDS(INFDK)
 +
    FINPUTR    IF  F32766        DISK    EXTIND(*INU2)
 +
    F                                    INFDS(INFDR)
 +
 
 +
      *
 +
    D A              S            255                                        WORK RU
 +
    D RU              S            255    varying
 +
    D RW              S              1                                        ROW 1 byte binary
 +
    D CL              S              1                                        COL 1 byte binary
 +
    D FNC            S              1
 +
    D OUTLEN          S              2
 +
    D INLEN          S              2
 +
    D IPL            S              5  0
 +
    D ROW            S              3  0
 +
    D XROW            S              3  0
 +
    D COL            S              3  0
 +
    D KEYSOK          S              1
 +
    D LENDSC          S              3  0
 +
    D LENWRK          S              5  0
 +
    D STRX            S              5  0
 +
    D ENDX            S              5  0
 +
    D VX              S              5  0
 +
    D X              S              5  0
 +
    D X1              S              5  0
 +
    D X2              S              5  0
 +
    D XX              S              5  0
 +
    D XP              S              5  0
 +
    D MX              S              5  0
 +
    D ONCE            S              1
 +
    D RBA            S              2
 +
    D LF              S              5  0
 +
    D ST              S              5  0
 +
    D Y              S              5  0
 +
    D Z              S              5  0
 +
    D OFF            S              5  0
 +
    D SUPZ            S              1
 +
    D NUMFLD          S              5  0
 +
    D WX              S              5  0
 +
    D NUMKEY          S              5  0
 +
    D NUMFKY          S              5  0
 +
    D SCRST          S            10
 +
    D SCRSTN          S              1
 +
    D KEYA            S            800
 +
    D RRNA            S            11  0
 +
    D RRN            S            11  0
 +
    D REHEAD          S              1
 +
    D NEWRU          S              1
 +
    D WRTRRN          S              1
 +
    D LVX            S              5  0
 +
    D LVL            S              5  0
 +
    D K1              S              5  0
 +
    D K2              S              5  0
 +
    D Z1              S              5  0
 +
    D W              S              5  0
 +
    D WK2            S              2
 +
    D MSSG            S            32
 +
      *
 +
    D BASE            S              5  0
 +
    D INZ            S              1
 +
 
 +
    D FILE            S            10
 +
    D LIB            S            10
 +
    D MBR            S            10
 +
    D RCDL            S              5  0
 +
    D ACCTP          S              1
 +
    D RLEN            S              5  0
 +
    D RLENTH          S              5
 +
    D LENF            S              5  0
 +
 
 +
 
 +
    D                DS
 +
    D TEXT500                      500
 +
    D LVW                          10    DIM(50) overlay(TEXT500:1)
 +
 
 +
    D TEXT800        S            800
 +
    D KW              S            800
 +
 
 +
    D                DS
 +
    D WRK11                  1    11
 +
    D NUM11                  1    11S 0
 +
 
 +
    D                DS
 +
    D NUSA                    1    60
 +
    D NUS                    1    60S 0
 +
    D                DS
 +
    D NUPA                    1    60
 +
    D NUP                    29    60P 0
 +
 
 +
    D WRU            S            61
 +
    D WRX            S            64
 +
    D WRXWRD          C                  '0                              -
 +
    D                                                                    -'
 +
    D WRSWRD          C                  '0                              -
 +
    D                                                                  -'
 +
    D WRV            S            60    varying
 +
 
 +
    D FLT14          S            14
 +
    D FLT23          S            23
 +
 
 +
      * SET FILE SIZE INCREMENTS (64 OF THEM)
 +
    D SZ              S              5  0 DIM(64)
 +
    D S              S              5  0 DIM(9000)                            START OF FLD
 +
    D E              S              5  0 DIM(9000)                            END OF FLD
 +
    D Q              S              5  0 DIM(9000)                            BYTES IN FIELD
 +
    D L              S              5  0 DIM(9000)                            LENGTH OF FLD
 +
    D C              S              3  0 DIM(9000)                            DEC DIGITS
 +
    D P              S              3  0 DIM(9000)                            DEC PRECISION
 +
    D B              S              2    DIM(9000) ASCEND                    BUFFER ADD
 +
    D I              S              2    DIM(9000)                            FLD FMT
 +
    D N              S            10    DIM(9000)                            FLD NAME
 +
    D T              S              1    DIM(9000)                            FLD TYPE
 +
    D V              S              1    DIM(9000)                            VARYING
 +
    D KY              S              1    DIM(9000)                            KEYED
 +
    D KE              S            10    DIM(128)                            KEY FLDS
 +
    D R              S              3  0 DIM(9000)                            KEY FLD START
 +
    D K              S              1    DIM(800)                            KEY
 +
    D NA              S              1    DIM(10)                              NAME WORK
 +
    D NU              S              1    DIM(60)                              NUM. WORK
 +
    D LV              S            10    DIM(50)                              SCREEN LEVELS
 +
    D MSG            S            32    DIM(8) CTDATA PERRCD(1)              MESSAGES
 +
    D CNS            S            50    DIM(2) CTDATA PERRCD(1)
 +
    D CRS            S              1    DIM(16) CTDATA PERRCD(16)
 +
 
 +
    D                DS
 +
    D  D                      1  2048
 +
    D                                    DIM(2048)                            INCOMING DATA
 +
    D  DA                    1    16
 +
    D  DB                    17    32
 +
    D  DC                    33    64
 +
    D  DD                    65    96
 +
    D  DE                    97    128
 +
    D  DF                  129    160
 +
    D  DG                  161    192
 +
    D  DH                  193    224
 +
    D  DI                  225    256
 +
    D  DJ                  257    288
 +
    D  DK                  289    320
 +
    D  DL                  321    352
 +
    D  DM                  353    384
 +
    D  DN                  385    416
 +
    D  DZ                  417    448
 +
    D  DO                  449    480
 +
    D  DP                  481    512
 +
    D  DQ                  513    544
 +
    D  DR                  545    576
 +
    D  DS                  577    608
 +
    D  DT                  609    640
 +
    D  DU                  641    672
 +
    D  DV                  673    704
 +
    D  DW                  705    736
 +
    D  DX                  737    768
 +
    D  DY                  769    800
 +
    D  D0                  801    832
 +
    D  D1                  833    864
 +
    D  D2                  865    896
 +
    D  D3                  897    928
 +
    D  D4                  929    960
 +
    D  D5                  961    992
 +
    D  D6                  993  1024
 +
    D  DBA                1025  1056
 +
    D  DCA                1057  1088
 +
    D  DDA                1089  1120
 +
    D  DEA                1121  1152
 +
    D  DFA                1153  1184
 +
    D  DGA                1185  1216
 +
    D  DHA                1217  1248
 +
    D  DIA                1249  1280
 +
    D  DJA                1281  1312
 +
    D  DKA                1313  1344
 +
    D  DLA                1345  1376
 +
    D  DMA                1377  1408
 +
    D  DNA                1409  1440
 +
    D  DOA                1441  1472
 +
    D  DPA                1473  1504
 +
    D  DQA                1505  1536
 +
    D  DRA                1537  1568
 +
    D  DSA                1569  1600
 +
    D  DTA                1601  1632
 +
    D  DUA                1633  1664
 +
    D  DVA                1665  1696
 +
    D  DWA                1697  1728
 +
    D  DXA                1729  1760
 +
    D  DYA                1761  1792
 +
    D  DZA                1793  1824
 +
    D  D0A                1825  1856
 +
    D  D1A                1857  1888
 +
    D  D2A                1889  1920
 +
    D  D3A                1921  1952
 +
    D  D4A                1953  1984
 +
    D  D5A                1985  2016
 +
    D  D6A                2017  2048
 +
    D                DS
 +
    D  ID                    1    800
 +
    D                                    DIM(800)                            INCOMING DATA
 +
    D  IDA                    1    800
 +
    D  ID0                    1    80
 +
    D  ID1                  81    160
 +
    D  ID2                  161    240
 +
    D  ID3                  241    320
 +
    D  ID4                  321    400
 +
    D  ID5                  401    480
 +
    D  ID6                  481    560
 +
    D  ID7                  561    640
 +
    D  ID8                  641    720
 +
    D  ID9                  721    800
 +
    D                DS
 +
    D  BIN                    1      2B 0
 +
    D  HX1                    2      2
 +
    D  HX2                    1      2
 +
    D                DS
 +
    D  PCK                    1      1P 0
 +
    D  PCK1                  1      1
 +
    D                DS
 +
    D  SGN                    1      1S 0
 +
    D  SGN1                  1      1
 +
 
 +
    D                DS
 +
    D  BIN4                  1      4B 0
 +
    D  BY4                    1      4
 +
 
 +
    D                DS
 +
    D  BIN2                  1      2B 0
 +
    D  BY2                    1      2
 +
 
 +
    D                DS
 +
    D  FLT4                  1      4F
 +
    D  FL4                    1      4
 +
 
 +
    D                DS
 +
    D  FLT8                  1      8F
 +
    D  FL8                    1      8
 +
 
 +
    D INFDK          DS
 +
    D  F1                    83    92
 +
    D  L1                    93    102
 +
    D  M1                  129    138
 +
    D  R1                  125    126B 0
 +
    D  A1                  160    160
 +
    D  LOP1                260    260
 +
    D  KEY_LEN              393    394I 0                                      Key length
 +
    D  RN1                  397    400B 0
 +
    D  LKY                  401  1200
 +
    D INFDR          DS
 +
    D  F2                    83    92
 +
    D  L2                    93    102
 +
    D  M2                  129    138
 +
    D  R2                  125    126B 0
 +
    D  A2                  160    160
 +
    D  LOP2                260    260
 +
    D  RN2                  397    400B 0
 +
    D*
 +
    D INFDS          DS
 +
    D  CURLOC              370    371
 +
    D                DS
 +
    D KEYLN                  1      4S 0
 +
    D KEYLNA                  1      4
 +
 
 +
    DDISP            PR
 +
    D                                1
 +
    D                                1
 +
    D                                4
 +
    D                                1
 +
    D                              500
 +
    D                                5
 +
    D                              800
 +
    DDISP            PI
 +
    D  ALL                          1
 +
    D  RTN                          1
 +
    D  KEYLNG                      4
 +
    D  UPDF                        1
 +
    D  SCNLV                      500
 +
    D  SCNLVL                      5
 +
    D  SCNKEY                    800
 +
 
 +
 
 +
    D @LOOP          C                  '1'
 +
 
 +
    D SND            C                  X'71'                                SEND TO DISP
 +
    D SNR            C                  X'73'                                SND/RCV
 +
    D RED            C                  X'42'                                READ
 +
    D RDM            C                  X'52'                                READ MTD
 +
    D ESC            C                  X'04'                                ESCAPE
 +
    D CLR            C                  X'40'                                CLEAR UNIT
 +
    D CC1            C                  X'00'                                CNTRL CHAR
 +
    D CC2            C                  X'08'                                CNTRL CHAR
 +
    D SBA            C                  X'11'                                SET BUFF ADR
 +
    D IC              C                  X'13'                                INSERT CURS
 +
    D WTD            C                  X'11'                                WRITE TO DSP
 +
    D WER            C                  X'21'                                WRITE ERROR
 +
    D SF              C                  X'1D'                                START FLD
 +
    D ATC            C                  X'20'                                ATTR CHAR
 +
    D ATN            C                  X'24'                                ATTR NUM
 +
    D X00            C                  X'00'
 +
    D X01            C                  X'01'
 +
    D X02            C                  X'02'
 +
    D X03            C                  X'03'
 +
    D X0D            C                  X'0D'
 +
    D X0F            C                  X'0F'
 +
    D X000            C                  X'0000'
 +
    D X1F            C                  X'1F'
 +
    D X20            C                  X'20'                                SCRN ATT NORMAL
 +
    D X22            C                  X'22'                                SCRN ATTR HI
 +
    D X25            C                  X'25'
 +
    D X26            C                  X'26'
 +
    D X31            C                  X'31'                                CMD 1 KEY
 +
    D X32            C                  X'32'                                CMD 2 KEY
 +
    D X33            C                  X'33'                                CMD 3 KEY
 +
    D X36            C                  X'36'                                CMD 6 KEY
 +
    D X37            C                  X'37'                                CMD 7 KEY
 +
    D X38            C                  X'38'                                CMD 8 KEY
 +
    D X39            C                  X'39'                                CMD 9 KEY
 +
    D X3B            C                  X'3B'                                CMD11 KEY
 +
    D XB7            C                  X'B7'                                CMD19 KEY
 +
    D XB8            C                  X'B8'                                CMD20 KEY
 +
    D X40            C                  X'40'
 +
    D X43            C                  X'43'
 +
    D X47            C                  X'47'
 +
    D X60            C                  X'60'
 +
    D X67            C                  X'67'
 +
    D X9F            C                  X'9F'
 +
    D XF0            C                  X'F0'
 +
    D XD0            C                  X'D0'
 +
    D X4000          C                  X'4000'
 +
    D X4800          C                  X'4800'                              FF ALPHA
 +
    D X4F06          C                  X'4F06'                              FF NUMERIC
 +
    D X6000          C                  X'6000'                              FF ALPHA
 +
    D X6706          C                  X'6706'                              FF NUMERIC
 +
    D CLRWTD          C                  X'044004112000'                      INCLUDES ESC CHARS
 +
    D RDDSP          C                  X'0411200804524000'                  REAB FROM DISPLAY
 +
    D FFA1            S              1    INZ(X'40')                          F.FMT 1 ALPH  60 BYP
 +
    D FFA2            S              1    INZ(X'00')                          F.FMT 2 ALPH
 +
    D FFN1            S              1    INZ(X'47')                          F.FMT 1 NUM  67 BYP
 +
    D FFN2            S              1    INZ(X'06')                          F.FMT 2 NUM
 +
    I*.
 +
    IINPUTK    NS  01
 +
    I                                  1  16  DA
 +
    I                                17  32  DB                30
 +
    I                                33  64  DC                31
 +
    I                                65  96  DD                32
 +
    I                                97  128  DE                33
 +
    I                                129  160  DF                34
 +
    I                                161  192  DG                35
 +
    I                                193  224  DH                36
 +
    I                                225  256  DI                37
 +
    I                                257  288  DJ                38
 +
    I                                289  320  DK                39
 +
    I                                321  352  DL                40
 +
    I                                353  384  DM                41
 +
    I                                385  416  DN                42
 +
    I                                417  448  DZ                43
 +
    I                                449  480  DO                44
 +
    I                                481  512  DP                45
 +
    I                                513  544  DQ                46
 +
    I                                545  576  DR                47
 +
    I                                577  608  DS                48
 +
    I                                609  640  DT                49
 +
    I                                641  672  DU                50
 +
    I                                673  704  DV                51
 +
    I                                705  736  DW                52
 +
    I                                737  768  DX                53
 +
    I                                769  800  DY                54
 +
    I                                801  832  D0                55
 +
    I                                833  864  D1                56
 +
    I                                865  896  D2                57
 +
    I                                897  928  D3                58
 +
    I                                929  960  D4                59
 +
    I                                961  992  D5                60
 +
    I                                993 1024  D6                61
 +
    I                              1025 1056  DBA              62
 +
    I                              1057 1088  DCA              63
 +
    I                              1089 1120  DDA              64
 +
    I                              1121 1152  DEA              65
 +
    I                              1153 1184  DFA              66
 +
    I                              1185 1216  DGA              67
 +
    I                              1217 1248  DHA              68
 +
    I                              1249 1280  DIA              69
 +
    I                              1281 1312  DJA              70
 +
    I                              1313 1344  DKA              71
 +
    I                              1345 1376  DLA              72
 +
    I                              1377 1408  DMA              73
 +
    I                              1409 1440  DNA              74
 +
    I                              1441 1472  DOA              75
 +
    I                              1473 1504  DPA              76
 +
    I                              1505 1536  DQA              77
 +
    I                              1537 1568  DRA              78
 +
    I                              1569 1600  DSA              79
 +
    I                              1601 1632  DTA              80
 +
    I                              1633 1664  DUA              81
 +
    I                              1665 1696  DVA              82
 +
    I                              1697 1728  DWA              83
 +
    I                              1729 1760  DXA              84
 +
    I                              1761 1792  DYA              85
 +
    I                              1793 1824  DZA              86
 +
    I                              1825 1856  D0A              87
 +
    I                              1857 1888  D1A              88
 +
    I                              1889 1920  D2A              89
 +
    I                              1921 1952  D3A              90
 +
    I                              1953 1984  D4A              91
 +
    I                              1985 2016  D5A              92
 +
    I                              2017 2048  D6A              93
 +
    IINPUTR    NS  01
 +
    I                                  1  16  DA
 +
    I                                17  32  DB                30
 +
    I                                33  64  DC                31
 +
    I                                65  96  DD                32
 +
    I                                97  128  DE                33
 +
    I                                129  160  DF                34
 +
    I                                161  192  DG                35
 +
    I                                193  224  DH                36
 +
    I                                225  256  DI                37
 +
    I                                257  288  DJ                38
 +
    I                                289  320  DK                39
 +
    I                                321  352  DL                40
 +
    I                                353  384  DM                41
 +
    I                                385  416  DN                42
 +
    I                                417  448  DZ                43
 +
    I                                449  480  DO                44
 +
    I                                481  512  DP                45
 +
    I                                513  544  DQ                46
 +
    I                                545  576  DR                47
 +
    I                                577  608  DS                48
 +
    I                                609  640  DT                49
 +
    I                                641  672  DU                50
 +
    I                                673  704  DV                51
 +
    I                                705  736  DW                52
 +
    I                                737  768  DX                53
 +
    I                                769  800  DY                54
 +
    I                                801  832  D0                55
 +
    I                                833  864  D1                56
 +
    I                                865  896  D2                57
 +
    I                                897  928  D3                58
 +
    I                                929  960  D4                59
 +
    I                                961  992  D5                60
 +
    I                                993 1024  D6                61
 +
    I                              1025 1056  DBA              62
 +
    I                              1057 1088  DCA              63
 +
    I                              1089 1120  DDA              64
 +
    I                              1121 1152  DEA              65
 +
    I                              1153 1184  DFA              66
 +
    I                              1185 1216  DGA              67
 +
    I                              1217 1248  DHA              68
 +
    I                              1249 1280  DIA              69
 +
    I                              1281 1312  DJA              70
 +
    I                              1313 1344  DKA              71
 +
    I                              1345 1376  DLA              72
 +
    I                              1377 1408  DMA              73
 +
    I                              1409 1440  DNA              74
 +
    I                              1441 1472  DOA              75
 +
    I                              1473 1504  DPA              76
 +
    I                              1505 1536  DQA              77
 +
    I                              1537 1568  DRA              78
 +
    I                              1569 1600  DSA              79
 +
    I                              1601 1632  DTA              80
 +
    I                              1633 1664  DUA              81
 +
    I                              1665 1696  DVA              82
 +
    I                              1697 1728  DWA              83
 +
    I                              1729 1760  DXA              84
 +
    I                              1761 1792  DYA              85
 +
    I                              1793 1824  DZA              86
 +
    I                              1825 1856  D0A              87
 +
    I                              1857 1888  D1A              88
 +
    I                              1889 1920  D2A              89
 +
    I                              1921 1952  D3A              90
 +
    I                              1953 1984  D4A              91
 +
    I                              1985 2016  D5A              92
 +
    I                              2017 2048  D6A              93
 +
    IDISPF    NS  02
 +
    I                                  3    3  AID
 +
    I                                  4  83  ID0
 +
    I                                84  163  ID1              20
 +
    I                                164  243  ID2              21
 +
    I                                244  323  ID3              22
 +
    I                                324  403  ID4              23
 +
    I                                404  483  ID5              24
 +
    I                                484  563  ID6              25
 +
    I                                564  643  ID7              26
 +
    I                                644  723  ID8              27
 +
    I                                724  803  ID9              28
 +
 
 +
 
 +
      /FREE
 +
            BASE = 0;
 +
 
 +
            IF  ONCE  =  ' ';
 +
                EXSR      @INITZ  ;
 +
            ENDIF;
 +
 
 +
        //  START        TAG
 +
          DOW      @LOOP = @LOOP;
 +
 
 +
          IF  RTN  = '3';
 +
 
 +
              IF *INU1;
 +
                KEYA =  SCNKEY;
 +
              ENDIF;
 +
              IF *INU2;
 +
                RRNA =  %DEC(%SUBST(SCNKEY:1:11):11:0);
 +
              ENDIF;
 +
                RTN = '0';
 +
                AID = '1';
 +
            ELSE;
 +
              RTN  = '0';
 +
              READ(E)  DISPF;
 +
          ENDIF;
 +
 
 +
        //  CF3 EXIT
 +
          IF  AID  = X33;
 +
            LEAVE;
 +
          ENDIF;
 +
 
 +
        //  CF2 RETURN
 +
          IF  AID  = X32;
 +
            RTN = '1';
 +
            LEAVE;
 +
          ENDIF;
 +
 
 +
        // CF1 HEX A FIELD
 +
          IF  AID  = X31;
 +
          Y = %LOOKUPLE( CURLOC : B );
 +
          IF Y > 0;
 +
            IF KY(Y) <= '1';
 +
              EXSR      @HXDSP;
 +
              REHEAD  = '1';
 +
              EXSR      @PUTHED;
 +
              REHEAD  = ' ';
 +
            ENDIF;
 +
            ENDIF;
 +
          ENDIF;
 +
 
 +
        //  CF20 MORE FIELDS
 +
          IF  AID  = XB8;
 +
 
 +
            LVX  = LVL + 1;
 +
            IF  LV(LVX)  <> *BLANK;
 +
              LVL = LVL +1 ;
 +
 
 +
              LVW  = LV;
 +
              SCNLV = TEXT500;
 +
              SCNLVL = %EDITC(LVL :'X');
 +
 
 +
            SCNKEY = *BLANKS;
 +
          IF  *INU1;
 +
                SCNKEY = KEYA;
 +
          ENDIF;
 +
          IF  *INU2;
 +
                SCNKEY = %EDITC(RRNA:'X');
 +
          ENDIF;
 +
 
 +
              RTN = '3';
 +
              LEAVE;
 +
            ENDIF;
 +
          ENDIF;
 +
 
 +
      //  CF19 PREVIOUS FIELDS
 +
          IF  AID  = XB7;
 +
 
 +
            LVX  = LVL - 1;
 +
            IF  LVX    >= 0 ;
 +
              LVL = LVL - 1 ;
 +
 
 +
              LVW  = LV;
 +
              SCNLV = TEXT500;
 +
              SCNLVL = %EDITC(LVL :'X');
 +
 
 +
                SCNKEY = *BLANKS;
 +
          IF  *INU1;
 +
                SCNKEY = KEYA;
 +
          ENDIF;
 +
          IF  *INU2;
 +
                SCNKEY = %EDITC(RRNA:'X');
 +
          ENDIF;
 +
 
 +
              RTN = '3';
 +
              LEAVE;
 +
            ENDIF;
 +
          ENDIF;
 +
 
 +
          // 1 ENTER
 +
          // 4 ROLL DN
 +
          // 5 ROLL UP
 +
          IF  AID  = '1'or AID = '4' or AID = '5';
 +
          ELSE;
 +
            MX = 1;
 +
            EXSR  @ERROR;
 +
          ENDIF;
 +
 
 +
          IF  RTN <> '3';
 +
            EXSR      @PCKD;
 +
          ENDIF;
 +
 
 +
 
 +
        // CONT1  GET A RECORD, KEY FROM DATA
 +
            EXSR      @SETIN;
 +
            EXSR      @GETF ;
 +
            EXSR      @PUTF ;
 +
            EXSR      @KEYIN;
 +
 
 +
          ENDDO ;
 +
 
 +
          *INLR = *ON;
 +
 
 +
      //  @@@@@@@  @INITZ @@@@@@@@@@@@@@@@@@@@@@@@@@
 +
        BEGSR  @INITZ;
 +
                ONCE  =  '1';
 +
                KEYLNA = KEYLNG  ;
 +
                EXSR      @INIT  ;
 +
                EXSR      @GETFLD ;
 +
                EXSR      @GETADD ;
 +
                EXSR      @PUTHED ;
 +
                EXSR      @KEYIN  ;
 +
                INZ  = '1';
 +
                EXSR      @PCKD  ;
 +
                INZ  = ' ';
 +
        ENDSR;
 +
 
 +
      //  @@@@@@@  @PCKD  @@@@@@@@@@@@@@@@@@@@@@@@@@
 +
 
 +
          BEGSR  @PCKD ;
 +
 
 +
            //  CONVERT  KEY DATA
 +
            IF  *INU1 ;
 +
              EXSR  @CVTKEY;
 +
            ENDIF;
 +
            IF  *INU2 ;
 +
              EXSR  @CVTRRN;
 +
            ENDIF;
 +
 
 +
          ENDSR;
 +
 
 +
      //  @@@@@@@  @CVTKEY  @@@@@@@@@@@@@@@@@@@@@@@@
 +
 
 +
          BEGSR  @CVTKEY;
 +
 
 +
      // EXTRACT THE KEY FIELD DATA FROM THE INCOMING STRING
 +
 
 +
        // FOR EACH KEY FIELD, CHECK IF FIELD WAS MODIFIED, AND IF SO MOVE
 +
        // THE MODIFIED DATA INTO THE COMPOSITE KEY
 +
 
 +
        K1 = 0;
 +
        K2 = 0;
 +
        W  = 1;
 +
 
 +
          FOR  Y  = 1  TO NUMKEY ;
 +
 
 +
      //  MOVE A KEY FIELDS DATA FROM ID ARRAY (SCREEN) TO K ARRAY (KEY FIELDS)
 +
 
 +
      //  GET SIZE OF FIELD IN BYTES
 +
          IF T(Y)  =  'A';  // ALPHA DATA
 +
          K = ' ';
 +
          K1 = 1;
 +
          K2 = Q(Y);
 +
          ELSE;
 +
          K  = '0';
 +
          K1 =  1;
 +
          K2 = C(Y);
 +
          ENDIF;
 +
 
 +
      // IF WHOLE KEY INIT WAS REQUESTED BYPASS THE EXTRACT
 +
          IF  INZ  = '1' ;
 +
            KW  = *BLANK;
 +
            EXSR      @PCKMOV;
 +
            ITER;
 +
          ENDIF;
 +
 
 +
          X  =  1;
 +
 
 +
          DOW  @LOOP = @LOOP;
 +
 
 +
      //  NXTSBA
 +
          X  = %LOOKUP(SBA : ID : X );
 +
          IF X = 0;
 +
            LEAVE;
 +
          ENDIF;
 +
 
 +
      // IS THIS THE FIELD?  CHECK THE BUFFER ADDRESS
 +
        X = X +1;
 +
        IF  B(Y)  <>  %SUBST(IDA : X :2);
 +
          ITER;
 +
        ENDIF;
 +
 
 +
      //  FOUND A MTD FOR THIS FIELD
 +
        X =  X + 2;
 +
 
 +
      //  CHECK IF FIELD WAS CLEARED ONLY
 +
        IF  ID(X) = SBA;
 +
            EXSR      @PCKMOV;
 +
            LEAVE ;
 +
        ENDIF;
 +
 
 +
      //  IF FIELD HAS DECIMALS BUMP X
 +
          IF (T(Y) = 'S' OR T(Y) = 'P' OR T(Y) = 'B') AND
 +
              P(Y) > 0;
 +
              X = X + 1;
 +
          ENDIF;
 +
 
 +
      //  CHECK IF ONLY BLANKS RETURNED
 +
        IF    %SUBST(IDA : X :K2) = *BLANKS;
 +
            EXSR      @PCKMOV;
 +
            LEAVE;
 +
        ENDIF;
 +
 
 +
      // EXTRACT THE DATA FROM THE INCOMING STRING
 +
        X1  = X;
 +
        FOR X2  =  1 TO  K2 ;
 +
 
 +
          IF ID(X1) < ' ';
 +
      // TRAP NULLS CAUSED BY FLD EXIT
 +
            EXSR      @PCKMOV;
 +
            LEAVE;
 +
          ENDIF;
 +
 
 +
        K(X2)  =  ID(X1);
 +
        X1    =  X1 +1;
 +
        ENDFOR;
 +
 
 +
        // CONSTRUCT THE ACTUAL KEY WITH PACKED DATA IF REQUIRED
 +
        // INTO ARRAY KW
 +
          EXSR      @PCKMOV;
 +
          LEAVE;
 +
        ENDDO;
 +
 
 +
        ENDFOR;
 +
 
 +
        //
 +
          KEYA  = KW;
 +
          CLEAR KW;
 +
        ENDSR ;
 +
 
 +
      //  @@@@@@@  @CVTRRN  @@@@@@@@@@@@@@@@@@@@@@@@
 +
 
 +
          BEGSR  @CVTRRN;
 +
 
 +
        //  RRN
 +
 
 +
          NUM11 = 0;
 +
 
 +
          DOW  @LOOP = @LOOP;  //  NOT REALLY A LOOP(SIMULATES GOTO)
 +
 
 +
      // GET THE FIRST SBA
 +
          X = 1;
 +
          X  = %LOOKUP(SBA : ID : X );
 +
          IF X = 0;
 +
          LEAVE;
 +
          ENDIF;
 +
 
 +
      // CHECK THE BUFFER ADDRESS MATCHES THE EXPECTED FIELD
 +
        X = X +1;
 +
        IF  B(1)  <>  %SUBST(IDA : X :2);
 +
          LEAVE;
 +
        ENDIF;
 +
 
 +
      //  FOUND A MTD FOR RRN  FIELD
 +
        X = X +2;
 +
 
 +
      //CHECK IF FIELD WAS CLEARED ONLY
 +
        IF  ID(X) = SBA;
 +
            LEAVE;
 +
        ENDIF;
 +
 
 +
      //  CHECK IF ONLY BLANKS RETURNED
 +
        IF    %SUBST(IDA : X :11) = *BLANKS;
 +
            LEAVE;
 +
        ENDIF;
 +
 
 +
 
 +
        //  WRK11  OVERLAYS NUM11
 +
        WRK11 = %SUBST(IDA : X :11);
 +
 
 +
        LEAVE;
 +
        ENDDO;
 +
 
 +
 
 +
        RRNA = NUM11;
 +
        IF RRNA < 0;
 +
        RRNA =  1;
 +
        ENDIF;
 +
 
 +
        ENDSR;
 +
 
 +
      //  @@@@@@@  @PCKMOV  @@@@@@@@@@@@@@@@@@@@@@@@
 +
 
 +
        BEGSR  @PCKMOV;
 +
      //
 +
      //  CONVERT  KEY DATA
 +
      //  SET START POSN IN KEY USING OFFSET IN R
 +
        W = R(Y) + 1;
 +
 
 +
        // ALPHA
 +
          IF  T(Y) = 'A';
 +
          X1  = 1;
 +
          FOR  Z = W  TO W + Q(Y);
 +
            %SUBST(KW : Z : 1) =  K(X1);
 +
            X1 = X1 + 1;
 +
          ENDFOR;
 +
          ENDIF;
 +
 
 +
        // NUMERIC FIELD
 +
        // RIGHT  ADJUST NUMERIC DATA ,STRIP - . ,CONVERT BLANKS
 +
          IF (T(Y) = 'S' OR T(Y) = 'P' OR T(Y) = 'B');
 +
          NU = '0';
 +
 
 +
          Z1 = 60;
 +
          FOR Z  =  K2  DOWNTO K1;
 +
 
 +
          IF K(Z) = '.' OR K(Z) = '-' OR K(Z) = '$';
 +
          ITER;
 +
          ENDIF;
 +
 
 +
          IF K(Z) = ' ' ;
 +
          NU(Z1) = '0';
 +
          ELSE;
 +
          NU(Z1) = K(Z);
 +
          ENDIF;
 +
 
 +
            Z1 = Z1 -1;
 +
          ENDFOR;
 +
 
 +
          ENDIF;
 +
 
 +
      // SIGNED FIELDS  (END POSN = OFFSET + SIZE)
 +
        IF T(Y)  = 'S';
 +
          NUS = 0;
 +
          FOR VX = 1 TO 60;
 +
            NUSA = %TRIM(NUSA) + NU(VX);
 +
          ENDFOR;
 +
        %SUBST(KW : W : Q(Y)) = %SUBST(NUSA: 61 -Q(Y));
 +
 
 +
        ENDIF;
 +
 
 +
      //  PACKED FIELDS
 +
          IF    T(Y)  =  'P';
 +
          NUSA= *BLANKS;
 +
          FOR VX = 1 TO 60;
 +
            NUSA = %TRIM(NUSA) + NU(VX);
 +
          ENDFOR;
 +
          NUP    = %DEC(NUSA : 60 : 0);
 +
 
 +
        %SUBST(KW : W : Q(Y))  =  %SUBST(NUPA: 61 -Q(Y));
 +
 
 +
        ENDIF;
 +
 
 +
      //  BINARY FIELDS
 +
        IF  T(Y) =  'B';
 +
 
 +
        IF  Q(Y) = 2 ;
 +
          BY2  = NU(1) + NU(2);
 +
          %SUBST(KW : W : 2)  =  BY2;
 +
        ENDIF;
 +
 
 +
        IF  Q(Y) = 4 ;
 +
          BY4  = NU(1) + NU(2) + NU(3) + NU(4);
 +
          %SUBST(KW : W : 4)  =  BY4;
 +
        ENDIF;
 +
 
 +
        ENDIF;
 +
 
 +
      ENDSR;
 +
 
 +
 
 +
      //  @@@@@@@  SETIN  @@@@@@@@@@@@@@@@@@@@@@@@@
 +
          BEGSR      @SETIN;
 +
 
 +
        //  SET the FFR indicators to get the Input buffer somewhat aligned with the
 +
        //  actual data.  RPG is somewhat tolerant to a difference between the Ispecs
 +
        //  and the actual file size but it can fail on big differences.
 +
        //  INCREMENT OF 32 BYTES
 +
          SZ(1)  = BASE + 16;
 +
          SZ(2)  = SZ(1) + 16;
 +
 
 +
          *IN30 = *ON;
 +
            IF (RLEN > SZ(2)) ;
 +
            *IN31  = *ON;
 +
            ENDIF;
 +
 
 +
          FOR X = 3 TO 64;
 +
          SZ(X) = SZ(X-1) + 32;
 +
            IF (RLEN > SZ(X)) ;
 +
            *IN(29+X) = *ON;
 +
            ENDIF;
 +
          ENDFOR;
 +
        ENDSR;
 +
 
 +
 
 +
        //@@@@@@@@@@@@@@@@@  @GETF  @@@@@@@@@@@@@@@@@
 +
          BEGSR  @GETF;
 +
      //  GET A DATA RECORD
 +
          IF  (*INU1);
 +
          IF  AID  = '1' OR AID  = X36 OR
 +
              AID  = X39 OR AID  = X3B ;
 +
            SETLL(E) KEYA  INPUTK;
 +
            READ(E)      INPUTK;
 +
              IF %EOF;
 +
              SETLL(E) KEYA  INPUTK;
 +
              READP(E)      INPUTK;
 +
              ENDIF;
 +
          ENDIF;
 +
 
 +
          IF  AID  = '4';
 +
            READP(E)  INPUTK;
 +
          ENDIF;
 +
 
 +
          IF  AID  = '5';
 +
            READ(E)  INPUTK;
 +
          ENDIF;
 +
 
 +
            IF  %ERROR;
 +
            SETLL(E) KEYA  INPUTK;
 +
            READ(E)      INPUTK;
 +
            MX = 7;
 +
                        EXSR      @ERROR;
 +
                        EXSR      @PUTF ;
 +
                        EXSR      @KEYIN;
 +
            ENDIF;
 +
 
 +
            KEYA = LKY;
 +
 
 +
 
 +
            CLEAR KW;
 +
            KW  = LKY;
 +
 
 +
          ENDIF;
 +
 
 +
          IF  (*INU2);
 +
          IF  AID  = '1';
 +
            CHAIN(E)  RRNA  INPUTR;
 +
            IF  %ERROR;
 +
              SETLL(E) RRNA  INPUTR;
 +
              READP(E)      INPUTR;
 +
            ENDIF;
 +
          ENDIF;
 +
 
 +
          IF  AID  = X36;
 +
            CHAIN(E)  RRNA  INPUTR;
 +
          ENDIF;
 +
 
 +
          IF  AID  = '4';
 +
            READP(E)  INPUTR;
 +
          ENDIF;
 +
 
 +
          IF  AID  = '5' OR AID = X3B;
 +
            READ(E)  INPUTR;
 +
          ENDIF;
 +
 
 +
          IF  AID  = X39;
 +
            SETLL(E) *HIVAL INPUTR;
 +
            READP(E)  INPUTR;
 +
          ENDIF;
 +
 
 +
          IF %ERROR;
 +
            CHAIN  1  INPUTR;
 +
            MX = 7;
 +
            EXSR      @ERROR;
 +
            EXSR      @PUTF ;
 +
            EXSR      @KEYIN;
 +
          ENDIF;
 +
          ENDIF;
 +
 
 +
          ENDSR;
 +
 
 +
 
 +
        //@@@@@@@@@@@@@@@@@  @PUTF  @@@@@@@@@@@@@@@@@
 +
          BEGSR  @PUTF;
 +
 
 +
              SELECT;
 +
                WHEN  *INU1;
 +
                RRN = RN1;
 +
                WHEN  *INU2;
 +
                RRN = RN2;
 +
              ENDSL;
 +
 
 +
        // IF GOT RECORDS WRITE DATA TO THE DISPLAY
 +
 
 +
            NEWRU  = '1';
 +
            WRTRRN = '1';
 +
            RU    = *ALLX'00';
 +
            CLEAR  RU;        //  initialise Request Unit  255 bytes max
 +
 
 +
          IF RRN > 0    ;
 +
            FOR  XX = 1 TO      NUMFKY; //NUMBER OF DATA ELEMENTS (FLD AND KEY)
 +
 
 +
            IF NEWRU = '1';
 +
              NEWRU  = '0';
 +
              RU  = ESC + WTD + X20 + X00;
 +
            ENDIF;
 +
 
 +
            IF WRTRRN = '1';
 +
              WRTRRN = '0';
 +
              RU  = RU + SBA + RBA ;
 +
              RU = RU + %TRIM(%EDITC(RRN:'Z'));
 +
            ENDIF;
 +
 
 +
        // BUFFER ADDRESS
 +
            RU  = RU + SBA + B(XX);
 +
 
 +
        //  PROCESS ALPHA DATA TYPE
 +
            IF  T(XX) = 'A'  OR T(XX) = 'T'  OR T(XX) = 'Z' OR
 +
                T(XX) = 'L';
 +
 
 +
              STRX = S(XX);
 +
              ENDX = E(XX);
 +
 
 +
              IF V(XX) = 'Y';  //VARYING
 +
              VX  = S(XX);
 +
              HX2  = D(VX) + D(VX+1);
 +
              STRX  = S(XX) + 2 ;
 +
              ENDX  = S(XX) + BIN;
 +
              ENDIF;
 +
 
 +
              FOR Y = STRX  TO ENDX ;
 +
                IF D(Y) >= ' ';
 +
                RU = RU + D(Y);
 +
                ELSE;
 +
                RU = RU + X1F ;  //IF NOT DISPLAYABLE REPLACE WITH X'1F'
 +
                ENDIF;
 +
              ENDFOR;
 +
            ENDIF;
 +
 
 +
        //  PROCESS SIGNED DATA TYPE (not the RRN field)
 +
            IF  T(XX) = 'S' and KY(XX) <> '3';
 +
              NUSA =  *ALL'0';
 +
              WRV  =  *ALLX'00';
 +
              CLEAR WRV;
 +
              FOR Y = S(XX) TO E(XX);
 +
                IF D(Y) >= XD0;
 +
                WRV    =  WRV + D(Y);
 +
                ENDIF;
 +
              ENDFOR;
 +
              EVAL  NUSA = %SUBST(NUSA : 1 : 60 - %LEN(WRV)) + WRV;
 +
              CLEAR WRU;
 +
              WRU = %TRIM(WRU) + %EDITW(NUS :WRSWRD);
 +
              IF  P(XX) > 0;
 +
                RU  = RU  +
 +
                    %SUBST(WRU :61-C(XX): C(XX)-P(XX)) + '.' +
 +
                    %SUBST(WRU :61-P(XX))    ;
 +
              ELSE;
 +
                RU  = RU  +
 +
                    %SUBST(WRU :61-C(XX));
 +
              ENDIF;
 +
            ENDIF;
 +
 
 +
 
 +
        //  PROCESS SIGNED DATA TYPE (the RRN field)
 +
            IF  T(XX) = 'S' and KY(XX) =  '3';
 +
              RRN = RN2;
 +
              RU = RU + %TRIM(%EDITC(RRN:'X'));
 +
            ENDIF;
 +
 
 +
        //  PROCESS PACKED DATA TYPE
 +
            IF  T(XX) = 'P';
 +
              NUPA =  *ALLX'00';
 +
              WRV  =  *ALLX'00';
 +
              CLEAR WRV;
 +
              FOR Y = S(XX) TO E(XX);
 +
                WRV    =  WRV + D(Y);
 +
              ENDFOR;
 +
 
 +
              IF  %BITAND(D(E(XX)) :X0F) = X0F OR
 +
                    %BITAND(D(E(XX)) :X0D) = X0D;
 +
 
 +
                EVAL  NUPA = %SUBST(NUPA : 1 : 60 - %LEN(WRV)) + WRV;
 +
                CLEAR WRX;
 +
                WRX = %TRIM(WRX) + %EDITW(NUP :WRXWRD);
 +
                IF  P(XX) > 0;
 +
                RU  = RU  +
 +
                      %SUBST(WRX :64-C(XX): C(XX)-P(XX)) + '.' +
 +
                      %SUBST(WRX :64-P(XX))    ;
 +
                ELSE;
 +
                RU  = RU  +
 +
                      %SUBST(WRX :64-C(XX));
 +
                ENDIF;
 +
              ELSE;
 +
                // PACKED FIELD IN ERROR
 +
                RU = RU + X1F;
 +
              ENDIF;
 +
 
 +
            ENDIF;
 +
 
 +
        //  PROCESS BINARY DATA TYPE
 +
            IF  T(XX) = 'B';
 +
 
 +
            ST = S(XX);
 +
              CLEAR NUSA;
 +
              IF  Q(XX) = 2;
 +
              BY2  = D(ST) + D(ST+1);
 +
              NUS  = BIN2;
 +
              ENDIF;
 +
              IF  Q(XX) = 4;
 +
              BY4  = D(ST) + D(ST+1)+ D(ST+2) + D(ST+3);
 +
              NUS  = BIN4;
 +
              ENDIF;
 +
 
 +
              WRU =  %EDITW(NUS :WRSWRD);
 +
              IF  P(XX) > 0;
 +
                RU  = RU  +
 +
                    %SUBST(WRU :61-C(XX): C(XX)-P(XX)) + '.' +
 +
                    %SUBST(WRU :61-P(XX))    ;
 +
              ELSE;
 +
                RU  = RU  +
 +
                    %SUBST(WRU :61-C(XX));
 +
              ENDIF;
 +
            ENDIF;
 +
 
 +
 
 +
        //  PROCESS FLOAT  DATA TYPE
 +
            IF  T(XX) = 'F';
 +
 
 +
            ST = S(XX);
 +
 
 +
              IF  Q(XX) = 4;
 +
              FL4  = D(ST) + D(ST+1)+ D(ST+2) + D(ST+3);
 +
              FLT14 =  %EDITFLT(FLT4);
 +
                RU  = RU  + FLT14;
 +
              ENDIF;
 +
 
 +
              IF  Q(XX) = 8;
 +
              FL8  = D(ST) + D(ST+1)+ D(ST+2) + D(ST+3) +
 +
                      D(ST+4) + D(ST+5)+ D(ST+6) + D(ST+7);
 +
              FLT23 =  %EDITFLT(FLT8);
 +
                RU  = RU  + FLT23;
 +
              ENDIF;
 +
 
 +
            ENDIF;
 +
 
 +
 
 +
          //  SEND A REQUEST UNIT IF GOT ENOUGH DATA
 +
 
 +
            IF  %LEN(RU) + L(XX + 1) >= 200;
 +
              RU  =  RU + X20;
 +
              BIN  =  %LEN(RU);
 +
              OUTLEN  =  HX2;
 +
              INLEN  =  X000;
 +
              FNC    =  SND;
 +
              A      = RU;
 +
              EXCEPT  DATAO;
 +
              NEWRU  = '1';
 +
              RU    = *ALLX'00';
 +
              CLEAR  RU;
 +
            ENDIF;
 +
 
 +
            ENDFOR;
 +
          ENDIF;
 +
 
 +
            IF  %LEN(RU) > 5 AND %LEN(RU) < 250;
 +
              RU  =  RU + X20;
 +
              BIN  =  %LEN(RU);
 +
              OUTLEN  =  HX2;
 +
              INLEN  =  X000;
 +
              FNC    =  SND;
 +
              A      = RU;
 +
              EXCEPT  DATAO;
 +
            ENDIF;
 +
          ENDSR;
 +
 
 +
 
 +
        // @@@@@@@@@@@@@@@    ROWINC  @@@@@@@@@@@@@@@
 +
 
 +
        // INCREMENT THE ROW
 +
          BEGSR    @ROWINC;
 +
          ROW = ROW + 2;
 +
          IF  ROW > 20;
 +
            MX = 3;
 +
          ENDIF;
 +
          ENDSR;
 +
 
 +
 
 +
 
 +
        // @@@@@@@@@@@@@@@    GETFLD  @@@@@@@@@@@@@@@
 +
 
 +
        // LOAD FIELD DESCRIPTION ARRAYS
 +
          BEGSR    @GETFLD;
 +
          MX = 0;
 +
          X  = 0;
 +
 
 +
          IF  (*INU2 = *ON);
 +
          // IF NON KEYED ACCESS SET UP A FIELD TO SHOW THE RRN
 +
            N(1) =  'RRN';
 +
            T(1) =  'S'  ;
 +
            C(1) =  11  ;
 +
            P(1) =  0    ;
 +
            S(1) =  0    ;
 +
            E(1) =  0    ;
 +
            L(1) =  12  ;
 +
            I(1) = X4F06 ;
 +
            KY(1)= '3'  ;
 +
            X    = 1    ;
 +
          ENDIF;
 +
 
 +
          SCRST = *BLANK;
 +
          SCRSTN = *BLANK;
 +
 
 +
          LVL  = %DEC(SCNLVL : 5:0);
 +
 
 +
        TEXT500 = SCNLV ;
 +
        LV      = LVW;
 +
 
 +
        IF  LVL <> 0;
 +
          SCRST = LV(LVL);
 +
        ENDIF;
 +
 
 +
          SETLL 1 QWHDRFFD ;
 +
 
 +
          DOW  @LOOP  = @LOOP;
 +
        //  REREAD  TAG
 +
          READ    QWHDRFFD;
 +
          IF %EOF;
 +
            LEAVE;
 +
          ENDIF;
 +
 
 +
        //  SELECT OR OMIT
 +
          IF  ALL  <> '1';
 +
          IF  ALL  =  'S' AND WHDFTL = 0; // USING WHDFTL FOR KEY FIELDS
 +
            IF  WHFIOB  <>  'S';
 +
              ITER;
 +
            ENDIF;
 +
          ENDIF;
 +
          IF  ALL  =  'O' AND WHDFTL = 0; // USING WHDFTL FOR KEY FIELDS
 +
            IF  WHFIOB  =  'O';
 +
              ITER;
 +
            ENDIF;
 +
          ENDIF;
 +
          ENDIF;
 +
 
 +
        //  FIND THE FIRST FIELD TO BE SHOWN (FOR MULTI PAGE FORMATS)
 +
          IF  WHDFTL  <> 0 ;
 +
            ELSE;
 +
            IF SCRST <> ' ' AND SCRSTN = ' ';
 +
              IF WHFLDE =  SCRST;
 +
                SCRSTN = '1';    //  FOUND THE START
 +
              ELSE;
 +
                ITER;
 +
              ENDIF;
 +
            ENDIF;
 +
          ENDIF;
 +
 
 +
 
 +
          X =  X  + 1;
 +
        // CHECK FOR KEY FIELDS,WILL BE USED TO PLACE THEM IN FRONT
 +
          IF  WHDFTL  <>  0;
 +
              KY(X) = '1';
 +
              WX    = WHDFTL ;
 +
              KE(WX) = WHFLDE;
 +
              IF  NUMKEY <  WHDFTL;
 +
                NUMKEY = WHDFTL;
 +
              ENDIF;
 +
          ENDIF;
 +
 
 +
            N(X) =  WHFLDE ;              //    NAME
 +
            T(X) =  WHFLDT ;              //    TYPE
 +
            V(X) =  WHVARL ;              //    VARYING
 +
            C(X) =  WHFLDD ;              //    DEC DIGITS
 +
            P(X) =  WHFLDP ;              //    DEC PREC
 +
            S(X) =  WHFOBO ;              //    START
 +
            Q(X) =  WHFLDB ;              //    BTYES
 +
            E(X) =  WHFOBO + WHFLDB -1 ;  //  END
 +
 
 +
            IF T(X) =  'F' ;              //    FLOAT
 +
 
 +
              I(X) = FFA1 + FFA2;          //  SCRN FIELD FORMAT ALPHA
 +
              L(X)  = 14;
 +
              IF Q(X) = 8;
 +
              L(X)  = 23;
 +
              ENDIF;
 +
 
 +
            ELSE;
 +
              IF  WHFLDD  <> 0 ;
 +
              IF  WHFLDP  <> 0 ;
 +
                L(X) =  WHFLDD +  2  ;      //  LENGTH
 +
              ELSE;
 +
                L(X) =  WHFLDD +  1  ;      //  LENGTH
 +
              ENDIF;
 +
 
 +
                I(X) = FFN1 + FFN2;        //  SCRN FIELD FORMAT NUMERIC
 +
 
 +
              ELSE;
 +
                L(X) =    WHFLDB  ;
 +
                I(X) = FFA1 + FFA2;        //  SCRN FIELD FORMAT ALPHA
 +
              ENDIF;
 +
            ENDIF;
 +
 
 +
        ENDDO;
 +
        //  NUMBER OF FIELDS
 +
        NUMFLD = X ;
 +
 
 +
      //  MAKE ROOM FOR KEYS
 +
          IF  NUMKEY  >  0 ;
 +
          X1  = NUMKEY  + NUMFLD;
 +
 
 +
          FOR  X =  NUMFLD DOWNTO 1;
 +
              KY(X1) = KY(X) ;
 +
              L(X1)  = L(X)  ;
 +
              I(X1)  = I(X)  ;
 +
              N(X1)  = N(X)  ;
 +
              T(X1)  = T(X)  ;
 +
              V(X1)  = V(X)  ;
 +
              C(X1)  = C(X)  ;
 +
              P(X1)  = P(X)  ;
 +
              S(X1)  = S(X)  ;
 +
              E(X1)  = E(X)  ;
 +
              Q(X1)  = Q(X)  ;
 +
              X1    = X1 - 1;
 +
          ENDFOR;
 +
 
 +
          //  PUT KEY FIELDS AT TOP
 +
          OFF  = 0;
 +
          FOR  X =  1 TO NUMKEY;
 +
          X1 = %LOOKUP(KE(X) : N : NUMKEY+1);
 +
 
 +
          KY(X) = '2';
 +
          L(X)  = L(X1);
 +
          I(X)  = I(X1);  // FIELD FMT
 +
          SELECT;                // INPUT ENABLE
 +
            WHEN  I(X) = X6000;
 +
                  I(X) = X4800;
 +
            WHEN  I(X) = X6706;
 +
                  I(X) = X4F06;
 +
          ENDSL;
 +
            N(X) =  N(X1);
 +
            T(X) =  T(X1);
 +
            V(X) =  V(X1);
 +
            C(X) =  C(X1);
 +
            P(X) =  P(X1);
 +
            S(X) =  S(X1);
 +
            E(X) =  E(X1);
 +
            Q(X) =  Q(X1);
 +
            R(X) =  OFF;
 +
            OFF  =  OFF + Q(X1);
 +
          ENDFOR;
 +
 
 +
        ENDIF;
 +
      //  NUMBER OF FIELDS AND KEYS
 +
        NUMFKY = NUMFLD  +  NUMKEY;
 +
 
 +
        ENDSR;
 +
 
 +
 
 +
        // @@@@@@@@@@@@@@@    GETADD  @@@@@@@@@@@@@@@
 +
 
 +
        // LOAD FIELD BUFFER ADDRESSES
 +
          BEGSR    @GETADD;
 +
          MX = 0;
 +
          X  = 0;
 +
          ROW = 3;
 +
          COL = 1;
 +
 
 +
          FOR X = 1 TO NUMFKY;
 +
 
 +
        // IF FINISHED WITH THE KEY FIELDS
 +
        //  INC  ROW FOR 1ST DATA FIELD
 +
          IF KEYSOK = ' ' ;
 +
          IF KY(X) = ' ' OR KY(X) = '1';
 +
            KEYSOK = '1' ;
 +
            ROW    = ROW + 2;
 +
            COL    = 1;
 +
          ENDIF;
 +
          ENDIF;
 +
 
 +
        //  SET THE BUFFER ADD ON THE LARGER OF THE FIELD TEXT OR THE FIELD SIZE
 +
          LENDSC  = %LEN(%TRIM(N(X)));
 +
          LENWRK  =  L(X);
 +
          IF LENDSC > L(X);
 +
            LENWRK = LENDSC;
 +
          ENDIF;
 +
            LENWRK = LENWRK + 2;
 +
 
 +
        //  TRAP FIELDS THAT OVERFLOW
 +
            ROW  = ROW  + XROW;
 +
            XROW = %DIV(LENWRK : 80);
 +
 
 +
            IF (COL + LENWRK) > 78;
 +
              EXSR @ROWINC;
 +
                IF MX = 3;
 +
                X= X-1;
 +
                NUMFKY = X;
 +
                LEAVE;
 +
                ENDIF;
 +
              COL = 1;
 +
            ENDIF;
 +
 
 +
        // INC COL. FOR FIELD START
 +
          CLEAR  B(X);
 +
          BIN  = ROW;
 +
          B(X) =  %TRIM(B(X)) + HX1;
 +
          BIN  = COL + 1;
 +
          B(X) =  %TRIM(B(X)) + HX1;
 +
 
 +
        // INC COL. FOR NEXT FIELD
 +
        COL = COL + LENWRK;
 +
            IF COL > 78;
 +
              EXSR @ROWINC;
 +
                IF MX = 3;    // NO ROOM FOR THE FIELD
 +
                X= X-1;
 +
                NUMFKY = X;
 +
                LEAVE;
 +
                ENDIF;
 +
              COL = 1;
 +
            ENDIF;
 +
 
 +
          ENDFOR;
 +
 
 +
        //  FIELD LEVEL
 +
          LVX      = LVL + 1;
 +
          LV(LVX)  = N(X);
 +
 
 +
        ENDSR;
 +
 
 +
 
 +
        // @@@@@@@@@@@@@@@    PUTHED  @@@@@@@@@@@@@@@
 +
 
 +
        //  PUT FIELD HEADINGS
 +
          BEGSR    @PUTHED;
 +
 
 +
 
 +
            NEWRU  = '1';
 +
 
 +
            RU    = *ALLX'00';
 +
            CLEAR  RU;                  //  initialise Request Unit  255 bytes max
 +
            FOR  XX = 1 TO      NUMFKY; //NUMBER OF DATA ELEMENTS (FLD AND KEY)
 +
 
 +
            IF NEWRU = '1';
 +
              NEWRU  = '0';
 +
              RU  = ESC + WTD + X20 + X00;
 +
            ENDIF;
 +
 
 +
            RU = RU + SBA;
 +
            BIN = 0;
 +
              // CONVERT DATA BUFADR TO HEADING BUFADR
 +
            HX1 = %SUBST(B(XX) :1:1);
 +
            BIN = BIN - 1;
 +
            RU  = RU + HX1;
 +
 
 +
            IF  REHEAD = '1'; // ON REDISPLAY OVERRIDE THE ATTR
 +
              BIN = 0;
 +
              HX1 = %SUBST(B(XX) :2:1);
 +
              BIN = BIN -1 ;
 +
              RU  = RU + HX1;
 +
            ELSE;
 +
              RU  = RU + %SUBST(B(XX) :2);
 +
            ENDIF;
 +
 
 +
            RU = RU + ATC ;
 +
 
 +
        //  LONG NUMBER FIELDS ,RIGHT ADJUST THE FIELD HEADINGS
 +
            LENDSC  = %LEN(%TRIM(N(XX)));
 +
            IF  T(XX) <> 'A' AND  LENDSC <  (L(XX) -1);
 +
            FOR Y = 1 TO (L(XX) -(LENDSC +1));
 +
              RU = RU + ' ';
 +
            ENDFOR;
 +
            ENDIF;
 +
 
 +
            RU = RU + %TRIM(N(XX));
 +
 
 +
              IF %LEN(RU) >= 200;
 +
              BIN    = %LEN(RU);
 +
              OUTLEN = HX2;
 +
              INLEN  = X000;
 +
              FNC    = SND;
 +
              A      = RU;
 +
              EXCEPT DATAO;
 +
              NEWRU  = '1';
 +
              RU    = *ALLX'00';
 +
              CLEAR  RU;
 +
              ENDIF;
 +
 
 +
            ENDFOR;
 +
 
 +
              IF %LEN(RU) >  5 AND %LEN(RU) <  200;
 +
              BIN    = %LEN(RU);
 +
              OUTLEN = HX2;
 +
              INLEN  = X000;
 +
              FNC    = SND;
 +
              A      = RU;
 +
              EXCEPT DATAO;
 +
              ENDIF;
 +
 
 +
          IF REHEAD <> '1';
 +
        //  FORMAT FIELDS
 +
 
 +
 
 +
            NEWRU  = '1';
 +
            RU    = *ALLX'00';
 +
            CLEAR  RU;                  //  initialise Request Unit  255 bytes max
 +
            FOR  XX = 1 TO      NUMFKY; //NUMBER OF DATA ELEMENTS (FLD AND KEY)
 +
 
 +
            IF NEWRU = '1';
 +
              NEWRU  = '0';
 +
              RU  = ESC + WTD + X20 + X00;
 +
            ENDIF;
 +
 
 +
            RU = RU + SBA +B(XX)+SF + I(XX);
 +
 
 +
            IF KY(XX) = '1' OR KY(XX) = '2' OR KY(XX) = '3';
 +
              RU = RU + X25;
 +
            ELSE;
 +
              RU = RU + X26;
 +
            ENDIF;
 +
 
 +
            BIN =  L(XX);
 +
            RU  = RU + HX2;
 +
 
 +
          // LENGTH OF INPUT FIELDS
 +
            LENF  = LENF + L(XX) + 3;
 +
 
 +
 
 +
              IF %LEN(RU) >= 200;
 +
              BIN    = %LEN(RU);
 +
              OUTLEN = HX2;
 +
              INLEN  = X000;
 +
              FNC    = SND;
 +
              A      = RU;
 +
              EXCEPT DATAO;
 +
              NEWRU  = '1';
 +
              RU    = *ALLX'00';
 +
              CLEAR  RU;
 +
              ENDIF;
 +
 
 +
          ENDFOR;
 +
 
 +
      //  PUT LAST R/U
 +
              IF %LEN(RU) >  5 AND %LEN(RU) <  200;
 +
              BIN    = %LEN(RU);
 +
              OUTLEN = HX2;
 +
              INLEN  = X000;
 +
              FNC    = SND;
 +
              A      = RU;
 +
              EXCEPT DATAO;
 +
              ENDIF;
 +
 
 +
        //INC BUFFER ADDRESS FOR ALL FIELDS FOR DATA PUT
 +
            FOR  XP = 1 TO      NUMFKY; //NUMBER OF DATA ELEMENTS (FLD AND KEY)
 +
            HX2  = B(XP);
 +
            BIN  = BIN + 1;
 +
            B(XP) = HX2;
 +
            ENDFOR;
 +
          ENDIF;
 +
 
 +
        ENDSR;
 +
 
 +
      //  @@@@@@@  INIT  @@@@@@@@@@@@@@@@@@@@@@@@@
 +
          BEGSR        @INIT;
 +
 
 +
        CLEAR  KW;
 +
 
 +
        //  UPDATE
 +
          IF  UPDF  = 'Y';
 +
                FFA1 = X40;
 +
                FFN1 = X47;
 +
          ELSE;
 +
                FFA1 = X60;
 +
                FFN1 = X67;
 +
          ENDIF;
 +
 
 +
          SELECT;
 +
          WHEN  *INU1 = '1';
 +
                FILE  =  F1 ;
 +
                LIB  =  L1 ;
 +
                MBR  =  M1 ;
 +
                RCDL  =  R1 ;
 +
                ACCTP =  A1 ;
 +
          WHEN  *INU2 = '1';
 +
                FILE  =  F2 ;
 +
                LIB  =  L2 ;
 +
                MBR  =  M2 ;
 +
                RCDL  =  R2 ;
 +
                ACCTP =  A2 ;
 +
          ENDSL;
 +
            RLEN    =  RCDL  ;
 +
            RLENTH  =  %EDITC(RLEN: 'X') ;
 +
            LENF    =  0    ;
 +
 
 +
 
 +
        // Control commands and data are constructed into RUs Request UNITS
 +
        // Each RU is 256 bytes max size.
 +
        // Construct and send as many RUs as needed to format the display.
 +
            RU    = *ALLX'00';
 +
            CLEAR  RU;        //  initialise Request Unit  255 bytes max
 +
            RU  = CLRWTD ;
 +
          //set up the screen headings
 +
            BIN = 1;    // set ROW to 1
 +
            RW  = HX1;
 +
            BIN = 2;    // set COL to 2
 +
            CL  = HX1;
 +
            RU  = RU + SBA + RW + CL + X22 + %TRIM(LIB) + '/' + %TRIM(FILE);
 +
            RU  = RU + ' Mbr ' + %TRIM(MBR) + ' Rcdl ' + %EDITC(RLEN  : 'Z') ;
 +
            RU  = RU + ' RRN '  ;
 +
            BIN = %len(RU) -4;
 +
            RBA = RW + HX1 ;  // address of the RRN field
 +
            RU  = RU + SBA + RBA + '          ';
 +
 
 +
      // FUNCTION KEYS
 +
            BIN  = 23;
 +
            RW  = HX1;
 +
            BIN  = 02;
 +
            CL  = HX1;
 +
            IF  UPDF = 'Y';  //  UPDATE IS ON
 +
            RU  = RU + SBA + RW + CL + %TRIM(CNS(2));
 +
            ELSE;
 +
            RU  = RU + SBA + RW + CL + %TRIM(CNS(1));
 +
            ENDIF;
 +
 
 +
        //  THIS IS A SEND ONLY FUNCTION
 +
          FNC    = SND;
 +
          CLEAR A;
 +
          A      = RU;
 +
          BIN2    = %LEN(RU);
 +
          OUTLEN  = BY2;
 +
          INLEN  = x000;
 +
 
 +
          EXCEPT    DATAO;
 +
 
 +
        ENDSR;
 +
 
 +
 
 +
      //  @@@@@@@  KEYIN  @@@@@@@@@@@@@@@@@@@@@@@@@
 +
        BEGSR  @KEYIN;
 +
      // ISSUE A READ FROM DISPLAY
 +
          FNC = SNR;
 +
          BIN2  = 8;
 +
          OUTLEN = BY2;
 +
          IPL = LENF + 34;
 +
          BIN2  = IPL;
 +
          INLEN  = BY2;
 +
 
 +
          // SET FRR INDICATORS TO CONTROL BUFFER OVERFLOW
 +
          FOR X =  1 TO  9;
 +
            IF IPL  >  ( X*80 +3);
 +
              *IN(X+19) = *ON;
 +
            ENDIF;
 +
          ENDFOR;
 +
 
 +
        RU    = *ALLX'00';
 +
        CLEAR  RU;
 +
        RU  = RDDSP;
 +
        A    = RU;
 +
 
 +
        EXCEPT DATAI;
 +
        ENDSR;
 +
 
 +
      //  @@@@@@@  ERROR  @@@@@@@@@@@@@@@@@@@@@@@@@
 +
        BEGSR    @ERROR;
 +
 
 +
      // SETUP PUT ERROR MESSAGE X'21'
 +
        RU    = *ALLX'00';
 +
        CLEAR RU;
 +
 
 +
        FNC    =  SNR;
 +
        BIN    = 42;
 +
        OUTLEN = HX2;
 +
        BIN    = LENF + 34;
 +
        IPL    = BIN;
 +
        INLEN  = HX2;
 +
 
 +
        FOR X        = 1 TO 9;
 +
          IF IPL      > (X * 80 +3) ;
 +
          *IN(X + 19) = *ON;          // SETON FFR 20 - 29 FOR INPUT
 +
          ENDIF;
 +
        ENDFOR;
 +
 
 +
        RU = ESC + WER + IC + B(1) + ATC + MSG(MX);
 +
        RU = RU + ESC + RDM + X40+ X00;
 +
 
 +
        A  = RU;
 +
        EXCEPT    DATAI;
 +
        RU    = *ALLX'00';
 +
        CLEAR RU;
 +
        ENDSR;
 +
 
 +
 
 +
      //  @@@@@@@    HXDSP @@@@@@@@@@@@@@@@@@@@@@@@@
 +
        BEGSR  @HXDSP;
 +
 
 +
          RU    = *ALLX'00';
 +
          CLEAR RU;
 +
          Y = %LOOKUPLE( CURLOC : B );
 +
          //
 +
          RU = ESC + WTD + X20 + X00 + SBA;
 +
          BIN = 0;
 +
          HX1 = %SUBST(B(Y) :1:1);
 +
          BIN = BIN - 1;
 +
          RU  = RU + HX1;
 +
          RU  = RU + %SUBST(B(Y) :2:1);
 +
 
 +
          FOR X = S(Y) TO E(Y);
 +
            BIN = 0;
 +
            HX1 = D(X);
 +
            HX1 = %BITAND(HX1  : XF0);
 +
            Z  = BIN / 16 + 1;
 +
            RU  = RU + CRS(Z);
 +
          ENDFOR;
 +
 
 +
            RU  = RU + X20;
 +
 
 +
            RU  = RU + SBA + B(Y);
 +
          FOR X = S(Y) TO E(Y);
 +
            BIN = 0;
 +
            HX1 = D(X);
 +
            HX1 = %BITAND(HX1  : X0F);
 +
            Z  = BIN  + 1;
 +
            RU  = RU + CRS(Z);
 +
          ENDFOR;
 +
 
 +
 
 +
          BIN    = %LEN(RU);
 +
          OUTLEN = HX2;
 +
          INLEN  = X000;
 +
          FNC    = SND;
 +
          A      = RU;
 +
          EXCEPT DATAO;
 +
          RU    = *ALLX'00';
 +
          CLEAR  RU;
 +
 
 +
 
 +
          EXSR      @KEYIN;
 +
          READ      DISPF;
 +
 
 +
 
 +
      //  CLEAR HEADINGS
 +
            RU    = *ALLX'00';
 +
            CLEAR RU;
 +
 
 +
        RU  = RU + ESC + WTD + X20 + X00 + SBA;
 +
        HX1  = %SUBST(B(Y) :1:1) ;
 +
        BIN  = BIN - 1;
 +
        RU  = RU + HX1 + %SUBST(B(Y):2:1);
 +
          FOR X = S(Y) TO E(Y);
 +
          RU = RU + ' ';
 +
          ENDFOR;
 +
        RU = RU + ' ';
 +
 
 +
        BIN    = %LEN(RU);
 +
        OUTLEN = HX2;
 +
        INLEN  = X000;
 +
        FNC    = SND;
 +
        A      = RU;
 +
        EXCEPT    DATAO;
 +
        RU    = *ALLX'00';
 +
        CLEAR  RU;
 +
 
 +
        ENDSR;
 +
 
 +
 
 +
      /END-FREE
 +
 
 +
    ODISPF    E            DATAO
 +
    O                                          K3 'PUT'
 +
    O                      OUTLEN              2
 +
    O                      INLEN
 +
    O                      FNC
 +
    O                      A
 +
 
 +
    O          E            DATAI
 +
    O                                          K3 'GET'
 +
    O                      OUTLEN              2
 +
    O                      INLEN
 +
    O                      FNC
 +
    O                      A
 +
**
 +
0000 INVALID COMMAND KEY
 +
0001  - A FIELD IS TOO LONG
 +
0002  - TOO MANY FIELDS
 +
0003  - ALPHAS IN PACKED KEY
 +
0004  - MISSING ' IN PACKED KEY
 +
0005  - MISSING DATA IN PCKD KEY
 +
0006  - RECORD NOT FOUND
 +
PRESS RESET TO CONTINUE
 +
**
 +
F1-HEX F2-Return F3-Exit F19-Prev_fld F20-More_fld
 +
F1-HEX F2-Return F3-Exit F19-Prev_fld F20-More_fld
 +
**
 +
0123456789ABCDEF
 +
</pre>
 +
 
 +
[[#top]]
 +
 
 +
===DISP1  RPG===
 +
 
 +
<pre>
 +
    H*eywords++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++Comments+++++++++++
 +
    H OPTION(*NODEBUGIO)
 +
    H DFTACTGRP(*NO) ACTGRP(*CALLER) DFTNAME(DISP )
 +
    F*
 +
    F*  LIMITED TO MAXIMUM FILE LENGTH OF 4080
 +
    F*  TEST
 +
    F*  REQUIRES FILE TO COMPILE
 +
    F*  DSPFFD  FILE(&LIB/&FILE) OUTPUT(*OUTFILE) OUTFILE(QTEMP/FFD)
 +
 
 +
    FFFD      IF  E            DISK
 +
    FDISPF    CF  F  803        WORKSTN
 +
    F*
 +
    F                                    INFDS(INFDS)
 +
    FINPUTK    IF  F32766  800AIDISK    KEYLOC(1)
 +
    F                                    EXTIND(*INU1)
 +
    F                                    INFDS(INFDK)
 +
    FINPUTR    IF  F32766        DISK    EXTIND(*INU2)
 +
    F                                    INFDS(INFDR)
 +
 
 +
      *
 +
    D A              S            255                                        WORK RU
 +
    D RU              S            255    varying
 +
    D RW              S              1                                        ROW 1 byte binary
 +
    D CL              S              1                                        COL 1 byte binary
 +
    D FNC            S              1
 +
    D OUTLEN          S              2
 +
    D INLEN          S              2
 +
    D IPL            S              5  0
 +
    D ROW            S              3  0
 +
    D XROW            S              3  0
 +
    D COL            S              3  0
 +
    D KEYSOK          S              1
 +
    D LENDSC          S              3  0
 +
    D LENWRK          S              5  0
 +
    D STRX            S              5  0
 +
    D ENDX            S              5  0
 +
    D VX              S              5  0
 +
    D X              S              5  0
 +
    D X1              S              5  0
 +
    D X2              S              5  0
 +
    D XX              S              5  0
 +
    D XP              S              5  0
 +
    D MX              S              5  0
 +
    D ONCE            S              1
 +
    D RBA            S              2
 +
    D LF              S              5  0
 +
    D ST              S              5  0
 +
    D Y              S              5  0
 +
    D Z              S              5  0
 +
    D OFF            S              5  0
 +
    D SUPZ            S              1
 +
    D NUMFLD          S              5  0
 +
    D WX              S              5  0
 +
    D NUMKEY          S              5  0
 +
    D NUMFKY          S              5  0
 +
    D SCRST          S            10
 +
    D SCRSTN          S              1
 +
    D KEYA            S            800
 +
    D RRNA            S            11  0
 +
    D RRN            S            11  0
 +
    D REHEAD          S              1
 +
    D NEWRU          S              1
 +
    D WRTRRN          S              1
 +
    D LVX            S              5  0
 +
    D LVL            S              5  0
 +
    D K1              S              5  0
 +
    D K2              S              5  0
 +
    D Z1              S              5  0
 +
    D W              S              5  0
 +
    D WK2            S              2
 +
    D MSSG            S            32
 +
      *
 +
    D BASE            S              5  0
 +
    D INZ            S              1
 +
 
 +
    D FILE            S            10
 +
    D LIB            S            10
 +
    D MBR            S            10
 +
    D RCDL            S              5  0
 +
    D ACCTP          S              1
 +
    D RLEN            S              5  0
 +
    D RLENTH          S              5
 +
    D LENF            S              5  0
 +
 
 +
 
 +
    D                DS
 +
    D TEXT500                      500
 +
    D LVW                          10    DIM(50) overlay(TEXT500:1)
 +
 
 +
    D TEXT800        S            800
 +
    D KW              S            800
 +
 
 +
    D                DS
 +
    D WRK11                  1    11
 +
    D NUM11                  1    11S 0
 +
 
 +
    D                DS
 +
    D NUSA                    1    60
 +
    D NUS                    1    60S 0
 +
    D                DS
 +
    D NUPA                    1    60
 +
    D NUP                    29    60P 0
 +
 
 +
    D WRU            S            61
 +
    D WRX            S            64
 +
    D WRXWRD          C                  '0                              -
 +
    D                                                                    -'
 +
    D WRSWRD          C                  '0                              -
 +
    D                                                                  -'
 +
    D WRV            S            60    varying
 +
 
 +
    D FLT14          S            14
 +
    D FLT23          S            23
 +
 
 +
      * SET FILE SIZE INCREMENTS (64 OF THEM)
 +
    D SZ              S              5  0 DIM(64)
 +
    D S              S              5  0 DIM(9000)                            START OF FLD
 +
    D E              S              5  0 DIM(9000)                            END OF FLD
 +
    D Q              S              5  0 DIM(9000)                            BYTES IN FIELD
 +
    D L              S              5  0 DIM(9000)                            LENGTH OF FLD
 +
    D C              S              3  0 DIM(9000)                            DEC DIGITS
 +
    D P              S              3  0 DIM(9000)                            DEC PRECISION
 +
    D B              S              2    DIM(9000) ASCEND                    BUFFER ADD
 +
    D I              S              2    DIM(9000)                            FLD FMT
 +
    D N              S            10    DIM(9000)                            FLD NAME
 +
    D T              S              1    DIM(9000)                            FLD TYPE
 +
    D V              S              1    DIM(9000)                            VARYING
 +
    D KY              S              1    DIM(9000)                            KEYED
 +
    D KE              S            10    DIM(128)                            KEY FLDS
 +
    D R              S              3  0 DIM(9000)                            KEY FLD START
 +
    D K              S              1    DIM(800)                            KEY
 +
    D NA              S              1    DIM(10)                              NAME WORK
 +
    D NU              S              1    DIM(60)                              NUM. WORK
 +
    D LV              S            10    DIM(50)                              SCREEN LEVELS
 +
    D MSG            S            32    DIM(8) CTDATA PERRCD(1)              MESSAGES
 +
    D CNS            S            79    DIM(2) CTDATA PERRCD(1)
 +
    D CRS            S              1    DIM(16) CTDATA PERRCD(16)
 +
 
 +
    D                DS
 +
    D  D                      1  4080
 +
    D                                    DIM(4080)                            INCOMING DATA
 +
    D  DA                    1  2048
 +
    D  DB                  2049  2064
 +
    D  DC                  2065  2096
 +
    D  DD                  2097  2128
 +
    D  DE                  2129  2160
 +
    D  DF                  2161  2192
 +
    D  DG                  2193  2224
 +
    D  DH                  2225  2256
 +
    D  DI                  2257  2288
 +
    D  DJ                  2289  2320
 +
    D  DK                  2321  2352
 +
    D  DL                  2353  2384
 +
    D  DM                  2385  2416
 +
    D  DN                  2417  2448
 +
    D  DZ                  2449  2480
 +
    D  DO                  2481  2512
 +
    D  DP                  2513  2544
 +
    D  DQ                  2545  2576
 +
    D  DR                  2577  2608
 +
    D  DS                  2609  2640
 +
    D  DT                  2641  2672
 +
    D  DU                  2673  2704
 +
    D  DV                  2705  2736
 +
    D  DW                  2737  2768
 +
    D  DX                  2769  2800
 +
    D  DY                  2801  2832
 +
    D  D0                  2833  2864
 +
    D  D1                  2865  2896
 +
    D  D2                  2897  2928
 +
    D  D3                  2929  2960
 +
    D  D4                  2961  2992
 +
    D  D5                  2993  3024
 +
    D  D6                  3025  3056
 +
    D  DBA                3057  3088
 +
    D  DCA                3089  3120
 +
    D  DDA                3121  3152
 +
    D  DEA                3153  3184
 +
    D  DFA                3185  3216
 +
    D  DGA                3217  3248
 +
    D  DHA                3249  3280
 +
    D  DIA                3281  3312
 +
    D  DJA                3313  3344
 +
    D  DKA                3345  3376
 +
    D  DLA                3377  3408
 +
    D  DMA                3409  3440
 +
    D  DNA                3441  3472
 +
    D  DOA                3473  3504
 +
    D  DPA                3505  3536
 +
    D  DQA                3537  3568
 +
    D  DRA                3569  3600
 +
    D  DSA                3601  3632
 +
    D  DTA                3633  3664
 +
    D  DUA                3665  3696
 +
    D  DVA                3697  3728
 +
    D  DWA                3729  3760
 +
    D  DXA                3761  3792
 +
    D  DYA                3793  3824
 +
    D  DZA                3825  3856
 +
    D  D0A                3857  3888
 +
    D  D1A                3889  3920
 +
    D  D2A                3921  3952
 +
    D  D3A                3953  3984
 +
    D  D4A                3985  4016
 +
    D  D5A                4017  4048
 +
    D  D6A                4049  4080
 +
    D                DS
 +
    D  ID                    1    800
 +
    D                                    DIM(800)                            INCOMING DATA
 +
    D  IDA                    1    800
 +
    D  ID0                    1    80
 +
    D  ID1                  81    160
 +
    D  ID2                  161    240
 +
    D  ID3                  241    320
 +
    D  ID4                  321    400
 +
    D  ID5                  401    480
 +
    D  ID6                  481    560
 +
    D  ID7                  561    640
 +
    D  ID8                  641    720
 +
    D  ID9                  721    800
 +
    D                DS
 +
    D  BIN                    1      2B 0
 +
    D  HX1                    2      2
 +
    D  HX2                    1      2
 +
    D                DS
 +
    D  PCK                    1      1P 0
 +
    D  PCK1                  1      1
 +
    D                DS
 +
    D  SGN                    1      1S 0
 +
    D  SGN1                  1      1
 +
 
 +
    D                DS
 +
    D  BIN4                  1      4B 0
 +
    D  BY4                    1      4
 +
 
 +
    D                DS
 +
    D  BIN2                  1      2B 0
 +
    D  BY2                    1      2
 +
 
 +
    D                DS
 +
    D  FLT4                  1      4F
 +
    D  FL4                    1      4
 +
 
 +
    D                DS
 +
    D  FLT8                  1      8F
 +
    D  FL8                    1      8
 +
 
 +
    D INFDK          DS
 +
    D  F1                    83    92
 +
    D  L1                    93    102
 +
    D  M1                  129    138
 +
    D  R1                  125    126B 0
 +
    D  A1                  160    160
 +
    D  LOP1                260    260
 +
    D  KEY_LEN              393    394I 0                                      Key length
 +
    D  RN1                  397    400B 0
 +
    D  LKY                  401  1200
 +
    D INFDR          DS
 +
    D  F2                    83    92
 +
    D  L2                    93    102
 +
    D  M2                  129    138
 +
    D  R2                  125    126B 0
 +
    D  A2                  160    160
 +
    D  LOP2                260    260
 +
    D  RN2                  397    400B 0
 +
    D*
 +
    D INFDS          DS
 +
    D  CURLOC              370    371
 +
    D                DS
 +
    D KEYLN                  1      4S 0
 +
    D KEYLNA                  1      4
 +
 
 +
    DDISP1            PR
 +
    D                                1
 +
    D                                1
 +
    D                                4
 +
    D                                1
 +
    D                              500
 +
    D                                5
 +
    D                              800
 +
    DDISP1            PI
 +
    D  ALL                          1
 +
    D  RTN                          1
 +
    D  KEYLNG                      4
 +
    D  UPDF                        1
 +
    D  SCNLV                      500
 +
    D  SCNLVL                      5
 +
    D  SCNKEY                    800
 +
 
 +
 
 +
    D @LOOP          C                  '1'
 +
 
 +
    D SND            C                  X'71'                                SEND TO DISP
 +
    D SNR            C                  X'73'                                SND/RCV
 +
    D RED            C                  X'42'                                READ
 +
    D RDM            C                  X'52'                                READ MTD
 +
    D ESC            C                  X'04'                                ESCAPE
 +
    D CLR            C                  X'40'                                CLEAR UNIT
 +
    D CC1            C                  X'00'                                CNTRL CHAR
 +
    D CC2            C                  X'08'                                CNTRL CHAR
 +
    D SBA            C                  X'11'                                SET BUFF ADR
 +
    D IC              C                  X'13'                                INSERT CURS
 +
    D WTD            C                  X'11'                                WRITE TO DSP
 +
    D WER            C                  X'21'                                WRITE ERROR
 +
    D SF              C                  X'1D'                                START FLD
 +
    D ATC            C                  X'20'                                ATTR CHAR
 +
    D ATN            C                  X'24'                                ATTR NUM
 +
    D X00            C                  X'00'
 +
    D X01            C                  X'01'
 +
    D X02            C                  X'02'
 +
    D X03            C                  X'03'
 +
    D X0D            C                  X'0D'
 +
    D X0F            C                  X'0F'
 +
    D X000            C                  X'0000'
 +
    D X1F            C                  X'1F'
 +
    D X20            C                  X'20'                                SCRN ATT NORMAL
 +
    D X22            C                  X'22'                                SCRN ATTR HI
 +
    D X25            C                  X'25'
 +
    D X26            C                  X'26'
 +
    D X31            C                  X'31'                                CMD 1 KEY
 +
    D X32            C                  X'32'                                CMD 2 KEY
 +
    D X33            C                  X'33'                                CMD 3 KEY
 +
    D X36            C                  X'36'                                CMD 6 KEY
 +
    D X37            C                  X'37'                                CMD 7 KEY
 +
    D X38            C                  X'38'                                CMD 8 KEY
 +
    D X39            C                  X'39'                                CMD 9 KEY
 +
    D X3B            C                  X'3B'                                CMD11 KEY
 +
    D XB7            C                  X'B7'                                CMD19 KEY
 +
    D XB8            C                  X'B8'                                CMD20 KEY
 +
    D X40            C                  X'40'
 +
    D X43            C                  X'43'
 +
    D X47            C                  X'47'
 +
    D X60            C                  X'60'
 +
    D X67            C                  X'67'
 +
    D X9F            C                  X'9F'
 +
    D XF0            C                  X'F0'
 +
    D XD0            C                  X'D0'
 +
    D X4000          C                  X'4000'
 +
    D X4800          C                  X'4800'                              FF ALPHA
 +
    D X4F06          C                  X'4F06'                              FF NUMERIC
 +
    D X6000          C                  X'6000'                              FF ALPHA
 +
    D X6706          C                  X'6706'                              FF NUMERIC
 +
    D CLRWTD          C                  X'044004112000'                      INCLUDES ESC CHARS
 +
    D RDDSP          C                  X'0411200804524000'                  REAB FROM DISPLAY
 +
    D FFA1            S              1    INZ(X'40')                          F.FMT 1 ALPH  60 BYP
 +
    D FFA2            S              1    INZ(X'00')                          F.FMT 2 ALPH
 +
    D FFN1            S              1    INZ(X'47')                          F.FMT 1 NUM  67 BYP
 +
    D FFN2            S              1    INZ(X'06')                          F.FMT 2 NUM
 +
    I*.
 +
    IINPUTK    NS  01
 +
    I                                  1 2048  DA
 +
    I                              2049 2064  DB                30
 +
    I                              2065 2096  DC                31
 +
    I                              2097 2128  DD                32
 +
    I                              2129 2160  DE                33
 +
    I                              2161 2192  DF                34
 +
    I                              2193 2224  DG                35
 +
    I                              2225 2256  DH                36
 +
    I                              2257 2288  DI                37
 +
    I                              2289 2320  DJ                38
 +
    I                              2321 2352  DK                39
 +
    I                              2353 2384  DL                40
 +
    I                              2385 2416  DM                41
 +
    I                              2417 2448  DN                42
 +
    I                              2449 2480  DZ                43
 +
    I                              2481 2512  DO                44
 +
    I                              2513 2544  DP                45
 +
    I                              2545 2576  DQ                46
 +
    I                              2577 2608  DR                47
 +
    I                              2609 2640  DS                48
 +
    I                              2641 2672  DT                49
 +
    I                              2673 2704  DU                50
 +
    I                              2705 2736  DV                51
 +
    I                              2737 2768  DW                52
 +
    I                              2769 2800  DX                53
 +
    I                              2801 2832  DY                54
 +
    I                              2833 2864  D0                55
 +
    I                              2865 2896  D1                56
 +
    I                              2897 2928  D2                57
 +
    I                              2929 2960  D3                58
 +
    I                              2961 2992  D4                59
 +
    I                              2993 3024  D5                60
 +
    I                              3025 3056  D6                61
 +
    I                              3057 3088  DBA              62
 +
    I                              3089 3120  DCA              63
 +
    I                              3121 3152  DDA              64
 +
    I                              3153 3184  DEA              65
 +
    I                              3185 3216  DFA              66
 +
    I                              3217 3248  DGA              67
 +
    I                              3249 3280  DHA              68
 +
    I                              3281 3312  DIA              69
 +
    I                              3313 3344  DJA              70
 +
    I                              3345 3376  DKA              71
 +
    I                              3377 3408  DLA              72
 +
    I                              3409 3440  DMA              73
 +
    I                              3441 3472  DNA              74
 +
    I                              3473 3504  DOA              75
 +
    I                              3505 3536  DPA              76
 +
    I                              3537 3568  DQA              77
 +
    I                              3569 3600  DRA              78
 +
    I                              3601 3632  DSA              79
 +
    I                              3633 3664  DTA              80
 +
    I                              3665 3696  DUA              81
 +
    I                              3697 3728  DVA              82
 +
    I                              3729 3760  DWA              83
 +
    I                              3761 3792  DXA              84
 +
    I                              3793 3824  DYA              85
 +
    I                              3825 3856  DZA              86
 +
    I                              3857 3888  D0A              87
 +
    I                              3889 3920  D1A              88
 +
    I                              3921 3952  D2A              89
 +
    I                              3953 3984  D3A              90
 +
    I                              3985 4016  D4A              91
 +
    I                              4017 4048  D5A              92
 +
    I                              4049 4080  D6A              93
 +
    IINPUTR    NS  01
 +
    I                                  1 2048  DA
 +
    I                              2049 2064  DB                30
 +
    I                              2065 2096  DC                31
 +
    I                              2097 2128  DD                32
 +
    I                              2129 2160  DE                33
 +
    I                              2161 2192  DF                34
 +
    I                              2193 2224  DG                35
 +
    I                              2225 2256  DH                36
 +
    I                              2257 2288  DI                37
 +
    I                              2289 2320  DJ                38
 +
    I                              2321 2352  DK                39
 +
    I                              2353 2384  DL                40
 +
    I                              2385 2416  DM                41
 +
    I                              2417 2448  DN                42
 +
    I                              2449 2480  DZ                43
 +
    I                              2481 2512  DO                44
 +
    I                              2513 2544  DP                45
 +
    I                              2545 2576  DQ                46
 +
    I                              2577 2608  DR                47
 +
    I                              2609 2640  DS                48
 +
    I                              2641 2672  DT                49
 +
    I                              2673 2704  DU                50
 +
    I                              2705 2736  DV                51
 +
    I                              2737 2768  DW                52
 +
    I                              2769 2800  DX                53
 +
    I                              2801 2832  DY                54
 +
    I                              2833 2864  D0                55
 +
    I                              2865 2896  D1                56
 +
    I                              2897 2928  D2                57
 +
    I                              2929 2960  D3                58
 +
    I                              2961 2992  D4                59
 +
    I                              2993 3024  D5                60
 +
    I                              3025 3056  D6                61
 +
    I                              3057 3088  DBA              62
 +
    I                              3089 3120  DCA              63
 +
    I                              3121 3152  DDA              64
 +
    I                              3153 3184  DEA              65
 +
    I                              3185 3216  DFA              66
 +
    I                              3217 3248  DGA              67
 +
    I                              3249 3280  DHA              68
 +
    I                              3281 3312  DIA              69
 +
    I                              3313 3344  DJA              70
 +
    I                              3345 3376  DKA              71
 +
    I                              3377 3408  DLA              72
 +
    I                              3409 3440  DMA              73
 +
    I                              3441 3472  DNA              74
 +
    I                              3473 3504  DOA              75
 +
    I                              3505 3536  DPA              76
 +
    I                              3537 3568  DQA              77
 +
    I                              3569 3600  DRA              78
 +
    I                              3601 3632  DSA              79
 +
    I                              3633 3664  DTA              80
 +
    I                              3665 3696  DUA              81
 +
    I                              3697 3728  DVA              82
 +
    I                              3729 3760  DWA              83
 +
    I                              3761 3792  DXA              84
 +
    I                              3793 3824  DYA              85
 +
    I                              3825 3856  DZA              86
 +
    I                              3857 3888  D0A              87
 +
    I                              3889 3920  D1A              88
 +
    I                              3921 3952  D2A              89
 +
    I                              3953 3984  D3A              90
 +
    I                              3985 4016  D4A              91
 +
    I                              4017 4048  D5A              92
 +
    I                              4049 4080  D6A              93
 +
 
 +
    IDISPF    NS  02
 +
    I                                  3    3  AID
 +
    I                                  4  83  ID0
 +
    I                                84  163  ID1              20
 +
    I                                164  243  ID2              21
 +
    I                                244  323  ID3              22
 +
    I                                324  403  ID4              23
 +
    I                                404  483  ID5              24
 +
    I                                484  563  ID6              25
 +
    I                                564  643  ID7              26
 +
    I                                644  723  ID8              27
 +
    I                                724  803  ID9              28
 +
 
 +
 
 +
      /FREE
 +
            BASE = 0;
 +
 
 +
            IF  ONCE  =  ' ';
 +
                EXSR      @INITZ  ;
 +
            ENDIF;
 +
 
 +
        //  START        TAG
 +
          DOW      @LOOP = @LOOP;
 +
 
 +
          IF  RTN  = '3';
 +
 
 +
              IF *INU1;
 +
                KEYA =  SCNKEY;
 +
              ENDIF;
 +
              IF *INU2;
 +
                RRNA =  %DEC(%SUBST(SCNKEY:1:11):11:0);
 +
              ENDIF;
 +
                RTN = '0';
 +
                AID = '1';
 +
            ELSE;
 +
              RTN  = '0';
 +
              READ(E)  DISPF;
 +
          ENDIF;
 +
 
 +
        //  CF3 EXIT
 +
          IF  AID  = X33;
 +
            LEAVE;
 +
          ENDIF;
 +
 
 +
        //  CF2 RETURN
 +
          IF  AID  = X32;
 +
            RTN = '1';
 +
            LEAVE;
 +
          ENDIF;
 +
 
 +
        // CF1 HEX A FIELD
 +
          IF  AID  = X31;
 +
          Y = %LOOKUPLE( CURLOC : B );
 +
          IF Y > 0;
 +
            IF KY(Y) <= '1';
 +
              EXSR      @HXDSP;
 +
              REHEAD  = '1';
 +
              EXSR      @PUTHED;
 +
              REHEAD  = ' ';
 +
            ENDIF;
 +
            ENDIF;
 +
          ENDIF;
 +
 
 +
        //  CF20 MORE FIELDS
 +
          IF  AID  = XB8;
 +
 
 +
            LVX  = LVL + 1;
 +
            IF  LV(LVX)  <> *BLANK;
 +
              LVL = LVL +1 ;
 +
 
 +
              LVW  = LV;
 +
              SCNLV = TEXT500;
 +
              SCNLVL = %EDITC(LVL :'X');
 +
 
 +
            SCNKEY = *BLANKS;
 +
          IF  *INU1;
 +
                SCNKEY = KEYA;
 +
          ENDIF;
 +
          IF  *INU2;
 +
                SCNKEY = %EDITC(RRNA:'X');
 +
          ENDIF;
 +
 
 +
              RTN = '3';
 +
              LEAVE;
 +
            ENDIF;
 +
          ENDIF;
 +
 
 +
      //  CF19 PREVIOUS FIELDS
 +
          IF  AID  = XB7;
 +
 
 +
            LVX  = LVL - 1;
 +
            IF  LVX    >= 0 ;
 +
              LVL = LVL - 1 ;
 +
 
 +
              LVW  = LV;
 +
              SCNLV = TEXT500;
 +
              SCNLVL = %EDITC(LVL :'X');
 +
 
 +
                SCNKEY = *BLANKS;
 +
          IF  *INU1;
 +
                SCNKEY = KEYA;
 +
          ENDIF;
 +
          IF  *INU2;
 +
                SCNKEY = %EDITC(RRNA:'X');
 +
          ENDIF;
 +
 
 +
              RTN = '3';
 +
              LEAVE;
 +
            ENDIF;
 +
          ENDIF;
 +
 
 +
          // 1 ENTER
 +
          // 4 ROLL DN
 +
          // 5 ROLL UP
 +
          IF  AID  = '1'or AID = '4' or AID = '5';
 +
          ELSE;
 +
            MX = 1;
 +
            EXSR  @ERROR;
 +
          ENDIF;
 +
 
 +
          IF  RTN <> '3';
 +
            EXSR      @PCKD;
 +
          ENDIF;
 +
 
 +
 
 +
        // CONT1  GET A RECORD, KEY FROM DATA
 +
            EXSR      @SETIN;
 +
            EXSR      @GETF ;
 +
            EXSR      @PUTF ;
 +
            EXSR      @KEYIN;
 +
 
 +
          ENDDO ;
 +
 
 +
          *INLR = *ON;
 +
 
 +
      //  @@@@@@@  @INITZ @@@@@@@@@@@@@@@@@@@@@@@@@@
 +
        BEGSR  @INITZ;
 +
                ONCE  =  '1';
 +
                KEYLNA = KEYLNG  ;
 +
                EXSR      @INIT  ;
 +
                EXSR      @GETFLD ;
 +
                EXSR      @GETADD ;
 +
                EXSR      @PUTHED ;
 +
                EXSR      @KEYIN  ;
 +
                INZ  = '1';
 +
                EXSR      @PCKD  ;
 +
                INZ  = ' ';
 +
        ENDSR;
 +
 
 +
      //  @@@@@@@  @PCKD  @@@@@@@@@@@@@@@@@@@@@@@@@@
 +
 
 +
          BEGSR  @PCKD ;
 +
 
 +
            //  CONVERT  KEY DATA
 +
            IF  *INU1 ;
 +
              EXSR  @CVTKEY;
 +
            ENDIF;
 +
            IF  *INU2 ;
 +
              EXSR  @CVTRRN;
 +
            ENDIF;
 +
 
 +
          ENDSR;
 +
 
 +
      //  @@@@@@@  @CVTKEY  @@@@@@@@@@@@@@@@@@@@@@@@
 +
 
 +
          BEGSR  @CVTKEY;
 +
 
 +
      // EXTRACT THE KEY FIELD DATA FROM THE INCOMING STRING
 +
 
 +
        // FOR EACH KEY FIELD, CHECK IF FIELD WAS MODIFIED, AND IF SO MOVE
 +
        // THE MODIFIED DATA INTO THE COMPOSITE KEY
 +
 
 +
        K1 = 0;
 +
        K2 = 0;
 +
        W  = 1;
 +
 
 +
          FOR  Y  = 1  TO NUMKEY ;
 +
 
 +
      //  MOVE A KEY FIELDS DATA FROM ID ARRAY (SCREEN) TO K ARRAY (KEY FIELDS)
 +
 
 +
      //  GET SIZE OF FIELD IN BYTES
 +
          IF T(Y)  =  'A';  // ALPHA DATA
 +
          K = ' ';
 +
          K1 = 1;
 +
          K2 = Q(Y);
 +
          ELSE;
 +
          K  = '0';
 +
          K1 =  1;
 +
          K2 = C(Y);
 +
          ENDIF;
 +
 
 +
      // IF WHOLE KEY INIT WAS REQUESTED BYPASS THE EXTRACT
 +
          IF  INZ  = '1' ;
 +
            KW  = *BLANK;
 +
            EXSR      @PCKMOV;
 +
            ITER;
 +
          ENDIF;
 +
 
 +
          X  =  1;
 +
 
 +
          DOW  @LOOP = @LOOP;
 +
 
 +
      //  NXTSBA
 +
          X  = %LOOKUP(SBA : ID : X );
 +
          IF X = 0;
 +
            LEAVE;
 +
          ENDIF;
 +
 
 +
      // IS THIS THE FIELD?  CHECK THE BUFFER ADDRESS
 +
        X = X +1;
 +
        IF  B(Y)  <>  %SUBST(IDA : X :2);
 +
          ITER;
 +
        ENDIF;
 +
 
 +
      //  FOUND A MTD FOR THIS FIELD
 +
        X =  X + 2;
 +
 
 +
      //  CHECK IF FIELD WAS CLEARED ONLY
 +
        IF  ID(X) = SBA;
 +
            EXSR      @PCKMOV;
 +
            LEAVE ;
 +
        ENDIF;
 +
 
 +
      //  IF FIELD HAS DECIMALS BUMP X
 +
          IF (T(Y) = 'S' OR T(Y) = 'P' OR T(Y) = 'B') AND
 +
              P(Y) > 0;
 +
              X = X + 1;
 +
          ENDIF;
 +
 
 +
      //  CHECK IF ONLY BLANKS RETURNED
 +
        IF    %SUBST(IDA : X :K2) = *BLANKS;
 +
            EXSR      @PCKMOV;
 +
            LEAVE;
 +
        ENDIF;
 +
 
 +
      // EXTRACT THE DATA FROM THE INCOMING STRING
 +
        X1  = X;
 +
        FOR X2  =  1 TO  K2 ;
 +
 
 +
          IF ID(X1) < ' ';
 +
      // TRAP NULLS CAUSED BY FLD EXIT
 +
            EXSR      @PCKMOV;
 +
            LEAVE;
 +
          ENDIF;
 +
 
 +
        K(X2)  =  ID(X1);
 +
        X1    =  X1 +1;
 +
        ENDFOR;
 +
 
 +
        // CONSTRUCT THE ACTUAL KEY WITH PACKED DATA IF REQUIRED
 +
        // INTO ARRAY KW
 +
          EXSR      @PCKMOV;
 +
          LEAVE;
 +
        ENDDO;
 +
 
 +
        ENDFOR;
 +
 
 +
        //
 +
          KEYA  = KW;
 +
          CLEAR KW;
 +
        ENDSR ;
 +
 
 +
      //  @@@@@@@  @CVTRRN  @@@@@@@@@@@@@@@@@@@@@@@@
 +
 
 +
          BEGSR  @CVTRRN;
 +
 
 +
        //  RRN
 +
 
 +
          NUM11 = 0;
 +
 
 +
          DOW  @LOOP = @LOOP;  //  NOT REALLY A LOOP(SIMULATES GOTO)
 +
 
 +
      // GET THE FIRST SBA
 +
          X = 1;
 +
          X  = %LOOKUP(SBA : ID : X );
 +
          IF X = 0;
 +
          LEAVE;
 +
          ENDIF;
 +
 
 +
      // CHECK THE BUFFER ADDRESS MATCHES THE EXPECTED FIELD
 +
        X = X +1;
 +
        IF  B(1)  <>  %SUBST(IDA : X :2);
 +
          LEAVE;
 +
        ENDIF;
 +
 
 +
      //  FOUND A MTD FOR RRN  FIELD
 +
        X = X +2;
 +
 
 +
      //CHECK IF FIELD WAS CLEARED ONLY
 +
        IF  ID(X) = SBA;
 +
            LEAVE;
 +
        ENDIF;
 +
 
 +
      //  CHECK IF ONLY BLANKS RETURNED
 +
        IF    %SUBST(IDA : X :11) = *BLANKS;
 +
            LEAVE;
 +
        ENDIF;
 +
 
 +
 
 +
        //  WRK11  OVERLAYS NUM11
 +
        WRK11 = %SUBST(IDA : X :11);
 +
 
 +
        LEAVE;
 +
        ENDDO;
 +
 
 +
 
 +
        RRNA = NUM11;
 +
        IF RRNA < 0;
 +
        RRNA =  1;
 +
        ENDIF;
 +
 
 +
        ENDSR;
 +
 
 +
      //  @@@@@@@  @PCKMOV  @@@@@@@@@@@@@@@@@@@@@@@@
 +
 
 +
        BEGSR  @PCKMOV;
 +
      //
 +
      //  CONVERT  KEY DATA
 +
      //  SET START POSN IN KEY USING OFFSET IN R
 +
        W = R(Y) + 1;
 +
 
 +
        // ALPHA
 +
          IF  T(Y) = 'A';
 +
          X1  = 1;
 +
          FOR  Z = W  TO W + Q(Y);
 +
            %SUBST(KW : Z : 1) =  K(X1);
 +
            X1 = X1 + 1;
 +
          ENDFOR;
 +
          ENDIF;
 +
 
 +
        // NUMERIC FIELD
 +
        // RIGHT  ADJUST NUMERIC DATA ,STRIP - . ,CONVERT BLANKS
 +
          IF (T(Y) = 'S' OR T(Y) = 'P' OR T(Y) = 'B');
 +
          NU = '0';
 +
 
 +
          Z1 = 60;
 +
          FOR Z  =  K2  DOWNTO K1;
 +
 
 +
          IF K(Z) = '.' OR K(Z) = '-' OR K(Z) = '$';
 +
          ITER;
 +
          ENDIF;
 +
 
 +
          IF K(Z) = ' ' ;
 +
          NU(Z1) = '0';
 +
          ELSE;
 +
          NU(Z1) = K(Z);
 +
          ENDIF;
 +
 
 +
            Z1 = Z1 -1;
 +
          ENDFOR;
 +
 
 +
          ENDIF;
 +
 
 +
      // SIGNED FIELDS  (END POSN = OFFSET + SIZE)
 +
        IF T(Y)  = 'S';
 +
          NUS = 0;
 +
          FOR VX = 1 TO 60;
 +
            NUSA = %TRIM(NUSA) + NU(VX);
 +
          ENDFOR;
 +
        %SUBST(KW : W : Q(Y)) = %SUBST(NUSA: 61 -Q(Y));
 +
 
 +
        ENDIF;
 +
 
 +
      //  PACKED FIELDS
 +
          IF    T(Y)  =  'P';
 +
          NUSA= *BLANKS;
 +
          FOR VX = 1 TO 60;
 +
            NUSA = %TRIM(NUSA) + NU(VX);
 +
          ENDFOR;
 +
          NUP    = %DEC(NUSA : 60 : 0);
 +
 
 +
        %SUBST(KW : W : Q(Y))  =  %SUBST(NUPA: 61 -Q(Y));
 +
 
 +
        ENDIF;
 +
 
 +
      //  BINARY FIELDS
 +
        IF  T(Y) =  'B';
 +
 
 +
        IF  Q(Y) = 2 ;
 +
          BY2  = NU(1) + NU(2);
 +
          %SUBST(KW : W : 2)  =  BY2;
 +
        ENDIF;
 +
 
 +
        IF  Q(Y) = 4 ;
 +
          BY4  = NU(1) + NU(2) + NU(3) + NU(4);
 +
          %SUBST(KW : W : 4)  =  BY4;
 +
        ENDIF;
 +
 
 +
        ENDIF;
 +
 
 +
      ENDSR;
 +
 
 +
 
 +
      //  @@@@@@@  SETIN  @@@@@@@@@@@@@@@@@@@@@@@@@
 +
          BEGSR      @SETIN;
 +
 
 +
        //  SET the FFR indicators to get the Input buffer somewhat aligned with the
 +
        //  actual data.  RPG is somewhat tolerant to a difference between the Ispecs
 +
        //  and the actual file size but it can fail on big differences.
 +
        //  INCREMENT OF 32 BYTES
 +
          SZ(1)  = BASE + 16;
 +
          SZ(2)  = SZ(1) + 16;
 +
 
 +
          *IN30 = *ON;
 +
            IF (RLEN > SZ(2)) ;
 +
            *IN31  = *ON;
 +
            ENDIF;
 +
 
 +
          FOR X = 3 TO 64;
 +
          SZ(X) = SZ(X-1) + 32;
 +
            IF (RLEN > SZ(X)) ;
 +
            *IN(29+X) = *ON;
 +
            ENDIF;
 +
          ENDFOR;
 +
        ENDSR;
 +
 
 +
 
 +
        //@@@@@@@@@@@@@@@@@  @GETF  @@@@@@@@@@@@@@@@@
 +
          BEGSR  @GETF;
 +
      //  GET A DATA RECORD
 +
          IF  (*INU1);
 +
          IF  AID  = '1' OR AID  = X36 OR
 +
              AID  = X39 OR AID  = X3B ;
 +
            SETLL(E) KEYA  INPUTK;
 +
            READ(E)      INPUTK;
 +
              IF %EOF;
 +
              SETLL(E) KEYA  INPUTK;
 +
              READP(E)      INPUTK;
 +
              ENDIF;
 +
          ENDIF;
 +
 
 +
          IF  AID  = '4';
 +
            READP(E)  INPUTK;
 +
          ENDIF;
 +
 
 +
          IF  AID  = '5';
 +
            READ(E)  INPUTK;
 +
          ENDIF;
 +
 
 +
            IF  %ERROR;
 +
            SETLL(E) KEYA  INPUTK;
 +
            READ(E)      INPUTK;
 +
            MX = 7;
 +
                        EXSR      @ERROR;
 +
                        EXSR      @PUTF ;
 +
                        EXSR      @KEYIN;
 +
            ENDIF;
 +
 
 +
            KEYA = LKY;
 +
 
 +
 
 +
            CLEAR KW;
 +
            KW  = LKY;
 +
 
 +
          ENDIF;
 +
 
 +
          IF  (*INU2);
 +
          IF  AID  = '1';
 +
            CHAIN(E)  RRNA  INPUTR;
 +
            IF  %ERROR;
 +
              SETLL(E) RRNA  INPUTR;
 +
              READP(E)      INPUTR;
 +
            ENDIF;
 +
          ENDIF;
 +
 
 +
          IF  AID  = X36;
 +
            CHAIN(E)  RRNA  INPUTR;
 +
          ENDIF;
 +
 
 +
          IF  AID  = '4';
 +
            READP(E)  INPUTR;
 +
          ENDIF;
 +
 
 +
          IF  AID  = '5' OR AID = X3B;
 +
            READ(E)  INPUTR;
 +
          ENDIF;
 +
 
 +
          IF  AID  = X39;
 +
            SETLL(E) *HIVAL INPUTR;
 +
            READP(E)  INPUTR;
 +
          ENDIF;
 +
 
 +
          IF %ERROR;
 +
            CHAIN  1  INPUTR;
 +
            MX = 7;
 +
            EXSR      @ERROR;
 +
            EXSR      @PUTF ;
 +
            EXSR      @KEYIN;
 +
          ENDIF;
 +
          ENDIF;
 +
 
 +
          ENDSR;
 +
 
 +
 
 +
        //@@@@@@@@@@@@@@@@@  @PUTF  @@@@@@@@@@@@@@@@@
 +
          BEGSR  @PUTF;
 +
 
 +
              SELECT;
 +
                WHEN  *INU1;
 +
                RRN = RN1;
 +
                WHEN  *INU2;
 +
                RRN = RN2;
 +
              ENDSL;
 +
        // IF GOT RECORDS WRITE DATA TO THE DISPLAY
 +
 
 +
            NEWRU  = '1';
 +
            WRTRRN = '1';
 +
            RU    = *ALLX'00';
 +
            CLEAR  RU;        //  initialise Request Unit  255 bytes max
 +
 
 +
          IF RRN > 0    ;
 +
            FOR  XX = 1 TO      NUMFKY; //NUMBER OF DATA ELEMENTS (FLD AND KEY)
 +
 
 +
            IF NEWRU = '1';
 +
              NEWRU  = '0';
 +
              RU  = ESC + WTD + X20 + X00;
 +
            ENDIF;
 +
 
 +
            IF WRTRRN = '1';
 +
              WRTRRN = '0';
 +
              RU  = RU + SBA + RBA ;
 +
              RU = RU + %TRIM(%EDITC(RRN:'Z'));
 +
            ENDIF;
 +
 
 +
        // BUFFER ADDRESS
 +
            RU  = RU + SBA + B(XX);
 +
 
 +
        //  PROCESS ALPHA DATA TYPE
 +
            IF  T(XX) = 'A'  OR T(XX) = 'T'  OR T(XX) = 'Z' OR
 +
                T(XX) = 'L';
 +
 
 +
              STRX = S(XX);
 +
              ENDX = E(XX);
 +
 
 +
              IF V(XX) = 'Y';  //VARYING
 +
              VX  = S(XX);
 +
              HX2  = D(VX) + D(VX+1);
 +
              STRX  = S(XX) + 2 ;
 +
              ENDX  = S(XX) + BIN;
 +
              ENDIF;
 +
 
 +
              FOR Y = STRX  TO ENDX ;
 +
                IF D(Y) >= ' ';
 +
                RU = RU + D(Y);
 +
                ELSE;
 +
                RU = RU + X1F ;  //IF NOT DISPLAYABLE REPLACE WITH X'1F'
 +
                ENDIF;
 +
              ENDFOR;
 +
            ENDIF;
 +
 
 +
        //  PROCESS SIGNED DATA TYPE (not the RRN field)
 +
            IF  T(XX) = 'S' and KY(XX) <> '3';
 +
              NUSA =  *ALL'0';
 +
              WRV  =  *ALLX'00';
 +
              CLEAR WRV;
 +
              FOR Y = S(XX) TO E(XX);
 +
                IF D(Y) >= XD0;
 +
                WRV    =  WRV + D(Y);
 +
                ENDIF;
 +
              ENDFOR;
 +
              EVAL  NUSA = %SUBST(NUSA : 1 : 60 - %LEN(WRV)) + WRV;
 +
              CLEAR WRU;
 +
              WRU = %TRIM(WRU) + %EDITW(NUS :WRSWRD);
 +
              IF  P(XX) > 0;
 +
                RU  = RU  +
 +
                    %SUBST(WRU :61-C(XX): C(XX)-P(XX)) + '.' +
 +
                    %SUBST(WRU :61-P(XX))    ;
 +
              ELSE;
 +
                RU  = RU  +
 +
                    %SUBST(WRU :61-C(XX));
 +
              ENDIF;
 +
            ENDIF;
 +
 
 +
 
 +
        //  PROCESS SIGNED DATA TYPE (the RRN field)
 +
            IF  T(XX) = 'S' and KY(XX) =  '3';
 +
              RRN = RN2;
 +
              RU = RU + %TRIM(%EDITC(RRN:'X'));
 +
            ENDIF;
 +
 
 +
        //  PROCESS PACKED DATA TYPE
 +
            IF  T(XX) = 'P';
 +
              NUPA =  *ALLX'00';
 +
              WRV  =  *ALLX'00';
 +
              CLEAR WRV;
 +
              FOR Y = S(XX) TO E(XX);
 +
                WRV    =  WRV + D(Y);
 +
              ENDFOR;
 +
 
 +
              IF  %BITAND(D(E(XX)) :X0F) = X0F OR
 +
                    %BITAND(D(E(XX)) :X0D) = X0D;
 +
 
 +
                EVAL  NUPA = %SUBST(NUPA : 1 : 60 - %LEN(WRV)) + WRV;
 +
                CLEAR WRX;
 +
                WRX = %TRIM(WRX) + %EDITW(NUP :WRXWRD);
 +
                IF  P(XX) > 0;
 +
                RU  = RU  +
 +
                      %SUBST(WRX :64-C(XX): C(XX)-P(XX)) + '.' +
 +
                      %SUBST(WRX :64-P(XX))    ;
 +
                ELSE;
 +
                RU  = RU  +
 +
                      %SUBST(WRX :64-C(XX));
 +
                ENDIF;
 +
              ELSE;
 +
                // PACKED FIELD IN ERROR
 +
                RU = RU + X1F;
 +
              ENDIF;
 +
 
 +
            ENDIF;
 +
 
 +
        //  PROCESS BINARY DATA TYPE
 +
            IF  T(XX) = 'B';
 +
 
 +
            ST = S(XX);
 +
              CLEAR NUSA;
 +
              IF  Q(XX) = 2;
 +
              BY2  = D(ST) + D(ST+1);
 +
              NUS  = BIN2;
 +
              ENDIF;
 +
              IF  Q(XX) = 4;
 +
              BY4  = D(ST) + D(ST+1)+ D(ST+2) + D(ST+3);
 +
              NUS  = BIN4;
 +
              ENDIF;
 +
 
 +
              WRU =  %EDITW(NUS :WRSWRD);
 +
              IF  P(XX) > 0;
 +
                RU  = RU  +
 +
                    %SUBST(WRU :61-C(XX): C(XX)-P(XX)) + '.' +
 +
                    %SUBST(WRU :61-P(XX))    ;
 +
              ELSE;
 +
                RU  = RU  +
 +
                    %SUBST(WRU :61-C(XX));
 +
              ENDIF;
 +
            ENDIF;
 +
 
 +
 
 +
        //  PROCESS FLOAT  DATA TYPE
 +
            IF  T(XX) = 'F';
 +
 
 +
            ST = S(XX);
 +
 
 +
              IF  Q(XX) = 4;
 +
              FL4  = D(ST) + D(ST+1)+ D(ST+2) + D(ST+3);
 +
              FLT14 =  %EDITFLT(FLT4);
 +
                RU  = RU  + FLT14;
 +
              ENDIF;
 +
 
 +
              IF  Q(XX) = 8;
 +
              FL8  = D(ST) + D(ST+1)+ D(ST+2) + D(ST+3) +
 +
                      D(ST+4) + D(ST+5)+ D(ST+6) + D(ST+7);
 +
              FLT23 =  %EDITFLT(FLT8);
 +
                RU  = RU  + FLT23;
 +
              ENDIF;
 +
 
 +
            ENDIF;
 +
 
 +
 
 +
          //  SEND A REQUEST UNIT IF GOT ENOUGH DATA
 +
 
 +
            IF  %LEN(RU) + L(XX + 1) >= 200;
 +
              RU  =  RU + X20;
 +
              BIN  =  %LEN(RU);
 +
              OUTLEN  =  HX2;
 +
              INLEN  =  X000;
 +
              FNC    =  SND;
 +
              A      = RU;
 +
              EXCEPT  DATAO;
 +
              NEWRU  = '1';
 +
              RU    = *ALLX'00';
 +
              CLEAR  RU;
 +
            ENDIF;
 +
 
 +
            ENDFOR;
 +
          ENDIF;
 +
 
 +
            IF  %LEN(RU) > 5 AND %LEN(RU) < 250;
 +
              RU  =  RU + X20;
 +
              BIN  =  %LEN(RU);
 +
              OUTLEN  =  HX2;
 +
              INLEN  =  X000;
 +
              FNC    =  SND;
 +
              A      = RU;
 +
              EXCEPT  DATAO;
 +
            ENDIF;
 +
          ENDSR;
 +
 
 +
 
 +
        // @@@@@@@@@@@@@@@    ROWINC  @@@@@@@@@@@@@@@
 +
 
 +
        // INCREMENT THE ROW
 +
          BEGSR    @ROWINC;
 +
          ROW = ROW + 2;
 +
          IF  ROW > 20;
 +
            MX = 3;
 +
          ENDIF;
 +
          ENDSR;
 +
 
 +
 
 +
 
 +
        // @@@@@@@@@@@@@@@    GETFLD  @@@@@@@@@@@@@@@
 +
 
 +
        // LOAD FIELD DESCRIPTION ARRAYS
 +
          BEGSR    @GETFLD;
 +
          MX = 0;
 +
          X  = 0;
 +
 
 +
          IF  (*INU2 = *ON);
 +
          // IF NON KEYED ACCESS SET UP A FIELD TO SHOW THE RRN
 +
            N(1) =  'RRN';
 +
            T(1) =  'S'  ;
 +
            C(1) =  11  ;
 +
            P(1) =  0    ;
 +
            S(1) =  0    ;
 +
            E(1) =  0    ;
 +
            L(1) =  12  ;
 +
            I(1) = X4F06 ;
 +
            KY(1)= '3'  ;
 +
            X    = 1    ;
 +
          ENDIF;
 +
 
 +
          SCRST = *BLANK;
 +
          SCRSTN = *BLANK;
 +
 
 +
          LVL  = %DEC(SCNLVL : 5:0);
 +
 
 +
        TEXT500 = SCNLV ;
 +
        LV      = LVW;
 +
 
 +
        IF  LVL <> 0;
 +
          SCRST = LV(LVL);
 +
        ENDIF;
 +
 
 +
          SETLL 1 QWHDRFFD ;
 +
 
 +
          DOW  @LOOP  = @LOOP;
 +
        //  REREAD  TAG
 +
          READ    QWHDRFFD;
 +
          IF %EOF;
 +
            LEAVE;
 +
          ENDIF;
 +
 
 +
        //  SELECT OR OMIT
 +
          IF  ALL  <> '1';
 +
          IF  ALL  =  'S' AND WHDFTL = 0; // USING WHDFTL FOR KEY FIELDS
 +
            IF  WHFIOB  <>  'S';
 +
              ITER;
 +
            ENDIF;
 +
          ENDIF;
 +
          IF  ALL  =  'O' AND WHDFTL = 0; // USING WHDFTL FOR KEY FIELDS
 +
            IF  WHFIOB  =  'O';
 +
              ITER;
 +
            ENDIF;
 +
          ENDIF;
 +
          ENDIF;
 +
 
 +
        //  FIND THE FIRST FIELD TO BE SHOWN (FOR MULTI PAGE FORMATS)
 +
          IF  WHDFTL  <> 0 ;
 +
            ELSE;
 +
            IF SCRST <> ' ' AND SCRSTN = ' ';
 +
              IF WHFLDE =  SCRST;
 +
                SCRSTN = '1';    //  FOUND THE START
 +
              ELSE;
 +
                ITER;
 +
              ENDIF;
 +
            ENDIF;
 +
          ENDIF;
 +
 
 +
 
 +
          X =  X  + 1;
 +
        // CHECK FOR KEY FIELDS,WILL BE USED TO PLACE THEM IN FRONT
 +
          IF  WHDFTL  <>  0;
 +
              KY(X) = '1';
 +
              WX    = WHDFTL ;
 +
              KE(WX) = WHFLDE;
 +
              IF  NUMKEY <  WHDFTL;
 +
                NUMKEY = WHDFTL;
 +
              ENDIF;
 +
          ENDIF;
 +
 
 +
            N(X) =  WHFLDE ;              //    NAME
 +
            T(X) =  WHFLDT ;              //    TYPE
 +
            V(X) =  WHVARL ;              //    VARYING
 +
            C(X) =  WHFLDD ;              //    DEC DIGITS
 +
            P(X) =  WHFLDP ;              //    DEC PREC
 +
            S(X) =  WHFOBO ;              //    START
 +
            Q(X) =  WHFLDB ;              //    BTYES
 +
            E(X) =  WHFOBO + WHFLDB -1 ;  //  END
 +
 
 +
            IF T(X) =  'F' ;              //    FLOAT
 +
 
 +
              I(X) = FFA1 + FFA2;          //  SCRN FIELD FORMAT ALPHA
 +
              L(X)  = 14;
 +
              IF Q(X) = 8;
 +
              L(X)  = 23;
 +
              ENDIF;
 +
 
 +
            ELSE;
 +
              IF  WHFLDD  <> 0 ;
 +
              IF  WHFLDP  <> 0 ;
 +
                L(X) =  WHFLDD +  2  ;      //  LENGTH
 +
              ELSE;
 +
                L(X) =  WHFLDD +  1  ;      //  LENGTH
 +
              ENDIF;
 +
 
 +
                I(X) = FFN1 + FFN2;        //  SCRN FIELD FORMAT NUMERIC
 +
 
 +
              ELSE;
 +
                L(X) =    WHFLDB  ;
 +
                I(X) = FFA1 + FFA2;        //  SCRN FIELD FORMAT ALPHA
 +
              ENDIF;
 +
            ENDIF;
 +
 
 +
        ENDDO;
 +
        //  NUMBER OF FIELDS
 +
        NUMFLD = X ;
 +
 
 +
      //  MAKE ROOM FOR KEYS
 +
          IF  NUMKEY  >  0 ;
 +
          X1  = NUMKEY  + NUMFLD;
 +
 
 +
          FOR  X =  NUMFLD DOWNTO 1;
 +
              KY(X1) = KY(X) ;
 +
              L(X1)  = L(X)  ;
 +
              I(X1)  = I(X)  ;
 +
              N(X1)  = N(X)  ;
 +
              T(X1)  = T(X)  ;
 +
              V(X1)  = V(X)  ;
 +
              C(X1)  = C(X)  ;
 +
              P(X1)  = P(X)  ;
 +
              S(X1)  = S(X)  ;
 +
              E(X1)  = E(X)  ;
 +
              Q(X1)  = Q(X)  ;
 +
              X1    = X1 - 1;
 +
          ENDFOR;
 +
 
 +
          //  PUT KEY FIELDS AT TOP
 +
          OFF  = 0;
 +
          FOR  X =  1 TO NUMKEY;
 +
          X1 = %LOOKUP(KE(X) : N : NUMKEY+1);
 +
 
 +
          KY(X) = '2';
 +
          L(X)  = L(X1);
 +
          I(X)  = I(X1);  // FIELD FMT
 +
          SELECT;                // INPUT ENABLE
 +
            WHEN  I(X) = X6000;
 +
                  I(X) = X4800;
 +
            WHEN  I(X) = X6706;
 +
                  I(X) = X4F06;
 +
          ENDSL;
 +
            N(X) =  N(X1);
 +
            T(X) =  T(X1);
 +
            V(X) =  V(X1);
 +
            C(X) =  C(X1);
 +
            P(X) =  P(X1);
 +
            S(X) =  S(X1);
 +
            E(X) =  E(X1);
 +
            Q(X) =  Q(X1);
 +
            R(X) =  OFF;
 +
            OFF  =  OFF + Q(X1);
 +
          ENDFOR;
 +
 
 +
        ENDIF;
 +
      //  NUMBER OF FIELDS AND KEYS
 +
        NUMFKY = NUMFLD  +  NUMKEY;
 +
 
 +
        ENDSR;
 +
 
 +
 
 +
        // @@@@@@@@@@@@@@@    GETADD  @@@@@@@@@@@@@@@
 +
 
 +
        // LOAD FIELD BUFFER ADDRESSES
 +
          BEGSR    @GETADD;
 +
          MX = 0;
 +
          X  = 0;
 +
          ROW = 3;
 +
          COL = 1;
 +
 
 +
          FOR X = 1 TO NUMFKY;
 +
 
 +
        // IF FINISHED WITH THE KEY FIELDS
 +
        //  INC  ROW FOR 1ST DATA FIELD
 +
          IF KEYSOK = ' ' ;
 +
          IF KY(X) = ' ' OR KY(X) = '1';
 +
            KEYSOK = '1' ;
 +
            ROW    = ROW + 2;
 +
            COL    = 1;
 +
          ENDIF;
 +
          ENDIF;
 +
 
 +
        //  SET THE BUFFER ADD ON THE LARGER OF THE FIELD TEXT OR THE FIELD SIZE
 +
          LENDSC  = %LEN(%TRIM(N(X)));
 +
          LENWRK  =  L(X);
 +
          IF LENDSC > L(X);
 +
            LENWRK = LENDSC;
 +
          ENDIF;
 +
            LENWRK = LENWRK + 2;
 +
 
 +
        //  TRAP FIELDS THAT OVERFLOW
 +
            ROW  = ROW  + XROW;
 +
            XROW = %DIV(LENWRK : 80);
 +
 
 +
            IF (COL + LENWRK) > 78;
 +
              EXSR @ROWINC;
 +
                IF MX = 3;
 +
                X= X-1;
 +
                NUMFKY = X;
 +
                LEAVE;
 +
                ENDIF;
 +
              COL = 1;
 +
            ENDIF;
 +
 
 +
        // INC COL. FOR FIELD START
 +
          CLEAR  B(X);
 +
          BIN  = ROW;
 +
          B(X) =  %TRIM(B(X)) + HX1;
 +
          BIN  = COL + 1;
 +
          B(X) =  %TRIM(B(X)) + HX1;
 +
 
 +
        // INC COL. FOR NEXT FIELD
 +
        COL = COL + LENWRK;
 +
            IF COL > 78;
 +
              EXSR @ROWINC;
 +
                IF MX = 3;    // NO ROOM FOR THE FIELD
 +
                X= X-1;
 +
                NUMFKY = X;
 +
                LEAVE;
 +
                ENDIF;
 +
              COL = 1;
 +
            ENDIF;
 +
 
 +
          ENDFOR;
 +
 
 +
        //  FIELD LEVEL
 +
          LVX      = LVL + 1;
 +
          LV(LVX)  = N(X);
 +
 
 +
        ENDSR;
 +
 
 +
 
 +
        // @@@@@@@@@@@@@@@    PUTHED  @@@@@@@@@@@@@@@
 +
 
 +
        //  PUT FIELD HEADINGS
 +
          BEGSR    @PUTHED;
 +
 
 +
 
 +
            NEWRU  = '1';
 +
 
 +
            RU    = *ALLX'00';
 +
            CLEAR  RU;                  //  initialise Request Unit  255 bytes max
 +
            FOR  XX = 1 TO      NUMFKY; //NUMBER OF DATA ELEMENTS (FLD AND KEY)
 +
 
 +
            IF NEWRU = '1';
 +
              NEWRU  = '0';
 +
              RU  = ESC + WTD + X20 + X00;
 +
            ENDIF;
 +
 
 +
            RU = RU + SBA;
 +
            BIN = 0;
 +
              // CONVERT DATA BUFADR TO HEADING BUFADR
 +
            HX1 = %SUBST(B(XX) :1:1);
 +
            BIN = BIN - 1;
 +
            RU  = RU + HX1;
 +
 
 +
            IF  REHEAD = '1'; // ON REDISPLAY OVERRIDE THE ATTR
 +
              BIN = 0;
 +
              HX1 = %SUBST(B(XX) :2:1);
 +
              BIN = BIN -1 ;
 +
              RU  = RU + HX1;
 +
            ELSE;
 +
              RU  = RU + %SUBST(B(XX) :2);
 +
            ENDIF;
 +
 
 +
            RU = RU + ATC ;
 +
 
 +
        //  LONG NUMBER FIELDS ,RIGHT ADJUST THE FIELD HEADINGS
 +
            LENDSC  = %LEN(%TRIM(N(XX)));
 +
            IF  T(XX) <> 'A' AND  LENDSC <  (L(XX) -1);
 +
            FOR Y = 1 TO (L(XX) -(LENDSC +1));
 +
              RU = RU + ' ';
 +
            ENDFOR;
 +
            ENDIF;
 +
 
 +
            RU = RU + %TRIM(N(XX));
 +
 
 +
              IF %LEN(RU) >= 200;
 +
              BIN    = %LEN(RU);
 +
              OUTLEN = HX2;
 +
              INLEN  = X000;
 +
              FNC    = SND;
 +
              A      = RU;
 +
              EXCEPT DATAO;
 +
              NEWRU  = '1';
 +
              RU    = *ALLX'00';
 +
              CLEAR  RU;
 +
              ENDIF;
 +
 
 +
            ENDFOR;
 +
 
 +
              IF %LEN(RU) >  5 AND %LEN(RU) <  200;
 +
              BIN    = %LEN(RU);
 +
              OUTLEN = HX2;
 +
              INLEN  = X000;
 +
              FNC    = SND;
 +
              A      = RU;
 +
              EXCEPT DATAO;
 +
              ENDIF;
 +
 
 +
          IF REHEAD <> '1';
 +
        //  FORMAT FIELDS
 +
 
 +
 
 +
            NEWRU  = '1';
 +
            RU    = *ALLX'00';
 +
            CLEAR  RU;                  //  initialise Request Unit  255 bytes max
 +
            FOR  XX = 1 TO      NUMFKY; //NUMBER OF DATA ELEMENTS (FLD AND KEY)
 +
 
 +
            IF NEWRU = '1';
 +
              NEWRU  = '0';
 +
              RU  = ESC + WTD + X20 + X00;
 +
            ENDIF;
 +
 
 +
            RU = RU + SBA +B(XX)+SF + I(XX);
 +
 
 +
            IF KY(XX) = '1' OR KY(XX) = '2' OR KY(XX) = '3';
 +
              RU = RU + X25;
 +
            ELSE;
 +
              RU = RU + X26;
 +
            ENDIF;
 +
 
 +
            BIN =  L(XX);
 +
            RU  = RU + HX2;
 +
 
 +
          // LENGTH OF INPUT FIELDS
 +
            LENF  = LENF + L(XX) + 3;
 +
 
 +
 
 +
              IF %LEN(RU) >= 200;
 +
              BIN    = %LEN(RU);
 +
              OUTLEN = HX2;
 +
              INLEN  = X000;
 +
              FNC    = SND;
 +
              A      = RU;
 +
              EXCEPT DATAO;
 +
              NEWRU  = '1';
 +
              RU    = *ALLX'00';
 +
              CLEAR  RU;
 +
              ENDIF;
 +
 
 +
          ENDFOR;
 +
 
 +
      //  PUT LAST R/U
 +
              IF %LEN(RU) >  5 AND %LEN(RU) <  200;
 +
              BIN    = %LEN(RU);
 +
              OUTLEN = HX2;
 +
              INLEN  = X000;
 +
              FNC    = SND;
 +
              A      = RU;
 +
              EXCEPT DATAO;
 +
              ENDIF;
 +
 
 +
        //INC BUFFER ADDRESS FOR ALL FIELDS FOR DATA PUT
 +
            FOR  XP = 1 TO      NUMFKY; //NUMBER OF DATA ELEMENTS (FLD AND KEY)
 +
            HX2  = B(XP);
 +
            BIN  = BIN + 1;
 +
            B(XP) = HX2;
 +
            ENDFOR;
 +
          ENDIF;
 +
 
 +
        ENDSR;
 +
 
 +
      //  @@@@@@@  INIT  @@@@@@@@@@@@@@@@@@@@@@@@@
 +
          BEGSR        @INIT;
 +
 
 +
        CLEAR  KW;
 +
 
 +
        //  UPDATE
 +
          IF  UPDF  = 'Y';
 +
                FFA1 = X40;
 +
                FFN1 = X47;
 +
          ELSE;
 +
                FFA1 = X60;
 +
                FFN1 = X67;
 +
          ENDIF;
 +
 
 +
          SELECT;
 +
          WHEN  *INU1 = '1';
 +
                FILE  =  F1 ;
 +
                LIB  =  L1 ;
 +
                MBR  =  M1 ;
 +
                RCDL  =  R1 ;
 +
                ACCTP =  A1 ;
 +
          WHEN  *INU2 = '1';
 +
                FILE  =  F2 ;
 +
                LIB  =  L2 ;
 +
                MBR  =  M2 ;
 +
                RCDL  =  R2 ;
 +
                ACCTP =  A2 ;
 +
          ENDSL;
 +
            RLEN    =  RCDL  ;
 +
            RLENTH  =  %EDITC(RLEN: 'X') ;
 +
            LENF    =  0    ;
 +
 
 +
 
 +
        // Control commands and data are constructed into RUs Request UNITS
 +
        // Each RU is 256 bytes max size.
 +
        // Construct and send as many RUs as needed to format the display.
 +
            RU    = *ALLX'00';
 +
            CLEAR  RU;        //  initialise Request Unit  255 bytes max
 +
            RU  = CLRWTD ;
 +
          //set up the screen headings
 +
            BIN = 1;    // set ROW to 1
 +
            RW  = HX1;
 +
            BIN = 2;    // set COL to 2
 +
            CL  = HX1;
 +
            RU  = RU + SBA + RW + CL + X22 + %TRIM(LIB) + '/' + %TRIM(FILE);
 +
            RU  = RU + ' Mbr ' + %TRIM(MBR) + ' Rcdl ' + %EDITC(RLEN  : 'Z') ;
 +
            RU  = RU + ' RRN '  ;
 +
            BIN = %len(RU) -4;
 +
            RBA = RW + HX1 ;  // address of the RRN field
 +
            RU  = RU + SBA + RBA + '          ';
 +
 
 +
      // FUNCTION KEYS
 +
            BIN  = 23;
 +
            RW  = HX1;
 +
            BIN  = 02;
 +
            CL  = HX1;
 +
            IF  UPDF = 'Y';  //  UPDATE IS ON
 +
            RU  = RU + SBA + RW + CL + %TRIM(CNS(2));
 +
            ELSE;
 +
            RU  = RU + SBA + RW + CL + %TRIM(CNS(1));
 +
            ENDIF;
 +
 
 +
        //  THIS IS A SEND ONLY FUNCTION
 +
          FNC    = SND;
 +
          CLEAR A;
 +
          A      = RU;
 +
          BIN2    = %LEN(RU);
 +
          OUTLEN  = BY2;
 +
          INLEN  = x000;
 +
 
 +
          EXCEPT    DATAO;
 +
 
 +
        ENDSR;
 +
 
 +
 
 +
      //  @@@@@@@  KEYIN  @@@@@@@@@@@@@@@@@@@@@@@@@
 +
        BEGSR  @KEYIN;
 +
      // ISSUE A READ FROM DISPLAY
 +
          FNC = SNR;
 +
          BIN2  = 8;
 +
          OUTLEN = BY2;
 +
          IPL = LENF + 34;
 +
          BIN2  = IPL;
 +
          INLEN  = BY2;
 +
 
 +
          // SET FRR INDICATORS TO CONTROL BUFFER OVERFLOW
 +
          FOR X =  1 TO  9;
 +
            IF IPL  >  ( X*80 +3);
 +
              *IN(X+19) = *ON;
 +
            ENDIF;
 +
          ENDFOR;
 +
 
 +
        RU    = *ALLX'00';
 +
        CLEAR  RU;
 +
        RU  = RDDSP;
 +
        A    = RU;
 +
 
 +
        EXCEPT DATAI;
 +
        ENDSR;
 +
 
 +
      //  @@@@@@@  ERROR  @@@@@@@@@@@@@@@@@@@@@@@@@
 +
        BEGSR    @ERROR;
 +
 
 +
      // SETUP PUT ERROR MESSAGE X'21'
 +
        RU    = *ALLX'00';
 +
        CLEAR RU;
 +
 
 +
        FNC    =  SNR;
 +
        BIN    = 42;
 +
        OUTLEN = HX2;
 +
        BIN    = LENF + 34;
 +
        IPL    = BIN;
 +
        INLEN  = HX2;
 +
 
 +
        FOR X        = 1 TO 9;
 +
          IF IPL      > (X * 80 +3) ;
 +
          *IN(X + 19) = *ON;          // SETON FFR 20 - 29 FOR INPUT
 +
          ENDIF;
 +
        ENDFOR;
 +
 
 +
        RU = ESC + WER + IC + B(1) + ATC + MSG(MX);
 +
        RU = RU + ESC + RDM + X40+ X00;
 +
 
 +
        A  = RU;
 +
        EXCEPT    DATAI;
 +
        RU    = *ALLX'00';
 +
        CLEAR RU;
 +
        ENDSR;
 +
 
 +
 
 +
      //  @@@@@@@    HXDSP @@@@@@@@@@@@@@@@@@@@@@@@@
 +
        BEGSR  @HXDSP;
 +
 
 +
          RU    = *ALLX'00';
 +
          CLEAR RU;
 +
          Y = %LOOKUPLE( CURLOC : B );
 +
          //
 +
          RU = ESC + WTD + X20 + X00 + SBA;
 +
          BIN = 0;
 +
          HX1 = %SUBST(B(Y) :1:1);
 +
          BIN = BIN - 1;
 +
          RU  = RU + HX1;
 +
          RU  = RU + %SUBST(B(Y) :2:1);
 +
 
 +
          FOR X = S(Y) TO E(Y);
 +
            BIN = 0;
 +
            HX1 = D(X);
 +
            HX1 = %BITAND(HX1  : XF0);
 +
            Z  = BIN / 16 + 1;
 +
            RU  = RU + CRS(Z);
 +
          ENDFOR;
 +
 
 +
            RU  = RU + X20;
 +
 
 +
            RU  = RU + SBA + B(Y);
 +
          FOR X = S(Y) TO E(Y);
 +
            BIN = 0;
 +
            HX1 = D(X);
 +
            HX1 = %BITAND(HX1  : X0F);
 +
            Z  = BIN  + 1;
 +
            RU  = RU + CRS(Z);
 +
          ENDFOR;
 +
 
 +
 
 +
          BIN    = %LEN(RU);
 +
          OUTLEN = HX2;
 +
          INLEN  = X000;
 +
          FNC    = SND;
 +
          A      = RU;
 +
          EXCEPT DATAO;
 +
          RU    = *ALLX'00';
 +
          CLEAR  RU;
 +
 
 +
 
 +
          EXSR      @KEYIN;
 +
          READ      DISPF;
 +
 
 +
 
 +
      //  CLEAR HEADINGS
 +
            RU    = *ALLX'00';
 +
            CLEAR RU;
 +
 
 +
        RU  = RU + ESC + WTD + X20 + X00 + SBA;
 +
        HX1  = %SUBST(B(Y) :1:1) ;
 +
        BIN  = BIN - 1;
 +
        RU  = RU + HX1 + %SUBST(B(Y):2:1);
 +
          FOR X = S(Y) TO E(Y);
 +
          RU = RU + ' ';
 +
          ENDFOR;
 +
        RU = RU + ' ';
 +
 
 +
        BIN    = %LEN(RU);
 +
        OUTLEN = HX2;
 +
        INLEN  = X000;
 +
        FNC    = SND;
 +
        A      = RU;
 +
        EXCEPT    DATAO;
 +
        RU    = *ALLX'00';
 +
        CLEAR  RU;
 +
 
 +
        ENDSR;
 +
 
 +
 
 +
      /END-FREE
 +
 
 +
    ODISPF    E            DATAO
 +
    O                                          K3 'PUT'
 +
    O                      OUTLEN              2
 +
    O                      INLEN
 +
    O                      FNC
 +
    O                      A
 +
 
 +
    O          E            DATAI
 +
    O                                          K3 'GET'
 +
    O                      OUTLEN              2
 +
    O                      INLEN
 +
    O                      FNC
 +
    O                      A
 +
**
 +
0000 INVALID COMMAND KEY
 +
0001  - A FIELD IS TOO LONG
 +
0002  - TOO MANY FIELDS
 +
0003  - ALPHAS IN PACKED KEY
 +
0004  - MISSING ' IN PACKED KEY
 +
0005  - MISSING DATA IN PCKD KEY
 +
0006  - RECORD NOT FOUND
 +
PRESS RESET TO CONTINUE
 +
**
 +
F1-HEX F2-Return F3-Exit F19-Prev_fld F20-More_fld
 +
F1-HEX F2-Return F3-Exit F19-Prev_fld F20-More_fld
 +
**
 +
0123456789ABCDEF
 +
 
 +
</pre>
 +
 
 +
[[#top]]
 +
 
 +
===DISP2  RPG===
 +
 
 +
<pre>
 +
    H*eywords++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++Comments+++++++++++
 +
    H OPTION(*NODEBUGIO)
 +
    H DFTACTGRP(*NO) ACTGRP(*CALLER) DFTNAME(DISP )
 +
    F*
 +
    F*  LIMITED TO MAXIMUM FILE LENGTH OF 6080
 +
 
 +
    F*  REQUIRES FILE  QTEMP/FFD  TO COMPILE
 +
    F*  use cmd DSPFFD  FILE(&LIB/&FILE) OUTPUT(*OUTFILE) OUTFILE(QTEMP/FFD)
 +
 
 +
    FFFD      IF  E            DISK
 +
    FDISPF    CF  F  803        WORKSTN
 +
    F*
 +
    F                                    INFDS(INFDS)
 +
    FINPUTK    IF  F32766  800AIDISK    KEYLOC(1)
 +
    F                                    EXTIND(*INU1)
 +
    F                                    INFDS(INFDK)
 +
    FINPUTR    IF  F32766        DISK    EXTIND(*INU2)
 +
    F                                    INFDS(INFDR)
 +
 
 +
      *
 +
    D A              S            255                                        WORK RU
 +
    D RU              S            255    varying
 +
    D RW              S              1                                        ROW 1 byte binary
 +
    D CL              S              1                                        COL 1 byte binary
 +
    D FNC            S              1
 +
    D OUTLEN          S              2
 +
    D INLEN          S              2
 +
    D IPL            S              5  0
 +
    D ROW            S              3  0
 +
    D XROW            S              3  0
 +
    D COL            S              3  0
 +
    D KEYSOK          S              1
 +
    D LENDSC          S              3  0
 +
    D LENWRK          S              5  0
 +
    D STRX            S              5  0
 +
    D ENDX            S              5  0
 +
    D VX              S              5  0
 +
    D X              S              5  0
 +
    D X1              S              5  0
 +
    D X2              S              5  0
 +
    D XX              S              5  0
 +
    D XP              S              5  0
 +
    D MX              S              5  0
 +
    D ONCE            S              1
 +
    D RBA            S              2
 +
    D LF              S              5  0
 +
    D ST              S              5  0
 +
    D Y              S              5  0
 +
    D Z              S              5  0
 +
    D OFF            S              5  0
 +
    D SUPZ            S              1
 +
    D NUMFLD          S              5  0
 +
    D WX              S              5  0
 +
    D NUMKEY          S              5  0
 +
    D NUMFKY          S              5  0
 +
    D SCRST          S            10
 +
    D SCRSTN          S              1
 +
    D KEYA            S            800
 +
    D RRNA            S            11  0
 +
    D RRN            S            11  0
 +
    D REHEAD          S              1
 +
    D NEWRU          S              1
 +
    D WRTRRN          S              1
 +
    D LVX            S              5  0
 +
    D LVL            S              5  0
 +
    D K1              S              5  0
 +
    D K2              S              5  0
 +
    D Z1              S              5  0
 +
    D W              S              5  0
 +
    D WK2            S              2
 +
    D MSSG            S            32
 +
      *
 +
    D BASE            S              5  0
 +
    D INZ            S              1
 +
 
 +
    D FILE            S            10
 +
    D LIB            S            10
 +
    D MBR            S            10
 +
    D RCDL            S              5  0
 +
    D ACCTP          S              1
 +
    D RLEN            S              5  0
 +
    D RLENTH          S              5
 +
    D LENF            S              5  0
 +
 
 +
 
 +
    D                DS
 +
    D TEXT500                      500
 +
    D LVW                          10    DIM(50) overlay(TEXT500:1)
 +
 
 +
    D TEXT800        S            800
 +
    D KW              S            800
 +
 
 +
    D                DS
 +
    D WRK11                  1    11
 +
    D NUM11                  1    11S 0
 +
 
 +
    D                DS
 +
    D NUSA                    1    60
 +
    D NUS                    1    60S 0
 +
    D                DS
 +
    D NUPA                    1    60
 +
    D NUP                    29    60P 0
 +
 
 +
    D WRU            S            61
 +
    D WRX            S            64
 +
    D WRXWRD          C                  '0                              -
 +
    D                                                                    -'
 +
    D WRSWRD          C                  '0                              -
 +
    D                                                                  -'
 +
    D WRV            S            60    varying
 +
 
 +
    D FLT14          S            14
 +
    D FLT23          S            23
 +
 
 +
      * SET FILE SIZE INCREMENTS (64 OF THEM)
 +
    D SZ              S              5  0 DIM(64)
 +
    D S              S              5  0 DIM(9000)                            START OF FLD
 +
    D E              S              5  0 DIM(9000)                            END OF FLD
 +
    D Q              S              5  0 DIM(9000)                            BYTES IN FIELD
 +
    D L              S              5  0 DIM(9000)                            LENGTH OF FLD
 +
    D C              S              3  0 DIM(9000)                            DEC DIGITS
 +
    D P              S              3  0 DIM(9000)                            DEC PRECISION
 +
    D B              S              2    DIM(9000) ASCEND                    BUFFER ADD
 +
    D I              S              2    DIM(9000)                            FLD FMT
 +
    D N              S            10    DIM(9000)                            FLD NAME
 +
    D T              S              1    DIM(9000)                            FLD TYPE
 +
    D V              S              1    DIM(9000)                            VARYING
 +
    D KY              S              1    DIM(9000)                            KEYED
 +
    D KE              S            10    DIM(128)                            KEY FLDS
 +
    D R              S              3  0 DIM(9000)                            KEY FLD START
 +
    D K              S              1    DIM(800)                            KEY
 +
    D NA              S              1    DIM(10)                              NAME WORK
 +
    D NU              S              1    DIM(60)                              NUM. WORK
 +
    D LV              S            10    DIM(50)                              SCREEN LEVELS
 +
    D MSG            S            32    DIM(8) CTDATA PERRCD(1)              MESSAGES
 +
    D CNS            S            50    DIM(2) CTDATA PERRCD(1)
 +
    D CRS            S              1    DIM(16) CTDATA PERRCD(16)
 +
 
 +
 
 +
    D                DS
 +
    D  D                      1  6080
 +
    D                                    DIM(6080)                            INCOMING DATA
 +
    D  DA                    1  4048
 +
    D  DB                  4049  4064
 +
    D  DC                  4065  4096
 +
    D  DD                  4097  4128
 +
    D  DE                  4129  4160
 +
    D  DF                  4161  4192
 +
    D  DG                  4193  4224
 +
    D  DH                  4225  4256
 +
    D  DI                  4257  4288
 +
    D  DJ                  4289  4320
 +
    D  DK                  4321  4352
 +
    D  DL                  4353  4384
 +
    D  DM                  4385  4416
 +
    D  DN                  4417  4448
 +
    D  DZ                  4449  4480
 +
    D  DO                  4481  4512
 +
    D  DP                  4513  4544
 +
    D  DQ                  4545  4576
 +
    D  DR                  4577  4608
 +
    D  DS                  4609  4640
 +
    D  DT                  4641  4672
 +
    D  DU                  4673  4704
 +
    D  DV                  4705  4736
 +
    D  DW                  4737  4768
 +
    D  DX                  4769  4800
 +
    D  DY                  4801  4832
 +
    D  D0                  4833  4864
 +
    D  D1                  4865  4896
 +
    D  D2                  4897  4928
 +
    D  D3                  4929  4960
 +
    D  D4                  4961  4992
 +
    D  D5                  4993  5024
 +
    D  D6                  5025  5056
 +
    D  DBA                5057  5088
 +
    D  DCA                5089  5120
 +
    D  DDA                5121  5152
 +
    D  DEA                5153  5184
 +
    D  DFA                5185  5216
 +
    D  DGA                5217  5248
 +
    D  DHA                5249  5280
 +
    D  DIA                5281  5312
 +
    D  DJA                5313  5344
 +
    D  DKA                5345  5376
 +
    D  DLA                5377  5408
 +
    D  DMA                5409  5440
 +
    D  DNA                5441  5472
 +
    D  DOA                5473  5504
 +
    D  DPA                5505  5536
 +
    D  DQA                5537  5568
 +
    D  DRA                5569  5600
 +
    D  DSA                5601  5632
 +
    D  DTA                5633  5664
 +
    D  DUA                5665  5696
 +
    D  DVA                5697  5728
 +
    D  DWA                5729  5760
 +
    D  DXA                5761  5792
 +
    D  DYA                5793  5824
 +
    D  DZA                5825  5856
 +
    D  D0A                5857  5888
 +
    D  D1A                5889  5920
 +
    D  D2A                5921  5952
 +
    D  D3A                5953  5984
 +
    D  D4A                5985  6016
 +
    D  D5A                6017  6048
 +
    D  D6A                6049  6080
 +
    D                DS
 +
    D  ID                    1    800
 +
    D                                    DIM(800)                            INCOMING DATA
 +
    D  IDA                    1    800
 +
    D  ID0                    1    80
 +
    D  ID1                  81    160
 +
    D  ID2                  161    240
 +
    D  ID3                  241    320
 +
    D  ID4                  321    400
 +
    D  ID5                  401    480
 +
    D  ID6                  481    560
 +
    D  ID7                  561    640
 +
    D  ID8                  641    720
 +
    D  ID9                  721    800
 +
    D                DS
 +
    D  BIN                    1      2B 0
 +
    D  HX1                    2      2
 +
    D  HX2                    1      2
 +
    D                DS
 +
    D  PCK                    1      1P 0
 +
    D  PCK1                  1      1
 +
    D                DS
 +
    D  SGN                    1      1S 0
 +
    D  SGN1                  1      1
 +
 
 +
    D                DS
 +
    D  BIN4                  1      4B 0
 +
    D  BY4                    1      4
 +
 
 +
    D                DS
 +
    D  BIN2                  1      2B 0
 +
    D  BY2                    1      2
 +
 
 +
    D                DS
 +
    D  FLT4                  1      4F
 +
    D  FL4                    1      4
 +
 
 +
    D                DS
 +
    D  FLT8                  1      8F
 +
    D  FL8                    1      8
 +
 
 +
    D INFDK          DS
 +
    D  F1                    83    92
 +
    D  L1                    93    102
 +
    D  M1                  129    138
 +
    D  R1                  125    126B 0
 +
    D  A1                  160    160
 +
    D  LOP1                260    260
 +
    D  KEY_LEN              393    394I 0                                      Key length
 +
    D  RN1                  397    400B 0
 +
    D  LKY                  401  1200
 +
    D INFDR          DS
 +
    D  F2                    83    92
 +
    D  L2                    93    102
 +
    D  M2                  129    138
 +
    D  R2                  125    126B 0
 +
    D  A2                  160    160
 +
    D  LOP2                260    260
 +
    D  RN2                  397    400B 0
 +
    D*
 +
    D INFDS          DS
 +
    D  CURLOC              370    371
 +
    D                DS
 +
    D KEYLN                  1      4S 0
 +
    D KEYLNA                  1      4
 +
 
 +
    DDISP2            PR
 +
    D                                1
 +
    D                                1
 +
    D                                4
 +
    D                                1
 +
    D                              500
 +
    D                                5
 +
    D                              800
 +
    DDISP2            PI
 +
    D  ALL                          1
 +
    D  RTN                          1
 +
    D  KEYLNG                      4
 +
    D  UPDF                        1
 +
    D  SCNLV                      500
 +
    D  SCNLVL                      5
 +
    D  SCNKEY                    800
 +
 
 +
 
 +
    D @LOOP          C                  '1'
 +
 
 +
    D SND            C                  X'71'                                SEND TO DISP
 +
    D SNR            C                  X'73'                                SND/RCV
 +
    D RED            C                  X'42'                                READ
 +
    D RDM            C                  X'52'                                READ MTD
 +
    D ESC            C                  X'04'                                ESCAPE
 +
    D CLR            C                  X'40'                                CLEAR UNIT
 +
    D CC1            C                  X'00'                                CNTRL CHAR
 +
    D CC2            C                  X'08'                                CNTRL CHAR
 +
    D SBA            C                  X'11'                                SET BUFF ADR
 +
    D IC              C                  X'13'                                INSERT CURS
 +
    D WTD            C                  X'11'                                WRITE TO DSP
 +
    D WER            C                  X'21'                                WRITE ERROR
 +
    D SF              C                  X'1D'                                START FLD
 +
    D ATC            C                  X'20'                                ATTR CHAR
 +
    D ATN            C                  X'24'                                ATTR NUM
 +
    D X00            C                  X'00'
 +
    D X01            C                  X'01'
 +
    D X02            C                  X'02'
 +
    D X03            C                  X'03'
 +
    D X0D            C                  X'0D'
 +
    D X0F            C                  X'0F'
 +
    D X000            C                  X'0000'
 +
    D X1F            C                  X'1F'
 +
    D X20            C                  X'20'                                SCRN ATT NORMAL
 +
    D X22            C                  X'22'                                SCRN ATTR HI
 +
    D X25            C                  X'25'
 +
    D X26            C                  X'26'
 +
    D X31            C                  X'31'                                CMD 1 KEY
 +
    D X32            C                  X'32'                                CMD 2 KEY
 +
    D X33            C                  X'33'                                CMD 3 KEY
 +
    D X36            C                  X'36'                                CMD 6 KEY
 +
    D X37            C                  X'37'                                CMD 7 KEY
 +
    D X38            C                  X'38'                                CMD 8 KEY
 +
    D X39            C                  X'39'                                CMD 9 KEY
 +
    D X3B            C                  X'3B'                                CMD11 KEY
 +
    D XB7            C                  X'B7'                                CMD19 KEY
 +
    D XB8            C                  X'B8'                                CMD20 KEY
 +
    D X40            C                  X'40'
 +
    D X43            C                  X'43'
 +
    D X47            C                  X'47'
 +
    D X60            C                  X'60'
 +
    D X67            C                  X'67'
 +
    D X9F            C                  X'9F'
 +
    D XF0            C                  X'F0'
 +
    D XD0            C                  X'D0'
 +
    D X4000          C                  X'4000'
 +
    D X4800          C                  X'4800'                              FF ALPHA
 +
    D X4F06          C                  X'4F06'                              FF NUMERIC
 +
    D X6000          C                  X'6000'                              FF ALPHA
 +
    D X6706          C                  X'6706'                              FF NUMERIC
 +
    D CLRWTD          C                  X'044004112000'                      INCLUDES ESC CHARS
 +
    D RDDSP          C                  X'0411200804524000'                  REAB FROM DISPLAY
 +
    D FFA1            S              1    INZ(X'40')                          F.FMT 1 ALPH  60 BYP
 +
    D FFA2            S              1    INZ(X'00')                          F.FMT 2 ALPH
 +
    D FFN1            S              1    INZ(X'47')                          F.FMT 1 NUM  67 BYP
 +
    D FFN2            S              1    INZ(X'06')                          F.FMT 2 NUM
 +
    I*.
 +
    IINPUTK    NS  01
 +
    I                                  1 4048  DA
 +
    I                              4049 4064  DB                30
 +
    I                              4065 4096  DC                31
 +
    I                              4097 4128  DD                32
 +
    I                              4129 4160  DE                33
 +
    I                              4161 4192  DF                34
 +
    I                              4193 4224  DG                35
 +
    I                              4225 4256  DH                36
 +
    I                              4257 4288  DI                37
 +
    I                              4289 4320  DJ                38
 +
    I                              4321 4352  DK                39
 +
    I                              4353 4384  DL                40
 +
    I                              4385 4416  DM                41
 +
    I                              4417 4448  DN                42
 +
    I                              4449 4480  DZ                43
 +
    I                              4481 4512  DO                44
 +
    I                              4513 4544  DP                45
 +
    I                              4545 4576  DQ                46
 +
    I                              4577 4608  DR                47
 +
    I                              4609 4640  DS                48
 +
    I                              4641 4672  DT                49
 +
    I                              4673 4704  DU                50
 +
    I                              4705 4736  DV                51
 +
    I                              4737 4768  DW                52
 +
    I                              4769 4800  DX                53
 +
    I                              4801 4832  DY                54
 +
    I                              4833 4864  D0                55
 +
    I                              4865 4896  D1                56
 +
    I                              4897 4928  D2                57
 +
    I                              4929 4960  D3                58
 +
    I                              4961 4992  D4                59
 +
    I                              4993 5024  D5                60
 +
    I                              5025 5056  D6                61
 +
    I                              5057 5088  DBA              62
 +
    I                              5089 5120  DCA              63
 +
    I                              5121 5152  DDA              64
 +
    I                              5153 5184  DEA              65
 +
    I                              5185 5216  DFA              66
 +
    I                              5217 5248  DGA              67
 +
    I                              5249 5280  DHA              68
 +
    I                              5281 5312  DIA              69
 +
    I                              5313 5344  DJA              70
 +
    I                              5345 5376  DKA              71
 +
    I                              5377 5408  DLA              72
 +
    I                              5409 5440  DMA              73
 +
    I                              5441 5472  DNA              74
 +
    I                              5473 5504  DOA              75
 +
    I                              5505 5536  DPA              76
 +
    I                              5537 5568  DQA              77
 +
    I                              5569 5600  DRA              78
 +
    I                              5601 5632  DSA              79
 +
    I                              5633 5664  DTA              80
 +
    I                              5665 5696  DUA              81
 +
    I                              5697 5728  DVA              82
 +
    I                              5729 5760  DWA              83
 +
    I                              5761 5792  DXA              84
 +
    I                              5793 5824  DYA              85
 +
    I                              5825 5856  DZA              86
 +
    I                              5857 5888  D0A              87
 +
    I                              5889 5920  D1A              88
 +
    I                              5921 5952  D2A              89
 +
    I                              5953 5984  D3A              90
 +
    I                              5985 6016  D4A              91
 +
    I                              6017 6048  D5A              92
 +
    I                              6049 6080  D6A              93
 +
    IINPUTR    NS  01
 +
    I                                  1 4048  DA
 +
    I                              4049 4064  DB                30
 +
    I                              4065 4096  DC                31
 +
    I                              4097 4128  DD                32
 +
    I                              4129 4160  DE                33
 +
    I                              4161 4192  DF                34
 +
    I                              4193 4224  DG                35
 +
    I                              4225 4256  DH                36
 +
    I                              4257 4288  DI                37
 +
    I                              4289 4320  DJ                38
 +
    I                              4321 4352  DK                39
 +
    I                              4353 4384  DL                40
 +
    I                              4385 4416  DM                41
 +
    I                              4417 4448  DN                42
 +
    I                              4449 4480  DZ                43
 +
    I                              4481 4512  DO                44
 +
    I                              4513 4544  DP                45
 +
    I                              4545 4576  DQ                46
 +
    I                              4577 4608  DR                47
 +
    I                              4609 4640  DS                48
 +
    I                              4641 4672  DT                49
 +
    I                              4673 4704  DU                50
 +
    I                              4705 4736  DV                51
 +
    I                              4737 4768  DW                52
 +
    I                              4769 4800  DX                53
 +
    I                              4801 4832  DY                54
 +
    I                              4833 4864  D0                55
 +
    I                              4865 4896  D1                56
 +
    I                              4897 4928  D2                57
 +
    I                              4929 4960  D3                58
 +
    I                              4961 4992  D4                59
 +
    I                              4993 5024  D5                60
 +
    I                              5025 5056  D6                61
 +
    I                              5057 5088  DBA              62
 +
    I                              5089 5120  DCA              63
 +
    I                              5121 5152  DDA              64
 +
    I                              5153 5184  DEA              65
 +
    I                              5185 5216  DFA              66
 +
    I                              5217 5248  DGA              67
 +
    I                              5249 5280  DHA              68
 +
    I                              5281 5312  DIA              69
 +
    I                              5313 5344  DJA              70
 +
    I                              5345 5376  DKA              71
 +
    I                              5377 5408  DLA              72
 +
    I                              5409 5440  DMA              73
 +
    I                              5441 5472  DNA              74
 +
    I                              5473 5504  DOA              75
 +
    I                              5505 5536  DPA              76
 +
    I                              5537 5568  DQA              77
 +
    I                              5569 5600  DRA              78
 +
    I                              5601 5632  DSA              79
 +
    I                              5633 5664  DTA              80
 +
    I                              5665 5696  DUA              81
 +
    I                              5697 5728  DVA              82
 +
    I                              5729 5760  DWA              83
 +
    I                              5761 5792  DXA              84
 +
    I                              5793 5824  DYA              85
 +
    I                              5825 5856  DZA              86
 +
    I                              5857 5888  D0A              87
 +
    I                              5889 5920  D1A              88
 +
    I                              5921 5952  D2A              89
 +
    I                              5953 5984  D3A              90
 +
    I                              5985 6016  D4A              91
 +
    I                              6017 6048  D5A              92
 +
    I                              6049 6080  D6A              93
 +
    IDISPF    NS  02
 +
    I                                  3    3  AID
 +
    I                                  4  83  ID0
 +
    I                                84  163  ID1              20
 +
    I                                164  243  ID2              21
 +
    I                                244  323  ID3              22
 +
    I                                324  403  ID4              23
 +
    I                                404  483  ID5              24
 +
    I                                484  563  ID6              25
 +
    I                                564  643  ID7              26
 +
    I                                644  723  ID8              27
 +
    I                                724  803  ID9              28
 +
 
 +
 
 +
      /FREE
 +
            BASE = 0;
 +
 
 +
            IF  ONCE  =  ' ';
 +
                EXSR      @INITZ  ;
 +
            ENDIF;
 +
 
 +
        //  START        TAG
 +
          DOW      @LOOP = @LOOP;
 +
 
 +
          IF  RTN  = '3';
 +
 
 +
              IF *INU1;
 +
                KEYA =  SCNKEY;
 +
              ENDIF;
 +
              IF *INU2;
 +
                RRNA =  %DEC(%SUBST(SCNKEY:1:11):11:0);
 +
              ENDIF;
 +
                RTN = '0';
 +
                AID = '1';
 +
            ELSE;
 +
              RTN  = '0';
 +
              READ(E)  DISPF;
 +
          ENDIF;
 +
 
 +
        //  CF3 EXIT
 +
          IF  AID  = X33;
 +
            LEAVE;
 +
          ENDIF;
 +
 
 +
        //  CF2 RETURN
 +
          IF  AID  = X32;
 +
            RTN = '1';
 +
            LEAVE;
 +
          ENDIF;
 +
 
 +
        // CF1 HEX A FIELD
 +
          IF  AID  = X31;
 +
          Y = %LOOKUPLE( CURLOC : B );
 +
          IF Y > 0;
 +
            IF KY(Y) <= '1';
 +
              EXSR      @HXDSP;
 +
              REHEAD  = '1';
 +
              EXSR      @PUTHED;
 +
              REHEAD  = ' ';
 +
            ENDIF;
 +
            ENDIF;
 +
          ENDIF;
 +
 
 +
        //  CF20 MORE FIELDS
 +
          IF  AID  = XB8;
 +
 
 +
            LVX  = LVL + 1;
 +
            IF  LV(LVX)  <> *BLANK;
 +
              LVL = LVL +1 ;
 +
 
 +
              LVW  = LV;
 +
              SCNLV = TEXT500;
 +
              SCNLVL = %EDITC(LVL :'X');
 +
 
 +
            SCNKEY = *BLANKS;
 +
          IF  *INU1;
 +
                SCNKEY = KEYA;
 +
          ENDIF;
 +
          IF  *INU2;
 +
                SCNKEY = %EDITC(RRNA:'X');
 +
          ENDIF;
 +
 
 +
              RTN = '3';
 +
              LEAVE;
 +
            ENDIF;
 +
          ENDIF;
 +
 
 +
      //  CF19 PREVIOUS FIELDS
 +
          IF  AID  = XB7;
 +
 
 +
            LVX  = LVL - 1;
 +
            IF  LVX    >= 0 ;
 +
              LVL = LVL - 1 ;
 +
 
 +
              LVW  = LV;
 +
              SCNLV = TEXT500;
 +
              SCNLVL = %EDITC(LVL :'X');
 +
 
 +
                SCNKEY = *BLANKS;
 +
          IF  *INU1;
 +
                SCNKEY = KEYA;
 +
          ENDIF;
 +
          IF  *INU2;
 +
                SCNKEY = %EDITC(RRNA:'X');
 +
          ENDIF;
 +
 
 +
              RTN = '3';
 +
              LEAVE;
 +
            ENDIF;
 +
          ENDIF;
 +
 
 +
          // 1 ENTER
 +
          // 4 ROLL DN
 +
          // 5 ROLL UP
 +
          IF  AID  = '1'or AID = '4' or AID = '5';
 +
          ELSE;
 +
            MX = 1;
 +
            EXSR  @ERROR;
 +
          ENDIF;
 +
 
 +
          IF  RTN <> '3';
 +
            EXSR      @PCKD;
 +
          ENDIF;
 +
 
 +
 
 +
        // CONT1  GET A RECORD, KEY FROM DATA
 +
            EXSR      @SETIN;
 +
            EXSR      @GETF ;
 +
            EXSR      @PUTF ;
 +
            EXSR      @KEYIN;
 +
 
 +
          ENDDO ;
 +
 
 +
          *INLR = *ON;
 +
 
 +
      //  @@@@@@@  @INITZ @@@@@@@@@@@@@@@@@@@@@@@@@@
 +
        BEGSR  @INITZ;
 +
                ONCE  =  '1';
 +
                KEYLNA = KEYLNG  ;
 +
                EXSR      @INIT  ;
 +
                EXSR      @GETFLD ;
 +
                EXSR      @GETADD ;
 +
                EXSR      @PUTHED ;
 +
                EXSR      @KEYIN  ;
 +
                INZ  = '1';
 +
                EXSR      @PCKD  ;
 +
                INZ  = ' ';
 +
        ENDSR;
 +
 
 +
      //  @@@@@@@  @PCKD  @@@@@@@@@@@@@@@@@@@@@@@@@@
 +
 
 +
          BEGSR  @PCKD ;
 +
 
 +
            //  CONVERT  KEY DATA
 +
            IF  *INU1 ;
 +
              EXSR  @CVTKEY;
 +
            ENDIF;
 +
            IF  *INU2 ;
 +
              EXSR  @CVTRRN;
 +
            ENDIF;
 +
 
 +
          ENDSR;
 +
 
 +
      //  @@@@@@@  @CVTKEY  @@@@@@@@@@@@@@@@@@@@@@@@
 +
 
 +
          BEGSR  @CVTKEY;
 +
 
 +
      // EXTRACT THE KEY FIELD DATA FROM THE INCOMING STRING
 +
 
 +
        // FOR EACH KEY FIELD, CHECK IF FIELD WAS MODIFIED, AND IF SO MOVE
 +
        // THE MODIFIED DATA INTO THE COMPOSITE KEY
 +
 
 +
        K1 = 0;
 +
        K2 = 0;
 +
        W  = 1;
 +
 
 +
          FOR  Y  = 1  TO NUMKEY ;
 +
 
 +
      //  MOVE A KEY FIELDS DATA FROM ID ARRAY (SCREEN) TO K ARRAY (KEY FIELDS)
 +
 
 +
      //  GET SIZE OF FIELD IN BYTES
 +
          IF T(Y)  =  'A';  // ALPHA DATA
 +
          K = ' ';
 +
          K1 = 1;
 +
          K2 = Q(Y);
 +
          ELSE;
 +
          K  = '0';
 +
          K1 =  1;
 +
          K2 = C(Y);
 +
          ENDIF;
 +
 
 +
      // IF WHOLE KEY INIT WAS REQUESTED BYPASS THE EXTRACT
 +
          IF  INZ  = '1' ;
 +
            KW  = *BLANK;
 +
            EXSR      @PCKMOV;
 +
            ITER;
 +
          ENDIF;
 +
 
 +
          X  =  1;
 +
 
 +
          DOW  @LOOP = @LOOP;
 +
 
 +
      //  NXTSBA
 +
          X  = %LOOKUP(SBA : ID : X );
 +
          IF X = 0;
 +
            LEAVE;
 +
          ENDIF;
 +
 
 +
      // IS THIS THE FIELD?  CHECK THE BUFFER ADDRESS
 +
        X = X +1;
 +
        IF  B(Y)  <>  %SUBST(IDA : X :2);
 +
          ITER;
 +
        ENDIF;
 +
 
 +
      //  FOUND A MTD FOR THIS FIELD
 +
        X =  X + 2;
 +
 
 +
      //  CHECK IF FIELD WAS CLEARED ONLY
 +
        IF  ID(X) = SBA;
 +
            EXSR      @PCKMOV;
 +
            LEAVE ;
 +
        ENDIF;
 +
 
 +
      //  IF FIELD HAS DECIMALS BUMP X
 +
          IF (T(Y) = 'S' OR T(Y) = 'P' OR T(Y) = 'B') AND
 +
              P(Y) > 0;
 +
              X = X + 1;
 +
          ENDIF;
 +
 
 +
      //  CHECK IF ONLY BLANKS RETURNED
 +
        IF    %SUBST(IDA : X :K2) = *BLANKS;
 +
            EXSR      @PCKMOV;
 +
            LEAVE;
 +
        ENDIF;
 +
 
 +
      // EXTRACT THE DATA FROM THE INCOMING STRING
 +
        X1  = X;
 +
        FOR X2  =  1 TO  K2 ;
 +
 
 +
          IF ID(X1) < ' ';
 +
      // TRAP NULLS CAUSED BY FLD EXIT
 +
            EXSR      @PCKMOV;
 +
            LEAVE;
 +
          ENDIF;
 +
 
 +
        K(X2)  =  ID(X1);
 +
        X1    =  X1 +1;
 +
        ENDFOR;
 +
 
 +
        // CONSTRUCT THE ACTUAL KEY WITH PACKED DATA IF REQUIRED
 +
        // INTO ARRAY KW
 +
          EXSR      @PCKMOV;
 +
          LEAVE;
 +
        ENDDO;
 +
 
 +
        ENDFOR;
 +
 
 +
        //
 +
          KEYA  = KW;
 +
          CLEAR KW;
 +
        ENDSR ;
 +
 
 +
      //  @@@@@@@  @CVTRRN  @@@@@@@@@@@@@@@@@@@@@@@@
 +
 
 +
          BEGSR  @CVTRRN;
 +
 
 +
        //  RRN
 +
 
 +
          NUM11 = 0;
 +
 
 +
          DOW  @LOOP = @LOOP;  //  NOT REALLY A LOOP(SIMULATES GOTO)
 +
 
 +
      // GET THE FIRST SBA
 +
          X = 1;
 +
          X  = %LOOKUP(SBA : ID : X );
 +
          IF X = 0;
 +
          LEAVE;
 +
          ENDIF;
 +
 
 +
      // CHECK THE BUFFER ADDRESS MATCHES THE EXPECTED FIELD
 +
        X = X +1;
 +
        IF  B(1)  <>  %SUBST(IDA : X :2);
 +
          LEAVE;
 +
        ENDIF;
 +
 
 +
      //  FOUND A MTD FOR RRN  FIELD
 +
        X = X +2;
 +
 
 +
      //CHECK IF FIELD WAS CLEARED ONLY
 +
        IF  ID(X) = SBA;
 +
            LEAVE;
 +
        ENDIF;
 +
 
 +
      //  CHECK IF ONLY BLANKS RETURNED
 +
        IF    %SUBST(IDA : X :11) = *BLANKS;
 +
            LEAVE;
 +
        ENDIF;
 +
 
 +
 
 +
        //  WRK11  OVERLAYS NUM11
 +
        WRK11 = %SUBST(IDA : X :11);
 +
 
 +
        LEAVE;
 +
        ENDDO;
 +
 
 +
 
 +
        RRNA = NUM11;
 +
        IF RRNA < 0;
 +
        RRNA =  1;
 +
        ENDIF;
 +
 
 +
        ENDSR;
 +
 
 +
      //  @@@@@@@  @PCKMOV  @@@@@@@@@@@@@@@@@@@@@@@@
 +
 
 +
        BEGSR  @PCKMOV;
 +
      //
 +
      //  CONVERT  KEY DATA
 +
      //  SET START POSN IN KEY USING OFFSET IN R
 +
        W = R(Y) + 1;
 +
 
 +
        // ALPHA
 +
          IF  T(Y) = 'A';
 +
          X1  = 1;
 +
          FOR  Z = W  TO W + Q(Y);
 +
            %SUBST(KW : Z : 1) =  K(X1);
 +
            X1 = X1 + 1;
 +
          ENDFOR;
 +
          ENDIF;
 +
 
 +
        // NUMERIC FIELD
 +
        // RIGHT  ADJUST NUMERIC DATA ,STRIP - . ,CONVERT BLANKS
 +
          IF (T(Y) = 'S' OR T(Y) = 'P' OR T(Y) = 'B');
 +
          NU = '0';
 +
 
 +
          Z1 = 60;
 +
          FOR Z  =  K2  DOWNTO K1;
 +
 
 +
          IF K(Z) = '.' OR K(Z) = '-' OR K(Z) = '$';
 +
          ITER;
 +
          ENDIF;
 +
 
 +
          IF K(Z) = ' ' ;
 +
          NU(Z1) = '0';
 +
          ELSE;
 +
          NU(Z1) = K(Z);
 +
          ENDIF;
 +
 
 +
            Z1 = Z1 -1;
 +
          ENDFOR;
 +
 
 +
          ENDIF;
 +
 
 +
      // SIGNED FIELDS  (END POSN = OFFSET + SIZE)