source: FOIAVistA/trunk/r/PHARMACY_BENEFITS_MANAGEMENT-PSU/PSULRHL1.m@ 1527

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

initial load of FOIAVistA 6/30/08 version
File size: 6.6 KB
Line 
1PSULRHL1 ;HCIOFO/BH/RDC - Process real time HL7 Lab messages ; 8/1/07 11:26am
2 ;;4.0;PHARMACY BENEFITS MANAGEMENT;**3,11**;MARCH, 2005;Build 8
3 ;
4 ; DBIA 3565 to subscribe to the LR7O ALL EVSEND RESULTS protocol
5 ; DBIA 998 to dig through ^DPT(i,"LR" go get the ien to file #63
6 ; DBIA 91-A to dig through ^LAB(60 to get the name of the test
7 ; DBIA 3630 to call the HL7 PID builder
8 ; DBIA 4727 to call EN^HLOCNRT
9 ; DBIA 3646 to call API: $$EMPL^DGSEC4
10 ; DBIA 4658 to call API: $$TSTRES^LRRPU
11 ;
12 ; This program is called when a lab test is verified. If it is for a
13 ; chemistry test, and not for an employee, an HL7 message will be
14 ; created and sent to the CMOP-NAT server.
15 ;
16 ;
17HL7 ; Entry point for PBM processing - triggered by lab protocol
18 ; LR7O ALL EVSEND RESULTS.
19 ;
20 N ARR,FIRST,LRDFN,PSUEXT,PSUHLFS,PSUHLECH,PSUHLCS
21 ;
22 ; OREMSG is the pointer reference to the global that contains the
23 ; lab data and is passed in by the LR7O ALL EVSEND RESULTS protocol.
24 ;
25 I '$D(@OREMSG) Q
26 ;
27 ; Get Lab parameters
28 ;
29 D INIT^HLFNC2("PSU-SITE-DRIVER",.PSUHL)
30 ;
31 ; Set up CS delimeter for the Pharmacy message
32 ;
33 S PSUHL("CS")=$E(PSUHL("ECH"),1)
34 ;
35 ; Set up segment processing parameters
36 ;
37 S PSUEXT("PSUBUF")=$NA(^TMP("HLS",$J))
38 S PSUEXT("PSUPTR")=0
39 ;
40 ; Get the delimiters that the passed in lab data is using
41 ;
42 D PARAMS
43 S PSUHLECH=$G(ARR("PSUHLECH"),"^~\&")
44 S PSUHLCS=$E(PSUHLECH,1)
45 ;
46 ; Quit if no DFN
47 ;
48 I '$D(ARR) Q
49 I ARR("DFN")=0!(ARR("DFN")="") Q
50 ;
51 ; Quit if patient is an employee
52 ;
53 I $$EMPL^DGSEC4(ARR("DFN"),"PS") Q
54 ;
55 ; Get Lab's equivalent of a DFN (LRDFN)
56 ;
57 S LRDFN=$P(^DPT(ARR("DFN"),"LR"),"^") ; DBIA 998 to get file #63 ien
58 ;
59 ; Loop through the lab data
60 ;
61 S FIRST=1
62 D LOOP
63 ;
64 ; Generate an HL7 if data exists to be sent
65 ;
66 I 'FIRST D GENERATE
67 ;
68 K PSUHL,ERR,OPTNS,ERR
69 ;
70 Q
71 ;
72LOOP ;
73 N CNT,LRIDT,LRSS,PREV1,PREV2,QUIT1,QUIT2,REC,REC1,REC2,SEG,SEG1,SEG2,STR1
74 K ^TMP("HLS",$J)
75 S CNT=0
76 F Q:CNT="" S CNT=$O(@OREMSG@(CNT)) Q:'CNT D
77 . S REC=@OREMSG@(CNT)
78 . S REC=$$STRING(REC,CNT)
79 . S SEG=$P(REC,PSUHLFS,1)
80 . I SEG'="ORC" Q
81 . S STR1=$P(REC,PSUHLFS,4)
82 . S STR1=$P(STR1,PSUHLCS,1)
83 . S LRSS=$P(STR1,";",4)
84 . ;
85 . ; Quit if data is not for Chemistry
86 . ;
87 . I LRSS'="CH" Q
88 . S LRIDT=$P(STR1,";",5)
89 . S QUIT1=0
90 . F Q:QUIT1!(CNT="") S PREV1=CNT,CNT=$O(@OREMSG@(CNT)) Q:'CNT D
91 . . S REC1=@OREMSG@(CNT)
92 . . S REC1=$$STRING(REC1,CNT)
93 . . S SEG1=$P(REC1,PSUHLFS,1)
94 . . I SEG1="ORC" S CNT=PREV1,QUIT1=1 Q
95 . . I SEG1'="OBR" Q
96 . . ; If this is the first OBR being processed i.e. this is valid
97 . . ; chemistry data set the PID segment
98 . . I FIRST D PID S FIRST=0
99 . . D OBR(REC1)
100 . . S QUIT2=0
101 . . F Q:QUIT2 S PREV2=CNT,CNT=$O(@OREMSG@(CNT)) Q:'CNT D
102 . . . S REC2=@OREMSG@(CNT)
103 . . . S REC2=$$STRING(REC2,CNT)
104 . . . S SEG2=$P(REC2,PSUHLFS,1)
105 . . . I SEG2="OBR"!(SEG2="ORC") S CNT=PREV2,QUIT2=1 Q
106 . . . I SEG2'="OBX" Q
107 . . . D OBX(REC2)
108 Q
109 ;
110PID ; Create the PID segment using the standard builder
111 ;
112 N K1,NEWSEG,SEG
113 S SEG="SEG"
114 D BLDPID^VAFCQRY(ARR("DFN"),1,"1,2,3",.SEG,.PSUHL,.ERR)
115 ;
116 ; Loop through the returned array just in case the data is spread over
117 ; more than one node
118 ;
119 S K1="",NEWSEG=""
120 F S K1=$O(SEG(K1)) Q:'K1 D
121 . S NEWSEG=NEWSEG_SEG(K1)
122 ;
123 ; Set the data string into the PBM HL7 array
124 ;
125 D SETSEG(NEWSEG)
126 ;
127 Q
128 ;
129OBR(REC) ; Re-forms lab OBR to only send required data
130 ;
131 N OBRSEG,SITE,SPECDATE
132 S OBRSEG="OBR"
133 S SPECDATE=$P(REC,PSUHLFS,8)
134 S SITE=$P(REC,PSUHLFS,16)
135 S SITE=$TR(SITE,PSUHLCS,PSUHL("CS"))
136 ;
137 ; Create new OBR Segment and pass to SETSEG
138 ;
139 S $P(OBRSEG,PSUHL("FS"),8)=SPECDATE
140 S $P(OBRSEG,PSUHL("FS"),16)=SITE
141 ;
142 ; Set the data string into the PBM HL7 array
143 ;
144 D SETSEG(OBRSEG)
145 ;
146 Q
147 ;
148OBX(REC) ; Reforms lab OBX to only send the data needed
149 N CODES,HRANGE,LABS,LNAME,LR60,LRANGE,LRDN,LOINC,LOINCS,P2,P3,P12,RANGE,RES,RESULTS,SEG,UNITS
150 ;
151 S P2=$P(REC,PSUHLFS,2)
152 S P3=$P(REC,PSUHLFS,3)
153 S P12=$P(REC,PSUHLFS,12)
154 S RESULTS=$P(REC,PSUHLFS,6)
155 S UNITS=$P(REC,PSUHLFS,7)
156 S LABS=$P(REC,PSUHLFS,4)
157 S LR60=$P(LABS,"^",4)
158 I LR60']"" Q
159 S LRDN=$G(^LAB(60,LR60,0))
160 S LRDN=$P($P(LRDN,"^",5),";",2) ; DBIA 91 for data name
161 ;
162 ; Make the call to LRRPU to get the LOINC code for this test
163 ;
164 I LRDN']"" Q
165 S RES=$$TSTRES^LRRPU(LRDFN,LRSS,LRIDT,LRDN,LR60,1)
166 ;
167 S CODES=$P(RES,U,8),LOINCS=$P(CODES,"!",3)
168 S LOINC=$P(LOINCS,";",1),LNAME=$P(LOINCS,";",2)
169 S LRANGE=$P(RES,U,3),HRANGE=$P(RES,U,4)
170 S RANGE=LRANGE_"-"_HRANGE I RANGE="-" S RANGE=""
171 ;
172 ; Use the Pharmacy HL7 delimeters
173 ;
174 S LABS=$TR(LABS,PSUHLCS,PSUHL("CS"))
175 ;
176 ; Add LOINC to the list of Labs if it exists
177 ;
178 I LOINC'="" D
179 . ;
180 . ; Append the LOINC data using the pharmacy delimiters
181 . S LABS=LABS_PSUHL("CS")_LOINC_PSUHL("CS")_LNAME_PSUHL("CS")_"99LN"
182 ;
183 ; Put the data in the string
184 ;
185 S SEG="OBX"
186 S $P(SEG,PSUHL("FS"),2)=P2
187 S $P(SEG,PSUHL("FS"),3)=P3
188 S $P(SEG,PSUHL("FS"),4)=LABS
189 S $P(SEG,PSUHL("FS"),6)=RESULTS
190 S $P(SEG,PSUHL("FS"),7)=UNITS
191 S $P(SEG,PSUHL("FS"),8)=RANGE
192 S $P(SEG,PSUHL("FS"),12)=P12
193 ;
194 ; Put the string into the PBM HL7 global
195 ;
196 D SETSEG(SEG)
197 ;
198 Q
199 ;
200STRING(HLSTR,CNT) ; Loops through sub nodes to create a full data string
201 N J
202 S J=""
203 F S J=$O(@OREMSG@(CNT,J)) Q:J="" S HLSTR=HLSTR_@OREMSG@(CNT,J)
204 Q HLSTR
205 ;
206PARAMS ; Get the delimiters used in the lab data
207 ;
208 N CNT,ID,QUIT,REC,RES
209 K ARR
210 S (QUIT,CNT)=0,RES=""
211 F S CNT=$O(@OREMSG@(CNT)) Q:'CNT!(QUIT=2) D
212 . S REC=@OREMSG@(CNT)
213 . I $E(REC,1,3)="MSH" D Q
214 . . S PSUHLFS=$E(REC,4,4)
215 . . S ARR("PSUHLECH")=$P(REC,PSUHLFS,2),QUIT=QUIT+1
216 . I $P(REC,PSUHLFS,1)="PID" D Q
217 . . S ARR("DFN")=$P(REC,PSUHLFS,4)
218 . . S QUIT=QUIT+1
219 Q
220 ;
221GENERATE ; Generate HL7 message
222 ;
223 ; D GENERATE^HLMA("PSU-SITE-DRIVER","GM",1,.RESULT,"",.OPTNS)
224 S OPTNS("QUEUE")="PBM LAB"
225 S RESULT=$$EN^HLOCNRT("PSU-SITE-DRIVER","GM",.OPTNS)
226 I +RESULT'=RESULT D
227 . S ^XTMP("PBM/HLO",DT,$J)=RESULT
228 K ^TMP("HLS",$J)
229 Q
230 ;
231 ;
232SETSEG(SEG) ;
233 ;
234 ;***** STORES THE SEGMENT INTO THE ^TMP("HLS",$J) BUFFER
235 ;
236 ; SEG HL7 segment
237 ;
238 ; The SETSEG procedure stores the HL7 segment into the
239 ; standard HL7 buffer ^TMP("HLS",$J). The <TAB>, <CR> and <LF>
240 ; characters are replaced with spaces. Long segments are split among
241 ; sub-nodes of the main segment node.
242 ;
243 ; The PSUEXT array must be initialized before
244 ; calling this function.
245 ;
246 N I1,I2,MAXLEN,NODE,PTR,PTR1,SID,SL
247 S NODE=PSUEXT("PSUBUF"),PTR=$G(PSUEXT("PSUPTR"))+1
248 S SL=$L(SEG),MAXLEN=245 K @NODE@(PTR)
249 ;--- Store the segment
250 S @NODE@(PTR)=$TR($E(SEG,1,MAXLEN),$C(9,10,13)," ")
251 ;
252 ;--- Split the segment into sub-nodes if necessary
253 D:SL>MAXLEN
254 . S I2=MAXLEN
255 . F PTR1=1:1 S I1=I2+1,I2=I1+MAXLEN-1 Q:I1>SL D
256 . . S @NODE@(PTR,PTR1)=$TR($E(SEG,I1,I2),$C(9,10,13)," ")
257 ;--- Save the pointer
258 S PSUEXT("PSUPTR")=PTR
259 Q
Note: See TracBrowser for help on using the repository browser.