cvtdat

À*====================================================================*
À*   Usage:     To use, move the date you wish to convert into        *
À*              the correct field (eg MOVE ddmmyy to PDDATE)          *
À*              and move the convert from identifier into PDCVTF      *
À*              (for Calendar 'C' which allows YYMM99 to get month    *
À*              end dates, for Julian 'J', for Hundred Year 'H',      *
À*              for *ISO 'I', for YMD 'Y', for MDY 'M' and for DMY    *
À*              use 'D').                                             *
À*              The translate values will then be returned to the     *
À*              calling program as fields:                            *
À*                    PDDATE = 6 Char Date format in                  *
À*                    PDDATH = Hundred Year format                    *
À*                    PDDATJ = Julian format                          *
À*                    PDNAME = Day Name                               *
À*                    PDDSAA = *ISO format (yyyy-mm-dd)               *
À*                    PDDJOB = *JOB format                            *
À*                    PDDAY# = Day Number                             *
À*====================================================================*

h optimize(*full)
 /eject
À*====================================================================
À* Declarations
À*====================================================================
À* Days per month
d pdm             s              2  0 dim(13) ctdata perrcd(13)
À* Day Names
d pdn             s              9    dim(7) ctdata perrcd(7)
À* Work Date in *ISO format (1999-12-31)
d work_iso        s               d   datfmt(*iso)
À* *ISO date with no "real" value
d no_date         s               d   datfmt(*iso) inz(d'0001-01-01')
À* *ISO start date
d startdate       s               d   datfmt(*iso) inz(d'1899-12-31')
À* Day Number
d day#            s              2  0
À* General work Fields
d @p              s              3  0
d work            s              5  0
d work4           s              4  0
À* YMD Date
d dteds           ds
d pdyy                           2  0 overlay(dteds:1)
d pdmm                           2  0 overlay(dteds:3)
d pddd                           2  0 overlay(dteds:5)
À* Program Status Data Structure
d                sds
d @sprgm                  1     10
d @s#prm                 37     39  0
d @splib                 81     90
d @sjnme                244    253
d @sjusr                254    263
d @sjob#                264    269  0
/eject
À*===================================================================
À* Mainline
À*===================================================================
À* Move alpha parms into numeric fields
c                   move      pddate        pddate#           6 0
c                   move      pddatj        pddatj#           5 0
c                   move      pddath        pddath#           5 0
À*===================================================================
À* Establish base date
À*===================================================================
c                   do
À* Process as per convert from mode
c                   select
À*===================================================================
À* Get month end date
À*===================================================================
c                   when      pdcvtf = 'C'
c                   move      pddate#       dteds
c                   if        pdmm >= 1 and pdmm <= 12
c     pdyy          div       4             work4             4 0
c                   mvr                     leap              3 0
c                   if        leap = *zero
c                   eval      pdm(2) = 29
c                   else
c                   eval      pdm(2) = 28
c                   endif
À*===================================================================
À* If day is 99 then get last day of mth
À*===================================================================
c                   if        pddd = 99
c                   eval      pddd = pdm(pdmm)
c                   move      dteds         pddate#
c                   endif
c                   endif
c     *jobrun       test(d)                 pddate#                31
c                   if        *in31
c                   leave
c                   endif
c     *jobrun       move      pddate#       work_iso
À*===================================================================
À*  Process Hundred Year format
À*===================================================================
c                   when      pdcvtf = 'H'
c     startdate     adddur    pddath#:*d    work_iso
À*===================================================================
À*  Test and Process Julian  format
À*===================================================================
c                   when      pdcvtf = 'J'
c     *jul          test(d)                 pddatj#                31
c                   if        *in31
c                   leave
c                   endif
c     *jul          move      pddatj#       work_iso
c                   when      pdcvtf = 'I'
c     *iso          test(d)                 pddsaa                 31
c                   if        *in31
c                   leave
c                   endif
c     *iso          move      pddsaa        work_iso
À*===================================================================
À*  Test and Process YMD  format
À*===================================================================
c                   when      pdcvtf = 'Y'
c     *ymd          test(d)                 pddate#                31
c                   if        *in31
c                   leave
c                   endif
c     *ymd          move      pddate#       work_iso
À*===================================================================
À*  Test and Process MDY  format
À*===================================================================
c                   when      pdcvtf = 'M'
c     *mdy          test(d)                 pddate#                31
c                   if        *in31
c                   leave
c                   endif
c     *mdy          move      pddate#       work_iso
À*===================================================================
À*  Test and Process DMY  format
À*===================================================================
c                   when      pdcvtf = 'D'
c     *dmy          test(d)                 pddate#                31
c                   if        *in31
c                   leave
c                   endif
c     *dmy          move      pddate#       work_iso
c                   endsl
c                   enddo
À*===================================================================
À*  Convert failed.....
À*===================================================================
c                   if        *in31
c                   eval      pddatx = *on
c                   eval      pddate = *all'0'
c                   eval      pddath = *all'0'
c                   eval      pddatj = *all'0'
c                   eval      pdname = *blanks
c                   eval      pdday# = '0'
c                   move      no_date       pddsaa
c                   eval      pddjob = *blanks
c                   return
c                   endif
À*===================================================================
À* Move work date to return date
À*===================================================================
c                   if        work_iso = no_date
c                   eval      pddate = '000000'
c                   eval      pddath = '00000'
c                   eval      pddatj = '00000'
c                   eval      pdname = *blank
c                   eval      pdday# = '0'
c                   move      work_iso      pddsaa
c                   if        @s#prm > 9
c                   eval      pddjob = *blank
c                   endif
c                   return
c                   endif
c                   test                    work_iso               31
     c                   if        *in31
     c                   eval      pddatx = *on
     c                   eval      pddate = *all'0'
     c                   eval      pddath = *all'0'
     c                   eval      pddatj = *all'0'
     c                   eval      pdname = *blanks
     c                   eval      pdday# = '0'
     c                   move      no_date       pddsaa
     c                   eval      pddjob = *blanks
     c                   return
     c                   endif
     c                   extrct    work_iso:*y   work_year         4 0
     c                   if        (work_year < 1940) or (work_year > 2039)
     c                   eval      pddatx = *on
     c                   return
     c                   endif
     À*===================================================================
     À*  Convert passed - Fill return parms
     À*===================================================================
     c     *jobrun       move      work_iso      pddate#
     c     *jul          move      work_iso      pddatj#
     c     *iso          move      work_iso      pddsaa
     c                   if        @s#prm > 9
     c     *jobrun       move      work_iso      pddjob
     c                   endif
     c                   move      pddate#       pddate
     c                   move      pddatj#       pddatj
     c     pdcvtf        ifne      'H'
     c     work_iso      subdur    startdate     pddath#:*d
     c                   move      pddath#       pddath
     c                   endif
     À*===================================================================
     À* Find day of the week
     À*===================================================================
     c     pddath#       div       7             work
     c                   mvr                     @p
     c                   eval      day# = @p + 1
     c                   eval      pdname = pdn(day#)
     c                   move      day#          pdday#
     À*
     c                   return
      /eject
     À*=============================================================
     À* Subroutines
     À*=============================================================
     c     *inzsr        begsr
     c     *entry        plist
     c                   parm                    pstop             1
     c                   parm                    pddate            6
     c                   parm                    pddath            5
     c                   parm                    pddatj            5
     c                   parm                    pdname            9
     c                   parm                    pdday#            1
     c                   parm                    pdcvtf            1
     c                   parm                    pddatx            1
     c                   parm                    pddsaa           10
     c                   parm                    pddjob           10
     c                   eval      pddatx = *off
     c                   eval      pdname = *blank
     c                   eval      *in31  = *off
     c                   if        (@s#prm = *zero) or (pstop = *on)
     c                   eval      *Inlr = *on
     c                   return
     c                   endif
     c                   endsr
     À*===================================================================
      /eject
**CTDATA pdm
31283130313031313031303101
**CTDATA pdn
Sunday   Monday   Tuesday  WednesdayThursday Friday   Saturday

Posted on