* Programme de Service v1
* Fonctions de date
Hnomain
Hdatfmt(*iso)
DT99 * renvoie une Date
* parm1 Num 8 0 || 991130 1091129 20080223 0 *omit ||
* parm2 Alpha 10 || rien ' ' *omit '1101231' '17890714' ||
* parm3 Alpha 5 (*iso,*eur,*usa,*cymd,*ymd,*cdmy,*dmy,*cmdy,*mdy)
*
/copy sources,dt99k
Pdt99 b export
Ddt99 pi d
Dn80x 8 0 const options(*nopass:*omit)
Da10x 10 const options(*nopass:*omit)
Dfmtx 5 const options(*nopass:*omit)
* Message d'escape
Ddt99c pr extproc('DT99C')
D parm1 512 const
* Zones de travail correspondant au paramètres
Dretw s like(dt99)
Dn80w s like(n80x)
Da10w s like(a10x)
Dfmtw s like(fmtx) inz('*cymd')
Derrfmtw s n
/free
// Si transmis les parametres sont affectés.
if %parms >= 1 and
%addr(n80x) <> *null;
n80w = n80x;
endif;
if %parms >= 2 and
%addr(a10x) <> *null;
a10w = a10x;
endif;
if %parms >= 3 and
%addr(fmtx) <> *null;
fmtw = fmtx;
endif;
// Numérique ou alpha, mais pas les deux !
if n80w <> 0 and a10w <> *blanks;
callp dt99c('Numérique ou Alpha, mais pas les deux : ' +
%editc(n80w:'X') + ' ' + a10w + ' !'); // Erreur, escape
endif;
// Si blank ou des zéro :
if n80w = 0 and
(a10w = *blanks or
(%check(' 0':a10w) = 0));
return *loval; // Retour *loval 0001-01-01
endif;
monitor;
// Les éventuels séparateurs de date sont enlevé.
// Convertion en numérique
if a10W <> *blanks;
n80w = %dec(%xlate('/-_.,:;':' ':a10w):8:0);
endif;
// Traitement des 999999
if (fmtw = '*cymd' or fmtw = '*cdmy' or fmtw = '*cmdy' or
fmtw = '*ymd ' or fmtw = '*dmy ' or fmtw = 'cmdy ') and
(n80w = 999999 or n80w = 1999999);
return *hival; // Retour *hival 9999-12-31
endif;
// Conversion en date
select;
when fmtw = '*cymd';
retw = %date(n80W:*cymd);
when fmtw = '*ymd ';
retw = %date(n80W:*ymd);
when fmtw = '*cdmy';
retw = %date(n80W:*cdmy);
when fmtw = '*dmy ';
retw = %date(n80W:*dmy);
when fmtw = '*cmdy';
retw = %date(n80W:*cmdy);
when fmtw = '*mdy ';
retw = %date(n80W:*mdy);
when fmtw = '*iso ';
retw = %date(n80W:*iso);
when fmtw = '*eur ';
retw = %date(n80W:*eur);
when fmtw = '*usa ';
retw = %date(n80W:*usa);
other;
errfmtw = *on; // Le format doit être valide !
endsl;
on-error;
retw = d'0001-01-02'; // Date invalide (par convention)
endmon;
if errfmtw; // Erreur, escape
callp dt99c('Format d''appel inconnu : ' +
fmtw + ' !');
endif;
return retw; // Retour d'une date
/end-free
P e
// Pour être appelable par une fonctions Sql,
// no more paramètres facultatifs.
// Entrée numérique, format par défaut.
Pdt99n b export
Ddt99n pi d
Dn80x 8 0 const
/free
return dt99(n80x);
/end-free
P e
// Entrée alpha, format par défaut.
Pdt99a b export
Ddt99a pi d
Da10x 10 const varying
Da10w s like(a10x)
/free
a10w = a10x;
return dt99(*omit:a10w);
/end-free
P e
// Entrée alpha, format par *cmdy pour les pseudo-dates système
Pdt99as b export
Ddt99as pi d
Da10x 10 const varying
Da10w s like(a10x)
/free
a10w = a10x;
return dt99(*omit:a10w:'*cmdy');
/end-free
P e
// Tous parametres
Pdt99naf b export
Ddt99naf pi d
Dn80x 8 0 const
Da10x 10 const varying
Dfmtx 5 const varying
/free
return dt99(n80x:a10x:fmtx);
/end-free
P e
