FHADRSY ; HISC/NCA - Purge Old Annual Dietetic Data ;4/25/95 12:47
;;5.5;DIETETICS;;Jan 28, 2005
EN1 ; Purge Data Older than three years
S X="T-1095",%DT="X" D ^%DT S EDT=$E(+Y,1,3)_"0500"
S FLG=0 F QTR=1:1:4 S PRE=$E(EDT,1,4)_QTR_"00" I $D(^FH(117.3,"B",PRE,PRE)) S FLG=1 Q
I 'FLG W !!,"Already Purged to ",$E(EDT,2,3) G KIL
D1 W !!,"Purge To The Year: ",$E(EDT,2,3)," // " R X:DTIME G:'$T!(X="^") KIL G:X="" D2 S %DT="E" D ^%DT G:U[X!$D(DTOUT) KIL G:Y<1 D1
S Y=$E(+Y,1,3)_"0000" I Y>EDT W *7,!!,"CANNOT PURGE TO YEAR THAT IS GREATER THAN THE DEFAULT!" G D1
S EDT=+Y
D2 F PRE=0:0 S PRE=$O(^FH(117.3,PRE)) Q:PRE'<EDT D K0
W !!,"... Done"
KIL G KILL^XUSCLEAN
K0 K ^FH(117.3,PRE),^FH(117.3,"B",PRE,PRE) Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HFHADRSY 725 printed Oct 16, 2024@17:47:32 Page 2
FHADRSY ; HISC/NCA - Purge Old Annual Dietetic Data ;4/25/95 12:47
+1 ;;5.5;DIETETICS;;Jan 28, 2005
EN1 ; Purge Data Older than three years
+1 SET X="T-1095"
SET %DT="X"
DO ^%DT
SET EDT=$EXTRACT(+Y,1,3)_"0500"
+2 SET FLG=0
FOR QTR=1:1:4
SET PRE=$EXTRACT(EDT,1,4)_QTR_"00"
IF $DATA(^FH(117.3,"B",PRE,PRE))
SET FLG=1
QUIT
+3 IF 'FLG
WRITE !!,"Already Purged to ",$EXTRACT(EDT,2,3)
GOTO KIL
D1 WRITE !!,"Purge To The Year: ",$EXTRACT(EDT,2,3)," // "
READ X:DTIME
if '$TEST!(X="^")
GOTO KIL
if X=""
GOTO D2
SET %DT="E"
DO ^%DT
if U[X!$DATA(DTOUT)
GOTO KIL
if Y<1
GOTO D1
+1 SET Y=$EXTRACT(+Y,1,3)_"0000"
IF Y>EDT
WRITE *7,!!,"CANNOT PURGE TO YEAR THAT IS GREATER THAN THE DEFAULT!"
GOTO D1
+2 SET EDT=+Y
D2 FOR PRE=0:0
SET PRE=$ORDER(^FH(117.3,PRE))
if PRE'<EDT
QUIT
DO K0
+1 WRITE !!,"... Done"
KIL GOTO KILL^XUSCLEAN
K0 KILL ^FH(117.3,PRE),^FH(117.3,"B",PRE,PRE)
QUIT
