PSBVDLU1 ;BIRMINGHAM/EFC-VIRTUAL DUE LIST (VDL) UTILITIES ;Mar 2004
;;3.0;BAR CODE MED ADMIN;**13,32**;Mar 2004;Build 32
;
; Reference/IA
; EN^PSJBCMA1/2829
;
ODDSCH(PSBTABX) ;
I (PSBOST'<PSBWBEG)&(PSBOST'>PSBWEND) D ADD(PSBREC,PSBOTXT,PSBOST,PSBDDS,PSBSOLS,PSBADDS,PSBTABX) ;Include start date/time as admin
S PSBQUIT=0,PSBCDT=PSBOST F S PSBCDT=$$FMADD^XLFDT(PSBCDT,"","",PSBFREQ) Q:PSBQUIT=1 D
.I $P(PSBCDT,".",2)="" S PSBCDT=PSBCDT-1_".24"
.I PSBCDT>PSBWEND S PSBQUIT=1 Q
.I PSBCDT'<PSBWBEG,PSBCDT<PSBOSP D ADD(PSBREC,PSBOTXT,PSBCDT,PSBDDS,PSBSOLS,PSBADDS,PSBTABX) Q
Q
GETFREQ(PSBDFN,PSBORDN) ;
K ^TMP("PSJ1",$J)
D EN^PSJBCMA1(PSBDFN,PSBORDN,1)
S PSBFREQ=$P(^TMP("PSJ1",$J,4),U,11)
S PSBSCHBR=$P(^TMP("PSJ1",$J,2),"^",5)
I $$PSBDCHK1^PSBVT1(PSBSCHBR) S PSBFREQ=""
K ^TMP("PSJ1",$J)
Q PSBFREQ
;
GETADMIN(PSBDFN,PSBORDN,PSBSTRT,PSBFREQ,PSBEVDT) ;
;Determine administration times of an odd schedule for today
N PSBADMIN
K ^TMP("PSB",$J,"GETADMIN")
D EN^PSJBCMA1(PSBDFN,PSBORDN,1)
S PSBADMIN=$P(^TMP("PSJ1",$J,4),U,9),PSBFREQ=$P(^TMP("PSJ1",$J,4),U,11),^TMP("PSB",$J,"GETADMIN",0)=PSBADMIN
I $E(PSBFREQ)'?1N K ^TMP("PSJ1",$J) Q $G(^TMP("PSB",$J,"GETADMIN",0))
I PSBFREQ=0 K ^TMP("PSJ1",$J) Q $G(^TMP("PSB",$J,"GETADMIN",0))
I PSBSTRT'<PSBEVDT S PSBADMIN=$E($P(PSBSTRT,".",2)_"0000",1,4),^TMP("PSB",$J,"GETADMIN",0)=PSBADMIN
S PSBCDT=PSBSTRT,(PSBADTMX,PSBQUIT)=0 F S PSBCDT=$$FMADD^XLFDT(PSBCDT,"","",PSBFREQ) D Q:PSBQUIT=1
.I $P(PSBCDT,".",2)="" S PSBCDT=PSBCDT-1_".24"
.I (PSBCDT\1)>(PSBEVDT\1) S PSBQUIT=1 Q
.I (PSBCDT\1)=(PSBEVDT\1) S PSBADMIN=PSBADMIN_$S(PSBADMIN="":"",1:"-")_$E($P(PSBCDT,".",2)_"0000",1,4)
.S ^TMP("PSB",$J,"GETADMIN",PSBADTMX)=PSBADMIN
.S:($L(PSBADMIN)+5)>255 PSBADTMX=PSBADTMX+1,PSBADMIN=""
K ^TMP("PSJ1",$J),PSBADTMX
Q $G(^TMP("PSB",$J,"GETADMIN",0))
;
ADD(PSBREC,PSBSI,PSBDT,PSBDD,PSBSOL,PSBADD,PSBTAB) ;
;
; Description: Add order to ^TMP("PSB",$J,PSBTAB,...) for RPC Return RESULTS
;
; PSBREC=order hdr from above
; PSBSI=special instructions
; PSBDT=admin date/time
; PSBDD=Dispense Drugs
; PSBSOL=Solutions
; PSBADD=Additives
;
N PSB
S PSBDT=$E(PSBDT,1,12),PSBQR=0
S PSB=$O(^TMP("PSB",$J,PSBTAB,""),-1) ; Get next node
S $P(PSBREC,U,14)=PSBDT ; Admin Time sits in ^14
I $P(PSBREC,U,5)'="O" S X=$O(^PSB(53.79,"AORD",DFN,PSBONX,PSBDT,0)) D:X
.S $P(PSBREC,U,12)=X
.K PSBLCK L +^PSB(53.79,X):1 I L -^PSB(53.79,X) S PSBLCK=1
.S PSBSTUS=$P(^PSB(53.79,X,0),U,9),$P(PSBREC,U,13)=$S(PSBSTUS="N":"",(PSBSTUS="")&$G(PSBLCK):"U",1:PSBSTUS),$P(PSBREC,U,23)=$P(^PSB(53.79,X,0),U,10),$P(PSBREC,U,24)=$P(^PSB(53.79,X,0),U,7)
.I $D(^PSB(53.79,X)) I PSBDOSEF="PATCH",PSBSTUS="G",PSBDT=$P(^PSB(53.79,X,.1),U,3),PSBQRR=0 S PSBQR=1
.I PSBSTUS="G",$G(PSBFLAG) D CHECK ;Get the correct dispense drug
I ($P(PSBREC,U,5)="O") D
.S X=$O(^PSB(53.79,"AORDX",DFN,PSBONX,"")) Q:X=""
.S Y=$O(^PSB(53.79,"AORDX",DFN,PSBONX,X,"")) Q:Y="" S $P(PSBREC,U,12)=Y
.K PSBLCK L +^PSB(53.79,Y):1 I L -^PSB(53.79,Y) S PSBLCK=1
.S PSBSTUS=$P(^PSB(53.79,Y,0),U,9),$P(PSBREC,U,13)=$S(PSBSTUS="N":"",(PSBSTUS="")&$G(PSBLCK):"U",1:PSBSTUS),$P(PSBREC,U,24)=$P(^PSB(53.79,Y,0),U,7)
.I $D(^PSB(53.79,Y)) I PSBDOSEF="PATCH",PSBSTUS="G",PSBDT=$P(^PSB(53.79,Y,.1),U,3),PSBQRR=0 S PSBQR=1
.I PSBSTUS="G",$G(PSBFLAG) D CHECK
Q:PSBQR=1
S $P(PSBREC,U,25)=0 I $G(PSBTRFL),$P(PSBREC,U,11)]"",$P(PSBREC,U,11)'<$G(PSBNTDT),$P(PSBREC,U,11)'>$G(PSBTRDT) S $P(PSBREC,U,25)=1
S PSB=PSB+1,^TMP("PSB",$J,PSBTAB,PSB)=PSBREC ; Order Hdr
I $P(PSBREC,U,12)]"" S PSBONVDL($P(PSBREC,U,12))=""
S PSB=PSB+1,^TMP("PSB",$J,PSBTAB,PSB)=PSBSI ; Special Instructions
; add dispense drugs
I $D(PSBDDA) S X="" F S X=$O(PSBDDA(X)) Q:X="" S PSB=PSB+1,^TMP("PSB",$J,PSBTAB,PSB)=PSBDDA(X)
S PSBCHDT=0
I (PSBTAB'["CVRSHT"),(PSBONX["V"),(PSBOSTS="D"),($G(PSBFOR)="") D Q ;get infusing bag from DCed but not DEed orders
.D PSJ^PSBVT(PSBX)
.D INFUSING^PSBVDLU2 I PSBCOMP=0 Q
.I $D(PSBSOLA) S X="" F S X=$O(PSBSOLA(X)) Q:X="" S PSB=PSB+1,^TMP("PSB",$J,PSBTAB,PSB)=PSBSOLA(X)
.I $D(PSBADA) S X="" F S X=$O(PSBADA(X)) Q:X="" S PSB=PSB+1,^TMP("PSB",$J,PSBTAB,PSB)=PSBADA(X)
.S X="" F S X=$O(PSBPORA(PSBONX,X)) S PSBUID=$P(PSBPORA(PSBONX,X),U,1) Q:PSBUID]"" Q:X=""
.I PSBUID["P" Q
.I PSBUID["WS" D
..S PSBNODE=$O(^PSB(53.79,"AUID",DFN,X,PSBUID,""))
..S PSBUIDA(PSBUID)="ID"_U_PSBUID
..S X=0 F S X=$O(^PSB(53.79,PSBNODE,.6,X)) Q:'X S PSBUIDA(PSBUID)=PSBUIDA(PSBUID)_U_"ADD;"_$P(^PSB(53.79,PSBNODE,.6,X,0),U,1)
..S X=0 F S X=$O(^PSB(53.79,PSBNODE,.7,X)) Q:'X S PSBUIDA(PSBUID)=PSBUIDA(PSBUID)_U_"SOL;"_$P(^PSB(53.79,PSBNODE,.7,X,0),U,1)
.S PSBSONX=PSBONX
.I '$D(PSBUIDA(PSBUID)) S PSBCKOR="" F S PSBCKOR=$O(PSBPORA(PSBSONX,PSBCKOR)) Q:PSBCKOR="" D CLEAN^PSBVT,PSJ1^PSBVT(DFN,PSBCKOR) Q:$D(PSBUIDA(PSBUID))
.S PSBONX=PSBSONX
.S:$D(PSBUIDA(PSBUID)) PSB=PSB+2,^TMP("PSB",$J,PSBTAB,PSB-1)=PSBUIDA(PSBUID),^TMP("PSB",$J,PSBTAB,PSB)="END"
.D CLEAN^PSBVT,PSJ1^PSBVT(DFN,$O(PSBPORA("")))
; add additives
I $D(PSBADA) S X="" F S X=$O(PSBADA(X)) Q:X="" S PSB=PSB+1,^TMP("PSB",$J,PSBTAB,PSB)=PSBADA(X)
; add solutions
I $D(PSBSOLA) S X="" F S X=$O(PSBSOLA(X)) Q:X="" S $P(PSBSOLA(X),U,5)="",PSB=PSB+1,^TMP("PSB",$J,PSBTAB,PSB)=PSBSOLA(X)
I PSBONX["V" D EN^PSBPOIV(DFN,PSBONX) ; get bags
I $D(^TMP("PSBAR",$J)) S PSBUID=DFN_"V"_99999 F S PSBUID=$O(^TMP("PSBAR",$J,PSBUID),-1) Q:PSBUID="" D
.S PSBUIDS=^TMP("PSBAR",$J,PSBUID)
.I $P(PSBUIDS,U,1)="I",$P(PSBUIDS,U,2)'="I",$P(PSBUIDS,U,2)'="S" Q ; bag has invalid IV parameter, is not infusing or stopped
.I $P(PSBUIDS,U,2)'="I",$P(PSBUIDS,U,2)'="S",$P(PSBUIDS,U,8)'="" Q ; label is no longer valid, bag is not infusing or stopped
.I $P(PSBUIDS,U,2)="C" Q ; bag is completed
.I $P(PSBUIDS,U,2)="G" Q ; bag is given (PBTAB)
.S PSB=PSB+1,^TMP("PSB",$J,PSBTAB,PSB)=$P(PSBUIDS,U,10,999)
K ^TMP("PSBAR",$J)
S PSB=PSB+1,^TMP("PSB",$J,PSBTAB,PSB)="END"
S ^TMP("PSB",$J,PSBTAB,0)=PSB
Q
;
CHECK S FILE=53.795,PSBNODE=.5,PSBIENS=X_","
F I=0:0 S I=$O(^PSB(53.79,X,PSBNODE,I)) Q:'I S $P(PSBDDS,U,3,4)=$$GET1^DIQ(FILE,I_","_PSBIENS,.01,"I")_U_$$GET1^DIQ(FILE,I_","_PSBIENS,.01)
Q
;
VNURSE(PSBTAB) ;add initials of verifying pharmacist/verifying nurse
F PSBLP=1:1:$P(^TMP("PSB",$J,PSBTAB,0),U,1) S X=^TMP("PSB",$J,PSBTAB,PSBLP) I $P(X,U)=DFN D
.K ^TMP("PSJ1",$J)
.D PSJ1^PSBVT(DFN,$P(X,U,2))
.S $P(^TMP("PSB",$J,PSBTAB,PSBLP),U,19)=$S(PSBVNI]"":PSBVNI,1:"***")
K PSBLP,PSBTAB
Q
;
OKAY(PSBSTRT,PSBADMIN,PSBSCH,PSBORDER,PSBDRUG,PSBFREQ,PSBOSTS) ;
;
; Description: Determines if an order schedule is valid for
; the date in PSBADMIN (i.e. Q4D, is it valid today)
;
; PSBSTRT: Start Date of order (Time ignored)
; PSBADMIN: Date of administration to check (Time ignored)
; PSBSCH: Schedule (i.e. MO-WE-FR@0900 or Q48H...)
; PSBORDER: Order reference
; PSBDRUG: Drug ordered (Orderable Item)
; PSBOSTS: The status of the order
;
N PSBOKAY,PSBDAYS,PSBDOW
S PSBOSTS=$G(PSBOSTS)
;
S PSBOKAY=0 ; Default Flag
I PSBFREQ'="",PSBFREQ'="D",PSBFREQ'>1440 Q 1
;PRN and ONE TIMES show everyday
I (PSBSCHT="P")!(PSBSCHT="O") Q 1
S PSBDAYS=$$DAYS(PSBSCH)
;
I PSBDAYS=1 S PSBOKAY=1 Q PSBOKAY ; Order is everyday
;
; find out if today is a good day for multi days
S PSBOKAY=0,PSBRDTE=PSBSTRT
S PSBADBR=PSBADMIN\1
S PSBENR=(PSBADMIN\1)+1
I PSBDAYS>1 D Q PSBOKAY
.I PSBADBR=(PSBSTRT\1) S PSBOKAY=1
.F S PSBRDTE=$$FMADD^XLFDT(PSBRDTE,"","",PSBFREQ) Q:PSBRDTE>PSBENR D
..I $P(PSBRDTE,".",2)="" S PSBRDTE=PSBRDTE-1_".24"
..I PSBRDTE\1=PSBADBR S PSBOKAY=1
..I PSBOKAY="1" Q
;
; Try the MO-WE-FR@0800 thing as last resort
S X=PSBADMIN D H^%DTC I %Y=-1 D Q PSBOKAY ; Error
.S PSBOKAY=0
.Q:PSBOSTS="E"
.Q:$G(PSBMHND)="PSBOMH"
.D ERROR^PSBMLU($G(PSBORDER,"UNKNOWN"),$G(PSBDRUG,""),DFN,"Unable to determine schedule "_PSBSCH,PSBSCH)
S PSBDOW=$P("SU^MO^TU^WE^TH^FR^SA",U,%Y+1)
I $F(PSBSCH,PSBDOW)>0 S PSBOKAY=1 Q PSBOKAY
S PSBOKAY=0
Q PSBOKAY
;
DAYS(PSB) ; Return days between doses (-1: error, 1:everyday 2: QOD...)
;
; Is it a PRN
I PSB?.E1"PRN".E Q 1 ; Straight PRN - As Needed
;
S PSB=$TR(PSB," ","")
I PSB?2.4N.E Q 1
S X=PSBFREQ/1440 Q X
;
Q
;
LAST ;
S PSBCC=0
S ZZ="" F S ZZ=$O(^PSB(53.79,X,.3,ZZ),-1) Q:'ZZ Q:PSBFLAG=1 S PSBDATA2=$G(^(ZZ,0)) D
.S PSBCC=PSBCC+1
.I (PSBCC=2)!($P($P(PSBDATA2,U)," ")="Refused:")!($P($P(PSBDATA2,U)," ")="Held:") S $P(PSBREC,U,11)=$P(PSBDATA2,U,3),PSBFLAG=1
Q
;
PSBVDLU1 ;BIRMINGHAM/EFC-VIRTUAL DUE LIST (VDL) UTILITIES ;Mar 2004
+1 ;;3.0;BAR CODE MED ADMIN;**13,32**;Mar 2004;Build 32
+2 ;
+3 ; Reference/IA
+4 ; EN^PSJBCMA1/2829
+5 ;
ODDSCH(PSBTABX) ;
+1 ;Include start date/time as admin
IF (PSBOST'<PSBWBEG)&(PSBOST'>PSBWEND)
DO ADD(PSBREC,PSBOTXT,PSBOST,PSBDDS,PSBSOLS,PSBADDS,PSBTABX)
+2 SET PSBQUIT=0
SET PSBCDT=PSBOST
FOR
SET PSBCDT=$$FMADD^XLFDT(PSBCDT,"","",PSBFREQ)
IF PSBQUIT=1
QUIT
Begin DoDot:1
+3 IF $PIECE(PSBCDT,".",2)=""
SET PSBCDT=PSBCDT-1_".24"
+4 IF PSBCDT>PSBWEND
SET PSBQUIT=1
QUIT
+5 IF PSBCDT'<PSBWBEG
IF PSBCDT<PSBOSP
DO ADD(PSBREC,PSBOTXT,PSBCDT,PSBDDS,PSBSOLS,PSBADDS,PSBTABX)
QUIT
End DoDot:1
+6 QUIT
GETFREQ(PSBDFN,PSBORDN) ;
+1 KILL ^TMP("PSJ1",$JOB)
+2 DO EN^PSJBCMA1(PSBDFN,PSBORDN,1)
+3 SET PSBFREQ=$PIECE(^TMP("PSJ1",$JOB,4),U,11)
+4 SET PSBSCHBR=$PIECE(^TMP("PSJ1",$JOB,2),"^",5)
+5 IF $$PSBDCHK1^PSBVT1(PSBSCHBR)
SET PSBFREQ=""
+6 KILL ^TMP("PSJ1",$JOB)
+7 QUIT PSBFREQ
+8 ;
GETADMIN(PSBDFN,PSBORDN,PSBSTRT,PSBFREQ,PSBEVDT) ;
+1 ;Determine administration times of an odd schedule for today
+2 NEW PSBADMIN
+3 KILL ^TMP("PSB",$JOB,"GETADMIN")
+4 DO EN^PSJBCMA1(PSBDFN,PSBORDN,1)
+5 SET PSBADMIN=$PIECE(^TMP("PSJ1",$JOB,4),U,9)
SET PSBFREQ=$PIECE(^TMP("PSJ1",$JOB,4),U,11)
SET ^TMP("PSB",$JOB,"GETADMIN",0)=PSBADMIN
+6 IF $EXTRACT(PSBFREQ)'?1N
KILL ^TMP("PSJ1",$JOB)
QUIT $GET(^TMP("PSB",$JOB,"GETADMIN",0))
+7 IF PSBFREQ=0
KILL ^TMP("PSJ1",$JOB)
QUIT $GET(^TMP("PSB",$JOB,"GETADMIN",0))
+8 IF PSBSTRT'<PSBEVDT
SET PSBADMIN=$EXTRACT($PIECE(PSBSTRT,".",2)_"0000",1,4)
SET ^TMP("PSB",$JOB,"GETADMIN",0)=PSBADMIN
+9 SET PSBCDT=PSBSTRT
SET (PSBADTMX,PSBQUIT)=0
FOR
SET PSBCDT=$$FMADD^XLFDT(PSBCDT,"","",PSBFREQ)
Begin DoDot:1
+10 IF $PIECE(PSBCDT,".",2)=""
SET PSBCDT=PSBCDT-1_".24"
+11 IF (PSBCDT\1)>(PSBEVDT\1)
SET PSBQUIT=1
QUIT
+12 IF (PSBCDT\1)=(PSBEVDT\1)
SET PSBADMIN=PSBADMIN_$SELECT(PSBADMIN="":"",1:"-")_$EXTRACT($PIECE(PSBCDT,".",2)_"0000",1,4)
+13 SET ^TMP("PSB",$JOB,"GETADMIN",PSBADTMX)=PSBADMIN
+14 IF ($LENGTH(PSBADMIN)+5)>255
SET PSBADTMX=PSBADTMX+1
SET PSBADMIN=""
End DoDot:1
IF PSBQUIT=1
QUIT
+15 KILL ^TMP("PSJ1",$JOB),PSBADTMX
+16 QUIT $GET(^TMP("PSB",$JOB,"GETADMIN",0))
+17 ;
ADD(PSBREC,PSBSI,PSBDT,PSBDD,PSBSOL,PSBADD,PSBTAB) ;
+1 ;
+2 ; Description: Add order to ^TMP("PSB",$J,PSBTAB,...) for RPC Return RESULTS
+3 ;
+4 ; PSBREC=order hdr from above
+5 ; PSBSI=special instructions
+6 ; PSBDT=admin date/time
+7 ; PSBDD=Dispense Drugs
+8 ; PSBSOL=Solutions
+9 ; PSBADD=Additives
+10 ;
+11 NEW PSB
+12 SET PSBDT=$EXTRACT(PSBDT,1,12)
SET PSBQR=0
+13 ; Get next node
SET PSB=$ORDER(^TMP("PSB",$JOB,PSBTAB,""),-1)
+14 ; Admin Time sits in ^14
SET $PIECE(PSBREC,U,14)=PSBDT
+15 IF $PIECE(PSBREC,U,5)'="O"
SET X=$ORDER(^PSB(53.79,"AORD",DFN,PSBONX,PSBDT,0))
IF X
Begin DoDot:1
+16 SET $PIECE(PSBREC,U,12)=X
+17 KILL PSBLCK
LOCK +^PSB(53.79,X):1
IF $TEST
LOCK -^PSB(53.79,X)
SET PSBLCK=1
+18 SET PSBSTUS=$PIECE(^PSB(53.79,X,0),U,9)
SET $PIECE(PSBREC,U,13)=$SELECT(PSBSTUS="N":"",(PSBSTUS="")&$GET(PSBLCK):"U",1:PSBSTUS)
SET $PIECE(PSBREC,U,23)=$PIECE(^PSB(53.79,X,0),U,10)
SET $PIECE(PSBREC,U,24)=$PIECE(^PSB(53.79,X,0),U,7)
+19 IF $DATA(^PSB(53.79,X))
IF PSBDOSEF="PATCH"
IF PSBSTUS="G"
IF PSBDT=$PIECE(^PSB(53.79,X,.1),U,3)
IF PSBQRR=0
SET PSBQR=1
+20 ;Get the correct dispense drug
IF PSBSTUS="G"
IF $GET(PSBFLAG)
DO CHECK
End DoDot:1
+21 IF ($PIECE(PSBREC,U,5)="O")
Begin DoDot:1
+22 SET X=$ORDER(^PSB(53.79,"AORDX",DFN,PSBONX,""))
IF X=""
QUIT
+23 SET Y=$ORDER(^PSB(53.79,"AORDX",DFN,PSBONX,X,""))
IF Y=""
QUIT
SET $PIECE(PSBREC,U,12)=Y
+24 KILL PSBLCK
LOCK +^PSB(53.79,Y):1
IF $TEST
LOCK -^PSB(53.79,Y)
SET PSBLCK=1
+25 SET PSBSTUS=$PIECE(^PSB(53.79,Y,0),U,9)
SET $PIECE(PSBREC,U,13)=$SELECT(PSBSTUS="N":"",(PSBSTUS="")&$GET(PSBLCK):"U",1:PSBSTUS)
SET $PIECE(PSBREC,U,24)=$PIECE(^PSB(53.79,Y,0),U,7)
+26 IF $DATA(^PSB(53.79,Y))
IF PSBDOSEF="PATCH"
IF PSBSTUS="G"
IF PSBDT=$PIECE(^PSB(53.79,Y,.1),U,3)
IF PSBQRR=0
SET PSBQR=1
+27 IF PSBSTUS="G"
IF $GET(PSBFLAG)
DO CHECK
End DoDot:1
+28 IF PSBQR=1
QUIT
+29 SET $PIECE(PSBREC,U,25)=0
IF $GET(PSBTRFL)
IF $PIECE(PSBREC,U,11)]""
IF $PIECE(PSBREC,U,11)'<$GET(PSBNTDT)
IF $PIECE(PSBREC,U,11)'>$GET(PSBTRDT)
SET $PIECE(PSBREC,U,25)=1
+30 ; Order Hdr
SET PSB=PSB+1
SET ^TMP("PSB",$JOB,PSBTAB,PSB)=PSBREC
+31 IF $PIECE(PSBREC,U,12)]""
SET PSBONVDL($PIECE(PSBREC,U,12))=""
+32 ; Special Instructions
SET PSB=PSB+1
SET ^TMP("PSB",$JOB,PSBTAB,PSB)=PSBSI
+33 ; add dispense drugs
+34 IF $DATA(PSBDDA)
SET X=""
FOR
SET X=$ORDER(PSBDDA(X))
IF X=""
QUIT
SET PSB=PSB+1
SET ^TMP("PSB",$JOB,PSBTAB,PSB)=PSBDDA(X)
+35 SET PSBCHDT=0
+36 ;get infusing bag from DCed but not DEed orders
IF (PSBTAB'["CVRSHT")
IF (PSBONX["V")
IF (PSBOSTS="D")
IF ($GET(PSBFOR)="")
Begin DoDot:1
+37 DO PSJ^PSBVT(PSBX)
+38 DO INFUSING^PSBVDLU2
IF PSBCOMP=0
QUIT
+39 IF $DATA(PSBSOLA)
SET X=""
FOR
SET X=$ORDER(PSBSOLA(X))
IF X=""
QUIT
SET PSB=PSB+1
SET ^TMP("PSB",$JOB,PSBTAB,PSB)=PSBSOLA(X)
+40 IF $DATA(PSBADA)
SET X=""
FOR
SET X=$ORDER(PSBADA(X))
IF X=""
QUIT
SET PSB=PSB+1
SET ^TMP("PSB",$JOB,PSBTAB,PSB)=PSBADA(X)
+41 SET X=""
FOR
SET X=$ORDER(PSBPORA(PSBONX,X))
SET PSBUID=$PIECE(PSBPORA(PSBONX,X),U,1)
IF PSBUID]""
QUIT
IF X=""
QUIT
+42 IF PSBUID["P"
QUIT
+43 IF PSBUID["WS"
Begin DoDot:2
+44 SET PSBNODE=$ORDER(^PSB(53.79,"AUID",DFN,X,PSBUID,""))
+45 SET PSBUIDA(PSBUID)="ID"_U_PSBUID
+46 SET X=0
FOR
SET X=$ORDER(^PSB(53.79,PSBNODE,.6,X))
IF 'X
QUIT
SET PSBUIDA(PSBUID)=PSBUIDA(PSBUID)_U_"ADD;"_$PIECE(^PSB(53.79,PSBNODE,.6,X,0),U,1)
+47 SET X=0
FOR
SET X=$ORDER(^PSB(53.79,PSBNODE,.7,X))
IF 'X
QUIT
SET PSBUIDA(PSBUID)=PSBUIDA(PSBUID)_U_"SOL;"_$PIECE(^PSB(53.79,PSBNODE,.7,X,0),U,1)
End DoDot:2
+48 SET PSBSONX=PSBONX
+49 IF '$DATA(PSBUIDA(PSBUID))
SET PSBCKOR=""
FOR
SET PSBCKOR=$ORDER(PSBPORA(PSBSONX,PSBCKOR))
IF PSBCKOR=""
QUIT
DO CLEAN^PSBVT
DO PSJ1^PSBVT(DFN,PSBCKOR)
IF $DATA(PSBUIDA(PSBUID))
QUIT
+50 SET PSBONX=PSBSONX
+51 IF $DATA(PSBUIDA(PSBUID))
SET PSB=PSB+2
SET ^TMP("PSB",$JOB,PSBTAB,PSB-1)=PSBUIDA(PSBUID)
SET ^TMP("PSB",$JOB,PSBTAB,PSB)="END"
+52 DO CLEAN^PSBVT
DO PSJ1^PSBVT(DFN,$ORDER(PSBPORA("")))
End DoDot:1
QUIT
+53 ; add additives
+54 IF $DATA(PSBADA)
SET X=""
FOR
SET X=$ORDER(PSBADA(X))
IF X=""
QUIT
SET PSB=PSB+1
SET ^TMP("PSB",$JOB,PSBTAB,PSB)=PSBADA(X)
+55 ; add solutions
+56 IF $DATA(PSBSOLA)
SET X=""
FOR
SET X=$ORDER(PSBSOLA(X))
IF X=""
QUIT
SET $PIECE(PSBSOLA(X),U,5)=""
SET PSB=PSB+1
SET ^TMP("PSB",$JOB,PSBTAB,PSB)=PSBSOLA(X)
+57 ; get bags
IF PSBONX["V"
DO EN^PSBPOIV(DFN,PSBONX)
+58 IF $DATA(^TMP("PSBAR",$JOB))
SET PSBUID=DFN_"V"_99999
FOR
SET PSBUID=$ORDER(^TMP("PSBAR",$JOB,PSBUID),-1)
IF PSBUID=""
QUIT
Begin DoDot:1
+59 SET PSBUIDS=^TMP("PSBAR",$JOB,PSBUID)
+60 ; bag has invalid IV parameter, is not infusing or stopped
IF $PIECE(PSBUIDS,U,1)="I"
IF $PIECE(PSBUIDS,U,2)'="I"
IF $PIECE(PSBUIDS,U,2)'="S"
QUIT
+61 ; label is no longer valid, bag is not infusing or stopped
IF $PIECE(PSBUIDS,U,2)'="I"
IF $PIECE(PSBUIDS,U,2)'="S"
IF $PIECE(PSBUIDS,U,8)'=""
QUIT
+62 ; bag is completed
IF $PIECE(PSBUIDS,U,2)="C"
QUIT
+63 ; bag is given (PBTAB)
IF $PIECE(PSBUIDS,U,2)="G"
QUIT
+64 SET PSB=PSB+1
SET ^TMP("PSB",$JOB,PSBTAB,PSB)=$PIECE(PSBUIDS,U,10,999)
End DoDot:1
+65 KILL ^TMP("PSBAR",$JOB)
+66 SET PSB=PSB+1
SET ^TMP("PSB",$JOB,PSBTAB,PSB)="END"
+67 SET ^TMP("PSB",$JOB,PSBTAB,0)=PSB
+68 QUIT
+69 ;
CHECK SET FILE=53.795
SET PSBNODE=.5
SET PSBIENS=X_","
+1 FOR I=0:0
SET I=$ORDER(^PSB(53.79,X,PSBNODE,I))
IF 'I
QUIT
SET $PIECE(PSBDDS,U,3,4)=$$GET1^DIQ(FILE,I_","_PSBIENS,.01,"I")_U_$$GET1^DIQ(FILE,I_","_PSBIENS,.01)
+2 QUIT
+3 ;
VNURSE(PSBTAB) ;add initials of verifying pharmacist/verifying nurse
+1 FOR PSBLP=1:1:$PIECE(^TMP("PSB",$JOB,PSBTAB,0),U,1)
SET X=^TMP("PSB",$JOB,PSBTAB,PSBLP)
IF $PIECE(X,U)=DFN
Begin DoDot:1
+2 KILL ^TMP("PSJ1",$JOB)
+3 DO PSJ1^PSBVT(DFN,$PIECE(X,U,2))
+4 SET $PIECE(^TMP("PSB",$JOB,PSBTAB,PSBLP),U,19)=$SELECT(PSBVNI]"":PSBVNI,1:"***")
End DoDot:1
+5 KILL PSBLP,PSBTAB
+6 QUIT
+7 ;
OKAY(PSBSTRT,PSBADMIN,PSBSCH,PSBORDER,PSBDRUG,PSBFREQ,PSBOSTS) ;
+1 ;
+2 ; Description: Determines if an order schedule is valid for
+3 ; the date in PSBADMIN (i.e. Q4D, is it valid today)
+4 ;
+5 ; PSBSTRT: Start Date of order (Time ignored)
+6 ; PSBADMIN: Date of administration to check (Time ignored)
+7 ; PSBSCH: Schedule (i.e. MO-WE-FR@0900 or Q48H...)
+8 ; PSBORDER: Order reference
+9 ; PSBDRUG: Drug ordered (Orderable Item)
+10 ; PSBOSTS: The status of the order
+11 ;
+12 NEW PSBOKAY,PSBDAYS,PSBDOW
+13 SET PSBOSTS=$GET(PSBOSTS)
+14 ;
+15 ; Default Flag
SET PSBOKAY=0
+16 IF PSBFREQ'=""
IF PSBFREQ'="D"
IF PSBFREQ'>1440
QUIT 1
+17 ;PRN and ONE TIMES show everyday
+18 IF (PSBSCHT="P")!(PSBSCHT="O")
QUIT 1
+19 SET PSBDAYS=$$DAYS(PSBSCH)
+20 ;
+21 ; Order is everyday
IF PSBDAYS=1
SET PSBOKAY=1
QUIT PSBOKAY
+22 ;
+23 ; find out if today is a good day for multi days
+24 SET PSBOKAY=0
SET PSBRDTE=PSBSTRT
+25 SET PSBADBR=PSBADMIN\1
+26 SET PSBENR=(PSBADMIN\1)+1
+27 IF PSBDAYS>1
Begin DoDot:1
+28 IF PSBADBR=(PSBSTRT\1)
SET PSBOKAY=1
+29 FOR
SET PSBRDTE=$$FMADD^XLFDT(PSBRDTE,"","",PSBFREQ)
IF PSBRDTE>PSBENR
QUIT
Begin DoDot:2
+30 IF $PIECE(PSBRDTE,".",2)=""
SET PSBRDTE=PSBRDTE-1_".24"
+31 IF PSBRDTE\1=PSBADBR
SET PSBOKAY=1
+32 IF PSBOKAY="1"
QUIT
End DoDot:2
End DoDot:1
QUIT PSBOKAY
+33 ;
+34 ; Try the MO-WE-FR@0800 thing as last resort
+35 ; Error
SET X=PSBADMIN
DO H^%DTC
IF %Y=-1
Begin DoDot:1
+36 SET PSBOKAY=0
+37 IF PSBOSTS="E"
QUIT
+38 IF $GET(PSBMHND)="PSBOMH"
QUIT
+39 DO ERROR^PSBMLU($GET(PSBORDER,"UNKNOWN"),$GET(PSBDRUG,""),DFN,"Unable to determine schedule "_PSBSCH,PSBSCH)
End DoDot:1
QUIT PSBOKAY
+40 SET PSBDOW=$PIECE("SU^MO^TU^WE^TH^FR^SA",U,%Y+1)
+41 IF $FIND(PSBSCH,PSBDOW)>0
SET PSBOKAY=1
QUIT PSBOKAY
+42 SET PSBOKAY=0
+43 QUIT PSBOKAY
+44 ;
DAYS(PSB) ; Return days between doses (-1: error, 1:everyday 2: QOD...)
+1 ;
+2 ; Is it a PRN
+3 ; Straight PRN - As Needed
IF PSB?.E1"PRN".E
QUIT 1
+4 ;
+5 SET PSB=$TRANSLATE(PSB," ","")
+6 IF PSB?2.4N.E
QUIT 1
+7 SET X=PSBFREQ/1440
QUIT X
+8 ;
+9 QUIT
+10 ;
LAST ;
+1 SET PSBCC=0
+2 SET ZZ=""
FOR
SET ZZ=$ORDER(^PSB(53.79,X,.3,ZZ),-1)
IF 'ZZ
QUIT
IF PSBFLAG=1
QUIT
SET PSBDATA2=$GET(^(ZZ,0))
Begin DoDot:1
+3 SET PSBCC=PSBCC+1
+4 IF (PSBCC=2)!($PIECE($PIECE(PSBDATA2,U)," ")="Refused:")!($PIECE($PIECE(PSBDATA2,U)," ")="Held:")
SET $PIECE(PSBREC,U,11)=$PIECE(PSBDATA2,U,3)
SET PSBFLAG=1
End DoDot:1
+5 QUIT
+6 ;
