- 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","")
