/* REXX
 |
 | NAME: COPYPROF
 |
 | Author: David Alcock
 |
 | Written: 26-October-1997
 |
 | Purpose: Copy profile members forward to a new profile dataset
 |          This rexx exec is used during upward ISPF migrations.
 |
 |          We identify a profile member as having a signature of
 |          '0044E3C9D9'x or '..TIR:' as the first bytes of the
 |          first line of the member.
 */

arg iprof oprof

if iprof == "" then do
   say "%COPYPROF - Input profile dataset name not given"
   exit 8
   end
if oprof == "" then do
   say "%COPYPROF - Output profile dataset name not given"
   exit 12
   end

/***********************************************************************
* Verify input dataset
***********************************************************************/

x = LISTDSI(iprof)

if x <> 0 then do
   say "%COPYPROF - Error with input profile dataset"
   say sysmsglvl2
   exit 12
   end

iprof_dsname = sysdsname

/***********************************************************************
* Verify output dataset
***********************************************************************/

x = LISTDSI(oprof)

if x <> 0 then do
   say "%COPYPROF - Error with output profile dataset"
   say sysmsglvl2
   exit 12
   end

oprof_dsname = sysdsname

/***********************************************************************
* Get member list of input profile dataset using LISTD and advance
* to the first member name
***********************************************************************/

x = outtrap("IPML.","*")
"LISTD '"iprof_dsname"' MEMBERS"
x = outtrap("off")

do i = 1 to IPML.0
   if IPML.i = "--MEMBERS--" then leave
   end

if i == IPML.0 then do
   say "%COPYPROF - No members in input profile dataset"
   exit 0
   end

/***********************************************************************
* Copy all members that "look" like profile members to output
***********************************************************************/

itime = time()
say "%COPYPROF - Starting copy of profile members"
address TSO
idd = "CPI"random()
odd = "CPO"random()

copycnt = 0
skipcnt = 0
errcnt = 0

do k = i+1 to IPML.0

   member = strip(ipml.k)
   "ALLOCATE FILE("idd") DA('"iprof_dsname"("member")') SHR REUSE"
   "EXECIO 1 DISKR "idd" (FINIS STEM imember."

   if substr(imember.1,1,5) == '0044E3C9D9'x then do

      pjul = substr(imember.1,45,3)
      ajul = c2x(pjul)       /* yycccF - a binary string */
      yy = substr(ajul,1,2)
      ddd = substr(ajul,3,3)
      if yy < 65 then cc = "20"
      else cc = "19"
      gdate = jul2greg(cc||yy||ddd)

      /*
       | You could put a check here and skip copies of members
       | that are over a year or two old like this untested code:
       |
       | if substr(gdate,1,4) < "1995" then do
       |    address TSO "FREE FILE("idd")"
       |    iterate
       |    end
       */


      "ALLOCATE FILE("odd") DA('"oprof_dsname"("member")') SHR REUSE"

      x = outtrap("REP.","*")
      "REPRO INFILE("idd") OUTFILE("odd")"
      rrc = rc
      x = outtrap("off")

      if rrc == 0 then do
         say "%COPYPROF - Copy of member "left(member,8)" successful" ,
             "- Last used:" gdate
         copycnt = copycnt + 1
         end
      else do
           say "%COPYPROF - Copy of profile member" member " failed"
           errcnt = errcnt + 1
           end
      address TSO "FREE FILE("odd")"
      end
   else skipcnt = skipcnt + 1

   address TSO "FREE FILE("idd")"
   end

say " "
say "%COPYPROF - Summary of results of profile member copies:"
say "          > Started--------------"itime
say "          > Profiles copied------"copycnt
say "          > Profiles w/errors----"errcnt
say "          > Members skipped------"skipcnt
say "          > Ended----------------"time()
exit

/*---------------------------------------------------------------------
 | Name:         JUL2GREG EXEC
 | Purpose:      Given an input julian date, convert to gregorian
 | Author:       Miklos Szigetvari (adapted from his REXX exec)
 | Usage:        In REXX:  gdate = jul2greg('1996201')
 |               Example:  say jul2greg('1996211')
 ------------------------------------------------------------------- */
JUL2GREG:
parse arg ijul
if length(ijul) <> 7 then return 0
if verify(ijul,"0123456789") > 0 then return 0 /* invalid input */

parse var ijul ccyy 5 ddd

if (ccyy // 4 = 0 & ccyy // 100 <> 0) | ccyy // 400 = 0 then ,
   if ddd < 1 | ddd > 366 then return 0 /* Invalid date 1..366 */
   else nop
else if ddd < 1 | ddd > 365 then return 0 /* Invalid date 1..365 */
     else nop
/*
*** Algorithm by R A Stone
*/
if ccyy//4 = 0 then a = 1
else a = 0
if ddd > 59 then h = 1
else h = 0
if (a+h) > 0 then b = (2-a)
else b = 0
c = ddd + b + 91
m = c * 100 % 3055
t =  c - (3055 * m % 100)
m = m - 2
/*
*** Adjust result and pass back to calling routine
*/
t = right(t,2,'0')
m = right(m,2,'0')
return ccyy"-"m"-"t