midrange.com -- source code scratchpad

midrange.com code scratchpad
Name:
Jerry C. Adams
Scriptlanguage:
Plain Text
Tabwidth:
Date:
09/21/2009 04:37:38 pm
IP:
Logged
Description:
The user was to lazy to give a description
Code:

         H COPYRIGHT('B&W Wholesale, Inc. 2009')

         H/copy $header

          //*******************************************************************************

          // Written By  :‚Jerry C. Adams                            €                   **

          // Date Written:‚18 September 2009          €                                  **

          // Project No :‚ 01398                      €                                  **

          // Program Name:‚ARQ900                                    €                   **

          // Program Desc: Provides the means by which one may inquire into the log of   **

          //               changes to the customer master table.                         **

          //*******************************************************************************

          // Revised By :‚__________     €Revised Date : ___-__-__                       **

          // Project No :‚____ €                                                         **

          // Reason     :                                                                **

          //*******************************************************************************

     
          //********************

          // FILE DEFINITIONS **

          //********************

     
         FARQ900D   CF   E             WORKSTN SFile(ARQ900B:rrnb)

     
          //*******************

          // DATA STRUCTURES **

          //*******************

     
          // Named Indicators

     
         D P_Indicators    S               *   INZ(%Addr(*IN))

         D  Indicators     DS                  Based(P_Indicators)

         D   SF_Display                        LIKE(*IN) Overlay(Indicators:33)

         D   SF_Clear                          LIKE(*IN) Overlay(Indicators:31)

         D   SF_End                            LIKE(*IN) Overlay(Indicators:90)

         D   Help                              LIKE(*IN) Overlay(Indicators:130)    F1

         D   EOJ                               LIKE(*IN) Overlay(Indicators:132)    F3

         D   Cancel                            LIKE(*IN) Overlay(Indicators:141)    F12

     
         D/Define MsgD

         D/Copy $Msg

     
          //*******************

          // FIELD NAMES     **

          //*******************

     
         D sqlString       S            256a

         D InvalidOption   C                   'GEN9901'

         D CustomerNF      C                   'GEN0003'

         D #Error          S               N

         D BasicSlt        S             71a   INZ('SELECT ARDATE, ARTIME, JOB, CUS+

         D                                     TOMER, BARNAME, AARNAME, FROM ARMAIN+

         D                                     TLOG')

         D #Limit          S                   Like(rrnb)

         D #Key            S                   Like(rrnb)

     
          //*************

          // ProtoTypes *

          //*************

     
         D $BuildList      PR

         D $PutList        PR

         D $StartList      PR

         D $ProcessList    PR

         D $ShowCustomer   PR

     
          //*****************

          // ---CONTROL--- **

          //*****************

     
          /FREE

          

           EXEC SQL

             SET Option

                 Naming  = *Sys,

                 DatFmt  = *ISO,

                 Commit  = *None,

                 UsrPrf  = *Owner;

     
           EXSR $INIT;

           EXSR $MAIN;

           EXSR $EOJ;

     
           //****************************************************************

           // SUBROUTINE - $INIT                                           **

           //    PURPOSE - Program Initialization                          **

           //****************************************************************

     
           BEGSR $INIT;

     
             EXSR  $MINIT;

     
           ENDSR;

     
           //****************************************************************

           // SUBROUTINE - $MAIN                                           **

           //    PURPOSE - Main Program Logic                              **

           //****************************************************************

     
           BEGSR $MAIN;

     
             DOW not eoj;

     
               WRITE MSGSFLB;

               @List   = *Blanks;

               @cust#  = *Zeros;

               EXFMT ARQ900A;

               EXSR  $CMsg;

     
               IF  not eoj;

                 EXSR  $EditA;

                 IF  #error;

                   ITER;

                 ENDIF;

     
                 SELECT;

     
                   WHEN  @List = 'A';

                     sqlString = basicslt  +

                                 ' ORDER BY customer for Read Only';

                   WHEN  @List = 'B';

                     sqlString = basicslt  +

                                 ' ORDER BY aarname, customer for Read Only';

                   OTHER;

                     sqlString = basicslt  +

                                 ' WHERE customer  = :@cust#';

     
                 ENDSL;

     
                 $StartList();

                 $BuildList();

                 $PutList();

                 DOW not cancel

                 AND not eoj;

                   $ProcessList();

                 ENDDO;

               ENDIF;

     
             ENDDO;

     
           ENDSR;

     
           //****************************************************************

           // SUBROUTINE - $EditA                                          **

           //    PURPOSE - Validate Panel 'A' options.                     **

           //****************************************************************

     
           BEGSR $EditA;

     
             #error  = *Off;

     
             IF  @list <>  'A'

             AND @list <>  'B'

             AND @list <>  *Blanks

             AND @cust#  = *Zeros;

               @msgId  = InvalidOption;

               #error  = *On;

               EXSR  $SMsg;

             ENDIF;

     
           ENDSR;

     
           //****************************************************************

           // SUBROUTINE - $EOJ                                            **

           //    PURPOSE - End of Program                                  **

           //****************************************************************

     
           BEGSR $EOJ;

     
             *INLR = *On;

             RETURN;

     
           ENDSR;

     
          /end-free

     
         C/Define MsgC

         C/copy $Msg

     
           //****************************************************************

           // Subprocedure - $StartList                                    **

           //    PURPOSE - Clear the subfile for next request.             **

           //****************************************************************

     
         P $StartList      B

     
         D                 PI

     
          /free

     
           rrnb      = *Zeros;

           SF_Clear  = *On;

           WRITE ARQ900BCTL;

           SF_Clear  = *Off;

     
           RETURN;

     
          /end-free

     
         P                 E

     
           //******************************************************************

           // Subprocedure - $BuildList                                       *

           //      Purpose - Load the subfile with the maintenance log        *

           //                records.                                         *

           //******************************************************************

     
         P $BuildList      B

     
         D                 PI

     
          /free

     
           EXEC SQL

             Prepare MySQLStmt from :sqlString;

     
           EXEC  SQL

            Declare CustList Cursor for MySQLStmt;

     
           EXEC SQL

             Open CustList;

     
           DOW 1 = 1;

     
             EXEC SQL

               Fetch Next from CustList

                 INTO :date,:time,:job@,:cust#,:nameBefore,:nameAfter;

     
             IF  sqlState  = '02000'

             OR  sqlCode   < *Zeros;

               EXEC SQL

                 CLOSE CustList;

               LEAVE;

             ENDIF;

     
             @option = *Blanks;

             rrnb   += 1;

             WRITE ARQ900B;

     
           ENDDO;

     
           #Limit = rrnb;

     
           RETURN;

     
          /end-free

     
         P                 E

     
          //*******************************************************************

          // Subprocedure - $PutList                                          *

          //      Purpose -  Display the subfile.                             *

          //*******************************************************************

     
         P $PutList        B

     
         D                 PI

     
          /free

     
           IF  rrnb  = *Zeros;

             SF_Display  = *Off;

           ELSE;

             SF_Display  = *On;

             SF_End      = *On;

             rrnb        = 1;

           ENDIF;

     
           WRITE ARQ900BFK;

           EXFMT ARQ900BCTL;

     
           RETURN;

     
          /end-free

     
         P                 E

     
          //*******************************************************************

          // Subprocedure - $ProcessList                                      *

          //      Purpose - Display the transaction(s) chosen by the user.    *

          //*******************************************************************

     
         P $ProcessList    B

     
         D                 PI

     
          /free

     
           IF  rrnb  > *Zeros;

             FOR #key  = 1 to  #limit;

               CHAIN #key  ARQ900B;

               IF  %found()

               AND @option <>  *Blanks;

                 $ShowCustomer();

                 IF  eoj;

                   LEAVE;

                 ENDIF;

               ENDIF;

             ENDFOR;

           ENDIF;

     
           RETURN;

     
          /end-free

     
         P                 E

     
          //*******************************************************************

          // Subprocedure - $ShowCustomer                                     *

          //      Purpose - Retrieve the transaction selected by the user and *

          //                display it.                                       *

          //*******************************************************************

     
         P $ShowCustomer   B

     
         D                 PI

     
         D @Action         S              1a

     
          /free

     
           EXEC SQL

             SELECT "ACTION",

                    customer,

                    userid,

                    job,

                    ardate,

                    artime,

                    barname,

                    barcons,

                    barsm#,

                    baradr1,

                    baradr2,

                    barcity,

                    barstat,

                    barzip,

                    bartxcd,

                    barcod5,

                    barcod6,

                    aarname,

                    aarcons,

                    aarsm#,

                    aaradr1,

                    aaradr2,

                    aarcity,

                    aarstat,

                    aarzip,

                    aartxcd,

                    aarcod5,

                    aarcod6

               INTO :@action,

                    :cust#,

                    :userid@,

                    :job@,

                    :date@,

                    :time@,

                    :nameb4,

                    :consb4,

                    :routeB4,

                    :street1b4,

                    :street2b4,

                    :cityb4,

                    :stateb4,

                    :zipb4,

                    :tierb4,

                    :wpcb4,

                    :rpcb4,

                    :nameaf,

                    :consaf,

                    :routeaf,

                    :street1af,

                    :street2af,

                    :cityaf,

                    :stateaf,

                    :zipaf,

                    :tieraf,

                    :wpcaf,

                    :rpcaf

               FROM ARMAINTLOG

               WHERE customer = :@cust# and

                     ardate = :date and

                     artime = :time and

                     job = :job@;

     
           SELECT;

     
             WHEN @action = 'A';

               Type = 'Add';

             WHEN @action - 'B';

               Type = 'Chg';

             WHEN @action = 'D';

               Type = 'Dlt';

             OTHER;

               Type = '???';

     
           ENDSL;

     
           EXFMT ARQ900C;

     
           RETURN;

     
          /end-free

     
         P                 E
generated in 0.008s
valid xhtml & css