PRCGPUTL ;MNT/RB-IFCAP ARCHIVE/PURGE DATE UTILITY ; 01/12/16
V ;;5.1;IFCAP;**193**;JAN 12, 2016;Build 9
;Per VA Directive 6402, this routine should not be modified.
;
;PRC*5.1*193 Universal date query for archive/purge options
;
PURGEDT(PRCGTHRU,PRCGYRS) ;ARCHIVE/PURGE date query
N PRCGDT,OUT D DT S OUT=0
P1 S PRCGDOUT=0,PRCGPGDT=0
S DIR(0)="D^::E",DIR("A")="Select Fiscal Year thru which this option is to run",DIR("?",1)="Enter a valid FileMan date (YYYY is valid), or an up-arrow to quit."
S DIR("?")="Date is converted to last day of FISCAL YEAR associated with entry"
S:PRCGTHRU>0 DIR("B")=PRCGTHRU
D ^DIR K DIR I X["^"!(X="") S OUT=1 G Q
I $E(Y,4,5)>9 S Y=($E(Y,1,3)+1)_"0930"
E S Y=$E(Y,1,3)_"0930"
S PRCGPGDT=Y
I PRCGPGDT>PRCGDT W !,"CANNOT RUN THIS OPTION FOR LESS THAN LAST "_PRCGYRS_" FISCAL YEARS + CURRENT FISCAL YEAR" K PRCGDOUT,PRCGPGDT G P1
D DD^%DT S PRCGDOUT=Y K Y
Q Q OUT
;
DT N U,X,MM,DD,YY
S U="^"
I '$D(DT) S DT=$$DT^XLFDT
S MM=$E(DT,4,5),DD=$E(DT,6,7),YY=$E(DT,1,3)
S YY=YY-PRCGYRS ;MIN = LAST 7 YEARS + CURRENT
S YY=YY-1,PRCGDT=YY_"0930"
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCGPUTL 1118 printed Sep 23, 2025@19:40:59 Page 2
PRCGPUTL ;MNT/RB-IFCAP ARCHIVE/PURGE DATE UTILITY ; 01/12/16
V ;;5.1;IFCAP;**193**;JAN 12, 2016;Build 9
+1 ;Per VA Directive 6402, this routine should not be modified.
+2 ;
+3 ;PRC*5.1*193 Universal date query for archive/purge options
+4 ;
PURGEDT(PRCGTHRU,PRCGYRS) ;ARCHIVE/PURGE date query
+1 NEW PRCGDT,OUT
DO DT
SET OUT=0
P1 SET PRCGDOUT=0
SET PRCGPGDT=0
+1 SET DIR(0)="D^::E"
SET DIR("A")="Select Fiscal Year thru which this option is to run"
SET DIR("?",1)="Enter a valid FileMan date (YYYY is valid), or an up-arrow to quit."
+2 SET DIR("?")="Date is converted to last day of FISCAL YEAR associated with entry"
+3 if PRCGTHRU>0
SET DIR("B")=PRCGTHRU
+4 DO ^DIR
KILL DIR
IF X["^"!(X="")
SET OUT=1
GOTO Q
+5 IF $EXTRACT(Y,4,5)>9
SET Y=($EXTRACT(Y,1,3)+1)_"0930"
+6 IF '$TEST
SET Y=$EXTRACT(Y,1,3)_"0930"
+7 SET PRCGPGDT=Y
+8 IF PRCGPGDT>PRCGDT
WRITE !,"CANNOT RUN THIS OPTION FOR LESS THAN LAST "_PRCGYRS_" FISCAL YEARS + CURRENT FISCAL YEAR"
KILL PRCGDOUT,PRCGPGDT
GOTO P1
+9 DO DD^%DT
SET PRCGDOUT=Y
KILL Y
Q QUIT OUT
+1 ;
DT NEW U,X,MM,DD,YY
+1 SET U="^"
+2 IF '$DATA(DT)
SET DT=$$DT^XLFDT
+3 SET MM=$EXTRACT(DT,4,5)
SET DD=$EXTRACT(DT,6,7)
SET YY=$EXTRACT(DT,1,3)
+4 ;MIN = LAST 7 YEARS + CURRENT
SET YY=YY-PRCGYRS
+5 SET YY=YY-1
SET PRCGDT=YY_"0930"
+6 QUIT
