PRCPURS2 ;WISC/RFJ-select dates ;24 May 93
;;5.1;IFCAP;**84**;Oct 20, 2000
;Per VHA Directive 10-93-142, this routine should not be modified.
Q
;
;
DATESEL(V1) ; select starting and ending dates in days
; returns datestrt and dateend
N %,%DT,%H,%I,DEFAULT,X,Y
K DATEEND,DATESTRT
START S Y=$E(DT,1,5)_"01" D DD^%DT S DEFAULT=Y
S %DT("A")="Start with "_$S(V1'="":V1_" ",1:"")_"Date: ",%DT("B")=DEFAULT,%DT="AEP",%DT(0)=-DT D ^%DT I Y<0 Q
I $E(Y,6,7)="00" S Y=$E(Y,1,5)_"01"
S DATESTRT=Y
S Y=DT D DD^%DT S DEFAULT=Y
S %DT("A")=" End with "_$S(V1'="":V1_" ",1:"")_"Date: ",%DT("B")=DEFAULT,%DT="AEP",%DT(0)=-DT D ^%DT I Y<0 Q
I $E(Y,6,7)="00" S Y=$E(Y,1,5)_"01"
I Y<DATESTRT W !,"END DATE MUST BE GREATER THAN OR EQUAL TO THE START DATE.",! G START
S DATEEND=Y,Y=DATESTRT D DD^%DT
W !?5,"*** Selected date range from ",Y," to " S Y=DATEEND D DD^%DT W Y," ***"
Q
;
;
MONTHSEL ; select starting and ending dates in months
; returns datestrt and dateend
; modified 5/27/05 to actually restrict selections to month & year
; and return DATESTRT as 1st of beginning month and DATEEND as last day of ending month. - T. Holloway
N %,%DT,%H,%I,DEFAULT,PRCLP,PRCMN,X,Y
K DATEEND,DATESTRT
START1 S X1=DT,X2=-90 D C^%DTC S Y=$E(X,1,5)_"00" D DD^%DT S DEFAULT=Y
S %DT("A")="Start with Date: ",%DT("B")=DEFAULT,%DT="AEPM",%DT(0)=-DT D ^%DT I Y<0 Q
S DATESTRT=Y
S Y=$E(DT,1,5)_"00" D DD^%DT S DEFAULT=Y
S %DT("A")=" End with Date: ",%DT("B")=DEFAULT,%DT="AEPM",%DT(0)=-DT D ^%DT I Y<0 Q
I Y<DATESTRT W !,"END DATE MUST BE GREATER THAN OR EQUAL TO THE START DATE.",! G START1
S PRCLP=$$LEAP^DIDTC($E(Y,1,3)),PRCMN=+$E(Y,4,5),DATESTRT=DATESTRT+1
S DATEEND=$E(Y,1,5)_$P("31^28^31^30^31^30^31^31^30^31^30^31","^",PRCMN) ; set end date to last day of month
S:PRCMN=2 DATEEND=DATEEND+PRCLP ; if February and Leap Year, add 1 to get 29th
S:DATEEND>DT DATEEND=DT-1 ; if end month is current month, set DATEEND to yesterday
I $E(DATEEND,6,7)="00" W !," You may not include the current month until at least 1 full day",!," has passed.",! G START1
S Y=DATESTRT D DD^%DT
W !?5,"*** Selected date range from ",Y," to " S Y=DATEEND D DD^%DT W Y," ***"
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCPURS2 2214 printed Sep 23, 2025@19:52:24 Page 2
PRCPURS2 ;WISC/RFJ-select dates ;24 May 93
+1 ;;5.1;IFCAP;**84**;Oct 20, 2000
+2 ;Per VHA Directive 10-93-142, this routine should not be modified.
+3 QUIT
+4 ;
+5 ;
DATESEL(V1) ; select starting and ending dates in days
+1 ; returns datestrt and dateend
+2 NEW %,%DT,%H,%I,DEFAULT,X,Y
+3 KILL DATEEND,DATESTRT
START SET Y=$EXTRACT(DT,1,5)_"01"
DO DD^%DT
SET DEFAULT=Y
+1 SET %DT("A")="Start with "_$SELECT(V1'="":V1_" ",1:"")_"Date: "
SET %DT("B")=DEFAULT
SET %DT="AEP"
SET %DT(0)=-DT
DO ^%DT
IF Y<0
QUIT
+2 IF $EXTRACT(Y,6,7)="00"
SET Y=$EXTRACT(Y,1,5)_"01"
+3 SET DATESTRT=Y
+4 SET Y=DT
DO DD^%DT
SET DEFAULT=Y
+5 SET %DT("A")=" End with "_$SELECT(V1'="":V1_" ",1:"")_"Date: "
SET %DT("B")=DEFAULT
SET %DT="AEP"
SET %DT(0)=-DT
DO ^%DT
IF Y<0
QUIT
+6 IF $EXTRACT(Y,6,7)="00"
SET Y=$EXTRACT(Y,1,5)_"01"
+7 IF Y<DATESTRT
WRITE !,"END DATE MUST BE GREATER THAN OR EQUAL TO THE START DATE.",!
GOTO START
+8 SET DATEEND=Y
SET Y=DATESTRT
DO DD^%DT
+9 WRITE !?5,"*** Selected date range from ",Y," to "
SET Y=DATEEND
DO DD^%DT
WRITE Y," ***"
+10 QUIT
+11 ;
+12 ;
MONTHSEL ; select starting and ending dates in months
+1 ; returns datestrt and dateend
+2 ; modified 5/27/05 to actually restrict selections to month & year
+3 ; and return DATESTRT as 1st of beginning month and DATEEND as last day of ending month. - T. Holloway
+4 NEW %,%DT,%H,%I,DEFAULT,PRCLP,PRCMN,X,Y
+5 KILL DATEEND,DATESTRT
START1 SET X1=DT
SET X2=-90
DO C^%DTC
SET Y=$EXTRACT(X,1,5)_"00"
DO DD^%DT
SET DEFAULT=Y
+1 SET %DT("A")="Start with Date: "
SET %DT("B")=DEFAULT
SET %DT="AEPM"
SET %DT(0)=-DT
DO ^%DT
IF Y<0
QUIT
+2 SET DATESTRT=Y
+3 SET Y=$EXTRACT(DT,1,5)_"00"
DO DD^%DT
SET DEFAULT=Y
+4 SET %DT("A")=" End with Date: "
SET %DT("B")=DEFAULT
SET %DT="AEPM"
SET %DT(0)=-DT
DO ^%DT
IF Y<0
QUIT
+5 IF Y<DATESTRT
WRITE !,"END DATE MUST BE GREATER THAN OR EQUAL TO THE START DATE.",!
GOTO START1
+6 SET PRCLP=$$LEAP^DIDTC($EXTRACT(Y,1,3))
SET PRCMN=+$EXTRACT(Y,4,5)
SET DATESTRT=DATESTRT+1
+7 ; set end date to last day of month
SET DATEEND=$EXTRACT(Y,1,5)_$PIECE("31^28^31^30^31^30^31^31^30^31^30^31","^",PRCMN)
+8 ; if February and Leap Year, add 1 to get 29th
if PRCMN=2
SET DATEEND=DATEEND+PRCLP
+9 ; if end month is current month, set DATEEND to yesterday
if DATEEND>DT
SET DATEEND=DT-1
+10 IF $EXTRACT(DATEEND,6,7)="00"
WRITE !," You may not include the current month until at least 1 full day",!," has passed.",!
GOTO START1
+11 SET Y=DATESTRT
DO DD^%DT
+12 WRITE !?5,"*** Selected date range from ",Y," to "
SET Y=DATEEND
DO DD^%DT
WRITE Y," ***"
+13 QUIT
