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