source: FOIAVistA/trunk/r/BAR_CODE_MED_ADMIN-ALPB-PSB/ALPBHL1.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: 8.2 KB
Line 
1ALPBHL1 ;OIFO-DALLAS MW,SED,KC - BCBU main HL7 message processor ;01/01/03
2 ;;3.0;BAR CODE MED ADMIN;**7,8**;Mar 2004
3 ;
4 S ALPBECH=HL("ECH")
5 S ALPBCS=$E(ALPBECH)
6 S ALPBFS=HL("FS")
7 S ALPBHREC=$S(+$G(HLMTIEN)>0:HLMTIEN,1:$G(HL("MID")))
8 ;
9 ; process the entire HL7 message's lines into local array...
10 F I=1:1 X HLNEXT Q:+$G(HLQUIT)'>0 D
11 .S ALPBSEG=$P(HLNODE,ALPBFS,1)
12 .; store patient ID and order segments in a special way...
13 .I ALPBSEG="PID"!(ALPBSEG="ORC")!(ALPBSEG="PV1")!(ALPBSEG="RXO") S ALPBMTXT(ALPBSEG)=HLNODE
14 .I ALPBSEG="AL1" S ALPBMTXT("AL1")=1
15 .S ALPBMTXT(I)=HLNODE
16 .; get any continuation lines...
17 .S J=0
18 .F S J=$O(HLNODE(J)) Q:'J S ALPBMTXT(I,J)=HLNODE(J)
19 .K ALPBSEG
20 ;
21 ; retrieve patient ID data from the PID segment...
22 S ALPBX=$G(ALPBMTXT("PID"))
23 I ALPBX'="" D
24 .D GETPID^ALPBUTL2(ALPBX,ALPBFS,ALPBCS,ALPBECH,.ALPBDATA)
25 .S ALPBPDFN=$G(ALPBDATA(1))
26 .S ALPBPNAM=$G(ALPBDATA(2))
27 .S ALPBPSSN=$G(ALPBDATA(3))
28 .S ALPBPDOB=$G(ALPBDATA(4))
29 .S ALPBPSEX=$G(ALPBDATA(5))
30 .K ALPBDATA
31 K ALPBX
32 ; we must have patient's SSN (ALPBPSSN) to process this message...
33 I $G(ALPBPSSN)="" D Q
34 .D ERRBLD^ALPBUTL1("PID","Invalid/missing SSN",.ALPBFERR)
35 .D ERRLOG^ALPBUTL1(0,0,ALPBHREC,"PID",$G(ALPBMTXT("PID"),"PID segment undefined"),.ALPBFERR)
36 .K ALPBFERR
37 .D CLEAN
38 K ALPBMTXT("PID")
39 ;
40 ; using patient's DFN, get BCBU record number...
41 S ALPBIEN=0
42 I $D(^ALPB(53.7,ALPBPDFN)) S ALPBIEN=ALPBPDFN
43 ; create new record?...
44 I ALPBIEN'>0 D
45 .S DIC="^ALPB(53.7,"
46 .S DIC(0)="LZ"
47 .S DINUM=ALPBPDFN
48 .S DLAYGO=53.7
49 .S X=ALPBPNAM
50 .D FILE^DICN
51 .K DIC,DINUM,DLAYGO
52 .S ALPBIEN=+Y
53 ; if ALPBIEN'>0 then patient record find or creation error...
54 I +ALPBIEN'>0 D Q
55 .D ERRBLD^ALPBUTL1("","Failed to find/create patient record",.ALPBFERR)
56 .D ERRLOG^ALPBUTL1(0,0,ALPBHREC,"",$G(ALPBPDFN,"DFN undefined")_"^"_$G(ALPBPNAM,"Name undefined")_"^"_$G(ALPBPSSN,"SSN undefined"),.ALPBFERR)
57 .K ALPBFERR
58 .D CLEAN
59 ;
60 ; check PV1 segment to see if this is a discharge movement. if so,
61 ; delete the patient's BCBU record and quit...
62 I $P($G(ALPBMTXT("PV1")),ALPBFS,37)'="" D Q
63 .D DELPT^ALPBUTL(+$G(ALPBIEN))
64 .D CLEAN
65 ;
66 ; file/update patient demographic data...
67 S ALPBFILE(53.7,ALPBIEN_",",.01)=ALPBPNAM
68 S ALPBFILE(53.7,ALPBIEN_",",1)=ALPBPSSN
69 S ALPBFILE(53.7,ALPBIEN_",",2)=ALPBPDOB
70 S ALPBFILE(53.7,ALPBIEN_",",3)=ALPBPSEX
71 D FILE^DIE("","ALPBFILE","ALPBFERR")
72 I +$G(ALPBFERR("DIERR")) D ERRLOG^ALPBUTL1(+$G(ALPBIEN),0,$G(ALPBHREC),"PID","Demographics update failed",.ALPBFERR)
73 K ALPBFERR,ALPBFILE
74 ;
75 ; if the allergies flag is set (ALPBMTXT("AL1")), delete any
76 ; allergies on file (they will be rebuilt by this message)...
77 I +$G(ALPBMTXT("AL1")) D DELALG^ALPBUTL2(ALPBIEN)
78 ;
79 ; if there is no ORC (order) segment, process the rest of the
80 ; message and quit...
81 I $G(ALPBMTXT("ORC"))="" D PM Q
82 ;
83 ; retrieve order number and transaction date from ORC segment...
84 D GETORC^ALPBUTL2($G(ALPBMTXT("ORC")),$G(ALPBFS),$G(ALPBCS),.ALPBDATA)
85 S ALPBMLOG=$S($G(ALPBDATA(0))="ML":1,1:0)
86 S ALPBORDN=$G(ALPBDATA(1))
87 S ALPBORDT=$G(ALPBDATA(2))
88 S ALPBORDC=+$G(ALPBDATA(3))
89 ; ALPBOTYP="V" for IV, "U" for Unit Dose, or "P" for Pending
90 S ALPBOTYP=$G(ALPBDATA(4))
91 K ALPBDATA
92 ;
93 ; we must have an order number to process the order-specific data,
94 ; if we do not then log that error condition and quit...
95 I $G(ALPBORDN)="" D Q
96 .D ERRBLD^ALPBUTL1("","No order number in ORC segment",.ALPBFERR)
97 .D ERRLOG^ALPBUTL1(0,0,ALPBHREC,"ORC",$G(ALPBMTXT("ORC"),"ORC segment not defined"),.ALPBFERR)
98 .K ALPBFERR
99 .D CLEAN
100 K ALPBMTXT("ORC")
101 ;
102 ; using CPRS order number, check to see if the order is already on
103 ; file. if so, and status is PENDING delete the order record...
104 I ALPBORDC>0 D
105 .;LOOP Through. May have replaced orders so need to check all
106 .S ALPBI=0
107 .F S ALPBI=$O(^ALPB(53.7,ALPBIEN,2,"ACPRS",ALPBORDC,ALPBI)) Q:+ALPBI'>0 D
108 ..I $E($P($G(^ALPB(53.7,ALPBIEN,2,ALPBI,0)),"^",3),1,2)'="IP" Q
109 ..D DELORD^ALPBUTL(ALPBIEN,ALPBI)
110 K ALPBI
111 ;
112 ; existing order's record number?...
113 K ALPBOIEN
114 S ALPBOIEN=+$O(^ALPB(53.7,ALPBIEN,2,"B",ALPBORDN,0))
115 ; if this isn't a Med Log update, and this order is already on
116 ; file, delete its drug(s), additive(s) and/or solution(s) --
117 ; they will be rebuilt by the other segments in this message...
118 I +$G(ALPBMLOG)=0&(ALPBOIEN>0) D CLORD^ALPBUTL2(ALPBIEN,ALPBOIEN)
119 ; create new order record?...
120 I +$G(ALPBOIEN)=0 D
121 .S ALPBOIEN=+$O(^ALPB(53.7,ALPBIEN,2," "),-1)+1
122 .S ALPBFILE(53.702,"+"_ALPBOIEN_","_ALPBIEN_",",.01)=ALPBORDN
123 .; don't file a 0 (zero) CPRS order number...
124 .I ALPBORDC>0 S ALPBFILE(53.702,"+"_ALPBOIEN_","_ALPBIEN_",",1)=ALPBORDC
125 .S ALPBFILE(53.702,"+"_ALPBOIEN_","_ALPBIEN_",",3)=ALPBORDT
126 .S ALPBFILE(53.702,"+"_ALPBOIEN_","_ALPBIEN_",",6)=ALPBOTYP
127 .D UPDATE^DIE("","ALPBFILE","ALPBOIEN","ALPBFERR")
128 .I +$G(ALPBFERR("DIERR")) D ERRLOG^ALPBUTL1(ALPBIEN,"0",ALPBHREC,"NEWORD","",.ALPBFERR)
129 .K ALPBFERR,ALPBFILE
130 ;
131PM ; process the message segments...
132 S I=0
133 F S I=$O(ALPBMTXT(I)) Q:'I D
134 .S ALPBDATA=ALPBMTXT(I)
135 .S ALPBSEG=$P(ALPBDATA,ALPBFS)
136 .; allergies segment...
137 .I ALPBSEG="AL1" D
138 ..D AL1^ALPBHL1U(+$G(ALPBIEN),$G(ALPBDATA),$G(ALPBFS),$G(ALPBCS),.ALPBFERR)
139 ..I +$G(ALPBFERR("DIERR")) D ERRLOG^ALPBUTL1(+$G(ALPBIEN),+$G(ALPBOIEN),$G(ALPBHREC),"AL1",$G(ALPBDATA),.ALPBFERR)
140 ..K ALPBFERR
141 .; general order segment...
142 .I ALPBSEG="ORC" D
143 ..D ORC^ALPBHL1U(+$G(ALPBIEN),+$G(ALPBOIEN),$G(ALPBDATA),$G(ALPBMLOG),$G(ALPBFS),$G(ALPBCS),.ALPBFERR)
144 ..I +$G(ALPBFERR("DIERR")) D ERRLOG^ALPBUTL1(+$G(ALPBIEN),+$G(ALPBOIEN),$G(ALPBHREC),"ORC",$G(ALPBDATA),.ALPBFERR)
145 ..K ALPBFERR
146 .; patient movement/location segment...
147 .I ALPBSEG="PV1" D
148 ..D PV1^ALPBHL1U(+$G(ALPBIEN),$G(ALPBDATA),$G(ALPBFS),$G(ALPBCS),.ALPBFERR)
149 ..I +$G(ALPBFERR("DIERR")) D ERRLOG^ALPBUTL1(+$G(ALPBIEN),+$G(ALPBOIEN),$G(ALPBHREC),"PV1",$G(ALPBDATA),.ALPBFERR)
150 ..K ALPBFERR
151 .; IV orders segment...
152 .I ALPBSEG="RXC" D
153 ..D RXC^ALPBHL1U(+$G(ALPBIEN),+$G(ALPBOIEN),$G(ALPBDATA),$G(ALPBFS),$G(ALPBCS),.ALPBFERR)
154 ..I +$G(ALPBFERR("DIERR")) D ERRLOG^ALPBUTL1(+$G(ALPBIEN),+$G(ALPBOIEN),$G(ALPBHREC),"RXC",$G(ALPBDATA),.ALPBFERR)
155 ..K ALPBFERR
156 .; drug, additives and/or solutions segment...
157 .I ALPBSEG="RXE" D
158 ..I $G(ALPBDATA)="" Q
159 ..; if this is a Pending order, check to see if a drug is included in this RXE seg. if not, let's try to add the one that may be in the RXO seg...
160 ..I +$P($P(ALPBDATA,ALPBFS,3),ALPBCS,4)=0 S $P(ALPBDATA,ALPBFS,3)=$P($G(ALPBMTXT("RXO")),ALPBFS,2)
161 ..;chech for any continuation lines
162 ..S J=0 F S J=$O(ALPBMTXT(I,J)) Q:'J S ALPBDATA=ALPBDATA_ALPBMTXT(I,J)
163 ..D RXE^ALPBHL1U(+$G(ALPBIEN),+$G(ALPBOIEN),ALPBDATA,$G(ALPBFS),$G(ALPBCS),$G(ALPBECH),.ALPBFERR)
164 ..I +$G(ALPBFERR("DIERR")) D ERRLOG^ALPBUTL1(+$G(ALPBIEN),+$G(ALPBOIEN),$G(ALPBHREC),"RXE",ALPBDATA,.ALPBFERR)
165 ..K ALPBFERR
166 .; med route...
167 .I ALPBSEG="RXR" D
168 ..D RXR^ALPBHL1U(+$G(ALPBIEN),+$G(ALPBOIEN),$G(ALPBDATA),$G(ALPBFS),$G(ALPBCS),.ALBPFERR)
169 ..I +$G(ALPBFERR("DIERR")) D ERRLOG^ALPBUTL1(+$G(ALPBIEN),+$G(ALPBOIEN),$G(ALPBHREC),"RXR",$G(ALPBDATA),.ALPBFERR)
170 ..K ALPBFERR
171 .; provider comments, special instructions or other print info...
172 .I ALPBSEG="NTE" D
173 ..; NTE segments can be multiple-lines. set up an array (ALPBNTE(...)) to pass to the filer...
174 ..; the first node will be the one that contains the NTE segment identifier
175 ..S ALPBNTE(1)=ALPBDATA
176 ..S ALPBX=1
177 ..; loop from ALPBMTXT(I) to retrieve any continuation lines...
178 ..S J=0
179 ..F S J=$O(ALPBMTXT(I,J)) Q:'J D
180 ...S ALPBX=ALPBX+1
181 ...S ALPBNTE(ALPBX)=ALPBMTXT(I,J)
182 ..K ALPBX,J
183 ..D NTE^ALPBHL1U(+$G(ALPBIEN),+$G(ALPBOIEN),.ALPBNTE,$G(ALPBFS),$G(ALPBCS),.ALPBFERR)
184 ..I +$G(ALPBFERR("DIERR")) D ERRLOG^ALPBUTL1(+$G(ALPBIEN),+$G(ALPBOIEN),$G(ALPBHREC),"NTE",ALPBDATA,.ALPBFERR)
185 ..K ALPBFERR,ALPBNTE
186 .K ALPBDATA,ALPBSEG
187 ;
188 ; set RECORD LAST UPDATED field...
189 S ALPBLUPD=$$NOW^XLFDT()
190 I $G(^ALPB(53.7,+$G(ALPBIEN),0))'="" D
191 .S ALPBFILE(53.7,ALPBIEN_",",7)=ALPBLUPD
192 .D FILE^DIE("","ALPBFILE","ALPBFERR")
193 .K ALPBFERR,ALPBFILE
194 ;
195 ; update PARAMETER file with last update date...
196 S ALPBPARM=+$O(^ALPB(53.71,0))
197 I ALPBPARM>0 D
198 .S ALPBFILE(53.71,ALPBPARM_",",4)=ALPBLUPD
199 .D FILE^DIE("","ALPBFILE","ALPBFERR")
200 .K ALPBFERR,ALPBFILE
201 K ALPBLUPD,ALPBPARM
202 ;
203CLEAN K ALPBCS,ALPBDATA,ALPBECH,ALPBFS,ALPBHREC,ALPBIEN,ALPBMLOG,ALPBMTXT
204 K ALPBOIEN,ALPBORDC,ALPBORDN,ALPBORDT,ALPBOTYP,ALPBPDFN,ALPBPDOB
205 K ALPBPNAM,ALPBPSEX,ALPBPSSN,ALPBSEG
206 Q
Note: See TracBrowser for help on using the repository browser.