- 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 Jan 18, 2025@02:56:24 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