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/XUMFX.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: 3.8 KB
Line 
1XUMFX ;ISS/RAM - XUMF API's;04/15/02
2 ;;8.0;KERNEL;**299,382,383**;Jul 10, 1995
3 ;
4 Q
5 ;
6 ;
7MFE(IFN,PKV,HLCS,IEN,ERROR) ; -- update
8 ;
9 N IENS,MFE,I,X,ID,XREF,NAME,FLD,FDA,DIC,Y
10 ;
11 S IFN=$G(IFN),IEN=$G(IEN),HLCS=$G(HLCS),ERROR=$G(ERROR)
12 S:HLCS="" HLCS="~"
13 ;
14 Q:ERROR
15 ;
16 I 'IFN S ERROR="1^Error - IFN required HLNODE: "_HLNODE Q
17 ;
18 I $P(PKV,HLCS)=""!($P(PKV,HLCS,2)="")!($P(PKV,HLCS,4)="") D Q:ERROR
19 .Q:$G(XUMFSDS)="1H"
20 .S ERROR="1^Error - PKV not valid HLNODE: "_HLNODE
21 .D EM^XUMFH(ERROR,.ERR)
22 ;
23 S MFE=$G(^DIC(4.001,IFN,"MFE")),XREF=$P(MFE,U,8)
24 I XREF="" D Q
25 .S ERROR="1^Error - MFE parameter XREF missing HLNODE: "_HLNODE
26 .D EM^XUMFH(ERROR,.ERR)
27 ;
28 ;I IFN=4.001 D Q
29 ;.S IEN=$$FIND1^DIC(1,,"BX",$P(PKV,HLCS))
30 ;.I 'IEN D Q
31 ;..S ERROR="1^not a valid IEN in MFE - HLNODE: "_HLNODE
32 ;..D EM^XUMFH(ERROR,.ERR)
33 ;.Q:$D(^DIC(4.001,IEN))
34 ;.S NAME=$P(PKV,HLCS)
35 ;.K FDA
36 ;.S FDA(IFN,"?+1,",.01)=NAME
37 ;.D UPDATE^DIE("E","FDA",,"ERR")
38 ;.I $D(ERR) D Q
39 ;..S ERROR="1^MFE UPDATE FAILED for .01 File#: "_IFN
40 ;..D EM^XUMFH(ERROR,.ERR)
41 ;
42 ;lookup an active VUID
43 S VUID=$P(PKV,HLCS)
44 I $G(XUMFSDS)="1H" S VUID=$P(PKV,HLCS,4)
45 S ROOT=$$ROOT^DILFD(IFN,,1)
46 I '$L(ROOT) D Q
47 .S ERROR="1^Error - MFE no root file#: "_IFN
48 .D EM^XUMFH(ERROR,.ERR)
49 S IEN=$O(@ROOT@("AMASTERVUID",VUID,1,0))
50 ;
51 ;reactivate an existing inactive VUID
52 I 'IEN D
53 .S IEN=$O(@ROOT@("AMASTERVUID",VUID,0,0)) Q:'IEN
54 .K FDA,ERR
55 .S IENS=IEN_","
56 .S FDA(IFN,IENS,99.98)=1
57 .D FILE^DIE("E","FDA","ERR")
58 .I $D(ERR) D
59 ..S ERROR="1^flag update error for IFN: "_IFN_" IEN: "_IEN_" PKV: "_PKV
60 ..D EM^XUMFH(ERROR,.ERR)
61 ..K ERR
62 ;
63 Q:IEN
64 ;
65 I $G(XUMFSDS)="1H",'IEN D Q
66 .S ERROR="1^SDS history could not find owning record PKV: "_PKV
67 .D EM^XUMFH(ERROR,.ERR)
68 ;
69 I 'IEN D
70 .S KEY=$P(PKV,HLCS,4)
71 .S IEN=$O(@ROOT@(XREF,KEY,0))
72 ;
73 I 'IEN D Q:ERROR
74 .S NAME=$P(PKV,HLCS,2)
75 .D CHK^DIE(IFN,.01,,NAME,.X)
76 .I X="^" D Q
77 ..S ERROR="1^Error - PKV .01 is invalid"_" File #: "_IFN_" PKV="_PKV
78 ..D EM^XUMFH(ERROR,.ERR)
79 .K DIC S DIC=IFN,DIC(0)="F" D FILE^DICN K DIC
80 .I Y="-1" D Q
81 ..S ERROR="1^stub entry for "_PKV_" failed PKV: "_PKV
82 ..D EM^XUMFH(ERROR,.ERR)
83 .S IEN=+Y
84 ;
85 S IENS=IEN_","
86 ;
87 I $L($P(MFE,U)),$P(MFE,U)'=99.99 Q
88 S FDA(IFN,IENS,99.99)=$P(PKV,HLCS,1)
89 S FDA(IFN,IENS,99.98)=1
90 ;
91 K ERR
92 ;
93 D FILE^DIE("E","FDA","ERR")
94 I $D(ERR) D
95 .S ERROR="1^VUID update error for IFN: "_IFN_" IEN: "_IEN_" PKV: "_PKV
96 .D EM^XUMFH(ERROR,.ERR)
97 .K ERR
98 ;
99 Q
100 ;
101VUID(FILE,FIELD,VUID,X) ; -- If value type pointer and VUID may be used,
102 ; get IEN and set it as internal value
103 N XVUID,X1
104 Q:'$L(FILE)!'FIELD!'$L(VUID) 0
105 Q:$E(X,1,$L(VUID))'=VUID 0
106 S XVUID=$E(X,$L(VUID)+1,$L(X))
107 D FIELD^DID(FILE,FIELD,,"POINTER","X1")
108 S X1=$G(X1("POINTER"))
109 Q:'$L(X1) 0
110 S X1=U_X1_"""AMASTERVUID"",XVUID,1,0)"
111 S X1=$O(@X1)
112 Q +X1
113 ;
114VAL(FILE,FIELD,VUID,VALUE,IENS) ; convert to internal
115 ;
116 N RESULT,ERR
117 ;
118 I $L(VUID) D Q RESULT
119 .I VUID="SDS" S VALUE=VUID_+VALUE
120 .S RESULT=$$VUID(FILE,FIELD,VUID,VALUE)
121 .I 'RESULT D
122 ..S RESULT="^",ERROR="1^VUID lookup failed on "_VALUE
123 ..D EM("VUID lookup failed on "_VALUE)
124 ;
125 I VALUE["\F\" F Q:VALUE'["\F\" D
126 .S VALUE=$P(VALUE,"\F\")_"^"_$P(VALUE,"\F\",2,9999)
127 I VALUE["\T\" F Q:VALUE'["\T\" D
128 .S VALUE=$P(VALUE,"\T\")_"&"_$P(VALUE,"\T\",2,9999)
129 ;
130 D VAL^DIE(FILE,IENS,FIELD,,VALUE,.RESULT,,"ERR")
131 I $D(ERR) D EM("validation error",.ERR)
132 I RESULT="^" S ERROR="1^data validation error"
133 ;
134 Q RESULT
135 ;
136EM(ERROR,ERR,XMSUB,XMY) ; -- error message
137 ;
138 N X,XMTEXT,XMDUZ,GROUP
139 ;
140 D MSG^DIALOG("AM",.X,80,,"ERR")
141 ;
142 S X(.1)="HL7 message ID: "_$G(HL("MID"))
143 S X(.2)="",X(.3)=$G(ERROR)
144 S X(.4)="",X(.5)="Key: "_$G(KEY),X(.6)=""
145 S:$G(XMSUB)="" XMSUB="MFS ERROR/WARNING/INFO"
146 S XMY("G.XUMF ERROR")="",XMDUZ=.5
147 S GROUP=$P($G(^DIC(4.001,+IFN,0)),U,6)
148 I GROUP'="" S GROUP="G."_GROUP,XMY(GROUP)=""
149 S XMTEXT="X("
150 ;
151 M ^TMP("XUMF ERROR",$J,$O(^TMP("XUMF ERROR",$J,9999999999999),-1)+1)=X
152 ;
153 D ^XMD
154 ;
155 Q
156 ;
Note: See TracBrowser for help on using the repository browser.