ALPBHL1 ;OIFO-DALLAS MW,SED,KC - BCBU main HL7 message processor ;2/6/21 15:33
;;3.0;BAR CODE MED ADMIN;**7,8,73,108**;Mar 2004;Build 33
;
;*108 - add ZZZ segment for Hazardous drug flags
;
S ALPBECH=HL("ECH")
S ALPBCS=$E(ALPBECH)
S ALPBFS=HL("FS")
S ALPBHREC=$S(+$G(HLMTIEN)>0:HLMTIEN,1:$G(HL("MID")))
;
; process the entire HL7 message's lines into local array...
F I=1:1 X HLNEXT Q:+$G(HLQUIT)'>0 D
.S ALPBSEG=$P(HLNODE,ALPBFS,1)
.; store patient ID and order segments in a special way...
.I ALPBSEG="PID"!(ALPBSEG="ORC")!(ALPBSEG="PV1")!(ALPBSEG="RXO")!(ALPBSEG="ZZZ") S ALPBMTXT(ALPBSEG)=HLNODE ;*108 add ZZZ seg
.I ALPBSEG="AL1" S ALPBMTXT("AL1")=1
.S ALPBMTXT(I)=HLNODE
.; get any continuation lines...
.S J=0
.F S J=$O(HLNODE(J)) Q:'J S ALPBMTXT(I,J)=HLNODE(J)
.K ALPBSEG
;
; retrieve patient ID data from the PID segment...
S ALPBX=$G(ALPBMTXT("PID"))
I ALPBX'="" D
.D GETPID^ALPBUTL2(ALPBX,ALPBFS,ALPBCS,ALPBECH,.ALPBDATA)
.S ALPBPDFN=$G(ALPBDATA(1))
.S ALPBPNAM=$G(ALPBDATA(2))
.S ALPBPSSN=$G(ALPBDATA(3))
.S ALPBPDOB=$G(ALPBDATA(4))
.S ALPBPSEX=$G(ALPBDATA(5))
.K ALPBDATA
K ALPBX
; we must have patient's SSN (ALPBPSSN) to process this message...
I $G(ALPBPSSN)="" D Q
.D ERRBLD^ALPBUTL1("PID","Invalid/missing SSN",.ALPBFERR)
.D ERRLOG^ALPBUTL1(0,0,ALPBHREC,"PID",$G(ALPBMTXT("PID"),"PID segment undefined"),.ALPBFERR)
.K ALPBFERR
.D CLEAN
K ALPBMTXT("PID")
;
; using patient's DFN, get BCBU record number...
S ALPBIEN=0
I $D(^ALPB(53.7,ALPBPDFN)) S ALPBIEN=ALPBPDFN
; create new record?...
I ALPBIEN'>0 D
.S DIC="^ALPB(53.7,"
.S DIC(0)="LZ"
.S DINUM=ALPBPDFN
.S DLAYGO=53.7
.S X=ALPBPNAM
.D FILE^DICN
.K DIC,DINUM,DLAYGO
.S ALPBIEN=+Y
; if ALPBIEN'>0 then patient record find or creation error...
I +ALPBIEN'>0 D Q
.D ERRBLD^ALPBUTL1("","Failed to find/create patient record",.ALPBFERR)
.D ERRLOG^ALPBUTL1(0,0,ALPBHREC,"",$G(ALPBPDFN,"DFN undefined")_"^"_$G(ALPBPNAM,"Name undefined")_"^"_$G(ALPBPSSN,"SSN undefined"),.ALPBFERR)
.K ALPBFERR
.D CLEAN
;
; check PV1 segment to see if this is a discharge movement. if so,
; delete the patient's BCBU record and quit...
I $P($G(ALPBMTXT("PV1")),ALPBFS,37)'="" D Q
.D DELPT^ALPBUTL(+$G(ALPBIEN))
.D CLEAN
;
; file/update patient demographic data...
S ALPBFILE(53.7,ALPBIEN_",",.01)=ALPBPNAM
S ALPBFILE(53.7,ALPBIEN_",",1)=ALPBPSSN
S ALPBFILE(53.7,ALPBIEN_",",2)=ALPBPDOB
S ALPBFILE(53.7,ALPBIEN_",",3)=ALPBPSEX
D FILE^DIE("","ALPBFILE","ALPBFERR")
I +$G(ALPBFERR("DIERR")) D ERRLOG^ALPBUTL1(+$G(ALPBIEN),0,$G(ALPBHREC),"PID","Demographics update failed",.ALPBFERR)
K ALPBFERR,ALPBFILE
;
; if the allergies flag is set (ALPBMTXT("AL1")), delete any
; allergies on file (they will be rebuilt by this message)...
I +$G(ALPBMTXT("AL1")) D DELALG^ALPBUTL2(ALPBIEN)
;
; if there is no ORC (order) segment, process the rest of the
; message and quit...
I $G(ALPBMTXT("ORC"))="" D PM Q
;
; retrieve order number and transaction date from ORC segment...
D GETORC^ALPBUTL2($G(ALPBMTXT("ORC")),$G(ALPBFS),$G(ALPBCS),.ALPBDATA)
S ALPBMLOG=$S($G(ALPBDATA(0))="ML":1,1:0)
S ALPBORDN=$G(ALPBDATA(1))
S ALPBORDT=$G(ALPBDATA(2))
S ALPBORDC=+$G(ALPBDATA(3))
; ALPBOTYP="V" for IV, "U" for Unit Dose, or "P" for Pending
S ALPBOTYP=$G(ALPBDATA(4))
K ALPBDATA
;
; retrieve Hazardous to Handle & Dispose flags from ZZZ segment...
D GETZZZ^ALPBUTL2($G(ALPBMTXT("ZZZ")),$G(ALPBFS),$G(ALPBCS),.ALPBDATA)
S ALPBHAZH=$G(ALPBDATA(1))
S ALPBHAZD=$G(ALPBDATA(2))
K ALPBDATA
;
; we must have an order number to process the order-specific data,
; if we do not then log that error condition and quit...
I $G(ALPBORDN)="" D Q
.D ERRBLD^ALPBUTL1("","No order number in ORC segment",.ALPBFERR)
.D ERRLOG^ALPBUTL1(0,0,ALPBHREC,"ORC",$G(ALPBMTXT("ORC"),"ORC segment not defined"),.ALPBFERR)
.K ALPBFERR
.D CLEAN
K ALPBMTXT("ORC")
;
; using CPRS order number, check to see if the order is already on
; file. if so, and status is PENDING delete the order record...
I ALPBORDC>0 D
.;LOOP Through. May have replaced orders so need to check all
.S ALPBI=0
.F S ALPBI=$O(^ALPB(53.7,ALPBIEN,2,"ACPRS",ALPBORDC,ALPBI)) Q:+ALPBI'>0 D
..I $E($P($G(^ALPB(53.7,ALPBIEN,2,ALPBI,0)),"^",3),1,2)'="IP" Q
..D DELORD^ALPBUTL(ALPBIEN,ALPBI)
K ALPBI
;
; existing order's record number?...
K ALPBOIEN
S ALPBOIEN=+$O(^ALPB(53.7,ALPBIEN,2,"B",ALPBORDN,0))
; if this isn't a Med Log update, and this order is already on
; file, delete its drug(s), additive(s) and/or solution(s) --
; they will be rebuilt by the other segments in this message...
I +$G(ALPBMLOG)=0&(ALPBOIEN>0) D CLORD^ALPBUTL2(ALPBIEN,ALPBOIEN)
; create new order record?...
I +$G(ALPBOIEN)=0 D
.S ALPBOIEN=+$O(^ALPB(53.7,ALPBIEN,2," "),-1)+1
.S ALPBFILE(53.702,"+"_ALPBOIEN_","_ALPBIEN_",",.01)=ALPBORDN
.; don't file a 0 (zero) CPRS order number...
.I ALPBORDC>0 S ALPBFILE(53.702,"+"_ALPBOIEN_","_ALPBIEN_",",1)=ALPBORDC
.S ALPBFILE(53.702,"+"_ALPBOIEN_","_ALPBIEN_",",3)=ALPBORDT
.S ALPBFILE(53.702,"+"_ALPBOIEN_","_ALPBIEN_",",6)=ALPBOTYP
.S:ALPBHAZH]"" ALPBFILE(53.702,"+"_ALPBOIEN_","_ALPBIEN_",",14)=ALPBHAZH ;*108
.S:ALPBHAZD]"" ALPBFILE(53.702,"+"_ALPBOIEN_","_ALPBIEN_",",15)=ALPBHAZD ;*108
.D UPDATE^DIE("","ALPBFILE","ALPBOIEN","ALPBFERR")
.I +$G(ALPBFERR("DIERR")) D ERRLOG^ALPBUTL1(ALPBIEN,"0",ALPBHREC,"NEWORD","",.ALPBFERR)
.K ALPBFERR,ALPBFILE
;
PM ; process the message segments...
S I=0
F S I=$O(ALPBMTXT(I)) Q:'I D
.S ALPBDATA=ALPBMTXT(I) I $O(ALPBMTXT(I,0)) D
..N CONTLN S CONTLN=0 F S CONTLN=$O(ALPBMTXT(I,CONTLN)) Q:'CONTLN I $L($G(ALPBMTXT(I,CONTLN))) S ALPBDATA=ALPBDATA_ALPBMTXT(I,CONTLN)
.S ALPBSEG=$P(ALPBDATA,ALPBFS)
.; allergies segment...
.I ALPBSEG="AL1" D
..D AL1^ALPBHL1U(+$G(ALPBIEN),$G(ALPBDATA),$G(ALPBFS),$G(ALPBCS),.ALPBFERR)
..I +$G(ALPBFERR("DIERR")) D ERRLOG^ALPBUTL1(+$G(ALPBIEN),+$G(ALPBOIEN),$G(ALPBHREC),"AL1",$G(ALPBDATA),.ALPBFERR)
..K ALPBFERR
.; general order segment...
.I ALPBSEG="ORC" D
..D ORC^ALPBHL1U(+$G(ALPBIEN),+$G(ALPBOIEN),$G(ALPBDATA),$G(ALPBMLOG),$G(ALPBFS),$G(ALPBCS),.ALPBFERR)
..I +$G(ALPBFERR("DIERR")) D ERRLOG^ALPBUTL1(+$G(ALPBIEN),+$G(ALPBOIEN),$G(ALPBHREC),"ORC",$G(ALPBDATA),.ALPBFERR)
..K ALPBFERR
.; patient movement/location segment...
.I ALPBSEG="PV1" D
..D PV1^ALPBHL1U(+$G(ALPBIEN),$G(ALPBDATA),$G(ALPBFS),$G(ALPBCS),.ALPBFERR)
..I +$G(ALPBFERR("DIERR")) D ERRLOG^ALPBUTL1(+$G(ALPBIEN),+$G(ALPBOIEN),$G(ALPBHREC),"PV1",$G(ALPBDATA),.ALPBFERR)
..K ALPBFERR
.; IV orders segment...
.I ALPBSEG="RXC" D
..D RXC^ALPBHL1U(+$G(ALPBIEN),+$G(ALPBOIEN),$G(ALPBDATA),$G(ALPBFS),$G(ALPBCS),.ALPBFERR)
..I +$G(ALPBFERR("DIERR")) D ERRLOG^ALPBUTL1(+$G(ALPBIEN),+$G(ALPBOIEN),$G(ALPBHREC),"RXC",$G(ALPBDATA),.ALPBFERR)
..K ALPBFERR
.; drug, additives and/or solutions segment...
.I ALPBSEG="RXE" D
..I $G(ALPBDATA)="" Q
..; 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...
..I +$P($P(ALPBDATA,ALPBFS,3),ALPBCS,4)=0 S $P(ALPBDATA,ALPBFS,3)=$P($G(ALPBMTXT("RXO")),ALPBFS,2)
..;chech for any continuation lines
..S J=0 F S J=$O(ALPBMTXT(I,J)) Q:'J S ALPBDATA=ALPBDATA_ALPBMTXT(I,J)
..D RXE^ALPBHL1U(+$G(ALPBIEN),+$G(ALPBOIEN),ALPBDATA,$G(ALPBFS),$G(ALPBCS),$G(ALPBECH),.ALPBFERR)
..I +$G(ALPBFERR("DIERR")) D ERRLOG^ALPBUTL1(+$G(ALPBIEN),+$G(ALPBOIEN),$G(ALPBHREC),"RXE",ALPBDATA,.ALPBFERR)
..K ALPBFERR
.; med route...
.I ALPBSEG="RXR" D
..D RXR^ALPBHL1U(+$G(ALPBIEN),+$G(ALPBOIEN),$G(ALPBDATA),$G(ALPBFS),$G(ALPBCS),.ALBPFERR)
..I +$G(ALPBFERR("DIERR")) D ERRLOG^ALPBUTL1(+$G(ALPBIEN),+$G(ALPBOIEN),$G(ALPBHREC),"RXR",$G(ALPBDATA),.ALPBFERR)
..K ALPBFERR
.; provider comments, special instructions or other print info...
.I ALPBSEG="NTE" D
..; NTE segments can be multiple-lines. set up an array (ALPBNTE(...)) to pass to the filer...
..; the first node will be the one that contains the NTE segment identifier
..N TMPI,TMPJ S TMPI=I S ALPBNTE(1)=$$UNESC^ALPBGEN(ALPBMTXT(I)) S I=TMPI
..S ALPBX=1
..; loop from ALPBMTXT(I) to retrieve any continuation lines...
..S TMPJ=0
..F S TMPJ=$O(ALPBMTXT(I,TMPJ)) Q:'TMPJ D
...S ALPBX=ALPBX+1
...S ALPBNTE(ALPBX)=$$UNESC^ALPBGEN(ALPBMTXT(I,TMPJ)) S I=TMPI
..K ALPBX,J
..D NTE^ALPBHL1U(+$G(ALPBIEN),+$G(ALPBOIEN),.ALPBNTE,$G(ALPBFS),$G(ALPBCS),.ALPBFERR)
..I +$G(ALPBFERR("DIERR")) D ERRLOG^ALPBUTL1(+$G(ALPBIEN),+$G(ALPBOIEN),$G(ALPBHREC),"NTE",ALPBDATA,.ALPBFERR)
..K ALPBFERR,ALPBNTE
.; Hazardous drug flags segment...
.I ALPBSEG="ZZZ" D
..D ZZZ^ALPBHL1U(+$G(ALPBIEN),+$G(ALPBOIEN),$G(ALPBDATA),$G(ALPBFS),$G(ALPBCS),.ALPBFERR)
..I +$G(ALPBFERR("DIERR")) D ERRLOG^ALPBUTL1(+$G(ALPBIEN),+$G(ALPBOIEN),$G(ALPBHREC),"ZZZ",$G(ALPBDATA),.ALPBFERR)
..K ALPBFERR
.K ALPBDATA,ALPBSEG
;
; set RECORD LAST UPDATED field...
S ALPBLUPD=$$NOW^XLFDT()
I $G(^ALPB(53.7,+$G(ALPBIEN),0))'="" D
.S ALPBFILE(53.7,ALPBIEN_",",7)=ALPBLUPD
.D FILE^DIE("","ALPBFILE","ALPBFERR")
.K ALPBFERR,ALPBFILE
;
; update PARAMETER file with last update date...
S ALPBPARM=+$O(^ALPB(53.71,0))
I ALPBPARM>0 D
.S ALPBFILE(53.71,ALPBPARM_",",4)=ALPBLUPD
.D FILE^DIE("","ALPBFILE","ALPBFERR")
.K ALPBFERR,ALPBFILE
K ALPBLUPD,ALPBPARM
;
CLEAN K ALPBCS,ALPBDATA,ALPBECH,ALPBFS,ALPBHREC,ALPBIEN,ALPBMLOG,ALPBMTXT
K ALPBOIEN,ALPBORDC,ALPBORDN,ALPBORDT,ALPBOTYP,ALPBPDFN,ALPBPDOB
K ALPBPNAM,ALPBPSEX,ALPBPSSN,ALPBSEG,ALPBHAZH,ALPBHAZD
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HALPBHL1 9646 printed Dec 13, 2024@01:39:23 Page 2
ALPBHL1 ;OIFO-DALLAS MW,SED,KC - BCBU main HL7 message processor ;2/6/21 15:33
+1 ;;3.0;BAR CODE MED ADMIN;**7,8,73,108**;Mar 2004;Build 33
+2 ;
+3 ;*108 - add ZZZ segment for Hazardous drug flags
+4 ;
+5 SET ALPBECH=HL("ECH")
+6 SET ALPBCS=$EXTRACT(ALPBECH)
+7 SET ALPBFS=HL("FS")
+8 SET ALPBHREC=$SELECT(+$GET(HLMTIEN)>0:HLMTIEN,1:$GET(HL("MID")))
+9 ;
+10 ; process the entire HL7 message's lines into local array...
+11 FOR I=1:1
XECUTE HLNEXT
if +$GET(HLQUIT)'>0
QUIT
Begin DoDot:1
+12 SET ALPBSEG=$PIECE(HLNODE,ALPBFS,1)
+13 ; store patient ID and order segments in a special way...
+14 ;*108 add ZZZ seg
IF ALPBSEG="PID"!(ALPBSEG="ORC")!(ALPBSEG="PV1")!(ALPBSEG="RXO")!(ALPBSEG="ZZZ")
SET ALPBMTXT(ALPBSEG)=HLNODE
+15 IF ALPBSEG="AL1"
SET ALPBMTXT("AL1")=1
+16 SET ALPBMTXT(I)=HLNODE
+17 ; get any continuation lines...
+18 SET J=0
+19 FOR
SET J=$ORDER(HLNODE(J))
if 'J
QUIT
SET ALPBMTXT(I,J)=HLNODE(J)
+20 KILL ALPBSEG
End DoDot:1
+21 ;
+22 ; retrieve patient ID data from the PID segment...
+23 SET ALPBX=$GET(ALPBMTXT("PID"))
+24 IF ALPBX'=""
Begin DoDot:1
+25 DO GETPID^ALPBUTL2(ALPBX,ALPBFS,ALPBCS,ALPBECH,.ALPBDATA)
+26 SET ALPBPDFN=$GET(ALPBDATA(1))
+27 SET ALPBPNAM=$GET(ALPBDATA(2))
+28 SET ALPBPSSN=$GET(ALPBDATA(3))
+29 SET ALPBPDOB=$GET(ALPBDATA(4))
+30 SET ALPBPSEX=$GET(ALPBDATA(5))
+31 KILL ALPBDATA
End DoDot:1
+32 KILL ALPBX
+33 ; we must have patient's SSN (ALPBPSSN) to process this message...
+34 IF $GET(ALPBPSSN)=""
Begin DoDot:1
+35 DO ERRBLD^ALPBUTL1("PID","Invalid/missing SSN",.ALPBFERR)
+36 DO ERRLOG^ALPBUTL1(0,0,ALPBHREC,"PID",$GET(ALPBMTXT("PID"),"PID segment undefined"),.ALPBFERR)
+37 KILL ALPBFERR
+38 DO CLEAN
End DoDot:1
QUIT
+39 KILL ALPBMTXT("PID")
+40 ;
+41 ; using patient's DFN, get BCBU record number...
+42 SET ALPBIEN=0
+43 IF $DATA(^ALPB(53.7,ALPBPDFN))
SET ALPBIEN=ALPBPDFN
+44 ; create new record?...
+45 IF ALPBIEN'>0
Begin DoDot:1
+46 SET DIC="^ALPB(53.7,"
+47 SET DIC(0)="LZ"
+48 SET DINUM=ALPBPDFN
+49 SET DLAYGO=53.7
+50 SET X=ALPBPNAM
+51 DO FILE^DICN
+52 KILL DIC,DINUM,DLAYGO
+53 SET ALPBIEN=+Y
End DoDot:1
+54 ; if ALPBIEN'>0 then patient record find or creation error...
+55 IF +ALPBIEN'>0
Begin DoDot:1
+56 DO ERRBLD^ALPBUTL1("","Failed to find/create patient record",.ALPBFERR)
+57 DO ERRLOG^ALPBUTL1(0,0,ALPBHREC,"",$GET(ALPBPDFN,"DFN undefined")_"^"_$GET(ALPBPNAM,"Name undefined")_"^"_$GET(ALPBPSSN,"SSN undefined"),.ALPBFERR)
+58 KILL ALPBFERR
+59 DO CLEAN
End DoDot:1
QUIT
+60 ;
+61 ; check PV1 segment to see if this is a discharge movement. if so,
+62 ; delete the patient's BCBU record and quit...
+63 IF $PIECE($GET(ALPBMTXT("PV1")),ALPBFS,37)'=""
Begin DoDot:1
+64 DO DELPT^ALPBUTL(+$GET(ALPBIEN))
+65 DO CLEAN
End DoDot:1
QUIT
+66 ;
+67 ; file/update patient demographic data...
+68 SET ALPBFILE(53.7,ALPBIEN_",",.01)=ALPBPNAM
+69 SET ALPBFILE(53.7,ALPBIEN_",",1)=ALPBPSSN
+70 SET ALPBFILE(53.7,ALPBIEN_",",2)=ALPBPDOB
+71 SET ALPBFILE(53.7,ALPBIEN_",",3)=ALPBPSEX
+72 DO FILE^DIE("","ALPBFILE","ALPBFERR")
+73 IF +$GET(ALPBFERR("DIERR"))
DO ERRLOG^ALPBUTL1(+$GET(ALPBIEN),0,$GET(ALPBHREC),"PID","Demographics update failed",.ALPBFERR)
+74 KILL ALPBFERR,ALPBFILE
+75 ;
+76 ; if the allergies flag is set (ALPBMTXT("AL1")), delete any
+77 ; allergies on file (they will be rebuilt by this message)...
+78 IF +$GET(ALPBMTXT("AL1"))
DO DELALG^ALPBUTL2(ALPBIEN)
+79 ;
+80 ; if there is no ORC (order) segment, process the rest of the
+81 ; message and quit...
+82 IF $GET(ALPBMTXT("ORC"))=""
DO PM
QUIT
+83 ;
+84 ; retrieve order number and transaction date from ORC segment...
+85 DO GETORC^ALPBUTL2($GET(ALPBMTXT("ORC")),$GET(ALPBFS),$GET(ALPBCS),.ALPBDATA)
+86 SET ALPBMLOG=$SELECT($GET(ALPBDATA(0))="ML":1,1:0)
+87 SET ALPBORDN=$GET(ALPBDATA(1))
+88 SET ALPBORDT=$GET(ALPBDATA(2))
+89 SET ALPBORDC=+$GET(ALPBDATA(3))
+90 ; ALPBOTYP="V" for IV, "U" for Unit Dose, or "P" for Pending
+91 SET ALPBOTYP=$GET(ALPBDATA(4))
+92 KILL ALPBDATA
+93 ;
+94 ; retrieve Hazardous to Handle & Dispose flags from ZZZ segment...
+95 DO GETZZZ^ALPBUTL2($GET(ALPBMTXT("ZZZ")),$GET(ALPBFS),$GET(ALPBCS),.ALPBDATA)
+96 SET ALPBHAZH=$GET(ALPBDATA(1))
+97 SET ALPBHAZD=$GET(ALPBDATA(2))
+98 KILL ALPBDATA
+99 ;
+100 ; we must have an order number to process the order-specific data,
+101 ; if we do not then log that error condition and quit...
+102 IF $GET(ALPBORDN)=""
Begin DoDot:1
+103 DO ERRBLD^ALPBUTL1("","No order number in ORC segment",.ALPBFERR)
+104 DO ERRLOG^ALPBUTL1(0,0,ALPBHREC,"ORC",$GET(ALPBMTXT("ORC"),"ORC segment not defined"),.ALPBFERR)
+105 KILL ALPBFERR
+106 DO CLEAN
End DoDot:1
QUIT
+107 KILL ALPBMTXT("ORC")
+108 ;
+109 ; using CPRS order number, check to see if the order is already on
+110 ; file. if so, and status is PENDING delete the order record...
+111 IF ALPBORDC>0
Begin DoDot:1
+112 ;LOOP Through. May have replaced orders so need to check all
+113 SET ALPBI=0
+114 FOR
SET ALPBI=$ORDER(^ALPB(53.7,ALPBIEN,2,"ACPRS",ALPBORDC,ALPBI))
if +ALPBI'>0
QUIT
Begin DoDot:2
+115 IF $EXTRACT($PIECE($GET(^ALPB(53.7,ALPBIEN,2,ALPBI,0)),"^",3),1,2)'="IP"
QUIT
+116 DO DELORD^ALPBUTL(ALPBIEN,ALPBI)
End DoDot:2
End DoDot:1
+117 KILL ALPBI
+118 ;
+119 ; existing order's record number?...
+120 KILL ALPBOIEN
+121 SET ALPBOIEN=+$ORDER(^ALPB(53.7,ALPBIEN,2,"B",ALPBORDN,0))
+122 ; if this isn't a Med Log update, and this order is already on
+123 ; file, delete its drug(s), additive(s) and/or solution(s) --
+124 ; they will be rebuilt by the other segments in this message...
+125 IF +$GET(ALPBMLOG)=0&(ALPBOIEN>0)
DO CLORD^ALPBUTL2(ALPBIEN,ALPBOIEN)
+126 ; create new order record?...
+127 IF +$GET(ALPBOIEN)=0
Begin DoDot:1
+128 SET ALPBOIEN=+$ORDER(^ALPB(53.7,ALPBIEN,2," "),-1)+1
+129 SET ALPBFILE(53.702,"+"_ALPBOIEN_","_ALPBIEN_",",.01)=ALPBORDN
+130 ; don't file a 0 (zero) CPRS order number...
+131 IF ALPBORDC>0
SET ALPBFILE(53.702,"+"_ALPBOIEN_","_ALPBIEN_",",1)=ALPBORDC
+132 SET ALPBFILE(53.702,"+"_ALPBOIEN_","_ALPBIEN_",",3)=ALPBORDT
+133 SET ALPBFILE(53.702,"+"_ALPBOIEN_","_ALPBIEN_",",6)=ALPBOTYP
+134 ;*108
if ALPBHAZH]""
SET ALPBFILE(53.702,"+"_ALPBOIEN_","_ALPBIEN_",",14)=ALPBHAZH
+135 ;*108
if ALPBHAZD]""
SET ALPBFILE(53.702,"+"_ALPBOIEN_","_ALPBIEN_",",15)=ALPBHAZD
+136 DO UPDATE^DIE("","ALPBFILE","ALPBOIEN","ALPBFERR")
+137 IF +$GET(ALPBFERR("DIERR"))
DO ERRLOG^ALPBUTL1(ALPBIEN,"0",ALPBHREC,"NEWORD","",.ALPBFERR)
+138 KILL ALPBFERR,ALPBFILE
End DoDot:1
+139 ;
PM ; process the message segments...
+1 SET I=0
+2 FOR
SET I=$ORDER(ALPBMTXT(I))
if 'I
QUIT
Begin DoDot:1
+3 SET ALPBDATA=ALPBMTXT(I)
IF $ORDER(ALPBMTXT(I,0))
Begin DoDot:2
+4 NEW CONTLN
SET CONTLN=0
FOR
SET CONTLN=$ORDER(ALPBMTXT(I,CONTLN))
if 'CONTLN
QUIT
IF $LENGTH($GET(ALPBMTXT(I,CONTLN)))
SET ALPBDATA=ALPBDATA_ALPBMTXT(I,CONTLN)
End DoDot:2
+5 SET ALPBSEG=$PIECE(ALPBDATA,ALPBFS)
+6 ; allergies segment...
+7 IF ALPBSEG="AL1"
Begin DoDot:2
+8 DO AL1^ALPBHL1U(+$GET(ALPBIEN),$GET(ALPBDATA),$GET(ALPBFS),$GET(ALPBCS),.ALPBFERR)
+9 IF +$GET(ALPBFERR("DIERR"))
DO ERRLOG^ALPBUTL1(+$GET(ALPBIEN),+$GET(ALPBOIEN),$GET(ALPBHREC),"AL1",$GET(ALPBDATA),.ALPBFERR)
+10 KILL ALPBFERR
End DoDot:2
+11 ; general order segment...
+12 IF ALPBSEG="ORC"
Begin DoDot:2
+13 DO ORC^ALPBHL1U(+$GET(ALPBIEN),+$GET(ALPBOIEN),$GET(ALPBDATA),$GET(ALPBMLOG),$GET(ALPBFS),$GET(ALPBCS),.ALPBFERR)
+14 IF +$GET(ALPBFERR("DIERR"))
DO ERRLOG^ALPBUTL1(+$GET(ALPBIEN),+$GET(ALPBOIEN),$GET(ALPBHREC),"ORC",$GET(ALPBDATA),.ALPBFERR)
+15 KILL ALPBFERR
End DoDot:2
+16 ; patient movement/location segment...
+17 IF ALPBSEG="PV1"
Begin DoDot:2
+18 DO PV1^ALPBHL1U(+$GET(ALPBIEN),$GET(ALPBDATA),$GET(ALPBFS),$GET(ALPBCS),.ALPBFERR)
+19 IF +$GET(ALPBFERR("DIERR"))
DO ERRLOG^ALPBUTL1(+$GET(ALPBIEN),+$GET(ALPBOIEN),$GET(ALPBHREC),"PV1",$GET(ALPBDATA),.ALPBFERR)
+20 KILL ALPBFERR
End DoDot:2
+21 ; IV orders segment...
+22 IF ALPBSEG="RXC"
Begin DoDot:2
+23 DO RXC^ALPBHL1U(+$GET(ALPBIEN),+$GET(ALPBOIEN),$GET(ALPBDATA),$GET(ALPBFS),$GET(ALPBCS),.ALPBFERR)
+24 IF +$GET(ALPBFERR("DIERR"))
DO ERRLOG^ALPBUTL1(+$GET(ALPBIEN),+$GET(ALPBOIEN),$GET(ALPBHREC),"RXC",$GET(ALPBDATA),.ALPBFERR)
+25 KILL ALPBFERR
End DoDot:2
+26 ; drug, additives and/or solutions segment...
+27 IF ALPBSEG="RXE"
Begin DoDot:2
+28 IF $GET(ALPBDATA)=""
QUIT
+29 ; 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...
+30 IF +$PIECE($PIECE(ALPBDATA,ALPBFS,3),ALPBCS,4)=0
SET $PIECE(ALPBDATA,ALPBFS,3)=$PIECE($GET(ALPBMTXT("RXO")),ALPBFS,2)
+31 ;chech for any continuation lines
+32 SET J=0
FOR
SET J=$ORDER(ALPBMTXT(I,J))
if 'J
QUIT
SET ALPBDATA=ALPBDATA_ALPBMTXT(I,J)
+33 DO RXE^ALPBHL1U(+$GET(ALPBIEN),+$GET(ALPBOIEN),ALPBDATA,$GET(ALPBFS),$GET(ALPBCS),$GET(ALPBECH),.ALPBFERR)
+34 IF +$GET(ALPBFERR("DIERR"))
DO ERRLOG^ALPBUTL1(+$GET(ALPBIEN),+$GET(ALPBOIEN),$GET(ALPBHREC),"RXE",ALPBDATA,.ALPBFERR)
+35 KILL ALPBFERR
End DoDot:2
+36 ; med route...
+37 IF ALPBSEG="RXR"
Begin DoDot:2
+38 DO RXR^ALPBHL1U(+$GET(ALPBIEN),+$GET(ALPBOIEN),$GET(ALPBDATA),$GET(ALPBFS),$GET(ALPBCS),.ALBPFERR)
+39 IF +$GET(ALPBFERR("DIERR"))
DO ERRLOG^ALPBUTL1(+$GET(ALPBIEN),+$GET(ALPBOIEN),$GET(ALPBHREC),"RXR",$GET(ALPBDATA),.ALPBFERR)
+40 KILL ALPBFERR
End DoDot:2
+41 ; provider comments, special instructions or other print info...
+42 IF ALPBSEG="NTE"
Begin DoDot:2
+43 ; NTE segments can be multiple-lines. set up an array (ALPBNTE(...)) to pass to the filer...
+44 ; the first node will be the one that contains the NTE segment identifier
+45 NEW TMPI,TMPJ
SET TMPI=I
SET ALPBNTE(1)=$$UNESC^ALPBGEN(ALPBMTXT(I))
SET I=TMPI
+46 SET ALPBX=1
+47 ; loop from ALPBMTXT(I) to retrieve any continuation lines...
+48 SET TMPJ=0
+49 FOR
SET TMPJ=$ORDER(ALPBMTXT(I,TMPJ))
if 'TMPJ
QUIT
Begin DoDot:3
+50 SET ALPBX=ALPBX+1
+51 SET ALPBNTE(ALPBX)=$$UNESC^ALPBGEN(ALPBMTXT(I,TMPJ))
SET I=TMPI
End DoDot:3
+52 KILL ALPBX,J
+53 DO NTE^ALPBHL1U(+$GET(ALPBIEN),+$GET(ALPBOIEN),.ALPBNTE,$GET(ALPBFS),$GET(ALPBCS),.ALPBFERR)
+54 IF +$GET(ALPBFERR("DIERR"))
DO ERRLOG^ALPBUTL1(+$GET(ALPBIEN),+$GET(ALPBOIEN),$GET(ALPBHREC),"NTE",ALPBDATA,.ALPBFERR)
+55 KILL ALPBFERR,ALPBNTE
End DoDot:2
+56 ; Hazardous drug flags segment...
+57 IF ALPBSEG="ZZZ"
Begin DoDot:2
+58 DO ZZZ^ALPBHL1U(+$GET(ALPBIEN),+$GET(ALPBOIEN),$GET(ALPBDATA),$GET(ALPBFS),$GET(ALPBCS),.ALPBFERR)
+59 IF +$GET(ALPBFERR("DIERR"))
DO ERRLOG^ALPBUTL1(+$GET(ALPBIEN),+$GET(ALPBOIEN),$GET(ALPBHREC),"ZZZ",$GET(ALPBDATA),.ALPBFERR)
+60 KILL ALPBFERR
End DoDot:2
+61 KILL ALPBDATA,ALPBSEG
End DoDot:1
+62 ;
+63 ; set RECORD LAST UPDATED field...
+64 SET ALPBLUPD=$$NOW^XLFDT()
+65 IF $GET(^ALPB(53.7,+$GET(ALPBIEN),0))'=""
Begin DoDot:1
+66 SET ALPBFILE(53.7,ALPBIEN_",",7)=ALPBLUPD
+67 DO FILE^DIE("","ALPBFILE","ALPBFERR")
+68 KILL ALPBFERR,ALPBFILE
End DoDot:1
+69 ;
+70 ; update PARAMETER file with last update date...
+71 SET ALPBPARM=+$ORDER(^ALPB(53.71,0))
+72 IF ALPBPARM>0
Begin DoDot:1
+73 SET ALPBFILE(53.71,ALPBPARM_",",4)=ALPBLUPD
+74 DO FILE^DIE("","ALPBFILE","ALPBFERR")
+75 KILL ALPBFERR,ALPBFILE
End DoDot:1
+76 KILL ALPBLUPD,ALPBPARM
+77 ;
CLEAN KILL ALPBCS,ALPBDATA,ALPBECH,ALPBFS,ALPBHREC,ALPBIEN,ALPBMLOG,ALPBMTXT
+1 KILL ALPBOIEN,ALPBORDC,ALPBORDN,ALPBORDT,ALPBOTYP,ALPBPDFN,ALPBPDOB
+2 KILL ALPBPNAM,ALPBPSEX,ALPBPSSN,ALPBSEG,ALPBHAZH,ALPBHAZD
+3 QUIT
