Sample LE/date functions from CLPLE

Sample LE/date functions from CLPLE

mehmet akif bulut
06 Feb 2002, (found on Search400.com)

Calculate functions:

A- Give between two date differences
B- Compute day of week
C- Date accumulator from beginning date

You can call this routine from any of your applications.

SAYDAYS.CLPLE

/**************************************/
/* SAYDAYS CLP/LE MAB13               */
/* USAGE:                             */
/*                                    */
/*  FORMAT 1: Between two date diff.  */
/*      SAYDAYS DATE1 DATE2 1         */
/*                                    */
/*  FORMAT 2: Compute day of week     */
/*      SAYDAYS DATE 2                */
/*                                    */
/*  FORMAT 3: Date accum. from spec. date */
/*      SAYDAYS DATE NUM 3            */
/*                                    */
/**************************************/

  PGM PARM(&FIRSTDATE &LASTDATE &RTNVAL)
  DCL  &BLANK     *CHAR  LEN(6)
  DCL  &FIRSTDATE *CHAR  LEN(6)
  DCL  &LASTDATE  *CHAR  LEN(6)
  DCL  &RTNVAL1   *CHAR  LEN(4)
  DCL  &RTNVAL2   *CHAR  LEN(4)
  DCL  &RTNVAL3   *DEC   LEN(10)
  DCL  &PICSTR    *CHAR  LEN(6)  VALUE(DDMMYY)
  DCL  &RTNVAL    *CHAR  LEN(10)

  IF (&RTNVAL *EQ '0000000001') GOTO CMDLBL(DATEDIFF)
  IF (&RTNVAL *EQ '0000000002') GOTO CMDLBL(DAYOFWEEK)
  IF (&RTNVAL *EQ '0000000003') GOTO CMDLBL(DATEACCUM)
  CHGVAR VAR(&RTNVAL) VALUE(-1)
  GOTO CMDLBL(EXIT)

/**************************************/
/* TWO DATE DIFFERENCES                          */
/*************************************/
  DATEDIFF:
  CHGVAR VAR(&RTNVAL) VALUE(-1)
  IF (&FIRSTDATE *EQ &BLANK) GOTO CMDLBL(EXIT)
  IF (&LASTDATE  *EQ &BLANK) GOTO CMDLBL(EXIT)

  CALLPRC  PRC(CEEDAYS) PARM(&FIRSTDATE &PICSTR &RTNVAL1 *OMIT)
  CALLPRC  PRC(CEEDAYS) PARM(&LASTDATE &PICSTR &RTNVAL2 *OMIT)
  CHGVAR VAR(&RTNVAL3) VALUE(%BIN(&RTNVAL1) - %BIN(&RTNVAL2) + 1)
  IF (&RTNVAL3 *LT 0) CHGVAR &RTNVAL3 VALUE(&RTNVAL3 * -1)
  CHGVAR VAR(&RTNVAL) VALUE(&RTNVAL3)

  GOTO CMDLBL(EXIT)

/**************************************/
/* DAY OF WEEK SUBROUTINE                           */
/**************************************/
  DAYOFWEEK:
  CALLPRC  PRC(CEEDAYS) PARM(&FIRSTDATE &PICSTR &RTNVAL1 *OMIT)
  CALLPRC  PRC(CEEDYWK) PARM(&RTNVAL1 &RTNVAL2 *OMIT)
  CHGVAR VAR(%BIN(&RTNVAL2)) VALUE(%BIN(&RTNVAL2) - 1)
  IF (%BIN(&RTNVAL2) *LE 0) CHGVAR VAR(%BIN(&RTNVAL2)) VALUE(7)
  CHGVAR VAR(&RTNVAL) VALUE(%BIN(&RTNVAL2))

  GOTO CMDLBL(EXIT)

/**************************************/
/* DATE ACCUMULATOR                      */
/**************************************/
  DATEACCUM:
  CHGVAR VAR(&RTNVAL) VALUE(-1)
  IF (&FIRSTDATE *EQ &BLANK) GOTO CMDLBL(EXIT)
  IF (&LASTDATE *EQ &BLANK) GOTO CMDLBL(EXIT)
  CALLPRC  PRC(CEEDAYS) PARM(&FIRSTDATE &PICSTR &RTNVAL1 *OMIT)
  CHGVAR %BIN(&RTNVAL2) VALUE(&LASTDATE)
  CHGVAR VAR(%BIN(&RTNVAL1)) VALUE(%BIN(&RTNVAL1) + %BIN(&RTNVAL2))
  CALLPRC  PRC(CEEDATE) PARM(&RTNVAL1 &PICSTR &RTNVAL *OMIT)

  GOTO CMDLBL(EXIT)

  EXIT:
  RETURN
ENDPGM
----------------------------------------
SAYDAYS.CMD

SAYDAYS:   CMD
           PARM  KWD(FIRSTDATE) +
                   TYPE(*CHAR) LEN(6) +
                   PROMPT('FIRST DATE')
           PARM  KWD(LASTDATE) +
                   TYPE(*CHAR) LEN(6) +
                   PROMPT('LAST DATE')
           PARM  KWD(RTNVALUE) +
                   TYPE(*CHAR) LEN(6) +
                   PROMPT('RETURN VALUE') +
                   RTNVAL(*YES)


-----------------------------------

Usage Sample-1: CLP Sample

PGM
DCL &RTNVALUE *CHAR 10
CHGVAR &RTNVALUE 1
SAYDAYS '280601' '250561' &RTNVALUE
SNDMSG MSG(&RTNVALUE) TOUSR(.....)
ENDPGM

[report a broken link by clicking here]