source: FOIAVistA/trunk/r/BAR_CODE_MED_ADMIN-ALPB-PSB/ALPBHL1U.m@ 1800

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

initial load of FOIAVistA 6/30/08 version
File size: 9.0 KB
Line 
1ALPBHL1U ;OIFO-DALLAS MW,SED,KC -HL7 MESSAGE SEGMENT PARSER AND UPDATE;01/01/03
2 ;;3.0;BAR CODE MED ADMIN;**7**;May 2002
3 ;
4 ; passed parameters common to all functions:
5 ; IEN = patient's internal entry number in file 53.7
6 ; OIEN = the order number's internal entry number in file 53.7
7 ; DATA = the HL7 message line
8 ; FS = the HL7 field separator character (e.g., "|" or "^")
9 ; CS = the HL7 component separator character (e.g., "~")
10 ; ECH = the HL7 encoding characters
11 ; ERR = an array passed by reference, returned containing
12 ; FileMan DBS call error array (if any)
13 ;
14AL1(IEN,DATA,FS,CS,ERR) ; process AL1 (allergies) segment...
15 I +$G(IEN)'>0!($G(DATA)="")!($G(FS)="")!($G(CS)="") D ERRBLD^ALPBUTL1("AL1","",.ERR) Q
16 N ALPBALG,ALPBALGN,ALPBFILE,ALPBNEXT
17 S ALPBALG=+$P(DATA,FS,4)
18 I ALPBALG'>0 D ERRBLD^ALPBUTL1("AL1","Undefined allergy "_DATA,.ERR) Q
19 S ALPBALGN=$P($P(DATA,FS,4),CS,2)
20 ; is this allergy already on file for this patient?...
21 I $D(^ALPB(53.7,IEN,1,"B",ALPBALG)) S ERR("DIERR")=0 Q
22 ; if not, file it...
23 S ALPBNEXT=+$O(^ALPB(53.7,IEN,1," "),-1)+1
24 S ALPBFILE(53.701,"+"_ALPBNEXT_","_IEN_",",.01)=ALPBALG
25 S ALPBFILE(53.701,"+"_ALPBNEXT_","_IEN_",",1)=ALPBALGN
26 D UPDATE^DIE("","ALPBFILE","ALPBNEXT","ERR")
27 Q
28 ;
29ORC(IEN,OIEN,DATA,MLOG,FS,CS,ERR) ; process ORC (common order) segment...
30 ; MLOG = if 1 then this is an ORC segment with a Med Log update
31 ; if 0 then this is a common order update
32 I +$G(IEN)'>0!(+$G(OIEN)'>0)!($G(DATA)="")!($G(MLOG)="")!($G(FS)="")!($G(CS)="") D ERRBLD^ALPBUTL1("ORC","",.ERR) Q
33 N ALPBFIEN,ALPBFILE,ALPBMREC,ALPBNEXT,ALPBTEXT,ALPBX
34 S ALPBFIEN=OIEN_","_IEN_","
35 ; ORC segment with NO MedLog data...
36 I +MLOG=0 D
37 .S ALPBX=$P(DATA,FS,1)
38 .; order status...
39 .S ALPBFILE(53.702,ALPBFIEN,2)=$P(DATA,FS,6)
40 .; provider...
41 .S ALPBFILE(53.702,ALPBFIEN,5)=$P($P(DATA,FS,13),CS,2)
42 .; entry person/rph...
43 .S ALPBFILE(53.702,ALPBFIEN,5.1)=$P($P(DATA,FS,11),CS,2)
44 .; verified by...
45 .S ALPBFILE(53.702,ALPBFIEN,5.2)=$P($P(DATA,FS,12),CS,2)
46 .D UPDATE^DIE("","ALPBFILE","","ERR")
47 .; if this is a pending order, add special instructions...
48 .I $P($P(DATA,FS,6),CS,1)="IP" D
49 ..S ALPBTEXT(1)="CAUTION! THIS IS A PENDING ORDER :: CHECK WITH PROVIDER OR PHARMACIST!"
50 ..D WP^DIE(53.702,ALPBFIEN,8,"A","ALPBTEXT","ERR")
51 ..K ALPBTEXT
52 ; ORC segment with specific MedLog data...
53 I +MLOG=1 D
54 .; ALPBX = med log date/time...
55 .S ALPBX=$$FMDATE^HLFNC($P(DATA,FS,10))
56 .I ALPBX="" K ALPBX Q
57 .; ALPBMREC = med log record number...
58 .S ALPBMREC=+$P($P(DATA,FS,3),CS,1)
59 .; if the med log entry is already on file, update and quit.
60 .; check for both an entry on file for the log date/time ("B" xref)
61 .; or med log record number ("C" xref)...
62 .S ALPBNEXT=+$O(^ALPB(53.7,IEN,2,OIEN,10,"B",ALPBX,""))
63 .I ALPBNEXT'>0 S ALPBNEXT=+$O(^ALPB(53.7,IEN,2,OIEN,10,"C",ALPBMREC,""))
64 .I ALPBNEXT>0 D Q
65 ..S ALPBFILE(53.70213,ALPBNEXT_","_ALPBFIEN,.01)=ALPBX
66 ..S ALPBFILE(53.70213,ALPBNEXT_","_ALPBFIEN,1)=$P($P(DATA,FS,11),CS,2)
67 ..S ALPBFILE(53.70213,ALPBNEXT_","_ALPBFIEN,2)=$P($P(DATA,FS,6),CS,2)
68 ..I ALPBMREC>0 S ALPBFILE(53.70213,ALPBNEXT_","_ALPBFIEN,3)=ALPBMREC
69 ..D UPDATE^DIE("","ALPBFILE","","ERR")
70 .K ALPBNEXT
71 .; if not, add it...
72 .S ALPBNEXT=+$O(^ALPB(53.7,IEN,2,OIEN,6," "),-1)+1
73 .S ALPBFILE(53.70213,"+"_ALPBNEXT_","_ALPBFIEN,.01)=ALPBX
74 .; med log entry person...
75 .S ALPBFILE(53.70213,"+"_ALPBNEXT_","_ALPBFIEN,1)=$P($P(DATA,FS,11),CS,2)
76 .; med log transaction message...
77 .S ALPBFILE(53.70213,"+"_ALPBNEXT_","_ALPBFIEN,2)=$P($P(DATA,FS,6),CS,2)
78 .; med log record number...
79 .I ALPBMREC>0 S ALPBFILE(53.70213,"+"_ALPBNEXT_","_ALPBFIEN,3)=ALPBMREC
80 .D UPDATE^DIE("","ALPBFILE","ALPBNEXT","ERR")
81 Q
82 ;
83PV1(IEN,DATA,FS,CS,ERR) ; process PV1 (patient visit/movement) segment...
84 I +$G(IEN)=0!($G(DATA)="") D ERRBLD^ALPBUTL1("PV1","",.ERR) Q
85 N ALPBFIEN,ALPBFILE,ALPBX
86 S ALPBFIEN=IEN_","
87 S ALPBX=$P(DATA,FS,4)
88 ; ward...
89 S ALPBFILE(53.7,ALPBFIEN,4)=$P(ALPBX,CS)
90 ; room...
91 S ALPBFILE(53.7,ALPBFIEN,5)=$P(ALPBX,CS,2)
92 ; bed...
93 S ALPBFILE(53.7,ALPBFIEN,6)=$P(ALPBX,CS,3)
94 D FILE^DIE("","ALPBFILE","ERR")
95 Q
96 ;
97RXO(IEN,OIEN,DATA,FS,CS,ERR) ; process RXO (pharmacy prescription order) segment...
98 ; for inpatient meds, this segment contains an orderable item. this
99 ; module is ONLY called if the order is "P"ending. it only files the
100 ; orderable item if no drug is on file for the order.
101 N ALPBDIEN,ALPBDRUG,ALPBFILE,ALPBNEXT
102 I +$G(IEN)'>0!(+$G(OIEN)'>0)!($G(DATA)="")!($G(FS)="")!($G(CS)="") D ERRBLD^ALPBUTL1("RXO","",.ERR) Q
103 S ALPBDIEN=+$P($P(DATA,FS,2),CS,4)
104 S ALPBDRUG=$P($P(DATA,FS,2),CS,5)
105 I ALPBDIEN'>0 D ERRBLD^ALPBUTL1("RXO","Invalid drug IEN in RXO segment",.ERR) Q
106 ; if there is ANY drug already on file, quit...
107 I +$O(^ALPB(53.7,IEN,2,OIEN,7,0))>0 Q
108 ; if not, file it...
109 S ALPBNEXT=+$O(^ALPB(53.7,IEN,2,OIEN,7," "),-1)+1
110 S ALPBFILE(53.703,"+"_ALPBNEXT_","_OIEN_","_IEN_",",.01)=ALPBDIEN
111 S ALPBFILE(53.703,"+"_ALPBNEXT_","_OIEN_","_IEN_",",1)=ALPBDRUG
112 D UPDATE^DIE("","ALPBFILE","ALPBNEXT","ERR")
113 Q
114 ;
115RXE(IEN,OIEN,DATA,FS,CS,ECH,ERR) ; process RXE (order detail) segment...
116 ; this segment may contain the drug name, though there may not be a drug
117 ; because this can also be used for order detail for IV's which are
118 ; contained in an RXC segment. this segment can also contain start/stop
119 ; date&time, dosage and schedule
120 I +$G(IEN)'>0!(+$G(OIEN)'>0)!($G(DATA)="")!($G(FS)="")!($G(CS)="")!($G(ECH)="") D ERRBLD^ALPBUTL1("RXE","",.ERR) Q
121 N ALPBDIEN,ALPBDRUG,ALPBFIEN,ALPBFILE,ALPBNEXT,ALPBSCHD,ALPBX,SCS
122 S SCS=$E(ECH,4)
123 S ALPBFIEN=OIEN_","_IEN_","
124 ; for drug, we'll use the one that came from the Drug file...
125 S ALPBDIEN=+$P($P(DATA,FS,3),CS,4)
126 S ALPBDRUG=$P($P(DATA,FS,3),CS,5)
127 ; is this drug already on file for this order? if not, add it...
128 I ALPBDIEN>0&('$D(^ALPB(53.7,IEN,2,OIEN,7,"B",ALPBDIEN))) D
129 .S ALPBNEXT=+$O(^ALPB(53.7,IEN,2,OIEN,7," "),-1)+1
130 .S ALPBFILE(53.703,"+"_ALPBNEXT_","_ALPBFIEN,.01)=ALPBDIEN
131 .S ALPBFILE(53.703,"+"_ALPBNEXT_","_ALPBFIEN,1)=ALPBDRUG
132 .D UPDATE^DIE("","ALPBFILE","ALPBNEXT","ERR")
133 .K ALPBFERR,ALPBFILE,ALPBNEXT
134 S ALPBX=$P(DATA,FS,2)
135 ; start date/time...
136 S ALPBFILE(53.702,ALPBFIEN,4)=$$FMDATE^HLFNC($P(ALPBX,CS,4))
137 ; stop date/time...
138 S ALPBFILE(53.702,ALPBFIEN,4.1)=$$FMDATE^HLFNC($P(ALPBX,CS,5))
139 ; dosage...
140 S ALPBFILE(53.702,ALPBFIEN,7)=$P(ALPBX,CS,8)
141 ; schedule...
142 S ALPBSCHD=$P(ALPBX,CS,2)
143 I $P(DATA,FS,24)'="" S ALPBSCHD=ALPBSCHD_" "_$P(DATA,FS,24)
144 I $P($P(DATA,FS,25),CS,5)'="" S ALPBSCHD=ALPBSCHD_" "_$P($P(DATA,FS,25),CS,5)
145 S ALPBFILE(53.702,ALPBFIEN,7.2)=ALPBSCHD
146 ; timing...
147 S ALPBFILE(53.702,ALPBFIEN,7.3)=$P($P(DATA,FS,22),CS,2)
148 D UPDATE^DIE("","ALPBFILE","","ERR")
149 Q
150 ;
151RXR(IEN,OIEN,DATA,FS,CS,ERR) ; process RXR (med administration route) segment...
152 I +$G(IEN)'>0!(+$G(OIEN)'>0)!($G(DATA)="")!($G(FS)="")!($G(CS)="") D ERRBLD^ALPBUTL1("RXR","",.ERR) Q
153 N ALPBFILE
154 ; route...
155 S ALPBFILE(53.702,OIEN_","_IEN_",",7.1)=$P($P(DATA,FS,2),CS,5)
156 D UPDATE^DIE("","ALPBFILE","","ERR")
157 Q
158 ;
159RXC(IEN,OIEN,DATA,FS,CS,ERR) ; process RXC (IV orders: additives/solutions) segment...
160 I +$G(IEN)'>0!(+$G(OIEN)'>0)!($G(DATA)="")!($G(FS)="")!($G(CS)="") D ERRBLD^ALPBUTL1("RXC","",.ERR) Q
161 N ALPBFILE,ALPBFNOD,ALPBGNOD,ALPBNAM,ALPBNEXT,ALPBNUM,ALPBTYP,ALPBUNIT
162 S ALPBTYP=$P(DATA,FS,2)
163 S ALPBGNOD=$S(ALPBTYP="A":8,ALPBTYP="B":9,1:0)
164 I ALPBGNOD=0 D ERRBLD^ALPBUTL1("RXC","Unable to determine Additive or Solution in RXC segment",.ERR) Q
165 S ALPBFNOD="53.7021"_$S(ALPBGNOD=8:1,1:2)
166 S ALPBNUM=$P($P(DATA,FS,3),CS,4)
167 ; is this additive or solution already on file?...
168 I $D(^ALPB(53.7,IEN,2,OIEN,ALPBGNOD,"B",ALPBNUM)) S ERR("DIERR")=0 Q
169 ; if not, file it...
170 S ALPBNAM=$P($P(DATA,FS,3),CS,5)
171 S ALPBUNIT=$P(DATA,FS,4)_$P($P(DATA,FS,5),CS,5)
172 S ALPBNEXT=+$O(^ALPB(53.7,IEN,2,OIEN,ALPBGNOD," "),-1)+1
173 S ALPBFILE(ALPBFNOD,"+"_ALPBNEXT_","_OIEN_","_IEN_",",.01)=ALPBNUM
174 S ALPBFILE(ALPBFNOD,"+"_ALPBNEXT_","_OIEN_","_IEN_",",1)=ALPBNAM
175 S ALPBFILE(ALPBFNOD,"+"_ALPBNEXT_","_OIEN_","_IEN_",",2)=ALPBUNIT
176 D UPDATE^DIE("","ALPBFILE","ALPBNEXT","ERR")
177 Q
178 ;
179NTE(IEN,OIEN,DATA,FS,CS,ERR) ; process NTE (note) segment...
180 ; note: in the case of NTE segments, DATA is passed in as an array.
181 ; NTE data can be in multiple nodes, the first subscript of which
182 ; contains the actual NTE segments itself.
183 I +$G(IEN)'>0!(+$G(OIEN)'>0)!($D(DATA)=0)!($G(FS)="")!($G(CS)="") D ERRBLD^ALPBUTL1("NTE","",.ERR) Q
184 N ALPBFILE,I
185 ; check the status of this order. if it is pending, abort
186 ; and do not file any special comments (note ORC module comments)...
187 I $E($P($G(^ALPB(53.7,IEN,2,OIEN,0)),"^",3),1,2)="IP" Q
188 ; examine DATA(1) and from the Pharmacy package code in the second
189 ; field, insert a header at the first subscript level of our working
190 ; array (which we will pass to the FileMan call)...
191 S ALPBFILE(1)=$S($P(DATA(1),FS,2)=6:"Provider Comments:",$P(DATA(1),FS,2)=21:"Special Instructions:",1:"Other Info:")
192 ; now get the data from DATA(1), field 4 and set it into the second subscript of our
193 ; working array...
194 S ALPBFILE(2)=$P(DATA(1),FS,4)
195 ; finally, process the rest of the lines from the DATA(n) array into our working array...
196 S I=2
197 F S I=$O(DATA(I)) Q:'I S ALPBFILE(I)=DATA(I)
198 D WP^DIE(53.702,OIEN_","_IEN_",",8,"","ALPBFILE","ERR")
199 Q
Note: See TracBrowser for help on using the repository browser.