BOPROC ; ILC/IHS/ALG - Process FT1 statments;14-Nov-2006 10:45;SM;
;;1.0;AUTOMATED DISPENSING INTERFACE;**1,2**;Jul 26, 2005
Q
DFT(BOPI) ;EP - This is the entry point to process the FT1/DFT messages
; BOPI = IEN for file 90355.1 (BOP QUEUE File)
;
N INPAT,A,B,C,BOMS,BOPORDT,BOPDTA,BOPDT,BOPDRGI,BOPVDT
;IHS/MSC/PLS - 10/24/06 - Next line commented out for patch 2
;Q:$$VENDTYP()'="P" ;Only Pyxis devices orders are supported in patch 1
S (BOPTT,BOPTC,BOPMSU,BOPPRDN,BOPDT,BOPMID,BOPSITE)=""
S (BOPTYP,BOPAMID,BOPDFN,BOPTQ,BOPTQA,BOPOB,BOPNU)=""
S (OPMSUN,BOPPYNM,BOPNAME)=""
S BOPSITE=+$P(^BOP(90355.1,BOPI,0),U,12) ;Set to Receiving Facility
S BOPSITE=+$P($G(^BOP(90355,1,3,BOPSITE,0)),U,9) ;Set to Outpatient Site (File 59)
Q:'BOPSITE
S BOPJ=0 K BOPARY
ONE ;
S BOPJ=$O(BOPIN(BOPJ)) I BOPJ="" D:$G(BOPARY(2))'="" LOOP G DONE
S X=BOPIN(BOPJ)
I X?1"MSH".E S BOMS=BOPJ G ONE
I X?1"EVN".E G ONE
; collect one group
I X?1"PID".E D D:$G(BOPARY(2))'="" LOOP S BOPJ=BOPJ-1 G ONE
.K BOPARY S BOPARY=1,BOPARY(1)=X
. F S OUT=0,K=BOPJ,BOPJ=$O(BOPIN(BOPJ)) D Q:OUT I 'BOPJ S BOPJ=K+1 Q
..I 'BOPJ D Q
...I 'BOMS Q
...; evn is before pid
...N I,X F I=BOMS:1:K S X=$G(BOPIN(I)) I X?1"EVN".E S BOPARY(4)=X Q
...K I,X Q
..S X=$G(BOPIN(BOPJ))
..I X?1"PID".E S OUT=1 Q
..I X?1"PV1".E S F=BOPARY,F=F+1,BOPARY=F,BOPARY(F)=X Q
..I X?1"FT1".E S F=BOPARY,F=F+1,BOPARY=F,BOPARY(F)=X Q
..I X?1"EVN".E S BOPARY(4)=X Q
..S OUT=1 Q
; process BOPARY
LOOP S (A,B,C,BOMS)=0
L1 ;
S A=$O(BOPARY(A)) I 'A K BOPARY Q
S X=$G(BOPARY(A))
I X?1"PID".E S BOPPID=X G L1
I X?1"PV1".E S BOPPV1=X G L1
I X?1"EVN".E S BOPEVN=X G L1
I X?1"FT1".E S BOPFT1=X
I $G(BOPEVN)="" S BOPEVN=$G(BOPARY(4))
; above is for the possibilty of multiple FT1's for a pt. PID and PV1
; stay the same but FT1 can change
RUN ; first check if supply or drug
S BOPUSER="" S BOPUSER=$P(BOPPID,"|",21) S BOPUSER=$P(BOPUSER,"^",3)_" "_$P(BOPUSER,"^",2)
S BOPDFN="" S BOPDFN=$P(BOPPID,"|",4) I BOPDFN="" D LOGEXN(5) G L1
I '$D(^DPT(BOPDFN,0)) D LOGEXN(6) G L1
; Determine patient status
S INPAT=$$ISINPT(BOPDFN)
S BOPDRGI=$$DRGIEN(BOPFT1)
I BOPDRGI="" D LOGEXN(3) G L1
S X=BOPFT1,BOPDB=$E($P(X,"|",18),1),BOPDB=$TR(BOPDB,"ds","DS")
; Check to see if item is in BOP DRUG file
S BOPDREC=$O(^BOP(90355.5,"BOP",BOPDRGI,""))
; If drug not in BOP DRUG file, process as Supply Item
I BOPDREC=""!INPAT G SUPFILE
S BOPCRCH=$$TRANTYP(BOPFT1)
; Process Credit transaction
I BOPCRCH="CR" D G L1
.N PSONOOR,%APSITE,%APSITE2,%APSITE3,APSDRTDA,BOPPSRX
.S BOPPSRX=""
.S %APSITE=$G(^APSPCTRL(BOPSITE,0))
.S %APSITE2=$G(^APSPCTRL(BOPSITE,2))
.S %APSITE3=$G(^APSPCTRL(BOPSITE,3))
.S BOPPSRX=$O(^BOP(90355.44,"DRUG",BOPDFN,BOPDRGI,BOPPSRX),-1)
.; A prescription was found, now mark as deleted.
.I BOPPSRX D
..N PSOIB,DA,RX,RXN,DIK,PSOABCDA,PSOZVER,DFN,I,STAT,COM,PSONOOR
..S PSONOOR="S" ; Set Nature of Order to Service Correction
..S PSOZVER=1 ; Control flag used by PSORXDL. Setting to 1 allows inventory adjustment and POS call to be made.
..; Set prescription status to DELETED
..S DA=BOPPSRX D ENQ^PSORXDL
; Process Charge transaction on drug/create NON-VERIFIED prescription
I BOPDB["D" D D:BOPDAS ENTRY^BOPUVER(BOPDAS)
.S BOPDT=$$NOW^XLFDT
.N DIC K DO,DD S DIC="^BOP(90355.44,",DIC(0)="L",X=BOPDT D FILE^DICN
.S BOPDAS=+Y,D=$G(^BOP(90355.44,BOPDAS,0))
.S E=BOPDB_U_BOPI_U_$P(BOPPID,"|",4)_U_$P(BOPPID,"|",19)_U S:$P(BOPPID,"|",20) E=E_$P(BOPPID,"|",20)
.S $P(^BOP(90355.44,BOPDAS,0),U,2,6)=E
.F I=1:1:3 S ^BOP(90355.44,BOPDAS,I)=$S(I=1:BOPPID,I=2:BOPPV1,I=3:BOPFT1,1:"")
.N DA,DIK S DA=BOPDAS,DIK="^BOP(90355.44," D IX1^DIK K DA,DIK
.S ^BOP(90355.1,BOPI,"TRACE4")=BOPDAS_U_$P(BOPPID,"|",4)_U_BOPDRGI
G L1 ; if drug in 90355.5 file, create unverified drug, but don't put it into ihs hl7 supply file
;
SUPFILE ; Set item into IHS HL7 Supply Interface file
; supply file only - don't create unverified order
S BOPNAME=$P(BOPPID,"|",6)
;S BOPDFN=$P(BOPPID,"|",4)
S BOPEXFN=$P(BOPPID,"|",19)
S BOPSSN=$P(BOPPID,"|",20)
IHSHRN I 'BOPDFN D ; Lookup up using HRN if in record
.Q:'BOPEXFN ;alternate ID not available
.N A,B,D,E,F,G
.S (A,B,D,E,F,G)=""
.S (A,B)="^AUPNPAT(""D"","_BOPEXFN S A=A_")"
.I BOPEXFN?1N.N D ; make sure that it is a number
..S D="" F S A=$Q(@A) Q:A=""!($E(A,1,$L(B))'=B) D Q:D'=""
...S E=$P(A,",",3),F=$P($P(A,",",4),")",1)
...S G=$G(^AUPNPAT(E,0)) Q:G=""
...S G=$G(^DPT(E,0)) Q:G=""
...S D=E
.S BOPDFN=D
S BOPLOC=$P($P(BOPPV1,"|",4),U) ; assigned patient location
S BOPATDOC=$P(BOPPV1,"|",8) ; attending doc
S BOPDESC=$S($$VENDTYP()="O":$P(BOPFT1,"|",9),$$VENDTYP()="P":$P($P(BOPFT1,"|",8),U,2)) ; charge description
S BOPDT=$P(BOPFT1,"|",5) ; HL7 transaction dt/time
S BOPTT=$$TRANTYP(BOPFT1) ;$P(BOPFT1,"|",7) ; transaction type CHarge or CRedit
S BOPTC=$P($P(BOPFT1,"|",8),U) ; transaction code (charge id)
S BOPTQ=$P(BOPFT1,"|",11) ; transaction qty
S BOPTQA=$S(BOPTT["CR":(BOPTQ*-1),1:BOPTQ)
S BOPMSU=$P(BOPFT1,"|",14) ; code for station used map to ^BOP(90355.41)
S BOPOB=$P(BOPFT1,"|",22),BOPOB=$P(BOPOB,U,2)_","_$TR($P(BOPOB,U,3,4),U," ") ; ordered by
I BOPOB]"" S BOPOB=$O(^VA(200,"B",BOPOB,0))
S BOPORDN=$$ORDNUM(BOPFT1) ; order number. nn-nnn pt order nnnn just item
I 'BOPORDN D ;Check for previously linked dispenses
.S BOPORDN=$$GETLINK^BOPSD(BOPDFN,BOPDRGI)
;
CHK ; chk point
; basic check
S BOP3PCM="",BOP3PPRC=""
S BOPPRICE="",BOPDRUG=""
I 'BOPDFN D LOGEXN(5) G L1
I '$D(^DPT(BOPDFN,0)) D LOGEXN(6) G L1
I BOPDESC="" D LOGEXN(4) G L1
S BOPDTA=$$FMDATE^HLFNC(BOPDT),(BOPVDT,BOPORDT)=BOPDTA
; check for visit date from ^AUPNVSIT("AC"
S X="zzzzzz",BOPAUVST=""
F S X=$O(^AUPNVSIT("AC",BOPDFN,X),-1) Q:'X S OUT="" D Q:OUT=1 ; get most recent
.S B=$G(^AUPNVSIT(X,0)) Q:B="" ; no data
.S B=$P(B,U,1) Q:B="" ; no date
.I B=BOPDTA!(B<BOPDTA) S BOPORDT=B,BOPAUVST=X,OUT=1 Q
I BOPORDT=BOPDTA&(BOPAUVST="")&(+BOPORDN) D ; chk for order dt in 55 if not visit
.S G=+$P($G(^PS(55,BOPDFN,5,+BOPORDN,0)),U,14)
.S:G BOPORDT=G
;
; Add dispense record to IHS HL7 Supply File
N DIC K DO,DD S DIC="^AUPNSUP(",DIC(0)="L",X=BOPDESC D FILE^DICN
I '$P(Y,U,3) D LOGEXN(7) G L1
S BOPAUDA=+Y
S X=BOPDFN_U_BOPORDT_U_U_BOPDTA
S $P(^AUPNSUP(BOPAUDA,0),U,2,5)=X
I BOPDB="D" D
.S ^AUPNSUP(BOPAUDA,1)=$$GET1^DIQ(50,+BOPTC,31)_"^^"_BOPTC ;NDC^^Drug IEN
E D
.S ^AUPNSUP(BOPAUDA,1)=BOPTC ; Supply Code
S ^AUPNSUP(BOPAUDA,2)=BOPDESC_U_BOPORDT_U_BOPTQA
;
I BOPDB="S" D ;-> if supply get chg code price
.S BOP3PCM=$O(^ABMCM("D",BOPTC,BOP3PCM))
.I $G(BOP3PCM) S BOP3PPRC=$P($G(^ABMDFEE(1,32,BOP3PCM,0)),U,2)
.S $P(^AUPNSUP(BOPAUDA,2),U,4)=BOP3PPRC
I BOPDB="D" D ;-> if drug get price from psdrug
.S $P(^AUPNSUP(BOPAUDA,2),U,4)=$$GDRGPRC($$DRGIEN(BOPFT1),1)
;
N DA,DIK S DA=BOPAUDA,DIK="^AUPNSUP(" D IX1^DIK K DA,DIK ; do xreff
;
; put BOPAUVST into 90355.1 node TRK by BOPJ, BOPDFN, BOPAUVST
; BOPJ is the current FT1 node being worked on
;
S X=$G(^BOP(90355.1,BOPI,0)) I X'="" S ^BOP(90355.1,BOPI,"TRK",(BOPJ+0),BOPDFN,(BOPAUVST+0))=$G(BOPAUDA)
; Update Extra Units for inpatient med order
I BOPDB="D",INPAT,+BOPORDN D
.D ADDXTRA
; Add inpatient dispense to BOP RECEIVE DRUG file
I BOPDB="D",INPAT D
.D ADDRECDG(BOPDRGI,BOPDFN,BOPVDT,BOPORDN,BOPTQA,+BOPOB,"S","")
.;D ADDRECDG(BOPDRGI,BOPDFN,BOPORDT,BOPORDN,BOPTQA,+BOPOB,"S","")
G L1
;
DONE Q
; Return Inpatient status
ISINPT(DFN) ;EP
N VAIN,VAERR
D INP^VADPT
Q +$G(VAIN(1))
;
; Update Dispense Drug Extra Units Dispensed
ADDXTRA ; EP
Q:'BOPDFN!'BOPORDN!'BOPDRGI
N FDA,DIEN,MSG
S DIEN=$O(^PS(55,BOPDFN,5,+BOPORDN,1,"B",BOPDRGI,0))
Q:'DIEN
S IENS=DIEN_","_+BOPORDN_","_BOPDFN_","
S FDA(55.07,IENS,.11)=BOPTQA
D FILE^DIE("K","FDA","MSG")
Q
; Return drug price
GDRGPRC(DIEN,AWPFLG) ; EP
Q:'DIEN ""
S AWPFLG=$G(AWPFLG,0)
N BOPPRICE
S BOPPRICE=""
S:AWPFLG BOPPRICE=$$GET1^DIQ(50,DIEN,9999999.32)
S:'BOPPRICE BOPPRICE=$$GET1^DIQ(50,DIEN,16)
Q BOPPRICE
; Return Order Number for Inpatient Order
ORDNUM(BOPFT1) ;EP
N RES,VEND
S VEND=$$VENDTYP()
I VEND="O" D ; Process Omnicell Message
.S RES=+$P(BOPFT1,"|",24)
E I VEND="P" D ; Process Pyxis Message
.S RES=+$P(BOPFT1,"|",10)
Q RES
; Return DRUG IEN
DRGIEN(BOPFT1) ;EP
N RES,VEND
S VEND=$$VENDTYP()
;I VEND="O" D ; Process Omnicell message
;.S RES=$P(BOPFT1,"|",24) ; Filler Order Number (Order Number-Drug IEN)
;.S RES=$P(RES,"-",$L(RES,"-")) ; Last piece contains Drug IEN
;E I VEND="P" D ; Process Pyxis message
S RES=+$P($P(BOPFT1,"|",8),U) ; Format=Drug IEN^Description or NDC^Description
Q $G(RES)
; Return Vendor type (internal format)
VENDTYP() ;EP
Q $$GET1^DIQ(90355,1,2.5,"I")
; Return CHarge or CRedit for Transaction Type
TRANTYP(BOPFT1) ;EP
N RES,VEND
S VEND=$$VENDTYP()
S RES=$P(BOPFT1,"|",7)
I VEND="P" D ; Process Pyxis message
.S RES=$S(RES["V":"CH",1:"CR")
Q RES
; Add entry to BOP RECEIVE DRUG file
ADDRECDG(DRUG,PAT,VDATE,ORDNUM,QVEND,ORDBY,ORDTYP,DISNAM) ;
N MSG,FDA,IEN,ARY
S IENS="+1,"
; Combine quantity of extraneous entries
I '$G(ORDNUM) D
.D FINDITMS^BOPSD(PAT,DRUG,.ARY)
.S IEN=$O(ARY(0))
.Q:'IEN
.D COMBINE^BOPSD(IEN,.ARY)
.S IENS=IEN_","
.S QVEND=QVEND+$P(^BOP(90355.2,IEN,0),U,5)
Q:'$G(DRUG)
S FDA(90355.2,IENS,.01)=DRUG
S FDA(90355.2,IENS,.02)=$G(PAT)
S FDA(90355.2,IENS,.03)=$G(VDATE)
S:$G(ORDNUM) FDA(90355.2,IENS,.04)=+ORDNUM
S FDA(90355.2,IENS,.05)=$G(QVEND)
S:$G(ORDBY) FDA(90355.2,IENS,.06)=ORDBY
S:'$G(ORDNUM)&($G(ORDTYP)="S") FDA(90355.2,IENS,.07)=$G(ORDTYP)
S FDA(90355.2,IENS,.09)=BOPI
S FDA(90355.2,IENS,.1)=$G(DISNAM)
S:$G(ORDNUM) FDA(90355.2,IENS,.08)="R"
D UPDATE^DIE(,"FDA",,"MSG")
Q
; Add exception to log
LOGEXN(BOPERR) ; EP
N FDA,FN,MSG,IENS
S FN=90355.4,IENS="+1,"
S FDA(FN,IENS,.01)=$$NOW^XLFDT
S FDA(FN,IENS,.02)=$G(BOPDFN)
S FDA(FN,IENS,.03)=$G(BOPORDT)
S FDA(FN,IENS,.04)=$G(BOPORDN)
S FDA(FN,IENS,.05)=$G(BOPTQA)
;S FDA(FN,IENS,.06)= ;ORDERED BY
;S FDA(FN,IENS,.07)= ;ORDER TYPE ( PREPAK, OBS, STARTER DOSE, NORMAL OR SUPPLY)
S FDA(FN,IENS,.08)=$G(BOPORDN)
;S FDA(FN,IENS,.1)= ;ITEM NAME
S FDA(FN,IENS,.09)=BOPERR
S FDA(FN,IENS,.11)=$G(BOPDRGI)
;S FDA(FN,IENS,.12)= ;CHARGE DESCRIPTION
S FDA(FN,IENS,.13)=$G(BOPI) ;QUEUE IEN
D UPDATE^DIE(,"FDA",,"MSG")
Q
BOPROC ; ILC/IHS/ALG - Process FT1 statments;14-Nov-2006 10:45;SM;
+1 ;;1.0;AUTOMATED DISPENSING INTERFACE;**1,2**;Jul 26, 2005
+2 QUIT
DFT(BOPI) ;EP - This is the entry point to process the FT1/DFT messages
+1 ; BOPI = IEN for file 90355.1 (BOP QUEUE File)
+2 ;
+3 NEW INPAT,A,B,C,BOMS,BOPORDT,BOPDTA,BOPDT,BOPDRGI,BOPVDT
+4 ;IHS/MSC/PLS - 10/24/06 - Next line commented out for patch 2
+5 ;Q:$$VENDTYP()'="P" ;Only Pyxis devices orders are supported in patch 1
+6 SET (BOPTT,BOPTC,BOPMSU,BOPPRDN,BOPDT,BOPMID,BOPSITE)=""
+7 SET (BOPTYP,BOPAMID,BOPDFN,BOPTQ,BOPTQA,BOPOB,BOPNU)=""
+8 SET (OPMSUN,BOPPYNM,BOPNAME)=""
+9 ;Set to Receiving Facility
SET BOPSITE=+$PIECE(^BOP(90355.1,BOPI,0),U,12)
+10 ;Set to Outpatient Site (File 59)
SET BOPSITE=+$PIECE($GET(^BOP(90355,1,3,BOPSITE,0)),U,9)
+11 IF 'BOPSITE
QUIT
+12 SET BOPJ=0
KILL BOPARY
ONE ;
+1 SET BOPJ=$ORDER(BOPIN(BOPJ))
IF BOPJ=""
IF $GET(BOPARY(2))'=""
DO LOOP
GOTO DONE
+2 SET X=BOPIN(BOPJ)
+3 IF X?1"MSH".E
SET BOMS=BOPJ
GOTO ONE
+4 IF X?1"EVN".E
GOTO ONE
+5 ; collect one group
+6 IF X?1"PID".E
Begin DoDot:1
+7 KILL BOPARY
SET BOPARY=1
SET BOPARY(1)=X
+8 FOR
SET OUT=0
SET K=BOPJ
SET BOPJ=$ORDER(BOPIN(BOPJ))
Begin DoDot:2
+9 IF 'BOPJ
Begin DoDot:3
+10 IF 'BOMS
QUIT
+11 ; evn is before pid
+12 NEW I,X
FOR I=BOMS:1:K
SET X=$GET(BOPIN(I))
IF X?1"EVN".E
SET BOPARY(4)=X
QUIT
+13 KILL I,X
QUIT
End DoDot:3
QUIT
+14 SET X=$GET(BOPIN(BOPJ))
+15 IF X?1"PID".E
SET OUT=1
QUIT
+16 IF X?1"PV1".E
SET F=BOPARY
SET F=F+1
SET BOPARY=F
SET BOPARY(F)=X
QUIT
+17 IF X?1"FT1".E
SET F=BOPARY
SET F=F+1
SET BOPARY=F
SET BOPARY(F)=X
QUIT
+18 IF X?1"EVN".E
SET BOPARY(4)=X
QUIT
+19 SET OUT=1
QUIT
End DoDot:2
IF OUT
QUIT
IF 'BOPJ
SET BOPJ=K+1
QUIT
End DoDot:1
IF $GET(BOPARY(2))'=""
DO LOOP
SET BOPJ=BOPJ-1
GOTO ONE
+20 ; process BOPARY
LOOP SET (A,B,C,BOMS)=0
L1 ;
+1 SET A=$ORDER(BOPARY(A))
IF 'A
KILL BOPARY
QUIT
+2 SET X=$GET(BOPARY(A))
+3 IF X?1"PID".E
SET BOPPID=X
GOTO L1
+4 IF X?1"PV1".E
SET BOPPV1=X
GOTO L1
+5 IF X?1"EVN".E
SET BOPEVN=X
GOTO L1
+6 IF X?1"FT1".E
SET BOPFT1=X
+7 IF $GET(BOPEVN)=""
SET BOPEVN=$GET(BOPARY(4))
+8 ; above is for the possibilty of multiple FT1's for a pt. PID and PV1
+9 ; stay the same but FT1 can change
RUN ; first check if supply or drug
+1 SET BOPUSER=""
SET BOPUSER=$PIECE(BOPPID,"|",21)
SET BOPUSER=$PIECE(BOPUSER,"^",3)_" "_$PIECE(BOPUSER,"^",2)
+2 SET BOPDFN=""
SET BOPDFN=$PIECE(BOPPID,"|",4)
IF BOPDFN=""
DO LOGEXN(5)
GOTO L1
+3 IF '$DATA(^DPT(BOPDFN,0))
DO LOGEXN(6)
GOTO L1
+4 ; Determine patient status
+5 SET INPAT=$$ISINPT(BOPDFN)
+6 SET BOPDRGI=$$DRGIEN(BOPFT1)
+7 IF BOPDRGI=""
DO LOGEXN(3)
GOTO L1
+8 SET X=BOPFT1
SET BOPDB=$EXTRACT($PIECE(X,"|",18),1)
SET BOPDB=$TRANSLATE(BOPDB,"ds","DS")
+9 ; Check to see if item is in BOP DRUG file
+10 SET BOPDREC=$ORDER(^BOP(90355.5,"BOP",BOPDRGI,""))
+11 ; If drug not in BOP DRUG file, process as Supply Item
+12 IF BOPDREC=""!INPAT
GOTO SUPFILE
+13 SET BOPCRCH=$$TRANTYP(BOPFT1)
+14 ; Process Credit transaction
+15 IF BOPCRCH="CR"
Begin DoDot:1
+16 NEW PSONOOR,%APSITE,%APSITE2,%APSITE3,APSDRTDA,BOPPSRX
+17 SET BOPPSRX=""
+18 SET %APSITE=$GET(^APSPCTRL(BOPSITE,0))
+19 SET %APSITE2=$GET(^APSPCTRL(BOPSITE,2))
+20 SET %APSITE3=$GET(^APSPCTRL(BOPSITE,3))
+21 SET BOPPSRX=$ORDER(^BOP(90355.44,"DRUG",BOPDFN,BOPDRGI,BOPPSRX),-1)
+22 ; A prescription was found, now mark as deleted.
+23 IF BOPPSRX
Begin DoDot:2
+24 NEW PSOIB,DA,RX,RXN,DIK,PSOABCDA,PSOZVER,DFN,I,STAT,COM,PSONOOR
+25 ; Set Nature of Order to Service Correction
SET PSONOOR="S"
+26 ; Control flag used by PSORXDL. Setting to 1 allows inventory adjustment and POS call to be made.
SET PSOZVER=1
+27 ; Set prescription status to DELETED
+28 SET DA=BOPPSRX
DO ENQ^PSORXDL
End DoDot:2
End DoDot:1
GOTO L1
+29 ; Process Charge transaction on drug/create NON-VERIFIED prescription
+30 IF BOPDB["D"
Begin DoDot:1
+31 SET BOPDT=$$NOW^XLFDT
+32 NEW DIC
KILL DO,DD
SET DIC="^BOP(90355.44,"
SET DIC(0)="L"
SET X=BOPDT
DO FILE^DICN
+33 SET BOPDAS=+Y
SET D=$GET(^BOP(90355.44,BOPDAS,0))
+34 SET E=BOPDB_U_BOPI_U_$PIECE(BOPPID,"|",4)_U_$PIECE(BOPPID,"|",19)_U
IF $PIECE(BOPPID,"|",20)
SET E=E_$PIECE(BOPPID,"|",20)
+35 SET $PIECE(^BOP(90355.44,BOPDAS,0),U,2,6)=E
+36 FOR I=1:1:3
SET ^BOP(90355.44,BOPDAS,I)=$SELECT(I=1:BOPPID,I=2:BOPPV1,I=3:BOPFT1,1:"")
+37 NEW DA,DIK
SET DA=BOPDAS
SET DIK="^BOP(90355.44,"
DO IX1^DIK
KILL DA,DIK
+38 SET ^BOP(90355.1,BOPI,"TRACE4")=BOPDAS_U_$PIECE(BOPPID,"|",4)_U_BOPDRGI
End DoDot:1
IF BOPDAS
DO ENTRY^BOPUVER(BOPDAS)
+39 ; if drug in 90355.5 file, create unverified drug, but don't put it into ihs hl7 supply file
GOTO L1
+40 ;
SUPFILE ; Set item into IHS HL7 Supply Interface file
+1 ; supply file only - don't create unverified order
+2 SET BOPNAME=$PIECE(BOPPID,"|",6)
+3 ;S BOPDFN=$P(BOPPID,"|",4)
+4 SET BOPEXFN=$PIECE(BOPPID,"|",19)
+5 SET BOPSSN=$PIECE(BOPPID,"|",20)
IHSHRN ; Lookup up using HRN if in record
IF 'BOPDFN
Begin DoDot:1
+1 ;alternate ID not available
IF 'BOPEXFN
QUIT
+2 NEW A,B,D,E,F,G
+3 SET (A,B,D,E,F,G)=""
+4 SET (A,B)="^AUPNPAT(""D"","_BOPEXFN
SET A=A_")"
+5 ; make sure that it is a number
IF BOPEXFN?1N.N
Begin DoDot:2
+6 SET D=""
FOR
SET A=$QUERY(@A)
IF A=""!($EXTRACT(A,1,$LENGTH(B))'=B)
QUIT
Begin DoDot:3
+7 SET E=$PIECE(A,",",3)
SET F=$PIECE($PIECE(A,",",4),")",1)
+8 SET G=$GET(^AUPNPAT(E,0))
IF G=""
QUIT
+9 SET G=$GET(^DPT(E,0))
IF G=""
QUIT
+10 SET D=E
End DoDot:3
IF D'=""
QUIT
End DoDot:2
+11 SET BOPDFN=D
End DoDot:1
+12 ; assigned patient location
SET BOPLOC=$PIECE($PIECE(BOPPV1,"|",4),U)
+13 ; attending doc
SET BOPATDOC=$PIECE(BOPPV1,"|",8)
+14 ; charge description
SET BOPDESC=$SELECT($$VENDTYP()="O":$PIECE(BOPFT1,"|",9),$$VENDTYP()="P":$PIECE($PIECE(BOPFT1,"|",8),U,2))
+15 ; HL7 transaction dt/time
SET BOPDT=$PIECE(BOPFT1,"|",5)
+16 ;$P(BOPFT1,"|",7) ; transaction type CHarge or CRedit
SET BOPTT=$$TRANTYP(BOPFT1)
+17 ; transaction code (charge id)
SET BOPTC=$PIECE($PIECE(BOPFT1,"|",8),U)
+18 ; transaction qty
SET BOPTQ=$PIECE(BOPFT1,"|",11)
+19 SET BOPTQA=$SELECT(BOPTT["CR":(BOPTQ*-1),1:BOPTQ)
+20 ; code for station used map to ^BOP(90355.41)
SET BOPMSU=$PIECE(BOPFT1,"|",14)
+21 ; ordered by
SET BOPOB=$PIECE(BOPFT1,"|",22)
SET BOPOB=$PIECE(BOPOB,U,2)_","_$TRANSLATE($PIECE(BOPOB,U,3,4),U," ")
+22 IF BOPOB]""
SET BOPOB=$ORDER(^VA(200,"B",BOPOB,0))
+23 ; order number. nn-nnn pt order nnnn just item
SET BOPORDN=$$ORDNUM(BOPFT1)
+24 ;Check for previously linked dispenses
IF 'BOPORDN
Begin DoDot:1
+25 SET BOPORDN=$$GETLINK^BOPSD(BOPDFN,BOPDRGI)
End DoDot:1
+26 ;
CHK ; chk point
+1 ; basic check
+2 SET BOP3PCM=""
SET BOP3PPRC=""
+3 SET BOPPRICE=""
SET BOPDRUG=""
+4 IF 'BOPDFN
DO LOGEXN(5)
GOTO L1
+5 IF '$DATA(^DPT(BOPDFN,0))
DO LOGEXN(6)
GOTO L1
+6 IF BOPDESC=""
DO LOGEXN(4)
GOTO L1
+7 SET BOPDTA=$$FMDATE^HLFNC(BOPDT)
SET (BOPVDT,BOPORDT)=BOPDTA
+8 ; check for visit date from ^AUPNVSIT("AC"
+9 SET X="zzzzzz"
SET BOPAUVST=""
+10 ; get most recent
FOR
SET X=$ORDER(^AUPNVSIT("AC",BOPDFN,X),-1)
IF 'X
QUIT
SET OUT=""
Begin DoDot:1
+11 ; no data
SET B=$GET(^AUPNVSIT(X,0))
IF B=""
QUIT
+12 ; no date
SET B=$PIECE(B,U,1)
IF B=""
QUIT
+13 IF B=BOPDTA!(B<BOPDTA)
SET BOPORDT=B
SET BOPAUVST=X
SET OUT=1
QUIT
End DoDot:1
IF OUT=1
QUIT
+14 ; chk for order dt in 55 if not visit
IF BOPORDT=BOPDTA&(BOPAUVST="")&(+BOPORDN)
Begin DoDot:1
+15 SET G=+$PIECE($GET(^PS(55,BOPDFN,5,+BOPORDN,0)),U,14)
+16 IF G
SET BOPORDT=G
End DoDot:1
+17 ;
+18 ; Add dispense record to IHS HL7 Supply File
+19 NEW DIC
KILL DO,DD
SET DIC="^AUPNSUP("
SET DIC(0)="L"
SET X=BOPDESC
DO FILE^DICN
+20 IF '$PIECE(Y,U,3)
DO LOGEXN(7)
GOTO L1
+21 SET BOPAUDA=+Y
+22 SET X=BOPDFN_U_BOPORDT_U_U_BOPDTA
+23 SET $PIECE(^AUPNSUP(BOPAUDA,0),U,2,5)=X
+24 IF BOPDB="D"
Begin DoDot:1
+25 ;NDC^^Drug IEN
SET ^AUPNSUP(BOPAUDA,1)=$$GET1^DIQ(50,+BOPTC,31)_"^^"_BOPTC
End DoDot:1
+26 IF '$TEST
Begin DoDot:1
+27 ; Supply Code
SET ^AUPNSUP(BOPAUDA,1)=BOPTC
End DoDot:1
+28 SET ^AUPNSUP(BOPAUDA,2)=BOPDESC_U_BOPORDT_U_BOPTQA
+29 ;
+30 ;-> if supply get chg code price
IF BOPDB="S"
Begin DoDot:1
+31 SET BOP3PCM=$ORDER(^ABMCM("D",BOPTC,BOP3PCM))
+32 IF $GET(BOP3PCM)
SET BOP3PPRC=$PIECE($GET(^ABMDFEE(1,32,BOP3PCM,0)),U,2)
+33 SET $PIECE(^AUPNSUP(BOPAUDA,2),U,4)=BOP3PPRC
End DoDot:1
+34 ;-> if drug get price from psdrug
IF BOPDB="D"
Begin DoDot:1
+35 SET $PIECE(^AUPNSUP(BOPAUDA,2),U,4)=$$GDRGPRC($$DRGIEN(BOPFT1),1)
End DoDot:1
+36 ;
+37 ; do xreff
NEW DA,DIK
SET DA=BOPAUDA
SET DIK="^AUPNSUP("
DO IX1^DIK
KILL DA,DIK
+38 ;
+39 ; put BOPAUVST into 90355.1 node TRK by BOPJ, BOPDFN, BOPAUVST
+40 ; BOPJ is the current FT1 node being worked on
+41 ;
+42 SET X=$GET(^BOP(90355.1,BOPI,0))
IF X'=""
SET ^BOP(90355.1,BOPI,"TRK",(BOPJ+0),BOPDFN,(BOPAUVST+0))=$GET(BOPAUDA)
+43 ; Update Extra Units for inpatient med order
+44 IF BOPDB="D"
IF INPAT
IF +BOPORDN
Begin DoDot:1
+45 DO ADDXTRA
End DoDot:1
+46 ; Add inpatient dispense to BOP RECEIVE DRUG file
+47 IF BOPDB="D"
IF INPAT
Begin DoDot:1
+48 DO ADDRECDG(BOPDRGI,BOPDFN,BOPVDT,BOPORDN,BOPTQA,+BOPOB,"S","")
+49 ;D ADDRECDG(BOPDRGI,BOPDFN,BOPORDT,BOPORDN,BOPTQA,+BOPOB,"S","")
End DoDot:1
+50 GOTO L1
+51 ;
DONE QUIT
+1 ; Return Inpatient status
ISINPT(DFN) ;EP
+1 NEW VAIN,VAERR
+2 DO INP^VADPT
+3 QUIT +$GET(VAIN(1))
+4 ;
+5 ; Update Dispense Drug Extra Units Dispensed
ADDXTRA ; EP
+1 IF 'BOPDFN!'BOPORDN!'BOPDRGI
QUIT
+2 NEW FDA,DIEN,MSG
+3 SET DIEN=$ORDER(^PS(55,BOPDFN,5,+BOPORDN,1,"B",BOPDRGI,0))
+4 IF 'DIEN
QUIT
+5 SET IENS=DIEN_","_+BOPORDN_","_BOPDFN_","
+6 SET FDA(55.07,IENS,.11)=BOPTQA
+7 DO FILE^DIE("K","FDA","MSG")
+8 QUIT
+9 ; Return drug price
GDRGPRC(DIEN,AWPFLG) ; EP
+1 IF 'DIEN
QUIT ""
+2 SET AWPFLG=$GET(AWPFLG,0)
+3 NEW BOPPRICE
+4 SET BOPPRICE=""
+5 IF AWPFLG
SET BOPPRICE=$$GET1^DIQ(50,DIEN,9999999.32)
+6 IF 'BOPPRICE
SET BOPPRICE=$$GET1^DIQ(50,DIEN,16)
+7 QUIT BOPPRICE
+8 ; Return Order Number for Inpatient Order
ORDNUM(BOPFT1) ;EP
+1 NEW RES,VEND
+2 SET VEND=$$VENDTYP()
+3 ; Process Omnicell Message
IF VEND="O"
Begin DoDot:1
+4 SET RES=+$PIECE(BOPFT1,"|",24)
End DoDot:1
+5 ; Process Pyxis Message
IF '$TEST
IF VEND="P"
Begin DoDot:1
+6 SET RES=+$PIECE(BOPFT1,"|",10)
End DoDot:1
+7 QUIT RES
+8 ; Return DRUG IEN
DRGIEN(BOPFT1) ;EP
+1 NEW RES,VEND
+2 SET VEND=$$VENDTYP()
+3 ;I VEND="O" D ; Process Omnicell message
+4 ;.S RES=$P(BOPFT1,"|",24) ; Filler Order Number (Order Number-Drug IEN)
+5 ;.S RES=$P(RES,"-",$L(RES,"-")) ; Last piece contains Drug IEN
+6 ;E I VEND="P" D ; Process Pyxis message
+7 ; Format=Drug IEN^Description or NDC^Description
SET RES=+$PIECE($PIECE(BOPFT1,"|",8),U)
+8 QUIT $GET(RES)
+9 ; Return Vendor type (internal format)
VENDTYP() ;EP
+1 QUIT $$GET1^DIQ(90355,1,2.5,"I")
+2 ; Return CHarge or CRedit for Transaction Type
TRANTYP(BOPFT1) ;EP
+1 NEW RES,VEND
+2 SET VEND=$$VENDTYP()
+3 SET RES=$PIECE(BOPFT1,"|",7)
+4 ; Process Pyxis message
IF VEND="P"
Begin DoDot:1
+5 SET RES=$SELECT(RES["V":"CH",1:"CR")
End DoDot:1
+6 QUIT RES
+7 ; Add entry to BOP RECEIVE DRUG file
ADDRECDG(DRUG,PAT,VDATE,ORDNUM,QVEND,ORDBY,ORDTYP,DISNAM) ;
+1 NEW MSG,FDA,IEN,ARY
+2 SET IENS="+1,"
+3 ; Combine quantity of extraneous entries
+4 IF '$GET(ORDNUM)
Begin DoDot:1
+5 DO FINDITMS^BOPSD(PAT,DRUG,.ARY)
+6 SET IEN=$ORDER(ARY(0))
+7 IF 'IEN
QUIT
+8 DO COMBINE^BOPSD(IEN,.ARY)
+9 SET IENS=IEN_","
+10 SET QVEND=QVEND+$PIECE(^BOP(90355.2,IEN,0),U,5)
End DoDot:1
+11 IF '$GET(DRUG)
QUIT
+12 SET FDA(90355.2,IENS,.01)=DRUG
+13 SET FDA(90355.2,IENS,.02)=$GET(PAT)
+14 SET FDA(90355.2,IENS,.03)=$GET(VDATE)
+15 IF $GET(ORDNUM)
SET FDA(90355.2,IENS,.04)=+ORDNUM
+16 SET FDA(90355.2,IENS,.05)=$GET(QVEND)
+17 IF $GET(ORDBY)
SET FDA(90355.2,IENS,.06)=ORDBY
+18 IF '$GET(ORDNUM)&($GET(ORDTYP)="S")
SET FDA(90355.2,IENS,.07)=$GET(ORDTYP)
+19 SET FDA(90355.2,IENS,.09)=BOPI
+20 SET FDA(90355.2,IENS,.1)=$GET(DISNAM)
+21 IF $GET(ORDNUM)
SET FDA(90355.2,IENS,.08)="R"
+22 DO UPDATE^DIE(,"FDA",,"MSG")
+23 QUIT
+24 ; Add exception to log
LOGEXN(BOPERR) ; EP
+1 NEW FDA,FN,MSG,IENS
+2 SET FN=90355.4
SET IENS="+1,"
+3 SET FDA(FN,IENS,.01)=$$NOW^XLFDT
+4 SET FDA(FN,IENS,.02)=$GET(BOPDFN)
+5 SET FDA(FN,IENS,.03)=$GET(BOPORDT)
+6 SET FDA(FN,IENS,.04)=$GET(BOPORDN)
+7 SET FDA(FN,IENS,.05)=$GET(BOPTQA)
+8 ;S FDA(FN,IENS,.06)= ;ORDERED BY
+9 ;S FDA(FN,IENS,.07)= ;ORDER TYPE ( PREPAK, OBS, STARTER DOSE, NORMAL OR SUPPLY)
+10 SET FDA(FN,IENS,.08)=$GET(BOPORDN)
+11 ;S FDA(FN,IENS,.1)= ;ITEM NAME
+12 SET FDA(FN,IENS,.09)=BOPERR
+13 SET FDA(FN,IENS,.11)=$GET(BOPDRGI)
+14 ;S FDA(FN,IENS,.12)= ;CHARGE DESCRIPTION
+15 ;QUEUE IEN
SET FDA(FN,IENS,.13)=$GET(BOPI)
+16 DO UPDATE^DIE(,"FDA",,"MSG")
+17 QUIT
