**free
// ==================================================================
// Use the DATEADJ command to invoke this program.
// Logic to add or subtract from a date with specified input and
// output formats.
// ==================================================================
// Note: ACTGRP *NEW is specified so that the activation group goes
//       away on return. This ensures that a new job date in
//       an interactive session is picked up.
//       Yes, some overhead, but I doubt if this will be noticed in
//       most CL programs.
ctl-opt option(*nodebugio: *srcstmt)
  actgrp(*new)
  main(Main);
ctl-opt BndDir('UTIL_BND');
/COPY ../Copy_Mbrs/SRV_MSG_P.RPGLE
dcl-pr getSpecFmts extpgm('DATEADJC');
  jobfmt char(4);
  sysvalfmt char(3);
end-pr;

dcl-proc Main;
  dcl-pi Main;
    piInDate    char(10);
    poOutDate   char(10);
    piAdj       packed(5);
    piAdjType   char(7);
    piInFmt     char(10);
    piOutFmt    char(10);
  end-pi;

  dcl-s wkInDate  like(piInDate);
  dcl-s wkInFmt   like(piInFmt);
  dcl-s wkOutFmt  like(piOutFmt);

  dcl-s JobDateFmt  char(4);
  dcl-s QDatFmt     char(3);

  dcl-s wkDate  date;

  poOutDate ='9999/99/99';

  // === Move input parameters to work variables ====================
  wkInDate = piInDate;
  wkInFmt = piInFmt;
  wkOutFmt =piOutFmt;

  // === Handle special values in and out fmts =======================
  if (piInFmt ='*JOBFMT'
      or piInFmt ='*SYSTEM'
      or piOutFmt = '*JOBFMT'
      or piOutFmt = '*SYSTEM');
    getSpecFmts(JobDateFmt:QDatFmt);
  endif;

  if (piInFmt = '*JOBFMT');
    wkInFmt = JobDateFmt;
  endif;

  if (piInFmt = '*SYSTEM');
    wkInFmt = '*' + QDatFmt;
  endif;

  if (piOutFmt = '*JOBFMT');
    wkOutFmt = JobDateFmt;
  endif;

  if (piOutFmt = '*SYSTEM');
    wkOutFmt = '*' + QDatFmt;
  endif;

  if (piOutFmt = '*INFMT');
    wkOutFmt = wkInFmt;
  endif;

  // === Handle special date values =================================
  if (piInDate = '*SYSTEM');
    wkInDate = %char(%date : *ISO);
    wkInFmt = '*ISO';  // ignore INFMT value
  endif;

  if (piInDate = '*JOBDATE');
    wkInDate =%char(%date(UDATE) :*ISO);
    wkInFmt = '*ISO';  // ignore INFMT value
  endif;

  *inlr = *on;

  // === Do the calculation and return the date =====================
  // wkInfmt & wkOutFmt control conversions.
  monitor;
    wkDate = CvtInDate(wkInDate : wkInFmt);
  on-error;
    badInDate(wkInDate : wkInFmt);
  endmon;

  select;
    when (piAdjType = '*DAYS');
      wkDate = wkDate + %days(piAdj);
    when (piAdjType = '*MONTHS');
      wkDate = wkDate + %months(piAdj);
    when (piAdjType = '*YEARS');
      wkDate = wkDate + %years(piAdj);
    other;
      SndEscMsg('ADJTYPE: '+ piAdjType + ' not supported' :4);
  endsl;

  monitor;
    poOutDate = toOutDate(wkDate : wkOutFmt);
  on-error;
    badOutDate(wkDate : piOutFmt);
  endmon;

  return;
end-proc;

// === Convert the input char string to a date =======================
dcl-proc CvtInDate;
  dcl-pi CvtInDate date;
    inChar  char(10);
    inFmt   char(10);
  end-pi;
  dcl-s outDate   date;
  select;
    when (inFmt = '*YMD');
      outDate = %date(inChar : *YMD);
    when (inFmt = '*MDY');
      outDate = %date(inChar : *MDY);
    when (inFmt = '*DMY');
      outDate = %date(inChar : *DMY);

    when (inFmt = '*YMD0');
      outDate = %date(inChar : *YMD0);
    when (inFmt = '*MDY0');
      outDate = %date(inChar : *MDY0);
    when (inFmt = '*DMY0');
      outDate = %date(inChar : *DMY0);

    when (inFmt = '*CYMD');
      outDate = %date(inChar : *CYMD);
    when (inFmt = '*CMDY');
      outDate = %date(inChar : *CMDY);
    when (inFmt = '*CDMY');
      outDate = %date(inChar : *CDMY);

    when (inFmt = '*CYMD0');
      outDate = %date(inChar : *CYMD0);
    when (inFmt = '*CMDY0');
      outDate = %date(inChar : *CMDY0);
    when (inFmt = '*CDMY0');
      outDate = %date(inChar : *CDMY0);

    when (inFmt = '*ISO');
      outDate = %date(inChar : *ISO);
    when (inFmt = '*ISO0');
      outDate = %date(inChar : *ISO0);

    when (inFmt = '*USA');
      outDate = %date(inChar : *USA);
    when (inFmt = '*USA0');
      outDate = %date(inChar : *USA0);

    when (inFmt = '*EUR');
      outDate = %date(inChar : *EUR);
    when (inFmt = '*EUR0');
      outDate = %date(inChar : *EUR0);

    when (inFmt = '*JIS');
      outDate = %date(inChar : *JIS);
    when (inFmt = '*JIS0');
      outDate = %date(inChar : *JIS0);

    when (inFmt = '*JUL');
      outDate = %date(inChar : *JUL);
    when (inFmt = '*LONGJUL');
      outDate = %date(inChar : *LONGJUL);

    other;    // Should never happen
      SndEscMsg('INFMT; ' + inFmt + ' not supported':4);
  endsl;
  return outDate;
end-proc;

// === Convert date to character =====================================
// Returns input date in format specified
dcl-proc toOutDate;
  dcl-pi toOutDate char(10);
    theDate date;
    outFmt char(10);
  end-pi;
  dcl-s   wkChar char(10);
  select;
    when (outFmt = '*YMD');
      wkChar = %char(theDate : *YMD);
    when (outFmt = '*MDY');
      wkChar = %char(theDate : *MDY);
    when (outFmt = '*DMY');
      wkChar = %char(theDate : *DMY);

    when (outFmt = '*YMD0');
      wkChar = %char(theDate : *YMD0);
    when (outFmt = '*MDY0');
      wkChar = %char(theDate : *MDY0);
    when (outFmt = '*DMY0');
      wkChar = %char(theDate : *DMY0);

    when (outFmt = '*CYMD');
      wkChar = %char(theDate : *CYMD);
    when (outFmt = '*CMDY');
      wkChar = %char(theDate : *CMDY);
    when (outFmt = '*CDMY');
      wkChar = %char(theDate : *CDMY);

    when (outFmt = '*CYMD0');
      wkChar = %char(theDate : *CYMD0);
    when (outFmt = '*CMDY0');
      wkChar = %char(theDate : *CMDY0);
    when (outFmt = '*CDMY0');
      wkChar = %char(theDate : *CDMY0);

    when (outFmt = '*ISO');
      wkChar = %char(theDate : *ISO);
    when (outFmt = '*ISO0');
      wkChar = %char(theDate : *ISO0);

    when (outFmt = '*USA');
      wkChar = %char(theDate : *USA);
    when (outFmt = '*USA0');
      wkChar = %char(theDate : *USA0);

    when (outFmt = '*EUR');
      wkChar = %char(theDate : *EUR);
    when (outFmt = '*EUR0');
      wkChar = %char(theDate : *EUR0);

    when (outFmt = '*JIS');
      wkChar = %char(theDate : *JIS);
    when (outFmt = '*JIS0');
      wkChar = %char(theDate : *JIS0);

    when (outFmt = '*JUL');
      wkChar = %char(theDate : *JUL);
    when (outFmt = '*LONGJUL');
      wkChar = %char(theDate : *LONGJUL);
    other;    // Should never happen
      SndEscMsg('OUTFMT; ' + outFmt + ' not supported':4);
  endsl;
  return wkChar;
end-proc;

// === Crash if input bad ============================================
// Standardizes the message for all input variations
dcl-proc badInDate;
  dcl-pi badInDate;
    theChar  char(10);
    theFmt   char(10);
  end-pi;
  SndEscMsg('Input date "' + %trim(theChar)
              + '" not valid or not compatible with input format "'
              + %trim(theFmt) + '"'
              :4);
end-proc;

// === Crash if incompatible output format ===========================
dcl-proc badOutDate;
  dcl-pi badOutDate;
    theDate date;
    theFmt  char(10);
  end-pi;
  SndEscMsg('Calculated date "' +%char(theDate)
            + '" is not compatible with output format "'
            + %trim(theFmt) + '"'
            :4);
end-proc;