ALPBHL1U ;OIFO-DALLAS MW,SED,KC -HL7 MESSAGE SEGMENT PARSER AND UPDATE ;2/6/21 15:41
;;3.0;BAR CODE MED ADMIN;**7,69,59,73,87,127,108,129**;May 2002;Build 16
;
; passed parameters common to all functions:
; IEN = patient's internal entry number in file 53.7
; OIEN = the order number's internal entry number in file 53.7
; DATA = the HL7 message line
; FS = the HL7 field separator character (e.g., "|" or "^")
; CS = the HL7 component separator character (e.g., "~")
; ECH = the HL7 encoding characters
; ERR = an array passed by reference, returned containing
; FileMan DBS call error array (if any)
;
;*69 - A New NTE segment will now contain WP unlimited text. This
; text will also contain formatted text escape character \.br\
; NTE tag will now rebuild work arrays honoring the line break
; escape character prior to storing into BCMA BACKUP DATA #53.7.
;**73- Add Clinic name to Order multiple for orders that were placed
; in a clinic vs. a Ward.
;*87 - Add Remove logic to pull out new fields and store to DB
;*108- add ZZZ segment for Hazardous drug flags
;
AL1(IEN,DATA,FS,CS,ERR) ; process AL1 (allergies) segment...
I +$G(IEN)'>0!($G(DATA)="")!($G(FS)="")!($G(CS)="") D ERRBLD^ALPBUTL1("AL1","",.ERR) Q
N ALPBALG,ALPBALGN,ALPBFILE,ALPBNEXT,ALPBSCHD,ALPBX,SCS,ALPBXX,ALPBSCHDLE1,ALPBX2,ALPBYY
S ALPBALG=+$P(DATA,FS,4)
I ALPBALG'>0 D ERRBLD^ALPBUTL1("AL1","Undefined allergy "_DATA,.ERR) Q
S ALPBALGN=$P($P(DATA,FS,4),CS,2)
; is this allergy already on file for this patient?...
I $D(^ALPB(53.7,IEN,1,"B",ALPBALG)) S ERR("DIERR")=0 Q
; if not, file it...
S ALPBNEXT=+$O(^ALPB(53.7,IEN,1," "),-1)+1
S ALPBFILE(53.701,"+"_ALPBNEXT_","_IEN_",",.01)=ALPBALG
S ALPBFILE(53.701,"+"_ALPBNEXT_","_IEN_",",1)=ALPBALGN
D UPDATE^DIE("","ALPBFILE","ALPBNEXT","ERR")
Q
;
ORC(IEN,OIEN,DATA,MLOG,FS,CS,ERR) ; process ORC (common order) segment...
; MLOG = if 1 then this is an ORC segment with a Med Log update
; if 0 then this is a common order update
I +$G(IEN)'>0!(+$G(OIEN)'>0)!($G(DATA)="")!($G(MLOG)="")!($G(FS)="")!($G(CS)="") D ERRBLD^ALPBUTL1("ORC","",.ERR) Q
N ALPBFIEN,ALPBFILE,ALPBMREC,ALPBNEXT,ALPBTEXT,ALPBX,SVZERO ;*87
S ALPBFIEN=OIEN_","_IEN_","
; ORC segment with NO MedLog data...
I +MLOG=0 D
.S ALPBX=$P(DATA,FS,1)
.; order status...
.S ALPBFILE(53.702,ALPBFIEN,2)=$P(DATA,FS,6)
.; provider...
.S ALPBFILE(53.702,ALPBFIEN,5)=$P($P(DATA,FS,13),CS,2)
.; entry person/rph...
.S ALPBFILE(53.702,ALPBFIEN,5.1)=$P($P(DATA,FS,11),CS,2)
.; verified by...
.S ALPBFILE(53.702,ALPBFIEN,5.2)=$P($P(DATA,FS,12),CS,2)
.; set clinic name in new DD field 3.5 if a clinic order ;*73
.S ALPBFILE(53.702,ALPBFIEN,3.5)=$P(DATA,FS,22)
.D UPDATE^DIE("","ALPBFILE","","ERR")
.; if this is a pending order, add special instructions...
.I $P($P(DATA,FS,6),CS,1)="IP" D
..S ALPBTEXT(1)="CAUTION! THIS IS A PENDING ORDER :: CHECK WITH PROVIDER OR PHARMACIST!"
..D WP^DIE(53.702,ALPBFIEN,8,"A","ALPBTEXT","ERR")
..K ALPBTEXT
; ORC segment with specific MedLog data...
I +MLOG=1 D
.; ALPBX = med log date/time...
.S ALPBX=$$FMDATE^HLFNC($P(DATA,FS,10))
.I ALPBX="" K ALPBX Q
.; ALPBMREC = med log record number...
.S ALPBMREC=+$P($P(DATA,FS,3),CS,1)
.;
.;UPDATE, If the med log entry is already on file, update and quit.
.; check for both an entry on file for the log date/time ("B" xref)
.; or med log record number ("C" xref)...
.S ALPBNEXT=+$O(^ALPB(53.7,IEN,2,OIEN,10,"B",ALPBX,""),-1)
.I ALPBNEXT'>0 S ALPBNEXT=+$O(^ALPB(53.7,IEN,2,OIEN,10,"C",ALPBMREC,""))
.I ALPBNEXT>0 D Q
..S ALPBFILE(53.70213,ALPBNEXT_","_ALPBFIEN,.01)=ALPBX
..S ALPBFILE(53.70213,ALPBNEXT_","_ALPBFIEN,1)=$P($P(DATA,FS,11),CS,2)
..S ALPBFILE(53.70213,ALPBNEXT_","_ALPBFIEN,2)=$P($P(DATA,FS,6),CS,2)
..I ALPBMREC>0 S ALPBFILE(53.70213,ALPBNEXT_","_ALPBFIEN,3)=ALPBMREC
..;if remove status, save associated Given info for storing *87
..D:$P($P(DATA,FS,6),CS,2)["REMOVE"
...S SVZERO=$G(^ALPB(53.7,IEN,2,OIEN,10,ALPBNEXT,0))
...S ALPBFILE(53.70213,ALPBNEXT_","_ALPBFIEN,4)=$P(SVZERO,U,1)
...S ALPBFILE(53.70213,ALPBNEXT_","_ALPBFIEN,5)=$P(SVZERO,U,2)
...S ALPBFILE(53.70213,ALPBNEXT_","_ALPBFIEN,6)=$P(SVZERO,U,3)
..;if Given cur action, then always set assoc Give fields to null *87
..D:$P($P(DATA,FS,6),CS,2)["GIVEN"
...S ALPBFILE(53.70213,ALPBNEXT_","_ALPBFIEN,4)=""
...S ALPBFILE(53.70213,ALPBNEXT_","_ALPBFIEN,5)=""
...S ALPBFILE(53.70213,ALPBNEXT_","_ALPBFIEN,6)=""
..;
..D UPDATE^DIE("","ALPBFILE","","ERR")
.K ALPBNEXT
.;
.;ADD, If not...
.S ALPBNEXT=+$O(^ALPB(53.7,IEN,2,OIEN,10," "),-1) ;bug fix *87
.S ALPBFILE(53.70213,"+"_ALPBNEXT_","_ALPBFIEN,.01)=ALPBX
.; med log entry person...
.S ALPBFILE(53.70213,"+"_ALPBNEXT_","_ALPBFIEN,1)=$P($P(DATA,FS,11),CS,2)
.; med log transaction message...
.S ALPBFILE(53.70213,"+"_ALPBNEXT_","_ALPBFIEN,2)=$P($P(DATA,FS,6),CS,2)
.; med log record number...
.I ALPBMREC>0 S ALPBFILE(53.70213,"+"_ALPBNEXT_","_ALPBFIEN,3)=ALPBMREC
.;if Given cur action, then always init assoc. fields to null *87
.D:$P($P(DATA,FS,6),CS,2)["GIVEN"
..S ALPBFILE(53.70213,"+"_ALPBNEXT_","_ALPBFIEN,4)=""
..S ALPBFILE(53.70213,"+"_ALPBNEXT_","_ALPBFIEN,5)=""
..S ALPBFILE(53.70213,"+"_ALPBNEXT_","_ALPBFIEN,6)=""
.;
.D UPDATE^DIE("","ALPBFILE","ALPBNEXT","ERR")
Q
;
PV1(IEN,DATA,FS,CS,ERR) ; process PV1 (patient visit/movement) segment...
I +$G(IEN)=0!($G(DATA)="") D ERRBLD^ALPBUTL1("PV1","",.ERR) Q
N ALPBFIEN,ALPBFILE,ALPBX
S ALPBFIEN=IEN_","
S ALPBX=$P(DATA,FS,4)
; ward...
S ALPBFILE(53.7,ALPBFIEN,4)=$P(ALPBX,CS)
; room...
S ALPBFILE(53.7,ALPBFIEN,5)=$P(ALPBX,CS,2)
; bed...
S ALPBFILE(53.7,ALPBFIEN,6)=$P(ALPBX,CS,3)
D FILE^DIE("","ALPBFILE","ERR")
Q
;
RXO(IEN,OIEN,DATA,FS,CS,ERR) ; process RXO (pharmacy prescription order) segment...
; for inpatient meds, this segment contains an orderable item. this
; module is ONLY called if the order is "P"ending. it only files the
; orderable item if no drug is on file for the order.
N ALPBDIEN,ALPBDRUG,ALPBFILE,ALPBNEXT
I +$G(IEN)'>0!(+$G(OIEN)'>0)!($G(DATA)="")!($G(FS)="")!($G(CS)="") D ERRBLD^ALPBUTL1("RXO","",.ERR) Q
S ALPBDIEN=+$P($P(DATA,FS,2),CS,4)
S ALPBDRUG=$P($P(DATA,FS,2),CS,5)
I ALPBDIEN'>0 D ERRBLD^ALPBUTL1("RXO","Invalid drug IEN in RXO segment",.ERR) Q
; if there is ANY drug already on file, quit...
I +$O(^ALPB(53.7,IEN,2,OIEN,7,0))>0 Q
; if not, file it...
S ALPBNEXT=+$O(^ALPB(53.7,IEN,2,OIEN,7," "),-1)+1
S ALPBFILE(53.703,"+"_ALPBNEXT_","_OIEN_","_IEN_",",.01)=ALPBDIEN
S ALPBFILE(53.703,"+"_ALPBNEXT_","_OIEN_","_IEN_",",1)=ALPBDRUG
D UPDATE^DIE("","ALPBFILE","ALPBNEXT","ERR")
Q
;
RXE(IEN,OIEN,DATA,FS,CS,ECH,ERR) ; process RXE (order detail) segment...
; this segment may contain the drug name, though there may not be a drug
; because this can also be used for order detail for IV's which are
; contained in an RXC segment. this segment can also contain start/stop
; date&time, dosage and schedule
I +$G(IEN)'>0!(+$G(OIEN)'>0)!($G(DATA)="")!($G(FS)="")!($G(CS)="")!($G(ECH)="") D ERRBLD^ALPBUTL1("RXE","",.ERR) Q
N ALPBDIEN,ALPBDRUG,ALPBFIEN,ALPBFILE,ALPBNEXT,ALPBSCHD,ALPBX,SCS
N ALPBDOA,ALPBREMV,ALPBTIMG,ALPBADM ;*87
S SCS=$E(ECH,4)
S ALPBFIEN=OIEN_","_IEN_","
; for drug, we'll use the one that came from the Drug file...
S ALPBDIEN=+$P($P(DATA,FS,3),CS,4)
S ALPBDRUG=$P($P(DATA,FS,3),CS,5)
; is this drug already on file for this order? if not, add it...
I ALPBDIEN>0&('$D(^ALPB(53.7,IEN,2,OIEN,7,"B",ALPBDIEN))) D
.S ALPBNEXT=+$O(^ALPB(53.7,IEN,2,OIEN,7," "),-1)+1
.S ALPBFILE(53.703,"+"_ALPBNEXT_","_ALPBFIEN,.01)=ALPBDIEN
.S ALPBFILE(53.703,"+"_ALPBNEXT_","_ALPBFIEN,1)=ALPBDRUG
.D UPDATE^DIE("","ALPBFILE","ALPBNEXT","ERR")
.K ALPBFERR,ALPBFILE,ALPBNEXT
S ALPBX=$P(DATA,FS,2)
; start date/time...
S ALPBFILE(53.702,ALPBFIEN,4)=$$FMDATE^HLFNC($P(ALPBX,CS,4))
; stop date/time...
S ALPBFILE(53.702,ALPBFIEN,4.1)=$$FMDATE^HLFNC($P(ALPBX,CS,5))
; dosage...
S ALPBFILE(53.702,ALPBFIEN,7)=$P(ALPBX,CS,8)
; schedule... alter getting directly from RXE.1.2 pieces ;*87
S ALPBTIMG=$P(ALPBX,CS,2)
S ALPBSCHD=$$UNESC^ALPBGEN($P(ALPBTIMG,SCS,1))
S ALPBREMV=$P(ALPBTIMG,SCS,3)
S ALPBDOA=$P(ALPBTIMG,SCS,4)
; end ;*87
I $P(DATA,FS,24)'="" S ALPBSCHD=ALPBSCHD_" "_$P(DATA,FS,24)
I $P($P(DATA,FS,25),CS,5)'="" S ALPBSCHD=ALPBSCHD_" "_$P($P(DATA,FS,25),CS,5)
S ALPBFILE(53.702,ALPBFIEN,7.2)=ALPBSCHD
; timing...
;convert adm & rem times to 4 digit, store them & DOA to 53.7 *87
S ALPBADM=$P($P(DATA,FS,22),CS,2)
S:+ALPBADM ALPBADM=$$CNVRT4(ALPBADM,"-")
S:+ALPBREMV ALPBREMV=$$CNVRT4(ALPBREMV,"-")
S ALPBFILE(53.702,ALPBFIEN,7.3)=ALPBADM
S ALPBFILE(53.702,ALPBFIEN,7.4)=ALPBREMV
S ALPBFILE(53.702,ALPBFIEN,7.5)=ALPBDOA
;
D UPDATE^DIE("","ALPBFILE","","ERR")
Q
;
RXR(IEN,OIEN,DATA,FS,CS,ERR) ; process RXR (med administration route) segment...
I +$G(IEN)'>0!(+$G(OIEN)'>0)!($G(DATA)="")!($G(FS)="")!($G(CS)="") D ERRBLD^ALPBUTL1("RXR","",.ERR) Q
N ALPBFILE
; route...
S ALPBFILE(53.702,OIEN_","_IEN_",",7.1)=$P($P(DATA,FS,2),CS,5)
D UPDATE^DIE("","ALPBFILE","","ERR")
Q
;
RXC(IEN,OIEN,DATA,FS,CS,ERR) ; process RXC (IV orders: additives/solutions) segment...
I +$G(IEN)'>0!(+$G(OIEN)'>0)!($G(DATA)="")!($G(FS)="")!($G(CS)="") D ERRBLD^ALPBUTL1("RXC","",.ERR) Q
N ALPBFILE,ALPBFNOD,ALPBGNOD,ALPBNAM,ALPBNEXT,ALPBNUM,ALPBTYP,ALPBUNIT
S ALPBTYP=$P(DATA,FS,2)
S ALPBGNOD=$S(ALPBTYP="A":8,ALPBTYP="B":9,1:0)
I ALPBGNOD=0 D ERRBLD^ALPBUTL1("RXC","Unable to determine Additive or Solution in RXC segment",.ERR) Q
S ALPBFNOD="53.7021"_$S(ALPBGNOD=8:1,1:2)
S ALPBNUM=$P($P(DATA,FS,3),CS,4)
; is this additive or solution already on file?...
I $D(^ALPB(53.7,IEN,2,OIEN,ALPBGNOD,"B",ALPBNUM)) S ERR("DIERR")=0 Q
; if not, file it...
S ALPBNAM=$P($P(DATA,FS,3),CS,5)
S ALPBUNIT=$P(DATA,FS,4)_$P($P(DATA,FS,5),CS,5)
S ALPBNEXT=+$O(^ALPB(53.7,IEN,2,OIEN,ALPBGNOD," "),-1)+1
S ALPBFILE(ALPBFNOD,"+"_ALPBNEXT_","_OIEN_","_IEN_",",.01)=ALPBNUM
S ALPBFILE(ALPBFNOD,"+"_ALPBNEXT_","_OIEN_","_IEN_",",1)=ALPBNAM
S ALPBFILE(ALPBFNOD,"+"_ALPBNEXT_","_OIEN_","_IEN_",",2)=ALPBUNIT
D UPDATE^DIE("","ALPBFILE","ALPBNEXT","ERR")
Q
;
NTE(IEN,OIEN,DATA,FS,CS,ERR) ; process NTE (note) segment...
; note: in the case of NTE segments, DATA is passed in as an array.
; NTE data can be in multiple nodes, the first subscript of which
; contains the actual NTE segments itself.
I +$G(IEN)'>0!(+$G(OIEN)'>0)!($D(DATA)=0)!($G(FS)="")!($G(CS)="") D ERRBLD^ALPBUTL1("NTE","",.ERR) Q
N ALPBFILE,I
; check the status of this order. if it is pending, abort
; and do not file any special comments (note ORC module comments)...
I $E($P($G(^ALPB(53.7,IEN,2,OIEN,0)),"^",3),1,2)="IP" Q
; examine DATA(1) and from the Pharmacy package code in the second
; field, insert a header at the first subscript level of our working
; array (which we will pass to the FileMan call)...
S ALPBFILE(1)=$S($P(DATA(1),FS,2)=6:"Provider Comments:",$P(DATA(1),FS,2)=21:"Special Instructions:",1:"Other Info:")
;
;*69 Rebuild the WP Instructions from the formatted NTE segment.
; The NTE text will be put into the DATA array and can contain
; the escape character \.br\ for line break. The line break will
; allow this routine to store the WP text exactly how the Rph
; keyed it in IM backdoor. They may have keyed in hard returns
; and spaces, so to create an aligned columnar table, i.e.
; an Insulin sliding scale.
S DATA(1)=$P(DATA(1),FS,4) ;reset DATA(1) from piece 4 of DATA(1)
;
; Unwrap DATA array into one large field, 64k is limit
N ALEN,DLEN,ELEN,QUIT,ALLTXT,NEWALPB
S QUIT=0,ALLTXT=""
;
; Put formatted NTE array together as one line up to 64k
F I=0:0 S I=$O(DATA(I)) Q:'I D Q:QUIT
.S ALEN=$L(ALLTXT),DLEN=$L(DATA(I))
.I ALEN+DLEN>65536 S ELEN=65536-ALEN S ALLTXT=ALLTXT_$E(DATA(I),1,ELEN) S QUIT=1 Q
.S ALLTXT=ALLTXT_DATA(I)
;
; Build new work array from the formatted lines of the large field
D HL7FMT(ALLTXT,.NEWALPB)
;
; Now add back to the text of the new working array into the original
; work array beginning with element 2, as element 1 has the heading
; 129 Added condition to check if Other Info and get P4 on line 1
; ex. line 1(NEWALPB)has NTE^21^L^TEST order for ZZTEST patient
; the rest does not had NTE^21^L segment so get the whole piece
;
I ALPBFILE(1)="Other Info:" F I=0:0 S I=$O(NEWALPB(I)) Q:'I D
. I I=1 S ALPBFILE(I+1)=$P(NEWALPB(I),"^",4)
. I I>1 S ALPBFILE(I+1)=NEWALPB(I)
I ALPBFILE(1)'="Other Info:" F I=0:0 S I=$O(NEWALPB(I)) Q:'I S ALPBFILE(I+1)=NEWALPB(I)
;
; Store new WP text to field 8
D WP^DIE(53.702,OIEN_","_IEN_",",8,"","ALPBFILE","ERR")
Q
;
ZZZ(IEN,OIEN,DATA,FS,CS,ERR) ; process Hazardous Drug flags segment *108
I +$G(IEN)'>0!(+$G(OIEN)'>0)!($G(DATA)="")!($G(FS)="")!($G(CS)="") D ERRBLD^ALPBUTL1("ORC","",.ERR) Q
N ALPBFIEN,ALPBFILE
S ALPBFIEN=OIEN_","_IEN_","
S ALPBFILE(53.702,ALPBFIEN,14)=$S($P(DATA,FS,5)="Y":1,1:0) ;HAZ Handle
S ALPBFILE(53.702,ALPBFIEN,15)=$S($P(DATA,FS,6)="Y":1,1:0) ;HAZ Dispose
D UPDATE^DIE("","ALPBFILE","","ERR")
Q
;
HL7FMT(NEWLN,AR) ;Unwrap formatted text array lines into a new array
; the escape character, \.br\ ,will cause a new array element to
; begin with the text after the escape character.
N ESC,LIN,LN,QUIT,I
S QUIT=0
F I=1:1 S LN=NEWLN D Q:QUIT
. S ESC=$F(LN,"\.br\")
. I ESC=6 S LIN="",NEWLN=$E(LN,ESC,65536) S AR(I)=LIN Q
. I ESC=0 S LIN=NEWLN,NEWLN="" S AR(I)=LIN,QUIT=1 Q
. S LIN=$E(LN,1,ESC-6)
. S NEWLN=$E(LN,ESC,65536)
. S AR(I)=LIN
Q
;
CNVRT4(STR,SEP) ;Converts a time string to 4 digit for consistency
; STR - string of times
; SEP - seperator character between times
;
N QQ
F QQ=1:1:$L(STR,SEP) S $P(STR,SEP,QQ)=$E($P(STR,SEP,QQ)_"0000",1,4)
Q STR
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HALPBHL1U 14207 printed Oct 16, 2024@17:40:15 Page 2
ALPBHL1U ;OIFO-DALLAS MW,SED,KC -HL7 MESSAGE SEGMENT PARSER AND UPDATE ;2/6/21 15:41
+1 ;;3.0;BAR CODE MED ADMIN;**7,69,59,73,87,127,108,129**;May 2002;Build 16
+2 ;
+3 ; passed parameters common to all functions:
+4 ; IEN = patient's internal entry number in file 53.7
+5 ; OIEN = the order number's internal entry number in file 53.7
+6 ; DATA = the HL7 message line
+7 ; FS = the HL7 field separator character (e.g., "|" or "^")
+8 ; CS = the HL7 component separator character (e.g., "~")
+9 ; ECH = the HL7 encoding characters
+10 ; ERR = an array passed by reference, returned containing
+11 ; FileMan DBS call error array (if any)
+12 ;
+13 ;*69 - A New NTE segment will now contain WP unlimited text. This
+14 ; text will also contain formatted text escape character \.br\
+15 ; NTE tag will now rebuild work arrays honoring the line break
+16 ; escape character prior to storing into BCMA BACKUP DATA #53.7.
+17 ;**73- Add Clinic name to Order multiple for orders that were placed
+18 ; in a clinic vs. a Ward.
+19 ;*87 - Add Remove logic to pull out new fields and store to DB
+20 ;*108- add ZZZ segment for Hazardous drug flags
+21 ;
AL1(IEN,DATA,FS,CS,ERR) ; process AL1 (allergies) segment...
+1 IF +$GET(IEN)'>0!($GET(DATA)="")!($GET(FS)="")!($GET(CS)="")
DO ERRBLD^ALPBUTL1("AL1","",.ERR)
QUIT
+2 NEW ALPBALG,ALPBALGN,ALPBFILE,ALPBNEXT,ALPBSCHD,ALPBX,SCS,ALPBXX,ALPBSCHDLE1,ALPBX2,ALPBYY
+3 SET ALPBALG=+$PIECE(DATA,FS,4)
+4 IF ALPBALG'>0
DO ERRBLD^ALPBUTL1("AL1","Undefined allergy "_DATA,.ERR)
QUIT
+5 SET ALPBALGN=$PIECE($PIECE(DATA,FS,4),CS,2)
+6 ; is this allergy already on file for this patient?...
+7 IF $DATA(^ALPB(53.7,IEN,1,"B",ALPBALG))
SET ERR("DIERR")=0
QUIT
+8 ; if not, file it...
+9 SET ALPBNEXT=+$ORDER(^ALPB(53.7,IEN,1," "),-1)+1
+10 SET ALPBFILE(53.701,"+"_ALPBNEXT_","_IEN_",",.01)=ALPBALG
+11 SET ALPBFILE(53.701,"+"_ALPBNEXT_","_IEN_",",1)=ALPBALGN
+12 DO UPDATE^DIE("","ALPBFILE","ALPBNEXT","ERR")
+13 QUIT
+14 ;
ORC(IEN,OIEN,DATA,MLOG,FS,CS,ERR) ; process ORC (common order) segment...
+1 ; MLOG = if 1 then this is an ORC segment with a Med Log update
+2 ; if 0 then this is a common order update
+3 IF +$GET(IEN)'>0!(+$GET(OIEN)'>0)!($GET(DATA)="")!($GET(MLOG)="")!($GET(FS)="")!($GET(CS)="")
DO ERRBLD^ALPBUTL1("ORC","",.ERR)
QUIT
+4 ;*87
NEW ALPBFIEN,ALPBFILE,ALPBMREC,ALPBNEXT,ALPBTEXT,ALPBX,SVZERO
+5 SET ALPBFIEN=OIEN_","_IEN_","
+6 ; ORC segment with NO MedLog data...
+7 IF +MLOG=0
Begin DoDot:1
+8 SET ALPBX=$PIECE(DATA,FS,1)
+9 ; order status...
+10 SET ALPBFILE(53.702,ALPBFIEN,2)=$PIECE(DATA,FS,6)
+11 ; provider...
+12 SET ALPBFILE(53.702,ALPBFIEN,5)=$PIECE($PIECE(DATA,FS,13),CS,2)
+13 ; entry person/rph...
+14 SET ALPBFILE(53.702,ALPBFIEN,5.1)=$PIECE($PIECE(DATA,FS,11),CS,2)
+15 ; verified by...
+16 SET ALPBFILE(53.702,ALPBFIEN,5.2)=$PIECE($PIECE(DATA,FS,12),CS,2)
+17 ; set clinic name in new DD field 3.5 if a clinic order ;*73
+18 SET ALPBFILE(53.702,ALPBFIEN,3.5)=$PIECE(DATA,FS,22)
+19 DO UPDATE^DIE("","ALPBFILE","","ERR")
+20 ; if this is a pending order, add special instructions...
+21 IF $PIECE($PIECE(DATA,FS,6),CS,1)="IP"
Begin DoDot:2
+22 SET ALPBTEXT(1)="CAUTION! THIS IS A PENDING ORDER :: CHECK WITH PROVIDER OR PHARMACIST!"
+23 DO WP^DIE(53.702,ALPBFIEN,8,"A","ALPBTEXT","ERR")
+24 KILL ALPBTEXT
End DoDot:2
End DoDot:1
+25 ; ORC segment with specific MedLog data...
+26 IF +MLOG=1
Begin DoDot:1
+27 ; ALPBX = med log date/time...
+28 SET ALPBX=$$FMDATE^HLFNC($PIECE(DATA,FS,10))
+29 IF ALPBX=""
KILL ALPBX
QUIT
+30 ; ALPBMREC = med log record number...
+31 SET ALPBMREC=+$PIECE($PIECE(DATA,FS,3),CS,1)
+32 ;
+33 ;UPDATE, If the med log entry is already on file, update and quit.
+34 ; check for both an entry on file for the log date/time ("B" xref)
+35 ; or med log record number ("C" xref)...
+36 SET ALPBNEXT=+$ORDER(^ALPB(53.7,IEN,2,OIEN,10,"B",ALPBX,""),-1)
+37 IF ALPBNEXT'>0
SET ALPBNEXT=+$ORDER(^ALPB(53.7,IEN,2,OIEN,10,"C",ALPBMREC,""))
+38 IF ALPBNEXT>0
Begin DoDot:2
+39 SET ALPBFILE(53.70213,ALPBNEXT_","_ALPBFIEN,.01)=ALPBX
+40 SET ALPBFILE(53.70213,ALPBNEXT_","_ALPBFIEN,1)=$PIECE($PIECE(DATA,FS,11),CS,2)
+41 SET ALPBFILE(53.70213,ALPBNEXT_","_ALPBFIEN,2)=$PIECE($PIECE(DATA,FS,6),CS,2)
+42 IF ALPBMREC>0
SET ALPBFILE(53.70213,ALPBNEXT_","_ALPBFIEN,3)=ALPBMREC
+43 ;if remove status, save associated Given info for storing *87
+44 if $PIECE($PIECE(DATA,FS,6),CS,2)["REMOVE"
Begin DoDot:3
+45 SET SVZERO=$GET(^ALPB(53.7,IEN,2,OIEN,10,ALPBNEXT,0))
+46 SET ALPBFILE(53.70213,ALPBNEXT_","_ALPBFIEN,4)=$PIECE(SVZERO,U,1)
+47 SET ALPBFILE(53.70213,ALPBNEXT_","_ALPBFIEN,5)=$PIECE(SVZERO,U,2)
+48 SET ALPBFILE(53.70213,ALPBNEXT_","_ALPBFIEN,6)=$PIECE(SVZERO,U,3)
End DoDot:3
+49 ;if Given cur action, then always set assoc Give fields to null *87
+50 if $PIECE($PIECE(DATA,FS,6),CS,2)["GIVEN"
Begin DoDot:3
+51 SET ALPBFILE(53.70213,ALPBNEXT_","_ALPBFIEN,4)=""
+52 SET ALPBFILE(53.70213,ALPBNEXT_","_ALPBFIEN,5)=""
+53 SET ALPBFILE(53.70213,ALPBNEXT_","_ALPBFIEN,6)=""
End DoDot:3
+54 ;
+55 DO UPDATE^DIE("","ALPBFILE","","ERR")
End DoDot:2
QUIT
+56 KILL ALPBNEXT
+57 ;
+58 ;ADD, If not...
+59 ;bug fix *87
SET ALPBNEXT=+$ORDER(^ALPB(53.7,IEN,2,OIEN,10," "),-1)
+60 SET ALPBFILE(53.70213,"+"_ALPBNEXT_","_ALPBFIEN,.01)=ALPBX
+61 ; med log entry person...
+62 SET ALPBFILE(53.70213,"+"_ALPBNEXT_","_ALPBFIEN,1)=$PIECE($PIECE(DATA,FS,11),CS,2)
+63 ; med log transaction message...
+64 SET ALPBFILE(53.70213,"+"_ALPBNEXT_","_ALPBFIEN,2)=$PIECE($PIECE(DATA,FS,6),CS,2)
+65 ; med log record number...
+66 IF ALPBMREC>0
SET ALPBFILE(53.70213,"+"_ALPBNEXT_","_ALPBFIEN,3)=ALPBMREC
+67 ;if Given cur action, then always init assoc. fields to null *87
+68 if $PIECE($PIECE(DATA,FS,6),CS,2)["GIVEN"
Begin DoDot:2
+69 SET ALPBFILE(53.70213,"+"_ALPBNEXT_","_ALPBFIEN,4)=""
+70 SET ALPBFILE(53.70213,"+"_ALPBNEXT_","_ALPBFIEN,5)=""
+71 SET ALPBFILE(53.70213,"+"_ALPBNEXT_","_ALPBFIEN,6)=""
End DoDot:2
+72 ;
+73 DO UPDATE^DIE("","ALPBFILE","ALPBNEXT","ERR")
End DoDot:1
+74 QUIT
+75 ;
PV1(IEN,DATA,FS,CS,ERR) ; process PV1 (patient visit/movement) segment...
+1 IF +$GET(IEN)=0!($GET(DATA)="")
DO ERRBLD^ALPBUTL1("PV1","",.ERR)
QUIT
+2 NEW ALPBFIEN,ALPBFILE,ALPBX
+3 SET ALPBFIEN=IEN_","
+4 SET ALPBX=$PIECE(DATA,FS,4)
+5 ; ward...
+6 SET ALPBFILE(53.7,ALPBFIEN,4)=$PIECE(ALPBX,CS)
+7 ; room...
+8 SET ALPBFILE(53.7,ALPBFIEN,5)=$PIECE(ALPBX,CS,2)
+9 ; bed...
+10 SET ALPBFILE(53.7,ALPBFIEN,6)=$PIECE(ALPBX,CS,3)
+11 DO FILE^DIE("","ALPBFILE","ERR")
+12 QUIT
+13 ;
RXO(IEN,OIEN,DATA,FS,CS,ERR) ; process RXO (pharmacy prescription order) segment...
+1 ; for inpatient meds, this segment contains an orderable item. this
+2 ; module is ONLY called if the order is "P"ending. it only files the
+3 ; orderable item if no drug is on file for the order.
+4 NEW ALPBDIEN,ALPBDRUG,ALPBFILE,ALPBNEXT
+5 IF +$GET(IEN)'>0!(+$GET(OIEN)'>0)!($GET(DATA)="")!($GET(FS)="")!($GET(CS)="")
DO ERRBLD^ALPBUTL1("RXO","",.ERR)
QUIT
+6 SET ALPBDIEN=+$PIECE($PIECE(DATA,FS,2),CS,4)
+7 SET ALPBDRUG=$PIECE($PIECE(DATA,FS,2),CS,5)
+8 IF ALPBDIEN'>0
DO ERRBLD^ALPBUTL1("RXO","Invalid drug IEN in RXO segment",.ERR)
QUIT
+9 ; if there is ANY drug already on file, quit...
+10 IF +$ORDER(^ALPB(53.7,IEN,2,OIEN,7,0))>0
QUIT
+11 ; if not, file it...
+12 SET ALPBNEXT=+$ORDER(^ALPB(53.7,IEN,2,OIEN,7," "),-1)+1
+13 SET ALPBFILE(53.703,"+"_ALPBNEXT_","_OIEN_","_IEN_",",.01)=ALPBDIEN
+14 SET ALPBFILE(53.703,"+"_ALPBNEXT_","_OIEN_","_IEN_",",1)=ALPBDRUG
+15 DO UPDATE^DIE("","ALPBFILE","ALPBNEXT","ERR")
+16 QUIT
+17 ;
RXE(IEN,OIEN,DATA,FS,CS,ECH,ERR) ; process RXE (order detail) segment...
+1 ; this segment may contain the drug name, though there may not be a drug
+2 ; because this can also be used for order detail for IV's which are
+3 ; contained in an RXC segment. this segment can also contain start/stop
+4 ; date&time, dosage and schedule
+5 IF +$GET(IEN)'>0!(+$GET(OIEN)'>0)!($GET(DATA)="")!($GET(FS)="")!($GET(CS)="")!($GET(ECH)="")
DO ERRBLD^ALPBUTL1("RXE","",.ERR)
QUIT
+6 NEW ALPBDIEN,ALPBDRUG,ALPBFIEN,ALPBFILE,ALPBNEXT,ALPBSCHD,ALPBX,SCS
+7 ;*87
NEW ALPBDOA,ALPBREMV,ALPBTIMG,ALPBADM
+8 SET SCS=$EXTRACT(ECH,4)
+9 SET ALPBFIEN=OIEN_","_IEN_","
+10 ; for drug, we'll use the one that came from the Drug file...
+11 SET ALPBDIEN=+$PIECE($PIECE(DATA,FS,3),CS,4)
+12 SET ALPBDRUG=$PIECE($PIECE(DATA,FS,3),CS,5)
+13 ; is this drug already on file for this order? if not, add it...
+14 IF ALPBDIEN>0&('$DATA(^ALPB(53.7,IEN,2,OIEN,7,"B",ALPBDIEN)))
Begin DoDot:1
+15 SET ALPBNEXT=+$ORDER(^ALPB(53.7,IEN,2,OIEN,7," "),-1)+1
+16 SET ALPBFILE(53.703,"+"_ALPBNEXT_","_ALPBFIEN,.01)=ALPBDIEN
+17 SET ALPBFILE(53.703,"+"_ALPBNEXT_","_ALPBFIEN,1)=ALPBDRUG
+18 DO UPDATE^DIE("","ALPBFILE","ALPBNEXT","ERR")
+19 KILL ALPBFERR,ALPBFILE,ALPBNEXT
End DoDot:1
+20 SET ALPBX=$PIECE(DATA,FS,2)
+21 ; start date/time...
+22 SET ALPBFILE(53.702,ALPBFIEN,4)=$$FMDATE^HLFNC($PIECE(ALPBX,CS,4))
+23 ; stop date/time...
+24 SET ALPBFILE(53.702,ALPBFIEN,4.1)=$$FMDATE^HLFNC($PIECE(ALPBX,CS,5))
+25 ; dosage...
+26 SET ALPBFILE(53.702,ALPBFIEN,7)=$PIECE(ALPBX,CS,8)
+27 ; schedule... alter getting directly from RXE.1.2 pieces ;*87
+28 SET ALPBTIMG=$PIECE(ALPBX,CS,2)
+29 SET ALPBSCHD=$$UNESC^ALPBGEN($PIECE(ALPBTIMG,SCS,1))
+30 SET ALPBREMV=$PIECE(ALPBTIMG,SCS,3)
+31 SET ALPBDOA=$PIECE(ALPBTIMG,SCS,4)
+32 ; end ;*87
+33 IF $PIECE(DATA,FS,24)'=""
SET ALPBSCHD=ALPBSCHD_" "_$PIECE(DATA,FS,24)
+34 IF $PIECE($PIECE(DATA,FS,25),CS,5)'=""
SET ALPBSCHD=ALPBSCHD_" "_$PIECE($PIECE(DATA,FS,25),CS,5)
+35 SET ALPBFILE(53.702,ALPBFIEN,7.2)=ALPBSCHD
+36 ; timing...
+37 ;convert adm & rem times to 4 digit, store them & DOA to 53.7 *87
+38 SET ALPBADM=$PIECE($PIECE(DATA,FS,22),CS,2)
+39 if +ALPBADM
SET ALPBADM=$$CNVRT4(ALPBADM,"-")
+40 if +ALPBREMV
SET ALPBREMV=$$CNVRT4(ALPBREMV,"-")
+41 SET ALPBFILE(53.702,ALPBFIEN,7.3)=ALPBADM
+42 SET ALPBFILE(53.702,ALPBFIEN,7.4)=ALPBREMV
+43 SET ALPBFILE(53.702,ALPBFIEN,7.5)=ALPBDOA
+44 ;
+45 DO UPDATE^DIE("","ALPBFILE","","ERR")
+46 QUIT
+47 ;
RXR(IEN,OIEN,DATA,FS,CS,ERR) ; process RXR (med administration route) segment...
+1 IF +$GET(IEN)'>0!(+$GET(OIEN)'>0)!($GET(DATA)="")!($GET(FS)="")!($GET(CS)="")
DO ERRBLD^ALPBUTL1("RXR","",.ERR)
QUIT
+2 NEW ALPBFILE
+3 ; route...
+4 SET ALPBFILE(53.702,OIEN_","_IEN_",",7.1)=$PIECE($PIECE(DATA,FS,2),CS,5)
+5 DO UPDATE^DIE("","ALPBFILE","","ERR")
+6 QUIT
+7 ;
RXC(IEN,OIEN,DATA,FS,CS,ERR) ; process RXC (IV orders: additives/solutions) segment...
+1 IF +$GET(IEN)'>0!(+$GET(OIEN)'>0)!($GET(DATA)="")!($GET(FS)="")!($GET(CS)="")
DO ERRBLD^ALPBUTL1("RXC","",.ERR)
QUIT
+2 NEW ALPBFILE,ALPBFNOD,ALPBGNOD,ALPBNAM,ALPBNEXT,ALPBNUM,ALPBTYP,ALPBUNIT
+3 SET ALPBTYP=$PIECE(DATA,FS,2)
+4 SET ALPBGNOD=$SELECT(ALPBTYP="A":8,ALPBTYP="B":9,1:0)
+5 IF ALPBGNOD=0
DO ERRBLD^ALPBUTL1("RXC","Unable to determine Additive or Solution in RXC segment",.ERR)
QUIT
+6 SET ALPBFNOD="53.7021"_$SELECT(ALPBGNOD=8:1,1:2)
+7 SET ALPBNUM=$PIECE($PIECE(DATA,FS,3),CS,4)
+8 ; is this additive or solution already on file?...
+9 IF $DATA(^ALPB(53.7,IEN,2,OIEN,ALPBGNOD,"B",ALPBNUM))
SET ERR("DIERR")=0
QUIT
+10 ; if not, file it...
+11 SET ALPBNAM=$PIECE($PIECE(DATA,FS,3),CS,5)
+12 SET ALPBUNIT=$PIECE(DATA,FS,4)_$PIECE($PIECE(DATA,FS,5),CS,5)
+13 SET ALPBNEXT=+$ORDER(^ALPB(53.7,IEN,2,OIEN,ALPBGNOD," "),-1)+1
+14 SET ALPBFILE(ALPBFNOD,"+"_ALPBNEXT_","_OIEN_","_IEN_",",.01)=ALPBNUM
+15 SET ALPBFILE(ALPBFNOD,"+"_ALPBNEXT_","_OIEN_","_IEN_",",1)=ALPBNAM
+16 SET ALPBFILE(ALPBFNOD,"+"_ALPBNEXT_","_OIEN_","_IEN_",",2)=ALPBUNIT
+17 DO UPDATE^DIE("","ALPBFILE","ALPBNEXT","ERR")
+18 QUIT
+19 ;
NTE(IEN,OIEN,DATA,FS,CS,ERR) ; process NTE (note) segment...
+1 ; note: in the case of NTE segments, DATA is passed in as an array.
+2 ; NTE data can be in multiple nodes, the first subscript of which
+3 ; contains the actual NTE segments itself.
+4 IF +$GET(IEN)'>0!(+$GET(OIEN)'>0)!($DATA(DATA)=0)!($GET(FS)="")!($GET(CS)="")
DO ERRBLD^ALPBUTL1("NTE","",.ERR)
QUIT
+5 NEW ALPBFILE,I
+6 ; check the status of this order. if it is pending, abort
+7 ; and do not file any special comments (note ORC module comments)...
+8 IF $EXTRACT($PIECE($GET(^ALPB(53.7,IEN,2,OIEN,0)),"^",3),1,2)="IP"
QUIT
+9 ; examine DATA(1) and from the Pharmacy package code in the second
+10 ; field, insert a header at the first subscript level of our working
+11 ; array (which we will pass to the FileMan call)...
+12 SET ALPBFILE(1)=$SELECT($PIECE(DATA(1),FS,2)=6:"Provider Comments:",$PIECE(DATA(1),FS,2)=21:"Special Instructions:",1:"Other Info:")
+13 ;
+14 ;*69 Rebuild the WP Instructions from the formatted NTE segment.
+15 ; The NTE text will be put into the DATA array and can contain
+16 ; the escape character \.br\ for line break. The line break will
+17 ; allow this routine to store the WP text exactly how the Rph
+18 ; keyed it in IM backdoor. They may have keyed in hard returns
+19 ; and spaces, so to create an aligned columnar table, i.e.
+20 ; an Insulin sliding scale.
+21 ;reset DATA(1) from piece 4 of DATA(1)
SET DATA(1)=$PIECE(DATA(1),FS,4)
+22 ;
+23 ; Unwrap DATA array into one large field, 64k is limit
+24 NEW ALEN,DLEN,ELEN,QUIT,ALLTXT,NEWALPB
+25 SET QUIT=0
SET ALLTXT=""
+26 ;
+27 ; Put formatted NTE array together as one line up to 64k
+28 FOR I=0:0
SET I=$ORDER(DATA(I))
if 'I
QUIT
Begin DoDot:1
+29 SET ALEN=$LENGTH(ALLTXT)
SET DLEN=$LENGTH(DATA(I))
+30 IF ALEN+DLEN>65536
SET ELEN=65536-ALEN
SET ALLTXT=ALLTXT_$EXTRACT(DATA(I),1,ELEN)
SET QUIT=1
QUIT
+31 SET ALLTXT=ALLTXT_DATA(I)
End DoDot:1
if QUIT
QUIT
+32 ;
+33 ; Build new work array from the formatted lines of the large field
+34 DO HL7FMT(ALLTXT,.NEWALPB)
+35 ;
+36 ; Now add back to the text of the new working array into the original
+37 ; work array beginning with element 2, as element 1 has the heading
+38 ; 129 Added condition to check if Other Info and get P4 on line 1
+39 ; ex. line 1(NEWALPB)has NTE^21^L^TEST order for ZZTEST patient
+40 ; the rest does not had NTE^21^L segment so get the whole piece
+41 ;
+42 IF ALPBFILE(1)="Other Info:"
FOR I=0:0
SET I=$ORDER(NEWALPB(I))
if 'I
QUIT
Begin DoDot:1
+43 IF I=1
SET ALPBFILE(I+1)=$PIECE(NEWALPB(I),"^",4)
+44 IF I>1
SET ALPBFILE(I+1)=NEWALPB(I)
End DoDot:1
+45 IF ALPBFILE(1)'="Other Info:"
FOR I=0:0
SET I=$ORDER(NEWALPB(I))
if 'I
QUIT
SET ALPBFILE(I+1)=NEWALPB(I)
+46 ;
+47 ; Store new WP text to field 8
+48 DO WP^DIE(53.702,OIEN_","_IEN_",",8,"","ALPBFILE","ERR")
+49 QUIT
+50 ;
ZZZ(IEN,OIEN,DATA,FS,CS,ERR) ; process Hazardous Drug flags segment *108
+1 IF +$GET(IEN)'>0!(+$GET(OIEN)'>0)!($GET(DATA)="")!($GET(FS)="")!($GET(CS)="")
DO ERRBLD^ALPBUTL1("ORC","",.ERR)
QUIT
+2 NEW ALPBFIEN,ALPBFILE
+3 SET ALPBFIEN=OIEN_","_IEN_","
+4 ;HAZ Handle
SET ALPBFILE(53.702,ALPBFIEN,14)=$SELECT($PIECE(DATA,FS,5)="Y":1,1:0)
+5 ;HAZ Dispose
SET ALPBFILE(53.702,ALPBFIEN,15)=$SELECT($PIECE(DATA,FS,6)="Y":1,1:0)
+6 DO UPDATE^DIE("","ALPBFILE","","ERR")
+7 QUIT
+8 ;
HL7FMT(NEWLN,AR) ;Unwrap formatted text array lines into a new array
+1 ; the escape character, \.br\ ,will cause a new array element to
+2 ; begin with the text after the escape character.
+3 NEW ESC,LIN,LN,QUIT,I
+4 SET QUIT=0
+5 FOR I=1:1
SET LN=NEWLN
Begin DoDot:1
+6 SET ESC=$FIND(LN,"\.br\")
+7 IF ESC=6
SET LIN=""
SET NEWLN=$EXTRACT(LN,ESC,65536)
SET AR(I)=LIN
QUIT
+8 IF ESC=0
SET LIN=NEWLN
SET NEWLN=""
SET AR(I)=LIN
SET QUIT=1
QUIT
+9 SET LIN=$EXTRACT(LN,1,ESC-6)
+10 SET NEWLN=$EXTRACT(LN,ESC,65536)
+11 SET AR(I)=LIN
End DoDot:1
if QUIT
QUIT
+12 QUIT
+13 ;
CNVRT4(STR,SEP) ;Converts a time string to 4 digit for consistency
+1 ; STR - string of times
+2 ; SEP - seperator character between times
+3 ;
+4 NEW QQ
+5 FOR QQ=1:1:$LENGTH(STR,SEP)
SET $PIECE(STR,SEP,QQ)=$EXTRACT($PIECE(STR,SEP,QQ)_"0000",1,4)
+6 QUIT STR
