Second Look: IBM RDi Extract Procedure Refactoring feature

By NickLitten

February 12, 2020

extract, RDi, Refactoring

Lets start with a reasonably mixed RPGLE code example which is older style column based RPG400 for its variable definitions but then uplifts to RPGLE /FREE for its body code:

 h dftactgrp(*no) actgrp(*caller) expropts(*resdecpos)
 h datfmt(*iso) timfmt(*iso) option(*nodebugio) debug
   //===============================================================
   //
   // application   :  Book To Bill.
   //
   // program id    :  BTB010R
   //
   // title         :  Book to Bill Selection.
   //
   // author        :  toby schofield (www.3psc.net)
    //
   // date          :  02/12/2019
   //
   // version       :  v 1.0
   //
   // modifications
   // mark         by           date
   //
   //===============================================================
 fBTB010D   cf   e             workstn infds(infds) infsr(*pssr)
   // Fiscal Calendar.
 fGPML01    if   e           k disk    infsr(*PSSR) usropn
   //===============================================================
   // Like Record Formats
   //===============================================================
 d IPG100PM_i      ds                  LikeRec(IPG100PM :*input )
   //===============================================================
   // define *entry plist parms
 d EntryPList      PR                  Extpgm('BTB010R')
 d sParmFunctionKey...
 d                                3A
   //===============================================================
 d EntryPlist      Pi
 d sParmFunctionKey...
 d                                3A
   //===============================================================
   // define indicators
 d IndicatorPtr    s               *   inz(%addr(*IN))
 d                 ds                  based(IndicatorPtr)
   // variable definition
 d lError          s              1n   inz('0')
 d sFunction       s             10    inz(*blanks)
 d  Space          s              1A   inz(' ')
 d  Comma          s              1A   inz(',')
 d sSdatdsSave     s                   inz(*blanks) like(sSdatds)
 d sEdatdsSave     s                   inz(*blanks) like(sEdatds)
 d nAmthdsSave     s                   inz(0)       like(nAmthds)

   //===============================================================
   // Define LDA Variables
   //===============================================================
 d lda            uds                  dtaara(*lda)
 d  nS6DateParm            1      6  0
 d  nE6DateParm            7     12  0
 d  nR6DateParm           13     18  0
 d  sMessageParm...
 d                        50    250
   //===============================================================
   // Date Conversion Variables.
   //===============================================================
 d nYears          s              2  0 inz(28)
 d nCompany        s              2  0 inz(10)
 d dCurrent        s               d
 d sCurrentDate    s             10    inz(*blanks)
 d sCurrentYear    s              2    inz(*blanks)
 d nCurrentYear    s              2  0 inz(0)
 d nC6Date         s              6  0 inz(0)
 d dStart          s               d
 d dEnd            s               d
 d dRep            s               d
 d dFiscalStart    S               d
 d dFiscalEnd      S               d
   //===============================================================
   // command keys
 d Cmd01           c                   const(x'31')                         Cmd-1
 d Cmd02           c                   const(x'32')                         Cmd-2
 d Cmd03           C                   const(x'33')                         Cmd-3
 d Cmd04           c                   const(x'34')                         Cmd-4
 d Cmd05           c                   const(x'35')                         Cmd-5
 d Cmd06           c                   const(x'36')                         Cmd-6
 d Cmd07           c                   const(x'37')                         Cmd-7
 d Cmd08           c                   const(x'38')                         Cmd-8
 d Cmd09           c                   const(x'39')                         Cmd-9
 d Cmd10           c                   const(x'3A')                         Cmd-10
 d Cmd11           c                   const(x'3B')                         Cmd-11
 d Cmd12           c                   const(x'3C')                         Cmd-12
 d Cmd13           c                   const(x'B1')                         Cmd-13
 d Cmd14           c                   const(x'B2')                         Cmd-14
 d Cmd15           c                   const(x'B3')                         Cmd-15
 d Cmd16           c                   const(x'B4')                         Cmd-16
 d Cmd17           c                   const(x'B5')                         Cmd-17
 d Cmd18           c                   const(x'B6')                         Cmd-18
 d Cmd19           c                   const(x'B7')                         Cmd-19
 d Cmd20           c                   const(x'B8')                         Cmd-20
 d Cmd21           c                   const(x'B9')                         Cmd-21
 d Cmd22           c                   const(x'BA')                         Cmd-22
 d Cmd23           c                   const(x'BB')                         Cmd-23
 d Cmd24           c                   const(x'BC')                         Cmd-24
 d EnterKey        c                   const(x'F1')                         Enter
 d RollUp          c                   const(x'F5')                         Roll Up
 d RollDown        c                   const(x'F4')                         Roll Down
   //===============================================================
 d infds           ds                                                       infds data structure
 d $Choice               369    369
   //===============================================================
 d sds            sds                                                       system DS
 d  $pgmid                 1     10
 d  $wsid                244    253
 d  $user                254    263
   //===============================================================
   // main line
   //===============================================================
  /Free

   Dow sFunction <> 'EXIT';

     Exfmt F01;
     Exsr #Keys;

     If sFunction<>'EXIT';
       Exsr #Validate;
     Endif;

   Enddo;

   *inlr = *on; // --- program termination ---
   //==============================================================
   // # keys process function keys.
   //==============================================================
   Begsr #keys;

     select;

     when $Choice = Cmd03;                      // Exit.
       sFunction = 'EXIT';
       // Set External Function Parameter.
       sParmFunctionKey = 'F03';

     when $Choice = EnterKey;                   // Submit.
       Exsr #Validate;
       If lError = *off;
         Exsr #Submit;
         sFunction='EXIT';
         // Set External Function Parameter.
         sParmFunctionKey = 'ENT';
       Endif;

     when $Choice = Cmd18;                      // Interactive.
       Exsr #Validate;
       If lError = *off;
         Exsr #Submit;
         sFunction='EXIT';
         // Set External Function Parameter.
         sParmFunctionKey = 'F18';
       Endif;

     endsl;

   Endsr;
   //==============================================================
   // # Validate Validate Panel (F03).
   //==============================================================
   Begsr #Validate;

     lError=*off;
     Clear sStatds;

     // dates must be valid.
     monitor;
       dStart = %date(sSdatds:*mdy);
     on-error;
       sStatds ='Start Date Invalid';
       lError=*on;
     endmon;

     monitor;
       dEnd = %date(sEdatds:*mdy);
     on-error;
       sStatds ='End Date Invalid';
       lError=*on;
     endmon;

     If lError=*off;
       // Add Months to Report End Date.
       // Default Start Date + default Months (Report End Date)
       dRep = dStart + %Months(nAmthds);
       sRdatds = %Char(dRep:*mdy/);
     Endif;

     // If Dates are Valid Start must be < End.
     If lError=*off;
       If dEnd<dStart;
         sStatds='End Date Greater Than Start Date';
         lError=*on;
       Endif;
     Endif;

     // if any field has changed - represent before submission.
     If lError=*off;

       If sSdatds <> sSdatdsSave Or
          sEdatds <> sEdatdsSave Or
          nAmthds <> nAmthdsSave;

         sSdatdsSave = sSdatds;
         sEdatdsSave = sEdatds;
         nAmthdsSave = nAmthds;

         lError=*on;

       Endif;

     Endif;


   Endsr;
   //==============================================================
   // # Convert * ISO Date to BPCS Date
   //==============================================================
   Begsr #ISODateToBPCSDate;

     // Start Date Short.

     // subtract 28 Years before Conversion.
     dStart = dStart - %Years(nYears);
     // Convert to 6 Digit Numeric Date.
     nS6DateParm = %Dec(dStart:*ymd);

     // End Date Short.

     // subtract 28 Years before Conversion.
     dEnd = dEnd - %Years(nYears);
     // Convert to 6 Digit Numeric Date.
     nE6DateParm = %Dec(dEnd:*ymd);

     // End Date (Report) Short.

     // subtract 28 Years before Conversion.
     dRep = dRep - %Years(nYears);
     // Convert to 6 Digit Numeric Date.
     nR6DateParm = %Dec(dRep:*ymd);
     // Set up a Header Message for E Mail.
     sMessageParm = (%Trim('Period:') +
     Space +
     %Editc(nFmthds:'4') +
     %Trim(Comma) +
     Space +
     %Trim('Start Date:') +
     Space +
     %Trim(sSdatdsSave) +
     %Trim(Comma) +
     Space +
     %Trim('End Date:') +
     Space +
     %Trim(sEdatdsSave) +
     %Trim(Comma) +
     Space +
     %Trim('End Report Date:') +
     Space +
     %Trim(sRdatds));

   Endsr;
   //==============================================================
   // # FisCalDefaults   Get Fiscal Defaults from Calendar.
   //==============================================================
   Begsr #FisCalDefaults;

     // Use Todays Date to find which month is Current.
     dCurrent = %Date();
     // subtract 28 Years before Conversion.
     dCurrent = dCurrent - %Years(nYears);
     // Place Date in String to retrieve Year.
     sCurrentDate = %Char(dCurrent);
     // Convert to 6 Digit Numeric Date.
     nC6Date = %Dec(dCurrent:*ymd);
     // Get Year and Make Numeric.
     sCurrentYear = %Subst(sCurrentDate:3:2);
     nCurrentYear = %Dec(sCurrentYear:2:0);

     Setll ( nCompany
           : nCurrentYear
           )
     GPML01;

     Reade ( nCompany
           : nCurrentYear
           )
     GPML01 IPG100PM_i;

     Dow Not %Eof(GPML01);
       // Find Calender entry where Current Date Falls between (or on)
       // Period Start/End Dates.
       If  nC6Date >= IPG100PM_i.Pstart
       And nC6Date <= IPG100PM_i.Pend;

         // Get current Month From Fiscal Calendar.
         nFmthds = IPG100PM_i.Period;
         // Start Date.
         dFiscalStart = %date(IPG100PM_i.Pstart:*ymd);
         // ESnd Date.
         dFiscalEnd = %date(IPG100PM_i.Pend:*ymd);

         Leave;

       Endif;

       Reade ( nCompany
             : nCurrentYear
             )
       GPML01 IPG100PM_i;

     Enddo;

     // Add 28 Years to Fiscal Dates.
     dFiscalStart = dFiscalStart + %Years(nYears);
     dFiscalEnd = dFiscalEnd + %Years(nYears);

   Endsr;
   //==============================================================
   // # Submit Submit Dates to Batch Process.
   //==============================================================
   Begsr #Submit;

     // Set Dates to relate to BPCS database.
     Exsr #ISODateToBPCSDate;
     Out LDA;

   Endsr;
   //==============================================================
   // * INZSR Initialization.
   //==============================================================
   Begsr *INZSR;

     // Fiscal Calendar.
     If Not %Open(GPML01);
       Open GPML01;
     Endif;

     // find Current Month Date Range from Fiscal Calendar
     Exsr #FisCalDefaults;

     // Fiscal Start Date.
     sSdatds = %Char(dFiscalStart:*mdy/);
     sSdatdsSave = sSdatds;
     // Fiscal End Date.
     sEdatds = %Char(dFiscalEnd:*mdy/);
     sEdatdsSave = sEdatds;
     // Default Add Months.
     nAmthds = 6;
     nAmthdsSave = nAmthds;
     // Default todays Date (Start Date)
     // Add Months to Report End Date.
     // Default Fiscal Start Date + default Months (Report End Date)
     dRep = dFiscalStart + %Months(nAmthds);
     sRdatds = %Char(dRep:*mdy/);

   Endsr;
   //==============================================================
   // * PSSR Dump Routine.
   //==============================================================
   Begsr *PSSR;

     Dump;

   Endsr;
  /End-free

Step1 – Run code through the Projex4i Code Moderniser.

The Upgrade RPG Source command (UPGRPGSRC) will clean our code, converting it to fully /FREEFORMAT ILE RPG source. Obviously you can use whichever modernisation tool, or manual technique you wish to get your code uplifted to something like this:

**FREE
ctl-opt dftactgrp(*no) actgrp(*caller) expropts(*resdecpos) datfmt(*iso) timfmt(*iso) option(*nodebugio) debug;

// application   :  Book To Bill.
// program id    :  BTB010R
// title         :  Book to Bill Selection.
// author        :  toby schofield (www.3psc.net)
// date          :  02/12/2019
// version       :  v 1.1
// modifications
// mark         by           date
// None         Nick Litten  2020.02.12

dcl-f BTB010D workstn infds(infds) infsr(*pssr);
// Fiscal Calendar.

dcl-f GPML01 keyed infsr(*pssr) usropn;

dcl-ds IPG100PM_i likerec(ipg100pm :*input );


dcl-pr EntryPList extpgm('BTB010R');
  *n char(3); // sParmFunctionKey
end-pr;

dcl-pi EntryPlist;
  sParmFunctionKey char(3);
end-pi;

// define indicators
dcl-s IndicatorPtr pointer inz(%addr(*in));
dcl-ds *n based(indicatorptr) end-ds;
// variable definition
dcl-s lError ind inz('0');
dcl-s sFunction char(10) inz(*blanks);
dcl-s Space char(1) inz(' ');
dcl-s Comma char(1) inz(',');
dcl-s sSdatdsSave inz(*blanks) like(ssdatds);
dcl-s sEdatdsSave inz(*blanks) like(sedatds);
dcl-s nAmthdsSave inz(0) like(namthds);

// Define LDA Variables
dcl-ds lda dtaara(*auto: *lda);
  nS6DateParm zoned(6) pos(1);
  nE6DateParm zoned(6) pos(7);
  nR6DateParm zoned(6) pos(13);
  sMessageParm char(201) pos(50);
end-ds;

// Date Conversion Variables.
dcl-s nYears packed(2) inz(28);
dcl-s nCompany packed(2) inz(10);
dcl-s dCurrent date;
dcl-s sCurrentDate char(10) inz(*blanks);
dcl-s sCurrentYear char(2) inz(*blanks);
dcl-s nCurrentYear packed(2) inz(0);
dcl-s nC6Date packed(6) inz(0);
dcl-s dStart date;
dcl-s dEnd date;
dcl-s dRep date;
dcl-s dFiscalStart date;
dcl-s dFiscalEnd date;

// command keys
dcl-c Cmd01 const(x'31'); // Cmd-1
dcl-c Cmd02 const(x'32'); // Cmd-2
dcl-c Cmd03 const(x'33'); // Cmd-3
dcl-c Cmd04 const(x'34'); // Cmd-4
dcl-c Cmd05 const(x'35'); // Cmd-5
dcl-c Cmd06 const(x'36'); // Cmd-6
dcl-c Cmd07 const(x'37'); // Cmd-7
dcl-c Cmd08 const(x'38'); // Cmd-8
dcl-c Cmd09 const(x'39'); // Cmd-9
dcl-c Cmd10 const(x'3A'); // Cmd-10
dcl-c Cmd11 const(x'3B'); // Cmd-11
dcl-c Cmd12 const(x'3C'); // Cmd-12
dcl-c Cmd13 const(x'B1'); // Cmd-13
dcl-c Cmd14 const(x'B2'); // Cmd-14
dcl-c Cmd15 const(x'B3'); // Cmd-15
dcl-c Cmd16 const(x'B4'); // Cmd-16
dcl-c Cmd17 const(x'B5'); // Cmd-17
dcl-c Cmd18 const(x'B6'); // Cmd-18
dcl-c Cmd19 const(x'B7'); // Cmd-19
dcl-c Cmd20 const(x'B8'); // Cmd-20
dcl-c Cmd21 const(x'B9'); // Cmd-21
dcl-c Cmd22 const(x'BA'); // Cmd-22
dcl-c Cmd23 const(x'BB'); // Cmd-23
dcl-c Cmd24 const(x'BC'); // Cmd-24
dcl-c EnterKey const(x'F1'); // Enter
dcl-c RollUp const(x'F5'); // Roll Up
dcl-c RollDown const(x'F4'); // Roll Down

dcl-ds infds; // infds data structure
  $Choice char(1) pos(369);
end-ds;

dcl-ds sds PSDS; // system DS
  $pgmid char(10) pos(1);
  $wsid char(10) pos(244);
  $user char(10) pos(254);
end-ds;

// main line

Dow sFunction <> 'EXIT';

  Exfmt F01;
  Exsr #Keys;

  If sFunction<>'EXIT';
    Exsr #Validate;
  Endif;

Enddo;

*inlr = *on; // --- program termination ---


//==============================================================
// # keys process function keys.
//==============================================================
Begsr #keys;

  select;

  when $Choice = Cmd03;                      // Exit.
    sFunction = 'EXIT';
    // Set External Function Parameter.
    sParmFunctionKey = 'F03';

  when $Choice = EnterKey;                   // Submit.
    Exsr #Validate;
    If lError = *off;
      Exsr #Submit;
      sFunction='EXIT';
      // Set External Function Parameter.
      sParmFunctionKey = 'ENT';
    Endif;

  when $Choice = Cmd18;                      // Interactive.
    Exsr #Validate;
    If lError = *off;
      Exsr #Submit;
      sFunction='EXIT';
      // Set External Function Parameter.
      sParmFunctionKey = 'F18';
    Endif;

  endsl;

Endsr;



//==============================================================
// # Validate Validate Panel (F03).
//==============================================================
Begsr #Validate;

  lError=*off;
  Clear sStatds;

  // dates must be valid.
  monitor;
    dStart = %date(sSdatds:*mdy);
  on-error;
    sStatds ='Start Date Invalid';
    lError=*on;
  endmon;

  monitor;
    dEnd = %date(sEdatds:*mdy);
  on-error;
    sStatds ='End Date Invalid';
    lError=*on;
  endmon;

  If lError=*off;
    // Add Months to Report End Date.
    // Default Start Date + default Months (Report End Date)
    dRep = dStart + %Months(nAmthds);
    sRdatds = %Char(dRep:*mdy/);
  Endif;

  // If Dates are Valid Start must be < End.
  If lError=*off;
    If dEnd<dStart;
      sStatds='End Date Greater Than Start Date';
      lError=*on;
    Endif;
  Endif;

  // if any field has changed - represent before submission.
  If lError=*off;

    If sSdatds <> sSdatdsSave Or
       sEdatds <> sEdatdsSave Or
       nAmthds <> nAmthdsSave;

      sSdatdsSave = sSdatds;
      sEdatdsSave = sEdatds;
      nAmthdsSave = nAmthds;

      lError=*on;

    Endif;

  Endif;

Endsr;



//==============================================================
// # Convert * ISO Date to BPCS Date
//==============================================================
Begsr #ISODateToBPCSDate;

  // Start Date Short.

  // subtract 28 Years before Conversion.
  dStart = dStart - %Years(nYears);
  // Convert to 6 Digit Numeric Date.
  nS6DateParm = %Dec(dStart:*ymd);

  // End Date Short.

  // subtract 28 Years before Conversion.
  dEnd = dEnd - %Years(nYears);
  // Convert to 6 Digit Numeric Date.
  nE6DateParm = %Dec(dEnd:*ymd);

  // End Date (Report) Short.

  // subtract 28 Years before Conversion.
  dRep = dRep - %Years(nYears);
  // Convert to 6 Digit Numeric Date.
  nR6DateParm = %Dec(dRep:*ymd);
  // Set up a Header Message for E Mail.
  sMessageParm = (%Trim('Period:') +
  Space +
  %Editc(nFmthds:'4') +
  %Trim(Comma) +
  Space +
  %Trim('Start Date:') +
  Space +
  %Trim(sSdatdsSave) +
  %Trim(Comma) +
  Space +
  %Trim('End Date:') +
  Space +
  %Trim(sEdatdsSave) +
  %Trim(Comma) +
  Space +
  %Trim('End Report Date:') +
  Space +
  %Trim(sRdatds));

Endsr;



//==============================================================
// # FisCalDefaults   Get Fiscal Defaults from Calendar.
//==============================================================
Begsr #FisCalDefaults;

  // Use Todays Date to find which month is Current.
  dCurrent = %Date();
  // subtract 28 Years before Conversion.
  dCurrent = dCurrent - %Years(nYears);
  // Place Date in String to retrieve Year.
  sCurrentDate = %Char(dCurrent);
  // Convert to 6 Digit Numeric Date.
  nC6Date = %Dec(dCurrent:*ymd);
  // Get Year and Make Numeric.
  sCurrentYear = %Subst(sCurrentDate:3:2);
  nCurrentYear = %Dec(sCurrentYear:2:0);

  Setll ( nCompany
        : nCurrentYear
        )
  GPML01;

  Reade ( nCompany
        : nCurrentYear
        )
  GPML01 IPG100PM_i;

  Dow Not %Eof(GPML01);
    // Find Calender entry where Current Date Falls between (or on)
    // Period Start/End Dates.
    If  nC6Date >= IPG100PM_i.Pstart
    And nC6Date <= IPG100PM_i.Pend;

      // Get current Month From Fiscal Calendar.
      nFmthds = IPG100PM_i.Period;
      // Start Date.
      dFiscalStart = %date(IPG100PM_i.Pstart:*ymd);
      // ESnd Date.
      dFiscalEnd = %date(IPG100PM_i.Pend:*ymd);

      Leave;

    Endif;

    Reade ( nCompany
          : nCurrentYear
          )
    GPML01 IPG100PM_i;

  Enddo;

  // Add 28 Years to Fiscal Dates.
  dFiscalStart = dFiscalStart + %Years(nYears);
  dFiscalEnd = dFiscalEnd + %Years(nYears);

Endsr;



//==============================================================
// # Submit Submit Dates to Batch Process.
//==============================================================
Begsr #Submit;

  // Set Dates to relate to BPCS database.
  Exsr #ISODateToBPCSDate;
  Out LDA;

Endsr;



//==============================================================
// * INZSR Initialization.
//==============================================================
Begsr *INZSR;

  // Fiscal Calendar.
  If Not %Open(GPML01);
    Open GPML01;
  Endif;

  // find Current Month Date Range from Fiscal Calendar
  Exsr #FisCalDefaults;

  // Fiscal Start Date.
  sSdatds = %Char(dFiscalStart:*mdy/);
  sSdatdsSave = sSdatds;
  // Fiscal End Date.
  sEdatds = %Char(dFiscalEnd:*mdy/);
  sEdatdsSave = sEdatds;
  // Default Add Months.
  nAmthds = 6;
  nAmthdsSave = nAmthds;
  // Default todays Date (Start Date)
  // Add Months to Report End Date.
  // Default Fiscal Start Date + default Months (Report End Date)
  dRep = dFiscalStart + %Months(nAmthds);
  sRdatds = %Char(dRep:*mdy/);

Endsr;



//==============================================================
// * PSSR Dump Routine.
//==============================================================
Begsr *PSSR;
  Dump;
Endsr;

So, now we have a fully free piece of code lets convert it to sub-procedures because… erm.. we can 🙂

Step2 – IBM RDi Extract Procedure Refactoring

Sadly, this new refactor procedure doesn’t (YET) handle conversion of subroutines into sub-procedures… but… we can select the subroutine body itself and convert to a sub-procedure and then just copy/paste/replace the EXSR statements with the sub-procedure calls instead:

Second Look: IBM RDi Extract Procedure Refactoring feature 1 — Come on IBM… let us do subroutines please 😉

Luckily, we can do it with a little manual copy/pasting. Simples.

Second Look: IBM RDi Extract Procedure Refactoring feature 2 — add the procedure name, description and whether to return a value

This now gives us this subprocedure call:

// Process Function Keys
     funcKeys();

// --------------------------------------------------
// Procedure name: funcKeys
// Purpose:        Process Function Keys
// Returns:        
// --------------------------------------------------
dcl-proc funcKeys;

   // Local fields
 select;
 when $Choice = Cmd03; // Exit.
     sFunction = 'EXIT';
     // Set External Function Parameter.
     sParmFunctionKey = 'F03';
 when $Choice = EnterKey; // Submit.
     Exsr #Validate;
     If lError = *off;
       Exsr #Submit;
       sFunction='EXIT';
       // Set External Function Parameter.
       sParmFunctionKey = 'ENT';
     Endif;
 when $Choice = Cmd18; // Interactive.
     Exsr #Validate;
     If lError = *off;
       Exsr #Submit;
       sFunction='EXIT';
       // Set External Function Parameter.
       sParmFunctionKey = 'F18';
     Endif;
 endsl;

 return;
end-proc;

How cool is that?

So, if I scream through the code, slurping this cup of tepid coffee:

and it finally ends up looking this:

*FREE
 ctl-opt dftactgrp(no) actgrp(caller) expropts(resdecpos)
 datfmt(iso) timfmt(iso) option(*nodebugio) debug;

 // application   :  Book To Bill.
 // program id    :  BTB010R
 // title         :  Book to Bill Selection.
 // author        :  toby schofield (www.3psc.net)
 // date          :  02/12/2019
 // version       :  v 1.2
 // modifications
 // mark         by           date
 // None         Nick Litten  2020.02.12

 dcl-f BTB010D workstn infds(infds) infsr(*pssr);

 // Fiscal Calendar.
 dcl-f GPML01 keyed infsr(*pssr) usropn;
 // Our Program *ENTRY point

 dcl-pi *n;
   sParmFunctionKey char(3);
 end-pi;

 dcl-ds IPG100PM_i likerec(ipg100pm :*input );

 dcl-s IndicatorPtr pointer inz(%addr(*in));
 dcl-ds *n based(indicatorptr) end-ds;
 dcl-s lError ind inz('0');
 dcl-s sFunction char(10) inz(blanks);
 dcl-s Space char(1) inz(' ');
 dcl-s Comma char(1) inz(',');
 dcl-s sSdatdsSave inz(blanks) like(ssdatds);
 dcl-s sEdatdsSave inz(*blanks) like(sedatds);
 dcl-s nAmthdsSave inz(0) like(namthds);

 dcl-ds lda dtaara(*auto: *lda);
   nS6DateParm zoned(6) pos(1);
   nE6DateParm zoned(6) pos(7);
   nR6DateParm zoned(6) pos(13);
   sMessageParm char(201) pos(50);
 end-ds;

 // Date Conversion Variables.
 dcl-s nYears packed(2) inz(28)
 dcl-s nCompany packed(2) inz(10);
 dcl-s dCurrent date;
 dcl-s sCurrentDate char(10) inz(blanks);
 dcl-s sCurrentYear char(2) inz(blanks);
 dcl-s nCurrentYear packed(2) inz(0);
 dcl-s nC6Date packed(6) inz(0);
 dcl-s dStart date;
 dcl-s dEnd date;
 dcl-s dRep date;
 dcl-s dFiscalStart date;
 dcl-s dFiscalEnd date;

 // command keys
 dcl-c Cmd01 const(x'31'); // Cmd-1
 dcl-c Cmd02 const(x'32'); // Cmd-2
 dcl-c Cmd03 const(x'33'); // Cmd-3
 dcl-c Cmd04 const(x'34'); // Cmd-4
 dcl-c Cmd05 const(x'35'); // Cmd-5
 dcl-c Cmd06 const(x'36'); // Cmd-6
 dcl-c Cmd07 const(x'37'); // Cmd-7
 dcl-c Cmd08 const(x'38'); // Cmd-8
 dcl-c Cmd09 const(x'39'); // Cmd-9
 dcl-c Cmd10 const(x'3A'); // Cmd-10
 dcl-c Cmd11 const(x'3B'); // Cmd-11
 dcl-c Cmd12 const(x'3C'); // Cmd-12
 dcl-c Cmd13 const(x'B1'); // Cmd-13
 dcl-c Cmd14 const(x'B2'); // Cmd-14
 dcl-c Cmd15 const(x'B3'); // Cmd-15
 dcl-c Cmd16 const(x'B4'); // Cmd-16
 dcl-c Cmd17 const(x'B5'); // Cmd-17
 dcl-c Cmd18 const(x'B6'); // Cmd-18
 dcl-c Cmd19 const(x'B7'); // Cmd-19
 dcl-c Cmd20 const(x'B8'); // Cmd-20
 dcl-c Cmd21 const(x'B9'); // Cmd-21
 dcl-c Cmd22 const(x'BA'); // Cmd-22
 dcl-c Cmd23 const(x'BB'); // Cmd-23
 dcl-c Cmd24 const(x'BC'); // Cmd-24
 dcl-c EnterKey const(x'F1'); // Enter
 dcl-c RollUp const(x'F5'); // Roll Up
 dcl-c RollDown const(x'F4'); // Roll Down

 dcl-ds infds; // infds data structure
   $Choice char(1) pos(369);
 end-ds;

 dcl-ds sds PSDS; // system DS
   $pgmid char(10) pos(1);
   $wsid char(10) pos(244);
   $user char(10) pos(254);
 end-ds;

 /title ----------------  MAINLINE  ------------------

 // Initialise the Program variables
 initialise();

 Dow sFunction <> 'EXIT';
 Exfmt F01;
   // Process Function Keys
   funcKeys();
 If sFunction<>'EXIT';
     // main code validation
     validate();
   Endif;
 Enddo;

 *inlr = *on; // --- program termination ---

 // --------------------------------------------------
 // * PSSR Dump Routine.
 // --------------------------------------------------
 Begsr *PSSR;
   Dump;
 Endsr;


 // --------------------------------------------------
 // Procedure name: funcKeys
 // Purpose:        Process Function Keys
 // Returns:
 // --------------------------------------------------
 dcl-proc funcKeys;

 select;
 when $Choice = Cmd03; // Exit.
     sFunction = 'EXIT';
     // Set External Function Parameter.
     sParmFunctionKey = 'F03';
 when $Choice = EnterKey; // Submit.
     validate();
     If lError = *off;
       // Submit Submit Dates to Batch Process.
       submit();
       sFunction='EXIT';
       // Set External Function Parameter.
       sParmFunctionKey = 'ENT';
     Endif;
 when $Choice = Cmd18; // Interactive.
     validate();
     If lError = *off;

       // Submit Submit Dates to Batch Process.
       submit();
       sFunction='EXIT';
       // Set External Function Parameter.
       sParmFunctionKey = 'F18';
     Endif;
 endsl;

 return;
 end-proc;


 // --------------------------------------------------
 // Procedure name: validate
 // Purpose:        main code validation
 // Returns:
 // --------------------------------------------------
 dcl-proc validate;
   lError=*off;
   Clear sStatds;

   // dates must be valid.
   monitor;
     dStart = %date(sSdatds:mdy);
   on-error;
     sStatds ='Start Date Invalid';
     lError=on;
   endmon;

   monitor;
     dEnd = %date(sEdatds:mdy);
   on-error;
     sStatds ='End Date Invalid';
     lError=on;
   endmon;

 If lError=off;
     // Add Months to Report End Date.
     // Default Start Date + default Months (Report End Date)
   dRep = dStart + %Months(nAmthds);     sRdatds = %Char(dRep:mdy/);
 Endif;

 // If Dates are Valid Start must be < End.
   If lError=off;     If dEndon;
     Endif;
   Endif;

 // if any field has changed - represent before submission.
   If lError=*off;
 If sSdatds <> sSdatdsSave Or sEdatds <> sEdatdsSave Or nAmthds <> nAmthdsSave;
   sSdatdsSave = sSdatds;
   sEdatdsSave = sEdatds;
   nAmthdsSave = nAmthds;
   lError=*on; Endif;
 Endif;

 return;
 end-proc;


 // --------------------------------------------------
 // Procedure name: convertISOdatetoBPCSDate
 // Purpose:        Start Date Short.
 // Returns:
 // --------------------------------------------------
 dcl-proc convertISOdatetoBPCSDate;

 // Start Date Short.
   // subtract 28 Years before Conversion.
   dStart = dStart - %Years(nYears);
   // Convert to 6 Digit Numeric Date.
   nS6DateParm = %Dec(dStart:*ymd);
 // End Date Short.

 // subtract 28 Years before Conversion.
   dEnd = dEnd - %Years(nYears);
   // Convert to 6 Digit Numeric Date.
   nE6DateParm = %Dec(dEnd:*ymd);
 // End Date (Report) Short.

 // subtract 28 Years before Conversion.
   dRep = dRep - %Years(nYears);

   // Convert to 6 Digit Numeric Date.
   nR6DateParm = %Dec(dRep:*ymd);

   // Set up a Header Message for E Mail.
   sMessageParm = (%Trim('Period:') +
   Space +
   %Editc(nFmthds:'4') +
   %Trim(Comma) +
   Space +
   %Trim('Start Date:') +
   Space +
   %Trim(sSdatdsSave) +
   %Trim(Comma) +
   Space +
   %Trim('End Date:') +
   Space +
   %Trim(sEdatdsSave) +
   %Trim(Comma) +
   Space +
   %Trim('End Report Date:') +
   Space +
   %Trim(sRdatds));

 return;
 end-proc;


 // --------------------------------------------------
 // Procedure name: submit
 // Purpose:        Submit Submit Dates to Batch Process.
 // Returns:
 // --------------------------------------------------
 dcl-proc submit;
   // Set Dates to relate to BPCS database.
   convertISOdatetoBPCSDate();
 Out LDA;
 return;
 end-proc;


 // --------------------------------------------------
 // Procedure name: getFiscalDefaults
 // Purpose:        Get Fiscal Defaults from Calendar.
 // Returns:
 // --------------------------------------------------
 dcl-proc getFiscalDefaults;
   // Use Todays Date to find which month is Current.
   dCurrent = %Date();
   // subtract 28 Years before Conversion.
   dCurrent = dCurrent - %Years(nYears);
   // Place Date in String to retrieve Year.
   sCurrentDate = %Char(dCurrent);
   // Convert to 6 Digit Numeric Date.
   nC6Date = %Dec(dCurrent:*ymd);
   // Get Year and Make Numeric.
   sCurrentYear = %Subst(sCurrentDate:3:2);
   nCurrentYear = %Dec(sCurrentYear:2:0);

 Setll ( nCompany : nCurrentYear ) GPML01;

 Reade ( nCompany : nCurrentYear ) GPML01 IPG100PM_i;

 Dow Not %Eof(GPML01);
     // Find Calender entry where Current Date Falls between (or on)
     // Period Start/End Dates.
   If  nC6Date >= IPG100PM_i.Pstart And nC6Date <= IPG100PM_i.Pend;
     // Get current Month From Fiscal Calendar.
     nFmthds = IPG100PM_i.Period;
     // Start Date.
     dFiscalStart = %date(IPG100PM_i.Pstart:*ymd);
     // ESnd Date.
     dFiscalEnd = %date(IPG100PM_i.Pend:*ymd);
     Leave;
   Endif;
 Reade ( nCompany : nCurrentYear ) GPML01 IPG100PM_i;
 Enddo;

 // Add 28 Years to Fiscal Dates.
   dFiscalStart = dFiscalStart + %Years(nYears);
   dFiscalEnd = dFiscalEnd + %Years(nYears);
 return;
 end-proc;


 // --------------------------------------------------
 // Procedure name: initialise
 // Purpose:        Initialise the Program variables
 // Returns:
 // --------------------------------------------------
 dcl-proc initialise;
   
   // Fiscal Calendar.
   If Not %Open(GPML01);
     Open GPML01;
   Endif;

   // find Current Month Date Range from Fiscal Calendar
   // Get Fiscal Defaults from Calendar.
   getFiscalDefaults();

   // Fiscal Start Date.
   sSdatds = %Char(dFiscalStart:mdy/);
   sSdatdsSave = sSdatds;

   // Fiscal End Date.
   sEdatds = %Char(dFiscalEnd:mdy/);
   sEdatdsSave = sEdatds;

   // Default Add Months.
   nAmthds = 6;
   nAmthdsSave = nAmthds;

   // Default todays Date (Start Date)
   // Add Months to Report End Date.
   // Default Fiscal Start Date + default Months (Report End Date)
   dRep = dFiscalStart + %Months(nAmthds);
   sRdatds = %Char(dRep:*mdy/);

 return;
 end-proc;

I dunno if thats more efficient.

But its definitely nerdily prettier. #thatsaword

Nice Work IBM Rational Developer Nerds 🙂

Of course I could have kept going down the RPG code modernisation rabbit hole with locally defined variables, using SQL for data retrieval, variable length fields, but I had to stop… the coffee was cold.

Share0

Tweet0

Share0

About the Author

IBM i Software Developer, Digital Dad, AS400 Anarchist, RPG Modernizer, Lunatic Libertarian, Technology Cognoscente, Ambassador for Common Sense, and Passionate Eater of Cheese and Biscuits. Nick Litten Dot Com is a mixture of blog posts that can be sometimes serious, frequently playful and probably down-right pointless all in the space of a day.

Join this IBM i community to ask questions and argue with the answers :)

COURSES

Second Look: IBM RDi Extract Procedure Refactoring feature

Second Look: IBM RDi Extract Procedure Refactoring feature

Step1 – Run code through the Projex4i Code Moderniser.

Step2 – IBM RDi Extract Procedure Refactoring

Nice Work IBM Rational Developer Nerds 🙂

The Epic Quest for “RULES.mk” Mastery: A Hero’s Journey with Visual Studio Code and IBM i

Playing with VSCode for IBM i – Modules, ILE and Bound Programs

IBM i Programming – OPM vs ILE FIGHT

IBM i PDM (Programming Development Manager)

Visual Studio Code and the Code for IBM i Extension

IBM i Access for Web

Join the IBM i Community for FREE Presentations, Lessons, Hints and Tips

Second Look: IBM RDi Extract Procedure Refactoring feature

Second Look: IBM RDi Extract Procedure Refactoring feature

Step1 – Run code through the Projex4i Code Moderniser.

Step2 – IBM RDi Extract Procedure Refactoring

Nice Work IBM Rational Developer Nerds 🙂

The Epic Quest for “RULES.mk” Mastery: A Hero’s Journey with Visual Studio Code and IBM i

Playing with VSCode for IBM i – Modules, ILE and Bound Programs

IBM i Programming – OPM vs ILE *FIGHT*

IBM i PDM (Programming Development Manager)

Visual Studio Code and the Code for IBM i Extension

IBM i Access for Web

Join the IBM i Community for FREE Presentations, Lessons, Hints and Tips

IBM i Programming – OPM vs ILE FIGHT