Difference between revisions of "UDDS File Display/Update"

From MidrangeWiki
Jump to: navigation, search
(DISF CLE)
m (DIS1 CL files with NULL fields cant be processed)
 
(18 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]
  
Line 8: Line 8:
 
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 24: 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 993: 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 999: 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,009: 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,167: Line 1,177:
  
 
             ENDFOR;
 
             ENDFOR;
 +
          ENDIF;
  
 
             IF  %LEN(RU) > 5 AND %LEN(RU) < 250;
 
             IF  %LEN(RU) > 5 AND %LEN(RU) < 250;
Line 1,795: 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,813: 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,783: 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,789: 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,799: 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,957: Line 2,968:
  
 
             ENDFOR;
 
             ENDFOR;
 +
          ENDIF;
  
 
             IF  %LEN(RU) > 5 AND %LEN(RU) < 250;
 
             IF  %LEN(RU) > 5 AND %LEN(RU) < 250;
Line 3,585: Line 3,597:
 
**
 
**
 
0123456789ABCDEF
 
0123456789ABCDEF
 +
 
</pre>
 
</pre>
  
 
[[#top]]
 
[[#top]]
  
 
+
===DISP2 RPG===
===DISP2   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 )
 
     F*
 
     F*
 
     F*  LIMITED TO MAXIMUM FILE LENGTH OF 6080
 
     F*  LIMITED TO MAXIMUM FILE LENGTH OF 6080
+
 
 
     F*  REQUIRES FILE  QTEMP/FFD  TO COMPILE
 
     F*  REQUIRES FILE  QTEMP/FFD  TO COMPILE
 
     F*  use cmd DSPFFD  FILE(&LIB/&FILE) OUTPUT(*OUTFILE) OUTFILE(QTEMP/FFD)
 
     F*  use cmd 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 4,573: Line 4,584:
 
           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 4,579: Line 4,597:
 
             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 4,588: Line 4,608:
 
             IF WRTRRN = '1';
 
             IF WRTRRN = '1';
 
               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 4,747: Line 4,761:
  
 
             ENDFOR;
 
             ENDFOR;
 +
          ENDIF;
  
 
             IF  %LEN(RU) > 5 AND %LEN(RU) < 250;
 
             IF  %LEN(RU) > 5 AND %LEN(RU) < 250;
Line 5,380: Line 5,395:
 
[[#top]]
 
[[#top]]
  
===DUSP   RPG ===
+
===DUSP 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(DUSP )
 
     F*
 
     F*
 
     F*  LIMITED TO MAXIMUM FILE LENGTH OF 2048
 
     F*  LIMITED TO MAXIMUM FILE LENGTH OF 2048
 
     F*  REQUIRES FILE  QTEMP/FFD  TO COMPILE
 
     F*  REQUIRES FILE  QTEMP/FFD  TO COMPILE
 
     F*  use cmd DSPFFD  FILE(&LIB/&FILE) OUTPUT(*OUTFILE) OUTFILE(QTEMP/FFD)
 
     F*  use cmd 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 5,400: Line 5,415:
 
     FINPUTR    UF A F32766        DISK    EXTIND(*INU2)
 
     FINPUTR    UF A F32766        DISK    EXTIND(*INU2)
 
     F                                    INFDS(INFDR)
 
     F                                    INFDS(INFDR)
 +
 +
 +
    D DISBIN          PR                  extpgm('DISBIN')
 +
    D  NUM                          15P 0
 +
    D  BAN2                          2
 +
    D  BAN4                          4
 +
    D  BINTYP                        1    CONST
  
 
       *
 
       *
Line 5,486: Line 5,508:
 
     D NUPA                    1    60
 
     D NUPA                    1    60
 
     D NUP                    29    60P 0
 
     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 WRU            S            61
Line 5,880: Line 5,919:
 
     I                                644  723  ID8              27
 
     I                                644  723  ID8              27
 
     I                                724  803  ID9              28
 
     I                                724  803  ID9              28
 
+
DCL V
  
 
       /FREE
 
       /FREE
Line 6,090: Line 6,129:
 
       //  MOVE A KEY FIELDS DATA FROM ID ARRAY (SCREEN) TO K ARRAY (KEY FIELDS)
 
       //  MOVE A KEY FIELDS DATA FROM ID ARRAY (SCREEN) TO K ARRAY (KEY FIELDS)
  
      //  GET SIZE OF FIELD IN BYTES
+
            //  GET SIZE OF FIELD IN BYTES
           IF T(Y)  =  'A';  // ALPHA DATA
+
        SELECT;
 +
           WHEN  T(Y)  =  'A';  // ALPHA DATA
 
           K = ' ';
 
           K = ' ';
 
           K1 = 1;
 
           K1 = 1;
 
           K2 = Q(Y);
 
           K2 = Q(Y);
           ELSE;
+
           WHEN  T(Y)  =  'F';  // FLOAT
 +
          K  = '0';
 +
          K1 =  1;
 +
          K2 = L(Y);
 +
          OTHER;
 
           K  = '0';
 
           K  = '0';
 
           K1 =  1;
 
           K1 =  1;
 
           K2 = C(Y);
 
           K2 = C(Y);
          ENDIF;
+
        ENDSL;
 +
 
  
 
       // IF WHOLE KEY INIT WAS REQUESTED BYPASS THE EXTRACT
 
       // IF WHOLE KEY INIT WAS REQUESTED BYPASS THE EXTRACT
Line 6,408: Line 6,453:
 
           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 6,414: Line 6,465:
 
             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 6,424: Line 6,477:
 
               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 6,582: Line 6,629:
  
 
             ENDFOR;
 
             ENDFOR;
 +
          ENDIF;
  
 
             IF  %LEN(RU) > 5 AND %LEN(RU) < 250;
 
             IF  %LEN(RU) > 5 AND %LEN(RU) < 250;
Line 7,205: Line 7,253:
  
 
       //  GET SIZE OF FIELD IN BYTES
 
       //  GET SIZE OF FIELD IN BYTES
           IF T(Y)  =  'A';  // ALPHA DATA
+
        SELECT;
 +
           WHEN  T(Y)  =  'A';  // ALPHA DATA
 
           K = ' ';
 
           K = ' ';
 
           K1 = 1;
 
           K1 = 1;
 
           K2 = Q(Y);
 
           K2 = Q(Y);
           ELSE;
+
           WHEN  T(Y)  =  'F';  // FLOAT
 +
          K  = '0';
 +
          K1 =  1;
 +
          K2 = L(Y);
 +
          OTHER;
 
           K  = '0';
 
           K  = '0';
 
           K1 =  1;
 
           K1 =  1;
 
           K2 = C(Y);
 
           K2 = C(Y);
          ENDIF;
+
        ENDSL;
  
 
           X  =  1;
 
           X  =  1;
Line 7,284: Line 7,337:
 
         //  the data start is in S(Y)
 
         //  the data start is in S(Y)
 
         //  the data is in array K
 
         //  the data is in array K
         //  get the length of the data cvt to bin and stik in pos 1 2
+
         //  get the length of the data cvt to bin and stick in pos 1 2
 
         //  put the rest in pos 3 onwards
 
         //  put the rest in pos 3 onwards
  
Line 7,337: Line 7,390:
 
       //  BINARY FIELDS
 
       //  BINARY FIELDS
 
         IF  T(Y) =  'B';
 
         IF  T(Y) =  'B';
 +
 +
          NUSA= *BLANKS;
 +
          FOR VX = 1 TO 60;
 +
            NUSA = %TRIM(NUSA) + NU(VX);
 +
          ENDFOR;
 +
            NUC  = NUS;
  
 
         IF  Q(Y) = 2 ;
 
         IF  Q(Y) = 2 ;
          BY2 = NU(1) + NU(2);
+
              DISBIN ( NUC : BAN2 : BAN4  : '2');
          %SUBST(DATA : W : 2)  =  BY2;
+
            %SUBST(DATA : W : 2)  =  BAN2;
 
         ENDIF;
 
         ENDIF;
  
 
         IF  Q(Y) = 4 ;
 
         IF  Q(Y) = 4 ;
          BY4 = NU(1) + NU(2) + NU(3) + NU(4);
+
              DISBIN ( NUC : BAN2 : BAN4  : '4');
          %SUBST(DATA : W : 4)  =  BY4;
+
            %SUBST(DATA : W : 4)  =  BAN4;
 
         ENDIF;
 
         ENDIF;
  
 
         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
 
         //  UPDATE KEY IF NECESSARY
Line 7,668: Line 7,758:
 
**
 
**
 
0123456789ABCDEF
 
0123456789ABCDEF
 +
  
 
</pre>
 
</pre>
Line 7,673: Line 7,764:
 
[[#top]]
 
[[#top]]
  
===DUSP1   RPG ===
+
===DUSP1 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(DUSP1 )
 
     F*
 
     F*
 
     F*  LIMITED TO MAXIMUM FILE LENGTH OF 4080
 
     F*  LIMITED TO MAXIMUM FILE LENGTH OF 4080
 
     F*  REQUIRES FILE  QTEMP/FFD  TO COMPILE
 
     F*  REQUIRES FILE  QTEMP/FFD  TO COMPILE
 
     F*  use cmd DSPFFD  FILE(&LIB/&FILE) OUTPUT(*OUTFILE) OUTFILE(QTEMP/FFD)
 
     F*  use cmd 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 7,693: Line 7,784:
 
     FINPUTR    UF A F32766        DISK    EXTIND(*INU2)
 
     FINPUTR    UF A F32766        DISK    EXTIND(*INU2)
 
     F                                    INFDS(INFDR)
 
     F                                    INFDS(INFDR)
 +
 +
    D DISBIN          PR                  extpgm('DISBIN')
 +
    D  NUM                          15P 0
 +
    D  BAN2                          2
 +
    D  BAN4                          4
 +
    D  BINTYP                        1    CONST
  
 
       *
 
       *
Line 7,779: Line 7,876:
 
     D NUPA                    1    60
 
     D NUPA                    1    60
 
     D NUP                    29    60P 0
 
     D NUP                    29    60P 0
 +
 +
    D NUC            S            15P 0
 +
    D BAN2            S              2
 +
DCL  D BAN4            S              4
  
 
     D WRU            S            61
 
     D WRU            S            61
Line 7,817: Line 7,918:
  
 
     D                DS
 
     D                DS
 +
    D  DATA                  1  4080
 
     D  D                      1  4080
 
     D  D                      1  4080
 
     D                                    DIM(4080)                            INCOMING DATA
 
     D                                    DIM(4080)                            INCOMING DATA
Line 7,951: Line 8,053:
 
     D KEYLNA                  1      4
 
     D KEYLNA                  1      4
  
     DDUSP            PR
+
     DDUSP1            PR
 
     D                                1
 
     D                                1
 
     D                                1
 
     D                                1
Line 7,959: Line 8,061:
 
     D                                5
 
     D                                5
 
     D                              800
 
     D                              800
     DDUSP            PI
+
     DDUSP1            PI
 
     D  ALL                          1
 
     D  ALL                          1
 
     D  RTN                          1
 
     D  RTN                          1
Line 8,702: Line 8,804:
 
           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';
            WRTRRN = '1';
+
            WRTRRN = '1';
 
             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 8,718: Line 8,828:
 
               WRTRRN = '0';
 
               WRTRRN = '0';
 
               RU  = RU + SBA + RBA ;
 
               RU  = RU + SBA + RBA ;
              SELECT;
+
               RU = RU + %TRIM(%EDITC(RRN:'Z'));
                WHEN  *INU1;
+
             ENDIF;
                RRN = RN1;
 
                WHEN  *INU2;
 
                RRN = RN2;
 
              ENDSL;
 
               RU = RU + %TRIM(%EDITC(RRN:'Z'));
 
             ENDIF;
 
  
 
         // BUFFER ADDRESS
 
         // BUFFER ADDRESS
Line 8,876: Line 8,980:
  
 
             ENDFOR;
 
             ENDFOR;
 +
          ENDIF;
  
 
             IF  %LEN(RU) > 5 AND %LEN(RU) < 250;
 
             IF  %LEN(RU) > 5 AND %LEN(RU) < 250;
Line 9,631: Line 9,736:
 
       //  BINARY FIELDS
 
       //  BINARY FIELDS
 
         IF  T(Y) =  'B';
 
         IF  T(Y) =  'B';
 +
 +
          NUSA= *BLANKS;
 +
          FOR VX = 1 TO 60;
 +
            NUSA = %TRIM(NUSA) + NU(VX);
 +
          ENDFOR;
 +
            NUC  = NUS;
  
 
         IF  Q(Y) = 2 ;
 
         IF  Q(Y) = 2 ;
          BY2 = NU(1) + NU(2);
+
              DISBIN ( NUC : BAN2 : BAN4  : '2');
          %SUBST(DATA : W : 2)  =  BY2;
+
            %SUBST(DATA : W : 2)  =  BAN2;
 
         ENDIF;
 
         ENDIF;
  
 
         IF  Q(Y) = 4 ;
 
         IF  Q(Y) = 4 ;
          BY4 = NU(1) + NU(2) + NU(3) + NU(4);
+
              DISBIN ( NUC : BAN2 : BAN4  : '4');
          %SUBST(DATA : W : 4)  =  BY4;
+
            %SUBST(DATA : W : 4)  =  BAN4;
 
         ENDIF;
 
         ENDIF;
  
Line 9,666: Line 9,777:
  
 
     OINPUTK    E    U1      UPDATREC
 
     OINPUTK    E    U1      UPDATREC
     O                      DA                
+
     O                      DA
 
     O              30      DB
 
     O              30      DB
 
     O              31      DC
 
     O              31      DC
Line 9,732: Line 9,843:
 
     O              93      D6A
 
     O              93      D6A
 
     OINPUTR    E      U2  UPDATREC
 
     OINPUTR    E      U2  UPDATREC
     O                      DA                
+
     O                      DA
 
     O              30      DB
 
     O              30      DB
 
     O              31      DC
 
     O              31      DC
Line 9,799: Line 9,910:
  
 
     OINPUTK    EADD U1      ADDREC
 
     OINPUTK    EADD U1      ADDREC
     O                      DA                
+
     O                      DA
 
     O              30      DB
 
     O              30      DB
 
     O              31      DC
 
     O              31      DC
Line 9,865: Line 9,976:
 
     O              93      D6A
 
     O              93      D6A
 
     OINPUTR    EADD    U2  ADDREC
 
     OINPUTR    EADD    U2  ADDREC
     O                      DA                
+
     O                      DA
 
     O              30      DB
 
     O              30      DB
 
     O              31      DC
 
     O              31      DC
Line 9,962: Line 10,073:
 
**
 
**
 
0123456789ABCDEF
 
0123456789ABCDEF
 +
  
 
</pre>
 
</pre>
Line 9,967: Line 10,079:
 
[[#top]]
 
[[#top]]
  
===DUSP2   RPG ===
+
===DUSP2 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(DUSP2 )
 
     F*
 
     F*
 
     F*  LIMITED TO MAXIMUM FILE LENGTH OF 6080
 
     F*  LIMITED TO MAXIMUM FILE LENGTH OF 6080
 
     F*  REQUIRES FILE  QTEMP/FFD  TO COMPILE
 
     F*  REQUIRES FILE  QTEMP/FFD  TO COMPILE
 
     F*  use cmd DSPFFD  FILE(&LIB/&FILE) OUTPUT(*OUTFILE) OUTFILE(QTEMP/FFD)
 
     F*  use cmd 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 9,987: Line 10,099:
 
     FINPUTR    UF A F32766        DISK    EXTIND(*INU2)
 
     FINPUTR    UF A F32766        DISK    EXTIND(*INU2)
 
     F                                    INFDS(INFDR)
 
     F                                    INFDS(INFDR)
 +
 +
    D DISBIN          PR                  extpgm('DISBIN')
 +
    D  NUM                          15P 0
 +
    D  BAN2                          2
 +
    D  BAN4                          4
 +
    D  BINTYP                        1    CONST
  
 
       *
 
       *
Line 10,073: Line 10,191:
 
     D NUPA                    1    60
 
     D NUPA                    1    60
 
     D NUP                    29    60P 0
 
     D NUP                    29    60P 0
 +
 +
    D NUC            S            15P 0
 +
    D BAN2            S              2
 +
DCL  D BAN4            S              4
 +
  
 
     D WRU            S            61
 
     D WRU            S            61
Line 10,109: Line 10,232:
 
     D CRS            S              1    DIM(16) CTDATA PERRCD(16)
 
     D CRS            S              1    DIM(16) CTDATA PERRCD(16)
 
     D                DS
 
     D                DS
 +
    D  DATA                  1  6080
 
     D  D                      1  6080
 
     D  D                      1  6080
 
     D                                    DIM(6080)                            INCOMING DATA
 
     D                                    DIM(6080)                            INCOMING DATA
Line 10,243: Line 10,367:
 
     D KEYLNA                  1      4
 
     D KEYLNA                  1      4
  
     DDUSP            PR
+
     DDUSP2            PR
 
     D                                1
 
     D                                1
 
     D                                1
 
     D                                1
Line 10,251: Line 10,375:
 
     D                                5
 
     D                                5
 
     D                              800
 
     D                              800
     DDUSP            PI
+
     DDUSP2            PI
 
     D  ALL                          1
 
     D  ALL                          1
 
     D  RTN                          1
 
     D  RTN                          1
Line 10,995: Line 11,119:
 
           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 11,001: Line 11,131:
 
             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 11,011: Line 11,143:
 
               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 11,169: Line 11,295:
  
 
             ENDFOR;
 
             ENDFOR;
 +
          ENDIF;
  
 
             IF  %LEN(RU) > 5 AND %LEN(RU) < 250;
 
             IF  %LEN(RU) > 5 AND %LEN(RU) < 250;
Line 11,924: Line 12,051:
 
       //  BINARY FIELDS
 
       //  BINARY FIELDS
 
         IF  T(Y) =  'B';
 
         IF  T(Y) =  'B';
 +
 +
        NUSA= *BLANKS;
 +
          FOR VX = 1 TO 60;
 +
            NUSA = %TRIM(NUSA) + NU(VX);
 +
          ENDFOR;
 +
            NUC  = NUS;
  
 
         IF  Q(Y) = 2 ;
 
         IF  Q(Y) = 2 ;
          BY2 = NU(1) + NU(2);
+
              DISBIN ( NUC : BAN2 : BAN4  : '2');
          %SUBST(DATA : W : 2)  =  BY2;
+
            %SUBST(DATA : W : 2)  =  BAN2;
 
         ENDIF;
 
         ENDIF;
  
 
         IF  Q(Y) = 4 ;
 
         IF  Q(Y) = 4 ;
          BY4 = NU(1) + NU(2) + NU(3) + NU(4);
+
              DISBIN ( NUC : BAN2 : BAN4  : '4');
          %SUBST(DATA : W : 4)  =  BY4;
+
            %SUBST(DATA : W : 4)  =  BAN4;
 
         ENDIF;
 
         ENDIF;
  
Line 11,959: Line 12,092:
  
 
     OINPUTK    E    U1      UPDATREC
 
     OINPUTK    E    U1      UPDATREC
     O                      DA                
+
     O                      DA
 
     O              30      DB
 
     O              30      DB
 
     O              31      DC
 
     O              31      DC
Line 12,025: Line 12,158:
 
     O              93      D6A
 
     O              93      D6A
 
     OINPUTR    E      U2  UPDATREC
 
     OINPUTR    E      U2  UPDATREC
     O                      DA                
+
     O                      DA
 
     O              30      DB
 
     O              30      DB
 
     O              31      DC
 
     O              31      DC
Line 12,092: Line 12,225:
  
 
     OINPUTK    EADD U1      ADDREC
 
     OINPUTK    EADD U1      ADDREC
     O                      DA                
+
     O                      DA
 
     O              30      DB
 
     O              30      DB
 
     O              31      DC
 
     O              31      DC
Line 12,158: Line 12,291:
 
     O              93      D6A
 
     O              93      D6A
 
     OINPUTR    EADD    U2  ADDREC
 
     OINPUTR    EADD    U2  ADDREC
     O                      DA                
+
     O                      DA
 
     O              30      DB
 
     O              30      DB
 
     O              31      DC
 
     O              31      DC
Line 12,255: Line 12,388:
 
**
 
**
 
0123456789ABCDEF
 
0123456789ABCDEF
 +
  
 
</pre>
 
</pre>
  
 
[[#top]]
 
[[#top]]
 +
  
 
===DISPF  DSPF ===
 
===DISPF  DSPF ===
Line 12,278: Line 12,413:
 
== WRAPPER CODE ==
 
== WRAPPER CODE ==
  
===DSPFF   CMD ===
+
===DSPFL   CMD ===
  
 
<pre>
 
<pre>
 
   /*  TO COMPILE */
 
   /*  TO COMPILE */
   /*  CRTCMD CMD(*CURLIB/DSPFF) PGM(*LIBL/DIS) SRCFILE(*LIBL/QCMDSRC) */
+
   /*  CRTCMD CMD(*CURLIB/DSPFL) PGM(*LIBL/DIS) SRCFILE(*LIBL/QCMDSRC) */
   /*          SRCMBR(DSPFF) VLDCKR(DISV) */
+
   /*          SRCMBR(DSPFL) VLDCKR(DISV) */
 
    
 
    
 
             CMD        PROMPT('Display file in field format')
 
             CMD        PROMPT('Display file in field format')
Line 12,317: Line 12,452:
 
[[#top]]
 
[[#top]]
  
===DIS    CLE ===
+
===DIS    CL ===
  
 
<pre>
 
<pre>
 +
 
/* Command processing program for DSPFF command */
 
/* Command processing program for DSPFF command */
  
Line 12,423: Line 12,559:
 
[[#top]]
 
[[#top]]
  
===DIS1   CLE ===
+
===DIS1   CL ===
  
 
<pre>
 
<pre>
 
 
/* CALLED BY DIS TO DRIVE SELECTION OF UDDS RPG PROGRAM */
 
/* CALLED BY DIS TO DRIVE SELECTION OF UDDS RPG PROGRAM */
 
/*  FILE DISPLAYER DRIVER  */
 
/*  FILE DISPLAYER DRIVER  */
Line 12,433: Line 12,568:
 
/*  WHEN ALL THE FIELDS DONT FIT ON ONE SCREEN                */
 
/*  WHEN ALL THE FIELDS DONT FIT ON ONE SCREEN                */
 
/*  THIS CONTAINS A LOOP SO THAT MORE FIELDS CAN BE DISPLAYED  */
 
/*  THIS CONTAINS A LOOP SO THAT MORE FIELDS CAN BE DISPLAYED  */
/* 
+
 
  
 
PGM (&FILIB  &MBR &UPD &RST &RTN &FILE &LIB &FILEF &FILEK)
 
PGM (&FILIB  &MBR &UPD &RST &RTN &FILE &LIB &FILEF &FILEK)
Line 12,462: Line 12,597:
 
DCL &SCNLVL *CHAR  5
 
DCL &SCNLVL *CHAR  5
 
DCL &SCNKEY *CHAR  800
 
DCL &SCNKEY *CHAR  800
DCL &ML    *CHAR  10
+
DCL &JOB  *CHAR  10
 
DCL &MSG  *CHAR  80
 
DCL &MSG  *CHAR  80
 
DCLF    DISPX
 
DCLF    DISPX
Line 12,476: Line 12,611:
 
OVRDBF  INPUT  &LIB/&FILE  SHARE(*NO)
 
OVRDBF  INPUT  &LIB/&FILE  SHARE(*NO)
 
CALL  DISPY    (&ALL &RTN &KEYL &ACCP &QRY &RCDL)
 
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
 
DLTOVR  INPUT
 
MONMSG CPF0000
 
MONMSG CPF0000
Line 12,576: Line 12,720:
 
[[#top]]
 
[[#top]]
  
===DIS3   CLE ===
+
===DIS3   CL ===
  
 
<pre>
 
<pre>
Line 12,590: Line 12,734:
 
DCL &SFILE  *CHAR  10
 
DCL &SFILE  *CHAR  10
 
DCL &SLIB  *CHAR  10
 
DCL &SLIB  *CHAR  10
DCL &LIB  *CHAR  10    'KOLMANNF '
+
 
  
 
DCLF QTEMP/DBR
 
DCLF QTEMP/DBR
  
 +
/* CREATE WORK FILES */
 +
CALL  DIS4
  
 
DLTF QTEMP/DBR
 
DLTF QTEMP/DBR
 
MONMSG CPF0000
 
MONMSG CPF0000
CLRPFM QTEMP/REL
 
MONMSG CPF0000 EXEC(DO)
 
CRTDUPOBJ  OBJ(QADSPDBR) FROMLIB(&LIB) +
 
      OBJTYPE(*FILE) TOLIB(QTEMP) NEWOBJ(REL)
 
MONMSG CPF0000
 
ENDDO
 
 
CLRPFM QTEMP/SEL
 
MONMSG CPF0000 EXEC(DO)
 
CRTDUPOBJ  OBJ(QAFDSELO) FROMLIB(&LIB) +
 
            OBJTYPE(*FILE) TOLIB(QTEMP) NEWOBJ(SEL)
 
MONMSG CPF0000
 
ENDDO
 
  
 
  DSPDBR    FILE(&PHYLIB/&PHY) OUTPUT(*OUTFILE) +
 
  DSPDBR    FILE(&PHYLIB/&PHY) OUTPUT(*OUTFILE) +
Line 12,646: Line 12,779:
 
[[#top]]
 
[[#top]]
  
===DISV  CLE ===
+
===DIS4    CL ===
  
 
<pre>
 
<pre>
  
/* VALIDITY CHECKER FOR DSPFF COMMAND */
+
/* CALL BY DIS3 TO CREATE WORK FILES */
  
 +
PGM
  
PGM (&FILIB  &MBR &UPD &RST &REL)
+
DCL  &LIB *CHAR 10
 +
DCL  &SRCF *CHAR 10
 +
 
 +
RTVDTAARA DTAARA(UDDSSRC *ALL)  RTNVAR(&SRCF)
  
DCL &FILIB *CHAR 20
+
DLTF QTEMP/XXXXFILE
DCL &FILE *CHAR  10
+
monmsg cpf0000
DCL &LIB  *CHAR  10
+
CRTPF      FILE(QTEMP/XXXXFILE) RCDLEN(80) OPTION(*NOLIST)
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
+
DSPFFD  FILE(QTEMP/XXXXFILE) OUTPUT(*OUTFILE) OUTFILE(QTEMP/FFD)
DCL &ERROR *LGL
+
CLRPFM QTEMP/FFD
 +
DLTF  FILE(QTEMP/FFDL01)
 +
MONMSG CPF0000
  
CHGVAR &FILE  &FILIB
+
RTVMBRD FILE(&SRCF) RTNLIB(&LIB)
CHGVAR &LIB  (%SST(&FILIB 11 10))
+
CRTLF FILE(QTEMP/FFDL01) SRCFILE(&LIB/&SRCF) SRCMBR(FFDL01) +
IF (&MBR *EQ '*FILE') (CHGVAR &MBR  &FILE )
+
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)
  
CHGVAR &AUT '*READ  '
+
DLTF  QTEMP/XXXXFILE
IF ((&UPD *EQ 'Y') *OR (&UPD *EQ 'y')) (CHGVAR &AUT '*CHANGE')
+
monmsg cpf0000
  
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
 
  
 +
ENDPGM
  
IF (*NOT &ERROR) DO
+
</pre>
  
RTVOBJD    OBJ(&LIB/&FILE) OBJTYPE(*FILE) OBJATR(&OBJATR)
+
[[#top]]
CHGVAR &AUT '*READ  '
 
IF ((&UPD *EQ 'Y') *OR (&UPD *EQ 'y')) (CHGVAR &AUT '*CHANGE')
 
  
CHKOBJ    OBJ(&LIB/&FILE) OBJTYPE(*FILE) MBR(&MBR) +
+
===DISBIN    CL ===
                          AUT(&AUT)
 
  
  MONMSG (CPF9815 )  EXEC(DO)
+
<pre>
/*  CHGVAR (&MSGDTA) VALUE('    '||&MBR||&FILE||&LIB)              */
+
/* NUMERIC TO BINARY CONVERTER */
/*  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))
 
  
 +
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
 
ENDPGM
  
Line 12,731: Line 12,850:
 
[[#top]]
 
[[#top]]
  
===DISF   CLE ===
+
===DISF   CL ===
  
 
<pre>
 
<pre>
Line 12,763: Line 12,882:
 
[[#top]]
 
[[#top]]
  
===DISPR  RPG ===
 
  
<pre>
 
  
</pre>
+
===DISV    CL ===
 
 
[[#top]]
 
 
 
===DISPRF  DSPF ===
 
  
 
<pre>
 
<pre>
 +
/* VALIDITY CHECKER FOR DSPFL COMMAND */
  
</pre>
 
  
[[#top]]
+
PGM (&FILIB  &MBR &UPD &RST &REL)
 
+
 
===DISPY   RPG ===
+
DCL &FILIB  *CHAR 20
 
+
DCL &FILE *CHAR  10
<pre>
+
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>
 
</pre>
Line 12,787: Line 12,968:
 
[[#top]]
 
[[#top]]
  
===DISPYF   DSPF ===
+
 
 +
===DISPR   RPG ===
  
 
<pre>
 
<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>
 
</pre>
  
 
[[#top]]
 
[[#top]]

Latest revision as of 17: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(&