PSBVDLVL ;BIRMINGHAM/EFC-BCMA VIRTUAL DUE LIST FUNCTIONS ;Mar 2004
;;3.0;BAR CODE MED ADMIN;**6,3,12,11,13,32,25**;Mar 2004;Build 6
;Per VHA Directive 2004-038 (or future revisions regarding same), this routine should not be modified.
;
;
; Reference/IA
; $$GET^XPAR/2263
;
EN(RESULTS,DFN,PSBXOR,PSBTYPE,PSBADMIN,PSBTAB,PSBUID,PSBASTS,PSBORSTS,PSBRMV) ;
;
; RPC: PSB VALIDATE ORDER
;
; Description: Final check of order against an actual administration
; date/time used immediately after scanned med has been
; validated to be a good un-administered order.
;
K PSBTST
N PSBFLAG
I PSBRMV="I" D GETOHIST^PSBRPC2(.PSBTST,DFN,PSBXOR_PSBTYPE) S I=0 F S I=$O(PSBTST(I)) Q:I="" I $P(PSBTST(I),U,5)="I" S RESULTS(0)=1,RESULTS(1)="-2^" K PSBTST Q
K PSBOKAY D CLEAN^PSBVT,PSJ1^PSBVT(DFN,PSBXOR_PSBTYPE) S PSB=0
S RESULTS(0)=1,RESULTS(1)="-1^***Unable to determine administration" ; Default Flag will be overwritten by anything
D NOW^%DTC
I ((PSBOSTS="A")!(PSBOSTS="R"))&(PSBOSP<%) S PSBOSTS="E"
I PSBORSTS'=PSBOSTS,((PSBSCHT'="O")&(PSBOSTS'="E")) S PSB=PSB+1,RESULTS(0)=PSB,RESULTS(PSB)="-2^ORDER STATUS MISMATCH" Q
I ((PSBTAB="UDTAB")!(PSBTAB="PBTAB")),((PSBRMV="RM")!(PSBRMV="N")) D Q
.S PSB=PSB+1,RESULTS(0)=PSB,RESULTS(PSB)="0^OKAY TO REMOVE" ; patch removal does not follow rest of validte rules
.I PSBASTS="" Q ;status is not given - don't check for missmatch
.I $D(^PSB(53.79,"AORD",DFN,PSBXOR_PSBTYPE,+PSBADMIN)) S X=$O(^PSB(53.79,"AORD",DFN,PSBXOR_PSBTYPE,+PSBADMIN,"")) I $P($G(^PSB(53.79,+X,0)),U,9)'=PSBASTS S PSB=PSB+1,RESULTS(0)=PSB,RESULTS(PSB)="-2^Admin status mismatch"
I PSBTYPE="V",PSBSCHT'="P",((PSBUID="")!(PSBUID["WS")) S RESULTS(0)=1,RESULTS(1)="0^Okay to administer" Q:PSBTAB="IVTAB"
I PSBTYPE="V",PSBUID'="" D Q:PSBTAB="IVTAB" ; validate IV bags Piggybacks have additional tests
.S PSB=0,PSBSUID=PSBUID D EN^PSBPOIV(DFN,PSBXOR_PSBTYPE)
.S X="" F S X=$O(^TMP("PSBAR",$J,X)) Q:X="" D
..I PSBSUID'=X Q
..S PSBUIDS=^TMP("PSBAR",$J,X)
..I $P(PSBUIDS,U,2)="I"!($P(PSBUIDS,U,2)="S") S PSB=PSB+1,RESULTS(0)=PSB,RESULTS(PSB)="0^Okay to administer" Q ; is infusing or stopped
..I $P(PSBUIDS,U,1)="I" S Y=$P(^TMP("PSBAR",$J,"I"),U,2) D DD^%DT S PSB=PSB+1,RESULTS(0)=PSB,RESULTS(PSB)=$P(^TMP("PSBAR",$J,"I"),U,3,99)_" "_Y Q
..I $P(PSBUIDS,U,1)["W" S PSBWS=$P(PSBUIDS,U,1) F PSBWM=2:1 Q:$P(PSBWS,";",PSBWM)="" D
...S Y=$P(^TMP("PSBAR",$J,"W",$P(PSBWS,";",PSBWM)),U,2) D DD^%DT S PSB=PSB+1,RESULTS(0)=PSB,RESULTS(PSB)=$P(^TMP("PSBAR",$J,"W",$P(PSBWS,";",PSBWM)),U,3,99)_" "_Y
..S PSB=PSB+1,RESULTS(0)=PSB,RESULTS(PSB)="0^Okay to administer"
.K ^TMP("PSBAR",$J)
;
; no IV orders
;
D NOW^%DTC
I PSBOSTS="H" S PSB=PSB+1,RESULTS(0)=PSB,RESULTS(PSB)="0^Order is on Provider Hold" Q
I PSBSCHT'="O"&(%<($$FMADD^XLFDT(PSBOST,"","",$$GET^XPAR("ALL","PSB ADMIN BEFORE")*-1))) S PSB=PSB+1,RESULTS(0)=PSB,RESULTS(PSB)="-1^Order Not Active" Q
I (%>PSBOSP) S PSB=PSB+1,RESULTS(0)=PSB,RESULTS(PSB)="-1^Order Not Active" Q
I (PSBSCHT="C")!((PSBSCHT="P")&(PSBDOSEF="PATCH")) D
.S PSBOKAY="0^Okay to administer"
.I PSBASTS["*UNKNOWN*" S PSBOKAY="-1^This administration has *UNKNOWN* status" Q
.I PSBOSTS'="A",PSBOSTS'="R",PSBOSTS'="O" S PSBOKAY="-1^Order Not Active" Q
.I PSBNGF S PSBOKAY="-1^marked DO NOT GIVE" Q
.S PSBFLAG=0 I PSBRMV="M"!(PSBRMV="H")!(PSBRMV="R") S PSBFLAG=1
.I $D(^PSB(53.79,"AORDX",DFN,PSBXOR_PSBTYPE)) D Q:X
..S X=0,PSBLADT=$O(^PSB(53.79,"AORDX",DFN,PSBXOR_PSBTYPE,""),-1),PSBLAIEN=$O(^PSB(53.79,"AORDX",DFN,PSBXOR_PSBTYPE,PSBLADT,""),-1)
..I $P($G(^PSB(53.79,PSBLAIEN,0)),U,9)="G",$P($G(^PSB(53.79,PSBLAIEN,.5,1,0)),U,4)="PATCH",PSBFLAG=0 S X=1,PSBOKAY="-1^Previous patch has not been removed" Q
.I $D(^PSB(53.79,"AORD",DFN,PSBXOR_PSBTYPE,+PSBADMIN)) D Q:+PSBOKAY<0
..S X=$O(^PSB(53.79,"AORD",DFN,PSBXOR_PSBTYPE,+PSBADMIN,""))
..L +^PSB(53.79,+X):1
..I L -^PSB(53.79,+X)
..E S PSBOKAY="-1^The "_$$GET1^DIQ(53.79,+X_",",.13)_" administration is being edited by another" Q
..I $G(PSBASTS)]"" D Q:+PSBOKAY<0
...I $P($G(^PSB(53.79,+X,0)),U,9)="" Q
...I $P($G(^PSB(53.79,+X,0)),U,9)'=PSBASTS S PSBOKAY="-2^Admin status mismatch" Q
.; Minutes before
.S PSBWIN1=$$GET^XPAR("DIV","PSB ADMIN BEFORE")*-1
.; Minutes After
.S PSBWIN2=$$GET^XPAR("DIV","PSB ADMIN AFTER")
.D NOW^%DTC S PSBMIN=$$DIFF^PSBUTL(PSBADMIN,%)
.; PENDING A PC SOLUTION!
.I PSBMIN<PSBWIN1 S PSBOKAY="1^Admin is "_(PSBMIN*-1)_" minutes before the scheduled administration time" Q
.I PSBMIN>PSBWIN2 S PSBOKAY="1^Admin is "_(PSBMIN)_" minutes after the scheduled administration time" Q
.S PSBOKAY="0^Okay to administer"
; Validate a PRN Order
D:(PSBSCHT="P")
.I PSBOSTS'="A",PSBOSTS'="R",PSBOSTS'="O" S PSBOKAY="-1^Order Not Active" Q
.I PSBNGF S PSBOKAY="-1^marked DO NOT GIVE" Q
.I (+($G(PSBOKAY))<0)&(PSBDOSEF="PATCH") Q ;A Patch may have to be removed.
.S PSBOKAY="1^"
.; Get Last Four Givens
.S PSBDT=""
.F S PSBDT=$O(^PSB(53.79,"AOIP",DFN,+PSBOIT,PSBDT),-1) Q:PSBDT="" D
..S PSBDA=""
..F S PSBDA=$O(^PSB(53.79,"AOIP",DFN,+PSBOIT,PSBDT,PSBDA),-1) Q:'PSBDA D
...S (PSBCNT1,PSBCNT2,PSBCNT3)=0
...S PSBLADT=$$GET1^DIQ(53.79,PSBDA_",",.06,"I")
...S PSBSTUS=$$GET1^DIQ(53.79,PSBDA_",",.09)
...S:PSBSTUS="" PSBSTUS="U"
...S PSBSCH=$$GET1^DIQ(53.79,PSBDA_",",.12)
...S PSBRSN=$$GET1^DIQ(53.79,PSBDA_",",.21)
...S PSBINJ=$$GET1^DIQ(53.79,PSBDA_",",.16)
...Q:$P(^PSB(53.79,PSBDA,0),U,9)="N"
...F PSBZ=.5,.6,.7 F PSBY=0:0 S PSBY=$O(^PSB(53.79,PSBDA,PSBZ,PSBY)) Q:'PSBY D
....Q:'$D(^PSB(53.79,PSBDA,PSBZ,PSBY))
....S PSBDD=$S(PSBZ=.5:53.795,PSBZ=.6:53.796,1:53.797)
....S PSBUNIT=$$GET1^DIQ(PSBDD,PSBY_","_PSBDA_",",.03)
....S PSBUNFR=$$GET1^DIQ(PSBDD,PSBY_","_PSBDA_",",.04)
....I PSBZ=.5 S PSBCNT1=PSBCNT1+1
....I PSBZ=.6 S PSBCNT2=PSBCNT2+1
....I PSBZ=.7 S PSBCNT3=PSBCNT3+1
...;Units given or free text not to display for multiple dispense drugs or additives and solution
...I (PSBCNT1>1)!(PSBCNT2>0)!(PSBCNT3>0) S (PSBUNIT,PSBUNFR)=""
...S X=PSBLADT_U
...S X=X_PSBSTUS_U_PSBSCH_U_$G(PSBRSN)_U_$G(PSBINJ)_U_$G(PSBUNIT)_U_$G(PSBUNFR)
...S PSBOKAY($O(PSBOKAY(""),-1)+1)=3_U_X
...S:$D(PSBOKAY(4)) PSBDT=0
.S X1=$$LASTG^PSBCSUTL(DFN,+PSBOIT) I X1>0 S PSBOKAY($O(PSBOKAY(""),-1)+1)=4_U_X1
; Validate a One-Time Order
D:PSBSCHT="O"
.S (PSBGVN,X,Y)=""
.F S X=$O(^PSB(53.79,"AOIP",DFN,PSBOIT,X),-1) Q:'X F S Y=$O(^PSB(53.79,"AOIP",DFN,PSBOIT,X,Y),-1) Q:'Y I $P(^PSB(53.79,Y,.1),U)=PSBONX,"G"[$P(^PSB(53.79,Y,0),U,9) S PSBGVN=1,(X,Y)=0
.I PSBGVN S PSBOKAY="-1^Dose Already on medication Log" Q
.; One Time are automatically expired so we don't check STATUS here
.I PSBNGF S PSBOKAY="-1^marked DO NOT GIVE" Q
.S PSBOKAY="0^Okay to administer"
; Validate an On Call Order
D:PSBSCHT="OC"
.S PSBOKAY="0^Okay to administer"
.S (PSBGVN,X,Y)=""
.F S X=$O(^PSB(53.79,"AOIP",DFN,PSBOIT,X),-1) Q:'X F S Y=$O(^PSB(53.79,"AOIP",DFN,PSBOIT,X,Y),-1) Q:'Y I $P(^PSB(53.79,Y,.1),U)=PSBONX,"G"[$P(^PSB(53.79,Y,0),U,9) S PSBGVN=1,(X,Y)=0
.I PSBGVN&('$$GET^XPAR("DIV","PSB ADMIN MULTIPLE ONCALL")) S PSBOKAY="-1^Dose Already on medication Log" Q
.I PSBOSTS'="A",PSBOSTS'="R",PSBOSTS'="O" S PSBOKAY="-1^Order Not Active" Q
.I PSBNGF S PSBOKAY="-1^marked DO NOT GIVE" Q
.I PSBGVN&($$GET^XPAR("DIV","PSB ADMIN MULTIPLE ONCALL"))&(PSBDOSEF="PATCH") S PSBOKAY="-1^Previous patch has not been removed" Q
.S PSBOKAY="0^Okay to administer"
;
D:+PSBOKAY'<0
.N PSBDIFF,Y
.D:(PSBSCHT="C")!(PSBSCHT="OC"&('$G(PSBGVN)))
..; On-call or cont and not on the log.
..S Y=$O(^PSB(53.79,"AOIP",DFN,PSBOIT,""),-1)
..;Check for the status of the medication and insert status in the text
..I Y]"" S X=$O(^PSB(53.79,"AOIP",DFN,+PSBOIT,Y,""),-1),PSBSTUS=$P(^PSB(53.79,X,0),U,9)
..S:Y']"" PSBSTUS=""
..I PSBSTUS="N" D Q:$G(PSBQUIT)
...S X=$O(^PSB(53.79,"AOIP",DFN,PSBOIT,Y,X),-1)
...D:X']""
....S Y=$O(^PSB(53.79,"AOIP",DFN,PSBOIT,Y),-1) I Y']"" S PSBQUIT=1 Q
....S X=$O(^PSB(53.79,"AOIP",DFN,+PSBOIT,Y,""),-1),PSBSTUS=$P(^PSB(53.79,X,0),U,9)
..S PSBDIFF=$$FMDIFF^XLFDT($$NOW^XLFDT(),Y,2)
..Q:PSBDIFF>7200 ; Greater than 2 hours
..I (PSBSTUS="G")!(PSBSTUS="H")!(PSBSTUS="R")!(PSBSTUS="RM") D
...S PSBSTUS=$$GET1^DIQ(53.79,X_",",.09)
...I PSBSTUS'="" D
....S Y="1^*** NOTICE, "_PSBOITX_" was "_PSBSTUS_" "_(PSBDIFF\60)_" minutes ago."
....I +PSBOKAY=1 S PSBOKAY(1)=Y
....E S PSBOKAY=Y
;
S PSB=PSB+1,RESULTS(0)=PSB,RESULTS(PSB)=PSBOKAY
F X=1:1 Q:'$D(PSBOKAY(X)) S PSB=PSB+1,RESULTS(0)=PSB,RESULTS(PSB)=PSBOKAY(X)
Q
;
PSBVDLVL ;BIRMINGHAM/EFC-BCMA VIRTUAL DUE LIST FUNCTIONS ;Mar 2004
+1 ;;3.0;BAR CODE MED ADMIN;**6,3,12,11,13,32,25**;Mar 2004;Build 6
+2 ;Per VHA Directive 2004-038 (or future revisions regarding same), this routine should not be modified.
+3 ;
+4 ;
+5 ; Reference/IA
+6 ; $$GET^XPAR/2263
+7 ;
EN(RESULTS,DFN,PSBXOR,PSBTYPE,PSBADMIN,PSBTAB,PSBUID,PSBASTS,PSBORSTS,PSBRMV) ;
+1 ;
+2 ; RPC: PSB VALIDATE ORDER
+3 ;
+4 ; Description: Final check of order against an actual administration
+5 ; date/time used immediately after scanned med has been
+6 ; validated to be a good un-administered order.
+7 ;
+8 KILL PSBTST
+9 NEW PSBFLAG
+10 IF PSBRMV="I"
DO GETOHIST^PSBRPC2(.PSBTST,DFN,PSBXOR_PSBTYPE)
SET I=0
FOR
SET I=$ORDER(PSBTST(I))
IF I=""
QUIT
IF $PIECE(PSBTST(I),U,5)="I"
SET RESULTS(0)=1
SET RESULTS(1)="-2^"
KILL PSBTST
QUIT
+11 KILL PSBOKAY
DO CLEAN^PSBVT
DO PSJ1^PSBVT(DFN,PSBXOR_PSBTYPE)
SET PSB=0
+12 ; Default Flag will be overwritten by anything
SET RESULTS(0)=1
SET RESULTS(1)="-1^***Unable to determine administration"
+13 DO NOW^%DTC
+14 IF ((PSBOSTS="A")!(PSBOSTS="R"))&(PSBOSP<%)
SET PSBOSTS="E"
+15 IF PSBORSTS'=PSBOSTS
IF ((PSBSCHT'="O")&(PSBOSTS'="E"))
SET PSB=PSB+1
SET RESULTS(0)=PSB
SET RESULTS(PSB)="-2^ORDER STATUS MISMATCH"
QUIT
+16 IF ((PSBTAB="UDTAB")!(PSBTAB="PBTAB"))
IF ((PSBRMV="RM")!(PSBRMV="N"))
Begin DoDot:1
+17 ; patch removal does not follow rest of validte rules
SET PSB=PSB+1
SET RESULTS(0)=PSB
SET RESULTS(PSB)="0^OKAY TO REMOVE"
+18 ;status is not given - don't check for missmatch
IF PSBASTS=""
QUIT
+19 IF $DATA(^PSB(53.79,"AORD",DFN,PSBXOR_PSBTYPE,+PSBADMIN))
SET X=$ORDER(^PSB(53.79,"AORD",DFN,PSBXOR_PSBTYPE,+PSBADMIN,""))
IF $PIECE($GET(^PSB(53.79,+X,0)),U,9)'=PSBASTS
SET PSB=PSB+1
SET RESULTS(0)=PSB
SET RESULTS(PSB)="-2^Admin status mismatch"
End DoDot:1
QUIT
+20 IF PSBTYPE="V"
IF PSBSCHT'="P"
IF ((PSBUID="")!(PSBUID["WS"))
SET RESULTS(0)=1
SET RESULTS(1)="0^Okay to administer"
IF PSBTAB="IVTAB"
QUIT
+21 ; validate IV bags Piggybacks have additional tests
IF PSBTYPE="V"
IF PSBUID'=""
Begin DoDot:1
+22 SET PSB=0
SET PSBSUID=PSBUID
DO EN^PSBPOIV(DFN,PSBXOR_PSBTYPE)
+23 SET X=""
FOR
SET X=$ORDER(^TMP("PSBAR",$JOB,X))
IF X=""
QUIT
Begin DoDot:2
+24 IF PSBSUID'=X
QUIT
+25 SET PSBUIDS=^TMP("PSBAR",$JOB,X)
+26 ; is infusing or stopped
IF $PIECE(PSBUIDS,U,2)="I"!($PIECE(PSBUIDS,U,2)="S")
SET PSB=PSB+1
SET RESULTS(0)=PSB
SET RESULTS(PSB)="0^Okay to administer"
QUIT
+27 IF $PIECE(PSBUIDS,U,1)="I"
SET Y=$PIECE(^TMP("PSBAR",$JOB,"I"),U,2)
DO DD^%DT
SET PSB=PSB+1
SET RESULTS(0)=PSB
SET RESULTS(PSB)=$PIECE(^TMP("PSBAR",$JOB,"I"),U,3,99)_" "_Y
QUIT
+28 IF $PIECE(PSBUIDS,U,1)["W"
SET PSBWS=$PIECE(PSBUIDS,U,1)
FOR PSBWM=2:1
IF $PIECE(PSBWS,";",PSBWM)=""
QUIT
Begin DoDot:3
+29 SET Y=$PIECE(^TMP("PSBAR",$JOB,"W",$PIECE(PSBWS,";",PSBWM)),U,2)
DO DD^%DT
SET PSB=PSB+1
SET RESULTS(0)=PSB
SET RESULTS(PSB)=$PIECE(^TMP("PSBAR",$JOB,"W",$PIECE(PSBWS,";",PSBWM)),U,3,99)_" "_Y
End DoDot:3
+30 SET PSB=PSB+1
SET RESULTS(0)=PSB
SET RESULTS(PSB)="0^Okay to administer"
End DoDot:2
+31 KILL ^TMP("PSBAR",$JOB)
End DoDot:1
IF PSBTAB="IVTAB"
QUIT
+32 ;
+33 ; no IV orders
+34 ;
+35 DO NOW^%DTC
+36 IF PSBOSTS="H"
SET PSB=PSB+1
SET RESULTS(0)=PSB
SET RESULTS(PSB)="0^Order is on Provider Hold"
QUIT
+37 IF PSBSCHT'="O"&(%<($$FMADD^XLFDT(PSBOST,"","",$$GET^XPAR("ALL","PSB ADMIN BEFORE")*-1)))
SET PSB=PSB+1
SET RESULTS(0)=PSB
SET RESULTS(PSB)="-1^Order Not Active"
QUIT
+38 IF (%>PSBOSP)
SET PSB=PSB+1
SET RESULTS(0)=PSB
SET RESULTS(PSB)="-1^Order Not Active"
QUIT
+39 IF (PSBSCHT="C")!((PSBSCHT="P")&(PSBDOSEF="PATCH"))
Begin DoDot:1
+40 SET PSBOKAY="0^Okay to administer"
+41 IF PSBASTS["*UNKNOWN*"
SET PSBOKAY="-1^This administration has *UNKNOWN* status"
QUIT
+42 IF PSBOSTS'="A"
IF PSBOSTS'="R"
IF PSBOSTS'="O"
SET PSBOKAY="-1^Order Not Active"
QUIT
+43 IF PSBNGF
SET PSBOKAY="-1^marked DO NOT GIVE"
QUIT
+44 SET PSBFLAG=0
IF PSBRMV="M"!(PSBRMV="H")!(PSBRMV="R")
SET PSBFLAG=1
+45 IF $DATA(^PSB(53.79,"AORDX",DFN,PSBXOR_PSBTYPE))
Begin DoDot:2
+46 SET X=0
SET PSBLADT=$ORDER(^PSB(53.79,"AORDX",DFN,PSBXOR_PSBTYPE,""),-1)
SET PSBLAIEN=$ORDER(^PSB(53.79,"AORDX",DFN,PSBXOR_PSBTYPE,PSBLADT,""),-1)
+47 IF $PIECE($GET(^PSB(53.79,PSBLAIEN,0)),U,9)="G"
IF $PIECE($GET(^PSB(53.79,PSBLAIEN,.5,1,0)),U,4)="PATCH"
IF PSBFLAG=0
SET X=1
SET PSBOKAY="-1^Previous patch has not been removed"
QUIT
End DoDot:2
IF X
QUIT
+48 IF $DATA(^PSB(53.79,"AORD",DFN,PSBXOR_PSBTYPE,+PSBADMIN))
Begin DoDot:2
+49 SET X=$ORDER(^PSB(53.79,"AORD",DFN,PSBXOR_PSBTYPE,+PSBADMIN,""))
+50 LOCK +^PSB(53.79,+X):1
+51 IF $TEST
LOCK -^PSB(53.79,+X)
+52 IF '$TEST
SET PSBOKAY="-1^The "_$$GET1^DIQ(53.79,+X_",",.13)_" administration is being edited by another"
QUIT
+53 IF $GET(PSBASTS)]""
Begin DoDot:3
+54 IF $PIECE($GET(^PSB(53.79,+X,0)),U,9)=""
QUIT
+55 IF $PIECE($GET(^PSB(53.79,+X,0)),U,9)'=PSBASTS
SET PSBOKAY="-2^Admin status mismatch"
QUIT
End DoDot:3
IF +PSBOKAY<0
QUIT
End DoDot:2
IF +PSBOKAY<0
QUIT
+56 ; Minutes before
+57 SET PSBWIN1=$$GET^XPAR("DIV","PSB ADMIN BEFORE")*-1
+58 ; Minutes After
+59 SET PSBWIN2=$$GET^XPAR("DIV","PSB ADMIN AFTER")
+60 DO NOW^%DTC
SET PSBMIN=$$DIFF^PSBUTL(PSBADMIN,%)
+61 ; PENDING A PC SOLUTION!
+62 IF PSBMIN<PSBWIN1
SET PSBOKAY="1^Admin is "_(PSBMIN*-1)_" minutes before the scheduled administration time"
QUIT
+63 IF PSBMIN>PSBWIN2
SET PSBOKAY="1^Admin is "_(PSBMIN)_" minutes after the scheduled administration time"
QUIT
+64 SET PSBOKAY="0^Okay to administer"
End DoDot:1
+65 ; Validate a PRN Order
+66 IF (PSBSCHT="P")
Begin DoDot:1
+67 IF PSBOSTS'="A"
IF PSBOSTS'="R"
IF PSBOSTS'="O"
SET PSBOKAY="-1^Order Not Active"
QUIT
+68 IF PSBNGF
SET PSBOKAY="-1^marked DO NOT GIVE"
QUIT
+69 ;A Patch may have to be removed.
IF (+($GET(PSBOKAY))<0)&(PSBDOSEF="PATCH")
QUIT
+70 SET PSBOKAY="1^"
+71 ; Get Last Four Givens
+72 SET PSBDT=""
+73 FOR
SET PSBDT=$ORDER(^PSB(53.79,"AOIP",DFN,+PSBOIT,PSBDT),-1)
IF PSBDT=""
QUIT
Begin DoDot:2
+74 SET PSBDA=""
+75 FOR
SET PSBDA=$ORDER(^PSB(53.79,"AOIP",DFN,+PSBOIT,PSBDT,PSBDA),-1)
IF 'PSBDA
QUIT
Begin DoDot:3
+76 SET (PSBCNT1,PSBCNT2,PSBCNT3)=0
+77 SET PSBLADT=$$GET1^DIQ(53.79,PSBDA_",",.06,"I")
+78 SET PSBSTUS=$$GET1^DIQ(53.79,PSBDA_",",.09)
+79 IF PSBSTUS=""
SET PSBSTUS="U"
+80 SET PSBSCH=$$GET1^DIQ(53.79,PSBDA_",",.12)
+81 SET PSBRSN=$$GET1^DIQ(53.79,PSBDA_",",.21)
+82 SET PSBINJ=$$GET1^DIQ(53.79,PSBDA_",",.16)
+83 IF $PIECE(^PSB(53.79,PSBDA,0),U,9)="N"
QUIT
+84 FOR PSBZ=.5,.6,.7
FOR PSBY=0:0
SET PSBY=$ORDER(^PSB(53.79,PSBDA,PSBZ,PSBY))
IF 'PSBY
QUIT
Begin DoDot:4
+85 IF '$DATA(^PSB(53.79,PSBDA,PSBZ,PSBY))
QUIT
+86 SET PSBDD=$SELECT(PSBZ=.5:53.795,PSBZ=.6:53.796,1:53.797)
+87 SET PSBUNIT=$$GET1^DIQ(PSBDD,PSBY_","_PSBDA_",",.03)
+88 SET PSBUNFR=$$GET1^DIQ(PSBDD,PSBY_","_PSBDA_",",.04)
+89 IF PSBZ=.5
SET PSBCNT1=PSBCNT1+1
+90 IF PSBZ=.6
SET PSBCNT2=PSBCNT2+1
+91 IF PSBZ=.7
SET PSBCNT3=PSBCNT3+1
End DoDot:4
+92 ;Units given or free text not to display for multiple dispense drugs or additives and solution
+93 IF (PSBCNT1>1)!(PSBCNT2>0)!(PSBCNT3>0)
SET (PSBUNIT,PSBUNFR)=""
+94 SET X=PSBLADT_U
+95 SET X=X_PSBSTUS_U_PSBSCH_U_$GET(PSBRSN)_U_$GET(PSBINJ)_U_$GET(PSBUNIT)_U_$GET(PSBUNFR)
+96 SET PSBOKAY($ORDER(PSBOKAY(""),-1)+1)=3_U_X
+97 IF $DATA(PSBOKAY(4))
SET PSBDT=0
End DoDot:3
End DoDot:2
+98 SET X1=$$LASTG^PSBCSUTL(DFN,+PSBOIT)
IF X1>0
SET PSBOKAY($ORDER(PSBOKAY(""),-1)+1)=4_U_X1
End DoDot:1
+99 ; Validate a One-Time Order
+100 IF PSBSCHT="O"
Begin DoDot:1
+101 SET (PSBGVN,X,Y)=""
+102 FOR
SET X=$ORDER(^PSB(53.79,"AOIP",DFN,PSBOIT,X),-1)
IF 'X
QUIT
FOR
SET Y=$ORDER(^PSB(53.79,"AOIP",DFN,PSBOIT,X,Y),-1)
IF 'Y
QUIT
IF $PIECE(^PSB(53.79,Y,.1),U)=PSBONX
IF "G"[$PIECE(^PSB(53.79,Y,0),U,9)
SET PSBGVN=1
SET (X,Y)=0
+103 IF PSBGVN
SET PSBOKAY="-1^Dose Already on medication Log"
QUIT
+104 ; One Time are automatically expired so we don't check STATUS here
+105 IF PSBNGF
SET PSBOKAY="-1^marked DO NOT GIVE"
QUIT
+106 SET PSBOKAY="0^Okay to administer"
End DoDot:1
+107 ; Validate an On Call Order
+108 IF PSBSCHT="OC"
Begin DoDot:1
+109 SET PSBOKAY="0^Okay to administer"
+110 SET (PSBGVN,X,Y)=""
+111 FOR
SET X=$ORDER(^PSB(53.79,"AOIP",DFN,PSBOIT,X),-1)
IF 'X
QUIT
FOR
SET Y=$ORDER(^PSB(53.79,"AOIP",DFN,PSBOIT,X,Y),-1)
IF 'Y
QUIT
IF $PIECE(^PSB(53.79,Y,.1),U)=PSBONX
IF "G"[$PIECE(^PSB(53.79,Y,0),U,9)
SET PSBGVN=1
SET (X,Y)=0
+112 IF PSBGVN&('$$GET^XPAR("DIV","PSB ADMIN MULTIPLE ONCALL"))
SET PSBOKAY="-1^Dose Already on medication Log"
QUIT
+113 IF PSBOSTS'="A"
IF PSBOSTS'="R"
IF PSBOSTS'="O"
SET PSBOKAY="-1^Order Not Active"
QUIT
+114 IF PSBNGF
SET PSBOKAY="-1^marked DO NOT GIVE"
QUIT
+115 IF PSBGVN&($$GET^XPAR("DIV","PSB ADMIN MULTIPLE ONCALL"))&(PSBDOSEF="PATCH")
SET PSBOKAY="-1^Previous patch has not been removed"
QUIT
+116 SET PSBOKAY="0^Okay to administer"
End DoDot:1
+117 ;
+118 IF +PSBOKAY'<0
Begin DoDot:1
+119 NEW PSBDIFF,Y
+120 IF (PSBSCHT="C")!(PSBSCHT="OC"&('$GET(PSBGVN)))
Begin DoDot:2
+121 ; On-call or cont and not on the log.
+122 SET Y=$ORDER(^PSB(53.79,"AOIP",DFN,PSBOIT,""),-1)
+123 ;Check for the status of the medication and insert status in the text
+124 IF Y]""
SET X=$ORDER(^PSB(53.79,"AOIP",DFN,+PSBOIT,Y,""),-1)
SET PSBSTUS=$PIECE(^PSB(53.79,X,0),U,9)
+125 IF Y']""
SET PSBSTUS=""
+126 IF PSBSTUS="N"
Begin DoDot:3
+127 SET X=$ORDER(^PSB(53.79,"AOIP",DFN,PSBOIT,Y,X),-1)
+128 IF X']""
Begin DoDot:4
+129 SET Y=$ORDER(^PSB(53.79,"AOIP",DFN,PSBOIT,Y),-1)
IF Y']""
SET PSBQUIT=1
QUIT
+130 SET X=$ORDER(^PSB(53.79,"AOIP",DFN,+PSBOIT,Y,""),-1)
SET PSBSTUS=$PIECE(^PSB(53.79,X,0),U,9)
End DoDot:4
End DoDot:3
IF $GET(PSBQUIT)
QUIT
+131 SET PSBDIFF=$$FMDIFF^XLFDT($$NOW^XLFDT(),Y,2)
+132 ; Greater than 2 hours
IF PSBDIFF>7200
QUIT
+133 IF (PSBSTUS="G")!(PSBSTUS="H")!(PSBSTUS="R")!(PSBSTUS="RM")
Begin DoDot:3
+134 SET PSBSTUS=$$GET1^DIQ(53.79,X_",",.09)
+135 IF PSBSTUS'=""
Begin DoDot:4
+136 SET Y="1^*** NOTICE, "_PSBOITX_" was "_PSBSTUS_" "_(PSBDIFF\60)_" minutes ago."
+137 IF +PSBOKAY=1
SET PSBOKAY(1)=Y
+138 IF '$TEST
SET PSBOKAY=Y
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+139 ;
+140 SET PSB=PSB+1
SET RESULTS(0)=PSB
SET RESULTS(PSB)=PSBOKAY
+141 FOR X=1:1
IF '$DATA(PSBOKAY(X))
QUIT
SET PSB=PSB+1
SET RESULTS(0)=PSB
SET RESULTS(PSB)=PSBOKAY(X)
+142 QUIT
+143 ;
