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

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

revised back to 6/30/08 version

File size: 8.9 KB
RevLine 
[623]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**;30 Apr 99;Build 8
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 types except 234.
111 S EXCTYP="",CNT=0
112 K ^TMP("RGEVDUP",$J)
113 F S EXCTYP=$O(^RGHL7(991.1,"ADFN",EXCTYP)) Q:'EXCTYP D
114 . I EXCTYP=234 Q ;**44 process 234s separately below
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 .... S EXCDT=$P(^RGHL7(991.1,IEN,0),"^",3)
122 .... I '$D(^TMP("RGEVDUP",$J,RGDFN,EXCTYP)) D Q
123 ..... S ^TMP("RGEVDUP",$J,RGDFN,EXCTYP)=EXCDT_"^"_IEN_"^"_IEN2
124 .... I $D(^TMP("RGEVDUP",$J,RGDFN,EXCTYP)) D
125 ..... S OLDNODE=^TMP("RGEVDUP",$J,RGDFN,EXCTYP)
126 ..... S OLDDT=$P(OLDNODE,"^")
127 ..... I EXCDT>OLDDT D Q
128 ...... S NUM="" S NUM=$P(^RGHL7(991.1,IEN,1,0),"^",4)
129 ...... I NUM=1 S DIK="^RGHL7(991.1,",DA=$P(OLDNODE,"^",2) D ^DIK K DIK,DA
130 ...... E I NUM>1 D
131 ....... S DA(1)=$P(OLDNODE,"^",2),DA=$P(OLDNODE,"^",3)
132 ....... S DIK="^RGHL7(991.1,"_DA(1)_",1," D ^DIK K DIK,DA
133 ...... S CNT=CNT+1
134 ...... S ^TMP("RGEVDUP",$J,RGDFN,EXCTYP)=EXCDT_"^"_IEN_"^"_IEN2
135 ..... I OLDDT>EXCDT!(OLDDT=EXCDT) D
136 ...... S NUM="" S NUM=$P(^RGHL7(991.1,IEN,1,0),"^",4)
137 ...... I NUM=1 S DIK="^RGHL7(991.1,",DA=IEN D ^DIK K DIK,DA S CNT=CNT+1
138 ...... E I NUM>1 D DEL
139 ; W !,CNT_" Duplicate entries"
140 ;Process PRIMARY VIEW REJECT (234) duplicates; purge if for SAME day.
141 ;**44 through remainder of module.
142 K ^TMP("RGDFNDT",$J) S RGDFN=""
143 F S RGDFN=$O(^RGHL7(991.1,"ADFN",234,RGDFN)) Q:'RGDFN D
144 .S IEN=0
145 .F S IEN=$O(^RGHL7(991.1,"ADFN",234,RGDFN,IEN)) Q:'IEN D
146 ..S IEN2=0
147 ..F S IEN2=$O(^RGHL7(991.1,"ADFN",234,RGDFN,IEN,IEN2)) Q:'IEN2 D
148 ...S EXCDT=$P(^RGHL7(991.1,IEN,0),"^",3)
149 ...;How many for each DFN? Store in ^TMP("RGDFNDT")
150 ...I '$D(^TMP("RGDFNDT",$J,RGDFN)) S ^TMP("RGDFNDT",$J,RGDFN)=0
151 ...I $D(^TMP("RGDFNDT",$J,RGDFN)) D
152 ....S ^TMP("RGDFNDT",$J,RGDFN)=^TMP("RGDFNDT",$J,RGDFN)+1
153 ....S ^TMP("RGDFNDT",$J,RGDFN,IEN,IEN2)=$P(EXCDT,".") ;date only/no time
154 ;If RGDFN has more than 1 exception, see if any are for same DAY.
155 ;Process the ^TMP("RGDFNDT",$J global to build LOC array.
156 I $D(^TMP("RGDFNDT",$J)) D
157 .S RGDFN=""
158 .F S RGDFN=$O(^TMP("RGDFNDT",$J,RGDFN)) Q:'RGDFN D
159 ..;If only one 234 exception for DFN ignore it.
160 ..I ^TMP("RGDFNDT",$J,RGDFN)=1 Q
161 ..;More than one for this DFN? How many for same day?
162 ..S IEN=0 K LOC
163 ..F S IEN=$O(^TMP("RGDFNDT",$J,RGDFN,IEN)) Q:'IEN D
164 ...S (IEN2,VAL)=0
165 ...F S IEN2=$O(^TMP("RGDFNDT",$J,RGDFN,IEN,IEN2)) Q:'IEN2 D
166 ....S VAL=$P(^TMP("RGDFNDT",$J,RGDFN,IEN,IEN2),"^")
167 ....I '$D(LOC(VAL)) S LOC(VAL)=0
168 ....I $D(LOC(VAL)) D
169 .....S LOC(VAL)=LOC(VAL)+1
170 .....S LOC(VAL,IEN,IEN2)=""
171 ..;Process the LOC array; contains numbers / day / DFN.
172 ..;If only 1 exception / day, keep it.
173 ..S RGDT=0 K CTR,TOT
174 ..F S RGDT=$O(LOC(RGDT)) Q:'RGDT D
175 ...S TOT=LOC(RGDT)
176 ...I TOT=1 K TOT Q ;only 1.
177 ...;More than 1, delete all except 1.
178 ...S TOT=TOT-1 ;leave 1; doesn't matter which - all are same day.
179 ...S IEN=0,CTR=0
180 ...F S IEN=$O(LOC(RGDT,IEN)) Q:'IEN D
181 ....I CTR=TOT Q
182 ....S CTR=CTR+1,IEN2=0
183 ....F S IEN2=$O(LOC(RGDT,IEN,IEN2)) Q:'IEN2 D DEL ;delete entry
184 K CNT,CTR,EXCDT,IEN,IEN2,LOC,NUM,OLDDT,OLDNODE,RGDFN,RGDT,TOT,VAL,^TMP("RGDFNDT")
185 Q
186PRGZZ ;Purge if name field is null (incomplete record)
187 ;Purge if -9 node exists, this indicates the record has been merged.
188 S EXCTYP="",CNT=""
189 F S EXCTYP=$O(^RGHL7(991.1,"ADFN",EXCTYP)) Q:'EXCTYP D
190 . S RGDFN=""
191 . F S RGDFN=$O(^RGHL7(991.1,"ADFN",EXCTYP,RGDFN)) Q:'RGDFN D
192 .. S IEN=0
193 .. F S IEN=$O(^RGHL7(991.1,"ADFN",EXCTYP,RGDFN,IEN)) Q:'IEN D
194 ... S IEN2=0
195 ... F S IEN2=$O(^RGHL7(991.1,"ADFN",EXCTYP,RGDFN,IEN,IEN2)) Q:'IEN2 D
196 .... S DFN=RGDFN D DEM^VADPT
197 .... I VADM(1)=""!($D(^DPT(RGDFN,-9))) D
198 ..... S NUM="" S NUM=$P(^RGHL7(991.1,IEN,1,0),"^",4)
199 ..... I NUM=1 S DIK="^RGHL7(991.1,",DA=IEN D ^DIK K DIK,DA
200 ..... E I NUM>1 D DEL
201 K EXCTYP,RGDFN,DFN,IEN,IEN2,NUM,VADM
202 Q
203DEL ;
204 S CNT=CNT+1
205 S DA(1)=IEN,DA=IEN2
206 S DIK="^RGHL7(991.1,"_DA(1)_",1,"
207 D ^DIK K DIK,DA
208 Q
209PROC ;Set these exception types to PROCESSED if they have a national ICN
210 ;209 - Required field(s) missing for patient sent to MPI,
211 ;227 - Multiple ICNs, 213 - SSN Match Failed, 214 - Name Doesn't Match
212 S EXCTYP=""
213 S HOME=$$SITE^VASITE()
214 F S EXCTYP=$O(^RGHL7(991.1,"AC",EXCTYP)) Q:'EXCTYP D
215 . I (EXCTYP=209)!(EXCTYP=227)!(EXCTYP=213)!(EXCTYP=214) D ;**43
216 .. S IEN=0
217 .. F S IEN=$O(^RGHL7(991.1,"AC",EXCTYP,IEN)) Q:'IEN D
218 ... S IEN2=0,ICN="",RGDFN=""
219 ... F S IEN2=$O(^RGHL7(991.1,"AC",EXCTYP,IEN,IEN2)) Q:'IEN2 D
220 .... S RGDFN=$P(^RGHL7(991.1,IEN,1,IEN2,0),"^",4) Q:'RGDFN
221 .... S ICN=+$$GETICN^MPIF001(RGDFN)
222 .... I $E(ICN,1,3)'=$E($P(HOME,"^",3),1,3)&(ICN>0) D
223 ..... L +^RGHL7(991.1,IEN):10
224 ..... S DA(1)=IEN,DA=IEN2,DR="6///"_1,DIE="^RGHL7(991.1,"_DA(1)_",1,"
225 ..... D ^DIE K DIE,DA,DR
226 ..... L -^RGHL7(991.1,IEN)
227 K EXCTYP,HOME,ICN,IEN,IEN2,RGDFN
228 Q
Note: See TracBrowser for help on using the repository browser.