Difference between revisions of "UDDS File Display/Update"

From MidrangeWiki
Jump to: navigation, search
(DUSP1 RPG)
m (DIS1 CL files with NULL fields cant be processed)
 
(25 intermediate revisions by the same user not shown)
Line 2: Line 2:
  
  
==UDDS   UNDER  CONSTRUCTION  MORE  CODE TO BE ADDED SOON ==
+
==UDDS PROGRAMS THAT SHOW FILES FIELDS AND RELATIONS AND ALLOWS UPDATE ==
 
The manual that describes the 5250 data stream is 5494 Remote Control Unit, Functions Reference. SC30-3533-04 (topic 15) [http://tn5250.sourceforge.net/resources.html]
 
The manual that describes the 5250 data stream is 5494 Remote Control Unit, Functions Reference. SC30-3533-04 (topic 15) [http://tn5250.sourceforge.net/resources.html]
  
Line 8: Line 8:
 
The purpose of this program is to demo an example of a program using UDDS.
 
The purpose of this program is to demo an example of a program using UDDS.
  
It shows file data, but is limited to 6048 max rcdlen.   
+
It shows file data, but is limited to 6048 max rcdlen.  There are 3 programs first is limited to 2048 last to 6048.
  
 
Use the code below at your own risk, no warranty is expressed or implied or even that the code is functional.
 
Use the code below at your own risk, no warranty is expressed or implied or even that the code is functional.
  
  
I am also inculding wrapper programs to make the displayer more useful, but there is no 'make' instruction. I am assuming you know enough about compiling source to figure it out for yourself. Once compiled the command to run it is  'DSPFL  yourlib/yourfile '
+
I am also inculding wrapper programs to make the displayer more useful.
 +
The COMPILE CL will create the objects once you have copied the source code into a source file.  
 +
 
 +
Once compiled the command to run it is  'DSPFL  yourlib/yourfile '
 +
 
  
 
===DISP  RPG===
 
===DISP  RPG===
  
 
<pre>
 
<pre>
     H*eywords++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++Comments+++++++++++  
+
     H*eywords++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++Comments+++++++++++
 
     H OPTION(*NODEBUGIO)
 
     H OPTION(*NODEBUGIO)
 
     H DFTACTGRP(*NO) ACTGRP(*CALLER) DFTNAME(DISP )
 
     H DFTACTGRP(*NO) ACTGRP(*CALLER) DFTNAME(DISP )
Line 24: Line 28:
 
     F*  LIMITED TO MAXIMUM FILE LENGTH OF 2048
 
     F*  LIMITED TO MAXIMUM FILE LENGTH OF 2048
 
     F*  TEST
 
     F*  TEST
 +
    F*  REQUIRES FILE TO COMPILE
 +
    F*  DSPFFD  FILE(&LIB/&FILE) OUTPUT(*OUTFILE) OUTFILE(QTEMP/FFD)
 +
 
     FFFD      IF  E            DISK
 
     FFFD      IF  E            DISK
 
     FDISPF    CF  F  803        WORKSTN
 
     FDISPF    CF  F  803        WORKSTN
Line 993: Line 1,000:
 
           BEGSR  @PUTF;
 
           BEGSR  @PUTF;
  
         // WRITE DATA TO THE DISPLAY
+
              SELECT;
 +
                WHEN  *INU1;
 +
                RRN = RN1;
 +
                WHEN  *INU2;
 +
                RRN = RN2;
 +
              ENDSL;
 +
 
 +
         // IF GOT RECORDS WRITE DATA TO THE DISPLAY
  
 
             NEWRU  = '1';
 
             NEWRU  = '1';
Line 999: Line 1,013:
 
             RU    = *ALLX'00';
 
             RU    = *ALLX'00';
 
             CLEAR  RU;        //  initialise Request Unit  255 bytes max
 
             CLEAR  RU;        //  initialise Request Unit  255 bytes max
 +
 +
          IF RRN > 0    ;
 
             FOR  XX = 1 TO      NUMFKY; //NUMBER OF DATA ELEMENTS (FLD AND KEY)
 
             FOR  XX = 1 TO      NUMFKY; //NUMBER OF DATA ELEMENTS (FLD AND KEY)
  
Line 1,009: Line 1,025:
 
               WRTRRN = '0';
 
               WRTRRN = '0';
 
               RU  = RU + SBA + RBA ;
 
               RU  = RU + SBA + RBA ;
              SELECT;
 
                WHEN  *INU1;
 
                RRN = RN1;
 
                WHEN  *INU2;
 
                RRN = RN2;
 
              ENDSL;
 
 
               RU = RU + %TRIM(%EDITC(RRN:'Z'));
 
               RU = RU + %TRIM(%EDITC(RRN:'Z'));
 
             ENDIF;
 
             ENDIF;
Line 1,167: Line 1,177:
  
 
             ENDFOR;
 
             ENDFOR;
 +
          ENDIF;
  
 
             IF  %LEN(RU) > 5 AND %LEN(RU) < 250;
 
             IF  %LEN(RU) > 5 AND %LEN(RU) < 250;
Line 1,795: Line 1,806:
 
**
 
**
 
0123456789ABCDEF
 
0123456789ABCDEF
 
 
</pre>
 
</pre>
  
 
[[#top]]
 
[[#top]]
  
 
+
===DISP1 RPG===
===DISP1   RPG ===
 
  
 
<pre>
 
<pre>
 
+
     H*eywords++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++Comments+++++++++++
 
 
 
 
     H*eywords++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++Comments+++++++++++  
 
 
     H OPTION(*NODEBUGIO)
 
     H OPTION(*NODEBUGIO)
 
     H DFTACTGRP(*NO) ACTGRP(*CALLER) DFTNAME(DISP )
 
     H DFTACTGRP(*NO) ACTGRP(*CALLER) DFTNAME(DISP )
Line 1,813: Line 1,819:
 
     F*  LIMITED TO MAXIMUM FILE LENGTH OF 4080
 
     F*  LIMITED TO MAXIMUM FILE LENGTH OF 4080
 
     F*  TEST
 
     F*  TEST
 +
    F*  REQUIRES FILE TO COMPILE
 +
    F*  DSPFFD  FILE(&LIB/&FILE) OUTPUT(*OUTFILE) OUTFILE(QTEMP/FFD)
 +
 
     FFFD      IF  E            DISK
 
     FFFD      IF  E            DISK
 
     FDISPF    CF  F  803        WORKSTN
 
     FDISPF    CF  F  803        WORKSTN
Line 2,783: Line 2,792:
 
           BEGSR  @PUTF;
 
           BEGSR  @PUTF;
  
         // WRITE DATA TO THE DISPLAY
+
              SELECT;
 +
                WHEN  *INU1;
 +
                RRN = RN1;
 +
                WHEN  *INU2;
 +
                RRN = RN2;
 +
              ENDSL;
 +
         // IF GOT RECORDS WRITE DATA TO THE DISPLAY
  
 
             NEWRU  = '1';
 
             NEWRU  = '1';
Line 2,789: Line 2,804:
 
             RU    = *ALLX'00';
 
             RU    = *ALLX'00';
 
             CLEAR  RU;        //  initialise Request Unit  255 bytes max
 
             CLEAR  RU;        //  initialise Request Unit  255 bytes max
 +
 +
          IF RRN > 0    ;
 
             FOR  XX = 1 TO      NUMFKY; //NUMBER OF DATA ELEMENTS (FLD AND KEY)
 
             FOR  XX = 1 TO      NUMFKY; //NUMBER OF DATA ELEMENTS (FLD AND KEY)
  
Line 2,799: Line 2,816:
 
               WRTRRN = '0';
 
               WRTRRN = '0';
 
               RU  = RU + SBA + RBA ;
 
               RU  = RU + SBA + RBA ;
              SELECT;
 
                WHEN  *INU1;
 
                RRN = RN1;
 
                WHEN  *INU2;
 
                RRN = RN2;
 
              ENDSL;
 
 
               RU = RU + %TRIM(%EDITC(RRN:'Z'));
 
               RU = RU + %TRIM(%EDITC(RRN:'Z'));
 
             ENDIF;
 
             ENDIF;
Line 2,957: Line 2,968:
  
 
             ENDFOR;
 
             ENDFOR;
 +
          ENDIF;
  
 
             IF  %LEN(RU) > 5 AND %LEN(RU) < 250;
 
             IF  %LEN(RU) > 5 AND %LEN(RU) < 250;
Line 3,585: Line 3,597:
 
**
 
**
 
0123456789ABCDEF
 
0123456789ABCDEF
 +
 
</pre>
 
</pre>
  
 
[[#top]]
 
[[#top]]
  
 
+
===DISP2 RPG===
===DISP2   RPG ===
 
  
 
<pre>
 
<pre>
 
+
     H*eywords++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++Comments+++++++++++
     H*eywords++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++Comments+++++++++++  
 
 
     H OPTION(*NODEBUGIO)
 
     H OPTION(*NODEBUGIO)
 
     H DFTACTGRP(*NO) ACTGRP(*CALLER) DFTNAME(DISP )
 
     H DFTACTGRP(*NO) ACTGRP(*CALLER) DFTNAME(DISP )
 
     F*
 
     F*
 
     F*  LIMITED TO MAXIMUM FILE LENGTH OF 6080
 
     F*  LIMITED TO MAXIMUM FILE LENGTH OF 6080
+
 
 
     F*  REQUIRES FILE  QTEMP/FFD  TO COMPILE
 
     F*  REQUIRES FILE  QTEMP/FFD  TO COMPILE
 
     F*  use cmd DSPFFD  FILE(&LIB/&FILE) OUTPUT(*OUTFILE) OUTFILE(QTEMP/FFD)
 
     F*  use cmd DSPFFD  FILE(&LIB/&FILE) OUTPUT(*OUTFILE) OUTFILE(QTEMP/FFD)
+
 
 
     FFFD      IF  E            DISK
 
     FFFD      IF  E            DISK
 
     FDISPF    CF  F  803        WORKSTN
 
     FDISPF    CF  F  803        WORKSTN
Line 4,573: Line 4,584:
 
           BEGSR  @PUTF;
 
           BEGSR  @PUTF;
  
         // WRITE DATA TO THE DISPLAY
+
              SELECT;
 +
                WHEN  *INU1;
 +
                RRN = RN1;
 +
                WHEN  *INU2;
 +
                RRN = RN2;
 +
              ENDSL;
 +
 
 +
         // IF GOT RECORDS WRITE DATA TO THE DISPLAY
  
 
             NEWRU  = '1';
 
             NEWRU  = '1';
Line 4,579: Line 4,597:
 
             RU    = *ALLX'00';
 
             RU    = *ALLX'00';
 
             CLEAR  RU;        //  initialise Request Unit  255 bytes max
 
             CLEAR  RU;        //  initialise Request Unit  255 bytes max
 +
 +
          IF RRN > 0    ;
 
             FOR  XX = 1 TO      NUMFKY; //NUMBER OF DATA ELEMENTS (FLD AND KEY)
 
             FOR  XX = 1 TO      NUMFKY; //NUMBER OF DATA ELEMENTS (FLD AND KEY)
  
Line 4,588: Line 4,608:
 
             IF WRTRRN = '1';
 
             IF WRTRRN = '1';
 
               WRTRRN = '0';
 
               WRTRRN = '0';
               RU = RU + SBA + RBA ;
+
               RU = RU + SBA + RBA ;
              SELECT;
 
                WHEN  *INU1;
 
                RRN = RN1;
 
                WHEN  *INU2;
 
                RRN = RN2;
 
              ENDSL;
 
 
               RU = RU + %TRIM(%EDITC(RRN:'Z'));
 
               RU = RU + %TRIM(%EDITC(RRN:'Z'));
 
             ENDIF;
 
             ENDIF;
Line 4,747: Line 4,761:
  
 
             ENDFOR;
 
             ENDFOR;
 +
          ENDIF;
  
 
             IF  %LEN(RU) > 5 AND %LEN(RU) < 250;
 
             IF  %LEN(RU) > 5 AND %LEN(RU) < 250;
Line 5,380: Line 5,395:
 
[[#top]]
 
[[#top]]
  
===DUSP   RPG ===
+
===DUSP RPG===
  
 
<pre>
 
<pre>
     H*eywords++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++Comments+++++++++++  
+
     H*eywords++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++Comments+++++++++++
 
     H OPTION(*NODEBUGIO)
 
     H OPTION(*NODEBUGIO)
     H DFTACTGRP(*NO) ACTGRP(*CALLER) DFTNAME(DISP )
+
     H DFTACTGRP(*NO) ACTGRP(*CALLER) DFTNAME(DUSP )
 
     F*
 
     F*
 
     F*  LIMITED TO MAXIMUM FILE LENGTH OF 2048
 
     F*  LIMITED TO MAXIMUM FILE LENGTH OF 2048
 
     F*  REQUIRES FILE  QTEMP/FFD  TO COMPILE
 
     F*  REQUIRES FILE  QTEMP/FFD  TO COMPILE
 
     F*  use cmd DSPFFD  FILE(&LIB/&FILE) OUTPUT(*OUTFILE) OUTFILE(QTEMP/FFD)
 
     F*  use cmd DSPFFD  FILE(&LIB/&FILE) OUTPUT(*OUTFILE) OUTFILE(QTEMP/FFD)
+
 
 
     FFFD      IF  E            DISK
 
     FFFD      IF  E            DISK
 
     FDISPF    CF  F  803        WORKSTN
 
     FDISPF    CF  F  803        WORKSTN
Line 5,400: Line 5,415:
 
     FINPUTR    UF A F32766        DISK    EXTIND(*INU2)
 
     FINPUTR    UF A F32766        DISK    EXTIND(*INU2)
 
     F                                    INFDS(INFDR)
 
     F                                    INFDS(INFDR)
 +
 +
 +
    D DISBIN          PR                  extpgm('DISBIN')
 +
    D  NUM                          15P 0
 +
    D  BAN2                          2
 +
    D  BAN4                          4
 +
    D  BINTYP                        1    CONST
  
 
       *
 
       *
Line 5,487: Line 5,509:
 
     D NUP                    29    60P 0
 
     D NUP                    29    60P 0
  
     D WRU            S            61
+
    D NUC            S            15P 0
     D WRX            S            64
+
    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 WRXWRD          C                  '0                              -
 
     D                                                                    -'
 
     D                                                                    -'
Line 5,880: Line 5,919:
 
     I                                644  723  ID8              27
 
     I                                644  723  ID8              27
 
     I                                724  803  ID9              28
 
     I                                724  803  ID9              28
 
+
DCL V
  
 
       /FREE
 
       /FREE
Line 6,090: Line 6,129:
 
       //  MOVE A KEY FIELDS DATA FROM ID ARRAY (SCREEN) TO K ARRAY (KEY FIELDS)
 
       //  MOVE A KEY FIELDS DATA FROM ID ARRAY (SCREEN) TO K ARRAY (KEY FIELDS)
  
      //  GET SIZE OF FIELD IN BYTES
+
            //  GET SIZE OF FIELD IN BYTES
           IF T(Y)  =  'A';  // ALPHA DATA
+
        SELECT;
 +
           WHEN  T(Y)  =  'A';  // ALPHA DATA
 
           K = ' ';
 
           K = ' ';
 
           K1 = 1;
 
           K1 = 1;
 
           K2 = Q(Y);
 
           K2 = Q(Y);
           ELSE;
+
           WHEN  T(Y)  =  'F';  // FLOAT
 +
          K  = '0';
 +
          K1 =  1;
 +
          K2 = L(Y);
 +
          OTHER;
 
           K  = '0';
 
           K  = '0';
 
           K1 =  1;
 
           K1 =  1;
 
           K2 = C(Y);
 
           K2 = C(Y);
          ENDIF;
+
        ENDSL;
 +
 
  
 
       // IF WHOLE KEY INIT WAS REQUESTED BYPASS THE EXTRACT
 
       // IF WHOLE KEY INIT WAS REQUESTED BYPASS THE EXTRACT
Line 6,408: Line 6,453:
 
           BEGSR  @PUTF;
 
           BEGSR  @PUTF;
  
         // WRITE DATA TO THE DISPLAY
+
              SELECT;
 +
                WHEN  *INU1;
 +
                RRN = RN1;
 +
                WHEN  *INU2;
 +
                RRN = RN2;
 +
              ENDSL;
 +
         // IF GOT RECORDS WRITE DATA TO THE DISPLAY
  
 
             NEWRU  = '1';
 
             NEWRU  = '1';
Line 6,414: Line 6,465:
 
             RU    = *ALLX'00';
 
             RU    = *ALLX'00';
 
             CLEAR  RU;        //  initialise Request Unit  255 bytes max
 
             CLEAR  RU;        //  initialise Request Unit  255 bytes max
 +
 +
          IF RRN > 0    ;
 
             FOR  XX = 1 TO      NUMFKY; //NUMBER OF DATA ELEMENTS (FLD AND KEY)
 
             FOR  XX = 1 TO      NUMFKY; //NUMBER OF DATA ELEMENTS (FLD AND KEY)
  
Line 6,424: Line 6,477:
 
               WRTRRN = '0';
 
               WRTRRN = '0';
 
               RU  = RU + SBA + RBA ;
 
               RU  = RU + SBA + RBA ;
              SELECT;
 
                WHEN  *INU1;
 
                RRN = RN1;
 
                WHEN  *INU2;
 
                RRN = RN2;
 
              ENDSL;
 
 
               RU = RU + %TRIM(%EDITC(RRN:'Z'));
 
               RU = RU + %TRIM(%EDITC(RRN:'Z'));
 
             ENDIF;
 
             ENDIF;
Line 6,582: Line 6,629:
  
 
             ENDFOR;
 
             ENDFOR;
 +
          ENDIF;
  
 
             IF  %LEN(RU) > 5 AND %LEN(RU) < 250;
 
             IF  %LEN(RU) > 5 AND %LEN(RU) < 250;
Line 7,205: Line 7,253:
  
 
       //  GET SIZE OF FIELD IN BYTES
 
       //  GET SIZE OF FIELD IN BYTES
           IF T(Y)  =  'A';  // ALPHA DATA
+
        SELECT;
 +
           WHEN  T(Y)  =  'A';  // ALPHA DATA
 
           K = ' ';
 
           K = ' ';
 
           K1 = 1;
 
           K1 = 1;
 
           K2 = Q(Y);
 
           K2 = Q(Y);
           ELSE;
+
           WHEN  T(Y)  =  'F';  // FLOAT
 +
          K  = '0';
 +
          K1 =  1;
 +
          K2 = L(Y);
 +
          OTHER;
 
           K  = '0';
 
           K  = '0';
 
           K1 =  1;
 
           K1 =  1;
 
           K2 = C(Y);
 
           K2 = C(Y);
          ENDIF;
+
        ENDSL;
  
 
           X  =  1;
 
           X  =  1;
Line 7,284: Line 7,337:
 
         //  the data start is in S(Y)
 
         //  the data start is in S(Y)
 
         //  the data is in array K
 
         //  the data is in array K
         //  get the length of the data cvt to bin and stik in pos 1 2
+
         //  get the length of the data cvt to bin and stick in pos 1 2
 
         //  put the rest in pos 3 onwards
 
         //  put the rest in pos 3 onwards
  
Line 7,337: Line 7,390:
 
       //  BINARY FIELDS
 
       //  BINARY FIELDS
 
         IF  T(Y) =  'B';
 
         IF  T(Y) =  'B';
 +
 +
          NUSA= *BLANKS;
 +
          FOR VX = 1 TO 60;
 +
            NUSA = %TRIM(NUSA) + NU(VX);
 +
          ENDFOR;
 +
            NUC  = NUS;
  
 
         IF  Q(Y) = 2 ;
 
         IF  Q(Y) = 2 ;
          BY2 = NU(1) + NU(2);
+
              DISBIN ( NUC : BAN2 : BAN4  : '2');
          %SUBST(DATA : W : 2)  =  BY2;
+
            %SUBST(DATA : W : 2)  =  BAN2;
 
         ENDIF;
 
         ENDIF;
  
 
         IF  Q(Y) = 4 ;
 
         IF  Q(Y) = 4 ;
          BY4 = NU(1) + NU(2) + NU(3) + NU(4);
+
              DISBIN ( NUC : BAN2 : BAN4  : '4');
          %SUBST(DATA : W : 4)  =  BY4;
+
            %SUBST(DATA : W : 4)  =  BAN4;
 
         ENDIF;
 
         ENDIF;
  
 
         ENDIF;
 
         ENDIF;
 +
 +
 +
      //  FLOAT FIELDS
 +
        IF  T(Y) =  'F';
 +
 +
        IF  Q(Y) = 4;
 +
          NUFA= *BLANKS;
 +
          FOR VX = 1 TO 14;
 +
            NUFA = %TRIM(NUFA) + K(VX);
 +
          ENDFOR;
 +
 +
          result4 = %float(NUF1);
 +
        %SUBST(DATA : W : 4)  =  NUFW4;
 +
 +
        ENDIF;
 +
 +
 +
        IF  Q(Y) = 8;
 +
          NUFA= *BLANKS;
 +
          FOR VX = 1 TO 23;
 +
            NUFA = %TRIM(NUFA) + K(VX);
 +
          ENDFOR;
 +
 +
          result8 = %float(NUF);
 +
          %SUBST(DATA : W : 8)  =  NUFW8;
 +
 +
        ENDIF;
 +
 +
        ENDIF;
 +
 +
  
 
         //  UPDATE KEY IF NECESSARY
 
         //  UPDATE KEY IF NECESSARY
Line 7,668: Line 7,758:
 
**
 
**
 
0123456789ABCDEF
 
0123456789ABCDEF
 +
  
 
</pre>
 
</pre>
Line 7,673: Line 7,764:
 
[[#top]]
 
[[#top]]
  
===DUSP1   RPG ===
+
===DUSP1 RPG===
  
 
<pre>
 
<pre>
     H*eywords++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++Comments+++++++++++  
+
     H*eywords++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++Comments+++++++++++
 
     H OPTION(*NODEBUGIO)
 
     H OPTION(*NODEBUGIO)
     H DFTACTGRP(*NO) ACTGRP(*CALLER) DFTNAME(DISP )
+
     H DFTACTGRP(*NO) ACTGRP(*CALLER) DFTNAME(DUSP1 )
 
     F*
 
     F*
 
     F*  LIMITED TO MAXIMUM FILE LENGTH OF 4080
 
     F*  LIMITED TO MAXIMUM FILE LENGTH OF 4080
 
     F*  REQUIRES FILE  QTEMP/FFD  TO COMPILE
 
     F*  REQUIRES FILE  QTEMP/FFD  TO COMPILE
 
     F*  use cmd DSPFFD  FILE(&LIB/&FILE) OUTPUT(*OUTFILE) OUTFILE(QTEMP/FFD)
 
     F*  use cmd DSPFFD  FILE(&LIB/&FILE) OUTPUT(*OUTFILE) OUTFILE(QTEMP/FFD)
+
 
 
     FFFD      IF  E            DISK
 
     FFFD      IF  E            DISK
 
     FDISPF    CF  F  803        WORKSTN
 
     FDISPF    CF  F  803        WORKSTN
Line 7,693: Line 7,784:
 
     FINPUTR    UF A F32766        DISK    EXTIND(*INU2)
 
     FINPUTR    UF A F32766        DISK    EXTIND(*INU2)
 
     F                                    INFDS(INFDR)
 
     F                                    INFDS(INFDR)
 +
 +
    D DISBIN          PR                  extpgm('DISBIN')
 +
    D  NUM                          15P 0
 +
    D  BAN2                          2
 +
    D  BAN4                          4
 +
    D  BINTYP                        1    CONST
  
 
       *
 
       *
Line 7,779: Line 7,876:
 
     D NUPA                    1    60
 
     D NUPA                    1    60
 
     D NUP                    29    60P 0
 
     D NUP                    29    60P 0
 +
 +
    D NUC            S            15P 0
 +
    D BAN2            S              2
 +
DCL  D BAN4            S              4
  
 
     D WRU            S            61
 
     D WRU            S            61
Line 7,817: Line 7,918:
  
 
     D                DS
 
     D                DS
 +
    D  DATA                  1  4080
 
     D  D                      1  4080
 
     D  D                      1  4080
 
     D                                    DIM(4080)                            INCOMING DATA
 
     D                                    DIM(4080)                            INCOMING DATA
Line 7,951: Line 8,053:
 
     D KEYLNA                  1      4
 
     D KEYLNA                  1      4
  
     DDUSP            PR
+
     DDUSP1            PR
 
     D                                1
 
     D                                1
 
     D                                1
 
     D                                1
Line 7,959: Line 8,061:
 
     D                                5
 
     D                                5
 
     D                              800
 
     D                              800
     DDUSP            PI
+
     DDUSP1            PI
 
     D  ALL                          1
 
     D  ALL                          1
 
     D  RTN                          1
 
     D  RTN                          1
Line 8,702: Line 8,804:
 
           BEGSR  @PUTF;
 
           BEGSR  @PUTF;
  
         // WRITE DATA TO THE DISPLAY
+
              SELECT;
 +
                WHEN  *INU1;
 +
                RRN = RN1;
 +
                WHEN  *INU2;
 +
                RRN = RN2;
 +
              ENDSL;
 +
         // IF GOT RECORDS WRITE DATA TO THE DISPLAY
  
            NEWRU  = '1';
+
            NEWRU  = '1';
            WRTRRN = '1';
+
            WRTRRN = '1';
 
             RU    = *ALLX'00';
 
             RU    = *ALLX'00';
 
             CLEAR  RU;        //  initialise Request Unit  255 bytes max
 
             CLEAR  RU;        //  initialise Request Unit  255 bytes max
 +
 +
          IF RRN > 0    ;
 
             FOR  XX = 1 TO      NUMFKY; //NUMBER OF DATA ELEMENTS (FLD AND KEY)
 
             FOR  XX = 1 TO      NUMFKY; //NUMBER OF DATA ELEMENTS (FLD AND KEY)
  
Line 8,718: Line 8,828:
 
               WRTRRN = '0';
 
               WRTRRN = '0';
 
               RU  = RU + SBA + RBA ;
 
               RU  = RU + SBA + RBA ;
              SELECT;
 
                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,876: Line 8,980:
  
 
             ENDFOR;
 
             ENDFOR;
 +
          ENDIF;
  
 
             IF  %LEN(RU) > 5 AND %LEN(RU) < 250;
 
             IF  %LEN(RU) > 5 AND %LEN(RU) < 250;
Line 9,631: Line 9,736:
 
       //  BINARY FIELDS
 
       //  BINARY FIELDS
 
         IF  T(Y) =  'B';
 
         IF  T(Y) =  'B';
 +
 +
          NUSA= *BLANKS;
 +
          FOR VX = 1 TO 60;
 +
            NUSA = %TRIM(NUSA) + NU(VX);
 +
          ENDFOR;
 +
            NUC  = NUS;
  
 
         IF  Q(Y) = 2 ;
 
         IF  Q(Y) = 2 ;
          BY2 = NU(1) + NU(2);
+
              DISBIN ( NUC : BAN2 : BAN4  : '2');
          %SUBST(DATA : W : 2)  =  BY2;
+
            %SUBST(DATA : W : 2)  =  BAN2;
 
         ENDIF;
 
         ENDIF;
  
 
         IF  Q(Y) = 4 ;
 
         IF  Q(Y) = 4 ;
          BY4 = NU(1) + NU(2) + NU(3) + NU(4);
+
              DISBIN ( NUC : BAN2 : BAN4  : '4');
          %SUBST(DATA : W : 4)  =  BY4;
+
            %SUBST(DATA : W : 4)  =  BAN4;
 
         ENDIF;
 
         ENDIF;
  
Line 9,666: Line 9,777:
  
 
     OINPUTK    E    U1      UPDATREC
 
     OINPUTK    E    U1      UPDATREC
     O                      DA                
+
     O                      DA
 
     O              30      DB
 
     O              30      DB
 
     O              31      DC
 
     O              31      DC
Line 9,732: Line 9,843:
 
     O              93      D6A
 
     O              93      D6A
 
     OINPUTR    E      U2  UPDATREC
 
     OINPUTR    E      U2  UPDATREC
     O                      DA                
+
     O                      DA
 
     O              30      DB
 
     O              30      DB
 
     O              31      DC
 
     O              31      DC
Line 9,799: Line 9,910:
  
 
     OINPUTK    EADD U1      ADDREC
 
     OINPUTK    EADD U1      ADDREC
     O                      DA                
+
     O                      DA
 
     O              30      DB
 
     O              30      DB
 
     O              31      DC
 
     O              31      DC
Line 9,865: Line 9,976:
 
     O              93      D6A
 
     O              93      D6A
 
     OINPUTR    EADD    U2  ADDREC
 
     OINPUTR    EADD    U2  ADDREC
     O                      DA                
+
     O                      DA
 
     O              30      DB
 
     O              30      DB
 
     O              31      DC
 
     O              31      DC
Line 9,963: Line 10,074:
 
0123456789ABCDEF
 
0123456789ABCDEF
  
</pre>
 
 
[[#top]]
 
 
===DUSP2  RPG ===
 
 
<pre>
 
  
 
</pre>
 
</pre>
Line 9,975: Line 10,079:
 
[[#top]]
 
[[#top]]
  
===DISPF  DSPF ===
+
===DUSP2  RPG===
  
 
<pre>
 
<pre>
     A                                      DSPSIZ(24 80 *DS3)
+
     H*eywords++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++Comments+++++++++++
     A                                      PRINT
+
    H OPTION(*NODEBUGIO)
     A                                      OPENPRT
+
     H DFTACTGRP(*NO) ACTGRP(*CALLER) DFTNAME(DUSP2 )
     A                                      HELP
+
     F*
     A                                      INDARA
+
     F*  LIMITED TO MAXIMUM FILE LENGTH OF 6080
     A          R PUT                      USRDFN
+
     F*  REQUIRES FILE  QTEMP/FFD  TO COMPILE
    A          R GET                      USRDFN
+
     F*  use cmd DSPFFD  FILE(&LIB/&FILE) OUTPUT(*OUTFILE) OUTFILE(QTEMP/FFD)
    A                                      INVITE
 
</pre>
 
  
 +
    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)
  
[[#top]]
+
    D DISBIN          PR                  extpgm('DISBIN')
 +
    D  NUM                          15P 0
 +
    D  BAN2                          2
 +
    D  BAN4                          4
 +
    D  BINTYP                        1    CONST
  
== WRAPPER CODE ==
+
      *
 
+
    D A              S            255                                        WORK RU
===DSPFF   CMD ===
+
    D RU              S            255   varying
 
+
    D RW              S              1                                        ROW 1 byte binary
<pre>
+
    D CL              S              1                                        COL 1 byte binary
 
+
    D FNC            S              1
</pre>
+
    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
  
[[#top]]
+
    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
  
===DIS    CLE ===
 
  
<pre>
+
    D                DS
 +
    D TEXT500                      500
 +
    D LVW                          10    DIM(50) overlay(TEXT500:1)
  
</pre>
+
    D TEXT800        S            800
 +
    D KW              S            800
  
[[#top]]
+
    D                DS
 +
    D WRK11                  1    11
 +
    D NUM11                  1    11S 0
  
===DIS1  CLE ===
+
    D                DS
 +
    D NUSA                    1    60
 +
    D NUS                    1    60S 0
 +
    D                DS
 +
    D NUPA                    1    60
 +
    D NUP                    29    60P 0
  
<pre>
+
    D NUC            S            15P 0
 +
    D BAN2            S              2
 +
DCL  D BAN4            S              4
  
</pre>
 
  
[[#top]]
+
    D WRU            S            61
 +
    D WRX            S            64
 +
    D WRXWRD          C                  '0                              -
 +
    D                                                                    -'
 +
    D WRSWRD          C                  '0                              -
 +
    D                                                                  -'
 +
    D WRV            S            60    varying
  
===DIS3  CLE ===
+
    D FLT14          S            14
 +
    D FLT23          S            23
  
<pre>
+
      * SET FILE SIZE INCREMENTS (64 OF THEM)
 
+
    D SZ              S              5  0 DIM(64)
</pre>
+
    D S              S              5  0 DIM(9000)                            START OF FLD
 
+
    D E              S              5  0 DIM(9000)                            END OF FLD
[[#top]]
+
    D Q              S              5  0 DIM(9000)                            BYTES IN FIELD
 
+
    D L              S              5  0 DIM(9000)                            LENGTH OF FLD
===DISV   CLE ===
+
    D C              S              3  0 DIM(9000)                            DEC DIGITS
 
+
    D P              S              3  0 DIM(9000)                            DEC PRECISION
<pre>
+
    D B              S              2    DIM(9000) ASCEND                    BUFFER ADD
 
+
    D I              S              2    DIM(9000)                            FLD FMT
</pre>
+
    D N              S            10    DIM(9000)                            FLD NAME
 
+
    D T              S              1    DIM(9000)                            FLD TYPE
[[#top]]
+
    D V              S              1    DIM(9000)                            VARYING
 
+
    D KY              S              1    DIM(9000)                            KEYED
===DISF   CLE ===
+
    D KE              S            10    DIM(128)                            KEY FLDS
 
+
    D R              S              3  0 DIM(9000)                            KEY FLD START
<pre>
+
    D K              S              1    DIM(800)                            KEY
 
+
    D NA              S              1    DIM(10)                              NAME WORK
</pre>
+
    D NU              S              1    DIM(60)                              NUM. WORK
 
+
    D LV              S            10    DIM(50)                              SCREEN LEVELS
[[#top]]
+
    D MSG            S            32    DIM(8) CTDATA PERRCD(1)              MESSAGES
 
+
    D CNS            S            79    DIM(2) CTDATA PERRCD(1)
===DISPR   RPG ===
+
    D CRS            S              1    DIM(16) CTDATA PERRCD(16)
 
+
    D                DS
<pre>
+
    D  DATA                  1  6080
 
+
    D  D                      1  6080
</pre>
+
    D                                    DIM(6080)                            INCOMING DATA
 
+
    D  DA                    1  4048
[[#top]]
+
    D                                    DIM(4048)
 
+
    D  DB                  4049  4064
===DISPRF   DSPF ===
+
    D  DC                  4065  4096
 
+
    D  DD                  4097  4128
<pre>
+
    D  DE                  4129  4160
 
+
    D  DF                  4161  4192
</pre>
+
    D  DG                  4193  4224
 
+
    D  DH                  4225  4256
[[#top]]
+
    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
  
===DISPY    RPG ===
+
    D                DS
 +
    D  BIN4                  1      4B 0
 +
    D  BY4                    1      4
  
<pre>
+
    D                DS
 +
    D  BIN2                  1      2B 0
 +
    D  BY2                    1      2
  
</pre>
+
    D                DS
 +
    D  FLT4                  1      4F
 +
    D  FL4                    1      4
  
[[#top]]
+
    D                DS
 
+
    D  FLT8                  1      8F
===DISPYF   DSPF ===
+
    D  FL8                    1      8
 +
 
 +
    D INFDK          DS
 +
    D  F1                    83    92
 +
    D  L1                    93    102
 +
    D  M1                  129    138
 +
    D  R1                  125    126B 0
 +
    D  A1                  160    160
 +
    D  LOP1                260    260
 +
    D  KEY_LEN              393    394I 0                                      Key length
 +
    D  RN1                  397    400B 0
 +
    D  LKY                  401  1200
 +
    D INFDR          DS
 +
    D  F2                    83    92
 +
    D  L2                    93    102
 +
    D  M2                  129    138
 +
    D  R2                  125    126B 0
 +
    D  A2                  160    160
 +
    D  LOP2                260    260
 +
    D  RN2                  397    400B 0
 +
    D*
 +
    D INFDS          DS
 +
    D  CURLOC              370    371
 +
    D                DS
 +
    D KEYLN                  1      4S 0
 +
    D KEYLNA                  1      4
 +
 
 +
    DDUSP2            PR
 +
    D                                1
 +
    D                                1
 +
    D                                4
 +
    D                                1
 +
    D                              500
 +
    D                                5
 +
    D                              800
 +
    DDUSP2            PI
 +
    D  ALL                          1
 +
    D  RTN                          1
 +
    D  KEYLNG                      4
 +
    D  UPDF                        1
 +
    D  SCNLV                      500
 +
    D  SCNLVL                      5
 +
    D  SCNKEY                    800
 +
 
 +
 
 +
    D @LOOP          C                  '1'
 +
    D @FALSE          C                  '0'
 +
    D @TRUE          C                  '1'
 +
 
 +
    D SND            C                  X'71'                                SEND TO DISP
 +
    D SNR            C                  X'73'                                SND/RCV
 +
    D RED            C                  X'42'                                READ
 +
    D RDM            C                  X'52'                                READ MTD
 +
    D ESC            C                  X'04'                                ESCAPE
 +
    D CLR            C                  X'40'                                CLEAR UNIT
 +
    D CC1            C                  X'00'                                CNTRL CHAR
 +
    D CC2            C                  X'08'                                CNTRL CHAR
 +
    D SBA            C                  X'11'                                SET BUFF ADR
 +
    D IC              C                  X'13'                                INSERT CURS
 +
    D WTD            C                  X'11'                                WRITE TO DSP
 +
    D WER            C                  X'21'                                WRITE ERROR
 +
    D SF              C                  X'1D'                                START FLD
 +
    D ATC            C                  X'20'                                ATTR CHAR
 +
    D ATN            C                  X'24'                                ATTR NUM
 +
    D X00            C                  X'00'
 +
    D X01            C                  X'01'
 +
    D X02            C                  X'02'
 +
    D X03            C                  X'03'
 +
    D X0D            C                  X'0D'
 +
    D X0F            C                  X'0F'
 +
    D X000            C                  X'0000'
 +
    D X1F            C                  X'1F'
 +
    D X20            C                  X'20'                                SCRN ATT NORMAL
 +
    D X22            C                  X'22'                                SCRN ATTR HI
 +
    D X25            C                  X'25'
 +
    D X26            C                  X'26'
 +
    D X31            C                  X'31'                                CMD 1 KEY
 +
    D X32            C                  X'32'                                CMD 2 KEY
 +
    D X33            C                  X'33'                                CMD 3 KEY
 +
    D X36            C                  X'36'                                CMD 6 KEY
 +
    D X37            C                  X'37'                                CMD 7 KEY
 +
    D X38            C                  X'38'                                CMD 8 KEY
 +
    D X39            C                  X'39'                                CMD 9 KEY
 +
    D X3B            C                  X'3B'                                CMD11 KEY
 +
    D XB7            C                  X'B7'                                CMD19 KEY
 +
    D XB8            C                  X'B8'                                CMD20 KEY
 +
    D X40            C                  X'40'
 +
    D X43            C                  X'43'
 +
    D X47            C                  X'47'
 +
    D X60            C                  X'60'
 +
    D X67            C                  X'67'
 +
    D X9F            C                  X'9F'
 +
    D XF0            C                  X'F0'
 +
    D XD0            C                  X'D0'
 +
    D X4000          C                  X'4000'
 +
    D X4800          C                  X'4800'                              FF ALPHA
 +
    D X4F06          C                  X'4F06'                              FF NUMERIC
 +
    D X6000          C                  X'6000'                              FF ALPHA
 +
    D X6706          C                  X'6706'                              FF NUMERIC
 +
    D CLRWTD          C                  X'044004112000'                      INCLUDES ESC CHARS
 +
    D RDDSP          C                  X'0411200804524000'                  READ FROM DISPLAY
 +
    D FFA1            S              1    INZ(X'40')                          F.FMT 1 ALPH  60 BYP
 +
    D FFA2            S              1    INZ(X'00')                          F.FMT 2 ALPH
 +
    D FFN1            S              1    INZ(X'47')                          F.FMT 1 NUM  67 BYP
 +
    D FFN2            S              1    INZ(X'06')                          F.FMT 2 NUM
 +
    I*.
 +
 
 +
0038 IINPUTK    NS  01
 +
0039 I                                  1 4048  DA
 +
0040 I                              4049 4064  DB                30
 +
0041 I                              4065 4096  DC                31
 +
0042 I                              4097 4128  DD                32
 +
0043 I                              4129 4160  DE                33
 +
0044 I                              4161 4192  DF                34
 +
0045 I                              4193 4224  DG                35
 +
0046 I                              4225 4256  DH                36
 +
0047 I                              4257 4288  DI                37
 +
0048 I                              4289 4320  DJ                38
 +
0049 I                              4321 4352  DK                39
 +
0050 I                              4353 4384  DL                40
 +
0051 I                              4385 4416  DM                41
 +
0052 I                              4417 4448  DN                42
 +
0053 I                              4449 4480  DZ                43
 +
0054 I                              4481 4512  DO                44
 +
0055 I                              4513 4544  DP                45
 +
0056 I                              4545 4576  DQ                46
 +
0057 I                              4577 4608  DR                47
 +
0058 I                              4609 4640  DS                48
 +
0059 I                              4641 4672  DT                49
 +
0060 I                              4673 4704  DU                50
 +
0061 I                              4705 4736  DV                51
 +
0062 I                              4737 4768  DW                52
 +
0063 I                              4769 4800  DX                53
 +
0064 I                              4801 4832  DY                54
 +
0065 I                              4833 4864  D0                55
 +
0066 I                              4865 4896  D1                56
 +
0067 I                              4897 4928  D2                57
 +
0068 I                              4929 4960  D3                58
 +
0069 I                              4961 4992  D4                59
 +
0070 I                              4993 5024  D5                60
 +
0071 I                              5025 5056  D6                61
 +
0072 I                              5057 5088  DBA              62
 +
0073 I                              5089 5120  DCA              63
 +
0074 I                              5121 5152  DDA              64
 +
0075 I                              5153 5184  DEA              65
 +
0076 I                              5185 5216  DFA              66
 +
0077 I                              5217 5248  DGA              67
 +
0078 I                              5249 5280  DHA              68
 +
0079 I                              5281 5312  DIA              69
 +
0080 I                              5313 5344  DJA              70
 +
0081 I                              5345 5376  DKA              71
 +
0082 I                              5377 5408  DLA              72
 +
0083 I                              5409 5440  DMA              73
 +
0084 I                              5441 5472  DNA              74
 +
0085 I                              5473 5504  DOA              75
 +
0086 I                              5505 5536  DPA              76
 +
0087 I                              5537 5568  DQA              77
 +
0088 I                              5569 5600  DRA              78
 +
0089 I                              5601 5632  DSA              79
 +
0090 I                              5633 5664  DTA              80
 +
0091 I                              5665 5696  DUA              81
 +
0092 I                              5697 5728  DVA              82
 +
0093 I                              5729 5760  DWA              83
 +
0094 I                              5761 5792  DXA              84
 +
0095 I                              5793 5824  DYA              85
 +
0096 I                              5825 5856  DZA              86
 +
0097 I                              5857 5888  D0A              87
 +
0098 I                              5889 5920  D1A              88
 +
0099 I                              5921 5952  D2A              89
 +
0100 I                              5953 5984  D3A              90
 +
0101 I                              5985 6016  D4A              91
 +
0102 I                              6017 6048  D5A              92
 +
0103 I                              6049 6080  D6A              93
 +
0104 IINPUTR    NS  01
 +
0105 I                                  1 4048  DA
 +
0106 I                              4049 4064  DB                30
 +
0107 I                              4065 4096  DC                31
 +
0108 I                              4097 4128  DD                32
 +
0109 I                              4129 4160  DE                33
 +
0110 I                              4161 4192  DF                34
 +
0111 I                              4193 4224  DG                35
 +
0112 I                              4225 4256  DH                36
 +
0113 I                              4257 4288  DI                37
 +
0114 I                              4289 4320  DJ                38
 +
0115 I                              4321 4352  DK                39
 +
0116 I                              4353 4384  DL                40
 +
0117 I                              4385 4416  DM                41
 +
0118 I                              4417 4448  DN                42
 +
0119 I                              4449 4480  DZ                43
 +
0120 I                              4481 4512  DO                44
 +
0121 I                              4513 4544  DP                45
 +
0122 I                              4545 4576  DQ                46
 +
0123 I                              4577 4608  DR                47
 +
0124 I                              4609 4640  DS                48
 +
0125 I                              4641 4672  DT                49
 +
0126 I                              4673 4704  DU                50
 +
0127 I                              4705 4736  DV                51
 +
0128 I                              4737 4768  DW                52
 +
0129 I                              4769 4800  DX                53
 +
0130 I                              4801 4832  DY                54
 +
0131 I                              4833 4864  D0                55
 +
0132 I                              4865 4896  D1                56
 +
0133 I                              4897 4928  D2                57
 +
0134 I                              4929 4960  D3                58
 +
0135 I                              4961 4992  D4                59
 +
0136 I                              4993 5024  D5                60
 +
0137 I                              5025 5056  D6                61
 +
0138 I                              5057 5088  DBA              62
 +
0139 I                              5089 5120  DCA              63
 +
0140 I                              5121 5152  DDA              64
 +
0141 I                              5153 5184  DEA              65
 +
0142 I                              5185 5216  DFA              66
 +
0143 I                              5217 5248  DGA              67
 +
0144 I                              5249 5280  DHA              68
 +
0145 I                              5281 5312  DIA              69
 +
0146 I                              5313 5344  DJA              70
 +
0147 I                              5345 5376  DKA              71
 +
0148 I                              5377 5408  DLA              72
 +
0149 I                              5409 5440  DMA              73
 +
0150 I                              5441 5472  DNA              74
 +
0151 I                              5473 5504  DOA              75
 +
0152 I                              5505 5536  DPA              76
 +
0153 I                              5537 5568  DQA              77
 +
0154 I                              5569 5600  DRA              78
 +
0155 I                              5601 5632  DSA              79
 +
0156 I                              5633 5664  DTA              80
 +
0157 I                              5665 5696  DUA              81
 +
0158 I                              5697 5728  DVA              82
 +
0159 I                              5729 5760  DWA              83
 +
0160 I                              5761 5792  DXA              84
 +
0161 I                              5793 5824  DYA              85
 +
0162 I                              5825 5856  DZA              86
 +
0163 I                              5857 5888  D0A              87
 +
0164 I                              5889 5920  D1A              88
 +
0165 I                              5921 5952  D2A              89
 +
0166 I                              5953 5984  D3A              90
 +
0167 I                              5985 6016  D4A              91
 +
0168 I                              6017 6048  D5A              92
 +
0169 I                              6049 6080  D6A              93
 +
    IDISPF    NS  02
 +
    I                                  3    3  AID
 +
    I                                  4  83  ID0
 +
    I                                84  163  ID1              20
 +
    I                                164  243  ID2              21
 +
    I                                244  323  ID3              22
 +
    I                                324  403  ID4              23
 +
    I                                404  483  ID5              24
 +
    I                                484  563  ID6              25
 +
    I                                564  643  ID7              26
 +
    I                                644  723  ID8              27
 +
    I                                724  803  ID9              28
 +
 
 +
 
 +
      /FREE
 +
            BASE = 4048;
 +
 
 +
            IF  ONCE  =  ' ';
 +
                EXSR      @INITZ  ;
 +
            ENDIF;
 +
 
 +
        //  START        TAG
 +
          DOW      @LOOP = @LOOP;
 +
 
 +
          IF  RTN  = '3';
 +
 
 +
              IF *INU1;
 +
                KEYA =  SCNKEY;
 +
              ENDIF;
 +
              IF *INU2;
 +
                RRNA =  %DEC(%SUBST(SCNKEY:1:11):11:0);
 +
              ENDIF;
 +
                RTN = '0';
 +
                AID = '1';
 +
            ELSE;
 +
              RTN  = '0';
 +
              READ(E)  DISPF;
 +
          ENDIF;
 +
 
 +
        //  CF3 EXIT
 +
          IF  AID  = X33;
 +
            LEAVE;
 +
          ENDIF;
 +
 
 +
        //  CF2 RETURN
 +
          IF  AID  = X32;
 +
            RTN = '1';
 +
            LEAVE;
 +
          ENDIF;
 +
 
 +
        // CF1 HEX A FIELD
 +
          IF  AID  = X31;
 +
          Y = %LOOKUPLE( CURLOC : B );
 +
          IF Y > 0;
 +
            IF KY(Y) <= '1';
 +
              EXSR      @HXDSP;
 +
              REHEAD  = '1';
 +
              EXSR      @PUTHED;
 +
              REHEAD  = ' ';
 +
            ENDIF;
 +
            ENDIF;
 +
          ENDIF;
 +
 
 +
        //  CF20 MORE FIELDS
 +
          IF  AID  = XB8;
 +
 
 +
            LVX  = LVL + 1;
 +
            IF  LV(LVX)  <> *BLANK;
 +
              LVL = LVL +1 ;
 +
 
 +
              LVW  = LV;
 +
              SCNLV = TEXT500;
 +
              SCNLVL = %EDITC(LVL :'X');
 +
 
 +
            SCNKEY = *BLANKS;
 +
          IF  *INU1;
 +
                SCNKEY = KEYA;
 +
          ENDIF;
 +
          IF  *INU2;
 +
                SCNKEY = %EDITC(RRNA:'X');
 +
          ENDIF;
 +
 
 +
              RTN = '3';
 +
              LEAVE;
 +
            ENDIF;
 +
          ENDIF;
 +
 
 +
      //  CF19 PREVIOUS FIELDS
 +
          IF  AID  = XB7;
 +
 
 +
            LVX  = LVL - 1;
 +
            IF  LVX    >= 0 ;
 +
              LVL = LVL - 1 ;
 +
 
 +
              LVW  = LV;
 +
              SCNLV = TEXT500;
 +
              SCNLVL = %EDITC(LVL :'X');
 +
 
 +
                SCNKEY = *BLANKS;
 +
          IF  *INU1;
 +
                SCNKEY = KEYA;
 +
          ENDIF;
 +
          IF  *INU2;
 +
                SCNKEY = %EDITC(RRNA:'X');
 +
          ENDIF;
 +
 
 +
              RTN = '3';
 +
              LEAVE;
 +
            ENDIF;
 +
          ENDIF;
 +
 
 +
          // 1 ENTER  4 ROLL DN  5 ROLL UP
 +
          // F6 = X36  F9 = X39  F11 = X3B
 +
          IF  AID  = '1'or AID = '4' or AID = '5' or
 +
              AID  = X36 or AID = X39 or AID = X3B;
 +
          ELSE;
 +
            MX = 1;        // INVALID KEY
 +
            EXSR  @ERROR;
 +
          ENDIF;
 +
 
 +
          //      UPDATE MODE
 +
          IF  UPDF    = 'Y';
 +
            UPDDONE = @FALSE;
 +
          // F6
 +
            IF *INU1 AND AID = X36 AND
 +
            (LOP1 = X01 OR LOP1 = X03);
 +
              EXSR @UPD;
 +
              EXCEPT UPDATREC;
 +
              UPDDONE = @TRUE;
 +
            ENDIF;
 +
 
 +
            IF *INU2 AND AID = X36 AND
 +
            (LOP2 = X01 OR LOP2 = X02);
 +
              EXSR @UPD;
 +
              EXCEPT UPDATREC;
 +
              UPDDONE = @TRUE;
 +
            ENDIF;
 +
 
 +
          // F9
 +
            IF AID = X39;
 +
              EXSR  @UPD;
 +
              EXCEPT ADDREC;
 +
              UPDDONE = @TRUE;
 +
            ENDIF;
 +
 
 +
          // F11
 +
            IF *INU1 AND AID = X3B AND
 +
            (LOP1 = X01 OR LOP1 = X03);
 +
              EXCEPT DELREC;
 +
              UPDDONE = @TRUE;
 +
              ENDIF;
 +
 
 +
            IF *INU2 AND AID = X3B AND
 +
            (LOP2 = X01 OR LOP2 = X02);
 +
              EXCEPT DELREC;
 +
              UPDDONE = @TRUE;
 +
              ENDIF;
 +
 
 +
            ENDIF;
 +
 
 +
 
 +
          IF  RTN = '3' OR UPDDONE = @TRUE;
 +
          ELSE;
 +
            EXSR      @PCKD;
 +
          ENDIF;
 +
 
 +
 
 +
        // CONT1  GET A RECORD, KEY FROM DATA
 +
            EXSR      @SETIN;
 +
            EXSR      @GETF ;
 +
            EXSR      @PUTF ;
 +
            EXSR      @KEYIN;
 +
 
 +
          ENDDO ;
 +
 
 +
          *INLR = *ON;
 +
 
 +
      //  @@@@@@@  @INITZ @@@@@@@@@@@@@@@@@@@@@@@@@@
 +
        BEGSR  @INITZ;
 +
                ONCE  =  '1';
 +
                KEYLNA = KEYLNG  ;
 +
                EXSR      @INIT  ;
 +
                EXSR      @GETFLD ;
 +
                EXSR      @GETADD ;
 +
                EXSR      @PUTHED ;
 +
                EXSR      @KEYIN  ;
 +
                INZ  = '1';
 +
                EXSR      @PCKD  ;
 +
                INZ  = ' ';
 +
        ENDSR;
 +
 
 +
      //  @@@@@@@  @PCKD  @@@@@@@@@@@@@@@@@@@@@@@@@@
 +
 
 +
          BEGSR  @PCKD ;
 +
 
 +
            //  CONVERT  KEY DATA
 +
            IF  *INU1 ;
 +
              EXSR  @CVTKEY;
 +
            ENDIF;
 +
            IF  *INU2 ;
 +
              EXSR  @CVTRRN;
 +
            ENDIF;
 +
 
 +
          ENDSR;
 +
 
 +
      //  @@@@@@@  @CVTKEY  @@@@@@@@@@@@@@@@@@@@@@@@
 +
 
 +
          BEGSR  @CVTKEY;
 +
 
 +
      // EXTRACT THE KEY FIELD DATA FROM THE INCOMING STRING
 +
 
 +
        // FOR EACH KEY FIELD, CHECK IF FIELD WAS MODIFIED, AND IF SO MOVE
 +
        // THE MODIFIED DATA INTO THE COMPOSITE KEY
 +
 
 +
        K1 = 0;
 +
        K2 = 0;
 +
        W  = 1;
 +
 
 +
          FOR  Y  = 1  TO NUMKEY ;
 +
 
 +
      //  MOVE A KEY FIELDS DATA FROM ID ARRAY (SCREEN) TO K ARRAY (KEY FIELDS)
 +
 
 +
      //  GET SIZE OF FIELD IN BYTES
 +
          IF T(Y)  =  'A';  // ALPHA DATA
 +
          K = ' ';
 +
          K1 = 1;
 +
          K2 = Q(Y);
 +
          ELSE;
 +
          K  = '0';
 +
          K1 =  1;
 +
          K2 = C(Y);
 +
          ENDIF;
 +
 
 +
      // IF WHOLE KEY INIT WAS REQUESTED BYPASS THE EXTRACT
 +
          IF  INZ  = '1' ;
 +
            KW  = *BLANK;
 +
            EXSR      @PCKMOV;
 +
            ITER;
 +
          ENDIF;
 +
 
 +
          X  =  1;
 +
 
 +
          DOW  @LOOP = @LOOP;
 +
 
 +
      //  NXTSBA
 +
          X  = %LOOKUP(SBA : ID : X );
 +
          IF X = 0;
 +
            LEAVE;
 +
          ENDIF;
 +
 
 +
      // IS THIS THE FIELD?  CHECK THE BUFFER ADDRESS
 +
        X = X +1;
 +
        IF  B(Y)  <>  %SUBST(IDA : X :2);
 +
          ITER;
 +
        ENDIF;
 +
 
 +
      //  FOUND A MTD FOR THIS FIELD
 +
        X =  X + 2;
 +
 
 +
      //  CHECK IF FIELD WAS CLEARED ONLY
 +
        IF  ID(X) = SBA;
 +
            EXSR      @PCKMOV;
 +
            LEAVE ;
 +
        ENDIF;
 +
 
 +
      //  IF FIELD HAS DECIMALS BUMP X
 +
          IF (T(Y) = 'S' OR T(Y) = 'P' OR T(Y) = 'B') AND
 +
              P(Y) > 0;
 +
              X = X + 1;
 +
          ENDIF;
 +
 
 +
      //  CHECK IF ONLY BLANKS RETURNED
 +
        IF    %SUBST(IDA : X :K2) = *BLANKS;
 +
            EXSR      @PCKMOV;
 +
            LEAVE;
 +
        ENDIF;
 +
 
 +
      // EXTRACT THE DATA FROM THE INCOMING STRING
 +
        X1  = X;
 +
        FOR X2  =  1 TO  K2 ;
 +
 
 +
          IF ID(X1) < ' ';
 +
      // TRAP NULLS CAUSED BY FLD EXIT
 +
            EXSR      @PCKMOV;
 +
            LEAVE;
 +
          ENDIF;
 +
 
 +
        K(X2)  =  ID(X1);
 +
        X1    =  X1 +1;
 +
        ENDFOR;
 +
 
 +
        // CONSTRUCT THE ACTUAL KEY WITH PACKED DATA IF REQUIRED
 +
        // INTO ARRAY KW
 +
          EXSR      @PCKMOV;
 +
          LEAVE;
 +
        ENDDO;
 +
 
 +
        ENDFOR;
 +
 
 +
        //
 +
          KEYA  = KW;
 +
          CLEAR KW;
 +
        ENDSR ;
 +
 
 +
      //  @@@@@@@  @CVTRRN  @@@@@@@@@@@@@@@@@@@@@@@@
 +
 
 +
          BEGSR  @CVTRRN;
 +
 
 +
        //  RRN
 +
 
 +
          NUM11 = 0;
 +
 
 +
          DOW  @LOOP = @LOOP;  //  NOT REALLY A LOOP(SIMULATES GOTO)
 +
 
 +
      // GET THE FIRST SBA
 +
          X = 1;
 +
          X  = %LOOKUP(SBA : ID : X );
 +
          IF X = 0;
 +
          LEAVE;
 +
          ENDIF;
 +
 
 +
      // CHECK THE BUFFER ADDRESS MATCHES THE EXPECTED FIELD
 +
        X = X +1;
 +
        IF  B(1)  <>  %SUBST(IDA : X :2);
 +
          ITER;
 +
        ENDIF;
 +
 
 +
      //  FOUND A MTD FOR RRN  FIELD
 +
        X = X +2;
 +
 
 +
      //CHECK IF FIELD WAS CLEARED ONLY
 +
        IF  ID(X) = SBA;
 +
            LEAVE;
 +
        ENDIF;
 +
 
 +
      //  CHECK IF ONLY BLANKS RETURNED
 +
        IF    %SUBST(IDA : X :11) = *BLANKS;
 +
            LEAVE;
 +
        ENDIF;
 +
 
 +
 
 +
        //  WRK11  OVERLAYS NUM11
 +
        WRK11 = %SUBST(IDA : X :11);
 +
 
 +
        LEAVE;
 +
        ENDDO;
 +
 
 +
 
 +
        RRNA = NUM11;
 +
        IF RRNA < 0;
 +
        RRNA =  1;
 +
        ENDIF;
 +
 
 +
        ENDSR;
 +
 
 +
      //  @@@@@@@  @PCKMOV  @@@@@@@@@@@@@@@@@@@@@@@@
 +
 
 +
        BEGSR  @PCKMOV;
 +
      //
 +
      //  CONVERT  KEY DATA
 +
      //  SET START POSN IN KEY USING OFFSET IN R
 +
          X1 = %LOOKUP(N(Y) : N );
 +
          W = R(X1) + 1;
 +
 
 +
        // ALPHA
 +
          IF  T(Y) = 'A';
 +
          X1  = 1;
 +
          FOR  Z = W  TO W + Q(Y);
 +
            %SUBST(KW : Z : 1) =  K(X1);
 +
            X1 = X1 + 1;
 +
          ENDFOR;
 +
          ENDIF;
 +
 
 +
        // NUMERIC FIELD
 +
        // RIGHT  ADJUST NUMERIC DATA ,STRIP - . ,CONVERT BLANKS
 +
          IF (T(Y) = 'S' OR T(Y) = 'P' OR T(Y) = 'B');
 +
          NU = '0';
 +
 
 +
          Z1 = 60;
 +
          FOR Z  =  K2  DOWNTO K1;
 +
 
 +
          IF K(Z) = '.' OR K(Z) = '-' OR K(Z) = '$';
 +
          ITER;
 +
          ENDIF;
 +
 
 +
          IF K(Z) = ' ' ;
 +
          NU(Z1) = '0';
 +
          ELSE;
 +
          NU(Z1) = K(Z);
 +
          ENDIF;
 +
 
 +
            Z1 = Z1 -1;
 +
          ENDFOR;
 +
 
 +
          ENDIF;
 +
 
 +
      // SIGNED FIELDS  (END POSN = OFFSET + SIZE)
 +
        IF T(Y)  = 'S';
 +
          NUS = 0;
 +
          FOR VX = 1 TO 60;
 +
            NUSA = %TRIM(NUSA) + NU(VX);
 +
          ENDFOR;
 +
        %SUBST(KW : W : Q(Y)) = %SUBST(NUSA: 61 -Q(Y));
 +
 
 +
        ENDIF;
 +
 
 +
      //  PACKED FIELDS
 +
          IF    T(Y)  =  'P';
 +
          NUSA= *BLANKS;
 +
          FOR VX = 1 TO 60;
 +
            NUSA = %TRIM(NUSA) + NU(VX);
 +
          ENDFOR;
 +
          NUP    = %DEC(NUSA : 60 : 0);
 +
 
 +
        %SUBST(KW : W : Q(Y))  =  %SUBST(NUPA: 61 -Q(Y));
 +
 
 +
        ENDIF;
 +
 
 +
      //  BINARY FIELDS
 +
        IF  T(Y) =  'B';
 +
 
 +
        IF  Q(Y) = 2 ;
 +
          BY2  = NU(1) + NU(2);
 +
          %SUBST(KW : W : 2)  =  BY2;
 +
        ENDIF;
 +
 
 +
        IF  Q(Y) = 4 ;
 +
          BY4  = NU(1) + NU(2) + NU(3) + NU(4);
 +
          %SUBST(KW : W : 4)  =  BY4;
 +
        ENDIF;
 +
 
 +
        ENDIF;
 +
 
 +
      ENDSR;
 +
 
 +
 
 +
      //  @@@@@@@  SETIN  @@@@@@@@@@@@@@@@@@@@@@@@@
 +
          BEGSR      @SETIN;
 +
 
 +
        //  SET the FFR indicators to get the Input buffer somewhat aligned with the
 +
        //  actual data.  RPG is somewhat tolerant to a difference between the Ispecs
 +
        //  and the actual file size but it can fail on big differences.
 +
        //  INCREMENT OF 32 BYTES
 +
          SZ(1)  = BASE + 16;
 +
          SZ(2)  = SZ(1) + 16;
 +
 
 +
          *IN30 = *ON;
 +
            IF (RLEN > SZ(2)) ;
 +
            *IN31  = *ON;
 +
            ENDIF;
 +
 
 +
          FOR X = 3 TO 64;
 +
          SZ(X) = SZ(X-1) + 32;
 +
            IF (RLEN > SZ(X)) ;
 +
            *IN(29+X) = *ON;
 +
            ENDIF;
 +
          ENDFOR;
 +
        ENDSR;
 +
 
 +
 
 +
        //@@@@@@@@@@@@@@@@@  @GETF  @@@@@@@@@@@@@@@@@
 +
          BEGSR  @GETF;
 +
      //  GET A DATA RECORD
 +
          IF  (*INU1);
 +
          IF  AID  = '1' OR AID  = X36 OR
 +
              AID  = X39 OR AID  = X3B ;
 +
            SETLL(E) KEYA  INPUTK;
 +
            READ(E)      INPUTK;
 +
              IF %EOF;
 +
              SETLL(E) KEYA  INPUTK;
 +
              READP(E)      INPUTK;
 +
              ENDIF;
 +
          ENDIF;
 +
 
 +
          IF  AID  = '4';
 +
            READP(E)  INPUTK;
 +
          ENDIF;
 +
 
 +
          IF  AID  = '5';
 +
            READ(E)  INPUTK;
 +
          ENDIF;
 +
 
 +
            IF  %ERROR;
 +
            SETLL(E) KEYA  INPUTK;
 +
            READ(E)      INPUTK;
 +
            MX = 7;
 +
                        EXSR      @ERROR;
 +
                        EXSR      @PUTF ;
 +
                        EXSR      @KEYIN;
 +
            ENDIF;
 +
 
 +
            KEYA = LKY;
 +
 
 +
 
 +
            CLEAR KW;
 +
            KW  = LKY;
 +
 
 +
          ENDIF;
 +
 
 +
          IF  (*INU2);
 +
          IF  AID  = '1';
 +
            CHAIN(E)  RRNA  INPUTR;
 +
            IF  %ERROR;
 +
              SETLL(E) RRNA  INPUTR;
 +
              READP(E)      INPUTR;
 +
            ENDIF;
 +
          ENDIF;
 +
 
 +
          IF  AID  = X36;
 +
            CHAIN(E)  RRNA  INPUTR;
 +
          ENDIF;
 +
 
 +
          IF  AID  = '4';
 +
            READP(E)  INPUTR;
 +
          ENDIF;
 +
 
 +
          IF  AID  = '5' OR AID = X3B;
 +
            READ(E)  INPUTR;
 +
          ENDIF;
 +
 
 +
          IF  AID  = X39;
 +
            SETLL(E) *HIVAL INPUTR;
 +
            READP(E)  INPUTR;
 +
          ENDIF;
 +
 
 +
          IF %ERROR;
 +
            CHAIN  1  INPUTR;
 +
            MX = 7;
 +
            EXSR      @ERROR;
 +
            EXSR      @PUTF ;
 +
            EXSR      @KEYIN;
 +
          ENDIF;
 +
          ENDIF;
 +
 
 +
          ENDSR;
 +
 
 +
 
 +
        //@@@@@@@@@@@@@@@@@  @PUTF  @@@@@@@@@@@@@@@@@
 +
          BEGSR  @PUTF;
 +
 
 +
              SELECT;
 +
                WHEN  *INU1;
 +
                RRN = RN1;
 +
                WHEN  *INU2;
 +
                RRN = RN2;
 +
              ENDSL;
 +
        // IF GOT RECORDS WRITE DATA TO THE DISPLAY
 +
 
 +
            NEWRU  = '1';
 +
            WRTRRN = '1';
 +
            RU    = *ALLX'00';
 +
            CLEAR  RU;        //  initialise Request Unit  255 bytes max
 +
 
 +
          IF RRN > 0    ;
 +
            FOR  XX = 1 TO      NUMFKY; //NUMBER OF DATA ELEMENTS (FLD AND KEY)
 +
 
 +
            IF NEWRU = '1';
 +
              NEWRU  = '0';
 +
              RU  = ESC + WTD + X20 + X00;
 +
            ENDIF;
 +
 
 +
            IF WRTRRN = '1';
 +
              WRTRRN = '0';
 +
              RU  = RU + SBA + RBA ;
 +
              RU = RU + %TRIM(%EDITC(RRN:'Z'));
 +
            ENDIF;
 +
 
 +
        // BUFFER ADDRESS
 +
            RU  = RU + SBA + B(XX);
 +
 
 +
        //  PROCESS ALPHA DATA TYPE
 +
            IF  T(XX) = 'A'  OR T(XX) = 'T'  OR T(XX) = 'Z' OR
 +
                T(XX) = 'L';
 +
 
 +
              STRX = S(XX);
 +
              ENDX = E(XX);
 +
 
 +
              IF V(XX) = 'Y';  //VARYING
 +
              VX  = S(XX);
 +
              HX2  = D(VX) + D(VX+1);
 +
              STRX  = S(XX) + 2 ;
 +
              ENDX  = S(XX) + BIN;
 +
              ENDIF;
 +
 
 +
              FOR Y = STRX  TO ENDX ;
 +
                IF D(Y) >= ' ';
 +
                RU = RU + D(Y);
 +
                ELSE;
 +
                RU = RU + X1F ;  //IF NOT DISPLAYABLE REPLACE WITH X'1F'
 +
                ENDIF;
 +
              ENDFOR;
 +
            ENDIF;
 +
 
 +
        //  PROCESS SIGNED DATA TYPE (not the RRN field)
 +
            IF  T(XX) = 'S' and KY(XX) <> '3';
 +
              NUSA =  *ALL'0';
 +
              WRV  =  *ALLX'00';
 +
              CLEAR WRV;
 +
              FOR Y = S(XX) TO E(XX);
 +
                IF D(Y) >= XD0;
 +
                WRV    =  WRV + D(Y);
 +
                ENDIF;
 +
              ENDFOR;
 +
              EVAL  NUSA = %SUBST(NUSA : 1 : 60 - %LEN(WRV)) + WRV;
 +
              CLEAR WRU;
 +
              WRU = %TRIM(WRU) + %EDITW(NUS :WRSWRD);
 +
              IF  P(XX) > 0;
 +
                RU  = RU  +
 +
                    %SUBST(WRU :61-C(XX): C(XX)-P(XX)) + '.' +
 +
                    %SUBST(WRU :61-P(XX))    ;
 +
              ELSE;
 +
                RU  = RU  +
 +
                    %SUBST(WRU :61-C(XX));
 +
              ENDIF;
 +
            ENDIF;
 +
 
 +
 
 +
        //  PROCESS SIGNED DATA TYPE (the RRN field)
 +
            IF  T(XX) = 'S' and KY(XX) =  '3';
 +
              RRN = RN2;
 +
              RU = RU + %TRIM(%EDITC(RRN:'X'));
 +
            ENDIF;
 +
 
 +
        //  PROCESS PACKED DATA TYPE
 +
            IF  T(XX) = 'P';
 +
              NUPA =  *ALLX'00';
 +
              WRV  =  *ALLX'00';
 +
              CLEAR WRV;
 +
              FOR Y = S(XX) TO E(XX);
 +
                WRV    =  WRV + D(Y);
 +
              ENDFOR;
 +
 
 +
              IF  %BITAND(D(E(XX)) :X0F) = X0F OR
 +
                    %BITAND(D(E(XX)) :X0D) = X0D;
 +
 
 +
                EVAL  NUPA = %SUBST(NUPA : 1 : 60 - %LEN(WRV)) + WRV;
 +
                CLEAR WRX;
 +
                WRX = %TRIM(WRX) + %EDITW(NUP :WRXWRD);
 +
                IF  P(XX) > 0;
 +
                RU  = RU  +
 +
                      %SUBST(WRX :64-C(XX): C(XX)-P(XX)) + '.' +
 +
                      %SUBST(WRX :64-P(XX))    ;
 +
                ELSE;
 +
                RU  = RU  +
 +
                      %SUBST(WRX :64-C(XX));
 +
                ENDIF;
 +
              ELSE;
 +
                // PACKED FIELD IN ERROR
 +
                RU = RU + X1F;
 +
              ENDIF;
 +
 
 +
            ENDIF;
 +
 
 +
        //  PROCESS BINARY DATA TYPE
 +
            IF  T(XX) = 'B';
 +
 
 +
            ST = S(XX);
 +
              CLEAR NUSA;
 +
              IF  Q(XX) = 2;
 +
              BY2  = D(ST) + D(ST+1);
 +
              NUS  = BIN2;
 +
              ENDIF;
 +
              IF  Q(XX) = 4;
 +
              BY4  = D(ST) + D(ST+1)+ D(ST+2) + D(ST+3);
 +
              NUS  = BIN4;
 +
              ENDIF;
 +
 
 +
              WRU =  %EDITW(NUS :WRSWRD);
 +
              IF  P(XX) > 0;
 +
                RU  = RU  +
 +
                    %SUBST(WRU :61-C(XX): C(XX)-P(XX)) + '.' +
 +
                    %SUBST(WRU :61-P(XX))    ;
 +
              ELSE;
 +
                RU  = RU  +
 +
                    %SUBST(WRU :61-C(XX));
 +
              ENDIF;
 +
            ENDIF;
 +
 
 +
 
 +
        //  PROCESS FLOAT  DATA TYPE
 +
            IF  T(XX) = 'F';
 +
 
 +
            ST = S(XX);
 +
 
 +
              IF  Q(XX) = 4;
 +
              FL4  = D(ST) + D(ST+1)+ D(ST+2) + D(ST+3);
 +
              FLT14 =  %EDITFLT(FLT4);
 +
                RU  = RU  + FLT14;
 +
              ENDIF;
 +
 
 +
              IF  Q(XX) = 8;
 +
              FL8  = D(ST) + D(ST+1)+ D(ST+2) + D(ST+3) +
 +
                      D(ST+4) + D(ST+5)+ D(ST+6) + D(ST+7);
 +
              FLT23 =  %EDITFLT(FLT8);
 +
                RU  = RU  + FLT23;
 +
              ENDIF;
 +
 
 +
            ENDIF;
 +
 
 +
 
 +
          //  SEND A REQUEST UNIT IF GOT ENOUGH DATA
 +
 
 +
            IF  %LEN(RU) + L(XX + 1) >= 200;
 +
              RU  =  RU + X20;
 +
              BIN  =  %LEN(RU);
 +
              OUTLEN  =  HX2;
 +
              INLEN  =  X000;
 +
              FNC    =  SND;
 +
              A      = RU;
 +
              EXCEPT  DATAO;
 +
              NEWRU  = '1';
 +
              RU    = *ALLX'00';
 +
              CLEAR  RU;
 +
            ENDIF;
 +
 
 +
            ENDFOR;
 +
          ENDIF;
 +
 
 +
            IF  %LEN(RU) > 5 AND %LEN(RU) < 250;
 +
              RU  =  RU + X20;
 +
              BIN  =  %LEN(RU);
 +
              OUTLEN  =  HX2;
 +
              INLEN  =  X000;
 +
              FNC    =  SND;
 +
              A      = RU;
 +
              EXCEPT  DATAO;
 +
            ENDIF;
 +
          ENDSR;
 +
 
 +
 
 +
        // @@@@@@@@@@@@@@@    ROWINC  @@@@@@@@@@@@@@@
 +
 
 +
        // INCREMENT THE ROW
 +
          BEGSR    @ROWINC;
 +
          ROW = ROW + 2;
 +
          IF  ROW > 20;
 +
            MX = 3;
 +
          ENDIF;
 +
          ENDSR;
 +
 
 +
 
 +
 
 +
        // @@@@@@@@@@@@@@@    GETFLD  @@@@@@@@@@@@@@@
 +
 
 +
        // LOAD FIELD DESCRIPTION ARRAYS
 +
          BEGSR    @GETFLD;
 +
          MX = 0;
 +
          X  = 0;
 +
 
 +
          IF  (*INU2 = *ON);
 +
          // IF NON KEYED ACCESS SET UP A FIELD TO SHOW THE RRN
 +
            N(1) =  'RRN';
 +
            T(1) =  'S'  ;
 +
            C(1) =  11  ;
 +
            P(1) =  0    ;
 +
            S(1) =  0    ;
 +
            E(1) =  0    ;
 +
            L(1) =  12  ;
 +
            I(1) = X4F06 ;
 +
            KY(1)= '3'  ;
 +
            X    = 1    ;
 +
          ENDIF;
 +
 
 +
          SCRST = *BLANK;
 +
          SCRSTN = *BLANK;
 +
 
 +
          LVL  = %DEC(SCNLVL : 5:0);
 +
 
 +
        TEXT500 = SCNLV ;
 +
        LV      = LVW;
 +
 
 +
        IF  LVL <> 0;
 +
          SCRST = LV(LVL);
 +
        ENDIF;
 +
 
 +
          SETLL 1 QWHDRFFD ;
 +
 
 +
          DOW  @LOOP  = @LOOP;
 +
        //  REREAD  TAG
 +
          READ    QWHDRFFD;
 +
          IF %EOF;
 +
            LEAVE;
 +
          ENDIF;
 +
 
 +
        //  SELECT OR OMIT
 +
          IF  ALL  <> '1';
 +
          IF  ALL  =  'S' AND WHDFTL = 0; // USING WHDFTL FOR KEY FIELDS
 +
            IF  WHFIOB  <>  'S';
 +
              ITER;
 +
            ENDIF;
 +
          ENDIF;
 +
          IF  ALL  =  'O' AND WHDFTL = 0; // USING WHDFTL FOR KEY FIELDS
 +
            IF  WHFIOB  =  'O';
 +
              ITER;
 +
            ENDIF;
 +
          ENDIF;
 +
          ENDIF;
 +
 
 +
        //  FIND THE FIRST FIELD TO BE SHOWN (FOR MULTI PAGE FORMATS)
 +
          IF  WHDFTL  <> 0 ;
 +
            ELSE;
 +
            IF SCRST <> ' ' AND SCRSTN = ' ';
 +
              IF WHFLDE =  SCRST;
 +
                SCRSTN = '1';    //  FOUND THE START
 +
              ELSE;
 +
                ITER;
 +
              ENDIF;
 +
            ENDIF;
 +
          ENDIF;
 +
 
 +
 
 +
          X =  X  + 1;
 +
        // CHECK FOR KEY FIELDS,WILL BE USED TO PLACE THEM IN FRONT
 +
          IF  WHDFTL  <>  0;
 +
              KY(X) = '1';
 +
              WX    = WHDFTL ;
 +
              KE(WX) = WHFLDE;
 +
              IF  NUMKEY <  WHDFTL;
 +
                NUMKEY = WHDFTL;
 +
              ENDIF;
 +
          ENDIF;
 +
 
 +
            N(X) =  WHFLDE ;              //    NAME
 +
            T(X) =  WHFLDT ;              //    TYPE
 +
            V(X) =  WHVARL ;              //    VARYING
 +
            C(X) =  WHFLDD ;              //    DEC DIGITS
 +
            P(X) =  WHFLDP ;              //    DEC PREC
 +
            S(X) =  WHFOBO ;              //    START
 +
            Q(X) =  WHFLDB ;              //    BTYES
 +
            E(X) =  WHFOBO + WHFLDB -1 ;  //  END
 +
 
 +
            IF T(X) =  'F' ;              //    FLOAT
 +
 
 +
              I(X) = FFA1 + FFA2;          //  SCRN FIELD FORMAT ALPHA
 +
              L(X)  = 14;
 +
              IF Q(X) = 8;
 +
              L(X)  = 23;
 +
              ENDIF;
 +
 
 +
            ELSE;
 +
              IF  WHFLDD  <> 0 ;
 +
              IF  WHFLDP  <> 0 ;
 +
                L(X) =  WHFLDD +  2  ;      //  LENGTH
 +
              ELSE;
 +
                L(X) =  WHFLDD +  1  ;      //  LENGTH
 +
              ENDIF;
 +
 
 +
                I(X) = FFN1 + FFN2;        //  SCRN FIELD FORMAT NUMERIC
 +
 
 +
              ELSE;
 +
                L(X) =    WHFLDB  ;
 +
                I(X) = FFA1 + FFA2;        //  SCRN FIELD FORMAT ALPHA
 +
              ENDIF;
 +
            ENDIF;
 +
 
 +
        ENDDO;
 +
        //  NUMBER OF FIELDS
 +
        NUMFLD = X ;
 +
 
 +
      //  MAKE ROOM FOR KEYS
 +
          IF  NUMKEY  >  0 ;
 +
          X1  = NUMKEY  + NUMFLD;
 +
 
 +
          FOR  X =  NUMFLD DOWNTO 1;
 +
              KY(X1) = KY(X) ;
 +
              L(X1)  = L(X)  ;
 +
              I(X1)  = I(X)  ;
 +
              N(X1)  = N(X)  ;
 +
              T(X1)  = T(X)  ;
 +
              V(X1)  = V(X)  ;
 +
              C(X1)  = C(X)  ;
 +
              P(X1)  = P(X)  ;
 +
              S(X1)  = S(X)  ;
 +
              E(X1)  = E(X)  ;
 +
              Q(X1)  = Q(X)  ;
 +
              X1    = X1 - 1;
 +
          ENDFOR;
 +
 
 +
          //  PUT KEY FIELDS AT TOP
 +
          OFF  = 0;
 +
          FOR  X =  1 TO NUMKEY;
 +
          X1 = %LOOKUP(KE(X) : N : NUMKEY+1);
 +
 
 +
          KY(X) = '2';
 +
          L(X)  = L(X1);
 +
          I(X)  = I(X1);  // FIELD FMT
 +
          SELECT;                // INPUT ENABLE
 +
            WHEN  I(X) = X6000;
 +
                  I(X) = X4800;
 +
            WHEN  I(X) = X6706;
 +
                  I(X) = X4F06;
 +
          ENDSL;
 +
            N(X) =  N(X1);
 +
            T(X) =  T(X1);
 +
            V(X) =  V(X1);
 +
            C(X) =  C(X1);
 +
            P(X) =  P(X1);
 +
            S(X) =  S(X1);
 +
            E(X) =  E(X1);
 +
            Q(X) =  Q(X1);
 +
            R(X) =  OFF;
 +
            OFF  =  OFF + Q(X1);
 +
          ENDFOR;
 +
 
 +
        ENDIF;
 +
      //  NUMBER OF FIELDS AND KEYS
 +
        NUMFKY = NUMFLD  +  NUMKEY;
 +
 
 +
        ENDSR;
 +
 
 +
 
 +
        // @@@@@@@@@@@@@@@    GETADD  @@@@@@@@@@@@@@@
 +
 
 +
        // LOAD FIELD BUFFER ADDRESSES
 +
          BEGSR    @GETADD;
 +
          MX = 0;
 +
          X  = 0;
 +
          ROW = 3;
 +
          COL = 1;
 +
 
 +
          FOR X = 1 TO NUMFKY;
 +
 
 +
        // IF FINISHED WITH THE KEY FIELDS
 +
        //  INC  ROW FOR 1ST DATA FIELD
 +
          IF KEYSOK = ' ' ;
 +
          IF KY(X) = ' ' OR KY(X) = '1';
 +
            KEYSOK = '1' ;
 +
            ROW    = ROW + 2;
 +
            COL    = 1;
 +
          ENDIF;
 +
          ENDIF;
 +
 
 +
        //  SET THE BUFFER ADD ON THE LARGER OF THE FIELD TEXT OR THE FIELD SIZE
 +
          LENDSC  = %LEN(%TRIM(N(X)));
 +
          LENWRK  =  L(X);
 +
          IF LENDSC > L(X);
 +
            LENWRK = LENDSC;
 +
          ENDIF;
 +
            LENWRK = LENWRK + 2;
 +
 
 +
        //  TRAP FIELDS THAT OVERFLOW
 +
            ROW  = ROW  + XROW;
 +
            XROW = %DIV(LENWRK : 80);
 +
 
 +
            IF (COL + LENWRK) > 78;
 +
              EXSR @ROWINC;
 +
                IF MX = 3;
 +
                X= X-1;
 +
                NUMFKY = X;
 +
                LEAVE;
 +
                ENDIF;
 +
              COL = 1;
 +
            ENDIF;
 +
 
 +
        // INC COL. FOR FIELD START
 +
          CLEAR  B(X);
 +
          BIN  = ROW;
 +
          B(X) =  %TRIM(B(X)) + HX1;
 +
          BIN  = COL + 1;
 +
          B(X) =  %TRIM(B(X)) + HX1;
 +
 
 +
        // INC COL. FOR NEXT FIELD
 +
        COL = COL + LENWRK;
 +
            IF COL > 78;
 +
              EXSR @ROWINC;
 +
                IF MX = 3;    // NO ROOM FOR THE FIELD
 +
                X= X-1;
 +
                NUMFKY = X;
 +
                LEAVE;
 +
                ENDIF;
 +
              COL = 1;
 +
            ENDIF;
 +
 
 +
          ENDFOR;
 +
 
 +
        //  FIELD LEVEL
 +
          LVX      = LVL + 1;
 +
          LV(LVX)  = N(X);
 +
 
 +
        ENDSR;
 +
 
 +
 
 +
        // @@@@@@@@@@@@@@@    PUTHED  @@@@@@@@@@@@@@@
 +
 
 +
        //  PUT FIELD HEADINGS
 +
          BEGSR    @PUTHED;
 +
 
 +
 
 +
            NEWRU  = '1';
 +
 
 +
            RU    = *ALLX'00';
 +
            CLEAR  RU;                  //  initialise Request Unit  255 bytes max
 +
            FOR  XX = 1 TO      NUMFKY; //NUMBER OF DATA ELEMENTS (FLD AND KEY)
 +
 
 +
            IF NEWRU = '1';
 +
              NEWRU  = '0';
 +
              RU  = ESC + WTD + X20 + X00;
 +
            ENDIF;
 +
 
 +
            RU = RU + SBA;
 +
            BIN = 0;
 +
              // CONVERT DATA BUFADR TO HEADING BUFADR
 +
            HX1 = %SUBST(B(XX) :1:1);
 +
            BIN = BIN - 1;
 +
            RU  = RU + HX1;
 +
 
 +
            IF  REHEAD = '1'; // ON REDISPLAY OVERRIDE THE ATTR
 +
              BIN = 0;
 +
              HX1 = %SUBST(B(XX) :2:1);
 +
              BIN = BIN -1 ;
 +
              RU  = RU + HX1;
 +
            ELSE;
 +
              RU  = RU + %SUBST(B(XX) :2);
 +
            ENDIF;
 +
 
 +
            RU = RU + ATC ;
 +
 
 +
        //  LONG NUMBER FIELDS ,RIGHT ADJUST THE FIELD HEADINGS
 +
            LENDSC  = %LEN(%TRIM(N(XX)));
 +
            IF  T(XX) <> 'A' AND  LENDSC <  (L(XX) -1);
 +
            FOR Y = 1 TO (L(XX) -(LENDSC +1));
 +
              RU = RU + ' ';
 +
            ENDFOR;
 +
            ENDIF;
 +
 
 +
            RU = RU + %TRIM(N(XX));
 +
 
 +
              IF %LEN(RU) >= 200;
 +
              BIN    = %LEN(RU);
 +
              OUTLEN = HX2;
 +
              INLEN  = X000;
 +
              FNC    = SND;
 +
              A      = RU;
 +
              EXCEPT DATAO;
 +
              NEWRU  = '1';
 +
              RU    = *ALLX'00';
 +
              CLEAR  RU;
 +
              ENDIF;
 +
 
 +
            ENDFOR;
 +
 
 +
              IF %LEN(RU) >  5 AND %LEN(RU) <  200;
 +
              BIN    = %LEN(RU);
 +
              OUTLEN = HX2;
 +
              INLEN  = X000;
 +
              FNC    = SND;
 +
              A      = RU;
 +
              EXCEPT DATAO;
 +
              ENDIF;
 +
 
 +
          IF REHEAD <> '1';
 +
        //  FORMAT FIELDS
 +
 
 +
 
 +
            NEWRU  = '1';
 +
            RU    = *ALLX'00';
 +
            CLEAR  RU;                  //  initialise Request Unit  255 bytes max
 +
            FOR  XX = 1 TO      NUMFKY; //NUMBER OF DATA ELEMENTS (FLD AND KEY)
 +
 
 +
            IF NEWRU = '1';
 +
              NEWRU  = '0';
 +
              RU  = ESC + WTD + X20 + X00;
 +
            ENDIF;
 +
 
 +
            RU = RU + SBA +B(XX)+SF + I(XX);
 +
 
 +
            IF KY(XX) = '1' OR KY(XX) = '2' OR KY(XX) = '3';
 +
              RU = RU + X25;
 +
            ELSE;
 +
              RU = RU + X26;
 +
            ENDIF;
 +
 
 +
            BIN =  L(XX);
 +
            RU  = RU + HX2;
 +
 
 +
          // LENGTH OF INPUT FIELDS
 +
            LENF  = LENF + L(XX) + 3;
 +
 
 +
 
 +
              IF %LEN(RU) >= 200;
 +
              BIN    = %LEN(RU);
 +
              OUTLEN = HX2;
 +
              INLEN  = X000;
 +
              FNC    = SND;
 +
              A      = RU;
 +
              EXCEPT DATAO;
 +
              NEWRU  = '1';
 +
              RU    = *ALLX'00';
 +
              CLEAR  RU;
 +
              ENDIF;
 +
 
 +
          ENDFOR;
 +
 
 +
      //  PUT LAST R/U
 +
              IF %LEN(RU) >  5 AND %LEN(RU) <  200;
 +
              BIN    = %LEN(RU);
 +
              OUTLEN = HX2;
 +
              INLEN  = X000;
 +
              FNC    = SND;
 +
              A      = RU;
 +
              EXCEPT DATAO;
 +
              ENDIF;
 +
 
 +
        //INC BUFFER ADDRESS FOR ALL FIELDS FOR DATA PUT
 +
            FOR  XP = 1 TO      NUMFKY; //NUMBER OF DATA ELEMENTS (FLD AND KEY)
 +
            HX2  = B(XP);
 +
            BIN  = BIN + 1;
 +
            B(XP) = HX2;
 +
            ENDFOR;
 +
          ENDIF;
 +
 
 +
        ENDSR;
 +
 
 +
      //  @@@@@@@  INIT  @@@@@@@@@@@@@@@@@@@@@@@@@
 +
          BEGSR        @INIT;
 +
 
 +
        CLEAR  KW;
 +
 
 +
        //  UPDATE
 +
          IF  UPDF  = 'Y';
 +
                FFA1 = X40;
 +
                FFN1 = X47;
 +
          ELSE;
 +
                FFA1 = X60;
 +
                FFN1 = X67;
 +
          ENDIF;
 +
 
 +
          SELECT;
 +
          WHEN  *INU1 = '1';
 +
                FILE  =  F1 ;
 +
                LIB  =  L1 ;
 +
                MBR  =  M1 ;
 +
                RCDL  =  R1 ;
 +
                ACCTP =  A1 ;
 +
          WHEN  *INU2 = '1';
 +
                FILE  =  F2 ;
 +
                LIB  =  L2 ;
 +
                MBR  =  M2 ;
 +
                RCDL  =  R2 ;
 +
                ACCTP =  A2 ;
 +
          ENDSL;
 +
            RLEN    =  RCDL  ;
 +
            RLENTH  =  %EDITC(RLEN: 'X') ;
 +
            LENF    =  0    ;
 +
 
 +
 
 +
        // Control commands and data are constructed into RUs Request UNITS
 +
        // Each RU is 256 bytes max size.
 +
        // Construct and send as many RUs as needed to format the display.
 +
            RU    = *ALLX'00';
 +
            CLEAR  RU;        //  initialise Request Unit  255 bytes max
 +
            RU  = CLRWTD ;
 +
          //set up the screen headings
 +
            BIN = 1;    // set ROW to 1
 +
            RW  = HX1;
 +
            BIN = 2;    // set COL to 2
 +
            CL  = HX1;
 +
            RU  = RU + SBA + RW + CL + X22 + %TRIM(LIB) + '/' + %TRIM(FILE);
 +
            RU  = RU + ' Mbr ' + %TRIM(MBR) + ' Rcdl ' + %EDITC(RLEN  : 'Z') ;
 +
            RU  = RU + ' RRN '  ;
 +
            BIN = %len(RU) -4;
 +
            RBA = RW + HX1 ;  // address of the RRN field
 +
            RU  = RU + SBA + RBA + '          ';
 +
 
 +
      // FUNCTION KEYS
 +
            BIN  = 23;
 +
            RW  = HX1;
 +
            BIN  = 02;
 +
            CL  = HX1;
 +
            IF  UPDF = 'Y';  //  UPDATE IS ON
 +
            RU  = RU + SBA + RW + CL + %TRIM(CNS(2));
 +
            ELSE;
 +
            RU  = RU + SBA + RW + CL + %TRIM(CNS(1));
 +
            ENDIF;
 +
 
 +
        //  THIS IS A SEND ONLY FUNCTION
 +
          FNC    = SND;
 +
          CLEAR A;
 +
          A      = RU;
 +
          BIN2    = %LEN(RU);
 +
          OUTLEN  = BY2;
 +
          INLEN  = x000;
 +
 
 +
          EXCEPT    DATAO;
 +
 
 +
        ENDSR;
 +
 
 +
 
 +
      //  @@@@@@@  KEYIN  @@@@@@@@@@@@@@@@@@@@@@@@@
 +
        BEGSR  @KEYIN;
 +
      // ISSUE A READ FROM DISPLAY
 +
          FNC = SNR;
 +
          BIN2  = 8;
 +
          OUTLEN = BY2;
 +
          IPL = LENF + 34;
 +
          BIN2  = IPL;
 +
          INLEN  = BY2;
 +
 
 +
          // SET FRR INDICATORS TO CONTROL BUFFER OVERFLOW
 +
          FOR X =  1 TO  9;
 +
            IF IPL  >  ( X*80 +3);
 +
              *IN(X+19) = *ON;
 +
            ENDIF;
 +
          ENDFOR;
 +
 
 +
        RU    = *ALLX'00';
 +
        CLEAR  RU;
 +
        RU  = RDDSP;
 +
        A    = RU;
 +
 
 +
        EXCEPT DATAI;
 +
        ENDSR;
 +
 
 +
      //  @@@@@@@  ERROR  @@@@@@@@@@@@@@@@@@@@@@@@@
 +
        BEGSR    @ERROR;
 +
 
 +
      // SETUP PUT ERROR MESSAGE X'21'
 +
        RU    = *ALLX'00';
 +
        CLEAR RU;
 +
 
 +
        FNC    =  SNR;
 +
        BIN    = 42;
 +
        OUTLEN = HX2;
 +
        BIN    = LENF + 34;
 +
        IPL    = BIN;
 +
        INLEN  = HX2;
 +
 
 +
        FOR X        = 1 TO 9;
 +
          IF IPL      > (X * 80 +3) ;
 +
          *IN(X + 19) = *ON;          // SETON FFR 20 - 29 FOR INPUT
 +
          ENDIF;
 +
        ENDFOR;
 +
 
 +
        RU = ESC + WER + IC + B(1) + ATC + MSG(MX);
 +
        RU = RU + ESC + RDM + X40+ X00;
 +
 
 +
        A  = RU;
 +
        EXCEPT    DATAI;
 +
        RU    = *ALLX'00';
 +
        CLEAR RU;
 +
        ENDSR;
 +
 
 +
 
 +
      //  @@@@@@@    HXDSP @@@@@@@@@@@@@@@@@@@@@@@@@
 +
        BEGSR  @HXDSP;
 +
 
 +
          RU    = *ALLX'00';
 +
          CLEAR RU;
 +
          Y = %LOOKUPLE( CURLOC : B );
 +
          //
 +
          RU = ESC + WTD + X20 + X00 + SBA;
 +
          BIN = 0;
 +
          HX1 = %SUBST(B(Y) :1:1);
 +
          BIN = BIN - 1;
 +
          RU  = RU + HX1;
 +
          RU  = RU + %SUBST(B(Y) :2:1);
 +
 
 +
          FOR X = S(Y) TO E(Y);
 +
            BIN = 0;
 +
            HX1 = D(X);
 +
            HX1 = %BITAND(HX1  : XF0);
 +
            Z  = BIN / 16 + 1;
 +
            RU  = RU + CRS(Z);
 +
          ENDFOR;
 +
 
 +
            RU  = RU + X20;
 +
 
 +
            RU  = RU + SBA + B(Y);
 +
          FOR X = S(Y) TO E(Y);
 +
            BIN = 0;
 +
            HX1 = D(X);
 +
            HX1 = %BITAND(HX1  : X0F);
 +
            Z  = BIN  + 1;
 +
            RU  = RU + CRS(Z);
 +
          ENDFOR;
 +
 
 +
 
 +
          BIN    = %LEN(RU);
 +
          OUTLEN = HX2;
 +
          INLEN  = X000;
 +
          FNC    = SND;
 +
          A      = RU;
 +
          EXCEPT DATAO;
 +
          RU    = *ALLX'00';
 +
          CLEAR  RU;
 +
 
 +
 
 +
          EXSR      @KEYIN;
 +
          READ      DISPF;
 +
 
 +
 
 +
      //  CLEAR HEADINGS
 +
            RU    = *ALLX'00';
 +
            CLEAR RU;
 +
 
 +
        RU  = RU + ESC + WTD + X20 + X00 + SBA;
 +
        HX1  = %SUBST(B(Y) :1:1) ;
 +
        BIN  = BIN - 1;
 +
        RU  = RU + HX1 + %SUBST(B(Y):2:1);
 +
          FOR X = S(Y) TO E(Y);
 +
          RU = RU + ' ';
 +
          ENDFOR;
 +
        RU = RU + ' ';
 +
 
 +
        BIN    = %LEN(RU);
 +
        OUTLEN = HX2;
 +
        INLEN  = X000;
 +
        FNC    = SND;
 +
        A      = RU;
 +
        EXCEPT    DATAO;
 +
        RU    = *ALLX'00';
 +
        CLEAR  RU;
 +
 
 +
        ENDSR;
 +
 
 +
 
 +
 
 +
      //  @@@@@@@    UPD  @@@@@@@@@@@@@@@@@@@@@@@@@
 +
          BEGSR  @UPD;
 +
 
 +
        // CONVERT  DATA  FOR OUTPUT
 +
 
 +
        //  FOR EACH  FIELD, CHECK IF FIELD WAS MODIFIED, AND IF SO MOVE
 +
        // THE MODIFIED DATA INTO THE OUTPUT ARRAY
 +
        K1 = 0;
 +
        K2 = 0;
 +
        W  = 1;
 +
        CGKY = *BLANK;  // KEY CHANGED
 +
        KW  = KEYA;
 +
 
 +
          FOR  Y  = 1  TO NUMFKY ;
 +
 
 +
            IF KY(Y) > '1';
 +
            ITER;
 +
            ENDIF;
 +
 
 +
 
 +
      //  MOVE A KEY FIELDS DATA FROM ID ARRAY (SCREEN) TO K ARRAY
 +
 
 +
      //  GET SIZE OF FIELD IN BYTES
 +
          IF T(Y)  =  'A';  // ALPHA DATA
 +
          K = ' ';
 +
          K1 = 1;
 +
          K2 = Q(Y);
 +
          ELSE;
 +
          K  = '0';
 +
          K1 =  1;
 +
          K2 = C(Y);
 +
          ENDIF;
 +
 
 +
          X  =  1;
 +
 
 +
          DOW  @LOOP = @LOOP;
 +
 
 +
      //  NXTSBA
 +
          X  = %LOOKUP(SBA : ID : X );
 +
          IF X = 0;
 +
            LEAVE;
 +
          ENDIF;
 +
 
 +
      // IS THIS THE FIELD?  CHECK THE BUFFER ADDRESS
 +
        X = X +1;
 +
        IF  B(Y)  <>  %SUBST(IDA : X :2);
 +
          ITER;
 +
        ENDIF;
 +
 
 +
 
 +
      //  FOUND A MTD FOR THIS FIELD
 +
 
 +
 
 +
        // CHECK IF FIELD WAS CLEARED ONLY
 +
          DOW @LOOP = @LOOP; //  not a loop
 +
        X =  X + 2;
 +
        IF  ID(X) = SBA;
 +
          LEAVE;
 +
        ENDIF;
 +
 
 +
      //  IF FIELD HAS DECIMALS BUMP X
 +
          IF (T(Y) = 'S' OR T(Y) = 'P' OR T(Y) = 'B') AND
 +
              P(Y) > 0;
 +
              X = X + 1;
 +
          ENDIF;
 +
 
 +
 
 +
      //  CHECK IF ONLY BLANKS RETURNED
 +
          IF    %SUBST(IDA : X :K2) = *BLANKS;
 +
              LEAVE;
 +
          ENDIF;
 +
 
 +
        // MOVE DATA TO WORK ARRAY K
 +
            X1 = X;
 +
            FOR X2 = 1 TO K2;
 +
 
 +
            IF ID(X1) < ' ';
 +
              LEAVE;
 +
            ENDIF;
 +
 
 +
            K(X2) = ID(X1);
 +
            X1 = X1 + 1;
 +
            ENDFOR;
 +
 
 +
          LEAVE;
 +
        ENDDO;
 +
 
 +
        // *  SET START POSN
 +
          W =  S(Y);
 +
 
 +
        // ALPHA
 +
          IF T(Y) =  'A'  and V(XX) <>  'Y';
 +
          FOR Z  =  K1 to K2;
 +
            D(W) =  K(Z);
 +
            W    =  W + 1;
 +
          ENDFOR;
 +
          ENDIF;
 +
 
 +
        IF T(Y) =  'A' and  V(XX) = 'Y';  //VARYING
 +
 
 +
        //  the data start is in S(Y)
 +
        //  the data is in array K
 +
        //  get the length of the data cvt to bin and stik in pos 1 2
 +
        //  put the rest in pos 3 onwards
 +
 
 +
              ENDIF;
 +
 
 +
        // NUMERIC FIELD
 +
        // RIGHT  ADJUST NUMERIC DATA ,STRIP - . ,CONVERT BLANKS
 +
          IF (T(Y) = 'S' OR T(Y) = 'P' OR T(Y) = 'B');
 +
          NU = '0';
 +
 
 +
          Z1 = 60;
 +
          FOR Z  =  K2  DOWNTO K1;
 +
 
 +
          IF K(Z) = '.' OR K(Z) = '-' OR K(Z) = '$';
 +
          ITER;
 +
          ENDIF;
 +
 
 +
          IF K(Z) = ' ' ;
 +
          NU(Z1) = '0';
 +
          ELSE;
 +
          NU(Z1) = K(Z);
 +
          ENDIF;
 +
 
 +
            Z1 = Z1 -1;
 +
          ENDFOR;
 +
 
 +
          ENDIF;
 +
 
 +
 
 +
      // SIGNED FIELDS  (END POSN = OFFSET + SIZE)
 +
        IF T(Y)  = 'S';
 +
          NUSA= *BLANKS;
 +
          FOR VX = 1 TO 60;
 +
            NUSA = %TRIM(NUSA) + NU(VX);
 +
          ENDFOR;
 +
        %SUBST(DATA  : W : Q(Y)) = %SUBST(NUSA: 61 -Q(Y));
 +
 
 +
        ENDIF;
 +
 
 +
 
 +
      //  PACKED FIELDS
 +
          IF    T(Y)  =  'P';
 +
          NUSA= *BLANKS;
 +
          FOR VX = 1 TO 60;
 +
            NUSA = %TRIM(NUSA) + NU(VX);
 +
          ENDFOR;
 +
          NUP    = %DEC(NUSA : 60 : 0);
 +
 
 +
        %SUBST(DATA : W : Q(Y))  =  %SUBST(NUPA: 61 -Q(Y));
 +
        ENDIF;
 +
 
 +
      //  BINARY FIELDS
 +
        IF  T(Y) =  'B';
 +
 
 +
        NUSA= *BLANKS;
 +
          FOR VX = 1 TO 60;
 +
            NUSA = %TRIM(NUSA) + NU(VX);
 +
          ENDFOR;
 +
            NUC  = NUS;
 +
 
 +
        IF  Q(Y) = 2 ;
 +
              DISBIN  ( NUC : BAN2 : BAN4  : '2');
 +
            %SUBST(DATA : W : 2)  =  BAN2;
 +
        ENDIF;
 +
 
 +
        IF  Q(Y) = 4 ;
 +
              DISBIN  ( NUC : BAN2 : BAN4  : '4');
 +
            %SUBST(DATA : W : 4)  =  BAN4;
 +
        ENDIF;
 +
 
 +
        ENDIF;
 +
 
 +
        //  UPDATE KEY IF NECESSARY
 +
        IF  KY(Y)  = '1';
 +
            CGKY = '1';
 +
            EXSR  @PCKMOV;
 +
        ENDIF;
 +
 
 +
 
 +
        ENDDO;
 +
        ENDFOR;
 +
 
 +
 
 +
          IF  CGKY = '1';
 +
          KEYA = KW;
 +
          ENDIF;
 +
 
 +
        ENDSR;
 +
 
 +
 
 +
 
 +
      /END-FREE
 +
 
 +
    OINPUTK    E    U1      UPDATREC
 +
    O                      DA
 +
    O              30      DB
 +
    O              31      DC
 +
    O              32      DD
 +
    O              33      DE
 +
    O              34      DF
 +
    O              35      DG
 +
    O              36      DH
 +
    O              37      DI
 +
    O              38      DJ
 +
    O              39      DK
 +
    O              40      DL
 +
    O              41      DM
 +
    O              42      DN
 +
    O              43      DZ
 +
    O              44      DO
 +
    O              45      DP
 +
    O              46      DQ
 +
    O              47      DR
 +
    O              48      DS
 +
    O              49      DT
 +
    O              50      DU
 +
    O              51      DV
 +
    O              52      DW
 +
    O              53      DX
 +
    O              54      DY
 +
    O              55      D0
 +
    O              56      D1
 +
    O              57      D2
 +
    O              58      D3
 +
    O              59      D4
 +
    O              60      D5
 +
    O              61      D6
 +
    O              62      DBA
 +
    O              63      DCA
 +
    O              64      DDA
 +
    O              65      DEA
 +
    O              66      DFA
 +
    O              67      DGA
 +
    O              68      DHA
 +
    O              69      DIA
 +
    O              70      DJA
 +
    O              71      DKA
 +
    O              72      DLA
 +
    O              73      DMA
 +
    O              74      DNA
 +
    O              75      DOA
 +
    O              76      DPA
 +
    O              77      DQA
 +
    O              78      DRA
 +
    O              79      DSA
 +
    O              80      DTA
 +
    O              81      DUA
 +
    O              82      DVA
 +
    O              83      DWA
 +
    O              84      DXA
 +
    O              85      DYA
 +
    O              86      DZA
 +
    O              87      D0A
 +
    O              88      D1A
 +
    O              89      D2A
 +
    O              90      D3A
 +
    O              91      D4A
 +
    O              92      D5A
 +
    O              93      D6A
 +
    OINPUTR    E      U2  UPDATREC
 +
    O                      DA
 +
    O              30      DB
 +
    O              31      DC
 +
    O              32      DD
 +
    O              33      DE
 +
    O              34      DF
 +
    O              35      DG
 +
    O              36      DH
 +
    O              37      DI
 +
    O              38      DJ
 +
    O              39      DK
 +
    O              40      DL
 +
    O              41      DM
 +
    O              42      DN
 +
    O              43      DZ
 +
    O              44      DO
 +
    O              45      DP
 +
    O              46      DQ
 +
    O              47      DR
 +
    O              48      DS
 +
    O              49      DT
 +
    O              50      DU
 +
    O              51      DV
 +
    O              52      DW
 +
    O              53      DX
 +
    O              54      DY
 +
    O              55      D0
 +
    O              56      D1
 +
    O              57      D2
 +
    O              58      D3
 +
    O              59      D4
 +
    O              60      D5
 +
    O              61      D6
 +
    O              62      DBA
 +
    O              63      DCA
 +
    O              64      DDA
 +
    O              65      DEA
 +
    O              66      DFA
 +
    O              67      DGA
 +
    O              68      DHA
 +
    O              69      DIA
 +
    O              70      DJA
 +
    O              71      DKA
 +
    O              72      DLA
 +
    O              73      DMA
 +
    O              74      DNA
 +
    O              75      DOA
 +
    O              76      DPA
 +
    O              77      DQA
 +
    O              78      DRA
 +
    O              79      DSA
 +
    O              80      DTA
 +
    O              81      DUA
 +
    O              82      DVA
 +
    O              83      DWA
 +
    O              84      DXA
 +
    O              85      DYA
 +
    O              86      DZA
 +
    O              87      D0A
 +
    O              88      D1A
 +
    O              89      D2A
 +
    O              90      D3A
 +
    O              91      D4A
 +
    O              92      D5A
 +
    O              93      D6A
 +
 
 +
    OINPUTK    EADD U1      ADDREC
 +
    O                      DA
 +
    O              30      DB
 +
    O              31      DC
 +
    O              32      DD
 +
    O              33      DE
 +
    O              34      DF
 +
    O              35      DG
 +
    O              36      DH
 +
    O              37      DI
 +
    O              38      DJ
 +
    O              39      DK
 +
    O              40      DL
 +
    O              41      DM
 +
    O              42      DN
 +
    O              43      DZ
 +
    O              44      DO
 +
    O              45      DP
 +
    O              46      DQ
 +
    O              47      DR
 +
    O              48      DS
 +
    O              49      DT
 +
    O              50      DU
 +
    O              51      DV
 +
    O              52      DW
 +
    O              53      DX
 +
    O              54      DY
 +
    O              55      D0
 +
    O              56      D1
 +
    O              57      D2
 +
    O              58      D3
 +
    O              59      D4
 +
    O              60      D5
 +
    O              61      D6
 +
    O              62      DBA
 +
    O              63      DCA
 +
    O              64      DDA
 +
    O              65      DEA
 +
    O              66      DFA
 +
    O              67      DGA
 +
    O              68      DHA
 +
    O              69      DIA
 +
    O              70      DJA
 +
    O              71      DKA
 +
    O              72      DLA
 +
    O              73      DMA
 +
    O              74      DNA
 +
    O              75      DOA
 +
    O              76      DPA
 +
    O              77      DQA
 +
    O              78      DRA
 +
    O              79      DSA
 +
    O              80      DTA
 +
    O              81      DUA
 +
    O              82      DVA
 +
    O              83      DWA
 +
    O              84      DXA
 +
    O              85      DYA
 +
    O              86      DZA
 +
    O              87      D0A
 +
    O              88      D1A
 +
    O              89      D2A
 +
    O              90      D3A
 +
    O              91      D4A
 +
    O              92      D5A
 +
    O              93      D6A
 +
    OINPUTR    EADD    U2  ADDREC
 +
    O                      DA
 +
    O              30      DB
 +
    O              31      DC
 +
    O              32      DD
 +
    O              33      DE
 +
    O              34      DF
 +
    O              35      DG
 +
    O              36      DH
 +
    O              37      DI
 +
    O              38      DJ
 +
    O              39      DK
 +
    O              40      DL
 +
    O              41      DM
 +
    O              42      DN
 +
    O              43      DZ
 +
    O              44      DO
 +
    O              45      DP
 +
    O              46      DQ
 +
    O              47      DR
 +
    O              48      DS
 +
    O              49      DT
 +
    O              50      DU
 +
    O              51      DV
 +
    O              52      DW
 +
    O              53      DX
 +
    O              54      DY
 +
    O              55      D0
 +
    O              56      D1
 +
    O              57      D2
 +
    O              58      D3
 +
    O              59      D4
 +
    O              60      D5
 +
    O              61      D6
 +
    O              62      DBA
 +
    O              63      DCA
 +
    O              64      DDA
 +
    O              65      DEA
 +
    O              66      DFA
 +
    O              67      DGA
 +
    O              68      DHA
 +
    O              69      DIA
 +
    O              70      DJA
 +
    O              71      DKA
 +
    O              72      DLA
 +
    O              73      DMA
 +
    O              74      DNA
 +
    O              75      DOA
 +
    O              76      DPA
 +
    O              77      DQA
 +
    O              78      DRA
 +
    O              79      DSA
 +
    O              80      DTA
 +
    O              81      DUA
 +
    O              82      DVA
 +
    O              83      DWA
 +
    O              84      DXA
 +
    O              85      DYA
 +
    O              86      DZA
 +
    O              87      D0A
 +
    O              88      D1A
 +
    O              89      D2A
 +
    O              90      D3A
 +
    O              91      D4A
 +
    O              92      D5A
 +
    O              93      D6A
 +
 
 +
    OINPUTK    EDEL U1      DELREC
 +
    OINPUTR    EDEL U2      DELREC
 +
 
 +
 
 +
    ODISPF    E            DATAO
 +
    O                                          K3 'PUT'
 +
    O                      OUTLEN              2
 +
    O                      INLEN
 +
    O                      FNC
 +
    O                      A
 +
 
 +
    O          E            DATAI
 +
    O                                          K3 'GET'
 +
    O                      OUTLEN              2
 +
    O                      INLEN
 +
    O                      FNC
 +
    O                      A
 +
**
 +
0000 INVALID COMMAND KEY
 +
0001  - A FIELD IS TOO LONG
 +
0002  - TOO MANY FIELDS
 +
0003  - ALPHAS IN PACKED KEY
 +
0004  - MISSING ' IN PACKED KEY
 +
0005  - MISSING DATA IN PCKD KEY
 +
0006  - RECORD NOT FOUND
 +
PRESS RESET TO CONTINUE
 +
**
 +
F1-HEX F2-Return F3-Exit F19-Prev_fld F20-More_fld
 +
F1-HEX F2-Return F3-Exit F6-Update F9-Add F11-Del F19-Prev_fld F20-More_fld
 +
**
 +
0123456789ABCDEF
 +
 
 +
 
 +
</pre>
 +
 
 +
[[#top]]
 +
 
 +
 
 +
===DISPF   DSPF ===
  
 
<pre>
 
<pre>
 +
    A                                      DSPSIZ(24 80 *DS3)
 +
    A                                      PRINT
 +
    A                                      OPENPRT
 +
    A                                      HELP
 +
    A                                      INDARA
 +
    A          R PUT                      USRDFN
 +
    A          R GET                      USRDFN
 +
    A                                      INVITE
 +
</pre>
 +
 +
 +
[[#top]]
 +
 +
== WRAPPER CODE ==
 +
 +
===DSPFL    CMD ===
 +
 +
<pre>
 +
  /*  TO COMPILE */
 +
  /*  CRTCMD CMD(*CURLIB/DSPFL) PGM(*LIBL/DIS) SRCFILE(*LIBL/QCMDSRC) */
 +
  /*          SRCMBR(DSPFL) VLDCKR(DISV) */
 +
 
 +
            CMD        PROMPT('Display file in field format')
 +
 +
            PARM      KWD(FILE) TYPE(QUAL1) MIN(1) MAX(1) +
 +
                          PROMPT('File')
 +
 +
            PARM      KWD(MBR) TYPE(*NAME) DFT(*FIRST) +
 +
                          SPCVAL((*FILE) (*FIRST)) MIN(0) MAX(1) +
 +
                          PROMPT('Member')
 +
 +
            PARM      KWD(UPD ) TYPE(*CHAR) LEN(1) DFT(N) +
 +
                          RSTD(*YES) VALUES('Y' 'N' 'y' 'n') +
 +
                          PROMPT('Update data (Y/N)')
 +
 +
            PARM      KWD(RST ) TYPE(*CHAR) LEN(1) DFT(N) +
 +
                          RSTD(*YES) VALUES('Y' 'N' 'y' 'n') +
 +
                          PROMPT('Get DDS again.')
 +
 +
            PARM      KWD(REL ) TYPE(*CHAR) LEN(1) DFT(N) +
 +
                          RSTD(*YES) VALUES('Y' 'N' 'y' 'n') +
 +
                          PROMPT('Show Relations')
 +
 +
 +
QUAL1:      QUAL      TYPE(*NAME) LEN(10)
 +
            QUAL      TYPE(*NAME) LEN(10) DFT(*LIBL  ) +
 +
                          SPCVAL(*LIBL  ) +
 +
                          PROMPT('Library name')
 +
 +
 +
</pre>
 +
 +
[[#top]]
 +
 +
===DIS    CL ===
 +
 +
<pre>
 +
 +
/* Command processing program for DSPFF command */
 +
 +
PGM (&FILIB  &MBR &UPD &RST &REL)
 +
 +
DCL &FILIB *CHAR 20
 +
DCL &FILE *CHAR  10
 +
DCL &LIB  *CHAR  10
 +
DCL &SFILE *CHAR  10
 +
DCL &SLIB  *CHAR  10
 +
DCL &MBR  *CHAR  10
 +
DCL &OPT  *CHAR  10
 +
DCL &ALL  *CHAR 1
 +
DCL &RTN  *CHAR 1
 +
DCL &RMBR  *CHAR  10
 +
 +
DCL &QRY  *LGL
 +
DCL &UPD  *LGL
 +
DCL &REL  *CHAR 1
 +
DCL &RST  *CHAR 1
 +
 +
DCL &RCDL *CHAR 5
 +
DCL &RCDLN *DEC (5 0)
 +
DCL &ACCP *CHAR 1
 +
DCL &OVR  *LGL  VALUE('0')
 +
DCL &FILEF *CHAR  10
 +
DCL &FILEK *CHAR  10
 +
DCL &ID    *CHAR  7
 +
DCL &MF    *CHAR  10
 +
DCL &ML    *CHAR  10
 +
DCL &TYPE  *CHAR  1
 +
DCL &PHY  *CHAR  10
 +
DCL &PHYLIB *CHAR  10
 +
 +
RMVLIBLE QTEMP
 +
MONMSG CPF0000
 +
ADDLIBLE QTEMP *FIRST
 +
MONMSG CPF0000 EXEC(GOTO END)
 +
 +
RESET:
 +
CHGVAR &FILE  &FILIB
 +
CHGVAR &LIB  (%SST(&FILIB 11 10))
 +
IF (&LIB *EQ ' ')    (CHGVAR &LIB '*LIBL')
 +
IF (&MBR *EQ '*FILE') (CHGVAR &MBR &FILE)
 +
IF (&MBR *EQ '*FIRST') (DO)
 +
RTVMBRD    FILE(&LIB/&FILE) RTNMBR(&RMBR)
 +
CHGVAR &MBR &RMBR
 +
ENDDO
 +
CHGVAR &FILEF ('FF'||(%SST(&FILE 1 8)))
 +
CHGVAR &FILEK ('KF'||(%SST(&FILE 1 8)))
 +
 +
IF (&RST= 'Y') DO
 +
DLTF  &FILEF
 +
MONMSG CPF0000
 +
DLTF  &FILEK
 +
MONMSG CPF0000
 +
ENDDO
 +
 +
 +
CHKOBJ (QTEMP/&FILEF) *FILE
 +
  MONMSG CPF9801 EXEC(DO)
 +
  DSPFFD  FILE(&LIB/&FILE) OUTPUT(*OUTFILE) OUTFILE(QTEMP/&FILEF)
 +
  DSPFD (&LIB/&FILE) TYPE(*ACCPTH) OUTPUT(*OUTFILE) OUTFILE(QTEMP/&FILEK)
 +
  CHGVAR &RTN '2'
 +
ENDDO
 +
 +
CHGPF QTEMP/&FILEF LVLCHK(*NO)
 +
CHGPF QTEMP/&FILEK LVLCHK(*NO)
 +
 +
IF (&REL = 'Y' ) DO
 +
  CALL DISF  (&FILEK &TYPE &PHY &PHYLIB)
 +
  IF (&TYPE *EQ 'P') DO
 +
    CHGVAR &PHY &FILE
 +
    CHGVAR &PHYLIB &LIB
 +
  ENDDO
 +
CALL  DIS3 (&PHY &PHYLIB &SFILE &SLIB)
 +
IF (&SFILE *NE ' ') DO
 +
  IF ((&SFILE *NE &FILE) *OR (&SLIB *NE &LIB)) DO
 +
  CHGVAR &FILIB (&SFILE||&SLIB)
 +
  CHGVAR &REL '0'
 +
  RTVMBRD    FILE(&SLIB/&SFILE) RTNMBR(&RMBR)
 +
  CHGVAR &MBR &RMBR
 +
  IF (&MBR  *EQ &FILE) THEN(CHGVAR &MBR '*FILE    ')
 +
  GOTO  RESET
 +
  ENDDO
 +
ENDDO
 +
ENDDO
 +
 +
CALL  DIS1 (&FILIB  &MBR &UPD &RST &RTN &FILE &LIB &FILEF &FILEK)
 +
 +
RCLRSC
 +
 +
END:
 +
CLOF  OPNID(&FILE)
 +
MONMSG CPF0000
 +
 +
 +
 +
ENDPGM
 +
 +
</pre>
 +
 +
[[#top]]
 +
 +
===DIS1    CL ===
 +
 +
<pre>
 +
/* CALLED BY DIS TO DRIVE SELECTION OF UDDS RPG PROGRAM */
 +
/*  FILE DISPLAYER DRIVER  */
 +
/*  SHOWS A LIST OF FIELDS IN A FILE , ALLOWS SELECTION OF FIELDS  */
 +
 +
/*  WHEN ALL THE FIELDS DONT FIT ON ONE SCREEN                */
 +
/*  THIS CONTAINS A LOOP SO THAT MORE FIELDS CAN BE DISPLAYED  */
 +
 +
 +
PGM (&FILIB  &MBR &UPD &RST &RTN &FILE &LIB &FILEF &FILEK)
 +
 +
DCL &FILIB *CHAR 20
 +
DCL &FILE *CHAR  10
 +
DCL &LIB  *CHAR  10
 +
DCL &MBR  *CHAR  10
 +
DCL &PRG  *CHAR  10
 +
DCL &OPT  *CHAR  10
 +
DCL &ALL  *CHAR 1
 +
DCL &RTN  *CHAR 1
 +
DCL &RMV  *CHAR 1
 +
DCL &QRY  *LGL
 +
DCL &UPD  *CHAR 1
 +
DCL &RST  *LGL
 +
DCL &KEYL *CHAR 4
 +
DCL &RCDL *CHAR 5
 +
DCL &RCDLN *DEC (5 0)
 +
DCL &ACCP *CHAR 1
 +
DCL &OVR  *LGL  VALUE('0')
 +
DCL &FILEF *CHAR  10
 +
DCL &FILEK *CHAR  10
 +
DCL &ID    *CHAR  7
 +
DCL &MF    *CHAR  10
 +
DCL &ML    *CHAR  10
 +
DCL &SCNLV *CHAR  500
 +
DCL &SCNLVL *CHAR  5
 +
DCL &SCNKEY *CHAR  800
 +
DCL &JOB  *CHAR  10
 +
DCL &MSG  *CHAR  80
 +
DCLF    DISPX
 +
 +
CHGVAR &PGMQ DIS
 +
CHGVAR &SCNLVL '00000'
 +
 +
OVRDBF FFD QTEMP/&FILEF SECURE(*YES)
 +
OVRDBF KF  QTEMP/&FILEK SECURE(*YES)
 +
 +
 +
RTN:
 +
OVRDBF  INPUT  &LIB/&FILE  SHARE(*NO)
 +
CALL  DISPY    (&ALL &RTN &KEYL &ACCP &QRY &RCDL)
 +
            MONMSG    MSGID(CPF5035 CPF5029 RNQ1299 RNX0000) EXEC(DO)
 +
            RTVJOBA    JOB(&JOB)
 +
            SNDBRKMSG  MSG('Cannot handle this file type. Possibly +
 +
                          has NULL data field.') TOMSGQ(&job) +
 +
                          MSGTYPE(*INQ) RPYMSGQ(&job)
 +
 +
  goto end
 +
ENDDO
 +
 +
DLTOVR  INPUT
 +
MONMSG CPF0000
 +
 +
IF (&RTN *EQ '1') (GOTO END)
 +
 +
IF (&ACCP *EQ 'K') DO
 +
CHGJOB SWS(10XXXXXX)
 +
OVRDBF    FILE(INPUTK) TOFILE(&LIB/&FILE) MBR(&MBR) +
 +
        SHARE(*YES) SEQONLY(*NO)  SECURE(*YES)
 +
IF (&QRY )  DO
 +
REMSG:
 +
 +
REQRY:      SNDRCVF    RCDFMT(SLT)
 +
            IF (&IN01 *OR &IN02) GOTO BYQRY
 +
            CHGVAR &OPT '*INP'
 +
            IF (&UPD *EQ 'Y') (CHGVAR &OPT '*ALL')
 +
            OPNQRYF    FILE((INPUTK)) OPTION(&OPT) QRYSLT(&QSLT) +
 +
                          KEYFLD(*FILE) SEQONLY(*NO)
 +
            MONMSG CPF9899 EXEC(DO)
 +
            RCVMSG    MSGTYPE(*ANY)
 +
            SNDF      RCDFMT(SLTC)
 +
            GOTO REMSG
 +
                                ENDDO
 +
                      ENDDO
 +
              ENDDO
 +
BYQRY:
 +
IF (&ACCP *EQ 'A') DO
 +
            CHGJOB SWS(01XXXXXX)
 +
          OVRDBF    FILE(INPUTR) TOFILE(&LIB/&FILE) MBR(&MBR) +
 +
                          SHARE(*YES) SEQONLY(*NO) SECURE(*YES)
 +
    IF (&QRY )        DO
 +
REMSGA:
 +
 +
REQRYA:    SNDRCVF    RCDFMT(SLT)
 +
            IF (&IN01 *OR &IN02) GOTO BYQRYA
 +
            CHGVAR &OPT '*INP'
 +
            IF (&UPD = 'Y') (CHGVAR &OPT '*ALL')
 +
            OPNQRYF    FILE((INPUTR)) OPTION(&OPT) QRYSLT(&QSLT) +
 +
                          KEYFLD(*FILE) SEQONLY(*NO)
 +
            MONMSG CPF9899 EXEC(DO)
 +
                RCVMSG    MSGTYPE(*ANY)
 +
                SNDF      RCDFMT(SLTC)
 +
                GOTO REMSGA
 +
                CHGVAR    VAR(&IN20) VALUE('1')
 +
    SDAMSG:    RCVMSG    RMV(*NO) MSG(&MSG)
 +
                IF        COND(&MSG ¬= ' ') THEN(DO)
 +
                SNDPGMMSG  MSG(&MSG)
 +
                GOTO      SDAMSG
 +
                ENDDO
 +
                SNDF      RCDFMT(SLTC)
 +
                GOTO      REMSGA
 +
                                ENDDO
 +
 +
                    ENDDO
 +
            ENDDO
 +
BYQRYA:
 +
CHGVAR &RCDLN &RCDL
 +
 +
IF ( &UPD= 'Y') (DO)
 +
IF ((&RCDLN *GT    0) *AND (&RCDLN *LE 2048)) (CHGVAR &PRG 'DUSP ')
 +
IF ((&RCDLN *GT 2048) *AND (&RCDLN *LE 4048)) (CHGVAR &PRG 'DUSP1')
 +
IF ((&RCDLN *GT 4048) *AND (&RCDLN *LE 6080)) (CHGVAR &PRG 'DUSP2')
 +
          ENDDO
 +
IF (&UPD *NE 'Y') (DO)
 +
IF ((&RCDLN *GT    0) *AND (&RCDLN *LE 2048)) (CHGVAR &PRG 'DISP ')
 +
IF ((&RCDLN *GT 2048) *AND (&RCDLN *LE 4048)) (CHGVAR &PRG 'DISP1')
 +
IF ((&RCDLN *GT 4048) *AND (&RCDLN *LE 6080)) (CHGVAR &PRG 'DISP2')
 +
          ENDDO
 +
 +
 +
CALL  &PRG  (&ALL &RTN &KEYL &UPD &SCNLV  &SCNLVL &SCNKEY)
 +
 +
IF (&QRY )  (DO)
 +
  IF (&ACCP *EQ 'K') DO
 +
  CLOF    INPUTK
 +
  MONMSG CPF0000
 +
                  ENDDO
 +
  IF (&ACCP *EQ 'A') DO
 +
  CLOF    INPUTR
 +
  MONMSG CPF0000
 +
                  ENDDO
 +
ENDDO
 +
 +
IF (&RTN *EQ '3') DO
 +
  GOTO BYQRYA
 +
  ENDDO
 +
 +
IF (&RTN *EQ '1') DO
 +
  CHGVAR &RTN '0'
 +
  GOTO RTN
 +
  ENDDO
 +
 +
 +
 +
END:  ENDPGM
 +
 +
</pre>
 +
 +
[[#top]]
 +
 +
===DIS3    CL ===
 +
 +
<pre>
 +
 +
/* CALL BY DIS TO SHOW FILE RELATIONS / ACCESS PATHS */
 +
 +
PGM  (&PHY &PHYLIB &SFILE &SLIB)
 +
 +
/* DISPLAY ACCESS PATHS */
 +
 +
DCL &PHY    *CHAR  10
 +
DCL &PHYLIB *CHAR  10
 +
DCL &SFILE  *CHAR  10
 +
DCL &SLIB  *CHAR  10
 +
 +
 +
DCLF QTEMP/DBR
 +
 +
/* CREATE WORK FILES */
 +
CALL  DIS4
 +
 +
DLTF QTEMP/DBR
 +
MONMSG CPF0000
 +
 +
DSPDBR    FILE(&PHYLIB/&PHY) OUTPUT(*OUTFILE) +
 +
  OUTFILE(QTEMP/DBR) OUTMBR(*FIRST *REPLACE)
 +
CHGPF QTEMP/DBR LVLCHK(*NO)
 +
 +
NEXT: RCVF
 +
MONMSG CPF0000 EXEC(GOTO END)
 +
IF (&WHREFI *NE ' ') DO
 +
DSPFD      FILE(&WHRELI/&WHREFI) TYPE(*ACCPTH) +
 +
        OUTPUT(*OUTFILE) OUTFILE(QTEMP/REL) OUTMBR(*FIRST *ADD)
 +
CHGPF QTEMP/REL LVLCHK(*NO)
 +
DSPFD      FILE(&WHRELI/&WHREFI) TYPE(*SELECT) +
 +
        OUTPUT(*OUTFILE) OUTFILE(QTEMP/SEL) OUTMBR(*FIRST *ADD)
 +
CHGPF QTEMP/SEL LVLCHK(*NO)
 +
        ENDDO
 +
GOTO NEXT
 +
 +
END:
 +
DSPFD      FILE(&PHYLIB/&PHY  ) TYPE(*ACCPTH) +
 +
        OUTPUT(*OUTFILE) OUTFILE(QTEMP/REL) OUTMBR(*FIRST *ADD)
 +
CHGPF QTEMP/REL LVLCHK(*NO)
 +
 +
CHGVAR &SFILE '          '
 +
CHGVAR &SLIB  '          '
 +
 +
OVRDBF SEL QTEMP/SEL
 +
OVRDBF REL QTEMP/REL
 +
CALL  DISPR (&SFILE &SLIB)
 +
DLTOVR *ALL
 +
 +
ENDPGM
 +
 +
</pre>
 +
 +
[[#top]]
 +
 +
===DIS4    CL ===
 +
 +
<pre>
 +
 +
/* CALL BY DIS3 TO CREATE WORK FILES */
 +
 +
PGM
 +
 +
DCL  &LIB *CHAR 10
 +
DCL  &SRCF *CHAR 10
 +
 +
RTVDTAARA DTAARA(UDDSSRC *ALL)  RTNVAR(&SRCF)
 +
 +
DLTF  QTEMP/XXXXFILE
 +
monmsg cpf0000
 +
CRTPF      FILE(QTEMP/XXXXFILE) RCDLEN(80) OPTION(*NOLIST)
 +
 +
DSPFFD  FILE(QTEMP/XXXXFILE) OUTPUT(*OUTFILE) OUTFILE(QTEMP/FFD)
 +
CLRPFM  QTEMP/FFD
 +
DLTF  FILE(QTEMP/FFDL01)
 +
MONMSG CPF0000
 +
 +
RTVMBRD FILE(&SRCF) RTNLIB(&LIB)
 +
CRTLF FILE(QTEMP/FFDL01) SRCFILE(&LIB/&SRCF) SRCMBR(FFDL01) +
 +
OPTION(*NOSRC *NOLIST)
 +
 +
DLTF  FILE(QTEMP/REL)
 +
MONMSG CPF0000
 +
DLTF  FILE(QTEMP/SEL)
 +
MONMSG CPF0000
 +
DLTF  FILE(QTEMP/DBR)
 +
MONMSG CPF0000
 +
 +
DSPFD      FILE(QTEMP/FFD) TYPE(*ACCPTH) +
 +
  OUTPUT(*OUTFILE) OUTFILE(QTEMP/REL) OUTMBR(*FIRST *ADD)
 +
 +
DSPFD FILE(QTEMP/FFDL01) TYPE(*SELECT) OUTPUT(*OUTFILE) OUTFILE(QTEMP/SEL)
 +
CLRPFM FILE(QTEMP/REL)
 +
CLRPFM FILE(QTEMP/SEL)
 +
 +
DLTF  QTEMP/XXXXFILE
 +
monmsg cpf0000
 +
 +
 +
ENDPGM
 +
 +
</pre>
 +
 +
[[#top]]
 +
 +
===DISBIN    CL ===
 +
 +
<pre>
 +
/* NUMERIC TO BINARY CONVERTER  */
 +
 +
 +
PGM (&NUM  &BIN2  &BIN4 &BINTYP  )
 +
 +
DCL  VAR(&NUM) TYPE(*DEC) LEN(15 0)
 +
DCL VAR(&BINTYP) TYPE(*CHAR) LEN(1)
 +
DCL VAR(&BIN2) TYPE(*CHAR) LEN(2)
 +
DCL VAR(&BIN4) TYPE(*CHAR) LEN(4)
 +
 +
IF (&BINTYP = '4') (CHGVAR %BIN(&BIN4) &NUM)
 +
IF (&BINTYP = '2') (CHGVAR %BIN(&BIN2) &NUM)
 +
ENDPGM
 +
 +
</pre>
 +
 +
[[#top]]
 +
 +
===DISF    CL ===
 +
 +
<pre>
 +
 +
/* CHECK FILE TYPE */
 +
 +
PGM (&DISF &TYPE &PHY &PHYLIB)
 +
 +
 +
DCL  &DISF  *CHAR 10
 +
DCL  &TYPE  *CHAR 1
 +
DCL  &PHY    *CHAR 10
 +
DCL  &PHYLIB *CHAR 10
 +
DCLF KF
 +
 +
            OVRDBF    FILE(KF) TOFILE(QTEMP/&DISF)
 +
            OPNDBF    FILE(KF) OPTION(*INP)
 +
            RCVF
 +
            CHGVAR &TYPE &APFTYP
 +
 +
            IF (&TYPE *EQ 'L') DO
 +
            CHGVAR &PHY &APBOF
 +
            CHGVAR &PHYLIB &APBOL
 +
            ENDDO
 +
 +
            CLOF      OPNID(KF)
 +
ENDPGM
 +
 +
</pre>
 +
 +
[[#top]]
 +
 +
 +
 +
===DISV    CL ===
 +
 +
<pre>
 +
/* VALIDITY CHECKER FOR DSPFL COMMAND */
 +
 +
 +
PGM (&FILIB  &MBR &UPD &RST &REL)
 +
 +
DCL &FILIB  *CHAR 20
 +
DCL &FILE *CHAR  10
 +
DCL &LIB  *CHAR  10
 +
DCL &MBR  *CHAR  10
 +
DCL &UPD  *CHAR  1
 +
DCL &RST  *CHAR  1
 +
DCL &REL  *CHAR  1
 +
DCL &OBJATR *CHAR 10
 +
DCL &AUT    *CHAR  8
 +
 +
DCL &MSGDTA *CHAR 40
 +
DCL &ERROR  *LGL
 +
 +
CHGVAR &FILE  &FILIB
 +
CHGVAR &LIB  (%SST(&FILIB 11 10))
 +
IF (&MBR *EQ '*FILE') (CHGVAR &MBR  &FILE  )
 +
 +
CHGVAR &AUT '*READ  '
 +
IF ((&UPD *EQ 'Y') *OR (&UPD *EQ 'y')) (CHGVAR &AUT '*CHANGE')
 +
 +
CHKOBJ  (&LIB/&FILE) OBJTYPE(*FILE) MBR(*NONE)  +
 +
  AUT( &AUT  )
 +
  MONMSG (CPF9899 CPF9801 CPF9802  CPF9820 CPF9830) EXEC(DO)
 +
/*  CHGVAR (&MSGDTA) VALUE('    '||&FILE||&LIB)                  */
 +
/*  SNDPGMMSG MSGID(USR0006) MSGF(*LIBL/QUSERMSG) MSGTYPE(*DIAG) +*/
 +
/*            MSGDTA(&MSGDTA)                                    */
 +
    SNDPGMMSG  MSG('Not authorised to the file.') +
 +
                          MSGTYPE(*DIAG)
 +
    CHGVAR (&ERROR) '1'
 +
  ENDDO
 +
  MONMSG (CPF9810) EXEC(DO)
 +
    CHGVAR (&MSGDTA) VALUE('    '||&LIB)
 +
/*  SNDPGMMSG MSGID(USR0008) MSGF(*LIBL/QUSERMSG) MSGTYPE(*DIAG)  +*/
 +
/*            MSGDTA(&MSGDTA)                                      */
 +
    SNDPGMMSG  MSG('Not authorised to the file.') +
 +
                          MSGTYPE(*DIAG)
 +
    CHGVAR (&ERROR) '1'
 +
  ENDDO
 +
 +
 +
IF (*NOT &ERROR) DO
 +
 +
RTVOBJD    OBJ(&LIB/&FILE) OBJTYPE(*FILE) OBJATR(&OBJATR)
 +
CHGVAR &AUT '*READ  '
 +
IF ((&UPD *EQ 'Y') *OR (&UPD *EQ 'y')) (CHGVAR &AUT '*CHANGE')
 +
 +
CHKOBJ    OBJ(&LIB/&FILE) OBJTYPE(*FILE) MBR(&MBR) +
 +
                          AUT(&AUT)
 +
 +
  MONMSG (CPF9815 )  EXEC(DO)
 +
/*  CHGVAR (&MSGDTA) VALUE('    '||&MBR||&FILE||&LIB)              */
 +
/*  SNDPGMMSG MSGID(USR0007) MSGF(*LIBL/QUSERMSG) MSGTYPE(*DIAG) + */
 +
/*            MSGDTA(&MSGDTA)                                      */
 +
            SNDPGMMSG  MSG('Not authorised to the file.') +
 +
                          MSGTYPE(*DIAG)
 +
    CHGVAR (&ERROR) '1'
 +
  ENDDO
 +
  MONMSG (CPF0000 )  EXEC(DO)
 +
/*  SNDPGMMSG MSGID(USR0022) MSGF(*LIBL/QUSERMSG) MSGTYPE(*DIAG) + */
 +
/*            MSGDTA(&MSGDTA)                                      */
 +
            SNDPGMMSG  MSG('Not authorised to the file.') +
 +
                          MSGTYPE(*DIAG)
 +
    CHGVAR (&ERROR) '1'
 +
  ENDDO
 +
ENDDO
 +
 +
IF (&ERROR)  (SNDPGMMSG MSGID(CPF0002) MSGF(QCPFMSG) MSGTYPE(*ESCAPE))
 +
 +
 +
 +
ENDPGM
 +
 +
</pre>
 +
 +
[[#top]]
 +
 +
 +
===DISPR  RPG ===
 +
 +
<pre>
 +
    H OPTIMIZE(*NONE) OPTION(*NODEBUGIO)
 +
    H DFTACTGRP(*NO) ACTGRP(*CALLER)
 +
 +
      *    FILE RELATIONS DISPLAYER
 +
      * REQUIRES FILES TO COMPILE
 +
      *
 +
 +
    FREL      IF  E            DISK
 +
    FSEL      IF  E            DISK
 +
    FDISPRF    CF  E            WORKSTN
 +
    F                                    SFILE(S01:RS01)
 +
    F                                    SFILE(S02:RS02)
 +
    F                                    INFDS(SFINF)
 +
      *
 +
 +
      *
 +
    DDISPR            PR
 +
    D                              10
 +
    D                              10
 +
    DDISPR            PI
 +
    D  SFILE                        10
 +
    D  SLIB                        10
 +
 +
      //  SCREEN LEVELS
 +
    D @SCN            S              6    DIM(50)
 +
    D @NSCN          S              6
 +
    D @LV            S              5  0
 +
    D @ERR            S                  LIKE(@TRUE)
 +
    D @FILE          S            10A  INZ('DISPY  ')
 +
    D WRKSWS          S              1
 +
    D I              S              4B 0
 +
 +
 +
    D @TRUE          S              1A  INZ('1')
 +
    D @FALSE          S              1A  INZ('0')
 +
    D @OK            S                  LIKE(@TRUE)
 +
    D @LOOP          S                  LIKE(@TRUE)
 +
 +
      //
 +
    D RS01            S              4S 0
 +
    D RS02            S              4S 0
 +
      //
 +
      // PARMS FOR SFL LOOPING
 +
    D SFC01          S                  LIKE(RS01)
 +
    D SFC02          S                  LIKE(RS01)
 +
 +
      // Program Status
 +
    D                SDS
 +
    D  PGM                    1    10
 +
    D  WSID                244    253
 +
    D  USER                254    263
 +
      //
 +
      //
 +
    D SFINF          DS
 +
    D  RRRN                376    377B 0
 +
    D  SRN                  378    379B 0
 +
 +
      //  MESSAGE DATA
 +
    D @DTA1          DS            80
 +
    D @DTA2          DS          500
 +
      //
 +
    D MAIN            PR
 +
 +
    D @S01BLD        PR
 +
    D @S01PRC        PR
 +
    D @S01PRS        PR
 +
    D @S02BLD        PR
 +
    D @S02PRC        PR
 +
    D
 +
    D @R9999          PR
 +
 +
    D @OPADJ          PR            2A
 +
    D  OPT                          2A
 +
 +
 +
      /FREE
 +
            *INLR = *ON;
 +
            MAIN();
 +
 +
 +
      //--------------*INZSR-------------------------------//
 +
          BEGSR  *INZSR;
 +
 +
        //  Set the TOP level (Exit if user backs up to here)
 +
              @LV = 1;
 +
              @SCN(@LV)  = '*END  ';
 +
        //  Set the Initial Screen to display
 +
              @LV = @LV + 1;
 +
              @SCN(@LV) = 'S01BLD ';
 +
 +
            ENDSR;
 +
      /END-FREE
 +
      //###################################################//
 +
 +
        //*************************************************************
 +
    P    MAIN        B
 +
 +
    D MAIN            PI
 +
 +
    D I              S              4B 0
 +
 +
      /FREE
 +
          EXSR      @INZSR;
 +
      //
 +
      // THIS IS THE CONTROLLING LOOP TO DRIVE THE NEXT PANEL TO DISPLAY
 +
          DOW      @LOOP = @LOOP;
 +
      // GET THE SCREEN NAME FROM THE SCREEN STACK ARRAY
 +
            @NSCN  = @SCN(@LV);
 +
          SELECT;
 +
        //  SELECT FIELDS FOR DISPLAY
 +
 +
        // SFL TO SELECT THE FILE FIELDS
 +
          WHEN      @NSCN = 'S01BLD';
 +
                            @S01BLD();
 +
          WHEN      @NSCN = 'S01PRC';
 +
                            @S01PRC();
 +
          WHEN      @NSCN = 'S01PRS';
 +
                            @S01PRS();
 +
          WHEN      @NSCN = 'S02BLD';
 +
                            @S02BLD();
 +
          WHEN      @NSCN = 'S02PRC';
 +
                            @S02PRC();
 +
          OTHER;
 +
            //  CATCH ALL (NEVER USED)
 +
              @R9999();
 +
              LEAVE;
 +
          ENDSL;
 +
 +
        //  CF3 EXIT
 +
          IF  *IN03 = *ON;
 +
            LEAVE;
 +
          ENDIF;
 +
 +
      //  CF12 PREVIOUS
 +
          IF  *IN12 = *ON;
 +
              *IN12 = *OFF;
 +
              @LV  = @LV -1;
 +
              @NSCN = @SCN(@LV);
 +
          ENDIF;
 +
 +
      //  Backed out to last level, Exit
 +
          IF    @NSCN = '*END';
 +
                  LEAVE;
 +
          ENDIF;
 +
 +
        ENDDO;
 +
 +
        RETURN;
 +
 +
      //--------------*INZSR-------------------------------//
 +
          BEGSR  @INZSR;
 +
              @NSCN = *BLANK;
 +
 +
          ENDSR;
 +
      //-ENDSR---*INZSR-------------------------------//
 +
      /END-FREE
 +
 +
    P    MAIN        E
 +
 +
 +
      //###################################################//
 +
      //###################################################//
 +
      //###################################################//
 +
      /space 3
 +
    P @S01BLD        B
 +
 +
    D @S01BLD        PI
 +
 +
    D WFILE          S                  LIKE(APFILE )
 +
    D WLIB            S                  LIKE(APLIB  )
 +
 +
          //  Build/Rebuild the subfile
 +
 +
      /FREE
 +
          EXSR      @INZSR;
 +
 +
          EXSR      BLD;
 +
 +
        //  SFL IS BUILT, PROCESS THE SFL CONTROL
 +
          @LV = @LV + 1;
 +
          @SCN(@LV) = 'S01PRC ' ;
 +
            RETURN ;
 +
 +
      //--------------  BLD -------------------------------//
 +
          BEGSR    BLD;
 +
 +
            EXSR      CLR;
 +
 +
 +
          SETLL 1    QWHFDACP;
 +
 +
          DOW @LOOP = @LOOP;
 +
          READ      QWHFDACP;
 +
          IF %EOF;
 +
          LEAVE;
 +
          ENDIF;
 +
 +
 +
          EXSR MOV;
 +
          //
 +
          RS01  = RS01 + 1;
 +
          WRITE S01;
 +
        ENDDO;
 +
 +
 +
        // Position to TOP of subfile
 +
            SRS01 = 1;
 +
            SFC01 = RS01;
 +
          ENDSR;
 +
 +
      //--------------  CLR -------------------------------//
 +
          BEGSR  CLR;
 +
 +
              *IN51 = *OFF;
 +
              *IN52 = *OFF;
 +
              *IN53 = *ON;
 +
              WRITE    C01;
 +
              *IN53 = *OFF;
 +
              RS01  = 0  ;
 +
              SFC01 = 0  ;
 +
              S01FUNC = *BLANK;
 +
              ENDSR;
 +
 +
      //--------------  MOV -------------------------------//
 +
          BEGSR  MOV;
 +
 +
            C01APBOF =  APBOF ;
 +
            C01APBOL =  APBOL ;
 +
 +
          IF APBOF = *BLANK AND APBOL =  *BLANK;
 +
          C01APBOF = APFILE;
 +
          C01APBOL = APLIB;
 +
          ENDIF;
 +
 +
        //  Load the subfile record
 +
 +
          IF APFILE = WFILE  AND
 +
            APLIB  = WLIB ;
 +
            *IN56 = *ON ;
 +
                  S01APFILE  =  *BLANK;
 +
                  S01APLIB  =  *BLANK;
 +
                  S01APACCP  =  *BLANK;
 +
                  S01APUNIQ  =  *BLANK;
 +
                  S01APSELO  =  *BLANK;
 +
                  S01APFTYP  =  *BLANK;
 +
                  S01APJOIN  =  *BLANK;
 +
                  S01APKEYO  =  *BLANK;
 +
                  S01APKSEQ  =  APKSEQ ;
 +
                  S01APKSIN  =  APKSIN ;
 +
                  S01APKEYF  =  APKEYF ;
 +
            ELSE      ;
 +
            WFILE = APFILE;
 +
            WLIB  = APLIB ;
 +
            *IN56 = *OFF;
 +
                  S01APFILE  =  APFILE ;
 +
                  S01APLIB  =  APLIB  ;
 +
                  S01APACCP  =  APACCP ;
 +
                  S01APUNIQ  =  APUNIQ ;
 +
                  S01APSELO  =  APSELO ;
 +
                  S01APFTYP  =  APFTYP ;
 +
                  S01APJOIN  =  APJOIN ;
 +
                  S01APKEYO  =  APKEYO ;
 +
                  S01APKSEQ  =  APKSEQ ;
 +
                  S01APKSIN  =  APKSIN ;
 +
                  S01APKEYF  =  APKEYF ;
 +
          ENDIF;
 +
 +
          ENDSR;
 +
 +
      //--------------*INZSR-------------------------------//
 +
          BEGSR    @INZSR;
 +
              @NSCN = *BLANK;
 +
          ENDSR;
 +
      /END-FREE
 +
 +
    P @S01BLD        E
 +
 +
      //###################################################//
 +
      //###################################################//
 +
 +
      /space 3
 +
    P @S01PRC        B
 +
 +
    D @S01PRC        PI
 +
 +
          //
 +
          //
 +
    D WRKRC          S              4S 0
 +
 +
      /FREE
 +
          EXSR      @INZSR;
 +
 +
            WRITE    R01;
 +
      //
 +
            DOW      @LOOP = @LOOP;
 +
 +
          //
 +
          // Write SFL Control
 +
            IF        SFC01 > 0;
 +
                *IN51 = *ON;
 +
            ENDIF;
 +
              *IN52 = *ON;
 +
 +
 +
              EXFMT    C01;
 +
          //  Setoff errors
 +
                *IN89 = *OFF;
 +
          //
 +
          //  Exit and Previous Screen
 +
            IF        *IN03 = *ON;
 +
                LEAVE;
 +
            ENDIF;
 +
            IF        *IN12 = *ON;
 +
                LEAVE;
 +
            ENDIF;
 +
 +
 +
        //  Process the subfile
 +
              @LV = @LV + 1;
 +
              @SCN(@LV) = 'S01PRS';
 +
              LEAVE;
 +
 +
            ENDDO;
 +
      //
 +
            RETURN;
 +
 +
      /space 3
 +
 +
 +
      //--------------*INZSR-------------------------------//
 +
          BEGSR    @INZSR;
 +
              @NSCN = *BLANK;
 +
          ENDSR;
 +
      /END-FREE
 +
    P @S01PRC        E
 +
 +
      //###################################################//
 +
      //###################################################//
 +
      //###################################################//
 +
      /space 3
 +
    P @S01PRS        B
 +
 +
    D @S01PRS        PI
 +
 +
          //
 +
          //
 +
    D WRKRC          S              4S 0
 +
 +
      /FREE
 +
 +
          EXSR      @INZSR;
 +
 +
        //  Process the subfile
 +
          EXSR      SFL;
 +
          RETURN;
 +
 +
      //--------------  SFL -------------------------------//
 +
          BEGSR      SFL;
 +
        //  Process the subfile
 +
 +
          FOR      WRKRC = 1 TO SFC01 + 1 ;
 +
              CHAIN  WRKRC  S01;
 +
                IF        NOT %FOUND;
 +
        //  Finished with the subfile
 +
                    @LV = @LV -1;
 +
                    LEAVE;
 +
                ENDIF;
 +
 +
        //  GET SELECTED FILE
 +
            IF  @OPADJ(S01FUNC) =  ' X';
 +
              SFILE  = S01APFILE;
 +
              SLIB  = S01APLIB ;
 +
              *IN03 = '1';
 +
                LEAVE;
 +
            ENDIF;
 +
 +
 +
        //  SHOW SELECT RULES
 +
            IF  @OPADJ(S01FUNC) =  ' R';
 +
              @LV = @LV + 1;
 +
              @SCN(@LV) = 'S02BLD ';
 +
                S01FUNC =  '  ';
 +
                UPDATE    S01;
 +
              LEAVE;
 +
            ENDIF;
 +
 +
          ENDFOR;
 +
 +
          ENDSR;
 +
      //---------------------------------------------------//
 +
 +
 +
 +
      //--------------*INZSR-------------------------------//
 +
          BEGSR    @INZSR;
 +
              @NSCN = *BLANK;
 +
          ENDSR;
 +
 +
 +
      /END-FREE
 +
    P @S01PRS        E
 +
 +
 +
      /space 3
 +
    P @S02BLD        B
 +
 +
    D @S02BLD        PI
 +
 +
          //  Build/Rebuild the subfile
 +
      /FREE
 +
 +
          EXSR @INZSR;
 +
 +
          C02APFILE  =  S01APFILE ;
 +
          C02APLIB  =  S01APLIB  ;
 +
 +
        EXSR BLD;
 +
 +
        //  SFL IS BUILT, PROCESS THE CONTROL
 +
          @LV = @LV + 1;
 +
          @SCN(@LV) = 'S02PRC ';
 +
      RETURN;
 +
      //--------------  BLD -------------------------------//
 +
      BEGSR  BLD;
 +
 +
        EXSR CLR;
 +
 +
 +
          SETLL 1    QWHFDSO ;
 +
 +
          DOW @LOOP = @LOOP;
 +
 +
          READ      QWHFDSO ;
 +
          IF %EOF;
 +
          LEAVE;
 +
          ENDIF;
 +
 +
          If SOFILE = S01APFILE  AND
 +
            SOLIB  = S01APLIB ;
 +
          EXSR MOV;
 +
 +
          //
 +
          RS02  = RS02 + 1;
 +
          WRITE S02;
 +
          ENDIF;
 +
        ENDDO;
 +
 +
        // Position to TOP of subfile
 +
        SRS02 = 1;
 +
        SFC02 = RS02;
 +
        ENDSR;
 +
 +
      //--------------  CLR -------------------------------//
 +
        BEGSR  CLR;
 +
          *IN51 = *OFF;
 +
          *IN52 = *OFF;
 +
          *IN53 = *ON;
 +
          WRITE C02;
 +
          *IN53 = *OFF;
 +
          RS02 =0;
 +
          SFC02=0;
 +
 +
        ENDSR;
 +
 +
      //--------------  MOV -------------------------------//
 +
        BEGSR  MOV;
 +
        //  Load the subfile record
 +
 +
          S02SOFLD  = SOFLD  ;
 +
          S02SORULE = SORULE ;
 +
          S02SOCOMP = SOCOMP ;
 +
          S02SOVALU = SOVALU ;
 +
 +
 +
 +
        ENDSR;
 +
 +
      //--------------*INZSR-------------------------------//
 +
        BEGSR  @INZSR;
 +
          @NSCN = *BLANK;
 +
        ENDSR;
 +
 +
      /END-FREE
 +
    P @S02BLD        E
 +
 +
      //###################################################//
 +
      //###################################################//
 +
      //###################################################//
 +
      /space 3
 +
    P @S02PRC        B
 +
 +
    D @S02PRC        PI
 +
 +
          //
 +
          //
 +
    D WRKRC          S              4S 0
 +
 +
      /FREE
 +
 +
          EXSR @INZSR;
 +
 +
        WRITE R02;
 +
 +
      //
 +
      DOW @LOOP = @LOOP;
 +
 +
          //
 +
          // Write SFL Control
 +
          IF SFC02 > 0;
 +
            *IN51 = *ON;
 +
          ENDIF;
 +
          *IN52 = *ON;
 +
          EXFMT C02;
 +
          //
 +
          //  Setoff errors
 +
          *IN89 = *OFF;
 +
          //
 +
          //  Exit and Previous Screen
 +
 +
          @LV = @LV -2;
 +
            LEAVE;
 +
 +
 +
        //  Process the subfile
 +
 +
      ENDDO;
 +
      //
 +
      RETURN;
 +
 +
      /space 3
 +
      //--------------*INZSR-------------------------------//
 +
        BEGSR  @INZSR;
 +
 +
          @NSCN = *BLANK;
 +
        ENDSR;
 +
      /END-FREE
 +
    P @S02PRC        E
 +
 +
 +
      //###################################################//
 +
      //###################################################//
 +
      //###################################################//
 +
 +
    P @R9999          B
 +
        //  Invalid Panel
 +
    D @R9999          PI
 +
 +
    P @R9999          E
 +
 +
 +
      /space 3
 +
      //###################################################//
 +
      //###################################################//
 +
      //###################################################//
 +
    P @OPADJ          B
 +
        //  RIGHT ADJ OPTION , zero suppress
 +
 +
    D @OPADJ          PI            2A
 +
    D  OPT                          2A
 +
 +
      /FREE
 +
        EVALR  OPT  = %trimr(OPT);
 +
        If %SubSt(OPT:1:1) =  '0';
 +
        OPT  = ' ' +  %SubSt(OPT:2:1);
 +
        EndIf;
 +
        RETURN OPT;
 +
      /END-FREE
 +
    P @OPADJ          E
 +
 +
      //###################################################//
 +
      //###################################################//
 +
 +
</pre>
 +
 +
[[#top]]
 +
 +
===DISPRF  DSPF  ===
 +
 +
<pre>
 +
 +
    A*%%TS  SD  20101208  163705  KOLMANNF    REL-V5R4M0  5722-WDS
 +
    A*
 +
      * REQUIRES FILES TO COMPILE
 +
      *  CRTDUPOBJ  OBJ(QAFDSELO) FROMLIB(QSYS)
 +
      *              OBJTYPE(*FILE) TOLIB(QTEMP) NEWOBJ(SEL)
 +
      *  CRTDUPOBJ  OBJ(QAFDACCP) FROMLIB(QSYS)
 +
      *        OBJTYPE(*FILE) TOLIB(QTEMP) NEWOBJ(ACC)
 +
 +
 +
    A*%%EC
 +
    A                                      DSPSIZ(24 80 *DS3)
 +
    A                                      PRINT
 +
    A                                      CF03(03)
 +
    A                                      CF12(12)
 +
    A          R S01                      SFL
 +
    A*%%TS  SD  20101208  163705  KOLMANNF    REL-V5R4M0  5722-WDS
 +
    A            S01FUNC        2A  I  4  3
 +
    A  55
 +
    AO 56                                  DSPATR(PR)
 +
    A            S01APFILE R        O  4  6REFFLD(QWHFDACP/APFILE QTEMP/REL)
 +
    A            S01APLIB  R        O  4 17REFFLD(QWHFDACP/APLIB QTEMP/REL)
 +
    A            S01APACCP R        O  4 29REFFLD(QWHFDACP/APACCP QTEMP/REL)
 +
    A            S01APUNIQ R        O  4 33REFFLD(QWHFDACP/APUNIQ QTEMP/REL)
 +
    A            S01APSELO R        O  4 37REFFLD(QWHFDACP/APSELO QTEMP/REL)
 +
    A            S01APFTYP R        O  4 41REFFLD(QWHFDACP/APFTYP QTEMP/REL)
 +
    A            S01APJOIN R        O  4 45REFFLD(QWHFDACP/APJOIN QTEMP/REL)
 +
    A            S01APKEYO R        O  4 48REFFLD(QWHFDACP/APKEYO QTEMP/REL)
 +
    A            S01APKSEQ R        O  4 53REFFLD(QWHFDACP/APKSEQ QTEMP/REL)
 +
    A            S01APKSIN R        O  4 57REFFLD(QWHFDACP/APKSIN QTEMP/REL)
 +
    A            S01APKEYF R        O  4 61REFFLD(QWHFDACP/APKEYF QTEMP/REL)
 +
    A          R C01                      SFLCTL(S01)
 +
    A*%%TS  SD  20101208  163705  KOLMANNF    REL-V5R4M0  5722-WDS
 +
    A                                      SFLSIZ(0019)
 +
    A                                      SFLPAG(0018)
 +
    A                                      OVERLAY
 +
    A  50                                  SFLEND
 +
    A  51                                  SFLDSP
 +
    A  52                                  SFLDSPCTL
 +
    A  53                                  SFLCLR
 +
    A            SRS01          4S 0H      SFLRCDNBR(CURSOR)
 +
    A*
 +
    A                                  1 18'FILE RELATIONS for '
 +
    A            C01APBOF  R        O  1 39REFFLD(QWHFDACP/APBOF QTEMP/REL)
 +
    A                                  1 51'Lib.'
 +
    A            C01APBOL  R        O  1 56REFFLD(QWHFDACP/APBOL QTEMP/REL)
 +
    A                                  2 32'Uni SEL        LIFO ASC Key'
 +
    A                                  3  6'File      Library    Acc Key OMT -
 +
    A                                      TYP  J  FIFO DSC Sgn Key'
 +
    A          R R01
 +
    A                                24  3'F3-Exit'
 +
    A                                22  3'R - Display Select/Omit rules'
 +
    A                                23  3'X - Select for display'
 +
      *
 +
    A          R R02
 +
    A                                24  3'F3-Exit'
 +
    A          R S02                      SFL
 +
    A                                      SFLNXTCHG
 +
    A            S02SOFLD  R        O  4  4REFFLD(QWHFDSO/SOFLD QTEMP/SEL)
 +
    A            S02SORULE R        O  4 17REFFLD(QWHFDSO/SORULE QTEMP/SEL)
 +
    A            S02SOCOMP R        O  4 22REFFLD(QWHFDSO/SOCOMP QTEMP/SEL)
 +
    A            S02SOVALU R        O  4 28REFFLD(QWHFDSO/SOVALU QTEMP/SEL)
 +
 +
    A          R C02                      SFLCTL(S02 )
 +
    A                                      OVERLAY
 +
    A  50                                  SFLEND
 +
    A  51                                  SFLDSP
 +
    A  52                                  SFLDSPCTL
 +
    A  53                                  SFLCLR
 +
    A                                      SFLSIZ(0019)
 +
    A                                      SFLPAG(0018)
 +
    A            SRS02          4S 0H      SFLRCDNBR(CURSOR)
 +
    A*
 +
    A                                  1  6'FILE SELECTS  for '
 +
    A            C02APFILE R        O  2  7REFFLD(QWHFDSO/SOFILE QTEMP/SEL)
 +
    A                                  2 20'Lib.'
 +
    A            C02APLIB  R        O  2 25REFFLD(QWHFDSO/SOLIB QTEMP/SEL)
 +
    A                                  3  4'Field'
 +
    A                                  3 28'Select/Omit Value'
 +
    A                                  3 16'S/O'
 +
    A                                  3 21'COMP'
 +
 +
</pre>
 +
 +
[[#top]]
 +
 +
 +
===DISPY  RPG ===
 +
 +
<pre>
 +
    H OPTIMIZE(*NONE) OPTION(*NODEBUGIO)
 +
    H DFTACTGRP(*NO) ACTGRP(*CALLER)
 +
 +
      //***************************************************************
 +
      //
 +
      //  PROGRAM ID : DISPY
 +
      //  Description: DISPLAY A FILES FIELDS FOR SELECTION
 +
 +
      //    needs files KF  FFD to compile use following commands
 +
      // DSPFD (&LIB/&FILE) TYPE(*ACCPTH) OUTPUT(*OUTFILE) OUTFILE(QTEMP/KF)
 +
      // DSPFFD  FILE(&LIB/&FILE) OUTPUT(*OUTFILE) OUTFILE(QTEMP/FFD)
 +
      //***************************************************************
 +
      // MODIFICATIONS:
 +
      // MOD  SR  DATE    MODIFICATION SUMMARY
 +
      //
 +
      //***************************************************************
 +
      //
 +
    FKF        IF  E            DISK
 +
    FFFD      UF  E            DISK
 +
    FINPUT    IF  F32766  2000AIDISK    KEYLOC(1)
 +
    F                                    INFDS(INFDS)
 +
    FDISPYF    CF  E            WORKSTN
 +
    F                                    SFILE(S01:RS01)
 +
    F                                    INFDS(SFINF)
 +
      //
 +
      //
 +
 +
      //  SCREEN LEVELS
 +
    D @SCN            S              6    DIM(50)
 +
    D @NSCN          S              6
 +
    D @LV            S              5  0
 +
    D @ERR            S                  LIKE(@TRUE)
 +
    D @FILE          S            10A  INZ('DISPY  ')
 +
    D WRKSWS          S              1
 +
    D I              S              4B 0
 +
 +
 +
    D @TRUE          S              1A  INZ('1')
 +
    D @FALSE          S              1A  INZ('0')
 +
    D @OK            S                  LIKE(@TRUE)
 +
    D @LOOP          S                  LIKE(@TRUE)
 +
 +
      //
 +
    D RS01            S              4S 0
 +
      //
 +
      // PARMS FOR SFL LOOPING
 +
    D SFC01          S                  LIKE(RS01)
 +
 +
      // Program Status
 +
    D                SDS
 +
    D  PGM                    1    10
 +
    D  WSID                244    253
 +
    D  USER                254    263
 +
      //
 +
      //
 +
    D SFINF          DS
 +
    D  RRRN                376    377B 0
 +
    D  SRN                  378    379B 0
 +
 +
      //
 +
    D FLD            S            10    DIM(9000)
 +
    D KEY            S            10    DIM(99)
 +
 +
    D INFDS          DS
 +
    D  FILE                  83    92
 +
    D  LIB                  93    102
 +
    D  MBR                  129    138
 +
    D  RCDL                125    126B 0
 +
    D  RCDS                156    159B 0
 +
    D  ACCTP                160    160
 +
 +
    D                DS
 +
    D  WHCOLD                1    60
 +
    D  WHCHD1                1    20
 +
    D  WHCHD2                21    40
 +
    D  WHCHD3                41    60
 +
 +
    D                DS
 +
    D  POSN                  1    10
 +
    D  P1                    1    10    DIM(10)
 +
 +
    D  POSNN                11    20
 +
    D  P2                    11    20    DIM(10)
 +
 +
 +
      *
 +
      //  MESSAGE DATA
 +
    D @DTA1          DS            80
 +
    D @DTA2          DS          500
 +
      //
 +
    D MAIN            PR
 +
 +
    D @S01BLD        PR
 +
    D @S01PRC        PR
 +
    D @S01PRS        PR
 +
    D
 +
    D @R9999          PR
 +
 +
    D @OPADJ          PR            2A
 +
    D  OPT                          2A
 +
 +
      *
 +
    DDISPY            PR
 +
    D                                1
 +
    D                                1
 +
    D                                4
 +
    D                                1
 +
    D                                1
 +
    D                                5
 +
    DDISPY            PI
 +
    D  ALL                          1
 +
    D  RTN                          1
 +
    D  KEYLNG                        4
 +
    D  ACCP                          1
 +
    D  QRY                          1
 +
    D  RCDLN                        5
 +
      *
 +
    D KEYLN          S              4S 0
 +
    D RCDLEN          S              5S 0
 +
      *-------------------------------------------------------------------
 +
      * QMHRTVM API (Retrieve Message text)
 +
      *-------------------------------------------------------------------
 +
    D  RtvMsgTxt      PR          1024
 +
    D  RMsgId                      7    Const
 +
    D  RMsgFle                    10    Const
 +
    D  RMsgLib                    10    Const
 +
    D  RMsgLvl                      1    Const
 +
 +
    D GETROWCOL      PR
 +
    D                              10A  const
 +
    D                              10A  const
 +
    D                              10A  const
 +
    D                              32A  const
 +
    D                                3P 0
 +
    D                                3P 0
 +
 +
    D SysDate        PR            8S 0
 +
    D SysTime        PR            6S 0
 +
    D DayOfWeek      PR            10I 0
 +
    D                                D  value datfmt(*iso)
 +
      // Message file names
 +
    D  cMsgLib        C                  Const('*LIBL    ')
 +
    D  cMsgF1        C                  Const('MSGF1    ')
 +
    D  cMsgF2        C                  Const('MSGF2    ')
 +
    D  cMsgLvl1      C                  Const('1')
 +
    D  cMsgLvl2      C                  Const('2')
 +
 +
      *
 +
    IINPUT    NS  01
 +
    I                                  1  256  D
 +
 +
      /FREE
 +
            *INLR = *ON;
 +
            MAIN();
 +
 +
 +
      //--------------*INZSR-------------------------------//
 +
          BEGSR  *INZSR;
 +
 +
        //  Set the TOP level (Exit if user backs up to here)
 +
              @LV = 1;
 +
              @SCN(@LV)  = '*END  ';
 +
        //  Set the Initial Screen to display
 +
              @LV = @LV + 1;
 +
              @SCN(@LV) = 'S01BLD ';
 +
 +
      //    DUMMY I/O TO GET NUMBER OF RECORDS IN FILE
 +
            READ      INPUT;
 +
      //  SFL IS NOT LOADED
 +
      //  READ THE LIST OF KEY FIELDS IN THE FILE SO THAT WE CAN LATER MARK THEM
 +
                  ACCP    = ACCTP;
 +
 +
              I    =  0;
 +
 +
              DOW  @LOOP = @LOOP;
 +
                READ      QWHFDACP;
 +
                IF  %EOF;
 +
                LEAVE;
 +
                ENDIF;
 +
                I = I + 1;
 +
                KEY(I) = APKEYF;
 +
              ENDDO;
 +
            ENDSR;
 +
      /END-FREE
 +
      //###################################################//
 +
 +
        //*************************************************************
 +
    P    MAIN        B
 +
 +
    D MAIN            PI
 +
 +
    D I              S              4B 0
 +
 +
      /FREE
 +
          EXSR      @INZSR;
 +
      //
 +
      // THIS IS THE CONTROLLING LOOP TO DRIVE THE NEXT PANEL TO DISPLAY
 +
          DOW      @LOOP = @LOOP;
 +
      // GET THE SCREEN NAME FROM THE SCREEN STACK ARRAY
 +
            @NSCN  = @SCN(@LV);
 +
          SELECT;
 +
        //  SELECT FIELDS FOR DISPLAY
 +
 +
        // SFL TO SELECT THE FILE FIELDS
 +
          WHEN      @NSCN = 'S01BLD';
 +
              @S01BLD();
 +
          WHEN      @NSCN = 'S01PRC';
 +
              @S01PRC();
 +
          WHEN      @NSCN = 'S01PRS';
 +
              @S01PRS();
 +
          OTHER;
 +
            //  CATCH ALL (NEVER USED)
 +
              @R9999();
 +
              LEAVE;
 +
          ENDSL;
 +
 +
        //  CF3 EXIT
 +
          IF  *IN03 = *ON;
 +
            LEAVE;
 +
          ENDIF;
 +
 +
      //  CF12 PREVIOUS
 +
          IF  *IN12 = *ON;
 +
              *IN12 = *OFF;
 +
              @LV  = @LV -1;
 +
              @NSCN    = @SCN(@LV);
 +
          ENDIF;
 +
 +
      //  Backed out to last level, Exit
 +
          IF    @NSCN = '*END';
 +
                  LEAVE;
 +
          ENDIF;
 +
 +
        ENDDO;
 +
 +
        KEYLNG  = %EDITC(KEYLN:'X');
 +
        RETURN;
 +
 +
      //--------------*INZSR-------------------------------//
 +
          BEGSR  @INZSR;
 +
              @NSCN = *BLANK;
 +
              RCDLEN = RCDL;
 +
              RCDLN = %CHAR(RCDLEN);
 +
 +
      // CLEAR FIELD SELECTIONS
 +
              IF  RTN  =  '2';
 +
                SETLL 1    QWHDRFFD;
 +
              DOW  @LOOP = @LOOP;
 +
                READ      QWHDRFFD ;
 +
                IF  %EOF;
 +
                LEAVE;
 +
                ENDIF;
 +
                  WHFIOB = ' ';
 +
                  UPDATE    QWHDRFFD;
 +
              ENDDO;
 +
 +
      // SET FILE I/O TO FIRST RCD IN FILE
 +
                SETLL 1    QWHDRFFD;
 +
                  RTN = '0';
 +
              ELSE;
 +
                CHAIN  1  QWHDRFFD;
 +
                SETLL  1  QWHDRFFD;
 +
              ENDIF;
 +
          ENDSR;
 +
      //-ENDSR---*INZSR-------------------------------//
 +
      /END-FREE
 +
 +
    P    MAIN        E
 +
 +
 +
      //###################################################//
 +
      //###################################################//
 +
      //###################################################//
 +
      /space 3
 +
    P @S01BLD        B
 +
 +
    D @S01BLD        PI
 +
 +
    D  SZ            DS            6
 +
    D  LEN1                  1      1
 +
    D  LEN2                  2      3
 +
    D  LEN3                  1      3
 +
    D  COMA                  4      4
 +
    D  DEC1                  5      5
 +
    D  DEC2                  5      6
 +
 +
    D                DS
 +
    D K                      1      3  0
 +
    D KA                      2      3
 +
 +
          //  Build/Rebuild the subfile
 +
 +
      /FREE
 +
          EXSR      @INZSR;
 +
 +
          EXSR      BLD;
 +
 +
        //  SFL IS BUILT, PROCESS THE SFL CONTROL
 +
          @LV = @LV + 1;
 +
          @SCN(@LV) = 'S01PRC ' ;
 +
            RETURN ;
 +
      //--------------  BLD -------------------------------//
 +
          BEGSR    BLD;
 +
 +
            EXSR      CLR;
 +
 +
          DOW      @LOOP = @LOOP;
 +
 +
            READ      QWHDRFFD;
 +
                IF  %EOF;
 +
                LEAVE;
 +
                ENDIF;
 +
            EXSR      MOV;
 +
 +
      // FLAG THE KEY FIELDS
 +
                  K = %LOOKUP(WHFLDE :KEY);
 +
                    WHDFTL  = K ;
 +
                    UPDATE    QWHDRFFD;
 +
 +
            RS01  = RS01 + 1;
 +
            WRITE    S01;
 +
          ENDDO;
 +
 +
        // Position to TOP of subfile
 +
            SRS01 = 1;
 +
            SFC01 = RS01;
 +
          ENDSR;
 +
 +
      //--------------  CLR -------------------------------//
 +
          BEGSR  CLR;
 +
              I    =  0;
 +
              CLEAR FLD;
 +
              KEYLN = 0;
 +
 +
              *IN51 = *OFF;
 +
              *IN52 = *OFF;
 +
              *IN53 = *ON;
 +
              WRITE    C01;
 +
              *IN53 = *OFF;
 +
              RS01  = 0  ;
 +
              SFC01 = 0  ;
 +
              S01OPT= *BLANK;
 +
              ENDSR;
 +
 +
      //--------------  MOV -------------------------------//
 +
          BEGSR  MOV;
 +
        //  Load the subfile record
 +
 +
 +
            S01OPT  =  WHFIOB ;
 +
            S01WHFLDB  = WHFLDB;
 +
            S01WHFLDT  = WHFLDT;
 +
            S01WHFLD =  WHFLDE ;
 +
            S01SFLD  =  WHFLDE ;
 +
            S01FROM = WHFOBO;
 +
            S01TO  = WHFLDB + WHFOBO -1 ;
 +
 +
      //  KEY FIELDS
 +
            S01KEYFLD  = '  ';
 +
              K = %LOOKUP(WHFLDE :KEY);
 +
                  IF K <> 0;
 +
                    S01KEYFLD = KA;
 +
                  IF  K <  10;
 +
                    %SUBST(S01KEYFLD:1:1) = 'K';
 +
                  ENDIF;
 +
                    KEYLN = KEYLN +  WHFLDB;
 +
                  ENDIF;
 +
        //  FORMAT THE FIELD LENGTH
 +
                  S01SIZE  =  '      ';
 +
                  SZ      =  '      ';
 +
                  IF WHFLDD =      0;
 +
                      LEN3  = %SUBST(%EDITC(WHFLDB:'Z'):3:3);
 +
                  ELSE;
 +
                      LEN2  = %EDITC(WHFLDD:'Z') ;
 +
                      COMA = ',';
 +
 +
                      IF    WHFLDP >  9;
 +
                        DEC2 = %CHAR(WHFLDP);
 +
                      ELSE;
 +
                        DEC1 = %CHAR(WHFLDP);
 +
                      ENDIF;
 +
                  ENDIF;
 +
                  IF  LEN1 =  '0';
 +
                      LEN1 = ' ';
 +
                  ENDIF;
 +
                  S01SIZE = SZ;
 +
 +
                  S01DESC = WHFTXT;
 +
                  IF    S01DESC=  ' ';
 +
                      S01DESC  =  WHCOLD ;
 +
                  ENDIF;
 +
 +
                  I = I + 1;
 +
                  FLD(I) =  S01WHFLD;
 +
 +
          ENDSR;
 +
 +
      //--------------*INZSR-------------------------------//
 +
          BEGSR    @INZSR;
 +
              @NSCN = *BLANK;
 +
          ENDSR;
 +
      /END-FREE
 +
 +
    P @S01BLD        E
 +
 +
      //###################################################//
 +
      //###################################################//
 +
 +
      /space 3
 +
    P @S01PRC        B
 +
 +
    D @S01PRC        PI
 +
 +
          //
 +
          //
 +
    D WRKRC          S              4S 0
 +
    D C01CHK          S                  LIKE(C01POSN)
 +
 +
      /FREE
 +
          EXSR      @INZSR;
 +
 +
            WRITE    R01;
 +
 +
      //
 +
            DOW      @LOOP = @LOOP;
 +
 +
          //
 +
          // Write SFL Control
 +
            IF        SFC01 > 0;
 +
                *IN51 = *ON;
 +
            ENDIF;
 +
              *IN52 = *ON;
 +
              EXFMT    C01;
 +
          //  Setoff errors
 +
                *IN89 = *OFF;
 +
          //
 +
          //  Exit and Previous Screen
 +
            IF        *IN03 = *ON;
 +
              RTN = '1';
 +
                LEAVE;
 +
            ENDIF;
 +
 +
            IF        *IN12 = *ON;
 +
                @LV = @LV -1;
 +
                LEAVE;
 +
            ENDIF;
 +
 +
          //  Set up for qry selection and exit
 +
            IF        *IN06 = *ON;
 +
              *IN03 = *ON;
 +
              QRY = '1';
 +
              LEAVE;
 +
            ENDIF;
 +
 +
        //  POSITION
 +
            IF  C01POSN <> ' ';
 +
              EXSR POS;
 +
              ITER;
 +
            ENDIF;
 +
 +
        //  Process the subfile
 +
              @LV = @LV + 1;
 +
              @SCN(@LV) = 'S01PRS';
 +
              LEAVE;
 +
 +
            ENDDO;
 +
      //
 +
            RETURN;
 +
 +
      /space 3
 +
 +
      //--------------POS  -------------------------------//
 +
          BEGSR    POS;
 +
 +
 +
          FOR      WRKRC = 1 TO SFC01;
 +
              CHAIN  WRKRC  S01;
 +
                IF        NOT %FOUND;
 +
                    LEAVE;
 +
                ENDIF;
 +
 +
                C01CHK  = %SUBST(S01WHFLD :1 : %LEN(%TRIM(C01POSN)));
 +
                IF  (C01POSN  = C01CHK  );
 +
                    SRS01  = WRKRC;
 +
                    LEAVE;
 +
                ENDIF;
 +
 +
          ENDFOR;
 +
 +
 +
          ENDSR;
 +
 +
 +
      //--------------*INZSR-------------------------------//
 +
          BEGSR    @INZSR;
 +
              @NSCN = *BLANK;
 +
 +
            C01FILE    =  FILE;
 +
            C01LIB    =  LIB;
 +
            C01MBR    =  MBR;
 +
            C01RCDL    =  RCDL;
 +
            C01ACCTP  =  ACCTP;
 +
            C01WHTEXT  =  WHTEXT;
 +
            C01RCORDS  =  RCDS;
 +
            C01POSN    =  '  ' ;
 +
            C01WHNAME  =  WHNAME;
 +
 +
          ENDSR;
 +
      /END-FREE
 +
 +
    P @S01PRC        E
 +
 +
      //###################################################//
 +
      //###################################################//
 +
      //###################################################//
 +
      /space 3
 +
    P @S01PRS        B
 +
 +
    D @S01PRS        PI
 +
 +
          //
 +
          //
 +
    D WRKRC          S              4S 0
 +
    D FX              S              5S 0
 +
 +
      /FREE
 +
 +
          EXSR      @INZSR;
 +
 +
        //  Process the subfile
 +
          EXSR      SFL;
 +
          *IN03 = '1';
 +
          RETURN;
 +
 +
      //--------------  SFL -------------------------------//
 +
          BEGSR      SFL;
 +
        //  Process the subfile
 +
 +
          FOR      WRKRC = 1 TO SFC01+1;
 +
              CHAIN  WRKRC  S01;
 +
                IF        NOT %FOUND;
 +
        //  Finished with the subfile
 +
        //  RETURN TO REBUILD LEVEL
 +
                    @LV = @LV -2;
 +
                    LEAVE;
 +
                ENDIF;
 +
 +
        //    RIGHT ADJUST OPTION
 +
              S01OPT  = @OPADJ(S01OPT);
 +
 +
        //    UPDATE SELECTIONS
 +
              EXSR UPD;
 +
 +
          ENDFOR;
 +
 +
          ENDSR;
 +
      //---------------------------------------------------//
 +
 +
      //--------------UPD ---------------------------------//
 +
          BEGSR      UPD;
 +
 +
      // UPDATE FIELD NAMES AND SELECT FLAG
 +
                FX = %LOOKUP(S01SFLD :FLD);
 +
                CHAIN  FX  QWHDRFFD;
 +
                WHFLDE  =  S01WHFLD;
 +
 +
                IF @OPADJ(S01OPT) = ' S' OR
 +
                    @OPADJ(S01OPT) = ' O';
 +
                    ALL    = %TRIM(S01OPT);
 +
                    WHFIOB = %TRIM(S01OPT);
 +
                ENDIF;
 +
 +
                IF @OPADJ(S01OPT) = ' ';
 +
                    WHFIOB = ' ';
 +
                ENDIF;
 +
                  UPDATE  QWHDRFFD;
 +
 +
          ENDSR;
 +
 +
 +
      //--------------*INZSR-------------------------------//
 +
          BEGSR    @INZSR;
 +
              ALL  = '1';
 +
              @NSCN = *BLANK;
 +
          ENDSR;
 +
 +
 +
      /END-FREE
 +
    P @S01PRS        E
 +
 +
      //###################################################//
 +
      //###################################################//
 +
      //###################################################//
 +
 +
    P @R9999          B
 +
        //  Invalid Panel
 +
    D @R9999          PI
 +
 +
    P @R9999          E
 +
 +
 +
      /space 3
 +
      //###################################################//
 +
      //###################################################//
 +
      //###################################################//
 +
    P @OPADJ          B
 +
        //  RIGHT ADJ OPTION , zero suppress
 +
 +
    D @OPADJ          PI            2A
 +
    D  OPT                          2A
 +
 +
      /FREE
 +
        EVALR  OPT  = %trimr(OPT);
 +
        If %SubSt(OPT:1:1) =  '0';
 +
        OPT  = ' ' +  %SubSt(OPT:2:1);
 +
        EndIf;
 +
        RETURN OPT;
 +
      /END-FREE
 +
    P @OPADJ          E
 +
 +
      //###################################################//
 +
      //###################################################//
 +
      //###################################################//
 +
    P  RtvMsgTxt      B
 +
      //************************************************************************
 +
      // API Call: QMHRTVM Retrieve Message text
 +
      //************************************************************************
 +
 +
 +
      // USAGE
 +
      // MsgTxt = RtvMsgTxt('MSG0001':cMsgF3:cMsgLib:cMsgLvl1);
 +
 +
    D  RtvMsgTxt      PI          1024
 +
    D  RMsgId                      7    Const
 +
    D  RMsgFle                    10    Const
 +
    D  RMsgLib                    10    Const
 +
    D  RMsgLvl                      1    Const
 +
 +
      // Retrieve Message Description API Prototype
 +
    D  Get_Message    PR                  ExtPgm('QMHRTVM')
 +
    D                            4000    Options(*VarSize)
 +
    D                              10I 0 Const
 +
    D                                8    Const
 +
    D                                7
 +
    D                              20    Const
 +
    D                            32765    Options(*VarSize)
 +
    D                              10I 0 Const
 +
    D                              10    Const
 +
    D                              10    Const
 +
    D                            8192    Options(*VarSize)
 +
    D                              10
 +
    D                                9B 0
 +
    D                                9B 0
 +
 +
      // Define Variables for QMHRTVM API call:
 +
      // --------------------------------------
 +
      // Return variables
 +
    D  MessageInfo    DS          4000
 +
    D  Data                  1  4000
 +
    D  OSMSG                65    68B 0
 +
    D  LMsgR                69    72B 0
 +
    D  LMsgA                73    76B 0
 +
    D  OSMSGH              77    80B 0
 +
    D  LMsgHR              81    84B 0
 +
    D  LMsgHA              85    88B 0
 +
 +
      // Required input variables
 +
    D  MessageLen    S            10I 0
 +
    D  MessageForm  S              8
 +
    D  MessageIden  S              7
 +
    D  MessageFile  S            20
 +
    D  Replacement  S          32765
 +
    D  ReplaceLen    S            10I 0
 +
    D  ReplaceSub    S            10
 +
    D  ReturnCtl    S            10
 +
 +
    D  RetrieveOpt  S            10
 +
    D  ConvToCCSID  S              9B 0
 +
    D  ReplDtaCCSID  S              9B 0
 +
 +
    D  Return_Text  S          1024
 +
 +
    D  ErrorCode      DS                  Qualified
 +
    D  BytesProv                    4B 0 Inz(0)
 +
    D  BytesAvail                  8B 0 Inz(0)
 +
    D  ExceptionId                  7
 +
    D  Reserved                    1
 +
    D  ExceptionDta