source: FOIAVistA/trunk/r/CLINICAL_INFO_RESOURCE_NETWORK-MRF-RGE--RG--RGED--RGUT--RGWB/RGEVPRG.m@ 1397

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

initial load of FOIAVistA 6/30/08 version
File size: 7.4 KB
Line 
1RGEVPRG ;BAY/ALS-OPTIONS TO PURGE MPI/PD EXCEPTIONS ;08/23/99
2 ;;1.0;CLINICAL INFO RESOURCE NETWORK;**3,12,19,32,35,43,44,50**;30 Apr 99;Build 3
3 ;
4MAIN ;
5 ;Q:($D(^TMP("RGEXC")))!($D(^TMP("RGEXC2")))
6 L +^RGHL7(991.1):0 I '$T Q
7 L -^RGHL7(991.1)
8 L +^RGHL7(991.1,"RG PURGE EXCEPTION"):5 E Q
9 I $D(ZTQUEUED) S ZTREQ="@"
10 S $P(^RGSITE(991.8,1,"EXCPRG"),"^",1)=$$NOW^XLFDT
11 S $P(^RGSITE(991.8,1,"EXCPRG"),"^",3)="R"
12 D PROC
13 D PRGDUP
14 D PRG30
15 D PRGZZ
16 S $P(^RGSITE(991.8,1,"EXCPRG"),"^",2)=$$NOW^XLFDT
17 S $P(^RGSITE(991.8,1,"EXCPRG"),"^",3)="C"
18 L -^RGHL7(991.1,"RG PURGE EXCEPTION")
19 Q
20PRGPAT ;Purge by Patient
21 W !
22 S DIC="^DPT(",DIC(0)="QEAM",DIC("A")="Select PATIENT: "
23 D ^DIC K DIC G:Y<0 QUIT S RGDFN=+Y
24 S EXCT="",FLAG=0
25 F S EXCT=$O(^RGHL7(991.1,"ADFN",EXCT)) Q:EXCT="" D
26 . I $D(^RGHL7(991.1,"ADFN",EXCT,RGDFN)) S FLAG=1 Q
27 I FLAG=0 W !,"There are no exceptions on file for this patient." G PRGPAT
28 I $$IFLOCAL^MPIF001(RGDFN) W !,"This patient does not have a national ICN assigned, do not purge." Q
29 S DFN=RGDFN D DEM^VADPT
30 S DIR(0)="YA",DIR("B")="YES"
31 S DIR("A")="Are you sure you want to purge all exceptions on file for "_VADM(1)_"? YES// "
32 D ^DIR Q:$D(DIRUT) I Y>0 D
33 . S EXCT="",CNT=0
34 . F S EXCT=$O(^RGHL7(991.1,"ADFN",EXCT)) Q:'EXCT D
35 .. S IEN=0
36 .. F S IEN=$O(^RGHL7(991.1,"ADFN",EXCT,RGDFN,IEN)) Q:'IEN D
37 ... S IEN2=0
38 ... F S IEN2=$O(^RGHL7(991.1,"ADFN",EXCT,RGDFN,IEN,IEN2)) Q:'IEN2 D
39 .... S NUM="" S NUM=$P(^RGHL7(991.1,IEN,1,0),"^",4)
40 .... I NUM=1 S DIK="^RGHL7(991.1,",DA=IEN D ^DIK K DIK,DA S CNT=CNT+1
41 .... E I NUM>1 D DEL
42 . W !,"All exceptions purged for "_VADM(1)_" DFN: "_RGDFN
43 K EXCT,DFN,FLAG,VADM,CNT,IEN,IEN2,NUM,RGDFN,Y
44QUIT Q
45 ;
46PRGDT ; Purge by Date
47 W !!,"Enter a date for the purge. All exceptions on file, on or before that date, will be deleted."
48 K DIR,DIRUT,DTOUT,DUOUT
49 S DIR(0)="DA^:DT:EPX",DIR("A")="Enter Date for Purge: "
50 D ^DIR K DIR Q:$D(DIRUT)
51 S PURDT=Y
52 S PDATE=$$FMTE^XLFDT(PURDT)
53 S DIR(0)="YA",DIR("B")="YES"
54 S DIR("A")="Are you sure you want to purge all exceptions on file dated on or before "_PDATE_"? YES// "
55 D ^DIR Q:$D(DIRUT) I Y>0 D
56 . S EXCDT="",CNT=0
57 . F S EXCDT=$O(^RGHL7(991.1,"AD",EXCDT)) Q:'EXCDT D
58 .. I ($P(EXCDT,".",1)=PURDT)!($P(EXCDT,".",1)<PURDT) D
59 ... S IEN=0
60 ... F S IEN=$O(^RGHL7(991.1,"AD",EXCDT,IEN)) Q:'IEN D
61 .... S NUM="" S NUM=$P($G(^RGHL7(991.1,IEN,1,0)),"^",4) Q:NUM<1
62 .... S CNT=CNT+NUM
63 .... S DIK="^RGHL7(991.1,",DA=IEN
64 .... D ^DIK K DIK,DA
65 I CNT=0 W !,"There are no exceptions dated on or before "_PDATE_", no data to purge."
66 E I CNT>0 W !,CNT_" exceptions, dated on or before "_PDATE_" have been purged!"
67 K PDATE,PURDT,EXCDT,CNT,IEN,NUM,Y
68 Q
69PRG30 ; Purge Exceptions over 30 days old
70 S TODAY=""
71 S TODAY=$$NOW^XLFDT D
72 . S EXCDT="",CNT=0,DIFF=""
73 . F S EXCDT=$O(^RGHL7(991.1,"AD",EXCDT)) Q:'EXCDT D
74 .. S DIFF=$$FMDIFF^XLFDT(TODAY,EXCDT)
75 .. I DIFF>30 D
76 ... S IEN=0
77 ... F S IEN=$O(^RGHL7(991.1,"AD",EXCDT,IEN)) Q:'IEN D
78 .... S NUM="" S NUM=$P($G(^RGHL7(991.1,IEN,1,0)),"^",4) Q:'NUM
79 .... S IEN2=0
80 .... F S IEN2=$O(^RGHL7(991.1,IEN,1,IEN2)) Q:'IEN2 D
81 ..... S STAT=""
82 ..... S STAT=$P(^RGHL7(991.1,IEN,1,IEN2,0),"^",5)
83 ..... ; Only delete PROCESSED exceptions
84 ..... I (STAT>0)!(STAT="") D
85 ...... I NUM>1 D DEL
86 ...... E I NUM=1 D
87 ....... S CNT=CNT+NUM
88 ....... S DIK="^RGHL7(991.1,",DA=IEN
89 ....... D ^DIK K DIK,DA
90 K DIFF,TODAY,EXCDT,CNT,IEN,IEN2,NUM,STAT
91 Q
92PRGEXC ; Purge by Exception Type
93 ;S DIC="^RGHL7(991.11,",DIC(0)="QEAM"
94 ;S DIC("A")="Enter an exception type to purge: "
95 ;D ^DIC K DIC G:Y<200 QUIT S EXCTYP=+Y,ETYPE=X
96 ;S DIR(0)="YA",DIR("B")="YES"
97 ;S DIR("A")="*WARNING* This will permanently delete all "_ETYPE_" exceptions. Are you sure you want to do this? YES// "
98 ;D ^DIR Q:$D(DIRUT) I Y>0 D
99 ;. S CNT=0,IEN=""
100 ;. F S IEN=$O(^RGHL7(991.1,"AC",EXCTYP,IEN)) Q:'IEN D
101 ;.. S IEN2=0
102 ;.. F S IEN2=$O(^RGHL7(991.1,"AC",EXCTYP,IEN,IEN2)) Q:'IEN2 D
103 ;... S NUM="" S NUM=$P(^RGHL7(991.1,IEN,1,0),"^",4)
104 ;... I NUM=1 S DIK="^RGHL7(991.1,",DA=IEN D ^DIK K DIK,DA S CNT=CNT+1
105 ;... E I NUM>1 D DEL
106 ;I CNT=0 W !,"There are no "_ETYPE_" exceptions on file."
107 ;E I CNT>0 W !,CNT_" "_ETYPE_" Exceptions purged!"
108 ;K ETYPE,CNT,IEN,IEN2,NUM,X,Y
109 ;Q
110PRGDUP ;Purge Duplicate Entries; retain most recent for all except types.
111 ;**50 through remainder of module.
112 S EXCTYP="",CNT=0
113 K ^TMP("RGEVDUP",$J)
114 F S EXCTYP=$O(^RGHL7(991.1,"ADFN",EXCTYP)) Q:'EXCTYP D
115 . S RGDFN=""
116 . F S RGDFN=$O(^RGHL7(991.1,"ADFN",EXCTYP,RGDFN)) Q:'RGDFN D
117 .. S IEN=0
118 .. F S IEN=$O(^RGHL7(991.1,"ADFN",EXCTYP,RGDFN,IEN)) Q:'IEN D
119 ... S IEN2=0
120 ... F S IEN2=$O(^RGHL7(991.1,"ADFN",EXCTYP,RGDFN,IEN,IEN2)) Q:'IEN2 D
121 .... I $P($G(^RGHL7(991.1,IEN,1,IEN2,0)),"^",5)=1 K ^RGHL7(991.1,"ADFN",EXCTYP,RGDFN,IEN,IEN2) Q ;exception processed
122 .... S EXCDT=$P($G(^RGHL7(991.1,IEN,0)),"^",3) ;incoming date
123 .... I '$D(^TMP("RGEVDUP",$J,RGDFN,EXCTYP)) D Q
124 ..... S ^TMP("RGEVDUP",$J,RGDFN,EXCTYP)=EXCDT_"^"_IEN_"^"_IEN2
125 .... I $D(^TMP("RGEVDUP",$J,RGDFN,EXCTYP)) D ;duplicate exists; compare incoming to previous.
126 ..... S OLDNODE=^TMP("RGEVDUP",$J,RGDFN,EXCTYP)
127 ..... S OLDDT=$P(OLDNODE,"^"),OLDIEN=$P(OLDNODE,"^",2),OLDIEN2=$P(OLDNODE,"^",3)
128 ..... I EXCDT>OLDDT D Q ;incoming date greater than previous? purge old, keep new.
129 ...... S NUM="" S NUM=$P(^RGHL7(991.1,IEN,1,0),"^",4)
130 ...... I NUM=1 S DIK="^RGHL7(991.1,",DA=OLDIEN D ^DIK K DIK,DA
131 ...... I NUM>1 D
132 ....... S DA(1)=OLDIEN,DA=OLDIEN2
133 ....... S DIK="^RGHL7(991.1,"_DA(1)_",1," D ^DIK K DIK,DA
134 ...... S ^TMP("RGEVDUP",$J,RGDFN,EXCTYP)=EXCDT_"^"_IEN_"^"_IEN2
135 ..... ;
136 ..... I OLDDT>EXCDT!(OLDDT=EXCDT) D ;previous date greater or equal incoming? purge new, keep old.
137 ...... S NUM="" S NUM=$P(^RGHL7(991.1,IEN,1,0),"^",4)
138 ...... I NUM=1 S DIK="^RGHL7(991.1,",DA=IEN D ^DIK K DIK,DA
139 ...... I NUM>1 D DEL
140 ...... ;
141 K CNT,EXCDT,EXCTYP,IEN,IEN2,NUM,OLDDT,OLDIEN,OLDIEN2,OLDNODE,RGDFN,RGDT,^TMP("RGEVDUP")
142 Q
143 ;
144PRGZZ ;Purge if name field is null (incomplete record)
145 ;Purge if -9 node exists, this indicates the record has been merged.
146 S EXCTYP="",CNT=""
147 F S EXCTYP=$O(^RGHL7(991.1,"ADFN",EXCTYP)) Q:'EXCTYP D
148 . S RGDFN=""
149 . F S RGDFN=$O(^RGHL7(991.1,"ADFN",EXCTYP,RGDFN)) Q:'RGDFN D
150 .. S IEN=0
151 .. F S IEN=$O(^RGHL7(991.1,"ADFN",EXCTYP,RGDFN,IEN)) Q:'IEN D
152 ... S IEN2=0
153 ... F S IEN2=$O(^RGHL7(991.1,"ADFN",EXCTYP,RGDFN,IEN,IEN2)) Q:'IEN2 D
154 .... S DFN=RGDFN D DEM^VADPT
155 .... I VADM(1)=""!($D(^DPT(RGDFN,-9))) D
156 ..... S NUM="" S NUM=$P(^RGHL7(991.1,IEN,1,0),"^",4)
157 ..... I NUM=1 S DIK="^RGHL7(991.1,",DA=IEN D ^DIK K DIK,DA
158 ..... E I NUM>1 D DEL
159 K EXCTYP,RGDFN,DFN,IEN,IEN2,NUM,VADM
160 Q
161DEL ;
162 S CNT=CNT+1
163 S DA(1)=IEN,DA=IEN2
164 S DIK="^RGHL7(991.1,"_DA(1)_",1,"
165 D ^DIK K DIK,DA
166 Q
167PROC ;Set these exception types to PROCESSED if they have a national ICN
168 ;209 - Required field(s) missing for patient sent to MPI,
169 ;227 - Multiple ICNs, 213 - SSN Match Failed, 214 - Name Doesn't Match
170 S EXCTYP=""
171 S HOME=$$SITE^VASITE()
172 F S EXCTYP=$O(^RGHL7(991.1,"AC",EXCTYP)) Q:'EXCTYP D
173 . I (EXCTYP=209)!(EXCTYP=227)!(EXCTYP=213)!(EXCTYP=214) D ;**43
174 .. S IEN=0
175 .. F S IEN=$O(^RGHL7(991.1,"AC",EXCTYP,IEN)) Q:'IEN D
176 ... S IEN2=0,ICN="",RGDFN=""
177 ... F S IEN2=$O(^RGHL7(991.1,"AC",EXCTYP,IEN,IEN2)) Q:'IEN2 D
178 .... S RGDFN=$P(^RGHL7(991.1,IEN,1,IEN2,0),"^",4) Q:'RGDFN
179 .... S ICN=+$$GETICN^MPIF001(RGDFN)
180 .... I $E(ICN,1,3)'=$E($P(HOME,"^",3),1,3)&(ICN>0) D
181 ..... L +^RGHL7(991.1,IEN):10
182 ..... S DA(1)=IEN,DA=IEN2,DR="6///"_1,DIE="^RGHL7(991.1,"_DA(1)_",1,"
183 ..... D ^DIE K DIE,DA,DR
184 ..... L -^RGHL7(991.1,IEN)
185 K EXCTYP,HOME,ICN,IEN,IEN2,RGDFN
186 Q
Note: See TracBrowser for help on using the repository browser.