DICATTD1.m

DICATTD1 ;SFISC/GFT- DATE,TIME ;2 FEB 2009

 ;;22.0;VA FileMan;**42,160**;Mar 30, 1999;Build 23

 ;Per VHA Directive 2004-038, this routine should not be modified.

 ;

EARLY ;

 S Y=">X" G Y

 ;

LATEST ;

 S Y="<X"

Y S Y=$F(DICATT5,Y) I Y S Y=$E(DICATT5,Y-9,Y-3) S:Y?.E1"DT" Y="DT" D:Y DD^%DT Q

 K Y Q

 ;

POST1 ;check DATE

 N Z,Y,%DT,I K DDSERROR

 S %DT="T"

 D  I $D(DDSERROR) D HLP^DDSUTL("'EARLIEST DATE' & 'LATEST DATE' ARE IN WRONG ORDER") S DDSBR="21^DICATT1^2.1" Q

 .S Y=$$G(21) I Y="DT" S X=$$G(22) D:X]""  Q

 ..I X'="DT" D ^%DT I Y<DT S DDSERROR=1 Q

 .Q:Y=""  S X=Y D ^%DT S X=$$G(22) Q:X=""  I X="DT" S:Y>DT DDSERROR=1 Q

 .S Z=Y D ^%DT I Y<Z S DDSERROR=1

 S DICATT5N="S %DT=""E"_$E("S",$$G(25)=1)_$E("T",$$G(24)=1)_$E("X",$$G(23)=0)_$E("R",$$G(26)=1)_""" D ^%DT S X=Y K:"

FROMTO K DICATTMN F I=21,22 S Z=$$G(I) Q:Z=""  D

 .I Z="DT" S Y=Z,Z="CURRENT DATE"

 .E  S X=Z D ^%DT S X=Y D DD^%DT S Z=Y,Y=X

 .S DICATTMN(I)=Z,DICATT5N(I)=Y ;Z is readable, Y internal

 I $D(DICATTMN(22)) S DICATTMN="Type a date between "_DICATTMN(21)_" and "_DICATTMN(22)_".",DICATT5N=DICATT5N_DICATT5N(22)_"<X!("_DICATT5N(21)_">X) X"

 E  I $D(DICATTMN(21)) S DICATTMN="Type a date not earlier than "_DICATTMN(21)_".",DICATT5N=DICATT5N_DICATT5N(21)_">X X"

 E  S DICATT5N=DICATT5N_"X<1 X",DICATTMN="(No range limit on date)"

 S DICATTLN=$$G(24)=1*5+7

 S DICATT2N="D",DICATT3N=""

 S X=DICATT5N K DICATT5N S DICATT5N=X ;get rid of those damn subscripts

CHNG I DICATT5N=DICATT5 K DICATTMN ;No DICATTMN means no change

 D:$D(DICATTMN) PUT^DDSVALF(98,"DICATT",1,DICATTMN)

 Q

 ;

G(I) N X Q $$GET^DDSVALF(I,"DICATT1",2.1,"I","")

DICATTD1  ;SFISC/GFT- DATE,TIME ;2 FEB 2009

 +1       ;;22.0;VA FileMan;**42,160**;Mar 30, 1999;Build 23

 +2       ;Per VHA Directive 2004-038, this routine should not be modified.

 +3       ;

EARLY     ;

 +1        SET Y=">X"

           GOTO Y

 +2       ;

LATEST    ;

 +1        SET Y="<X"

Y          SET Y=$FIND(DICATT5,Y)

           IF Y

               SET Y=$EXTRACT(DICATT5,Y-9,Y-3)

               IF Y?.E1"DT"

                   SET Y="DT"

               IF Y

                   DO DD^%DT

               QUIT 

 +1        KILL Y

           QUIT 

 +2       ;

POST1     ;check DATE

 +1        NEW Z,Y,%DT,I

           KILL DDSERROR

 +2        SET %DT="T"

 +3        Begin DoDot:1

 +4            SET Y=$$G(21)

               IF Y="DT"

                   SET X=$$G(22)

                   IF X]""

                       Begin DoDot:2

 +5                        IF X'="DT"

                               DO ^%DT

                               IF Y<DT

                                   SET DDSERROR=1

                                   QUIT 

                       End DoDot:2

                   QUIT 

 +6            IF Y=""

                   QUIT 

               SET X=Y

               DO ^%DT

               SET X=$$G(22)

               IF X=""

                   QUIT 

               IF X="DT"

                   IF Y>DT

                       SET DDSERROR=1

                   QUIT 

 +7            SET Z=Y

               DO ^%DT

               IF Y<Z

                   SET DDSERROR=1

           End DoDot:1

           IF $DATA(DDSERROR)

               DO HLP^DDSUTL("'EARLIEST DATE' & 'LATEST DATE' ARE IN WRONG ORDER")

               SET DDSBR="21^DICATT1^2.1"

               QUIT 

 +8        SET DICATT5N="S %DT=""E"_$EXTRACT("S",$$G(25)=1)_$EXTRACT("T",$$G(24)=1)_$EXTRACT("X",$$G(23)=0)_$EXTRACT("R",$$G(26)=1)_""" D ^%DT S X=Y K:"

FROMTO     KILL DICATTMN

           FOR I=21,22

               SET Z=$$G(I)

               IF Z=""

                   QUIT 

               Begin DoDot:1

 +1                IF Z="DT"

                       SET Y=Z

                       SET Z="CURRENT DATE"

 +2               IF '$TEST

                       SET X=Z

                       DO ^%DT

                       SET X=Y

                       DO DD^%DT

                       SET Z=Y

                       SET Y=X

 +3       ;Z is readable, Y internal

                   SET DICATTMN(I)=Z

                   SET DICATT5N(I)=Y

               End DoDot:1

 +4        IF $DATA(DICATTMN(22))

               SET DICATTMN="Type a date between "_DICATTMN(21)_" and "_DICATTMN(22)_"."

               SET DICATT5N=DICATT5N_DICATT5N(22)_"<X!("_DICATT5N(21)_">X) X"

 +5       IF '$TEST

               IF $DATA(DICATTMN(21))

                   SET DICATTMN="Type a date not earlier than "_DICATTMN(21)_"."

                   SET DICATT5N=DICATT5N_DICATT5N(21)_">X X"

 +6       IF '$TEST

               SET DICATT5N=DICATT5N_"X<1 X"

               SET DICATTMN="(No range limit on date)"

 +7        SET DICATTLN=$$G(24)=1*5+7

 +8        SET DICATT2N="D"

           SET DICATT3N=""

 +9       ;get rid of those damn subscripts

           SET X=DICATT5N

           KILL DICATT5N

           SET DICATT5N=X

CHNG      ;No DICATTMN means no change

           IF DICATT5N=DICATT5

               KILL DICATTMN

 +1        IF $DATA(DICATTMN)

               DO PUT^DDSVALF(98,"DICATT",1,DICATTMN)

 +2        QUIT 

 +3       ;

G(I)       NEW X

           QUIT $$GET^DDSVALF(I,"DICATT1",2.1,"I","")