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