source: WorldVistAEHR/trunk/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XUMF0.m@ 701

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

initial load of WorldVistAEHR
File size: 4.1 KB
Line 
1XUMF0 ;ISS/RAM - XUMF API's;04/15/02
2 ;;8.0;KERNEL;**407**;Jul 10, 1995;Build 8
3 ;
4 Q
5 ;
6 ;
7MFE(IFN,VUID,IEN,ERROR) ; -- update
8 ;
9 ;N IENS,MFE,I,X,ID,XREF,NAME,FLD,FDA,DIC,Y
10 ;
11 I 'IFN S ERROR="1^Error - IFN required HLNODE: "_HLNODE Q
12 I IFN=4.009 S IEN=$$FIND1^DIC(IFN,,"B","GLOBAL VERSION") Q
13 I 'VUID S ERROR="1^Error - VUID required HLNODE: "_HLNODE Q
14 ;
15 S ROOT=$$ROOT^DILFD(IFN,,1)
16 S IEN=$O(@ROOT@("AMASTERVUID",VUID,1,0))
17 ;
18 ;reactivate an existing inactive VUID
19 I 'IEN D
20 .S IEN=$O(@ROOT@("AMASTERVUID",VUID,0,0)) Q:'IEN
21 .K FDA,ERR
22 .S IENS=IEN_","
23 .S FDA(IFN,IENS,99.98)=1
24 .D FILE^DIE("E","FDA","ERR")
25 .I $D(ERR) D
26 ..S ERROR="1^flag update error for IFN: "_IFN_" IEN: "_IEN_" PKV: "_PKV
27 ..D EM^XUMF1H(ERROR,.ERR) K ERR
28 ;
29 Q
30 ;
31STUB ; -- create record and update VUID with master flag
32 ;
33 S XREF="B"
34 S NAME=$$UNESC($P(HLNODE,HLFS,3),.HL)
35 S ROOT=$$ROOT^DILFD(IFN,,1)
36 S IEN=$O(@ROOT@(XREF,NAME,0))
37 ;
38 I 'IEN D Q:ERROR
39 .D CHK^DIE(IFN,.01,,NAME,.X)
40 .I X="^" S ERROR="1^Error - .01 is invalid"_" File #: "_IFN_" HLNODE="_HLNODE Q
41 .K DIC S DIC=IFN,DIC(0)="F" D FILE^DICN K DIC
42 .I Y="-1" S ERROR="1^Error - stub entry IFN: "_IFN_" failed HLNODE: "_HLNODE Q
43 .S IEN=+Y
44 ;
45 S IENS=IEN_","
46 ;
47 ;I $L($P(MFE,U)),$P(MFE,U)'=99.99 Q
48 S FDA(IFN,IENS,99.99)=VUID
49 S FDA(IFN,IENS,99.98)=1
50 ;
51 K ERR
52 ;
53 D FILE^DIE("E","FDA","ERR")
54 I $D(ERR) D
55 .S ERROR="1^VUID update error IFN: "_IFN_" IEN: "_IEN_" VUID: "_VUID_" HLNODE: "_HLNODE
56 .D EM^XUMF1H(ERROR,.ERR) K ERR
57 ;
58 D ADD^XUMF1H
59 ;
60 ; clean multiple flag
61 K:'$D(XIEN(IEN)) XIEN
62 S XIEN(IEN)=$G(XIEN(IEN))+1
63 ;
64 Q
65 ;
66VUID(FILE,FIELD,VUID1,X) ; -- If value type pointer and VUID may be used,
67 ; get IEN and set it as internal value
68 N X1
69 Q:'$L(FILE)!'FIELD!'$L(VUID1) 0
70 D FIELD^DID(FILE,FIELD,,"POINTER","X1")
71 S X1=$G(X1("POINTER"))
72 Q:'$L(X1) 0
73 S X1=U_X1_"""AMASTERVUID"",X,1,0)"
74 S X1=$O(@X1)
75 Q +X1
76 ;
77VAL(FILE,FIELD,VUID1,VALUE,IENS) ; convert to internal
78 ;
79 N RESULT,ERR
80 ;
81 I $G(VALUE)="" Q "^"
82 I $G(VALUE)="""""" Q ""
83 ;
84 I $L(VUID1) D Q RESULT
85 .S RESULT=$$VUID(FILE,FIELD,VUID,VALUE)
86 .I 'RESULT S RESULT="^",ERROR="1^VUID lookup failed on "_VALUE
87 ;
88 D VAL^DIE(FILE,IENS,FIELD,,VALUE,.RESULT,,"ERR")
89 I $D(ERR)!(RESULT="^") D
90 .S ERROR="1^data validation error"
91 .D EM^XUMF1H(ERROR,.ERR)
92 ;
93 Q RESULT
94 ;
95UNESC(VALUE,HL) ;Unescape value
96 N RESULT,ESC,ESCFS,ESCCMP,ESCSUB,ESCREP,ESCESC,ESCSEQ,CVRT
97 S ESC=$E(HL("ECH"),3)
98 S ESCFS=ESC_"F"_ESC S CVRT(ESCFS)=HL("FS")
99 S ESCCMP=ESC_"S"_ESC S CVRT(ESCCMP)=$E(HL("ECH"),1)
100 S ESCREP=ESC_"R"_ESC S CVRT(ESCREP)=$E(HL("ECH"),2)
101 S ESCESC=ESC_"E"_ESC S CVRT(ESCESC)=ESC
102 S ESCSUB=ESC_"T"_ESC S CVRT(ESCSUB)=$E(HL("ECH"),4)
103 F ESCSEQ=ESCFS,ESCCMP,ESCSUB,ESCREP,ESCESC D
104 .F Q:VALUE'[ESCSEQ D
105 ..S VALUE=$P(VALUE,ESCSEQ,1)_CVRT(ESCSEQ)_$P(VALUE,ESCSEQ,2,9999)
106 Q VALUE
107 ;
108UNESCWP(TEXT,HL) ;Unescape word processing field
109 N ESC,NODE,NXTNODE,BNDBEG,BNDEND,CHECK,SPOT
110 S ESC=$E(HL("ECH"),3)
111 S NODE=0
112 F S NODE=+$O(TEXT(NODE)) Q:'NODE D
113 .S TEXT(NODE)=$$UNESC(TEXT(NODE),.HL)
114 .S BNDBEG=$E(TEXT(NODE),$L(TEXT(NODE))-1,$L(TEXT(NODE)))
115 .I BNDBEG[ESC D
116 ..S NXTNODE=$O(TEXT(NODE)) Q:'NXTNODE
117 ..S BNDEND=$E(TEXT(NXTNODE),1,2)
118 ..Q:(BNDEND'[ESC)
119 ..S CHECK=$$UNESC(BNDBEG_BNDEND,.HL)
120 ..Q:($L(CHECK)=4)
121 ..I $E(BNDBEG,1)=ESC D Q
122 ...S TEXT(NODE)=$E(TEXT(NODE),1,$L(TEXT(NODE))-2)_$E(CHECK,1)
123 ...S TEXT(NXTNODE)=$E(CHECK,2)_$E(TEXT(NXTNODE),3,$L(TEXT(NXTNODE)))
124 ..S TEXT(NODE)=$E(TEXT(NODE),1,$L(TEXT(NODE))-2)_CHECK
125 ..S TEXT(NXTNODE)=$E(TEXT(NXTNODE),3,$L(TEXT(NXTNODE)))
126 Q
127 ;
128EM ; -- error message
129 ;
130 N X,XMTEXT,XMDUZ,GROUP,XMSUB,XMY
131 ;
132 D MSG^DIALOG("AM",.X,80,,"ERR")
133 ;
134 S X(.1)="HL7 message ID: "_$G(HL("MID"))
135 S X(.11)="",X(.12)="This message was generated by the NTRT process and MFS. No action is required on your part."
136 S X(.13)="This message is informational and may be used in some instances as a troubleshooting tool."
137 S X(.2)="",X(.3)=$G(ERROR)
138 S X(.4)="",X(.5)="VUID: "_$G(VUID),X(.6)=""
139 S:$G(XMSUB)="" XMSUB="MFS ERROR/WARNING/INFO"
140 S XMY("G.XUMF ERROR")="",XMDUZ=.5
141 S GROUP=$P($G(^DIC(4.001,+IFN,0)),U,6)
142 I GROUP'="" S GROUP="G."_GROUP,XMY(GROUP)=""
143 S XMTEXT="X("
144 ;
145 M X=^TMP("XUMF ERROR",$J)
146 ;
147 D ^XMD
148 ;
149 Q
150 ;
Note: See TracBrowser for help on using the repository browser.