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/XUMF.m@ 677

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

initial load of FOIAVistA 6/30/08 version
File size: 8.2 KB
Line 
1XUMF ;OIFO-OAK/RAM - XUMF API's;04/15/02
2 ;;8.0;KERNEL;**218,335,416**;Jul 10, 1995;Build 5
3 ;
4 Q
5 ;
6IEN(IFN,CDSYS,ID) ; -- Internal Entry Number
7 ;
8 N IEN,ROOT
9 ;
10 S IFN=$G(IFN),CDSYS=$G(CDSYS),ID=$G(ID)
11 ;
12 Q:'IFN "0^IFN required"
13 Q:CDSYS="" "0^CDSYS required"
14 Q:ID="" "0^ID required"
15 ;
16 S ROOT=$$ROOT^DILFD(IFN,,1) Q:ROOT="" "0^invalid IFN"
17 S IEN=$O(@ROOT@("XUMFIDX",CDSYS,ID,0))
18 ;
19 Q $S(IEN:IEN,1:"0^not found")
20 ;
21FLD(FILE,FIELD) ; field
22 ;
23 N Y,DA,X
24 ;
25 S Y=$$FIELD(FILE,FIELD,"LABEL")
26 ;
27 Q $S(Y'="":1,1:0)
28 ;
29LBL(FILE,FIELD) ; field label
30 ;
31 Q $$FIELD(FILE,FIELD,"LABEL")
32 ;
33TYP(FILE,FIELD) ; field type
34 ;
35 Q $$FIELD(FILE,FIELD,"TYPE")
36 ;
37PTR(FILE,FIELD) ; pointer field?
38 ;
39 Q $S($$TYP(FILE,FIELD)="POINTER":1,1:0)
40 ;
41FIELD(FILE,FIELD,ATT) ; field attributes
42 ;
43 N Y,DA,X
44 ;
45 Q:'$G(FILE) ""
46 Q:'$G(FIELD) ""
47 Q:$G(ATT)="" ""
48 ;
49 D FIELD^DID(FILE,FIELD,"N",ATT,"Y")
50 ;
51 Q $G(Y(ATT))
52 ;
53FILE(FILE,ATT) ; file attributes
54 ;
55 N Y,DA,X
56 ;
57 Q:'$G(FILE) ""
58 Q:$G(ATT)="" ""
59 ;
60 D FILE^DID(FILE,,ATT,"Y")
61 ;
62 Q $G(Y(ATT))
63 ;
64ECHO(FILE,IDX,X,XUMF) ; validate field exists and echo name
65 ;
66 Q:'$$F(+$G(XUMF)) 0
67 ;
68 N SUBFILE,NAME
69 ;
70 S SUBFILE=$P($G(^DIC(4.001,+$G(FILE),1,+$G(IDX),0)),U,4)
71 ;
72 S NAME=$$LBL($S(SUBFILE:SUBFILE,1:+$G(FILE)),X)
73 ;
74 Q:NAME="" 0
75 ;
76 ;W " "_NAME
77 ;
78 Q 1
79 ;
80F(XUMF) ; constrain edits to standard values
81 ;
82 Q $S($G(XUMF):1,1:0)
83 ;
84PKV(IFN,IEN,HLCS) ; Primary Key Value - MFE.4
85 ;
86 S IFN=$G(IFN),IEN=$G(IEN),HLCS=$G(HLCS)
87 ;
88 N MFE,NODE,ID,TEXT,CDSYS,IENS
89 ;
90 S NODE=$G(^DIC(4.001,IFN,"MFE"))
91 Q:NODE="" "1Error - MFS parameter not defined for IFN "_IFN
92 ;
93 S:HLCS="" HLCS="~"
94 S CDSYS=$P(NODE,U,3)
95 ;
96 Q:IEN="NEW" IEN_HLCS_"NEW ENTRY"_HLCS_CDSYS
97 ;
98 Q:'IFN "1Error - IFN required"
99 Q:'IEN "1Error - IEN required"
100 ;
101 S IENS=IEN_","
102 ;
103 S FIELD=$P(NODE,U,1),ID=$$GET1^DIQ(IFN,IENS,FIELD)
104 S FIELD=$P(NODE,U,2),TEXT=$$GET1^DIQ(IFN,IENS,FIELD)
105 ;
106 S MFE=ID_HLCS_TEXT_HLCS_CDSYS
107 ;
108 Q:'$P(NODE,U,4) MFE
109 ;
110 S FIELD=$P(NODE,U,4),ID=$$GET1^DIQ(IFN,IENS,FIELD)
111 S FIELD=$P(NODE,U,5),TEXT=$$GET1^DIQ(IFN,IENS,FIELD)
112 S CDSYS=$P(NODE,U,6)
113 ;
114 Q MFE_HLCS_ID_HLCS_TEXT_HLCS_CDSYS
115 ;
116MFE(IFN,PKV,HLCS,IEN,ERROR) ; -- update
117 ;
118 N IENS,MFE,I,X,ID,XREF,NAME,FLD,FDA,DIC
119 ;
120 S IFN=$G(IFN),IEN=$G(IEN),HLCS=$G(HLCS),ERROR=$G(ERROR)
121 S:HLCS="" HLCS="~"
122 ;
123 Q:ERROR
124 ;
125 I 'IFN S ERROR="1Error - IFN required" Q
126 ;
127 I IFN'=4.001 D Q:ERROR
128 .S MFE=$G(^DIC(4.001,IFN,"MFE")),XREF=$P(MFE,U,8)
129 .I '$P(MFE,U,1) D Q
130 ..S ERROR="1MFS PARAM MFE.4.1 null"
131 ..D EM^XUMFH(ERROR,.ERR)
132 .I '$P(MFE,U,2) D Q
133 ..S ERROR="1MFS PARAM MFE.4.2 null"
134 ..D EM^XUMFH(ERROR,.ERR)
135 .I XREF="" D Q
136 ..S ERROR="1MFS PARAM MFE XREF not defined"
137 ..D EM^XUMFH(ERROR,.ERR)
138 ;
139 I IFN=4.001 D Q
140 .S IEN=$$FIND1^DIC(1,,"BX",$P(PKV,HLCS))
141 .I 'IEN D Q
142 ..S ERROR="1not a valid IEN in MFE XUMF"
143 ..D EM^XUMFH(ERROR,.ERR)
144 .Q:$D(^DIC(4.001,IEN))
145 .X HLNEXT
146 .I $P(HLNODE,HLFS)'="ZZZ" D Q
147 ..S ERROR="1MFP error in MFE XUMF"
148 ..D EM^XUMFH(ERROR,.ERR)
149 .S MFE=$P(HLNODE,HLFS,7,12),MFE=$TR(MFE,HLFS,U)
150 .S X="" F I=5,4,2,1 S:$P(MFE,U,I)=.01 X=I
151 .I 'X D Q
152 ..S ERROR="1MFS PARAM no .01 in MFE"
153 ..D EM^XUMFH(ERROR,.ERR)
154 .S NAME=$P(PKV,HLCS,X) K X
155 .K FDA
156 .S FDA(IFN,"?+1,",.01)=NAME
157 .D UPDATE^DIE("E","FDA")
158 ;
159 S ID=$P(PKV,HLCS)
160 I ID="" D Q
161 .S ERROR="1MFS PARAM MFE PKV ID null"
162 .D EM^XUMFH(ERROR,.ERR)
163 S ROOT=$$ROOT^DILFD(IFN,,1)
164 I $D(@ROOT@(XREF)),'$G(IEN) S IEN=$O(@ROOT@(XREF,ID,0))
165 S:'IEN IEN=$$FIND1^DIC(IFN,,"B",ID)
166 ;
167 I 'IEN D Q:ERROR
168 .S X="" F I=5,4,2,1 S:$P(MFE,U,I)=.01 X=I
169 .I 'X D Q
170 ..S ERROR="1MFS PARAM no .01 in MFE"
171 ..D EM^XUMFH(ERROR,.ERR)
172 .S NAME=$P(PKV,HLCS,X) K X
173 .I NAME="" S ERROR="1MFS PARAM MFE PKV .01 is null" Q
174 .D CHK^DIE(IFN,.01,,NAME,.X)
175 .I X="^" D Q
176 ..S ERROR="1MFS PARAM MFE PKV .01 is invalid"
177 ..D EM^XUMFH(ERROR,.ERR)
178 .K DIC S DIC=IFN,DIC(0)="F" D FILE^DICN K DIC
179 .I Y="-1" D Q
180 ..S ERROR="1MFS PARAM MFE FileDICN unsuccessful"
181 ..D EM^XUMFH(ERROR,.ERR)
182 .S IEN=+Y
183 ;
184 S IENS=IEN_","
185 ;
186 F I=1,2,4,5 D
187 .S FLD=$P(MFE,U,I) Q:'FLD
188 .S FDA(IFN,IENS,FLD)=$P(PKV,HLCS,I)
189 ;
190 D FILE^DIE("E","FDA","ERR")
191 I $D(ERR) D
192 .D EM^XUMFH("1FILE DIE error msg in MFE of XUMF",.ERR)
193 .K ERR
194 ;
195 Q
196 ;
197MFP(IFN,ERR) ; -- validate Master File Parameters entry FALSE=valid
198 ;
199 Q:'$G(IFN) "IFN null"
200 ;
201 D ZERO(IFN,.ERR)
202 D MFE1(IFN,.ERR)
203 D SEQ(IFN,.ERR)
204 ;
205 Q $S($D(ERR("FATAL")):1,$D(ERR("WARNING")):2,1:0)
206 ;
207ZERO(IFN,ERR) ; -- zero node
208 ;
209 N X,CNT
210 ;
211 S X=$G(^DIC(4.001,+IFN,0)),CNT=1
212 I $P(X,U,2)="" D
213 .S ERR("FATAL","ZERO",CNT)="Z SEGMENT is null",CNT=CNT+1
214 I $P(X,U,3)="" D
215 .S ERR("FATAL","ZERO",CNT)="MFI CODE is null",CNT=CNT+1
216 I $P(X,U,4)="" D
217 .S ERR("WARNING","ZERO",CNT)="PRE-UPDATE ROUTINE is null",CNT=CNT+1
218 I $P(X,U,5)="" D
219 .S ERR("WARNING","ZERO",CNT)="POST-UPDATE ROUTINE is null",CNT=CNT+1
220 I $P(X,U,6)="" D
221 .S ERR("WARNING","ZERO",CNT)="MAIL GROUP is null",CNT=CNT+1
222 ;
223 Q
224 ;
225MFE1(IFN,ERR) ; -- MFE node
226 ;
227 N X,I,CNT
228 ;
229 S X=$G(^DIC(4.001,+IFN,"MFE")),CNT=1
230 F I=1:1:6 I $P(X,U,I)="" D
231 .S ERR("FATAL","MFE",CNT)="MFE ID & ALT ID field and codsys required"
232 .S CNT=CNT+1
233 I $P(X,U,8)="" D
234 .S ERR("FATAL","MFE",CNT)="MFE PKV X-REF required",CNT=CNT+1
235 F I=11,12,14,15 I $P(X,U,I)="" D
236 .S ERR("WARNING","MFE",CNT)="MFE PKV types are null",CNT=CNT+1
237 I $P(X,U,9)="" D
238 .S ERR("WARNING","MFE",CNT)="ASSIGNING AUTHORITY is null",CNT=CNT+1
239 ;
240 Q
241 ;
242SEQ(IFN,ERR) ; -- sequence nodes
243 ;
244 N SEQ,MULT,X,I,Y
245 ;
246 S SEQ=0
247 F S SEQ=$O(^DIC(4.001,IFN,1,SEQ)) Q:'SEQ D
248 .S X=$G(^DIC(4.001,IFN,1,SEQ,0))
249 .I $$TYP($S($P(X,U,4):$P(X,U,4),1:IFN),$P(X,U,2))="POINTER" D
250 ..Q:$P(X,U,7)'=""
251 ..S Y=$S($P(X,U,4):$P(X,U,4),1:IFN),Y=$$LBL(Y,$P(X,U,2))
252 ..S Y="field "_Y_" is pointer EXTENDED POINTER LKUP is NULL"
253 ..S ERR("WARNING",SEQ)=Y
254 .S MULT=$S($P(X,U,4):1,1:0)
255 .I '$P(X,U,2) S ERR("FATAL",SEQ)=" missing FIELD NUMBER"
256 .I MULT,$P(X,U,8)="" D
257 ..S ERR("FATAL",SEQ)=" MULT IEN FUNCTION is null"
258 .I MULT,$P(X,U,6),$P(X,U,5)'="" D
259 ..S ERR("FATAL",SEQ)=" SUBFILE KEY LKUP/KEY SEQ mismatch"
260 .I MULT,'$P(X,U,6),$P(X,U,5)="" D
261 ..S ERR("FATAL",SEQ)=" SUBFILE KEY LKUP/KEY SEQ mismatch"
262 .I 'MULT F I=5,6,8 D
263 ..Q:$P(X,U,I)=""
264 ..S ERR("FATAL",SEQ)=" SUBFILE null with subfile parameters"
265 ;
266 Q
267 ;
268BG(IFN,IEN,TYP) ; -- background job
269 ;
270 ; type (5=file, 7=array)
271 ;
272 N ZTRTN,ZTDESC,ZTDTH,ZTIO,ZTSAVE
273 ;
274 S TYP=$G(TYP) S:'TYP TYP=5
275 S IEN=$G(IEN) S:IEN="" IEN="ALL"
276 ;
277 S ZTDTH=$$NOW^XLFDT,ZTRTN="BG1^XUMF",ZTIO=""
278 S ZTSAVE("IFN")="",ZTSAVE("TYP")="",ZTSAVE("IEN")=""
279 S ZTDESC="XUMF get "_$$FILE^XUMF(IFN,"NAME")_" using MFS"
280 ;
281 D ^%ZTLOAD
282 ;
283 Q
284 ;
285BG1 ; -- get file
286 ;
287 D MFS(IFN,IEN,TYP,.ERROR),EXIT
288 ;
289 Q
290 ;
291LOAD(IFN) ; -- query and file
292 ;
293 D MFS(IFN,"ALL",5,.ERROR)
294 ;
295 Q
296 ;
297ARRAY(IFN) ; -- query and put in array
298 ;
299 D MFS(IFN,"ALL",7,.ERROR)
300 ;
301 Q
302 ;
303GETCE(IFN,IEN,TYP,ERROR) ; -- get master file provide coded element
304 ;
305 Q
306 ;
307MFS(IFN,IEN,TYP,ERROR) ; -- get file from Master File Server
308 ;
309 ; TYP (5=query/file, 7=query/tmp_array)
310 ;
311 N TEST
312 ;
313 S (ERROR,TEST)=0
314 ;
315 S IFN=$G(IFN),IEN=$G(IEN),TYP=$G(TYP)
316 ;
317 I 'IFN S ERROR="1IFN not valid MFS in XUMF" Q
318 I IEN="" S ERROR="1IEN not valid MFS in XUMF" Q
319 I TYP'=5,TYP'=7 S ERROR="1type not support by MFS in XUMF" Q
320 ;
321 I $P($$PARAM^HLCS2,U,3)="T" S TEST=1
322 ;
323 S PARAM("LLNK")="XUMF MFR^XUMF "_$S('TEST:"FORUM",1:"TEST")
324 S PARAM("PROTOCOL")=$O(^ORD(101,"B","XUMF MFQ",0))
325 ;
326 D MAIN^XUMFP(IFN,"ALL",TYP,.PARAM,.ERROR) Q:ERROR
327 D MAIN^XUMFI(IFN,"ALL",TYP,.PARAM,.ERROR) Q:ERROR
328 D MAIN^XUMFH
329 ;
330 Q
331 ;
332 ;
333EXIT ; -- cleanup and quit
334 ;
335 K ^TMP("XUMF MFS",$J),^TMP("DIERR",$J)
336 ;
337 S ZTREQ="@"
338 ;
339 Q
340 ;
341NPI ; -- NPI
342 ;
343 N COL,X,FDA,NPIDT,NPISTAT,NPI,TAX,TAXPC,TAXSTAT,ERR
344 ;
345 D SEGPRSE^XUMFXHL7("HLNODE","COL")
346 ;
347 S NPIDT=$$FMDATE^HLFNC(COL(17))
348 S NPISTAT=COL(18)
349 S NPI=COL(19)
350 S TAX=COL(20)
351 S TAXPC=COL(21)
352 S TAXSTAT=COL(22)
353 ;
354 S X=$$NPI^XUSNPI("Organization_ID",IEN,NPIDT)
355 I $S(X=0:1,$$UP^XLFSTR($P(X,U,3))'=NPISTAT:1,NPI'=+X:1,1:0) D
356 .S X=$$ADDNPI^XUSNPI("Organization_ID",IEN,NPI,NPIDT,$S(NPISTAT="ACTIVE":1,1:0))
357 ;
358 S IENS="?+1,"_IEN_","
359 K FDA
360 S FDA(4.9999,IENS,.01)="NPI"
361 S FDA(4.9999,IENS,.02)=NPI
362 D UPDATE^DIE("E","FDA",,"ERR")
363 ;
364 K FDA
365 S IENS="?+1,"_IEN_","
366 S FDA(4.043,IENS,.01)=TAX
367 S FDA(4.043,IENS,.02)=TAXPC
368 S FDA(4.043,IENS,.03)=TAXSTAT
369 D UPDATE^DIE("E","FDA",,"ERR")
370 ;
371 S SEQ=22
372 ;
373 Q
374 ;
375CDSYS(CDSYS,ID,IEN) ; udpate coding system / ID
376 ;
377 N IENS,FDA
378 ;
379 S IENS="?+1,"_IEN_","
380 K FDA
381 S FDA(4.9999,IENS,.01)=CDSYS
382 S FDA(4.9999,IENS,.02)=ID
383 D
384 .N IEN,VALUE
385 .D UPDATE^DIE("E","FDA")
386 ;
387 Q
388 ;
Note: See TracBrowser for help on using the repository browser.