source: FOIAVistA/trunk/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XUMF4.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.2 KB
Line 
1XUMF4 ;OIFO-OAK/RAM - Institution File Clean Up; 06/28/00
2 ;;8.0;KERNEL;**206,209,212,261**;Jul 10, 1995
3 ;
4 ;
5EN ; -- entry point
6 ;
7 K ^TMP("XUMF ARRAY",$J)
8 ;
9 N PARAM,XUMFLAG,ERROR,TEST,ERR
10 ;
11 S (ERROR,XUMFLAG,TEST)=0
12 ;
13 I $P($$PARAM^HLCS2,U,3)="T" S TEST=1
14 ;
15 L +^TMP("XUMF ARRAY",$J):0 D:'$T
16 .S ERROR="1^another process is using the Master File Server"
17 ;
18 I ERROR D EXIT1 Q
19 ;
20 I '$D(^TMP("XUMF ARRAY",$J)) D
21 .W !!,"...connecting with master file server..."
22 .D MFS0
23 ;
24 I ERROR D EXIT1 Q
25 ;
26 I '$D(^TMP("XUMF ARRAY",$J)) D D EXIT1 Q
27 .S ERROR="1^Connection to master file server failed!"
28 ;
29 D FTCLEAN^XUMF4A I ERROR D EXIT1 Q
30 ;
31 K ^TMP("XUMF ARRAY",$J),^TMP("XUMF MFS",$J)
32 ;
33 W !!,"...connecting with master file server..."
34 D MFS1
35 ;
36 I ERROR D EXIT1 Q
37 ;
38 I '$D(^TMP("XUMF ARRAY",$J)) D Q
39 .S ERROR="1^Connection to master file server failed!"
40 .D EXIT1
41 ;
42 D EN^VALM("XUMF NAME")
43 ;
44 D EXIT1
45 ;
46 Q
47 ;
48RDSN ; - resolve duplicate station number
49 ;
50 I '$O(@VALMAR@("INDEX",0)) D Q
51 .W !!,"No duplicates to select from!",!
52 .S VALMBCK="R" H 2
53 ;
54 N ENTRY,VALMY,DA,DR,DIE,STA,MERGED,FROM
55 ;
56 D EN^VALM2(XQORNOD(0),"OS")
57 Q:'$D(VALMY) Q:'$D(VALMAR)
58 ;
59 S DA=@VALMAR@("INDEX",+$O(VALMY(0)))
60 S DR="99///@",DIE=4
61 I DA D
62 .I $O(^HLCS(870,"C",DA,0)) D Q
63 ..W !!?20,"Pointed to by HL7 Logical Link"
64 ..W !?22,"*select other entry*",!!
65 .D ^DIE
66 ;
67 D @($E($P(VALMAR,"XUMF ",2),1,4)_"^XUMF4")
68 S VALMBCK="R"
69 ;
70 Q
71 ;
72 ;
73DSTA ; -- duplicate station #s
74 ;
75 K ^TMP("XUMF DSTA",$J),^TMP("XUMF TMP",$J)
76 ;
77 I 'XUMFLAG D LOCAL
78 ;
79 S STA="",IEN=0
80 F S STA=$O(^DIC(4,"D",STA)) Q:STA="" D
81 .F S IEN=$O(^DIC(4,"D",STA,IEN)) Q:'IEN D
82 ..Q:'$D(^TMP("XUMF ARRAY",$J,STA))
83 ..S ^TMP("XUMF TMP",$J,STA,IEN)=$P(^DIC(4,IEN,0),U)
84 ;
85 S STA="",(VALMCNT,IEN)=0
86 F S STA=$O(^TMP("XUMF TMP",$J,STA)) Q:STA="" D
87 .Q:'$O(^TMP("XUMF TMP",$J,STA,+$O(^TMP("XUMF TMP",$J,STA,0))))
88 .F S IEN=$O(^TMP("XUMF TMP",$J,STA,IEN)) Q:'IEN D
89 ..S VALMCNT=VALMCNT+1
90 ..S VAR="",NAME=$P(^TMP("XUMF TMP",$J,STA,IEN),U)
91 ..S VAR=$$SETFLD^VALM1(VALMCNT,VAR,"ENTRY NUMBER")
92 ..S VAR=$$SETFLD^VALM1(STA,VAR,"STATION NUMBER")
93 ..S VAR=$$SETFLD^VALM1(NAME,VAR,"INSTITUTION NAME")
94 ..S VAR=$$SETFLD^VALM1(IEN,VAR,"IEN")
95 ..D SET^VALM10(VALMCNT,VAR,VALMCNT)
96 ..S @VALMAR@("INDEX",VALMCNT)=IEN
97 ;
98 D:'VALMCNT
99 .S VAR="",VAR=$$SETFLD^VALM1("***No duplicates***",VAR,"INSTITUTION NAME")
100 .S VALMCNT=1
101 .D SET^VALM10(VALMCNT,VAR,VALMCNT)
102 ;
103 K ^TMP("XUMF TMP",$J)
104 ;
105 Q
106 ;
107LOCAL ; -- auto-delete local/duplicate station numbers
108 ;
109 W !!,"This action will auto-delete local/duplicate station numbers."
110 N Y S DIR(0)="Y",DIR("B")="YES" W !
111 S DIR("A")="Do you wish to proceed"
112 D ^DIR K DIR I 'Y Q
113 ;
114 S XUMFLAG=1
115 D DXRF
116 ;
117 N IEN,STA,STANUM,VAR,NAME,FLAG,CNT
118 ;
119 S STA="",(IEN,CNT)=0
120 F S STA=$O(^DIC(4,"D",STA)) Q:STA="" D
121 .Q:'$O(^DIC(4,"D",STA,+$O(^DIC(4,"D",STA,0))))
122 .S FLAG=0
123 .F S IEN=$O(^DIC(4,"D",STA,IEN)) Q:'IEN D
124 ..S:$O(^HLCS(870,"C",IEN,0)) FLAG=1
125 .Q:'FLAG
126 .F S IEN=$O(^DIC(4,"D",STA,IEN)) Q:'IEN D
127 ..Q:$O(^HLCS(870,"C",IEN,0))
128 ..W !?5,"deleting duplicate station number ",STA," from IEN: ",IEN
129 ..H 1
130 ..S DR="99///@",DIE=4,DA=IEN,CNT=CNT+1
131 ..N IEN,STA,FLAG D ^DIE
132 I CNT D EOP S CNT=0
133 ;
134 S STA="",IEN=0
135 F S STA=$O(^DIC(4,"D",STA)) Q:STA="" D
136 .Q:$D(^TMP("XUMF ARRAY",$J,STA))
137 .Q:'$D(^TMP("XUMF ARRAY",$J))
138 .F S IEN=$O(^DIC(4,"D",STA,IEN)) Q:'IEN D
139 ..S DR="99///@",DIE=4,DA=IEN,CNT=CNT+1
140 ..W !?5,"deleting local station number ",STA," from IEN: ",IEN
141 ..H 1
142 ..N IEN,STA D ^DIE
143 I CNT D EOP S CNT=0
144 ;
145 Q
146 ;
147 ;
148DXRF ; -- re-index "D" cross-reference
149 ;
150 N DIK
151 ;
152 K ^DIC(4,"D")
153 ;
154 S DIK="^DIC(4,",DIK(1)="99^D" D ENALL^DIK
155 ;
156 Q
157 ;
158 ;
159LLCL ; -- local data
160 ;
161 K ^TMP("XUMF LLCL",$J)
162 ;
163 N STA,IEN,STANUM,VAR,NAME,FTYP
164 ;
165 S STA="",VALMCNT=0
166 F S STA=$O(^DIC(4,"D",STA)) Q:STA="" D
167 .S IEN=$O(^DIC(4,"D",STA,0))
168 .S FTYP=$P($G(^DIC(4.1,+$G(^DIC(4,+IEN,3)),0)),U)
169 .Q:$D(^TMP("XUMF ARRAY",$J,STA))
170 .S VALMCNT=VALMCNT+1
171 .S VAR="",NAME=$P(^DIC(4,IEN,0),U)
172 .S VAR=$$SETFLD^VALM1(STA,VAR,"STATION NUMBER")
173 .S VAR=$$SETFLD^VALM1(NAME,VAR,"INSTITUTION NAME")
174 .S VAR=$$SETFLD^VALM1(IEN,VAR,"IEN")
175 .S VAR=$$SETFLD^VALM1(FTYP,VAR,"FACILITY TYPE")
176 .D SET^VALM10(VALMCNT,VAR,VALMCNT)
177 .S @VALMAR@("INDEX",VALMCNT)=IEN
178 ;
179 D:'VALMCNT
180 .S VAR="",VAR=$$SETFLD^VALM1("***None found***",VAR,"INSTITUTION NAME")
181 .D SET^VALM10(1,VAR,1)
182 ;
183 Q
184 ;
185 ;
186NATL ; -- national data to merge
187 ;
188 K ^TMP("XUMF NATL",$J)
189 ;
190 N STA,VAR,NAME,TYPE,STATE
191 ;
192 S STA="",VALMCNT=0
193 F S STA=$O(^TMP("XUMF ARRAY",$J,STA)) Q:STA="" D
194 .Q:$D(^DIC(4,"D",STA))
195 .S VALMCNT=VALMCNT+1
196 .S VAR="",NAME=$P(^TMP("XUMF ARRAY",$J,STA),U,2)
197 .S TYPE=$P($P(^TMP("XUMF ARRAY",$J,STA),U,5),"~")
198 .S STATE=$P(^TMP("XUMF ARRAY",$J,STA),U,8)
199 .S VAR=$$SETFLD^VALM1(STA,VAR,"STATION NUMBER")
200 .S VAR=$$SETFLD^VALM1(NAME,VAR,"NATIONAL NAME")
201 .S VAR=$$SETFLD^VALM1(STATE,VAR,"STATE")
202 .S VAR=$$SETFLD^VALM1(TYPE,VAR,"TYPE")
203 .D SET^VALM10(VALMCNT,VAR,VALMCNT)
204 ;
205 D:'VALMCNT
206 .S VAR="",VAR=$$SETFLD^VALM1("***None found***",VAR,"NATIONAL NAME")
207 .D SET^VALM10(1,VAR,1)
208 ;
209 Q
210 ;
211 ;
212NAME ; -- compare INSTITUTION name vs national name
213 ;
214 K ^TMP("XUMF NAME",$J),^TMP("XUMF TABLE",$J)
215 ;
216 N STA,IEN,NAME,GOLD,NAME,VAR,ARRAY
217 ;
218 D DXRF
219 ;
220 S STA="",(IEN,VALMCNT)=0
221 F S STA=$O(^DIC(4,"D",STA)) Q:STA="" D
222 .S IEN=$O(^DIC(4,"D",STA,0))
223 .S GOLD=$P($G(^TMP("XUMF ARRAY",$J,STA)),U,2)
224 .S NAME=$P(^DIC(4,IEN,0),U)
225 .S ^TMP("XUMF TABLE",$J,STA,IEN)=NAME_U_GOLD
226 ;
227 F S STA=$O(^TMP("XUMF ARRAY",$J,STA)) Q:STA="" D
228 .Q:$D(^TMP("XUMF TABLE",$J,STA))
229 .S NAME=$P(^TMP("XUMF ARRAY",$J,STA),U,2)
230 .S ^TMP("XUMF TABLE",$J,STA,9999)="^"_NAME
231 ;
232 S (IEN,VALMCNT)=0
233 F S STA=$O(^TMP("XUMF TABLE",$J,STA)) Q:STA="" D
234 .F S IEN=$O(^TMP("XUMF TABLE",$J,STA,IEN)) Q:'IEN D
235 ..S GOLD=$P(^TMP("XUMF TABLE",$J,STA,IEN),U,2)
236 ..S NAME=$P(^TMP("XUMF TABLE",$J,STA,IEN),U)
237 ..S VALMCNT=VALMCNT+1,VAR=""
238 ..S VAR=$$SETFLD^VALM1(STA,VAR,"STATION NUMBER")
239 ..S VAR=$$SETFLD^VALM1(NAME,VAR,"INSTITUTION NAME")
240 ..S VAR=$$SETFLD^VALM1(GOLD,VAR,"GOLD NAME")
241 ..D SET^VALM10(VALMCNT,VAR,VALMCNT)
242 ;
243 D:'VALMCNT
244 .S VAR="",VAR=$$SETFLD^VALM1("***None found***",VAR,"INSTITUTION NAME")
245 .D SET^VALM10(1,VAR,1)
246 ;
247 K ^TMP("XUMF TABLE",$J)
248 ;
249 Q
250 ;
251 ;
252MFS0 ; -- get national facility type file from Master File Server
253 ;
254 D FACTYP^XUMF4A
255 D STATE^XUMF4A
256 ;
257 S PARAM("LLNK")="XUMF MFR^XUMF "_$S('TEST:"FORUM",1:"TEST")
258 S PARAM("PROTOCOL")=$O(^ORD(101,"B","XUMF MFQ",0))
259 ;
260 W !!,"...getting FACILITY TYPE file..."
261 D MAIN^XUMFP(4.1,"ALL",7,.PARAM,.ERROR) Q:ERROR
262 D MAIN^XUMFI(4.1,"ALL",7,.PARAM,.ERROR) Q:ERROR
263 D MAIN^XUMFH
264 ;
265 Q
266 ;
267MFS1 ; -- get national facility type file from Master File Server
268 ;
269 S PARAM("LLNK")="XUMF MFR^XUMF "_$S('TEST:"FORUM",1:"TEST")
270 S PARAM("PROTOCOL")=$O(^ORD(101,"B","XUMF MFQ",0))
271 ;
272 W !!,"...getting INSTITUTION file..."
273 W !,"...please wait...(approx. 5 minutes)..."
274 D MAIN^XUMFP(4,"ALL",7,.PARAM,.ERROR) Q:ERROR
275 D MAIN^XUMFI(4,"ALL",7,.PARAM,.ERROR) Q:ERROR
276 D MAIN^XUMFH
277 ;
278 Q
279 ;
280EXIT ; -- cleanup and quit
281 ;
282 K:$D(VALMAR) @VALMAR
283 ;
284 Q
285 ;
286EXIT1 ;
287 ;
288 K ^TMP("XUMF ARRAY",$J),^TMP("XUMF MFS",$J)
289 K ^TMP("DIERR",$J)
290 ;
291 L -^TMP("XUMF ARRAY",$J)
292 ;
293 I ERROR D
294 .N XMY S XMY("G.XUMF INSTITUTION")=""
295 .D EM^XUMFH(ERROR,.ERR,"IFR CLEANUP",.XMY)
296 .W !!,ERROR,!,$G(ERR),!
297 ;
298 Q
299 ;
300EOP ; -- End-of-Page
301 ;
302 S DIR(0)="E"
303 D ^DIR,CLEAR^VALM1
304 S VALMBCK="R"
305 ;
306 Q
307 ;
Note: See TracBrowser for help on using the repository browser.