BOPSD ;ILC/IHS/ALG/CIA/PLS - ILC Starter Dose Query ;19-Sep-2006 22:08;SM;
;;1.0;AUTOMATED DISPENSING INTERFACE;**1**;Jul 26, 2005
;
Q:'PSGP Q:'PSGORD
N BOPJ,BOPDFN,BOPWHO,BOPI,BOPMID,BOPORDN,BOPDD0,BOPMED,BOPK,BOPN
N DA,DR,DIE,STA
S BOPDFN=PSGP,BOPORDN=+PSGORD
S BOPWHO=$$INTFACE^BOPTU(1) S BOPWHO=$S(BOPWHO="O":"Omnicell",1:"Pyxis")
F BOPI=0:0 S BOPI=$O(^PS(55,BOPDFN,5,BOPORDN,1,BOPI)) Q:'BOPI D
.S BOPDD0=$G(^PS(55,BOPDFN,5,BOPORDN,1,BOPI,0)) Q:'BOPDD0
.Q:$P(BOPDD0,U,3) ; Check for inactive date
.S STA=$P(^PS(55,BOPDFN,5,BOPORDN,0),U,9)
.Q:STA'="A"&(STA'="R")&(STA'="RE")
.S BOPMID=+$P(BOPDD0,U) Q:'$D(^PSDRUG(BOPMID,0))
.Q:'$D(^BOP(90355.2,"AT",BOPDFN,BOPMID)) ;No entries for medication or already linked
ASK .S BOPK=0
.W !!,"The following items were removed from a "_$G(BOPWHO)_" Medstation."
.W !,?5,"BOPED DRUG",?46,"QUANTITY",?61,"DATE/TIME",!
.K BOPMED
.F BOPJ=0:0 S BOPJ=$O(^BOP(90355.2,"AT",BOPDFN,BOPMID,BOPJ)) Q:BOPJ<1 D
..Q:'$D(^BOP(90355.2,BOPJ,0))
..S BOPK=BOPK+1,BOPMED(BOPK)=BOPJ
..W !,BOPK,?5,$P(^PSDRUG(BOPMID,0),U)
..W ?50,$P(^BOP(90355.2,BOPJ,0),U,5)
..W ?56,$$FMTE^XLFDT($P($G(^BOP(90355.2,BOPJ,0)),U,3),"2Z"),! ;S Y=$P(^BOP(90355.2,BOPJ,0),U,3) X ^DD("DD") W ?56,Y,!
.Q:'BOPK ; No entries to link
.S DIR("A")="If any of the above is a pre-exchange dose for this order, select its number."
.S DIR(0)="N" D ^DIR K DIR Q:$D(DIRUT)
.S BOPN=+Y I '$D(BOPMED(BOPN)) W $C(7) G ASK
.D UPXTRA(BOPDFN,BOPORDN,BOPI,BOPMED(BOPN))
.S DA=BOPMED(BOPN)
.S DIE="^BOP(90355.2,",DR=".04///"_BOPORDN_";.07///@"_";.08///R"
.D ^DIE
Q
;
; Update Extra Units field
UPXTRA(DFN,UORDN,MSEQN,RECDRGI) ;
N DA,DIE,DR
S DA=MSEQN,DA(1)=UORDN,DA(2)=DFN
S DIE="^PS(55,"_DFN_",5,"_UORDN_",1,"
S DR=".11///"_$P(^BOP(90355.2,RECDRGI,0),U,5)
S:$P($G(^PS(55,DFN,5,UORDN,1,MSEQN,0)),"^",11) $P(^(0),"^",11)=""
D ^DIE
Q
; Return linked unit dose order number
; Input:
; DFN - Patient
; MEDIEN - Drug IEN
; Output: Order Number (e.g. 30-1478) or null ("")
GETLINK(DFN,MEDIEN) ; EP
N RES,DA,NODE
S RES=""
S DA=0 F S DA=$O(^BOP(90355.2,"C",DFN,DA)) Q:'DA D Q:RES
.S NODE=^BOP(90355.2,DA,0)
.Q:+NODE'=MEDIEN ; compare medication
.Q:'$P(NODE,U,4) ; lacks an order number
.Q:'$$ISACTIVE(DFN,+$P(NODE,U,4),MEDIEN)
.S RES=$P(NODE,U,4) ; return order number
Q RES
; Return true if unit dose order med is active
; Input: DFN - Patient
; ORDNUM - Unit Dose order number
; MEDIEN - Drug IEN
; Output: Boolean
ISACTIVE(DFN,ORDNUM,MEDIEN) ; EP
N LP,SEQN,NODE,STA
S (SEQN,LP)=0 F S LP=$O(^PS(55,DFN,5,ORDNUM,1,"B",MEDIEN,LP)) Q:'LP D
.S NODE=^PS(55,DFN,5,ORDNUM,1,LP,0)
.Q:$P(NODE,U,3) ; med is inactive
.S STA=$P(^PS(55,DFN,5,ORDNUM,0),U,9)
.I STA="A"!(STA="R")!(STA="RE") D ;Active, Renewed and Reinstated
..S SEQN=LP
Q ''SEQN
; Find entries matching patient and med and not matched to inpatient order
FINDITMS(DFN,MEDIEN,ARY) ;EP
N LP,DA
K ARY
S DA=0 F S DA=$O(^BOP(90355.2,"C",DFN,DA)) Q:'DA D
.S NODE=^BOP(90355.2,DA,0)
.Q:+NODE'=MEDIEN ; compare medication
.Q:$P(NODE,U,4) ; can't have order number
.S ARY(DA)=NODE
Q
; Combine similiar entries into first entry matching patient and med.
COMBINE(DA,ARY) ;EP
Q:'DA
N IEN,QTY
S QTY=$P(^BOP(90355.2,DA,0),U,5)
S IEN=DA F S IEN=$O(ARY(IEN)) Q:'IEN D
.S QTY=QTY+$P(ARY(IEN),U,5)
.D DELITM(IEN)
D UPDITM(DA,QTY)
Q
; Delete combined entry
DELITM(DA) ;EP
N DIK
S DIK="^BOP(90355.2,"
D ^DIK
Q
; Update Qty value of entry
UPDITM(DA,QTY) ;EP
N ERR
S FDA(90355.2,DA_",",.05)=QTY
D FILE^DIE("K","FDA","ERR")
Q
BOPSD ;ILC/IHS/ALG/CIA/PLS - ILC Starter Dose Query ;19-Sep-2006 22:08;SM;
+1 ;;1.0;AUTOMATED DISPENSING INTERFACE;**1**;Jul 26, 2005
+2 ;
+3 IF 'PSGP
QUIT
IF 'PSGORD
QUIT
+4 NEW BOPJ,BOPDFN,BOPWHO,BOPI,BOPMID,BOPORDN,BOPDD0,BOPMED,BOPK,BOPN
+5 NEW DA,DR,DIE,STA
+6 SET BOPDFN=PSGP
SET BOPORDN=+PSGORD
+7 SET BOPWHO=$$INTFACE^BOPTU(1)
SET BOPWHO=$SELECT(BOPWHO="O":"Omnicell",1:"Pyxis")
+8 FOR BOPI=0:0
SET BOPI=$ORDER(^PS(55,BOPDFN,5,BOPORDN,1,BOPI))
IF 'BOPI
QUIT
Begin DoDot:1
+9 SET BOPDD0=$GET(^PS(55,BOPDFN,5,BOPORDN,1,BOPI,0))
IF 'BOPDD0
QUIT
+10 ; Check for inactive date
IF $PIECE(BOPDD0,U,3)
QUIT
+11 SET STA=$PIECE(^PS(55,BOPDFN,5,BOPORDN,0),U,9)
+12 IF STA'="A"&(STA'="R")&(STA'="RE")
QUIT
+13 SET BOPMID=+$PIECE(BOPDD0,U)
IF '$DATA(^PSDRUG(BOPMID,0))
QUIT
+14 ;No entries for medication or already linked
IF '$DATA(^BOP(90355.2,"AT",BOPDFN,BOPMID))
QUIT
ASK SET BOPK=0
+1 WRITE !!,"The following items were removed from a "_$GET(BOPWHO)_" Medstation."
+2 WRITE !,?5,"BOPED DRUG",?46,"QUANTITY",?61,"DATE/TIME",!
+3 KILL BOPMED
+4 FOR BOPJ=0:0
SET BOPJ=$ORDER(^BOP(90355.2,"AT",BOPDFN,BOPMID,BOPJ))
IF BOPJ<1
QUIT
Begin DoDot:2
+5 IF '$DATA(^BOP(90355.2,BOPJ,0))
QUIT
+6 SET BOPK=BOPK+1
SET BOPMED(BOPK)=BOPJ
+7 WRITE !,BOPK,?5,$PIECE(^PSDRUG(BOPMID,0),U)
+8 WRITE ?50,$PIECE(^BOP(90355.2,BOPJ,0),U,5)
+9 ;S Y=$P(^BOP(90355.2,BOPJ,0),U,3) X ^DD("DD") W ?56,Y,!
WRITE ?56,$$FMTE^XLFDT($PIECE($GET(^BOP(90355.2,BOPJ,0)),U,3),"2Z"),!
End DoDot:2
+10 ; No entries to link
IF 'BOPK
QUIT
+11 SET DIR("A")="If any of the above is a pre-exchange dose for this order, select its number."
+12 SET DIR(0)="N"
DO ^DIR
KILL DIR
IF $DATA(DIRUT)
QUIT
+13 SET BOPN=+Y
IF '$DATA(BOPMED(BOPN))
WRITE $CHAR(7)
GOTO ASK
+14 DO UPXTRA(BOPDFN,BOPORDN,BOPI,BOPMED(BOPN))
+15 SET DA=BOPMED(BOPN)
+16 SET DIE="^BOP(90355.2,"
SET DR=".04///"_BOPORDN_";.07///@"_";.08///R"
+17 DO ^DIE
End DoDot:1
+18 QUIT
+19 ;
+20 ; Update Extra Units field
UPXTRA(DFN,UORDN,MSEQN,RECDRGI) ;
+1 NEW DA,DIE,DR
+2 SET DA=MSEQN
SET DA(1)=UORDN
SET DA(2)=DFN
+3 SET DIE="^PS(55,"_DFN_",5,"_UORDN_",1,"
+4 SET DR=".11///"_$PIECE(^BOP(90355.2,RECDRGI,0),U,5)
+5 IF $PIECE($GET(^PS(55,DFN,5,UORDN,1,MSEQN,0)),"^",11)
SET $PIECE(^(0),"^",11)=""
+6 DO ^DIE
+7 QUIT
+8 ; Return linked unit dose order number
+9 ; Input:
+10 ; DFN - Patient
+11 ; MEDIEN - Drug IEN
+12 ; Output: Order Number (e.g. 30-1478) or null ("")
GETLINK(DFN,MEDIEN) ; EP
+1 NEW RES,DA,NODE
+2 SET RES=""
+3 SET DA=0
FOR
SET DA=$ORDER(^BOP(90355.2,"C",DFN,DA))
IF 'DA
QUIT
Begin DoDot:1
+4 SET NODE=^BOP(90355.2,DA,0)
+5 ; compare medication
IF +NODE'=MEDIEN
QUIT
+6 ; lacks an order number
IF '$PIECE(NODE,U,4)
QUIT
+7 IF '$$ISACTIVE(DFN,+$PIECE(NODE,U,4),MEDIEN)
QUIT
+8 ; return order number
SET RES=$PIECE(NODE,U,4)
End DoDot:1
IF RES
QUIT
+9 QUIT RES
+10 ; Return true if unit dose order med is active
+11 ; Input: DFN - Patient
+12 ; ORDNUM - Unit Dose order number
+13 ; MEDIEN - Drug IEN
+14 ; Output: Boolean
ISACTIVE(DFN,ORDNUM,MEDIEN) ; EP
+1 NEW LP,SEQN,NODE,STA
+2 SET (SEQN,LP)=0
FOR
SET LP=$ORDER(^PS(55,DFN,5,ORDNUM,1,"B",MEDIEN,LP))
IF 'LP
QUIT
Begin DoDot:1
+3 SET NODE=^PS(55,DFN,5,ORDNUM,1,LP,0)
+4 ; med is inactive
IF $PIECE(NODE,U,3)
QUIT
+5 SET STA=$PIECE(^PS(55,DFN,5,ORDNUM,0),U,9)
+6 ;Active, Renewed and Reinstated
IF STA="A"!(STA="R")!(STA="RE")
Begin DoDot:2
+7 SET SEQN=LP
End DoDot:2
End DoDot:1
+8 QUIT ''SEQN
+9 ; Find entries matching patient and med and not matched to inpatient order
FINDITMS(DFN,MEDIEN,ARY) ;EP
+1 NEW LP,DA
+2 KILL ARY
+3 SET DA=0
FOR
SET DA=$ORDER(^BOP(90355.2,"C",DFN,DA))
IF 'DA
QUIT
Begin DoDot:1
+4 SET NODE=^BOP(90355.2,DA,0)
+5 ; compare medication
IF +NODE'=MEDIEN
QUIT
+6 ; can't have order number
IF $PIECE(NODE,U,4)
QUIT
+7 SET ARY(DA)=NODE
End DoDot:1
+8 QUIT
+9 ; Combine similiar entries into first entry matching patient and med.
COMBINE(DA,ARY) ;EP
+1 IF 'DA
QUIT
+2 NEW IEN,QTY
+3 SET QTY=$PIECE(^BOP(90355.2,DA,0),U,5)
+4 SET IEN=DA
FOR
SET IEN=$ORDER(ARY(IEN))
IF 'IEN
QUIT
Begin DoDot:1
+5 SET QTY=QTY+$PIECE(ARY(IEN),U,5)
+6 DO DELITM(IEN)
End DoDot:1
+7 DO UPDITM(DA,QTY)
+8 QUIT
+9 ; Delete combined entry
DELITM(DA) ;EP
+1 NEW DIK
+2 SET DIK="^BOP(90355.2,"
+3 DO ^DIK
+4 QUIT
+5 ; Update Qty value of entry
UPDITM(DA,QTY) ;EP
+1 NEW ERR
+2 SET FDA(90355.2,DA_",",.05)=QTY
+3 DO FILE^DIE("K","FDA","ERR")
+4 QUIT
