source: FOIAVistA/trunk/r/DIETETICS-FH/FHSYSK.m@ 1607

Last change on this file since 1607 was 628, checked in by George Lilly, 15 years ago

initial load of FOIAVistA 6/30/08 version

File size: 1.1 KB
Line 
1FHSYSK ; HISC/REL - Purge Old Diet Activities ;2/13/95 13:34
2 ;;5.5;DIETETICS;;Jan 28, 2005
3 S X="T-400",%DT="X" D ^%DT S EDT=+Y
4D1 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
5 I Y>EDT W *7,!!,"CANNOT PURGE DATA LATER THAN T-400 DAYS!" G D1
6 S EDT=+Y
7D2 K ZTUCI,ZTDTH,ZTIO,ZTSAVE S ZTRTN="Q1^FHSYSK",ZTREQ="@",ZTSAVE("ZTREQ")="",ZTSAVE("EDT")=""
8 W !!,"Request will be Queued."
9 S ZTIO="",ZTDESC="Purge Old Dietetic Activities" D ^%ZTLOAD K ZTSK Q
10Q1 ; Process Purge
11 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
12 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)
13 K %DT,ADM,D1,D2,FHDFN,DFN,EDT,K1,X,Y Q
14K0 K ^FHPT(FHDFN,"A",ADM),^FHPT("ADTF",FHDFN,ADM),^FHPT("AOO",FHDFN,ADM),^FHPT("ASP",FHDFN,ADM) Q
Note: See TracBrowser for help on using the repository browser.