/* rexx */
/* Exec Name:    SORTCNTL                                            */
/* Date Written: 02/25/1999                                          */
/* Author:       Bruce R. Gillispie                                  */
/* Description:  Generate control cards for Sort                     */
/* Notice the adate function, it subtracts "nd" days from today      */
/*
! Disclaimer:
! The "SORTCNTL" utility IS NOT in the Public Domain Freeware Software.
! You may use this utility AT YOUR OWN RISK, it is provided for your
! enjoyment and neither the Author or his Employer provides any 
! warranty for its use.
/*
/*-------------------------------------------------------------------*/
 signal on error                              /* catch all routine   */

 nd = '14'      /* number of days to subtract from today  */

 cntl_recs.1 = "   RECORD TYPE=F                           "
 cntl_recs.2 = "   INCLUDE COND=(39,8,CH,LT,C'"adate(nd)"',"
 cntl_recs.3 = "                 AND,64,1,CH,NE,C'S',      "
 cntl_recs.4 = "                 AND,8,3,CH,NE,C'005')     "
 cntl_recs.5 = "   SORT FIELDS=(39,8,CH,A),STOPAFT=800     "
 cntl_recs.6 = "   OUTREC FIELDS=(17:1,6,                  "
 cntl_recs.7 = "                  24:57X'40')              "

 cntl_recs.0 = "7"                    /* how many sort statements */

 wkname      = "TESTALL.STK.SORTCNTL"; /* output data             */
/*              ....5....+....5....+....5....+....5....+....5.... */

call alloc_wrkfile
call write_cntl_recs
call close_work_file
call free_work_file
exit 00
/*                                                                */
/* call display_job                        used for development   */
/* call delete_work_file                   used for development   */

/* \\\\\\\\\\\\\\\\\\\ called routines below ///////////////////// */

/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
/* Write Sort Control Statement                                      */
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
write_cntl_recs:
 do i = 1 to cntl_recs.0
  queue cntl_recs.i
"execio 1 diskw $TMPFLE$";
 end i
return retcode;

/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
/* Close Work file                                                   */
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
close_work_file:
"execio 0 diskw $TMPFLE$ (FINIS";
return retcode;

/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
/* Free Work file                                                    */
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
free_work_file:
Address 'TSO' 'FREE F($TMPFLE$)'
return retcode;

/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
/* adate Function: Subtract/Add ARG "nd" from todays date...        */
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
adate: procedure expose yyyy mm dd ARG nd
parse value date('S') with yyyy +4 mm +2 dd +2;      /* todays date */
/* --------------------------------------------------------------   */
/* Special thanks to H. D. Knoble for making the Flandern date      */
/* routines available.                                              */
/* H. D. Knoble, hdk@psu.edu                                        */
/* Penn State Center for Academic Computing  - November 1985.       */
/* ---------------------------------------------------------------- */ 
/* Convert calendar date to julian date                             */
/* See CACM 1968 11(10):657, authors: Fliegal and Van Flandern      */
/* ---------------------------------------------------------------- */
jd = dd-32075+1461*(yyyy+4800+(mm-14)%12)%4+367*(mm-2-((mm-14)%12),
     *12)%12-3*((yyyy+4900+(mm-14)%12)%100)%4 ;
/* ---------------------------------------------------------------- */

jd=nd+jd; /* apply plus or minus value "nd" to julian date "jd"*/

/* ---------------------------------------------------------------- */
/* Convert julian date to calender date, as yyyy mm dd              */
/* See CACM 1968 11(10):657, authors: Fliegal and Van Flandern      */
/* ---------------------------------------------------------------- */
v=jd+68569; n=4*v%146097;
v=v-(146097*n+3)%4; yyyy=4000*(v+1)%1461001;
v=v-1461*yyyy%4+31; mm=80*v%2447; dd=v-2447*mm%80;
v=mm%11; mm=mm+2-12*v; yyyy=100*(n-49)+yyyy+v;
/* ---------------------------------------------------------------- */

if mm <10 then mm=0||mm;              /* add leading zero if needed */
if dd <10 then dd=0||dd;              /* add leading zero if needed */

return yyyy||mm||dd;                  /* return in Standard format  */


/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
/*  Allocate Work file                                               */
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
alloc_wrkfile:
  Address 'TSO'
    "ALLOC NEW CAT F($TMPFLE$) DSO(PS) SP(1,1) CYL "||,
    "DA('" || wkname || "') REUSE "||,
    "RECFM(F) BLKSIZE(0) LRECL(80) UNIT(SYSALLDA)";
 retcode = rc;                             /* Save the return code    */
 if retcode <> 0                           /* Did it work ??          */
    then do;                               /*     no, tell them       */
            Say "Allocation failed with rc=" retcode;
            Say "For the Temp Work File";
            exit 888
            return retcode;
            end;

return retcode;

/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
/* Display Job using Library Services                                */
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
display_job:
"ISPEXEC LMINIT DATAID(LMID) DDNAME($TMPFLE$)"
"ISPEXEC browse DATAID(&LMID)"
"ISPEXEC LMFREE DATAID(&LMID)"
return retcode;

/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
/* Free and Delete Work file                                         */
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
delete_work_file:
Address 'TSO' 'FREE F($TMPFLE$) DELETE'
return retcode;

/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
/* Signal On Error Routine                                           */
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
error:
say '----------------------------------------------------------- '
say ' The return code from the command on line' SIGL 'is:' RC
say '----------------------------------------------------------- '
call close_work_file
call delete_work_file
exit 13;
return retcode;

/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
/* End of exec...                                                    */
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */