source: FOIAVistA/trunk/r/BAR_CODE_MED_ADMIN-ALPB-PSB/PSBSVHL7.m

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

initial load of FOIAVistA 6/30/08 version
File size: 9.5 KB
Line 
1PSBSVHL7 ;BIRMINGHAM/TEJ-BCMA HL7 SERVER ;Mar 2004
2 ;;3.0;BAR CODE MED ADMIN;**3**;Mar 2004
3 ; Reference/IA
4 ; $$HLDATE^HLFNC/10106
5 ; $$HLNAME^HLFNC/10106
6 ; INIT^HLFNC2/2161
7 ; GENERATE^HLMA/2164
8 ; File 50.7/2880
9 ; File 52.6/436
10 ; File 52.7/437
11 ; File 200/10060
12 ; DEM^VADPT/10061
13 ;
14 ; Description:
15 ; This routine is to service BCMA HL7 messaging to other COTS and
16 ; VISTA application.
17 ; The entry point ("EN") is accessed via BCMA. This routine
18 ; basically consists of subroutines to generate HL7 messages
19 ; per trigger events coresponding to BCMA transactions.
20 ; These trigger events are captured within the routine PSBML.
21 ; PSBML passes the affected BCMA MEDICATION LOG File IEN and
22 ; a variable capturing the BCMA activity as the input.
23 ; Input - PSBIEN Affected BCMA record(s)
24 ; PSBHL7X BCMA trigger event/transaction
25 ; Output - HL7 broadcast to subscribing Applications
26 ;
27EN(PSBIEN,PSBHL7X) ; This is the entry point for for all HL7 processing
281 ; set up environment for message
29 N PSBHLFS,PSBHLCS
30 D INIT^HLFNC2("PSB BCMA RASO17 SRV",.HL)
31 I $G(HL) W:+HL'=16 !,"Error: "_$P(HL,2) Q ; error occurred
32 S PSBHLFS=$G(HL("FS")) I PSBHLFS="" S PSBHLFS="^"
33 S PSBHLCS=$E(HL("ECH"),1)
34 S PSBHLSCS=$E(HL("ECH"),4)
352 ; Add appropriate message txt to HLA array
36 K HLA,HLEVN
37 N PSBDFN,PSBHL7MS
38 S PSBCNT=0
39 I (PSBHL7X["MEDPASS")!(PSBHL7X["UPDATE STATUS") D MEDSTAT Q
40 I (PSBHL7X["ADD COMMENT") D COMMENT Q
41 I (PSBHL7X["PRN EFFECTI") D PRNEFFE Q
42 Q
43MEDSTAT ;MEDPASS and UPDATE trigger events
44 D PID,PV1,ORC,RXO
45 D:$D(^PSB(53.79,PSBIEN,.3,0)) NTE
46 D RXR,RXC,RXA,TRANS Q
47COMMENT ;ADD COMNMENT trigger event
48 D PID,ORC,NTE,TRANS Q
49PRNEFFE ;PRN EFFECTIVENESS trigger event
50 D PID,ORC,NTE,TRANS Q
51PID ; PID segment -- use segment generator
52 S PSBDFN=$P(^PSB(53.79,PSBIEN,0),U,1),DFN=PSBDFN D DEM^VADPT
53 S PSBCNT=PSBCNT+1,$P(PSBHL7MS,PSBHLFS,3)=PSBDFN
54 S $P(VADM(4),PSBHLCS)=VADM(4),$P(VADM(4),PSBHLCS,5)="AGE",$P(PSBHL7MS,PSBHLFS,4)=VADM(4)
55 S $P(PSBHL7MS,PSBHLFS,5)=$$HLNAME^HLFNC(VADM(1),HL("ECH"))
56 S $P(PSBHL7MS,PSBHLFS,7)=$$HLDATE^HLFNC(+VADM(3),"DT")
57 S $P(PSBHL7MS,PSBHLFS,19)=$P(VADM(2),"^")
58 S $P(PSBHL7MS,PSBHLFS,8)=$P(VADM(5),"^")
59 S HLA("HLS",PSBCNT)="PID"_PSBHLFS_PSBHL7MS
60 Q
61PV1 ; PV1 segment
62 K PSBHL7MS,PSBHL7FD
63 S PSBCNT=PSBCNT+1,HLA("HLS",PSBCNT)="PV1"_PSBHLFS
64 S $P(PSBHL7MS,PSBHLFS,2)="U"
65 ; Construct location field
66 S $P(PSBHL7FD,PSBHLCS,1)=$$ESC($P(^PSB(53.79,PSBIEN,0),U,2))
67 S $P(PSBHL7FD,PSBHLCS,4)=$$ESC($P(^PSB(53.79,PSBIEN,0),U,3))
68 S $P(PSBHL7MS,PSBHLFS,3)=PSBHL7FD K PSBHL7FD
69 ; Construct attending physician data
70 S $P(PSBHL7FD,PSBHLCS,1)=$P(^PSB(53.79,PSBIEN,0),U,5)
71 S $P(PSBHL7FD,PSBHLCS,2)=$$HLNAME^HLFNC($$GET1^DIQ(200,$P(PSBHL7FD,PSBHLCS,1)_",",.01),HL("ECH"))
72 S $P(PSBHL7MS,PSBHLFS,7)=PSBHL7FD K PSBHL7FD
73 S HLA("HLS",PSBCNT)=(HLA("HLS",PSBCNT))_PSBHL7MS
74 Q
75ORC ; ORC segment
76 K PSBHL7MS,PSBHL7FD
77 S PSBCNT=PSBCNT+1,HLA("HLS",PSBCNT)="ORC"_PSBHLFS
78 S $P(PSBHL7MS,PSBHLFS,1)="XX"
79 S $P(PSBHL7MS,PSBHLFS,2)=PSBIEN_PSBHLCS_"PSB"_PSBHLCS_PSBIEN_PSBHLCS_"IEN"
80 S $P(PSBHL7MS,PSBHLFS,3)=$P(^PSB(53.79,PSBIEN,.1),U)
81 D PSJ1^PSBVT(PSBDFN,$P(PSBHL7MS,PSBHLFS,3))
82 ; Construct quantity/time
83 S $P(PSBHL7FD,PSBHLCS,1)=$P(^PSB(53.79,PSBIEN,.1),U,5)
84 S $P(PSBHL7FD,PSBHLCS,2)=$$ESC(PSBSCH)
85 S $P(PSBHL7FD,PSBHLCS,4)=$$HLDATE^HLFNC($P(^PSB(53.79,PSBIEN,.1),U,3),"TS")
86 S $P(PSBHL7FD,PSBHLCS,10)=$$ESC(PSBSCHT)
87 S $P(PSBHL7MS,PSBHLFS,7)=PSBHL7FD K PSBHL7FD
88 ; Construct previous (parent) order data
89 S:$D(PSBPONX) $P(PSBHL7FD,PSBHLCS,2)=PSBPONX
90 S $P(PSBHL7MS,PSBHLFS,8)=$G(PSBHL7FD) K PSBHL7FD
91 S $P(PSBHL7MS,PSBHLFS,9)=$$HLDATE^HLFNC($P(^PSB(53.79,PSBIEN,0),U,6),"TS")
92 ; Construct entered by data
93 S $P(PSBHL7FD,PSBHLCS,1)=$P(^PSB(53.79,PSBIEN,0),U,5)
94 S $P(PSBHL7FD,PSBHLCS,2)=$$HLNAME^HLFNC($$GET1^DIQ(200,$P(PSBHL7FD,PSBHLCS,1)_",",.01),HL("ECH"))
95 S $P(PSBHL7MS,PSBHLFS,10)=PSBHL7FD K PSBHL7FD
96 S $P(PSBHL7MS,PSBHLFS,15)=$$HLDATE^HLFNC($P(^PSB(53.79,PSBIEN,0),U,4),"TS")
97 ; Construct action by data
98 S $P(PSBHL7FD,PSBHLCS,1)=$P(^PSB(53.79,PSBIEN,0),U,7)
99 S $P(PSBHL7FD,PSBHLCS,2)=$$HLNAME^HLFNC($$GET1^DIQ(200,$P(PSBHL7FD,PSBHLCS,1)_",",.01),HL("ECH"))
100 S $P(PSBHL7MS,PSBHLFS,19)=PSBHL7FD K PSBHL7FD
101 S HLA("HLS",PSBCNT)=(HLA("HLS",PSBCNT))_PSBHL7MS
102 Q
103RXO ; RXO segment
104 K PSBHL7MS,PSBHL7FD
105 S PSBCNT=PSBCNT+1,HLA("HLS",PSBCNT)="RXO"_PSBHLFS
106 ; Construct rq give code data
107 S $P(PSBHL7FD,PSBHLCS,1)=$P(^PSB(53.79,PSBIEN,0),U,8)
108 S $P(PSBHL7FD,PSBHLCS,2)=$$GET1^DIQ(50.7,$P(PSBHL7FD,PSBHLCS,1)_",",.01)
109 S $P(PSBHL7MS,PSBHLFS,1)=PSBHL7FD K PSBHL7FD
110 S $P(PSBHL7MS,PSBHLFS,2)=$$ESC($P(^PSB(53.79,PSBIEN,.1),U,5))
111 S $P(PSBHL7MS,PSBHLFS,10)=$$ESC($P(^PSB(53.79,PSBIEN,0),U,10))
112 S $P(PSBHL7FD,PSBHLCS,2)=$$ESC($P(^PSB(53.79,PSBIEN,0),U,11))
113 S $P(PSBHL7MS,PSBHLFS,21)=PSBHL7FD
114 S HLA("HLS",PSBCNT)=(HLA("HLS",PSBCNT))_PSBHL7MS
115 Q
116NTE ; NTE segment(s) - notes and comments
117 K PSBHL7MS,PSBHL7FD
118 S PSBCNT=PSBCNT+1,HLA("HLS",PSBCNT)="NTE"_PSBHLFS
119 S $P(PSBHL7MS,PSBHLFS,2)="O"
120 ; Construct comment and comment type
121 D:($G(PSBSCHT)="P")&($D(^PSB(53.79,PSBIEN,.2)))&(PSBHL7X["PRN EFF")
122 .S $P(PSBHL7MS,PSBHLFS,3)=$$ESC($P(^PSB(53.79,PSBIEN,.2),U,2))
123 .S $P(PSBHL7FD,PSBHLCS,1)=$P(^PSB(53.79,PSBIEN,.2),U,3)
124 .S $P(PSBHL7FD,PSBHLCS,2)=$$HLNAME^HLFNC($$GET1^DIQ(200,$P(PSBHL7FD,PSBHLCS,1)_",",.01),HL("ECH"))
125 .S $P(PSBHL7FD,PSBHLCS,4)=$$HLDATE^HLFNC($P(^PSB(53.79,PSBIEN,.2),U,4),"TS")
126 .S $P(PSBHL7FD,PSBHLCS,5)="Date Entered"
127 .S $P(PSBHL7FD,PSBHLCS,7)=$P(^PSB(53.79,PSBIEN,.2),U,5)
128 .S $P(PSBHL7FD,PSBHLCS,8)="PRN Minutes"
129 .S $P(PSBHL7MS,PSBHLFS,4)=PSBHL7FD K PSBHL7FD
130 D:$D(^PSB(53.79,PSBIEN,.3,0))&(PSBHL7X'["PRN EFF")
131 .S PSBINDX="",PSBINDX=$O(^PSB(53.79,PSBIEN,.3,PSBINDX),-1)
132 .S $P(PSBHL7MS,PSBHLFS,3)=PSBINDX_PSBHLCS_$$ESC($P(^PSB(53.79,PSBIEN,.3,PSBINDX,0),U))
133 .S $P(PSBHL7FD,PSBHLCS,1)=$P(^PSB(53.79,PSBIEN,.3,PSBINDX,0),U,2)
134 .S $P(PSBHL7FD,PSBHLCS,2)=$$HLNAME^HLFNC($$GET1^DIQ(200,$P(PSBHL7FD,PSBHLCS,1)_",",.01),HL("ECH"))
135 .S $P(PSBHL7FD,PSBHLCS,4)=$$HLDATE^HLFNC($P(^PSB(53.79,PSBIEN,.3,PSBINDX,0),U,3),"TS")
136 .S $P(PSBHL7FD,PSBHLCS,5)="Date Entered"
137 .S $P(PSBHL7MS,PSBHLFS,4)=PSBHL7FD K PSBHL7FD
138 S HLA("HLS",PSBCNT)=(HLA("HLS",PSBCNT))_PSBHL7MS
139 Q
140RXR ; RXR segment
141 K PSBHL7MS,PSBHL7FD
142 S PSBCNT=PSBCNT+1,HLA("HLS",PSBCNT)="RXR"_PSBHLFS
143 S:$D(PSBMRAB) $P(PSBHL7MS,PSBHLFS,1)=PSBMRAB
144 S $P(PSBHL7MS,PSBHLFS,2)=$P($G(^PSB(53.79,PSBIEN,.1)),U,6)
145 S HLA("HLS",PSBCNT)=(HLA("HLS",PSBCNT))_PSBHL7MS
146 S:""=$TR(PSBHL7MS,PSBHLFS,"") PSBCNT=PSBCNT-1
147 Q
148RXC ; RXC segment
149 ; loop through .5,.6,and .7 send segments for each "component"
150 K PSBSUBFD F PSBSUBFD=".5",".6",".7" D:$D(^PSB(53.79,PSBIEN,PSBSUBFD,1))
151 .K PSBFILE S PSBFILE=$S(PSBSUBFD=".5":"^PSDRUG(",PSBSUBFD=".6":"^PS(52.6,",PSBSUBFD=".7":"^PS(52.7,")
152 .K PSBRXTYP S PSBRXTYP=$S(PSBSUBFD=".5":"B",PSBSUBFD=".6":"A",PSBSUBFD=".7":"B")
153 .S PSBSUBX=0 F S PSBSUBX=$O(^PSB(53.79,PSBIEN,PSBSUBFD,PSBSUBX)) Q:+PSBSUBX=0 D
154 ..K PSBHL7MS,PSBHL7FD S PSBCNT=PSBCNT+1,HLA("HLS",PSBCNT)="RXC"_PSBHLFS
155 ..S $P(PSBHL7MS,PSBHLFS,1)=PSBRXTYP
156 ..; Construct component code data
157 ..S $P(PSBHL7FD,PSBHLCS,1)=$P(^PSB(53.79,PSBIEN,PSBSUBFD,PSBSUBX,0),U)
158 ..S PSBFILE1=PSBFILE_$P(^PSB(53.79,PSBIEN,PSBSUBFD,PSBSUBX,0),U)_",0)"
159 ..I $P(^PSB(53.79,PSBIEN,PSBSUBFD,PSBSUBX,0),U)]"" S $P(PSBHL7FD,PSBHLCS,2)=$P($G(@PSBFILE1),U) K PSBFILE1
160 ..I $G(PSBHL7FD)]"" S $P(PSBHL7MS,PSBHLFS,2)=PSBHL7FD,PSBRXAX=PSBHL7FD,PSBRXA(PSBRXAX)="RXA ADMIN CODE" K PSBHL7FD
161 ..S $P(PSBHL7MS,PSBHLFS,3)=$P(^PSB(53.79,PSBIEN,PSBSUBFD,PSBSUBX,0),U,2)
162 ..S $P(PSBHL7MS,PSBHLFS,4)=$P(^PSB(53.79,PSBIEN,PSBSUBFD,PSBSUBX,0),U,4)
163 ..I $G(PSBRXAX)]"" S PSBRXA(PSBRXAX)=$P(^PSB(53.79,PSBIEN,PSBSUBFD,PSBSUBX,0),U,3)_U_$P(PSBHL7MS,PSBHLFS,4)
164 ..S HLA("HLS",PSBCNT)=(HLA("HLS",PSBCNT))_PSBHL7MS
165 Q
166RXA ; RXA segment
167 K PSBHL7MS,PSBHL7FD S PSBRXAX=""
168 F PSBRX=1:1 S PSBRXAX=$O(PSBRXA(PSBRXAX)) Q:PSBRXAX="" D
169 .S PSBCNT=PSBCNT+1,HLA("HLS",PSBCNT)="RXA"_PSBHLFS
170 .S $P(PSBHL7MS,PSBHLFS,1)=0
171 .S $P(PSBHL7MS,PSBHLFS,2)=PSBRX
172 .S $P(PSBHL7MS,PSBHLFS,3)=$$HLDATE^HLFNC($P(^PSB(53.79,PSBIEN,0),U,6),"TS")
173 .S $P(PSBHL7MS,PSBHLFS,4)=" "
174 .; Construct administered code data
175 .S $P(PSBHL7MS,PSBHLFS,5)=PSBRXAX
176 .S $P(PSBHL7MS,PSBHLFS,6)=$P(PSBRXA(PSBRXAX),U)
177 .S $P(PSBHL7MS,PSBHLFS,7)=$P(PSBRXA(PSBRXAX),U,2)
178 .D:$D(^PSB(53.79,PSBIEN,.9,1))
179 ..S PSBINDX=$O(^PSB(53.79,PSBIEN,.9,"B"),-1)
180 ..S:$D(PSBINDX) $P(PSBHL7MS,PSBHLFS,9)=PSBINDX_PSBHLCS_$$HLDATE^HLFNC($P(^PSB(53.79,PSBIEN,.9,PSBINDX,0),U),"TS")
181 .; "PRN reason"
182 .S:($G(PSBSCHT)="P")&($D(^PSB(53.79,PSBIEN,.2))) $P(PSBHL7FD,PSBHLCS,2)=$P(^PSB(53.79,PSBIEN,.2),U,1)
183 .S $P(PSBHL7MS,PSBHLFS,18)=$G(PSBHL7FD) K PSBHL7FD
184 .; Construct indication - "variance"
185 .S $P(PSBHL7FD,PSBHLCS,2)=$P(^PSB(53.79,PSBIEN,.1),U,4)
186 .S $P(PSBHL7MS,PSBHLFS,19)=PSBHL7FD K PSBHL7FD
187 .S $P(PSBHL7MS,PSBHLFS,20)=$P(^PSB(53.79,PSBIEN,0),U,9)
188 .S HLA("HLS",PSBCNT)=(HLA("HLS",PSBCNT))_PSBHL7MS
189 K PSBRX,PSBRXA,PSBRXAX
190 Q
191ESC(PSBINF) ; Escape message data
192 S PSBINFO=PSBINF K PSBESC,PSBINFO1 F PSBESCX=1:1:4 D
193 .S PSBCHR=$E(HL("ECH"),PSBESCX)
194 .I ($L(PSBINFO,PSBCHR)-1)>0 S PSBINFO1=PSBINFO F PSBESCXX=1:1:$L(PSBINFO,PSBCHR)-1 D
195 ..S PSBESC($F(PSBINFO1,PSBCHR)-1)=$E(HL("ECH"),3)_$E("SRET",PSBESCX)_$E(HL("ECH"),3)
196 ..S PSBINFO1=$E(PSBINFO1,1,$F(PSBINFO1,PSBCHR)-2)_U_$E(PSBINFO1,$F(PSBINFO1,PSBCHR),250)
197 S:$D(PSBINFO1) PSBINFO=PSBINFO1
198 S (PSBCNT1,PSBESCX,PSBESCXX)=0 F S PSBESCX=$O(PSBESC(PSBESCX)) Q:PSBESCX="" D
199 .S PSBESCXX=PSBESCX+PSBCNT1,PSBINFO=$E(PSBINFO,1,PSBESCXX-1)_$G(PSBESC(PSBESCX))_$E(PSBINFO,PSBESCXX+1,250),PSBCNT1=PSBCNT1+2
200 Q PSBINFO
201 ;
202TRANS ; CALL HL7 TO Transmit Message
203 K PSBHL7MS,PSBHL7FD
204 D:$D(HLA("HLS")) GENERATE^HLMA("PSB BCMA RASO17 SRV","LM",1,.PSBHL7T,"",.PSBHL7OP)
205 I +$P(PSBHL7T,U,2) W !,"PSB(BCMA) HL7 MESSAGE HAS FAILED TRANSMISSION - could not generate"
206 Q
207 ;
Note: See TracBrowser for help on using the repository browser.