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

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

initial load of WorldVistAEHR
File size: 7.7 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,52**;30 Apr 99;Build 2
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 ;**52 Module is obsolete
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 ;**52 This module was obsolete before 52; just adding comment
94 ;S DIC="^RGHL7(991.11,",DIC(0)="QEAM"
95 ;S DIC("A")="Enter an exception type to purge: "
96 ;D ^DIC K DIC G:Y<200 QUIT S EXCTYP=+Y,ETYPE=X
97 ;S DIR(0)="YA",DIR("B")="YES"
98 ;S DIR("A")="*WARNING* This will permanently delete all "_ETYPE_" exceptions. Are you sure you want to do this? YES// "
99 ;D ^DIR Q:$D(DIRUT) I Y>0 D
100 ;. S CNT=0,IEN=""
101 ;. F S IEN=$O(^RGHL7(991.1,"AC",EXCTYP,IEN)) Q:'IEN D
102 ;.. S IEN2=0
103 ;.. F S IEN2=$O(^RGHL7(991.1,"AC",EXCTYP,IEN,IEN2)) Q:'IEN2 D
104 ;... S NUM="" S NUM=$P(^RGHL7(991.1,IEN,1,0),"^",4)
105 ;... I NUM=1 S DIK="^RGHL7(991.1,",DA=IEN D ^DIK K DIK,DA S CNT=CNT+1
106 ;... E I NUM>1 D DEL
107 ;I CNT=0 W !,"There are no "_ETYPE_" exceptions on file."
108 ;E I CNT>0 W !,CNT_" "_ETYPE_" Exceptions purged!"
109 ;K ETYPE,CNT,IEN,IEN2,NUM,X,Y
110 Q ;**52;if module accidentally called, should quit instead of falling into next module.
111PRGDUP ;Purge Duplicate Entries; retain most recent for all except types.
112 ;**50 through remainder of module.
113 S EXCTYP="",CNT=0
114 K ^TMP("RGEVDUP",$J)
115 F S EXCTYP=$O(^RGHL7(991.1,"ADFN",EXCTYP)) Q:'EXCTYP D
116 . S RGDFN=""
117 . F S RGDFN=$O(^RGHL7(991.1,"ADFN",EXCTYP,RGDFN)) Q:'RGDFN D
118 .. S IEN=0
119 .. F S IEN=$O(^RGHL7(991.1,"ADFN",EXCTYP,RGDFN,IEN)) Q:'IEN D
120 ... S IEN2=0
121 ... F S IEN2=$O(^RGHL7(991.1,"ADFN",EXCTYP,RGDFN,IEN,IEN2)) Q:'IEN2 D
122 .... I $P($G(^RGHL7(991.1,IEN,1,IEN2,0)),"^",5)=1 K ^RGHL7(991.1,"ADFN",EXCTYP,RGDFN,IEN,IEN2) Q ;exception processed
123 .... S EXCDT=$P($G(^RGHL7(991.1,IEN,0)),"^",3) ;incoming date
124 .... I '$D(^TMP("RGEVDUP",$J,RGDFN,EXCTYP)) D Q
125 ..... S ^TMP("RGEVDUP",$J,RGDFN,EXCTYP)=EXCDT_"^"_IEN_"^"_IEN2
126 .... I $D(^TMP("RGEVDUP",$J,RGDFN,EXCTYP)) D ;duplicate exists; compare incoming to previous.
127 ..... S OLDNODE=^TMP("RGEVDUP",$J,RGDFN,EXCTYP)
128 ..... S OLDDT=$P(OLDNODE,"^"),OLDIEN=$P(OLDNODE,"^",2),OLDIEN2=$P(OLDNODE,"^",3)
129 ..... I EXCDT>OLDDT D Q ;incoming date greater than previous? purge old, keep new.
130 ...... S NUM="" S NUM=$P(^RGHL7(991.1,IEN,1,0),"^",4)
131 ...... I NUM=1 S DIK="^RGHL7(991.1,",DA=OLDIEN D ^DIK K DIK,DA
132 ...... I NUM>1 D
133 ....... S DA(1)=OLDIEN,DA=OLDIEN2
134 ....... S DIK="^RGHL7(991.1,"_DA(1)_",1," D ^DIK K DIK,DA
135 ...... S ^TMP("RGEVDUP",$J,RGDFN,EXCTYP)=EXCDT_"^"_IEN_"^"_IEN2
136 ..... ;
137 ..... I OLDDT>EXCDT!(OLDDT=EXCDT) D ;previous date greater or equal incoming? purge new, keep old.
138 ...... S NUM="" S NUM=$P(^RGHL7(991.1,IEN,1,0),"^",4)
139 ...... I NUM=1 S DIK="^RGHL7(991.1,",DA=IEN D ^DIK K DIK,DA
140 ...... I NUM>1 D DEL
141 ...... ;
142 K CNT,EXCDT,EXCTYP,IEN,IEN2,NUM,OLDDT,OLDIEN,OLDIEN2,OLDNODE,RGDFN,RGDT,^TMP("RGEVDUP")
143 Q
144 ;
145PRGZZ ;Purge if name field is null (incomplete record)
146 ;Purge if -9 node exists, this indicates the record has been merged.
147 S EXCTYP="",CNT=""
148 F S EXCTYP=$O(^RGHL7(991.1,"ADFN",EXCTYP)) Q:'EXCTYP D
149 . S RGDFN=""
150 . F S RGDFN=$O(^RGHL7(991.1,"ADFN",EXCTYP,RGDFN)) Q:'RGDFN D
151 .. S IEN=0
152 .. F S IEN=$O(^RGHL7(991.1,"ADFN",EXCTYP,RGDFN,IEN)) Q:'IEN D
153 ... S IEN2=0
154 ... F S IEN2=$O(^RGHL7(991.1,"ADFN",EXCTYP,RGDFN,IEN,IEN2)) Q:'IEN2 D
155 .... S DFN=RGDFN D DEM^VADPT
156 .... I VADM(1)=""!($D(^DPT(RGDFN,-9))) D
157 ..... S NUM="" S NUM=$P(^RGHL7(991.1,IEN,1,0),"^",4)
158 ..... I NUM=1 S DIK="^RGHL7(991.1,",DA=IEN D ^DIK K DIK,DA
159 ..... E I NUM>1 D DEL
160 K EXCTYP,RGDFN,DFN,IEN,IEN2,NUM,VADM
161 Q
162DEL ;
163 S CNT=CNT+1
164 S DA(1)=IEN,DA=IEN2
165 S DIK="^RGHL7(991.1,"_DA(1)_",1,"
166 D ^DIK K DIK,DA
167 Q
168PROC ;Set these exception types to PROCESSED if they have a national ICN
169 ;**52 The PROC module is obsolete and is no longer being called.
170 ;209 - Required field(s) missing for patient sent to MPI,
171 ;227 - Multiple ICNs, 213 - SSN Match Failed, 214 - Name Doesn't Match
172 ;S EXCTYP=""
173 ;S HOME=$$SITE^VASITE()
174 ;F S EXCTYP=$O(^RGHL7(991.1,"AC",EXCTYP)) Q:'EXCTYP D
175 ;. I (EXCTYP=209)!(EXCTYP=227)!(EXCTYP=213)!(EXCTYP=214) D ;**43
176 ;.. S IEN=0
177 ;.. F S IEN=$O(^RGHL7(991.1,"AC",EXCTYP,IEN)) Q:'IEN D
178 ;... S IEN2=0,ICN="",RGDFN=""
179 ;... F S IEN2=$O(^RGHL7(991.1,"AC",EXCTYP,IEN,IEN2)) Q:'IEN2 D
180 ;.... S RGDFN=$P(^RGHL7(991.1,IEN,1,IEN2,0),"^",4) Q:'RGDFN
181 ;.... S ICN=+$$GETICN^MPIF001(RGDFN)
182 ;.... I $E(ICN,1,3)'=$E($P(HOME,"^",3),1,3)&(ICN>0) D
183 ;..... L +^RGHL7(991.1,IEN):10
184 ;..... S DA(1)=IEN,DA=IEN2,DR="6///"_1,DIE="^RGHL7(991.1,"_DA(1)_",1,"
185 ;..... D ^DIE K DIE,DA,DR
186 ;..... L -^RGHL7(991.1,IEN)
187 ;K EXCTYP,HOME,ICN,IEN,IEN2,RGDFN
188 Q
Note: See TracBrowser for help on using the repository browser.