Difference between revisions of "UDDS File Display/Update"

From MidrangeWiki
Jump to: navigation, search
m (DIS1 CL files with NULL fields cant be processed)
 
(31 intermediate revisions by the same user not shown)
Line 2: Line 2:
  
  
==UDDS   UNDER  CONSTRUCTION  MORE  CODE TO BE ADDED SOON ==
+
==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]]
  
 
+
===DISP1 RPG===
===DISP1   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 1,814: Line 1,819:
 
     F*  LIMITED TO MAXIMUM FILE LENGTH OF 4080
 
     F*  LIMITED TO MAXIMUM FILE LENGTH OF 4080
 
     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 2,784: Line 2,792:
 
           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 2,790: Line 2,804:
 
             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 2,800: Line 2,816:
 
               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 2,958: Line 2,968:
  
 
             ENDFOR;
 
             ENDFOR;
 +
          ENDIF;
  
 
             IF  %LEN(RU) > 5 AND %LEN(RU) < 250;
 
             IF  %LEN(RU) > 5 AND %LEN(RU) < 250;
Line 3,586: Line 3,597:
 
**
 
**
 
0123456789ABCDEF
 
0123456789ABCDEF
 +
 
</pre>
 
</pre>
  
 
[[#top]]
 
[[#top]]
  
 
+
===DISP2  RPG===
===DISPF  DSPF ===
 
  
 
<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 6080
    A          R PUT                      USRDFN
 
    A          R GET                      USRDFN
 
    A                                      INVITE
 
</pre>
 
  
 +
    F*  REQUIRES FILE  QTEMP/FFD  TO COMPILE
 +
    F*  use cmd DSPFFD  FILE(&LIB/&FILE) OUTPUT(*OUTFILE) OUTFILE(QTEMP/FFD)
  
[[#top]]
+
    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)
  
== WRAPPER CODE ==
+
      *
===DISPR   RPG ===
+
    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>
 
 
</pre>
 
</pre>
 +
 +
[[#top]]
 +
 +
===DUSP  RPG===
 +
 +
<pre>
 +
    H*eywords++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++Comments+++++++++++
 +
    H OPTION(*NODEBUGIO)
 +
    H DFTACTGRP(*NO) ACTGRP(*CALLER) DFTNAME(DUSP )
 +
    F*
 +
    F*  LIMITED TO MAXIMUM FILE LENGTH OF 2048
 +
    F*  REQUIRES FILE  QTEMP/FFD  TO COMPILE
 +
    F*  use cmd DSPFFD  FILE(&LIB/&FILE) OUTPUT(*OUTFILE) OUTFILE(QTEMP/FFD)
 +
 +
    FFFD      IF  E            DISK
 +
    FDISPF    CF  F  803        WORKSTN
 +
    F*
 +
    F                                    INFDS(INFDS)
 +
    FINPUTK    UF A F32766  800AIDISK    KEYLOC(1)
 +
    F                                    EXTIND(*INU1)
 +
    F                                    INFDS(INFDK)
 +
    FINPUTR    UF A F32766        DISK    EXTIND(*INU2)
 +
    F                                    INFDS(INFDR)
 +
 +
 +
    D DISBIN          PR                  extpgm('DISBIN')
 +
    D  NUM                          15P 0
 +
    D  BAN2                          2
 +
    D  BAN4                          4
 +
    D  BINTYP                        1    CONST
 +
 +
      *
 +
    D A              S            255                                        WORK RU
 +
    D RU              S            255    varying
 +
    D RW              S              1                                        ROW 1 byte binary
 +
    D CL              S              1                                        COL 1 byte binary
 +
    D FNC            S              1
 +
    D OUTLEN          S              2
 +
    D INLEN          S              2
 +
    D IPL            S              5  0
 +
    D ROW            S              3  0
 +
    D XROW            S              3  0
 +
    D COL            S              3  0
 +
    D KEYSOK          S              1
 +
    D LENDSC          S              3  0
 +
    D LENWRK          S              5  0
 +
    D STRX            S              5  0
 +
    D ENDX            S              5  0
 +
    D VX              S              5  0
 +
    D X              S              5  0
 +
    D X1              S              5  0
 +
    D X2              S              5  0
 +
    D XX              S              5  0
 +
    D XP              S              5  0
 +
    D MX              S              5  0
 +
    D ONCE            S              1
 +
    D RBA            S              2
 +
    D LF              S              5  0
 +
    D ST              S              5  0
 +
    D Y              S              5  0
 +
    D Z              S              5  0
 +
    D OFF            S              5  0
 +
    D CGKY            S              1
 +
    D UPDDONE        S              1
 +
    D SUPZ            S              1
 +
    D NUMFLD          S              5  0
 +
    D WX              S              5  0
 +
    D NUMKEY          S              5  0
 +
    D NUMFKY          S              5  0
 +
    D SCRST          S            10
 +
    D SCRSTN          S              1
 +
    D KEYA            S            800
 +
    D RRNA            S            11  0
 +
    D RRN            S            11  0
 +
    D REHEAD          S              1
 +
    D NEWRU          S              1
 +
    D WRTRRN          S              1
 +
    D LVX            S              5  0
 +
    D LVL            S              5  0
 +
    D K1              S              5  0
 +
    D K2              S              5  0
 +
    D Z1              S              5  0
 +
    D W              S              5  0
 +
    D WK2            S              2
 +
    D MSSG            S            32
 +
      *
 +
    D BASE            S              5  0
 +
    D INZ            S              1
 +
 +
    D FILE            S            10
 +
    D LIB            S            10
 +
    D MBR            S            10
 +
    D RCDL            S              5  0
 +
    D ACCTP          S              1
 +
    D RLEN            S              5  0
 +
    D RLENTH          S              5
 +
    D LENF            S              5  0
 +
 +
 +
    D                DS
 +
    D TEXT500                      500
 +
    D LVW                          10    DIM(50) overlay(TEXT500:1)
 +
 +
    D TEXT800        S            800
 +
    D KW              S            800
 +
 +
    D                DS
 +
    D WRK11                  1    11
 +
    D NUM11                  1    11S 0
 +
 +
    D                DS
 +
    D NUSA                    1    60
 +
    D NUS                    1    60S 0
 +
    D                DS
 +
    D NUPA                    1    60
 +
    D NUP                    29    60P 0
 +
 +
    D NUC            S            15P 0
 +
    D BAN2            S              2
 +
    D BAN4            S              4
 +
 +
    D                DS
 +
    D NUFA                    1    60A
 +
    D NUF                    1    23A
 +
    D NUF1                    1    14A
 +
 +
    D                DS
 +
    D result8                        8F
 +
    D NUFW8                  1      8A
 +
 +
    D                DS
 +
    D result4                        4F
 +
    D NUFW4                  1      4A
 +
 +
    D WRU            S            61
 +
    D WRX            S            64
 +
    D WRXWRD          C                  '0                              -
 +
    D                                                                    -'
 +
    D WRSWRD          C                  '0                              -
 +
    D                                                                  -'
 +
    D WRV            S            60    varying
 +
 +
    D FLT14          S            14
 +
    D FLT23          S            23
 +
 +
      * SET FILE SIZE INCREMENTS (64 OF THEM)
 +
    D SZ              S              5  0 DIM(64)
 +
    D S              S              5  0 DIM(9000)                            START OF FLD
 +
    D E              S              5  0 DIM(9000)                            END OF FLD
 +
    D Q              S              5  0 DIM(9000)                            BYTES IN FIELD
 +
    D L              S              5  0 DIM(9000)                            LENGTH OF FLD
 +
    D C              S              3  0 DIM(9000)                            DEC DIGITS
 +
    D P              S              3  0 DIM(9000)                            DEC PRECISION
 +
    D B              S              2    DIM(9000) ASCEND                    BUFFER ADD
 +
    D I              S              2    DIM(9000)                            FLD FMT
 +
    D N              S            10    DIM(9000)                            FLD NAME
 +
    D T              S              1    DIM(9000)                            FLD TYPE
 +
    D V              S              1    DIM(9000)                            VARYING
 +
    D KY              S              1    DIM(9000)                            KEYED
 +
    D KE              S            10    DIM(128)                            KEY FLDS
 +
    D R              S              3  0 DIM(9000)                            KEY FLD START
 +
    D K              S              1    DIM(800)                            KEY
 +
    D NA              S              1    DIM(10)                              NAME WORK
 +
    D NU              S              1    DIM(60)                              NUM. WORK
 +
    D LV              S            10    DIM(50)                              SCREEN LEVELS
 +
    D MSG            S            32    DIM(8) CTDATA PERRCD(1)              MESSAGES
 +
    D CNS            S            79    DIM(2) CTDATA PERRCD(1)
 +
    D CRS            S              1    DIM(16) CTDATA PERRCD(16)
 +
 +
    D                DS
 +
    D  DATA                  1  2048
 +
    D  D                      1  2048
 +
    D                                    DIM(2048)                            INCOMING DATA
 +
    D  DA                    1    16
 +
    D  DB                    17    32
 +
    D  DC                    33    64
 +
    D  DD                    65    96
 +
    D  DE                    97    128
 +
    D  DF                  129    160
 +
    D  DG                  161    192
 +
    D  DH                  193    224
 +
    D  DI                  225    256
 +
    D  DJ                  257    288
 +
    D  DK                  289    320
 +
    D  DL                  321    352
 +
    D  DM                  353    384
 +
    D  DN                  385    416
 +
    D  DZ                  417    448
 +
    D  DO                  449    480
 +
    D  DP                  481    512
 +
    D  DQ                  513    544
 +
    D  DR                  545    576
 +
    D  DS                  577    608
 +
    D  DT                  609    640
 +
    D  DU                  641    672
 +
    D  DV                  673    704
 +
    D  DW                  705    736
 +
    D  DX                  737    768
 +
    D  DY                  769    800
 +
    D  D0                  801    832
 +
    D  D1                  833    864
 +
    D  D2                  865    896
 +
    D  D3                  897    928
 +
    D  D4                  929    960
 +
    D  D5                  961    992
 +
    D  D6                  993  1024
 +
    D  DBA                1025  1056
 +
    D  DCA                1057  1088
 +
    D  DDA                1089  1120
 +
    D  DEA                1121  1152
 +
    D  DFA                1153  1184
 +
    D  DGA                1185  1216
 +
    D  DHA                1217  1248
 +
    D  DIA                1249  1280
 +
    D  DJA                1281  1312
 +
    D  DKA                1313  1344
 +
    D  DLA                1345  1376
 +
    D  DMA                1377  1408
 +
    D  DNA                1409  1440
 +
    D  DOA                1441  1472
 +
    D  DPA                1473  1504
 +
    D  DQA                1505  1536
 +
    D  DRA                1537  1568
 +
    D  DSA                1569  1600
 +
    D  DTA                1601  1632
 +
    D  DUA                1633  1664
 +
    D  DVA                1665  1696
 +
    D  DWA                1697  1728
 +
    D  DXA                1729  1760
 +
    D  DYA                1761  1792
 +
    D  DZA                1793  1824
 +
    D  D0A                1825  1856
 +
    D  D1A                1857  1888
 +
    D  D2A                1889  1920
 +
    D  D3A                1921  1952
 +
    D  D4A                1953  1984
 +
    D  D5A                1985  2016
 +
    D  D6A                2017  2048
 +
    D                DS
 +
    D  ID                    1    800
 +
    D                                    DIM(800)                            INCOMING DATA
 +
    D  IDA                    1    800
 +
    D  ID0                    1    80
 +
    D  ID1                  81    160
 +
    D  ID2                  161    240
 +
    D  ID3                  241    320
 +
    D  ID4                  321    400
 +
    D  ID5                  401    480
 +
    D  ID6                  481    560
 +
    D  ID7                  561    640
 +
    D  ID8                  641    720
 +
    D  ID9                  721    800
 +
    D                DS
 +
    D  BIN                    1      2B 0
 +
    D  HX1                    2      2
 +
    D  HX2                    1      2
 +
    D                DS
 +
    D  PCK                    1      1P 0
 +
    D  PCK1                  1      1
 +
    D                DS
 +
    D  SGN                    1      1S 0
 +
    D  SGN1                  1      1
 +
 +
    D                DS
 +
    D  BIN4                  1      4B 0
 +
    D  BY4                    1      4
 +
 +
    D                DS
 +
    D  BIN2                  1      2B 0
 +
    D  BY2                    1      2
 +
 +
    D                DS
 +
    D  FLT4                  1      4F
 +
    D  FL4                    1      4
 +
 +
    D                DS
 +
    D  FLT8                  1      8F
 +
    D  FL8                    1      8
 +
 +
    D INFDK          DS
 +
    D  F1                    83    92
 +
    D  L1                    93    102
 +
    D  M1                  129    138
 +
    D  R1                  125    126B 0
 +
    D  A1                  160    160
 +
    D  LOP1                260    260
 +
    D  KEY_LEN              393    394I 0                                      Key length
 +
    D  RN1                  397    400B 0
 +
    D  LKY                  401  1200
 +
    D INFDR          DS
 +
    D  F2                    83    92
 +
    D  L2                    93    102
 +
    D  M2                  129    138
 +
    D  R2                  125    126B 0
 +
    D  A2                  160    160
 +
    D  LOP2                260    260
 +
    D  RN2                  397    400B 0
 +
    D*
 +
    D INFDS          DS
 +
    D  CURLOC              370    371
 +
    D                DS
 +
    D KEYLN                  1      4S 0
 +
    D KEYLNA                  1      4
 +
 +
    DDUSP            PR
 +
    D                                1
 +
    D                                1
 +
    D                                4
 +
    D                                1
 +
    D                              500
 +
    D                                5
 +
    D                              800
 +
    DDUSP            PI
 +
    D  ALL                          1
 +
    D  RTN                          1
 +
    D  KEYLNG                      4
 +
    D  UPDF                        1
 +
    D  SCNLV                      500
 +
    D  SCNLVL                      5
 +
    D  SCNKEY                    800
 +
 +
 +
    D @LOOP          C                  '1'
 +
    D @FALSE          C                  '0'
 +
    D @TRUE          C                  '1'
 +
 +
    D SND            C                  X'71'                                SEND TO DISP
 +
    D SNR            C                  X'73'                                SND/RCV
 +
    D RED            C                  X'42'                                READ
 +
    D RDM            C                  X'52'                                READ MTD
 +
    D ESC            C                  X'04'                                ESCAPE
 +
    D CLR            C                  X'40'                                CLEAR UNIT
 +
    D CC1            C                  X'00'                                CNTRL CHAR
 +
    D CC2            C                  X'08'                                CNTRL CHAR
 +
    D SBA            C                  X'11'                                SET BUFF ADR
 +
    D IC              C                  X'13'                                INSERT CURS
 +
    D WTD            C                  X'11'                                WRITE TO DSP
 +
    D WER            C                  X'21'                                WRITE ERROR
 +
    D SF              C                  X'1D'                                START FLD
 +
    D ATC            C                  X'20'                                ATTR CHAR
 +
    D ATN            C                  X'24'                                ATTR NUM
 +
    D X00            C                  X'00'
 +
    D X01            C                  X'01'
 +
    D X02            C                  X'02'
 +
    D X03            C                  X'03'
 +
    D X0D            C                  X'0D'
 +
    D X0F            C                  X'0F'
 +
    D X000            C                  X'0000'
 +
    D X1F            C                  X'1F'
 +
    D X20            C                  X'20'                                SCRN ATT NORMAL
 +
    D X22            C                  X'22'                                SCRN ATTR HI
 +
    D X25            C                  X'25'
 +
    D X26            C                  X'26'
 +
    D X31            C                  X'31'                                CMD 1 KEY
 +
    D X32            C                  X'32'                                CMD 2 KEY
 +
    D X33            C                  X'33'                                CMD 3 KEY
 +
    D X36            C                  X'36'                                CMD 6 KEY
 +
    D X37            C                  X'37'                                CMD 7 KEY
 +
    D X38            C                  X'38'                                CMD 8 KEY
 +
    D X39            C                  X'39'                                CMD 9 KEY
 +
    D X3B            C                  X'3B'                                CMD11 KEY
 +
    D XB7            C                  X'B7'                                CMD19 KEY
 +
    D XB8            C                  X'B8'                                CMD20 KEY
 +
    D X40            C                  X'40'
 +
    D X43            C                  X'43'
 +
    D X47            C                  X'47'
 +
    D X60            C                  X'60'
 +
    D X67            C                  X'67'
 +
    D X9F            C                  X'9F'
 +
    D XF0            C                  X'F0'
 +
    D XD0            C                  X'D0'
 +
    D X4000          C                  X'4000'
 +
    D X4800          C                  X'4800'                              FF ALPHA
 +
    D X4F06          C                  X'4F06'                              FF NUMERIC
 +
    D X6000          C                  X'6000'                              FF ALPHA
 +
    D X6706          C                  X'6706'                              FF NUMERIC
 +
    D CLRWTD          C                  X'044004112000'                      INCLUDES ESC CHARS
 +
    D RDDSP          C                  X'0411200804524000'                  REAB FROM DISPLAY
 +
    D FFA1            S              1    INZ(X'40')                          F.FMT 1 ALPH  60 BYP
 +
    D FFA2            S              1    INZ(X'00')                          F.FMT 2 ALPH
 +
    D FFN1            S              1    INZ(X'47')                          F.FMT 1 NUM  67 BYP
 +
    D FFN2            S              1    INZ(X'06')                          F.FMT 2 NUM
 +
    I*.
 +
    IINPUTK    NS  01
 +
    I                                  1  16  DA
 +
    I                                17  32  DB                30
 +
    I                                33  64  DC                31
 +
    I                                65  96  DD                32
 +
    I                                97  128  DE                33
 +
    I                                129  160  DF                34
 +
    I                                161  192  DG                35
 +
    I                                193  224  DH                36
 +
    I                                225  256  DI                37
 +
    I                                257  288  DJ                38
 +
    I                                289  320  DK                39
 +
    I                                321  352  DL                40
 +
    I                                353  384  DM                41
 +
    I                                385  416  DN                42
 +
    I                                417  448  DZ                43
 +
    I                                449  480  DO                44
 +
    I                                481  512  DP                45
 +
    I                                513  544  DQ                46
 +
    I                                545  576  DR                47
 +
    I                                577  608  DS                48
 +
    I                                609  640  DT                49
 +
    I                                641  672  DU                50
 +
    I                                673  704  DV                51
 +
    I                                705  736  DW                52
 +
    I                                737  768  DX                53
 +
    I                                769  800  DY                54
 +
    I                                801  832  D0                55
 +
    I                                833  864  D1                56
 +
    I                                865  896  D2                57
 +
    I                                897  928  D3                58
 +
    I                                929  960  D4                59
 +
    I                                961  992  D5                60
 +
    I                                993 1024  D6                61
 +
    I                              1025 1056  DBA              62
 +
    I                              1057 1088  DCA              63
 +
    I                              1089 1120  DDA              64
 +
    I                              1121 1152  DEA              65
 +
    I                              1153 1184  DFA              66
 +
    I                              1185 1216  DGA              67
 +
    I                              1217 1248  DHA              68
 +
    I                              1249 1280  DIA              69
 +
    I                              1281 1312  DJA              70
 +
    I                              1313 1344  DKA              71
 +
    I                              1345 1376  DLA              72
 +
    I                              1377 1408  DMA              73
 +
    I                              1409 1440  DNA              74
 +
    I                              1441 1472  DOA              75
 +
    I                              1473 1504  DPA              76
 +
    I                              1505 1536  DQA              77
 +
    I                              1537 1568  DRA              78
 +
    I                              1569 1600  DSA              79
 +
    I                              1601 1632  DTA              80
 +
    I                              1633 1664  DUA              81
 +
    I                              1665 1696  DVA              82
 +
    I                              1697 1728  DWA              83
 +
    I                              1729 1760  DXA              84
 +
    I                              1761 1792  DYA              85
 +
    I                              1793 1824  DZA              86
 +
    I                              1825 1856  D0A              87
 +
    I                              1857 1888  D1A              88
 +
    I                              1889 1920  D2A              89
 +
    I                              1921 1952  D3A              90
 +
    I                              1953 1984  D4A              91
 +
    I                              1985 2016  D5A              92
 +
    I                              2017 2048  D6A              93
 +
    IINPUTR    NS  01
 +
    I                                  1  16  DA
 +
    I                                17  32  DB                30
 +
    I                                33  64  DC                31
 +
    I                                65  96  DD                32
 +
    I                                97  128  DE                33
 +
    I                                129  160  DF                34
 +
    I                                161  192  DG                35
 +
    I                                193  224  DH                36
 +
    I                                225  256  DI                37
 +
    I                                257  288  DJ                38
 +
    I                                289  320  DK                39
 +
    I                                321  352  DL                40
 +
    I                                353  384  DM                41
 +
    I                                385  416  DN                42
 +
    I                                417  448  DZ                43
 +
    I                                449  480  DO                44
 +
    I                                481  512  DP                45
 +
    I                                513  544  DQ                46
 +
    I                                545  576  DR                47
 +
    I                                577  608  DS                48
 +
    I                                609  640  DT                49
 +
    I                                641  672  DU                50
 +
    I                                673  704  DV                51
 +
    I                                705  736  DW                52
 +
    I                                737  768  DX                53
 +
    I                                769  800  DY                54
 +
    I                                801  832  D0                55
 +
    I                                833  864  D1                56
 +
    I                                865  896  D2                57
 +
    I                                897  928  D3                58
 +
    I                                929  960  D4                59
 +
    I                                961  992  D5                60
 +
    I                                993 1024  D6                61
 +
    I                              1025 1056  DBA              62
 +
    I                              1057 1088  DCA              63
 +
    I                              1089 1120  DDA              64
 +
    I                              1121 1152  DEA              65
 +
    I                              1153 1184  DFA              66
 +
    I                              1185 1216  DGA              67
 +
    I                              1217 1248  DHA              68
 +
    I                              1249 1280  DIA              69
 +
    I                              1281 1312  DJA              70
 +
    I                              1313 1344  DKA              71
 +
    I                              1345 1376  DLA              72
 +
    I                              1377 1408  DMA              73
 +
    I                              1409 1440  DNA              74
 +
    I                              1441 1472  DOA              75
 +
    I                              1473 1504  DPA              76
 +
    I                              1505 1536  DQA              77
 +
    I                              1537 1568  DRA              78
 +
    I                              1569 1600  DSA              79
 +
    I                              1601 1632  DTA              80
 +
    I                              1633 1664  DUA              81
 +
    I                              1665 1696  DVA              82
 +
    I                              1697 1728  DWA              83
 +
    I                              1729 1760  DXA              84
 +
    I                              1761 1792  DYA              85
 +
    I                              1793 1824  DZA              86
 +
    I                              1825 1856  D0A              87
 +
    I                              1857 1888  D1A              88
 +
    I                              1889 1920  D2A              89
 +
    I                              1921 1952  D3A              90
 +
    I                              1953 1984  D4A              91
 +
    I                              1985 2016  D5A              92
 +
    I                              2017 2048  D6A              93
 +
    IDISPF    NS  02
 +
    I                                  3    3  AID
 +
    I                                  4  83  ID0
 +
    I                                84  163  ID1              20
 +
    I                                164  243  ID2              21
 +
    I                                244  323  ID3              22
 +
    I                                324  403  ID4              23
 +
    I                                404  483  ID5              24
 +
    I                                484  563  ID6              25
 +
    I                                564  643  ID7              26
 +
    I                                644  723  ID8              27
 +
    I                                724  803  ID9              28
 +
DCL V
 +
 +
      /FREE
 +
            BASE = 0;
 +
 +
            IF  ONCE  =  ' ';
 +
                EXSR      @INITZ  ;
 +
            ENDIF;
 +
 +
        //  START        TAG
 +
          DOW      @LOOP = @LOOP;
 +
 +
          IF  RTN  = '3';
 +
 +
              IF *INU1;
 +
                KEYA =  SCNKEY;
 +
              ENDIF;
 +
              IF *INU2;
 +
                RRNA =  %DEC(%SUBST(SCNKEY:1:11):11:0);
 +
              ENDIF;
 +
                RTN = '0';
 +
                AID = '1';
 +
            ELSE;
 +
              RTN  = '0';
 +
              READ(E)  DISPF;
 +
          ENDIF;
 +
 +
        //  CF3 EXIT
 +
          IF  AID  = X33;
 +
            LEAVE;
 +
          ENDIF;
 +
 +
        //  CF2 RETURN
 +
          IF  AID  = X32;
 +
            RTN = '1';
 +
            LEAVE;
 +
          ENDIF;
 +
 +
        // CF1 HEX A FIELD
 +
          IF  AID  = X31;
 +
          Y = %LOOKUPLE( CURLOC : B );
 +
          IF Y > 0;
 +
            IF KY(Y) <= '1';
 +
              EXSR      @HXDSP;
 +
              REHEAD  = '1';
 +
              EXSR      @PUTHED;
 +
              REHEAD  = ' ';
 +
            ENDIF;
 +
            ENDIF;
 +
          ENDIF;
 +
 +
        //  CF20 MORE FIELDS
 +
          IF  AID  = XB8;
 +
 +
            LVX  = LVL + 1;
 +
            IF  LV(LVX)  <> *BLANK;
 +
              LVL = LVL +1 ;
 +
 +
              LVW  = LV;
 +
              SCNLV = TEXT500;
 +
              SCNLVL = %EDITC(LVL :'X');
 +
 +
            SCNKEY = *BLANKS;
 +
          IF  *INU1;
 +
                SCNKEY = KEYA;
 +
          ENDIF;
 +
          IF  *INU2;
 +
                SCNKEY = %EDITC(RRNA:'X');
 +
          ENDIF;
 +
 +
              RTN = '3';
 +
              LEAVE;
 +
            ENDIF;
 +
          ENDIF;
 +
 +
      //  CF19 PREVIOUS FIELDS
 +
          IF  AID  = XB7;
 +
 +
            LVX  = LVL - 1;
 +
            IF  LVX    >= 0 ;
 +
              LVL = LVL - 1 ;
 +
 +
              LVW  = LV;
 +
              SCNLV = TEXT500;
 +
              SCNLVL = %EDITC(LVL :'X');
 +
 +
                SCNKEY = *BLANKS;
 +
          IF  *INU1;
 +
                SCNKEY = KEYA;
 +
          ENDIF;
 +
          IF  *INU2;
 +
                SCNKEY = %EDITC(RRNA:'X');
 +
          ENDIF;
 +
 +
              RTN = '3';
 +
              LEAVE;
 +
            ENDIF;
 +
          ENDIF;
 +
 +
          // 1 ENTER  4 ROLL DN  5 ROLL UP
 +
          // F6 = X36  F9 = X39  F11 = X3B
 +
          IF  AID  = '1'or AID = '4' or AID = '5' or
 +
              AID  = X36 or AID = X39 or AID = X3B;
 +
          ELSE;
 +
            MX = 1;        // INVALID KEY
 +
            EXSR  @ERROR;
 +
          ENDIF;
 +
 +
          //      UPDATE MODE
 +
          IF  UPDF    = 'Y';
 +
            UPDDONE = @FALSE;
 +
          // F6
 +
            IF *INU1 AND AID = X36 AND
 +
            (LOP1 = X01 OR LOP1 = X03);
 +
              EXSR @UPD;
 +
              EXCEPT UPDATREC;
 +
              UPDDONE = @TRUE;
 +
            ENDIF;
 +
 +
            IF *INU2 AND AID = X36 AND
 +
            (LOP2 = X01 OR LOP2 = X02);
 +
              EXSR @UPD;
 +
              EXCEPT UPDATREC;
 +
              UPDDONE = @TRUE;
 +
            ENDIF;
 +
 +
          // F9
 +
            IF AID = X39;
 +
              EXSR  @UPD;
 +
              EXCEPT ADDREC;
 +
              UPDDONE = @TRUE;
 +
            ENDIF;
 +
 +
          // F11
 +
            IF *INU1 AND AID = X3B AND
 +
            (LOP1 = X01 OR LOP1 = X03);
 +
              EXCEPT DELREC;
 +
              UPDDONE = @TRUE;
 +
              ENDIF;
 +
 +
            IF *INU2 AND AID = X3B AND
 +
            (LOP2 = X01 OR LOP2 = X02);
 +
              EXCEPT DELREC;
 +
              UPDDONE = @TRUE;
 +
              ENDIF;
 +
 +
            ENDIF;
 +
 +
 +
          IF  RTN = '3' OR UPDDONE = @TRUE;
 +
          ELSE;
 +
            EXSR      @PCKD;
 +
          ENDIF;
 +
 +
 +
        // CONT1  GET A RECORD, KEY FROM DATA
 +
            EXSR      @SETIN;
 +
            EXSR      @GETF ;
 +
            EXSR      @PUTF ;
 +
            EXSR      @KEYIN;
 +
 +
          ENDDO ;
 +
 +
          *INLR = *ON;
 +
 +
      //  @@@@@@@  @INITZ @@@@@@@@@@@@@@@@@@@@@@@@@@
 +
        BEGSR  @INITZ;
 +
                ONCE  =  '1';
 +
                KEYLNA = KEYLNG  ;
 +
                EXSR      @INIT  ;
 +
                EXSR      @GETFLD ;
 +
                EXSR      @GETADD ;
 +
                EXSR      @PUTHED ;
 +
                EXSR      @KEYIN  ;
 +
                INZ  = '1';
 +
                EXSR      @PCKD  ;
 +
                INZ  = ' ';
 +
        ENDSR;
 +
 +
      //  @@@@@@@  @PCKD  @@@@@@@@@@@@@@@@@@@@@@@@@@
 +
 +
          BEGSR  @PCKD ;
 +
 +
            //  CONVERT  KEY DATA
 +
            IF  *INU1 ;
 +
              EXSR  @CVTKEY;
 +
            ENDIF;
 +
            IF  *INU2 ;
 +
              EXSR  @CVTRRN;
 +
            ENDIF;
 +
 +
          ENDSR;
 +
 +
      //  @@@@@@@  @CVTKEY  @@@@@@@@@@@@@@@@@@@@@@@@
 +
 +
          BEGSR  @CVTKEY;
 +
 +
      // EXTRACT THE KEY FIELD DATA FROM THE INCOMING STRING
 +
 +
        // FOR EACH KEY FIELD, CHECK IF FIELD WAS MODIFIED, AND IF SO MOVE
 +
        // THE MODIFIED DATA INTO THE COMPOSITE KEY
 +
 +
        K1 = 0;
 +
        K2 = 0;
 +
        W  = 1;
 +
 +
          FOR  Y  = 1  TO NUMKEY ;
 +
 +
      //  MOVE A KEY FIELDS DATA FROM ID ARRAY (SCREEN) TO K ARRAY (KEY FIELDS)
 +
 +
            //  GET SIZE OF FIELD IN BYTES
 +
        SELECT;
 +
          WHEN  T(Y)  =  'A';  // ALPHA DATA
 +
          K = ' ';
 +
          K1 = 1;
 +
          K2 = Q(Y);
 +
          WHEN  T(Y)  =  'F';  // FLOAT
 +
          K  = '0';
 +
          K1 =  1;
 +
          K2 = L(Y);
 +
          OTHER;
 +
          K  = '0';
 +
          K1 =  1;
 +
          K2 = C(Y);
 +
        ENDSL;
 +
 +
 +
      // IF WHOLE KEY INIT WAS REQUESTED BYPASS THE EXTRACT
 +
          IF  INZ  = '1' ;
 +
            KW  = *BLANK;
 +
            EXSR      @PCKMOV;
 +
            ITER;
 +
          ENDIF;
 +
 +
          X  =  1;
 +
 +
          DOW  @LOOP = @LOOP;
 +
 +
      //  NXTSBA
 +
          X  = %LOOKUP(SBA : ID : X );
 +
          IF X = 0;
 +
            LEAVE;
 +
          ENDIF;
 +
 +
      // IS THIS THE FIELD?  CHECK THE BUFFER ADDRESS
 +
        X = X +1;
 +
        IF  B(Y)  <>  %SUBST(IDA : X :2);
 +
          ITER;
 +
        ENDIF;
 +
 +
      //  FOUND A MTD FOR THIS FIELD
 +
        X =  X + 2;
 +
 +
      //  CHECK IF FIELD WAS CLEARED ONLY
 +
        IF  ID(X) = SBA;
 +
            EXSR      @PCKMOV;
 +
            LEAVE ;
 +
        ENDIF;
 +
 +
      //  IF FIELD HAS DECIMALS BUMP X
 +
          IF (T(Y) = 'S' OR T(Y) = 'P' OR T(Y) = 'B') AND
 +
              P(Y) > 0;
 +
              X = X + 1;
 +
          ENDIF;
 +
 +
      //  CHECK IF ONLY BLANKS RETURNED
 +
        IF    %SUBST(IDA : X :K2) = *BLANKS;
 +
            EXSR      @PCKMOV;
 +
            LEAVE;
 +
        ENDIF;
 +
 +
      // EXTRACT THE DATA FROM THE INCOMING STRING
 +
        X1  = X;
 +
        FOR X2  =  1 TO  K2 ;
 +
 +
          IF ID(X1) < ' ';
 +
      // TRAP NULLS CAUSED BY FLD EXIT
 +
            EXSR      @PCKMOV;
 +
            LEAVE;
 +
          ENDIF;
 +
 +
        K(X2)  =  ID(X1);
 +
        X1    =  X1 +1;
 +
        ENDFOR;
 +
 +
        // CONSTRUCT THE ACTUAL KEY WITH PACKED DATA IF REQUIRED
 +
        // INTO ARRAY KW
 +
          EXSR      @PCKMOV;
 +
          LEAVE;
 +
        ENDDO;
 +
 +
        ENDFOR;
 +
 +
        //
 +
          KEYA  = KW;
 +
          CLEAR KW;
 +
        ENDSR ;
 +
 +
      //  @@@@@@@  @CVTRRN  @@@@@@@@@@@@@@@@@@@@@@@@
 +
 +
          BEGSR  @CVTRRN;
 +
 +
        //  RRN
 +
 +
          NUM11 = 0;
 +
 +
          DOW  @LOOP = @LOOP;  //  NOT REALLY A LOOP(SIMULATES GOTO)
 +
 +
      // GET THE FIRST SBA
 +
          X = 1;
 +
          X  = %LOOKUP(SBA : ID : X );
 +
          IF X = 0;
 +
          LEAVE;
 +
          ENDIF;
 +
 +
      // CHECK THE BUFFER ADDRESS MATCHES THE EXPECTED FIELD
 +
        X = X +1;
 +
        IF  B(1)  <>  %SUBST(IDA : X :2);
 +
          ITER;
 +
        ENDIF;
 +
 +
      //  FOUND A MTD FOR RRN  FIELD
 +
        X = X +2;
 +
 +
      //CHECK IF FIELD WAS CLEARED ONLY
 +
        IF  ID(X) = SBA;
 +
            LEAVE;
 +
        ENDIF;
 +
 +
      //  CHECK IF ONLY BLANKS RETURNED
 +
        IF    %SUBST(IDA : X :11) = *BLANKS;
 +
            LEAVE;
 +
        ENDIF;
 +
 +
 +
        //  WRK11  OVERLAYS NUM11
 +
        WRK11 = %SUBST(IDA : X :11);
 +
 +
        LEAVE;
 +
        ENDDO;
 +
 +
 +
        RRNA = NUM11;
 +
        IF RRNA < 0;
 +
        RRNA =  1;
 +
        ENDIF;
 +
 +
        ENDSR;
 +
 +
      //  @@@@@@@  @PCKMOV  @@@@@@@@@@@@@@@@@@@@@@@@
 +
 +
        BEGSR  @PCKMOV;
 +
      //
 +
      //  CONVERT  KEY DATA
 +
      //  SET START POSN IN KEY USING OFFSET IN R
 +
          X1 = %LOOKUP(N(Y) : N );
 +
          W = R(X1) + 1;
 +
 +
        // ALPHA
 +
          IF  T(Y) = 'A';
 +
          X1  = 1;
 +
          FOR  Z = W  TO W + Q(Y);
 +
            %SUBST(KW : Z : 1) =  K(X1);
 +
            X1 = X1 + 1;
 +
          ENDFOR;
 +
          ENDIF;
 +
 +
        // NUMERIC FIELD
 +
        // RIGHT  ADJUST NUMERIC DATA ,STRIP - . ,CONVERT BLANKS
 +
          IF (T(Y) = 'S' OR T(Y) = 'P' OR T(Y) = 'B');
 +
          NU = '0';
 +
 +
          Z1 = 60;
 +
          FOR Z  =  K2  DOWNTO K1;
 +
 +
          IF K(Z) = '.' OR K(Z) = '-' OR K(Z) = '$';
 +
          ITER;
 +
          ENDIF;
 +
 +
          IF K(Z) = ' ' ;
 +
          NU(Z1) = '0';
 +
          ELSE;
 +
          NU(Z1) = K(Z);
 +
          ENDIF;
 +
 +
            Z1 = Z1 -1;
 +
          ENDFOR;
 +
 +
          ENDIF;
 +
 +
      // SIGNED FIELDS  (END POSN = OFFSET + SIZE)
 +
        IF T(Y)  = 'S';
 +
          NUS = 0;
 +
          FOR VX = 1 TO 60;
 +
            NUSA = %TRIM(NUSA) + NU(VX);
 +
          ENDFOR;
 +
        %SUBST(KW : W : Q(Y)) = %SUBST(NUSA: 61 -Q(Y));
 +
 +
        ENDIF;
 +
 +
      //  PACKED FIELDS
 +
          IF    T(Y)  =  'P';
 +
          NUSA= *BLANKS;
 +
          FOR VX = 1 TO 60;
 +
            NUSA = %TRIM(NUSA) + NU(VX);
 +
          ENDFOR;
 +
          NUP    = %DEC(NUSA : 60 : 0);
 +
 +
        %SUBST(KW : W : Q(Y))  =  %SUBST(NUPA: 61 -Q(Y));
 +
 +
        ENDIF;
 +
 +
      //  BINARY FIELDS
 +
        IF  T(Y) =  'B';
 +
 +
        IF  Q(Y) = 2 ;
 +
          BY2  = NU(1) + NU(2);
 +
          %SUBST(KW : W : 2)  =  BY2;
 +
        ENDIF;
 +
 +
        IF  Q(Y) = 4 ;
 +
          BY4  = NU(1) + NU(2) + NU(3) + NU(4);
 +
          %SUBST(KW : W : 4)  =  BY4;
 +
        ENDIF;
 +
 +
        ENDIF;
 +
 +
      ENDSR;
 +
 +
 +
      //  @@@@@@@  SETIN  @@@@@@@@@@@@@@@@@@@@@@@@@
 +
          BEGSR      @SETIN;
 +
 +
        //  SET the FFR indicators to get the Input buffer somewhat aligned with the
 +
        //  actual data.  RPG is somewhat tolerant to a difference between the Ispecs
 +
        //  and the actual file size but it can fail on big differences.
 +
        //  INCREMENT OF 32 BYTES
 +
          SZ(1)  = BASE + 16;
 +
          SZ(2)  = SZ(1) + 16;
 +
 +
          *IN30 = *ON;
 +
            IF (RLEN > SZ(2)) ;
 +
            *IN31  = *ON;
 +
            ENDIF;
 +
 +
          FOR X = 3 TO 64;
 +
          SZ(X) = SZ(X-1) + 32;
 +
            IF (RLEN > SZ(X)) ;
 +
            *IN(29+X) = *ON;
 +
            ENDIF;
 +
          ENDFOR;
 +
        ENDSR;
 +
 +
 +
        //@@@@@@@@@@@@@@@@@  @GETF  @@@@@@@@@@@@@@@@@
 +
          BEGSR  @GETF;
 +
      //  GET A DATA RECORD
 +
          IF  (*INU1);
 +
          IF  AID  = '1' OR AID  = X36 OR
 +
              AID  = X39 OR AID  = X3B ;
 +
            SETLL(E) KEYA  INPUTK;
 +
            READ(E)      INPUTK;
 +
              IF %EOF;
 +
              SETLL(E) KEYA  INPUTK;
 +
              READP(E)      INPUTK;
 +
              ENDIF;
 +
          ENDIF;
 +
 +
          IF  AID  = '4';
 +
            READP(E)  INPUTK;
 +
          ENDIF;
 +
 +
          IF  AID  = '5';
 +
            READ(E)  INPUTK;
 +
          ENDIF;
 +
 +
            IF  %ERROR;
 +
            SETLL(E) KEYA  INPUTK;
 +
            READ(E)      INPUTK;
 +
            MX = 7;
 +
                        EXSR      @ERROR;
 +
                        EXSR      @PUTF ;
 +
                        EXSR      @KEYIN;
 +
            ENDIF;
 +
 +
            KEYA = LKY;
 +
 +
 +
            CLEAR KW;
 +
            KW  = LKY;
 +
 +
          ENDIF;
 +
 +
          IF  (*INU2);
 +
          IF  AID  = '1';
 +
            CHAIN(E)  RRNA  INPUTR;
 +
            IF  %ERROR;
 +
              SETLL(E) RRNA  INPUTR;
 +
              READP(E)      INPUTR;
 +
            ENDIF;
 +
          ENDIF;
 +
 +
          IF  AID  = X36;
 +
            CHAIN(E)  RRNA  INPUTR;
 +
          ENDIF;
 +
 +
          IF  AID  = '4';
 +
            READP(E)  INPUTR;
 +
          ENDIF;
 +
 +
          IF  AID  = '5' OR AID = X3B;
 +
            READ(E)  INPUTR;
 +
          ENDIF;
 +
 +
          IF  AID  = X39;
 +
            SETLL(E) *HIVAL INPUTR;
 +
            READP(E)  INPUTR;
 +
          ENDIF;
 +
 +
          IF %ERROR;
 +
            CHAIN  1  INPUTR;
 +
            MX = 7;
 +
            EXSR      @ERROR;
 +
            EXSR      @PUTF ;
 +
            EXSR      @KEYIN;
 +
          ENDIF;
 +
          ENDIF;
 +
 +
          ENDSR;
 +
 +
 +
        //@@@@@@@@@@@@@@@@@  @PUTF  @@@@@@@@@@@@@@@@@
 +
          BEGSR  @PUTF;
 +
 +
              SELECT;
 +
                WHEN  *INU1;
 +
                RRN = RN1;
 +
                WHEN  *INU2;
 +
                RRN = RN2;
 +
              ENDSL;
 +
        // IF GOT RECORDS WRITE DATA TO THE DISPLAY
 +
 +
            NEWRU  = '1';
 +
            WRTRRN = '1';
 +
            RU    = *ALLX'00';
 +
            CLEAR  RU;        //  initialise Request Unit  255 bytes max
 +
 +
          IF RRN > 0    ;
 +
            FOR  XX = 1 TO      NUMFKY; //NUMBER OF DATA ELEMENTS (FLD AND KEY)
 +
 +
            IF NEWRU = '1';
 +
              NEWRU  = '0';
 +
              RU  = ESC + WTD + X20 + X00;
 +
            ENDIF;
 +
 +
            IF WRTRRN = '1';
 +
              WRTRRN = '0';
 +
              RU  = RU + SBA + RBA ;
 +
              RU = RU + %TRIM(%EDITC(RRN:'Z'));
 +
            ENDIF;
 +
 +
        // BUFFER ADDRESS
 +
            RU  = RU + SBA + B(XX);
 +
 +
        //  PROCESS ALPHA DATA TYPE
 +
            IF  T(XX) = 'A'  OR T(XX) = 'T'  OR T(XX) = 'Z' OR
 +
                T(XX) = 'L';
 +
 +
              STRX = S(XX);
 +
              ENDX = E(XX);
 +
 +
              IF V(XX) = 'Y';  //VARYING
 +
              VX  = S(XX);
 +
              HX2  = D(VX) + D(VX+1);
 +
              STRX  = S(XX) + 2 ;
 +
              ENDX  = S(XX) + BIN;
 +
              ENDIF;
 +
 +
              FOR Y = STRX  TO ENDX ;
 +
                IF D(Y) >= ' ';
 +
                RU = RU + D(Y);
 +
                ELSE;
 +
                RU = RU + X1F ;  //IF NOT DISPLAYABLE REPLACE WITH X'1F'
 +
                ENDIF;
 +
              ENDFOR;
 +
            ENDIF;
 +
 +
        //  PROCESS SIGNED DATA TYPE (not the RRN field)
 +
            IF  T(XX) = 'S' and KY(XX) <> '3';
 +
              NUSA =  *ALL'0';
 +
              WRV  =  *ALLX'00';
 +
              CLEAR WRV;
 +
              FOR Y = S(XX) TO E(XX);
 +
                IF D(Y) >= XD0;
 +
                WRV    =  WRV + D(Y);
 +
                ENDIF;
 +
              ENDFOR;
 +
              EVAL  NUSA = %SUBST(NUSA : 1 : 60 - %LEN(WRV)) + WRV;
 +
              CLEAR WRU;
 +
              WRU = %TRIM(WRU) + %EDITW(NUS :WRSWRD);
 +
              IF  P(XX) > 0;
 +
                RU  = RU  +
 +
                    %SUBST(WRU :61-C(XX): C(XX)-P(XX)) + '.' +
 +
                    %SUBST(WRU :61-P(XX))    ;
 +
              ELSE;
 +
                RU  = RU  +
 +
                    %SUBST(WRU :61-C(XX));
 +
              ENDIF;
 +
            ENDIF;
 +
 +
 +
        //  PROCESS SIGNED DATA TYPE (the RRN field)
 +
            IF  T(XX) = 'S' and KY(XX) =  '3';
 +
              RRN = RN2;
 +
              RU = RU + %TRIM(%EDITC(RRN:'X'));
 +
            ENDIF;
 +
 +
        //  PROCESS PACKED DATA TYPE
 +
            IF  T(XX) = 'P';
 +
              NUPA =  *ALLX'00';
 +
              WRV  =  *ALLX'00';
 +
              CLEAR WRV;
 +
              FOR Y = S(XX) TO E(XX);
 +
                WRV    =  WRV + D(Y);
 +
              ENDFOR;
 +
 +
              IF  %BITAND(D(E(XX)) :X0F) = X0F OR
 +
                    %BITAND(D(E(XX)) :X0D) = X0D;
 +
 +
                EVAL  NUPA = %SUBST(NUPA : 1 : 60 - %LEN(WRV)) + WRV;
 +
                CLEAR WRX;
 +
                WRX = %TRIM(WRX) + %EDITW(NUP :WRXWRD);
 +
                IF  P(XX) > 0;
 +
                RU  = RU  +
 +
                      %SUBST(WRX :64-C(XX): C(XX)-P(XX)) + '.' +
 +
                      %SUBST(WRX :64-P(XX))    ;
 +
                ELSE;
 +
                RU  = RU  +
 +
                      %SUBST(WRX :64-C(XX));
 +
                ENDIF;
 +
              ELSE;
 +
                // PACKED FIELD IN ERROR
 +
                RU = RU + X1F;
 +
              ENDIF;
 +
 +
            ENDIF;
 +
 +
        //  PROCESS BINARY DATA TYPE
 +
            IF  T(XX) = 'B';
 +
 +
            ST = S(XX);
 +
              CLEAR NUSA;
 +
              IF  Q(XX) = 2;
 +
              BY2  = D(ST) + D(ST+1);
 +
              NUS  = BIN2;
 +
              ENDIF;
 +
              IF  Q(XX) = 4;
 +
              BY4  = D(ST) + D(ST+1)+ D(ST+2) + D(ST+3);
 +
              NUS  = BIN4;
 +
              ENDIF;
 +
 +
              WRU =  %EDITW(NUS :WRSWRD);
 +
              IF  P(XX) > 0;
 +
                RU  = RU  +
 +
                    %SUBST(WRU :61-C(XX): C(XX)-P(XX)) + '.' +
 +
                    %SUBST(WRU :61-P(XX))    ;
 +
              ELSE;
 +
                RU  = RU  +
 +
                    %SUBST(WRU :61-C(XX));
 +
              ENDIF;
 +
            ENDIF;
 +
 +
 +
        //  PROCESS FLOAT  DATA TYPE
 +
            IF  T(XX) = 'F';
 +
 +
            ST = S(XX);
 +
 +
              IF  Q(XX) = 4;
 +
              FL4  = D(ST) + D(ST+1)+ D(ST+2) + D(ST+3);
 +
              FLT14 =  %EDITFLT(FLT4);
 +
                RU  = RU  + FLT14;
 +
              ENDIF;
 +
 +
              IF  Q(XX) = 8;
 +
              FL8  = D(ST) + D(ST+1)+ D(ST+2) + D(ST+3) +
 +
                      D(ST+4) + D(ST+5)+ D(ST+6) + D(ST+7);
 +
              FLT23 =  %EDITFLT(FLT8);
 +
                RU  = RU  + FLT23;
 +
              ENDIF;
 +
 +
            ENDIF;
 +
 +
 +
          //  SEND A REQUEST UNIT IF GOT ENOUGH DATA
 +
 +
            IF  %LEN(RU) + L(XX + 1) >= 200;
 +
              RU  =  RU + X20;
 +
              BIN  =  %LEN(RU);
 +
              OUTLEN  =  HX2;
 +
              INLEN  =  X000;
 +
              FNC    =  SND;
 +
              A      = RU;
 +
              EXCEPT  DATAO;
 +
              NEWRU  = '1';
 +
              RU    = *ALLX'00';
 +
              CLEAR  RU;
 +
            ENDIF;
 +
 +
            ENDFOR;
 +
          ENDIF;
 +
 +
            IF  %LEN(RU) > 5 AND %LEN(RU) < 250;
 +
              RU  =  RU + X20;
 +
              BIN  =  %LEN(RU);
 +
              OUTLEN  =  HX2;
 +
              INLEN  =  X000;
 +
              FNC    =  SND;
 +
              A      = RU;
 +
              EXCEPT  DATAO;
 +
            ENDIF;
 +
          ENDSR;
 +
 +
 +
        // @@@@@@@@@@@@@@@    ROWINC  @@@@@@@@@@@@@@@
 +
 +
        // INCREMENT THE ROW
 +
          BEGSR    @ROWINC;
 +
          ROW = ROW + 2;
 +
          IF  ROW > 20;
 +
            MX = 3;
 +
          ENDIF;
 +
          ENDSR;
 +
 +
 +
 +
        // @@@@@@@@@@@@@@@    GETFLD  @@@@@@@@@@@@@@@
 +
 +
        // LOAD FIELD DESCRIPTION ARRAYS
 +
          BEGSR    @GETFLD;
 +
          MX = 0;
 +
          X  = 0;
 +
 +
          IF  (*INU2 = *ON);
 +
          // IF NON KEYED ACCESS SET UP A FIELD TO SHOW THE RRN
 +
            N(1) =  'RRN';
 +
            T(1) =  'S'  ;
 +
            C(1) =  11  ;
 +
            P(1) =  0    ;
 +
            S(1) =  0    ;
 +
            E(1) =  0    ;
 +
            L(1) =  12  ;
 +
            I(1) = X4F06 ;
 +
            KY(1)= '3'  ;
 +
            X    = 1    ;
 +
          ENDIF;
 +
 +
          SCRST = *BLANK;
 +
          SCRSTN = *BLANK;
 +
 +
          LVL  = %DEC(SCNLVL : 5:0);
 +
 +
        TEXT500 = SCNLV ;
 +
        LV      = LVW;
 +
 +
        IF  LVL <> 0;
 +
          SCRST = LV(LVL);
 +
        ENDIF;
 +
 +
          SETLL 1 QWHDRFFD ;
 +
 +
          DOW  @LOOP  = @LOOP;
 +
        //  REREAD  TAG
 +
          READ    QWHDRFFD;
 +
          IF %EOF;
 +
            LEAVE;
 +
          ENDIF;
 +
 +
        //  SELECT OR OMIT
 +
          IF  ALL  <> '1';
 +
          IF  ALL  =  'S' AND WHDFTL = 0; // USING WHDFTL FOR KEY FIELDS
 +
            IF  WHFIOB  <>  'S';
 +
              ITER;
 +
            ENDIF;
 +
          ENDIF;
 +
          IF  ALL  =  'O' AND WHDFTL = 0; // USING WHDFTL FOR KEY FIELDS
 +
            IF  WHFIOB  =  'O';
 +
              ITER;
 +
            ENDIF;
 +
          ENDIF;
 +
          ENDIF;
 +
 +
        //  FIND THE FIRST FIELD TO BE SHOWN (FOR MULTI PAGE FORMATS)
 +
          IF  WHDFTL  <> 0 ;
 +
            ELSE;
 +
            IF SCRST <> ' ' AND SCRSTN = ' ';
 +
              IF WHFLDE =  SCRST;
 +
                SCRSTN = '1';    //  FOUND THE START
 +
              ELSE;
 +
                ITER;
 +
              ENDIF;
 +
            ENDIF;
 +
          ENDIF;
 +
 +
 +
          X =  X  + 1;
 +
        // CHECK FOR KEY FIELDS,WILL BE USED TO PLACE THEM IN FRONT
 +
          IF  WHDFTL  <>  0;
 +
              KY(X) = '1';
 +
              WX    = WHDFTL ;
 +
              KE(WX) = WHFLDE;
 +
              IF  NUMKEY <  WHDFTL;
 +
                NUMKEY = WHDFTL;
 +
              ENDIF;
 +
          ENDIF;
 +
 +
            N(X) =  WHFLDE ;              //    NAME
 +
            T(X) =  WHFLDT ;              //    TYPE
 +
            V(X) =  WHVARL ;              //    VARYING
 +
            C(X) =  WHFLDD ;              //    DEC DIGITS
 +
            P(X) =  WHFLDP ;              //    DEC PREC
 +
            S(X) =  WHFOBO ;              //    START
 +
            Q(X) =  WHFLDB ;              //    BTYES
 +
            E(X) =  WHFOBO + WHFLDB -1 ;  //  END
 +
 +
            IF T(X) =  'F' ;              //    FLOAT
 +
 +
              I(X) = FFA1 + FFA2;          //  SCRN FIELD FORMAT ALPHA
 +
              L(X)  = 14;
 +
              IF Q(X) = 8;
 +
              L(X)  = 23;
 +
              ENDIF;
 +
 +
            ELSE;
 +
              IF  WHFLDD  <> 0 ;
 +
              IF  WHFLDP  <> 0 ;
 +
                L(X) =  WHFLDD +  2  ;      //  LENGTH
 +
              ELSE;
 +
                L(X) =  WHFLDD +  1  ;      //  LENGTH
 +
              ENDIF;
 +
 +
                I(X) = FFN1 + FFN2;        //  SCRN FIELD FORMAT NUMERIC
 +
 +
              ELSE;
 +
                L(X) =    WHFLDB  ;
 +
                I(X) = FFA1 + FFA2;        //  SCRN FIELD FORMAT ALPHA
 +
              ENDIF;
 +
            ENDIF;
 +
 +
        ENDDO;
 +
        //  NUMBER OF FIELDS
 +
        NUMFLD = X ;
 +
 +
      //  MAKE ROOM FOR KEYS
 +
          IF  NUMKEY  >  0 ;
 +
          X1  = NUMKEY  + NUMFLD;
 +
 +
          FOR  X =  NUMFLD DOWNTO 1;
 +
              KY(X1) = KY(X) ;
 +
              L(X1)  = L(X)  ;
 +
              I(X1)  = I(X)  ;
 +
              N(X1)  = N(X)  ;
 +
              T(X1)  = T(X)  ;
 +
              V(X1)  = V(X)  ;
 +
              C(X1)  = C(X)  ;
 +
              P(X1)  = P(X)  ;
 +
              S(X1)  = S(X)  ;
 +
              E(X1)  = E(X)  ;
 +
              Q(X1)  = Q(X)  ;
 +
              X1    = X1 - 1;
 +
          ENDFOR;
 +
 +
          //  PUT KEY FIELDS AT TOP
 +
          OFF  = 0;
 +
          FOR  X =  1 TO NUMKEY;
 +
          X1 = %LOOKUP(KE(X) : N : NUMKEY+1);
 +
 +
          KY(X) = '2';
 +
          L(X)  = L(X1);
 +
          I(X)  = I(X1);  // FIELD FMT
 +
          SELECT;                // INPUT ENABLE
 +
            WHEN  I(X) = X6000;
 +
                  I(X) = X4800;
 +
            WHEN  I(X) = X6706;
 +
                  I(X) = X4F06;
 +
          ENDSL;
 +
            N(X) =  N(X1);
 +
            T(X) =  T(X1);
 +
            V(X) =  V(X1);
 +
            C(X) =  C(X1);
 +
            P(X) =  P(X1);
 +
            S(X) =  S(X1);
 +
            E(X) =  E(X1);
 +
            Q(X) =  Q(X1);
 +
            R(X) =  OFF;
 +
            OFF  =  OFF + Q(X1);
 +
          ENDFOR;
 +
 +
        ENDIF;
 +
      //  NUMBER OF FIELDS AND KEYS
 +
        NUMFKY = NUMFLD  +  NUMKEY;
 +
 +
        ENDSR;
 +
 +
 +
        // @@@@@@@@@@@@@@@    GETADD  @@@@@@@@@@@@@@@
 +
 +
        // LOAD FIELD BUFFER ADDRESSES
 +
          BEGSR    @GETADD;
 +
          MX = 0;
 +
          X  = 0;
 +
          ROW = 3;
 +
          COL = 1;
 +
 +
          FOR X = 1 TO NUMFKY;
 +
 +
        // IF FINISHED WITH THE KEY FIELDS
 +
        //  INC  ROW FOR 1ST DATA FIELD
 +
          IF KEYSOK = ' ' ;
 +
          IF KY(X) = ' ' OR KY(X) = '1';
 +
            KEYSOK = '1' ;
 +
            ROW    = ROW + 2;
 +
            COL    = 1;
 +
          ENDIF;
 +
          ENDIF;
 +
 +
        //  SET THE BUFFER ADD ON THE LARGER OF THE FIELD TEXT OR THE FIELD SIZE
 +
          LENDSC  = %LEN(%TRIM(N(X)));
 +
          LENWRK  =  L(X);
 +
          IF LENDSC > L(X);
 +
            LENWRK = LENDSC;
 +
          ENDIF;
 +
            LENWRK = LENWRK + 2;
 +
 +
        //  TRAP FIELDS THAT OVERFLOW
 +
            ROW  = ROW  + XROW;
 +
            XROW = %DIV(LENWRK : 80);
 +
 +
            IF (COL + LENWRK) > 78;
 +
              EXSR @ROWINC;
 +
                IF MX = 3;
 +
                X= X-1;
 +
                NUMFKY = X;
 +
                LEAVE;
 +
                ENDIF;
 +
              COL = 1;
 +
            ENDIF;
 +
 +
        // INC COL. FOR FIELD START
 +
          CLEAR  B(X);
 +
          BIN  = ROW;
 +
          B(X) =  %TRIM(B(X)) + HX1;
 +
          BIN  = COL + 1;
 +
          B(X) =  %TRIM(B(X)) + HX1;
 +
 +
        // INC COL. FOR NEXT FIELD
 +
        COL = COL + LENWRK;
 +
            IF COL > 78;
 +
              EXSR @ROWINC;
 +
                IF MX = 3;    // NO ROOM FOR THE FIELD
 +
                X= X-1;
 +
                NUMFKY = X;
 +
                LEAVE;
 +
                ENDIF;
 +
              COL = 1;
 +
            ENDIF;
 +
 +
          ENDFOR;
 +
 +
        //  FIELD LEVEL
 +
          LVX      = LVL + 1;
 +
          LV(LVX)  = N(X);
 +
 +
        ENDSR;
 +
 +
 +
        // @@@@@@@@@@@@@@@    PUTHED  @@@@@@@@@@@@@@@
 +
 +
        //  PUT FIELD HEADINGS
 +
          BEGSR    @PUTHED;
 +
 +
 +
            NEWRU  = '1';
 +
 +
            RU    = *ALLX'00';
 +
            CLEAR  RU;                  //  initialise Request Unit  255 bytes max
 +
            FOR  XX = 1 TO      NUMFKY; //NUMBER OF DATA ELEMENTS (FLD AND KEY)
 +
 +
            IF NEWRU = '1';
 +
              NEWRU  = '0';
 +
              RU  = ESC + WTD + X20 + X00;
 +
            ENDIF;
 +
 +
            RU = RU + SBA;
 +
            BIN = 0;
 +
              // CONVERT DATA BUFADR TO HEADING BUFADR
 +
            HX1 = %SUBST(B(XX) :1:1);
 +
            BIN = BIN - 1;
 +
            RU  = RU + HX1;
 +
 +
            IF  REHEAD = '1'; // ON REDISPLAY OVERRIDE THE ATTR
 +
              BIN = 0;
 +
              HX1 = %SUBST(B(XX) :2:1);
 +
              BIN = BIN -1 ;
 +
              RU  = RU + HX1;
 +
            ELSE;
 +
              RU  = RU + %SUBST(B(XX) :2);
 +
            ENDIF;
 +
 +
            RU = RU + ATC ;
 +
 +
        //  LONG NUMBER FIELDS ,RIGHT ADJUST THE FIELD HEADINGS
 +
            LENDSC  = %LEN(%TRIM(N(XX)));
 +
            IF  T(XX) <> 'A' AND  LENDSC <  (L(XX) -1);
 +
            FOR Y = 1 TO (L(XX) -(LENDSC +1));
 +
              RU = RU + ' ';
 +
            ENDFOR;
 +
            ENDIF;
 +
 +
            RU = RU + %TRIM(N(XX));
 +
 +
              IF %LEN(RU) >= 200;
 +
              BIN    = %LEN(RU);
 +
              OUTLEN = HX2;
 +
              INLEN  = X000;
 +
              FNC    = SND;
 +
              A      = RU;
 +
              EXCEPT DATAO;
 +
              NEWRU  = '1';
 +
              RU    = *ALLX'00';
 +
              CLEAR  RU;
 +
              ENDIF;
 +
 +
            ENDFOR;
 +
 +
              IF %LEN(RU) >  5 AND %LEN(RU) <  200;
 +
              BIN    = %LEN(RU);
 +
              OUTLEN = HX2;
 +
              INLEN  = X000;
 +
              FNC    = SND;
 +
              A      = RU;
 +
              EXCEPT DATAO;
 +
              ENDIF;
 +
 +
          IF REHEAD <> '1';
 +
        //  FORMAT FIELDS
 +
 +
 +
            NEWRU  = '1';
 +
            RU    = *ALLX'00';
 +
            CLEAR  RU;                  //  initialise Request Unit  255 bytes max
 +
            FOR  XX = 1 TO      NUMFKY; //NUMBER OF DATA ELEMENTS (FLD AND KEY)
 +
 +
            IF NEWRU = '1';
 +
              NEWRU  = '0';
 +
              RU  = ESC + WTD + X20 + X00;
 +
            ENDIF;
 +
 +
            RU = RU + SBA +B(XX)+SF + I(XX);
 +
 +
            IF KY(XX) = '1' OR KY(XX) = '2' OR KY(XX) = '3';
 +
              RU = RU + X25;
 +
            ELSE;
 +
              RU = RU + X26;
 +
            ENDIF;
 +
 +
            BIN =  L(XX);
 +
            RU  = RU + HX2;
 +
 +
          // LENGTH OF INPUT FIELDS
 +
            LENF  = LENF + L(XX) + 3;
 +
 +
 +
              IF %LEN(RU) >= 200;
 +
              BIN    = %LEN(RU);
 +
              OUTLEN = HX2;
 +
              INLEN  = X000;
 +
              FNC    = SND;
 +
              A      = RU;
 +
              EXCEPT DATAO;
 +
              NEWRU  = '1';
 +
              RU    = *ALLX'00';
 +
              CLEAR  RU;
 +
              ENDIF;
 +
 +
          ENDFOR;
 +
 +
      //  PUT LAST R/U
 +
              IF %LEN(RU) >  5 AND %LEN(RU) <  200;
 +
              BIN    = %LEN(RU);
 +
              OUTLEN = HX2;
 +
              INLEN  = X000;
 +
              FNC    = SND;
 +
              A      = RU;
 +
              EXCEPT DATAO;
 +
              ENDIF;
 +
 +
        //INC BUFFER ADDRESS FOR ALL FIELDS FOR DATA PUT
 +
            FOR  XP = 1 TO      NUMFKY; //NUMBER OF DATA ELEMENTS (FLD AND KEY)
 +
            HX2  = B(XP);
 +
            BIN  = BIN + 1;
 +
            B(XP) = HX2;
 +
            ENDFOR;
 +
          ENDIF;
 +
 +
        ENDSR;
 +
 +
      //  @@@@@@@  INIT  @@@@@@@@@@@@@@@@@@@@@@@@@
 +
          BEGSR        @INIT;
 +
 +
        CLEAR  KW;
 +
 +
        //  UPDATE
 +
          IF  UPDF  = 'Y';
 +
                FFA1 = X40;
 +
                FFN1 = X47;
 +
          ELSE;
 +
                FFA1 = X60;
 +
                FFN1 = X67;
 +
          ENDIF;
 +
 +
          SELECT;
 +
          WHEN  *INU1 = '1';
 +
                FILE  =  F1 ;
 +
                LIB  =  L1 ;
 +
                MBR  =  M1 ;
 +
                RCDL  =  R1 ;
 +
                ACCTP =  A1 ;
 +
          WHEN  *INU2 = '1';
 +
                FILE  =  F2 ;
 +
                LIB  =  L2 ;
 +
                MBR  =  M2 ;
 +
                RCDL  =  R2 ;
 +
                ACCTP =  A2 ;
 +
          ENDSL;
 +
            RLEN    =  RCDL  ;
 +
            RLENTH  =  %EDITC(RLEN: 'X') ;
 +
            LENF    =  0    ;
 +
 +
 +
        // Control commands and data are constructed into RUs Request UNITS
 +
        // Each RU is 256 bytes max size.
 +
        // Construct and send as many RUs as needed to format the display.
 +
            RU    = *ALLX'00';
 +
            CLEAR  RU;        //  initialise Request Unit  255 bytes max
 +
            RU  = CLRWTD ;
 +
          //set up the screen headings
 +
            BIN = 1;    // set ROW to 1
 +
            RW  = HX1;
 +
            BIN = 2;    // set COL to 2
 +
            CL  = HX1;
 +
            RU  = RU + SBA + RW + CL + X22 + %TRIM(LIB) + '/' + %TRIM(FILE);
 +
            RU  = RU + ' Mbr ' + %TRIM(MBR) + ' Rcdl ' + %EDITC(RLEN  : 'Z') ;
 +
            RU  = RU + ' RRN '  ;
 +
            BIN = %len(RU) -4;
 +
            RBA = RW + HX1 ;  // address of the RRN field
 +
            RU  = RU + SBA + RBA + '          ';
 +
 +
      // FUNCTION KEYS
 +
            BIN  = 23;
 +
            RW  = HX1;
 +
            BIN  = 02;
 +
            CL  = HX1;
 +
            IF  UPDF = 'Y';  //  UPDATE IS ON
 +
            RU  = RU + SBA + RW + CL + %TRIM(CNS(2));
 +
            ELSE;
 +
            RU  = RU + SBA + RW + CL + %TRIM(CNS(1));
 +
            ENDIF;
 +
 +
        //  THIS IS A SEND ONLY FUNCTION
 +
          FNC    = SND;
 +
          CLEAR A;
 +
          A      = RU;
 +
          BIN2    = %LEN(RU);
 +
          OUTLEN  = BY2;
 +
          INLEN  = x000;
 +
 +
          EXCEPT    DATAO;
 +
 +
        ENDSR;
 +
 +
 +
      //  @@@@@@@  KEYIN  @@@@@@@@@@@@@@@@@@@@@@@@@
 +
        BEGSR  @KEYIN;
 +
      // ISSUE A READ FROM DISPLAY
 +
          FNC = SNR;
 +
          BIN2  = 8;
 +
          OUTLEN = BY2;
 +
          IPL = LENF + 34;
 +
          BIN2  = IPL;
 +
          INLEN  = BY2;
 +
 +
          // SET FRR INDICATORS TO CONTROL BUFFER OVERFLOW
 +
          FOR X =  1 TO  9;
 +
            IF IPL  >  ( X*80 +3);
 +
              *IN(X+19) = *ON;
 +
            ENDIF;
 +
          ENDFOR;
 +
 +
        RU    = *ALLX'00';
 +
        CLEAR  RU;
 +
        RU  = RDDSP;
 +
        A    = RU;
 +
 +
        EXCEPT DATAI;
 +
        ENDSR;
 +
 +
      //  @@@@@@@  ERROR  @@@@@@@@@@@@@@@@@@@@@@@@@
 +
        BEGSR    @ERROR;
 +
 +
      // SETUP PUT ERROR MESSAGE X'21'
 +
        RU    = *ALLX'00';
 +
        CLEAR RU;
 +
 +
        FNC    =  SNR;
 +
        BIN    = 42;
 +
        OUTLEN = HX2;
 +
        BIN    = LENF + 34;
 +
        IPL    = BIN;
 +
        INLEN  = HX2;
 +
 +
        FOR X        = 1 TO 9;
 +
          IF IPL      > (X * 80 +3) ;
 +
          *IN(X + 19) = *ON;          // SETON FFR 20 - 29 FOR INPUT
 +
          ENDIF;
 +
        ENDFOR;
 +
 +
        RU = ESC + WER + IC + B(1) + ATC + MSG(MX);
 +
        RU = RU + ESC + RDM + X40+ X00;
 +
 +
        A  = RU;
 +
        EXCEPT    DATAI;
 +
        RU    = *ALLX'00';
 +
        CLEAR RU;
 +
        ENDSR;
 +
 +
 +
      //  @@@@@@@    HXDSP @@@@@@@@@@@@@@@@@@@@@@@@@
 +
        BEGSR  @HXDSP;
 +
 +
          RU    = *ALLX'00';
 +
          CLEAR RU;
 +
          Y = %LOOKUPLE( CURLOC : B );
 +
          //
 +
          RU = ESC + WTD + X20 + X00 + SBA;
 +
          BIN = 0;
 +
          HX1 = %SUBST(B(Y) :1:1);
 +
          BIN = BIN - 1;
 +
          RU  = RU + HX1;
 +
          RU  = RU + %SUBST(B(Y) :2:1);
 +
 +
          FOR X = S(Y) TO E(Y);
 +
            BIN = 0;
 +
            HX1 = D(X);
 +
            HX1 = %BITAND(HX1  : XF0);
 +
            Z  = BIN / 16 + 1;
 +
            RU  = RU + CRS(Z);
 +
          ENDFOR;
 +
 +
            RU  = RU + X20;
 +
 +
            RU  = RU + SBA + B(Y);
 +
          FOR X = S(Y) TO E(Y);
 +
            BIN = 0;
 +
            HX1 = D(X);
 +
            HX1 = %BITAND(HX1  : X0F);
 +
            Z  = BIN  + 1;
 +
            RU  = RU + CRS(Z);
 +
          ENDFOR;
 +
 +
 +
          BIN    = %LEN(RU);
 +
          OUTLEN = HX2;
 +
          INLEN  = X000;
 +
          FNC    = SND;
 +
          A      = RU;
 +
          EXCEPT DATAO;
 +
          RU    = *ALLX'00';
 +
          CLEAR  RU;
 +
 +
 +
          EXSR      @KEYIN;
 +
          READ      DISPF;
 +
 +
 +
      //  CLEAR HEADINGS
 +
            RU    = *ALLX'00';
 +
            CLEAR RU;
 +
 +
        RU  = RU + ESC + WTD + X20 + X00 + SBA;
 +
        HX1  = %SUBST(B(Y) :1:1) ;
 +
        BIN  = BIN - 1;
 +
        RU  = RU + HX1 + %SUBST(B(Y):2:1);
 +
          FOR X = S(Y) TO E(Y);
 +
          RU = RU + ' ';
 +
          ENDFOR;
 +
        RU = RU + ' ';
 +
 +
        BIN    = %LEN(RU);
 +
        OUTLEN = HX2;
 +
        INLEN  = X000;
 +
        FNC    = SND;
 +
        A      = RU;
 +
        EXCEPT    DATAO;
 +
        RU    = *ALLX'00';
 +
        CLEAR  RU;
 +
 +
        ENDSR;
 +
 +
 +
 +
      //  @@@@@@@    UPD  @@@@@@@@@@@@@@@@@@@@@@@@@
 +
          BEGSR  @UPD;
 +
 +
        // CONVERT  DATA  FOR OUTPUT
 +
 +
        //  FOR EACH  FIELD, CHECK IF FIELD WAS MODIFIED, AND IF SO MOVE
 +
        // THE MODIFIED DATA INTO THE OUTPUT ARRAY
 +
        K1 = 0;
 +
        K2 = 0;
 +
        W  = 1;
 +
        CGKY = *BLANK;  // KEY CHANGED
 +
        KW  = KEYA;
 +
 +
          FOR  Y  = 1  TO NUMFKY ;
 +
 +
            IF KY(Y) > '1';
 +
            ITER;
 +
            ENDIF;
 +
 +
 +
      //  MOVE A KEY FIELDS DATA FROM ID ARRAY (SCREEN) TO K ARRAY
 +
 +
      //  GET SIZE OF FIELD IN BYTES
 +
        SELECT;
 +
          WHEN  T(Y)  =  'A';  // ALPHA DATA
 +
          K = ' ';
 +
          K1 = 1;
 +
          K2 = Q(Y);
 +
          WHEN  T(Y)  =  'F';  // FLOAT
 +
          K  = '0';
 +
          K1 =  1;
 +
          K2 = L(Y);
 +
          OTHER;
 +
          K  = '0';
 +
          K1 =  1;
 +
          K2 = C(Y);
 +
        ENDSL;
 +
 +
          X  =  1;
 +
 +
          DOW  @LOOP = @LOOP;
 +
 +
      //  NXTSBA
 +
          X  = %LOOKUP(SBA : ID : X );
 +
          IF X = 0;
 +
            LEAVE;
 +
          ENDIF;
 +
 +
      // IS THIS THE FIELD?  CHECK THE BUFFER ADDRESS
 +
        X = X +1;
 +
        IF  B(Y)  <>  %SUBST(IDA : X :2);
 +
          ITER;
 +
        ENDIF;
 +
 +
 +
      //  FOUND A MTD FOR THIS FIELD
 +
 +
 +
        // CHECK IF FIELD WAS CLEARED ONLY
 +
          DOW @LOOP = @LOOP; //  not a loop
 +
        X =  X + 2;
 +
        IF  ID(X) = SBA;
 +
          LEAVE;
 +
        ENDIF;
 +
 +
      //  IF FIELD HAS DECIMALS BUMP X
 +
          IF (T(Y) = 'S' OR T(Y) = 'P' OR T(Y) = 'B') AND
 +
              P(Y) > 0;
 +
              X = X + 1;
 +
          ENDIF;
 +
 +
 +
      //  CHECK IF ONLY BLANKS RETURNED
 +
          IF    %SUBST(IDA : X :K2) = *BLANKS;
 +
              LEAVE;
 +
          ENDIF;
 +
 +
        // MOVE DATA TO WORK ARRAY K
 +
            X1 = X;
 +
            FOR X2 = 1 TO K2;
 +
 +
            IF ID(X1) < ' ';
 +
              LEAVE;
 +
            ENDIF;
 +
 +
            K(X2) = ID(X1);
 +
            X1 = X1 + 1;
 +
            ENDFOR;
 +
 +
          LEAVE;
 +
        ENDDO;
 +
 +
        // *  SET START POSN
 +
          W =  S(Y);
 +
 +
        // ALPHA
 +
          IF T(Y) =  'A'  and V(XX) <>  'Y';
 +
          FOR Z  =  K1 to K2;
 +
            D(W) =  K(Z);
 +
            W    =  W + 1;
 +
          ENDFOR;
 +
          ENDIF;
 +
 +
        IF T(Y) =  'A' and  V(XX) = 'Y';  //VARYING
 +
 +
        //  the data start is in S(Y)
 +
        //  the data is in array K
 +
        //  get the length of the data cvt to bin and stick in pos 1 2
 +
        //  put the rest in pos 3 onwards
 +
 +
              ENDIF;
 +
 +
        // NUMERIC FIELD
 +
        // RIGHT  ADJUST NUMERIC DATA ,STRIP - . ,CONVERT BLANKS
 +
          IF (T(Y) = 'S' OR T(Y) = 'P' OR T(Y) = 'B');
 +
          NU = '0';
 +
 +
          Z1 = 60;
 +
          FOR Z  =  K2  DOWNTO K1;
 +
 +
          IF K(Z) = '.' OR K(Z) = '-' OR K(Z) = '$';
 +
          ITER;
 +
          ENDIF;
 +
 +
          IF K(Z) = ' ' ;
 +
          NU(Z1) = '0';
 +
          ELSE;
 +
          NU(Z1) = K(Z);
 +
          ENDIF;
 +
 +
            Z1 = Z1 -1;
 +
          ENDFOR;
 +
 +
          ENDIF;
 +
 +
 +
      // SIGNED FIELDS  (END POSN = OFFSET + SIZE)
 +
        IF T(Y)  = 'S';
 +
          NUSA= *BLANKS;
 +
          FOR VX = 1 TO 60;
 +
            NUSA = %TRIM(NUSA) + NU(VX);
 +
          ENDFOR;
 +
        %SUBST(DATA  : W : Q(Y)) = %SUBST(NUSA: 61 -Q(Y));
 +
 +
        ENDIF;
 +
 +
 +
      //  PACKED FIELDS
 +
          IF    T(Y)  =  'P';
 +
          NUSA= *BLANKS;
 +
          FOR VX = 1 TO 60;
 +
            NUSA = %TRIM(NUSA) + NU(VX);
 +
          ENDFOR;
 +
          NUP    = %DEC(NUSA : 60 : 0);
 +
 +
        %SUBST(DATA : W : Q(Y))  =  %SUBST(NUPA: 61 -Q(Y));
 +
        ENDIF;
 +
 +
      //  BINARY FIELDS
 +
        IF  T(Y) =  'B';
 +
 +
          NUSA= *BLANKS;
 +
          FOR VX = 1 TO 60;
 +
            NUSA = %TRIM(NUSA) + NU(VX);
 +
          ENDFOR;
 +
            NUC  = NUS;
 +
 +
        IF  Q(Y) = 2 ;
 +
              DISBIN  ( NUC : BAN2 : BAN4  : '2');
 +
            %SUBST(DATA : W : 2)  =  BAN2;
 +
        ENDIF;
 +
 +
        IF  Q(Y) = 4 ;
 +
              DISBIN  ( NUC : BAN2 : BAN4  : '4');
 +
            %SUBST(DATA : W : 4)  =  BAN4;
 +
        ENDIF;
 +
 +
        ENDIF;
 +
 +
 +
      //  FLOAT FIELDS
 +
        IF  T(Y) =  'F';
 +
 +
        IF  Q(Y) = 4;
 +
          NUFA= *BLANKS;
 +
          FOR VX = 1 TO 14;
 +
            NUFA = %TRIM(NUFA) + K(VX);
 +
          ENDFOR;
 +
 +
          result4 = %float(NUF1);
 +
        %SUBST(DATA : W : 4)  =  NUFW4;
 +
 +
        ENDIF;
 +
 +
 +
        IF  Q(Y) = 8;
 +
          NUFA= *BLANKS;
 +
          FOR VX = 1 TO 23;
 +
            NUFA = %TRIM(NUFA) + K(VX);
 +
          ENDFOR;
 +
 +
          result8 = %float(NUF);
 +
          %SUBST(DATA : W : 8)  =  NUFW8;
 +
 +
        ENDIF;
 +
 +
        ENDIF;
 +
 +
 +
 +
        //  UPDATE KEY IF NECESSARY
 +
        IF  KY(Y)  = '1';
 +
            CGKY = '1';
 +
            EXSR  @PCKMOV;
 +
        ENDIF;
 +
 +
 +
        ENDDO;
 +
        ENDFOR;
 +
 +
 +
          IF  CGKY = '1';
 +
          KEYA = KW;
 +
          ENDIF;
 +
 +
        ENDSR;
 +
 +
 +
 +
      /END-FREE
 +
 +
    OINPUTK    E    U1      UPDATREC
 +
    O                      DA                  16
 +
    O              30      DB
 +
    O              31      DC
 +
    O              32      DD
 +
    O              33      DE
 +
    O              34      DF
 +
    O              35      DG
 +
    O              36      DH
 +
    O              37      DI
 +
    O              38      DJ
 +
    O              39      DK
 +
    O              40      DL
 +
    O              41      DM
 +
    O              42      DN
 +
    O              43      DZ
 +
    O              44      DO
 +
    O              45      DP
 +
    O              46      DQ
 +
    O              47      DR
 +
    O              48      DS
 +
    O              49      DT
 +
    O              50      DU
 +
    O              51      DV
 +
    O              52      DW
 +
    O              53      DX
 +
    O              54      DY
 +
    O              55      D0
 +
    O              56      D1
 +
    O              57      D2
 +
    O              58      D3
 +
    O              59      D4
 +
    O              60      D5
 +
    O              61      D6
 +
    O              62      DBA
 +
    O              63      DCA
 +
    O              64      DDA
 +
    O              65      DEA
 +
    O              66      DFA
 +
    O              67      DGA
 +
    O              68      DHA
 +
    O              69      DIA
 +
    O              70      DJA
 +
    O              71      DKA
 +
    O              72      DLA
 +
    O              73      DMA
 +
    O              74      DNA
 +
    O              75      DOA
 +
    O              76      DPA
 +
    O              77      DQA
 +
    O              78      DRA
 +
    O              79      DSA
 +
    O              80      DTA
 +
    O              81      DUA
 +
    O              82      DVA
 +
    O              83      DWA
 +
    O              84      DXA
 +
    O              85      DYA
 +
    O              86      DZA
 +
    O              87      D0A
 +
    O              88      D1A
 +
    O              89      D2A
 +
    O              90      D3A
 +
    O              91      D4A
 +
    O              92      D5A
 +
    O              93      D6A
 +
    OINPUTR    E      U2  UPDATREC
 +
    O                      DA                  16
 +
    O              30      DB
 +
    O              31      DC
 +
    O              32      DD
 +
    O              33      DE
 +
    O              34      DF
 +
    O              35      DG
 +
    O              36      DH
 +
    O              37      DI
 +
    O              38      DJ
 +
    O              39      DK
 +
    O              40      DL
 +
    O              41      DM
 +
    O              42      DN
 +
    O              43      DZ
 +
    O              44      DO
 +
    O              45      DP
 +
    O              46      DQ
 +
    O              47      DR
 +
    O              48      DS
 +
    O              49      DT
 +
    O              50      DU
 +
    O              51      DV
 +
    O              52      DW
 +
    O              53      DX
 +
    O              54      DY
 +
    O              55      D0
 +
    O              56      D1
 +
    O              57      D2
 +
    O              58      D3
 +
    O              59      D4
 +
    O              60      D5
 +
    O              61      D6
 +
    O              62      DBA
 +
    O              63      DCA
 +
    O              64      DDA
 +
    O              65      DEA
 +
    O              66      DFA
 +
    O              67      DGA
 +
    O              68      DHA
 +
    O              69      DIA
 +
    O              70      DJA
 +
    O              71      DKA
 +
    O              72      DLA
 +
    O              73      DMA
 +
    O              74      DNA
 +
    O              75      DOA
 +
    O              76      DPA
 +
    O              77      DQA
 +
    O              78      DRA
 +
    O              79      DSA
 +
    O              80      DTA
 +
    O              81      DUA
 +
    O              82      DVA
 +
    O              83      DWA
 +
    O              84      DXA
 +
    O              85      DYA
 +
    O              86      DZA
 +
    O              87      D0A
 +
    O              88      D1A
 +
    O              89      D2A
 +
    O              90      D3A
 +
    O              91      D4A
 +
    O              92      D5A
 +
    O              93      D6A
 +
 +
    OINPUTK    EADD U1      ADDREC
 +
    O                      DA                  16
 +
    O              30      DB
 +
    O              31      DC
 +
    O              32      DD
 +
    O              33      DE
 +
    O              34      DF
 +
    O              35      DG
 +
    O              36      DH
 +
    O              37      DI
 +
    O              38      DJ
 +
    O              39      DK
 +
    O              40      DL
 +
    O              41      DM
 +
    O              42      DN
 +
    O              43      DZ
 +
    O              44      DO
 +
    O              45      DP
 +
    O              46      DQ
 +
    O              47      DR
 +
    O              48      DS
 +
    O              49      DT
 +
    O              50      DU
 +
    O              51      DV
 +
    O              52      DW
 +
    O              53      DX
 +
    O              54      DY
 +
    O              55      D0
 +
    O              56      D1
 +
    O              57      D2
 +
    O              58      D3
 +
    O              59      D4
 +
    O              60      D5
 +
    O              61      D6
 +
    O              62      DBA
 +
    O              63      DCA
 +
    O              64      DDA
 +
    O              65      DEA
 +
    O              66      DFA
 +
    O              67      DGA
 +
    O              68      DHA
 +
    O              69      DIA
 +
    O              70      DJA
 +
    O              71      DKA
 +
    O              72      DLA
 +
    O              73      DMA
 +
    O              74      DNA
 +
    O              75      DOA
 +
    O              76      DPA
 +
    O              77      DQA
 +
    O              78      DRA
 +
    O              79      DSA
 +
    O              80      DTA
 +
    O              81      DUA
 +
    O              82      DVA
 +
    O              83      DWA
 +
    O              84      DXA
 +
    O              85      DYA
 +
    O              86      DZA
 +
    O              87      D0A
 +
    O              88      D1A
 +
    O              89      D2A
 +
    O              90      D3A
 +
    O              91      D4A
 +
    O              92      D5A
 +
    O              93      D6A
 +
    OINPUTR    EADD    U2  ADDREC
 +
    O                      DA                  16
 +
    O              30      DB
 +
    O              31      DC
 +
    O              32      DD
 +
    O              33      DE
 +
    O              34      DF
 +
    O              35      DG
 +
    O              36      DH
 +
    O              37      DI
 +
    O              38      DJ
 +
    O              39      DK
 +
    O              40      DL
 +
    O              41      DM
 +
    O              42      DN
 +
    O              43      DZ
 +
    O              44      DO
 +
    O              45      DP
 +
    O              46      DQ
 +
    O              47      DR
 +
    O              48      DS
 +
    O              49      DT
 +
    O              50      DU
 +
    O              51      DV
 +
    O              52      DW
 +
    O              53      DX
 +
    O              54      DY
 +
    O              55      D0
 +
    O              56      D1
 +
    O              57      D2
 +
    O              58      D3
 +
    O              59      D4
 +
    O              60      D5
 +
    O              61      D6
 +
    O              62      DBA
 +
    O              63      DCA
 +
    O              64      DDA
 +
    O              65      DEA
 +
    O              66      DFA
 +
    O              67      DGA
 +
    O              68      DHA
 +
    O              69      DIA
 +
    O              70      DJA
 +
    O              71      DKA
 +
    O              72      DLA
 +
    O              73      DMA
 +
    O              74      DNA
 +
    O              75      DOA
 +
    O              76      DPA
 +
    O              77      DQA
 +
    O              78      DRA
 +
    O              79      DSA
 +
    O              80      DTA
 +
    O              81      DUA
 +
    O              82      DVA
 +
    O              83      DWA
 +
    O              84      DXA
 +
    O              85      DYA
 +
    O              86      DZA
 +
    O              87      D0A
 +
    O              88      D1A
 +
    O              89      D2A
 +
    O              90      D3A
 +
    O              91      D4A
 +
    O              92      D5A
 +
    O              93      D6A
 +
 +
    OINPUTK    EDEL U1      DELREC
 +
    OINPUTR    EDEL U2      DELREC
 +
 +
 +
    ODISPF    E            DATAO
 +
    O                                          K3 'PUT'
 +
    O                      OUTLEN              2
 +
    O                      INLEN
 +
    O                      FNC
 +
    O                      A
 +
 +
    O          E            DATAI
 +
    O                                          K3 'GET'
 +
    O                      OUTLEN              2
 +
    O                      INLEN
 +
    O                      FNC
 +
    O                      A
 +
**
 +
0000 INVALID COMMAND KEY
 +
0001  - A FIELD IS TOO LONG
 +
0002  - TOO MANY FIELDS
 +
0003  - ALPHAS IN PACKED KEY
 +
0004  - MISSING ' IN PACKED KEY
 +
0005  - MISSING DATA IN PCKD KEY
 +
0006  - RECORD NOT FOUND
 +
PRESS RESET TO CONTINUE
 +
**
 +
F1-HEX F2-Return F3-Exit F19-Prev_fld F20-More_fld
 +
F1-HEX F2-Return F3-Exit F6-Update F9-Add F11-Del F19-Prev_fld F20-More_fld
 +
**
 +
0123456789ABCDEF
 +
 +
 +
</pre>
 +
 +
[[#top]]
 +
 +
===DUSP1  RPG===
 +
 +
<pre>
 +
    H*eywords++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++Comments+++++++++++
 +
    H OPTION(*NODEBUGIO)
 +
    H DFTACTGRP(*NO) ACTGRP(*CALLER) DFTNAME(DUSP1 )
 +
    F*
 +
    F*  LIMITED TO MAXIMUM FILE LENGTH OF 4080
 +
    F*  REQUIRES FILE  QTEMP/FFD  TO COMPILE
 +
    F*  use cmd DSPFFD  FILE(&LIB/&FILE) OUTPUT(*OUTFILE) OUTFILE(QTEMP/FFD)
 +
 +
    FFFD      IF  E            DISK
 +
    FDISPF    CF  F  803        WORKSTN
 +
    F*
 +
    F                                    INFDS(INFDS)
 +
    FINPUTK    UF A F32766  800AIDISK    KEYLOC(1)
 +
    F                                    EXTIND(*INU1)
 +
    F                                    INFDS(INFDK)
 +
    FINPUTR    UF A F32766        DISK    EXTIND(*INU2)
 +
    F                                    INFDS(INFDR)
 +
 +
    D DISBIN          PR                  extpgm('DISBIN')
 +
    D  NUM                          15P 0
 +
    D  BAN2                          2
 +
    D  BAN4                          4
 +
    D  BINTYP                        1    CONST
 +
 +
      *
 +
    D A              S            255                                        WORK RU
 +
    D RU              S            255    varying
 +
    D RW              S              1                                        ROW 1 byte binary
 +
    D CL              S              1                                        COL 1 byte binary
 +
    D FNC            S              1
 +
    D OUTLEN          S              2
 +
    D INLEN          S              2
 +
    D IPL            S              5  0
 +
    D ROW            S              3  0
 +
    D XROW            S              3  0
 +
    D COL            S              3  0
 +
    D KEYSOK          S              1
 +
    D LENDSC          S              3  0
 +
    D LENWRK          S              5  0
 +
    D STRX            S              5  0
 +
    D ENDX            S              5  0
 +
    D VX              S              5  0
 +
    D X              S              5  0
 +
    D X1              S              5  0
 +
    D X2              S              5  0
 +
    D XX              S              5  0
 +
    D XP              S              5  0
 +
    D MX              S              5  0
 +
    D ONCE            S              1
 +
    D RBA            S              2
 +
    D LF              S              5  0
 +
    D ST              S              5  0
 +
    D Y              S              5  0
 +
    D Z              S              5  0
 +
    D OFF            S              5  0
 +
    D CGKY            S              1
 +
    D UPDDONE        S              1
 +
    D SUPZ            S              1
 +
    D NUMFLD          S              5  0
 +
    D WX              S              5  0
 +
    D NUMKEY          S              5  0
 +
    D NUMFKY          S              5  0
 +
    D SCRST          S            10
 +
    D SCRSTN          S              1
 +
    D KEYA            S            800
 +
    D RRNA            S            11  0
 +
    D RRN            S            11  0
 +
    D REHEAD          S              1
 +
    D NEWRU          S              1
 +
    D WRTRRN          S              1
 +
    D LVX            S              5  0
 +
    D LVL            S              5  0
 +
    D K1              S              5  0
 +
    D K2              S              5  0
 +
    D Z1              S              5  0
 +
    D W              S              5  0
 +
    D WK2            S              2
 +
    D MSSG            S            32
 +
      *
 +
    D BASE            S              5  0
 +
    D INZ            S              1
 +
 +
    D FILE            S            10
 +
    D LIB            S            10
 +
    D MBR            S            10
 +
    D RCDL            S              5  0
 +
    D ACCTP          S              1
 +
    D RLEN            S              5  0
 +
    D RLENTH          S              5
 +
    D LENF            S              5  0
 +
 +
 +
    D                DS
 +
    D TEXT500                      500
 +
    D LVW                          10    DIM(50) overlay(TEXT500:1)
 +
 +
    D TEXT800        S            800
 +
    D KW              S            800
 +
 +
    D                DS
 +
    D WRK11                  1    11
 +
    D NUM11                  1    11S 0
 +
 +
    D                DS
 +
    D NUSA                    1    60
 +
    D NUS                    1    60S 0
 +
    D                DS
 +
    D NUPA                    1    60
 +
    D NUP                    29    60P 0
 +
 +
    D NUC            S            15P 0
 +
    D BAN2            S              2
 +
DCL  D BAN4            S              4
 +
 +
    D WRU            S            61
 +
    D WRX            S            64
 +
    D WRXWRD          C                  '0                              -
 +
    D                                                                    -'
 +
    D WRSWRD          C                  '0                              -
 +
    D                                                                  -'
 +
    D WRV            S            60    varying
 +
 +
    D FLT14          S            14
 +
    D FLT23          S            23
 +
 +
      * SET FILE SIZE INCREMENTS (64 OF THEM)
 +
    D SZ              S              5  0 DIM(64)
 +
    D S              S              5  0 DIM(9000)                            START OF FLD
 +
    D E              S              5  0 DIM(9000)                            END OF FLD
 +
    D Q              S              5  0 DIM(9000)                            BYTES IN FIELD
 +
    D L              S              5  0 DIM(9000)                            LENGTH OF FLD
 +
    D C              S              3  0 DIM(9000)                            DEC DIGITS
 +
    D P              S              3  0 DIM(9000)                            DEC PRECISION
 +
    D B              S              2    DIM(9000) ASCEND                    BUFFER ADD
 +
    D I              S              2    DIM(9000)                            FLD FMT
 +
    D N              S            10    DIM(9000)                            FLD NAME
 +
    D T              S              1    DIM(9000)                            FLD TYPE
 +
    D V              S              1    DIM(9000)                            VARYING
 +
    D KY              S              1    DIM(9000)                            KEYED
 +
    D KE              S            10    DIM(128)                            KEY FLDS
 +
    D R              S              3  0 DIM(9000)                            KEY FLD START
 +
    D K              S              1    DIM(800)                            KEY
 +
    D NA              S              1    DIM(10)                              NAME WORK
 +
    D NU              S              1    DIM(60)                              NUM. WORK
 +
    D LV              S            10    DIM(50)                              SCREEN LEVELS
 +
    D MSG            S            32    DIM(8) CTDATA PERRCD(1)              MESSAGES
 +
    D CNS            S            79    DIM(2) CTDATA PERRCD(1)
 +
    D CRS            S              1    DIM(16) CTDATA PERRCD(16)
 +
 +
 +
    D                DS
 +
    D  DATA                  1  4080
 +
    D  D                      1  4080
 +
    D                                    DIM(4080)                            INCOMING DATA
 +
    D  DA                    1  2048
 +
    D                                    DIM(2048)
 +
    D  DB                  2049  2064
 +
    D  DC                  2065  2096
 +
    D  DD                  2097  2128
 +
    D  DE                  2129  2160
 +
    D  DF                  2161  2192
 +
    D  DG                  2193  2224
 +
    D  DH                  2225  2256
 +
    D  DI                  2257  2288
 +
    D  DJ                  2289  2320
 +
    D  DK                  2321  2352
 +
    D  DL                  2353  2384
 +
    D  DM                  2385  2416
 +
    D  DN                  2417  2448
 +
    D  DZ                  2449  2480
 +
    D  DO                  2481  2512
 +
    D  DP                  2513  2544
 +
    D  DQ                  2545  2576
 +
    D  DR                  2577  2608
 +
    D  DS                  2609  2640
 +
    D  DT                  2641  2672
 +
    D  DU                  2673  2704
 +
    D  DV                  2705  2736
 +
    D  DW                  2737  2768
 +
    D  DX                  2769  2800
 +
    D  DY                  2801  2832
 +
    D  D0                  2833  2864
 +
    D  D1                  2865  2896
 +
    D  D2                  2897  2928
 +
    D  D3                  2929  2960
 +
    D  D4                  2961  2992
 +
    D  D5                  2993  3024
 +
    D  D6                  3025  3056
 +
    D  DBA                3057  3088
 +
    D  DCA                3089  3120
 +
    D  DDA                3121  3152
 +
    D  DEA                3153  3184
 +
    D  DFA                3185  3216
 +
    D  DGA                3217  3248
 +
    D  DHA                3249  3280
 +
    D  DIA                3281  3312
 +
    D  DJA                3313  3344
 +
    D  DKA                3345  3376
 +
    D  DLA                3377  3408
 +
    D  DMA                3409  3440
 +
    D  DNA                3441  3472
 +
    D  DOA                3473  3504
 +
    D  DPA                3505  3536
 +
    D  DQA                3537  3568
 +
    D  DRA                3569  3600
 +
    D  DSA                3601  3632
 +
    D  DTA                3633  3664
 +
    D  DUA                3665  3696
 +
    D  DVA                3697  3728
 +
    D  DWA                3729  3760
 +
    D  DXA                3761  3792
 +
    D  DYA                3793  3824
 +
    D  DZA                3825  3856
 +
    D  D0A                3857  3888
 +
    D  D1A                3889  3920
 +
    D  D2A                3921  3952
 +
    D  D3A                3953  3984
 +
    D  D4A                3985  4016
 +
    D  D5A                4017  4048
 +
    D  D6A                4049  4080
 +
    D                DS
 +
    D  ID                    1    800
 +
    D                                    DIM(800)                            INCOMING DATA
 +
    D  IDA                    1    800
 +
    D  ID0                    1    80
 +
    D  ID1                  81    160
 +
    D  ID2                  161    240
 +
    D  ID3                  241    320
 +
    D  ID4                  321    400
 +
    D  ID5                  401    480
 +
    D  ID6                  481    560
 +
    D  ID7                  561    640
 +
    D  ID8                  641    720
 +
    D  ID9                  721    800
 +
    D                DS
 +
    D  BIN                    1      2B 0
 +
    D  HX1                    2      2
 +
    D  HX2                    1      2
 +
    D                DS
 +
    D  PCK                    1      1P 0
 +
    D  PCK1                  1      1
 +
    D                DS
 +
    D  SGN                    1      1S 0
 +
    D  SGN1                  1      1
 +
 +
    D                DS
 +
    D  BIN4                  1      4B 0
 +
    D  BY4                    1      4
 +
 +
    D                DS
 +
    D  BIN2                  1      2B 0
 +
    D  BY2                    1      2
 +
 +
    D                DS
 +
    D  FLT4                  1      4F
 +
    D  FL4                    1      4
 +
 +
    D                DS
 +
    D  FLT8                  1      8F
 +
    D  FL8                    1      8
 +
 +
    D INFDK          DS
 +
    D  F1                    83    92
 +
    D  L1                    93    102
 +
    D  M1                  129    138
 +
    D  R1                  125    126B 0
 +
    D  A1                  160    160
 +
    D  LOP1                260    260
 +
    D  KEY_LEN              393    394I 0                                      Key length
 +
    D  RN1                  397    400B 0
 +
    D  LKY                  401  1200
 +
    D INFDR          DS
 +
    D  F2                    83    92
 +
    D  L2                    93    102
 +
    D  M2                  129    138
 +
    D  R2                  125    126B 0
 +
    D  A2                  160    160
 +
    D  LOP2                260    260
 +
    D  RN2                  397    400B 0
 +
    D*
 +
    D INFDS          DS
 +
    D  CURLOC              370    371
 +
    D                DS
 +
    D KEYLN                  1      4S 0
 +
    D KEYLNA                  1      4
 +
 +
    DDUSP1            PR
 +
    D                                1
 +
    D                                1
 +
    D                                4
 +
    D                                1
 +
    D                              500
 +
    D                                5
 +
    D                              800
 +
    DDUSP1            PI
 +
    D  ALL                          1
 +
    D  RTN                          1
 +
    D  KEYLNG                      4
 +
    D  UPDF                        1
 +
    D  SCNLV                      500
 +
    D  SCNLVL                      5
 +
    D  SCNKEY                    800
 +
 +
 +
    D @LOOP          C                  '1'
 +
    D @FALSE          C                  '0'
 +
    D @TRUE          C                  '1'
 +
 +
    D SND            C                  X'71'                                SEND TO DISP
 +
    D SNR            C                  X'73'                                SND/RCV
 +
    D RED            C                  X'42'                                READ
 +
    D RDM            C                  X'52'                                READ MTD
 +
    D ESC            C                  X'04'                                ESCAPE
 +
    D CLR            C                  X'40'                                CLEAR UNIT
 +
    D CC1            C                  X'00'                                CNTRL CHAR
 +
    D CC2            C                  X'08'                                CNTRL CHAR
 +
    D SBA            C                  X'11'                                SET BUFF ADR
 +
    D IC              C                  X'13'                                INSERT CURS
 +
    D WTD            C                  X'11'                                WRITE TO DSP
 +
    D WER            C                  X'21'                                WRITE ERROR
 +
    D SF              C                  X'1D'                                START FLD
 +
    D ATC            C                  X'20'                                ATTR CHAR
 +
    D ATN            C                  X'24'                                ATTR NUM
 +
    D X00            C                  X'00'
 +
    D X01            C                  X'01'
 +
    D X02            C                  X'02'
 +
    D X03            C                  X'03'
 +
    D X0D            C                  X'0D'
 +
    D X0F            C                  X'0F'
 +
    D X000            C                  X'0000'
 +
    D X1F            C                  X'1F'
 +
    D X20            C                  X'20'                                SCRN ATT NORMAL
 +
    D X22            C                  X'22'                                SCRN ATTR HI
 +
    D X25            C                  X'25'
 +
    D X26            C                  X'26'
 +
    D X31            C                  X'31'                                CMD 1 KEY
 +
    D X32            C                  X'32'                                CMD 2 KEY
 +
    D X33            C                  X'33'                                CMD 3 KEY
 +
    D X36            C                  X'36'                                CMD 6 KEY
 +
    D X37            C                  X'37'                                CMD 7 KEY
 +
    D X38            C                  X'38'                                CMD 8 KEY
 +
    D X39            C                  X'39'                                CMD 9 KEY
 +
    D X3B            C                  X'3B'                                CMD11 KEY
 +
    D XB7            C                  X'B7'                                CMD19 KEY
 +
    D XB8            C                  X'B8'                                CMD20 KEY
 +
    D X40            C                  X'40'
 +
    D X43            C                  X'43'
 +
    D X47            C                  X'47'
 +
    D X60            C                  X'60'
 +
    D X67            C                  X'67'
 +
    D X9F            C                  X'9F'
 +
    D XF0            C                  X'F0'
 +
    D XD0            C                  X'D0'
 +
    D X4000          C                  X'4000'
 +
    D X4800          C                  X'4800'                              FF ALPHA
 +
    D X4F06          C                  X'4F06'                              FF NUMERIC
 +
    D X6000          C                  X'6000'                              FF ALPHA
 +
    D X6706          C                  X'6706'                              FF NUMERIC
 +
    D CLRWTD          C                  X'044004112000'                      INCLUDES ESC CHARS
 +
    D RDDSP          C                  X'0411200804524000'                  READ FROM DISPLAY
 +
    D FFA1            S              1    INZ(X'40')                          F.FMT 1 ALPH  60 BYP
 +
    D FFA2            S              1    INZ(X'00')                          F.FMT 2 ALPH
 +
    D FFN1            S              1    INZ(X'47')                          F.FMT 1 NUM  67 BYP
 +
    D FFN2            S              1    INZ(X'06')                          F.FMT 2 NUM
 +
    I*.
 +
    IINPUTK    NS  01
 +
    I                                  1 2048  DA
 +
    I                              2049 2064  DB                30
 +
    I                              2065 2096  DC                31
 +
    I                              2097 2128  DD                32
 +
    I                              2129 2160  DE                33
 +
    I                              2161 2192  DF                34
 +
    I                              2193 2224  DG                35
 +
    I                              2225 2256  DH                36
 +
    I                              2257 2288  DI                37
 +
    I                              2289 2320  DJ                38
 +
    I                              2321 2352  DK                39
 +
    I                              2353 2384  DL                40
 +
    I                              2385 2416  DM                41
 +
    I                              2417 2448  DN                42
 +
    I                              2449 2480  DZ                43
 +
    I                              2481 2512  DO                44
 +
    I                              2513 2544  DP                45
 +
    I                              2545 2576  DQ                46
 +
    I                              2577 2608  DR                47
 +
    I                              2609 2640  DS                48
 +
    I                              2641 2672  DT                49
 +
    I                              2673 2704  DU                50
 +
    I                              2705 2736  DV                51
 +
    I                              2737 2768  DW                52
 +
    I                              2769 2800  DX                53
 +
    I                              2801 2832  DY                54
 +
    I                              2833 2864  D0                55
 +
    I                              2865 2896  D1                56
 +
    I                              2897 2928  D2                57
 +
    I                              2929 2960  D3                58
 +
    I                              2961 2992  D4                59
 +
    I                              2993 3024  D5                60
 +
    I                              3025 3056  D6                61
 +
    I                              3057 3088  DBA              62
 +
    I                              3089 3120  DCA              63
 +
    I                              3121 3152  DDA              64
 +
    I                              3153 3184  DEA              65
 +
    I                              3185 3216  DFA              66
 +
    I                              3217 3248  DGA              67
 +
    I                              3249 3280  DHA              68
 +
    I                              3281 3312  DIA              69
 +
    I                              3313 3344  DJA              70
 +
    I                              3345 3376  DKA              71
 +
    I                              3377 3408  DLA              72
 +
    I                              3409 3440  DMA              73
 +
    I                              3441 3472  DNA              74
 +
    I                              3473 3504  DOA              75
 +
    I                              3505 3536  DPA              76
 +
    I                              3537 3568  DQA              77
 +
    I                              3569 3600  DRA              78
 +
    I                              3601 3632  DSA              79
 +
    I                              3633 3664  DTA              80
 +
    I                              3665 3696  DUA              81
 +
    I                              3697 3728  DVA              82
 +
    I                              3729 3760  DWA              83
 +
    I                              3761 3792  DXA              84
 +
    I                              3793 3824  DYA              85
 +
    I                              3825 3856  DZA              86
 +
    I                              3857 3888  D0A              87
 +
    I                              3889 3920  D1A              88
 +
    I                              3921 3952  D2A              89
 +
    I                              3953 3984  D3A              90
 +
    I                              3985 4016  D4A              91
 +
    I                              4017 4048  D5A              92
 +
    I                              4049 4080  D6A              93
 +
    IINPUTR    NS  01
 +
    I                                  1 2048  DA
 +
    I                              2049 2064  DB                30
 +
    I                              2065 2096  DC                31
 +
    I                              2097 2128  DD                32
 +
    I                              2129 2160  DE                33
 +
    I                              2161 2192  DF                34
 +
    I                              2193 2224  DG                35
 +
    I                              2225 2256  DH                36
 +
    I                              2257 2288  DI                37
 +
    I                              2289 2320  DJ                38
 +
    I                              2321 2352  DK                39
 +
    I                              2353 2384  DL                40
 +
    I                              2385 2416  DM                41
 +
    I                              2417 2448  DN                42
 +
    I                              2449 2480  DZ                43
 +
    I                              2481 2512  DO                44
 +
    I                              2513 2544  DP                45
 +
    I                              2545 2576  DQ                46
 +
    I                              2577 2608  DR                47
 +
    I                              2609 2640  DS                48
 +
    I                              2641 2672  DT                49
 +
    I                              2673 2704  DU                50
 +
    I                              2705 2736  DV                51
 +
    I                              2737 2768  DW                52
 +
    I                              2769 2800  DX                53
 +
    I                              2801 2832  DY                54
 +
    I                              2833 2864  D0                55
 +
    I                              2865 2896  D1                56
 +
    I                              2897 2928  D2                57
 +
    I                              2929 2960  D3                58
 +
    I                              2961 2992  D4                59
 +
    I                              2993 3024  D5                60
 +
    I                              3025 3056  D6                61
 +
    I                              3057 3088  DBA              62
 +
    I                              3089 3120  DCA              63
 +
    I                              3121 3152  DDA              64
 +
    I                              3153 3184  DEA              65
 +
    I                              3185 3216  DFA              66
 +
    I                              3217 3248  DGA              67
 +
    I                              3249 3280  DHA              68
 +
    I                              3281 3312  DIA              69
 +
    I                              3313 3344  DJA              70
 +
    I                              3345 3376  DKA              71
 +
    I                              3377 3408  DLA              72
 +
    I                              3409 3440  DMA              73
 +
    I                              3441 3472  DNA              74
 +
    I                              3473 3504  DOA              75
 +
    I                              3505 3536  DPA              76
 +
    I                              3537 3568  DQA              77
 +
    I                              3569 3600  DRA              78
 +
    I                              3601 3632  DSA              79
 +
    I                              3633 3664  DTA              80
 +
    I                              3665 3696  DUA              81
 +
    I                              3697 3728  DVA              82
 +
    I                              3729 3760  DWA              83
 +
    I                              3761 3792  DXA              84
 +
    I                              3793 3824  DYA              85
 +
    I                              3825 3856  DZA              86
 +
    I                              3857 3888  D0A              87
 +
    I                              3889 3920  D1A              88
 +
    I                              3921 3952  D2A              89
 +
    I                              3953 3984  D3A              90
 +
    I                              3985 4016  D4A              91
 +
    I                              4017 4048  D5A              92
 +
    I                              4049 4080  D6A              93
 +
    IDISPF    NS  02
 +
    I                                  3    3  AID
 +
    I                                  4  83  ID0
 +
    I                                84  163  ID1              20
 +
    I                                164  243  ID2              21
 +
    I                                244  323  ID3              22
 +
    I                                324  403  ID4              23
 +
    I                                404  483  ID5              24
 +
    I                                484  563  ID6              25
 +
    I                                564  643  ID7              26
 +
    I                                644  723  ID8              27
 +
    I                                724  803  ID9              28
 +
 +
 +
      /FREE
 +
            BASE = 2048;
 +
 +
            IF  ONCE  =  ' ';
 +
                EXSR      @INITZ  ;
 +
            ENDIF;
 +
 +
        //  START        TAG
 +
          DOW      @LOOP = @LOOP;
 +
 +
          IF  RTN  = '3';
 +
 +
              IF *INU1;
 +
                KEYA =  SCNKEY;
 +
              ENDIF;
 +
              IF *INU2;
 +
                RRNA =  %DEC(%SUBST(SCNKEY:1:11):11:0);
 +
              ENDIF;
 +
                RTN = '0';
 +
                AID = '1';
 +
            ELSE;
 +
              RTN  = '0';
 +
              READ(E)  DISPF;
 +
          ENDIF;
 +
 +
        //  CF3 EXIT
 +
          IF  AID  = X33;
 +
            LEAVE;
 +
          ENDIF;
 +
 +
        //  CF2 RETURN
 +
          IF  AID  = X32;
 +
            RTN = '1';
 +
            LEAVE;
 +
          ENDIF;
 +
 +
        // CF1 HEX A FIELD
 +
          IF  AID  = X31;
 +
          Y = %LOOKUPLE( CURLOC : B );
 +
          IF Y > 0;
 +
            IF KY(Y) <= '1';
 +
              EXSR      @HXDSP;
 +
              REHEAD  = '1';
 +
              EXSR      @PUTHED;
 +
              REHEAD  = ' ';
 +
            ENDIF;
 +
            ENDIF;
 +
          ENDIF;
 +
 +
        //  CF20 MORE FIELDS
 +
          IF  AID  = XB8;
 +
 +
            LVX  = LVL + 1;
 +
            IF  LV(LVX)  <> *BLANK;
 +
              LVL = LVL +1 ;
 +
 +
              LVW  = LV;
 +
              SCNLV = TEXT500;
 +
              SCNLVL = %EDITC(LVL :'X');
 +
 +
            SCNKEY = *BLANKS;
 +
          IF  *INU1;
 +
                SCNKEY = KEYA;
 +
          ENDIF;
 +
          IF  *INU2;
 +
                SCNKEY = %EDITC(RRNA:'X');
 +
          ENDIF;
 +
 +
              RTN = '3';
 +
              LEAVE;
 +
            ENDIF;
 +
          ENDIF;
 +
 +
      //  CF19 PREVIOUS FIELDS
 +
          IF  AID  = XB7;
 +
 +
            LVX  = LVL - 1;
 +
            IF  LVX    >= 0 ;
 +
              LVL = LVL - 1 ;
 +
 +
              LVW  = LV;
 +
              SCNLV = TEXT500;
 +
              SCNLVL = %EDITC(LVL :'X');
 +
 +
                SCNKEY = *BLANKS;
 +
          IF  *INU1;
 +
                SCNKEY = KEYA;
 +
          ENDIF;
 +
          IF  *INU2;
 +
                SCNKEY = %EDITC(RRNA:'X');
 +
          ENDIF;
 +
 +
              RTN = '3';
 +
              LEAVE;
 +
            ENDIF;
 +
          ENDIF;
 +
 +
          // 1 ENTER  4 ROLL DN  5 ROLL UP
 +
          // F6 = X36  F9 = X39  F11 = X3B
 +
          IF  AID  = '1'or AID = '4' or AID = '5' or
 +
              AID  = X36 or AID = X39 or AID = X3B;
 +
          ELSE;
 +
            MX = 1;        // INVALID KEY
 +
            EXSR  @ERROR;
 +
          ENDIF;
 +
 +
          //      UPDATE MODE
 +
          IF  UPDF    = 'Y';
 +
            UPDDONE = @FALSE;
 +
          // F6
 +
            IF *INU1 AND AID = X36 AND
 +
            (LOP1 = X01 OR LOP1 = X03);
 +
              EXSR @UPD;
 +
              EXCEPT UPDATREC;
 +
              UPDDONE = @TRUE;
 +
            ENDIF;
 +
 +
            IF *INU2 AND AID = X36 AND
 +
            (LOP2 = X01 OR LOP2 = X02);
 +
              EXSR @UPD;
 +
              EXCEPT UPDATREC;
 +
              UPDDONE = @TRUE;
 +
            ENDIF;
 +
 +
          // F9
 +
            IF AID = X39;
 +
              EXSR  @UPD;
 +
              EXCEPT ADDREC;
 +
              UPDDONE = @TRUE;
 +
            ENDIF;
 +
 +
          // F11
 +
            IF *INU1 AND AID = X3B AND
 +
            (LOP1 = X01 OR LOP1 = X03);
 +
              EXCEPT DELREC;
 +
              UPDDONE = @TRUE;
 +
              ENDIF;
 +
 +
            IF *INU2 AND AID = X3B AND
 +
            (LOP2 = X01 OR LOP2 = X02);
 +
              EXCEPT DELREC;
 +
              UPDDONE = @TRUE;
 +
              ENDIF;
 +
 +
            ENDIF;
 +
 +
 +
          IF  RTN = '3' OR UPDDONE = @TRUE;
 +
          ELSE;
 +
            EXSR      @PCKD;
 +
          ENDIF;
 +
 +
 +
        // CONT1  GET A RECORD, KEY FROM DATA
 +
            EXSR      @SETIN;
 +
            EXSR      @GETF ;
 +
            EXSR      @PUTF ;
 +
            EXSR      @KEYIN;
 +
 +
          ENDDO ;
 +
 +
          *INLR = *ON;
 +
 +
      //  @@@@@@@  @INITZ @@@@@@@@@@@@@@@@@@@@@@@@@@
 +
        BEGSR  @INITZ;
 +
                ONCE  =  '1';
 +
                KEYLNA = KEYLNG  ;
 +
                EXSR      @INIT  ;
 +
                EXSR      @GETFLD ;
 +
                EXSR      @GETADD ;
 +
                EXSR      @PUTHED ;
 +
                EXSR      @KEYIN  ;
 +
                INZ  = '1';
 +
                EXSR      @PCKD  ;
 +
                INZ  = ' ';
 +
        ENDSR;
 +
 +
      //  @@@@@@@  @PCKD  @@@@@@@@@@@@@@@@@@@@@@@@@@
 +
 +
          BEGSR  @PCKD ;
 +
 +
            //  CONVERT  KEY DATA
 +
            IF  *INU1 ;
 +
              EXSR  @CVTKEY;
 +
            ENDIF;
 +
            IF  *INU2 ;
 +
              EXSR  @CVTRRN;
 +
            ENDIF;
 +
 +
          ENDSR;
 +
 +
      //  @@@@@@@  @CVTKEY  @@@@@@@@@@@@@@@@@@@@@@@@
 +
 +
          BEGSR  @CVTKEY;
 +
 +
      // EXTRACT THE KEY FIELD DATA FROM THE INCOMING STRING
 +
 +
        // FOR EACH KEY FIELD, CHECK IF FIELD WAS MODIFIED, AND IF SO MOVE
 +
        // THE MODIFIED DATA INTO THE COMPOSITE KEY
 +
 +
        K1 = 0;
 +
        K2 = 0;
 +
        W  = 1;
 +
 +
          FOR  Y  = 1  TO NUMKEY ;
 +
 +
      //  MOVE A KEY FIELDS DATA FROM ID ARRAY (SCREEN) TO K ARRAY (KEY FIELDS)
 +
 +
      //  GET SIZE OF FIELD IN BYTES
 +
          IF T(Y)  =  'A';  // ALPHA DATA
 +
          K = ' ';
 +
          K1 = 1;
 +
          K2 = Q(Y);
 +
          ELSE;
 +
          K  = '0';
 +
          K1 =  1;
 +
          K2 = C(Y);
 +
          ENDIF;
 +
 +
      // IF WHOLE KEY INIT WAS REQUESTED BYPASS THE EXTRACT
 +
          IF  INZ  = '1' ;
 +
            KW  = *BLANK;
 +
            EXSR      @PCKMOV;
 +
            ITER;
 +
          ENDIF;
 +
 +
          X  =  1;
 +
 +
          DOW  @LOOP = @LOOP;
 +
 +
      //  NXTSBA
 +
          X  = %LOOKUP(SBA : ID : X );
 +
          IF X = 0;
 +
            LEAVE;
 +
          ENDIF;
 +
 +
      // IS THIS THE FIELD?  CHECK THE BUFFER ADDRESS
 +
        X = X +1;
 +
        IF  B(Y)  <>  %SUBST(IDA : X :2);
 +
          ITER;
 +
        ENDIF;
 +
 +
      //  FOUND A MTD FOR THIS FIELD
 +
        X =  X + 2;
 +
 +
      //  CHECK IF FIELD WAS CLEARED ONLY
 +
        IF  ID(X) = SBA;
 +
            EXSR      @PCKMOV;
 +
            LEAVE ;
 +
        ENDIF;
 +
 +
      //  IF FIELD HAS DECIMALS BUMP X
 +
          IF (T(Y) = 'S' OR T(Y) = 'P' OR T(Y) = 'B') AND
 +
              P(Y) > 0;
 +
              X = X + 1;
 +
          ENDIF;
 +
 +
      //  CHECK IF ONLY BLANKS RETURNED
 +
        IF    %SUBST(IDA : X :K2) = *BLANKS;
 +
            EXSR      @PCKMOV;
 +
            LEAVE;
 +
        ENDIF;
 +
 +
      // EXTRACT THE DATA FROM THE INCOMING STRING
 +
        X1  = X;
 +
        FOR X2  =  1 TO  K2 ;
 +
 +
          IF ID(X1) < ' ';
 +
      // TRAP NULLS CAUSED BY FLD EXIT
 +
            EXSR      @PCKMOV;
 +
            LEAVE;
 +
          ENDIF;
 +
 +
        K(X2)  =  ID(X1);
 +
        X1    =  X1 +1;
 +
        ENDFOR;
 +
 +
        // CONSTRUCT THE ACTUAL KEY WITH PACKED DATA IF REQUIRED
 +
        // INTO ARRAY KW
 +
          EXSR      @PCKMOV;
 +
          LEAVE;
 +
        ENDDO;
 +
 +
        ENDFOR;
 +
 +
        //
 +
          KEYA  = KW;
 +
          CLEAR KW;
 +
        ENDSR ;
 +
 +
      //  @@@@@@@  @CVTRRN  @@@@@@@@@@@@@@@@@@@@@@@@
 +
 +
          BEGSR  @CVTRRN;
 +
 +
        //  RRN
 +
 +
          NUM11 = 0;
 +
 +
          DOW  @LOOP = @LOOP;  //  NOT REALLY A LOOP(SIMULATES GOTO)
 +
 +
      // GET THE FIRST SBA
 +
          X = 1;
 +
          X  = %LOOKUP(SBA : ID : X );
 +
          IF X = 0;
 +
          LEAVE;
 +
          ENDIF;
 +
 +
      // CHECK THE BUFFER ADDRESS MATCHES THE EXPECTED FIELD
 +
        X = X +1;
 +
        IF  B(1)  <>  %SUBST(IDA : X :2);
 +
          ITER;
 +
        ENDIF;
 +
 +
      //  FOUND A MTD FOR RRN  FIELD
 +
        X = X +2;
 +
 +
      //CHECK IF FIELD WAS CLEARED ONLY
 +
        IF  ID(X) = SBA;
 +
            LEAVE;
 +
        ENDIF;
 +
 +
      //  CHECK IF ONLY BLANKS RETURNED
 +
        IF    %SUBST(IDA : X :11) = *BLANKS;
 +
            LEAVE;
 +
        ENDIF;
 +
 +
 +
        //  WRK11  OVERLAYS NUM11
 +
        WRK11 = %SUBST(IDA : X :11);
 +
 +
        LEAVE;
 +
        ENDDO;
 +
 +
 +
        RRNA = NUM11;
 +
        IF RRNA < 0;
 +
        RRNA =  1;
 +
        ENDIF;
 +
 +
        ENDSR;
 +
 +
      //  @@@@@@@  @PCKMOV  @@@@@@@@@@@@@@@@@@@@@@@@
 +
 +
        BEGSR  @PCKMOV;
 +
      //
 +
      //  CONVERT  KEY DATA
 +
      //  SET START POSN IN KEY USING OFFSET IN R
 +
          X1 = %LOOKUP(N(Y) : N );
 +
          W = R(X1) + 1;
 +
 +
        // ALPHA
 +
          IF  T(Y) = 'A';
 +
          X1  = 1;
 +
          FOR  Z = W  TO W + Q(Y);
 +
            %SUBST(KW : Z : 1) =  K(X1);
 +
            X1 = X1 + 1;
 +
          ENDFOR;
 +
          ENDIF;
 +
 +
        // NUMERIC FIELD
 +
        // RIGHT  ADJUST NUMERIC DATA ,STRIP - . ,CONVERT BLANKS
 +
          IF (T(Y) = 'S' OR T(Y) = 'P' OR T(Y) = 'B');
 +
          NU = '0';
 +
 +
          Z1 = 60;
 +
          FOR Z  =  K2  DOWNTO K1;
 +
 +
          IF K(Z) = '.' OR K(Z) = '-' OR K(Z) = '$';
 +
          ITER;
 +
          ENDIF;
 +
 +
          IF K(Z) = ' ' ;
 +
          NU(Z1) = '0';
 +
          ELSE;
 +
          NU(Z1) = K(Z);
 +
          ENDIF;
 +
 +
            Z1 = Z1 -1;
 +
          ENDFOR;
 +
 +
          ENDIF;
 +
 +
      // SIGNED FIELDS  (END POSN = OFFSET + SIZE)
 +
        IF T(Y)  = 'S';
 +
          NUS = 0;
 +
          FOR VX = 1 TO 60;
 +
            NUSA = %TRIM(NUSA) + NU(VX);
 +
          ENDFOR;
 +
        %SUBST(KW : W : Q(Y)) = %SUBST(NUSA: 61 -Q(Y));
 +
 +
        ENDIF;
 +
 +
      //  PACKED FIELDS
 +
          IF    T(Y)  =  'P';
 +
          NUSA= *BLANKS;
 +
          FOR VX = 1 TO 60;
 +
            NUSA = %TRIM(NUSA) + NU(VX);
 +
          ENDFOR;
 +
          NUP    = %DEC(NUSA : 60 : 0);
 +
 +
        %SUBST(KW : W : Q(Y))  =  %SUBST(NUPA: 61 -Q(Y));
 +
 +
        ENDIF;
 +
 +
      //  BINARY FIELDS
 +
        IF  T(Y) =  'B';
 +
 +
        IF  Q(Y) = 2 ;
 +
          BY2  = NU(1) + NU(2);
 +
          %SUBST(KW : W : 2)  =  BY2;
 +
        ENDIF;
 +
 +
        IF  Q(Y) = 4 ;
 +
          BY4  = NU(1) + NU(2) + NU(3) + NU(4);
 +
          %SUBST(KW : W : 4)  =  BY4;
 +
        ENDIF;
 +
 +
        ENDIF;
 +
 +
      ENDSR;
 +
 +
 +
      //  @@@@@@@  SETIN  @@@@@@@@@@@@@@@@@@@@@@@@@
 +
          BEGSR      @SETIN;
 +
 +
        //  SET the FFR indicators to get the Input buffer somewhat aligned with the
 +
        //  actual data.  RPG is somewhat tolerant to a difference between the Ispecs
 +
        //  and the actual file size but it can fail on big differences.
 +
        //  INCREMENT OF 32 BYTES
 +
          SZ(1)  = BASE + 16;
 +
          SZ(2)  = SZ(1) + 16;
 +
 +
          *IN30 = *ON;
 +
            IF (RLEN > SZ(2)) ;
 +
            *IN31  = *ON;
 +
            ENDIF;
 +
 +
          FOR X = 3 TO 64;
 +
          SZ(X) = SZ(X-1) + 32;
 +
            IF (RLEN > SZ(X)) ;
 +
            *IN(29+X) = *ON;
 +
            ENDIF;
 +
          ENDFOR;
 +
        ENDSR;
 +
 +
 +
        //@@@@@@@@@@@@@@@@@  @GETF  @@@@@@@@@@@@@@@@@
 +
          BEGSR  @GETF;
 +
      //  GET A DATA RECORD
 +
          IF  (*INU1);
 +
          IF  AID  = '1' OR AID  = X36 OR
 +
              AID  = X39 OR AID  = X3B ;
 +
            SETLL(E) KEYA  INPUTK;
 +
            READ(E)      INPUTK;
 +
              IF %EOF;
 +
              SETLL(E) KEYA  INPUTK;
 +
              READP(E)      INPUTK;
 +
              ENDIF;
 +
          ENDIF;
 +
 +
          IF  AID  = '4';
 +
            READP(E)  INPUTK;
 +
          ENDIF;
 +
 +
          IF  AID  = '5';
 +
            READ(E)  INPUTK;
 +
          ENDIF;
 +
 +
            IF  %ERROR;
 +
            SETLL(E) KEYA  INPUTK;
 +
            READ(E)      INPUTK;
 +
            MX = 7;
 +
                        EXSR      @ERROR;
 +
                        EXSR      @PUTF ;
 +
                        EXSR      @KEYIN;
 +
            ENDIF;
 +
 +
            KEYA = LKY;
 +
 +
 +
            CLEAR KW;
 +
            KW  = LKY;
 +
 +
          ENDIF;
 +
 +
          IF  (*INU2);
 +
          IF  AID  = '1';
 +
            CHAIN(E)  RRNA  INPUTR;
 +
            IF  %ERROR;
 +
              SETLL(E) RRNA  INPUTR;
 +
              READP(E)      INPUTR;
 +
            ENDIF;
 +
          ENDIF;
 +
 +
          IF  AID  = X36;
 +
            CHAIN(E)  RRNA  INPUTR;
 +
          ENDIF;
 +
 +
          IF  AID  = '4';
 +
            READP(E)  INPUTR;
 +
          ENDIF;
 +
 +
          IF  AID  = '5' OR AID = X3B;
 +
            READ(E)  INPUTR;
 +
          ENDIF;
 +
 +
          IF  AID  = X39;
 +
            SETLL(E) *HIVAL INPUTR;
 +
            READP(E)  INPUTR;
 +
          ENDIF;
 +
 +
          IF %ERROR;
 +
            CHAIN  1  INPUTR;
 +
            MX = 7;
 +
            EXSR      @ERROR;
 +
            EXSR      @PUTF ;
 +
            EXSR      @KEYIN;
 +
          ENDIF;
 +
          ENDIF;
 +
 +
          ENDSR;
 +
 +
 +
        //@@@@@@@@@@@@@@@@@  @PUTF  @@@@@@@@@@@@@@@@@
 +
          BEGSR  @PUTF;
 +
 +
              SELECT;
 +
                WHEN  *INU1;
 +
                RRN = RN1;
 +
                WHEN  *INU2;
 +
                RRN = RN2;
 +
              ENDSL;
 +
        // IF GOT RECORDS WRITE DATA TO THE DISPLAY
 +
 +
            NEWRU  = '1';
 +
            WRTRRN = '1';
 +
            RU    = *ALLX'00';
 +
            CLEAR  RU;        //  initialise Request Unit  255 bytes max
 +
 +
          IF RRN > 0    ;
 +
            FOR  XX = 1 TO      NUMFKY; //NUMBER OF DATA ELEMENTS (FLD AND KEY)
 +
 +
            IF NEWRU = '1';
 +
              NEWRU  = '0';
 +
              RU  = ESC + WTD + X20 + X00;
 +
            ENDIF;
 +
 +
            IF WRTRRN = '1';
 +
              WRTRRN = '0';
 +
              RU  = RU + SBA + RBA ;
 +
              RU = RU + %TRIM(%EDITC(RRN:'Z'));
 +
            ENDIF;
 +
 +
        // BUFFER ADDRESS
 +
            RU  = RU + SBA + B(XX);
 +
 +
        //  PROCESS ALPHA DATA TYPE
 +
            IF  T(XX) = 'A'  OR T(XX) = 'T'  OR T(XX) = 'Z' OR
 +
                T(XX) = 'L';
 +
 +
              STRX = S(XX);
 +
              ENDX = E(XX);
 +
 +
              IF V(XX) = 'Y';  //VARYING
 +
              VX  = S(XX);
 +
              HX2  = D(VX) + D(VX+1);
 +
              STRX  = S(XX) + 2 ;
 +
              ENDX  = S(XX) + BIN;
 +
              ENDIF;
 +
 +
              FOR Y = STRX  TO ENDX ;
 +
                IF D(Y) >= ' ';
 +
                RU = RU + D(Y);
 +
                ELSE;
 +
                RU = RU + X1F ;  //IF NOT DISPLAYABLE REPLACE WITH X'1F'
 +
                ENDIF;
 +
              ENDFOR;
 +
            ENDIF;
 +
 +
        //  PROCESS SIGNED DATA TYPE (not the RRN field)
 +
            IF  T(XX) = 'S' and KY(XX) <> '3';
 +
              NUSA =  *ALL'0';
 +
              WRV  =  *ALLX'00';
 +
              CLEAR WRV;
 +
              FOR Y = S(XX) TO E(XX);
 +
                IF D(Y) >= XD0;
 +
                WRV    =  WRV + D(Y);
 +
                ENDIF;
 +
              ENDFOR;
 +
              EVAL  NUSA = %SUBST(NUSA : 1 : 60 - %LEN(WRV)) + WRV;
 +
              CLEAR WRU;
 +
              WRU = %TRIM(WRU) + %EDITW(NUS :WRSWRD);
 +
              IF  P(XX) > 0;
 +
                RU  = RU  +
 +
                    %SUBST(WRU :61-C(XX): C(XX)-P(XX)) + '.' +
 +
                    %SUBST(WRU :61-P(XX))    ;
 +
              ELSE;
 +
                RU  = RU  +
 +
                    %SUBST(WRU :61-C(XX));
 +
              ENDIF;
 +
            ENDIF;
 +
 +
 +
        //  PROCESS SIGNED DATA TYPE (the RRN field)
 +
            IF  T(XX) = 'S' and KY(XX) =  '3';
 +
              RRN = RN2;
 +
              RU = RU + %TRIM(%EDITC(RRN:'X'));
 +
            ENDIF;
 +
 +
        //  PROCESS PACKED DATA TYPE
 +
            IF  T(XX) = 'P';
 +
              NUPA =  *ALLX'00';
 +
              WRV  =  *ALLX'00';
 +
              CLEAR WRV;
 +
              FOR Y = S(XX) TO E(XX);
 +
                WRV    =  WRV + D(Y);
 +
              ENDFOR;
 +
 +
              IF  %BITAND(D(E(XX)) :X0F) = X0F OR
 +
                    %BITAND(D(E(XX)) :X0D) = X0D;
 +
 +
                EVAL  NUPA = %SUBST(NUPA : 1 : 60 - %LEN(WRV)) + WRV;
 +
                CLEAR WRX;
 +
                WRX = %TRIM(WRX) + %EDITW(NUP :WRXWRD);
 +
                IF  P(XX) > 0;
 +
                RU  = RU  +
 +
                      %SUBST(WRX :64-C(XX): C(XX)-P(XX)) + '.' +
 +
                      %SUBST(WRX :64-P(XX))    ;
 +
                ELSE;
 +
                RU  = RU  +
 +
                      %SUBST(WRX :64-C(XX));
 +
                ENDIF;
 +
              ELSE;
 +
                // PACKED FIELD IN ERROR
 +
                RU = RU + X1F;
 +
              ENDIF;
 +
 +
            ENDIF;
 +
 +
        //  PROCESS BINARY DATA TYPE
 +
            IF  T(XX) = 'B';
 +
 +
            ST = S(XX);
 +
              CLEAR NUSA;
 +
              IF  Q(XX) = 2;
 +
              BY2  = D(ST) + D(ST+1);
 +
              NUS  = BIN2;
 +
              ENDIF;
 +
              IF  Q(XX) = 4;
 +
              BY4  = D(ST) + D(ST+1)+ D(ST+2) + D(ST+3);
 +
              NUS  = BIN4;
 +
              ENDIF;
 +
 +
              WRU =  %EDITW(NUS :WRSWRD);
 +
              IF  P(XX) > 0;
 +
                RU  = RU  +
 +
                    %SUBST(WRU :61-C(XX): C(XX)-P(XX)) + '.' +
 +
                    %SUBST(WRU :61-P(XX))    ;
 +
              ELSE;
 +
                RU  = RU  +
 +
                    %SUBST(WRU :61-C(XX));
 +
              ENDIF;
 +
            ENDIF;
 +
 +
 +
        //  PROCESS FLOAT  DATA TYPE
 +
            IF  T(XX) = 'F';
 +
 +
            ST = S(XX);
 +
 +
              IF  Q(XX) = 4;
 +
              FL4  = D(ST) + D(ST+1)+ D(ST+2) + D(ST+3);
 +
              FLT14 =  %EDITFLT(FLT4);
 +
                RU  = RU  + FLT14;
 +
              ENDIF;
 +
 +
              IF  Q(XX) = 8;
 +
              FL8  = D(ST) + D(ST+1)+ D(ST+2) + D(ST+3) +
 +
                      D(ST+4) + D(ST+5)+ D(ST+6) + D(ST+7);
 +
              FLT23 =  %EDITFLT(FLT8);
 +
                RU  = RU  + FLT23;
 +
              ENDIF;
 +
 +
            ENDIF;
 +
 +
 +
          //  SEND A REQUEST UNIT IF GOT ENOUGH DATA
 +
 +
            IF  %LEN(RU) + L(XX + 1) >= 200;
 +
              RU  =  RU + X20;
 +
              BIN  =  %LEN(RU);
 +
              OUTLEN  =  HX2;
 +
              INLEN  =  X000;
 +
              FNC    =  SND;
 +
              A      = RU;
 +
              EXCEPT  DATAO;
 +
              NEWRU  = '1';
 +
              RU    = *ALLX'00';
 +
              CLEAR  RU;
 +
            ENDIF;
 +
 +
            ENDFOR;
 +
          ENDIF;
 +
 +
            IF  %LEN(RU) > 5 AND %LEN(RU) < 250;
 +
              RU  =  RU + X20;
 +
              BIN  =  %LEN(RU);
 +
              OUTLEN  =  HX2;
 +
              INLEN  =  X000;
 +
              FNC    =  SND;
 +
              A      = RU;
 +
              EXCEPT  DATAO;
 +
            ENDIF;
 +
          ENDSR;
 +
 +
 +
        // @@@@@@@@@@@@@@@    ROWINC  @@@@@@@@@@@@@@@
 +
 +
        // INCREMENT THE ROW
 +
          BEGSR    @ROWINC;
 +
          ROW = ROW + 2;
 +
          IF  ROW > 20;
 +
            MX = 3;
 +
          ENDIF;
 +
          ENDSR;
 +
 +
 +
 +
        // @@@@@@@@@@@@@@@    GETFLD  @@@@@@@@@@@@@@@
 +
 +
        // LOAD FIELD DESCRIPTION ARRAYS
 +
          BEGSR    @GETFLD;
 +
          MX = 0;
 +
          X  = 0;
 +
 +
          IF  (*INU2 = *ON);
 +
          // IF NON KEYED ACCESS SET UP A FIELD TO SHOW THE RRN
 +
            N(1) =  'RRN';
 +
            T(1) =  'S'  ;
 +
            C(1) =  11  ;
 +
            P(1) =  0    ;
 +
            S(1) =  0    ;
 +
            E(1) =  0    ;
 +
            L(1) =  12  ;
 +
            I(1) = X4F06 ;
 +
            KY(1)= '3'  ;
 +
            X    = 1    ;
 +
          ENDIF;
 +
 +
          SCRST = *BLANK;
 +
          SCRSTN = *BLANK;
 +
 +
          LVL  = %DEC(SCNLVL : 5:0);
 +
 +
        TEXT500 = SCNLV ;
 +
        LV      = LVW;
 +
 +
        IF  LVL <> 0;
 +
          SCRST = LV(LVL);
 +
        ENDIF;
 +
 +
          SETLL 1 QWHDRFFD ;
 +
 +
          DOW  @LOOP  = @LOOP;
 +
        //  REREAD  TAG
 +
          READ    QWHDRFFD;
 +
          IF %EOF;
 +
            LEAVE;
 +
          ENDIF;
 +
 +
        //  SELECT OR OMIT
 +
          IF  ALL  <> '1';
 +
          IF  ALL  =  'S' AND WHDFTL = 0; // USING WHDFTL FOR KEY FIELDS
 +
            IF  WHFIOB  <>  'S';
 +
              ITER;
 +
            ENDIF;
 +
          ENDIF;
 +
          IF  ALL  =  'O' AND WHDFTL = 0; // USING WHDFTL FOR KEY FIELDS
 +
            IF  WHFIOB  =  'O';
 +
              ITER;
 +
            ENDIF;
 +
          ENDIF;
 +
          ENDIF;
 +
 +
        //  FIND THE FIRST FIELD TO BE SHOWN (FOR MULTI PAGE FORMATS)
 +
          IF  WHDFTL  <> 0 ;
 +
            ELSE;
 +
            IF SCRST <> ' ' AND SCRSTN = ' ';
 +
              IF WHFLDE =  SCRST;
 +
                SCRSTN = '1';    //  FOUND THE START
 +
              ELSE;
 +
                ITER;
 +
              ENDIF;
 +
            ENDIF;
 +
          ENDIF;
 +
 +
 +
          X =  X  + 1;
 +
        // CHECK FOR KEY FIELDS,WILL BE USED TO PLACE THEM IN FRONT
 +
          IF  WHDFTL  <>  0;
 +
              KY(X) = '1';
 +
              WX    = WHDFTL ;
 +
              KE(WX) = WHFLDE;
 +
              IF  NUMKEY <  WHDFTL;
 +
                NUMKEY = WHDFTL;
 +
              ENDIF;
 +
          ENDIF;
 +
 +
            N(X) =  WHFLDE ;              //    NAME
 +
            T(X) =  WHFLDT ;              //    TYPE
 +
            V(X) =  WHVARL ;              //    VARYING
 +
            C(X) =  WHFLDD ;              //    DEC DIGITS
 +
            P(X) =  WHFLDP ;              //    DEC PREC
 +
            S(X) =  WHFOBO ;              //    START
 +
            Q(X) =  WHFLDB ;              //    BTYES
 +
            E(X) =  WHFOBO + WHFLDB -1 ;  //  END
 +
 +
            IF T(X) =  'F' ;              //    FLOAT
 +
 +
              I(X) = FFA1 + FFA2;          //  SCRN FIELD FORMAT ALPHA
 +
              L(X)  = 14;
 +
              IF Q(X) = 8;
 +
              L(X)  = 23;
 +
              ENDIF;
 +
 +
            ELSE;
 +
              IF  WHFLDD  <> 0 ;
 +
              IF  WHFLDP  <> 0 ;
 +
                L(X) =  WHFLDD +  2  ;      //  LENGTH
 +
              ELSE;
 +
                L(X) =  WHFLDD +  1  ;      //  LENGTH
 +
              ENDIF;
 +
 +
                I(X) = FFN1 + FFN2;        //  SCRN FIELD FORMAT NUMERIC
 +
 +
              ELSE;
 +
                L(X) =    WHFLDB  ;
 +
                I(X) = FFA1 + FFA2;        //  SCRN FIELD FORMAT ALPHA
 +
              ENDIF;
 +
            ENDIF;
 +
 +
        ENDDO;
 +
        //  NUMBER OF FIELDS
 +
        NUMFLD = X ;
 +
 +
      //  MAKE ROOM FOR KEYS
 +
          IF  NUMKEY  >  0 ;
 +
          X1  = NUMKEY  + NUMFLD;
 +
 +
          FOR  X =  NUMFLD DOWNTO 1;
 +
              KY(X1) = KY(X) ;
 +
              L(X1)  = L(X)  ;
 +
              I(X1)  = I(X)  ;
 +
              N(X1)  = N(X)  ;
 +
              T(X1)  = T(X)  ;
 +
              V(X1)  = V(X)  ;
 +
              C(X1)  = C(X)  ;
 +
              P(X1)  = P(X)  ;
 +
              S(X1)  = S(X)  ;
 +
              E(X1)  = E(X)  ;
 +
              Q(X1)  = Q(X)  ;
 +
              X1    = X1 - 1;
 +
          ENDFOR;
 +
 +
          //  PUT KEY FIELDS AT TOP
 +
          OFF  = 0;
 +
          FOR  X =  1 TO NUMKEY;
 +
          X1 = %LOOKUP(KE(X) : N : NUMKEY+1);
 +
 +
          KY(X) = '2';
 +
          L(X)  = L(X1);
 +
          I(X)  = I(X1);  // FIELD FMT
 +
          SELECT;                // INPUT ENABLE
 +
            WHEN  I(X) = X6000;
 +
                  I(X) = X4800;
 +
            WHEN  I(X) = X6706;
 +
                  I(X) = X4F06;
 +
          ENDSL;
 +
            N(X) =  N(X1);
 +
            T(X) =  T(X1);
 +
            V(X) =  V(X1);
 +
            C(X) =  C(X1);
 +
            P(X) =  P(X1);
 +
            S(X) =  S(X1);
 +
            E(X) =  E(X1);
 +
            Q(X) =  Q(X1);
 +
            R(X) =  OFF;
 +
            OFF  =  OFF + Q(X1);
 +
          ENDFOR;
 +
 +
        ENDIF;
 +
      //  NUMBER OF FIELDS AND KEYS
 +
        NUMFKY = NUMFLD  +  NUMKEY;
 +
 +
        ENDSR;
 +
 +
 +
        // @@@@@@@@@@@@@@@    GETADD  @@@@@@@@@@@@@@@
 +
 +
        // LOAD FIELD BUFFER ADDRESSES
 +
          BEGSR    @GETADD;
 +
          MX = 0;
 +
          X  = 0;
 +
          ROW = 3;
 +
          COL = 1;
 +
 +
          FOR X = 1 TO NUMFKY;
 +
 +
        // IF FINISHED WITH THE KEY FIELDS
 +
        //  INC  ROW FOR 1ST DATA FIELD
 +
          IF KEYSOK = ' ' ;
 +
          IF KY(X) = ' ' OR KY(X) = '1';
 +
            KEYSOK = '1' ;
 +
            ROW    = ROW + 2;
 +
            COL    = 1;
 +
          ENDIF;
 +
          ENDIF;
 +
 +
        //  SET THE BUFFER ADD ON THE LARGER OF THE FIELD TEXT OR THE FIELD SIZE
 +
          LENDSC  = %LEN(%TRIM(N(X)));
 +
          LENWRK  =  L(X);
 +
          IF LENDSC > L(X);
 +
            LENWRK = LENDSC;
 +
          ENDIF;
 +
            LENWRK = LENWRK + 2;
 +
 +
        //  TRAP FIELDS THAT OVERFLOW
 +
            ROW  = ROW  + XROW;
 +
            XROW = %DIV(LENWRK : 80);
 +
 +
            IF (COL + LENWRK) > 78;
 +
              EXSR @ROWINC;
 +
                IF MX = 3;
 +
                X= X-1;
 +
                NUMFKY = X;
 +
                LEAVE;
 +
                ENDIF;
 +
              COL = 1;
 +
            ENDIF;
 +
 +
        // INC COL. FOR FIELD START
 +
          CLEAR  B(X);
 +
          BIN  = ROW;
 +
          B(X) =  %TRIM(B(X)) + HX1;
 +
          BIN  = COL + 1;
 +
          B(X) =  %TRIM(B(X)) + HX1;
 +
 +
        // INC COL. FOR NEXT FIELD
 +
        COL = COL + LENWRK;
 +
            IF COL > 78;
 +
              EXSR @ROWINC;
 +
                IF MX = 3;    // NO ROOM FOR THE FIELD
 +
                X= X-1;
 +
                NUMFKY = X;
 +
                LEAVE;
 +
                ENDIF;
 +
              COL = 1;
 +
            ENDIF;
 +
 +
          ENDFOR;
 +
 +
        //  FIELD LEVEL
 +
          LVX      = LVL + 1;
 +
          LV(LVX)  = N(X);
 +
 +
        ENDSR;
 +
 +
 +
        // @@@@@@@@@@@@@@@    PUTHED  @@@@@@@@@@@@@@@
 +
 +
        //  PUT FIELD HEADINGS
 +
          BEGSR    @PUTHED;
 +
 +
 +
            NEWRU  = '1';
 +
 +
            RU    = *ALLX'00';
 +
            CLEAR  RU;                  //  initialise Request Unit  255 bytes max
 +
            FOR  XX = 1 TO      NUMFKY; //NUMBER OF DATA ELEMENTS (FLD AND KEY)
 +
 +
            IF NEWRU = '1';
 +
              NEWRU  = '0';
 +
              RU  = ESC + WTD + X20 + X00;
 +
            ENDIF;
 +
 +
            RU = RU + SBA;
 +
            BIN = 0;
 +
              // CONVERT DATA BUFADR TO HEADING BUFADR
 +
            HX1 = %SUBST(B(XX) :1:1);
 +
            BIN = BIN - 1;
 +
            RU  = RU + HX1;
 +
 +
            IF  REHEAD = '1'; // ON REDISPLAY OVERRIDE THE ATTR
 +
              BIN = 0;
 +
              HX1 = %SUBST(B(XX) :2:1);
 +
              BIN = BIN -1 ;
 +
              RU  = RU + HX1;
 +
            ELSE;
 +
              RU  = RU + %SUBST(B(XX) :2);
 +
            ENDIF;
 +
 +
            RU = RU + ATC ;
 +
 +
        //  LONG NUMBER FIELDS ,RIGHT ADJUST THE FIELD HEADINGS
 +
            LENDSC  = %LEN(%TRIM(N(XX)));
 +
            IF  T(XX) <> 'A' AND  LENDSC <  (L(XX) -1);
 +
            FOR Y = 1 TO (L(XX) -(LENDSC +1));
 +
              RU = RU + ' ';
 +
            ENDFOR;
 +
            ENDIF;
 +
 +
            RU = RU + %TRIM(N(XX));
 +
 +
              IF %LEN(RU) >= 200;
 +
              BIN    = %LEN(RU);
 +
              OUTLEN = HX2;
 +
              INLEN  = X000;
 +
              FNC    = SND;
 +
              A      = RU;
 +
              EXCEPT DATAO;
 +
              NEWRU  = '1';
 +
              RU    = *ALLX'00';
 +
              CLEAR  RU;
 +
              ENDIF;
 +
 +
            ENDFOR;
 +
 +
              IF %LEN(RU) >  5 AND %LEN(RU) <  200;
 +
              BIN    = %LEN(RU);
 +
              OUTLEN = HX2;
 +
              INLEN  = X000;
 +
              FNC    = SND;
 +
              A      = RU;
 +
              EXCEPT DATAO;
 +
              ENDIF;
 +
 +
          IF REHEAD <> '1';
 +
        //  FORMAT FIELDS
 +
 +
 +
            NEWRU  = '1';
 +
            RU    = *ALLX'00';
 +
            CLEAR  RU;                  //  initialise Request Unit  255 bytes max
 +
            FOR  XX = 1 TO      NUMFKY; //NUMBER OF DATA ELEMENTS (FLD AND KEY)
 +
 +
            IF NEWRU = '1';
 +
              NEWRU  = '0';
 +
              RU  = ESC + WTD + X20 + X00;
 +
            ENDIF;
 +
 +
            RU = RU + SBA +B(XX)+SF + I(XX);
 +
 +
            IF KY(XX) = '1' OR KY(XX) = '2' OR KY(XX) = '3';
 +
              RU = RU + X25;
 +
            ELSE;
 +
              RU = RU + X26;
 +
            ENDIF;
 +
 +
            BIN =  L(XX);
 +
            RU  = RU + HX2;
 +
 +
          // LENGTH OF INPUT FIELDS
 +
            LENF  = LENF + L(XX) + 3;
 +
 +
 +
              IF %LEN(RU) >= 200;
 +
              BIN    = %LEN(RU);
 +
              OUTLEN = HX2;
 +
              INLEN  = X000;
 +
              FNC    = SND;
 +
              A      = RU;
 +
              EXCEPT DATAO;
 +
              NEWRU  = '1';
 +
              RU    = *ALLX'00';
 +
              CLEAR  RU;
 +
              ENDIF;
 +
 +
          ENDFOR;
 +
 +
      //  PUT LAST R/U
 +
              IF %LEN(RU) >  5 AND %LEN(RU) <  200;
 +
              BIN    = %LEN(RU);
 +
              OUTLEN = HX2;
 +
              INLEN  = X000;
 +
              FNC    = SND;
 +
              A      = RU;
 +
              EXCEPT DATAO;
 +
              ENDIF;
 +
 +
        //INC BUFFER ADDRESS FOR ALL FIELDS FOR DATA PUT
 +
            FOR  XP = 1 TO      NUMFKY; //NUMBER OF DATA ELEMENTS (FLD AND KEY)
 +
            HX2  = B(XP);
 +
            BIN  = BIN + 1;
 +
            B(XP) = HX2;
 +
            ENDFOR;
 +
          ENDIF;
 +
 +
        ENDSR;
 +
 +
      //  @@@@@@@  INIT  @@@@@@@@@@@@@@@@@@@@@@@@@
 +
          BEGSR        @INIT;
 +
 +
        CLEAR  KW;
 +
 +
        //  UPDATE
 +
          IF  UPDF  = 'Y';
 +
                FFA1 = X40;
 +
                FFN1 = X47;
 +
          ELSE;
 +
                FFA1 = X60;
 +
                FFN1 = X67;
 +
          ENDIF;
 +
 +
          SELECT;
 +
          WHEN  *INU1 = '1';
 +
                FILE  =  F1 ;
 +
                LIB  =  L1 ;
 +
                MBR  =  M1 ;
 +
                RCDL  =  R1 ;
 +
                ACCTP =  A1 ;
 +
          WHEN  *INU2 = '1';
 +
                FILE  =  F2 ;
 +
                LIB  =  L2 ;
 +
                MBR  =  M2 ;
 +
                RCDL  =  R2 ;
 +
                ACCTP =  A2 ;
 +
          ENDSL;
 +
            RLEN    =  RCDL  ;
 +
            RLENTH  =  %EDITC(RLEN: 'X') ;
 +
            LENF    =  0    ;
 +
 +
 +
        // Control commands and data are constructed into RUs Request UNITS
 +
        // Each RU is 256 bytes max size.
 +
        // Construct and send as many RUs as needed to format the display.
 +
            RU    = *ALLX'00';
 +
            CLEAR  RU;        //  initialise Request Unit  255 bytes max
 +
            RU  = CLRWTD ;
 +
          //set up the screen headings
 +
            BIN = 1;    // set ROW to 1
 +
            RW  = HX1;
 +
            BIN = 2;    // set COL to 2
 +
            CL  = HX1;
 +
            RU  = RU + SBA + RW + CL + X22 + %TRIM(LIB) + '/' + %TRIM(FILE);
 +
            RU  = RU + ' Mbr ' + %TRIM(MBR) + ' Rcdl ' + %EDITC(RLEN  : 'Z') ;
 +
            RU  = RU + ' RRN '  ;
 +
            BIN = %len(RU) -4;
 +
            RBA = RW + HX1 ;  // address of the RRN field
 +
            RU  = RU + SBA + RBA + '          ';
 +
 +
      // FUNCTION KEYS
 +
            BIN  = 23;
 +
            RW  = HX1;
 +
            BIN  = 02;
 +
            CL  = HX1;
 +
            IF  UPDF = 'Y';  //  UPDATE IS ON
 +
            RU  = RU + SBA + RW + CL + %TRIM(CNS(2));
 +
            ELSE;
 +
            RU  = RU + SBA + RW + CL + %TRIM(CNS(1));
 +
            ENDIF;
 +
 +
        //  THIS IS A SEND ONLY FUNCTION
 +
          FNC    = SND;
 +
          CLEAR A;
 +
          A      = RU;
 +
          BIN2    = %LEN(RU);
 +
          OUTLEN  = BY2;
 +
          INLEN  = x000;
 +
 +
          EXCEPT    DATAO;
 +
 +
        ENDSR;
 +
 +
 +
      //  @@@@@@@  KEYIN  @@@@@@@@@@@@@@@@@@@@@@@@@
 +
        BEGSR  @KEYIN;
 +
      // ISSUE A READ FROM DISPLAY
 +
          FNC = SNR;
 +
          BIN2  = 8;
 +
          OUTLEN = BY2;
 +
          IPL = LENF + 34;
 +
          BIN2  = IPL;
 +
          INLEN  = BY2;
 +
 +
          // SET FRR INDICATORS TO CONTROL BUFFER OVERFLOW
 +
          FOR X =  1 TO  9;
 +
            IF IPL  >  ( X*80 +3);
 +
              *IN(X+19) = *ON;
 +
            ENDIF;
 +
          ENDFOR;
 +
 +
        RU    = *ALLX'00';
 +
        CLEAR  RU;
 +
        RU  = RDDSP;
 +
        A    = RU;
 +
 +
        EXCEPT DATAI;
 +
        ENDSR;
 +
 +
      //  @@@@@@@  ERROR  @@@@@@@@@@@@@@@@@@@@@@@@@
 +
        BEGSR    @ERROR;
 +
 +
      // SETUP PUT ERROR MESSAGE X'21'
 +
        RU    = *ALLX'00';
 +
        CLEAR RU;
 +
 +
        FNC    =  SNR;
 +
        BIN    = 42;
 +
        OUTLEN = HX2;
 +
        BIN    = LENF + 34;
 +
        IPL    = BIN;
 +
        INLEN  = HX2;
 +
 +
        FOR X        = 1 TO 9;
 +
          IF IPL      > (X * 80 +3) ;
 +
          *IN(X + 19) = *ON;          // SETON FFR 20 - 29 FOR INPUT
 +
          ENDIF;
 +
        ENDFOR;
 +
 +
        RU = ESC + WER + IC + B(1) + ATC + MSG(MX);
 +
        RU = RU + ESC + RDM + X40+ X00;
 +
 +
        A  = RU;
 +
        EXCEPT    DATAI;
 +
        RU    = *ALLX'00';
 +
        CLEAR RU;
 +
        ENDSR;
 +
 +
 +
      //  @@@@@@@    HXDSP @@@@@@@@@@@@@@@@@@@@@@@@@
 +
        BEGSR  @HXDSP;
 +
 +
          RU    = *ALLX'00';
 +
          CLEAR RU;
 +
          Y = %LOOKUPLE( CURLOC : B );
 +
          //
 +
          RU = ESC + WTD + X20 + X00 + SBA;
 +
          BIN = 0;
 +
          HX1 = %SUBST(B(Y) :1:1);
 +
          BIN = BIN - 1;
 +
          RU  = RU + HX1;
 +
          RU  = RU + %SUBST(B(Y) :2:1);
 +
 +
          FOR X = S(Y) TO E(Y);
 +
            BIN = 0;
 +
            HX1 = D(X);
 +
            HX1 = %BITAND(HX1  : XF0);
 +
            Z  = BIN / 16 + 1;
 +
            RU  = RU + CRS(Z);
 +
          ENDFOR;
 +
 +
            RU  = RU + X20;
 +
 +
            RU  = RU + SBA + B(Y);
 +
          FOR X = S(Y) TO E(Y);
 +
            BIN = 0;
 +
            HX1 = D(X);
 +
            HX1 = %BITAND(HX1  : X0F);
 +
            Z  = BIN  + 1;
 +
            RU  = RU + CRS(Z);
 +
          ENDFOR;
 +
 +
 +
          BIN    = %LEN(RU);
 +
          OUTLEN = HX2;
 +
          INLEN  = X000;
 +
          FNC    = SND;
 +
          A      = RU;
 +
          EXCEPT DATAO;
 +
          RU    = *ALLX'00';
 +
          CLEAR  RU;
 +
 +
 +
          EXSR      @KEYIN;
 +
          READ      DISPF;
 +
 +
 +
      //  CLEAR HEADINGS
 +
            RU    = *ALLX'00';
 +
            CLEAR RU;
 +
 +
        RU  = RU + ESC + WTD + X20 + X00 + SBA;
 +
        HX1  = %SUBST(B(Y) :1:1) ;
 +
        BIN  = BIN - 1;
 +
        RU  = RU + HX1 + %SUBST(B(Y):2:1);
 +
          FOR X = S(Y) TO E(Y);
 +
          RU = RU + ' ';
 +
          ENDFOR;
 +
        RU = RU + ' ';
 +
 +
        BIN    = %LEN(RU);
 +
        OUTLEN = HX2;
 +
        INLEN  = X000;
 +
        FNC    = SND;
 +
        A      = RU;
 +
        EXCEPT    DATAO;
 +
        RU    = *ALLX'00';
 +
        CLEAR  RU;
 +
 +
        ENDSR;
 +
 +
 +
 +
      //  @@@@@@@    UPD  @@@@@@@@@@@@@@@@@@@@@@@@@
 +
          BEGSR  @UPD;
 +
 +
        // CONVERT  DATA  FOR OUTPUT
 +
 +
        //  FOR EACH  FIELD, CHECK IF FIELD WAS MODIFIED, AND IF SO MOVE
 +
        // THE MODIFIED DATA INTO THE OUTPUT ARRAY
 +
        K1 = 0;
 +
        K2 = 0;
 +
        W  = 1;
 +
        CGKY = *BLANK;  // KEY CHANGED
 +
        KW  = KEYA;
 +
 +
          FOR  Y  = 1  TO NUMFKY ;
 +
 +
            IF KY(Y) > '1';
 +
            ITER;
 +
            ENDIF;
 +
 +
 +
      //  MOVE A KEY FIELDS DATA FROM ID ARRAY (SCREEN) TO K ARRAY
 +
 +
      //  GET SIZE OF FIELD IN BYTES
 +
          IF T(Y)  =  'A';  // ALPHA DATA
 +
          K = ' ';
 +
          K1 = 1;
 +
          K2 = Q(Y);
 +
          ELSE;
 +
          K  = '0';
 +
          K1 =  1;
 +
          K2 = C(Y);
 +
          ENDIF;
 +
 +
          X  =  1;
 +
 +
          DOW  @LOOP = @LOOP;
 +
 +
      //  NXTSBA
 +
          X  = %LOOKUP(SBA : ID : X );
 +
          IF X = 0;
 +
            LEAVE;
 +
          ENDIF;
 +
 +
      // IS THIS THE FIELD?  CHECK THE BUFFER ADDRESS
 +
        X = X +1;
 +
        IF  B(Y)  <>  %SUBST(IDA : X :2);
 +
          ITER;
 +
        ENDIF;
 +
 +
 +
      //  FOUND A MTD FOR THIS FIELD
 +
 +
 +
        // CHECK IF FIELD WAS CLEARED ONLY
 +
          DOW @LOOP = @LOOP; //  not a loop
 +
        X =  X + 2;
 +
        IF  ID(X) = SBA;
 +
          LEAVE;
 +
        ENDIF;
 +
 +
      //  IF FIELD HAS DECIMALS BUMP X
 +
          IF (T(Y) = 'S' OR T(Y) = 'P' OR T(Y) = 'B') AND
 +
              P(Y) > 0;
 +
              X = X + 1;
 +
          ENDIF;
 +
 +
 +
      //  CHECK IF ONLY BLANKS RETURNED
 +
          IF    %SUBST(IDA : X :K2) = *BLANKS;
 +
              LEAVE;
 +
          ENDIF;
 +
 +
        // MOVE DATA TO WORK ARRAY K
 +
            X1 = X;
 +
            FOR X2 = 1 TO K2;
 +
 +
            IF ID(X1) < ' ';
 +
              LEAVE;
 +
            ENDIF;
 +
 +
            K(X2) = ID(X1);
 +
            X1 = X1 + 1;
 +
            ENDFOR;
 +
 +
          LEAVE;
 +
        ENDDO;
 +
 +
        // *  SET START POSN
 +
          W =  S(Y);
 +
 +
        // ALPHA
 +
          IF T(Y) =  'A'  and V(XX) <>  'Y';
 +
          FOR Z  =  K1 to K2;
 +
            D(W) =  K(Z);
 +
            W    =  W + 1;
 +
          ENDFOR;
 +
          ENDIF;
 +
 +
        IF T(Y) =  'A' and  V(XX) = 'Y';  //VARYING
 +
 +
        //  the data start is in S(Y)
 +
        //  the data is in array K
 +
        //  get the length of the data cvt to bin and stik in pos 1 2
 +
        //  put the rest in pos 3 onwards
 +
 +
              ENDIF;
 +
 +
        // NUMERIC FIELD
 +
        // RIGHT  ADJUST NUMERIC DATA ,STRIP - . ,CONVERT BLANKS
 +
          IF (T(Y) = 'S' OR T(Y) = 'P' OR T(Y) = 'B');
 +
          NU = '0';
 +
 +
          Z1 = 60;
 +
          FOR Z  =  K2  DOWNTO K1;
 +
 +
          IF K(Z) = '.' OR K(Z) = '-' OR K(Z) = '$';
 +
          ITER;
 +
          ENDIF;
 +
 +
          IF K(Z) = ' ' ;
 +
          NU(Z1) = '0';
 +
          ELSE;
 +
          NU(Z1) = K(Z);
 +
          ENDIF;
 +
 +
            Z1 = Z1 -1;
 +
          ENDFOR;
 +
 +
          ENDIF;
 +
 +
 +
      // SIGNED FIELDS  (END POSN = OFFSET + SIZE)
 +
        IF T(Y)  = 'S';
 +
          NUSA= *BLANKS;
 +
          FOR VX = 1 TO 60;
 +
            NUSA = %TRIM(NUSA) + NU(VX);
 +
          ENDFOR;
 +
        %SUBST(DATA  : W : Q(Y)) = %SUBST(NUSA: 61 -Q(Y));
 +
 +
        ENDIF;
 +
 +
 +
      //  PACKED FIELDS
 +
          IF    T(Y)  =  'P';
 +
          NUSA= *BLANKS;
 +
          FOR VX = 1 TO 60;
 +
            NUSA = %TRIM(NUSA) + NU(VX);
 +
          ENDFOR;
 +
          NUP    = %DEC(NUSA : 60 : 0);
 +
 +
        %SUBST(DATA : W : Q(Y))  =  %SUBST(NUPA: 61 -Q(Y));
 +
        ENDIF;
 +
 +
      //  BINARY FIELDS
 +
        IF  T(Y) =  'B';
 +
 +
          NUSA= *BLANKS;
 +
          FOR VX = 1 TO 60;
 +
            NUSA = %TRIM(NUSA) + NU(VX);
 +
          ENDFOR;
 +
            NUC  = NUS;
 +
 +
        IF  Q(Y) = 2 ;
 +
              DISBIN  ( NUC : BAN2 : BAN4  : '2');
 +
            %SUBST(DATA : W : 2)  =  BAN2;
 +
        ENDIF;
 +
 +
        IF  Q(Y) = 4 ;
 +
              DISBIN  ( NUC : BAN2 : BAN4  : '4');
 +
            %SUBST(DATA : W : 4)  =  BAN4;
 +
        ENDIF;
 +
 +
        ENDIF;
 +
 +
        //  UPDATE KEY IF NECESSARY
 +
        IF  KY(Y)  = '1';
 +
            CGKY = '1';
 +
            EXSR  @PCKMOV;
 +
        ENDIF;
 +
 +
 +
        ENDDO;
 +
        ENDFOR;
 +
 +
 +
          IF  CGKY = '1';
 +
          KEYA = KW;
 +
          ENDIF;
 +
 +
        ENDSR;
 +
 +
 +
 +
      /END-FREE
 +
 +
    OINPUTK    E    U1      UPDATREC
 +
    O                      DA
 +
    O              30      DB
 +
    O              31      DC
 +
    O              32      DD
 +
    O              33      DE
 +
    O              34      DF
 +
    O              35      DG
 +
    O              36      DH
 +
    O              37      DI
 +
    O              38      DJ
 +
    O              39      DK
 +
    O              40      DL
 +
    O              41      DM
 +
    O              42      DN
 +
    O              43      DZ
 +
    O              44      DO
 +
    O              45      DP
 +
    O              46      DQ
 +
    O              47      DR
 +
    O              48      DS
 +
    O              49      DT
 +
    O              50      DU
 +
    O              51      DV
 +
    O              52      DW
 +
    O              53      DX
 +
    O              54      DY
 +
    O              55      D0
 +
    O              56      D1
 +
    O              57      D2
 +
    O              58      D3
 +
    O              59      D4
 +
    O              60      D5
 +
    O              61      D6
 +
    O              62      DBA
 +
    O              63      DCA
 +
    O              64      DDA
 +
    O              65      DEA
 +
    O              66      DFA
 +
    O              67      DGA
 +
    O              68      DHA
 +
    O              69      DIA
 +
    O              70      DJA
 +
    O              71      DKA
 +
    O              72      DLA
 +
    O              73      DMA
 +
    O              74      DNA
 +
    O              75      DOA
 +
    O              76      DPA
 +
    O              77      DQA
 +
    O              78      DRA
 +
    O              79      DSA
 +
    O              80      DTA
 +
    O              81      DUA
 +
    O              82      DVA
 +
    O              83      DWA
 +
    O              84      DXA
 +
    O              85      DYA
 +
    O              86      DZA
 +
    O              87      D0A
 +
    O              88      D1A
 +
    O              89      D2A
 +
    O              90      D3A
 +
    O              91      D4A
 +
    O              92      D5A
 +
    O              93      D6A
 +
    OINPUTR    E      U2  UPDATREC
 +
    O                      DA
 +
    O              30      DB
 +
    O              31      DC
 +
    O              32      DD
 +
    O              33      DE
 +
    O              34      DF
 +
    O              35      DG
 +
    O              36      DH
 +
    O              37      DI
 +
    O              38      DJ
 +
    O              39      DK
 +
    O              40      DL
 +
    O              41      DM
 +
    O              42      DN
 +
    O              43      DZ
 +
    O              44      DO
 +
    O              45      DP
 +
    O              46      DQ
 +
    O              47      DR
 +
    O              48      DS
 +
    O              49      DT
 +
    O              50      DU
 +
    O              51      DV
 +
    O              52      DW
 +
    O              53      DX
 +
    O              54      DY
 +
    O              55      D0
 +
    O              56      D1
 +
    O              57      D2
 +
    O              58      D3
 +
    O              59      D4
 +
    O              60      D5
 +
    O              61      D6
 +
    O              62      DBA
 +
    O              63      DCA
 +
    O              64      DDA
 +
    O              65      DEA
 +
    O              66      DFA
 +
    O              67      DGA
 +
    O              68      DHA
 +
    O              69      DIA
 +
    O              70      DJA
 +
    O              71      DKA
 +
    O              72      DLA
 +
    O              73      DMA
 +
    O              74      DNA
 +
    O              75      DOA
 +
    O              76      DPA
 +
    O              77      DQA
 +
    O              78      DRA
 +
    O              79      DSA
 +
    O              80      DTA
 +
    O              81      DUA
 +
    O              82      DVA
 +
    O              83      DWA
 +
    O              84      DXA
 +
    O              85      DYA
 +
    O              86      DZA
 +
    O              87      D0A
 +
    O              88      D1A
 +
    O              89      D2A
 +
    O              90      D3A
 +
    O              91      D4A
 +
    O              92      D5A
 +
    O              93      D6A
 +
 +
    OINPUTK    EADD U1      ADDREC
 +
    O                      DA
 +
    O              30      DB
 +
    O              31      DC
 +
    O              32      DD
 +
    O              33      DE
 +
    O              34      DF
 +
    O              35      DG
 +
    O              36      DH
 +
    O              37      DI
 +
    O              38      DJ
 +
    O              39      DK
 +
    O              40      DL
 +
    O              41      DM
 +
    O              42      DN
 +
    O              43      DZ
 +
    O              44      DO
 +
    O              45      DP
 +
    O              46      DQ
 +
    O              47      DR
 +
    O              48      DS
 +
    O              49      DT
 +
    O              50      DU
 +
    O              51      DV
 +
    O              52      DW
 +
    O              53      DX
 +
    O              54      DY
 +
    O              55      D0
 +
    O              56      D1
 +
    O              57      D2
 +
    O              58      D3
 +
    O              59      D4
 +
    O              60      D5
 +
    O              61      D6
 +
    O              62      DBA
 +
    O              63      DCA
 +
    O              64      DDA
 +
    O              65      DEA
 +
    O              66      DFA
 +
    O              67      DGA
 +
    O              68      DHA
 +
    O              69      DIA
 +
    O              70      DJA
 +
    O              71      DKA
 +
    O              72      DLA
 +
    O              73      DMA
 +
    O              74      DNA
 +
    O              75      DOA
 +
    O              76      DPA
 +
    O              77      DQA
 +
    O              78      DRA
 +
    O              79      DSA
 +
    O              80      DTA
 +
    O              81      DUA
 +
    O              82      DVA
 +
    O              83      DWA
 +
    O              84      DXA
 +
    O              85      DYA
 +
    O              86      DZA
 +
    O              87      D0A
 +
    O              88      D1A
 +
    O              89      D2A
 +
    O              90      D3A
 +
    O              91      D4A
 +
    O              92      D5A
 +
    O              93      D6A
 +
    OINPUTR    EADD    U2  ADDREC
 +
    O                      DA
 +
    O              30      DB
 +
    O              31      DC
 +
    O              32      DD
 +
    O              33      DE
 +
    O              34      DF
 +
    O              35      DG
 +
    O              36      DH
 +
    O              37      DI
 +
    O              38      DJ
 +
    O              39      DK
 +
    O              40      DL
 +
    O              41      DM
 +
    O              42      DN
 +
    O              43      DZ
 +
    O              44      DO
 +
    O              45      DP
 +
    O              46      DQ
 +
    O              47      DR
 +
    O              48      DS
 +
    O              49      DT
 +
    O              50      DU
 +
    O              51      DV
 +
    O              52      DW
 +
    O              53      DX
 +
    O              54      DY
 +
    O              55      D0
 +
    O              56      D1
 +
    O              57      D2
 +
    O              58      D3
 +
    O              59      D4
 +
    O              60      D5
 +
    O              61      D6
 +
    O              62      DBA
 +
    O              63      DCA
 +
    O              64      DDA
 +
    O              65      DEA
 +
    O              66      DFA
 +
    O              67      DGA
 +
    O              68      DHA
 +
    O              69      DIA
 +
    O              70      DJA
 +
    O              71      DKA
 +
    O              72      DLA
 +
    O              73      DMA
 +
    O              74      DNA
 +
    O              75      DOA
 +
    O              76      DPA
 +
    O              77      DQA
 +
    O              78      DRA
 +
    O              79      DSA
 +
    O              80      DTA
 +
    O              81      DUA
 +
    O              82      DVA
 +
    O              83      DWA
 +
    O              84      DXA
 +
    O              85      DYA
 +
    O              86      DZA
 +
    O              87      D0A
 +
    O              88      D1A
 +
    O              89      D2A
 +
    O              90      D3A
 +
    O              91      D4A
 +
    O              92      D5A
 +
    O              93      D6A
 +
 +
    OINPUTK    EDEL U1      DELREC
 +
    OINPUTR    EDEL U2      DELREC
 +
 +
 +
    ODISPF    E            DATAO
 +
    O                                          K3 'PUT'
 +
    O                      OUTLEN              2
 +
    O                      INLEN
 +
    O                      FNC
 +
    O                      A
 +
 +
    O          E            DATAI
 +
    O                                          K3 'GET'
 +
    O                      OUTLEN              2
 +
    O                      INLEN
 +
    O                      FNC
 +
    O                      A
 +
**
 +
0000 INVALID COMMAND KEY
 +
0001  - A FIELD IS TOO LONG
 +
0002  - TOO MANY FIELDS
 +
0003  - ALPHAS IN PACKED KEY
 +
0004  - MISSING ' IN PACKED KEY
 +
0005  - MISSING DATA IN PCKD KEY
 +
0006  - RECORD NOT FOUND
 +
PRESS RESET TO CONTINUE
 +
**
 +
F1-HEX F2-Return F3-Exit F19-Prev_fld F20-More_fld
 +
F1-HEX F2-Return F3-Exit F6-Update F9-Add F11-Del F19-Prev_fld F20-More_fld
 +
**
 +
0123456789ABCDEF
 +
 +
 +
</pre>
 +
 +
[[#top]]
 +
 +
===DUSP2  RPG===
 +
 +
<pre>
 +
    H*eywords++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++Comments+++++++++++
 +
    H OPTION(*NODEBUGIO)
 +
    H DFTACTGRP(*NO) ACTGRP(*CALLER) DFTNAME(DUSP2 )
 +
    F*
 +
    F*  LIMITED TO MAXIMUM FILE LENGTH OF 6080
 +
    F*  REQUIRES FILE  QTEMP/FFD  TO COMPILE
 +
    F*  use cmd DSPFFD  FILE(&LIB/&FILE) OUTPUT(*OUTFILE) OUTFILE(QTEMP/FFD)
 +
 +
    FFFD      IF  E            DISK
 +
    FDISPF    CF  F  803        WORKSTN
 +
    F*
 +
    F                                    INFDS(INFDS)
 +
    FINPUTK    UF A F32766  800AIDISK    KEYLOC(1)
 +
    F                                    EXTIND(*INU1)
 +
    F                                    INFDS(INFDK)
 +
    FINPUTR    UF A F32766        DISK    EXTIND(*INU2)
 +
    F                                    INFDS(INFDR)
 +
 +
    D DISBIN          PR                  extpgm('DISBIN')
 +
    D  NUM                          15P 0
 +
    D  BAN2                          2
 +
    D  BAN4                          4
 +
    D  BINTYP                        1    CONST
 +
 +
      *
 +
    D A              S            255                                        WORK RU
 +
    D RU              S            255    varying
 +
    D RW              S              1                                        ROW 1 byte binary
 +
    D CL              S              1                                        COL 1 byte binary
 +
    D FNC            S              1
 +
    D OUTLEN          S              2
 +
    D INLEN          S              2
 +
    D IPL            S              5  0
 +
    D ROW            S              3  0
 +
    D XROW            S              3  0
 +
    D COL            S              3  0
 +
    D KEYSOK          S              1
 +
    D LENDSC          S              3  0
 +
    D LENWRK          S              5  0
 +
    D STRX            S              5  0
 +
    D ENDX            S              5  0
 +
    D VX              S              5  0
 +
    D X              S              5  0
 +
    D X1              S              5  0
 +
    D X2              S              5  0
 +
    D XX              S              5  0
 +
    D XP              S              5  0
 +
    D MX              S              5  0
 +
    D ONCE            S              1
 +
    D RBA            S              2
 +
    D LF              S              5  0
 +
    D ST              S              5  0
 +
    D Y              S              5  0
 +
    D Z              S              5  0
 +
    D OFF            S              5  0
 +
    D CGKY            S              1
 +
    D UPDDONE        S              1
 +
    D SUPZ            S              1
 +
    D NUMFLD          S              5  0
 +
    D WX              S              5  0
 +
    D NUMKEY          S              5  0
 +
    D NUMFKY          S              5  0
 +
    D SCRST          S            10
 +
    D SCRSTN          S              1
 +
    D KEYA            S            800
 +
    D RRNA            S            11  0
 +
    D RRN            S            11  0
 +
    D REHEAD          S              1
 +
    D NEWRU          S              1
 +
    D WRTRRN          S              1
 +
    D LVX            S              5  0
 +
    D LVL            S              5  0
 +
    D K1              S              5  0
 +
    D K2              S              5  0
 +
    D Z1              S              5  0
 +
    D W              S              5  0
 +
    D WK2            S              2
 +
    D MSSG            S            32
 +
      *
 +
    D BASE            S              5  0
 +
    D INZ            S              1
 +
 +
    D FILE            S            10
 +
    D LIB            S            10
 +
    D MBR            S            10
 +
    D RCDL            S              5  0
 +
    D ACCTP          S              1
 +
    D RLEN            S              5  0
 +
    D RLENTH          S              5
 +
    D LENF            S              5  0
 +
 +
 +
    D                DS
 +
    D TEXT500                      500
 +
    D LVW                          10    DIM(50) overlay(TEXT500:1)
 +
 +
    D TEXT800        S            800
 +
    D KW              S            800
 +
 +
    D                DS
 +
    D WRK11                  1    11
 +
    D NUM11                  1    11S 0
 +
 +
    D                DS
 +
    D NUSA                    1    60
 +
    D NUS                    1    60S 0
 +
    D                DS
 +
    D NUPA                    1    60
 +
    D NUP                    29    60P 0
 +
 +
    D NUC            S            15P 0
 +
    D BAN2            S              2
 +
DCL  D BAN4            S              4
 +
 +
 +
    D WRU            S            61
 +
    D WRX            S            64
 +
    D WRXWRD          C                  '0                              -
 +
    D                                                                    -'
 +
    D WRSWRD          C                  '0                              -
 +
    D                                                                  -'
 +
    D WRV            S            60    varying
 +
 +
    D FLT14          S            14
 +
    D FLT23          S            23
 +
 +
      * SET FILE SIZE INCREMENTS (64 OF THEM)
 +
    D SZ              S              5  0 DIM(64)
 +
    D S              S              5  0 DIM(9000)                            START OF FLD
 +
    D E              S              5  0 DIM(9000)                            END OF FLD
 +
    D Q              S              5  0 DIM(9000)                            BYTES IN FIELD
 +
    D L              S              5  0 DIM(9000)                            LENGTH OF FLD
 +
    D C              S              3  0 DIM(9000)                            DEC DIGITS
 +
    D P              S              3  0 DIM(9000)                            DEC PRECISION
 +
    D B              S              2    DIM(9000) ASCEND                    BUFFER ADD
 +
    D I              S              2    DIM(9000)                            FLD FMT
 +
    D N              S            10    DIM(9000)                            FLD NAME
 +
    D T              S              1    DIM(9000)                            FLD TYPE
 +
    D V              S              1    DIM(9000)                            VARYING
 +
    D KY              S              1    DIM(9000)                            KEYED
 +
    D KE              S            10    DIM(128)                            KEY FLDS
 +
    D R              S              3  0 DIM(9000)                            KEY FLD START
 +
    D K              S              1    DIM(800)                            KEY
 +
    D NA              S              1    DIM(10)                              NAME WORK
 +
    D NU              S              1    DIM(60)                              NUM. WORK
 +
    D LV              S            10    DIM(50)                              SCREEN LEVELS
 +
    D MSG            S            32    DIM(8) CTDATA PERRCD(1)              MESSAGES
 +
    D CNS            S            79    DIM(2) CTDATA PERRCD(1)
 +
    D CRS            S              1    DIM(16) CTDATA PERRCD(16)
 +
    D                DS
 +
    D  DATA                  1  6080
 +
    D  D                      1  6080
 +
    D                                    DIM(6080)                            INCOMING DATA
 +
    D  DA                    1  4048
 +
    D                                    DIM(4048)
 +
    D  DB                  4049  4064
 +
    D  DC                  4065  4096
 +
    D  DD                  4097  4128
 +
    D  DE                  4129  4160
 +
    D  DF                  4161  4192
 +
    D  DG                  4193  4224
 +
    D  DH                  4225  4256
 +
    D  DI                  4257  4288
 +
    D  DJ                  4289  4320
 +
    D  DK                  4321  4352
 +
    D  DL                  4353  4384
 +
    D  DM                  4385  4416
 +
    D  DN                  4417  4448
 +
    D  DZ                  4449  4480
 +
    D  DO                  4481  4512
 +
    D  DP                  4513  4544
 +
    D  DQ                  4545  4576
 +
    D  DR                  4577  4608
 +
    D  DS                  4609  4640
 +
    D  DT                  4641  4672
 +
    D  DU                  4673  4704
 +
    D  DV                  4705  4736
 +
    D  DW                  4737  4768
 +
    D  DX                  4769  4800
 +
    D  DY                  4801  4832
 +
    D  D0                  4833  4864
 +
    D  D1                  4865  4896
 +
    D  D2                  4897  4928
 +
    D  D3                  4929  4960
 +
    D  D4                  4961  4992
 +
    D  D5                  4993  5024
 +
    D  D6                  5025  5056
 +
    D  DBA                5057  5088
 +
    D  DCA                5089  5120
 +
    D  DDA                5121  5152
 +
    D  DEA                5153  5184
 +
    D  DFA                5185  5216
 +
    D  DGA                5217  5248
 +
    D  DHA                5249  5280
 +
    D  DIA                5281  5312
 +
    D  DJA                5313  5344
 +
    D  DKA                5345  5376
 +
    D  DLA                5377  5408
 +
    D  DMA                5409  5440
 +
    D  DNA                5441  5472
 +
    D  DOA                5473  5504
 +
    D  DPA                5505  5536
 +
    D  DQA                5537  5568
 +
    D  DRA                5569  5600
 +
    D  DSA                5601  5632
 +
    D  DTA                5633  5664
 +
    D  DUA                5665  5696
 +
    D  DVA                5697  5728
 +
    D  DWA                5729  5760
 +
    D  DXA                5761  5792
 +
    D  DYA                5793  5824
 +
    D  DZA                5825  5856
 +
    D  D0A                5857  5888
 +
    D  D1A                5889  5920
 +
    D  D2A                5921  5952
 +
    D  D3A                5953  5984
 +
    D  D4A                5985  6016
 +
    D  D5A                6017  6048
 +
    D  D6A                6049  6080
 +
    D                DS
 +
    D  ID                    1    800
 +
    D                                    DIM(800)                            INCOMING DATA
 +
    D  IDA                    1    800
 +
    D  ID0                    1    80
 +
    D  ID1                  81    160
 +
    D  ID2                  161    240
 +
    D  ID3                  241    320
 +
    D  ID4                  321    400
 +
    D  ID5                  401    480
 +
    D  ID6                  481    560
 +
    D  ID7                  561    640
 +
    D  ID8                  641    720
 +
    D  ID9                  721    800
 +
    D                DS
 +
    D  BIN                    1      2B 0
 +
    D  HX1                    2      2
 +
    D  HX2                    1      2
 +
    D                DS
 +
    D  PCK                    1      1P 0
 +
    D  PCK1                  1      1
 +
    D                DS
 +
    D  SGN                    1      1S 0
 +
    D  SGN1                  1      1
 +
 +
    D                DS
 +
    D  BIN4                  1      4B 0
 +
    D  BY4                    1      4
 +
 +
    D                DS
 +
    D  BIN2                  1      2B 0
 +
    D  BY2                    1      2
 +
 +
    D                DS
 +
    D  FLT4                  1      4F
 +
    D  FL4                    1      4
 +
 +
    D                DS
 +
    D  FLT8                  1      8F
 +
    D  FL8                    1      8
 +
 +
    D INFDK          DS
 +
    D  F1                    83    92
 +
    D  L1                    93    102
 +
    D  M1                  129    138
 +
    D  R1                  125    126B 0
 +
    D  A1                  160    160
 +
    D  LOP1                260    260
 +
    D  KEY_LEN              393    394I 0                                      Key length
 +
    D  RN1                  397    400B 0
 +
    D  LKY                  401  1200
 +
    D INFDR          DS
 +
    D  F2                    83    92
 +
    D  L2                    93    102
 +
    D  M2                  129    138
 +
    D  R2                  125    126B 0
 +
    D  A2                  160    160
 +
    D  LOP2                260    260
 +
    D  RN2                  397    400B 0
 +
    D*
 +
    D INFDS          DS
 +
    D  CURLOC              370    371
 +
    D                DS
 +
    D KEYLN                  1      4S 0
 +
    D KEYLNA                  1      4
 +
 +
    DDUSP2            PR
 +
    D                                1
 +
    D                                1
 +
    D                                4
 +
    D                                1
 +
    D                              500
 +
    D                                5
 +
    D                              800
 +
    DDUSP2            PI
 +
    D  ALL                          1
 +
    D  RTN                          1
 +
    D  KEYLNG                      4
 +
    D  UPDF                        1
 +
    D  SCNLV                      500
 +
    D  SCNLVL                      5
 +
    D  SCNKEY                    800
 +
 +
 +
    D @LOOP          C                  '1'
 +
    D @FALSE          C                  '0'
 +
    D @TRUE          C                  '1'
 +
 +
    D SND            C                  X'71'                                SEND TO DISP
 +
    D SNR            C                  X'73'                                SND/RCV
 +
    D RED            C                  X'42'                                READ
 +
    D RDM            C                  X'52'                                READ MTD
 +
    D ESC            C                  X'04'                                ESCAPE
 +
    D CLR            C                  X'40'                                CLEAR UNIT
 +
    D CC1            C                  X'00'                                CNTRL CHAR
 +
    D CC2            C                  X'08'                                CNTRL CHAR
 +
    D SBA            C                  X'11'                                SET BUFF ADR
 +
    D IC              C                  X'13'                                INSERT CURS
 +
    D WTD            C                  X'11'                                WRITE TO DSP
 +
    D WER            C                  X'21'                                WRITE ERROR
 +
    D SF              C                  X'1D'                                START FLD
 +
    D ATC            C                  X'20'                                ATTR CHAR
 +
    D ATN            C                  X'24'                                ATTR NUM
 +
    D X00            C                  X'00'
 +
    D X01            C                  X'01'
 +
    D X02            C                  X'02'
 +
    D X03            C                  X'03'
 +
    D X0D            C                  X'0D'
 +
    D X0F            C                  X'0F'
 +
    D X000            C                  X'0000'
 +
    D X1F            C                  X'1F'
 +
    D X20            C                  X'20'                                SCRN ATT NORMAL
 +
    D X22            C                  X'22'                                SCRN ATTR HI
 +
    D X25            C                  X'25'
 +
    D X26            C                  X'26'
 +
    D X31            C                  X'31'                                CMD 1 KEY
 +
    D X32            C                  X'32'                                CMD 2 KEY
 +
    D X33            C                  X'33'                                CMD 3 KEY
 +
    D X36            C                  X'36'                                CMD 6 KEY
 +
    D X37            C                  X'37'                                CMD 7 KEY
 +
    D X38            C                  X'38'                                CMD 8 KEY
 +
    D X39            C                  X'39'                                CMD 9 KEY
 +
    D X3B            C                  X'3B'                                CMD11 KEY
 +
    D XB7            C                  X'B7'                                CMD19 KEY
 +
    D XB8            C                  X'B8'                                CMD20 KEY
 +
    D X40            C                  X'40'
 +
    D X43            C                  X'43'
 +
    D X47            C                  X'47'
 +
    D X60            C                  X'60'
 +
    D X67            C                  X'67'
 +
    D X9F            C                  X'9F'
 +
    D XF0            C                  X'F0'
 +
    D XD0            C                  X'D0'
 +
    D X4000          C                  X'4000'
 +
    D X4800          C                  X'4800'                              FF ALPHA
 +
    D X4F06          C                  X'4F06'                              FF NUMERIC
 +
    D X6000          C                  X'6000'                              FF ALPHA
 +
    D X6706          C                  X'6706'                              FF NUMERIC
 +
    D CLRWTD          C                  X'044004112000'                      INCLUDES ESC CHARS
 +
    D RDDSP          C                  X'0411200804524000'                  READ FROM DISPLAY
 +
    D FFA1            S              1    INZ(X'40')                          F.FMT 1 ALPH  60 BYP
 +
    D FFA2            S              1    INZ(X'00')                          F.FMT 2 ALPH
 +
    D FFN1            S              1    INZ(X'47')                          F.FMT 1 NUM  67 BYP
 +
    D FFN2            S              1    INZ(X'06')                          F.FMT 2 NUM
 +
    I*.
 +
 +
0038 IINPUTK    NS  01
 +
0039 I                                  1 4048  DA
 +
0040 I                              4049 4064  DB                30
 +
0041 I                              4065 4096  DC                31
 +
0042 I                              4097 4128  DD                32
 +
0043 I                              4129 4160  DE                33
 +
0044 I                              4161 4192  DF                34
 +
0045 I                              4193 4224  DG                35
 +
0046 I                              4225 4256  DH                36
 +
0047 I                              4257 4288  DI                37
 +
0048 I                              4289 4320  DJ                38
 +
0049 I                              4321 4352  DK                39
 +
0050 I                              4353 4384  DL                40
 +
0051 I                              4385 4416  DM                41
 +
0052 I                              4417 4448  DN                42
 +
0053 I                              4449 4480  DZ                43
 +
0054 I                              4481 4512  DO                44
 +
0055 I                              4513 4544  DP                45
 +
0056 I                              4545 4576  DQ                46
 +
0057 I                              4577 4608  DR                47
 +
0058 I                              4609 4640  DS                48
 +
0059 I                              4641 4672  DT                49
 +
0060 I                              4673 4704  DU                50
 +
0061 I                              4705 4736  DV                51
 +
0062 I                              4737 4768  DW                52
 +
0063 I                              4769 4800  DX                53
 +
0064 I                              4801 4832  DY                54
 +
0065 I                              4833 4864  D0                55
 +
0066 I                              4865 4896  D1                56
 +
0067 I                              4897 4928  D2                57
 +
0068 I                              4929 4960  D3                58
 +
0069 I                              4961 4992  D4                59
 +
0070 I                              4993 5024  D5                60
 +
0071 I                              5025 5056  D6                61
 +
0072 I                              5057 5088  DBA              62
 +
0073 I                              5089 5120  DCA              63
 +
0074 I                              5121 5152  DDA              64
 +
0075 I                              5153 5184  DEA              65
 +
0076 I                              5185 5216  DFA              66
 +
0077 I                              5217 5248  DGA              67
 +
0078 I                              5249 5280  DHA              68
 +
0079 I                              5281 5312  DIA              69
 +
0080 I                              5313 5344  DJA              70
 +
0081 I                              5345 5376  DKA              71
 +
0082 I                              5377 5408  DLA              72
 +
0083 I                              5409 5440  DMA              73
 +
0084 I                              5441 5472  DNA              74
 +
0085 I                              5473 5504  DOA              75
 +
0086 I                              5505 5536  DPA              76
 +
0087 I                              5537 5568  DQA              77
 +
0088 I                              5569 5600  DRA              78
 +
0089 I                              5601 5632  DSA              79
 +
0090 I                              5633 5664  DTA              80
 +
0091 I                              5665 5696  DUA              81
 +
0092 I                              5697 5728  DVA              82
 +
0093 I                              5729 5760  DWA              83
 +
0094 I                              5761 5792  DXA              84
 +
0095 I                              5793 5824  DYA              85
 +
0096 I                              5825 5856  DZA              86
 +
0097 I                              5857 5888  D0A              87
 +
0098 I                              5889 5920  D1A              88
 +
0099 I                              5921 5952  D2A              89
 +
0100 I                              5953 5984  D3A              90
 +
0101 I                              5985 6016  D4A              91
 +
0102 I                              6017 6048  D5A              92
 +
0103 I                              6049 6080  D6A              93
 +
0104 IINPUTR    NS  01
 +
0105 I                                  1 4048  DA
 +
0106 I                              4049 4064  DB                30
 +
0107 I                              4065 4096  DC                31
 +
0108 I                              4097 4128  DD                32
 +
0109 I                              4129 4160  DE                33
 +
0110 I                              4161 4192  DF                34
 +
0111 I                              4193 4224  DG                35
 +
0112 I                              4225 4256  DH                36
 +
0113 I                              4257 4288  DI                37
 +
0114 I                              4289 4320  DJ                38
 +
0115 I                              4321 4352  DK                39
 +
0116 I                              4353 4384  DL                40
 +
0117 I                              4385 4416  DM                41
 +
0118 I                              4417 4448  DN                42
 +
0119 I                              4449 4480  DZ                43
 +
0120 I                              4481 4512  DO                44
 +
0121 I                              4513 4544  DP                45
 +
0122 I                              4545 4576  DQ                46
 +
0123 I                              4577 4608  DR                47
 +
0124 I                              4609 4640  DS                48
 +
0125 I                              4641 4672  DT                49
 +
0126 I                              4673 4704  DU                50
 +
0127 I                              4705 4736  DV                51
 +
0128 I                              4737 4768  DW                52
 +
0129 I                              4769 4800  DX                53
 +
0130 I                              4801 4832  DY                54
 +
0131 I                              4833 4864  D0                55
 +
0132 I                              4865 4896  D1                56
 +
0133 I                              4897 4928  D2                57
 +
0134 I                              4929 4960  D3                58
 +
0135 I                              4961 4992  D4                59
 +
0136 I                              4993 5024  D5                60
 +
0137 I                              5025 5056  D6                61
 +
0138 I                              5057 5088  DBA              62
 +
0139 I                              5089 5120  DCA              63
 +
0140 I                              5121 5152  DDA              64
 +
0141 I                              5153 5184  DEA              65
 +
0142 I                              5185 5216  DFA              66
 +
0143 I                              5217 5248  DGA              67
 +
0144 I                              5249 5280  DHA              68
 +
0145 I                              5281 5312  DIA              69
 +
0146 I                              5313 5344  DJA              70
 +
0147 I                              5345 5376  DKA              71
 +
0148 I                              5377 5408  DLA              72
 +
0149 I                              5409 5440  DMA              73
 +
0150 I                              5441 5472  DNA              74
 +
0151 I                              5473 5504  DOA              75
 +
0152 I                              5505 5536  DPA              76
 +
0153 I                              5537 5568  DQA              77
 +
0154 I                              5569 5600  DRA              78
 +
0155 I                              5601 5632  DSA              79
 +
0156 I                              5633 5664  DTA              80
 +
0157 I                              5665 5696  DUA              81
 +
0158 I                              5697 5728  DVA              82
 +
0159 I                              5729 5760  DWA              83
 +
0160 I                              5761 5792  DXA              84
 +
0161 I                              5793 5824  DYA              85
 +
0162 I                              5825 5856  DZA              86
 +
0163 I                              5857 5888  D0A              87
 +
0164 I                              5889 5920  D1A              88
 +
0165 I                              5921 5952  D2A              89
 +
0166 I                              5953 5984  D3A              90
 +
0167 I                              5985 6016  D4A              91
 +
0168 I                              6017 6048  D5A              92
 +
0169 I                              6049 6080  D6A              93
 +
    IDISPF    NS  02
 +
    I                                  3    3  AID
 +
    I                                  4  83  ID0
 +
    I                                84  163  ID1              20
 +
    I                                164  243  ID2              21
 +
    I                                244  323  ID3              22
 +
    I                                324  403  ID4              23
 +
    I                                404  483  ID5              24
 +
    I                                484  563  ID6              25
 +
    I                                564  643  ID7              26
 +
    I                                644  723  ID8              27
 +
    I                                724  803  ID9              28
 +
 +
 +
      /FREE
 +
            BASE = 4048;
 +
 +
            IF  ONCE  =  ' ';
 +
                EXSR      @INITZ  ;
 +
            ENDIF;
 +
 +
        //  START        TAG
 +
          DOW      @LOOP = @LOOP;
 +
 +
          IF  RTN  = '3';
 +
 +
              IF *INU1;
 +
                KEYA =  SCNKEY;
 +
              ENDIF;
 +
              IF *INU2;
 +
                RRNA =  %DEC(%SUBST(SCNKEY:1:11):11:0);
 +
              ENDIF;
 +
                RTN = '0';
 +
                AID = '1';
 +
            ELSE;
 +
              RTN  = '0';
 +
              READ(E)  DISPF;
 +
          ENDIF;
 +
 +
        //  CF3 EXIT
 +
          IF  AID  = X33;
 +
            LEAVE;
 +
          ENDIF;
 +
 +
        //  CF2 RETURN
 +
          IF  AID  = X32;
 +
            RTN = '1';
 +
            LEAVE;
 +
          ENDIF;
 +
 +
        // CF1 HEX A FIELD
 +
          IF  AID  = X31;
 +
          Y = %LOOKUPLE( CURLOC : B );
 +
          IF Y > 0;
 +
            IF KY(Y) <= '1';
 +
              EXSR      @HXDSP;
 +
              REHEAD  = '1';
 +
              EXSR      @PUTHED;
 +
              REHEAD  = ' ';
 +
            ENDIF;
 +
            ENDIF;
 +
          ENDIF;
 +
 +
        //  CF20 MORE FIELDS
 +
          IF  AID  = XB8;
 +
 +
            LVX  = LVL + 1;
 +
            IF  LV(LVX)  <> *BLANK;
 +
              LVL = LVL +1 ;
 +
 +
              LVW  = LV;
 +
              SCNLV = TEXT500;
 +
              SCNLVL = %EDITC(LVL :'X');
 +
 +
            SCNKEY = *BLANKS;
 +
          IF  *INU1;
 +
                SCNKEY = KEYA;
 +
          ENDIF;
 +
          IF  *INU2;
 +
                SCNKEY = %EDITC(RRNA:'X');
 +
          ENDIF;
 +
 +
              RTN = '3';
 +
              LEAVE;
 +
            ENDIF;
 +
          ENDIF;
 +
 +
      //  CF19 PREVIOUS FIELDS
 +
          IF  AID  = XB7;
 +
 +
            LVX  = LVL - 1;
 +
            IF  LVX    >= 0 ;
 +
              LVL = LVL - 1 ;
 +
 +
              LVW  = LV;
 +
              SCNLV = TEXT500;
 +
              SCNLVL = %EDITC(LVL :'X');
 +
 +
                SCNKEY = *BLANKS;
 +
          IF  *INU1;
 +
                SCNKEY = KEYA;
 +
          ENDIF;
 +
          IF  *INU2;
 +
                SCNKEY = %EDITC(RRNA:'X');
 +
          ENDIF;
 +
 +
              RTN = '3';
 +
              LEAVE;
 +
            ENDIF;
 +
          ENDIF;
 +
 +
          // 1 ENTER  4 ROLL DN  5 ROLL UP
 +
          // F6 = X36  F9 = X39  F11 = X3B
 +
          IF  AID  = '1'or AID = '4' or AID = '5' or
 +
              AID  = X36 or AID = X39 or AID = X3B;
 +
          ELSE;
 +
            MX = 1;        // INVALID KEY
 +
            EXSR  @ERROR;
 +
          ENDIF;
 +
 +
          //      UPDATE MODE
 +
          IF  UPDF    = 'Y';
 +
            UPDDONE = @FALSE;
 +
          // F6
 +
            IF *INU1 AND AID = X36 AND
 +
            (LOP1 = X01 OR LOP1 = X03);
 +
              EXSR @UPD;
 +
              EXCEPT UPDATREC;
 +
              UPDDONE = @TRUE;
 +
            ENDIF;
 +
 +
            IF *INU2 AND AID = X36 AND
 +
            (LOP2 = X01 OR LOP2 = X02);
 +
              EXSR @UPD;
 +
              EXCEPT UPDATREC;
 +
              UPDDONE = @TRUE;
 +
            ENDIF;
 +
 +
          // F9
 +
            IF AID = X39;
 +
              EXSR  @UPD;
 +
              EXCEPT ADDREC;
 +
              UPDDONE = @TRUE;
 +
            ENDIF;
 +
 +
          // F11
 +
            IF *INU1 AND AID = X3B AND
 +
            (LOP1 = X01 OR LOP1 = X03);
 +
              EXCEPT DELREC;
 +
              UPDDONE = @TRUE;
 +
              ENDIF;
 +
 +
            IF *INU2 AND AID = X3B AND
 +
            (LOP2 = X01 OR LOP2 = X02);
 +
              EXCEPT DELREC;
 +
              UPDDONE = @TRUE;
 +
              ENDIF;
 +
 +
            ENDIF;
 +
 +
 +
          IF  RTN = '3' OR UPDDONE = @TRUE;
 +
          ELSE;
 +
            EXSR      @PCKD;
 +
          ENDIF;
 +
 +
 +
        // CONT1  GET A RECORD, KEY FROM DATA
 +
            EXSR      @SETIN;
 +
            EXSR      @GETF ;
 +
            EXSR      @PUTF ;
 +
            EXSR      @KEYIN;
 +
 +
          ENDDO ;
 +
 +
          *INLR = *ON;
 +
 +
      //  @@@@@@@  @INITZ @@@@@@@@@@@@@@@@@@@@@@@@@@
 +
        BEGSR  @INITZ;
 +
                ONCE  =  '1';
 +
                KEYLNA = KEYLNG  ;
 +
                EXSR      @INIT  ;
 +
                EXSR      @GETFLD ;
 +
                EXSR      @GETADD ;
 +
                EXSR      @PUTHED ;
 +
                EXSR      @KEYIN  ;
 +
                INZ  = '1';
 +
                EXSR      @PCKD  ;
 +
                INZ  = ' ';
 +
        ENDSR;
 +
 +
      //  @@@@@@@  @PCKD  @@@@@@@@@@@@@@@@@@@@@@@@@@
 +
 +
          BEGSR  @PCKD ;
 +
 +
            //  CONVERT  KEY DATA
 +
            IF  *INU1 ;
 +
              EXSR  @CVTKEY;
 +
            ENDIF;
 +
            IF  *INU2 ;
 +
              EXSR  @CVTRRN;
 +
            ENDIF;
 +
 +
          ENDSR;
 +
 +
      //  @@@@@@@  @CVTKEY  @@@@@@@@@@@@@@@@@@@@@@@@
 +
 +
          BEGSR  @CVTKEY;
 +
 +
      // EXTRACT THE KEY FIELD DATA FROM THE INCOMING STRING
 +
 +
        // FOR EACH KEY FIELD, CHECK IF FIELD WAS MODIFIED, AND IF SO MOVE
 +
        // THE MODIFIED DATA INTO THE COMPOSITE KEY
 +
 +
        K1 = 0;
 +
        K2 = 0;
 +
        W  = 1;
 +
 +
          FOR  Y  = 1  TO NUMKEY ;
 +
 +
      //  MOVE A KEY FIELDS DATA FROM ID ARRAY (SCREEN) TO K ARRAY (KEY FIELDS)
 +
 +
      //  GET SIZE OF FIELD IN BYTES
 +
          IF T(Y)  =  'A';  // ALPHA DATA
 +
          K = ' ';
 +
          K1 = 1;
 +
          K2 = Q(Y);
 +
          ELSE;
 +
          K  = '0';
 +
          K1 =  1;
 +
          K2 = C(Y);
 +
          ENDIF;
 +
 +
      // IF WHOLE KEY INIT WAS REQUESTED BYPASS THE EXTRACT
 +
          IF  INZ  = '1' ;
 +
            KW  = *BLANK;
 +
            EXSR      @PCKMOV;
 +
            ITER;
 +
          ENDIF;
 +
 +
          X  =  1;
 +
 +
          DOW  @LOOP = @LOOP;
 +
 +
      //  NXTSBA
 +
          X  = %LOOKUP(SBA : ID : X );
 +
          IF X = 0;
 +
            LEAVE;
 +
          ENDIF;
 +
 +
      // IS THIS THE FIELD?  CHECK THE BUFFER ADDRESS
 +
        X = X +1;
 +
        IF  B(Y)  <>  %SUBST(IDA : X :2);
 +
          ITER;
 +
        ENDIF;
 +
 +
      //  FOUND A MTD FOR THIS FIELD
 +
        X =  X + 2;
 +
 +
      //  CHECK IF FIELD WAS CLEARED ONLY
 +
        IF  ID(X) = SBA;
 +
            EXSR      @PCKMOV;
 +
            LEAVE ;
 +
        ENDIF;
 +
 +
      //  IF FIELD HAS DECIMALS BUMP X
 +
          IF (T(Y) = 'S' OR T(Y) = 'P' OR T(Y) = 'B') AND
 +
              P(Y) > 0;
 +
              X = X + 1;
 +
          ENDIF;
 +
 +
      //  CHECK IF ONLY BLANKS RETURNED
 +
        IF    %SUBST(IDA : X :K2) = *BLANKS;
 +
            EXSR      @PCKMOV;
 +
            LEAVE;
 +
        ENDIF;
 +
 +
      // EXTRACT THE DATA FROM THE INCOMING STRING
 +
        X1  = X;
 +
        FOR X2  =  1 TO  K2 ;
 +
 +
          IF ID(X1) < ' ';
 +
      // TRAP NULLS CAUSED BY FLD EXIT
 +
            EXSR      @PCKMOV;
 +
            LEAVE;
 +
          ENDIF;
 +
 +
        K(X2)  =  ID(X1);
 +
        X1    =  X1 +1;
 +
        ENDFOR;
 +
 +
        // CONSTRUCT THE ACTUAL KEY WITH PACKED DATA IF REQUIRED
 +
        // INTO ARRAY KW
 +
          EXSR      @PCKMOV;
 +
          LEAVE;
 +
        ENDDO;
 +
 +
        ENDFOR;
 +
 +
        //
 +
          KEYA  = KW;
 +
          CLEAR KW;
 +
        ENDSR ;
 +
 +
      //  @@@@@@@  @CVTRRN  @@@@@@@@@@@@@@@@@@@@@@@@
 +
 +
          BEGSR  @CVTRRN;
 +
 +
        //  RRN
 +
 +
          NUM11 = 0;
 +
 +
          DOW  @LOOP = @LOOP;  //  NOT REALLY A LOOP(SIMULATES GOTO)
 +
 +
      // GET THE FIRST SBA
 +
          X = 1;
 +
          X  = %LOOKUP(SBA : ID : X );
 +
          IF X = 0;
 +
          LEAVE;
 +
          ENDIF;
 +
 +
      // CHECK THE BUFFER ADDRESS MATCHES THE EXPECTED FIELD
 +
        X = X +1;
 +
        IF  B(1)  <>  %SUBST(IDA : X :2);
 +
          ITER;
 +
        ENDIF;
 +
 +
      //  FOUND A MTD FOR RRN  FIELD
 +
        X = X +2;
 +
 +
      //CHECK IF FIELD WAS CLEARED ONLY
 +
        IF  ID(X) = SBA;
 +
            LEAVE;
 +
        ENDIF;
 +
 +
      //  CHECK IF ONLY BLANKS RETURNED
 +
        IF    %SUBST(IDA : X :11) = *BLANKS;
 +
            LEAVE;
 +
        ENDIF;
 +
 +
 +
        //  WRK11  OVERLAYS NUM11
 +
        WRK11 = %SUBST(IDA : X :11);
 +
 +
        LEAVE;
 +
        ENDDO;
 +
 +
 +
        RRNA = NUM11;
 +
        IF RRNA < 0;
 +
        RRNA =  1;
 +
        ENDIF;
 +
 +
        ENDSR;
 +
 +
      //  @@@@@@@  @PCKMOV  @@@@@@@@@@@@@@@@@@@@@@@@
 +
 +
        BEGSR  @PCKMOV;
 +
      //
 +
      //  CONVERT  KEY DATA
 +
      //  SET START POSN IN KEY USING OFFSET IN R
 +
          X1 = %LOOKUP(N(Y) : N );
 +
          W = R(X1) + 1;
 +
 +
        // ALPHA
 +
          IF  T(Y) = 'A';
 +
          X1  = 1;
 +
          FOR  Z = W  TO W + Q(Y);
 +
            %SUBST(KW : Z : 1) =  K(X1);
 +
            X1 = X1 + 1;
 +
          ENDFOR;
 +
          ENDIF;
 +
 +
        // NUMERIC FIELD
 +
        // RIGHT  ADJUST NUMERIC DATA ,STRIP - . ,CONVERT BLANKS
 +
          IF (T(Y) = 'S' OR T(Y) = 'P' OR T(Y) = 'B');
 +
          NU = '0';
 +
 +
          Z1 = 60;
 +
          FOR Z  =  K2  DOWNTO K1;
 +
 +
          IF K(Z) = '.' OR K(Z) = '-' OR K(Z) = '$';
 +
          ITER;
 +
          ENDIF;
 +
 +
          IF K(Z) = ' ' ;
 +
          NU(Z1) = '0';
 +
          ELSE;
 +
          NU(Z1) = K(Z);
 +
          ENDIF;
 +
 +
            Z1 = Z1 -1;
 +
          ENDFOR;
 +
 +
          ENDIF;
 +
 +
      // SIGNED FIELDS  (END POSN = OFFSET + SIZE)
 +
        IF T(Y)  = 'S';
 +
          NUS = 0;
 +
          FOR VX = 1 TO 60;
 +
            NUSA = %TRIM(NUSA) + NU(VX);
 +
          ENDFOR;
 +
        %SUBST(KW : W : Q(Y)) = %SUBST(NUSA: 61 -Q(Y));
 +
 +
        ENDIF;
 +
 +
      //  PACKED FIELDS
 +
          IF    T(Y)  =  'P';
 +
          NUSA= *BLANKS;
 +
          FOR VX = 1 TO 60;
 +
            NUSA = %TRIM(NUSA) + NU(VX);
 +
          ENDFOR;
 +
          NUP    = %DEC(NUSA : 60 : 0);
 +
 +
        %SUBST(KW : W : Q(Y))  =  %SUBST(NUPA: 61 -Q(Y));
 +
 +
        ENDIF;
 +
 +
      //  BINARY FIELDS
 +
        IF  T(Y) =  'B';
 +
 +
        IF  Q(Y) = 2 ;
 +
          BY2  = NU(1) + NU(2);
 +
          %SUBST(KW : W : 2)  =  BY2;
 +
        ENDIF;
 +
 +
        IF  Q(Y) = 4 ;
 +
          BY4  = NU(1) + NU(2) + NU(3) + NU(4);
 +
          %SUBST(KW : W : 4)  =  BY4;
 +
        ENDIF;
 +
 +
        ENDIF;
 +
 +
      ENDSR;
 +
 +
 +
      //  @@@@@@@  SETIN  @@@@@@@@@@@@@@@@@@@@@@@@@
 +
          BEGSR      @SETIN;
 +
 +
        //  SET the FFR indicators to get the Input buffer somewhat aligned with the
 +
        //  actual data.  RPG is somewhat tolerant to a difference between the Ispecs
 +
        //  and the actual file size but it can fail on big differences.
 +
        //  INCREMENT OF 32 BYTES
 +
          SZ(1)  = BASE + 16;
 +
          SZ(2)  = SZ(1) + 16;
 +
 +
          *IN30 = *ON;
 +
            IF (RLEN > SZ(2)) ;
 +
            *IN31  = *ON;
 +
            ENDIF;
 +
 +
          FOR X = 3 TO 64;
 +
          SZ(X) = SZ(X-1) + 32;
 +
            IF (RLEN > SZ(X)) ;
 +
            *IN(29+X) = *ON;
 +
            ENDIF;
 +
          ENDFOR;
 +
        ENDSR;
 +
 +
 +
        //@@@@@@@@@@@@@@@@@  @GETF  @@@@@@@@@@@@@@@@@
 +
          BEGSR  @GETF;
 +
      //  GET A DATA RECORD
 +
          IF  (*INU1);
 +
          IF  AID  = '1' OR AID  = X36 OR
 +
              AID  = X39 OR AID  = X3B ;
 +
            SETLL(E) KEYA  INPUTK;
 +
            READ(E)      INPUTK;
 +
              IF %EOF;
 +
              SETLL(E) KEYA  INPUTK;
 +
              READP(E)      INPUTK;
 +
              ENDIF;
 +
          ENDIF;
 +
 +
          IF  AID  = '4';
 +
            READP(E)  INPUTK;
 +
          ENDIF;
 +
 +
          IF  AID  = '5';
 +
            READ(E)  INPUTK;
 +
          ENDIF;
 +
 +
            IF  %ERROR;
 +
            SETLL(E) KEYA  INPUTK;
 +
            READ(E)      INPUTK;
 +
            MX = 7;
 +
                        EXSR      @ERROR;
 +
                        EXSR      @PUTF ;
 +
                        EXSR      @KEYIN;
 +
            ENDIF;
 +
 +
            KEYA = LKY;
 +
 +
 +
            CLEAR KW;
 +
            KW  = LKY;
 +
 +
          ENDIF;
 +
 +
          IF  (*INU2);
 +
          IF  AID  = '1';
 +
            CHAIN(E)  RRNA  INPUTR;
 +
            IF  %ERROR;
 +
              SETLL(E) RRNA  INPUTR;
 +
              READP(E)      INPUTR;
 +
            ENDIF;
 +
          ENDIF;
 +
 +
          IF  AID  = X36;
 +
            CHAIN(E)  RRNA  INPUTR;
 +
          ENDIF;
 +
 +
          IF  AID  = '4';
 +
            READP(E)  INPUTR;
 +
          ENDIF;
 +
 +
          IF  AID  = '5' OR AID = X3B;
 +
            READ(E)  INPUTR;
 +
          ENDIF;
 +
 +
          IF  AID  = X39;
 +
            SETLL(E) *HIVAL INPUTR;
 +
            READP(E)  INPUTR;
 +
          ENDIF;
 +
 +
          IF %ERROR;
 +
            CHAIN  1  INPUTR;
 +
            MX = 7;
 +
            EXSR      @ERROR;
 +
            EXSR      @PUTF ;
 +
            EXSR      @KEYIN;
 +
          ENDIF;
 +
          ENDIF;
 +
 +
          ENDSR;
 +
 +
 +
        //@@@@@@@@@@@@@@@@@  @PUTF  @@@@@@@@@@@@@@@@@
 +
          BEGSR  @PUTF;
 +
 +
              SELECT;
 +
                WHEN  *INU1;
 +
                RRN = RN1;
 +
                WHEN  *INU2;
 +
                RRN = RN2;
 +
              ENDSL;
 +
        // IF GOT RECORDS WRITE DATA TO THE DISPLAY
 +
 +
            NEWRU  = '1';
 +
            WRTRRN = '1';
 +
            RU    = *ALLX'00';
 +
            CLEAR  RU;        //  initialise Request Unit  255 bytes max
 +
 +
          IF RRN > 0    ;
 +
            FOR  XX = 1 TO      NUMFKY; //NUMBER OF DATA ELEMENTS (FLD AND KEY)
 +
 +
            IF NEWRU = '1';
 +
              NEWRU  = '0';
 +
              RU  = ESC + WTD + X20 + X00;
 +
            ENDIF;
 +
 +
            IF WRTRRN = '1';
 +
              WRTRRN = '0';
 +
              RU  = RU + SBA + RBA ;
 +
              RU = RU + %TRIM(%EDITC(RRN:'Z'));
 +
            ENDIF;
 +
 +
        // BUFFER ADDRESS
 +
            RU  = RU + SBA + B(XX);
 +
 +
        //  PROCESS ALPHA DATA TYPE
 +
            IF  T(XX) = 'A'  OR T(XX) = 'T'  OR T(XX) = 'Z' OR
 +
                T(XX) = 'L';
 +
 +
              STRX = S(XX);
 +
              ENDX = E(XX);
 +
 +
              IF V(XX) = 'Y';  //VARYING
 +
              VX  = S(XX);
 +
              HX2  = D(VX) + D(VX+1);
 +
              STRX  = S(XX) + 2 ;
 +
              ENDX  = S(XX) + BIN;
 +
              ENDIF;
 +
 +
              FOR Y = STRX  TO ENDX ;
 +
                IF D(Y) >= ' ';
 +
                RU = RU + D(Y);
 +
                ELSE;
 +
                RU = RU + X1F ;  //IF NOT DISPLAYABLE REPLACE WITH X'1F'
 +
                ENDIF;
 +
              ENDFOR;
 +
            ENDIF;
 +
 +
        //  PROCESS SIGNED DATA TYPE (not the RRN field)
 +
            IF  T(XX) = 'S' and KY(XX) <> '3';
 +
              NUSA =  *ALL'0';
 +
              WRV  =  *ALLX'00';
 +
              CLEAR WRV;
 +
              FOR Y = S(XX) TO E(XX);
 +
                IF D(Y) >= XD0;
 +
                WRV    =  WRV + D(Y);
 +
                ENDIF;
 +
              ENDFOR;
 +
              EVAL  NUSA = %SUBST(NUSA : 1 : 60 - %LEN(WRV)) + WRV;
 +
              CLEAR WRU;
 +
              WRU = %TRIM(WRU) + %EDITW(NUS :WRSWRD);
 +
              IF  P(XX) > 0;
 +
                RU  = RU  +
 +
                    %SUBST(WRU :61-C(XX): C(XX)-P(XX)) + '.' +
 +
                    %SUBST(WRU :61-P(XX))    ;
 +
              ELSE;
 +
                RU  = RU  +
 +
                    %SUBST(WRU :61-C(XX));
 +
              ENDIF;
 +
            ENDIF;
 +
 +
 +
        //  PROCESS SIGNED DATA TYPE (the RRN field)
 +
            IF  T(XX) = 'S' and KY(XX) =  '3';
 +
              RRN = RN2;
 +
              RU = RU + %TRIM(%EDITC(RRN:'X'));
 +
            ENDIF;
 +
 +
        //  PROCESS PACKED DATA TYPE
 +
            IF  T(XX) = 'P';
 +
              NUPA =  *ALLX'00';
 +
              WRV  =  *ALLX'00';
 +
              CLEAR WRV;
 +
              FOR Y = S(XX) TO E(XX);
 +
                WRV    =  WRV + D(Y);
 +
              ENDFOR;
 +
 +
              IF  %BITAND(D(E(XX)) :X0F) = X0F OR
 +
                    %BITAND(D(E(XX)) :X0D) = X0D;
 +
 +
                EVAL  NUPA = %SUBST(NUPA : 1 : 60 - %LEN(WRV)) + WRV;
 +
                CLEAR WRX;
 +
                WRX = %TRIM(WRX) + %EDITW(NUP :WRXWRD);
 +
                IF  P(XX) > 0;
 +
                RU  = RU  +
 +
                      %SUBST(WRX :64-C(XX): C(XX)-P(XX)) + '.' +
 +
                      %SUBST(WRX :64-P(XX))    ;
 +
                ELSE;
 +
                RU  = RU  +
 +
                      %SUBST(WRX :64-C(XX));
 +
                ENDIF;
 +
              ELSE;
 +
                // PACKED FIELD IN ERROR
 +
                RU = RU + X1F;
 +
              ENDIF;
 +
 +
            ENDIF;
 +
 +
        //  PROCESS BINARY DATA TYPE
 +
            IF  T(XX) = 'B';
 +
 +
            ST = S(XX);
 +
              CLEAR NUSA;
 +
              IF  Q(XX) = 2;
 +
              BY2  = D(ST) + D(ST+1);
 +
              NUS  = BIN2;
 +
              ENDIF;
 +
              IF  Q(XX) = 4;
 +
              BY4  = D(ST) + D(ST+1)+ D(ST+2) + D(ST+3);
 +
              NUS  = BIN4;
 +
              ENDIF;
 +
 +
              WRU =  %EDITW(NUS :WRSWRD);
 +
              IF  P(XX) > 0;
 +
                RU  = RU  +
 +
                    %SUBST(WRU :61-C(XX): C(XX)-P(XX)) + '.' +
 +
                    %SUBST(WRU :61-P(XX))    ;
 +
              ELSE;
 +
                RU  = RU  +
 +
                    %SUBST(WRU :61-C(XX));
 +
              ENDIF;
 +
            ENDIF;
 +
 +
 +
        //  PROCESS FLOAT  DATA TYPE
 +
            IF  T(XX) = 'F';
 +
 +
            ST = S(XX);
 +
 +
              IF  Q(XX) = 4;
 +
              FL4  = D(ST) + D(ST+1)+ D(ST+2) + D(ST+3);
 +
              FLT14 =  %EDITFLT(FLT4);
 +
                RU  = RU  + FLT14;
 +
              ENDIF;
 +
 +
              IF  Q(XX) = 8;
 +
              FL8  = D(ST) + D(ST+1)+ D(ST+2) + D(ST+3) +
 +
                      D(ST+4) + D(ST+5)+ D(ST+6) + D(ST+7);
 +
              FLT23 =  %EDITFLT(FLT8);
 +
                RU  = RU  + FLT23;
 +
              ENDIF;
 +
 +
            ENDIF;
 +
 +
 +
          //  SEND A REQUEST UNIT IF GOT ENOUGH DATA
 +
 +
            IF  %LEN(RU) + L(XX + 1) >= 200;
 +
              RU  =  RU + X20;
 +
              BIN  =  %LEN(RU);
 +
              OUTLEN  =  HX2;
 +
              INLEN  =  X000;
 +
              FNC    =  SND;
 +
              A      = RU;
 +
              EXCEPT  DATAO;
 +
              NEWRU  = '1';
 +
              RU    = *ALLX'00';
 +
              CLEAR  RU;
 +
            ENDIF;
 +
 +
            ENDFOR;
 +
          ENDIF;
 +
 +
            IF  %LEN(RU) > 5 AND %LEN(RU) < 250;
 +
              RU  =  RU + X20;
 +
              BIN  =  %LEN(RU);
 +
              OUTLEN  =  HX2;
 +
              INLEN  =  X000;
 +
              FNC    =  SND;
 +
              A      = RU;
 +
              EXCEPT  DATAO;
 +
            ENDIF;
 +
          ENDSR;
 +
 +
 +
        // @@@@@@@@@@@@@@@    ROWINC  @@@@@@@@@@@@@@@
 +
 +
        // INCREMENT THE ROW
 +
          BEGSR    @ROWINC;
 +
          ROW = ROW + 2;
 +
          IF  ROW > 20;
 +
            MX = 3;
 +
          ENDIF;
 +
          ENDSR;
 +
 +
 +
 +
        // @@@@@@@@@@@@@@@    GETFLD  @@@@@@@@@@@@@@@
 +
 +
        // LOAD FIELD DESCRIPTION ARRAYS
 +
          BEGSR    @GETFLD;
 +
          MX = 0;
 +
          X  = 0;
 +
 +
          IF  (*INU2 = *ON);
 +
          // IF NON KEYED ACCESS SET UP A FIELD TO SHOW THE RRN
 +
            N(1) =  'RRN';
 +
            T(1) =  'S'  ;
 +
            C(1) =  11  ;
 +
            P(1) =  0    ;
 +
            S(1) =  0    ;
 +
            E(1) =  0    ;
 +
            L(1) =  12  ;
 +
            I(1) = X4F06 ;
 +
            KY(1)= '3'  ;
 +
            X    = 1    ;
 +
          ENDIF;
 +
 +
          SCRST = *BLANK;
 +
          SCRSTN = *BLANK;
 +
 +
          LVL  = %DEC(SCNLVL : 5:0);
 +
 +
        TEXT500 = SCNLV ;
 +
        LV      = LVW;
 +
 +
        IF  LVL <> 0;
 +
          SCRST = LV(LVL);
 +
        ENDIF;
 +
 +
          SETLL 1 QWHDRFFD ;
 +
 +
          DOW  @LOOP  = @LOOP;
 +
        //  REREAD  TAG
 +
          READ    QWHDRFFD;
 +
          IF %EOF;
 +
            LEAVE;
 +
          ENDIF;
 +
 +
        //  SELECT OR OMIT
 +
          IF  ALL  <> '1';
 +
          IF  ALL  =  'S' AND WHDFTL = 0; // USING WHDFTL FOR KEY FIELDS
 +
            IF  WHFIOB  <>  'S';
 +
              ITER;
 +
            ENDIF;
 +
          ENDIF;
 +
          IF  ALL  =  'O' AND WHDFTL = 0; // USING WHDFTL FOR KEY FIELDS
 +
            IF  WHFIOB  =  'O';
 +
              ITER;
 +
            ENDIF;
 +
          ENDIF;
 +
          ENDIF;
 +
 +
        //  FIND THE FIRST FIELD TO BE SHOWN (FOR MULTI PAGE FORMATS)
 +
          IF  WHDFTL  <> 0 ;
 +
            ELSE;
 +
            IF SCRST <> ' ' AND SCRSTN = ' ';
 +
              IF WHFLDE =  SCRST;
 +
                SCRSTN = '1';    //  FOUND THE START
 +
              ELSE;
 +
                ITER;
 +
              ENDIF;
 +
            ENDIF;
 +
          ENDIF;
 +
 +
 +
          X =  X  + 1;
 +
        // CHECK FOR KEY FIELDS,WILL BE USED TO PLACE THEM IN FRONT
 +
          IF  WHDFTL  <>  0;
 +
              KY(X) = '1';
 +
              WX    = WHDFTL ;
 +
              KE(WX) = WHFLDE;
 +
              IF  NUMKEY <  WHDFTL;
 +
                NUMKEY = WHDFTL;
 +
              ENDIF;
 +
          ENDIF;
 +
 +
            N(X) =  WHFLDE ;              //    NAME
 +
            T(X) =  WHFLDT ;              //    TYPE
 +
            V(X) =  WHVARL ;              //    VARYING
 +
            C(X) =  WHFLDD ;              //    DEC DIGITS
 +
            P(X) =  WHFLDP ;              //    DEC PREC
 +
            S(X) =  WHFOBO ;              //    START
 +
            Q(X) =  WHFLDB ;              //    BTYES
 +
            E(X) =  WHFOBO + WHFLDB -1 ;  //  END
 +
 +
            IF T(X) =  'F' ;              //    FLOAT
 +
 +
              I(X) = FFA1 + FFA2;          //  SCRN FIELD FORMAT ALPHA
 +
              L(X)  = 14;
 +
              IF Q(X) = 8;
 +
              L(X)  = 23;
 +
              ENDIF;
 +
 +
            ELSE;
 +
              IF  WHFLDD  <> 0 ;
 +
              IF  WHFLDP  <> 0 ;
 +
                L(X) =  WHFLDD +  2  ;      //  LENGTH
 +
              ELSE;
 +
                L(X) =  WHFLDD +  1  ;      //  LENGTH
 +
              ENDIF;
 +
 +
                I(X) = FFN1 + FFN2;        //  SCRN FIELD FORMAT NUMERIC
 +
 +
              ELSE;
 +
                L(X) =    WHFLDB  ;
 +
                I(X) = FFA1 + FFA2;        //  SCRN FIELD FORMAT ALPHA
 +
              ENDIF;
 +
            ENDIF;
 +
 +
        ENDDO;
 +
        //  NUMBER OF FIELDS
 +
        NUMFLD = X ;
 +
 +
      //  MAKE ROOM FOR KEYS
 +
          IF  NUMKEY  >  0 ;
 +
          X1  = NUMKEY  + NUMFLD;
 +
 +
          FOR  X =  NUMFLD DOWNTO 1;
 +
              KY(X1) = KY(X) ;
 +
              L(X1)  = L(X)  ;
 +
              I(X1)  = I(X)  ;
 +
              N(X1)  = N(X)  ;
 +
              T(X1)  = T(X)  ;
 +
              V(X1)  = V(X)  ;
 +
              C(X1)  = C(X)  ;
 +
              P(X1)  = P(X)  ;
 +
              S(X1)  = S(X)  ;
 +
              E(X1)  = E(X)  ;
 +
              Q(X1)  = Q(X)  ;
 +
              X1    = X1 - 1;
 +
          ENDFOR;
 +
 +
          //  PUT KEY FIELDS AT TOP
 +
          OFF  = 0;
 +
          FOR  X =  1 TO NUMKEY;
 +
          X1 = %LOOKUP(KE(X) : N : NUMKEY+1);
 +
 +
          KY(X) = '2';
 +
          L(X)  = L(X1);
 +
          I(X)  = I(X1);  // FIELD FMT
 +
          SELECT;                // INPUT ENABLE
 +
            WHEN  I(X) = X6000;
 +
                  I(X) = X4800;
 +
            WHEN  I(X) = X6706;
 +
                  I(X) = X4F06;
 +
          ENDSL;
 +
            N(X) =  N(X1);
 +
            T(X) =  T(X1);
 +
            V(X) =  V(X1);
 +
            C(X) =  C(X1);
 +
            P(X) =  P(X1);
 +
            S(X) =  S(X1);
 +
            E(X) =  E(X1);
 +
            Q(X) =  Q(X1);
 +
            R(X) =  OFF;
 +
            OFF  =  OFF + Q(X1);
 +
          ENDFOR;
 +
 +
        ENDIF;
 +
      //  NUMBER OF FIELDS AND KEYS
 +
        NUMFKY = NUMFLD  +  NUMKEY;
 +
 +
        ENDSR;
 +
 +
 +
        // @@@@@@@@@@@@@@@    GETADD  @@@@@@@@@@@@@@@
 +
 +
        // LOAD FIELD BUFFER ADDRESSES
 +
          BEGSR    @GETADD;
 +
          MX = 0;
 +
          X  = 0;
 +
          ROW = 3;
 +
          COL = 1;
 +
 +
          FOR X = 1 TO NUMFKY;
 +
 +
        // IF FINISHED WITH THE KEY FIELDS
 +
        //  INC  ROW FOR 1ST DATA FIELD
 +
          IF KEYSOK = ' ' ;
 +
          IF KY(X) = ' ' OR KY(X) = '1';
 +
            KEYSOK = '1' ;
 +
            ROW    = ROW + 2;
 +
            COL    = 1;
 +
          ENDIF;
 +
          ENDIF;
 +
 +
        //  SET THE BUFFER ADD ON THE LARGER OF THE FIELD TEXT OR THE FIELD SIZE
 +
          LENDSC  = %LEN(%TRIM(N(X)));
 +
          LENWRK  =  L(X);
 +
          IF LENDSC > L(X);
 +
            LENWRK = LENDSC;
 +
          ENDIF;
 +
            LENWRK = LENWRK + 2;
 +
 +
        //  TRAP FIELDS THAT OVERFLOW
 +
            ROW  = ROW  + XROW;
 +
            XROW = %DIV(LENWRK : 80);
 +
 +
            IF (COL + LENWRK) > 78;
 +
              EXSR @ROWINC;
 +
                IF MX = 3;
 +
                X= X-1;
 +
                NUMFKY = X;
 +
                LEAVE;
 +
                ENDIF;
 +
              COL = 1;
 +
            ENDIF;
 +
 +
        // INC COL. FOR FIELD START
 +
          CLEAR  B(X);
 +
          BIN  = ROW;
 +
          B(X) =  %TRIM(B(X)) + HX1;
 +
          BIN  = COL + 1;
 +
          B(X) =  %TRIM(B(X)) + HX1;
 +
 +
        // INC COL. FOR NEXT FIELD
 +
        COL = COL + LENWRK;
 +
            IF COL > 78;
 +
              EXSR @ROWINC;
 +
                IF MX = 3;    // NO ROOM FOR THE FIELD
 +
                X= X-1;
 +
                NUMFKY = X;
 +
                LEAVE;
 +
                ENDIF;
 +
              COL = 1;
 +
            ENDIF;
 +
 +
          ENDFOR;
 +
 +
        //  FIELD LEVEL
 +
          LVX      = LVL + 1;
 +
          LV(LVX)  = N(X);
 +
 +
        ENDSR;
 +
 +
 +
        // @@@@@@@@@@@@@@@    PUTHED  @@@@@@@@@@@@@@@
 +
 +
        //  PUT FIELD HEADINGS
 +
          BEGSR    @PUTHED;
 +
 +
 +
            NEWRU  = '1';
 +
 +
            RU    = *ALLX'00';
 +
            CLEAR  RU;                  //  initialise Request Unit  255 bytes max
 +
            FOR  XX = 1 TO      NUMFKY; //NUMBER OF DATA ELEMENTS (FLD AND KEY)
 +
 +
            IF NEWRU = '1';
 +
              NEWRU  = '0';
 +
              RU  = ESC + WTD + X20 + X00;
 +
            ENDIF;
 +
 +
            RU = RU + SBA;
 +
            BIN = 0;
 +
              // CONVERT DATA BUFADR TO HEADING BUFADR
 +
            HX1 = %SUBST(B(XX) :1:1);
 +
            BIN = BIN - 1;
 +
            RU  = RU + HX1;
 +
 +
            IF  REHEAD = '1'; // ON REDISPLAY OVERRIDE THE ATTR
 +
              BIN = 0;
 +
              HX1 = %SUBST(B(XX) :2:1);
 +
              BIN = BIN -1 ;
 +
              RU  = RU + HX1;
 +
            ELSE;
 +
              RU  = RU + %SUBST(B(XX) :2);
 +
            ENDIF;
 +
 +
            RU = RU + ATC ;
 +
 +
        //  LONG NUMBER FIELDS ,RIGHT ADJUST THE FIELD HEADINGS
 +
            LENDSC  = %LEN(%TRIM(N(XX)));
 +
            IF  T(XX) <> 'A' AND  LENDSC <  (L(XX) -1);
 +
            FOR Y = 1 TO (L(XX) -(LENDSC +1));
 +
              RU = RU + ' ';
 +
            ENDFOR;
 +
            ENDIF;
 +
 +
            RU = RU + %TRIM(N(XX));
 +
 +
              IF %LEN(RU) >= 200;
 +
              BIN    = %LEN(RU);
 +
              OUTLEN = HX2;
 +
              INLEN  = X000;
 +
              FNC    = SND;
 +
              A      = RU;
 +
              EXCEPT DATAO;
 +
              NEWRU  = '1';
 +
              RU    = *ALLX'00';
 +
              CLEAR  RU;
 +
              ENDIF;
 +
 +
            ENDFOR;
 +
 +
              IF %LEN(RU) >  5 AND %LEN(RU) <  200;
 +
              BIN    = %LEN(RU);
 +
              OUTLEN = HX2;
 +
              INLEN  = X000;
 +
              FNC    = SND;
 +
              A      = RU;
 +
              EXCEPT DATAO;
 +
              ENDIF;
 +
 +
          IF REHEAD <> '1';
 +
        //  FORMAT FIELDS
 +
 +
 +
            NEWRU  = '1';
 +
            RU    = *ALLX'00';
 +
            CLEAR  RU;                  //  initialise Request Unit  255 bytes max
 +
            FOR  XX = 1 TO      NUMFKY; //NUMBER OF DATA ELEMENTS (FLD AND KEY)
 +
 +
            IF NEWRU = '1';
 +
              NEWRU  = '0';
 +
              RU  = ESC + WTD + X20 + X00;
 +
            ENDIF;
 +
 +
            RU = RU + SBA +B(XX)+SF + I(XX);
 +
 +
            IF KY(XX) = '1' OR KY(XX) = '2' OR KY(XX) = '3';
 +
              RU = RU + X25;
 +
            ELSE;
 +
              RU = RU + X26;
 +
            ENDIF;
 +
 +
            BIN =  L(XX);
 +
            RU  = RU + HX2;
 +
 +
          // LENGTH OF INPUT FIELDS
 +
            LENF  = LENF + L(XX) + 3;
 +
 +
 +
              IF %LEN(RU) >= 200;
 +
              BIN    = %LEN(RU);
 +
              OUTLEN = HX2;
 +
              INLEN  = X000;
 +
              FNC    = SND;
 +
              A      = RU;
 +
              EXCEPT DATAO;
 +
              NEWRU  = '1';
 +
              RU    = *ALLX'00';
 +
              CLEAR  RU;
 +
              ENDIF;
 +
 +
          ENDFOR;
 +
 +
      //  PUT LAST R/U
 +
              IF %LEN(RU) >  5 AND %LEN(RU) <  200;
 +
              BIN    = %LEN(RU);
 +
              OUTLEN = HX2;
 +
              INLEN  = X000;
 +
              FNC    = SND;
 +
              A      = RU;
 +
              EXCEPT DATAO;
 +
              ENDIF;
 +
 +
        //INC BUFFER ADDRESS FOR ALL FIELDS FOR DATA PUT
 +
            FOR  XP = 1 TO      NUMFKY; //NUMBER OF DATA ELEMENTS (FLD AND KEY)
 +
            HX2  = B(XP);
 +
            BIN  = BIN + 1;
 +
            B(XP) = HX2;
 +
            ENDFOR;
 +
          ENDIF;
 +
 +
        ENDSR;
 +
 +
      //  @@@@@@@  INIT  @@@@@@@@@@@@@@@@@@@@@@@@@
 +
          BEGSR        @INIT;
 +
 +
        CLEAR  KW;
 +
 +
        //  UPDATE
 +
          IF  UPDF  = 'Y';
 +
                FFA1 = X40;
 +
                FFN1 = X47;
 +
          ELSE;
 +
                FFA1 = X60;
 +
                FFN1 = X67;
 +
          ENDIF;
 +
 +
          SELECT;
 +
          WHEN  *INU1 = '1';
 +
                FILE  =  F1 ;
 +
                LIB  =  L1 ;
 +
                MBR  =  M1 ;
 +
                RCDL  =  R1 ;
 +
                ACCTP =  A1 ;
 +
          WHEN  *INU2 = '1';
 +
                FILE  =  F2 ;
 +
                LIB  =  L2 ;
 +
                MBR  =  M2 ;
 +
                RCDL  =  R2 ;
 +
                ACCTP =  A2 ;
 +
          ENDSL;
 +
            RLEN    =  RCDL  ;
 +
            RLENTH  =  %EDITC(RLEN: 'X') ;
 +
            LENF    =  0    ;
 +
 +
 +
        // Control commands and data are constructed into RUs Request UNITS
 +
        // Each RU is 256 bytes max size.
 +
        // Construct and send as many RUs as needed to format the display.
 +
            RU    = *ALLX'00';
 +
            CLEAR  RU;        //  initialise Request Unit  255 bytes max
 +
            RU  = CLRWTD ;
 +
          //set up the screen headings
 +
            BIN = 1;    // set ROW to 1
 +
            RW  = HX1;
 +
            BIN = 2;    // set COL to 2
 +
            CL  = HX1;
 +
            RU  = RU + SBA + RW + CL + X22 + %TRIM(LIB) + '/' + %TRIM(FILE);
 +
            RU  = RU + ' Mbr ' + %TRIM(MBR) + ' Rcdl ' + %EDITC(RLEN  : 'Z') ;
 +
            RU  = RU + ' RRN '  ;
 +
            BIN = %len(RU) -4;
 +
            RBA = RW + HX1 ;  // address of the RRN field
 +
            RU  = RU + SBA + RBA + '          ';
 +
 +
      // FUNCTION KEYS
 +
            BIN  = 23;
 +
            RW  = HX1;
 +
            BIN  = 02;
 +
            CL  = HX1;
 +
            IF  UPDF = 'Y';  //  UPDATE IS ON
 +
            RU  = RU + SBA + RW + CL + %TRIM(CNS(2));
 +
            ELSE;
 +
            RU  = RU + SBA + RW + CL + %TRIM(CNS(1));
 +
            ENDIF;
 +
 +
        //  THIS IS A SEND ONLY FUNCTION
 +
          FNC    = SND;
 +
          CLEAR A;
 +
          A      = RU;
 +
          BIN2    = %LEN(RU);
 +
          OUTLEN  = BY2;
 +
          INLEN  = x000;
 +
 +
          EXCEPT    DATAO;
 +
 +
        ENDSR;
 +
 +
 +
      //  @@@@@@@  KEYIN  @@@@@@@@@@@@@@@@@@@@@@@@@
 +
        BEGSR  @KEYIN;
 +
      // ISSUE A READ FROM DISPLAY
 +
          FNC = SNR;
 +
          BIN2  = 8;
 +
          OUTLEN = BY2;
 +
          IPL = LENF + 34;
 +
          BIN2  = IPL;
 +
          INLEN  = BY2;
 +
 +
          // SET FRR INDICATORS TO CONTROL BUFFER OVERFLOW
 +
          FOR X =  1 TO  9;
 +
            IF IPL  >  ( X*80 +3);
 +
              *IN(X+19) = *ON;
 +
            ENDIF;
 +
          ENDFOR;
 +
 +
        RU    = *ALLX'00';
 +
        CLEAR  RU;
 +
        RU  = RDDSP;
 +
        A    = RU;
 +
 +
        EXCEPT DATAI;
 +
        ENDSR;
 +
 +
      //  @@@@@@@  ERROR  @@@@@@@@@@@@@@@@@@@@@@@@@
 +
        BEGSR    @ERROR;
 +
 +
      // SETUP PUT ERROR MESSAGE X'21'
 +
        RU    = *ALLX'00';
 +
        CLEAR RU;
 +
 +
        FNC    =  SNR;
 +
        BIN    = 42;
 +
        OUTLEN = HX2;
 +
        BIN    = LENF + 34;
 +
        IPL    = BIN;
 +
        INLEN  = HX2;
 +
 +
        FOR X        = 1 TO 9;
 +
          IF IPL      > (X * 80 +3) ;
 +
          *IN(X + 19) = *ON;          // SETON FFR 20 - 29 FOR INPUT
 +
          ENDIF;
 +
        ENDFOR;
 +
 +
        RU = ESC + WER + IC + B(1) + ATC + MSG(MX);
 +
        RU = RU + ESC + RDM + X40+ X00;
 +
 +
        A  = RU;
 +
        EXCEPT    DATAI;
 +
        RU    = *ALLX'00';
 +
        CLEAR RU;
 +
        ENDSR;
 +
 +
 +
      //  @@@@@@@    HXDSP @@@@@@@@@@@@@@@@@@@@@@@@@
 +
        BEGSR  @HXDSP;
 +
 +
          RU    = *ALLX'00';
 +
          CLEAR RU;
 +
          Y = %LOOKUPLE( CURLOC : B );
 +
          //
 +
          RU = ESC + WTD + X20 + X00 + SBA;
 +
          BIN = 0;
 +
          HX1 = %SUBST(B(Y) :1:1);
 +
          BIN = BIN - 1;
 +
          RU  = RU + HX1;
 +
          RU  = RU + %SUBST(B(Y) :2:1);
 +
 +
          FOR X = S(Y) TO E(Y);
 +
            BIN = 0;
 +
            HX1 = D(X);
 +
            HX1 = %BITAND(HX1  : XF0);
 +
            Z  = BIN / 16 + 1;
 +
            RU  = RU + CRS(Z);
 +
          ENDFOR;
 +
 +
            RU  = RU + X20;
 +
 +
            RU  = RU + SBA + B(Y);
 +
          FOR X = S(Y) TO E(Y);
 +
            BIN = 0;
 +
            HX1 = D(X);
 +
            HX1 = %BITAND(HX1  : X0F);
 +
            Z  = BIN  + 1;
 +
            RU  = RU + CRS(Z);
 +
          ENDFOR;
 +
 +
 +
          BIN    = %LEN(RU);
 +
          OUTLEN = HX2;
 +
          INLEN  = X000;
 +
          FNC    = SND;
 +
          A      = RU;
 +
          EXCEPT DATAO;
 +
          RU    = *ALLX'00';
 +
          CLEAR  RU;
 +
 +
 +
          EXSR      @KEYIN;
 +
          READ      DISPF;
 +
 +
 +
      //  CLEAR HEADINGS
 +
            RU    = *ALLX'00';
 +
            CLEAR RU;
 +
 +
        RU  = RU + ESC + WTD + X20 + X00 + SBA;
 +
        HX1  = %SUBST(B(Y) :1:1) ;
 +
        BIN  = BIN - 1;
 +
        RU  = RU + HX1 + %SUBST(B(Y):2:1);
 +
          FOR X = S(Y) TO E(Y);
 +
          RU = RU + ' ';
 +
          ENDFOR;
 +
        RU = RU + ' ';
 +
 +
        BIN    = %LEN(RU);
 +
        OUTLEN = HX2;
 +
        INLEN  = X000;
 +
        FNC    = SND;
 +
        A      = RU;
 +
        EXCEPT    DATAO;
 +
        RU    = *ALLX'00';
 +
        CLEAR  RU;
 +
 +
        ENDSR;
 +
 +
 +
 +
      //  @@@@@@@    UPD  @@@@@@@@@@@@@@@@@@@@@@@@@
 +
          BEGSR  @UPD;
 +
 +
        // CONVERT  DATA  FOR OUTPUT
 +
 +
        //  FOR EACH  FIELD, CHECK IF FIELD WAS MODIFIED, AND IF SO MOVE
 +
        // THE MODIFIED DATA INTO THE OUTPUT ARRAY
 +
        K1 = 0;
 +
        K2 = 0;
 +
        W  = 1;
 +
        CGKY = *BLANK;  // KEY CHANGED
 +
        KW  = KEYA;
 +
 +
          FOR  Y  = 1  TO NUMFKY ;
 +
 +
            IF KY(Y) > '1';
 +
            ITER;
 +
            ENDIF;
 +
 +
 +
      //  MOVE A KEY FIELDS DATA FROM ID ARRAY (SCREEN) TO K ARRAY
 +
 +
      //  GET SIZE OF FIELD IN BYTES
 +
          IF T(Y)  =  'A';  // ALPHA DATA
 +
          K = ' ';
 +
          K1 = 1;
 +
          K2 = Q(Y);
 +
          ELSE;
 +
          K  = '0';
 +
          K1 =  1;
 +
          K2 = C(Y);
 +
          ENDIF;
 +
 +
          X  =  1;
 +
 +
          DOW  @LOOP = @LOOP;
 +
 +
      //  NXTSBA
 +
          X  = %LOOKUP(SBA : ID : X );
 +
          IF X = 0;
 +
            LEAVE;
 +
          ENDIF;
 +
 +
      // IS THIS THE FIELD?  CHECK THE BUFFER ADDRESS
 +
        X = X +1;
 +
        IF  B(Y)  <>  %SUBST(IDA : X :2);
 +
          ITER;
 +
        ENDIF;
 +
 +
 +
      //  FOUND A MTD FOR THIS FIELD
 +
 +
 +
        // CHECK IF FIELD WAS CLEARED ONLY
 +
          DOW @LOOP = @LOOP; //  not a loop
 +
        X =  X + 2;
 +
        IF  ID(X) = SBA;
 +
          LEAVE;
 +
        ENDIF;
 +
 +
      //  IF FIELD HAS DECIMALS BUMP X
 +
          IF (T(Y) = 'S' OR T(Y) = 'P' OR T(Y) = 'B') AND
 +
              P(Y) > 0;
 +
              X = X + 1;
 +
          ENDIF;
 +
 +
 +
      //  CHECK IF ONLY BLANKS RETURNED
 +
          IF    %SUBST(IDA : X :K2) = *BLANKS;
 +
              LEAVE;
 +
          ENDIF;
 +
 +
        // MOVE DATA TO WORK ARRAY K
 +
            X1 = X;
 +
            FOR X2 = 1 TO K2;
 +
 +
            IF ID(X1) < ' ';
 +
              LEAVE;
 +
            ENDIF;
 +
 +
            K(X2) = ID(X1);
 +
            X1 = X1 + 1;
 +
            ENDFOR;
 +
 +
          LEAVE;
 +
        ENDDO;
 +
 +
        // *  SET START POSN
 +
          W =  S(Y);
 +
 +
        // ALPHA
 +
          IF T(Y) =  'A'  and V(XX) <>  'Y';
 +
          FOR Z  =  K1 to K2;
 +
            D(W) =  K(Z);
 +
            W    =  W + 1;
 +
          ENDFOR;
 +
          ENDIF;
 +
 +
        IF T(Y) =  'A' and  V(XX) = 'Y';  //VARYING
 +
 +
        //  the data start is in S(Y)
 +
        //  the data is in array K
 +
        //  get the length of the data cvt to bin and stik in pos 1 2
 +
        //  put the rest in pos 3 onwards
 +
 +
              ENDIF;
 +
 +
        // NUMERIC FIELD
 +
        // RIGHT  ADJUST NUMERIC DATA ,STRIP - . ,CONVERT BLANKS
 +
          IF (T(Y) = 'S' OR T(Y) = 'P' OR T(Y) = 'B');
 +
          NU = '0';
 +
 +
          Z1 = 60;
 +
          FOR Z  =  K2  DOWNTO K1;
 +
 +
          IF K(Z) = '.' OR K(Z) = '-' OR K(Z) = '$';
 +
          ITER;
 +
          ENDIF;
 +
 +
          IF K(Z) = ' ' ;
 +
          NU(Z1) = '0';
 +
          ELSE;
 +
          NU(Z1) = K(Z);
 +
          ENDIF;
 +
 +
            Z1 = Z1 -1;
 +
          ENDFOR;
 +
 +
          ENDIF;
 +
 +
 +
      // SIGNED FIELDS  (END POSN = OFFSET + SIZE)
 +
        IF T(Y)  = 'S';
 +
          NUSA= *BLANKS;
 +
          FOR VX = 1 TO 60;
 +
            NUSA = %TRIM(NUSA) + NU(VX);
 +
          ENDFOR;
 +
        %SUBST(DATA  : W : Q(Y)) = %SUBST(NUSA: 61 -Q(Y));
 +
 +
        ENDIF;
 +
 +
 +
      //  PACKED FIELDS
 +
          IF    T(Y)  =  'P';
 +
          NUSA= *BLANKS;
 +
          FOR VX = 1 TO 60;
 +
            NUSA = %TRIM(NUSA) + NU(VX);
 +
          ENDFOR;
 +
          NUP    = %DEC(NUSA : 60 : 0);
 +
 +
        %SUBST(DATA : W : Q(Y))  =  %SUBST(NUPA: 61 -Q(Y));
 +
        ENDIF;
 +
 +
      //  BINARY FIELDS
 +
        IF  T(Y) =  'B';
 +
 +
        NUSA= *BLANKS;
 +
          FOR VX = 1 TO 60;
 +
            NUSA = %TRIM(NUSA) + NU(VX);
 +
          ENDFOR;
 +
            NUC  = NUS;
 +
 +
        IF  Q(Y) = 2 ;
 +
              DISBIN  ( NUC : BAN2 : BAN4  : '2');
 +
            %SUBST(DATA : W : 2)  =  BAN2;
 +
        ENDIF;
 +
 +
        IF  Q(Y) = 4 ;
 +
              DISBIN  ( NUC : BAN2 : BAN4  : '4');
 +
            %SUBST(DATA : W : 4)  =  BAN4;
 +
        ENDIF;
 +
 +
        ENDIF;
 +
 +
        //  UPDATE KEY IF NECESSARY
 +
        IF  KY(Y)  = '1';
 +
            CGKY = '1';
 +
            EXSR  @PCKMOV;
 +
        ENDIF;
 +
 +
 +
        ENDDO;
 +
        ENDFOR;
 +
 +
 +
          IF  CGKY = '1';
 +
          KEYA = KW;
 +
          ENDIF;
 +
 +
        ENDSR;
 +
 +
 +
 +
      /END-FREE
 +
 +
    OINPUTK    E    U1      UPDATREC
 +
    O                      DA
 +
    O              30      DB
 +
    O              31      DC
 +
    O              32      DD
 +
    O              33      DE
 +
    O              34      DF
 +
    O              35      DG
 +
    O              36      DH
 +
    O              37      DI
 +
    O              38      DJ
 +
    O              39      DK
 +
    O              40      DL
 +
    O              41      DM
 +
    O              42      DN
 +
    O              43      DZ
 +
    O              44      DO
 +
    O              45      DP
 +
    O              46      DQ
 +
    O              47      DR
 +
    O              48      DS
 +
    O              49      DT
 +
    O              50      DU
 +
    O              51      DV
 +
    O              52      DW
 +
    O              53      DX
 +
    O              54      DY
 +
    O              55      D0
 +
    O              56      D1
 +
    O              57      D2
 +
    O              58      D3
 +
    O              59      D4
 +
    O              60      D5
 +
    O              61      D6
 +
    O              62      DBA
 +
    O              63      DCA
 +
    O              64      DDA
 +
    O              65      DEA
 +
    O              66      DFA
 +
    O              67      DGA
 +
    O              68      DHA
 +
    O              69      DIA
 +
    O              70      DJA
 +
    O              71      DKA
 +
    O              72      DLA
 +
    O              73      DMA
 +
    O              74      DNA
 +
    O              75      DOA
 +
    O              76      DPA
 +
    O              77      DQA
 +
    O              78      DRA
 +
    O              79      DSA
 +
    O              80      DTA
 +
    O              81      DUA
 +
    O              82      DVA
 +
    O              83      DWA
 +
    O              84      DXA
 +
    O              85      DYA
 +
    O              86      DZA
 +
    O              87      D0A
 +
    O              88      D1A
 +
    O              89      D2A
 +
    O              90      D3A
 +
    O              91      D4A
 +
    O              92      D5A
 +
    O              93      D6A
 +
    OINPUTR    E      U2  UPDATREC
 +
    O                      DA
 +
    O              30      DB
 +
    O              31      DC
 +
    O              32      DD
 +
    O              33      DE
 +
    O              34      DF
 +
    O              35      DG
 +
    O              36      DH
 +
    O              37      DI
 +
    O              38      DJ
 +
    O              39      DK
 +
    O              40      DL
 +
    O              41      DM
 +
    O              42      DN
 +
    O              43      DZ
 +
    O              44      DO
 +
    O              45      DP
 +
    O              46      DQ
 +
    O              47      DR
 +
    O              48      DS
 +
    O              49      DT
 +
    O              50      DU
 +
    O              51      DV
 +
    O              52      DW
 +
    O              53      DX
 +
    O              54      DY
 +
    O              55      D0
 +
    O              56      D1
 +
    O              57      D2
 +
    O              58      D3
 +
    O              59      D4
 +
    O              60      D5
 +
    O              61      D6
 +
    O              62      DBA
 +
    O              63      DCA
 +
    O              64      DDA
 +
    O              65      DEA
 +
    O              66      DFA
 +
    O              67      DGA
 +
    O              68      DHA
 +
    O              69      DIA
 +
    O              70      DJA
 +
    O              71      DKA
 +
    O              72      DLA
 +
    O              73      DMA
 +
    O              74      DNA
 +
    O              75      DOA
 +
    O              76      DPA
 +
    O              77      DQA
 +
    O              78      DRA
 +
    O              79      DSA
 +
    O              80      DTA
 +
    O              81      DUA
 +
    O              82      DVA
 +
    O              83      DWA
 +
    O              84      DXA
 +
    O              85      DYA
 +
    O              86      DZA
 +
    O              87      D0A
 +
    O              88      D1A
 +
    O              89      D2A
 +
    O              90      D3A
 +
    O              91      D4A
 +
    O              92      D5A
 +
    O              93      D6A
 +
 +
    OINPUTK    EADD U1      ADDREC
 +
    O                      DA
 +
    O              30      DB
 +
    O              31      DC
 +
    O              32      DD
 +
    O              33      DE
 +
    O              34      DF
 +
    O              35      DG
 +
    O              36      DH
 +
    O              37      DI
 +
    O              38      DJ
 +
    O              39      DK
 +
    O              40      DL
 +
    O              41      DM
 +
    O              42      DN
 +
    O              43      DZ
 +
    O              44      DO
 +
    O              45      DP
 +
    O              46      DQ
 +
    O              47      DR
 +
    O              48      DS
 +
    O              49      DT
 +
    O              50      DU
 +
    O              51      DV
 +
    O              52      DW
 +
    O              53      DX
 +
    O              54      DY
 +
    O              55      D0
 +
    O              56      D1
 +
    O              57      D2
 +
    O              58      D3
 +
    O              59      D4
 +
    O              60      D5
 +
    O              61      D6
 +
    O              62      DBA
 +
    O              63      DCA
 +
    O              64      DDA
 +
    O              65      DEA
 +
    O              66      DFA
 +
    O              67      DGA
 +
    O              68      DHA
 +
    O              69      DIA
 +
    O              70      DJA
 +
    O              71      DKA
 +
    O              72      DLA
 +
    O              73      DMA
 +
    O              74      DNA
 +
    O              75      DOA
 +
    O              76      DPA
 +
    O              77      DQA
 +
    O              78      DRA
 +
    O              79      DSA
 +
    O              80      DTA
 +
    O              81      DUA
 +
    O              82      DVA
 +
    O              83      DWA
 +
    O              84      DXA
 +
    O              85      DYA
 +
    O              86      DZA
 +
    O              87      D0A
 +
    O              88      D1A
 +
    O              89      D2A
 +
    O              90      D3A
 +
    O              91      D4A
 +
    O              92      D5A
 +
    O              93      D6A
 +
    OINPUTR    EADD    U2  ADDREC
 +
    O                      DA
 +
    O              30      DB
 +
    O              31      DC
 +
    O              32      DD
 +
    O              33      DE
 +
    O              34      DF
 +
    O              35      DG
 +
    O              36      DH
 +
    O              37      DI
 +
    O              38      DJ
 +
    O              39      DK
 +
    O              40      DL
 +
    O              41      DM
 +
    O              42      DN
 +
    O              43      DZ
 +
    O              44      DO
 +
    O              45      DP
 +
    O              46      DQ
 +
    O              47      DR
 +
    O              48      DS
 +
    O              49      DT
 +
    O              50      DU
 +
    O              51      DV
 +
    O              52      DW
 +
    O              53      DX
 +
    O              54      DY
 +
    O              55      D0
 +
    O              56      D1
 +
    O              57      D2
 +
    O              58      D3
 +
    O              59      D4
 +
    O              60      D5
 +
    O              61      D6
 +
    O              62      DBA
 +
    O              63      DCA
 +
    O              64      DDA
 +
    O              65      DEA
 +
    O              66      DFA
 +
    O              67      DGA
 +
    O              68      DHA
 +
    O              69      DIA
 +
    O              70      DJA
 +
    O              71      DKA
 +
    O              72      DLA
 +
    O              73      DMA
 +
    O              74      DNA
 +
    O              75      DOA
 +
    O              76      DPA
 +
    O              77      DQA
 +
    O              78      DRA
 +
    O              79      DSA
 +
    O              80      DTA
 +
    O              81      DUA
 +
    O              82      DVA
 +
    O              83      DWA
 +
    O              84      DXA
 +
    O              85      DYA
 +
    O              86      DZA
 +
    O              87      D0A
 +
    O              88      D1A
 +
    O              89      D2A
 +
    O              90      D3A
 +
    O              91      D4A
 +
    O              92      D5A
 +
    O              93      D6A
 +
 +
    OINPUTK    EDEL U1      DELREC
 +
    OINPUTR    EDEL U2      DELREC
 +
 +
 +
    ODISPF    E            DATAO
 +
    O                                          K3 'PUT'
 +
    O                      OUTLEN              2
 +
    O                      INLEN
 +
    O                      FNC
 +
    O                      A
 +
 +
    O          E            DATAI
 +
    O                                          K3 'GET'
 +
    O                      OUTLEN              2
 +
    O                      INLEN
 +
    O                      FNC
 +
    O                      A
 +
**
 +
0000 INVALID COMMAND KEY
 +
0001  - A FIELD IS TOO LONG
 +
0002  - TOO MANY FIELDS
 +
0003  - ALPHAS IN PACKED KEY
 +
0004  - MISSING ' IN PACKED KEY
 +
0005  - MISSING DATA IN PCKD KEY
 +
0006  - RECORD NOT FOUND
 +
PRESS RESET TO CONTINUE
 +
**
 +
F1-HEX F2-Return F3-Exit F19-Prev_fld F20-More_fld
 +
F1-HEX F2-Return F3-Exit F6-Update F9-Add F11-Del F19-Prev_fld F20-More_fld
 +
**
 +
0123456789ABCDEF
 +
 +
 +
</pre>
 +
 +
[[#top]]
 +
 +
 +
===DISPF  DSPF ===
 +
 +
<pre>
 +
    A                                      DSPSIZ(24 80 *DS3)
 +
    A                                      PRINT
 +
    A                                      OPENPRT
 +
    A                                      HELP
 +
    A                                      INDARA
 +
    A          R PUT                      USRDFN
 +
    A          R GET                      USRDFN
 +
    A                                      INVITE
 +
</pre>
 +
 +
 +
[[#top]]
 +
 +
== WRAPPER CODE ==
 +
 +
===DSPFL    CMD ===
 +
 +
<pre>
 +
  /*  TO COMPILE */
 +
  /*  CRTCMD CMD(*CURLIB/DSPFL) PGM(*LIBL/DIS) SRCFILE(*LIBL/QCMDSRC) */
 +
  /*          SRCMBR(DSPFL) VLDCKR(DISV) */
 +
 
 +
            CMD        PROMPT('Display file in field format')
 +
 +
            PARM      KWD(FILE) TYPE(QUAL1) MIN(1) MAX(1) +
 +
                          PROMPT('File')
 +
 +
            PARM      KWD(MBR) TYPE(*NAME) DFT(*FIRST) +
 +
                          SPCVAL((*FILE) (*FIRST)) MIN(0) MAX(1) +
 +
                          PROMPT('Member')
 +
 +
            PARM      KWD(UPD ) TYPE(*CHAR) LEN(1) DFT(N) +
 +
                          RSTD(*YES) VALUES('Y' 'N' 'y' 'n') +
 +
                          PROMPT('Update data (Y/N)')
 +
 +
            PARM      KWD(RST ) TYPE(*CHAR) LEN(1) DFT(N) +
 +
                          RSTD(*YES) VALUES('Y' 'N' 'y' 'n') +
 +
                          PROMPT('Get DDS again.')
 +
 +
            PARM      KWD(REL ) TYPE(*CHAR) LEN(1) DFT(N) +
 +
                          RSTD(*YES) VALUES('Y' 'N' 'y' 'n') +
 +
                          PROMPT('Show Relations')
 +
 +
 +
QUAL1:      QUAL      TYPE(*NAME) LEN(10)
 +
            QUAL      TYPE(*NAME) LEN(10) DFT(*LIBL  ) +
 +
                          SPCVAL(*LIBL  ) +
 +
                          PROMPT('Library name')
 +
 +
 +
</pre>
 +
 +
[[#top]]
 +
 +
===DIS    CL ===
 +
 +
<pre>
 +
 +
/* Command processing program for DSPFF command */
 +
 +
PGM (&FILIB  &MBR &UPD &RST &REL)
 +
 +
DCL &FILIB *CHAR 20
 +
DCL &FILE *CHAR  10
 +
DCL &LIB  *CHAR  10
 +
DCL &SFILE *CHAR  10
 +
DCL &SLIB  *CHAR  10
 +
DCL &MBR  *CHAR  10
 +
DCL &OPT  *CHAR  10
 +
DCL &ALL  *CHAR 1
 +
DCL &RTN  *CHAR 1
 +
DCL &RMBR  *CHAR  10
 +
 +
DCL &QRY  *LGL
 +
DCL &UPD  *LGL
 +
DCL &REL  *CHAR 1
 +
DCL &RST  *CHAR 1
 +
 +
DCL &RCDL *CHAR 5
 +
DCL &RCDLN *DEC (5 0)
 +
DCL &ACCP *CHAR 1
 +
DCL &OVR  *LGL  VALUE('0')
 +
DCL &FILEF *CHAR  10
 +
DCL &FILEK *CHAR  10
 +
DCL &ID    *CHAR  7
 +
DCL &MF    *CHAR  10
 +
DCL &ML    *CHAR  10
 +
DCL &TYPE  *CHAR  1
 +
DCL &PHY  *CHAR  10
 +
DCL &PHYLIB *CHAR  10
 +
 +
RMVLIBLE QTEMP
 +
MONMSG CPF0000
 +
ADDLIBLE QTEMP *FIRST
 +
MONMSG CPF0000 EXEC(GOTO END)
 +
 +
RESET:
 +
CHGVAR &FILE  &FILIB
 +
CHGVAR &LIB  (%SST(&FILIB 11 10))
 +
IF (&LIB *EQ ' ')    (CHGVAR &LIB '*LIBL')
 +
IF (&MBR *EQ '*FILE') (CHGVAR &MBR &FILE)
 +
IF (&MBR *EQ '*FIRST') (DO)
 +
RTVMBRD    FILE(&LIB/&FILE) RTNMBR(&RMBR)
 +
CHGVAR &MBR &RMBR
 +
ENDDO
 +
CHGVAR &FILEF ('FF'||(%SST(&FILE 1 8)))
 +
CHGVAR &FILEK ('KF'||(%SST(&FILE 1 8)))
 +
 +
IF (&RST= 'Y') DO
 +
DLTF  &FILEF
 +
MONMSG CPF0000
 +
DLTF  &FILEK
 +
MONMSG CPF0000
 +
ENDDO
 +
 +
 +
CHKOBJ (QTEMP/&FILEF) *FILE
 +
  MONMSG CPF9801 EXEC(DO)
 +
  DSPFFD  FILE(&LIB/&FILE) OUTPUT(*OUTFILE) OUTFILE(QTEMP/&FILEF)
 +
  DSPFD (&LIB/&FILE) TYPE(*ACCPTH) OUTPUT(*OUTFILE) OUTFILE(QTEMP/&FILEK)
 +
  CHGVAR &RTN '2'
 +
ENDDO
 +
 +
CHGPF QTEMP/&FILEF LVLCHK(*NO)
 +
CHGPF QTEMP/&FILEK LVLCHK(*NO)
 +
 +
IF (&REL = 'Y' ) DO
 +
  CALL DISF  (&FILEK &TYPE &PHY &PHYLIB)
 +
  IF (&TYPE *EQ 'P') DO
 +
    CHGVAR &PHY &FILE
 +
    CHGVAR &PHYLIB &LIB
 +
  ENDDO
 +
CALL  DIS3 (&PHY &PHYLIB &SFILE &SLIB)
 +
IF (&SFILE *NE ' ') DO
 +
  IF ((&SFILE *NE &FILE) *OR (&SLIB *NE &LIB)) DO
 +
  CHGVAR &FILIB (&SFILE||&SLIB)
 +
  CHGVAR &REL '0'
 +
  RTVMBRD    FILE(&SLIB/&SFILE) RTNMBR(&RMBR)
 +
  CHGVAR &MBR &RMBR
 +
  IF (&MBR  *EQ &FILE) THEN(CHGVAR &MBR '*FILE    ')
 +
  GOTO  RESET
 +
  ENDDO
 +
ENDDO
 +
ENDDO
 +
 +
CALL  DIS1 (&FILIB  &MBR &UPD &RST &RTN &FILE &LIB &FILEF &FILEK)
 +
 +
RCLRSC
 +
 +
END:
 +
CLOF  OPNID(&FILE)
 +
MONMSG CPF0000
 +
 +
 +
 +
ENDPGM
 +
 +
</pre>
 +
 +
[[#top]]
 +
 +
===DIS1    CL ===
 +
 +
<pre>
 +
/* CALLED BY DIS TO DRIVE SELECTION OF UDDS RPG PROGRAM */
 +
/*  FILE DISPLAYER DRIVER  */
 +
/*  SHOWS A LIST OF FIELDS IN A FILE , ALLOWS SELECTION OF FIELDS  */
 +
 +
/*  WHEN ALL THE FIELDS DONT FIT ON ONE SCREEN                */
 +
/*  THIS CONTAINS A LOOP SO THAT MORE FIELDS CAN BE DISPLAYED  */
 +
 +
 +
PGM (&FILIB  &MBR &UPD &RST &RTN &FILE &LIB &FILEF &FILEK)
 +
 +
DCL &FILIB *CHAR 20
 +
DCL &FILE *CHAR  10
 +
DCL &LIB  *CHAR  10
 +
DCL &MBR  *CHAR  10
 +
DCL &PRG  *CHAR  10
 +
DCL &OPT  *CHAR  10
 +
DCL &ALL  *CHAR 1
 +
DCL &RTN  *CHAR 1
 +
DCL &RMV  *CHAR 1
 +
DCL &QRY  *LGL
 +
DCL &UPD  *CHAR 1
 +
DCL &RST  *LGL
 +
DCL &KEYL *CHAR 4
 +
DCL &RCDL *CHAR 5
 +
DCL &RCDLN *DEC (5 0)
 +
DCL &ACCP *CHAR 1
 +
DCL &OVR  *LGL  VALUE('0')
 +
DCL &FILEF *CHAR  10
 +
DCL &FILEK *CHAR  10
 +
DCL &ID    *CHAR  7
 +
DCL &MF    *CHAR  10
 +
DCL &ML    *CHAR  10
 +
DCL &SCNLV *CHAR  500
 +
DCL &SCNLVL *CHAR  5
 +
DCL &SCNKEY *CHAR  800
 +
DCL &JOB  *CHAR  10
 +
DCL &MSG  *CHAR  80
 +
DCLF    DISPX
 +
 +
CHGVAR &PGMQ DIS
 +
CHGVAR &SCNLVL '00000'
 +
 +
OVRDBF FFD QTEMP/&FILEF SECURE(*YES)
 +
OVRDBF KF  QTEMP/&FILEK SECURE(*YES)
 +
 +
 +
RTN:
 +
OVRDBF  INPUT  &LIB/&FILE  SHARE(*NO)
 +
CALL  DISPY    (&ALL &RTN &KEYL &ACCP &QRY &RCDL)
 +
            MONMSG    MSGID(CPF5035 CPF5029 RNQ1299 RNX0000) EXEC(DO)
 +
            RTVJOBA    JOB(&JOB)
 +
            SNDBRKMSG  MSG('Cannot handle this file type. Possibly +
 +
                          has NULL data field.') TOMSGQ(&job) +
 +
                          MSGTYPE(*INQ) RPYMSGQ(&job)
 +
 +
  goto end
 +
ENDDO
 +
 +
DLTOVR  INPUT
 +
MONMSG CPF0000
 +
 +
IF (&RTN *EQ '1') (GOTO END)
 +
 +
IF (&ACCP *EQ 'K') DO
 +
CHGJOB SWS(10XXXXXX)
 +
OVRDBF    FILE(INPUTK) TOFILE(&LIB/&FILE) MBR(&MBR) +
 +
        SHARE(*YES) SEQONLY(*NO)  SECURE(*YES)
 +
IF (&QRY )  DO
 +
REMSG:
 +
 +
REQRY:      SNDRCVF    RCDFMT(SLT)
 +
            IF (&IN01 *OR &IN02) GOTO BYQRY
 +
            CHGVAR &OPT '*INP'
 +
            IF (&UPD *EQ 'Y') (CHGVAR &OPT '*ALL')
 +
            OPNQRYF    FILE((INPUTK)) OPTION(&OPT) QRYSLT(&QSLT) +
 +
                          KEYFLD(*FILE) SEQONLY(*NO)
 +
            MONMSG CPF9899 EXEC(DO)
 +
            RCVMSG    MSGTYPE(*ANY)
 +
            SNDF      RCDFMT(SLTC)
 +
            GOTO REMSG
 +
                                ENDDO
 +
                      ENDDO
 +
              ENDDO
 +
BYQRY:
 +
IF (&ACCP *EQ 'A') DO
 +
            CHGJOB SWS(01XXXXXX)
 +
          OVRDBF    FILE(INPUTR) TOFILE(&LIB/&FILE) MBR(&MBR) +
 +
                          SHARE(*YES) SEQONLY(*NO) SECURE(*YES)
 +
    IF (&QRY )        DO
 +
REMSGA:
 +
 +
REQRYA:    SNDRCVF    RCDFMT(SLT)
 +
            IF (&IN01 *OR &IN02) GOTO BYQRYA
 +
            CHGVAR &OPT '*INP'
 +
            IF (&UPD = 'Y') (CHGVAR &OPT '*ALL')
 +
            OPNQRYF    FILE((INPUTR)) OPTION(&OPT) QRYSLT(&QSLT) +
 +
                          KEYFLD(*FILE) SEQONLY(*NO)
 +
            MONMSG CPF9899 EXEC(DO)
 +
                RCVMSG    MSGTYPE(*ANY)
 +
                SNDF      RCDFMT(SLTC)
 +
                GOTO REMSGA
 +
                CHGVAR    VAR(&IN20) VALUE('1')
 +
    SDAMSG:    RCVMSG    RMV(*NO) MSG(&MSG)
 +
                IF        COND(&MSG ¬= ' ') THEN(DO)
 +
                SNDPGMMSG  MSG(&MSG)
 +
                GOTO      SDAMSG
 +
                ENDDO
 +
                SNDF      RCDFMT(SLTC)
 +
                GOTO      REMSGA
 +
                                ENDDO
 +
 +
                    ENDDO
 +
            ENDDO
 +
BYQRYA:
 +
CHGVAR &RCDLN &RCDL
 +
 +
IF ( &UPD= 'Y') (DO)
 +
IF ((&RCDLN *GT    0) *AND (&RCDLN *LE 2048)) (CHGVAR &PRG 'DUSP ')
 +
IF ((&RCDLN *GT 2048) *AND (&RCDLN *LE 4048)) (CHGVAR &PRG 'DUSP1')
 +
IF ((&RCDLN *GT 4048) *AND (&RCDLN *LE 6080)) (CHGVAR &PRG 'DUSP2')
 +
          ENDDO
 +
IF (&UPD *NE 'Y') (DO)
 +
IF ((&RCDLN *GT    0) *AND (&RCDLN *LE 2048)) (CHGVAR &PRG 'DISP ')
 +
IF ((&RCDLN *GT 2048) *AND (&RCDLN *LE 4048)) (CHGVAR &PRG 'DISP1')
 +
IF ((&RCDLN *GT 4048) *AND (&RCDLN *LE 6080)) (CHGVAR &PRG 'DISP2')
 +
          ENDDO
 +
 +
 +
CALL  &PRG  (&ALL &RTN &KEYL &UPD &SCNLV  &SCNLVL &SCNKEY)
 +
 +
IF (&QRY )  (DO)
 +
  IF (&ACCP *EQ 'K') DO
 +
  CLOF    INPUTK
 +
  MONMSG CPF0000
 +
                  ENDDO
 +
  IF (&ACCP *EQ 'A') DO
 +
  CLOF    INPUTR
 +
  MONMSG CPF0000
 +
                  ENDDO
 +
ENDDO
 +
 +
IF (&RTN *EQ '3') DO
 +
  GOTO BYQRYA
 +
  ENDDO
 +
 +
IF (&RTN *EQ '1') DO
 +
  CHGVAR &RTN '0'
 +
  GOTO RTN
 +
  ENDDO
 +
 +
 +
 +
END:  ENDPGM
 +
 +
</pre>
 +
 +
[[#top]]
 +
 +
===DIS3    CL ===
 +
 +
<pre>
 +
 +
/* CALL BY DIS TO SHOW FILE RELATIONS / ACCESS PATHS */
 +
 +
PGM  (&PHY &PHYLIB &SFILE &SLIB)
 +
 +
/* DISPLAY ACCESS PATHS */
 +
 +
DCL &PHY    *CHAR  10
 +
DCL &PHYLIB *CHAR  10
 +
DCL &SFILE  *CHAR  10
 +
DCL &SLIB  *CHAR  10
 +
 +
 +
DCLF QTEMP/DBR
 +
 +
/* CREATE WORK FILES */
 +
CALL  DIS4
 +
 +
DLTF QTEMP/DBR
 +
MONMSG CPF0000
 +
 +
DSPDBR    FILE(&PHYLIB/&PHY) OUTPUT(*OUTFILE) +
 +
  OUTFILE(QTEMP/DBR) OUTMBR(*FIRST *REPLACE)
 +
CHGPF QTEMP/DBR LVLCHK(*NO)
 +
 +
NEXT: RCVF
 +
MONMSG CPF0000 EXEC(GOTO END)
 +
IF (&WHREFI *NE ' ') DO
 +
DSPFD      FILE(&WHRELI/&WHREFI) TYPE(*ACCPTH) +
 +
        OUTPUT(*OUTFILE) OUTFILE(QTEMP/REL) OUTMBR(*FIRST *ADD)
 +
CHGPF QTEMP/REL LVLCHK(*NO)
 +
DSPFD      FILE(&WHRELI/&WHREFI) TYPE(*SELECT) +
 +
        OUTPUT(*OUTFILE) OUTFILE(QTEMP/SEL) OUTMBR(*FIRST *ADD)
 +
CHGPF QTEMP/SEL LVLCHK(*NO)
 +
        ENDDO
 +
GOTO NEXT
 +
 +
END:
 +
DSPFD      FILE(&PHYLIB/&PHY  ) TYPE(*ACCPTH) +
 +
        OUTPUT(*OUTFILE) OUTFILE(QTEMP/REL) OUTMBR(*FIRST *ADD)
 +
CHGPF QTEMP/REL LVLCHK(*NO)
 +
 +
CHGVAR &SFILE '          '
 +
CHGVAR &SLIB  '          '
 +
 +
OVRDBF SEL QTEMP/SEL
 +
OVRDBF REL QTEMP/REL
 +
CALL  DISPR (&SFILE &SLIB)
 +
DLTOVR *ALL
 +
 +
ENDPGM
 +
 +
</pre>
 +
 +
[[#top]]
 +
 +
===DIS4    CL ===
 +
 +
<pre>
 +
 +
/* CALL BY DIS3 TO CREATE WORK FILES */
 +
 +
PGM
 +
 +
DCL  &LIB *CHAR 10
 +
DCL  &SRCF *CHAR 10
 +
 +
RTVDTAARA DTAARA(UDDSSRC *ALL)  RTNVAR(&SRCF)
 +
 +
DLTF  QTEMP/XXXXFILE
 +
monmsg cpf0000
 +
CRTPF      FILE(QTEMP/XXXXFILE) RCDLEN(80) OPTION(*NOLIST)
 +
 +
DSPFFD  FILE(QTEMP/XXXXFILE) OUTPUT(*OUTFILE) OUTFILE(QTEMP/FFD)
 +
CLRPFM  QTEMP/FFD
 +
DLTF  FILE(QTEMP/FFDL01)
 +
MONMSG CPF0000
 +
 +
RTVMBRD FILE(&SRCF) RTNLIB(&LIB)
 +
CRTLF FILE(QTEMP/FFDL01) SRCFILE(&LIB/&SRCF) SRCMBR(FFDL01) +
 +
OPTION(*NOSRC *NOLIST)
 +
 +
DLTF  FILE(QTEMP/REL)
 +
MONMSG CPF0000
 +
DLTF  FILE(QTEMP/SEL)
 +
MONMSG CPF0000
 +
DLTF  FILE(QTEMP/DBR)
 +
MONMSG CPF0000
 +
 +
DSPFD      FILE(QTEMP/FFD) TYPE(*ACCPTH) +
 +
  OUTPUT(*OUTFILE) OUTFILE(QTEMP/REL) OUTMBR(*FIRST *ADD)
 +
 +
DSPFD FILE(QTEMP/FFDL01) TYPE(*SELECT) OUTPUT(*OUTFILE) OUTFILE(QTEMP/SEL)
 +
CLRPFM FILE(QTEMP/REL)
 +
CLRPFM FILE(QTEMP/SEL)
 +
 +
DLTF  QTEMP/XXXXFILE
 +
monmsg cpf0000
 +
 +
 +
ENDPGM
 +
 +
</pre>
 +
 +
[[#top]]
 +
 +
===DISBIN    CL ===
 +
 +
<pre>
 +
/* NUMERIC TO BINARY CONVERTER  */
 +
 +
 +
PGM (&NUM  &BIN2  &BIN4 &BINTYP  )
 +
 +
DCL  VAR(&NUM) TYPE(*DEC) LEN(15 0)
 +
DCL VAR(&BINTYP) TYPE(*CHAR) LEN(1)
 +
DCL VAR(&BIN2) TYPE(*CHAR) LEN(2)
 +
DCL VAR(&BIN4) TYPE(*CHAR) LEN(4)
 +
 +
IF (&BINTYP = '4') (CHGVAR %BIN(&BIN4) &NUM)
 +
IF (&BINTYP = '2') (CHGVAR %BIN(&BIN2) &NUM)
 +
ENDPGM
 +
 +
</pre>
 +
 +
[[#top]]
 +
 +
===DISF    CL ===
 +
 +
<pre>
 +
 +
/* CHECK FILE TYPE */
 +
 +
PGM (&DISF &TYPE &PHY &PHYLIB)
 +
 +
 +
DCL  &DISF  *CHAR 10
 +
DCL  &TYPE  *CHAR 1
 +
DCL  &PHY    *CHAR 10
 +
DCL  &PHYLIB *CHAR 10
 +
DCLF KF
 +
 +
            OVRDBF    FILE(KF) TOFILE(QTEMP/&DISF)
 +
            OPNDBF    FILE(KF) OPTION(*INP)
 +
            RCVF
 +
            CHGVAR &TYPE &APFTYP
 +
 +
            IF (&TYPE *EQ 'L') DO
 +
            CHGVAR &PHY &APBOF
 +
            CHGVAR &PHYLIB &APBOL
 +
            ENDDO
 +
 +
            CLOF      OPNID(KF)
 +
ENDPGM
 +
 +
</pre>
 +
 +
[[#top]]
 +
 +
 +
 +
===DISV    CL ===
 +
 +
<pre>
 +
/* VALIDITY CHECKER FOR DSPFL COMMAND */
 +
 +
 +
PGM (&FILIB  &MBR &UPD &RST &REL)
 +
 +
DCL &FILIB  *CHAR 20
 +
DCL &FILE *CHAR  10
 +
DCL &LIB  *CHAR  10
 +
DCL &MBR  *CHAR  10
 +
DCL &UPD  *CHAR  1
 +
DCL &RST  *CHAR  1
 +
DCL &REL  *CHAR  1
 +
DCL &OBJATR *CHAR 10
 +
DCL &AUT    *CHAR  8
 +
 +
DCL &MSGDTA *CHAR 40
 +
DCL &ERROR  *LGL
 +
 +
CHGVAR &FILE  &FILIB
 +
CHGVAR &LIB  (%SST(&FILIB 11 10))
 +
IF (&MBR *EQ '*FILE') (CHGVAR &MBR  &FILE  )
 +
 +
CHGVAR &AUT '*READ  '
 +
IF ((&UPD *EQ 'Y') *OR (&UPD *EQ 'y')) (CHGVAR &AUT '*CHANGE')
 +
 +
CHKOBJ  (&LIB/&FILE) OBJTYPE(*FILE) MBR(*NONE)  +
 +
  AUT( &AUT  )
 +
  MONMSG (CPF9899 CPF9801 CPF9802  CPF9820 CPF9830) EXEC(DO)
 +
/*  CHGVAR (&MSGDTA) VALUE('    '||&FILE||&LIB)                  */
 +
/*  SNDPGMMSG MSGID(USR0006) MSGF(*LIBL/QUSERMSG) MSGTYPE(*DIAG) +*/
 +
/*            MSGDTA(&MSGDTA)                                    */
 +
    SNDPGMMSG  MSG('Not authorised to the file.') +
 +
                          MSGTYPE(*DIAG)
 +
    CHGVAR (&ERROR) '1'
 +
  ENDDO
 +
  MONMSG (CPF9810) EXEC(DO)
 +
    CHGVAR (&MSGDTA) VALUE('    '||&LIB)
 +
/*  SNDPGMMSG MSGID(USR0008) MSGF(*LIBL/QUSERMSG) MSGTYPE(*DIAG)  +*/
 +
/*            MSGDTA(&MSGDTA)                                      */
 +
    SNDPGMMSG  MSG('Not authorised to the file.') +
 +
                          MSGTYPE(*DIAG)
 +
    CHGVAR (&ERROR) '1'
 +
  ENDDO
 +
 +
 +
IF (*NOT &ERROR) DO
 +
 +
RTVOBJD    OBJ(&LIB/&FILE) OBJTYPE(*FILE) OBJATR(&OBJATR)
 +
CHGVAR &AUT '*READ  '
 +
IF ((&UPD *EQ 'Y') *OR (&UPD *EQ 'y')) (CHGVAR &AUT '*CHANGE')
 +
 +
CHKOBJ    OBJ(&LIB/&FILE) OBJTYPE(*FILE) MBR(&MBR) +
 +
                          AUT(&AUT)
 +
 +
  MONMSG (CPF9815 )  EXEC(DO)
 +
/*  CHGVAR (&MSGDTA) VALUE('    '||&MBR||&FILE||&LIB)              */
 +
/*  SNDPGMMSG MSGID(USR0007) MSGF(*LIBL/QUSERMSG) MSGTYPE(*DIAG) + */
 +
/*            MSGDTA(&MSGDTA)                                      */
 +
            SNDPGMMSG  MSG('Not authorised to the file.') +
 +
                          MSGTYPE(*DIAG)
 +
    CHGVAR (&ERROR) '1'
 +
  ENDDO
 +
  MONMSG (CPF0000 )  EXEC(DO)
 +
/*  SNDPGMMSG MSGID(USR0022) MSGF(*LIBL/QUSERMSG) MSGTYPE(*DIAG) + */
 +
/*            MSGDTA(&MSGDTA)                                      */
 +
            SNDPGMMSG  MSG('Not authorised to the file.') +
 +
                          MSGTYPE(*DIAG)
 +
    CHGVAR (&ERROR) '1'
 +
  ENDDO
 +
ENDDO
 +
 +
IF (&ERROR)  (SNDPGMMSG MSGID(CPF0002) MSGF(QCPFMSG) MSGTYPE(*ESCAPE))
 +
 +
 +
 +
ENDPGM
 +
 +
</pre>
 +
 +
[[#top]]
 +
 +
 +
===DISPR  RPG ===
 +
 +
<pre>
 +
    H OPTIMIZE(*NONE) OPTION(*NODEBUGIO)
 +
    H DFTACTGRP(*NO) ACTGRP(*CALLER)
 +
 +
      *    FILE RELATIONS DISPLAYER
 +
      * REQUIRES FILES TO COMPILE
 +
      *
 +
 +
    FREL      IF  E            DISK
 +
    FSEL      IF  E            DISK
 +
    FDISPRF    CF  E            WORKSTN
 +
    F                                    SFILE(S01:RS01)
 +
    F                                    SFILE(S02:RS02)
 +
    F                                    INFDS(SFINF)
 +
      *
 +
 +
      *
 +
    DDISPR            PR
 +
    D                              10
 +
    D                              10
 +
    DDISPR            PI
 +
    D  SFILE                        10
 +
    D  SLIB                        10
 +
 +
      //  SCREEN LEVELS
 +
    D @SCN            S              6    DIM(50)
 +
    D @NSCN          S              6
 +
    D @LV            S              5  0
 +
    D @ERR            S                  LIKE(@TRUE)
 +
    D @FILE          S            10A  INZ('DISPY  ')
 +
    D WRKSWS          S              1
 +
    D I              S              4B 0
 +
 +
 +
    D @TRUE          S              1A  INZ('1')
 +
    D @FALSE          S              1A  INZ('0')
 +
    D @OK            S                  LIKE(@TRUE)
 +
    D @LOOP          S                  LIKE(@TRUE)
 +
 +
      //
 +
    D RS01            S              4S 0
 +
    D RS02            S              4S 0
 +
      //
 +
      // PARMS FOR SFL LOOPING
 +
    D SFC01          S                  LIKE(RS01)
 +
    D SFC02          S                  LIKE(RS01)
 +
 +
      // Program Status
 +
    D                SDS
 +
    D  PGM                    1    10
 +
    D  WSID                244    253
 +
    D  USER                254    263
 +
      //
 +
      //
 +
    D SFINF          DS
 +
    D  RRRN                376    377B 0
 +
    D  SRN                  378    379B 0
 +
 +
      //  MESSAGE DATA
 +
    D @DTA1          DS            80
 +
    D @DTA2          DS          500
 +
      //
 +
    D MAIN            PR
 +
 +
    D @S01BLD        PR
 +
    D @S01PRC        PR
 +
    D @S01PRS        PR
 +
    D @S02BLD        PR
 +
    D @S02PRC        PR
 +
    D
 +
    D @R9999          PR
 +
 +
    D @OPADJ          PR            2A
 +
    D  OPT                          2A
 +
 +
 +
      /FREE
 +
            *INLR = *ON;
 +
            MAIN();
 +
 +
 +
      //--------------*INZSR-------------------------------//
 +
          BEGSR  *INZSR;
 +
 +
        //  Set the TOP level (Exit if user backs up to here)
 +
              @LV = 1;
 +
              @SCN(@LV)  = '*END  ';
 +
        //  Set the Initial Screen to display
 +
              @LV = @LV + 1;
 +
              @SCN(@LV) = 'S01BLD ';
 +
 +
            ENDSR;
 +
      /END-FREE
 +
      //###################################################//
 +
 +
        //*************************************************************
 +
    P    MAIN        B
 +
 +
    D MAIN            PI
 +
 +
    D I              S              4B 0
 +
 +
      /FREE
 +
          EXSR      @INZSR;
 +
      //
 +
      // THIS IS THE CONTROLLING LOOP TO DRIVE THE NEXT PANEL TO DISPLAY
 +
          DOW      @LOOP = @LOOP;
 +
      // GET THE SCREEN NAME FROM THE SCREEN STACK ARRAY
 +
            @NSCN  = @SCN(@LV);
 +
          SELECT;
 +
        //  SELECT FIELDS FOR DISPLAY
 +
 +
        // SFL TO SELECT THE FILE FIELDS
 +
          WHEN      @NSCN = 'S01BLD';
 +
                            @S01BLD();
 +
          WHEN      @NSCN = 'S01PRC';
 +
                            @S01PRC();
 +
          WHEN      @NSCN = 'S01PRS';
 +
                            @S01PRS();
 +
          WHEN      @NSCN = 'S02BLD';
 +
                            @S02BLD();
 +
          WHEN      @NSCN = 'S02PRC';
 +
                            @S02PRC();
 +
          OTHER;
 +
            //  CATCH ALL (NEVER USED)
 +
              @R9999();
 +
              LEAVE;
 +
          ENDSL;
 +
 +
        //  CF3 EXIT
 +
          IF  *IN03 = *ON;
 +
            LEAVE;
 +
          ENDIF;
 +
 +
      //  CF12 PREVIOUS
 +
          IF  *IN12 = *ON;
 +
              *IN12 = *OFF;
 +
              @LV  = @LV -1;
 +
              @NSCN = @SCN(@LV);
 +
          ENDIF;
 +
 +
      //  Backed out to last level, Exit
 +
          IF    @NSCN = '*END';
 +
                  LEAVE;
 +
          ENDIF;
 +
 +
        ENDDO;
 +
 +
        RETURN;
 +
 +
      //--------------*INZSR-------------------------------//
 +
          BEGSR  @INZSR;
 +
              @NSCN = *BLANK;
 +
 +
          ENDSR;
 +
      //-ENDSR---*INZSR-------------------------------//
 +
      /END-FREE
 +
 +
    P    MAIN        E
 +
 +
 +
      //###################################################//
 +
      //###################################################//
 +
      //###################################################//
 +
      /space 3
 +
    P @S01BLD        B
 +
 +
    D @S01BLD        PI
 +
 +
    D WFILE          S                  LIKE(APFILE )
 +
    D WLIB            S                  LIKE(APLIB  )
 +
 +
          //  Build/Rebuild the subfile
 +
 +
      /FREE
 +
          EXSR      @INZSR;
 +
 +
          EXSR      BLD;
 +
 +
        //  SFL IS BUILT, PROCESS THE SFL CONTROL
 +
          @LV = @LV + 1;
 +
          @SCN(@LV) = 'S01PRC ' ;
 +
            RETURN ;
 +
 +
      //--------------  BLD -------------------------------//
 +
          BEGSR    BLD;
 +
 +
            EXSR      CLR;
 +
 +
 +
          SETLL 1    QWHFDACP;
 +
 +
          DOW @LOOP = @LOOP;
 +
          READ      QWHFDACP;
 +
          IF %EOF;
 +
          LEAVE;
 +
          ENDIF;
 +
 +
 +
          EXSR MOV;
 +
          //
 +
          RS01  = RS01 + 1;
 +
          WRITE S01;
 +
        ENDDO;
 +
 +
 +
        // Position to TOP of subfile
 +
            SRS01 = 1;
 +
            SFC01 = RS01;
 +
          ENDSR;
 +
 +
      //--------------  CLR -------------------------------//
 +
          BEGSR  CLR;
 +
 +
              *IN51 = *OFF;
 +
              *IN52 = *OFF;
 +
              *IN53 = *ON;
 +
              WRITE    C01;
 +
              *IN53 = *OFF;
 +
              RS01  = 0  ;
 +
              SFC01 = 0  ;
 +
              S01FUNC = *BLANK;
 +
              ENDSR;
 +
 +
      //--------------  MOV -------------------------------//
 +
          BEGSR  MOV;
 +
 +
            C01APBOF =  APBOF ;
 +
            C01APBOL =  APBOL ;
 +
 +
          IF APBOF = *BLANK AND APBOL =  *BLANK;
 +
          C01APBOF = APFILE;
 +
          C01APBOL = APLIB;
 +
          ENDIF;
 +
 +
        //  Load the subfile record
 +
 +
          IF APFILE = WFILE  AND
 +
            APLIB  = WLIB ;
 +
            *IN56 = *ON ;
 +
                  S01APFILE  =  *BLANK;
 +
                  S01APLIB  =  *BLANK;
 +
                  S01APACCP  =  *BLANK;
 +
                  S01APUNIQ  =  *BLANK;
 +
                  S01APSELO  =  *BLANK;
 +
                  S01APFTYP  =  *BLANK;
 +
                  S01APJOIN  =  *BLANK;
 +
                  S01APKEYO  =  *BLANK;
 +
                  S01APKSEQ  =  APKSEQ ;
 +
                  S01APKSIN  =  APKSIN ;
 +
                  S01APKEYF  =  APKEYF ;
 +
            ELSE      ;
 +
            WFILE = APFILE;
 +
            WLIB  = APLIB ;
 +
            *IN56 = *OFF;
 +
                  S01APFILE  =  APFILE ;
 +
                  S01APLIB  =  APLIB  ;
 +
                  S01APACCP  =  APACCP ;
 +
                  S01APUNIQ  =  APUNIQ ;
 +
                  S01APSELO  =  APSELO ;
 +
                  S01APFTYP  =  APFTYP ;
 +
                  S01APJOIN  =  APJOIN ;
 +
                  S01APKEYO  =  APKEYO ;
 +
                  S01APKSEQ  =  APKSEQ ;
 +
                  S01APKSIN  =  APKSIN ;
 +
                  S01APKEYF  =  APKEYF ;
 +
          ENDIF;
 +
 +
          ENDSR;
 +
 +
      //--------------*INZSR-------------------------------//
 +
          BEGSR    @INZSR;
 +
              @NSCN = *BLANK;
 +
          ENDSR;
 +
      /END-FREE
 +
 +
    P @S01BLD        E
 +
 +
      //###################################################//
 +
      //###################################################//
 +
 +
      /space 3
 +
    P @S01PRC        B
 +
 +
    D @S01PRC        PI
 +
 +
          //
 +
          //
 +
    D WRKRC          S              4S 0
 +
 +
      /FREE
 +
          EXSR      @INZSR;
 +
 +
            WRITE    R01;
 +
      //
 +
            DOW      @LOOP = @LOOP;
 +
 +
          //
 +
          // Write SFL Control
 +
            IF        SFC01 > 0;
 +
                *IN51 = *ON;
 +
            ENDIF;
 +
              *IN52 = *ON;
 +
 +
 +
              EXFMT    C01;
 +
          //  Setoff errors
 +
                *IN89 = *OFF;
 +
          //
 +
          //  Exit and Previous Screen
 +
            IF        *IN03 = *ON;
 +
                LEAVE;
 +
            ENDIF;
 +
            IF        *IN12 = *ON;
 +
                LEAVE;
 +
            ENDIF;
 +
 +
 +
        //  Process the subfile
 +
              @LV = @LV + 1;
 +
              @SCN(@LV) = 'S01PRS';
 +
              LEAVE;
 +
 +
            ENDDO;
 +
      //
 +
            RETURN;
 +
 +
      /space 3
 +
 +
 +
      //--------------*INZSR-------------------------------//
 +
          BEGSR    @INZSR;
 +
              @NSCN = *BLANK;
 +
          ENDSR;
 +
      /END-FREE
 +
    P @S01PRC        E
 +
 +
      //###################################################//
 +
      //###################################################//
 +
      //###################################################//
 +
      /space 3
 +
    P @S01PRS        B
 +
 +
    D @S01PRS        PI
 +
 +
          //
 +
          //
 +
    D WRKRC          S              4S 0
 +
 +
      /FREE
 +
 +
          EXSR      @INZSR;
 +
 +
        //  Process the subfile
 +
          EXSR      SFL;
 +
          RETURN;
 +
 +
      //--------------  SFL -------------------------------//
 +
          BEGSR      SFL;
 +
        //  Process the subfile
 +
 +
          FOR      WRKRC = 1 TO SFC01 + 1 ;
 +
              CHAIN  WRKRC  S01;
 +
                IF        NOT %FOUND;
 +
        //  Finished with the subfile
 +
                    @LV = @LV -1;
 +
                    LEAVE;
 +
                ENDIF;
 +
 +
        //  GET SELECTED FILE
 +
            IF  @OPADJ(S01FUNC) =  ' X';
 +
              SFILE  = S01APFILE;
 +
              SLIB  = S01APLIB ;
 +
              *IN03 = '1';
 +
                LEAVE;
 +
            ENDIF;
 +
 +
 +
        //  SHOW SELECT RULES
 +
            IF  @OPADJ(S01FUNC) =  ' R';
 +
              @LV = @LV + 1;
 +
              @SCN(@LV) = 'S02BLD ';
 +
                S01FUNC =  '  ';
 +
                UPDATE    S01;
 +
              LEAVE;
 +
            ENDIF;
 +
 +
          ENDFOR;
 +
 +
          ENDSR;
 +
      //---------------------------------------------------//
 +
 +
 +
 +
      //--------------*INZSR-------------------------------//
 +
          BEGSR    @INZSR;
 +
              @NSCN = *BLANK;
 +
          ENDSR;
 +
 +
 +
      /END-FREE
 +
    P @S01PRS        E
 +
 +
 +
      /space 3
 +
    P @S02BLD        B
 +
 +
    D @S02BLD        PI
 +
 +
          //  Build/Rebuild the subfile
 +
      /FREE
 +
 +
          EXSR @INZSR;
 +
 +
          C02APFILE  =  S01APFILE ;
 +
          C02APLIB  =  S01APLIB  ;
 +
 +
        EXSR BLD;
 +
 +
        //  SFL IS BUILT, PROCESS THE CONTROL
 +
          @LV = @LV + 1;
 +
          @SCN(@LV) = 'S02PRC ';
 +
      RETURN;
 +
      //--------------  BLD -------------------------------//
 +
      BEGSR  BLD;
 +
 +
        EXSR CLR;
 +
 +
 +
          SETLL 1    QWHFDSO ;
 +
 +
          DOW @LOOP = @LOOP;
 +
 +
          READ      QWHFDSO ;
 +
          IF %EOF;
 +
          LEAVE;
 +
          ENDIF;
 +
 +
          If SOFILE = S01APFILE  AND
 +
            SOLIB  = S01APLIB ;
 +
          EXSR MOV;
 +
 +
          //
 +
          RS02  = RS02 + 1;
 +
          WRITE S02;
 +
          ENDIF;
 +
        ENDDO;
 +
 +
        // Position to TOP of subfile
 +
        SRS02 = 1;
 +
        SFC02 = RS02;
 +
        ENDSR;
 +
 +
      //--------------  CLR -------------------------------//
 +
        BEGSR  CLR;
 +
          *IN51 = *OFF;
 +
          *IN52 = *OFF;
 +
          *IN53 = *ON;
 +
          WRITE C02;
 +
          *IN53 = *OFF;
 +
          RS02 =0;
 +
          SFC02=0;
 +
 +
        ENDSR;
 +
 +
      //--------------  MOV -------------------------------//
 +
        BEGSR  MOV;
 +
        //  Load the subfile record
 +
 +
          S02SOFLD  = SOFLD  ;
 +
          S02SORULE = SORULE ;
 +
          S02SOCOMP = SOCOMP ;
 +
          S02SOVALU = SOVALU ;
 +
 +
 +
 +
        ENDSR;
 +
 +
      //--------------*INZSR-------------------------------//
 +
        BEGSR  @INZSR;
 +
          @NSCN = *BLANK;
 +
        ENDSR;
 +
 +
      /END-FREE
 +
    P @S02BLD        E
 +
 +
      //###################################################//
 +
      //###################################################//
 +
      //###################################################//
 +
      /space 3
 +
    P @S02PRC        B
 +
 +
    D @S02PRC        PI
 +
 +
          //
 +
          //
 +
    D WRKRC          S              4S 0
 +
 +
      /FREE
 +
 +
          EXSR @INZSR;
 +
 +
        WRITE R02;
 +
 +
      //
 +
      DOW @LOOP = @LOOP;
 +
 +
          //
 +
          // Write SFL Control
 +
          IF SFC02 > 0;
 +
            *IN51 = *ON;
 +
          ENDIF;
 +
          *IN52 = *ON;
 +
          EXFMT C02;
 +
          //
 +
          //  Setoff errors
 +
          *IN89 = *OFF;
 +
          //
 +
          //  Exit and Previous Screen
 +
 +
          @LV = @LV -2;
 +
            LEAVE;
 +
 +
 +
        //  Process the subfile
 +
 +
      ENDDO;
 +
      //
 +
      RETURN;
 +
 +
      /space 3
 +
      //--------------*INZSR-------------------------------//
 +
        BEGSR  @INZSR;
 +
 +
          @NSCN = *BLANK;
 +
        ENDSR;
 +
      /END-FREE
 +
    P @S02PRC        E
 +
 +
 +
      //###################################################//
 +
      //###################################################//
 +
      //###################################################//
 +
 +
    P @R9999          B
 +
        //  Invalid Panel
 +
    D @R9999          PI
 +
 +
    P @R9999          E
 +
 +
 +
      /space 3
 +
      //###################################################//
 +
      //###################################################//
 +
      //###################################################//
 +
    P @OPADJ          B
 +
        //  RIGHT ADJ OPTION , zero suppress
 +
 +
    D @OPADJ          PI            2A
 +
    D  OPT                          2A
 +
 +
      /FREE
 +
        EVALR  OPT  = %trimr(OPT);
 +
        If %SubSt(OPT:1:1) =  '0';
 +
        OPT  = ' ' +  %SubSt(OPT:2:1);
 +
        EndIf;
 +
        RETURN OPT;
 +
      /END-FREE
 +
    P @OPADJ          E
 +
 +
      //###################################################//
 +
      //###################################################//
 +
 +
</pre>
 +
 +
[[#top]]
 +
 +
===DISPRF  DSPF  ===
 +
 +
<pre>
 +
 +
    A*%%TS  SD  20101208  163705  KOLMANNF    REL-V5R4M0  5722-WDS
 +
    A*
 +
      * REQUIRES FILES TO COMPILE
 +
      *  CRTDUPOBJ  OBJ(QAFDSELO) FROMLIB(QSYS)
 +
      *              OBJTYPE(*FILE) TOLIB(QTEMP) NEWOBJ(SEL)
 +
      *  CRTDUPOBJ  OBJ(QAFDACCP) FROMLIB(QSYS)
 +
      *        OBJTYPE(*FILE) TOLIB(QTEMP) NEWOBJ(ACC)
 +
 +
 +
    A*%%EC
 +
    A                                      DSPSIZ(24 80 *DS3)
 +
    A                                      PRINT
 +
    A                                      CF03(03)
 +
    A                                      CF12(12)
 +
    A          R S01                      SFL
 +
    A*%%TS  SD  20101208  163705  KOLMANNF    REL-V5R4M0  5722-WDS
 +
    A            S01FUNC        2A  I  4  3
 +
    A  55
 +
    AO 56                                  DSPATR(PR)
 +
    A            S01APFILE R        O  4  6REFFLD(QWHFDACP/APFILE QTEMP/REL)
 +
    A            S01APLIB  R        O  4 17REFFLD(QWHFDACP/APLIB QTEMP/REL)
 +
    A            S01APACCP R        O  4 29REFFLD(QWHFDACP/APACCP QTEMP/REL)
 +
    A            S01APUNIQ R        O  4 33REFFLD(QWHFDACP/APUNIQ QTEMP/REL)
 +
    A            S01APSELO R        O  4 37REFFLD(QWHFDACP/APSELO QTEMP/REL)
 +
    A            S01APFTYP R        O  4 41REFFLD(QWHFDACP/APFTYP QTEMP/REL)
 +
    A            S01APJOIN R        O  4 45REFFLD(QWHFDACP/APJOIN QTEMP/REL)
 +
    A            S01APKEYO R        O  4 48REFFLD(QWHFDACP/APKEYO QTEMP/REL)
 +
    A            S01APKSEQ R        O  4 53REFFLD(QWHFDACP/APKSEQ QTEMP/REL)
 +
    A            S01APKSIN R        O  4 57REFFLD(QWHFDACP/APKSIN QTEMP/REL)
 +
    A            S01APKEYF R        O  4 61REFFLD(QWHFDACP/APKEYF QTEMP/REL)
 +
    A          R C01                      SFLCTL(S01)
 +
    A*%%TS  SD  20101208  163705  KOLMANNF    REL-V5R4M0  5722-WDS
 +
    A                                      SFLSIZ(0019)
 +
    A                                      SFLPAG(0018)
 +
    A                                      OVERLAY
 +
    A  50                                  SFLEND
 +
    A  51                                  SFLDSP
 +
    A  52                                  SFLDSPCTL
 +
    A  53                                  SFLCLR
 +
    A            SRS01          4S 0H      SFLRCDNBR(CURSOR)
 +
    A*
 +
    A                                  1 18'FILE RELATIONS for '
 +
    A            C01APBOF  R        O  1 39REFFLD(QWHFDACP/APBOF QTEMP/REL)
 +
    A                                  1 51'Lib.'
 +
    A            C01APBOL  R        O  1 56REFFLD(QWHFDACP/APBOL QTEMP/REL)
 +
    A                                  2 32'Uni SEL        LIFO ASC Key'
 +
    A                                  3  6'File      Library    Acc Key OMT -
 +
    A                                      TYP  J  FIFO DSC Sgn Key'
 +
    A          R R01
 +
    A                                24  3'F3-Exit'
 +
    A                                22  3'R - Display Select/Omit rules'
 +
    A                                23  3'X - Select for display'
 +
      *
 +
    A          R R02
 +
    A                                24  3'F3-Exit'
 +
    A          R S02                      SFL
 +
    A                                      SFLNXTCHG
 +
    A            S02SOFLD  R        O  4  4REFFLD(QWHFDSO/SOFLD QTEMP/SEL)
 +
    A            S02SORULE R        O  4 17REFFLD(QWHFDSO/SORULE QTEMP/SEL)
 +
    A            S02SOCOMP R        O  4 22REFFLD(QWHFDSO/SOCOMP QTEMP/SEL)
 +
    A            S02SOVALU R        O  4 28REFFLD(QWHFDSO/SOVALU QTEMP/SEL)
 +
 +
    A          R C02                      SFLCTL(S02 )
 +
    A                                      OVERLAY
 +
    A  50                                  SFLEND
 +
    A  51                                  SFLDSP
 +
    A  52                                  SFLDSPCTL
 +
    A  53                                  SFLCLR
 +
    A                                      SFLSIZ(0019)
 +
    A                                      SFLPAG(0018)
 +
    A            SRS02          4S 0H      SFLRCDNBR(CURSOR)
 +
    A*
 +
    A                                  1  6'FILE SELECTS  for '
 +
    A            C02APFILE R        O  2  7REFFLD(QWHFDSO/SOFILE QTEMP/SEL)
 +
    A                                  2 20'Lib.'
 +
    A            C02APLIB  R        O  2 25REFFLD(QWHFDSO/SOLIB QTEMP/SEL)
 +
    A                                  3  4'Field'
 +
    A                                  3 28'Select/Omit Value'
 +
    A                                  3 16'S/O'
 +
    A                                  3 21'COMP'
 +
 +
</pre>
 +
 +
[[#top]]
 +
 +
 +
===DISPY  RPG ===
 +
 +
<pre>
 +
    H OPTIMIZE(*NONE) OPTION(*NODEBUGIO)
 +
    H DFTACTGRP(*NO) ACTGRP(*CALLER)
 +
 +
      //***************************************************************
 +
      //
 +
      //  PROGRAM ID : DISPY
 +
      //  Description: DISPLAY A FILES FIELDS FOR SELECTION
 +
 +
      //    needs files KF  FFD to compile use following commands
 +
      // DSPFD (&LIB/&FILE) TYPE(*ACCPTH) OUTPUT(*OUTFILE) OUTFILE(QTEMP/KF)
 +
      // DSPFFD  FILE(&LIB/&FILE) OUTPUT(*OUTFILE) OUTFILE(QTEMP/FFD)
 +
      //***************************************************************
 +
      // MODIFICATIONS:
 +
      // MOD  SR  DATE    MODIFICATION SUMMARY
 +
      //
 +
      //***************************************************************
 +
      //
 +
    FKF        IF  E            DISK
 +
    FFFD      UF  E            DISK
 +
    FINPUT    IF  F32766  2000AIDISK    KEYLOC(1)
 +
    F                                    INFDS(INFDS)
 +
    FDISPYF    CF  E            WORKSTN
 +
    F                                    SFILE(S01:RS01)
 +
    F                                    INFDS(SFINF)
 +
      //
 +
      //
 +
 +
      //  SCREEN LEVELS
 +
    D @SCN            S              6    DIM(50)
 +
    D @NSCN          S              6
 +
    D @LV            S              5  0
 +
    D @ERR            S                  LIKE(@TRUE)
 +
    D @FILE          S            10A  INZ('DISPY  ')
 +
    D WRKSWS          S              1
 +
    D I              S              4B 0
 +
 +
 +
    D @TRUE          S              1A  INZ('1')
 +
    D @FALSE          S              1A  INZ('0')
 +
    D @OK            S                  LIKE(@TRUE)
 +
    D @LOOP          S                  LIKE(@TRUE)
 +
 +
      //
 +
    D RS01            S              4S 0
 +
      //
 +
      // PARMS FOR SFL LOOPING
 +
    D SFC01          S                  LIKE(RS01)
 +
 +
      // Program Status
 +
    D                SDS
 +
    D  PGM                    1    10
 +
    D  WSID                244    253
 +
    D  USER                254    263
 +
      //
 +
      //
 +
    D SFINF          DS
 +
    D  RRRN                376    377B 0
 +
    D  SRN                  378    379B 0
 +
 +
      //
 +
    D FLD            S            10    DIM(9000)
 +
    D KEY            S            10    DIM(99)
 +
 +
    D INFDS          DS
 +
    D  FILE                  83    92
 +
    D  LIB                  93    102
 +
    D  MBR                  129    138
 +
    D  RCDL                125    126B 0
 +
    D  RCDS                156    159B 0
 +
    D  ACCTP                160    160
 +
 +
    D                DS
 +
    D  WHCOLD                1    60
 +
    D  WHCHD1                1    20
 +
    D  WHCHD2                21    40
 +
    D  WHCHD3                41    60
 +
 +
    D                DS
 +
    D  POSN                  1    10
 +
    D  P1                    1    10    DIM(10)
 +
 +
    D  POSNN                11    20
 +
    D  P2                    11    20    DIM(10)
 +
 +
 +
      *
 +
      //  MESSAGE DATA
 +
    D @DTA1          DS            80
 +
    D @DTA2          DS          500
 +
      //
 +
    D MAIN            PR
 +
 +
    D @S01BLD        PR
 +
    D @S01PRC        PR
 +
    D @S01PRS        PR
 +
    D
 +
    D @R9999          PR
 +
 +
    D @OPADJ          PR            2A
 +
    D  OPT                          2A
 +
 +
      *
 +
    DDISPY            PR
 +
    D                                1
 +
    D                                1
 +
    D                                4
 +
    D                                1
 +
    D                                1
 +
    D                                5
 +
    DDISPY            PI
 +
    D  ALL                          1
 +
    D  RTN                          1
 +
    D  KEYLNG                        4
 +
    D  ACCP                          1
 +
    D  QRY                          1
 +
    D  RCDLN                        5
 +
      *
 +
    D KEYLN          S              4S 0
 +
    D RCDLEN          S              5S 0
 +
      *-------------------------------------------------------------------
 +
      * QMHRTVM API (Retrieve Message text)
 +
      *-------------------------------------------------------------------
 +
    D  RtvMsgTxt      PR          1024
 +
    D  RMsgId                      7    Const
 +
    D  RMsgFle                    10    Const
 +
    D  RMsgLib                    10    Const
 +
    D  RMsgLvl                      1    Const
 +
 +
    D GETROWCOL      PR
 +
    D                              10A  const
 +
    D                              10A  const
 +
    D                              10A  const
 +
    D                              32A  const
 +
    D                                3P 0
 +
    D                                3P 0
 +
 +
    D SysDate        PR            8S 0
 +
    D SysTime        PR            6S 0
 +
    D DayOfWeek      PR            10I 0
 +
    D                                D  value datfmt(*iso)
 +
      // Message file names
 +
    D  cMsgLib        C                  Const('*LIBL    ')
 +
    D  cMsgF1        C                  Const('MSGF1    ')
 +
    D  cMsgF2        C                  Const('MSGF2    ')
 +
    D  cMsgLvl1      C                  Const('1')
 +
    D  cMsgLvl2      C                  Const('2')
 +
 +
      *
 +
    IINPUT    NS  01
 +
    I                                  1  256  D
 +
 +
      /FREE
 +
            *INLR = *ON;
 +
            MAIN();
 +
 +
 +
      //--------------*INZSR-------------------------------//
 +
          BEGSR  *INZSR;
 +
 +
        //  Set the TOP level (Exit if user backs up to here)
 +
              @LV = 1;
 +
              @SCN(@LV)  = '*END  ';
 +
        //  Set the Initial Screen to display
 +
              @LV = @LV + 1;
 +
              @SCN(@LV) = 'S01BLD ';
 +
 +
      //    DUMMY I/O TO GET NUMBER OF RECORDS IN FILE
 +
            READ      INPUT;
 +
      //  SFL IS NOT LOADED
 +
      //  READ THE LIST OF KEY FIELDS IN THE FILE SO THAT WE CAN LATER MARK THEM
 +
                  ACCP    = ACCTP;
 +
 +
              I    =  0;
 +
 +
              DOW  @LOOP = @LOOP;
 +
                READ      QWHFDACP;
 +
                IF  %EOF;
 +
                LEAVE;
 +
                ENDIF;
 +
                I = I + 1;
 +
                KEY(I) = APKEYF;
 +
              ENDDO;
 +
            ENDSR;
 +
      /END-FREE
 +
      //###################################################//
 +
 +
        //*************************************************************
 +
    P    MAIN        B
 +
 +
    D MAIN            PI
 +
 +
    D I              S              4B 0
 +
 +
      /FREE
 +
          EXSR      @INZSR;
 +
      //
 +
      // THIS IS THE CONTROLLING LOOP TO DRIVE THE NEXT PANEL TO DISPLAY
 +
          DOW      @LOOP = @LOOP;
 +
      // GET THE SCREEN NAME FROM THE SCREEN STACK ARRAY
 +
            @NSCN  = @SCN(@LV);
 +
          SELECT;
 +
        //  SELECT FIELDS FOR DISPLAY
 +
 +
        // SFL TO SELECT THE FILE FIELDS
 +
          WHEN      @NSCN = 'S01BLD';
 +
              @S01BLD();
 +
          WHEN      @NSCN = 'S01PRC';
 +
              @S01PRC();
 +
          WHEN      @NSCN = 'S01PRS';
 +
              @S01PRS();
 +
          OTHER;
 +
            //  CATCH ALL (NEVER USED)
 +
              @R9999();
 +
              LEAVE;
 +
          ENDSL;
 +
 +
        //  CF3 EXIT
 +
          IF  *IN03 = *ON;
 +
            LEAVE;
 +
          ENDIF;
 +
 +
      //  CF12 PREVIOUS
 +
          IF  *IN12 = *ON;
 +
              *IN12 = *OFF;
 +
              @LV  = @LV -1;
 +
              @NSCN    = @SCN(@LV);
 +
          ENDIF;
 +
 +
      //  Backed out to last level, Exit
 +
          IF    @NSCN = '*END';
 +
                  LEAVE;
 +
          ENDIF;
 +
 +
        ENDDO;
 +
 +
        KEYLNG  = %EDITC(KEYLN:'X');
 +
        RETURN;
 +
 +
      //--------------*INZSR-------------------------------//
 +
          BEGSR  @INZSR;
 +
              @NSCN = *BLANK;
 +
              RCDLEN = RCDL;
 +
              RCDLN = %CHAR(RCDLEN);
 +
 +
      // CLEAR FIELD SELECTIONS
 +
              IF  RTN  =  '2';
 +
                SETLL 1    QWHDRFFD;
 +
              DOW  @LOOP = @LOOP;
 +
                READ      QWHDRFFD ;
 +
                IF  %EOF;
 +
                LEAVE;
 +
                ENDIF;
 +
                  WHFIOB = ' ';
 +
                  UPDATE    QWHDRFFD;
 +
              ENDDO;
 +
 +
      // SET FILE I/O TO FIRST RCD IN FILE
 +
                SETLL 1    QWHDRFFD;
 +
                  RTN = '0';
 +
              ELSE;
 +
                CHAIN  1  QWHDRFFD;
 +
                SETLL  1  QWHDRFFD;
 +
              ENDIF;
 +
          ENDSR;
 +
      //-ENDSR---*INZSR-------------------------------//
 +
      /END-FREE
 +
 +
    P    MAIN        E
 +
 +
 +
      //###################################################//
 +
      //###################################################//
 +
      //###################################################//
 +
      /space 3
 +
    P @S01BLD        B
 +
 +
    D @S01BLD        PI
 +
 +
    D  SZ            DS            6
 +
    D  LEN1                  1      1
 +
    D  LEN2                  2      3
 +
    D  LEN3                  1      3
 +
    D  COMA                  4      4
 +
    D  DEC1                  5      5
 +
    D  DEC2                  5      6
 +
 +
    D                DS
 +
    D K                      1      3  0
 +
    D KA                      2      3
 +
 +
          //  Build/Rebuild the subfile
 +
 +
      /FREE
 +
          EXSR      @INZSR;
 +
 +
          EXSR      BLD;
 +
 +
        //  SFL IS BUILT, PROCESS THE SFL CONTROL
 +
          @LV = @LV + 1;
 +
          @SCN(@LV) = 'S01PRC ' ;
 +
            RETURN ;
 +
      //--------------  BLD -------------------------------//
 +
          BEGSR    BLD;
 +
 +
            EXSR      CLR;
 +
 +
          DOW      @LOOP = @LOOP;
 +
 +
            READ      QWHDRFFD;
 +
                IF  %EOF;
 +
                LEAVE;
 +
                ENDIF;
 +
            EXSR      MOV;
 +
 +
      // FLAG THE KEY FIELDS
 +
                  K = %LOOKUP(WHFLDE :KEY);
 +
                    WHDFTL  = K ;
 +
                    UPDATE    QWHDRFFD;
 +
 +
            RS01  = RS01 + 1;
 +
            WRITE    S01;
 +
          ENDDO;
 +
 +
        // Position to TOP of subfile
 +
            SRS01 = 1;
 +
            SFC01 = RS01;
 +
          ENDSR;
 +
 +
      //--------------  CLR -------------------------------//
 +
          BEGSR  CLR;
 +
              I    =  0;
 +
              CLEAR FLD;
 +
              KEYLN = 0;
 +
 +
              *IN51 = *OFF;
 +
              *IN52 = *OFF;
 +
              *IN53 = *ON;
 +
              WRITE    C01;
 +
              *IN53 = *OFF;
 +
              RS01  = 0  ;
 +
              SFC01 = 0  ;
 +
              S01OPT= *BLANK;
 +
              ENDSR;
 +
 +
      //--------------  MOV -------------------------------//
 +
          BEGSR  MOV;
 +
        //  Load the subfile record
 +
 +
 +
            S01OPT  =  WHFIOB ;
 +
            S01WHFLDB  = WHFLDB;
 +
            S01WHFLDT  = WHFLDT;
 +
            S01WHFLD =  WHFLDE ;
 +
            S01SFLD  =  WHFLDE ;
 +
            S01FROM = WHFOBO;
 +
            S01TO  = WHFLDB + WHFOBO -1 ;
 +
 +
      //  KEY FIELDS
 +
            S01KEYFLD  = '  ';
 +
              K = %LOOKUP(WHFLDE :KEY);
 +
                  IF K <> 0;
 +
                    S01KEYFLD = KA;
 +
                  IF  K <  10;
 +
                    %SUBST(S01KEYFLD:1:1) = 'K';
 +
                  ENDIF;
 +
                    KEYLN = KEYLN +  WHFLDB;
 +
                  ENDIF;
 +
        //  FORMAT THE FIELD LENGTH
 +
                  S01SIZE  =  '      ';
 +
                  SZ      =  '      ';
 +
                  IF WHFLDD =      0;
 +
                      LEN3  = %SUBST(%EDITC(WHFLDB:'Z'):3:3);
 +
                  ELSE;
 +
                      LEN2  = %EDITC(WHFLDD:'Z') ;
 +
                      COMA = ',';
 +
 +
                      IF    WHFLDP >  9;
 +
                        DEC2 = %CHAR(WHFLDP);
 +
                      ELSE;
 +
                        DEC1 = %CHAR(WHFLDP);
 +
                      ENDIF;
 +
                  ENDIF;
 +
                  IF  LEN1 =  '0';
 +
                      LEN1 = ' ';
 +
                  ENDIF;
 +
                  S01SIZE = SZ;
 +
 +
                  S01DESC = WHFTXT;
 +
                  IF    S01DESC=  ' ';
 +
                      S01DESC  =  WHCOLD ;
 +
                  ENDIF;
 +
 +
                  I = I + 1;
 +
                  FLD(I) =  S01WHFLD;
 +
 +
          ENDSR;
 +
 +
      //--------------*INZSR-------------------------------//
 +
          BEGSR    @INZSR;
 +
              @NSCN = *BLANK;
 +
          ENDSR;
 +
      /END-FREE
 +
 +
    P @S01BLD        E
 +
 +
      //###################################################//
 +
      //###################################################//
 +
 +
      /space 3
 +
    P @S01PRC        B
 +
 +
    D @S01PRC        PI
 +
 +
          //
 +
          //
 +
    D WRKRC          S              4S 0
 +
    D C01CHK          S                  LIKE(C01POSN)
 +
 +
      /FREE
 +
          EXSR      @INZSR;
 +
 +
            WRITE    R01;
 +
 +
      //
 +
            DOW      @LOOP = @LOOP;
 +
 +
          //
 +
          // Write SFL Control
 +
            IF        SFC01 > 0;
 +
                *IN51 = *ON;
 +
            ENDIF;
 +
              *IN52 = *ON;
 +
              EXFMT    C01;
 +
          //  Setoff errors
 +
                *IN89 = *OFF;
 +
          //
 +
          //  Exit and Previous Screen
 +
            IF        *IN03 = *ON;
 +
              RTN = '1';
 +
                LEAVE;
 +
            ENDIF;
 +
 +
            IF        *IN12 = *ON;
 +
                @LV = @LV -1;
 +
                LEAVE;
 +
            ENDIF;
 +
 +
          //  Set up for qry selection and exit
 +
            IF        *IN06 = *ON;
 +
              *IN03 = *ON;
 +
              QRY = '1';
 +
              LEAVE;
 +
            ENDIF;
 +
 +
        //  POSITION
 +
            IF  C01POSN <> ' ';
 +
              EXSR POS;
 +
              ITER;
 +
            ENDIF;
 +
 +
        //  Process the subfile
 +
              @LV = @LV + 1;
 +
              @SCN(@LV) = 'S01PRS';
 +
              LEAVE;
 +
 +
            ENDDO;
 +
      //
 +
            RETURN;
 +
 +
      /space 3
 +
 +
      //--------------POS  -------------------------------//
 +
          BEGSR    POS;
 +
 +
 +
          FOR      WRKRC = 1 TO SFC01;
 +
              CHAIN  WRKRC  S01;
 +
                IF        NOT %FOUND;
 +
                    LEAVE;
 +
                ENDIF;
 +
 +
                C01CHK  = %SUBST(S01WHFLD :1 : %LEN(%TRIM(C01POSN)));
 +
                IF  (C01POSN  = C01CHK  );
 +
                    SRS01  = WRKRC;
 +
                    LEAVE;
 +
                ENDIF;
 +
 +
          ENDFOR;
 +
 +
 +
          ENDSR;
 +
 +
 +
      //--------------*INZSR-------------------------------//
 +
          BEGSR    @INZSR;
 +
              @NSCN = *BLANK;
 +
 +
            C01FILE    =  FILE;
 +
            C01LIB    =  LIB;
 +
            C01MBR    =  MBR;
 +
            C01RCDL    =  RCDL;
 +
            C01ACCTP  =  ACCTP;
 +
            C01WHTEXT  =  WHTEXT;
 +
            C01RCORDS  =  RCDS;
 +
            C01POSN    =  '  ' ;
 +
            C01WHNAME  =  WHNAME;
 +
 +
          ENDSR;
 +
      /END-FREE
 +
 +
    P @S01PRC        E
 +
 +
      //###################################################//
 +
      //###################################################//
 +
      //###################################################//
 +
      /space 3
 +
    P @S01PRS        B
 +
 +
    D @S01PRS        PI
 +
 +
          //
 +
          //
 +
    D WRKRC          S              4S 0
 +
    D FX              S              5S 0
 +
 +
      /FREE
 +
 +
          EXSR      @INZSR;
 +
 +
        //  Process the subfile
 +
          EXSR      SFL;
 +
          *IN03 = '1';
 +
          RETURN;
 +
 +
      //--------------  SFL -------------------------------//
 +
          BEGSR      SFL;
 +
        //  Process the subfile
 +
 +
          FOR      WRKRC = 1 TO SFC01+1;
 +
              CHAIN  WRKRC  S01;
 +
                IF        NOT %FOUND;
 +
        //  Finished with the subfile
 +
        //  RETURN TO REBUILD LEVEL
 +
                    @LV = @LV -2;
 +
                    LEAVE;
 +
                ENDIF;
 +
 +
        //    RIGHT ADJUST OPTION
 +
              S01OPT  = @OPADJ(S01OPT);
 +
 +
        //    UPDATE SELECTIONS
 +
              EXSR UPD;
 +
 +
          ENDFOR;
 +
 +
          ENDSR;
 +
      //---------------------------------------------------//
 +
 +
      //--------------UPD ---------------------------------//
 +
          BEGSR      UPD;
 +
 +
      // UPDATE FIELD NAMES AND SELECT FLAG
 +
                FX = %LOOKUP(S01SFLD :FLD);
 +
                CHAIN  FX  QWHDRFFD;
 +
                WHFLDE  =  S01WHFLD;
 +
 +
                IF @OPADJ(S01OPT) = ' S' OR
 +
                    @OPADJ(S01OPT) = ' O';
 +
                    ALL    = %TRIM(S01OPT);
 +
                    WHFIOB = %TRIM(S01OPT);
 +
                ENDIF;
 +
 +
                IF @OPADJ(S01OPT) = ' ';
 +
                    WHFIOB = ' ';
 +
                ENDIF;
 +
                  UPDATE  QWHDRFFD;
 +
 +
          ENDSR;
 +
 +
 +
      //--------------*INZSR-------------------------------//
 +
          BEGSR    @INZSR;
 +
              ALL  = '1';
 +
              @NSCN = *BLANK;
 +
          ENDSR;
 +
 +
 +
      /END-FREE
 +
    P @S01PRS        E
 +
 +
      //###################################################//
 +
      //###################################################//
 +
      //###################################################//
 +
 +
    P @R9999          B
 +
        //  Invalid Panel
 +
    D @R9999          PI
 +
 +
    P @R9999          E
 +
 +
 +
      /space 3
 +
      //###################################################//
 +
      //###################################################//
 +
      //###################################################//
 +
    P @OPADJ          B
 +
        //  RIGHT ADJ OPTION , zero suppress
 +
 +
    D @OPADJ          PI            2A
 +
    D  OPT                          2A
 +
 +
      /FREE
 +
        EVALR  OPT  = %trimr(OPT);
 +
        If %SubSt(OPT:1:1) =  '0';
 +
        OPT  = ' ' +  %SubSt(OPT:2:1);
 +
        EndIf;
 +
        RETURN OPT;
 +
      /END-FREE
 +
    P @OPADJ          E
 +
 +
      //###################################################//
 +
      //###################################################//
 +
      //###################################################//
 +
    P  RtvMsgTxt      B
 +
      //************************************************************************
 +
      // API Call: QMHRTVM Retrieve Message text
 +
      //************************************************************************
 +
 +
 +
      // USAGE
 +
      // MsgTxt = RtvMsgTxt('MSG0001':cMsgF3:cMsgLib:cMsgLvl1);
 +
 +
    D  RtvMsgTxt      PI          1024
 +
    D  RMsgId                      7    Const
 +
    D  RMsgFle                    10    Const
 +
    D  RMsgLib                    10    Const
 +
    D  RMsgLvl                      1    Const
 +
 +
      // Retrieve Message Description API Prototype
 +
    D  Get_Message    PR                  ExtPgm('QMHRTVM')
 +
    D                            4000    Options(*VarSize)
 +
    D                              10I 0 Const
 +
    D                                8    Const
 +
    D                                7
 +
    D                              20    Const
 +
    D                            32765    Options(*VarSize)
 +
    D                              10I 0 Const
 +
    D                              10    Const
 +
    D                              10    Const
 +
    D                            8192    Options(*VarSize)
 +
    D                              10
 +
    D                                9B 0
 +
    D                                9B 0
 +
 +
      // Define Variables for QMHRTVM API call:
 +
      // --------------------------------------
 +
      // Return variables
 +
    D  MessageInfo    DS          4000
 +
    D  Data                  1  4000
 +
    D  OSMSG                65    68B 0
 +
    D  LMsgR                69    72B 0
 +
    D  LMsgA                73    76B 0
 +
    D  OSMSGH              77    80B 0
 +
    D  LMsgHR              81    84B 0
 +
    D  LMsgHA              85    88B 0
 +
 +
      // Required input variables
 +
    D  MessageLen    S            10I 0
 +
    D  MessageForm  S              8
 +
    D  MessageIden  S              7
 +
    D  MessageFile  S            20
 +
    D  Replacement  S          32765
 +
    D  ReplaceLen    S            10I 0
 +
    D  ReplaceSub    S            10
 +
    D  ReturnCtl    S            10
 +
 +
    D  RetrieveOpt  S            10
 +
    D  ConvToCCSID  S              9B 0
 +
    D  ReplDtaCCSID  S              9B 0
 +
 +
    D  Return_Text  S          1024
 +
 +
    D  ErrorCode      DS                  Qualified
 +
    D  BytesProv                    4B 0 Inz(0)
 +
    D  BytesAvail                  8B 0 Inz(0)
 +
    D  ExceptionId                  7
 +
    D  Reserved                    1
 +
    D  ExceptionDta              512
 +
      /FREE
 +
 +
        // Load API parameter fields
 +
        MessageInfo  = *blanks;
 +
        MessageLen    = 4000;
 +
        MessageForm  = 'RTVM0300';
 +
        MessageIden  = RMsgId;
 +
        MessageFile  = RMsgFle + RMsgLib;
 +
        Replacement  = *blanks;
 +
        ReplaceLen    = %Len(Replacement);
 +
        ReplaceSub    = '*YES';
 +
        ReturnCtl    = '*YES';
 +
        RetrieveOpt  = '*MSGID';
 +
        ConvToCCSID  = 0;
 +
        ReplDtaCCSID  = 0;
 +
 +
        // Retrieve message description
 +
        Get_Message(MessageInfo :
 +
                    MessageLen  :
 +
                    MessageForm :
 +
                    MessageIden :
 +
                    MessageFile :
 +
                    Replacement :
 +
                    ReplaceLen  :
 +
                    ReplaceSub  :
 +
                    ReturnCtl  :
 +
                    ErrorCode  :
 +
                    RetrieveOpt :
 +
                    ConvToCCSID :
 +
                    ReplDtaCCSID);
 +
 +
        // Process Return variables
 +
        Return_Text = *blanks;
 +
 +
        // If no errors, determine the correct portion of the message text
 +
        If ErrorCode.BytesProv = 0;
 +
          Select;
 +
          When RMsgLvl = '1';
 +
              Return_Text = %Subst(data:OSMSG+1:LMsgA);  // Msg Lvl 1
 +
          When RMsgLvl = '2';
 +
              Return_Text = %Subst(data:OSMSGH+1:LMsgHA);  // Msg Lvl 2
 +
          EndSl;
 +
        Else;
 +
          Return_Text = 'Get_Message failed.';
 +
        EndIf;
 +
 +
        // Return to calling point
 +
        Return Return_Text;
 +
 +
      /END-FREE
 +
    P                E
 +
 +
 +
      //###################################################//
 +
      //###################################################//
 +
      //###################################################//
 +
    P GETROWCOL      B
 +
      *
 +
      *    Retreive a DSPF FIELD  Row and Col
 +
      *    Used for Setting  CSRLOC for cursor positioning
 +
      *    USAGE
 +
      *    GETROWCOL  (FILE :'*LIBL' : FORMAT : FLDNAM : ROW : COL)
 +
      *
 +
    D GETROWCOL      PR
 +
    D  schFile                    10A  const
 +
    D  schLib                      10A  const
 +
    D  schFormat                  10A  const
 +
    D  schString                  32A  const
 +
    D  rtnROW                      3P 0
 +
    D  RtnCOL                      3P 0
 +
 +
    D GETROWCOL      PI
 +
    D  schFile                    10A  const
 +
    D  schLib                      10A  const
 +
    D  schFormat                  10A  const
 +
    D  schString                  32A  const
 +
    D  rtnROW                      3P 0
 +
    D  RtnCOL                      3P 0
 +
 +
    D QUSCRTUS        PR                  ExtPgm('QUSCRTUS')
 +
    D  UserSpace                  20A  CONST
 +
    D  ExtAttrib                  10A  CONST
 +
    D  InitialSize                10I 0 CONST
 +
    D  InitialVal                  1A  CONST
 +
    D  PublicAuth                  10A  CONST
 +
    D  Text                        50A  CONST
 +
    D  Replace                    10A  CONST options(*nopass)
 +
    D  ErrorCode                32767A  options(*varsize:*nopass)
 +
 +
    D QUSPTRUS        PR                  ExtPgm('QUSPTRUS')
 +
    D  UserSpace                  20A  CONST
 +
    D  Pointer                      *
 +
 +
    D QUSDLTUS        PR                  ExtPgm('QUSDLTUS')
 +
    D  UserSpace                  20A  CONST
 +
    D  ErrorCode                32767A  options(*varsize)
 +
 +
    D QUSLFLD        PR                  ExtPgm('QUSLFLD')
 +
    D  UsrSpc                      20A  const
 +
    D  Format                      8A  const
 +
    D  QualFile                    20A  const
 +
    D  RcdFmt                      10A  const
 +
    D  UseOvrd                      1A  const
 +
    D  ErrorCode                32767A  options(*nopass:*varsize)
 +
 +
    D ErrorCode      ds                  qualified
 +
    D  BytesProv                  10I 0 inz(0)
 +
    D  BytesAvail                  10I 0 inz(0)
 +
 +
    D ListHeader      ds                  based(p_ListHeader)
 +
    d  ListOffset                  10I 0 overlay(ListHeader:125)
 +
    d  EntryCount                  10I 0 overlay(ListHeader:133)
 +
    d  EntrySize                  10I 0 overlay(ListHeader:137)
 +
 +
    D Field          ds                  based(p_Field)
 +
    D                                    qualified
 +
    D  Name                        10a
 +
    D  FILLER                      438a
 +
    d  DspRow                      10i 0
 +
    d  DspCol                      10i 0
 +
 +
    D TEMPSPC        C                  'GETROWCOL QTEMP'
 +
 +
    D x              s            10I 0
 +
 +
      /free
 +
 +
                  rtnrow =    999;
 +
                  rtnrow =    999;
 +
          // --------------------------------------------------
 +
          // Delete the user space if it exists (ignore errors)
 +
          ErrorCode.BytesProv = %size(ErrorCode);
 +
          QUSDLTUS( TEMPSPC: ErrorCode );
 +
          ErrorCode.BytesProv = 0;
 +
 +
          // --------------------------------------------------
 +
          // Create a new 128k user space
 +
          QUSCRTUS( TEMPSPC : 'SCHTEXT' : 128 * 1024  : x'00'
 +
                  : '*EXCLUDE' : 'List of fields in file' : '*NO'
 +
                  : ErrorCode );
 +
 +
          // --------------------------------------------------
 +
          // Dump list of fields in file to user space
 +
          // Invaid data is ignored an 999 returned for row and col
 +
          monitor;
 +
          QUSLFLD( TEMPSPC : 'FLDL0100'  : SchFile + SchLib
 +
                  : SchFormat  : *OFF  : ErrorCode );
 +
              on-Error;
 +
                RETURN;
 +
            EndMon;
 +
          // --------------------------------------------------
 +
          // Get a pointer to the user space
 +
          QUSPTRUS( TEMPSPC: p_ListHeader );
 +
 +
          // --------------------------------------------------
 +
          // Loop through all fields in space, to get the field we need
 +
          for x = 0 to (EntryCount - 1);
 +
              p_Field = p_ListHeader + ListOffset + (EntrySize * x);
 +
 +
              if Field.Name = schString;
 +
                  rtnRow =    Field.DspRow;
 +
                  rtnCol =    Field.DspCol;
 +
                leave;
 +
              endif;
 +
          endfor;
 +
 +
          // --------------------------------------------------
 +
          // Delete temp user space & end
 +
          QUSDLTUS( TEMPSPC: ErrorCode );
 +
 +
            return;
 +
 +
      /end-free
 +
    P                E
 +
 +
</pre>
 +
 +
[[#top]]
 +
 +
===DISPYF  RPG ===
 +
 +
<pre>
 +
 +
    A*%%TS  SD  20101203  131649  KOLMANNF    REL-V5R4M0  5722-WDS
 +
    A*  90/01/08  12:52:36                REL-R01M02  5728-PW1
 +
    A*            16:33:07                REL-R08M00  5714-UT1
 +
    A*%%EC
 +
    A                                      DSPSIZ(24 80 *DS3)
 +
    A                                      REF(*LIBL/QADSPFFD)
 +
    A                                      PRINT
 +
    A                                      CA03(03 'End of job')
 +
    A                                      CA12(12 'Previous')
 +
    A                                      CA04(04 'Add FIELDS')
 +
    A                                      CA05(05 'Attr changes')
 +
    A                                      CF06(06 'Field Select')
 +
    A                                      CA07(07 'Name changes')
 +
    A*****
 +
    A*            15:04:39                REL-R08M00  5714-UT1
 +
    A          R S01                      SFL
 +
    A*%%TS  SD  20101203  131649  KOLMANNF    REL-V5R4M0  5722-WDS
 +
    A  40                                  SFLNXTCHG
 +
    A            S01OPT        2A  B  7  2
 +
    A            S01KEYFLD      2A  O  7  5DSPATR(HI)
 +
    A            S01WHFLD  R        B  7  8REFFLD(WHFLDI)
 +
    A  23                                  DSPATR(HI)
 +
    A N23                                  DSPATR(PR)
 +
    A            S01WHFLDB R        B  7 19REFFLD(WHFLDB)
 +
    A                                      EDTCDE(Z)
 +
    A  25                                  DSPATR(HI)
 +
    A N25                                  DSPATR(PR)
 +
    A            S01SIZE        6A  O  7 25
 +
    A            S01FROM        4Y 0O  7 32EDTCDE(Z)
 +
    A            S01TO          4Y 0O  7 37EDTCDE(Z)
 +
    A            S01DESC      35A  O  7 44
 +
    A            S01WHFLDT R        B  7 42REFFLD(WHFLDT)
 +
    A  25                                  DSPATR(HI)
 +
    A N25                                  DSPATR(PR)
 +
    A            S01SFLD  R        H      REFFLD(WHFLDI)
 +
    A*****
 +
    A*
 +
    A          R C01                      SFLCTL(S01)
 +
    A*%%TS  SD  20101203  131649  KOLMANNF    REL-V5R4M0  5722-WDS
 +
    A                                      SFLSIZ(0015)
 +
    A                                      SFLPAG(0014)
 +
    A  88                                  CSRLOC(ROW01      COL01)
 +
    A                                      OVERLAY
 +
    A                                      TEXT('WORK WITH FIELDS')
 +
    A  51                                  SFLDSP
 +
    A  52                                  SFLDSPCTL
 +
    A  53                                  SFLCLR
 +
    A  99                                  SFLEND
 +
    A            SRS01          4S 0H      SFLRCDNBR(CURSOR)
 +
    A*
 +
    A  89        C01MSG        79  M
 +
    A            ROW01          3S 0H
 +
    A            COL01          3S 0H
 +
    A                                  1  3'File'
 +
    A            C01FILE      10A  O  1  8DSPATR(HI)
 +
    A                                  1 20'Lib'
 +
    A            C01LIB        10A  O  1 24DSPATR(HI)
 +
    A                                  1 37'Mbr'
 +
    A            C01MBR        10A  O  1 41DSPATR(HI)
 +
    A                                  1 53'Rcdlen'
 +
    A            C01RCDL        4S 0O  1 60DSPATR(HI)
 +
    A                                  1 66'Access'
 +
    A            C01ACCTP      1A  O  1 73DSPATR(HI)
 +
    A                                  2  3'Text'
 +
    A            C01WHTEXT R        O  2  9REFFLD(WHTEXT)
 +
    A                                      DSPATR(HI)
 +
    A                                  2 60'#Records'
 +
    A            C01RCORDS      7Y 0O  2 69DSPATR(HI)
 +
    A                                      EDTCDE(Z)
 +
    A            C01POSN      10A  I  3  7
 +
    A                                  4  2'Select/Omit (S/O) fields for displ-
 +
    A                                      ay.(Default *ALL)'
 +
    A                                  5 11'Use Select Or Omit,not Select with-
 +
    A                                      Omit'
 +
    A                                  6  8'Name      Bytes  Size  From  To T-
 +
    A                                      p  Description'
 +
    A                                  4 54'Format'
 +
    A            C01WHNAME R        O  4 61REFFLD(QWHDRFFD/WHNAME)
 +
    A                                      DSPATR(HI)
 +
    A          R R01
 +
    A                                23  2'F3-Exit F6-Data Sel'
 +
 +
</pre>
 +
 +
[[#top]]
 +
 +
===DISPX  DSPF ===
 +
 +
<pre>
 +
    A                                      DSPSIZ(24 80 *DS3)
 +
    A                                      PRINT
 +
    A                                      CF02(02 'return')
 +
    A                                      CF03(01 'exit')
 +
    A          R SLT
 +
    A                                      OVERLAY
 +
    A                                  1  2'Qryslt:'
 +
    A            QSLT        1509A  B  1 12CHECK(LC)
 +
    A                                20  1'F2-Return '
 +
    A          R SLTR                      SFL
 +
    A                                      SFLMSGRCD(21)
 +
    A            MSGKEY                    SFLMSGKEY
 +
    A            PGMQ                      SFLPGMQ
 +
    A          R SLTC                      SFLCTL(SLTR  )
 +
    A                                      OVERLAY
 +
    A                                      SFLSIZ(50) SFLPAG(3)
 +
    A N20                                  SFLEND
 +
    A N20                                  SFLDSP
 +
    A N20                                  SFLDSPCTL
 +
    A N20                                  SFLINZ
 +
    A  20                                  SFLCLR
 +
    A            PGMQ                      SFLPGMQ
 +
 +
</pre>
 +
 +
[[#top]]
 +
 +
===FFDL01 LF ===
 +
 +
<pre>
 +
    A          R QWHDRFFD                  PFILE(FFD)
 +
                K WHFILE
 +
 +
</pre>
 +
 +
[[#top]]
 +
 +
 +
=== COMPILE CL    ===
 +
 +
<pre>
 +
/* COMPILE OBJECTS                    */
 +
/* CRTBNDCL  PGM(KOLMANN/COMPILE) SRCFILE(KOLMANN/UDDSSRC)    */
 +
/*            SRCMBR(COMPILE) OUTPUT(*NONE) REPLACE(*YES)      */
 +
/* call compile ('KOLMANN' 'UDDSSRC')                          */
 +
PGM (&LIB &SRCF)
 +
 +
DCL &LIB  *CHAR  10
 +
DCL &SRCF *CHAR  10
 +
 +
CRTDTAARA  DTAARA(&LIB/UDDSSRC) TYPE(*CHAR) LEN(10) +
 +
  VALUE(&SRCF) TEXT('SOURCE LIBRARY FOR  UDDS PROGRAMS')
 +
MONMSG CPF0000
 +
 +
dltf qtemp/afile
 +
monmsg cpf0000
 +
CRTPF      FILE(QTEMP/AFILE) RCDLEN(80) OPTION(*NOLIST)
 +
 +
CRTDSPF    FILE(&LIB/DISPF) SRCFILE(&LIB/&SRCF) +
 +
                          SRCMBR(DISPF) OPTION(*NOLIST *NOSRC) +
 +
                          REPLACE(*YES)
 +
 +
 +
DSPFFD  FILE(QTEMP/AFILE) OUTPUT(*OUTFILE) OUTFILE(QTEMP/FFD)
 +
DLTF  FILE(QTEMP/FFDL01)
 +
MONMSG CPF0000
 +
CRTLF FILE(QTEMP/FFDL01) SRCFILE(&LIB/&SRCF) SRCMBR(FFDL01) +
 +
OPTION(*NOSRC *NOLIST)
 +
 +
DSPFFD  FILE(QTEMP/FFD) OUTPUT(*OUTFILE) OUTFILE(QTEMP/FFFFD)
 +
DSPFD (QTEMP/FFD ) TYPE(*ACCPTH) OUTPUT(*OUTFILE) OUTFILE(QTEMP/KFFFD )
 +
OVRDBF    FILE(KF) TOFILE(QTEMP/KFFFD)
 +
CRTBNDCL  PGM(&LIB/DISF) SRCFILE(&LIB/&SRCF) +
 +
        DBGVIEW(*SOURCE)  SRCMBR(DISF) OUTPUT(*NONE) REPLACE(*YES)
 +
CRTBNDCL  PGM(&LIB/DISV) SRCFILE(&LIB/&SRCF) +
 +
        DBGVIEW(*SOURCE)  SRCMBR(DISV) OUTPUT(*NONE) REPLACE(*YES)
 +
 +
CRTBNDRPG  PGM(&LIB/DISPY) SRCFILE(&LIB/&SRCF) +
 +
    SRCMBR(DISPY) DBGVIEW(*SOURCE) OUTPUT(*NONE) REPLACE(*YES)
 +
 +
 +
DLTF  FILE(QTEMP/REL)
 +
MONMSG CPF0000
 +
DLTF  FILE(QTEMP/SEL)
 +
MONMSG CPF0000
 +
DLTF  FILE(QTEMP/DBR)
 +
MONMSG CPF0000
 +
 +
DSPFD      FILE(QTEMP/FFD) TYPE(*ACCPTH) +
 +
  OUTPUT(*OUTFILE) OUTFILE(QTEMP/REL) OUTMBR(*FIRST *ADD)
 +
DSPFD FILE(QTEMP/FFDL01) TYPE(*SELECT) OUTPUT(*OUTFILE) OUTFILE(QTEMP/SEL)
 +
CRTDSPF    FILE(&LIB/DISPRF) SRCFILE(&LIB/&SRCF) +
 +
                          SRCMBR(DISPRF) OPTION(*NOLIST *NOSRC) +
 +
                          REPLACE(*YES)
 +
 +
DSPDBR    FILE(QTEMP/FFD) OUTPUT(*OUTFILE) +
 +
  OUTFILE(QTEMP/DBR) OUTMBR(*FIRST *REPLACE)
 +
 +
DLTF  FILE(QTEMP/ACC)
 +
MONMSG CPF0000
 +
DSPFD FILE(QTEMP/FFDL01) TYPE(*ACCPTH) OUTPUT(*OUTFILE) OUTFILE(QTEMP/ACC)
 +
 +
CRTBNDRPG  PGM(&LIB/DISP) SRCFILE(&LIB/&SRCF) +
 +
  SRCMBR(DISP) DBGVIEW(*SOURCE) OUTPUT(*NONE) REPLACE(*YES)
 +
CRTBNDRPG  PGM(&LIB/DISP1) SRCFILE(&LIB/&SRCF) +
 +
  SRCMBR(DISP1) DBGVIEW(*SOURCE) OUTPUT(*NONE) REPLACE(*YES)
 +
CRTBNDRPG  PGM(&LIB/DISP2) SRCFILE(&LIB/&SRCF) +
 +
  SRCMBR(DISP2) DBGVIEW(*SOURCE) OUTPUT(*NONE) REPLACE(*YES)
 +
 +
CRTBNDRPG  PGM(&LIB/DUSP) SRCFILE(&LIB/&SRCF) +
 +
  SRCMBR(DUSP) DBGVIEW(*SOURCE)                REPLACE(*YES)
 +
CRTBNDRPG  PGM(&LIB/DUSP1) SRCFILE(&LIB/&SRCF) +
 +
  SRCMBR(DUSP1) DBGVIEW(*SOURCE) OUTPUT(*NONE) REPLACE(*YES)
 +
CRTBNDRPG  PGM(&LIB/DUSP2) SRCFILE(&LIB/&SRCF) +
 +
  SRCMBR(DUSP2) DBGVIEW(*SOURCE) OUTPUT(*NONE) REPLACE(*YES)
 +
 +
CRTBNDCL  PGM(&LIB/DIS) SRCFILE(&LIB/&SRCF) +
 +
      DBGVIEW(*SOURCE)    SRCMBR(DIS) OUTPUT(*NONE) REPLACE(*YES)
 +
CRTBNDCL  PGM(&LIB/DIS3) SRCFILE(&LIB/&SRCF) +
 +
      DBGVIEW(*SOURCE)    SRCMBR(DIS3) OUTPUT(*NONE) REPLACE(*YES)
 +
CRTBNDCL  PGM(&LIB/DIS4) SRCFILE(&LIB/&SRCF) +
 +
      DBGVIEW(*SOURCE)    SRCMBR(DIS4) OUTPUT(*NONE) REPLACE(*YES)
 +
CRTBNDCL  PGM(&LIB/DISBIN) SRCFILE(&LIB/&SRCF) +
 +
      DBGVIEW(*SOURCE)    SRCMBR(DISBIN) OUTPUT(*NONE) REPLACE(*YES)
 +
 +
CRTBNDRPG  PGM(&LIB/DISPR) SRCFILE(&LIB/&SRCF) +
 +
    SRCMBR(DISPR) DBGVIEW(*SOURCE) OUTPUT(*NONE) REPLACE(*YES)
 +
 +
CRTCMD CMD(&LIB/DSPFL) PGM(*LIBL/DIS) SRCFILE(&LIB/&SRCF)  +
 +
            SRCMBR(DSPFL) VLDCKR(DISV)
 +
 +
CRTDSPF    FILE(&LIB/DISPX) SRCFILE(&LIB/&SRCF) +
 +
                          SRCMBR(DISPX) OPTION(*NOLIST *NOSRC) +
 +
                          REPLACE(*YES)
 +
CRTBNDCL  PGM(&LIB/DIS1) SRCFILE(&LIB/&SRCF) +
 +
      DBGVIEW(*SOURCE)  SRCMBR(DIS1) OUTPUT(*NONE) REPLACE(*YES)
 +
 +
 +
 +
ENDPGM
 +
 +
 +
</pre>
 +
 +
[[#top]]
 +
 +
=== TESTPF  PF      ===
 +
 +
<pre>
 +
    A          R TESTR
 +
    A            ACTIV          1A        TEXT('Active flag (0 - inactive, 1')
 +
    A            CMPNO          3P        TEXT('Company number              ')
 +
    A            PLTNO          2P        TEXT('Plant number                ')
 +
    A            PRDNO        15A        TEXT('Product number              ')
 +
    A            OPBAL        13P 3      TEXT('Opening balance - this perio')
 +
    A            SERVU          5S 2      TEXT('Service level based on units')
 +
    A            QTY            5B 2      TEXT('QTY')
 +
    A            QTYF          17F 4      FLTPCN(*DOUBLE)
 +
    A            CCYYMMDD        L        TEXT('DATE')
 +
    A            HHMMSS          T        TEXT('TIME')
 +
    A            DATTIM          Z        TEXT('DATE TIME')
 +
    A            VTEXT        100A        VARLEN
 +
    A                                      TEXT('VARIABLE TEXT')
 +
    A            DESCP        30A        TEXT('Product description or name ')
 +
 +
    A          K ACTIV
 +
    A          K CMPNO
 +
    A          K PRDNO
 +
    A          K OPBAL
 +
    A          K SERVU
 +
 +
</pre>
 +
 +
[[#top]]
 +
 +
=== TESTPF1  PF      ===
 +
 +
<pre>
 +
    A          R TESTR
 +
    A            ACTIV          1A        TEXT('Active flag (0 - inactive, 1')
 +
    A            CMPNO          3P        TEXT('Company number              ')
 +
    A            PLTNO          2P        TEXT('Plant number                ')
 +
    A            PRDNO        15A        TEXT('Product number              ')
 +
    A            OPBAL        13P 3      TEXT('Opening balance - this perio')
 +
    A            SERVU          5S 2      TEXT('Service level based on units')
 +
    A            QTY            5B 2      TEXT('QTY')
 +
    A            QTYF          17F 4      FLTPCN(*DOUBLE)
 +
    A            CCYYMMDD        L        TEXT('DATE')
 +
    A            HHMMSS          T        TEXT('TIME')
 +
    A            DATTIM          Z        TEXT('DATE TIME')
 +
    A            VTEXT        100A        VARLEN
 +
    A                                      TEXT('VARIABLE TEXT')
 +
    A            DESCP        30A        TEXT('Product description or name ')
 +
    A            TXT1        500A        TEXT('TXT1  ')
 +
    A            TXT2        500A        TEXT('TXT2  ')
 +
    A            TXT3        500A        TEXT('TXT3  ')
 +
    A            TXT4        500A        TEXT('TXT4  ')
 +
    A          K ACTIV
 +
    A          K CMPNO
 +
    A          K PRDNO
 +
    A          K OPBAL
 +
    A          K SERVU
 +
 +
</pre>
 +
 +
[[#top]]
 +
 +
=== TESTPF2  PF      ===
 +
 +
<pre>
 +
 +
    A          R TESTR
 +
    A            ACTIV          1A        TEXT('Active flag (0 - inactive, 1')
 +
    A            CMPNO          3P        TEXT('Company number              ')
 +
    A            PLTNO          2P        TEXT('Plant number                ')
 +
    A            PRDNO        15A        TEXT('Product number              ')
 +
    A            OPBAL        13P 3      TEXT('Opening balance - this perio')
 +
    A            SERVU          5S 2      TEXT('Service level based on units')
 +
    A            QTY            5B 2      TEXT('QTY')
 +
    A            QTYF          17F 4      FLTPCN(*DOUBLE)
 +
    A            CCYYMMDD        L        TEXT('DATE')
 +
    A            HHMMSS          T        TEXT('TIME')
 +
    A            DATTIM          Z        TEXT('DATE TIME')
 +
    A            VTEXT        100A        VARLEN
 +
    A                                      TEXT('VARIABLE TEXT')
 +
    A            DESCP        30A        TEXT('Product description or name ')
 +
    A            TXT1        500A        TEXT('TXT1  ')
 +
    A            TXT2        500A        TEXT('TXT2  ')
 +
    A            TXT3        500A        TEXT('TXT3  ')
 +
    A            TXT4        500A        TEXT('TXT4  ')
 +
    A            TXT5        500A        TEXT('TXT5  ')
 +
    A            TXT6        500A        TEXT('TXT6  ')
 +
    A            TXT7        500A        TEXT('TXT7  ')
 +
    A            TXT8        500A        TEXT('TXT8  ')
 +
    A          K ACTIV
 +
    A          K CMPNO
 +
    A          K PRDNO
 +
    A          K OPBAL
 +
    A          K SERVU
 +
 +
 +
</pre>
 +
 +
[[#top]]

Latest revision as of 22:42, 7 December 2018


UDDS PROGRAMS THAT SHOW FILES FIELDS AND RELATIONS AND ALLOWS UPDATE

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


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

It shows file data, but is limited to 6048 max rcdlen. There are 3 programs first is limited to 2048 last to 6048.

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


I am also inculding wrapper programs to make the displayer more useful. The COMPILE CL will create the objects once you have copied the source code into a source file.

Once compiled the command to run it is 'DSPFL yourlib/yourfile '


DISP RPG

     H*eywords++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++Comments+++++++++++
     H OPTION(*NODEBUGIO)
     H DFTACTGRP(*NO) ACTGRP(*CALLER) DFTNAME(DISP )
     F*
     F*  LIMITED TO MAXIMUM FILE LENGTH OF 2048
     F*   TEST
     F*   REQUIRES FILE TO COMPILE
     F*  DSPFFD  FILE(&LIB/&FILE) OUTPUT(*OUTFILE) OUTFILE(QTEMP/FFD)

     FFFD       IF   E             DISK
     FDISPF     CF   F  803        WORKSTN
     F*
     F                                     INFDS(INFDS)
     FINPUTK    IF   F32766   800AIDISK    KEYLOC(1)
     F                                     EXTIND(*INU1)
     F                                     INFDS(INFDK)
     FINPUTR    IF   F32766        DISK    EXTIND(*INU2)
     F                                     INFDS(INFDR)

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

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


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

     D TEXT800         S            800
     D KW              S            800

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

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

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

     D FLT14           S             14
     D FLT23           S             23

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

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

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

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

     D                 DS
     D  FLT4                   1      4F
     D  FL4                    1      4

     D                 DS
     D  FLT8                   1      8F
     D  FL8                    1      8

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

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


     D @LOOP           C                   '1'

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


      /FREE
             BASE = 0;

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

         //   START        TAG
           DOW       @LOOP = @LOOP;

           IF  RTN  = '3';

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

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

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

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

        //  CF20 MORE FIELDS
           IF  AID  = XB8;

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

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

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

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

       //  CF19 PREVIOUS FIELDS
           IF  AID  = XB7;

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

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

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

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

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

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


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

          ENDDO ;

           *INLR = *ON;

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

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

          BEGSR   @PCKD ;

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

          ENDSR;

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

          BEGSR   @CVTKEY;

       // EXTRACT THE KEY FIELD DATA FROM THE INCOMING STRING

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

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

           FOR  Y  = 1  TO NUMKEY ;

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

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

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

          X  =  1;

          DOW  @LOOP = @LOOP;

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

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

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

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

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

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

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

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

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

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

         ENDFOR;

         //
          KEYA  = KW;
          CLEAR KW;
        ENDSR ;

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

          BEGSR   @CVTRRN;

        //   RRN

           NUM11 = 0;

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

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

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

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

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

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


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

         LEAVE;
         ENDDO;


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

         ENDSR;

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

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

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

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

          Z1 = 60;
          FOR Z  =  K2  DOWNTO K1;

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

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

            Z1 = Z1 -1;
          ENDFOR;

          ENDIF;

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

        ENDIF;

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

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

        ENDIF;

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

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

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

        ENDIF;

       ENDSR;


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

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

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

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


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

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

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

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

             KEYA = LKY;


             CLEAR KW;
             KW   = LKY;

          ENDIF;

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

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

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

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

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

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

          ENDSR;


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

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

        // IF GOT RECORDS WRITE DATA TO THE DISPLAY

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

          IF RRN > 0    ;
            FOR  XX = 1 TO      NUMFKY; //NUMBER OF DATA ELEMENTS (FLD AND KEY)

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

             IF WRTRRN = '1';
              WRTRRN = '0';
              RU  = RU + SBA + RBA ;
              RU = RU + %TRIM(%EDITC(RRN:'Z'));
             ENDIF;

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

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

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

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

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

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


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

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

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

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

             ENDIF;

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

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

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


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

             ST = S(XX);

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

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

             ENDIF;


           //   SEND A REQUEST UNIT IF GOT ENOUGH DATA

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

            ENDFOR;
           ENDIF;

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


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

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



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

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

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

          SCRST = *BLANK;
          SCRSTN = *BLANK;

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

         TEXT500 = SCNLV ;
         LV      = LVW;

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

          SETLL 1 QWHDRFFD ;

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

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

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


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

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

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

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

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

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

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

        ENDDO;
        //  NUMBER OF FIELDS
         NUMFLD = X ;

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

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

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

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

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

        ENDSR;


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

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

          FOR X = 1 TO NUMFKY;

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

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

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

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

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

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

          ENDFOR;

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

        ENDSR;


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

        //  PUT FIELD HEADINGS
          BEGSR     @PUTHED;


            NEWRU  = '1';

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

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

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

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

             RU = RU + ATC ;

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

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

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

            ENDFOR;

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

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


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

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

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

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

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

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


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

           ENDFOR;

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

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

        ENDSR;

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

        CLEAR  KW;

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

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


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

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

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

           EXCEPT    DATAO;

        ENDSR;


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

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

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

         EXCEPT DATAI;
         ENDSR;

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

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

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

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

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

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


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

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

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

             RU  = RU + X20;

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


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


          EXSR      @KEYIN;
          READ      DISPF;


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

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

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

         ENDSR;


      /END-FREE

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

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

#top

DISP1 RPG

     H*eywords++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++Comments+++++++++++
     H OPTION(*NODEBUGIO)
     H DFTACTGRP(*NO) ACTGRP(*CALLER) DFTNAME(DISP )
     F*
     F*  LIMITED TO MAXIMUM FILE LENGTH OF 4080
     F*   TEST
     F*   REQUIRES FILE TO COMPILE
     F*  DSPFFD  FILE(&LIB/&FILE) OUTPUT(*OUTFILE) OUTFILE(QTEMP/FFD)

     FFFD       IF   E             DISK
     FDISPF     CF   F  803        WORKSTN
     F*
     F                                     INFDS(INFDS)
     FINPUTK    IF   F32766   800AIDISK    KEYLOC(1)
     F                                     EXTIND(*INU1)
     F                                     INFDS(INFDK)
     FINPUTR    IF   F32766        DISK    EXTIND(*INU2)
     F                                     INFDS(INFDR)

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

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


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

     D TEXT800         S            800
     D KW              S            800

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

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

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

     D FLT14           S             14
     D FLT23           S             23

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

     D                 DS
     D  D                      1   4080
     D                                     DIM(4080)                            INCOMING DATA
     D  DA                     1   2048
     D  DB                  2049   2064
     D  DC                  2065   2096
     D  DD                  2097   2128
     D  DE                  2129   2160
     D  DF                  2161   2192
     D  DG                  2193   2224
     D  DH                  2225   2256
     D  DI                  2257   2288
     D  DJ                  2289   2320
     D  DK                  2321   2352
     D  DL                  2353   2384
     D  DM                  2385   2416
     D  DN                  2417   2448
     D  DZ                  2449   2480
     D  DO                  2481   2512
     D  DP                  2513   2544
     D  DQ                  2545   2576
     D  DR                  2577   2608
     D  DS                  2609   2640
     D  DT                  2641   2672
     D  DU                  2673   2704
     D  DV                  2705   2736
     D  DW                  2737   2768
     D  DX                  2769   2800
     D  DY                  2801   2832
     D  D0                  2833   2864
     D  D1                  2865   2896
     D  D2                  2897   2928
     D  D3                  2929   2960
     D  D4                  2961   2992
     D  D5                  2993   3024
     D  D6                  3025   3056
     D  DBA                 3057   3088
     D  DCA                 3089   3120
     D  DDA                 3121   3152
     D  DEA                 3153   3184
     D  DFA                 3185   3216
     D  DGA                 3217   3248
     D  DHA                 3249   3280
     D  DIA                 3281   3312
     D  DJA                 3313   3344
     D  DKA                 3345   3376
     D  DLA                 3377   3408
     D  DMA                 3409   3440
     D  DNA                 3441   3472
     D  DOA                 3473   3504
     D  DPA                 3505   3536
     D  DQA                 3537   3568
     D  DRA                 3569   3600
     D  DSA                 3601   3632
     D  DTA                 3633   3664
     D  DUA                 3665   3696
     D  DVA                 3697   3728
     D  DWA                 3729   3760
     D  DXA                 3761   3792
     D  DYA                 3793   3824
     D  DZA                 3825   3856
     D  D0A                 3857   3888
     D  D1A                 3889   3920
     D  D2A                 3921   3952
     D  D3A                 3953   3984
     D  D4A                 3985   4016
     D  D5A                 4017   4048
     D  D6A                 4049   4080
     D                 DS
     D  ID                     1    800
     D                                     DIM(800)                             INCOMING DATA
     D  IDA                    1    800
     D  ID0                    1     80
     D  ID1                   81    160
     D  ID2                  161    240
     D  ID3                  241    320
     D  ID4                  321    400
     D  ID5                  401    480
     D  ID6                  481    560
     D  ID7                  561    640
     D  ID8                  641    720
     D  ID9                  721    800
     D                 DS
     D  BIN                    1      2B 0
     D  HX1                    2      2
     D  HX2                    1      2
     D                 DS
     D  PCK                    1      1P 0
     D  PCK1                   1      1
     D                 DS
     D  SGN                    1      1S 0
     D  SGN1                   1      1

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

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

     D                 DS
     D  FLT4                   1      4F
     D  FL4                    1      4

     D                 DS
     D  FLT8                   1      8F
     D  FL8                    1      8

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

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


     D @LOOP           C                   '1'

     D SND             C                   X'71'                                SEND TO DISP
     D SNR             C                   X'73'                                SND/RCV
     D RED             C                   X'42'                                READ
     D RDM             C                   X'52'                                READ MTD
     D ESC             C                   X'04'                                ESCAPE
     D CLR             C                   X'40'                                CLEAR UNIT
     D CC1             C                   X'00'                                CNTRL CHAR
     D CC2             C                   X'08'                                CNTRL CHAR
     D SBA             C                   X'11'                                SET BUFF ADR
     D IC              C                   X'13'                                INSERT CURS
     D WTD             C                   X'11'                                WRITE TO DSP
     D WER             C                   X'21'                                WRITE ERROR
     D SF              C                   X'1D'                                START FLD
     D ATC             C                   X'20'                                ATTR CHAR
     D ATN             C                   X'24'                                ATTR NUM
     D X00             C                   X'00'
     D X01             C                   X'01'
     D X02             C                   X'02'
     D X03             C                   X'03'
     D X0D             C                   X'0D'
     D X0F             C                   X'0F'
     D X000            C                   X'0000'
     D X1F             C                   X'1F'
     D X20             C                   X'20'                                SCRN ATT NORMAL
     D X22             C                   X'22'                                SCRN ATTR HI
     D X25             C                   X'25'
     D X26             C                   X'26'
     D X31             C                   X'31'                                CMD 1 KEY
     D X32             C                   X'32'                                CMD 2 KEY
     D X33             C                   X'33'                                CMD 3 KEY
     D X36             C                   X'36'                                CMD 6 KEY
     D X37             C                   X'37'                                CMD 7 KEY
     D X38             C                   X'38'                                CMD 8 KEY
     D X39             C                   X'39'                                CMD 9 KEY
     D X3B             C                   X'3B'                                CMD11 KEY
     D XB7             C                   X'B7'                                CMD19 KEY
     D XB8             C                   X'B8'                                CMD20 KEY
     D X40             C                   X'40'
     D X43             C                   X'43'
     D X47             C                   X'47'
     D X60             C                   X'60'
     D X67             C                   X'67'
     D X9F             C                   X'9F'
     D XF0             C                   X'F0'
     D XD0             C                   X'D0'
     D X4000           C                   X'4000'
     D X4800           C                   X'4800'                              FF ALPHA
     D X4F06           C                   X'4F06'                              FF NUMERIC
     D X6000           C                   X'6000'                              FF ALPHA
     D X6706           C                   X'6706'                              FF NUMERIC
     D CLRWTD          C                   X'044004112000'                      INCLUDES ESC CHARS
     D RDDSP           C                   X'0411200804524000'                  REAB FROM DISPLAY
     D FFA1            S              1    INZ(X'40')                           F.FMT 1 ALPH  60 BYP
     D FFA2            S              1    INZ(X'00')                           F.FMT 2 ALPH
     D FFN1            S              1    INZ(X'47')                           F.FMT 1 NUM   67 BYP
     D FFN2            S              1    INZ(X'06')                           F.FMT 2 NUM
     I*.
     IINPUTK    NS  01
     I                                  1 2048  DA
     I                               2049 2064  DB                30
     I                               2065 2096  DC                31
     I                               2097 2128  DD                32
     I                               2129 2160  DE                33
     I                               2161 2192  DF                34
     I                               2193 2224  DG                35
     I                               2225 2256  DH                36
     I                               2257 2288  DI                37
     I                               2289 2320  DJ                38
     I                               2321 2352  DK                39
     I                               2353 2384  DL                40
     I                               2385 2416  DM                41
     I                               2417 2448  DN                42
     I                               2449 2480  DZ                43
     I                               2481 2512  DO                44
     I                               2513 2544  DP                45
     I                               2545 2576  DQ                46
     I                               2577 2608  DR                47
     I                               2609 2640  DS                48
     I                               2641 2672  DT                49
     I                               2673 2704  DU                50
     I                               2705 2736  DV                51
     I                               2737 2768  DW                52
     I                               2769 2800  DX                53
     I                               2801 2832  DY                54
     I                               2833 2864  D0                55
     I                               2865 2896  D1                56
     I                               2897 2928  D2                57
     I                               2929 2960  D3                58
     I                               2961 2992  D4                59
     I                               2993 3024  D5                60
     I                               3025 3056  D6                61
     I                               3057 3088  DBA               62
     I                               3089 3120  DCA               63
     I                               3121 3152  DDA               64
     I                               3153 3184  DEA               65
     I                               3185 3216  DFA               66
     I                               3217 3248  DGA               67
     I                               3249 3280  DHA               68
     I                               3281 3312  DIA               69
     I                               3313 3344  DJA               70
     I                               3345 3376  DKA               71
     I                               3377 3408  DLA               72
     I                               3409 3440  DMA               73
     I                               3441 3472  DNA               74
     I                               3473 3504  DOA               75
     I                               3505 3536  DPA               76
     I                               3537 3568  DQA               77
     I                               3569 3600  DRA               78
     I                               3601 3632  DSA               79
     I                               3633 3664  DTA               80
     I                               3665 3696  DUA               81
     I                               3697 3728  DVA               82
     I                               3729 3760  DWA               83
     I                               3761 3792  DXA               84
     I                               3793 3824  DYA               85
     I                               3825 3856  DZA               86
     I                               3857 3888  D0A               87
     I                               3889 3920  D1A               88
     I                               3921 3952  D2A               89
     I                               3953 3984  D3A               90
     I                               3985 4016  D4A               91
     I                               4017 4048  D5A               92
     I                               4049 4080  D6A               93
     IINPUTR    NS  01
     I                                  1 2048  DA
     I                               2049 2064  DB                30
     I                               2065 2096  DC                31
     I                               2097 2128  DD                32
     I                               2129 2160  DE                33
     I                               2161 2192  DF                34
     I                               2193 2224  DG                35
     I                               2225 2256  DH                36
     I                               2257 2288  DI                37
     I                               2289 2320  DJ                38
     I                               2321 2352  DK                39
     I                               2353 2384  DL                40
     I                               2385 2416  DM                41
     I                               2417 2448  DN                42
     I                               2449 2480  DZ                43
     I                               2481 2512  DO                44
     I                               2513 2544  DP                45
     I                               2545 2576  DQ                46
     I                               2577 2608  DR                47
     I                               2609 2640  DS                48
     I                               2641 2672  DT                49
     I                               2673 2704  DU                50
     I                               2705 2736  DV                51
     I                               2737 2768  DW                52
     I                               2769 2800  DX                53
     I                               2801 2832  DY                54
     I                               2833 2864  D0                55
     I                               2865 2896  D1                56
     I                               2897 2928  D2                57
     I                               2929 2960  D3                58
     I                               2961 2992  D4                59
     I                               2993 3024  D5                60
     I                               3025 3056  D6                61
     I                               3057 3088  DBA               62
     I                               3089 3120  DCA               63
     I                               3121 3152  DDA               64
     I                               3153 3184  DEA               65
     I                               3185 3216  DFA               66
     I                               3217 3248  DGA               67
     I                               3249 3280  DHA               68
     I                               3281 3312  DIA               69
     I                               3313 3344  DJA               70
     I                               3345 3376  DKA               71
     I                               3377 3408  DLA               72
     I                               3409 3440  DMA               73
     I                               3441 3472  DNA               74
     I                               3473 3504  DOA               75
     I                               3505 3536  DPA               76
     I                               3537 3568  DQA               77
     I                               3569 3600  DRA               78
     I                               3601 3632  DSA               79
     I                               3633 3664  DTA               80
     I                               3665 3696  DUA               81
     I                               3697 3728  DVA               82
     I                               3729 3760  DWA               83
     I                               3761 3792  DXA               84
     I                               3793 3824  DYA               85
     I                               3825 3856  DZA               86
     I                               3857 3888  D0A               87
     I                               3889 3920  D1A               88
     I                               3921 3952  D2A               89
     I                               3953 3984  D3A               90
     I                               3985 4016  D4A               91
     I                               4017 4048  D5A               92
     I                               4049 4080  D6A               93

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


      /FREE
             BASE = 0;

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

         //   START        TAG
           DOW       @LOOP = @LOOP;

           IF  RTN  = '3';

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

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

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

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

        //  CF20 MORE FIELDS
           IF  AID  = XB8;

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

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

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

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

       //  CF19 PREVIOUS FIELDS
           IF  AID  = XB7;

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

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

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

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

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

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


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

          ENDDO ;

           *INLR = *ON;

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

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

          BEGSR   @PCKD ;

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

          ENDSR;

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

          BEGSR   @CVTKEY;

       // EXTRACT THE KEY FIELD DATA FROM THE INCOMING STRING

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

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

           FOR  Y  = 1  TO NUMKEY ;

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

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

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

          X  =  1;

          DOW  @LOOP = @LOOP;

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

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

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

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

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

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

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

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

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

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

         ENDFOR;

         //
          KEYA  = KW;
          CLEAR KW;
        ENDSR ;

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

          BEGSR   @CVTRRN;

        //   RRN

           NUM11 = 0;

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

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

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

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

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

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


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

         LEAVE;
         ENDDO;


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

         ENDSR;

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

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

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

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

          Z1 = 60;
          FOR Z  =  K2  DOWNTO K1;

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

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

            Z1 = Z1 -1;
          ENDFOR;

          ENDIF;

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

        ENDIF;

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

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

        ENDIF;

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

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

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

        ENDIF;

       ENDSR;


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

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

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

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


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

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

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

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

             KEYA = LKY;


             CLEAR KW;
             KW   = LKY;

          ENDIF;

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

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

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

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

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

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

          ENDSR;


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

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

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

          IF RRN > 0    ;
            FOR  XX = 1 TO      NUMFKY; //NUMBER OF DATA ELEMENTS (FLD AND KEY)

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

             IF WRTRRN = '1';
              WRTRRN = '0';
              RU  = RU + SBA + RBA ;
              RU = RU + %TRIM(%EDITC(RRN:'Z'));
             ENDIF;

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

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

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

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

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

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


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

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

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

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

             ENDIF;

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

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

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


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

             ST = S(XX);

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

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

             ENDIF;


           //   SEND A REQUEST UNIT IF GOT ENOUGH DATA

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

            ENDFOR;
           ENDIF;

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


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

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



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

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

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

          SCRST = *BLANK;
          SCRSTN = *BLANK;

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

         TEXT500 = SCNLV ;
         LV      = LVW;

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

          SETLL 1 QWHDRFFD ;

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

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

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


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

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

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

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

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

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

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

        ENDDO;
        //  NUMBER OF FIELDS
         NUMFLD = X ;

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

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

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

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

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

        ENDSR;


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

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

          FOR X = 1 TO NUMFKY;

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

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

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

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

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

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

          ENDFOR;

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

        ENDSR;


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

        //  PUT FIELD HEADINGS
          BEGSR     @PUTHED;


            NEWRU  = '1';

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

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

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

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

             RU = RU + ATC ;

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

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

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

            ENDFOR;

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

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


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

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

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

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

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

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


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

           ENDFOR;

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

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

        ENDSR;

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

        CLEAR  KW;

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

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


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

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

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

           EXCEPT    DATAO;

        ENDSR;


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

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

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

         EXCEPT DATAI;
         ENDSR;

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

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

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

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

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

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


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

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

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

             RU  = RU + X20;

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


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


          EXSR      @KEYIN;
          READ      DISPF;


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

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

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

         ENDSR;


      /END-FREE

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

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

#top

DISP2 RPG

     H*eywords++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++Comments+++++++++++
     H OPTION(*NODEBUGIO)
     H DFTACTGRP(*NO) ACTGRP(*CALLER) DFTNAME(DISP )
     F*
     F*  LIMITED TO MAXIMUM FILE LENGTH OF 6080

     F*  REQUIRES FILE  QTEMP/FFD  TO COMPILE
     F*  use cmd DSPFFD  FILE(&LIB/&FILE) OUTPUT(*OUTFILE) OUTFILE(QTEMP/FFD)

     FFFD       IF   E             DISK
     FDISPF     CF   F  803        WORKSTN
     F*
     F                                     INFDS(INFDS)
     FINPUTK    IF   F32766   800AIDISK    KEYLOC(1)
     F                                     EXTIND(*INU1)
     F                                     INFDS(INFDK)
     FINPUTR    IF   F32766        DISK    EXTIND(*INU2)
     F                                     INFDS(INFDR)

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

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


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

     D TEXT800         S            800
     D KW              S            800

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

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

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

     D FLT14           S             14
     D FLT23           S             23

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


     D                 DS
     D  D                      1   6080
     D                                     DIM(6080)                            INCOMING DATA
     D  DA                     1   4048
     D  DB                  4049   4064
     D  DC                  4065   4096
     D  DD                  4097   4128
     D  DE                  4129   4160
     D  DF                  4161   4192
     D  DG                  4193   4224
     D  DH                  4225   4256
     D  DI                  4257   4288
     D  DJ                  4289   4320
     D  DK                  4321   4352
     D  DL                  4353   4384
     D  DM                  4385   4416
     D  DN                  4417   4448
     D  DZ                  4449   4480
     D  DO                  4481   4512
     D  DP                  4513   4544
     D  DQ                  4545   4576
     D  DR                  4577   4608
     D  DS                  4609   4640
     D  DT                  4641   4672
     D  DU                  4673   4704
     D  DV                  4705   4736
     D  DW                  4737   4768
     D  DX                  4769   4800
     D  DY                  4801   4832
     D  D0                  4833   4864
     D  D1                  4865   4896
     D  D2                  4897   4928
     D  D3                  4929   4960
     D  D4                  4961   4992
     D  D5                  4993   5024
     D  D6                  5025   5056
     D  DBA                 5057   5088
     D  DCA                 5089   5120
     D  DDA                 5121   5152
     D  DEA                 5153   5184
     D  DFA                 5185   5216
     D  DGA                 5217   5248
     D  DHA                 5249   5280
     D  DIA                 5281   5312
     D  DJA                 5313   5344
     D  DKA                 5345   5376
     D  DLA                 5377   5408
     D  DMA                 5409   5440
     D  DNA                 5441   5472
     D  DOA                 5473   5504
     D  DPA                 5505   5536
     D  DQA                 5537   5568
     D  DRA                 5569   5600
     D  DSA                 5601   5632
     D  DTA                 5633   5664
     D  DUA                 5665   5696
     D  DVA                 5697   5728
     D  DWA                 5729   5760
     D  DXA                 5761   5792
     D  DYA                 5793   5824
     D  DZA                 5825   5856
     D  D0A                 5857   5888
     D  D1A                 5889   5920
     D  D2A                 5921   5952
     D  D3A                 5953   5984
     D  D4A                 5985   6016
     D  D5A                 6017   6048
     D  D6A                 6049   6080
     D                 DS
     D  ID                     1    800
     D                                     DIM(800)                             INCOMING DATA
     D  IDA                    1    800
     D  ID0                    1     80
     D  ID1                   81    160
     D  ID2                  161    240
     D  ID3                  241    320
     D  ID4                  321    400
     D  ID5                  401    480
     D  ID6                  481    560
     D  ID7                  561    640
     D  ID8                  641    720
     D  ID9                  721    800
     D                 DS
     D  BIN                    1      2B 0
     D  HX1                    2      2
     D  HX2                    1      2
     D                 DS
     D  PCK                    1      1P 0
     D  PCK1                   1      1
     D                 DS
     D  SGN                    1      1S 0
     D  SGN1                   1      1

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

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

     D                 DS
     D  FLT4                   1      4F
     D  FL4                    1      4

     D                 DS
     D  FLT8                   1      8F
     D  FL8                    1      8

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

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


     D @LOOP           C                   '1'

     D SND             C                   X'71'                                SEND TO DISP
     D SNR             C                   X'73'                                SND/RCV
     D RED             C                   X'42'                                READ
     D RDM             C                   X'52'                                READ MTD
     D ESC             C                   X'04'                                ESCAPE
     D CLR             C                   X'40'                                CLEAR UNIT
     D CC1             C                   X'00'                                CNTRL CHAR
     D CC2             C                   X'08'                                CNTRL CHAR
     D SBA             C                   X'11'                                SET BUFF ADR
     D IC              C                   X'13'                                INSERT CURS
     D WTD             C                   X'11'                                WRITE TO DSP
     D WER             C                   X'21'                                WRITE ERROR
     D SF              C                   X'1D'                                START FLD
     D ATC             C                   X'20'                                ATTR CHAR
     D ATN             C                   X'24'                                ATTR NUM
     D X00             C                   X'00'
     D X01             C                   X'01'
     D X02             C                   X'02'
     D X03             C                   X'03'
     D X0D             C                   X'0D'
     D X0F             C                   X'0F'
     D X000            C                   X'0000'
     D X1F             C                   X'1F'
     D X20             C                   X'20'                                SCRN ATT NORMAL
     D X22             C                   X'22'                                SCRN ATTR HI
     D X25             C                   X'25'
     D X26             C                   X'26'
     D X31             C                   X'31'                                CMD 1 KEY
     D X32             C                   X'32'                                CMD 2 KEY
     D X33             C                   X'33'                                CMD 3 KEY
     D X36             C                   X'36'                                CMD 6 KEY
     D X37             C                   X'37'                                CMD 7 KEY
     D X38             C                   X'38'                                CMD 8 KEY
     D X39             C                   X'39'                                CMD 9 KEY
     D X3B             C                   X'3B'                                CMD11 KEY
     D XB7             C                   X'B7'                                CMD19 KEY
     D XB8             C                   X'B8'                                CMD20 KEY
     D X40             C                   X'40'
     D X43             C                   X'43'
     D X47             C                   X'47'
     D X60             C                   X'60'
     D X67             C                   X'67'
     D X9F             C                   X'9F'
     D XF0             C                   X'F0'
     D XD0             C                   X'D0'
     D X4000           C                   X'4000'
     D X4800           C                   X'4800'                              FF ALPHA
     D X4F06           C                   X'4F06'                              FF NUMERIC
     D X6000           C                   X'6000'                              FF ALPHA
     D X6706           C                   X'6706'                              FF NUMERIC
     D CLRWTD          C                   X'044004112000'                      INCLUDES ESC CHARS
     D RDDSP           C                   X'0411200804524000'                  REAB FROM DISPLAY
     D FFA1            S              1    INZ(X'40')                           F.FMT 1 ALPH  60 BYP
     D FFA2            S              1    INZ(X'00')                           F.FMT 2 ALPH
     D FFN1            S              1    INZ(X'47')                           F.FMT 1 NUM   67 BYP
     D FFN2            S              1    INZ(X'06')                           F.FMT 2 NUM
     I*.
     IINPUTK    NS  01
     I                                  1 4048  DA
     I                               4049 4064  DB                30
     I                               4065 4096  DC                31
     I                               4097 4128  DD                32
     I                               4129 4160  DE                33
     I                               4161 4192  DF                34
     I                               4193 4224  DG                35
     I                               4225 4256  DH                36
     I                               4257 4288  DI                37
     I                               4289 4320  DJ                38
     I                               4321 4352  DK                39
     I                               4353 4384  DL                40
     I                               4385 4416  DM                41
     I                               4417 4448  DN                42
     I                               4449 4480  DZ                43
     I                               4481 4512  DO                44
     I                               4513 4544  DP                45
     I                               4545 4576  DQ                46
     I                               4577 4608  DR                47
     I                               4609 4640  DS                48
     I                               4641 4672  DT                49
     I                               4673 4704  DU                50
     I                               4705 4736  DV                51
     I                               4737 4768  DW                52
     I                               4769 4800  DX                53
     I                               4801 4832  DY                54
     I                               4833 4864  D0                55
     I                               4865 4896  D1                56
     I                               4897 4928  D2                57
     I                               4929 4960  D3                58
     I                               4961 4992  D4                59
     I                               4993 5024  D5                60
     I                               5025 5056  D6                61
     I                               5057 5088  DBA               62
     I                               5089 5120  DCA               63
     I                               5121 5152  DDA               64
     I                               5153 5184  DEA               65
     I                               5185 5216  DFA               66
     I                               5217 5248  DGA               67
     I                               5249 5280  DHA               68
     I                               5281 5312  DIA               69
     I                               5313 5344  DJA               70
     I                               5345 5376  DKA               71
     I                               5377 5408  DLA               72
     I                               5409 5440  DMA               73
     I                               5441 5472  DNA               74
     I                               5473 5504  DOA               75
     I                               5505 5536  DPA               76
     I                               5537 5568  DQA               77
     I                               5569 5600  DRA               78
     I                               5601 5632  DSA               79
     I                               5633 5664  DTA               80
     I                               5665 5696  DUA               81
     I                               5697 5728  DVA               82
     I                               5729 5760  DWA               83
     I                               5761 5792  DXA               84
     I                               5793 5824  DYA               85
     I                               5825 5856  DZA               86
     I                               5857 5888  D0A               87
     I                               5889 5920  D1A               88
     I                               5921 5952  D2A               89
     I                               5953 5984  D3A               90
     I                               5985 6016  D4A               91
     I                               6017 6048  D5A               92
     I                               6049 6080  D6A               93
     IINPUTR    NS  01
     I                                  1 4048  DA
     I                               4049 4064  DB                30
     I                               4065 4096  DC                31
     I                               4097 4128  DD                32
     I                               4129 4160  DE                33
     I                               4161 4192  DF                34
     I                               4193 4224  DG                35
     I                               4225 4256  DH                36
     I                               4257 4288  DI                37
     I                               4289 4320  DJ                38
     I                               4321 4352  DK                39
     I                               4353 4384  DL                40
     I                               4385 4416  DM                41
     I                               4417 4448  DN                42
     I                               4449 4480  DZ                43
     I                               4481 4512  DO                44
     I                               4513 4544  DP                45
     I                               4545 4576  DQ                46
     I                               4577 4608  DR                47
     I                               4609 4640  DS                48
     I                               4641 4672  DT                49
     I                               4673 4704  DU                50
     I                               4705 4736  DV                51
     I                               4737 4768  DW                52
     I                               4769 4800  DX                53
     I                               4801 4832  DY                54
     I                               4833 4864  D0                55
     I                               4865 4896  D1                56
     I                               4897 4928  D2                57
     I                               4929 4960  D3                58
     I                               4961 4992  D4                59
     I                               4993 5024  D5                60
     I                               5025 5056  D6                61
     I                               5057 5088  DBA               62
     I                               5089 5120  DCA               63
     I                               5121 5152  DDA               64
     I                               5153 5184  DEA               65
     I                               5185 5216  DFA               66
     I                               5217 5248  DGA               67
     I                               5249 5280  DHA               68
     I                               5281 5312  DIA               69
     I                               5313 5344  DJA               70
     I                               5345 5376  DKA               71
     I                               5377 5408  DLA               72
     I                               5409 5440  DMA               73
     I                               5441 5472  DNA               74
     I                               5473 5504  DOA               75
     I                               5505 5536  DPA               76
     I                               5537 5568  DQA               77
     I                               5569 5600  DRA               78
     I                               5601 5632  DSA               79
     I                               5633 5664  DTA               80
     I                               5665 5696  DUA               81
     I                               5697 5728  DVA               82
     I                               5729 5760  DWA               83
     I                               5761 5792  DXA               84
     I                               5793 5824  DYA               85
     I                               5825 5856  DZA               86
     I                               5857 5888  D0A               87
     I                               5889 5920  D1A               88
     I                               5921 5952  D2A               89
     I                               5953 5984  D3A               90
     I                               5985 6016  D4A               91
     I                               6017 6048  D5A               92
     I                               6049 6080  D6A               93
     IDISPF     NS  02
     I                                  3    3  AID
     I                                  4   83  ID0
     I                                 84  163  ID1               20
     I                                164  243  ID2               21
     I                                244  323  ID3               22
     I                                324  403  ID4               23
     I                                404  483  ID5               24
     I                                484  563  ID6               25
     I                                564  643  ID7               26
     I                                644  723  ID8               27
     I                                724  803  ID9               28


      /FREE
             BASE = 0;

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

         //   START        TAG
           DOW       @LOOP = @LOOP;

           IF  RTN  = '3';

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

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

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

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

        //  CF20 MORE FIELDS
           IF  AID  = XB8;

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

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

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

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

       //  CF19 PREVIOUS FIELDS
           IF  AID  = XB7;

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

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

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

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

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

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


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

          ENDDO ;

           *INLR = *ON;

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

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

          BEGSR   @PCKD ;

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

          ENDSR;

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

          BEGSR   @CVTKEY;

       // EXTRACT THE KEY FIELD DATA FROM THE INCOMING STRING

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

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

           FOR  Y  = 1  TO NUMKEY ;

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

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

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

          X  =  1;

          DOW  @LOOP = @LOOP;

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

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

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

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

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

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

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

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

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

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

         ENDFOR;

         //
          KEYA  = KW;
          CLEAR KW;
        ENDSR ;

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

          BEGSR   @CVTRRN;

        //   RRN

           NUM11 = 0;

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

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

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

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

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

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


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

         LEAVE;
         ENDDO;


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

         ENDSR;

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

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

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

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

          Z1 = 60;
          FOR Z  =  K2  DOWNTO K1;

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

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

            Z1 = Z1 -1;
          ENDFOR;

          ENDIF;

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

        ENDIF;

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

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

        ENDIF;

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

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

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

        ENDIF;

       ENDSR;


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

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

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

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


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

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

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

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

             KEYA = LKY;


             CLEAR KW;
             KW   = LKY;

          ENDIF;

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

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

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

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

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

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

          ENDSR;


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

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

        // IF GOT RECORDS WRITE DATA TO THE DISPLAY

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

          IF RRN > 0    ;
            FOR  XX = 1 TO      NUMFKY; //NUMBER OF DATA ELEMENTS (FLD AND KEY)

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

             IF WRTRRN = '1';
              WRTRRN = '0';
              RU = RU + SBA + RBA ;
              RU = RU + %TRIM(%EDITC(RRN:'Z'));
             ENDIF;

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

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

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

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

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

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


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

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

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

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

             ENDIF;

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

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

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


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

             ST = S(XX);

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

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

             ENDIF;


           //   SEND A REQUEST UNIT IF GOT ENOUGH DATA

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

            ENDFOR;
          ENDIF;

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


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

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



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

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

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

          SCRST = *BLANK;
          SCRSTN = *BLANK;

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

         TEXT500 = SCNLV ;
         LV      = LVW;

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

          SETLL 1 QWHDRFFD ;

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

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

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


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

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

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

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

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

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

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

        ENDDO;
        //  NUMBER OF FIELDS
         NUMFLD = X ;

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

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

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

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

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

        ENDSR;


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

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

          FOR X = 1 TO NUMFKY;

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

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

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

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

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

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

          ENDFOR;

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

        ENDSR;


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

        //  PUT FIELD HEADINGS
          BEGSR     @PUTHED;


            NEWRU  = '1';

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

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

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

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

             RU = RU + ATC ;

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

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

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

            ENDFOR;

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

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


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

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

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

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

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

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


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

           ENDFOR;

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

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

        ENDSR;

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

        CLEAR  KW;

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

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


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

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

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

           EXCEPT    DATAO;

        ENDSR;


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

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

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

         EXCEPT DATAI;
         ENDSR;

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

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

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

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

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

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


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

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

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

             RU  = RU + X20;

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


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


          EXSR      @KEYIN;
          READ      DISPF;


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

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

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

         ENDSR;


      /END-FREE

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

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

#top

DUSP RPG

     H*eywords++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++Comments+++++++++++
     H OPTION(*NODEBUGIO)
     H DFTACTGRP(*NO) ACTGRP(*CALLER) DFTNAME(DUSP )
     F*
     F*  LIMITED TO MAXIMUM FILE LENGTH OF 2048
     F*  REQUIRES FILE  QTEMP/FFD  TO COMPILE
     F*  use cmd DSPFFD  FILE(&LIB/&FILE) OUTPUT(*OUTFILE) OUTFILE(QTEMP/FFD)

     FFFD       IF   E             DISK
     FDISPF     CF   F  803        WORKSTN
     F*
     F                                     INFDS(INFDS)
     FINPUTK    UF A F32766   800AIDISK    KEYLOC(1)
     F                                     EXTIND(*INU1)
     F                                     INFDS(INFDK)
     FINPUTR    UF A F32766        DISK    EXTIND(*INU2)
     F                                     INFDS(INFDR)


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

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

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


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

     D TEXT800         S            800
     D KW              S            800

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

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

     D NUC             S             15P 0
     D BAN2            S              2
     D BAN4            S              4

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

     D                 DS
     D result8                        8F
     D NUFW8                   1      8A

     D                 DS
     D result4                        4F
     D NUFW4                   1      4A

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

     D FLT14           S             14
     D FLT23           S             23

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

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

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

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

     D                 DS
     D  FLT4                   1      4F
     D  FL4                    1      4

     D                 DS
     D  FLT8                   1      8F
     D  FL8                    1      8

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

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


     D @LOOP           C                   '1'
     D @FALSE          C                   '0'
     D @TRUE           C                   '1'

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

      /FREE
             BASE = 0;

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

         //   START        TAG
           DOW       @LOOP = @LOOP;

           IF  RTN  = '3';

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

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

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

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

        //  CF20 MORE FIELDS
           IF  AID  = XB8;

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

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

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

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

       //  CF19 PREVIOUS FIELDS
           IF  AID  = XB7;

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

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

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

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

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

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

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

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

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

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

             ENDIF;


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


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

          ENDDO ;

           *INLR = *ON;

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

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

          BEGSR   @PCKD ;

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

          ENDSR;

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

          BEGSR   @CVTKEY;

       // EXTRACT THE KEY FIELD DATA FROM THE INCOMING STRING

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

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

           FOR  Y  = 1  TO NUMKEY ;

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

            //  GET SIZE OF FIELD IN BYTES
         SELECT;
          WHEN  T(Y)  =  'A';  // ALPHA DATA
           K = ' ';
           K1 = 1;
           K2 = Q(Y);
          WHEN  T(Y)  =  'F';  // FLOAT
           K  = '0';
           K1 =  1;
           K2 = L(Y);
          OTHER;
           K  = '0';
           K1 =  1;
           K2 = C(Y);
         ENDSL;


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

          X  =  1;

          DOW  @LOOP = @LOOP;

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

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

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

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

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

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

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

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

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

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

         ENDFOR;

         //
          KEYA  = KW;
          CLEAR KW;
        ENDSR ;

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

          BEGSR   @CVTRRN;

        //   RRN

           NUM11 = 0;

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

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

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

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

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

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


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

         LEAVE;
         ENDDO;


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

         ENDSR;

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

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

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

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

          Z1 = 60;
          FOR Z  =  K2  DOWNTO K1;

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

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

            Z1 = Z1 -1;
          ENDFOR;

          ENDIF;

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

        ENDIF;

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

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

        ENDIF;

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

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

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

        ENDIF;

       ENDSR;


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

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

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

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


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

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

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

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

             KEYA = LKY;


             CLEAR KW;
             KW   = LKY;

          ENDIF;

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

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

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

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

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

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

          ENDSR;


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

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

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

          IF RRN > 0    ;
            FOR  XX = 1 TO      NUMFKY; //NUMBER OF DATA ELEMENTS (FLD AND KEY)

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

             IF WRTRRN = '1';
              WRTRRN = '0';
              RU  = RU + SBA + RBA ;
              RU = RU + %TRIM(%EDITC(RRN:'Z'));
             ENDIF;

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

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

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

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

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

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


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

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

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

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

             ENDIF;

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

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

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


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

             ST = S(XX);

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

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

             ENDIF;


           //   SEND A REQUEST UNIT IF GOT ENOUGH DATA

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

            ENDFOR;
          ENDIF;

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


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

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



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

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

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

          SCRST = *BLANK;
          SCRSTN = *BLANK;

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

         TEXT500 = SCNLV ;
         LV      = LVW;

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

          SETLL 1 QWHDRFFD ;

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

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

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


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

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

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

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

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

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

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

        ENDDO;
        //  NUMBER OF FIELDS
         NUMFLD = X ;

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

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

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

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

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

        ENDSR;


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

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

          FOR X = 1 TO NUMFKY;

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

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

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

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

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

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

          ENDFOR;

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

        ENDSR;


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

        //  PUT FIELD HEADINGS
          BEGSR     @PUTHED;


            NEWRU  = '1';

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

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

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

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

             RU = RU + ATC ;

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

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

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

            ENDFOR;

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

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


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

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

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

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

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

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


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

           ENDFOR;

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

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

        ENDSR;

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

        CLEAR  KW;

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

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


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

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

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

           EXCEPT    DATAO;

        ENDSR;


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

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

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

         EXCEPT DATAI;
         ENDSR;

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

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

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

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

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

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


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

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

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

             RU  = RU + X20;

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


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


          EXSR      @KEYIN;
          READ      DISPF;


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

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

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

         ENDSR;



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

        // CONVERT  DATA  FOR OUTPUT

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

           FOR  Y  = 1  TO NUMFKY ;

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


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

       //  GET SIZE OF FIELD IN BYTES
         SELECT;
          WHEN  T(Y)  =  'A';  // ALPHA DATA
           K = ' ';
           K1 = 1;
           K2 = Q(Y);
          WHEN  T(Y)  =  'F';  // FLOAT
           K  = '0';
           K1 =  1;
           K2 = L(Y);
          OTHER;
           K  = '0';
           K1 =  1;
           K2 = C(Y);
         ENDSL;

          X  =  1;

           DOW  @LOOP = @LOOP;

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

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


       //  FOUND A MTD FOR THIS FIELD


         // CHECK IF FIELD WAS CLEARED ONLY
          DOW @LOOP = @LOOP; //  not a loop
         X =  X + 2;
         IF  ID(X) = SBA;
          LEAVE;
         ENDIF;

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


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

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

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

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

          LEAVE;
         ENDDO;

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

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

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

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

              ENDIF;

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

          Z1 = 60;
          FOR Z  =  K2  DOWNTO K1;

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

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

            Z1 = Z1 -1;
          ENDFOR;

          ENDIF;


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

        ENDIF;


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

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

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

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

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

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

        ENDIF;


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

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

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

        ENDIF;


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

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

        ENDIF;

        ENDIF;



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


         ENDDO;
        ENDFOR;


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

        ENDSR;



      /END-FREE

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

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

     OINPUTK    EDEL U1      DELREC
     OINPUTR    EDEL U2      DELREC


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

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


#top

DUSP1 RPG

     H*eywords++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++Comments+++++++++++
     H OPTION(*NODEBUGIO)
     H DFTACTGRP(*NO) ACTGRP(*CALLER) DFTNAME(DUSP1 )
     F*
     F*  LIMITED TO MAXIMUM FILE LENGTH OF 4080
     F*  REQUIRES FILE  QTEMP/FFD  TO COMPILE
     F*  use cmd DSPFFD  FILE(&LIB/&FILE) OUTPUT(*OUTFILE) OUTFILE(QTEMP/FFD)

     FFFD       IF   E             DISK
     FDISPF     CF   F  803        WORKSTN
     F*
     F                                     INFDS(INFDS)
     FINPUTK    UF A F32766   800AIDISK    KEYLOC(1)
     F                                     EXTIND(*INU1)
     F                                     INFDS(INFDK)
     FINPUTR    UF A F32766        DISK    EXTIND(*INU2)
     F                                     INFDS(INFDR)

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

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

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


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

     D TEXT800         S            800
     D KW              S            800

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

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

     D NUC             S             15P 0
     D BAN2            S              2
DCL  D BAN4            S              4

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

     D FLT14           S             14
     D FLT23           S             23

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


     D                 DS
     D  DATA                   1   4080
     D  D                      1   4080
     D                                     DIM(4080)                            INCOMING DATA
     D  DA                     1   2048
     D                                     DIM(2048)
     D  DB                  2049   2064
     D  DC                  2065   2096
     D  DD                  2097   2128
     D  DE                  2129   2160
     D  DF                  2161   2192
     D  DG                  2193   2224
     D  DH                  2225   2256
     D  DI                  2257   2288
     D  DJ                  2289   2320
     D  DK                  2321   2352
     D  DL                  2353   2384
     D  DM                  2385   2416
     D  DN                  2417   2448
     D  DZ                  2449   2480
     D  DO                  2481   2512
     D  DP                  2513   2544
     D  DQ                  2545   2576
     D  DR                  2577   2608
     D  DS                  2609   2640
     D  DT                  2641   2672
     D  DU                  2673   2704
     D  DV                  2705   2736
     D  DW                  2737   2768
     D  DX                  2769   2800
     D  DY                  2801   2832
     D  D0                  2833   2864
     D  D1                  2865   2896
     D  D2                  2897   2928
     D  D3                  2929   2960
     D  D4                  2961   2992
     D  D5                  2993   3024
     D  D6                  3025   3056
     D  DBA                 3057   3088
     D  DCA                 3089   3120
     D  DDA                 3121   3152
     D  DEA                 3153   3184
     D  DFA                 3185   3216
     D  DGA                 3217   3248
     D  DHA                 3249   3280
     D  DIA                 3281   3312
     D  DJA                 3313   3344
     D  DKA                 3345   3376
     D  DLA                 3377   3408
     D  DMA                 3409   3440
     D  DNA                 3441   3472
     D  DOA                 3473   3504
     D  DPA                 3505   3536
     D  DQA                 3537   3568
     D  DRA                 3569   3600
     D  DSA                 3601   3632
     D  DTA                 3633   3664
     D  DUA                 3665   3696
     D  DVA                 3697   3728
     D  DWA                 3729   3760
     D  DXA                 3761   3792
     D  DYA                 3793   3824
     D  DZA                 3825   3856
     D  D0A                 3857   3888
     D  D1A                 3889   3920
     D  D2A                 3921   3952
     D  D3A                 3953   3984
     D  D4A                 3985   4016
     D  D5A                 4017   4048
     D  D6A                 4049   4080
     D                 DS
     D  ID                     1    800
     D                                     DIM(800)                             INCOMING DATA
     D  IDA                    1    800
     D  ID0                    1     80
     D  ID1                   81    160
     D  ID2                  161    240
     D  ID3                  241    320
     D  ID4                  321    400
     D  ID5                  401    480
     D  ID6                  481    560
     D  ID7                  561    640
     D  ID8                  641    720
     D  ID9                  721    800
     D                 DS
     D  BIN                    1      2B 0
     D  HX1                    2      2
     D  HX2                    1      2
     D                 DS
     D  PCK                    1      1P 0
     D  PCK1                   1      1
     D                 DS
     D  SGN                    1      1S 0
     D  SGN1                   1      1

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

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

     D                 DS
     D  FLT4                   1      4F
     D  FL4                    1      4

     D                 DS
     D  FLT8                   1      8F
     D  FL8                    1      8

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

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


     D @LOOP           C                   '1'
     D @FALSE          C                   '0'
     D @TRUE           C                   '1'

     D SND             C                   X'71'                                SEND TO DISP
     D SNR             C                   X'73'                                SND/RCV
     D RED             C                   X'42'                                READ
     D RDM             C                   X'52'                                READ MTD
     D ESC             C                   X'04'                                ESCAPE
     D CLR             C                   X'40'                                CLEAR UNIT
     D CC1             C                   X'00'                                CNTRL CHAR
     D CC2             C                   X'08'                                CNTRL CHAR
     D SBA             C                   X'11'                                SET BUFF ADR
     D IC              C                   X'13'                                INSERT CURS
     D WTD             C                   X'11'                                WRITE TO DSP
     D WER             C                   X'21'                                WRITE ERROR
     D SF              C                   X'1D'                                START FLD
     D ATC             C                   X'20'                                ATTR CHAR
     D ATN             C                   X'24'                                ATTR NUM
     D X00             C                   X'00'
     D X01             C                   X'01'
     D X02             C                   X'02'
     D X03             C                   X'03'
     D X0D             C                   X'0D'
     D X0F             C                   X'0F'
     D X000            C                   X'0000'
     D X1F             C                   X'1F'
     D X20             C                   X'20'                                SCRN ATT NORMAL
     D X22             C                   X'22'                                SCRN ATTR HI
     D X25             C                   X'25'
     D X26             C                   X'26'
     D X31             C                   X'31'                                CMD 1 KEY
     D X32             C                   X'32'                                CMD 2 KEY
     D X33             C                   X'33'                                CMD 3 KEY
     D X36             C                   X'36'                                CMD 6 KEY
     D X37             C                   X'37'                                CMD 7 KEY
     D X38             C                   X'38'                                CMD 8 KEY
     D X39             C                   X'39'                                CMD 9 KEY
     D X3B             C                   X'3B'                                CMD11 KEY
     D XB7             C                   X'B7'                                CMD19 KEY
     D XB8             C                   X'B8'                                CMD20 KEY
     D X40             C                   X'40'
     D X43             C                   X'43'
     D X47             C                   X'47'
     D X60             C                   X'60'
     D X67             C                   X'67'
     D X9F             C                   X'9F'
     D XF0             C                   X'F0'
     D XD0             C                   X'D0'
     D X4000           C                   X'4000'
     D X4800           C                   X'4800'                              FF ALPHA
     D X4F06           C                   X'4F06'                              FF NUMERIC
     D X6000           C                   X'6000'                              FF ALPHA
     D X6706           C                   X'6706'                              FF NUMERIC
     D CLRWTD          C                   X'044004112000'                      INCLUDES ESC CHARS
     D RDDSP           C                   X'0411200804524000'                  READ FROM DISPLAY
     D FFA1            S              1    INZ(X'40')                           F.FMT 1 ALPH  60 BYP
     D FFA2            S              1    INZ(X'00')                           F.FMT 2 ALPH
     D FFN1            S              1    INZ(X'47')                           F.FMT 1 NUM   67 BYP
     D FFN2            S              1    INZ(X'06')                           F.FMT 2 NUM
     I*.
     IINPUTK    NS  01
     I                                  1 2048  DA
     I                               2049 2064  DB                30
     I                               2065 2096  DC                31
     I                               2097 2128  DD                32
     I                               2129 2160  DE                33
     I                               2161 2192  DF                34
     I                               2193 2224  DG                35
     I                               2225 2256  DH                36
     I                               2257 2288  DI                37
     I                               2289 2320  DJ                38
     I                               2321 2352  DK                39
     I                               2353 2384  DL                40
     I                               2385 2416  DM                41
     I                               2417 2448  DN                42
     I                               2449 2480  DZ                43
     I                               2481 2512  DO                44
     I                               2513 2544  DP                45
     I                               2545 2576  DQ                46
     I                               2577 2608  DR                47
     I                               2609 2640  DS                48
     I                               2641 2672  DT                49
     I                               2673 2704  DU                50
     I                               2705 2736  DV                51
     I                               2737 2768  DW                52
     I                               2769 2800  DX                53
     I                               2801 2832  DY                54
     I                               2833 2864  D0                55
     I                               2865 2896  D1                56
     I                               2897 2928  D2                57
     I                               2929 2960  D3                58
     I                               2961 2992  D4                59
     I                               2993 3024  D5                60
     I                               3025 3056  D6                61
     I                               3057 3088  DBA               62
     I                               3089 3120  DCA               63
     I                               3121 3152  DDA               64
     I                               3153 3184  DEA               65
     I                               3185 3216  DFA               66
     I                               3217 3248  DGA               67
     I                               3249 3280  DHA               68
     I                               3281 3312  DIA               69
     I                               3313 3344  DJA               70
     I                               3345 3376  DKA               71
     I                               3377 3408  DLA               72
     I                               3409 3440  DMA               73
     I                               3441 3472  DNA               74
     I                               3473 3504  DOA               75
     I                               3505 3536  DPA               76
     I                               3537 3568  DQA               77
     I                               3569 3600  DRA               78
     I                               3601 3632  DSA               79
     I                               3633 3664  DTA               80
     I                               3665 3696  DUA               81
     I                               3697 3728  DVA               82
     I                               3729 3760  DWA               83
     I                               3761 3792  DXA               84
     I                               3793 3824  DYA               85
     I                               3825 3856  DZA               86
     I                               3857 3888  D0A               87
     I                               3889 3920  D1A               88
     I                               3921 3952  D2A               89
     I                               3953 3984  D3A               90
     I                               3985 4016  D4A               91
     I                               4017 4048  D5A               92
     I                               4049 4080  D6A               93
     IINPUTR    NS  01
     I                                  1 2048  DA
     I                               2049 2064  DB                30
     I                               2065 2096  DC                31
     I                               2097 2128  DD                32
     I                               2129 2160  DE                33
     I                               2161 2192  DF                34
     I                               2193 2224  DG                35
     I                               2225 2256  DH                36
     I                               2257 2288  DI                37
     I                               2289 2320  DJ                38
     I                               2321 2352  DK                39
     I                               2353 2384  DL                40
     I                               2385 2416  DM                41
     I                               2417 2448  DN                42
     I                               2449 2480  DZ                43
     I                               2481 2512  DO                44
     I                               2513 2544  DP                45
     I                               2545 2576  DQ                46
     I                               2577 2608  DR                47
     I                               2609 2640  DS                48
     I                               2641 2672  DT                49
     I                               2673 2704  DU                50
     I                               2705 2736  DV                51
     I                               2737 2768  DW                52
     I                               2769 2800  DX                53
     I                               2801 2832  DY                54
     I                               2833 2864  D0                55
     I                               2865 2896  D1                56
     I                               2897 2928  D2                57
     I                               2929 2960  D3                58
     I                               2961 2992  D4                59
     I                               2993 3024  D5                60
     I                               3025 3056  D6                61
     I                               3057 3088  DBA               62
     I                               3089 3120  DCA               63
     I                               3121 3152  DDA               64
     I                               3153 3184  DEA               65
     I                               3185 3216  DFA               66
     I                               3217 3248  DGA               67
     I                               3249 3280  DHA               68
     I                               3281 3312  DIA               69
     I                               3313 3344  DJA               70
     I                               3345 3376  DKA               71
     I                               3377 3408  DLA               72
     I                               3409 3440  DMA               73
     I                               3441 3472  DNA               74
     I                               3473 3504  DOA               75
     I                               3505 3536  DPA               76
     I                               3537 3568  DQA               77
     I                               3569 3600  DRA               78
     I                               3601 3632  DSA               79
     I                               3633 3664  DTA               80
     I                               3665 3696  DUA               81
     I                               3697 3728  DVA               82
     I                               3729 3760  DWA               83
     I                               3761 3792  DXA               84
     I                               3793 3824  DYA               85
     I                               3825 3856  DZA               86
     I                               3857 3888  D0A               87
     I                               3889 3920  D1A               88
     I                               3921 3952  D2A               89
     I                               3953 3984  D3A               90
     I                               3985 4016  D4A               91
     I                               4017 4048  D5A               92
     I                               4049 4080  D6A               93
     IDISPF     NS  02
     I                                  3    3  AID
     I                                  4   83  ID0
     I                                 84  163  ID1               20
     I                                164  243  ID2               21
     I                                244  323  ID3               22
     I                                324  403  ID4               23
     I                                404  483  ID5               24
     I                                484  563  ID6               25
     I                                564  643  ID7               26
     I                                644  723  ID8               27
     I                                724  803  ID9               28


      /FREE
             BASE = 2048;

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

         //   START        TAG
           DOW       @LOOP = @LOOP;

           IF  RTN  = '3';

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

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

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

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

        //  CF20 MORE FIELDS
           IF  AID  = XB8;

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

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

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

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

       //  CF19 PREVIOUS FIELDS
           IF  AID  = XB7;

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

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

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

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

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

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

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

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

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

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

             ENDIF;


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


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

          ENDDO ;

           *INLR = *ON;

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

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

          BEGSR   @PCKD ;

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

          ENDSR;

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

          BEGSR   @CVTKEY;

       // EXTRACT THE KEY FIELD DATA FROM THE INCOMING STRING

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

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

           FOR  Y  = 1  TO NUMKEY ;

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

       //  GET SIZE OF FIELD IN BYTES
          IF T(Y)  =  'A';  // ALPHA DATA
           K = ' ';
           K1 = 1;
           K2 = Q(Y);
          ELSE;
           K  = '0';
           K1 =  1;
           K2 = C(Y);
          ENDIF;

       // IF WHOLE KEY INIT WAS REQUESTED BYPASS THE EXTRACT
           IF  INZ  = '1' ;
             KW  = *BLANK;
             EXSR      @PCKMOV;
             ITER;
           ENDIF;

          X  =  1;

          DOW  @LOOP = @LOOP;

       //  NXTSBA
          X  = %LOOKUP(SBA : ID : X );
           IF X = 0;
             LEAVE;
           ENDIF;

       // IS THIS THE FIELD?  CHECK THE BUFFER ADDRESS
         X = X +1;
         IF   B(Y)  <>  %SUBST(IDA : X :2);
          ITER;
         ENDIF;

       //  FOUND A MTD FOR THIS FIELD
         X =  X + 2;

       //  CHECK IF FIELD WAS CLEARED ONLY
         IF  ID(X) = SBA;
             EXSR      @PCKMOV;
             LEAVE ;
         ENDIF;

       //  IF FIELD HAS DECIMALS BUMP X
          IF (T(Y) = 'S' OR T(Y) = 'P' OR T(Y) = 'B') AND
              P(Y) > 0;
              X = X + 1;
          ENDIF;

       //   CHECK IF ONLY BLANKS RETURNED
         IF     %SUBST(IDA : X :K2) = *BLANKS;
             EXSR      @PCKMOV;
             LEAVE;
         ENDIF;

       // EXTRACT THE DATA FROM THE INCOMING STRING
         X1  = X;
         FOR X2  =  1 TO  K2 ;

           IF ID(X1) < ' ';
       // TRAP NULLS CAUSED BY FLD EXIT
             EXSR      @PCKMOV;
             LEAVE;
           ENDIF;

         K(X2)  =  ID(X1);
         X1     =  X1 +1;
         ENDFOR;

        // CONSTRUCT THE ACTUAL KEY WITH PACKED DATA IF REQUIRED
        // INTO ARRAY KW
          EXSR      @PCKMOV;
          LEAVE;
         ENDDO;

         ENDFOR;

         //
          KEYA  = KW;
          CLEAR KW;
        ENDSR ;

       //   @@@@@@@  @CVTRRN  @@@@@@@@@@@@@@@@@@@@@@@@

          BEGSR   @CVTRRN;

        //   RRN

           NUM11 = 0;

          DOW  @LOOP = @LOOP;  //  NOT REALLY A LOOP(SIMULATES GOTO)

       // GET THE FIRST SBA
          X = 1;
          X  = %LOOKUP(SBA : ID : X );
           IF X = 0;
           LEAVE;
           ENDIF;

       // CHECK THE BUFFER ADDRESS MATCHES THE EXPECTED FIELD
         X = X +1;
         IF   B(1)  <>  %SUBST(IDA : X :2);
          ITER;
         ENDIF;

       //  FOUND A MTD FOR RRN  FIELD
         X = X +2;

       //CHECK IF FIELD WAS CLEARED ONLY
         IF  ID(X) = SBA;
             LEAVE;
         ENDIF;

       //   CHECK IF ONLY BLANKS RETURNED
         IF     %SUBST(IDA : X :11) = *BLANKS;
             LEAVE;
         ENDIF;


         //  WRK11  OVERLAYS NUM11
         WRK11 = %SUBST(IDA : X :11);

         LEAVE;
         ENDDO;


         RRNA = NUM11;
         IF RRNA < 0;
         RRNA =  1;
         ENDIF;

         ENDSR;

       //   @@@@@@@  @PCKMOV  @@@@@@@@@@@@@@@@@@@@@@@@

         BEGSR  @PCKMOV;
       //
       //   CONVERT  KEY DATA
       //   SET START POSN IN KEY USING OFFSET IN R
          X1 = %LOOKUP(N(Y) : N );
          W = R(X1) + 1;

        // ALPHA
          IF  T(Y) = 'A';
           X1  = 1;
           FOR  Z = W   TO W + Q(Y);
             %SUBST(KW : Z : 1) =  K(X1);
             X1 = X1 + 1;
           ENDFOR;
          ENDIF;

        // NUMERIC FIELD
        // RIGHT  ADJUST NUMERIC DATA ,STRIP - . ,CONVERT BLANKS
          IF (T(Y) = 'S' OR T(Y) = 'P' OR T(Y) = 'B');
          NU = '0';

          Z1 = 60;
          FOR Z  =  K2  DOWNTO K1;

          IF K(Z) = '.' OR K(Z) = '-' OR K(Z) = '$';
          ITER;
          ENDIF;

          IF K(Z) = ' ' ;
           NU(Z1) = '0';
          ELSE;
           NU(Z1) = K(Z);
          ENDIF;

            Z1 = Z1 -1;
          ENDFOR;

          ENDIF;

       // SIGNED FIELDS  (END POSN = OFFSET + SIZE)
        IF T(Y)  = 'S';
           NUS = 0;
           FOR VX = 1 TO 60;
             NUSA = %TRIM(NUSA) + NU(VX);
           ENDFOR;
         %SUBST(KW : W : Q(Y)) = %SUBST(NUSA: 61 -Q(Y));

        ENDIF;

       //  PACKED FIELDS
          IF     T(Y)  =  'P';
           NUSA= *BLANKS;
           FOR VX = 1 TO 60;
             NUSA = %TRIM(NUSA) + NU(VX);
           ENDFOR;
           NUP    = %DEC(NUSA : 60 : 0);

         %SUBST(KW : W : Q(Y))   =   %SUBST(NUPA: 61 -Q(Y));

        ENDIF;

       //  BINARY FIELDS
        IF   T(Y) =  'B';

         IF  Q(Y) = 2 ;
           BY2  = NU(1) + NU(2);
           %SUBST(KW : W : 2)   =   BY2;
         ENDIF;

         IF  Q(Y) = 4 ;
           BY4  = NU(1) + NU(2) + NU(3) + NU(4);
           %SUBST(KW : W : 4)   =   BY4;
         ENDIF;

        ENDIF;

       ENDSR;


       //   @@@@@@@   SETIN  @@@@@@@@@@@@@@@@@@@@@@@@@
           BEGSR       @SETIN;

        //  SET the FFR indicators to get the Input buffer somewhat aligned with the
        //  actual data.  RPG is somewhat tolerant to a difference between the Ispecs
        //  and the actual file size but it can fail on big differences.
        //  INCREMENT OF 32 BYTES
           SZ(1)  = BASE + 16;
           SZ(2)  = SZ(1) + 16;

           *IN30 = *ON;
            IF (RLEN > SZ(2)) ;
             *IN31  = *ON;
            ENDIF;

           FOR X = 3 TO 64;
           SZ(X) = SZ(X-1) + 32;
            IF (RLEN > SZ(X)) ;
             *IN(29+X) = *ON;
            ENDIF;
           ENDFOR;
        ENDSR;


        //@@@@@@@@@@@@@@@@@  @GETF   @@@@@@@@@@@@@@@@@
           BEGSR  @GETF;
       //   GET A DATA RECORD
          IF  (*INU1);
           IF  AID  = '1' OR AID  = X36 OR
               AID  = X39 OR AID  = X3B ;
             SETLL(E) KEYA  INPUTK;
             READ(E)       INPUTK;
              IF %EOF;
               SETLL(E) KEYA  INPUTK;
               READP(E)       INPUTK;
              ENDIF;
           ENDIF;

           IF  AID  = '4';
            READP(E)  INPUTK;
           ENDIF;

           IF  AID  = '5';
            READ(E)   INPUTK;
           ENDIF;

            IF  %ERROR;
             SETLL(E) KEYA  INPUTK;
             READ(E)       INPUTK;
             MX = 7;
                         EXSR      @ERROR;
                         EXSR      @PUTF ;
                         EXSR      @KEYIN;
            ENDIF;

             KEYA = LKY;


             CLEAR KW;
             KW   = LKY;

          ENDIF;

          IF  (*INU2);
           IF  AID  = '1';
             CHAIN(E)  RRNA   INPUTR;
             IF  %ERROR;
              SETLL(E) RRNA  INPUTR;
              READP(E)       INPUTR;
             ENDIF;
           ENDIF;

           IF  AID  = X36;
             CHAIN(E)  RRNA   INPUTR;
           ENDIF;

           IF  AID  = '4';
             READP(E)   INPUTR;
           ENDIF;

           IF  AID  = '5' OR AID = X3B;
             READ(E)   INPUTR;
           ENDIF;

           IF  AID  = X39;
             SETLL(E) *HIVAL INPUTR;
             READP(E)   INPUTR;
           ENDIF;

           IF %ERROR;
             CHAIN  1  INPUTR;
             MX = 7;
             EXSR      @ERROR;
             EXSR      @PUTF ;
             EXSR      @KEYIN;
           ENDIF;
          ENDIF;

          ENDSR;


        //@@@@@@@@@@@@@@@@@  @PUTF   @@@@@@@@@@@@@@@@@
          BEGSR  @PUTF;

               SELECT;
                WHEN  *INU1;
                 RRN = RN1;
                WHEN  *INU2;
                 RRN = RN2;
               ENDSL;
        // IF GOT RECORDS WRITE DATA TO THE DISPLAY

            NEWRU  = '1';
            WRTRRN = '1';
            RU    = *ALLX'00';
            CLEAR  RU;        //  initialise Request Unit  255 bytes max

          IF RRN > 0    ;
            FOR  XX = 1 TO      NUMFKY; //NUMBER OF DATA ELEMENTS (FLD AND KEY)

             IF NEWRU = '1';
              NEWRU  = '0';
              RU   = ESC + WTD + X20 + X00;
             ENDIF;

             IF WRTRRN = '1';
              WRTRRN = '0';
              RU  = RU + SBA + RBA ;
              RU = RU + %TRIM(%EDITC(RRN:'Z'));
             ENDIF;

        // BUFFER ADDRESS
             RU  = RU + SBA + B(XX);

        //  PROCESS ALPHA DATA TYPE
             IF  T(XX) = 'A'  OR T(XX) = 'T'  OR T(XX) = 'Z' OR
                 T(XX) = 'L';

              STRX = S(XX);
              ENDX = E(XX);

              IF V(XX) = 'Y';  //VARYING
               VX   = S(XX);
               HX2   = D(VX) + D(VX+1);
               STRX  = S(XX) + 2 ;
               ENDX  = S(XX) + BIN;
              ENDIF;

               FOR Y = STRX  TO ENDX ;
                IF D(Y) >= ' ';
                 RU = RU + D(Y);
                ELSE;
                 RU = RU + X1F ;  //IF NOT DISPLAYABLE REPLACE WITH X'1F'
                ENDIF;
               ENDFOR;
             ENDIF;

        //  PROCESS SIGNED DATA TYPE (not the RRN field)
             IF  T(XX) = 'S' and KY(XX) <> '3';
               NUSA =  *ALL'0';
               WRV  =  *ALLX'00';
               CLEAR WRV;
               FOR Y = S(XX) TO E(XX);
                IF D(Y) >= XD0;
                 WRV    =  WRV + D(Y);
                ENDIF;
               ENDFOR;
               EVAL  NUSA = %SUBST(NUSA : 1 : 60 - %LEN(WRV)) + WRV;
               CLEAR WRU;
               WRU = %TRIM(WRU) + %EDITW(NUS :WRSWRD);
               IF  P(XX) > 0;
                RU  = RU  +
                     %SUBST(WRU :61-C(XX): C(XX)-P(XX)) + '.' +
                     %SUBST(WRU :61-P(XX))    ;
               ELSE;
                RU  = RU  +
                     %SUBST(WRU :61-C(XX));
               ENDIF;
             ENDIF;


        //  PROCESS SIGNED DATA TYPE (the RRN field)
             IF  T(XX) = 'S' and KY(XX) =  '3';
              RRN = RN2;
              RU = RU + %TRIM(%EDITC(RRN:'X'));
             ENDIF;

        //  PROCESS PACKED DATA TYPE
             IF  T(XX) = 'P';
               NUPA =  *ALLX'00';
               WRV  =  *ALLX'00';
               CLEAR WRV;
               FOR Y = S(XX) TO E(XX);
                 WRV    =  WRV + D(Y);
               ENDFOR;

               IF   %BITAND(D(E(XX)) :X0F) = X0F OR
                    %BITAND(D(E(XX)) :X0D) = X0D;

                EVAL  NUPA = %SUBST(NUPA : 1 : 60 - %LEN(WRV)) + WRV;
                CLEAR WRX;
                WRX = %TRIM(WRX) + %EDITW(NUP :WRXWRD);
                IF  P(XX) > 0;
                 RU  = RU  +
                      %SUBST(WRX :64-C(XX): C(XX)-P(XX)) + '.' +
                      %SUBST(WRX :64-P(XX))    ;
                ELSE;
                 RU  = RU  +
                      %SUBST(WRX :64-C(XX));
                ENDIF;
               ELSE;
                 // PACKED FIELD IN ERROR
                RU = RU + X1F;
               ENDIF;

             ENDIF;

        //  PROCESS BINARY DATA TYPE
             IF  T(XX) = 'B';

             ST = S(XX);
              CLEAR NUSA;
              IF  Q(XX) = 2;
               BY2  = D(ST) + D(ST+1);
               NUS  = BIN2;
              ENDIF;
              IF  Q(XX) = 4;
               BY4  = D(ST) + D(ST+1)+ D(ST+2) + D(ST+3);
               NUS  = BIN4;
              ENDIF;

              WRU =  %EDITW(NUS :WRSWRD);
               IF  P(XX) > 0;
                RU  = RU  +
                     %SUBST(WRU :61-C(XX): C(XX)-P(XX)) + '.' +
                     %SUBST(WRU :61-P(XX))    ;
               ELSE;
                RU  = RU  +
                     %SUBST(WRU :61-C(XX));
               ENDIF;
             ENDIF;


        //  PROCESS FLOAT  DATA TYPE
             IF  T(XX) = 'F';

             ST = S(XX);

              IF  Q(XX) = 4;
               FL4   = D(ST) + D(ST+1)+ D(ST+2) + D(ST+3);
               FLT14 =  %EDITFLT(FLT4);
                RU  = RU  + FLT14;
              ENDIF;

              IF  Q(XX) = 8;
               FL8  = D(ST) + D(ST+1)+ D(ST+2) + D(ST+3) +
                      D(ST+4) + D(ST+5)+ D(ST+6) + D(ST+7);
               FLT23 =  %EDITFLT(FLT8);
                RU  = RU  + FLT23;
              ENDIF;

             ENDIF;


           //   SEND A REQUEST UNIT IF GOT ENOUGH DATA

             IF  %LEN(RU) + L(XX + 1) >= 200;
              RU   =  RU + X20;
              BIN  =  %LEN(RU);
              OUTLEN  =  HX2;
              INLEN   =  X000;
              FNC     =  SND;
              A       = RU;
              EXCEPT  DATAO;
              NEWRU  = '1';
              RU    = *ALLX'00';
              CLEAR  RU;
             ENDIF;

            ENDFOR;
           ENDIF;

             IF  %LEN(RU) > 5 AND %LEN(RU) < 250;
              RU   =  RU + X20;
              BIN  =  %LEN(RU);
              OUTLEN  =  HX2;
              INLEN   =  X000;
              FNC     =  SND;
              A       = RU;
              EXCEPT  DATAO;
             ENDIF;
          ENDSR;


         // @@@@@@@@@@@@@@@    ROWINC  @@@@@@@@@@@@@@@

        // INCREMENT THE ROW
          BEGSR     @ROWINC;
           ROW = ROW + 2;
           IF  ROW > 20;
             MX = 3;
           ENDIF;
          ENDSR;



         // @@@@@@@@@@@@@@@    GETFLD  @@@@@@@@@@@@@@@

        // LOAD FIELD DESCRIPTION ARRAYS
          BEGSR     @GETFLD;
          MX = 0;
          X  = 0;

          IF  (*INU2 = *ON);
           // IF NON KEYED ACCESS SET UP A FIELD TO SHOW THE RRN
             N(1) =  'RRN';
             T(1) =  'S'  ;
             C(1) =  11   ;
             P(1) =  0    ;
             S(1) =  0    ;
             E(1) =  0    ;
             L(1) =  12   ;
             I(1) = X4F06 ;
             KY(1)= '3'   ;
             X    = 1     ;
          ENDIF;

          SCRST = *BLANK;
          SCRSTN = *BLANK;

          LVL  = %DEC(SCNLVL : 5:0);

         TEXT500 = SCNLV ;
         LV      = LVW;

         IF  LVL <> 0;
           SCRST = LV(LVL);
         ENDIF;

          SETLL 1 QWHDRFFD ;

          DOW  @LOOP  = @LOOP;
        //  REREAD  TAG
          READ    QWHDRFFD;
           IF %EOF;
            LEAVE;
           ENDIF;

        //  SELECT OR OMIT
           IF  ALL  <> '1';
           IF  ALL  =  'S' AND WHDFTL = 0; // USING WHDFTL FOR KEY FIELDS
             IF   WHFIOB  <>   'S';
              ITER;
             ENDIF;
           ENDIF;
           IF  ALL  =  'O' AND WHDFTL = 0; // USING WHDFTL FOR KEY FIELDS
             IF   WHFIOB   =   'O';
              ITER;
             ENDIF;
           ENDIF;
           ENDIF;

        //  FIND THE FIRST FIELD TO BE SHOWN (FOR MULTI PAGE FORMATS)
           IF  WHDFTL  <> 0 ;
             ELSE;
             IF SCRST <> ' ' AND SCRSTN = ' ';
               IF WHFLDE =  SCRST;
                 SCRSTN = '1';    //  FOUND THE START
               ELSE;
                 ITER;
               ENDIF;
             ENDIF;
           ENDIF;


          X =  X  + 1;
        // CHECK FOR KEY FIELDS,WILL BE USED TO PLACE THEM IN FRONT
          IF  WHDFTL  <>   0;
              KY(X) = '1';
              WX    = WHDFTL ;
              KE(WX) = WHFLDE;
              IF   NUMKEY <  WHDFTL;
                NUMKEY = WHDFTL;
              ENDIF;
          ENDIF;

             N(X) =  WHFLDE ;               //    NAME
             T(X) =  WHFLDT ;               //    TYPE
             V(X) =  WHVARL ;               //    VARYING
             C(X) =  WHFLDD ;               //    DEC DIGITS
             P(X) =  WHFLDP ;               //    DEC PREC
             S(X) =  WHFOBO ;               //    START
             Q(X) =  WHFLDB ;               //    BTYES
             E(X) =  WHFOBO + WHFLDB -1 ;   //   END

             IF T(X) =  'F' ;               //    FLOAT

               I(X) = FFA1 + FFA2;          //   SCRN FIELD FORMAT ALPHA
               L(X)   = 14;
              IF Q(X) = 8;
               L(X)   = 23;
              ENDIF;

             ELSE;
              IF  WHFLDD  <> 0 ;
               IF  WHFLDP  <> 0 ;
                 L(X) =  WHFLDD +  2  ;      //   LENGTH
               ELSE;
                 L(X) =  WHFLDD +  1  ;      //   LENGTH
               ENDIF;

                 I(X) = FFN1 + FFN2;         //   SCRN FIELD FORMAT NUMERIC

              ELSE;
                 L(X) =    WHFLDB  ;
                 I(X) = FFA1 + FFA2;         //   SCRN FIELD FORMAT ALPHA
              ENDIF;
             ENDIF;

        ENDDO;
        //  NUMBER OF FIELDS
         NUMFLD = X ;

       //  MAKE ROOM FOR KEYS
           IF   NUMKEY  >   0 ;
           X1  = NUMKEY  + NUMFLD;

           FOR  X =  NUMFLD DOWNTO 1;
              KY(X1) = KY(X) ;
              L(X1)  = L(X)  ;
              I(X1)  = I(X)  ;
              N(X1)  = N(X)  ;
              T(X1)  = T(X)  ;
              V(X1)  = V(X)  ;
              C(X1)  = C(X)  ;
              P(X1)  = P(X)  ;
              S(X1)  = S(X)  ;
              E(X1)  = E(X)  ;
              Q(X1)  = Q(X)  ;
              X1     = X1 - 1;
           ENDFOR;

          //  PUT KEY FIELDS AT TOP
          OFF  = 0;
          FOR  X =  1 TO NUMKEY;
          X1 = %LOOKUP(KE(X) : N : NUMKEY+1);

          KY(X) = '2';
          L(X)  = L(X1);
          I(X)  = I(X1);  // FIELD FMT
           SELECT;                // INPUT ENABLE
            WHEN  I(X) = X6000;
                  I(X) = X4800;
            WHEN  I(X) = X6706;
                  I(X) = X4F06;
           ENDSL;
            N(X) =  N(X1);
            T(X) =  T(X1);
            V(X) =  V(X1);
            C(X) =  C(X1);
            P(X) =  P(X1);
            S(X) =  S(X1);
            E(X) =  E(X1);
            Q(X) =  Q(X1);
            R(X) =  OFF;
            OFF  =  OFF + Q(X1);
          ENDFOR;

        ENDIF;
       //  NUMBER OF FIELDS AND KEYS
        NUMFKY = NUMFLD  +  NUMKEY;

        ENDSR;


         // @@@@@@@@@@@@@@@    GETADD  @@@@@@@@@@@@@@@

        // LOAD FIELD BUFFER ADDRESSES
          BEGSR     @GETADD;
          MX = 0;
          X  = 0;
          ROW = 3;
          COL = 1;

          FOR X = 1 TO NUMFKY;

        // IF FINISHED WITH THE KEY FIELDS
        //  INC  ROW FOR 1ST DATA FIELD
          IF KEYSOK = ' ' ;
           IF KY(X) = ' ' OR KY(X) = '1';
             KEYSOK = '1' ;
             ROW    = ROW + 2;
             COL    = 1;
           ENDIF;
          ENDIF;

        //  SET THE BUFFER ADD ON THE LARGER OF THE FIELD TEXT OR THE FIELD SIZE
           LENDSC  = %LEN(%TRIM(N(X)));
           LENWRK  =  L(X);
           IF LENDSC > L(X);
             LENWRK = LENDSC;
           ENDIF;
             LENWRK = LENWRK + 2;

        //   TRAP FIELDS THAT OVERFLOW
             ROW  = ROW  + XROW;
             XROW = %DIV(LENWRK : 80);

             IF (COL + LENWRK) > 78;
              EXSR @ROWINC;
                IF MX = 3;
                 X= X-1;
                 NUMFKY = X;
                 LEAVE;
                ENDIF;
              COL = 1;
             ENDIF;

        // INC COL. FOR FIELD START
           CLEAR  B(X);
           BIN  = ROW;
           B(X) =  %TRIM(B(X)) + HX1;
           BIN  = COL + 1;
           B(X) =  %TRIM(B(X)) + HX1;

        // INC COL. FOR NEXT FIELD
        COL = COL + LENWRK;
             IF COL > 78;
              EXSR @ROWINC;
                IF MX = 3;     // NO ROOM FOR THE FIELD
                 X= X-1;
                 NUMFKY = X;
                 LEAVE;
                ENDIF;
              COL = 1;
             ENDIF;

          ENDFOR;

         //  FIELD LEVEL
          LVX      = LVL + 1;
          LV(LVX)  = N(X);

        ENDSR;


         // @@@@@@@@@@@@@@@    PUTHED  @@@@@@@@@@@@@@@

        //  PUT FIELD HEADINGS
          BEGSR     @PUTHED;


            NEWRU  = '1';

            RU    = *ALLX'00';
            CLEAR  RU;                  //  initialise Request Unit  255 bytes max
            FOR  XX = 1 TO      NUMFKY; //NUMBER OF DATA ELEMENTS (FLD AND KEY)

             IF NEWRU = '1';
              NEWRU  = '0';
              RU  = ESC + WTD + X20 + X00;
             ENDIF;

             RU = RU + SBA;
             BIN = 0;
               // CONVERT DATA BUFADR TO HEADING BUFADR
             HX1 = %SUBST(B(XX) :1:1);
             BIN = BIN - 1;
             RU  = RU + HX1;

             IF  REHEAD = '1'; // ON REDISPLAY OVERRIDE THE ATTR
               BIN = 0;
               HX1 = %SUBST(B(XX) :2:1);
               BIN = BIN -1 ;
               RU  = RU + HX1;
             ELSE;
               RU  = RU + %SUBST(B(XX) :2);
             ENDIF;

             RU = RU + ATC ;

        //  LONG NUMBER FIELDS ,RIGHT ADJUST THE FIELD HEADINGS
             LENDSC  = %LEN(%TRIM(N(XX)));
            IF  T(XX) <> 'A' AND  LENDSC <  (L(XX) -1);
             FOR Y = 1 TO (L(XX) -(LENDSC +1));
              RU = RU + ' ';
             ENDFOR;
            ENDIF;

             RU = RU + %TRIM(N(XX));

              IF %LEN(RU) >= 200;
               BIN    = %LEN(RU);
               OUTLEN = HX2;
               INLEN  = X000;
               FNC    = SND;
               A      = RU;
               EXCEPT DATAO;
               NEWRU  = '1';
               RU    = *ALLX'00';
               CLEAR  RU;
              ENDIF;

            ENDFOR;

              IF %LEN(RU) >  5 AND %LEN(RU) <  200;
               BIN    = %LEN(RU);
               OUTLEN = HX2;
               INLEN  = X000;
               FNC    = SND;
               A      = RU;
               EXCEPT DATAO;
              ENDIF;

           IF REHEAD <> '1';
        //  FORMAT FIELDS


            NEWRU  = '1';
            RU    = *ALLX'00';
            CLEAR  RU;                  //  initialise Request Unit  255 bytes max
            FOR  XX = 1 TO      NUMFKY; //NUMBER OF DATA ELEMENTS (FLD AND KEY)

             IF NEWRU = '1';
              NEWRU  = '0';
              RU   = ESC + WTD + X20 + X00;
             ENDIF;

             RU = RU + SBA +B(XX)+SF + I(XX);

             IF KY(XX) = '1' OR KY(XX) = '2' OR KY(XX) = '3';
               RU = RU + X25;
             ELSE;
               RU = RU + X26;
             ENDIF;

             BIN =  L(XX);
             RU  = RU + HX2;

          // LENGTH OF INPUT FIELDS
             LENF  = LENF + L(XX) + 3;


              IF %LEN(RU) >= 200;
               BIN    = %LEN(RU);
               OUTLEN = HX2;
               INLEN  = X000;
               FNC    = SND;
               A      = RU;
               EXCEPT DATAO;
               NEWRU  = '1';
               RU    = *ALLX'00';
               CLEAR  RU;
              ENDIF;

           ENDFOR;

       //   PUT LAST R/U
              IF %LEN(RU) >  5 AND %LEN(RU) <  200;
               BIN    = %LEN(RU);
               OUTLEN = HX2;
               INLEN  = X000;
               FNC    = SND;
               A      = RU;
               EXCEPT DATAO;
              ENDIF;

        //INC BUFFER ADDRESS FOR ALL FIELDS FOR DATA PUT
            FOR  XP = 1 TO      NUMFKY; //NUMBER OF DATA ELEMENTS (FLD AND KEY)
             HX2   = B(XP);
             BIN   = BIN + 1;
             B(XP) = HX2;
            ENDFOR;
           ENDIF;

        ENDSR;

       //   @@@@@@@   INIT   @@@@@@@@@@@@@@@@@@@@@@@@@
          BEGSR         @INIT;

        CLEAR  KW;

        //  UPDATE
           IF  UPDF  = 'Y';
                FFA1 = X40;
                FFN1 = X47;
           ELSE;
                FFA1 = X60;
                FFN1 = X67;
           ENDIF;

           SELECT;
           WHEN  *INU1 = '1';
                 FILE  =  F1 ;
                 LIB   =  L1 ;
                 MBR   =  M1 ;
                 RCDL  =  R1 ;
                 ACCTP =  A1 ;
           WHEN  *INU2 = '1';
                 FILE  =  F2 ;
                 LIB   =  L2 ;
                 MBR   =  M2 ;
                 RCDL  =  R2 ;
                 ACCTP =  A2 ;
           ENDSL;
            RLEN    =   RCDL  ;
            RLENTH  =   %EDITC(RLEN: 'X') ;
            LENF    =   0     ;


        // Control commands and data are constructed into RUs Request UNITS
        // Each RU is 256 bytes max size.
        // Construct and send as many RUs as needed to format the display.
            RU    = *ALLX'00';
            CLEAR  RU;        //  initialise Request Unit  255 bytes max
            RU   = CLRWTD ;
          //set up the screen headings
            BIN = 1;    // set ROW to 1
            RW  = HX1;
            BIN = 2;    // set COL to 2
            CL  = HX1;
            RU  = RU + SBA + RW + CL + X22 + %TRIM(LIB) + '/' + %TRIM(FILE);
            RU  = RU + ' Mbr ' + %TRIM(MBR) + ' Rcdl ' + %EDITC(RLEN   : 'Z') ;
            RU  = RU + ' RRN '  ;
            BIN = %len(RU) -4;
            RBA = RW + HX1 ;   // address of the RRN field
            RU  = RU + SBA + RBA + '          ';

       // FUNCTION KEYS
            BIN  = 23;
            RW  = HX1;
            BIN  = 02;
            CL  = HX1;
            IF  UPDF = 'Y';   //  UPDATE IS ON
             RU  = RU + SBA + RW + CL + %TRIM(CNS(2));
            ELSE;
             RU  = RU + SBA + RW + CL + %TRIM(CNS(1));
            ENDIF;

        //  THIS IS A SEND ONLY FUNCTION
           FNC     = SND;
           CLEAR A;
           A       = RU;
           BIN2    = %LEN(RU);
           OUTLEN  = BY2;
           INLEN   = x000;

           EXCEPT    DATAO;

        ENDSR;


       //   @@@@@@@   KEYIN  @@@@@@@@@@@@@@@@@@@@@@@@@
         BEGSR   @KEYIN;
       // ISSUE A READ FROM DISPLAY
           FNC = SNR;
           BIN2   = 8;
           OUTLEN = BY2;
           IPL = LENF + 34;
           BIN2   = IPL;
           INLEN  = BY2;

          // SET FRR INDICATORS TO CONTROL BUFFER OVERFLOW
           FOR X =  1 TO  9;
             IF IPL  >  ( X*80 +3);
              *IN(X+19) = *ON;
             ENDIF;
           ENDFOR;

         RU    = *ALLX'00';
         CLEAR  RU;
         RU   = RDDSP;
         A    = RU;

         EXCEPT DATAI;
         ENDSR;

       //   @@@@@@@   ERROR  @@@@@@@@@@@@@@@@@@@@@@@@@
         BEGSR    @ERROR;

       // SETUP PUT ERROR MESSAGE X'21'
         RU    = *ALLX'00';
         CLEAR RU;

         FNC    =  SNR;
         BIN    = 42;
         OUTLEN = HX2;
         BIN    = LENF + 34;
         IPL    = BIN;
         INLEN  = HX2;

         FOR X         = 1 TO 9;
          IF IPL       > (X * 80 +3) ;
           *IN(X + 19) = *ON;          // SETON FFR 20 - 29 FOR INPUT
          ENDIF;
         ENDFOR;

         RU = ESC + WER + IC + B(1) + ATC + MSG(MX);
         RU = RU + ESC + RDM + X40+ X00;

         A  = RU;
         EXCEPT    DATAI;
         RU    = *ALLX'00';
         CLEAR RU;
         ENDSR;


       //   @@@@@@@    HXDSP @@@@@@@@@@@@@@@@@@@@@@@@@
         BEGSR   @HXDSP;

           RU    = *ALLX'00';
           CLEAR RU;
           Y = %LOOKUPLE( CURLOC : B );
          //
          RU = ESC + WTD + X20 + X00 + SBA;
          BIN = 0;
          HX1 = %SUBST(B(Y) :1:1);
          BIN = BIN - 1;
          RU  = RU + HX1;
          RU  = RU + %SUBST(B(Y) :2:1);

           FOR X = S(Y) TO E(Y);
             BIN = 0;
             HX1 = D(X);
             HX1 = %BITAND(HX1  : XF0);
             Z   = BIN / 16 + 1;
             RU  = RU + CRS(Z);
           ENDFOR;

             RU  = RU + X20;

             RU  = RU + SBA + B(Y);
           FOR X = S(Y) TO E(Y);
             BIN = 0;
             HX1 = D(X);
             HX1 = %BITAND(HX1  : X0F);
             Z   = BIN  + 1;
             RU  = RU + CRS(Z);
           ENDFOR;


          BIN    = %LEN(RU);
          OUTLEN = HX2;
          INLEN  = X000;
          FNC    = SND;
          A       = RU;
          EXCEPT DATAO;
          RU    = *ALLX'00';
          CLEAR  RU;


          EXSR      @KEYIN;
          READ      DISPF;


       //   CLEAR HEADINGS
            RU    = *ALLX'00';
            CLEAR RU;

         RU   = RU + ESC + WTD + X20 + X00 + SBA;
         HX1  = %SUBST(B(Y) :1:1) ;
         BIN  = BIN - 1;
         RU   = RU + HX1 + %SUBST(B(Y):2:1);
          FOR X = S(Y) TO E(Y);
           RU = RU + ' ';
          ENDFOR;
         RU = RU + ' ';

         BIN    = %LEN(RU);
         OUTLEN = HX2;
         INLEN  = X000;
         FNC    = SND;
         A      = RU;
         EXCEPT    DATAO;
         RU    = *ALLX'00';
         CLEAR  RU;

         ENDSR;



       //   @@@@@@@    UPD   @@@@@@@@@@@@@@@@@@@@@@@@@
          BEGSR  @UPD;

        // CONVERT  DATA  FOR OUTPUT

        //  FOR EACH  FIELD, CHECK IF FIELD WAS MODIFIED, AND IF SO MOVE
        // THE MODIFIED DATA INTO THE OUTPUT ARRAY
         K1 = 0;
         K2 = 0;
         W  = 1;
         CGKY = *BLANK;  // KEY CHANGED
         KW   = KEYA;

           FOR  Y  = 1  TO NUMFKY ;

            IF KY(Y) > '1';
             ITER;
            ENDIF;


       //  MOVE A KEY FIELDS DATA FROM ID ARRAY (SCREEN) TO K ARRAY

       //  GET SIZE OF FIELD IN BYTES
          IF T(Y)  =  'A';  // ALPHA DATA
           K = ' ';
           K1 = 1;
           K2 = Q(Y);
          ELSE;
           K  = '0';
           K1 =  1;
           K2 = C(Y);
          ENDIF;

          X  =  1;

           DOW  @LOOP = @LOOP;

       //  NXTSBA
           X  = %LOOKUP(SBA : ID : X );
           IF X = 0;
             LEAVE;
           ENDIF;

       // IS THIS THE FIELD?  CHECK THE BUFFER ADDRESS
         X = X +1;
         IF   B(Y)  <>  %SUBST(IDA : X :2);
          ITER;
         ENDIF;


       //  FOUND A MTD FOR THIS FIELD


         // CHECK IF FIELD WAS CLEARED ONLY
          DOW @LOOP = @LOOP; //  not a loop
         X =  X + 2;
         IF  ID(X) = SBA;
          LEAVE;
         ENDIF;

       //  IF FIELD HAS DECIMALS BUMP X
          IF (T(Y) = 'S' OR T(Y) = 'P' OR T(Y) = 'B') AND
              P(Y) > 0;
              X = X + 1;
          ENDIF;


       //   CHECK IF ONLY BLANKS RETURNED
          IF     %SUBST(IDA : X :K2) = *BLANKS;
              LEAVE;
          ENDIF;

        // MOVE DATA TO WORK ARRAY K
             X1 = X;
            FOR X2 = 1 TO K2;

             IF ID(X1) < ' ';
              LEAVE;
             ENDIF;

             K(X2) = ID(X1);
             X1 = X1 + 1;
            ENDFOR;

          LEAVE;
         ENDDO;

        // *  SET START POSN
          W =   S(Y);

         // ALPHA
          IF T(Y) =  'A'  and V(XX) <>  'Y';
           FOR Z  =  K1 to K2;
             D(W) =  K(Z);
             W    =  W + 1;
           ENDFOR;
          ENDIF;

        IF T(Y) =  'A' and  V(XX) = 'Y';  //VARYING

         //  the data start is in S(Y)
         //  the data is in array K
         //  get the length of the data cvt to bin and stik in pos 1 2
         //  put the rest in pos 3 onwards

              ENDIF;

        // NUMERIC FIELD
        // RIGHT  ADJUST NUMERIC DATA ,STRIP - . ,CONVERT BLANKS
          IF (T(Y) = 'S' OR T(Y) = 'P' OR T(Y) = 'B');
          NU = '0';

          Z1 = 60;
          FOR Z  =  K2  DOWNTO K1;

          IF K(Z) = '.' OR K(Z) = '-' OR K(Z) = '$';
          ITER;
          ENDIF;

          IF K(Z) = ' ' ;
           NU(Z1) = '0';
          ELSE;
           NU(Z1) = K(Z);
          ENDIF;

            Z1 = Z1 -1;
          ENDFOR;

          ENDIF;


       // SIGNED FIELDS  (END POSN = OFFSET + SIZE)
        IF T(Y)  = 'S';
           NUSA= *BLANKS;
           FOR VX = 1 TO 60;
             NUSA = %TRIM(NUSA) + NU(VX);
           ENDFOR;
         %SUBST(DATA  : W : Q(Y)) = %SUBST(NUSA: 61 -Q(Y));

        ENDIF;


       //  PACKED FIELDS
          IF     T(Y)  =  'P';
           NUSA= *BLANKS;
           FOR VX = 1 TO 60;
             NUSA = %TRIM(NUSA) + NU(VX);
           ENDFOR;
           NUP    = %DEC(NUSA : 60 : 0);

         %SUBST(DATA : W : Q(Y))   =   %SUBST(NUPA: 61 -Q(Y));
        ENDIF;

       //  BINARY FIELDS
        IF   T(Y) =  'B';

           NUSA= *BLANKS;
           FOR VX = 1 TO 60;
             NUSA = %TRIM(NUSA) + NU(VX);
           ENDFOR;
             NUC  = NUS;

         IF  Q(Y) = 2 ;
              DISBIN  ( NUC : BAN2 : BAN4  : '2');
            %SUBST(DATA : W : 2)   =   BAN2;
         ENDIF;

         IF  Q(Y) = 4 ;
              DISBIN  ( NUC : BAN2 : BAN4  : '4');
            %SUBST(DATA : W : 4)   =   BAN4;
         ENDIF;

        ENDIF;

         //  UPDATE KEY IF NECESSARY
         IF   KY(Y)  = '1';
            CGKY = '1';
            EXSR  @PCKMOV;
         ENDIF;


         ENDDO;
        ENDFOR;


          IF  CGKY = '1';
           KEYA = KW;
          ENDIF;

        ENDSR;



      /END-FREE

     OINPUTK    E    U1      UPDATREC
     O                       DA
     O               30      DB
     O               31      DC
     O               32      DD
     O               33      DE
     O               34      DF
     O               35      DG
     O               36      DH
     O               37      DI
     O               38      DJ
     O               39      DK
     O               40      DL
     O               41      DM
     O               42      DN
     O               43      DZ
     O               44      DO
     O               45      DP
     O               46      DQ
     O               47      DR
     O               48      DS
     O               49      DT
     O               50      DU
     O               51      DV
     O               52      DW
     O               53      DX
     O               54      DY
     O               55      D0
     O               56      D1
     O               57      D2
     O               58      D3
     O               59      D4
     O               60      D5
     O               61      D6
     O               62      DBA
     O               63      DCA
     O               64      DDA
     O               65      DEA
     O               66      DFA
     O               67      DGA
     O               68      DHA
     O               69      DIA
     O               70      DJA
     O               71      DKA
     O               72      DLA
     O               73      DMA
     O               74      DNA
     O               75      DOA
     O               76      DPA
     O               77      DQA
     O               78      DRA
     O               79      DSA
     O               80      DTA
     O               81      DUA
     O               82      DVA
     O               83      DWA
     O               84      DXA
     O               85      DYA
     O               86      DZA
     O               87      D0A
     O               88      D1A
     O               89      D2A
     O               90      D3A
     O               91      D4A
     O               92      D5A
     O               93      D6A
     OINPUTR    E       U2   UPDATREC
     O                       DA
     O               30      DB
     O               31      DC
     O               32      DD
     O               33      DE
     O               34      DF
     O               35      DG
     O               36      DH
     O               37      DI
     O               38      DJ
     O               39      DK
     O               40      DL
     O               41      DM
     O               42      DN
     O               43      DZ
     O               44      DO
     O               45      DP
     O               46      DQ
     O               47      DR
     O               48      DS
     O               49      DT
     O               50      DU
     O               51      DV
     O               52      DW
     O               53      DX
     O               54      DY
     O               55      D0
     O               56      D1
     O               57      D2
     O               58      D3
     O               59      D4
     O               60      D5
     O               61      D6
     O               62      DBA
     O               63      DCA
     O               64      DDA
     O               65      DEA
     O               66      DFA
     O               67      DGA
     O               68      DHA
     O               69      DIA
     O               70      DJA
     O               71      DKA
     O               72      DLA
     O               73      DMA
     O               74      DNA
     O               75      DOA
     O               76      DPA
     O               77      DQA
     O               78      DRA
     O               79      DSA
     O               80      DTA
     O               81      DUA
     O               82      DVA
     O               83      DWA
     O               84      DXA
     O               85      DYA
     O               86      DZA
     O               87      D0A
     O               88      D1A
     O               89      D2A
     O               90      D3A
     O               91      D4A
     O               92      D5A
     O               93      D6A

     OINPUTK    EADD U1      ADDREC
     O                       DA
     O               30      DB
     O               31      DC
     O               32      DD
     O               33      DE
     O               34      DF
     O               35      DG
     O               36      DH
     O               37      DI
     O               38      DJ
     O               39      DK
     O               40      DL
     O               41      DM
     O               42      DN
     O               43      DZ
     O               44      DO
     O               45      DP
     O               46      DQ
     O               47      DR
     O               48      DS
     O               49      DT
     O               50      DU
     O               51      DV
     O               52      DW
     O               53      DX
     O               54      DY
     O               55      D0
     O               56      D1
     O               57      D2
     O               58      D3
     O               59      D4
     O               60      D5
     O               61      D6
     O               62      DBA
     O               63      DCA
     O               64      DDA
     O               65      DEA
     O               66      DFA
     O               67      DGA
     O               68      DHA
     O               69      DIA
     O               70      DJA
     O               71      DKA
     O               72      DLA
     O               73      DMA
     O               74      DNA
     O               75      DOA
     O               76      DPA
     O               77      DQA
     O               78      DRA
     O               79      DSA
     O               80      DTA
     O               81      DUA
     O               82      DVA
     O               83      DWA
     O               84      DXA
     O               85      DYA
     O               86      DZA
     O               87      D0A
     O               88      D1A
     O               89      D2A
     O               90      D3A
     O               91      D4A
     O               92      D5A
     O               93      D6A
     OINPUTR    EADD    U2   ADDREC
     O                       DA
     O               30      DB
     O               31      DC
     O               32      DD
     O               33      DE
     O               34      DF
     O               35      DG
     O               36      DH
     O               37      DI
     O               38      DJ
     O               39      DK
     O               40      DL
     O               41      DM
     O               42      DN
     O               43      DZ
     O               44      DO
     O               45      DP
     O               46      DQ
     O               47      DR
     O               48      DS
     O               49      DT
     O               50      DU
     O               51      DV
     O               52      DW
     O               53      DX
     O               54      DY
     O               55      D0
     O               56      D1
     O               57      D2
     O               58      D3
     O               59      D4
     O               60      D5
     O               61      D6
     O               62      DBA
     O               63      DCA
     O               64      DDA
     O               65      DEA
     O               66      DFA
     O               67      DGA
     O               68      DHA
     O               69      DIA
     O               70      DJA
     O               71      DKA
     O               72      DLA
     O               73      DMA
     O               74      DNA
     O               75      DOA
     O               76      DPA
     O               77      DQA
     O               78      DRA
     O               79      DSA
     O               80      DTA
     O               81      DUA
     O               82      DVA
     O               83      DWA
     O               84      DXA
     O               85      DYA
     O               86      DZA
     O               87      D0A
     O               88      D1A
     O               89      D2A
     O               90      D3A
     O               91      D4A
     O               92      D5A
     O               93      D6A

     OINPUTK    EDEL U1      DELREC
     OINPUTR    EDEL U2      DELREC


     ODISPF     E            DATAO
     O                                           K3 'PUT'
     O                       OUTLEN               2
     O                       INLEN
     O                       FNC
     O                       A

     O          E            DATAI
     O                                           K3 'GET'
     O                       OUTLEN               2
     O                       INLEN
     O                       FNC
     O                       A
**
0000 INVALID COMMAND KEY
0001  - A FIELD IS TOO LONG
0002  - TOO MANY FIELDS
0003  - ALPHAS IN PACKED KEY
0004  - MISSING ' IN PACKED KEY
0005  - MISSING DATA IN PCKD KEY
0006  - RECORD NOT FOUND
PRESS RESET TO CONTINUE
**
F1-HEX F2-Return F3-Exit F19-Prev_fld F20-More_fld
F1-HEX F2-Return F3-Exit F6-Update F9-Add F11-Del F19-Prev_fld F20-More_fld
**
0123456789ABCDEF


#top

DUSP2 RPG

     H*eywords++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++Comments+++++++++++
     H OPTION(*NODEBUGIO)
     H DFTACTGRP(*NO) ACTGRP(*CALLER) DFTNAME(DUSP2 )
     F*
     F*  LIMITED TO MAXIMUM FILE LENGTH OF 6080
     F*  REQUIRES FILE  QTEMP/FFD  TO COMPILE
     F*  use cmd DSPFFD  FILE(&LIB/&FILE) OUTPUT(*OUTFILE) OUTFILE(QTEMP/FFD)

     FFFD       IF   E             DISK
     FDISPF     CF   F  803        WORKSTN
     F*
     F                                     INFDS(INFDS)
     FINPUTK    UF A F32766   800AIDISK    KEYLOC(1)
     F                                     EXTIND(*INU1)
     F                                     INFDS(INFDK)
     FINPUTR    UF A F32766        DISK    EXTIND(*INU2)
     F                                     INFDS(INFDR)

     D DISBIN          PR                  extpgm('DISBIN')
     D  NUM                          15P 0
     D  BAN2                          2
     D  BAN4                          4
     D  BINTYP                        1    CONST

      *
     D A               S            255                                         WORK RU
     D RU              S            255    varying
     D RW              S              1                                         ROW 1 byte binary
     D CL              S              1                                         COL 1 byte binary
     D FNC             S              1
     D OUTLEN          S              2
     D INLEN           S              2
     D IPL             S              5  0
     D ROW             S              3  0
     D XROW            S              3  0
     D COL             S              3  0
     D KEYSOK          S              1
     D LENDSC          S              3  0
     D LENWRK          S              5  0
     D STRX            S              5  0
     D ENDX            S              5  0
     D VX              S              5  0
     D X               S              5  0
     D X1              S              5  0
     D X2              S              5  0
     D XX              S              5  0
     D XP              S              5  0
     D MX              S              5  0
     D ONCE            S              1
     D RBA             S              2
     D LF              S              5  0
     D ST              S              5  0
     D Y               S              5  0
     D Z               S              5  0
     D OFF             S              5  0
     D CGKY            S              1
     D UPDDONE         S              1
     D SUPZ            S              1
     D NUMFLD          S              5  0
     D WX              S              5  0
     D NUMKEY          S              5  0
     D NUMFKY          S              5  0
     D SCRST           S             10
     D SCRSTN          S              1
     D KEYA            S            800
     D RRNA            S             11  0
     D RRN             S             11  0
     D REHEAD          S              1
     D NEWRU           S              1
     D WRTRRN          S              1
     D LVX             S              5  0
     D LVL             S              5  0
     D K1              S              5  0
     D K2              S              5  0
     D Z1              S              5  0
     D W               S              5  0
     D WK2             S              2
     D MSSG            S             32
      *
     D BASE            S              5  0
     D INZ             S              1

     D FILE            S             10
     D LIB             S             10
     D MBR             S             10
     D RCDL            S              5  0
     D ACCTP           S              1
     D RLEN            S              5  0
     D RLENTH          S              5
     D LENF            S              5  0


     D                 DS
     D TEXT500                      500
     D LVW                           10    DIM(50) overlay(TEXT500:1)

     D TEXT800         S            800
     D KW              S            800

     D                 DS
     D WRK11                   1     11
     D NUM11                   1     11S 0

     D                 DS
     D NUSA                    1     60
     D NUS                     1     60S 0
     D                 DS
     D NUPA                    1     60
     D NUP                    29     60P 0

     D NUC             S             15P 0
     D BAN2            S              2
DCL  D BAN4            S              4


     D WRU             S             61
     D WRX             S             64
     D WRXWRD          C                   '0                              -
     D                                                                     -'
     D WRSWRD          C                   '0                              -
     D                                                                  -'
     D WRV             S             60    varying

     D FLT14           S             14
     D FLT23           S             23

      * SET FILE SIZE INCREMENTS (64 OF THEM)
     D SZ              S              5  0 DIM(64)
     D S               S              5  0 DIM(9000)                            START OF FLD
     D E               S              5  0 DIM(9000)                            END OF FLD
     D Q               S              5  0 DIM(9000)                            BYTES IN FIELD
     D L               S              5  0 DIM(9000)                            LENGTH OF FLD
     D C               S              3  0 DIM(9000)                            DEC DIGITS
     D P               S              3  0 DIM(9000)                            DEC PRECISION
     D B               S              2    DIM(9000) ASCEND                     BUFFER ADD
     D I               S              2    DIM(9000)                            FLD FMT
     D N               S             10    DIM(9000)                            FLD NAME
     D T               S              1    DIM(9000)                            FLD TYPE
     D V               S              1    DIM(9000)                            VARYING
     D KY              S              1    DIM(9000)                            KEYED
     D KE              S             10    DIM(128)                             KEY FLDS
     D R               S              3  0 DIM(9000)                            KEY FLD START
     D K               S              1    DIM(800)                             KEY
     D NA              S              1    DIM(10)                              NAME WORK
     D NU              S              1    DIM(60)                              NUM. WORK
     D LV              S             10    DIM(50)                              SCREEN LEVELS
     D MSG             S             32    DIM(8) CTDATA PERRCD(1)              MESSAGES
     D CNS             S             79    DIM(2) CTDATA PERRCD(1)
     D CRS             S              1    DIM(16) CTDATA PERRCD(16)
     D                 DS
     D  DATA                   1   6080
     D  D                      1   6080
     D                                     DIM(6080)                            INCOMING DATA
     D  DA                     1   4048
     D                                     DIM(4048)
     D  DB                  4049   4064
     D  DC                  4065   4096
     D  DD                  4097   4128
     D  DE                  4129   4160
     D  DF                  4161   4192
     D  DG                  4193   4224
     D  DH                  4225   4256
     D  DI                  4257   4288
     D  DJ                  4289   4320
     D  DK                  4321   4352
     D  DL                  4353   4384
     D  DM                  4385   4416
     D  DN                  4417   4448
     D  DZ                  4449   4480
     D  DO                  4481   4512
     D  DP                  4513   4544
     D  DQ                  4545   4576
     D  DR                  4577   4608
     D  DS                  4609   4640
     D  DT                  4641   4672
     D  DU                  4673   4704
     D  DV                  4705   4736
     D  DW                  4737   4768
     D  DX                  4769   4800
     D  DY                  4801   4832
     D  D0                  4833   4864
     D  D1                  4865   4896
     D  D2                  4897   4928
     D  D3                  4929   4960
     D  D4                  4961   4992
     D  D5                  4993   5024
     D  D6                  5025   5056
     D  DBA                 5057   5088
     D  DCA                 5089   5120
     D  DDA                 5121   5152
     D  DEA                 5153   5184
     D  DFA                 5185   5216
     D  DGA                 5217   5248
     D  DHA                 5249   5280
     D  DIA                 5281   5312
     D  DJA                 5313   5344
     D  DKA                 5345   5376
     D  DLA                 5377   5408
     D  DMA                 5409   5440
     D  DNA                 5441   5472
     D  DOA                 5473   5504
     D  DPA                 5505   5536
     D  DQA                 5537   5568
     D  DRA                 5569   5600
     D  DSA                 5601   5632
     D  DTA                 5633   5664
     D  DUA                 5665   5696
     D  DVA                 5697   5728
     D  DWA                 5729   5760
     D  DXA                 5761   5792
     D  DYA                 5793   5824
     D  DZA                 5825   5856
     D  D0A                 5857   5888
     D  D1A                 5889   5920
     D  D2A                 5921   5952
     D  D3A                 5953   5984
     D  D4A                 5985   6016
     D  D5A                 6017   6048
     D  D6A                 6049   6080
     D                 DS
     D  ID                     1    800
     D                                     DIM(800)                             INCOMING DATA
     D  IDA                    1    800
     D  ID0                    1     80
     D  ID1                   81    160
     D  ID2                  161    240
     D  ID3                  241    320
     D  ID4                  321    400
     D  ID5                  401    480
     D  ID6                  481    560
     D  ID7                  561    640
     D  ID8                  641    720
     D  ID9                  721    800
     D                 DS
     D  BIN                    1      2B 0
     D  HX1                    2      2
     D  HX2                    1      2
     D                 DS
     D  PCK                    1      1P 0
     D  PCK1                   1      1
     D                 DS
     D  SGN                    1      1S 0
     D  SGN1                   1      1

     D                 DS
     D  BIN4                   1      4B 0
     D  BY4                    1      4

     D                 DS
     D  BIN2                   1      2B 0
     D  BY2                    1      2

     D                 DS
     D  FLT4                   1      4F
     D  FL4                    1      4

     D                 DS
     D  FLT8                   1      8F
     D  FL8                    1      8

     D INFDK           DS
     D  F1                    83     92
     D  L1                    93    102
     D  M1                   129    138
     D  R1                   125    126B 0
     D  A1                   160    160
     D  LOP1                 260    260
     D  KEY_LEN              393    394I 0                                      Key length
     D  RN1                  397    400B 0
     D  LKY                  401   1200
     D INFDR           DS
     D  F2                    83     92
     D  L2                    93    102
     D  M2                   129    138
     D  R2                   125    126B 0
     D  A2                   160    160
     D  LOP2                 260    260
     D  RN2                  397    400B 0
     D*
     D INFDS           DS
     D  CURLOC               370    371
     D                 DS
     D KEYLN                   1      4S 0
     D KEYLNA                  1      4

     DDUSP2            PR
     D                                1
     D                                1
     D                                4
     D                                1
     D                              500
     D                                5
     D                              800
     DDUSP2            PI
     D   ALL                          1
     D   RTN                          1
     D   KEYLNG                       4
     D   UPDF                         1
     D   SCNLV                      500
     D   SCNLVL                       5
     D   SCNKEY                     800


     D @LOOP           C                   '1'
     D @FALSE          C                   '0'
     D @TRUE           C                   '1'

     D SND             C                   X'71'                                SEND TO DISP
     D SNR             C                   X'73'                                SND/RCV
     D RED             C                   X'42'                                READ
     D RDM             C                   X'52'                                READ MTD
     D ESC             C                   X'04'                                ESCAPE
     D CLR             C                   X'40'                                CLEAR UNIT
     D CC1             C                   X'00'                                CNTRL CHAR
     D CC2             C                   X'08'                                CNTRL CHAR
     D SBA             C                   X'11'                                SET BUFF ADR
     D IC              C                   X'13'                                INSERT CURS
     D WTD             C                   X'11'                                WRITE TO DSP
     D WER             C                   X'21'                                WRITE ERROR
     D SF              C                   X'1D'                                START FLD
     D ATC             C                   X'20'                                ATTR CHAR
     D ATN             C                   X'24'                                ATTR NUM
     D X00             C                   X'00'
     D X01             C                   X'01'
     D X02             C                   X'02'
     D X03             C                   X'03'
     D X0D             C                   X'0D'
     D X0F             C                   X'0F'
     D X000            C                   X'0000'
     D X1F             C                   X'1F'
     D X20             C                   X'20'                                SCRN ATT NORMAL
     D X22             C                   X'22'                                SCRN ATTR HI
     D X25             C                   X'25'
     D X26             C                   X'26'
     D X31             C                   X'31'                                CMD 1 KEY
     D X32             C                   X'32'                                CMD 2 KEY
     D X33             C                   X'33'                                CMD 3 KEY
     D X36             C                   X'36'                                CMD 6 KEY
     D X37             C                   X'37'                                CMD 7 KEY
     D X38             C                   X'38'                                CMD 8 KEY
     D X39             C                   X'39'                                CMD 9 KEY
     D X3B             C                   X'3B'                                CMD11 KEY
     D XB7             C                   X'B7'                                CMD19 KEY
     D XB8             C                   X'B8'                                CMD20 KEY
     D X40             C                   X'40'
     D X43             C                   X'43'
     D X47             C                   X'47'
     D X60             C                   X'60'
     D X67             C                   X'67'
     D X9F             C                   X'9F'
     D XF0             C                   X'F0'
     D XD0             C                   X'D0'
     D X4000           C                   X'4000'
     D X4800           C                   X'4800'                              FF ALPHA
     D X4F06           C                   X'4F06'                              FF NUMERIC
     D X6000           C                   X'6000'                              FF ALPHA
     D X6706           C                   X'6706'                              FF NUMERIC
     D CLRWTD          C                   X'044004112000'                      INCLUDES ESC CHARS
     D RDDSP           C                   X'0411200804524000'                  READ FROM DISPLAY
     D FFA1            S              1    INZ(X'40')                           F.FMT 1 ALPH  60 BYP
     D FFA2            S              1    INZ(X'00')                           F.FMT 2 ALPH
     D FFN1            S              1    INZ(X'47')                           F.FMT 1 NUM   67 BYP
     D FFN2            S              1    INZ(X'06')                           F.FMT 2 NUM
     I*.

0038 IINPUTK    NS  01
0039 I                                  1 4048  DA
0040 I                               4049 4064  DB                30
0041 I                               4065 4096  DC                31
0042 I                               4097 4128  DD                32
0043 I                               4129 4160  DE                33
0044 I                               4161 4192  DF                34
0045 I                               4193 4224  DG                35
0046 I                               4225 4256  DH                36
0047 I                               4257 4288  DI                37
0048 I                               4289 4320  DJ                38
0049 I                               4321 4352  DK                39
0050 I                               4353 4384  DL                40
0051 I                               4385 4416  DM                41
0052 I                               4417 4448  DN                42
0053 I                               4449 4480  DZ                43
0054 I                               4481 4512  DO                44
0055 I                               4513 4544  DP                45
0056 I                               4545 4576  DQ                46
0057 I                               4577 4608  DR                47
0058 I                               4609 4640  DS                48
0059 I                               4641 4672  DT                49
0060 I                               4673 4704  DU                50
0061 I                               4705 4736  DV                51
0062 I                               4737 4768  DW                52
0063 I                               4769 4800  DX                53
0064 I                               4801 4832  DY                54
0065 I                               4833 4864  D0                55
0066 I                               4865 4896  D1                56
0067 I                               4897 4928  D2                57
0068 I                               4929 4960  D3                58
0069 I                               4961 4992  D4                59
0070 I                               4993 5024  D5                60
0071 I                               5025 5056  D6                61
0072 I                               5057 5088  DBA               62
0073 I                               5089 5120  DCA               63
0074 I                               5121 5152  DDA               64
0075 I                               5153 5184  DEA               65
0076 I                               5185 5216  DFA               66
0077 I                               5217 5248  DGA               67
0078 I                               5249 5280  DHA               68
0079 I                               5281 5312  DIA               69
0080 I                               5313 5344  DJA               70
0081 I                               5345 5376  DKA               71
0082 I                               5377 5408  DLA               72
0083 I                               5409 5440  DMA               73
0084 I                               5441 5472  DNA               74
0085 I                               5473 5504  DOA               75
0086 I                               5505 5536  DPA               76
0087 I                               5537 5568  DQA               77
0088 I                               5569 5600  DRA               78
0089 I                               5601 5632  DSA               79
0090 I                               5633 5664  DTA               80
0091 I                               5665 5696  DUA               81
0092 I                               5697 5728  DVA               82
0093 I                               5729 5760  DWA               83
0094 I                               5761 5792  DXA               84
0095 I                               5793 5824  DYA               85
0096 I                               5825 5856  DZA               86
0097 I                               5857 5888  D0A               87
0098 I                               5889 5920  D1A               88
0099 I                               5921 5952  D2A               89
0100 I                               5953 5984  D3A               90
0101 I                               5985 6016  D4A               91
0102 I                               6017 6048  D5A               92
0103 I                               6049 6080  D6A               93
0104 IINPUTR    NS  01
0105 I                                  1 4048  DA
0106 I                               4049 4064  DB                30
0107 I                               4065 4096  DC                31
0108 I                               4097 4128  DD                32
0109 I                               4129 4160  DE                33
0110 I                               4161 4192  DF                34
0111 I                               4193 4224  DG                35
0112 I                               4225 4256  DH                36
0113 I                               4257 4288  DI                37
0114 I                               4289 4320  DJ                38
0115 I                               4321 4352  DK                39
0116 I                               4353 4384  DL                40
0117 I                               4385 4416  DM                41
0118 I                               4417 4448  DN                42
0119 I                               4449 4480  DZ                43
0120 I                               4481 4512  DO                44
0121 I                               4513 4544  DP                45
0122 I                               4545 4576  DQ                46
0123 I                               4577 4608  DR                47
0124 I                               4609 4640  DS                48
0125 I                               4641 4672  DT                49
0126 I                               4673 4704  DU                50
0127 I                               4705 4736  DV                51
0128 I                               4737 4768  DW                52
0129 I                               4769 4800  DX                53
0130 I                               4801 4832  DY                54
0131 I                               4833 4864  D0                55
0132 I                               4865 4896  D1                56
0133 I                               4897 4928  D2                57
0134 I                               4929 4960  D3                58
0135 I                               4961 4992  D4                59
0136 I                               4993 5024  D5                60
0137 I                               5025 5056  D6                61
0138 I                               5057 5088  DBA               62
0139 I                               5089 5120  DCA               63
0140 I                               5121 5152  DDA               64
0141 I                               5153 5184  DEA               65
0142 I                               5185 5216  DFA               66
0143 I                               5217 5248  DGA               67
0144 I                               5249 5280  DHA               68
0145 I                               5281 5312  DIA               69
0146 I                               5313 5344  DJA               70
0147 I                               5345 5376  DKA               71
0148 I                               5377 5408  DLA               72
0149 I                               5409 5440  DMA               73
0150 I                               5441 5472  DNA               74
0151 I                               5473 5504  DOA               75
0152 I                               5505 5536  DPA               76
0153 I                               5537 5568  DQA               77
0154 I                               5569 5600  DRA               78
0155 I                               5601 5632  DSA               79
0156 I                               5633 5664  DTA               80
0157 I                               5665 5696  DUA               81
0158 I                               5697 5728  DVA               82
0159 I                               5729 5760  DWA               83
0160 I                               5761 5792  DXA               84
0161 I                               5793 5824  DYA               85
0162 I                               5825 5856  DZA               86
0163 I                               5857 5888  D0A               87
0164 I                               5889 5920  D1A               88
0165 I                               5921 5952  D2A               89
0166 I                               5953 5984  D3A               90
0167 I                               5985 6016  D4A               91
0168 I                               6017 6048  D5A               92
0169 I                               6049 6080  D6A               93
     IDISPF     NS  02
     I                                  3    3  AID
     I                                  4   83  ID0
     I                                 84  163  ID1               20
     I                                164  243  ID2               21
     I                                244  323  ID3               22
     I                                324  403  ID4               23
     I                                404  483  ID5               24
     I                                484  563  ID6               25
     I                                564  643  ID7               26
     I                                644  723  ID8               27
     I                                724  803  ID9               28


      /FREE
             BASE = 4048;

             IF  ONCE  =  ' ';
                EXSR      @INITZ  ;
             ENDIF;

         //   START        TAG
           DOW       @LOOP = @LOOP;

           IF  RTN  = '3';

              IF *INU1;
                KEYA =  SCNKEY;
              ENDIF;
              IF *INU2;
                RRNA =  %DEC(%SUBST(SCNKEY:1:11):11:0);
              ENDIF;
                RTN = '0';
                AID = '1';
            ELSE;
              RTN  = '0';
              READ(E)   DISPF;
           ENDIF;

        //  CF3 EXIT
           IF  AID  = X33;
            LEAVE;
           ENDIF;

        //  CF2 RETURN
           IF  AID  = X32;
            RTN = '1';
            LEAVE;
           ENDIF;

        // CF1 HEX A FIELD
           IF  AID  = X31;
           Y = %LOOKUPLE( CURLOC : B );
           IF Y > 0;
            IF KY(Y) <= '1';
              EXSR      @HXDSP;
              REHEAD  = '1';
              EXSR      @PUTHED;
              REHEAD  = ' ';
             ENDIF;
            ENDIF;
           ENDIF;

        //  CF20 MORE FIELDS
           IF  AID  = XB8;

            LVX   = LVL + 1;
            IF   LV(LVX)  <> *BLANK;
              LVL = LVL +1 ;

              LVW  = LV;
              SCNLV = TEXT500;
              SCNLVL = %EDITC(LVL :'X');

            SCNKEY = *BLANKS;
           IF  *INU1;
                SCNKEY = KEYA;
           ENDIF;
           IF  *INU2;
                SCNKEY = %EDITC(RRNA:'X');
           ENDIF;

               RTN = '3';
               LEAVE;
             ENDIF;
           ENDIF;

       //  CF19 PREVIOUS FIELDS
           IF  AID  = XB7;

            LVX   = LVL - 1;
            IF   LVX     >= 0 ;
              LVL = LVL - 1 ;

              LVW  = LV;
              SCNLV = TEXT500;
              SCNLVL = %EDITC(LVL :'X');

                SCNKEY = *BLANKS;
           IF  *INU1;
                SCNKEY = KEYA;
           ENDIF;
           IF  *INU2;
                SCNKEY = %EDITC(RRNA:'X');
           ENDIF;

               RTN = '3';
               LEAVE;
             ENDIF;
           ENDIF;

          // 1 ENTER  4 ROLL DN  5 ROLL UP
          // F6 = X36  F9 = X39  F11 = X3B
           IF  AID  = '1'or AID = '4' or AID = '5' or
               AID  = X36 or AID = X39 or AID = X3B;
           ELSE;
            MX = 1;         // INVALID KEY
            EXSR  @ERROR;
           ENDIF;

          //       UPDATE MODE
           IF  UPDF    = 'Y';
             UPDDONE = @FALSE;
           // F6
             IF *INU1 AND AID = X36 AND
             (LOP1 = X01 OR LOP1 = X03);
               EXSR @UPD;
               EXCEPT UPDATREC;
               UPDDONE = @TRUE;
             ENDIF;

             IF *INU2 AND AID = X36 AND
             (LOP2 = X01 OR LOP2 = X02);
               EXSR @UPD;
               EXCEPT UPDATREC;
               UPDDONE = @TRUE;
             ENDIF;

           // F9
             IF AID = X39;
               EXSR   @UPD;
               EXCEPT ADDREC;
               UPDDONE = @TRUE;
             ENDIF;

           // F11
             IF *INU1 AND AID = X3B AND
             (LOP1 = X01 OR LOP1 = X03);
               EXCEPT DELREC;
               UPDDONE = @TRUE;
              ENDIF;

             IF *INU2 AND AID = X3B AND
             (LOP2 = X01 OR LOP2 = X02);
               EXCEPT DELREC;
               UPDDONE = @TRUE;
              ENDIF;

             ENDIF;


          IF  RTN = '3' OR UPDDONE = @TRUE;
          ELSE;
            EXSR      @PCKD;
          ENDIF;


        // CONT1  GET A RECORD, KEY FROM DATA
            EXSR      @SETIN;
            EXSR      @GETF ;
            EXSR      @PUTF ;
            EXSR      @KEYIN;

          ENDDO ;

           *INLR = *ON;

       //   @@@@@@@  @INITZ @@@@@@@@@@@@@@@@@@@@@@@@@@
         BEGSR  @INITZ;
                ONCE   =  '1';
                KEYLNA = KEYLNG  ;
                EXSR      @INIT   ;
                EXSR      @GETFLD ;
                EXSR      @GETADD ;
                EXSR      @PUTHED ;
                EXSR      @KEYIN  ;
                INZ   = '1';
                EXSR      @PCKD   ;
                INZ   = ' ';
         ENDSR;

       //   @@@@@@@  @PCKD  @@@@@@@@@@@@@@@@@@@@@@@@@@

          BEGSR   @PCKD ;

            //  CONVERT  KEY DATA
            IF  *INU1 ;
               EXSR  @CVTKEY;
            ENDIF;
            IF  *INU2 ;
               EXSR  @CVTRRN;
            ENDIF;

          ENDSR;

       //   @@@@@@@  @CVTKEY  @@@@@@@@@@@@@@@@@@@@@@@@

          BEGSR   @CVTKEY;

       // EXTRACT THE KEY FIELD DATA FROM THE INCOMING STRING

         // FOR EACH KEY FIELD, CHECK IF FIELD WAS MODIFIED, AND IF SO MOVE
         // THE MODIFIED DATA INTO THE COMPOSITE KEY

         K1 = 0;
         K2 = 0;
         W  = 1;

           FOR  Y  = 1  TO NUMKEY ;

       //  MOVE A KEY FIELDS DATA FROM ID ARRAY (SCREEN) TO K ARRAY (KEY FIELDS)

       //  GET SIZE OF FIELD IN BYTES
          IF T(Y)  =  'A';  // ALPHA DATA
           K = ' ';
           K1 = 1;
           K2 = Q(Y);
          ELSE;
           K  = '0';
           K1 =  1;
           K2 = C(Y);
          ENDIF;

       // IF WHOLE KEY INIT WAS REQUESTED BYPASS THE EXTRACT
           IF  INZ  = '1' ;
             KW  = *BLANK;
             EXSR      @PCKMOV;
             ITER;
           ENDIF;

          X  =  1;

          DOW  @LOOP = @LOOP;

       //  NXTSBA
          X  = %LOOKUP(SBA : ID : X );
           IF X = 0;
             LEAVE;
           ENDIF;

       // IS THIS THE FIELD?  CHECK THE BUFFER ADDRESS
         X = X +1;
         IF   B(Y)  <>  %SUBST(IDA : X :2);
          ITER;
         ENDIF;

       //  FOUND A MTD FOR THIS FIELD
         X =  X + 2;

       //  CHECK IF FIELD WAS CLEARED ONLY
         IF  ID(X) = SBA;
             EXSR      @PCKMOV;
             LEAVE ;
         ENDIF;

       //  IF FIELD HAS DECIMALS BUMP X
          IF (T(Y) = 'S' OR T(Y) = 'P' OR T(Y) = 'B') AND
              P(Y) > 0;
              X = X + 1;
          ENDIF;

       //   CHECK IF ONLY BLANKS RETURNED
         IF     %SUBST(IDA : X :K2) = *BLANKS;
             EXSR      @PCKMOV;
             LEAVE;
         ENDIF;

       // EXTRACT THE DATA FROM THE INCOMING STRING
         X1  = X;
         FOR X2  =  1 TO  K2 ;

           IF ID(X1) < ' ';
       // TRAP NULLS CAUSED BY FLD EXIT
             EXSR      @PCKMOV;
             LEAVE;
           ENDIF;

         K(X2)  =  ID(X1);
         X1     =  X1 +1;
         ENDFOR;

        // CONSTRUCT THE ACTUAL KEY WITH PACKED DATA IF REQUIRED
        // INTO ARRAY KW
          EXSR      @PCKMOV;
          LEAVE;
         ENDDO;

         ENDFOR;

         //
          KEYA  = KW;
          CLEAR KW;
        ENDSR ;

       //   @@@@@@@  @CVTRRN  @@@@@@@@@@@@@@@@@@@@@@@@

          BEGSR   @CVTRRN;

        //   RRN

           NUM11 = 0;

          DOW  @LOOP = @LOOP;  //  NOT REALLY A LOOP(SIMULATES GOTO)

       // GET THE FIRST SBA
          X = 1;
          X  = %LOOKUP(SBA : ID : X );
           IF X = 0;
           LEAVE;
           ENDIF;

       // CHECK THE BUFFER ADDRESS MATCHES THE EXPECTED FIELD
         X = X +1;
         IF   B(1)  <>  %SUBST(IDA : X :2);
          ITER;
         ENDIF;

       //  FOUND A MTD FOR RRN  FIELD
         X = X +2;

       //CHECK IF FIELD WAS CLEARED ONLY
         IF  ID(X) = SBA;
             LEAVE;
         ENDIF;

       //   CHECK IF ONLY BLANKS RETURNED
         IF     %SUBST(IDA : X :11) = *BLANKS;
             LEAVE;
         ENDIF;


         //  WRK11  OVERLAYS NUM11
         WRK11 = %SUBST(IDA : X :11);

         LEAVE;
         ENDDO;


         RRNA = NUM11;
         IF RRNA < 0;
         RRNA =  1;
         ENDIF;

         ENDSR;

       //   @@@@@@@  @PCKMOV  @@@@@@@@@@@@@@@@@@@@@@@@

         BEGSR  @PCKMOV;
       //
       //   CONVERT  KEY DATA
       //   SET START POSN IN KEY USING OFFSET IN R
          X1 = %LOOKUP(N(Y) : N );
          W = R(X1) + 1;

        // ALPHA
          IF  T(Y) = 'A';
           X1  = 1;
           FOR  Z = W   TO W + Q(Y);
             %SUBST(KW : Z : 1) =  K(X1);
             X1 = X1 + 1;
           ENDFOR;
          ENDIF;

        // NUMERIC FIELD
        // RIGHT  ADJUST NUMERIC DATA ,STRIP - . ,CONVERT BLANKS
          IF (T(Y) = 'S' OR T(Y) = 'P' OR T(Y) = 'B');
          NU = '0';

          Z1 = 60;
          FOR Z  =  K2  DOWNTO K1;

          IF K(Z) = '.' OR K(Z) = '-' OR K(Z) = '$';
          ITER;
          ENDIF;

          IF K(Z) = ' ' ;
           NU(Z1) = '0';
          ELSE;
           NU(Z1) = K(Z);
          ENDIF;

            Z1 = Z1 -1;
          ENDFOR;

          ENDIF;

       // SIGNED FIELDS  (END POSN = OFFSET + SIZE)
        IF T(Y)  = 'S';
           NUS = 0;
           FOR VX = 1 TO 60;
             NUSA = %TRIM(NUSA) + NU(VX);
           ENDFOR;
         %SUBST(KW : W : Q(Y)) = %SUBST(NUSA: 61 -Q(Y));

        ENDIF;

       //  PACKED FIELDS
          IF     T(Y)  =  'P';
           NUSA= *BLANKS;
           FOR VX = 1 TO 60;
             NUSA = %TRIM(NUSA) + NU(VX);
           ENDFOR;
           NUP    = %DEC(NUSA : 60 : 0);

         %SUBST(KW : W : Q(Y))   =   %SUBST(NUPA: 61 -Q(Y));

        ENDIF;

       //  BINARY FIELDS
        IF   T(Y) =  'B';

         IF  Q(Y) = 2 ;
           BY2  = NU(1) + NU(2);
           %SUBST(KW : W : 2)   =   BY2;
         ENDIF;

         IF  Q(Y) = 4 ;
           BY4  = NU(1) + NU(2) + NU(3) + NU(4);
           %SUBST(KW : W : 4)   =   BY4;
         ENDIF;

        ENDIF;

       ENDSR;


       //   @@@@@@@   SETIN  @@@@@@@@@@@@@@@@@@@@@@@@@
           BEGSR       @SETIN;

        //  SET the FFR indicators to get the Input buffer somewhat aligned with the
        //  actual data.  RPG is somewhat tolerant to a difference between the Ispecs
        //  and the actual file size but it can fail on big differences.
        //  INCREMENT OF 32 BYTES
           SZ(1)  = BASE + 16;
           SZ(2)  = SZ(1) + 16;

           *IN30 = *ON;
            IF (RLEN > SZ(2)) ;
             *IN31  = *ON;
            ENDIF;

           FOR X = 3 TO 64;
           SZ(X) = SZ(X-1) + 32;
            IF (RLEN > SZ(X)) ;
             *IN(29+X) = *ON;
            ENDIF;
           ENDFOR;
        ENDSR;


        //@@@@@@@@@@@@@@@@@  @GETF   @@@@@@@@@@@@@@@@@
           BEGSR  @GETF;
       //   GET A DATA RECORD
          IF  (*INU1);
           IF  AID  = '1' OR AID  = X36 OR
               AID  = X39 OR AID  = X3B ;
             SETLL(E) KEYA  INPUTK;
             READ(E)       INPUTK;
              IF %EOF;
               SETLL(E) KEYA  INPUTK;
               READP(E)       INPUTK;
              ENDIF;
           ENDIF;

           IF  AID  = '4';
            READP(E)  INPUTK;
           ENDIF;

           IF  AID  = '5';
            READ(E)   INPUTK;
           ENDIF;

            IF  %ERROR;
             SETLL(E) KEYA  INPUTK;
             READ(E)       INPUTK;
             MX = 7;
                         EXSR      @ERROR;
                         EXSR      @PUTF ;
                         EXSR      @KEYIN;
            ENDIF;

             KEYA = LKY;


             CLEAR KW;
             KW   = LKY;

          ENDIF;

          IF  (*INU2);
           IF  AID  = '1';
             CHAIN(E)  RRNA   INPUTR;
             IF  %ERROR;
              SETLL(E) RRNA  INPUTR;
              READP(E)       INPUTR;
             ENDIF;
           ENDIF;

           IF  AID  = X36;
             CHAIN(E)  RRNA   INPUTR;
           ENDIF;

           IF  AID  = '4';
             READP(E)   INPUTR;
           ENDIF;

           IF  AID  = '5' OR AID = X3B;
             READ(E)   INPUTR;
           ENDIF;

           IF  AID  = X39;
             SETLL(E) *HIVAL INPUTR;
             READP(E)   INPUTR;
           ENDIF;

           IF %ERROR;
             CHAIN  1  INPUTR;
             MX = 7;
             EXSR      @ERROR;
             EXSR      @PUTF ;
             EXSR      @KEYIN;
           ENDIF;
          ENDIF;

          ENDSR;


        //@@@@@@@@@@@@@@@@@  @PUTF   @@@@@@@@@@@@@@@@@
          BEGSR  @PUTF;

               SELECT;
                WHEN  *INU1;
                 RRN = RN1;
                WHEN  *INU2;
                 RRN = RN2;
               ENDSL;
        // IF GOT RECORDS WRITE DATA TO THE DISPLAY

             NEWRU  = '1';
             WRTRRN = '1';
            RU    = *ALLX'00';
            CLEAR  RU;        //  initialise Request Unit  255 bytes max

          IF RRN > 0    ;
            FOR  XX = 1 TO      NUMFKY; //NUMBER OF DATA ELEMENTS (FLD AND KEY)

             IF NEWRU = '1';
              NEWRU  = '0';
              RU   = ESC + WTD + X20 + X00;
             ENDIF;

             IF WRTRRN = '1';
              WRTRRN = '0';
              RU  = RU + SBA + RBA ;
              RU = RU + %TRIM(%EDITC(RRN:'Z'));
             ENDIF;

        // BUFFER ADDRESS
             RU  = RU + SBA + B(XX);

        //  PROCESS ALPHA DATA TYPE
             IF  T(XX) = 'A'  OR T(XX) = 'T'  OR T(XX) = 'Z' OR
                 T(XX) = 'L';

              STRX = S(XX);
              ENDX = E(XX);

              IF V(XX) = 'Y';  //VARYING
               VX   = S(XX);
               HX2   = D(VX) + D(VX+1);
               STRX  = S(XX) + 2 ;
               ENDX  = S(XX) + BIN;
              ENDIF;

               FOR Y = STRX  TO ENDX ;
                IF D(Y) >= ' ';
                 RU = RU + D(Y);
                ELSE;
                 RU = RU + X1F ;  //IF NOT DISPLAYABLE REPLACE WITH X'1F'
                ENDIF;
               ENDFOR;
             ENDIF;

        //  PROCESS SIGNED DATA TYPE (not the RRN field)
             IF  T(XX) = 'S' and KY(XX) <> '3';
               NUSA =  *ALL'0';
               WRV  =  *ALLX'00';
               CLEAR WRV;
               FOR Y = S(XX) TO E(XX);
                IF D(Y) >= XD0;
                 WRV    =  WRV + D(Y);
                ENDIF;
               ENDFOR;
               EVAL  NUSA = %SUBST(NUSA : 1 : 60 - %LEN(WRV)) + WRV;
               CLEAR WRU;
               WRU = %TRIM(WRU) + %EDITW(NUS :WRSWRD);
               IF  P(XX) > 0;
                RU  = RU  +
                     %SUBST(WRU :61-C(XX): C(XX)-P(XX)) + '.' +
                     %SUBST(WRU :61-P(XX))    ;
               ELSE;
                RU  = RU  +
                     %SUBST(WRU :61-C(XX));
               ENDIF;
             ENDIF;


        //  PROCESS SIGNED DATA TYPE (the RRN field)
             IF  T(XX) = 'S' and KY(XX) =  '3';
              RRN = RN2;
              RU = RU + %TRIM(%EDITC(RRN:'X'));
             ENDIF;

        //  PROCESS PACKED DATA TYPE
             IF  T(XX) = 'P';
               NUPA =  *ALLX'00';
               WRV  =  *ALLX'00';
               CLEAR WRV;
               FOR Y = S(XX) TO E(XX);
                 WRV    =  WRV + D(Y);
               ENDFOR;

               IF   %BITAND(D(E(XX)) :X0F) = X0F OR
                    %BITAND(D(E(XX)) :X0D) = X0D;

                EVAL  NUPA = %SUBST(NUPA : 1 : 60 - %LEN(WRV)) + WRV;
                CLEAR WRX;
                WRX = %TRIM(WRX) + %EDITW(NUP :WRXWRD);
                IF  P(XX) > 0;
                 RU  = RU  +
                      %SUBST(WRX :64-C(XX): C(XX)-P(XX)) + '.' +
                      %SUBST(WRX :64-P(XX))    ;
                ELSE;
                 RU  = RU  +
                      %SUBST(WRX :64-C(XX));
                ENDIF;
               ELSE;
                 // PACKED FIELD IN ERROR
                RU = RU + X1F;
               ENDIF;

             ENDIF;

        //  PROCESS BINARY DATA TYPE
             IF  T(XX) = 'B';

             ST = S(XX);
              CLEAR NUSA;
              IF  Q(XX) = 2;
               BY2  = D(ST) + D(ST+1);
               NUS  = BIN2;
              ENDIF;
              IF  Q(XX) = 4;
               BY4  = D(ST) + D(ST+1)+ D(ST+2) + D(ST+3);
               NUS  = BIN4;
              ENDIF;

              WRU =  %EDITW(NUS :WRSWRD);
               IF  P(XX) > 0;
                RU  = RU  +
                     %SUBST(WRU :61-C(XX): C(XX)-P(XX)) + '.' +
                     %SUBST(WRU :61-P(XX))    ;
               ELSE;
                RU  = RU  +
                     %SUBST(WRU :61-C(XX));
               ENDIF;
             ENDIF;


        //  PROCESS FLOAT  DATA TYPE
             IF  T(XX) = 'F';

             ST = S(XX);

              IF  Q(XX) = 4;
               FL4   = D(ST) + D(ST+1)+ D(ST+2) + D(ST+3);
               FLT14 =  %EDITFLT(FLT4);
                RU  = RU  + FLT14;
              ENDIF;

              IF  Q(XX) = 8;
               FL8  = D(ST) + D(ST+1)+ D(ST+2) + D(ST+3) +
                      D(ST+4) + D(ST+5)+ D(ST+6) + D(ST+7);
               FLT23 =  %EDITFLT(FLT8);
                RU  = RU  + FLT23;
              ENDIF;

             ENDIF;


           //   SEND A REQUEST UNIT IF GOT ENOUGH DATA

             IF  %LEN(RU) + L(XX + 1) >= 200;
              RU   =  RU + X20;
              BIN  =  %LEN(RU);
              OUTLEN  =  HX2;
              INLEN   =  X000;
              FNC     =  SND;
              A       = RU;
              EXCEPT  DATAO;
              NEWRU  = '1';
              RU    = *ALLX'00';
              CLEAR  RU;
             ENDIF;

            ENDFOR;
          ENDIF;

             IF  %LEN(RU) > 5 AND %LEN(RU) < 250;
              RU   =  RU + X20;
              BIN  =  %LEN(RU);
              OUTLEN  =  HX2;
              INLEN   =  X000;
              FNC     =  SND;
              A       = RU;
              EXCEPT  DATAO;
             ENDIF;
          ENDSR;


         // @@@@@@@@@@@@@@@    ROWINC  @@@@@@@@@@@@@@@

        // INCREMENT THE ROW
          BEGSR     @ROWINC;
           ROW = ROW + 2;
           IF  ROW > 20;
             MX = 3;
           ENDIF;
          ENDSR;



         // @@@@@@@@@@@@@@@    GETFLD  @@@@@@@@@@@@@@@

        // LOAD FIELD DESCRIPTION ARRAYS
          BEGSR     @GETFLD;
          MX = 0;
          X  = 0;

          IF  (*INU2 = *ON);
           // IF NON KEYED ACCESS SET UP A FIELD TO SHOW THE RRN
             N(1) =  'RRN';
             T(1) =  'S'  ;
             C(1) =  11   ;
             P(1) =  0    ;
             S(1) =  0    ;
             E(1) =  0    ;
             L(1) =  12   ;
             I(1) = X4F06 ;
             KY(1)= '3'   ;
             X    = 1     ;
          ENDIF;

          SCRST = *BLANK;
          SCRSTN = *BLANK;

          LVL  = %DEC(SCNLVL : 5:0);

         TEXT500 = SCNLV ;
         LV      = LVW;

         IF  LVL <> 0;
           SCRST = LV(LVL);
         ENDIF;

          SETLL 1 QWHDRFFD ;

          DOW  @LOOP  = @LOOP;
        //  REREAD  TAG
          READ    QWHDRFFD;
           IF %EOF;
            LEAVE;
           ENDIF;

        //  SELECT OR OMIT
           IF  ALL  <> '1';
           IF  ALL  =  'S' AND WHDFTL = 0; // USING WHDFTL FOR KEY FIELDS
             IF   WHFIOB  <>   'S';
              ITER;
             ENDIF;
           ENDIF;
           IF  ALL  =  'O' AND WHDFTL = 0; // USING WHDFTL FOR KEY FIELDS
             IF   WHFIOB   =   'O';
              ITER;
             ENDIF;
           ENDIF;
           ENDIF;

        //  FIND THE FIRST FIELD TO BE SHOWN (FOR MULTI PAGE FORMATS)
           IF  WHDFTL  <> 0 ;
             ELSE;
             IF SCRST <> ' ' AND SCRSTN = ' ';
               IF WHFLDE =  SCRST;
                 SCRSTN = '1';    //  FOUND THE START
               ELSE;
                 ITER;
               ENDIF;
             ENDIF;
           ENDIF;


          X =  X  + 1;
        // CHECK FOR KEY FIELDS,WILL BE USED TO PLACE THEM IN FRONT
          IF  WHDFTL  <>   0;
              KY(X) = '1';
              WX    = WHDFTL ;
              KE(WX) = WHFLDE;
              IF   NUMKEY <  WHDFTL;
                NUMKEY = WHDFTL;
              ENDIF;
          ENDIF;

             N(X) =  WHFLDE ;               //    NAME
             T(X) =  WHFLDT ;               //    TYPE
             V(X) =  WHVARL ;               //    VARYING
             C(X) =  WHFLDD ;               //    DEC DIGITS
             P(X) =  WHFLDP ;               //    DEC PREC
             S(X) =  WHFOBO ;               //    START
             Q(X) =  WHFLDB ;               //    BTYES
             E(X) =  WHFOBO + WHFLDB -1 ;   //   END

             IF T(X) =  'F' ;               //    FLOAT

               I(X) = FFA1 + FFA2;          //   SCRN FIELD FORMAT ALPHA
               L(X)   = 14;
              IF Q(X) = 8;
               L(X)   = 23;
              ENDIF;

             ELSE;
              IF  WHFLDD  <> 0 ;
               IF  WHFLDP  <> 0 ;
                 L(X) =  WHFLDD +  2  ;      //   LENGTH
               ELSE;
                 L(X) =  WHFLDD +  1  ;      //   LENGTH
               ENDIF;

                 I(X) = FFN1 + FFN2;         //   SCRN FIELD FORMAT NUMERIC

              ELSE;
                 L(X) =    WHFLDB  ;
                 I(X) = FFA1 + FFA2;         //   SCRN FIELD FORMAT ALPHA
              ENDIF;
             ENDIF;

        ENDDO;
        //  NUMBER OF FIELDS
         NUMFLD = X ;

       //  MAKE ROOM FOR KEYS
           IF   NUMKEY  >   0 ;
           X1  = NUMKEY  + NUMFLD;

           FOR  X =  NUMFLD DOWNTO 1;
              KY(X1) = KY(X) ;
              L(X1)  = L(X)  ;
              I(X1)  = I(X)  ;
              N(X1)  = N(X)  ;
              T(X1)  = T(X)  ;
              V(X1)  = V(X)  ;
              C(X1)  = C(X)  ;
              P(X1)  = P(X)  ;
              S(X1)  = S(X)  ;
              E(X1)  = E(X)  ;
              Q(X1)  = Q(X)  ;
              X1     = X1 - 1;
           ENDFOR;

          //  PUT KEY FIELDS AT TOP
          OFF  = 0;
          FOR  X =  1 TO NUMKEY;
          X1 = %LOOKUP(KE(X) : N : NUMKEY+1);

          KY(X) = '2';
          L(X)  = L(X1);
          I(X)  = I(X1);  // FIELD FMT
           SELECT;                // INPUT ENABLE
            WHEN  I(X) = X6000;
                  I(X) = X4800;
            WHEN  I(X) = X6706;
                  I(X) = X4F06;
           ENDSL;
            N(X) =  N(X1);
            T(X) =  T(X1);
            V(X) =  V(X1);
            C(X) =  C(X1);
            P(X) =  P(X1);
            S(X) =  S(X1);
            E(X) =  E(X1);
            Q(X) =  Q(X1);
            R(X) =  OFF;
            OFF  =  OFF + Q(X1);
          ENDFOR;

        ENDIF;
       //  NUMBER OF FIELDS AND KEYS
        NUMFKY = NUMFLD  +  NUMKEY;

        ENDSR;


         // @@@@@@@@@@@@@@@    GETADD  @@@@@@@@@@@@@@@

        // LOAD FIELD BUFFER ADDRESSES
          BEGSR     @GETADD;
          MX = 0;
          X  = 0;
          ROW = 3;
          COL = 1;

          FOR X = 1 TO NUMFKY;

        // IF FINISHED WITH THE KEY FIELDS
        //  INC  ROW FOR 1ST DATA FIELD
          IF KEYSOK = ' ' ;
           IF KY(X) = ' ' OR KY(X) = '1';
             KEYSOK = '1' ;
             ROW    = ROW + 2;
             COL    = 1;
           ENDIF;
          ENDIF;

        //  SET THE BUFFER ADD ON THE LARGER OF THE FIELD TEXT OR THE FIELD SIZE
           LENDSC  = %LEN(%TRIM(N(X)));
           LENWRK  =  L(X);
           IF LENDSC > L(X);
             LENWRK = LENDSC;
           ENDIF;
             LENWRK = LENWRK + 2;

        //   TRAP FIELDS THAT OVERFLOW
             ROW  = ROW  + XROW;
             XROW = %DIV(LENWRK : 80);

             IF (COL + LENWRK) > 78;
              EXSR @ROWINC;
                IF MX = 3;
                 X= X-1;
                 NUMFKY = X;
                 LEAVE;
                ENDIF;
              COL = 1;
             ENDIF;

        // INC COL. FOR FIELD START
           CLEAR  B(X);
           BIN  = ROW;
           B(X) =  %TRIM(B(X)) + HX1;
           BIN  = COL + 1;
           B(X) =  %TRIM(B(X)) + HX1;

        // INC COL. FOR NEXT FIELD
        COL = COL + LENWRK;
             IF COL > 78;
              EXSR @ROWINC;
                IF MX = 3;     // NO ROOM FOR THE FIELD
                 X= X-1;
                 NUMFKY = X;
                 LEAVE;
                ENDIF;
              COL = 1;
             ENDIF;

          ENDFOR;

         //  FIELD LEVEL
          LVX      = LVL + 1;
          LV(LVX)  = N(X);

        ENDSR;


         // @@@@@@@@@@@@@@@    PUTHED  @@@@@@@@@@@@@@@

        //  PUT FIELD HEADINGS
          BEGSR     @PUTHED;


            NEWRU  = '1';

            RU    = *ALLX'00';
            CLEAR  RU;                  //  initialise Request Unit  255 bytes max
            FOR  XX = 1 TO      NUMFKY; //NUMBER OF DATA ELEMENTS (FLD AND KEY)

             IF NEWRU = '1';
              NEWRU  = '0';
              RU  = ESC + WTD + X20 + X00;
             ENDIF;

             RU = RU + SBA;
             BIN = 0;
               // CONVERT DATA BUFADR TO HEADING BUFADR
             HX1 = %SUBST(B(XX) :1:1);
             BIN = BIN - 1;
             RU  = RU + HX1;

             IF  REHEAD = '1'; // ON REDISPLAY OVERRIDE THE ATTR
               BIN = 0;
               HX1 = %SUBST(B(XX) :2:1);
               BIN = BIN -1 ;
               RU  = RU + HX1;
             ELSE;
               RU  = RU + %SUBST(B(XX) :2);
             ENDIF;

             RU = RU + ATC ;

        //  LONG NUMBER FIELDS ,RIGHT ADJUST THE FIELD HEADINGS
             LENDSC  = %LEN(%TRIM(N(XX)));
            IF  T(XX) <> 'A' AND  LENDSC <  (L(XX) -1);
             FOR Y = 1 TO (L(XX) -(LENDSC +1));
              RU = RU + ' ';
             ENDFOR;
            ENDIF;

             RU = RU + %TRIM(N(XX));

              IF %LEN(RU) >= 200;
               BIN    = %LEN(RU);
               OUTLEN = HX2;
               INLEN  = X000;
               FNC    = SND;
               A      = RU;
               EXCEPT DATAO;
               NEWRU  = '1';
               RU    = *ALLX'00';
               CLEAR  RU;
              ENDIF;

            ENDFOR;

              IF %LEN(RU) >  5 AND %LEN(RU) <  200;
               BIN    = %LEN(RU);
               OUTLEN = HX2;
               INLEN  = X000;
               FNC    = SND;
               A      = RU;
               EXCEPT DATAO;
              ENDIF;

           IF REHEAD <> '1';
        //  FORMAT FIELDS


            NEWRU  = '1';
            RU    = *ALLX'00';
            CLEAR  RU;                  //  initialise Request Unit  255 bytes max
            FOR  XX = 1 TO      NUMFKY; //NUMBER OF DATA ELEMENTS (FLD AND KEY)

             IF NEWRU = '1';
              NEWRU  = '0';
              RU   = ESC + WTD + X20 + X00;
             ENDIF;

             RU = RU + SBA +B(XX)+SF + I(XX);

             IF KY(XX) = '1' OR KY(XX) = '2' OR KY(XX) = '3';
               RU = RU + X25;
             ELSE;
               RU = RU + X26;
             ENDIF;

             BIN =  L(XX);
             RU  = RU + HX2;

          // LENGTH OF INPUT FIELDS
             LENF  = LENF + L(XX) + 3;


              IF %LEN(RU) >= 200;
               BIN    = %LEN(RU);
               OUTLEN = HX2;
               INLEN  = X000;
               FNC    = SND;
               A      = RU;
               EXCEPT DATAO;
               NEWRU  = '1';
               RU    = *ALLX'00';
               CLEAR  RU;
              ENDIF;

           ENDFOR;

       //   PUT LAST R/U
              IF %LEN(RU) >  5 AND %LEN(RU) <  200;
               BIN    = %LEN(RU);
               OUTLEN = HX2;
               INLEN  = X000;
               FNC    = SND;
               A      = RU;
               EXCEPT DATAO;
              ENDIF;

        //INC BUFFER ADDRESS FOR ALL FIELDS FOR DATA PUT
            FOR  XP = 1 TO      NUMFKY; //NUMBER OF DATA ELEMENTS (FLD AND KEY)
             HX2   = B(XP);
             BIN   = BIN + 1;
             B(XP) = HX2;
            ENDFOR;
           ENDIF;

        ENDSR;

       //   @@@@@@@   INIT   @@@@@@@@@@@@@@@@@@@@@@@@@
          BEGSR         @INIT;

        CLEAR  KW;

        //  UPDATE
           IF  UPDF  = 'Y';
                FFA1 = X40;
                FFN1 = X47;
           ELSE;
                FFA1 = X60;
                FFN1 = X67;
           ENDIF;

           SELECT;
           WHEN  *INU1 = '1';
                 FILE  =  F1 ;
                 LIB   =  L1 ;
                 MBR   =  M1 ;
                 RCDL  =  R1 ;
                 ACCTP =  A1 ;
           WHEN  *INU2 = '1';
                 FILE  =  F2 ;
                 LIB   =  L2 ;
                 MBR   =  M2 ;
                 RCDL  =  R2 ;
                 ACCTP =  A2 ;
           ENDSL;
            RLEN    =   RCDL  ;
            RLENTH  =   %EDITC(RLEN: 'X') ;
            LENF    =   0     ;


        // Control commands and data are constructed into RUs Request UNITS
        // Each RU is 256 bytes max size.
        // Construct and send as many RUs as needed to format the display.
            RU    = *ALLX'00';
            CLEAR  RU;        //  initialise Request Unit  255 bytes max
            RU   = CLRWTD ;
          //set up the screen headings
            BIN = 1;    // set ROW to 1
            RW  = HX1;
            BIN = 2;    // set COL to 2
            CL  = HX1;
            RU  = RU + SBA + RW + CL + X22 + %TRIM(LIB) + '/' + %TRIM(FILE);
            RU  = RU + ' Mbr ' + %TRIM(MBR) + ' Rcdl ' + %EDITC(RLEN   : 'Z') ;
            RU  = RU + ' RRN '  ;
            BIN = %len(RU) -4;
            RBA = RW + HX1 ;   // address of the RRN field
            RU  = RU + SBA + RBA + '          ';

       // FUNCTION KEYS
            BIN  = 23;
            RW  = HX1;
            BIN  = 02;
            CL  = HX1;
            IF  UPDF = 'Y';   //  UPDATE IS ON
             RU  = RU + SBA + RW + CL + %TRIM(CNS(2));
            ELSE;
             RU  = RU + SBA + RW + CL + %TRIM(CNS(1));
            ENDIF;

        //  THIS IS A SEND ONLY FUNCTION
           FNC     = SND;
           CLEAR A;
           A       = RU;
           BIN2    = %LEN(RU);
           OUTLEN  = BY2;
           INLEN   = x000;

           EXCEPT    DATAO;

        ENDSR;


       //   @@@@@@@   KEYIN  @@@@@@@@@@@@@@@@@@@@@@@@@
         BEGSR   @KEYIN;
       // ISSUE A READ FROM DISPLAY
           FNC = SNR;
           BIN2   = 8;
           OUTLEN = BY2;
           IPL = LENF + 34;
           BIN2   = IPL;
           INLEN  = BY2;

          // SET FRR INDICATORS TO CONTROL BUFFER OVERFLOW
           FOR X =  1 TO  9;
             IF IPL  >  ( X*80 +3);
              *IN(X+19) = *ON;
             ENDIF;
           ENDFOR;

         RU    = *ALLX'00';
         CLEAR  RU;
         RU   = RDDSP;
         A    = RU;

         EXCEPT DATAI;
         ENDSR;

       //   @@@@@@@   ERROR  @@@@@@@@@@@@@@@@@@@@@@@@@
         BEGSR    @ERROR;

       // SETUP PUT ERROR MESSAGE X'21'
         RU    = *ALLX'00';
         CLEAR RU;

         FNC    =  SNR;
         BIN    = 42;
         OUTLEN = HX2;
         BIN    = LENF + 34;
         IPL    = BIN;
         INLEN  = HX2;

         FOR X         = 1 TO 9;
          IF IPL       > (X * 80 +3) ;
           *IN(X + 19) = *ON;          // SETON FFR 20 - 29 FOR INPUT
          ENDIF;
         ENDFOR;

         RU = ESC + WER + IC + B(1) + ATC + MSG(MX);
         RU = RU + ESC + RDM + X40+ X00;

         A  = RU;
         EXCEPT    DATAI;
         RU    = *ALLX'00';
         CLEAR RU;
         ENDSR;


       //   @@@@@@@    HXDSP @@@@@@@@@@@@@@@@@@@@@@@@@
         BEGSR   @HXDSP;

           RU    = *ALLX'00';
           CLEAR RU;
           Y = %LOOKUPLE( CURLOC : B );
          //
          RU = ESC + WTD + X20 + X00 + SBA;
          BIN = 0;
          HX1 = %SUBST(B(Y) :1:1);
          BIN = BIN - 1;
          RU  = RU + HX1;
          RU  = RU + %SUBST(B(Y) :2:1);

           FOR X = S(Y) TO E(Y);
             BIN = 0;
             HX1 = D(X);
             HX1 = %BITAND(HX1  : XF0);
             Z   = BIN / 16 + 1;
             RU  = RU + CRS(Z);
           ENDFOR;

             RU  = RU + X20;

             RU  = RU + SBA + B(Y);
           FOR X = S(Y) TO E(Y);
             BIN = 0;
             HX1 = D(X);
             HX1 = %BITAND(HX1  : X0F);
             Z   = BIN  + 1;
             RU  = RU + CRS(Z);
           ENDFOR;


          BIN    = %LEN(RU);
          OUTLEN = HX2;
          INLEN  = X000;
          FNC    = SND;
          A       = RU;
          EXCEPT DATAO;
          RU    = *ALLX'00';
          CLEAR  RU;


          EXSR      @KEYIN;
          READ      DISPF;


       //   CLEAR HEADINGS
            RU    = *ALLX'00';
            CLEAR RU;

         RU   = RU + ESC + WTD + X20 + X00 + SBA;
         HX1  = %SUBST(B(Y) :1:1) ;
         BIN  = BIN - 1;
         RU   = RU + HX1 + %SUBST(B(Y):2:1);
          FOR X = S(Y) TO E(Y);
           RU = RU + ' ';
          ENDFOR;
         RU = RU + ' ';

         BIN    = %LEN(RU);
         OUTLEN = HX2;
         INLEN  = X000;
         FNC    = SND;
         A      = RU;
         EXCEPT    DATAO;
         RU    = *ALLX'00';
         CLEAR  RU;

         ENDSR;



       //   @@@@@@@    UPD   @@@@@@@@@@@@@@@@@@@@@@@@@
          BEGSR  @UPD;

        // CONVERT  DATA  FOR OUTPUT

        //  FOR EACH  FIELD, CHECK IF FIELD WAS MODIFIED, AND IF SO MOVE
        // THE MODIFIED DATA INTO THE OUTPUT ARRAY
         K1 = 0;
         K2 = 0;
         W  = 1;
         CGKY = *BLANK;  // KEY CHANGED
         KW   = KEYA;

           FOR  Y  = 1  TO NUMFKY ;

            IF KY(Y) > '1';
             ITER;
            ENDIF;


       //  MOVE A KEY FIELDS DATA FROM ID ARRAY (SCREEN) TO K ARRAY

       //  GET SIZE OF FIELD IN BYTES
          IF T(Y)  =  'A';  // ALPHA DATA
           K = ' ';
           K1 = 1;
           K2 = Q(Y);
          ELSE;
           K  = '0';
           K1 =  1;
           K2 = C(Y);
          ENDIF;

          X  =  1;

           DOW  @LOOP = @LOOP;

       //  NXTSBA
           X  = %LOOKUP(SBA : ID : X );
           IF X = 0;
             LEAVE;
           ENDIF;

       // IS THIS THE FIELD?  CHECK THE BUFFER ADDRESS
         X = X +1;
         IF   B(Y)  <>  %SUBST(IDA : X :2);
          ITER;
         ENDIF;


       //  FOUND A MTD FOR THIS FIELD


         // CHECK IF FIELD WAS CLEARED ONLY
          DOW @LOOP = @LOOP; //  not a loop
         X =  X + 2;
         IF  ID(X) = SBA;
          LEAVE;
         ENDIF;

       //  IF FIELD HAS DECIMALS BUMP X
          IF (T(Y) = 'S' OR T(Y) = 'P' OR T(Y) = 'B') AND
              P(Y) > 0;
              X = X + 1;
          ENDIF;


       //   CHECK IF ONLY BLANKS RETURNED
          IF     %SUBST(IDA : X :K2) = *BLANKS;
              LEAVE;
          ENDIF;

        // MOVE DATA TO WORK ARRAY K
             X1 = X;
            FOR X2 = 1 TO K2;

             IF ID(X1) < ' ';
              LEAVE;
             ENDIF;

             K(X2) = ID(X1);
             X1 = X1 + 1;
            ENDFOR;

          LEAVE;
         ENDDO;

        // *  SET START POSN
          W =   S(Y);

         // ALPHA
          IF T(Y) =  'A'  and V(XX) <>  'Y';
           FOR Z  =  K1 to K2;
             D(W) =  K(Z);
             W    =  W + 1;
           ENDFOR;
          ENDIF;

        IF T(Y) =  'A' and  V(XX) = 'Y';  //VARYING

         //  the data start is in S(Y)
         //  the data is in array K
         //  get the length of the data cvt to bin and stik in pos 1 2
         //  put the rest in pos 3 onwards

              ENDIF;

        // NUMERIC FIELD
        // RIGHT  ADJUST NUMERIC DATA ,STRIP - . ,CONVERT BLANKS
          IF (T(Y) = 'S' OR T(Y) = 'P' OR T(Y) = 'B');
          NU = '0';

          Z1 = 60;
          FOR Z  =  K2  DOWNTO K1;

          IF K(Z) = '.' OR K(Z) = '-' OR K(Z) = '$';
          ITER;
          ENDIF;

          IF K(Z) = ' ' ;
           NU(Z1) = '0';
          ELSE;
           NU(Z1) = K(Z);
          ENDIF;

            Z1 = Z1 -1;
          ENDFOR;

          ENDIF;


       // SIGNED FIELDS  (END POSN = OFFSET + SIZE)
        IF T(Y)  = 'S';
           NUSA= *BLANKS;
           FOR VX = 1 TO 60;
             NUSA = %TRIM(NUSA) + NU(VX);
           ENDFOR;
         %SUBST(DATA  : W : Q(Y)) = %SUBST(NUSA: 61 -Q(Y));

        ENDIF;


       //  PACKED FIELDS
          IF     T(Y)  =  'P';
           NUSA= *BLANKS;
           FOR VX = 1 TO 60;
             NUSA = %TRIM(NUSA) + NU(VX);
           ENDFOR;
           NUP    = %DEC(NUSA : 60 : 0);

         %SUBST(DATA : W : Q(Y))   =   %SUBST(NUPA: 61 -Q(Y));
        ENDIF;

       //  BINARY FIELDS
        IF   T(Y) =  'B';

         NUSA= *BLANKS;
           FOR VX = 1 TO 60;
             NUSA = %TRIM(NUSA) + NU(VX);
           ENDFOR;
             NUC  = NUS;

         IF  Q(Y) = 2 ;
              DISBIN  ( NUC : BAN2 : BAN4  : '2');
            %SUBST(DATA : W : 2)   =   BAN2;
         ENDIF;

         IF  Q(Y) = 4 ;
              DISBIN  ( NUC : BAN2 : BAN4  : '4');
            %SUBST(DATA : W : 4)   =   BAN4;
         ENDIF;

        ENDIF;

         //  UPDATE KEY IF NECESSARY
         IF   KY(Y)  = '1';
            CGKY = '1';
            EXSR  @PCKMOV;
         ENDIF;


         ENDDO;
        ENDFOR;


          IF  CGKY = '1';
           KEYA = KW;
          ENDIF;

        ENDSR;



      /END-FREE

     OINPUTK    E    U1      UPDATREC
     O                       DA
     O               30      DB
     O               31      DC
     O               32      DD
     O               33      DE
     O               34      DF
     O               35      DG
     O               36      DH
     O               37      DI
     O               38      DJ
     O               39      DK
     O               40      DL
     O               41      DM
     O               42      DN
     O               43      DZ
     O               44      DO
     O               45      DP
     O               46      DQ
     O               47      DR
     O               48      DS
     O               49      DT
     O               50      DU
     O               51      DV
     O               52      DW
     O               53      DX
     O               54      DY
     O               55      D0
     O               56      D1
     O               57      D2
     O               58      D3
     O               59      D4
     O               60      D5
     O               61      D6
     O               62      DBA
     O               63      DCA
     O               64      DDA
     O               65      DEA
     O               66      DFA
     O               67      DGA
     O               68      DHA
     O               69      DIA
     O               70      DJA
     O               71      DKA
     O               72      DLA
     O               73      DMA
     O               74      DNA
     O               75      DOA
     O               76      DPA
     O               77      DQA
     O               78      DRA
     O               79      DSA
     O               80      DTA
     O               81      DUA
     O               82      DVA
     O               83      DWA
     O               84      DXA
     O               85      DYA
     O               86      DZA
     O               87      D0A
     O               88      D1A
     O               89      D2A
     O               90      D3A
     O               91      D4A
     O               92      D5A
     O               93      D6A
     OINPUTR    E       U2   UPDATREC
     O                       DA
     O               30      DB
     O               31      DC
     O               32      DD
     O               33      DE
     O               34      DF
     O               35      DG
     O               36      DH
     O               37      DI
     O               38      DJ
     O               39      DK
     O               40      DL
     O               41      DM
     O               42      DN
     O               43      DZ
     O               44      DO
     O               45      DP
     O               46      DQ
     O               47      DR
     O               48      DS
     O               49      DT
     O               50      DU
     O               51      DV
     O               52      DW
     O               53      DX
     O               54      DY
     O               55      D0
     O               56      D1
     O               57      D2
     O               58      D3
     O               59      D4
     O               60      D5
     O               61      D6
     O               62      DBA
     O               63      DCA
     O               64      DDA
     O               65      DEA
     O               66      DFA
     O               67      DGA
     O               68      DHA
     O               69      DIA
     O               70      DJA
     O               71      DKA
     O               72      DLA
     O               73      DMA
     O               74      DNA
     O               75      DOA
     O               76      DPA
     O               77      DQA
     O               78      DRA
     O               79      DSA
     O               80      DTA
     O               81      DUA
     O               82      DVA
     O               83      DWA
     O               84      DXA
     O               85      DYA
     O               86      DZA
     O               87      D0A
     O               88      D1A
     O               89      D2A
     O               90      D3A
     O               91      D4A
     O               92      D5A
     O               93      D6A

     OINPUTK    EADD U1      ADDREC
     O                       DA
     O               30      DB
     O               31      DC
     O               32      DD
     O               33      DE
     O               34      DF
     O               35      DG
     O               36      DH
     O               37      DI
     O               38      DJ
     O               39      DK
     O               40      DL
     O               41      DM
     O               42      DN
     O               43      DZ
     O               44      DO
     O               45      DP
     O               46      DQ
     O               47      DR
     O               48      DS
     O               49      DT
     O               50      DU
     O               51      DV
     O               52      DW
     O               53      DX
     O               54      DY
     O               55      D0
     O               56      D1
     O               57      D2
     O               58      D3
     O               59      D4
     O               60      D5
     O               61      D6
     O               62      DBA
     O               63      DCA
     O               64      DDA
     O               65      DEA
     O               66      DFA
     O               67      DGA
     O               68      DHA
     O               69      DIA
     O               70      DJA
     O               71      DKA
     O               72      DLA
     O               73      DMA
     O               74      DNA
     O               75      DOA
     O               76      DPA
     O               77      DQA
     O               78      DRA
     O               79      DSA
     O               80      DTA
     O               81      DUA
     O               82      DVA
     O               83      DWA
     O               84      DXA
     O               85      DYA
     O               86      DZA
     O               87      D0A
     O               88      D1A
     O               89      D2A
     O               90      D3A
     O               91      D4A
     O               92      D5A
     O               93      D6A
     OINPUTR    EADD    U2   ADDREC
     O                       DA
     O               30      DB
     O               31      DC
     O               32      DD
     O               33      DE
     O               34      DF
     O               35      DG
     O               36      DH
     O               37      DI
     O               38      DJ
     O               39      DK
     O               40      DL
     O               41      DM
     O               42      DN
     O               43      DZ
     O               44      DO
     O               45      DP
     O               46      DQ
     O               47      DR
     O               48      DS
     O               49      DT
     O               50      DU
     O               51      DV
     O               52      DW
     O               53      DX
     O               54      DY
     O               55      D0
     O               56      D1
     O               57      D2
     O               58      D3
     O               59      D4
     O               60      D5
     O               61      D6
     O               62      DBA
     O               63      DCA
     O               64      DDA
     O               65      DEA
     O               66      DFA
     O               67      DGA
     O               68      DHA
     O               69      DIA
     O               70      DJA
     O               71      DKA
     O               72      DLA
     O               73      DMA
     O               74      DNA
     O               75      DOA
     O               76      DPA
     O               77      DQA
     O               78      DRA
     O               79      DSA
     O               80      DTA
     O               81      DUA
     O               82      DVA
     O               83      DWA
     O               84      DXA
     O               85      DYA
     O               86      DZA
     O               87      D0A
     O               88      D1A
     O               89      D2A
     O               90      D3A
     O               91      D4A
     O               92      D5A
     O               93      D6A

     OINPUTK    EDEL U1      DELREC
     OINPUTR    EDEL U2      DELREC


     ODISPF     E            DATAO
     O                                           K3 'PUT'
     O                       OUTLEN               2
     O                       INLEN
     O                       FNC
     O                       A

     O          E            DATAI
     O                                           K3 'GET'
     O                       OUTLEN               2
     O                       INLEN
     O                       FNC
     O                       A
**
0000 INVALID COMMAND KEY
0001  - A FIELD IS TOO LONG
0002  - TOO MANY FIELDS
0003  - ALPHAS IN PACKED KEY
0004  - MISSING ' IN PACKED KEY
0005  - MISSING DATA IN PCKD KEY
0006  - RECORD NOT FOUND
PRESS RESET TO CONTINUE
**
F1-HEX F2-Return F3-Exit F19-Prev_fld F20-More_fld
F1-HEX F2-Return F3-Exit F6-Update F9-Add F11-Del F19-Prev_fld F20-More_fld
**
0123456789ABCDEF


#top


DISPF DSPF

     A                                      DSPSIZ(24 80 *DS3)
     A                                      PRINT
     A                                      OPENPRT
     A                                      HELP
     A                                      INDARA
     A          R PUT                       USRDFN
     A          R GET                       USRDFN
     A                                      INVITE


#top

WRAPPER CODE

DSPFL CMD

  /*   TO COMPILE */
  /*   CRTCMD CMD(*CURLIB/DSPFL) PGM(*LIBL/DIS) SRCFILE(*LIBL/QCMDSRC) */
  /*          SRCMBR(DSPFL) VLDCKR(DISV) */
  
             CMD        PROMPT('Display file in field format')

             PARM       KWD(FILE) TYPE(QUAL1) MIN(1) MAX(1) +
                          PROMPT('File')

             PARM       KWD(MBR) TYPE(*NAME) DFT(*FIRST) +
                          SPCVAL((*FILE) (*FIRST)) MIN(0) MAX(1) +
                          PROMPT('Member')

             PARM       KWD(UPD ) TYPE(*CHAR) LEN(1) DFT(N) +
                          RSTD(*YES) VALUES('Y' 'N' 'y' 'n') +
                          PROMPT('Update data (Y/N)')

             PARM       KWD(RST ) TYPE(*CHAR) LEN(1) DFT(N) +
                          RSTD(*YES) VALUES('Y' 'N' 'y' 'n') +
                          PROMPT('Get DDS again.')

             PARM       KWD(REL ) TYPE(*CHAR) LEN(1) DFT(N) +
                          RSTD(*YES) VALUES('Y' 'N' 'y' 'n') +
                          PROMPT('Show Relations')


 QUAL1:      QUAL       TYPE(*NAME) LEN(10)
             QUAL       TYPE(*NAME) LEN(10) DFT(*LIBL  ) +
                          SPCVAL(*LIBL  ) +
                          PROMPT('Library name')


#top

DIS CL


/* Command processing program for DSPFF command */

PGM (&FILIB  &MBR &UPD &RST &REL)

DCL &FILIB *CHAR 20
DCL &FILE *CHAR  10
DCL &LIB  *CHAR  10
DCL &SFILE *CHAR  10
DCL &SLIB  *CHAR  10
DCL &MBR  *CHAR  10
DCL &OPT  *CHAR  10
DCL &ALL  *CHAR 1
DCL &RTN  *CHAR 1
DCL &RMBR  *CHAR  10

DCL &QRY  *LGL
DCL &UPD  *LGL
DCL &REL  *CHAR 1
DCL &RST  *CHAR 1

DCL &RCDL *CHAR 5
DCL &RCDLN *DEC (5 0)
DCL &ACCP *CHAR 1
DCL &OVR  *LGL  VALUE('0')
DCL &FILEF *CHAR  10
DCL &FILEK *CHAR  10
DCL &ID    *CHAR  7
DCL &MF    *CHAR  10
DCL &ML    *CHAR  10
DCL &TYPE  *CHAR  1
DCL &PHY   *CHAR  10
DCL &PHYLIB *CHAR  10

RMVLIBLE QTEMP
MONMSG CPF0000
ADDLIBLE QTEMP *FIRST
MONMSG CPF0000 EXEC(GOTO END)

RESET:
CHGVAR &FILE  &FILIB
CHGVAR &LIB   (%SST(&FILIB 11 10))
IF (&LIB *EQ ' ')     (CHGVAR &LIB '*LIBL')
IF (&MBR *EQ '*FILE') (CHGVAR &MBR &FILE)
IF (&MBR *EQ '*FIRST') (DO)
 RTVMBRD    FILE(&LIB/&FILE) RTNMBR(&RMBR)
 CHGVAR &MBR &RMBR
ENDDO
CHGVAR &FILEF ('FF'||(%SST(&FILE 1 8)))
CHGVAR &FILEK ('KF'||(%SST(&FILE 1 8)))

IF (&RST= 'Y') DO
DLTF   &FILEF
MONMSG CPF0000
DLTF   &FILEK
MONMSG CPF0000
ENDDO


CHKOBJ (QTEMP/&FILEF) *FILE
  MONMSG CPF9801 EXEC(DO)
  DSPFFD  FILE(&LIB/&FILE) OUTPUT(*OUTFILE) OUTFILE(QTEMP/&FILEF)
  DSPFD (&LIB/&FILE) TYPE(*ACCPTH) OUTPUT(*OUTFILE) OUTFILE(QTEMP/&FILEK)
  CHGVAR &RTN '2'
ENDDO

CHGPF QTEMP/&FILEF LVLCHK(*NO)
CHGPF QTEMP/&FILEK LVLCHK(*NO)

IF (&REL = 'Y' ) DO
  CALL DISF  (&FILEK &TYPE &PHY &PHYLIB)
  IF (&TYPE *EQ 'P') DO
    CHGVAR &PHY &FILE
    CHGVAR &PHYLIB &LIB
   ENDDO
CALL  DIS3 (&PHY &PHYLIB &SFILE &SLIB)
 IF (&SFILE *NE ' ') DO
  IF ((&SFILE *NE &FILE) *OR (&SLIB *NE &LIB)) DO
   CHGVAR &FILIB (&SFILE||&SLIB)
   CHGVAR &REL '0'
   RTVMBRD    FILE(&SLIB/&SFILE) RTNMBR(&RMBR)
   CHGVAR &MBR &RMBR
  IF (&MBR  *EQ &FILE) THEN(CHGVAR &MBR '*FILE     ')
  GOTO  RESET
  ENDDO
 ENDDO
ENDDO

CALL  DIS1 (&FILIB  &MBR &UPD &RST &RTN &FILE &LIB &FILEF &FILEK)

RCLRSC

END:
CLOF  OPNID(&FILE)
MONMSG CPF0000



ENDPGM

#top

DIS1 CL

/* CALLED BY DIS TO DRIVE SELECTION OF UDDS RPG PROGRAM */
/*  FILE DISPLAYER DRIVER  */
/*  SHOWS A LIST OF FIELDS IN A FILE , ALLOWS SELECTION OF FIELDS  */

/*  WHEN ALL THE FIELDS DONT FIT ON ONE SCREEN                 */
/*  THIS CONTAINS A LOOP SO THAT MORE FIELDS CAN BE DISPLAYED  */


PGM (&FILIB  &MBR &UPD &RST &RTN &FILE &LIB &FILEF &FILEK)

DCL &FILIB *CHAR 20
DCL &FILE *CHAR  10
DCL &LIB  *CHAR  10
DCL &MBR  *CHAR  10
DCL &PRG  *CHAR  10
DCL &OPT  *CHAR  10
DCL &ALL  *CHAR 1
DCL &RTN  *CHAR 1
DCL &RMV  *CHAR 1
DCL &QRY  *LGL
DCL &UPD  *CHAR 1
DCL &RST  *LGL
DCL &KEYL *CHAR 4
DCL &RCDL *CHAR 5
DCL &RCDLN *DEC (5 0)
DCL &ACCP *CHAR 1
DCL &OVR  *LGL  VALUE('0')
DCL &FILEF *CHAR  10
DCL &FILEK *CHAR  10
DCL &ID    *CHAR  7
DCL &MF    *CHAR  10
DCL &ML    *CHAR  10
DCL &SCNLV *CHAR  500
DCL &SCNLVL *CHAR  5
DCL &SCNKEY *CHAR  800
DCL &JOB   *CHAR  10
DCL &MSG   *CHAR  80
DCLF    DISPX

CHGVAR &PGMQ DIS
CHGVAR &SCNLVL '00000'

OVRDBF FFD QTEMP/&FILEF SECURE(*YES)
OVRDBF KF  QTEMP/&FILEK SECURE(*YES)


RTN:
OVRDBF   INPUT   &LIB/&FILE   SHARE(*NO)
CALL  DISPY     (&ALL &RTN &KEYL &ACCP &QRY &RCDL)
             MONMSG     MSGID(CPF5035 CPF5029 RNQ1299 RNX0000) EXEC(DO)
             RTVJOBA    JOB(&JOB)
             SNDBRKMSG  MSG('Cannot handle this file type. Possibly +
                          has NULL data field.') TOMSGQ(&job) +
                          MSGTYPE(*INQ) RPYMSGQ(&job)

  goto end
ENDDO

DLTOVR   INPUT
MONMSG CPF0000

IF (&RTN *EQ '1') (GOTO END)

IF (&ACCP *EQ 'K') DO
 CHGJOB SWS(10XXXXXX)
 OVRDBF     FILE(INPUTK) TOFILE(&LIB/&FILE) MBR(&MBR) +
         SHARE(*YES) SEQONLY(*NO)  SECURE(*YES)
IF (&QRY )   DO
 REMSG:

 REQRY:      SNDRCVF    RCDFMT(SLT)
             IF (&IN01 *OR &IN02) GOTO BYQRY
             CHGVAR &OPT '*INP'
             IF (&UPD *EQ 'Y') (CHGVAR &OPT '*ALL')
             OPNQRYF    FILE((INPUTK)) OPTION(&OPT) QRYSLT(&QSLT) +
                          KEYFLD(*FILE) SEQONLY(*NO)
             MONMSG CPF9899 EXEC(DO)
             RCVMSG     MSGTYPE(*ANY)
             SNDF       RCDFMT(SLTC)
             GOTO REMSG
                                ENDDO
                       ENDDO
              ENDDO
BYQRY:
IF (&ACCP *EQ 'A') DO
            CHGJOB SWS(01XXXXXX)
           OVRDBF     FILE(INPUTR) TOFILE(&LIB/&FILE) MBR(&MBR) +
                          SHARE(*YES) SEQONLY(*NO) SECURE(*YES)
     IF (&QRY )         DO
 REMSGA:

 REQRYA:     SNDRCVF    RCDFMT(SLT)
             IF (&IN01 *OR &IN02) GOTO BYQRYA
             CHGVAR &OPT '*INP'
             IF (&UPD = 'Y') (CHGVAR &OPT '*ALL')
             OPNQRYF    FILE((INPUTR)) OPTION(&OPT) QRYSLT(&QSLT) +
                          KEYFLD(*FILE) SEQONLY(*NO)
             MONMSG CPF9899 EXEC(DO)
                RCVMSG     MSGTYPE(*ANY)
                SNDF       RCDFMT(SLTC)
                GOTO REMSGA
                CHGVAR     VAR(&IN20) VALUE('1')
    SDAMSG:     RCVMSG     RMV(*NO) MSG(&MSG)
                IF         COND(&MSG ¬= ' ') THEN(DO)
                SNDPGMMSG  MSG(&MSG)
                GOTO       SDAMSG
                ENDDO
                SNDF       RCDFMT(SLTC)
                GOTO       REMSGA
                                ENDDO

                    ENDDO
            ENDDO
BYQRYA:
CHGVAR &RCDLN &RCDL

IF ( &UPD= 'Y') (DO)
 IF ((&RCDLN *GT    0) *AND (&RCDLN *LE 2048)) (CHGVAR &PRG 'DUSP ')
 IF ((&RCDLN *GT 2048) *AND (&RCDLN *LE 4048)) (CHGVAR &PRG 'DUSP1')
 IF ((&RCDLN *GT 4048) *AND (&RCDLN *LE 6080)) (CHGVAR &PRG 'DUSP2')
           ENDDO
IF (&UPD *NE 'Y') (DO)
 IF ((&RCDLN *GT    0) *AND (&RCDLN *LE 2048)) (CHGVAR &PRG 'DISP ')
 IF ((&RCDLN *GT 2048) *AND (&RCDLN *LE 4048)) (CHGVAR &PRG 'DISP1')
 IF ((&RCDLN *GT 4048) *AND (&RCDLN *LE 6080)) (CHGVAR &PRG 'DISP2')
           ENDDO


 CALL  &PRG  (&ALL &RTN &KEYL &UPD &SCNLV  &SCNLVL &SCNKEY)

IF (&QRY )  (DO)
   IF (&ACCP *EQ 'K') DO
   CLOF     INPUTK
   MONMSG CPF0000
                   ENDDO
   IF (&ACCP *EQ 'A') DO
   CLOF     INPUTR
   MONMSG CPF0000
                   ENDDO
ENDDO

IF (&RTN *EQ '3') DO
  GOTO BYQRYA
  ENDDO

IF (&RTN *EQ '1') DO
  CHGVAR &RTN '0'
  GOTO RTN
  ENDDO



END:  ENDPGM

#top

DIS3 CL


/* CALL BY DIS TO SHOW FILE RELATIONS / ACCESS PATHS */

PGM  (&PHY &PHYLIB &SFILE &SLIB)

/* DISPLAY ACCESS PATHS */

DCL &PHY    *CHAR  10
DCL &PHYLIB *CHAR  10
DCL &SFILE  *CHAR  10
DCL &SLIB   *CHAR  10


DCLF QTEMP/DBR

/* CREATE WORK FILES */
CALL  DIS4

DLTF QTEMP/DBR
MONMSG CPF0000

 DSPDBR     FILE(&PHYLIB/&PHY) OUTPUT(*OUTFILE) +
   OUTFILE(QTEMP/DBR) OUTMBR(*FIRST *REPLACE)
 CHGPF QTEMP/DBR LVLCHK(*NO)

NEXT: RCVF
 MONMSG CPF0000 EXEC(GOTO END)
 IF (&WHREFI *NE ' ') DO
 DSPFD      FILE(&WHRELI/&WHREFI) TYPE(*ACCPTH) +
         OUTPUT(*OUTFILE) OUTFILE(QTEMP/REL) OUTMBR(*FIRST *ADD)
 CHGPF QTEMP/REL LVLCHK(*NO)
 DSPFD      FILE(&WHRELI/&WHREFI) TYPE(*SELECT) +
         OUTPUT(*OUTFILE) OUTFILE(QTEMP/SEL) OUTMBR(*FIRST *ADD)
 CHGPF QTEMP/SEL LVLCHK(*NO)
         ENDDO
GOTO NEXT

END:
 DSPFD      FILE(&PHYLIB/&PHY   ) TYPE(*ACCPTH) +
         OUTPUT(*OUTFILE) OUTFILE(QTEMP/REL) OUTMBR(*FIRST *ADD)
 CHGPF QTEMP/REL LVLCHK(*NO)

CHGVAR &SFILE '          '
CHGVAR &SLIB  '          '

OVRDBF SEL QTEMP/SEL
OVRDBF REL QTEMP/REL
CALL  DISPR (&SFILE &SLIB)
DLTOVR *ALL

ENDPGM

#top

DIS4 CL


/* CALL BY DIS3 TO CREATE WORK FILES */

PGM

DCL  &LIB *CHAR 10
DCL  &SRCF *CHAR 10

RTVDTAARA DTAARA(UDDSSRC *ALL)  RTNVAR(&SRCF)

DLTF  QTEMP/XXXXFILE
monmsg cpf0000
CRTPF      FILE(QTEMP/XXXXFILE) RCDLEN(80) OPTION(*NOLIST)

DSPFFD  FILE(QTEMP/XXXXFILE) OUTPUT(*OUTFILE) OUTFILE(QTEMP/FFD)
CLRPFM  QTEMP/FFD
DLTF   FILE(QTEMP/FFDL01)
MONMSG CPF0000

RTVMBRD FILE(&SRCF) RTNLIB(&LIB)
CRTLF FILE(QTEMP/FFDL01) SRCFILE(&LIB/&SRCF) SRCMBR(FFDL01) +
OPTION(*NOSRC *NOLIST)

DLTF   FILE(QTEMP/REL)
MONMSG CPF0000
DLTF   FILE(QTEMP/SEL)
MONMSG CPF0000
DLTF   FILE(QTEMP/DBR)
MONMSG CPF0000

DSPFD      FILE(QTEMP/FFD) TYPE(*ACCPTH) +
  OUTPUT(*OUTFILE) OUTFILE(QTEMP/REL) OUTMBR(*FIRST *ADD)

DSPFD FILE(QTEMP/FFDL01) TYPE(*SELECT) OUTPUT(*OUTFILE) OUTFILE(QTEMP/SEL)
CLRPFM FILE(QTEMP/REL)
CLRPFM FILE(QTEMP/SEL)

DLTF  QTEMP/XXXXFILE
monmsg cpf0000


ENDPGM

#top

DISBIN CL

/* NUMERIC TO BINARY CONVERTER  */


PGM (&NUM  &BIN2  &BIN4 &BINTYP  )

DCL  VAR(&NUM) TYPE(*DEC) LEN(15 0)
DCL VAR(&BINTYP) TYPE(*CHAR) LEN(1)
DCL VAR(&BIN2) TYPE(*CHAR) LEN(2)
DCL VAR(&BIN4) TYPE(*CHAR) LEN(4)

IF (&BINTYP = '4') (CHGVAR %BIN(&BIN4) &NUM)
IF (&BINTYP = '2') (CHGVAR %BIN(&BIN2) &NUM)
ENDPGM

#top

DISF CL


/* CHECK FILE TYPE */

PGM (&DISF &TYPE &PHY &PHYLIB)


DCL  &DISF   *CHAR 10
DCL  &TYPE   *CHAR 1
DCL  &PHY    *CHAR 10
DCL  &PHYLIB *CHAR 10
DCLF KF

             OVRDBF     FILE(KF) TOFILE(QTEMP/&DISF)
             OPNDBF     FILE(KF) OPTION(*INP)
             RCVF
             CHGVAR &TYPE &APFTYP

             IF (&TYPE *EQ 'L') DO
             CHGVAR &PHY &APBOF
             CHGVAR &PHYLIB &APBOL
             ENDDO

             CLOF       OPNID(KF)
ENDPGM

#top


DISV CL

/* VALIDITY CHECKER FOR DSPFL COMMAND */


PGM (&FILIB   &MBR &UPD &RST &REL)

DCL &FILIB  *CHAR 20
DCL &FILE *CHAR  10
DCL &LIB  *CHAR  10
DCL &MBR  *CHAR  10
DCL &UPD  *CHAR  1
DCL &RST  *CHAR  1
DCL &REL  *CHAR  1
DCL &OBJATR *CHAR 10
DCL &AUT    *CHAR  8

DCL &MSGDTA *CHAR 40
DCL &ERROR  *LGL

CHGVAR &FILE  &FILIB
CHGVAR &LIB   (%SST(&FILIB 11 10))
IF (&MBR *EQ '*FILE') (CHGVAR &MBR  &FILE  )

CHGVAR &AUT '*READ   '
IF ((&UPD *EQ 'Y') *OR (&UPD *EQ 'y')) (CHGVAR &AUT '*CHANGE')

CHKOBJ   (&LIB/&FILE) OBJTYPE(*FILE) MBR(*NONE)  +
  AUT( &AUT   )
  MONMSG (CPF9899 CPF9801 CPF9802  CPF9820 CPF9830) EXEC(DO)
/*  CHGVAR (&MSGDTA) VALUE('    '||&FILE||&LIB)                   */
/*  SNDPGMMSG MSGID(USR0006) MSGF(*LIBL/QUSERMSG) MSGTYPE(*DIAG) +*/
/*            MSGDTA(&MSGDTA)                                     */
    SNDPGMMSG  MSG('Not authorised to the file.') +
                          MSGTYPE(*DIAG)
    CHGVAR (&ERROR) '1'
  ENDDO
  MONMSG (CPF9810) EXEC(DO)
    CHGVAR (&MSGDTA) VALUE('    '||&LIB)
/*  SNDPGMMSG MSGID(USR0008) MSGF(*LIBL/QUSERMSG) MSGTYPE(*DIAG)  +*/
/*            MSGDTA(&MSGDTA)                                      */
    SNDPGMMSG  MSG('Not authorised to the file.') +
                          MSGTYPE(*DIAG)
    CHGVAR (&ERROR) '1'
  ENDDO


IF (*NOT &ERROR) DO

RTVOBJD    OBJ(&LIB/&FILE) OBJTYPE(*FILE) OBJATR(&OBJATR)
CHGVAR &AUT '*READ   '
IF ((&UPD *EQ 'Y') *OR (&UPD *EQ 'y')) (CHGVAR &AUT '*CHANGE')

CHKOBJ     OBJ(&LIB/&FILE) OBJTYPE(*FILE) MBR(&MBR) +
                          AUT(&AUT)

  MONMSG (CPF9815 )  EXEC(DO)
/*  CHGVAR (&MSGDTA) VALUE('    '||&MBR||&FILE||&LIB)              */
/*  SNDPGMMSG MSGID(USR0007) MSGF(*LIBL/QUSERMSG) MSGTYPE(*DIAG) + */
/*            MSGDTA(&MSGDTA)                                      */
             SNDPGMMSG  MSG('Not authorised to the file.') +
                          MSGTYPE(*DIAG)
    CHGVAR (&ERROR) '1'
  ENDDO
  MONMSG (CPF0000 )  EXEC(DO)
/*  SNDPGMMSG MSGID(USR0022) MSGF(*LIBL/QUSERMSG) MSGTYPE(*DIAG) + */
/*            MSGDTA(&MSGDTA)                                      */
             SNDPGMMSG  MSG('Not authorised to the file.') +
                          MSGTYPE(*DIAG)
    CHGVAR (&ERROR) '1'
  ENDDO
ENDDO

IF (&ERROR)   (SNDPGMMSG MSGID(CPF0002) MSGF(QCPFMSG) MSGTYPE(*ESCAPE))



ENDPGM

#top


DISPR RPG

     H OPTIMIZE(*NONE) OPTION(*NODEBUGIO)
     H DFTACTGRP(*NO) ACTGRP(*CALLER)

      *    FILE RELATIONS DISPLAYER
      * REQUIRES FILES TO COMPILE
      *

     FREL       IF   E             DISK
     FSEL       IF   E             DISK
     FDISPRF    CF   E             WORKSTN
     F                                     SFILE(S01:RS01)
     F                                     SFILE(S02:RS02)
     F                                     INFDS(SFINF)
      *

      *
     DDISPR            PR
     D                               10
     D                               10
     DDISPR            PI
     D  SFILE                        10
     D  SLIB                         10

      //  SCREEN LEVELS
     D @SCN            S              6    DIM(50)
     D @NSCN           S              6
     D @LV             S              5  0
     D @ERR            S                   LIKE(@TRUE)
     D @FILE           S             10A   INZ('DISPY  ')
     D WRKSWS          S              1
     D I               S              4B 0


     D @TRUE           S              1A   INZ('1')
     D @FALSE          S              1A   INZ('0')
     D @OK             S                   LIKE(@TRUE)
     D @LOOP           S                   LIKE(@TRUE)

      //
     D RS01            S              4S 0
     D RS02            S              4S 0
      //
      // PARMS FOR SFL LOOPING
     D SFC01           S                   LIKE(RS01)
     D SFC02           S                   LIKE(RS01)

      // Program Status
     D                SDS
     D  PGM                    1     10
     D  WSID                 244    253
     D  USER                 254    263
      //
      //
     D SFINF           DS
     D  RRRN                 376    377B 0
     D  SRN                  378    379B 0

      //  MESSAGE DATA
     D @DTA1           DS            80
     D @DTA2           DS           500
      //
     D MAIN            PR

     D @S01BLD         PR
     D @S01PRC         PR
     D @S01PRS         PR
     D @S02BLD         PR
     D @S02PRC         PR
     D
     D @R9999          PR

     D @OPADJ          PR             2A
     D  OPT                           2A


      /FREE
            *INLR = *ON;
            MAIN();


       //--------------*INZSR-------------------------------//
           BEGSR   *INZSR;

        //  Set the TOP level (Exit if user backs up to here)
              @LV = 1;
              @SCN(@LV)  = '*END  ';
        //  Set the Initial Screen to display
              @LV = @LV + 1;
              @SCN(@LV) = 'S01BLD ';

            ENDSR;
      /END-FREE
       //###################################################//

        //*************************************************************
     P    MAIN         B

     D MAIN            PI

     D I               S              4B 0

      /FREE
          EXSR      @INZSR;
       //
       // THIS IS THE CONTROLLING LOOP TO DRIVE THE NEXT PANEL TO DISPLAY
          DOW       @LOOP = @LOOP;
       // GET THE SCREEN NAME FROM THE SCREEN STACK ARRAY
            @NSCN  = @SCN(@LV);
          SELECT;
         //  SELECT FIELDS FOR DISPLAY

         // SFL TO SELECT THE FILE FIELDS
           WHEN      @NSCN = 'S01BLD';
                             @S01BLD();
           WHEN      @NSCN = 'S01PRC';
                             @S01PRC();
           WHEN      @NSCN = 'S01PRS';
                             @S01PRS();
           WHEN      @NSCN = 'S02BLD';
                             @S02BLD();
           WHEN      @NSCN = 'S02PRC';
                             @S02PRC();
          OTHER;
            //  CATCH ALL (NEVER USED)
              @R9999();
              LEAVE;
          ENDSL;

        //  CF3 EXIT
          IF  *IN03 = *ON;
            LEAVE;
          ENDIF;

       //   CF12 PREVIOUS
          IF  *IN12 = *ON;
               *IN12 = *OFF;
               @LV   = @LV -1;
               @NSCN = @SCN(@LV);
          ENDIF;

       //  Backed out to last level, Exit
          IF     @NSCN = '*END';
                   LEAVE;
          ENDIF;

         ENDDO;

         RETURN;

       //--------------*INZSR-------------------------------//
           BEGSR   @INZSR;
              @NSCN = *BLANK;

          ENDSR;
       //-ENDSR---*INZSR-------------------------------//
      /END-FREE

     P    MAIN         E


       //###################################################//
       //###################################################//
       //###################################################//
      /space 3
     P @S01BLD         B

     D @S01BLD         PI

     D WFILE           S                   LIKE(APFILE )
     D WLIB            S                   LIKE(APLIB  )

          //  Build/Rebuild the subfile

      /FREE
           EXSR      @INZSR;

           EXSR      BLD;

         //  SFL IS BUILT, PROCESS THE SFL CONTROL
           @LV = @LV + 1;
           @SCN(@LV) = 'S01PRC ' ;
            RETURN ;

       //--------------  BLD -------------------------------//
           BEGSR     BLD;

            EXSR      CLR;


          SETLL 1    QWHFDACP;

          DOW @LOOP = @LOOP;
          READ      QWHFDACP;
          IF %EOF;
           LEAVE;
          ENDIF;


          EXSR MOV;
          //
           RS01   = RS01 + 1;
          WRITE S01;
         ENDDO;


         // Position to TOP of subfile
            SRS01 = 1;
            SFC01 = RS01;
           ENDSR;

       //--------------  CLR -------------------------------//
           BEGSR   CLR;

               *IN51 = *OFF;
               *IN52 = *OFF;
               *IN53 = *ON;
               WRITE     C01;
               *IN53 = *OFF;
               RS01  = 0   ;
               SFC01 = 0   ;
               S01FUNC = *BLANK;
               ENDSR;

       //--------------  MOV -------------------------------//
           BEGSR   MOV;

            C01APBOF =  APBOF ;
            C01APBOL =  APBOL ;

           IF APBOF = *BLANK AND APBOL =  *BLANK;
           C01APBOF = APFILE;
           C01APBOL = APLIB;
           ENDIF;

         //  Load the subfile record

          IF APFILE = WFILE  AND
             APLIB  = WLIB ;
             *IN56 = *ON ;
                  S01APFILE  =   *BLANK;
                  S01APLIB   =   *BLANK;
                  S01APACCP  =   *BLANK;
                  S01APUNIQ  =   *BLANK;
                  S01APSELO  =   *BLANK;
                  S01APFTYP  =   *BLANK;
                  S01APJOIN  =   *BLANK;
                  S01APKEYO  =   *BLANK;
                  S01APKSEQ  =   APKSEQ ;
                  S01APKSIN  =   APKSIN ;
                  S01APKEYF  =   APKEYF ;
            ELSE       ;
             WFILE = APFILE;
             WLIB  = APLIB ;
             *IN56 = *OFF;
                  S01APFILE  =   APFILE ;
                  S01APLIB   =   APLIB  ;
                  S01APACCP  =   APACCP ;
                  S01APUNIQ  =   APUNIQ ;
                  S01APSELO  =   APSELO ;
                  S01APFTYP  =   APFTYP ;
                  S01APJOIN  =   APJOIN ;
                  S01APKEYO  =   APKEYO ;
                  S01APKSEQ  =   APKSEQ ;
                  S01APKSIN  =   APKSIN ;
                  S01APKEYF  =   APKEYF ;
          ENDIF;

           ENDSR;

       //--------------*INZSR-------------------------------//
           BEGSR     @INZSR;
               @NSCN = *BLANK;
           ENDSR;
      /END-FREE

     P @S01BLD         E

       //###################################################//
       //###################################################//

      /space 3
     P @S01PRC         B

     D @S01PRC         PI

          //
          //
     D WRKRC           S              4S 0

      /FREE
           EXSR      @INZSR;

            WRITE     R01;
       //
            DOW       @LOOP = @LOOP;

           //
           // Write SFL Control
             IF        SFC01 > 0;
                *IN51 = *ON;
             ENDIF;
               *IN52 = *ON;


               EXFMT     C01;
           //  Setoff errors
                 *IN89 = *OFF;
           //
           //  Exit and Previous Screen
             IF        *IN03 = *ON;
                LEAVE;
             ENDIF;
             IF        *IN12 = *ON;
                 LEAVE;
             ENDIF;


         //  Process the subfile
               @LV = @LV + 1;
               @SCN(@LV) = 'S01PRS';
               LEAVE;

            ENDDO;
       //
            RETURN;

      /space 3


       //--------------*INZSR-------------------------------//
           BEGSR     @INZSR;
               @NSCN = *BLANK;
           ENDSR;
      /END-FREE
     P @S01PRC         E

       //###################################################//
       //###################################################//
       //###################################################//
      /space 3
     P @S01PRS         B

     D @S01PRS         PI

          //
          //
     D WRKRC           S              4S 0

      /FREE

          EXSR      @INZSR;

         //  Process the subfile
           EXSR      SFL;
           RETURN;

       //--------------  SFL -------------------------------//
           BEGSR      SFL;
        //  Process the subfile

           FOR       WRKRC = 1 TO SFC01 + 1 ;
               CHAIN  WRKRC   S01;
                 IF        NOT %FOUND;
         //  Finished with the subfile
                    @LV = @LV -1;
                    LEAVE;
                 ENDIF;

         //   GET SELECTED FILE
            IF   @OPADJ(S01FUNC) =   ' X';
               SFILE  = S01APFILE;
               SLIB   = S01APLIB ;
               *IN03 = '1';
                LEAVE;
            ENDIF;


         //   SHOW SELECT RULES
            IF   @OPADJ(S01FUNC) =   ' R';
              @LV = @LV + 1;
              @SCN(@LV) = 'S02BLD ';
                 S01FUNC =  '  ';
                 UPDATE    S01;
              LEAVE;
            ENDIF;

           ENDFOR;

           ENDSR;
       //---------------------------------------------------//



       //--------------*INZSR-------------------------------//
           BEGSR     @INZSR;
               @NSCN = *BLANK;
           ENDSR;


      /END-FREE
     P @S01PRS         E


      /space 3
     P @S02BLD         B

     D @S02BLD         PI

          //  Build/Rebuild the subfile
      /FREE

          EXSR @INZSR;

          C02APFILE  =  S01APFILE ;
          C02APLIB   =  S01APLIB  ;

         EXSR BLD;

         //  SFL IS BUILT, PROCESS THE CONTROL
           @LV = @LV + 1;
           @SCN(@LV) = 'S02PRC ';
       RETURN;
       //--------------  BLD -------------------------------//
       BEGSR   BLD;

         EXSR CLR;


          SETLL 1    QWHFDSO ;

          DOW @LOOP = @LOOP;

          READ      QWHFDSO ;
          IF %EOF;
           LEAVE;
          ENDIF;

          If SOFILE = S01APFILE  AND
             SOLIB  = S01APLIB ;
          EXSR MOV;

          //
           RS02   = RS02 + 1;
          WRITE S02;
          ENDIF;
         ENDDO;

         // Position to TOP of subfile
         SRS02 = 1;
         SFC02 = RS02;
         ENDSR;

       //--------------  CLR -------------------------------//
         BEGSR  CLR;
          *IN51 = *OFF;
          *IN52 = *OFF;
          *IN53 = *ON;
          WRITE C02;
          *IN53 = *OFF;
           RS02 =0;
           SFC02=0;

         ENDSR;

       //--------------  MOV -------------------------------//
        BEGSR  MOV;
         //  Load the subfile record

          S02SOFLD  = SOFLD  ;
          S02SORULE = SORULE ;
          S02SOCOMP = SOCOMP ;
          S02SOVALU = SOVALU ;



         ENDSR;

       //--------------*INZSR-------------------------------//
         BEGSR  @INZSR;
           @NSCN = *BLANK;
         ENDSR;

      /END-FREE
     P @S02BLD         E

       //###################################################//
       //###################################################//
       //###################################################//
      /space 3
     P @S02PRC         B

     D @S02PRC         PI

          //
          //
     D WRKRC           S              4S 0

      /FREE

          EXSR @INZSR;

         WRITE R02;

       //
       DOW @LOOP = @LOOP;

           //
           // Write SFL Control
           IF SFC02 > 0;
             *IN51 = *ON;
           ENDIF;
           *IN52 = *ON;
           EXFMT C02;
           //
           //  Setoff errors
           *IN89 = *OFF;
           //
           //  Exit and Previous Screen

           @LV = @LV -2;
             LEAVE;


         //  Process the subfile

       ENDDO;
       //
       RETURN;

      /space 3
       //--------------*INZSR-------------------------------//
         BEGSR  @INZSR;

           @NSCN = *BLANK;
         ENDSR;
      /END-FREE
     P @S02PRC         E


       //###################################################//
       //###################################################//
       //###################################################//

     P @R9999          B
        //  Invalid Panel
     D @R9999          PI

     P @R9999          E


      /space 3
       //###################################################//
       //###################################################//
       //###################################################//
     P @OPADJ          B
        //   RIGHT ADJ OPTION , zero suppress

     D @OPADJ          PI             2A
     D  OPT                           2A

      /FREE
         EVALR  OPT   = %trimr(OPT);
         If %SubSt(OPT:1:1) =  '0';
         OPT   = ' ' +  %SubSt(OPT:2:1);
         EndIf;
         RETURN OPT;
      /END-FREE
     P @OPADJ          E

       //###################################################//
       //###################################################//

#top

DISPRF DSPF


     A*%%TS  SD  20101208  163705  KOLMANNF    REL-V5R4M0  5722-WDS
     A*
      * REQUIRES FILES TO COMPILE
      *   CRTDUPOBJ  OBJ(QAFDSELO) FROMLIB(QSYS)
      *              OBJTYPE(*FILE) TOLIB(QTEMP) NEWOBJ(SEL)
      *   CRTDUPOBJ  OBJ(QAFDACCP) FROMLIB(QSYS)
      *         OBJTYPE(*FILE) TOLIB(QTEMP) NEWOBJ(ACC)


     A*%%EC
     A                                      DSPSIZ(24 80 *DS3)
     A                                      PRINT
     A                                      CF03(03)
     A                                      CF12(12)
     A          R S01                       SFL
     A*%%TS  SD  20101208  163705  KOLMANNF    REL-V5R4M0  5722-WDS
     A            S01FUNC        2A  I  4  3
     A  55
     AO 56                                  DSPATR(PR)
     A            S01APFILE R        O  4  6REFFLD(QWHFDACP/APFILE QTEMP/REL)
     A            S01APLIB  R        O  4 17REFFLD(QWHFDACP/APLIB QTEMP/REL)
     A            S01APACCP R        O  4 29REFFLD(QWHFDACP/APACCP QTEMP/REL)
     A            S01APUNIQ R        O  4 33REFFLD(QWHFDACP/APUNIQ QTEMP/REL)
     A            S01APSELO R        O  4 37REFFLD(QWHFDACP/APSELO QTEMP/REL)
     A            S01APFTYP R        O  4 41REFFLD(QWHFDACP/APFTYP QTEMP/REL)
     A            S01APJOIN R        O  4 45REFFLD(QWHFDACP/APJOIN QTEMP/REL)
     A            S01APKEYO R        O  4 48REFFLD(QWHFDACP/APKEYO QTEMP/REL)
     A            S01APKSEQ R        O  4 53REFFLD(QWHFDACP/APKSEQ QTEMP/REL)
     A            S01APKSIN R        O  4 57REFFLD(QWHFDACP/APKSIN QTEMP/REL)
     A            S01APKEYF R        O  4 61REFFLD(QWHFDACP/APKEYF QTEMP/REL)
     A          R C01                       SFLCTL(S01)
     A*%%TS  SD  20101208  163705  KOLMANNF    REL-V5R4M0  5722-WDS
     A                                      SFLSIZ(0019)
     A                                      SFLPAG(0018)
     A                                      OVERLAY
     A  50                                  SFLEND
     A  51                                  SFLDSP
     A  52                                  SFLDSPCTL
     A  53                                  SFLCLR
     A            SRS01          4S 0H      SFLRCDNBR(CURSOR)
     A*
     A                                  1 18'FILE RELATIONS for '
     A            C01APBOF  R        O  1 39REFFLD(QWHFDACP/APBOF QTEMP/REL)
     A                                  1 51'Lib.'
     A            C01APBOL  R        O  1 56REFFLD(QWHFDACP/APBOL QTEMP/REL)
     A                                  2 32'Uni SEL         LIFO ASC Key'
     A                                  3  6'File       Library    Acc Key OMT -
     A                                      TYP  J  FIFO DSC Sgn Key'
     A          R R01
     A                                 24  3'F3-Exit'
     A                                 22  3'R - Display Select/Omit rules'
     A                                 23  3'X - Select for display'
      *
     A          R R02
     A                                 24  3'F3-Exit'
     A          R S02                       SFL
     A                                      SFLNXTCHG
     A            S02SOFLD  R        O  4  4REFFLD(QWHFDSO/SOFLD QTEMP/SEL)
     A            S02SORULE R        O  4 17REFFLD(QWHFDSO/SORULE QTEMP/SEL)
     A            S02SOCOMP R        O  4 22REFFLD(QWHFDSO/SOCOMP QTEMP/SEL)
     A            S02SOVALU R        O  4 28REFFLD(QWHFDSO/SOVALU QTEMP/SEL)

     A          R C02                       SFLCTL(S02 )
     A                                      OVERLAY
     A  50                                  SFLEND
     A  51                                  SFLDSP
     A  52                                  SFLDSPCTL
     A  53                                  SFLCLR
     A                                      SFLSIZ(0019)
     A                                      SFLPAG(0018)
     A            SRS02          4S 0H      SFLRCDNBR(CURSOR)
     A*
     A                                  1  6'FILE SELECTS   for '
     A            C02APFILE R        O  2  7REFFLD(QWHFDSO/SOFILE QTEMP/SEL)
     A                                  2 20'Lib.'
     A            C02APLIB  R        O  2 25REFFLD(QWHFDSO/SOLIB QTEMP/SEL)
     A                                  3  4'Field'
     A                                  3 28'Select/Omit Value'
     A                                  3 16'S/O'
     A                                  3 21'COMP'

#top


DISPY RPG

     H OPTIMIZE(*NONE) OPTION(*NODEBUGIO)
     H DFTACTGRP(*NO) ACTGRP(*CALLER)

      //***************************************************************
      //
      //  PROGRAM ID : DISPY
      //  Description: DISPLAY A FILES FIELDS FOR SELECTION

      //    needs files KF  FFD to compile use following commands
      // DSPFD (&LIB/&FILE) TYPE(*ACCPTH) OUTPUT(*OUTFILE) OUTFILE(QTEMP/KF)
      // DSPFFD  FILE(&LIB/&FILE) OUTPUT(*OUTFILE) OUTFILE(QTEMP/FFD)
      //***************************************************************
      // MODIFICATIONS:
      // MOD   SR   DATE    MODIFICATION SUMMARY
      //
      //***************************************************************
      //
     FKF        IF   E             DISK
     FFFD       UF   E             DISK
     FINPUT     IF   F32766  2000AIDISK    KEYLOC(1)
     F                                     INFDS(INFDS)
     FDISPYF    CF   E             WORKSTN
     F                                     SFILE(S01:RS01)
     F                                     INFDS(SFINF)
      //
      //

      //  SCREEN LEVELS
     D @SCN            S              6    DIM(50)
     D @NSCN           S              6
     D @LV             S              5  0
     D @ERR            S                   LIKE(@TRUE)
     D @FILE           S             10A   INZ('DISPY  ')
     D WRKSWS          S              1
     D I               S              4B 0


     D @TRUE           S              1A   INZ('1')
     D @FALSE          S              1A   INZ('0')
     D @OK             S                   LIKE(@TRUE)
     D @LOOP           S                   LIKE(@TRUE)

      //
     D RS01            S              4S 0
      //
      // PARMS FOR SFL LOOPING
     D SFC01           S                   LIKE(RS01)

      // Program Status
     D                SDS
     D  PGM                    1     10
     D  WSID                 244    253
     D  USER                 254    263
      //
      //
     D SFINF           DS
     D  RRRN                 376    377B 0
     D  SRN                  378    379B 0

      //
     D FLD             S             10    DIM(9000)
     D KEY             S             10    DIM(99)

     D INFDS           DS
     D  FILE                  83     92
     D  LIB                   93    102
     D  MBR                  129    138
     D  RCDL                 125    126B 0
     D  RCDS                 156    159B 0
     D  ACCTP                160    160

     D                 DS
     D  WHCOLD                 1     60
     D  WHCHD1                 1     20
     D  WHCHD2                21     40
     D  WHCHD3                41     60

     D                 DS
     D  POSN                   1     10
     D  P1                     1     10    DIM(10)

     D  POSNN                 11     20
     D  P2                    11     20    DIM(10)


      *
      //  MESSAGE DATA
     D @DTA1           DS            80
     D @DTA2           DS           500
      //
     D MAIN            PR

     D @S01BLD         PR
     D @S01PRC         PR
     D @S01PRS         PR
     D
     D @R9999          PR

     D @OPADJ          PR             2A
     D  OPT                           2A

      *
     DDISPY            PR
     D                                1
     D                                1
     D                                4
     D                                1
     D                                1
     D                                5
     DDISPY            PI
     D  ALL                           1
     D  RTN                           1
     D  KEYLNG                        4
     D  ACCP                          1
     D  QRY                           1
     D  RCDLN                         5
      *
     D KEYLN           S              4S 0
     D RCDLEN          S              5S 0
      *-------------------------------------------------------------------
      * QMHRTVM API (Retrieve Message text)
      *-------------------------------------------------------------------
     D  RtvMsgTxt      PR          1024
     D   RMsgId                       7    Const
     D   RMsgFle                     10    Const
     D   RMsgLib                     10    Const
     D   RMsgLvl                      1    Const

     D GETROWCOL       PR
     D                               10A   const
     D                               10A   const
     D                               10A   const
     D                               32A   const
     D                                3P 0
     D                                3P 0

     D SysDate         PR             8S 0
     D SysTime         PR             6S 0
     D DayOfWeek       PR            10I 0
     D                                 D   value datfmt(*iso)
       // Message file names
     D  cMsgLib        C                   Const('*LIBL     ')
     D  cMsgF1         C                   Const('MSGF1     ')
     D  cMsgF2         C                   Const('MSGF2     ')
     D  cMsgLvl1       C                   Const('1')
     D  cMsgLvl2       C                   Const('2')

      *
     IINPUT     NS  01
     I                                  1  256  D

      /FREE
            *INLR = *ON;
            MAIN();


       //--------------*INZSR-------------------------------//
           BEGSR   *INZSR;

        //  Set the TOP level (Exit if user backs up to here)
              @LV = 1;
              @SCN(@LV)  = '*END  ';
        //  Set the Initial Screen to display
              @LV = @LV + 1;
              @SCN(@LV) = 'S01BLD ';

       //    DUMMY I/O TO GET NUMBER OF RECORDS IN FILE
             READ      INPUT;
       //   SFL IS NOT LOADED
       //   READ THE LIST OF KEY FIELDS IN THE FILE SO THAT WE CAN LATER MARK THEM
                  ACCP    = ACCTP;

               I     =   0;

               DOW  @LOOP = @LOOP;
                READ      QWHFDACP;
                IF  %EOF;
                 LEAVE;
                ENDIF;
                 I = I + 1;
                 KEY(I) = APKEYF;
               ENDDO;
            ENDSR;
      /END-FREE
       //###################################################//

        //*************************************************************
     P    MAIN         B

     D MAIN            PI

     D I               S              4B 0

      /FREE
          EXSR      @INZSR;
       //
       // THIS IS THE CONTROLLING LOOP TO DRIVE THE NEXT PANEL TO DISPLAY
          DOW       @LOOP = @LOOP;
       // GET THE SCREEN NAME FROM THE SCREEN STACK ARRAY
            @NSCN  = @SCN(@LV);
          SELECT;
         //  SELECT FIELDS FOR DISPLAY

         // SFL TO SELECT THE FILE FIELDS
           WHEN      @NSCN = 'S01BLD';
              @S01BLD();
           WHEN      @NSCN = 'S01PRC';
              @S01PRC();
           WHEN      @NSCN = 'S01PRS';
              @S01PRS();
          OTHER;
            //  CATCH ALL (NEVER USED)
              @R9999();
              LEAVE;
          ENDSL;

        //  CF3 EXIT
          IF  *IN03 = *ON;
            LEAVE;
          ENDIF;

       //   CF12 PREVIOUS
          IF  *IN12 = *ON;
               *IN12 = *OFF;
               @LV   = @LV -1;
               @NSCN    = @SCN(@LV);
          ENDIF;

       //  Backed out to last level, Exit
          IF     @NSCN = '*END';
                   LEAVE;
          ENDIF;

         ENDDO;

         KEYLNG  = %EDITC(KEYLN:'X');
         RETURN;

       //--------------*INZSR-------------------------------//
           BEGSR   @INZSR;
              @NSCN = *BLANK;
              RCDLEN = RCDL;
              RCDLN = %CHAR(RCDLEN);

       // CLEAR FIELD SELECTIONS
              IF  RTN  =  '2';
                SETLL 1    QWHDRFFD;
               DOW  @LOOP = @LOOP;
                READ      QWHDRFFD ;
                IF  %EOF;
                 LEAVE;
                ENDIF;
                   WHFIOB = ' ';
                   UPDATE    QWHDRFFD;
               ENDDO;

       // SET FILE I/O TO FIRST RCD IN FILE
                SETLL 1    QWHDRFFD;
                   RTN = '0';
              ELSE;
                CHAIN  1  QWHDRFFD;
                SETLL  1  QWHDRFFD;
              ENDIF;
          ENDSR;
       //-ENDSR---*INZSR-------------------------------//
      /END-FREE

     P    MAIN         E


       //###################################################//
       //###################################################//
       //###################################################//
      /space 3
     P @S01BLD         B

     D @S01BLD         PI

     D  SZ             DS             6
     D  LEN1                   1      1
     D  LEN2                   2      3
     D  LEN3                   1      3
     D  COMA                   4      4
     D  DEC1                   5      5
     D  DEC2                   5      6

     D                 DS
     D K                       1      3  0
     D KA                      2      3

          //  Build/Rebuild the subfile

      /FREE
           EXSR      @INZSR;

           EXSR      BLD;

         //  SFL IS BUILT, PROCESS THE SFL CONTROL
           @LV = @LV + 1;
           @SCN(@LV) = 'S01PRC ' ;
            RETURN ;
       //--------------  BLD -------------------------------//
           BEGSR     BLD;

            EXSR      CLR;

           DOW       @LOOP = @LOOP;

             READ      QWHDRFFD;
                IF  %EOF;
                 LEAVE;
                ENDIF;
            EXSR      MOV;

       // FLAG THE KEY FIELDS
                  K = %LOOKUP(WHFLDE :KEY);
                     WHDFTL  = K ;
                     UPDATE    QWHDRFFD;

            RS01   = RS01 + 1;
            WRITE     S01;
           ENDDO;

         // Position to TOP of subfile
            SRS01 = 1;
            SFC01 = RS01;
           ENDSR;

       //--------------  CLR -------------------------------//
           BEGSR   CLR;
               I     =  0;
               CLEAR FLD;
               KEYLN = 0;

               *IN51 = *OFF;
               *IN52 = *OFF;
               *IN53 = *ON;
               WRITE     C01;
               *IN53 = *OFF;
               RS01  = 0   ;
               SFC01 = 0   ;
               S01OPT= *BLANK;
               ENDSR;

       //--------------  MOV -------------------------------//
           BEGSR   MOV;
         //  Load the subfile record


             S01OPT   =  WHFIOB ;
             S01WHFLDB  = WHFLDB;
             S01WHFLDT  = WHFLDT;
             S01WHFLD =  WHFLDE ;
             S01SFLD  =  WHFLDE ;
             S01FROM = WHFOBO;
             S01TO   = WHFLDB + WHFOBO -1 ;

       //  KEY FIELDS
             S01KEYFLD   = '  ';
               K = %LOOKUP(WHFLDE :KEY);
                  IF K <> 0;
                     S01KEYFLD = KA;
                   IF   K <  10;
                    %SUBST(S01KEYFLD:1:1) = 'K';
                   ENDIF;
                     KEYLN = KEYLN +  WHFLDB;
                  ENDIF;
        //  FORMAT THE FIELD LENGTH
                  S01SIZE  =  '      ';
                  SZ       =  '      ';
                  IF WHFLDD =       0;
                      LEN3   = %SUBST(%EDITC(WHFLDB:'Z'):3:3);
                   ELSE;
                      LEN2   = %EDITC(WHFLDD:'Z') ;
                      COMA = ',';

                      IF     WHFLDP >  9;
                        DEC2 = %CHAR(WHFLDP);
                      ELSE;
                        DEC1 = %CHAR(WHFLDP);
                      ENDIF;
                  ENDIF;
                  IF   LEN1 =  '0';
                       LEN1 = ' ';
                  ENDIF;
                  S01SIZE = SZ;

                   S01DESC = WHFTXT;
                   IF    S01DESC=   ' ';
                      S01DESC  =  WHCOLD ;
                   ENDIF;

                   I = I + 1;
                   FLD(I) =  S01WHFLD;

           ENDSR;

       //--------------*INZSR-------------------------------//
           BEGSR     @INZSR;
               @NSCN = *BLANK;
           ENDSR;
      /END-FREE

     P @S01BLD         E

       //###################################################//
       //###################################################//

      /space 3
     P @S01PRC         B

     D @S01PRC         PI

          //
          //
     D WRKRC           S              4S 0
     D C01CHK          S                   LIKE(C01POSN)

      /FREE
           EXSR      @INZSR;

            WRITE     R01;

       //
            DOW       @LOOP = @LOOP;

           //
           // Write SFL Control
             IF        SFC01 > 0;
                *IN51 = *ON;
             ENDIF;
               *IN52 = *ON;
               EXFMT     C01;
           //  Setoff errors
                 *IN89 = *OFF;
           //
           //  Exit and Previous Screen
             IF        *IN03 = *ON;
               RTN = '1';
                LEAVE;
             ENDIF;

             IF        *IN12 = *ON;
                @LV = @LV -1;
                 LEAVE;
             ENDIF;

           //  Set up for qry selection and exit
             IF        *IN06 = *ON;
               *IN03 = *ON;
               QRY = '1';
               LEAVE;
             ENDIF;

         //  POSITION
             IF   C01POSN <> ' ';
               EXSR POS;
               ITER;
             ENDIF;

         //  Process the subfile
               @LV = @LV + 1;
               @SCN(@LV) = 'S01PRS';
               LEAVE;

            ENDDO;
       //
            RETURN;

      /space 3

       //--------------POS   -------------------------------//
           BEGSR     POS;


           FOR       WRKRC = 1 TO SFC01;
               CHAIN  WRKRC   S01;
                 IF        NOT %FOUND;
                    LEAVE;
                 ENDIF;

                 C01CHK  = %SUBST(S01WHFLD :1 : %LEN(%TRIM(C01POSN)));
                 IF   (C01POSN  = C01CHK  );
                    SRS01  = WRKRC;
                    LEAVE;
                 ENDIF;

           ENDFOR;


           ENDSR;


       //--------------*INZSR-------------------------------//
           BEGSR     @INZSR;
               @NSCN = *BLANK;

            C01FILE    =  FILE;
            C01LIB     =  LIB;
            C01MBR     =  MBR;
            C01RCDL    =  RCDL;
            C01ACCTP   =  ACCTP;
            C01WHTEXT  =  WHTEXT;
            C01RCORDS  =  RCDS;
            C01POSN    =  '  ' ;
            C01WHNAME  =  WHNAME;

           ENDSR;
      /END-FREE

     P @S01PRC         E

       //###################################################//
       //###################################################//
       //###################################################//
      /space 3
     P @S01PRS         B

     D @S01PRS         PI

          //
          //
     D WRKRC           S              4S 0
     D FX              S              5S 0

      /FREE

          EXSR      @INZSR;

         //  Process the subfile
           EXSR      SFL;
           *IN03 = '1';
           RETURN;

       //--------------  SFL -------------------------------//
           BEGSR      SFL;
        //  Process the subfile

           FOR       WRKRC = 1 TO SFC01+1;
               CHAIN  WRKRC   S01;
                 IF        NOT %FOUND;
         //  Finished with the subfile
         //  RETURN TO REBUILD LEVEL
                    @LV = @LV -2;
                    LEAVE;
                 ENDIF;

         //     RIGHT ADJUST OPTION
               S01OPT  = @OPADJ(S01OPT);

         //    UPDATE SELECTIONS
               EXSR UPD;

           ENDFOR;

           ENDSR;
       //---------------------------------------------------//

       //--------------UPD ---------------------------------//
           BEGSR      UPD;

       // UPDATE FIELD NAMES AND SELECT FLAG
                 FX = %LOOKUP(S01SFLD :FLD);
                 CHAIN  FX  QWHDRFFD;
                 WHFLDE  =  S01WHFLD;

                 IF @OPADJ(S01OPT) = ' S' OR
                    @OPADJ(S01OPT) = ' O';
                     ALL    = %TRIM(S01OPT);
                     WHFIOB = %TRIM(S01OPT);
                 ENDIF;

                 IF @OPADJ(S01OPT) = ' ';
                     WHFIOB = ' ';
                 ENDIF;
                  UPDATE  QWHDRFFD;

           ENDSR;


       //--------------*INZSR-------------------------------//
           BEGSR     @INZSR;
               ALL   = '1';
               @NSCN = *BLANK;
           ENDSR;


      /END-FREE
     P @S01PRS         E

       //###################################################//
       //###################################################//
       //###################################################//

     P @R9999          B
        //  Invalid Panel
     D @R9999          PI

     P @R9999          E


      /space 3
       //###################################################//
       //###################################################//
       //###################################################//
     P @OPADJ          B
        //   RIGHT ADJ OPTION , zero suppress

     D @OPADJ          PI             2A
     D  OPT                           2A

      /FREE
         EVALR  OPT   = %trimr(OPT);
         If %SubSt(OPT:1:1) =  '0';
         OPT   = ' ' +  %SubSt(OPT:2:1);
         EndIf;
         RETURN OPT;
      /END-FREE
     P @OPADJ          E

       //###################################################//
       //###################################################//
       //###################################################//
     P  RtvMsgTxt      B
      //************************************************************************
      // API Call: QMHRTVM Retrieve Message text
      //************************************************************************


       // USAGE
       // MsgTxt = RtvMsgTxt('MSG0001':cMsgF3:cMsgLib:cMsgLvl1);

     D  RtvMsgTxt      PI          1024
     D   RMsgId                       7    Const
     D   RMsgFle                     10    Const
     D   RMsgLib                     10    Const
     D   RMsgLvl                      1    Const

      // Retrieve Message Description API Prototype
     D  Get_Message    PR                  ExtPgm('QMHRTVM')
     D                             4000    Options(*VarSize)
     D                               10I 0 Const
     D                                8    Const
     D                                7
     D                               20    Const
     D                            32765    Options(*VarSize)
     D                               10I 0 Const
     D                               10    Const
     D                               10    Const
     D                             8192    Options(*VarSize)
     D                               10
     D                                9B 0
     D                                9B 0

      // Define Variables for QMHRTVM API call:
      // --------------------------------------
      // Return variables
     D  MessageInfo    DS          4000
     D   Data                  1   4000
     D   OSMSG                65     68B 0
     D   LMsgR                69     72B 0
     D   LMsgA                73     76B 0
     D   OSMSGH               77     80B 0
     D   LMsgHR               81     84B 0
     D   LMsgHA               85     88B 0

      // Required input variables
     D   MessageLen    S             10I 0
     D   MessageForm   S              8
     D   MessageIden   S              7
     D   MessageFile   S             20
     D   Replacement   S          32765
     D   ReplaceLen    S             10I 0
     D   ReplaceSub    S             10
     D   ReturnCtl     S             10

     D   RetrieveOpt   S             10
     D   ConvToCCSID   S              9B 0
     D   ReplDtaCCSID  S              9B 0

     D   Return_Text   S           1024

     D  ErrorCode      DS                  Qualified
     D   BytesProv                    4B 0 Inz(0)
     D   BytesAvail                   8B 0 Inz(0)
     D   ExceptionId                  7
     D   Reserved                     1
     D   ExceptionDta               512
      /FREE

         // Load API parameter fields
         MessageInfo   = *blanks;
         MessageLen    = 4000;
         MessageForm   = 'RTVM0300';
         MessageIden   = RMsgId;
         MessageFile   = RMsgFle + RMsgLib;
         Replacement   = *blanks;
         ReplaceLen    = %Len(Replacement);
         ReplaceSub    = '*YES';
         ReturnCtl     = '*YES';
         RetrieveOpt   = '*MSGID';
         ConvToCCSID   = 0;
         ReplDtaCCSID  = 0;

         // Retrieve message description
         Get_Message(MessageInfo :
                     MessageLen  :
                     MessageForm :
                     MessageIden :
                     MessageFile :
                     Replacement :
                     ReplaceLen  :
                     ReplaceSub  :
                     ReturnCtl   :
                     ErrorCode   :
                     RetrieveOpt :
                     ConvToCCSID :
                     ReplDtaCCSID);

         // Process Return variables
         Return_Text = *blanks;

         // If no errors, determine the correct portion of the message text
         If ErrorCode.BytesProv = 0;
           Select;
           When RMsgLvl = '1';
               Return_Text = %Subst(data:OSMSG+1:LMsgA);   // Msg Lvl 1
           When RMsgLvl = '2';
               Return_Text = %Subst(data:OSMSGH+1:LMsgHA);   // Msg Lvl 2
           EndSl;
         Else;
           Return_Text = 'Get_Message failed.';
         EndIf;

         // Return to calling point
         Return Return_Text;

      /END-FREE
     P                 E


       //###################################################//
       //###################################################//
       //###################################################//
     P GETROWCOL       B
      *
      *    Retreive a DSPF FIELD  Row and Col
      *    Used for Setting  CSRLOC for cursor positioning
      *    USAGE
      *    GETROWCOL  (FILE :'*LIBL' : FORMAT : FLDNAM : ROW : COL)
      *
     D GETROWCOL       PR
     D   schFile                     10A   const
     D   schLib                      10A   const
     D   schFormat                   10A   const
     D   schString                   32A   const
     D   rtnROW                       3P 0
     D   RtnCOL                       3P 0

     D GETROWCOL       PI
     D   schFile                     10A   const
     D   schLib                      10A   const
     D   schFormat                   10A   const
     D   schString                   32A   const
     D   rtnROW                       3P 0
     D   RtnCOL                       3P 0

     D QUSCRTUS        PR                  ExtPgm('QUSCRTUS')
     D   UserSpace                   20A   CONST
     D   ExtAttrib                   10A   CONST
     D   InitialSize                 10I 0 CONST
     D   InitialVal                   1A   CONST
     D   PublicAuth                  10A   CONST
     D   Text                        50A   CONST
     D   Replace                     10A   CONST options(*nopass)
     D   ErrorCode                32767A   options(*varsize:*nopass)

     D QUSPTRUS        PR                  ExtPgm('QUSPTRUS')
     D   UserSpace                   20A   CONST
     D   Pointer                       *

     D QUSDLTUS        PR                  ExtPgm('QUSDLTUS')
     D   UserSpace                   20A   CONST
     D   ErrorCode                32767A   options(*varsize)

     D QUSLFLD         PR                  ExtPgm('QUSLFLD')
     D   UsrSpc                      20A   const
     D   Format                       8A   const
     D   QualFile                    20A   const
     D   RcdFmt                      10A   const
     D   UseOvrd                      1A   const
     D   ErrorCode                32767A   options(*nopass:*varsize)

     D ErrorCode       ds                  qualified
     D   BytesProv                   10I 0 inz(0)
     D   BytesAvail                  10I 0 inz(0)

     D ListHeader      ds                  based(p_ListHeader)
     d   ListOffset                  10I 0 overlay(ListHeader:125)
     d   EntryCount                  10I 0 overlay(ListHeader:133)
     d   EntrySize                   10I 0 overlay(ListHeader:137)

     D Field           ds                  based(p_Field)
     D                                     qualified
     D  Name                         10a
     D  FILLER                      438a
     d  DspRow                       10i 0
     d  DspCol                       10i 0

     D TEMPSPC         C                   'GETROWCOL QTEMP'

     D x               s             10I 0

      /free

                  rtnrow =    999;
                  rtnrow =    999;
           // --------------------------------------------------
           // Delete the user space if it exists (ignore errors)
           ErrorCode.BytesProv = %size(ErrorCode);
           QUSDLTUS( TEMPSPC: ErrorCode );
           ErrorCode.BytesProv = 0;

           // --------------------------------------------------
           // Create a new 128k user space
           QUSCRTUS( TEMPSPC : 'SCHTEXT' : 128 * 1024   : x'00'
                   : '*EXCLUDE' : 'List of fields in file' : '*NO'
                   : ErrorCode );

           // --------------------------------------------------
           // Dump list of fields in file to user space
           // Invaid data is ignored an 999 returned for row and col
           monitor;
           QUSLFLD( TEMPSPC : 'FLDL0100'  : SchFile + SchLib
                  : SchFormat  : *OFF  : ErrorCode );
               on-Error;
                 RETURN;
            EndMon;
           // --------------------------------------------------
           // Get a pointer to the user space
           QUSPTRUS( TEMPSPC: p_ListHeader );

           // --------------------------------------------------
           // Loop through all fields in space, to get the field we need
           for x = 0 to (EntryCount - 1);
               p_Field = p_ListHeader + ListOffset + (EntrySize * x);

               if Field.Name = schString;
                  rtnRow =    Field.DspRow;
                  rtnCol =    Field.DspCol;
                 leave;
               endif;
           endfor;

           // --------------------------------------------------
           // Delete temp user space & end
           QUSDLTUS( TEMPSPC: ErrorCode );

            return;

      /end-free
     P                 E

#top

DISPYF RPG


     A*%%TS  SD  20101203  131649  KOLMANNF    REL-V5R4M0  5722-WDS
     A*  90/01/08  12:52:36                REL-R01M02  5728-PW1
     A*            16:33:07                REL-R08M00  5714-UT1
     A*%%EC
     A                                      DSPSIZ(24 80 *DS3)
     A                                      REF(*LIBL/QADSPFFD)
     A                                      PRINT
     A                                      CA03(03 'End of job')
     A                                      CA12(12 'Previous')
     A                                      CA04(04 'Add FIELDS')
     A                                      CA05(05 'Attr changes')
     A                                      CF06(06 'Field Select')
     A                                      CA07(07 'Name changes')
     A*****
     A*            15:04:39                REL-R08M00  5714-UT1
     A          R S01                       SFL
     A*%%TS  SD  20101203  131649  KOLMANNF    REL-V5R4M0  5722-WDS
     A  40                                  SFLNXTCHG
     A            S01OPT         2A  B  7  2
     A            S01KEYFLD      2A  O  7  5DSPATR(HI)
     A            S01WHFLD  R        B  7  8REFFLD(WHFLDI)
     A  23                                  DSPATR(HI)
     A N23                                  DSPATR(PR)
     A            S01WHFLDB R        B  7 19REFFLD(WHFLDB)
     A                                      EDTCDE(Z)
     A  25                                  DSPATR(HI)
     A N25                                  DSPATR(PR)
     A            S01SIZE        6A  O  7 25
     A            S01FROM        4Y 0O  7 32EDTCDE(Z)
     A            S01TO          4Y 0O  7 37EDTCDE(Z)
     A            S01DESC       35A  O  7 44
     A            S01WHFLDT R        B  7 42REFFLD(WHFLDT)
     A  25                                  DSPATR(HI)
     A N25                                  DSPATR(PR)
     A            S01SFLD   R        H      REFFLD(WHFLDI)
     A*****
     A*
     A          R C01                       SFLCTL(S01)
     A*%%TS  SD  20101203  131649  KOLMANNF    REL-V5R4M0  5722-WDS
     A                                      SFLSIZ(0015)
     A                                      SFLPAG(0014)
     A  88                                  CSRLOC(ROW01      COL01)
     A                                      OVERLAY
     A                                      TEXT('WORK WITH FIELDS')
     A  51                                  SFLDSP
     A  52                                  SFLDSPCTL
     A  53                                  SFLCLR
     A  99                                  SFLEND
     A            SRS01          4S 0H      SFLRCDNBR(CURSOR)
     A*
     A  89        C01MSG        79   M
     A            ROW01          3S 0H
     A            COL01          3S 0H
     A                                  1  3'File'
     A            C01FILE       10A  O  1  8DSPATR(HI)
     A                                  1 20'Lib'
     A            C01LIB        10A  O  1 24DSPATR(HI)
     A                                  1 37'Mbr'
     A            C01MBR        10A  O  1 41DSPATR(HI)
     A                                  1 53'Rcdlen'
     A            C01RCDL        4S 0O  1 60DSPATR(HI)
     A                                  1 66'Access'
     A            C01ACCTP       1A  O  1 73DSPATR(HI)
     A                                  2  3'Text'
     A            C01WHTEXT R        O  2  9REFFLD(WHTEXT)
     A                                      DSPATR(HI)
     A                                  2 60'#Records'
     A            C01RCORDS      7Y 0O  2 69DSPATR(HI)
     A                                      EDTCDE(Z)
     A            C01POSN       10A  I  3  7
     A                                  4  2'Select/Omit (S/O) fields for displ-
     A                                      ay.(Default *ALL)'
     A                                  5 11'Use Select Or Omit,not Select with-
     A                                       Omit'
     A                                  6  8'Name       Bytes  Size  From  To T-
     A                                      p   Description'
     A                                  4 54'Format'
     A            C01WHNAME R        O  4 61REFFLD(QWHDRFFD/WHNAME)
     A                                      DSPATR(HI)
     A          R R01
     A                                 23  2'F3-Exit F6-Data Sel'

#top

DISPX DSPF

     A                                      DSPSIZ(24 80 *DS3)
     A                                      PRINT
     A                                      CF02(02 'return')
     A                                      CF03(01 'exit')
     A          R SLT
     A                                      OVERLAY
     A                                  1  2'Qryslt:'
     A            QSLT        1509A  B  1 12CHECK(LC)
     A                                 20  1'F2-Return '
     A          R SLTR                      SFL
     A                                      SFLMSGRCD(21)
     A            MSGKEY                    SFLMSGKEY
     A            PGMQ                      SFLPGMQ
     A          R SLTC                      SFLCTL(SLTR   )
     A                                      OVERLAY
     A                                      SFLSIZ(50) SFLPAG(3)
     A N20                                  SFLEND
     A N20                                  SFLDSP
     A N20                                  SFLDSPCTL
     A N20                                  SFLINZ
     A  20                                  SFLCLR
     A            PGMQ                      SFLPGMQ

#top

FFDL01 LF

     A          R QWHDRFFD                  PFILE(FFD)
                K WHFILE

#top


COMPILE CL

/* COMPILE OBJECTS                    */
/* CRTBNDCL   PGM(KOLMANN/COMPILE) SRCFILE(KOLMANN/UDDSSRC)     */
/*            SRCMBR(COMPILE) OUTPUT(*NONE) REPLACE(*YES)       */
/* call compile ('KOLMANN' 'UDDSSRC')                           */
PGM (&LIB &SRCF)

DCL &LIB  *CHAR  10
DCL &SRCF *CHAR  10

CRTDTAARA  DTAARA(&LIB/UDDSSRC) TYPE(*CHAR) LEN(10) +
   VALUE(&SRCF) TEXT('SOURCE LIBRARY FOR  UDDS PROGRAMS')
MONMSG CPF0000

dltf qtemp/afile
monmsg cpf0000
CRTPF      FILE(QTEMP/AFILE) RCDLEN(80) OPTION(*NOLIST)

CRTDSPF    FILE(&LIB/DISPF) SRCFILE(&LIB/&SRCF) +
                          SRCMBR(DISPF) OPTION(*NOLIST *NOSRC) +
                          REPLACE(*YES)


DSPFFD  FILE(QTEMP/AFILE) OUTPUT(*OUTFILE) OUTFILE(QTEMP/FFD)
DLTF   FILE(QTEMP/FFDL01)
MONMSG CPF0000
CRTLF FILE(QTEMP/FFDL01) SRCFILE(&LIB/&SRCF) SRCMBR(FFDL01) +
OPTION(*NOSRC *NOLIST)

DSPFFD  FILE(QTEMP/FFD) OUTPUT(*OUTFILE) OUTFILE(QTEMP/FFFFD)
DSPFD (QTEMP/FFD ) TYPE(*ACCPTH) OUTPUT(*OUTFILE) OUTFILE(QTEMP/KFFFD )
OVRDBF     FILE(KF) TOFILE(QTEMP/KFFFD)
CRTBNDCL   PGM(&LIB/DISF) SRCFILE(&LIB/&SRCF) +
        DBGVIEW(*SOURCE)  SRCMBR(DISF) OUTPUT(*NONE) REPLACE(*YES)
CRTBNDCL   PGM(&LIB/DISV) SRCFILE(&LIB/&SRCF) +
        DBGVIEW(*SOURCE)  SRCMBR(DISV) OUTPUT(*NONE) REPLACE(*YES)

 CRTBNDRPG  PGM(&LIB/DISPY) SRCFILE(&LIB/&SRCF) +
    SRCMBR(DISPY) DBGVIEW(*SOURCE) OUTPUT(*NONE) REPLACE(*YES)


DLTF   FILE(QTEMP/REL)
MONMSG CPF0000
DLTF   FILE(QTEMP/SEL)
MONMSG CPF0000
DLTF   FILE(QTEMP/DBR)
MONMSG CPF0000

DSPFD      FILE(QTEMP/FFD) TYPE(*ACCPTH) +
  OUTPUT(*OUTFILE) OUTFILE(QTEMP/REL) OUTMBR(*FIRST *ADD)
DSPFD FILE(QTEMP/FFDL01) TYPE(*SELECT) OUTPUT(*OUTFILE) OUTFILE(QTEMP/SEL)
CRTDSPF    FILE(&LIB/DISPRF) SRCFILE(&LIB/&SRCF) +
                          SRCMBR(DISPRF) OPTION(*NOLIST *NOSRC) +
                          REPLACE(*YES)

DSPDBR     FILE(QTEMP/FFD) OUTPUT(*OUTFILE) +
   OUTFILE(QTEMP/DBR) OUTMBR(*FIRST *REPLACE)

DLTF   FILE(QTEMP/ACC)
MONMSG CPF0000
DSPFD FILE(QTEMP/FFDL01) TYPE(*ACCPTH) OUTPUT(*OUTFILE) OUTFILE(QTEMP/ACC)

CRTBNDRPG  PGM(&LIB/DISP) SRCFILE(&LIB/&SRCF) +
  SRCMBR(DISP) DBGVIEW(*SOURCE) OUTPUT(*NONE) REPLACE(*YES)
CRTBNDRPG  PGM(&LIB/DISP1) SRCFILE(&LIB/&SRCF) +
  SRCMBR(DISP1) DBGVIEW(*SOURCE) OUTPUT(*NONE) REPLACE(*YES)
CRTBNDRPG  PGM(&LIB/DISP2) SRCFILE(&LIB/&SRCF) +
  SRCMBR(DISP2) DBGVIEW(*SOURCE) OUTPUT(*NONE) REPLACE(*YES)

CRTBNDRPG  PGM(&LIB/DUSP) SRCFILE(&LIB/&SRCF) +
  SRCMBR(DUSP) DBGVIEW(*SOURCE)                REPLACE(*YES)
CRTBNDRPG  PGM(&LIB/DUSP1) SRCFILE(&LIB/&SRCF) +
  SRCMBR(DUSP1) DBGVIEW(*SOURCE) OUTPUT(*NONE) REPLACE(*YES)
CRTBNDRPG  PGM(&LIB/DUSP2) SRCFILE(&LIB/&SRCF) +
  SRCMBR(DUSP2) DBGVIEW(*SOURCE) OUTPUT(*NONE) REPLACE(*YES)

CRTBNDCL   PGM(&LIB/DIS) SRCFILE(&LIB/&SRCF) +
      DBGVIEW(*SOURCE)    SRCMBR(DIS) OUTPUT(*NONE) REPLACE(*YES)
CRTBNDCL   PGM(&LIB/DIS3) SRCFILE(&LIB/&SRCF) +
      DBGVIEW(*SOURCE)    SRCMBR(DIS3) OUTPUT(*NONE) REPLACE(*YES)
CRTBNDCL   PGM(&LIB/DIS4) SRCFILE(&LIB/&SRCF) +
      DBGVIEW(*SOURCE)    SRCMBR(DIS4) OUTPUT(*NONE) REPLACE(*YES)
CRTBNDCL   PGM(&LIB/DISBIN) SRCFILE(&LIB/&SRCF) +
      DBGVIEW(*SOURCE)    SRCMBR(DISBIN) OUTPUT(*NONE) REPLACE(*YES)

CRTBNDRPG  PGM(&LIB/DISPR) SRCFILE(&LIB/&SRCF) +
    SRCMBR(DISPR) DBGVIEW(*SOURCE) OUTPUT(*NONE) REPLACE(*YES)

CRTCMD CMD(&LIB/DSPFL) PGM(*LIBL/DIS) SRCFILE(&LIB/&SRCF)  +
             SRCMBR(DSPFL) VLDCKR(DISV)

CRTDSPF    FILE(&LIB/DISPX) SRCFILE(&LIB/&SRCF) +
                          SRCMBR(DISPX) OPTION(*NOLIST *NOSRC) +
                          REPLACE(*YES)
CRTBNDCL   PGM(&LIB/DIS1) SRCFILE(&LIB/&SRCF) +
       DBGVIEW(*SOURCE)   SRCMBR(DIS1) OUTPUT(*NONE) REPLACE(*YES)



ENDPGM


#top

TESTPF PF

     A          R TESTR
     A            ACTIV          1A         TEXT('Active flag (0 - inactive, 1')
     A            CMPNO          3P         TEXT('Company number              ')
     A            PLTNO          2P         TEXT('Plant number                ')
     A            PRDNO         15A         TEXT('Product number              ')
     A            OPBAL         13P 3       TEXT('Opening balance - this perio')
     A            SERVU          5S 2       TEXT('Service level based on units')
     A            QTY            5B 2       TEXT('QTY')
     A            QTYF          17F 4       FLTPCN(*DOUBLE)
     A            CCYYMMDD        L         TEXT('DATE')
     A            HHMMSS          T         TEXT('TIME')
     A            DATTIM          Z         TEXT('DATE TIME')
     A            VTEXT        100A         VARLEN
     A                                      TEXT('VARIABLE TEXT')
     A            DESCP         30A         TEXT('Product description or name ')

     A          K ACTIV
     A          K CMPNO
     A          K PRDNO
     A          K OPBAL
     A          K SERVU

#top

TESTPF1 PF

     A          R TESTR
     A            ACTIV          1A         TEXT('Active flag (0 - inactive, 1')
     A            CMPNO          3P         TEXT('Company number              ')
     A            PLTNO          2P         TEXT('Plant number                ')
     A            PRDNO         15A         TEXT('Product number              ')
     A            OPBAL         13P 3       TEXT('Opening balance - this perio')
     A            SERVU          5S 2       TEXT('Service level based on units')
     A            QTY            5B 2       TEXT('QTY')
     A            QTYF          17F 4       FLTPCN(*DOUBLE)
     A            CCYYMMDD        L         TEXT('DATE')
     A            HHMMSS          T         TEXT('TIME')
     A            DATTIM          Z         TEXT('DATE TIME')
     A            VTEXT        100A         VARLEN
     A                                      TEXT('VARIABLE TEXT')
     A            DESCP         30A         TEXT('Product description or name ')
     A            TXT1         500A         TEXT('TXT1  ')
     A            TXT2         500A         TEXT('TXT2  ')
     A            TXT3         500A         TEXT('TXT3  ')
     A            TXT4         500A         TEXT('TXT4  ')
     A          K ACTIV
     A          K CMPNO
     A          K PRDNO
     A          K OPBAL
     A          K SERVU

#top

TESTPF2 PF


     A          R TESTR
     A            ACTIV          1A         TEXT('Active flag (0 - inactive, 1')
     A            CMPNO          3P         TEXT('Company number              ')
     A            PLTNO          2P         TEXT('Plant number                ')
     A            PRDNO         15A         TEXT('Product number              ')
     A            OPBAL         13P 3       TEXT('Opening balance - this perio')
     A            SERVU          5S 2       TEXT('Service level based on units')
     A            QTY            5B 2       TEXT('QTY')
     A            QTYF          17F 4       FLTPCN(*DOUBLE)
     A            CCYYMMDD        L         TEXT('DATE')
     A            HHMMSS          T         TEXT('TIME')
     A            DATTIM          Z         TEXT('DATE TIME')
     A            VTEXT        100A         VARLEN
     A                                      TEXT('VARIABLE TEXT')
     A            DESCP         30A         TEXT('Product description or name ')
     A            TXT1         500A         TEXT('TXT1  ')
     A            TXT2         500A         TEXT('TXT2  ')
     A            TXT3         500A         TEXT('TXT3  ')
     A            TXT4         500A         TEXT('TXT4  ')
     A            TXT5         500A         TEXT('TXT5  ')
     A            TXT6         500A         TEXT('TXT6  ')
     A            TXT7         500A         TEXT('TXT7  ')
     A            TXT8         500A         TEXT('TXT8  ')
     A          K ACTIV
     A          K CMPNO
     A          K PRDNO
     A          K OPBAL
     A          K SERVU


#top