Difference between revisions of "UDDS File Display/Update"

From MidrangeWiki
Jump to: navigation, search
m (DUSP2 RPG)
(BUG FIXES AND A MAKE/COMPILE CL)
Line 16: Line 16:
  
 
Once compiled the command to run it is  'DSPFL  yourlib/yourfile '
 
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 998: Line 999:
 
           BEGSR  @PUTF;
 
           BEGSR  @PUTF;
  
         // WRITE DATA TO THE DISPLAY
+
              SELECT;
 +
                WHEN  *INU1;
 +
                RRN = RN1;
 +
                WHEN  *INU2;
 +
                RRN = RN2;
 +
              ENDSL;
 +
 
 +
         // IF GOT RECORDS WRITE DATA TO THE DISPLAY
  
 
             NEWRU  = '1';
 
             NEWRU  = '1';
Line 1,004: Line 1,012:
 
             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,014: Line 1,024:
 
               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,172: Line 1,176:
  
 
             ENDFOR;
 
             ENDFOR;
 +
          ENDIF;
  
 
             IF  %LEN(RU) > 5 AND %LEN(RU) < 250;
 
             IF  %LEN(RU) > 5 AND %LEN(RU) < 250;
Line 1,800: Line 1,805:
 
**
 
**
 
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 2,790: Line 2,791:
 
           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,796: Line 2,803:
 
             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,806: Line 2,815:
 
               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,964: Line 2,967:
  
 
             ENDFOR;
 
             ENDFOR;
 +
          ENDIF;
  
 
             IF  %LEN(RU) > 5 AND %LEN(RU) < 250;
 
             IF  %LEN(RU) > 5 AND %LEN(RU) < 250;
Line 3,592: Line 3,596:
 
**
 
**
 
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,579: Line 4,583:
 
           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,585: Line 4,596:
 
             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,594: Line 4,607:
 
             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,753: Line 4,760:
  
 
             ENDFOR;
 
             ENDFOR;
 +
          ENDIF;
  
 
             IF  %LEN(RU) > 5 AND %LEN(RU) < 250;
 
             IF  %LEN(RU) > 5 AND %LEN(RU) < 250;
Line 5,386: Line 5,394:
 
[[#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,406: Line 5,414:
 
     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,492: Line 5,507:
 
     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,886: Line 5,918:
 
     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,096: Line 6,128:
 
       //  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,414: Line 6,452:
 
           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,420: Line 6,464:
 
             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,430: Line 6,476:
 
               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,588: Line 6,628:
  
 
             ENDFOR;
 
             ENDFOR;
 +
          ENDIF;
  
 
             IF  %LEN(RU) > 5 AND %LEN(RU) < 250;
 
             IF  %LEN(RU) > 5 AND %LEN(RU) < 250;
Line 7,211: Line 7,252:
  
 
       //  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,290: Line 7,336:
 
         //  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,343: Line 7,389:
 
       //  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,674: Line 7,757:
 
**
 
**
 
0123456789ABCDEF
 
0123456789ABCDEF
 +
  
 
</pre>
 
</pre>
Line 7,679: Line 7,763:
 
[[#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,699: Line 7,783:
 
     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,785: Line 7,875:
 
     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 8,709: Line 8,803:
 
           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,725: Line 8,827:
 
               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 8,883: Line 8,979:
  
 
             ENDFOR;
 
             ENDFOR;
 +
          ENDIF;
  
 
             IF  %LEN(RU) > 5 AND %LEN(RU) < 250;
 
             IF  %LEN(RU) > 5 AND %LEN(RU) < 250;
Line 9,638: Line 9,735:
 
       //  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,673: Line 9,776:
  
 
     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,739: Line 9,842:
 
     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,806: Line 9,909:
  
 
     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,872: Line 9,975:
 
     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,969: Line 10,072:
 
**
 
**
 
0123456789ABCDEF
 
0123456789ABCDEF
 +
  
 
</pre>
 
</pre>
Line 9,974: Line 10,078:
 
[[#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,994: Line 10,098:
 
     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,080: Line 10,190:
 
     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 11,003: Line 11,118:
 
           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,009: Line 11,130:
 
             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,019: Line 11,142:
 
               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,177: Line 11,294:
  
 
             ENDFOR;
 
             ENDFOR;
 +
          ENDIF;
  
 
             IF  %LEN(RU) > 5 AND %LEN(RU) < 250;
 
             IF  %LEN(RU) > 5 AND %LEN(RU) < 250;
Line 11,932: Line 12,050:
 
       //  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,967: Line 12,091:
  
 
     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,033: Line 12,157:
 
     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,100: Line 12,224:
  
 
     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,166: Line 12,290:
 
     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,263: Line 12,387:
 
**
 
**
 
0123456789ABCDEF
 
0123456789ABCDEF
 +
  
 
</pre>
 
</pre>
  
 
[[#top]]
 
[[#top]]
 +
  
 
===DISPF  DSPF ===
 
===DISPF  DSPF ===
Line 12,325: Line 12,451:
 
[[#top]]
 
[[#top]]
  
===DIS    CLE ===
+
===DIS    CL ===
  
 
<pre>
 
<pre>
 +
 
/* Command processing program for DSPFF command */
 
/* Command processing program for DSPFF command */
  
Line 12,431: Line 12,558:
 
[[#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,441: Line 12,567:
 
/*  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,584: Line 12,710:
 
[[#top]]
 
[[#top]]
  
===DIS3   CLE ===
+
===DIS3   CL ===
  
 
<pre>
 
<pre>
Line 12,598: Line 12,724:
 
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,654: Line 12,769:
 
[[#top]]
 
[[#top]]
  
===DISV  CLE ===
+
===DIS4    CL ===
  
 
<pre>
 
<pre>
  
/* VALIDITY CHECKER FOR DSPFL COMMAND */
+
/* CALL BY DIS3 TO CREATE WORK FILES */
 +
 
 +
PGM
 +
 
 +
DCL  &LIB *CHAR 10
 +
DCL  &SRCF *CHAR 10
 +
 
 +
RTVDTAARA DTAARA(UDDSSRC *ALL)  RTNVAR(&SRCF)
 +
 
 +
DLTF  QTEMP/XXXXFILE
 +
monmsg cpf0000
 +
CRTPF      FILE(QTEMP/XXXXFILE) RCDLEN(80) OPTION(*NOLIST)
 +
 
 +
DSPFFD  FILE(QTEMP/XXXXFILE) OUTPUT(*OUTFILE) OUTFILE(QTEMP/FFD)
 +
CLRPFM  QTEMP/FFD
 +
DLTF  FILE(QTEMP/FFDL01)
 +
MONMSG CPF0000
 +
 
 +
RTVMBRD FILE(&SRCF) RTNLIB(&LIB)
 +
CRTLF FILE(QTEMP/FFDL01) SRCFILE(&LIB/&SRCF) SRCMBR(FFDL01) +
 +
OPTION(*NOSRC *NOLIST)
  
 +
DLTF  FILE(QTEMP/REL)
 +
MONMSG CPF0000
 +
DLTF  FILE(QTEMP/SEL)
 +
MONMSG CPF0000
 +
DLTF  FILE(QTEMP/DBR)
 +
MONMSG CPF0000
  
PGM (&FILIB   &MBR &UPD &RST &REL)
+
DSPFD      FILE(QTEMP/FFD) TYPE(*ACCPTH) +
 +
   OUTPUT(*OUTFILE) OUTFILE(QTEMP/REL) OUTMBR(*FIRST *ADD)
  
DCL &FILIB  *CHAR 20
+
DSPFD FILE(QTEMP/FFDL01) TYPE(*SELECT) OUTPUT(*OUTFILE) OUTFILE(QTEMP/SEL)
DCL &FILE *CHAR  10
+
CLRPFM FILE(QTEMP/REL)
DCL &LIB  *CHAR  10
+
CLRPFM FILE(QTEMP/SEL)
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
+
DLTF  QTEMP/XXXXFILE
DCL &ERROR  *LGL
+
monmsg cpf0000
  
CHGVAR &FILE  &FILIB
 
CHGVAR &LIB  (%SST(&FILIB 11 10))
 
IF (&MBR *EQ '*FILE') (CHGVAR &MBR  &FILE  )
 
  
CHGVAR &AUT '*READ  '
+
ENDPGM
IF ((&UPD *EQ 'Y') *OR (&UPD *EQ 'y')) (CHGVAR &AUT '*CHANGE')
 
  
CHKOBJ  (&LIB/&FILE) OBJTYPE(*FILE) MBR(*NONE)  +
+
</pre>
  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
 
  
 +
[[#top]]
  
IF (*NOT &ERROR) DO
+
===DISBIN    CL ===
  
RTVOBJD    OBJ(&LIB/&FILE) OBJTYPE(*FILE) OBJATR(&OBJATR)
+
<pre>
CHGVAR &AUT '*READ  '
+
/* NUMERIC TO BINARY CONVERTER  */
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))
 
  
 +
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,739: Line 12,840:
 
[[#top]]
 
[[#top]]
  
===DISF   CLE ===
+
===DISF   CL ===
  
 
<pre>
 
<pre>
Line 12,771: Line 12,872:
 
[[#top]]
 
[[#top]]
  
===DISPR  RPG ===
 
  
<pre>
 
    H OPTIMIZE(*NONE) OPTION(*NODEBUGIO)
 
    H DFTACTGRP(*NO) ACTGRP(*CALLER)
 
  
      *   FILE RELATIONS DISPLAYER
+
===DISV   CL ===
      * 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)
 
      *
 
  
    FREL      IF  E            DISK
+
<pre>
    FSEL      IF  E            DISK
+
/* VALIDITY CHECKER FOR DSPFL COMMAND */
    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
+
PGM (&FILIB   &MBR &UPD &RST &REL)
    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
 
  
 +
DCL &FILIB  *CHAR 20
 +
DCL &FILE *CHAR  10
 +
DCL &LIB  *CHAR  10
 +
DCL &MBR  *CHAR  10
 +
DCL &UPD  *CHAR  1
 +
DCL &RST  *CHAR  1
 +
DCL &REL  *CHAR  1
 +
DCL &OBJATR *CHAR 10
 +
DCL &AUT    *CHAR  8
  
    D @TRUE          S              1A  INZ('1')
+
DCL &MSGDTA *CHAR 40
    D @FALSE          S              1A  INZ('0')
+
DCL &ERROR  *LGL
    D @OK            S                  LIKE(@TRUE)
 
    D @LOOP          S                  LIKE(@TRUE)
 
  
      //
+
CHGVAR &FILE  &FILIB
    D RS01            S              4S 0
+
CHGVAR &LIB  (%SST(&FILIB 11 10))
    D RS02            S              4S 0
+
IF (&MBR *EQ '*FILE') (CHGVAR &MBR  &FILE  )
      //
 
      // PARMS FOR SFL LOOPING
 
    D SFC01          S                  LIKE(RS01)
 
    D SFC02          S                  LIKE(RS01)
 
  
      // Program Status
+
CHGVAR &AUT '*READ  '
    D                SDS
+
IF ((&UPD *EQ 'Y') *OR (&UPD *EQ 'y')) (CHGVAR &AUT '*CHANGE')
    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
+
CHKOBJ  (&LIB/&FILE) OBJTYPE(*FILE) MBR(*NONE)  +
    D @DTA1          DS           80
+
  AUT( &AUT  )
    D @DTA2          DS          500
+
  MONMSG (CPF9899 CPF9801 CPF9802  CPF9820 CPF9830) EXEC(DO)
      //
+
/* CHGVAR (&MSGDTA) VALUE('    '||&FILE||&LIB)                  */
    D MAIN           PR
+
/*  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
  
    D @S01BLD        PR
 
    D @S01PRC        PR
 
    D @S01PRS        PR
 
    D @S02BLD        PR
 
    D @S02PRC        PR
 
    D
 
    D @R9999          PR
 
  
    D @OPADJ          PR            2A
+
IF (*NOT &ERROR) DO
    D  OPT                          2A
 
  
 +
RTVOBJD    OBJ(&LIB/&FILE) OBJTYPE(*FILE) OBJATR(&OBJATR)
 +
CHGVAR &AUT '*READ  '
 +
IF ((&UPD *EQ 'Y') *OR (&UPD *EQ 'y')) (CHGVAR &AUT '*CHANGE')
  
      /FREE
+
CHKOBJ    OBJ(&LIB/&FILE) OBJTYPE(*FILE) MBR(&MBR) +
            *INLR = *ON;
+
                          AUT(&AUT)
            MAIN();
 
  
 +
  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
  
      //--------------*INZSR-------------------------------//
+
IF (&ERROR)   (SNDPGMMSG MSGID(CPF0002) MSGF(QCPFMSG) MSGTYPE(*ESCAPE))
          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
 
      //###################################################//
 
  
        //*************************************************************
+
ENDPGM
    P    MAIN        B
 
  
    D MAIN            PI
+
</pre>
  
    D I              S              4B 0
+
[[#top]]
  
      /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
+
===DISPR  RPG ===
          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
+
<pre>
          IF  *IN03 = *ON;
+
    H OPTIMIZE(*NONE) OPTION(*NODEBUGIO)
            LEAVE;
+
    H DFTACTGRP(*NO) ACTGRP(*CALLER)
          ENDIF;
 
  
      //  CF12 PREVIOUS
+
      *    FILE RELATIONS DISPLAYER
          IF  *IN12 = *ON;
+
      * REQUIRES FILES TO COMPILE
              *IN12 = *OFF;
+
      *
              @LV  = @LV -1;
 
              @NSCN = @SCN(@LV);
 
          ENDIF;
 
  
      //  Backed out to last level, Exit
+
    FREL      IF  E            DISK
          IF     @NSCN = '*END';
+
    FSEL      IF   E            DISK
                  LEAVE;
+
    FDISPRF    CF  E            WORKSTN
          ENDIF;
+
    F                                    SFILE(S01:RS01)
 +
    F                                    SFILE(S02:RS02)
 +
    F                                    INFDS(SFINF)
 +
      *
  
        ENDDO;
+
      *
 +
    DDISPR            PR
 +
    D                              10
 +
    D                              10
 +
    DDISPR            PI
 +
    D  SFILE                        10
 +
    D  SLIB                        10
  
         RETURN;
+
      //  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
  
      //--------------*INZSR-------------------------------//
 
          BEGSR  @INZSR;
 
              @NSCN = *BLANK;
 
  
           ENDSR;
+
    D @TRUE           S              1A  INZ('1')
      //-ENDSR---*INZSR-------------------------------//
+
    D @FALSE          S              1A  INZ('0')
      /END-FREE
+
    D @OK            S                  LIKE(@TRUE)
 +
    D @LOOP          S                  LIKE(@TRUE)
  
     P    MAIN        E
+
      //
 +
     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
       /space 3
+
       //
     P @S01BLD        B
+
     D MAIN            PR
  
     D @S01BLD        PI
+
     D @S01BLD        PR
 +
    D @S01PRC        PR
 +
    D @S01PRS        PR
 +
    D @S02BLD        PR
 +
    D @S02PRC        PR
 +
    D
 +
    D @R9999          PR
  
     D WFILE          S                  LIKE(APFILE )
+
     D @OPADJ          PR            2A
     D WLIB            S                  LIKE(APLIB )
+
     D  OPT                          2A
  
          //  Build/Rebuild the subfile
 
  
 
       /FREE
 
       /FREE
          EXSR      @INZSR;
+
            *INLR = *ON;
 +
            MAIN();
  
          EXSR      BLD;
 
  
        // SFL IS BUILT, PROCESS THE SFL CONTROL
+
      //--------------*INZSR-------------------------------//
           @LV = @LV + 1;
+
           BEGSR  *INZSR;
          @SCN(@LV) = 'S01PRC ' ;
 
            RETURN ;
 
  
      //-------------- BLD -------------------------------//
+
        //  Set the TOP level (Exit if user backs up to here)
          BEGSR    BLD;
+
              @LV = 1;
 +
              @SCN(@LV)  = '*END  ';
 +
        // Set the Initial Screen to display
 +
              @LV = @LV + 1;
 +
              @SCN(@LV) = 'S01BLD ';
  
             EXSR      CLR;
+
             ENDSR;
 +
      /END-FREE
 +
      //###################################################//
  
 +
        //*************************************************************
 +
    P    MAIN        B
  
          SETLL 1    QWHFDACP;
+
    D MAIN            PI
  
          DOW @LOOP = @LOOP;
+
     D I              S              4B 0
          READ     QWHFDACP;
 
          IF %EOF;
 
          LEAVE;
 
          ENDIF;
 
  
 +
      /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
  
           EXSR MOV;
+
        // SFL TO SELECT THE FILE FIELDS
          //
+
          WHEN      @NSCN = 'S01BLD';
          RS01  = RS01 + 1;
+
                            @S01BLD();
          WRITE S01;
+
          WHEN      @NSCN = 'S01PRC';
        ENDDO;
+
                            @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;
  
        // Position to TOP of subfile
+
          ENDSR;
            SRS01 = 1;
+
       //-ENDSR---*INZSR-------------------------------//
            SFC01 = RS01;
+
      /END-FREE
          ENDSR;
 
 
 
       //--------------  CLR -------------------------------//
 
          BEGSR  CLR;
 
  
              *IN51 = *OFF;
+
    P    MAIN        E
              *IN52 = *OFF;
 
              *IN53 = *ON;
 
              WRITE    C01;
 
              *IN53 = *OFF;
 
              RS01  = 0  ;
 
              SFC01 = 0  ;
 
              S01FUNC = *BLANK;
 
              ENDSR;
 
  
      //--------------  MOV -------------------------------//
 
          BEGSR  MOV;
 
  
            C01APBOF =  APBOF ;
+
      //###################################################//
            C01APBOL =  APBOL ;
+
      //###################################################//
 +
      //###################################################//
 +
      /space 3
 +
    P @S01BLD        B
  
          IF APBOF = *BLANK AND APBOL =  *BLANK;
+
    D @S01BLD        PI
          C01APBOF = APFILE;
 
          C01APBOL = APLIB;
 
          ENDIF;
 
  
        // Load the subfile record
+
    D WFILE          S                  LIKE(APFILE )
 +
    D WLIB            S                  LIKE(APLIB )
  
           IF APFILE = WFILE AND
+
           // Build/Rebuild the subfile
            APLIB  = WLIB ;
+
 
            *IN56 = *ON ;
+
       /FREE
                  S01APFILE  =  *BLANK;
+
          EXSR      @INZSR;
                  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;
+
           EXSR      BLD;
  
      //--------------*INZSR-------------------------------//
+
        // SFL IS BUILT, PROCESS THE SFL CONTROL
           BEGSR    @INZSR;
+
           @LV = @LV + 1;
              @NSCN = *BLANK;
+
          @SCN(@LV) = 'S01PRC ' ;
          ENDSR;
+
            RETURN ;
      /END-FREE
 
  
    P @S01BLD        E
+
      //--------------  BLD -------------------------------//
 +
          BEGSR    BLD;
  
      //###################################################//
+
            EXSR      CLR;
      //###################################################//
 
  
      /space 3
 
    P @S01PRC        B
 
  
    D @S01PRC        PI
+
          SETLL 1    QWHFDACP;
  
           //
+
           DOW @LOOP = @LOOP;
           //
+
           READ      QWHFDACP;
    D WRKRC           S              4S 0
+
          IF %EOF;
 +
          LEAVE;
 +
           ENDIF;
  
      /FREE
 
          EXSR      @INZSR;
 
  
            WRITE    R01;
+
          EXSR MOV;
      //
+
          //
            DOW      @LOOP = @LOOP;
+
          RS01  = RS01 + 1;
 +
          WRITE S01;
 +
        ENDDO;
  
          //
 
          // Write SFL Control
 
            IF        SFC01 > 0;
 
                *IN51 = *ON;
 
            ENDIF;
 
              *IN52 = *ON;
 
  
 +
        // Position to TOP of subfile
 +
            SRS01 = 1;
 +
            SFC01 = RS01;
 +
          ENDSR;
  
              EXFMT    C01;
+
      //-------------- CLR -------------------------------//
          //  Setoff errors
+
          BEGSR  CLR;
                *IN89 = *OFF;
+
 
          //
+
              *IN51 = *OFF;
          //  Exit and Previous Screen
+
              *IN52 = *OFF;
            IF        *IN03 = *ON;
+
              *IN53 = *ON;
                LEAVE;
+
              WRITE    C01;
            ENDIF;
+
              *IN53 = *OFF;
            IF        *IN12 = *ON;
+
              RS01  = 0  ;
                LEAVE;
+
              SFC01 = 0  ;
            ENDIF;
+
              S01FUNC = *BLANK;
 +
              ENDSR;
 +
 
 +
      //--------------  MOV -------------------------------//
 +
          BEGSR  MOV;
  
 +
            C01APBOF =  APBOF ;
 +
            C01APBOL =  APBOL ;
  
        // Process the subfile
+
          IF APBOF = *BLANK AND APBOL = *BLANK;
              @LV = @LV + 1;
+
          C01APBOF = APFILE;
              @SCN(@LV) = 'S01PRS';
+
          C01APBOL = APLIB;
              LEAVE;
+
          ENDIF;
  
            ENDDO;
+
        // Load the subfile record
      //
 
            RETURN;
 
  
       /space 3
+
          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-------------------------------//
 
       //--------------*INZSR-------------------------------//
Line 13,112: Line 13,236:
 
           ENDSR;
 
           ENDSR;
 
       /END-FREE
 
       /END-FREE
     P @S01PRC         E
+
 
 +
     P @S01BLD         E
  
 
       //###################################################//
 
       //###################################################//
 
       //###################################################//
 
       //###################################################//
      //###################################################//
+
 
 
       /space 3
 
       /space 3
     P @S01PRS        B
+
    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 @S01PRS        PI
Line 13,354: Line 13,538:
 
[[#top]]
 
[[#top]]
  
===DISPRF  DSPF ===
+
===DISPRF  DSPF ===
  
 
<pre>
 
<pre>
 +
 
     A*%%TS  SD  20101208  163705  KOLMANNF    REL-V5R4M0  5722-WDS
 
     A*%%TS  SD  20101208  163705  KOLMANNF    REL-V5R4M0  5722-WDS
 
     A*
 
     A*
  * REQUIRES FILES TO COMPILE
+
      * REQUIRES FILES TO COMPILE
 
       *  CRTDUPOBJ  OBJ(QAFDSELO) FROMLIB(QSYS)
 
       *  CRTDUPOBJ  OBJ(QAFDSELO) FROMLIB(QSYS)
 
       *              OBJTYPE(*FILE) TOLIB(QTEMP) NEWOBJ(SEL)
 
       *              OBJTYPE(*FILE) TOLIB(QTEMP) NEWOBJ(SEL)
 
       *  CRTDUPOBJ  OBJ(QAFDACCP) FROMLIB(QSYS)
 
       *  CRTDUPOBJ  OBJ(QAFDACCP) FROMLIB(QSYS)
 
       *        OBJTYPE(*FILE) TOLIB(QTEMP) NEWOBJ(ACC)
 
       *        OBJTYPE(*FILE) TOLIB(QTEMP) NEWOBJ(ACC)
 
+
 
+
 
 
     A*%%EC
 
     A*%%EC
 
     A                                      DSPSIZ(24 80 *DS3)
 
     A                                      DSPSIZ(24 80 *DS3)
Line 13,442: Line 13,627:
 
[[#top]]
 
[[#top]]
  
===DISPY   RPG ===
+
 
 +
===DISPY   RPG ===
  
 
<pre>
 
<pre>
Line 13,453: Line 13,639:
 
       //  Description: DISPLAY A FILES FIELDS FOR SELECTION
 
       //  Description: DISPLAY A FILES FIELDS FOR SELECTION
  
       //    needs files KF  FFD to compile use following commands  
+
       //    needs files KF  FFD to compile use following commands
 
       // DSPFD (&LIB/&FILE) TYPE(*ACCPTH) OUTPUT(*OUTFILE) OUTFILE(QTEMP/KF)
 
       // DSPFD (&LIB/&FILE) TYPE(*ACCPTH) OUTPUT(*OUTFILE) OUTFILE(QTEMP/KF)
 
       // DSPFFD  FILE(&LIB/&FILE) OUTPUT(*OUTFILE) OUTFILE(QTEMP/FFD)
 
       // DSPFFD  FILE(&LIB/&FILE) OUTPUT(*OUTFILE) OUTFILE(QTEMP/FFD)
Line 14,307: Line 14,493:
 
       /end-free
 
       /end-free
 
     P                E
 
     P                E
 
  
 
</pre>
 
</pre>
Line 14,313: Line 14,498:
 
[[#top]]
 
[[#top]]
  
===DISPYF  DSPF ===
+
===DISPYF  RPG ===
  
 
<pre>
 
<pre>
 +
 
     A*%%TS  SD  20101203  131649  KOLMANNF    REL-V5R4M0  5722-WDS
 
     A*%%TS  SD  20101203  131649  KOLMANNF    REL-V5R4M0  5722-WDS
 
     A*  90/01/08  12:52:36                REL-R01M02  5728-PW1
 
     A*  90/01/08  12:52:36                REL-R01M02  5728-PW1
Line 14,397: Line 14,583:
 
     A          R R01
 
     A          R R01
 
     A                                23  2'F3-Exit F6-Data Sel'
 
     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]]

Revision as of 09:21, 30 November 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, but there is no 'make' instruction. I am assuming you know enough about compiling source to figure it out for yourself.

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


DISP RPG

     H*eywords++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++Comments+++++++++++
     H OPTION(*NODEBUGIO)
     H DFTACTGRP(*NO) ACTGRP(*CALLER) DFTNAME(DISP )
     F*
     F*  LIMITED TO MAXIMUM FILE LENGTH OF 2048
     F*   TEST
     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 &ML    *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)
DLTOVR   INPUT
MONMSG CPF0000

IF (&RTN *EQ '1') (GOTO END)

IF (&ACCP *EQ 'K') DO
 CHGJOB SWS(10XXXXXX)
 OVRDBF     FILE(INPUTK) TOFILE(&LIB/&FILE) MBR(&MBR) +
         SHARE(*YES) SEQONLY(*NO)  SECURE(*YES)
IF (&QRY )   DO
 REMSG:

 REQRY:      SNDRCVF    RCDFMT(SLT)
             IF (&IN01 *OR &IN02) GOTO BYQRY
             CHGVAR &OPT '*INP'
             IF (&UPD *EQ 'Y') (CHGVAR &OPT '*ALL')
             OPNQRYF    FILE((INPUTK)) OPTION(&OPT) QRYSLT(&QSLT) +
                          KEYFLD(*FILE) SEQONLY(*NO)
             MONMSG CPF9899 EXEC(DO)
             RCVMSG     MSGTYPE(*ANY)
             SNDF       RCDFMT(SLTC)
             GOTO REMSG
                                ENDDO
                       ENDDO
              ENDDO
BYQRY:
IF (&ACCP *EQ 'A') DO
            CHGJOB SWS(01XXXXXX)
           OVRDBF     FILE(INPUTR) TOFILE(&LIB/&FILE) MBR(&MBR) +
                          SHARE(*YES) SEQONLY(*NO) SECURE(*YES)
     IF (&QRY )         DO
 REMSGA:

 REQRYA:     SNDRCVF    RCDFMT(SLT)
             IF (&IN01 *OR &IN02) GOTO BYQRYA
             CHGVAR &OPT '*INP'
             IF (&UPD = 'Y') (CHGVAR &OPT '*ALL')
             OPNQRYF    FILE((INPUTR)) OPTION(&OPT) QRYSLT(&QSLT) +
                          KEYFLD(*FILE) SEQONLY(*NO)
             MONMSG CPF9899 EXEC(DO)
                RCVMSG     MSGTYPE(*ANY)
                SNDF       RCDFMT(SLTC)
                GOTO REMSGA
                CHGVAR     VAR(&IN20) VALUE('1')
    SDAMSG:     RCVMSG     RMV(*NO) MSG(&MSG)
                IF         COND(&MSG ¬= ' ') THEN(DO)
                SNDPGMMSG  MSG(&MSG)
                GOTO       SDAMSG
                ENDDO
                SNDF       RCDFMT(SLTC)
                GOTO       REMSGA
                                ENDDO

                    ENDDO
            ENDDO
BYQRYA:
CHGVAR &RCDLN &RCDL

IF ( &UPD= 'Y') (DO)
 IF ((&RCDLN *GT    0) *AND (&RCDLN *LE 2048)) (CHGVAR &PRG 'DUSP ')
 IF ((&RCDLN *GT 2048) *AND (&RCDLN *LE 4048)) (CHGVAR &PRG 'DUSP1')
 IF ((&RCDLN *GT 4048) *AND (&RCDLN *LE 6080)) (CHGVAR &PRG 'DUSP2')
           ENDDO
IF (&UPD *NE 'Y') (DO)
 IF ((&RCDLN *GT    0) *AND (&RCDLN *LE 2048)) (CHGVAR &PRG 'DISP ')
 IF ((&RCDLN *GT 2048) *AND (&RCDLN *LE 4048)) (CHGVAR &PRG 'DISP1')
 IF ((&RCDLN *GT 4048) *AND (&RCDLN *LE 6080)) (CHGVAR &PRG 'DISP2')
           ENDDO


 CALL  &PRG  (&ALL &RTN &KEYL &UPD &SCNLV  &SCNLVL &SCNKEY)

IF (&QRY )  (DO)
   IF (&ACCP *EQ 'K') DO
   CLOF     INPUTK
   MONMSG CPF0000
                   ENDDO
   IF (&ACCP *EQ 'A') DO
   CLOF     INPUTR
   MONMSG CPF0000
                   ENDDO
ENDDO

IF (&RTN *EQ '3') DO
  GOTO BYQRYA
  ENDDO

IF (&RTN *EQ '1') DO
  CHGVAR &RTN '0'
  GOTO RTN
  ENDDO



END:  ENDPGM

#top

DIS3 CL


/* CALL BY DIS TO SHOW FILE RELATIONS / ACCESS PATHS */

PGM  (&PHY &PHYLIB &SFILE &SLIB)

/* DISPLAY ACCESS PATHS */

DCL &PHY    *CHAR  10
DCL &PHYLIB *CHAR  10
DCL &SFILE  *CHAR  10
DCL &SLIB   *CHAR  10


DCLF QTEMP/DBR

/* CREATE WORK FILES */
CALL  DIS4

DLTF QTEMP/DBR
MONMSG CPF0000

 DSPDBR     FILE(&PHYLIB/&PHY) OUTPUT(*OUTFILE) +
   OUTFILE(QTEMP/DBR) OUTMBR(*FIRST *REPLACE)
 CHGPF QTEMP/DBR LVLCHK(*NO)

NEXT: RCVF
 MONMSG CPF0000 EXEC(GOTO END)
 IF (&WHREFI *NE ' ') DO
 DSPFD      FILE(&WHRELI/&WHREFI) TYPE(*ACCPTH) +
         OUTPUT(*OUTFILE) OUTFILE(QTEMP/REL) OUTMBR(*FIRST *ADD)
 CHGPF QTEMP/REL LVLCHK(*NO)
 DSPFD      FILE(&WHRELI/&WHREFI) TYPE(*SELECT) +
         OUTPUT(*OUTFILE) OUTFILE(QTEMP/SEL) OUTMBR(*FIRST *ADD)
 CHGPF QTEMP/SEL LVLCHK(*NO)
         ENDDO
GOTO NEXT

END:
 DSPFD      FILE(&PHYLIB/&PHY   ) TYPE(*ACCPTH) +
         OUTPUT(*OUTFILE) OUTFILE(QTEMP/REL) OUTMBR(*FIRST *ADD)
 CHGPF QTEMP/REL LVLCHK(*NO)

CHGVAR &SFILE '          '
CHGVAR &SLIB  '          '

OVRDBF SEL QTEMP/SEL
OVRDBF REL QTEMP/REL
CALL  DISPR (&SFILE &SLIB)
DLTOVR *ALL

ENDPGM

#top

DIS4 CL


/* CALL BY DIS3 TO CREATE WORK FILES */

PGM

DCL  &LIB *CHAR 10
DCL  &SRCF *CHAR 10

RTVDTAARA DTAARA(UDDSSRC *ALL)  RTNVAR(&SRCF)

DLTF  QTEMP/XXXXFILE
monmsg cpf0000
CRTPF      FILE(QTEMP/XXXXFILE) RCDLEN(80) OPTION(*NOLIST)

DSPFFD  FILE(QTEMP/XXXXFILE) OUTPUT(*OUTFILE) OUTFILE(QTEMP/FFD)
CLRPFM  QTEMP/FFD
DLTF   FILE(QTEMP/FFDL01)
MONMSG CPF0000

RTVMBRD FILE(&SRCF) RTNLIB(&LIB)
CRTLF FILE(QTEMP/FFDL01) SRCFILE(&LIB/&SRCF) SRCMBR(FFDL01) +
OPTION(*NOSRC *NOLIST)

DLTF   FILE(QTEMP/REL)
MONMSG CPF0000
DLTF   FILE(QTEMP/SEL)
MONMSG CPF0000
DLTF   FILE(QTEMP/DBR)
MONMSG CPF0000

DSPFD      FILE(QTEMP/FFD) TYPE(*ACCPTH) +
  OUTPUT(*OUTFILE) OUTFILE(QTEMP/REL) OUTMBR(*FIRST *ADD)

DSPFD FILE(QTEMP/FFDL01) TYPE(*SELECT) OUTPUT(*OUTFILE) OUTFILE(QTEMP/SEL)
CLRPFM FILE(QTEMP/REL)
CLRPFM FILE(QTEMP/SEL)

DLTF  QTEMP/XXXXFILE
monmsg cpf0000


ENDPGM

#top

DISBIN CL

/* NUMERIC TO BINARY CONVERTER  */


PGM (&NUM  &BIN2  &BIN4 &BINTYP  )

DCL  VAR(&NUM) TYPE(*DEC) LEN(15 0)
DCL VAR(&BINTYP) TYPE(*CHAR) LEN(1)
DCL VAR(&BIN2) TYPE(*CHAR) LEN(2)
DCL VAR(&BIN4) TYPE(*CHAR) LEN(4)

IF (&BINTYP = '4') (CHGVAR %BIN(&BIN4) &NUM)
IF (&BINTYP = '2') (CHGVAR %BIN(&BIN2) &NUM)
ENDPGM

#top

DISF CL


/* CHECK FILE TYPE */

PGM (&DISF &TYPE &PHY &PHYLIB)


DCL  &DISF   *CHAR 10
DCL  &TYPE   *CHAR 1
DCL  &PHY    *CHAR 10
DCL  &PHYLIB *CHAR 10
DCLF KF

             OVRDBF     FILE(KF) TOFILE(QTEMP/&DISF)
             OPNDBF     FILE(KF) OPTION(*INP)
             RCVF
             CHGVAR &TYPE &APFTYP

             IF (&TYPE *EQ 'L') DO
             CHGVAR &PHY &APBOF
             CHGVAR &PHYLIB &APBOL
             ENDDO

             CLOF       OPNID(KF)
ENDPGM

#top


DISV CL

/* VALIDITY CHECKER FOR DSPFL COMMAND */


PGM (&FILIB   &MBR &UPD &RST &REL)

DCL &FILIB  *CHAR 20
DCL &FILE *CHAR  10
DCL &LIB  *CHAR  10
DCL &MBR  *CHAR  10
DCL &UPD  *CHAR  1
DCL &RST  *CHAR  1
DCL &REL  *CHAR  1
DCL &OBJATR *CHAR 10
DCL &AUT    *CHAR  8

DCL &MSGDTA *CHAR 40
DCL &ERROR  *LGL

CHGVAR &FILE  &FILIB
CHGVAR &LIB   (%SST(&FILIB 11 10))
IF (&MBR *EQ '*FILE') (CHGVAR &MBR  &FILE  )

CHGVAR &AUT '*READ   '
IF ((&UPD *EQ 'Y') *OR (&UPD *EQ 'y')) (CHGVAR &AUT '*CHANGE')

CHKOBJ   (&LIB/&FILE) OBJTYPE(*FILE) MBR(*NONE)  +
  AUT( &AUT   )
  MONMSG (CPF9899 CPF9801 CPF9802  CPF9820 CPF9830) EXEC(DO)
/*  CHGVAR (&MSGDTA) VALUE('    '||&FILE||&LIB)                   */
/*  SNDPGMMSG MSGID(USR0006) MSGF(*LIBL/QUSERMSG) MSGTYPE(*DIAG) +*/
/*            MSGDTA(&MSGDTA)                                     */
    SNDPGMMSG  MSG('Not authorised to the file.') +
                          MSGTYPE(*DIAG)
    CHGVAR (&ERROR) '1'
  ENDDO
  MONMSG (CPF9810) EXEC(DO)
    CHGVAR (&MSGDTA) VALUE('    '||&LIB)
/*  SNDPGMMSG MSGID(USR0008) MSGF(*LIBL/QUSERMSG) MSGTYPE(*DIAG)  +*/
/*            MSGDTA(&MSGDTA)                                      */
    SNDPGMMSG  MSG('Not authorised to the file.') +
                          MSGTYPE(*DIAG)
    CHGVAR (&ERROR) '1'
  ENDDO


IF (*NOT &ERROR) DO

RTVOBJD    OBJ(&LIB/&FILE) OBJTYPE(*FILE) OBJATR(&OBJATR)
CHGVAR &AUT '*READ   '
IF ((&UPD *EQ 'Y') *OR (&UPD *EQ 'y')) (CHGVAR &AUT '*CHANGE')

CHKOBJ     OBJ(&LIB/&FILE) OBJTYPE(*FILE) MBR(&MBR) +
                          AUT(&AUT)

  MONMSG (CPF9815 )  EXEC(DO)
/*  CHGVAR (&MSGDTA) VALUE('    '||&MBR||&FILE||&LIB)              */
/*  SNDPGMMSG MSGID(USR0007) MSGF(*LIBL/QUSERMSG) MSGTYPE(*DIAG) + */
/*            MSGDTA(&MSGDTA)                                      */
             SNDPGMMSG  MSG('Not authorised to the file.') +
                          MSGTYPE(*DIAG)
    CHGVAR (&ERROR) '1'
  ENDDO
  MONMSG (CPF0000 )  EXEC(DO)
/*  SNDPGMMSG MSGID(USR0022) MSGF(*LIBL/QUSERMSG) MSGTYPE(*DIAG) + */
/*            MSGDTA(&MSGDTA)                                      */
             SNDPGMMSG  MSG('Not authorised to the file.') +
                          MSGTYPE(*DIAG)
    CHGVAR (&ERROR) '1'
  ENDDO
ENDDO

IF (&ERROR)   (SNDPGMMSG MSGID(CPF0002) MSGF(QCPFMSG) MSGTYPE(*ESCAPE))



ENDPGM

#top


DISPR RPG

     H OPTIMIZE(*NONE) OPTION(*NODEBUGIO)
     H DFTACTGRP(*NO) ACTGRP(*CALLER)

      *    FILE RELATIONS DISPLAYER
      * REQUIRES FILES TO COMPILE
      *

     FREL       IF   E             DISK
     FSEL       IF   E             DISK
     FDISPRF    CF   E             WORKSTN
     F                                     SFILE(S01:RS01)
     F                                     SFILE(S02:RS02)
     F                                     INFDS(SFINF)
      *

      *
     DDISPR            PR
     D                               10
     D                               10
     DDISPR            PI
     D  SFILE                        10
     D  SLIB                         10

      //  SCREEN LEVELS
     D @SCN            S              6    DIM(50)
     D @NSCN           S              6
     D @LV             S              5  0
     D @ERR            S                   LIKE(@TRUE)
     D @FILE           S             10A   INZ('DISPY  ')
     D WRKSWS          S              1
     D I               S              4B 0


     D @TRUE           S              1A   INZ('1')
     D @FALSE          S              1A   INZ('0')
     D @OK             S                   LIKE(@TRUE)
     D @LOOP           S                   LIKE(@TRUE)

      //
     D RS01            S              4S 0
     D RS02            S              4S 0
      //
      // PARMS FOR SFL LOOPING
     D SFC01           S                   LIKE(RS01)
     D SFC02           S                   LIKE(RS01)

      // Program Status
     D                SDS
     D  PGM                    1     10
     D  WSID                 244    253
     D  USER                 254    263
      //
      //
     D SFINF           DS
     D  RRRN                 376    377B 0
     D  SRN                  378    379B 0

      //  MESSAGE DATA
     D @DTA1           DS            80
     D @DTA2           DS           500
      //
     D MAIN            PR

     D @S01BLD         PR
     D @S01PRC         PR
     D @S01PRS         PR
     D @S02BLD         PR
     D @S02PRC         PR
     D
     D @R9999          PR

     D @OPADJ          PR             2A
     D  OPT                           2A


      /FREE
            *INLR = *ON;
            MAIN();


       //--------------*INZSR-------------------------------//
           BEGSR   *INZSR;

        //  Set the TOP level (Exit if user backs up to here)
              @LV = 1;
              @SCN(@LV)  = '*END  ';
        //  Set the Initial Screen to display
              @LV = @LV + 1;
              @SCN(@LV) = 'S01BLD ';

            ENDSR;
      /END-FREE
       //###################################################//

        //*************************************************************
     P    MAIN         B

     D MAIN            PI

     D I               S              4B 0

      /FREE
          EXSR      @INZSR;
       //
       // THIS IS THE CONTROLLING LOOP TO DRIVE THE NEXT PANEL TO DISPLAY
          DOW       @LOOP = @LOOP;
       // GET THE SCREEN NAME FROM THE SCREEN STACK ARRAY
            @NSCN  = @SCN(@LV);
          SELECT;
         //  SELECT FIELDS FOR DISPLAY

         // SFL TO SELECT THE FILE FIELDS
           WHEN      @NSCN = 'S01BLD';
                             @S01BLD();
           WHEN      @NSCN = 'S01PRC';
                             @S01PRC();
           WHEN      @NSCN = 'S01PRS';
                             @S01PRS();
           WHEN      @NSCN = 'S02BLD';
                             @S02BLD();
           WHEN      @NSCN = 'S02PRC';
                             @S02PRC();
          OTHER;
            //  CATCH ALL (NEVER USED)
              @R9999();
              LEAVE;
          ENDSL;

        //  CF3 EXIT
          IF  *IN03 = *ON;
            LEAVE;
          ENDIF;

       //   CF12 PREVIOUS
          IF  *IN12 = *ON;
               *IN12 = *OFF;
               @LV   = @LV -1;
               @NSCN = @SCN(@LV);
          ENDIF;

       //  Backed out to last level, Exit
          IF     @NSCN = '*END';
                   LEAVE;
          ENDIF;

         ENDDO;

         RETURN;

       //--------------*INZSR-------------------------------//
           BEGSR   @INZSR;
              @NSCN = *BLANK;

          ENDSR;
       //-ENDSR---*INZSR-------------------------------//
      /END-FREE

     P    MAIN         E


       //###################################################//
       //###################################################//
       //###################################################//
      /space 3
     P @S01BLD         B

     D @S01BLD         PI

     D WFILE           S                   LIKE(APFILE )
     D WLIB            S                   LIKE(APLIB  )

          //  Build/Rebuild the subfile

      /FREE
           EXSR      @INZSR;

           EXSR      BLD;

         //  SFL IS BUILT, PROCESS THE SFL CONTROL
           @LV = @LV + 1;
           @SCN(@LV) = 'S01PRC ' ;
            RETURN ;

       //--------------  BLD -------------------------------//
           BEGSR     BLD;

            EXSR      CLR;


          SETLL 1    QWHFDACP;

          DOW @LOOP = @LOOP;
          READ      QWHFDACP;
          IF %EOF;
           LEAVE;
          ENDIF;


          EXSR MOV;
          //
           RS01   = RS01 + 1;
          WRITE S01;
         ENDDO;


         // Position to TOP of subfile
            SRS01 = 1;
            SFC01 = RS01;
           ENDSR;

       //--------------  CLR -------------------------------//
           BEGSR   CLR;

               *IN51 = *OFF;
               *IN52 = *OFF;
               *IN53 = *ON;
               WRITE     C01;
               *IN53 = *OFF;
               RS01  = 0   ;
               SFC01 = 0   ;
               S01FUNC = *BLANK;
               ENDSR;

       //--------------  MOV -------------------------------//
           BEGSR   MOV;

            C01APBOF =  APBOF ;
            C01APBOL =  APBOL ;

           IF APBOF = *BLANK AND APBOL =  *BLANK;
           C01APBOF = APFILE;
           C01APBOL = APLIB;
           ENDIF;

         //  Load the subfile record

          IF APFILE = WFILE  AND
             APLIB  = WLIB ;
             *IN56 = *ON ;
                  S01APFILE  =   *BLANK;
                  S01APLIB   =   *BLANK;
                  S01APACCP  =   *BLANK;
                  S01APUNIQ  =   *BLANK;
                  S01APSELO  =   *BLANK;
                  S01APFTYP  =   *BLANK;
                  S01APJOIN  =   *BLANK;
                  S01APKEYO  =   *BLANK;
                  S01APKSEQ  =   APKSEQ ;
                  S01APKSIN  =   APKSIN ;
                  S01APKEYF  =   APKEYF ;
            ELSE       ;
             WFILE = APFILE;
             WLIB  = APLIB ;
             *IN56 = *OFF;
                  S01APFILE  =   APFILE ;
                  S01APLIB   =   APLIB  ;
                  S01APACCP  =   APACCP ;
                  S01APUNIQ  =   APUNIQ ;
                  S01APSELO  =   APSELO ;
                  S01APFTYP  =   APFTYP ;
                  S01APJOIN  =   APJOIN ;
                  S01APKEYO  =   APKEYO ;
                  S01APKSEQ  =   APKSEQ ;
                  S01APKSIN  =   APKSIN ;
                  S01APKEYF  =   APKEYF ;
          ENDIF;

           ENDSR;

       //--------------*INZSR-------------------------------//
           BEGSR     @INZSR;
               @NSCN = *BLANK;
           ENDSR;
      /END-FREE

     P @S01BLD         E

       //###################################################//
       //###################################################//

      /space 3
     P @S01PRC         B

     D @S01PRC         PI

          //
          //
     D WRKRC           S              4S 0

      /FREE
           EXSR      @INZSR;

            WRITE     R01;
       //
            DOW       @LOOP = @LOOP;

           //
           // Write SFL Control
             IF        SFC01 > 0;
                *IN51 = *ON;
             ENDIF;
               *IN52 = *ON;


               EXFMT     C01;
           //  Setoff errors
                 *IN89 = *OFF;
           //
           //  Exit and Previous Screen
             IF        *IN03 = *ON;
                LEAVE;
             ENDIF;
             IF        *IN12 = *ON;
                 LEAVE;
             ENDIF;


         //  Process the subfile
               @LV = @LV + 1;
               @SCN(@LV) = 'S01PRS';
               LEAVE;

            ENDDO;
       //
            RETURN;

      /space 3


       //--------------*INZSR-------------------------------//
           BEGSR     @INZSR;
               @NSCN = *BLANK;
           ENDSR;
      /END-FREE
     P @S01PRC         E

       //###################################################//
       //###################################################//
       //###################################################//
      /space 3
     P @S01PRS         B

     D @S01PRS         PI

          //
          //
     D WRKRC           S              4S 0

      /FREE

          EXSR      @INZSR;

         //  Process the subfile
           EXSR      SFL;
           RETURN;

       //--------------  SFL -------------------------------//
           BEGSR      SFL;
        //  Process the subfile

           FOR       WRKRC = 1 TO SFC01 + 1 ;
               CHAIN  WRKRC   S01;
                 IF        NOT %FOUND;
         //  Finished with the subfile
                    @LV = @LV -1;
                    LEAVE;
                 ENDIF;

         //   GET SELECTED FILE
            IF   @OPADJ(S01FUNC) =   ' X';
               SFILE  = S01APFILE;
               SLIB   = S01APLIB ;
               *IN03 = '1';
                LEAVE;
            ENDIF;


         //   SHOW SELECT RULES
            IF   @OPADJ(S01FUNC) =   ' R';
              @LV = @LV + 1;
              @SCN(@LV) = 'S02BLD ';
                 S01FUNC =  '  ';
                 UPDATE    S01;
              LEAVE;
            ENDIF;

           ENDFOR;

           ENDSR;
       //---------------------------------------------------//



       //--------------*INZSR-------------------------------//
           BEGSR     @INZSR;
               @NSCN = *BLANK;
           ENDSR;


      /END-FREE
     P @S01PRS         E


      /space 3
     P @S02BLD         B

     D @S02BLD         PI

          //  Build/Rebuild the subfile
      /FREE

          EXSR @INZSR;

          C02APFILE  =  S01APFILE ;
          C02APLIB   =  S01APLIB  ;

         EXSR BLD;

         //  SFL IS BUILT, PROCESS THE CONTROL
           @LV = @LV + 1;
           @SCN(@LV) = 'S02PRC ';
       RETURN;
       //--------------  BLD -------------------------------//
       BEGSR   BLD;

         EXSR CLR;


          SETLL 1    QWHFDSO ;

          DOW @LOOP = @LOOP;

          READ      QWHFDSO ;
          IF %EOF;
           LEAVE;
          ENDIF;

          If SOFILE = S01APFILE  AND
             SOLIB  = S01APLIB ;
          EXSR MOV;

          //
           RS02   = RS02 + 1;
          WRITE S02;
          ENDIF;
         ENDDO;

         // Position to TOP of subfile
         SRS02 = 1;
         SFC02 = RS02;
         ENDSR;

       //--------------  CLR -------------------------------//
         BEGSR  CLR;
          *IN51 = *OFF;
          *IN52 = *OFF;
          *IN53 = *ON;
          WRITE C02;
          *IN53 = *OFF;
           RS02 =0;
           SFC02=0;

         ENDSR;

       //--------------  MOV -------------------------------//
        BEGSR  MOV;
         //  Load the subfile record

          S02SOFLD  = SOFLD  ;
          S02SORULE = SORULE ;
          S02SOCOMP = SOCOMP ;
          S02SOVALU = SOVALU ;



         ENDSR;

       //--------------*INZSR-------------------------------//
         BEGSR  @INZSR;
           @NSCN = *BLANK;
         ENDSR;

      /END-FREE
     P @S02BLD         E

       //###################################################//
       //###################################################//
       //###################################################//
      /space 3
     P @S02PRC         B

     D @S02PRC         PI

          //
          //
     D WRKRC           S              4S 0

      /FREE

          EXSR @INZSR;

         WRITE R02;

       //
       DOW @LOOP = @LOOP;

           //
           // Write SFL Control
           IF SFC02 > 0;
             *IN51 = *ON;
           ENDIF;
           *IN52 = *ON;
           EXFMT C02;
           //
           //  Setoff errors
           *IN89 = *OFF;
           //
           //  Exit and Previous Screen

           @LV = @LV -2;
             LEAVE;


         //  Process the subfile

       ENDDO;
       //
       RETURN;

      /space 3
       //--------------*INZSR-------------------------------//
         BEGSR  @INZSR;

           @NSCN = *BLANK;
         ENDSR;
      /END-FREE
     P @S02PRC         E


       //###################################################//
       //###################################################//
       //###################################################//

     P @R9999          B
        //  Invalid Panel
     D @R9999          PI

     P @R9999          E


      /space 3
       //###################################################//
       //###################################################//
       //###################################################//
     P @OPADJ          B
        //   RIGHT ADJ OPTION , zero suppress

     D @OPADJ          PI             2A
     D  OPT                           2A

      /FREE
         EVALR  OPT   = %trimr(OPT);
         If %SubSt(OPT:1:1) =  '0';
         OPT   = ' ' +  %SubSt(OPT:2:1);
         EndIf;
         RETURN OPT;
      /END-FREE
     P @OPADJ          E

       //###################################################//
       //###################################################//

#top

DISPRF DSPF


     A*%%TS  SD  20101208  163705  KOLMANNF    REL-V5R4M0  5722-WDS
     A*
      * REQUIRES FILES TO COMPILE
      *   CRTDUPOBJ  OBJ(QAFDSELO) FROMLIB(QSYS)
      *              OBJTYPE(*FILE) TOLIB(QTEMP) NEWOBJ(SEL)
      *   CRTDUPOBJ  OBJ(QAFDACCP) FROMLIB(QSYS)
      *         OBJTYPE(*FILE) TOLIB(QTEMP) NEWOBJ(ACC)


     A*%%EC
     A                                      DSPSIZ(24 80 *DS3)
     A                                      PRINT
     A                                      CF03(03)
     A                                      CF12(12)
     A          R S01                       SFL
     A*%%TS  SD  20101208  163705  KOLMANNF    REL-V5R4M0  5722-WDS
     A            S01FUNC        2A  I  4  3
     A  55
     AO 56                                  DSPATR(PR)
     A            S01APFILE R        O  4  6REFFLD(QWHFDACP/APFILE QTEMP/REL)
     A            S01APLIB  R        O  4 17REFFLD(QWHFDACP/APLIB QTEMP/REL)
     A            S01APACCP R        O  4 29REFFLD(QWHFDACP/APACCP QTEMP/REL)
     A            S01APUNIQ R        O  4 33REFFLD(QWHFDACP/APUNIQ QTEMP/REL)
     A            S01APSELO R        O  4 37REFFLD(QWHFDACP/APSELO QTEMP/REL)
     A            S01APFTYP R        O  4 41REFFLD(QWHFDACP/APFTYP QTEMP/REL)
     A            S01APJOIN R        O  4 45REFFLD(QWHFDACP/APJOIN QTEMP/REL)
     A            S01APKEYO R        O  4 48REFFLD(QWHFDACP/APKEYO QTEMP/REL)
     A            S01APKSEQ R        O  4 53REFFLD(QWHFDACP/APKSEQ QTEMP/REL)
     A            S01APKSIN R        O  4 57REFFLD(QWHFDACP/APKSIN QTEMP/REL)
     A            S01APKEYF R        O  4 61REFFLD(QWHFDACP/APKEYF QTEMP/REL)
     A          R C01                       SFLCTL(S01)
     A*%%TS  SD  20101208  163705  KOLMANNF    REL-V5R4M0  5722-WDS
     A                                      SFLSIZ(0019)
     A                                      SFLPAG(0018)
     A                                      OVERLAY
     A  50                                  SFLEND
     A  51                                  SFLDSP
     A  52                                  SFLDSPCTL
     A  53                                  SFLCLR
     A            SRS01          4S 0H      SFLRCDNBR(CURSOR)
     A*
     A                                  1 18'FILE RELATIONS for '
     A            C01APBOF  R        O  1 39REFFLD(QWHFDACP/APBOF QTEMP/REL)
     A                                  1 51'Lib.'
     A            C01APBOL  R        O  1 56REFFLD(QWHFDACP/APBOL QTEMP/REL)
     A                                  2 32'Uni SEL         LIFO ASC Key'
     A                                  3  6'File       Library    Acc Key OMT -
     A                                      TYP  J  FIFO DSC Sgn Key'
     A          R R01
     A                                 24  3'F3-Exit'
     A                                 22  3'R - Display Select/Omit rules'
     A                                 23  3'X - Select for display'
      *
     A          R R02
     A                                 24  3'F3-Exit'
     A          R S02                       SFL
     A                                      SFLNXTCHG
     A            S02SOFLD  R        O  4  4REFFLD(QWHFDSO/SOFLD QTEMP/SEL)
     A            S02SORULE R        O  4 17REFFLD(QWHFDSO/SORULE QTEMP/SEL)
     A            S02SOCOMP R        O  4 22REFFLD(QWHFDSO/SOCOMP QTEMP/SEL)
     A            S02SOVALU R        O  4 28REFFLD(QWHFDSO/SOVALU QTEMP/SEL)

     A          R C02                       SFLCTL(S02 )
     A                                      OVERLAY
     A  50                                  SFLEND
     A  51                                  SFLDSP
     A  52                                  SFLDSPCTL
     A  53                                  SFLCLR
     A                                      SFLSIZ(0019)
     A                                      SFLPAG(0018)
     A            SRS02          4S 0H      SFLRCDNBR(CURSOR)
     A*
     A                                  1  6'FILE SELECTS   for '
     A            C02APFILE R        O  2  7REFFLD(QWHFDSO/SOFILE QTEMP/SEL)
     A                                  2 20'Lib.'
     A            C02APLIB  R        O  2 25REFFLD(QWHFDSO/SOLIB QTEMP/SEL)
     A                                  3  4'Field'
     A                                  3 28'Select/Omit Value'
     A                                  3 16'S/O'
     A                                  3 21'COMP'

#top


DISPY RPG

     H OPTIMIZE(*NONE) OPTION(*NODEBUGIO)
     H DFTACTGRP(*NO) ACTGRP(*CALLER)

      //***************************************************************
      //
      //  PROGRAM ID : DISPY
      //  Description: DISPLAY A FILES FIELDS FOR SELECTION

      //    needs files KF  FFD to compile use following commands
      // DSPFD (&LIB/&FILE) TYPE(*ACCPTH) OUTPUT(*OUTFILE) OUTFILE(QTEMP/KF)
      // DSPFFD  FILE(&LIB/&FILE) OUTPUT(*OUTFILE) OUTFILE(QTEMP/FFD)
      //***************************************************************
      // MODIFICATIONS:
      // MOD   SR   DATE    MODIFICATION SUMMARY
      //
      //***************************************************************
      //
     FKF        IF   E             DISK
     FFFD       UF   E             DISK
     FINPUT     IF   F32766  2000AIDISK    KEYLOC(1)
     F                                     INFDS(INFDS)
     FDISPYF    CF   E             WORKSTN
     F                                     SFILE(S01:RS01)
     F                                     INFDS(SFINF)
      //
      //

      //  SCREEN LEVELS
     D @SCN            S              6    DIM(50)
     D @NSCN           S              6
     D @LV             S              5  0
     D @ERR            S                   LIKE(@TRUE)
     D @FILE           S             10A   INZ('DISPY  ')
     D WRKSWS          S              1
     D I               S              4B 0


     D @TRUE           S              1A   INZ('1')
     D @FALSE          S              1A   INZ('0')
     D @OK             S                   LIKE(@TRUE)
     D @LOOP           S                   LIKE(@TRUE)

      //
     D RS01            S              4S 0
      //
      // PARMS FOR SFL LOOPING
     D SFC01           S                   LIKE(RS01)

      // Program Status
     D                SDS
     D  PGM                    1     10
     D  WSID                 244    253
     D  USER                 254    263
      //
      //
     D SFINF           DS
     D  RRRN                 376    377B 0
     D  SRN                  378    379B 0

      //
     D FLD             S             10    DIM(9000)
     D KEY             S             10    DIM(99)

     D INFDS           DS
     D  FILE                  83     92
     D  LIB                   93    102
     D  MBR                  129    138
     D  RCDL                 125    126B 0
     D  RCDS                 156    159B 0
     D  ACCTP                160    160

     D                 DS
     D  WHCOLD                 1     60
     D  WHCHD1                 1     20
     D  WHCHD2                21     40
     D  WHCHD3                41     60

     D                 DS
     D  POSN                   1     10
     D  P1                     1     10    DIM(10)

     D  POSNN                 11     20
     D  P2                    11     20    DIM(10)


      *
      //  MESSAGE DATA
     D @DTA1           DS            80
     D @DTA2           DS           500
      //
     D MAIN            PR

     D @S01BLD         PR
     D @S01PRC         PR
     D @S01PRS         PR
     D
     D @R9999          PR

     D @OPADJ          PR             2A
     D  OPT                           2A

      *
     DDISPY            PR
     D                                1
     D                                1
     D                                4
     D                                1
     D                                1
     D                                5
     DDISPY            PI
     D  ALL                           1
     D  RTN                           1
     D  KEYLNG                        4
     D  ACCP                          1
     D  QRY                           1
     D  RCDLN                         5
      *
     D KEYLN           S              4S 0
     D RCDLEN          S              5S 0
      *-------------------------------------------------------------------
      * QMHRTVM API (Retrieve Message text)
      *-------------------------------------------------------------------
     D  RtvMsgTxt      PR          1024
     D   RMsgId                       7    Const
     D   RMsgFle                     10    Const
     D   RMsgLib                     10    Const
     D   RMsgLvl                      1    Const

     D GETROWCOL       PR
     D                               10A   const
     D                               10A   const
     D                               10A   const
     D                               32A   const
     D                                3P 0
     D                                3P 0

     D SysDate         PR             8S 0
     D SysTime         PR             6S 0
     D DayOfWeek       PR            10I 0
     D                                 D   value datfmt(*iso)
       // Message file names
     D  cMsgLib        C                   Const('*LIBL     ')
     D  cMsgF1         C                   Const('MSGF1     ')
     D  cMsgF2         C                   Const('MSGF2     ')
     D  cMsgLvl1       C                   Const('1')
     D  cMsgLvl2       C                   Const('2')

      *
     IINPUT     NS  01
     I                                  1  256  D

      /FREE
            *INLR = *ON;
            MAIN();


       //--------------*INZSR-------------------------------//
           BEGSR   *INZSR;

        //  Set the TOP level (Exit if user backs up to here)
              @LV = 1;
              @SCN(@LV)  = '*END  ';
        //  Set the Initial Screen to display
              @LV = @LV + 1;
              @SCN(@LV) = 'S01BLD ';

       //    DUMMY I/O TO GET NUMBER OF RECORDS IN FILE
             READ      INPUT;
       //   SFL IS NOT LOADED
       //   READ THE LIST OF KEY FIELDS IN THE FILE SO THAT WE CAN LATER MARK THEM
                  ACCP    = ACCTP;

               I     =   0;

               DOW  @LOOP = @LOOP;
                READ      QWHFDACP;
                IF  %EOF;
                 LEAVE;
                ENDIF;
                 I = I + 1;
                 KEY(I) = APKEYF;
               ENDDO;
            ENDSR;
      /END-FREE
       //###################################################//

        //*************************************************************
     P    MAIN         B

     D MAIN            PI

     D I               S              4B 0

      /FREE
          EXSR      @INZSR;
       //
       // THIS IS THE CONTROLLING LOOP TO DRIVE THE NEXT PANEL TO DISPLAY
          DOW       @LOOP = @LOOP;
       // GET THE SCREEN NAME FROM THE SCREEN STACK ARRAY
            @NSCN  = @SCN(@LV);
          SELECT;
         //  SELECT FIELDS FOR DISPLAY

         // SFL TO SELECT THE FILE FIELDS
           WHEN      @NSCN = 'S01BLD';
              @S01BLD();
           WHEN      @NSCN = 'S01PRC';
              @S01PRC();
           WHEN      @NSCN = 'S01PRS';
              @S01PRS();
          OTHER;
            //  CATCH ALL (NEVER USED)
              @R9999();
              LEAVE;
          ENDSL;

        //  CF3 EXIT
          IF  *IN03 = *ON;
            LEAVE;
          ENDIF;

       //   CF12 PREVIOUS
          IF  *IN12 = *ON;
               *IN12 = *OFF;
               @LV   = @LV -1;
               @NSCN    = @SCN(@LV);
          ENDIF;

       //  Backed out to last level, Exit
          IF     @NSCN = '*END';
                   LEAVE;
          ENDIF;

         ENDDO;

         KEYLNG  = %EDITC(KEYLN:'X');
         RETURN;

       //--------------*INZSR-------------------------------//
           BEGSR   @INZSR;
              @NSCN = *BLANK;
              RCDLEN = RCDL;
              RCDLN = %CHAR(RCDLEN);

       // CLEAR FIELD SELECTIONS
              IF  RTN  =  '2';
                SETLL 1    QWHDRFFD;
               DOW  @LOOP = @LOOP;
                READ      QWHDRFFD ;
                IF  %EOF;
                 LEAVE;
                ENDIF;
                   WHFIOB = ' ';
                   UPDATE    QWHDRFFD;
               ENDDO;

       // SET FILE I/O TO FIRST RCD IN FILE
                SETLL 1    QWHDRFFD;
                   RTN = '0';
              ELSE;
                CHAIN  1  QWHDRFFD;
                SETLL  1  QWHDRFFD;
              ENDIF;
          ENDSR;
       //-ENDSR---*INZSR-------------------------------//
      /END-FREE

     P    MAIN         E


       //###################################################//
       //###################################################//
       //###################################################//
      /space 3
     P @S01BLD         B

     D @S01BLD         PI

     D  SZ             DS             6
     D  LEN1                   1      1
     D  LEN2                   2      3
     D  LEN3                   1      3
     D  COMA                   4      4
     D  DEC1                   5      5
     D  DEC2                   5      6

     D                 DS
     D K                       1      3  0
     D KA                      2      3

          //  Build/Rebuild the subfile

      /FREE
           EXSR      @INZSR;

           EXSR      BLD;

         //  SFL IS BUILT, PROCESS THE SFL CONTROL
           @LV = @LV + 1;
           @SCN(@LV) = 'S01PRC ' ;
            RETURN ;
       //--------------  BLD -------------------------------//
           BEGSR     BLD;

            EXSR      CLR;

           DOW       @LOOP = @LOOP;

             READ      QWHDRFFD;
                IF  %EOF;
                 LEAVE;
                ENDIF;
            EXSR      MOV;

       // FLAG THE KEY FIELDS
                  K = %LOOKUP(WHFLDE :KEY);
                     WHDFTL  = K ;
                     UPDATE    QWHDRFFD;

            RS01   = RS01 + 1;
            WRITE     S01;
           ENDDO;

         // Position to TOP of subfile
            SRS01 = 1;
            SFC01 = RS01;
           ENDSR;

       //--------------  CLR -------------------------------//
           BEGSR   CLR;
               I     =  0;
               CLEAR FLD;
               KEYLN = 0;

               *IN51 = *OFF;
               *IN52 = *OFF;
               *IN53 = *ON;
               WRITE     C01;
               *IN53 = *OFF;
               RS01  = 0   ;
               SFC01 = 0   ;
               S01OPT= *BLANK;
               ENDSR;

       //--------------  MOV -------------------------------//
           BEGSR   MOV;
         //  Load the subfile record


             S01OPT   =  WHFIOB ;
             S01WHFLDB  = WHFLDB;
             S01WHFLDT  = WHFLDT;
             S01WHFLD =  WHFLDE ;
             S01SFLD  =  WHFLDE ;
             S01FROM = WHFOBO;
             S01TO   = WHFLDB + WHFOBO -1 ;

       //  KEY FIELDS
             S01KEYFLD   = '  ';
               K = %LOOKUP(WHFLDE :KEY);
                  IF K <> 0;
                     S01KEYFLD = KA;
                   IF   K <  10;
                    %SUBST(S01KEYFLD:1:1) = 'K';
                   ENDIF;
                     KEYLN = KEYLN +  WHFLDB;
                  ENDIF;
        //  FORMAT THE FIELD LENGTH
                  S01SIZE  =  '      ';
                  SZ       =  '      ';
                  IF WHFLDD =       0;
                      LEN3   = %SUBST(%EDITC(WHFLDB:'Z'):3:3);
                   ELSE;
                      LEN2   = %EDITC(WHFLDD:'Z') ;
                      COMA = ',';

                      IF     WHFLDP >  9;
                        DEC2 = %CHAR(WHFLDP);
                      ELSE;
                        DEC1 = %CHAR(WHFLDP);
                      ENDIF;
                  ENDIF;
                  IF   LEN1 =  '0';
                       LEN1 = ' ';
                  ENDIF;
                  S01SIZE = SZ;

                   S01DESC = WHFTXT;
                   IF    S01DESC=   ' ';
                      S01DESC  =  WHCOLD ;
                   ENDIF;

                   I = I + 1;
                   FLD(I) =  S01WHFLD;

           ENDSR;

       //--------------*INZSR-------------------------------//
           BEGSR     @INZSR;
               @NSCN = *BLANK;
           ENDSR;
      /END-FREE

     P @S01BLD         E

       //###################################################//
       //###################################################//

      /space 3
     P @S01PRC         B

     D @S01PRC         PI

          //
          //
     D WRKRC           S              4S 0
     D C01CHK          S                   LIKE(C01POSN)

      /FREE
           EXSR      @INZSR;

            WRITE     R01;

       //
            DOW       @LOOP = @LOOP;

           //
           // Write SFL Control
             IF        SFC01 > 0;
                *IN51 = *ON;
             ENDIF;
               *IN52 = *ON;
               EXFMT     C01;
           //  Setoff errors
                 *IN89 = *OFF;
           //
           //  Exit and Previous Screen
             IF        *IN03 = *ON;
               RTN = '1';
                LEAVE;
             ENDIF;

             IF        *IN12 = *ON;
                @LV = @LV -1;
                 LEAVE;
             ENDIF;

           //  Set up for qry selection and exit
             IF        *IN06 = *ON;
               *IN03 = *ON;
               QRY = '1';
               LEAVE;
             ENDIF;

         //  POSITION
             IF   C01POSN <> ' ';
               EXSR POS;
               ITER;
             ENDIF;

         //  Process the subfile
               @LV = @LV + 1;
               @SCN(@LV) = 'S01PRS';
               LEAVE;

            ENDDO;
       //
            RETURN;

      /space 3

       //--------------POS   -------------------------------//
           BEGSR     POS;


           FOR       WRKRC = 1 TO SFC01;
               CHAIN  WRKRC   S01;
                 IF        NOT %FOUND;
                    LEAVE;
                 ENDIF;

                 C01CHK  = %SUBST(S01WHFLD :1 : %LEN(%TRIM(C01POSN)));
                 IF   (C01POSN  = C01CHK  );
                    SRS01  = WRKRC;
                    LEAVE;
                 ENDIF;

           ENDFOR;


           ENDSR;


       //--------------*INZSR-------------------------------//
           BEGSR     @INZSR;
               @NSCN = *BLANK;

            C01FILE    =  FILE;
            C01LIB     =  LIB;
            C01MBR     =  MBR;
            C01RCDL    =  RCDL;
            C01ACCTP   =  ACCTP;
            C01WHTEXT  =  WHTEXT;
            C01RCORDS  =  RCDS;
            C01POSN    =  '  ' ;
            C01WHNAME  =  WHNAME;

           ENDSR;
      /END-FREE

     P @S01PRC         E

       //###################################################//
       //###################################################//
       //###################################################//
      /space 3
     P @S01PRS         B

     D @S01PRS         PI

          //
          //
     D WRKRC           S              4S 0
     D FX              S              5S 0

      /FREE

          EXSR      @INZSR;

         //  Process the subfile
           EXSR      SFL;
           *IN03 = '1';
           RETURN;

       //--------------  SFL -------------------------------//
           BEGSR      SFL;
        //  Process the subfile

           FOR       WRKRC = 1 TO SFC01+1;
               CHAIN  WRKRC   S01;
                 IF        NOT %FOUND;
         //  Finished with the subfile
         //  RETURN TO REBUILD LEVEL
                    @LV = @LV -2;
                    LEAVE;
                 ENDIF;

         //     RIGHT ADJUST OPTION
               S01OPT  = @OPADJ(S01OPT);

         //    UPDATE SELECTIONS
               EXSR UPD;

           ENDFOR;

           ENDSR;
       //---------------------------------------------------//

       //--------------UPD ---------------------------------//
           BEGSR      UPD;

       // UPDATE FIELD NAMES AND SELECT FLAG
                 FX = %LOOKUP(S01SFLD :FLD);
                 CHAIN  FX  QWHDRFFD;
                 WHFLDE  =  S01WHFLD;

                 IF @OPADJ(S01OPT) = ' S' OR
                    @OPADJ(S01OPT) = ' O';
                     ALL    = %TRIM(S01OPT);
                     WHFIOB = %TRIM(S01OPT);
                 ENDIF;

                 IF @OPADJ(S01OPT) = ' ';
                     WHFIOB = ' ';
                 ENDIF;
                  UPDATE  QWHDRFFD;

           ENDSR;


       //--------------*INZSR-------------------------------//
           BEGSR     @INZSR;
               ALL   = '1';
               @NSCN = *BLANK;
           ENDSR;


      /END-FREE
     P @S01PRS         E

       //###################################################//
       //###################################################//
       //###################################################//

     P @R9999          B
        //  Invalid Panel
     D @R9999          PI

     P @R9999          E


      /space 3
       //###################################################//
       //###################################################//
       //###################################################//
     P @OPADJ          B
        //   RIGHT ADJ OPTION , zero suppress

     D @OPADJ          PI             2A
     D  OPT                           2A

      /FREE
         EVALR  OPT   = %trimr(OPT);
         If %SubSt(OPT:1:1) =  '0';
         OPT   = ' ' +  %SubSt(OPT:2:1);
         EndIf;
         RETURN OPT;
      /END-FREE
     P @OPADJ          E

       //###################################################//
       //###################################################//
       //###################################################//
     P  RtvMsgTxt      B
      //************************************************************************
      // API Call: QMHRTVM Retrieve Message text
      //************************************************************************


       // USAGE
       // MsgTxt = RtvMsgTxt('MSG0001':cMsgF3:cMsgLib:cMsgLvl1);

     D  RtvMsgTxt      PI          1024
     D   RMsgId                       7    Const
     D   RMsgFle                     10    Const
     D   RMsgLib                     10    Const
     D   RMsgLvl                      1    Const

      // Retrieve Message Description API Prototype
     D  Get_Message    PR                  ExtPgm('QMHRTVM')
     D                             4000    Options(*VarSize)
     D                               10I 0 Const
     D                                8    Const
     D                                7
     D                               20    Const
     D                            32765    Options(*VarSize)
     D                               10I 0 Const
     D                               10    Const
     D                               10    Const
     D                             8192    Options(*VarSize)
     D                               10
     D                                9B 0
     D                                9B 0

      // Define Variables for QMHRTVM API call:
      // --------------------------------------
      // Return variables
     D  MessageInfo    DS          4000
     D   Data                  1   4000
     D   OSMSG                65     68B 0
     D   LMsgR                69     72B 0
     D   LMsgA                73     76B 0
     D   OSMSGH               77     80B 0
     D   LMsgHR               81     84B 0
     D   LMsgHA               85     88B 0

      // Required input variables
     D   MessageLen    S             10I 0
     D   MessageForm   S              8
     D   MessageIden   S              7
     D   MessageFile   S             20
     D   Replacement   S          32765
     D   ReplaceLen    S             10I 0
     D   ReplaceSub    S             10
     D   ReturnCtl     S             10

     D   RetrieveOpt   S             10
     D   ConvToCCSID   S              9B 0
     D   ReplDtaCCSID  S              9B 0

     D   Return_Text   S           1024

     D  ErrorCode      DS                  Qualified
     D   BytesProv                    4B 0 Inz(0)
     D   BytesAvail                   8B 0 Inz(0)
     D   ExceptionId                  7
     D   Reserved                     1
     D   ExceptionDta               512
      /FREE

         // Load API parameter fields
         MessageInfo   = *blanks;
         MessageLen    = 4000;
         MessageForm   = 'RTVM0300';
         MessageIden   = RMsgId;
         MessageFile   = RMsgFle + RMsgLib;
         Replacement   = *blanks;
         ReplaceLen    = %Len(Replacement);
         ReplaceSub    = '*YES';
         ReturnCtl     = '*YES';
         RetrieveOpt   = '*MSGID';
         ConvToCCSID   = 0;
         ReplDtaCCSID  = 0;

         // Retrieve message description
         Get_Message(MessageInfo :
                     MessageLen  :
                     MessageForm :
                     MessageIden :
                     MessageFile :
                     Replacement :
                     ReplaceLen  :
                     ReplaceSub  :
                     ReturnCtl   :
                     ErrorCode   :
                     RetrieveOpt :
                     ConvToCCSID :
                     ReplDtaCCSID);

         // Process Return variables
         Return_Text = *blanks;

         // If no errors, determine the correct portion of the message text
         If ErrorCode.BytesProv = 0;
           Select;
           When RMsgLvl = '1';
               Return_Text = %Subst(data:OSMSG+1:LMsgA);   // Msg Lvl 1
           When RMsgLvl = '2';
               Return_Text = %Subst(data:OSMSGH+1:LMsgHA);   // Msg Lvl 2
           EndSl;
         Else;
           Return_Text = 'Get_Message failed.';
         EndIf;

         // Return to calling point
         Return Return_Text;

      /END-FREE
     P                 E


       //###################################################//
       //###################################################//
       //###################################################//
     P GETROWCOL       B
      *
      *    Retreive a DSPF FIELD  Row and Col
      *    Used for Setting  CSRLOC for cursor positioning
      *    USAGE
      *    GETROWCOL  (FILE :'*LIBL' : FORMAT : FLDNAM : ROW : COL)
      *
     D GETROWCOL       PR
     D   schFile                     10A   const
     D   schLib                      10A   const
     D   schFormat                   10A   const
     D   schString                   32A   const
     D   rtnROW                       3P 0
     D   RtnCOL                       3P 0

     D GETROWCOL       PI
     D   schFile                     10A   const
     D   schLib                      10A   const
     D   schFormat                   10A   const
     D   schString                   32A   const
     D   rtnROW                       3P 0
     D   RtnCOL                       3P 0

     D QUSCRTUS        PR                  ExtPgm('QUSCRTUS')
     D   UserSpace                   20A   CONST
     D   ExtAttrib                   10A   CONST
     D   InitialSize                 10I 0 CONST
     D   InitialVal                   1A   CONST
     D   PublicAuth                  10A   CONST
     D   Text                        50A   CONST
     D   Replace                     10A   CONST options(*nopass)
     D   ErrorCode                32767A   options(*varsize:*nopass)

     D QUSPTRUS        PR                  ExtPgm('QUSPTRUS')
     D   UserSpace                   20A   CONST
     D   Pointer                       *

     D QUSDLTUS        PR                  ExtPgm('QUSDLTUS')
     D   UserSpace                   20A   CONST
     D   ErrorCode                32767A   options(*varsize)

     D QUSLFLD         PR                  ExtPgm('QUSLFLD')
     D   UsrSpc                      20A   const
     D   Format                       8A   const
     D   QualFile                    20A   const
     D   RcdFmt                      10A   const
     D   UseOvrd                      1A   const
     D   ErrorCode                32767A   options(*nopass:*varsize)

     D ErrorCode       ds                  qualified
     D   BytesProv                   10I 0 inz(0)
     D   BytesAvail                  10I 0 inz(0)

     D ListHeader      ds                  based(p_ListHeader)
     d   ListOffset                  10I 0 overlay(ListHeader:125)
     d   EntryCount                  10I 0 overlay(ListHeader:133)
     d   EntrySize                   10I 0 overlay(ListHeader:137)

     D Field           ds                  based(p_Field)
     D                                     qualified
     D  Name                         10a
     D  FILLER                      438a
     d  DspRow                       10i 0
     d  DspCol                       10i 0

     D TEMPSPC         C                   'GETROWCOL QTEMP'

     D x               s             10I 0

      /free

                  rtnrow =    999;
                  rtnrow =    999;
           // --------------------------------------------------
           // Delete the user space if it exists (ignore errors)
           ErrorCode.BytesProv = %size(ErrorCode);
           QUSDLTUS( TEMPSPC: ErrorCode );
           ErrorCode.BytesProv = 0;

           // --------------------------------------------------
           // Create a new 128k user space
           QUSCRTUS( TEMPSPC : 'SCHTEXT' : 128 * 1024   : x'00'
                   : '*EXCLUDE' : 'List of fields in file' : '*NO'
                   : ErrorCode );

           // --------------------------------------------------
           // Dump list of fields in file to user space
           // Invaid data is ignored an 999 returned for row and col
           monitor;
           QUSLFLD( TEMPSPC : 'FLDL0100'  : SchFile + SchLib
                  : SchFormat  : *OFF  : ErrorCode );
               on-Error;
                 RETURN;
            EndMon;
           // --------------------------------------------------
           // Get a pointer to the user space
           QUSPTRUS( TEMPSPC: p_ListHeader );

           // --------------------------------------------------
           // Loop through all fields in space, to get the field we need
           for x = 0 to (EntryCount - 1);
               p_Field = p_ListHeader + ListOffset + (EntrySize * x);

               if Field.Name = schString;
                  rtnRow =    Field.DspRow;
                  rtnCol =    Field.DspCol;
                 leave;
               endif;
           endfor;

           // --------------------------------------------------
           // Delete temp user space & end
           QUSDLTUS( TEMPSPC: ErrorCode );

            return;

      /end-free
     P                 E

#top

DISPYF RPG


     A*%%TS  SD  20101203  131649  KOLMANNF    REL-V5R4M0  5722-WDS
     A*  90/01/08  12:52:36                REL-R01M02  5728-PW1
     A*            16:33:07                REL-R08M00  5714-UT1
     A*%%EC
     A                                      DSPSIZ(24 80 *DS3)
     A                                      REF(*LIBL/QADSPFFD)
     A                                      PRINT
     A                                      CA03(03 'End of job')
     A                                      CA12(12 'Previous')
     A                                      CA04(04 'Add FIELDS')
     A                                      CA05(05 'Attr changes')
     A                                      CF06(06 'Field Select')
     A                                      CA07(07 'Name changes')
     A*****
     A*            15:04:39                REL-R08M00  5714-UT1
     A          R S01                       SFL
     A*%%TS  SD  20101203  131649  KOLMANNF    REL-V5R4M0  5722-WDS
     A  40                                  SFLNXTCHG
     A            S01OPT         2A  B  7  2
     A            S01KEYFLD      2A  O  7  5DSPATR(HI)
     A            S01WHFLD  R        B  7  8REFFLD(WHFLDI)
     A  23                                  DSPATR(HI)
     A N23                                  DSPATR(PR)
     A            S01WHFLDB R        B  7 19REFFLD(WHFLDB)
     A                                      EDTCDE(Z)
     A  25                                  DSPATR(HI)
     A N25                                  DSPATR(PR)
     A            S01SIZE        6A  O  7 25
     A            S01FROM        4Y 0O  7 32EDTCDE(Z)
     A            S01TO          4Y 0O  7 37EDTCDE(Z)
     A            S01DESC       35A  O  7 44
     A            S01WHFLDT R        B  7 42REFFLD(WHFLDT)
     A  25                                  DSPATR(HI)
     A N25                                  DSPATR(PR)
     A            S01SFLD   R        H      REFFLD(WHFLDI)
     A*****
     A*
     A          R C01                       SFLCTL(S01)
     A*%%TS  SD  20101203  131649  KOLMANNF    REL-V5R4M0  5722-WDS
     A                                      SFLSIZ(0015)
     A                                      SFLPAG(0014)
     A  88                                  CSRLOC(ROW01      COL01)
     A                                      OVERLAY
     A                                      TEXT('WORK WITH FIELDS')
     A  51                                  SFLDSP
     A  52                                  SFLDSPCTL
     A  53                                  SFLCLR
     A  99                                  SFLEND
     A            SRS01          4S 0H      SFLRCDNBR(CURSOR)
     A*
     A  89        C01MSG        79   M
     A            ROW01          3S 0H
     A            COL01          3S 0H
     A                                  1  3'File'
     A            C01FILE       10A  O  1  8DSPATR(HI)
     A                                  1 20'Lib'
     A            C01LIB        10A  O  1 24DSPATR(HI)
     A                                  1 37'Mbr'
     A            C01MBR        10A  O  1 41DSPATR(HI)
     A                                  1 53'Rcdlen'
     A            C01RCDL        4S 0O  1 60DSPATR(HI)
     A                                  1 66'Access'
     A            C01ACCTP       1A  O  1 73DSPATR(HI)
     A                                  2  3'Text'
     A            C01WHTEXT R        O  2  9REFFLD(WHTEXT)
     A                                      DSPATR(HI)
     A                                  2 60'#Records'
     A            C01RCORDS      7Y 0O  2 69DSPATR(HI)
     A                                      EDTCDE(Z)
     A            C01POSN       10A  I  3  7
     A                                  4  2'Select/Omit (S/O) fields for displ-
     A                                      ay.(Default *ALL)'
     A                                  5 11'Use Select Or Omit,not Select with-
     A                                       Omit'
     A                                  6  8'Name       Bytes  Size  From  To T-
     A                                      p   Description'
     A                                  4 54'Format'
     A            C01WHNAME R        O  4 61REFFLD(QWHDRFFD/WHNAME)
     A                                      DSPATR(HI)
     A          R R01
     A                                 23  2'F3-Exit F6-Data Sel'

#top

DISPX DSPF

     A                                      DSPSIZ(24 80 *DS3)
     A                                      PRINT
     A                                      CF02(02 'return')
     A                                      CF03(01 'exit')
     A          R SLT
     A                                      OVERLAY
     A                                  1  2'Qryslt:'
     A            QSLT        1509A  B  1 12CHECK(LC)
     A                                 20  1'F2-Return '
     A          R SLTR                      SFL
     A                                      SFLMSGRCD(21)
     A            MSGKEY                    SFLMSGKEY
     A            PGMQ                      SFLPGMQ
     A          R SLTC                      SFLCTL(SLTR   )
     A                                      OVERLAY
     A                                      SFLSIZ(50) SFLPAG(3)
     A N20                                  SFLEND
     A N20                                  SFLDSP
     A N20                                  SFLDSPCTL
     A N20                                  SFLINZ
     A  20                                  SFLCLR
     A            PGMQ                      SFLPGMQ

#top

FFDL01 LF

     A          R QWHDRFFD                  PFILE(FFD)
                K WHFILE

#top


COMPILE CL

/* COMPILE OBJECTS                    */
/* CRTBNDCL   PGM(KOLMANN/COMPILE) SRCFILE(KOLMANN/UDDSSRC)     */
/*            SRCMBR(COMPILE) OUTPUT(*NONE) REPLACE(*YES)       */
/* call compile ('KOLMANN' 'UDDSSRC')                           */
PGM (&LIB &SRCF)

DCL &LIB  *CHAR  10
DCL &SRCF *CHAR  10

CRTDTAARA  DTAARA(&LIB/UDDSSRC) TYPE(*CHAR) LEN(10) +
   VALUE(&SRCF) TEXT('SOURCE LIBRARY FOR  UDDS PROGRAMS')
MONMSG CPF0000

dltf qtemp/afile
monmsg cpf0000
CRTPF      FILE(QTEMP/AFILE) RCDLEN(80) OPTION(*NOLIST)

CRTDSPF    FILE(&LIB/DISPF) SRCFILE(&LIB/&SRCF) +
                          SRCMBR(DISPF) OPTION(*NOLIST *NOSRC) +
                          REPLACE(*YES)


DSPFFD  FILE(QTEMP/AFILE) OUTPUT(*OUTFILE) OUTFILE(QTEMP/FFD)
DLTF   FILE(QTEMP/FFDL01)
MONMSG CPF0000
CRTLF FILE(QTEMP/FFDL01) SRCFILE(&LIB/&SRCF) SRCMBR(FFDL01) +
OPTION(*NOSRC *NOLIST)

DSPFFD  FILE(QTEMP/FFD) OUTPUT(*OUTFILE) OUTFILE(QTEMP/FFFFD)
DSPFD (QTEMP/FFD ) TYPE(*ACCPTH) OUTPUT(*OUTFILE) OUTFILE(QTEMP/KFFFD )
OVRDBF     FILE(KF) TOFILE(QTEMP/KFFFD)
CRTBNDCL   PGM(&LIB/DISF) SRCFILE(&LIB/&SRCF) +
        DBGVIEW(*SOURCE)  SRCMBR(DISF) OUTPUT(*NONE) REPLACE(*YES)
CRTBNDCL   PGM(&LIB/DISV) SRCFILE(&LIB/&SRCF) +
        DBGVIEW(*SOURCE)  SRCMBR(DISV) OUTPUT(*NONE) REPLACE(*YES)

 CRTBNDRPG  PGM(&LIB/DISPY) SRCFILE(&LIB/&SRCF) +
    SRCMBR(DISPY) DBGVIEW(*SOURCE) OUTPUT(*NONE) REPLACE(*YES)


DLTF   FILE(QTEMP/REL)
MONMSG CPF0000
DLTF   FILE(QTEMP/SEL)
MONMSG CPF0000
DLTF   FILE(QTEMP/DBR)
MONMSG CPF0000

DSPFD      FILE(QTEMP/FFD) TYPE(*ACCPTH) +
  OUTPUT(*OUTFILE) OUTFILE(QTEMP/REL) OUTMBR(*FIRST *ADD)
DSPFD FILE(QTEMP/FFDL01) TYPE(*SELECT) OUTPUT(*OUTFILE) OUTFILE(QTEMP/SEL)
CRTDSPF    FILE(&LIB/DISPRF) SRCFILE(&LIB/&SRCF) +
                          SRCMBR(DISPRF) OPTION(*NOLIST *NOSRC) +
                          REPLACE(*YES)

DSPDBR     FILE(QTEMP/FFD) OUTPUT(*OUTFILE) +
   OUTFILE(QTEMP/DBR) OUTMBR(*FIRST *REPLACE)

DLTF   FILE(QTEMP/ACC)
MONMSG CPF0000
DSPFD FILE(QTEMP/FFDL01) TYPE(*ACCPTH) OUTPUT(*OUTFILE) OUTFILE(QTEMP/ACC)

CRTBNDRPG  PGM(&LIB/DISP) SRCFILE(&LIB/&SRCF) +
  SRCMBR(DISP) DBGVIEW(*SOURCE) OUTPUT(*NONE) REPLACE(*YES)
CRTBNDRPG  PGM(&LIB/DISP1) SRCFILE(&LIB/&SRCF) +
  SRCMBR(DISP1) DBGVIEW(*SOURCE) OUTPUT(*NONE) REPLACE(*YES)
CRTBNDRPG  PGM(&LIB/DISP2) SRCFILE(&LIB/&SRCF) +
  SRCMBR(DISP2) DBGVIEW(*SOURCE) OUTPUT(*NONE) REPLACE(*YES)

CRTBNDRPG  PGM(&LIB/DUSP) SRCFILE(&LIB/&SRCF) +
  SRCMBR(DUSP) DBGVIEW(*SOURCE)                REPLACE(*YES)
CRTBNDRPG  PGM(&LIB/DUSP1) SRCFILE(&LIB/&SRCF) +
  SRCMBR(DUSP1) DBGVIEW(*SOURCE) OUTPUT(*NONE) REPLACE(*YES)
CRTBNDRPG  PGM(&LIB/DUSP2) SRCFILE(&LIB/&SRCF) +
  SRCMBR(DUSP2) DBGVIEW(*SOURCE) OUTPUT(*NONE) REPLACE(*YES)

CRTBNDCL   PGM(&LIB/DIS) SRCFILE(&LIB/&SRCF) +
      DBGVIEW(*SOURCE)    SRCMBR(DIS) OUTPUT(*NONE) REPLACE(*YES)
CRTBNDCL   PGM(&LIB/DIS3) SRCFILE(&LIB/&SRCF) +
      DBGVIEW(*SOURCE)    SRCMBR(DIS3) OUTPUT(*NONE) REPLACE(*YES)
CRTBNDCL   PGM(&LIB/DIS4) SRCFILE(&LIB/&SRCF) +
      DBGVIEW(*SOURCE)    SRCMBR(DIS4) OUTPUT(*NONE) REPLACE(*YES)
CRTBNDCL   PGM(&LIB/DISBIN) SRCFILE(&LIB/&SRCF) +
      DBGVIEW(*SOURCE)    SRCMBR(DISBIN) OUTPUT(*NONE) REPLACE(*YES)

CRTBNDRPG  PGM(&LIB/DISPR) SRCFILE(&LIB/&SRCF) +
    SRCMBR(DISPR) DBGVIEW(*SOURCE) OUTPUT(*NONE) REPLACE(*YES)

CRTCMD CMD(&LIB/DSPFL) PGM(*LIBL/DIS) SRCFILE(&LIB/&SRCF)  +
             SRCMBR(DSPFL) VLDCKR(DISV)

CRTDSPF    FILE(&LIB/DISPX) SRCFILE(&LIB/&SRCF) +
                          SRCMBR(DISPX) OPTION(*NOLIST *NOSRC) +
                          REPLACE(*YES)
CRTBNDCL   PGM(&LIB/DIS1) SRCFILE(&LIB/&SRCF) +
       DBGVIEW(*SOURCE)   SRCMBR(DIS1) OUTPUT(*NONE) REPLACE(*YES)



ENDPGM


#top

TESTPF PF

     A          R TESTR
     A            ACTIV          1A         TEXT('Active flag (0 - inactive, 1')
     A            CMPNO          3P         TEXT('Company number              ')
     A            PLTNO          2P         TEXT('Plant number                ')
     A            PRDNO         15A         TEXT('Product number              ')
     A            OPBAL         13P 3       TEXT('Opening balance - this perio')
     A            SERVU          5S 2       TEXT('Service level based on units')
     A            QTY            5B 2       TEXT('QTY')
     A            QTYF          17F 4       FLTPCN(*DOUBLE)
     A            CCYYMMDD        L         TEXT('DATE')
     A            HHMMSS          T         TEXT('TIME')
     A            DATTIM          Z         TEXT('DATE TIME')
     A            VTEXT        100A         VARLEN
     A                                      TEXT('VARIABLE TEXT')
     A            DESCP         30A         TEXT('Product description or name ')

     A          K ACTIV
     A          K CMPNO
     A          K PRDNO
     A          K OPBAL
     A          K SERVU

#top

TESTPF1 PF

     A          R TESTR
     A            ACTIV          1A         TEXT('Active flag (0 - inactive, 1')
     A            CMPNO          3P         TEXT('Company number              ')
     A            PLTNO          2P         TEXT('Plant number                ')
     A            PRDNO         15A         TEXT('Product number              ')
     A            OPBAL         13P 3       TEXT('Opening balance - this perio')
     A            SERVU          5S 2       TEXT('Service level based on units')
     A            QTY            5B 2       TEXT('QTY')
     A            QTYF          17F 4       FLTPCN(*DOUBLE)
     A            CCYYMMDD        L         TEXT('DATE')
     A            HHMMSS          T         TEXT('TIME')
     A            DATTIM          Z         TEXT('DATE TIME')
     A            VTEXT        100A         VARLEN
     A                                      TEXT('VARIABLE TEXT')
     A            DESCP         30A         TEXT('Product description or name ')
     A            TXT1         500A         TEXT('TXT1  ')
     A            TXT2         500A         TEXT('TXT2  ')
     A            TXT3         500A         TEXT('TXT3  ')
     A            TXT4         500A         TEXT('TXT4  ')
     A          K ACTIV
     A          K CMPNO
     A          K PRDNO
     A          K OPBAL
     A          K SERVU

#top

TESTPF2 PF


     A          R TESTR
     A            ACTIV          1A         TEXT('Active flag (0 - inactive, 1')
     A            CMPNO          3P         TEXT('Company number              ')
     A            PLTNO          2P         TEXT('Plant number                ')
     A            PRDNO         15A         TEXT('Product number              ')
     A            OPBAL         13P 3       TEXT('Opening balance - this perio')
     A            SERVU          5S 2       TEXT('Service level based on units')
     A            QTY            5B 2       TEXT('QTY')
     A            QTYF          17F 4       FLTPCN(*DOUBLE)
     A            CCYYMMDD        L         TEXT('DATE')
     A            HHMMSS          T         TEXT('TIME')
     A            DATTIM          Z         TEXT('DATE TIME')
     A            VTEXT        100A         VARLEN
     A                                      TEXT('VARIABLE TEXT')
     A            DESCP         30A         TEXT('Product description or name ')
     A            TXT1         500A         TEXT('TXT1  ')
     A            TXT2         500A         TEXT('TXT2  ')
     A            TXT3         500A         TEXT('TXT3  ')
     A            TXT4         500A         TEXT('TXT4  ')
     A            TXT5         500A         TEXT('TXT5  ')
     A            TXT6         500A         TEXT('TXT6  ')
     A            TXT7         500A         TEXT('TXT7  ')
     A            TXT8         500A         TEXT('TXT8  ')
     A          K ACTIV
     A          K CMPNO
     A          K PRDNO
     A          K OPBAL
     A          K SERVU


#top