FHSYSK ; HISC/REL - Purge Old Diet Activities ;2/13/95 13:34
;;5.5;DIETETICS;;Jan 28, 2005
S X="T-400",%DT="X" D ^%DT S EDT=+Y
D1 W !!,"Purge To: ",$E(EDT,4,5),"-",$E(EDT,6,7),"-",$E(EDT,2,3)," // " R X:DTIME Q:'$T!(X="^") G:X="" D2 S %DT="EX" D ^%DT Q:U[X!$D(DTOUT) G:Y<1 D1
I Y>EDT W *7,!!,"CANNOT PURGE DATA LATER THAN T-400 DAYS!" G D1
S EDT=+Y
D2 K ZTUCI,ZTDTH,ZTIO,ZTSAVE S ZTRTN="Q1^FHSYSK",ZTREQ="@",ZTSAVE("ZTREQ")="",ZTSAVE("EDT")=""
W !!,"Request will be Queued."
S ZTIO="",ZTDESC="Purge Old Dietetic Activities" D ^%ZTLOAD K ZTSK Q
Q1 ; Process Purge
F FHDFN=0:0 S FHDFN=$O(^FHPT(FHDFN)) Q:FHDFN<1 F ADM=0:0 S ADM=$O(^FHPT(FHDFN,"A",ADM)) Q:ADM<1 S X=$P($G(^DGPM(ADM,0)),"^",17) I X S X=$P($G(^DGPM(+X,0)),"^",1) I X,X<EDT D K0
F D1="ADLT","ADR","ADRU" S D2="" F K1=0:0 S D2=$O(^FHPT(D1,D2)) Q:D2="" F FHDFN=0:0 S FHDFN=$O(^FHPT(D1,D2,FHDFN)) Q:FHDFN<1 F ADM=0:0 S ADM=$O(^FHPT(D1,D2,FHDFN,ADM)) Q:ADM<1 I '$D(^FHPT(FHDFN,"A",ADM)) K ^FHPT(D1,D2,FHDFN,ADM)
K %DT,ADM,D1,D2,FHDFN,DFN,EDT,K1,X,Y Q
K0 K ^FHPT(FHDFN,"A",ADM),^FHPT("ADTF",FHDFN,ADM),^FHPT("AOO",FHDFN,ADM),^FHPT("ASP",FHDFN,ADM) Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HFHSYSK 1138 printed Nov 22, 2024@17:05:21 Page 2
FHSYSK ; HISC/REL - Purge Old Diet Activities ;2/13/95 13:34
+1 ;;5.5;DIETETICS;;Jan 28, 2005
+2 SET X="T-400"
SET %DT="X"
DO ^%DT
SET EDT=+Y
D1 WRITE !!,"Purge To: ",$EXTRACT(EDT,4,5),"-",$EXTRACT(EDT,6,7),"-",$EXTRACT(EDT,2,3)," // "
READ X:DTIME
if '$TEST!(X="^")
QUIT
if X=""
GOTO D2
SET %DT="EX"
DO ^%DT
if U[X!$DATA(DTOUT)
QUIT
if Y<1
GOTO D1
+1 IF Y>EDT
WRITE *7,!!,"CANNOT PURGE DATA LATER THAN T-400 DAYS!"
GOTO D1
+2 SET EDT=+Y
D2 KILL ZTUCI,ZTDTH,ZTIO,ZTSAVE
SET ZTRTN="Q1^FHSYSK"
SET ZTREQ="@"
SET ZTSAVE("ZTREQ")=""
SET ZTSAVE("EDT")=""
+1 WRITE !!,"Request will be Queued."
+2 SET ZTIO=""
SET ZTDESC="Purge Old Dietetic Activities"
DO ^%ZTLOAD
KILL ZTSK
QUIT
Q1 ; Process Purge
+1 FOR FHDFN=0:0
SET FHDFN=$ORDER(^FHPT(FHDFN))
if FHDFN<1
QUIT
FOR ADM=0:0
SET ADM=$ORDER(^FHPT(FHDFN,"A",ADM))
if ADM<1
QUIT
SET X=$PIECE($GET(^DGPM(ADM,0)),"^",17)
IF X
SET X=$PIECE($GET(^DGPM(+X,0)),"^",1)
IF X
IF X<EDT
DO K0
+2 FOR D1="ADLT","ADR","ADRU"
SET D2=""
FOR K1=0:0
SET D2=$ORDER(^FHPT(D1,D2))
if D2=""
QUIT
FOR FHDFN=0:0
SET FHDFN=$ORDER(^FHPT(D1,D2,FHDFN))
if FHDFN<1
QUIT
FOR ADM=0:0
SET ADM=$ORDER(^FHPT(D1,D2,FHDFN,ADM))
if ADM<1
QUIT
IF '$DATA(^FHPT(FHDFN,"A",ADM))
KILL ^FHPT(D1,D2,FHDFN,ADM)
+3 KILL %DT,ADM,D1,D2,FHDFN,DFN,EDT,K1,X,Y
QUIT
K0 KILL ^FHPT(FHDFN,"A",ADM),^FHPT("ADTF",FHDFN,ADM),^FHPT("AOO",FHDFN,ADM),^FHPT("ASP",FHDFN,ADM)
QUIT
