Difference between revisions of "UDDS File Display/Update"

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