source: FOIAVistA/trunk/r/AUTOMATED_MED_INFO_EXCHANGE-DVBA-DVBC/DVBCPURG.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.5 KB
Line 
1DVBCPURG ;ALB/GTS-557/THM-C&P PURGING PROGRAM ; 10/28/90 8:40 PM
2 ;;2.7;AMIE;**48**;Apr 10, 1995
3 ;
4 ;** Version Changes
5 ; 2.7 - GTS/Coded to purge 396.95 (Enhc 13)
6 ; 2.7 - JLU/Utilize the 2507 purge parameter
7 ;
8SETUP I '$D(DT) S X="T" D ^%DT S DT=Y
9 S HIST=$$PAR()
10 S X1=DT,X2=HIST,X2=-X2 D C^%DTC S PDATE=X
11 ;
12GO F TYP="C","CT","X","RX" F REGOFF=0:0 S REGOFF=$O(^DVB(396.3,"AF",TYP,REGOFF)) Q:REGOFF="" F REQDA=0:0 S REQDA=$O(^DVB(396.3,"AF",TYP,REGOFF,REQDA)) Q:REQDA="" D KILL
13 ;
14EXIT K DIK,X,Y,REGOFF,DA,I,J,PDATE,X1,X2,HIST,%,%DT,%H,TYP,REQDA,EXMDA
15 Q
16 ;
17KILL I '$D(^DVB(396.3,REQDA,0)) K ^DVB(396.3,"AF",TYP,REGOFF,REQDA)
18 I '$D(^DVB(396.3,REQDA,0)) Q ;clean up bad index records
19 S X1=PDATE
20 S X2=$S(TYP["X":$P(^DVB(396.3,REQDA,0),U,19),1:$P(^DVB(396.3,REQDA,0),U,7))
21 D ^%DTC I (+X>0),('$D(^DVB(396.3,"AORQ",REQDA))) D APPTLP,EXAMLP S DIK="^DVB(396.3,",DA=REQDA D ^DIK
22 K DIK,DA
23 Q
24 ;
25APPTLP ; ** Loop through existing appointments **
26 N LPCNT
27 S LPCNT=""
28 F S LPCNT=$O(^DVB(396.95,"AR",REQDA,LPCNT)) Q:LPCNT="" DO
29 .S DIK="^DVB(396.95,",DA=LPCNT D ^DIK K DA,DIK
30 Q
31 ;
32EXAMLP ; ** Loop through existing exams **
33 F EXMDA=0:0 S EXMDA=$O(^DVB(396.4,"C",REQDA,EXMDA)) Q:EXMDA="" D KEXAMS
34 Q
35 ;
36KEXAMS ; ** Delete exams on the request **
37 S DA=EXMDA,DIK="^DVB(396.4," D ^DIK K DIK,DA
38 Q
39 ;
40PAR() ;function call to get the number of days to retain the 2507 requests.
41 ;
42 N IFN,Y
43 S IFN=$$IFNPAR^DVBAUTL3()
44 I IFN DO
45 .S Y=$P(^DVB(396.1,IFN,0),U,11)
46 .I 'Y!(Y<120) S Y=99999
47 I 'IFN S Y=99999
48 Q Y
Note: See TracBrowser for help on using the repository browser.