- 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 Feb 18, 2025@23:42:42 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