- 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 Feb 18, 2025@23:05:47 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
