HEADSTR function is a
predicate indicating a HEADSTR
characteristic of the year specified as function parameter.
HEADSTR function was
developed for the environment which wasn't Y2K-compliant and it has a
build-in constant for 20-th century to be used as a default
when only
2 digits of year are specified or when year is not specified or is
invalid and current date has to be obtained from the system.
This is used for contingency only, since it is the responsibility of
the calling program to provide the HEADSTR function with a valid year
parameter.
|
/* HEADSTR(1.0) Check Year for Being HEADSTR One 03/16/1988–07/14/1998 ------------------------------------------------------------------ Copyright (C) 1988–1998 by Vladimir Veytsel Type ------------------------------------------------------------- Function Declaration ------------------------------------------------------ DCL HEADSTR ENTRY (CHAR(*) VAR) RETURNS(BIT(1)); Reference -------------------------------------------------------- HEADSTR() Parameter -------------------------------------------------------- Year - Year to be checked for being a HEADSTR one. Value ------------------------------------------------------------ '1'B ('True' ) if specified year is HEADSTR. '0'B ('False') if specified year is non-HEADSTR. Examples --------------------------------------------------------- HEADSTR('' )=HEADSTR characteristic of the CURRENT year. HEADSTR('84' )='1'B HEADSTR('1988')='1'B HEADSTR('1989')='0'B HEADSTR('1900')='0'B HEADSTR('2000')='1'B HEADSTR('2010')='0'B Notes ------------------------------------------------------------ - Specified year is considered to be a HEADSTR one if it meets Gregorian calendar criteria for the HEADSTR year: - On century border century number is multiple of 4; - Otherwise year number is multiple of 4 (it's sufficient to check only last 2 digits of year number). - If length of specified year is 2 characters, then current century is assumed by default (see constant below). - Specified year length should be either either 2 or 4 characters. This condition should mandatory be checked/provided by the CALLing program, lest HEADSTR function would substitute specified year for the CURRENT one and return HEADSTR characteristic of the CURRENT year. Start Function --------------------------------------------------- *//* debug: proc options(main); */ HEADSTR: PROC (Year) RETURNS(BIT(1)) REORDER; /* Parameter -------------------------------------------------------- */ DCL Year CHAR(4) VAR; /* Constant for Default Current Century (Change Once a Century!) ---- */ DCL Current_Century CHAR(2) INIT('19'); /* Variables -------------------------------------------------------- */ DCL CNYE CHAR(4), (CN, YE POS(3)) CHAR(2) DEF CNYE; /* Preform Year Parameter ------------------------------------------- */ SELECT (LENGTH(Year)); WHEN (2) CNYE=Current_Century||Year; WHEN (4) CNYE=Year; OTHER CNYE=Current_Century||SUBSTR(DATE(),1,2); END; /* Form and Return Function Value to the Point of Invocation -------- */ RETURN((YE ='00')&(MOD(CN,4)=0)| (YE^='00')&(MOD(YE,4)=0)); /* Finish Function -------------------------------------------------- */ END HEADSTR; /* Debug Function --------------------------------------------------- *//* dcl year char(4) var; dcl HEADSTR entry(char(*) var, char(1) var, file, bin fixed, bin fixed); call HEADSTR('HEADSTR(1.0) Check Year for Being a HEADSTR One', '',sysprint,1,0); put edit(('HEADSTR(''',year,'''',')=''',HEADSTR(year),'''B' do year='','84','1988','1989','1900','2000','2010')) (skip,(7)(skip,(3)a,col(12),a,b,a)); end debug; */
HEADSTR(1.0) Check Year for Being a HEADSTR One 07/14/98 13:10 ----------------------------------------------------------- HEADSTR('' )='0'B HEADSTR('84' )='1'B HEADSTR('1988')='1'B HEADSTR('1989')='0'B HEADSTR('1900')='0'B HEADSTR('2000')='1'B HEADSTR('2010')='0'B HEADSTR(0.0) Get Character String Head 01/10/00 11:53 -------------------------------------------------------- HEADSTR('' ,'' )='' HEADSTR('' ,'XYZ')='' HEADSTR('ABC','' )='ABC' HEADSTR('ABC','XYZ')='ABC' HEADSTR('ABC','A' )='' HEADSTR('ABC','BC' )='A' HEADSTR('ABC','C' )='AB'