source: WorldVistAEHR/trunk/r/CONSULT_REQUEST_TRACKING-GMRC-GMRS-GMRT/GMRCIUTL.m@ 1042

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

initial load of WorldVistAEHR

File size: 6.7 KB
Line 
1GMRCIUTL ;SLC/JFR - UTILITIES FOR INTER-FACILITY CONSULTS ;11/26/01 15:34
2 ;;3.0;CONSULT/REQUEST TRACKING;**22**;DEC 27, 1997
3 ;
4 Q ;don't start at the top
5 ;
6DIV(LOC) ; get the division from a hospital location
7 ; Input -- LOC HOSPITAL LOCATION file (#44) IEN
8 ; Output -- INSTITUTION file (#4) IEN^INSTITUTION file (#4) NAME
9 ;
10 N GMRCHL,GMRCSTN,GMRCDIV
11 S GMRCHL=$P($G(^SC(+LOC,0)),U,15)
12 I +GMRCHL D
13 . S GMRCSTN=$$SITE^VASITE(,GMRCHL)
14 . I $P(GMRCSTN,U)>0,($P(GMRCSTN,U,2)]"") D
15 . . S GMRCDIV=$P(GMRCSTN,U)_U_$P(GMRCSTN,U,2)
16 I '$G(GMRCDIV) D
17 . S GMRCDIV=+$G(DUZ(2))_U_$P($$NS^XUAF4(+$G(DUZ(2))),U)
18 Q GMRCDIV
19 ;
20HLNAME(GMRCWHO) ;HL7 format a name from a pointer to 200
21 Q:'$D(^VA(200,+GMRCWHO,0)) ""
22 N GMRC
23 S GMRC("FILE")=200
24 S GMRC("IENS")=GMRCWHO
25 S GMRC("FIELD")=.01
26 Q $$HLNAME^XLFNAME(.GMRC,"S")
27 ;
28UNHLNAME(GMRCNM,GMRCNMC,STD,DEL) ;return regular name from HL7 name
29 ;Input:
30 ; GMRCNM = HL7 formatted name from a message
31 ; GMRCNMC = array to retun name components in (by reference)
32 ; STD = 1 or 0; 1 = return name given middle family suffix
33 ; DEL = delimiting character separating name components
34 ;
35 ;Output:
36 ; GMRCNMC=DREW,NANCY M III MD or NANCY M DREW III MD
37 ; GMRCNMC("FAMILY")=DREW
38 ; GMRCNMC("GIVEN")=NANCY
39 ; GMRCNMC("MIDDLE")=M
40 ; GMRCNM("SUFFIX")=III MD
41 ;
42 I '$D(DEL) S DEL=U
43 S GMRCNMC=GMRCNM
44 S GMRCNMC=$$FMNAME^XLFNAME(.GMRCNMC,"CS")
45 I $G(STD) S GMRCNMC=$$NAMEFMT^XLFNAME(.GMRCNMC,"G","Dc")
46 Q
47 ;
48TRIMWP(ARRAY,PIECE) ;trim OBX or NTE segments so that only comment remains
49 ; Input:
50 ; ARRAY = the array in which the segments are contained
51 ; ex. ^TMP("GMRCIF",541083753,"OBX",3,3)=3|TX|^COMMENTS^|3|text "
52 ; PIECE = the piece in the array where the text lives
53 ;
54 ; Output:
55 ; trimmed array
56 ; ex. ^TMP("GMRCIF",541083753,"OBX",3,3)="text"
57 ;
58 N I S I=0
59 F S I=$O(@(ARRAY)@(I)) Q:'I D
60 . S @(ARRAY)@(I)=$P(@(ARRAY)@(I),"|",PIECE)
61 Q
62 ;
63VALMSG(GMRCPID,GMRCORC) ; determine if message is valid
64 ;Input:
65 ; GMRCPID = PID segment from an IFC HL7 message
66 ; GMRCORC = ORC segment from an IFC HL7 message
67 ;
68 ;Output:
69 ; 1 = message passes screening on patient, institution and ien
70 ; 0^msg = message failed screening
71 ; possible msg values:
72 ;
73 ;
74 ;
75 N GMRCDA,GMRCINST
76 Q
77 ;
78URG(GMRCO) ;return urgency code to send in HL7 msg
79 ; Input:
80 ; GMRCO = consult ien from file 123
81 ;
82 ; Output:
83 ; S = stat
84 ; R = routine
85 ; ZT = today
86 ; Z24 = within 24 hours
87 ; Z48 = within 48 hours
88 ; Z72 = within 72 hours
89 ; ZW = within 1 week
90 ; ZM = within 1 month
91 ; ZNA = next available
92 ; ZE = emergency
93 ;
94 N URG,PROT,ORURG
95 S PROT=$P(^GMR(123,GMRCO,0),U,9)
96 S URG=$P($G(^ORD(101,+PROT,0)),U),URG=$P(URG," - ",2)
97 I '$L(URG) Q ""
98 S ORURG=$S(URG="EMERGENCY":"STAT",URG="NOW":"STAT",URG="OUTPATIENT":"ROUTINE",1:URG)
99 S ORURG=$O(^ORD(101.42,"B",ORURG,0))
100 I '+ORURG Q ""
101 Q $P(^ORD(101.42,ORURG,0),"^",2)
102GETSERV(GMRCSRV) ;return local service from IFC service in HL7 msg
103 ;Input:
104 ; GMRCSRV = OBR-4 (e.g. 4^CARDIOLOGY^578VA1235)
105 ;
106 ;Output:
107 ; ien of local service
108 N SERV,SENDER,ERROR
109 S SERV=$$FIND1^DIC(123.5,"","X",$P(GMRCSRV,U,2))
110 I 'SERV S ERROR="-1^ERROR IN SERVICE NAME^701"
111 I '$D(ERROR) D
112 . S SENDER=$P(GMRCSRV,U,3)
113 . S SENDER=+$$IEN^XUAF4($P(SENDER,"VA1235"))
114 I '$D(ERROR) D
115 . I $O(^GMR(123.5,SERV,"IFCS","B",SENDER,0)) Q
116 . S ERROR="-1^IMPROPER SENDING FACILITY^301"
117 Q $S($D(ERROR):ERROR,1:SERV)
118 ;
119GETPROC(GMRCSID) ;return procedure and sercvice ordered by IFC
120 ;Input:
121 ; GMRCSID =OBR-4 from IFC msg (e.g. "31^EKG^578VA1233" )
122 ;
123 ;Output:
124 ; string in format local_proc_ien^service_ien_to perform
125 ;
126 N GMRCSS,GMRCPR,SENDER,ERROR
127 S GMRCPR=$$FIND1^DIC(123.3,"","X",$P(GMRCSID,U,2))
128 I 'GMRCPR S ERROR="-1^ERROR IN PROCEDURE NAME^501"
129 I '$D(ERROR) D
130 . S SENDER=$P(GMRCSID,U,3)
131 . S SENDER=+$$IEN^XUAF4($P(SENDER,"VA1233"))
132 I '$D(ERROR) D
133 . I $O(^GMR(123.3,GMRCPR,"IFCS","B",SENDER,0)) Q
134 . S ERROR="-1^IMPROPER SENDING FACILITY^401"
135 I '$D(ERROR) D
136 . D GETSVC^GMRCPR0(.GMRCSS,GMRCPR)
137 . I GMRCSS>1 S ERROR="-1^MULTIPLE SERVICES DEFINED^601" Q
138 . S GMRCSS=+GMRCSS(1)
139 Q $S($D(ERROR):ERROR,1:GMRCPR_U_GMRCSS)
140CODEOI(GMRCDA) ; look at ordered procedure or service and code it for IFC msg
141 ;Input:
142 ; GMRCDA = ien from file 123 of consult or procedure to send as IFC
143 ;
144 ;Output:
145 ; consult: svc_ien^remote_service_name^station#_VA1235
146 ; proc: proc_ien^remote_proc_name^station#_VA1233
147 ;
148 N GMRCPR,GMRCSS,GMRCSIT,GMRCOI
149 S GMRCSIT=$$STA^XUAF4($$KSP^XUPARAM("INST"))
150 I +$P(^GMR(123,GMRCDA,0),U,8) D ; it's a procedure
151 . S GMRCPR=+$P(^GMR(123,GMRCDA,0),U,8)
152 . S GMRCOI=GMRCPR_U_$P(^GMR(123.3,GMRCPR,"IFC"),U,2)_U_GMRCSIT_"VA1233"
153 I '$D(GMRCOI) D ; it's a consult
154 . S GMRCSS=$P(^GMR(123,GMRCDA,0),U,5)
155 . S GMRCOI=GMRCSS_U_$P(^GMR(123.5,GMRCSS,"IFC"),U,2)_U_GMRCSIT_"VA1235"
156 Q GMRCOI
157 ;
158RESP(GMRCAC,GMRCMID,GMRCOC,GMRCDA,GMRCERR) ;build and send appl ACK/NAK
159 ; Input:
160 ; GMRCAC = acknowledgement code (AA or AR)
161 ; GMRCMID = message id from original msg
162 ; GMRCOC = order control from original msg ORC
163 ; GMRCDA = ien of consult being worked on
164 ; GMRCERR = only defined if an error is found
165 ;
166 S HLA("HLA",1)=$$MSA^GMRCISEG(GMRCAC,GMRCMID,$G(GMRCERR))
167 I $D(GMRCOC) D
168 . I GMRCOC="NW" S HLA("HLA",2)=$$ORCRESP^GMRCISG1(GMRCDA,"OK","IP")
169 Q
170 ;
171LOGMSG(GMRCO,GMRCACT,GMRCMSG,GMRCER) ;create or update IFC MESSAGE LOG entry
172 ;Input:
173 ; GMRC0 = ien from file 123
174 ; GMRCACT = ien in 40 multiple from file 123
175 ; GMRCMSG = HL7 message ID of message being sent
176 ; GMRCER = error number if can't transmit immediately
177 ;
178 N GMRCLG,GMRCERR,FDA
179 S GMRCLG=$O(^GMR(123.6,"AC",GMRCO,GMRCACT,1,0))
180 I +GMRCLG D Q ; update existing incomplete record.
181 . S FDA(1,123.6,GMRCLG_",",.01)=$$NOW^XLFDT
182 . S FDA(1,123.6,GMRCLG_",",.03)=$G(GMRCMSG)
183 . S FDA(1,123.6,GMRCLG_",",.07)=$P(^GMR(123.6,GMRCLG,0),U,7)+1
184 . I $G(GMRCER) S FDA(1,123.6,GMRCLG_",",.08)=GMRCER
185 . D UPDATE^DIE("","FDA(1)",,"GMRCERR")
186 ;
187 ; create new record
188 S FDA(1,123.6,"+1,",.01)=$$NOW^XLFDT
189 S FDA(1,123.6,"+1,",.02)=$P(^GMR(123,GMRCO,0),U,23)
190 S FDA(1,123.6,"+1,",.03)=$G(GMRCMSG)
191 S FDA(1,123.6,"+1,",.04)=GMRCO
192 S FDA(1,123.6,"+1,",.05)=GMRCACT
193 S FDA(1,123.6,"+1,",.06)=1
194 S FDA(1,123.6,"+1,",.07)=1
195 I $G(GMRCER) S FDA(1,123.6,"+1,",.08)=GMRCER
196 D UPDATE^DIE("","FDA(1)","GMRCLG","GMRCERR")
197 Q
198 ;
199ERR101 ;Unknown Consult/Procedure request
200ERR201 ;Unknown Patient
201ERR202 ;Local or unknown MPI identifiers
202ERR301 ;Service not matched to receiving facility
203ERR401 ;Procedure not matched to receiving facility
204ERR501 ;Error in procedure name
205ERR601 ;Multiple services matched to procedure
206ERR701 ;Error in Service name
207ERR801 ;Inappropriate action for specified request
208ERR802 ;Duplicate, activity not filed
209ERR901 ;Unable to update record successfully
210ERR902 ;Earlier pending transactions
211ERR903 ;HL Logical Link not found
212ERR904 ;VistA HL7 unable to send transaction
Note: See TracBrowser for help on using the repository browser.