Snippets/Templates

From MidrangeWiki
< Snippets
Revision as of 11:14, 7 January 2011 by FKOL (talk | contribs) (reorg)
Jump to: navigation, search

Templates

RPG FTP TEMPLATE

     H OPTIMIZE(*NONE) OPTION(*NODEBUGIO)
     H DFTACTGRP(*NO) ACTGRP(*CALLER)
     H Bnddir('QC2LE')
       // 
      //***************************************************************
      //  USE  FTP TO GET OR PUT FILES TO THE IFS
      //  BIN(ARY) TRANSFERS ARE USED,DATA IS ASSUMED TO BE ASCII
      //  IT IS ASSUMED OTHER FUNCTIONS PUT OR GET FROM IFS TO DB FILES
      //  SENT FILES (PUT) ARE ARCHIVED TO ARCH SUBDIRECTORY IF IT EXISTS
        // 
        //  REQUIRES FILES FTPADDR AND FTPMSGLOG 
        //   (LAYOUT CAN BE INFERRED FROM THIS PGM LOGIC)	  	
       // 
       //  PARMS  IN	
       // D  ADDR  10A		KEY TO FILE FOR USER PWORD AND FTP_ADDR 
       // D  FDIR  40A        LCD IFS DIRECTORY OF FILE TO PUT/GET
       // D  TDIR  40A		CD IFS DIRECTORY OF FILE TO PUT/GET
       // D  FN     3A		PUT  OR GET
       // D  FFIL  40A		NAME OF FILE
       // 
       //   PARMS OUT		
       // D  FERR   1A		FTP FAIL IF NOT ZERO
      //***************************************************************
      //
      //
     FFTPADDR   IF   E           K DISK

     D PROFILE         S             25
     D FROMDIR         S             40
     D TODIR           S             40
     D FNC             S              3
     D FNCFILE         S             40
       // 
     D RT              S             10I 0
     D SRCDTA          S            100
     D NOK             C                   -1
     D OK              C                   0
     D TCK1            C                   'TRANSFER COMPLETE'
      // Program Status
     D                SDS
     D  PGM                    1     10
     D  WSID                 244    253A
     D  USER                 254    263A
     D  NBR                  264    269A
     D  DAT                  276    281A
      //
      //
      //-------------------- Prototypes
     D FTPPGM         PR
     D                               10A
     D                               40A
     D                               40A
     D                                3A
     D                               40A
     D                                1A
     D FTPPGM         PI
     D  ADDR                         10A
     D  FDIR                         40A
     D  TDIR                         40A
     D  FN                            3A
     D  FFIL                         40A
     D  FERR                          1A
       //  FOR RUNNING AS400 COMMANDS
     D SYS             PR            10I 0 Extproc('system')
     D   CmdString                     *   Value
     D                                     Options(*String)
       // 
     D MAIN            PR
     D WRKFILES        PR
     D LOADFTPS        PR
     D DOTHEFTP        PR
     D RMVWRKF         PR
     D CKTHEFTP        PR
     D MOVTOARCH       PR
     D LOGTHEFTP       PR

      /FREE
                MAIN();
      /END-FREE
       //
       //###################################################//
     P    MAIN         B
       //
      //***************************************************************
     D MAIN            PI
      /FREE
              *INLR = *ON;
       //
         WRKFILES();  // SETUP FTP WORK FILES
       //
         LOADFTPS();  // SETUP FTP COMMANDS
       //
         DOTHEFTP();  // EXECUTE THE FTP
       //
         CKTHEFTP();  // CHECK THE TRANSFER
       //
         MOVTOARCH(); // MOVE TO ARCHIVE
       //
         LOGTHEFTP(); // LOG THE FTP OUTPUT 
       //
         RMVWRKF ();  // CLEANUP THE WORK FILES
       RETURN;
       //###################################################//
      /END-FREE
     P    MAIN         E
       //
       //###################################################//
     P  WRKFILES       B
      /FREE
       RT  = SYS('DLTF  QTEMP/INPUT');
       RT  = SYS('DLTF  QTEMP/OUTPUT');
       RT  = SYS('CRTSRCPF  QTEMP/INPUT MBR(*FILE)');
       RT  = SYS('CRTSRCPF  QTEMP/OUTPUT MBR(*FILE)');
       RT  = SYS('OVRDBF INPUT  QTEMP/INPUT OVRSCOPE(*JOB)');
       RT  = SYS('OVRDBF OUTPUT  QTEMP/OUTPUT OVRSCOPE(*JOB)');
      /END-FREE
     P  WRKFILES       E
       //
       //###################################################//
     P  LOADFTPS       B
      /FREE
          FERR = '0';
          CHAIN ADDR  FTPADDR;
             IF NOT %FOUND;
                FERR = '1';
                RETURN;
              ENDIF;
         //
          PROFILE = FTUSER + ' ' + FTPASS;
          FROMDIR = FDIR;
          TODIR   = TDIR;
          FNCFILE = FFIL;
          FNC     = FN;
         //
         EXEC SQL SET OPTION COMMIT =*NONE;
         //
         EXEC SQL
         INSERT INTO  INPUT  VALUES
         (0,0 , :PROFILE                             ) ,
         (0,0 , 'NAMEFMT 1          '                ) ,
         (0,0 , 'LCD ' || :FROMDIR                   ) ,
         (0,0 , 'CD '  || :TODIR                     ) ,
         (0,0 , 'BIN '                               ) ,
         (0,0 , :FNC ||' ' || :FNCFILE               ) ,
         (0,0 , 'CLOSE '                             ) ,
         (0,0 , 'QUIT'                               ) ;
        //
         IF  sqlstt <> '00000';
                FERR = '2';
                RETURN;
         ENDIF;
      /END-FREE
     P  LOADFTPS       E
       // 
       //###################################################//
     P  DOTHEFTP       B
      /FREE
        IF  FERR <> '0';
          RETURN;
        ENDIF;
       RT  = SYS('FTP ' + FTADDR );
      /END-FREE
     P  DOTHEFTP       E
       // 
       //###################################################//
     P  CKTHEFTP       B
      /FREE
           EXEC SQL                                       
 		SELECT SRCDTA into :SRCDTA FROM OUTPUT WHERE  
 		  UPPER(SRCDTA)  like  '%TRANSFER COMPLETE%'         
  		 FETCH FIRST 1 ROW ONLY ;      
        //    
         IF  sqlstt <> '00000';
                FERR = '3';
                RETURN;
         ENDIF;
      /END-FREE
     P  CKTHEFTP       E
       // 
       //###################################################//
     P  MOVTOARCH      B
      /FREE
        IF  FERR <> '0';
          RETURN;
        ENDIF;
        //  ONLY ARCHIVE THE SENT FILES  (PUT)
        IF  FNC  =  'GET';
          RETURN;
        ENDIF;
       RT  = SYS('MOV OBJ(''' + %TRIM(FROMDIR) +
                          %TRIM(FNCFILE) +  ''') ' +
                 'TODIR('''+ %TRIM(FROMDIR) + 'ARCH'')') ;
      /END-FREE
     P  MOVTOARCH      E
       //
       //###################################################//
     P  LOGTHEFTP      B
      /FREE
         EXEC SQL
         INSERT INTO FTPMSGLOG
         (SELECT :WSID, :USER,:NBR, :DAT, SRCDTA FROM OUTPUT) ;
      /END-FREE
     P  LOGTHEFTP      E
       //
       //###################################################//
     P  RMVWRKF        B
      /FREE
       RT  = SYS('DLTF  QTEMP/INPUT');
       RT  = SYS('DLTF  QTEMP/OUTPUT');
       RT  = SYS('DLTOVR  INPUT LVL(*JOB)');
       RT  = SYS('DLTOVR  OUTPUT LVL(*JOB)');
      /END-FREE
     P  RMVWRKF        E

#top


RPG IFS READ TEMPLATE

 H OPTIMIZE(*NONE) OPTION(*NODEBUGIO)
     H DFTACTGRP(*NO ) ACTGRP(*CALLER)
   >
   >  *  RPGLE  IFSREADR  CHECK the files in a directory
   >  *  If the file exists it needs to be PROCESSED
   >  *
      *
      *  PARMS IN
      *   prefix   10 chr   10 character prefix to find a file
      *   path    256 chr   the path on the IFS to check   
      *
  
      *
     D p_old_dir       s               *
     D old_dir         s            256A
     D p_new_dir       s               *
     D new_dir         s            256A

     d* a few local variables...
     D dh              S               *
     D PathName        S            256A
     D Name            S            256A
     D cl              S             10U 0
     D @loop           S              1A
     D NameF           S             64A
     D Suff            S              3A
     D x               S              9P 0
     D prefixv         S             10A   varying

   >
      //-------------------- Prototypes
     D MAIN            PR
     D WRKFILES        PR

     D IFSREADR        PR
     D                               10A
     D                              256A
     D IFSREADR        PI
     D  prefix                       10A
     D  PATH                        256A



      *
     d**********************************************************************
     d*
     d* Directory Entry Structure (dirent)
     d*
     d* struct dirent {
     d*   char           d_reserved1[16];  /* Reserved                       */
     d*   unsigned int   d_reserved2;      /* Reserved                       */
     d*   ino_t          d_fileno;         /* The file number of the file    */
     d*   unsigned int   d_reclen;         /* Length of this directory entry
     d*                                     * in bytes                       */
     d*   int            d_reserved3;      /* Reserved                       */
     d*   char           d_reserved4[8];   /* Reserved                       */
     d*   qlg_nls_t      d_nlsinfo;        /* National Language Information
     d*                                     * about d_name                   */
     d*   unsigned int   d_namelen;        /* Length of the name, in bytes
     d*                                     * excluding NULL terminator      */
     d*   char           d_name[_QP0L_DIR_NAME]; /* Name...null terminated   */
     d*
     d* };

     D p_dirent        s               *
     D dirent          ds                  based(p_dirent)
     D   d_reserv1                   16A
     D   d_reserv2                   10U 0
     D   d_fileno                    10U 0
     D   d_reclen                    10U 0
     D   d_reserv3                   10I 0
     D   d_reserv4                    8A
     D   d_nlsinfo                   12A
     D     nls_ccsid                 10I 0 OVERLAY(d_nlsinfo:1)
     D     nls_cntry                  2A   OVERLAY(d_nlsinfo:5)
     D     nls_lang                   3A   OVERLAY(d_nlsinfo:7)
     D     nls_reserv                 3A   OVERLAY(d_nlsinfo:10)
     D   d_namelen                   10U 0
     D   d_name                     640A

     d*--------------------------------------------------------------------
     d* Open a Directory
     d* DIR *opendir(const char *dirname)
     D opendir         PR              *   EXTPROC('opendir')
     D  dirname                        *   VALUE

     d*--------------------------------------------------------------------
     d* Read Directory Entry
     d* struct dirent *readdir(DIR *dirp)
     D readdir         PR              *   EXTPROC('readdir')
     D  dirp                           *   VALUE


     d*--------------------------------------------------------------------
     d* Close  Directory
     d* int closedir(DIR *dirp)
     D closedir        PR            10U 0 EXTPROC('closedir')
     D  cldirp                         *   VALUE


      /FREE
                MAIN();
      /END-FREE

       //###################################################//
     P    MAIN         B
      /FREE
          *inlr = '1' ;
          prefixv = %trim(prefix);

       // Step1: Open up the directory.
               PathName= %trim(PATH)+ x'00';
               dh = opendir(%addr(PathName));

       // Step2: Read each entry from the directory
           dow       @loop = @loop;
                p_dirent = readdir(dh);
                  if      p_dirent =  *NULL;
                     leave;
                  endif;

                  Name = %subst(d_name:1:d_namelen);
       // not a file
          If Name = '. ' or Name = '.. ' ;
            Iter;
          Endif;

       // Strip the suffix
            Namef = %subst(Name:1:10);
            x  = %scan('.':Name:1);
            If x > 1;
            NameF = %subst(Name:1:x-1);
            EndIf;
       // not a file  (assume names without suff are not files)
            If x < 2;
            Iter;
            Endif;
       // Get the suffix
            Suff  = %trim(%subst(Name:x+1));


       //  PROCESS  THE FILE

          WRKFILES();


          EndDo;

       // Step3: Close  the directory.
               cl = closedir(dh);
      /END-FREE

     P    MAIN         E


       //###################################################//
     P    WRKFILES     B

     D FTPPROC         PR                  EXTPGM('FTPPGM')
     D                               10A   CONST
     D                               40A   CONST
     D                               40A   CONST
     D                                3A   CONST
     D                               40A   CONST
     D                                1A

     D WC011R          PR                  EXTPGM('WC011R')
     D                               10A   CONST
     D                               10A   CONST
     D                               10A   CONST
     D                              256A   CONST
     D                                1A

     D   ADDR          s             10A
     D   FDIR          s             40A
     D   TDIR          s             40A
     D   FFIL          s             40A
     D   FERR          s              1A
     D   CDATA         s            256A
     D   ERR           s              1A
     D   @@ENV         S              4A
      /FREE
            x  = %scan(prefixv:NameF:1);

            If x = 1;
         //  Found a file matching the pre fix

           ADDR = 'CAR';
           FFIL =  NAME;
        //  GET A DIR FOR A CONTROL FILE
         WC011R ('INVC   ':'COMPY1   ':'LOC   ': CDATA: ERR) ;
           TDIR =  CDATA;

          FDIR  =  %TRIM(PATH);


        IF (ERR = 'N') ;
        //  FTP SEND THE FILE
         FTPPROC    ( ADDR : FDIR : TDIR :'PUT': FFIL : FERR );
        ENDIF;

            EndIf;

      /END-FREE
     P    WRKFILES     E


#top


RPG SUBFILE TEMPLATE

     

This is a demo RPG subfile processing program.
It can be used as a template.

Except for the viewing SFL (S05),it uses the simplest subfile method where 
number of SflRcds is limited to 9999.
SFL (S05) does a page at a time via a preloaded auto extending User Space.

For messages does NOT use message subfiles.
IMO message SFL are an overkill. 
How often have you done or seen done, a position to the MSGSFL messages and scroll.
Users deal with one message at a time then press enter, hence the first error
encountered is sent to the user, and so on.

Indicators for positioning the cursor to the error are NOT used. 
CSRLOC keywords are used.  An API converts FIELD NAMES to the row/col which is
what IBM should have done in the first place, instead of forcing the hard 
coding of row, col.
Indicators are used sparingly, mainly for Display file interaction  F keys &
SFL CTL.  Two indicators 88 89 are used to flag an error.
A trick with Cursor Positioning is used, because if an ERRMSG type keyword is
actioned IBM will not position the cursor, so 88 controls a write to pos the cur
then 89 is done to show the message.


This statement is at the heart of the logic.
One issue with multi screen processing is the way the program logic digs itself
into ever deeper layers. If you know what this means then it may be of interest
that this programs structure only goes down ONE level, even though the program
seems to drop through level after level.
This is achieved by a looping structure and an array that carries the 'logical'
level. F12 will seem to step backwards through many program levels.
Array SCN is dimmed at 99 but this can be whatever you need.
To get from one screen to another the logic MUST always drop back to the
controlling procedure (MAIN) and tell (MAIN) what is the next panel to display.

Each subfile needs 3 procedures,  BLD  PRC and PRS.
BLD loads the subfile.  PRC drives the SFLCTL. PRS processes the SFL lines.
The SFL lines are never used as 'data entry/maintenance' rather an Option
brings up a Display Record panel for the actual data manipulation.



      //***************************************************************
      //  THIS PROGRAM ONLY GOES 1 LEVEL DOWN IN ITS CALL STRUCTURE
      //  Each panel is precessed by its own procedure.
      //  A driving procdeure  then calls the panels procedure.
      //  The user will see that there are many panels on top
      //  of each other by pressing CF12, but this is a LOGICAL
      //  structure ONLY, controlled by the levels array SCN.
      //  The TOP level in SCN will contain *END and when reached
      //  will cause the program to end.



     H OPTIMIZE(*NONE) OPTION(*NODEBUGIO)
     H DFTACTGRP(*NO) ACTGRP(*CALLER)
     H Bnddir('QC2LE')
      //***************************************************************
      //
      //  PROGRAM ID : USEDPRODRU 
      //  Description: Entry of PRODUCT   Usage

      //
      //***************************************************************
      // MODIFICATIONS:
      // MOD   SR   DATE    MODIFICATION SUMMARY
      //
      //***************************************************************
      //
      //
     FPCODES    UF A E           K DISK
     FUSEDPROD  UF A E           K DISK
     FUSEDPROD1 IF   E           K DISK
     F                                     RENAME(PUP100:PUP101)
      //
     FUSEDPRODFPCF   E             WORKSTN
     F                                     INFDS(SFINF)
     F                                     SFILE(S02:RS02)
     F                                     SFILE(S05:RS05)
     F                                     SFILE(S06:RS06)
     F                                     SFILE(S08:RS08)
     F                                     SFILE(S09:RS09)


     D COMPANY         S              3S 0  DTAARA
     D DBLIB           S             10     DTAARA
      //  SCREEN LEVELS
     D @SCN            S              6    DIM(99)
     D @NSCN           S              6
     D @LV             S              5  0
     D @ERR            S                   LIKE(@TRUE)
     D @FILE           S             10A   INZ('USEDPRODFP')
     D WRKSWS          S              1

     D L08KEY          S                   LIKE(S08KEY)

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

      //
     D RS02            S              4S 0
     D RS05            S              4S 0
     D RS06            S              4S 0
     D RS08            S              4S 0
     D RS09            S              4S 0
      //
      // PARMS FOR SFL LOOPING
     D SFC02           S                   LIKE(RS02)
     D SFC05           S                   LIKE(RS05)
     D SFC06           S                   LIKE(RS06)
     D SFC08           S                   LIKE(RS08)
     D SFC09           S                   LIKE(RS09)

     D RCD05           S             12  0
      // Program Status
     D                SDS
     D  PGM                    1     10
     D  WSID                 244    253
     D  USER                 254    263
      //
     D PCSTKEY         DS                  likerec(PCP100  : *key)
     D PUSTKEY         DS                  likerec(PUP100  : *key)
     D PUSTKY1         DS                  likerec(PUP101  : *key)
      //
     D S05DTA          DS                  likerec(S05 : *OUTPUT)
      //  MESSAGE DATA
     D @DTA1           DS            80
     D @DTA2           DS           500
      //
     D SFINF           DS
     D  RRRN                 376    377B 0
     D  SRN                  378    379B 0
      //
     D WFLDS           DS                  OCCURS(999)
     D  FNAME                        10
     D  FTYP                          1
     D  FLEN                         10i 0
     D  FDEC                         10i 0

     D   SDATA         DS            80
     D    SFMT                17     17
     D    SNAME               19     28
     D    SLEN                32     34S 0
     D    STYP                35     35
     D    SDEC                36     37

       //  FOR RUNNING AS400 COMMANDS
     D RT              S             10I 0
     D SYS             PR            10I 0 Extproc('system')
     D   CmdString                     *   Value
     D                                     Options(*String)

      //
     D MAIN            PR
     D @R01            PR
     D @R03            PR
     D @R04            PR
     D @S02BLD         PR
     D @S02PRC         PR
     D @S02PRS         PR
     D @S05BLD         PR
     D @S05PRC         PR
     D @S06BLD         PR
     D @S06PRC         PR
     D @S06PRS         PR
     D @R07            PR
     D @S08BLD         PR
     D @S08PRC         PR
     D @S08PRS         PR
     D @S09BLD         PR
     D @S09PRC         PR
     D
     D @R9999          PR

     D @OPADJ          PR             2A
     D  OPT                           2A

      *-------------------------------------------------------------------
      * 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')





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


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

        //  Get Company
          CMPNO = 0;
         IN   COMPANY;
          CMPNO = COMPANY;

        @LOOP = @TRUE;
        @OK   = @TRUE;
        @LV = 1;
        @SCN(@LV)  = '*END  ';
        @LV = @LV + 1;
        @SCN(@LV) = 'R01    ';

       ENDSR;

      /END-FREE

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

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

     D MAIN            PI


      /FREE
          EXSR @INZSR;
       //
       DOW @LOOP = @LOOP;

           @NSCN  = @SCN(@LV);
           SELECT;
            //  PROMPT FOR A DATE
            //  F6 TO MAINTAIN PRODUCT CODES
           WHEN     @NSCN = 'R01   ';
             @R01();

            // SFL TO MAINTAIN PRODUCT USAGE
           WHEN     @NSCN = 'S02BLD';
             @S02BLD();
           WHEN     @NSCN = 'S02PRC';
             @S02PRC();
           WHEN     @NSCN = 'S02PRS';
             @S02PRS();

            // RCD TO ADD  PRODUCT  USAGE
           WHEN     @NSCN = 'R03';
             @R03();

            // RCD TO CHG  PRODUCT  USAGE
           WHEN     @NSCN = 'R04';
             @R04();

            // SFL TO VIEW PRODUCT  USAGE (WITH POSN)
           WHEN     @NSCN = 'S05BLD';
             @S05BLD();
           WHEN     @NSCN = 'S05PRC';
             @S05PRC();

            // SFL TO MAINTAIN PRODUCT  CODES
           WHEN     @NSCN = 'S06BLD';
             @S06BLD();
           WHEN     @NSCN = 'S06PRC';
             @S06PRC();
           WHEN     @NSCN = 'S06PRS';
             @S06PRS();

            // RCD TO ADD  PRODUCT  CODE
           WHEN     @NSCN = 'R07';
             @R07();

            // SFL WDW TO LOOKUP PRODUCT  CODES
           WHEN     @NSCN = 'S08BLD';
             @S08BLD();
           WHEN     @NSCN = 'S08PRC';
             @S08PRC();
           WHEN     @NSCN = 'S08PRS';
             @S08PRS();

            // SFL FOR DEL PRODUCT  CODES (WITH VALIDATION)
           WHEN     @NSCN = 'S09BLD';
             @S09BLD();
           WHEN     @NSCN = 'S09PRC';
             @S09PRC();

           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;
      /END-FREE
     P    MAIN         E

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

     P @R01            B
      *

     D @R01            PI

     D @DAYNO          S             10I 0
     D @FORMAT         S             10    INZ('R01')

      //

      /free
          EXSR @INZSR;

          EXSR BLD;
           DOW     @LOOP  = @LOOP;

           EXFMT   R01;
       // setoff errors
          @ERR = @FALSE;
          *IN88 = *OFF;
          *IN89 = *OFF;
          ROW01 = 999;
          COL01 = 999;
       //Exit and Previous Screen
          IF        (*IN03 = *ON) or
                    (*IN12 = *ON);
                         Leave;
          ENDIF;
       // Create
          IF        (*IN06 = *ON) ;
            @LV = @LV +1;
            @SCN(@LV) = 'S06BLD';
            LEAVE;
          ENDIF;
       // View
          IF        (*IN07 = *ON) ;
            @LV = @LV +1;
            @SCN(@LV) = 'S05BLD';
            LEAVE;
          ENDIF;

        //   Validate the data
          EXSR      VAL;
          IF        @Err = @True;
                    *IN88 = *ON ;
                    *IN89 = *OFF;
                    WRITE R01;
                    *IN89 = *ON;
                    ITER;
          ELSE;
           WRITE R01;
            @LV = @LV +1;
            @SCN(@LV) = 'S02BLD';
            LEAVE;
          ENDIF;

          ENDDO;

       //
       RETURN;


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

         CLEAR  R01MTH ;

        ENDSR;

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


        ENDSR;

       //--------------  VAL -------------------------------//
        BEGSR    VAL;

           DOW     @LOOP  = @LOOP;

        // VALID DATE
         TEST(DE) *ISO  R01MTH;
         IF %error;
          @ERR  =   @TRUE ;
          GETROWCOL  (@FILE :'*LIBL' : @FORMAT : 'R01MTH': ROW01:COL01);
          R01MSG = RtvMsgTxt('MSG0001':cMsgF2:cMsgLib:cMsgLvl1);
          LEAVE;
         ENDIF;

        // SATURDAY

        @DAYNO =  DayOfWeek(%DATE(R01MTH:*ISO));
         IF @DAYNO <> 6;
          @ERR  =   @TRUE ;
          GETROWCOL  (@FILE :'*LIBL' : @FORMAT : 'R01MTH': ROW01:COL01);
          R01MSG = 'DATE MUST BE A SATURDAY';
          LEAVE;
         ENDIF;

          LEAVE;


          ENDDO;
          ENDSR;

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

         ENDSR;
      /END-FREE
     P @R01            E

       //###################################################//
       //###################################################//
       //###################################################//
      /space 3
     P @S02BLD         B

     D @S02BLD         PI

          //  LOAD   PRODUCTS PANEL
          //
          //  Build/Rebuild the subfile

      /FREE

          EXSR @INZSR;

         // SAVKEY = *Blanks;
         EXSR BLD;

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

         C02MTH = R01MTH;
         EXSR CLR;

          PUSTKEY.PUSDAT=  %DATE(R01MTH:*ISO );

          SETLL  %kds(PUSTKEY:1) PUP100 ;

          DOW @LOOP = @LOOP;
          READE  %kds(PUSTKEY:1) PUP100 ;
          IF %EOF;
           LEAVE;
          ENDIF;

         EXSR MOV;

         //
          RS02   = RS02 + 1;
         WRITE S02;
          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;
           S02OPT=*BLANK;
         ENDSR;

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

          S02OPT = *BLANK;
          S02KEY =  PUSKY;
          S02CT  =  PUSCT;
          S02CT2 =  PUSCT2;
          S02QTY =  PUSQTY;

          PCSTKEY.PCSKY = PUSKY   ;
          CHAIN  %kds(PCSTKEY) PCP100 ;
          S02PRD =  PCDSC;


         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
           IF *IN03 = *ON;
             LEAVE;
           ENDIF;

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

           IF *IN06 = *ON;
           @LV = @LV +1;
             @SCN(@LV) = 'R04   ';
             LEAVE;
           ENDIF;

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

       ENDDO;
       //
       RETURN;

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

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

       //###################################################//
       //###################################################//
       //###################################################//
      /space 3
     P @S02PRS         B

     D @S02PRS         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 SFC02+1;
           CHAIN WRKRC S02;
            IF NOT %FOUND;
         //  Finished with the subfile
         //  RETURN TO REBUILD LEVEL
             @LV = @LV -2;
             LEAVE;
            ENDIF;

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

           SELECT;
             // WORK WITH
           WHEN S02OPT = ' 2';
             @LV = @LV +1;
             @SCN(@LV) =  'R03';
             S02OPT = *blank;
             UPDATE S02;
             LEAVE;
             //
           OTHER;
             S02OPT = *blank;
             UPDATE S02;
           ENDSL;
           //
         ENDFOR;
         //
         ENDSR;
       //---------------------------------------------------//

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

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

       //###################################################//
       //###################################################//
       //###################################################//
      /space 3
     P @R03            B
      *


     D @R03            PI

     D @FORMAT         S             10    INZ('R03')

      //

      /free
          EXSR @INZSR;

          EXSR BLD;
           DOW     @LOOP  = @LOOP;

           EXFMT   R03;
       // setoff errors
          @ERR = @FALSE;
          *IN88 = *OFF;
          *IN89 = *OFF;
          ROW03 = 999;
          COL03 = 999;
       //Exit and Previous Screen
          IF        (*IN03 = *ON) or
                    (*IN12 = *ON);
                         Leave;
          ENDIF;

        //   Validate the data
          EXSR      VAL;
          IF        @Err = @True;
                    *IN88 = *ON ;
                    *IN89 = *OFF;
                    WRITE R03;
                    *IN89 = *ON;
                    ITER;
          ELSE;
           WRITE R03;
          ENDIF;

       //UPDATE   Previous Screen
          IF        (*IN06 = *ON);
              EXSR      UPD;
              @LV = @LV -1 ;
              Leave;
          ENDIF;
          ENDDO;

       //
       RETURN;

       //---------------------------------------------------//

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

         CLEAR  R03QTY ;

        ENDSR;

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

         R03KEY =  S02KEY ;
         R03MTH =  C02MTH ;
         R03PRD =  S02PRD ;
         R03QTY =  S02QTY ;
         R03CT  =  S02CT  ;
         R03CT2 =  S02CT2 ;

        ENDSR;

       //--------------  VAL -------------------------------//
        BEGSR    VAL;

          DOW     @LOOP  = @LOOP;
          LEAVE;
          ENDDO;
          ENDSR;

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

          PUSTKEY.PUSDAT= %DATE(R03MTH : *ISO);
          PUSTKEY.PUSKY = R03KEY;
          PUSTKEY.PUSCT = R03CT ;
          PUSTKEY.PUSCT2= R03CT2;
          CHAIN  %kds(PUSTKEY) PUP100 ;
          IF  %FOUND;
            PUSQTY = R03QTY;
            UPDATE    PUP100;
          ELSE;
            PUSDAT =  %DATE(R03MTH : *ISO);
            PUSCT  =  R03CT ;
            PUSCT2 =  R03CT2;
            PUSKY  =  R03KEY;
            PUSQTY =  R03QTY;
            WRITE     PUP100;
          ENDIF;

         ENDSR;




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

         ENDSR;
      /END-FREE
     P @R03            E

       //###################################################//
       //###################################################//
       //###################################################//
      /space 3
     P @R04            B
      *


     D @R04            PI

     D @FORMAT         S             10    INZ('R04')

      //

      /free
          EXSR @INZSR;

          EXSR BLD;
           DOW     @LOOP  = @LOOP;

           EXFMT   R04;
       // setoff errors
          @ERR = @FALSE;
          *IN88 = *OFF;
          *IN89 = *OFF;
          ROW04 = 999;
          COL04 = 999;
       //Exit and Previous Screen
          IF        (*IN03 = *ON) or
                    (*IN12 = *ON);
                         Leave;
          ENDIF;
       //Lookup Product
          IF        (*IN04 = *ON);
            @LV = @LV +1;
            @SCN(@LV) = 'S08BLD';
              Leave;
          ENDIF;

        //   Validate the data
          EXSR      VAL;
          IF        @Err = @True;
                    *IN88 = *ON ;
                    *IN89 = *OFF;
                    WRITE R04;
                    *IN89 = *ON;
                    ITER;
          ELSE;
           WRITE R04;
          ENDIF;

       //UPDATE   Previous Screen
          IF        (*IN06 = *ON);
              EXSR      UPD;
              @LV = @LV -2 ;
              Leave;
          ENDIF;
          ENDDO;

       //
       RETURN;

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


        ENDSR;

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

         IN   DBLIB;
          R04CT = %subst(DBLIB:2:2);
          R04PRD = *BLANK;
          R04MTH = C02MTH;

        // USE LOOKUP VALUE , IF ANY
         IF  L08KEY <> *BLANK;
          R04KEY  = L08KEY;
          L08KEY  = *BLANK;
         ENDIF;

        ENDSR;

       //--------------  VAL -------------------------------//
        BEGSR    VAL;

          @ERR  =   @FALSE;
          DOW     @LOOP  = @LOOP;

        //  CHECK THE PRODUCT KEY
          PCSTKEY.PCSKY = R04KEY  ;
          CHAIN  %kds(PCSTKEY) PCP100 ;
          R04PRD = *BLANK;
          IF %found ;
          R04PRD = PCDSC;
          ELSE;
           @ERR  =   @TRUE ;
           GETROWCOL  (@FILE :'*LIBL' : @FORMAT : 'R04KEY': ROW04:COL04);
           R04MSG = RtvMsgTxt('MSG0002':cMsgF2:cMsgLib:cMsgLvl1);
           LEAVE;
          ENDIF;

           IF  R04QTY  <= 0;
           @ERR  =   @TRUE ;
           GETROWCOL  (@FILE :'*LIBL' : @FORMAT : 'R04QTY': ROW04:COL04);
           R04MSG = RtvMsgTxt('MSG0003':cMsgF2:cMsgLib:cMsgLvl1);
           LEAVE;
          ENDIF;


          PUSTKEY.PUSDAT= %DATE(R04MTH : *ISO);
          PUSTKEY.PUSKY = R04KEY;
          PUSTKEY.PUSCT = R04CT ;
          PUSTKEY.PUSCT2= R04CT2;
          CHAIN  %kds(PUSTKEY) PUP100 ;
          IF  %FOUND;
           @ERR  =   @TRUE ;
           GETROWCOL  (@FILE :'*LIBL' : @FORMAT : 'R04KEY': ROW04:COL04);
           R04MSG = RtvMsgTxt('MSG0004':cMsgF2:cMsgLib:cMsgLvl1);
           LEAVE;
          ENDIF;

          LEAVE;
          ENDDO;
          ENDSR;

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

          PUSTKEY.PUSDAT= %DATE(R04MTH : *ISO);
          PUSTKEY.PUSKY = R04KEY;
          PUSTKEY.PUSCT = R04CT ;
          PUSTKEY.PUSCT2= R04CT2;
          CHAIN  %kds(PUSTKEY) PUP100 ;
          IF  %FOUND;
            PUSQTY = R04QTY;
            UPDATE    PUP100;
          ELSE;
            PUSDAT =  %DATE(R04MTH : *ISO);
            PUSCT  =  R04CT ;
            PUSCT2 =  R04CT2;
            PUSKY  =  R04KEY;
            PUSQTY =  R04QTY;
            WRITE     PUP100;
          ENDIF;

         ENDSR;




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

         ENDSR;
      /END-FREE
     P @R04            E

       //###################################################//
       //###################################################//
       //###################################################//
      /space 3
     P @S05BLD         B

     D @S05BLD         PI

          //  S05 IS A PAGE AT A TIME SFL
          //  A USER SPACE IS LOADED TO SUPPORT THE SFL
          //  ENABLE > 9999 DATA RECORDS
          //
     D X               S             10i 0

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

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

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

     D QUSCUSAT        PR                  ExtPgm('QUSCUSAT')
     D  ReturnLibrary                10A
     D  UserSpace                    20A   Const
     D  Attribute                          Const
     D                                     LikeDS(SpaceAttr)
     D  ErrorCode                          LikeDS(ErrorCode)


     D SpaceAttr       DS                  Qualified
     D  NumberRecs                   10I 0
     D  ExtendRecord                 12A
     D   Key                         10I 0 Overlay(ExtendRecord)
     D   Length                      10I 0 OverLay(ExtendRecord:*Next)
     D   Extend                       1A   OverLay(ExtendRecord:*Next)


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

     D DataEntry       S                   Based(DataPtr) Like(S05DTA)

     D TEMPSPC         DS            20
     D SpaceName                     10A   Inz('SCROLL05 ')
     D Library                       10A   Inz('QTEMP  ')

      * BasePtr will hold the base address of the User Space
      * At the beginning of the space is a count (Count) of the entries
     D BasePtr         S               *
     D Count           S             12P 0 Based(BasePtr)
     D CountMessage    S             30A
     D RtnLib          S             10A
     D SpaceNotFound   C                   'User Space not found'


      /FREE

          EXSR @INZSR;

         // SAVKEY = *Blanks;
         EXSR BLD;

         //  USER SPC IS  LOADED , RUN THE CONTROL
           @LV = @LV + 1;
           @SCN(@LV) = 'S05PRC ';
       RETURN;

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

         EXSR CLR;
         *IN53 = *OFF;

          PUSTKEY.PUSDAT= *LOVAL;
          PUSTKEY.PUSKY = *LOVAL;
          SETLL  %kds(PUSTKEY) PUP100 ;
          IF  %FOUND;

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

         EXSR MOV;

          ENDDO;
          ENDIF;

         ENDSR;

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


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

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

           //  Set the user space to Auto extend
            SpaceAttr.NumberRecs = 1;
            SpaceAttr.Key = 3;          //  3 is auto extend key
            SpaceAttr.Length = 1;
            SpaceAttr.Extend = '1';     //  1 means auto extend
            QUSCUSAT( Rtnlib  : TEMPSPC
                      : SpaceAttr  : ErrorCode );


           // Get a pointer to the user space
           QUSPTRUS( TEMPSPC: BasePtr      );

             If        BasePtr <> *Null;
               DataPtr = BasePtr + %Size(Count);
               Eval      Count = 0;
             Endif;


         ENDSR;

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

          RCD05   = RCD05 + 1;
          count   = count + 1;
         S05DTA.S05MTH    =  %CHAR(PUSDAT : *iso);
         S05DTA.S05QTY    = PUSQTY;
         S05DTA.S05KEY    = PUSKY;
         S05DTA.S05CT2    = PUSCT2;

          PCSTKEY.PCSKY = S05DTA.S05KEY  ;
          CHAIN  %kds(PCSTKEY) PCP100 ;
         S05DTA.S05PRD =  PCDSC;

          DataEntry = S05DTA;
          DataPtr = DataPtr + %Size(S05DTA);
         ENDSR;

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

           @NSCN = *BLANK;

         ENDSR;
      /END-FREE
     P @S05BLD         E

       //###################################################//
       //###################################################//
       //###################################################//
      /space 3
     P @S05PRC         B

     D @S05PRC         PI


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

     D DataEntry       S                   Based(DataPtr) Like(S05DTA)

     D TEMPSPC         DS            20
     D SpaceName                     10A   Inz('SCROLL05 ')
     D Library                       10A   Inz('QTEMP  ')

      * BasePtr will hold the base address of the User Space
      * At the beginning of the space is a count (Count) of the entries
     D BasePtr         S               *
     D Count           S             12P 0 Based(BasePtr)
     D CountMessage    S             30A
     D SpaceNotFound   C                   'User Space not found'

          //
          //
     D WRKRC           S              4S 0

     D X               S             12S 0
     D RECS            S              4S 0 INZ(14)
     D CURS            S             12S 0
     D TOPS            S             12S 0

      /FREE

          EXSR @INZSR;

         WRITE R05;

       //
       DOW @LOOP = @LOOP;

           // Write SFL Control
           IF SFC05 > 0;
             *IN51 = *ON;
           ENDIF;
           *IN52 = *ON;
           EXFMT C05;
           //
           //  Setoff errors
           *IN89 = *OFF;
           //  Setoff MORE
           *IN99 = *OFF;
           //
           //  Exit and Previous Screen
           IF *IN03 = *ON;
             LEAVE;
           ENDIF;

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

           //  PAGE UP
           IF *IN62 = *ON;
             IF TOPS = 1;
              ITER;
             ENDIF;
             EXSR PAGEUP;
             ITER;
           ENDIF;

           //  PAGE DOWN
           IF *IN61 = *ON;
             IF CURS = RCD05;
              *IN99 = *ON;
              ITER;
             ENDIF;
             EXSR PAGEDN;
             ITER;
           ENDIF;

         IF C05MTH  <> *BLANK;
           EXSR POS;
           ITER;
         ENDIF;

       ENDDO;
       //
       RETURN;


      /space 3

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

         FOR X  = 1 TO RCD05  ;

          CURS = X-1;
              DataPtr = BasePtr + %Size(Count) +
                     + CURS *%Size(S05DTA);
          S05DTA = DataEntry ;

            IF S05DTA.S05MTH >= C05MTH;
             EXSR PAGEDN;
             LEAVE;
            ENDIF;
          ENDFOR;

         ENDSR;

      /space 3

       //--------------  PAGEUP ------------------------------//
         BEGSR PAGEUP;

         TOPS  =  TOPS - RECS;

         IF TOPS < 1;
          TOPS  =  1;
         ENDIF;

         CURS = TOPS - 1;
         DataPtr = BasePtr + %Size(Count) +
                     + CURS *%Size(S05DTA);

         EXSR  PAGEDN;

         ENDSR;


      /space 3

       //--------------  PAGEDN ------------------------------//
         BEGSR PAGEDN;

         EXSR CLR;

         TOPS = CURS + 1;

         FOR X  = 1 TO RECS;

         IF CURS = RCD05;
          *IN99 = *ON;
          LEAVE  ;
         ENDIF;

         CURS = CURS + 1;

          S05DTA = DataEntry ;
          DataPtr = DataPtr + %Size(S05DTA);

         EXSR MOV;
         SFC05 = 1;
         SRS05 = 1;
         RS05 = X;
         WRITE S05;

         ENDFOR;

         ENDSR;

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

           S05MTH =   S05DTA.S05MTH;
           S05QTY =   S05DTA.S05QTY;
           S05KEY =   S05DTA.S05KEY;
           S05CT2 =   S05DTA.S05CT2;
           S05PRD =   S05DTA.S05PRD;

         ENDSR;

       //--------------  CLR -------------------------------//
         BEGSR  CLR;
          *IN51 = *OFF;
          *IN52 = *OFF;
          *IN53 = *ON;
          WRITE C05;
          *IN53 = *OFF;
           RS05 =0;
           SFC05=0;
         ENDSR;

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

           @NSCN = *BLANK;
           TOPS  =  0;
           CURS  =  0;


           // Get a pointer to the user space
           QUSPTRUS( TEMPSPC: BasePtr      );

             If        BasePtr <> *Null;
               DataPtr = BasePtr + %Size(Count);
               Eval      RCD05 = Count ;
             Endif;


           EXSR  PAGEDN;
         ENDSR;
      /END-FREE
     P @S05PRC         E


       //###################################################//
       //###################################################//
       //###################################################//
      /space 3
     P @S06BLD         B

     D @S06BLD         PI

          //  LOAD   PRODUCTS PANEL
          //
          //  Build/Rebuild the subfile

      /FREE

          EXSR @INZSR;

         // SAVKEY = *Blanks;
         EXSR BLD;

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

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

         EXSR CLR;


          PCSTKEY.PCSKY =  *LOVAL;
          SETLL  %kds(PCSTKEY) PCP100 ;

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

         EXSR MOV;

         //
          RS06   = RS06 + 1;
         WRITE S06;
          ENDDO;

         // Position to TOP of subfile
          SRS06 = 1;
          SFC06 = RS06;
         ENDSR;

       //--------------  CLR -------------------------------//
         BEGSR  CLR;
          *IN51 = *OFF;
          *IN52 = *OFF;
          *IN53 = *ON;
          WRITE C06;
          *IN53 = *OFF;
           RS06 =0;
           SFC06=0;
           S06OPT=*BLANK;
         ENDSR;

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

          S06OPT = *BLANK;
          S06KEY =  PCSKY;
          S06PRD =  PCDSC;

         ENDSR;

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

      /END-FREE
     P @S06BLD         E

       //###################################################//
       //###################################################//
       //###################################################//
      /space 3
     P @S06PRC         B

     D @S06PRC         PI

          //
          //
     D WRKRC           S              4S 0

      /FREE

          EXSR @INZSR;

         WRITE R06;

       //
       DOW @LOOP = @LOOP;


           // Write SFL Control
           IF SFC06 > 0;
             *IN51 = *ON;
           ENDIF;
           *IN52 = *ON;
           EXFMT C06;
           //
           //  Setoff errors
           *IN89 = *OFF;
           //
           //  Exit and Previous Screen
           IF *IN03 = *ON;
             LEAVE;
           ENDIF;

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

           IF *IN06 = *ON;
             @LV = @LV + 1;
             @SCN(@LV) = 'R07';
             LEAVE;
           ENDIF;

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

       ENDDO;
       //
       RETURN;


      /space 3


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

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

       //###################################################//
       //###################################################//
       //###################################################//
      /space 3
     P @S06PRS         B

     D @S06PRS         PI

          //
          //
     D WRKRC           S              4S 0

      /FREE

          EXSR @INZSR;

       //

         //  Process the subfile
         EXSR SFL;
       //
       RETURN;


       //--------------  SFL -------------------------------//
         BEGSR  SFL;


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

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

           SELECT;
             // WORK WITH
           WHEN S06OPT = ' 4';
             @LV = @LV +1;
             @SCN(@LV) =  'S09BLD';
             LEAVE;
             //
           OTHER;
             S06OPT = *blank;
             UPDATE S06;
           ENDSL;
           //
         ENDFOR;
         //
         ENDSR;
       //---------------------------------------------------//

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

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

      /space 3
       //###################################################//
       //###################################################//
       //###################################################//
     P @R07            B
     D @R07            PI


     D @FORMAT         S             10    INZ('R07')

      //

      /free
          EXSR @INZSR;

          EXSR BLD;
           DOW     @LOOP  = @LOOP;

           EXFMT   R07;
       // setoff errors
          @ERR = @FALSE;
          *IN88 = *OFF;
          *IN89 = *OFF;
          ROW07 = 999;
          COL07 = 999;
       //Exit and Previous Screen
          IF        (*IN03 = *ON) or
                    (*IN12 = *ON);
                         Leave;
          ENDIF;

        //   Validate the data
          EXSR      VAL;
          IF        @Err = @True;
                    *IN88 = *ON ;
                    *IN89 = *OFF;
                    WRITE R07;
                    *IN88 = *OFF;
                    ROW07 = 999;
                    COL07 = 999;
                    *IN89 = *ON;
                    ITER;
          ELSE;
           WRITE R07;
          ENDIF;

       //UPDATE   Previous Screen
          IF        (*IN06 = *ON);
              EXSR      UPD;
              @LV = @LV -2 ;
              Leave;
          ENDIF;
          ENDDO;

       //
       RETURN;

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


        ENDSR;

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

         R07KEY =  *BLANK ;
         R07PRD =  *BLANK ;

        ENDSR;

       //--------------  VAL -------------------------------//
        BEGSR    VAL;

          DOW     @LOOP  = @LOOP;
          LEAVE;
          ENDDO;
          ENDSR;

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

          PCSTKEY.PCSKY = R07KEY  ;
          CHAIN  %kds(PCSTKEY) PCP100 ;
          IF  %FOUND;
            PCDSC  = R07PRD;
            UPDATE    PCP100;
          ELSE;
            PCSKY  =  R07KEY;
            PCDSC  =  R07PRD;
            WRITE     PCP100;
          ENDIF;

         ENDSR;




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

         ENDSR;
      /END-FREE
     P @R07            E

       //###################################################//
       //###################################################//
       //###################################################//
      /space 3
     P @S08BLD         B

     D @S08BLD         PI

          //  LOAD   PRODUCTS PANEL
          //
          //  Build/Rebuild the subfile

      /FREE

          EXSR @INZSR;

         // SAVKEY = *Blanks;
         EXSR BLD;

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

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

         EXSR CLR;


          PCSTKEY.PCSKY =  *LOVAL;
          SETLL  %kds(PCSTKEY) PCP100 ;

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

         EXSR MOV;

         //
          RS08   = RS08 + 1;
         WRITE S08;
          ENDDO;

         // Position to TOP of subfile
          SRS08 = 1;
          SFC08 = RS08;
         ENDSR;

       //--------------  CLR -------------------------------//
         BEGSR  CLR;
          *IN51 = *OFF;
          *IN52 = *OFF;
          *IN53 = *ON;
          WRITE C08;
          *IN53 = *OFF;
           RS08 =0;
           SFC08=0;
           S08OPT=*BLANK;
         ENDSR;

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

          S08OPT = *BLANK;
          S08KEY =  PCSKY;
          S08PRD =  PCDSC;

         ENDSR;

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

       //###################################################//
       //###################################################//
       //###################################################//
      /space 3
     P @S08PRC         B

     D @S08PRC         PI

          //
          //
     D WRKRC           S              4S 0

      /FREE

          EXSR @INZSR;

        //  WRITE R08;

       //
       DOW @LOOP = @LOOP;

           //
           // Write SFL Control
           IF SFC08 > 0;
             *IN51 = *ON;
           ENDIF;
           *IN52 = *ON;
           EXFMT C08;
           //
           //  Setoff errors
           *IN89 = *OFF;
           //
           //  Exit and Previous Screen
           IF *IN03 = *ON;
             LEAVE;
           ENDIF;

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

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


       ENDDO;
       //
       RETURN;


      /space 3


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

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

       //###################################################//
       //###################################################//
       //###################################################//
      /space 3
     P @S08PRS         B

     D @S08PRS         PI

          //
          //
     D WRKRC           S              4S 0

      /FREE

          EXSR @INZSR;

         //  Process the subfile
         EXSR SFL;
       //
       RETURN;


       //--------------  SFL -------------------------------//
         BEGSR  SFL;

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

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

           SELECT;
             // SELECTED KEY
           WHEN S08OPT = ' 1';
             L08KEY = S08KEY;
             @LV = @LV -3;
             LEAVE;
             //
           OTHER;
             S08OPT = *blank;
             UPDATE S08;
           ENDSL;
           //
         ENDFOR;
         //
         ENDSR;
       //---------------------------------------------------//

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

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

       //###################################################//
       //###################################################//
       //###################################################//
      /space 3
     P @S09BLD         B

     D @S09BLD         PI

          //  LOAD   PRODUCTS PANEL
          //
          //  Build/Rebuild the subfile
     D WRKRC           S              4S 0

      /FREE

          EXSR @INZSR;

         // SAVKEY = *Blanks;
         EXSR BLD;

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

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

         EXSR CLR;
         *IN53 = *OFF;



         FOR WRKRC = 1 TO SFC06;
           CHAIN WRKRC S06;

         IF @OPADJ(S06OPT) = ' 4';
          EXSR MOV;
          RS09   = RS09 + 1;
          WRITE S09;
         ENDIF;

          ENDFOR;

         // Position to TOP of subfile
          SRS09 = 1;
          SFC09 = RS09;
         ENDSR;
       //---------------------------------------------------//

       //--------------  CLR -------------------------------//
         BEGSR  CLR;
          *IN51 = *OFF;
          *IN52 = *OFF;
          *IN53 = *ON;
          WRITE C09;
          *IN53 = *OFF;
           RS09 =0;
           SFC09=0;
         ENDSR;

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

          S09KEY    = S06KEY ;
          S09PRD    = S06PRD ;
         ENDSR;

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

       //###################################################//
       //###################################################//
       //###################################################//
      /space 3
     P @S09PRC         B

     D @S09PRC         PI

          //

     D WRKRC           S              4S 0

      /FREE

          EXSR @INZSR;

         WRITE R09;

       //
       DOW @LOOP = @LOOP;

           // Write SFL Control
           IF SFC09 > 0;
             *IN51 = *ON;
           ENDIF;
           *IN52 = *ON;
           EXFMT C09;

           //  Setoff errors
           *IN89 = *OFF;
           @ERR = @FALSE;
           //
           //  Exit and Previous Screen
           IF *IN03 = *ON;
             LEAVE;
           ENDIF;

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

          EXSR CHKDEL;
          IF @ERR = @TRUE;
           *IN89 = *ON ;
          ITER;
          ENDIF;


          EXSR DEL;
          @LV = @LV -4;
          LEAVE;

       ENDDO;
       //
       RETURN;


       //---------------------------------------------------//
       BEGSR   DEL;


         FOR WRKRC = 1 TO SFC06  ;
           CHAIN WRKRC S06;

         IF @OPADJ(S06OPT) = ' 4';
             S06OPT  = '  ';
             UPDATE   S06;

          PCSTKEY.PCSKY = S06KEY  ;
          DELETE %kds(PCSTKEY) PCP100 ;

         ENDIF;

          ENDFOR;

         ENDSR;
       //---------------------------------------------------//
       BEGSR   CHKDEL;


         FOR WRKRC = 1 TO SFC06  ;
           CHAIN WRKRC S06;

         IF @OPADJ(S06OPT) = ' 4';


          PUSTKY1.PUSKY =  S06KEY;

          SETLL  %kds(PUSTKY1:1) PUP101 ;
          IF  %EQUAL;
          @ERR = @TRUE;
          C09MSG = 'CANNOT DELETE ' + S06KEY +
                   ' AS IT IS IN USE.';
          LEAVE;
          ENDIF;

         ENDIF;

         ENDFOR;

         ENDSR;
       //---------------------------------------------------//
      /space 3


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

           @NSCN = *BLANK;
         ENDSR;
      /END-FREE
     P @S09PRC         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('MSG0005':cMsgF3:cMsgLib:cMsgLvl1);

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

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

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

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

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

     D   Return_Text   S           1024

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

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

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

         // Process Return variables
         Return_Text = *blanks;

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

         // Return to calling point
         Return Return_Text;

      /END-FREE
     P                 E


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

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

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

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

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

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

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

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

     D Field           ds                  based(p_Field)
     D                                     qualified
     D  Name                         10a
     D  Type                          1a
     D  Use                           1a
     D  Obuff                        10i 0
     D  Ibuff                        10i 0
     D  Len                          10i 0
     D  Digt                         10i 0
     D  Dec                          10i 0
     D  FILLER                      416a
     d  DspRow                       10i 0
     d  DspCol                       10i 0

     D TEMPSPC         C                   'GETROWCOL QTEMP'

     D x               s             10I 0

      /free

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

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

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

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


               if  schString = '*ALL';

                 %OCCUR(WFLDS) =x+1;
                  rtnRow =     x+1;
                  rtnCol =    0;
                  FNAME = Field.name;
                  FTYP  = Field.Type;
                  FLEN  = Field.Len ;
                  FDEC  = Field.Dec ;

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



           endfor;

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

            return;

      /end-free
     P                 E

       //###################################################//
       //###################################################//
       //###################################################//
     P SysDate         B
      * // Procedure:  SysDate                                             //
      * // Purpose:  Gets the system date YYYYMMDD format 8S 0              //
      * // Parameters:                                                     //
      * // Returns:                                                        //
      * //    int    -- date in YYYYMMDD fmt                               //
      * //\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\//
     P
     D SysDate         PI             8S 0
     D
      /free
         Return     %INT(%CHAR(%DATE():*ISO0));
      /end-free
     P SysDate         E

       //###################################################//
       //###################################################//
       //####################################################
     P SysTime         B
      * // Procedure:  SysTime                                             //
      * // Purpose:  Gets the system time HHMMSS format 6S 0              //
      * // Parameters:                                                     //
      * // Returns:                                                        //
      * //    int    -- TMIE in HHMMSS fmt                               //
      * //\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\//
     P
     D SysTime         PI             6S 0
     D
      /free
         Return  %INT(%CHAR(%TIME():*ISO0));
      /end-free
     P SysTime         E

       //###################################################//
       //###################################################//
       //####################################################
     P DayOfWeek       B
      * // Procedure:  DayOfWeek
      * // Purpose:  Determine the day of week for a particular date
      * // Parameters:
      * //    I: dt   -- date
      *
      * // Returns:
      * //    0..6    -- 0=Sunday, 1=Monday, 2=Tuesday, etc.
      * // Notes:
      * //    January 5, 1800 is a Sunday.  This procedure only works for
      * //    dates later than 1800-01-05.
     P
     D DayOfWeek       pi            10i 0
     D   dt                            d   value datfmt(*iso)

      /free
        return %rem (%diff (dt: d'1800-01-05': *days): 7);
      /end-free
     P DayOfWeek       e
       //####################################################

      //***************************************************************
      //  THIS PROGRAM ONLY GOES 1 LEVEL DOWN IN ITS CALL STRUCTURE
      //  Each panel is precessed by its own procedure.
      //  A driving procdeure  then calls the panels procedure.
      //  The user will see that there are many panels on top
      //  of each other by pressing CF12, but this is a LOGICAL
      //  structure ONLY, controlled by the levels array SCN.
      //  The TOP level in SCN will contain *END and when reached
      //  will cause the program to end.
     *****************************************************************
     ** OBJECT ID: PCODES
     ** TEXT:      PRODUCT CODES
     *****************************************************************
     ** MODIFICATIONS:
     ** MOD   SCN    DATE   MODIFICATION SUMMARY
     **
     *****************************************************************

     A          R PCP100                    TEXT('PRODUCT CODES ')
     A            PCSKY         15          TEXT('KEY ')
     A            PCDSC         30          TEXT('DESCRIPTION')

     A          K PCSKY

     *****************************************************************
     ** OBJECT ID: USEDPROD
     ** TEXT:      USED PRODUCTS
     *****************************************************************
     ** MODIFICATIONS:
     ** MOD   SCN    DATE   MODIFICATION SUMMARY
     **
     *****************************************************************

     A          R PUP100                    TEXT('PRODUCT USAGE')
     A            PUSDAT          L         TEXT('DATE')
     A            PUSCT          2          TEXT('AREA ')
     A            PUSCT2         2          TEXT('SUBURB ')
     A            PUSKY         15          TEXT('KEY ')
     A            PUSQTY         5  0       TEXT('USED')
     A
     A          K PUSDAT
     A          K PUSKY
     A          K PUSCT
     A          K PUSCT2

     *****************************************************************
     ** OBJECT ID: USEDPROD
     ** TEXT:      USED PRODUCTS
     *****************************************************************
     ** MODIFICATIONS:
     ** MOD   SCN    DATE   MODIFICATION SUMMARY
     **
     *****************************************************************

     A          R PUP100                    TEXT('PRODUCT USAGE ')
     A                                      PFILE(USEDPROD)
     A          K PUSKY
     A          K PUSCT
     A          K PUSCT2

     A*
     A* File name   : USEDPRODFM
     A*
     A* Description : Used Product Entry
     A*
     A* Written     :
     A*
     A*==============================================================*
     A* MODIFICATIONS:
     A* MOD   SCN    DATE   MODIFICATION SUMMARY
     A*
     A*
     A*==============================================================*
     A*%%EC
     A                                      DSPSIZ(24 80 *DS3)
     A                                      PRINT
     A                                      CA03(03 'End of job')
     A                                      CA12(12 'Previous')
     A*==============================================================*
     A*
     A*
     A          R R01
     A                                      CF06(06 'Create')
     A*%%TS  SD  20101013  125107   
     A                                      CA07(07 'View')
     A  88                                  CSRLOC(ROW01      COL01)
     A  89        R01MSG        79   M
     A            ROW01          3S 0H
     A            COL01          3S 0H
     A*
     A                                  1  2'USEDPRODFM.01'
     A            CMPNO          3Y 0O  1 13EDTCDE(Z)
     A                                  1 28'USED PRODUCT REPORTING'
     A                                  1 60TIME
     A                                  1 70DATE
     A                                      EDTCDE(Y)
     A                                  2 28'Used Product Entry'
     A                                  5  3'Enter the Date  :'
     A            R01MTH         8Y 0B  5 22EDTCDE(4)
     A                                  5 32'(YYYYMMDD)'
     A                                 24  2'F3=Exit  F6=Maintain PROD  F7=View-
     A                                        F12=Cancel'
     A          R S02                       SFL
     A*%%TS  SD  20101013  130118   
     A            S02OPT         2A  B 10  2
     A            S02PRD        30A  O 10  6
     A            S02QTY         6Y 0O 10 38EDTCDE(Z)
     A            S02CT2         2A  O 10 46
     A            S02CT          2A  H
     A            S02KEY        15A  H
     A*
     A*==============================================================*
     A          R C02                       SFLCTL(S02)
     A                                      CF06(06 'Create')
     A*%%TS  SD  20101013  130118   
     A                                      SFLSIZ(0015)
     A                                      SFLPAG(0014)
     A                                      TEXT('Used Product Entry')
     A                                      OVERLAY
     A  51                                  SFLDSP
     A  52                                  SFLDSPCTL
     A  53                                  SFLCLR
     A  99                                  SFLEND
     A  89        C02MSG        79   M
     A            SRS02          4S 0H      SFLRCDNBR
     A*
     A                                  1  2'USEDPRODFM.02'
     A            CMPNO          3Y 0O  1 13EDTCDE(Z)
     A                                  1 28'USED PRODUCT REPORTING'
     A                                  1 60TIME
     A                                  1 70DATE
     A                                      EDTCDE(Y)
     A                                  2 28'Used Product Entry'
     A                                  4  2'Maintain the Number of Used Produc-
     A                                      ts'
     A                                  5  3'For the Date :'
     A            C02MTH         8Y 0O  5 20EDTCDE(4)
     A                                  6  2'Type options, press Enter'
     A                                  7  2'2=Change '
     A                                  9  2'Act Product                       -
     A                                      Quantity   Area '
     A                                      DSPATR(UL)
     A*==============================================================*
     A          R R02
     A*%%TS  SD  20100512  134524   
     A                                 24  2'F3=Exit  F6=Add   F12=Cancel'
     A*
     A          R R03
     A*%%TS  SD  20101013  134924   
     A                                      CF06(06 'UPDATE')
     A  88                                  CSRLOC(ROW03      COL03)
     A  89        R03MSG        79   M
     A            ROW03          3S 0H
     A            COL03          3S 0H
     A            R03KEY        15A  H
     A            R03CT          2A  H
     A*
     A                                  1  2'USEDPRODFM.03'
     A            CMPNO          3Y 0O  1 13EDTCDE(Z)
     A                                  1 28'USED PRODUCT REPORTING'
     A                                  1 60TIME
     A                                  1 70DATE
     A                                      EDTCDE(Y)
     A                                  2 28'Used Product Entry'
     A                                  5  3'For the Date . .:'
     A            R03MTH         8Y 0O  5 22EDTCDE(4)
     A                                  5 32'(YYYYMMDD)'
     A                                  6  3'PRODUCT    Set .:'
     A            R03PRD        30A  O  6 22
     A                                  8  3'Quantity . . . .:'
     A            R03QTY         6S 0B  8 22
     A                                  9  3'Suburb . . . . .:'
     A            R03CT2         2A  B  9 22
     A                                 24  2'F3=Exit   F6=Accept   F12=Cancel'
     A          R R04
     A*%%TS  SD  20101013  155830   
     A                                      CF04(04 'lookup')
     A                                      CF06(06 'UPDATE')
     A  88                                  CSRLOC(ROW04      COL04)
     A  89        R04MSG        79   M
     A            ROW04          3S 0H
     A            COL04          3S 0H
     A            R04CT          2A  H
     A*
     A                                  1  2'USEDPRODFM.04'
     A            CMPNO          3Y 0O  1 13EDTCDE(Z)
     A                                  1 28'USED PRODUCT REPORTING'
     A                                  1 60TIME
     A                                  1 70DATE
     A                                      EDTCDE(Y)
     A                                  2 28'Used Product Entry'
     A                                  5  3'For the Date . .:'
     A            R04MTH         8Y 0O  5 22EDTCDE(4)
     A                                  5 32'(YYYYMMDD)'
     A                                  6  3'PRODUCT    Set .:'
     A            R04KEY        15   B  6 22
     A            R04PRD        30A  O  6 42
     A                                  8  3'Quantity . . . .:'
     A            R04QTY         6S 0B  8 22
     A                                  9  3'Suburb . . . . .:'
     A            R04CT2         2A  B  9 22VALUES('  ' 'HK')
     A                                 24  2'F3=Exit  F4=Lookup  -
     A                                      F6=Accept  F12=Cancel'
     A**************
     A          R S05                       SFL
     A*%%TS  SD  20101013  134924   
     A            S05MTH        10A  O  8  2
     A            S05KEY        15   O  8 13
     A            S05PRD        30A  O  8 29
     A            S05CT2         2   O  8 60
     A            S05QTY         6Y 0O  8 63EDTCDE(Z)
     A*
     A*==============================================================*
     A          R C05                       SFLCTL(S05)
     A*%%TS  SD  20101014  102330   
     A                                      SFLSIZ(0014)
     A                                      SFLPAG(0014)
     A                                      TEXT('Used Product Entry')
     A                                      OVERLAY
     A  51                                  SFLDSP
     A  52                                  SFLDSPCTL
     A                                      ROLLUP(61)
     A                                      ROLLDOWN(62)
     A  53                                  SFLCLR
     A  99                                  SFLEND(*MORE)
     A  89        C05MSG        79   M
     A            SRS05          4S 0H      SFLRCDNBR
     A*
     A                                  1  2'USEDPRODFM.05'
     A            CMPNO          3Y 0O  1 13EDTCDE(Z)
     A                                  1 28'USED PRODUCT REPORTING'
     A                                  1 60TIME
     A                                  1 70DATE
     A                                      EDTCDE(Y)
     A                                  2 28'Used Product '
     A                                  4  2'View the  Used Products  '
     A            C05MTH        10   B  6  2
     A                                  7 14'Product                           -
     A                                              Suburb Quantity'
     A*==============================================================*
     A          R R05
     A*%%TS  SD  20100512  134524   
     A                                 24  2'F3=Exit               F12=Cancel'
     A          R S06                       SFL
     A*%%TS  SD  20101013  171041   
     A            S06OPT         2A  B 10  2
     A            S06KEY        15A  O 10  6
     A            S06PRD        30A  O 10 23
     A*==============================================================*
     A          R C06                       SFLCTL(S06)
     A                                      CF06(06 'Create')
     A*%%TS  SD  20101013  134924   
     A                                      SFLSIZ(0015)
     A                                      SFLPAG(0014)
     A                                      TEXT('Used Product Entry')
     A                                      OVERLAY
     A  51                                  SFLDSP
     A  52                                  SFLDSPCTL
     A  53                                  SFLCLR
     A  99                                  SFLEND
     A  89        C06MSG        79   M
     A            SRS06          4S 0H      SFLRCDNBR
     A                                  1  2'USEDPRODFM.06'
     A            CMPNO          3Y 0O  1 13EDTCDE(Z)
     A                                  1 28'USED PRODUCT REPORTING'
     A                                  1 60TIME
     A                                  1 70DATE
     A                                      EDTCDE(Y)
     A                                  2 28'Used Product Entry'
     A                                  4  2'Maintain PRODUCTS       '
     A                                  6  2'Type options, press Enter'
     A                                  7  2'4=Delete'
     A                                  9  2'Act Product       '
     A                                      DSPATR(UL)
     A          R R06
     A*%%TS  SD  20101013  134924   
     A                                 24  2'F3=Exit  F6=Create  F12=Cancel'
     A          R R07
     A*%%TS  SD  20101013  173309   
     A                                      CF06(06 'UPDATE')
     A  88                                  CSRLOC(ROW07      COL07)
     A  89        R07MSG        79   M
     A            ROW07          3S 0H
     A            COL07          3S 0H
     A*
     A                                  1  2'USEDPRODFM.07'
     A            CMPNO          3Y 0O  1 13EDTCDE(Z)
     A                                  1 28'USED PRODUCT REPORTING'
     A                                  1 60TIME
     A                                  1 70DATE
     A                                      EDTCDE(Y)
     A                                  2 28'Used Product Entry'
     A                                  5  3'Product Code   .:'
     A            R07KEY        15A  B  5 25
     A                                  6  3'Description    .:'
     A            R07PRD        30A  B  6 25
     A                                 24  2'F3=Exit  F6=Accept   F1-
     A                                      2=Cancel'
     A          R S08                       SFL
     A*%%TS  SD  20101013  172031   
     A            S08OPT         2A  B  7  4
     A            S08KEY        15A  O  7  8
     A            S08PRD        30A  O  7 25
     A*==============================================================*
     A          R C08                       SFLCTL(S08)
     A*%%TS  SD  20101013  172031   
     A                                      WINDOW(7 8 14 60)
     A                                      WDWBORDER((*COLOR TRQ) +
     A                                      (*DSPATR RI))
     A                                      WDWTITLE((*TEXT ' PRDUCT+
     A                                      S         ') +
     A                                      (*COLOR BLU))
     A                                      SFLSIZ(0015)
     A                                      SFLPAG(0007)
     A                                      TEXT('Used Product Entry')
     A                                      OVERLAY
     A  51                                  SFLDSP
     A  52                                  SFLDSPCTL
     A  53                                  SFLCLR
     A  99                                  SFLEND
     A  89        C08MSG        79   M
     A            SRS08          4S 0H      SFLRCDNBR
     A*
     A                                  1  2'USEDPRODFM.08'
     A            CMPNO          3Y 0O  1 13EDTCDE(Z)
     A                                  1 17'USED PRODUCT REPORTING'
     A                                  1 38DATE
     A                                      EDTCDE(Y)
     A                                  2 17'Used Product '
     A                                  2 38TIME
     A                                  3  4'Select the Product'
     A                                  4  5'1=Select'
     A            C08KEY        15A  B  5  8
     A                                  6  8' Product       '
   
     A          R S09                       SFL
     A*%%TS  SD  
     A            S09KEY        15A  O  8  4
     A            S09PRD        30A  O  8 20
     A*
     A*==============================================================*
     A          R C09                       SFLCTL(S09)
     A*%%TS  SD  
     A                                      SFLSIZ(0015)
     A                                      SFLPAG(0014)
     A                                      TEXT('Used Product Entry')
     A                                      OVERLAY
     A  51                                  SFLDSP
     A  52                                  SFLDSPCTL
     A  53                                  SFLCLR
     A  99                                  SFLEND
     A  89        C09MSG        79   M
     A            SRS09          4S 0H      SFLRCDNBR
     A*
     A                                  1  2'USEDPRODFM.09'
     A            CMPNO          3Y 0O  1 13EDTCDE(Z)
     A                                  1 28'USED PRODUCT REPORTING'
     A                                  1 60TIME
     A                                  1 70DATE
     A                                      EDTCDE(Y)
     A                                  2 28'Used Product '
     A                                  7  6'Product        '
     A                                  4  3'Used Product selected for delet-
     A                                      ion.'
     A                                  5  3'Press ENTER to DELETE or F12 to ca-
     A                                      ncel deletion.'
     A*==============================================================*
     A          R R09
     A*%%TS  SD  20100512  134524   
     A                                 24  2'F3=Exit               F12=Cancel'