PSBVDLVL ;BIRMINGHAM/EFC-BCMA VIRTUAL DUE LIST FUNCTIONS ;03/06/16 3:06pm
;;3.0;BAR CODE MED ADMIN;**6,3,12,11,13,32,25,61,70,83,114**;Mar 2004;Build 3
;Per VHA Directive 2004-038 (or future revisions regarding same), this routine should not be modified.
;
;
; Reference/IA
; $$GET^XPAR/2263
;
;*70 - Clinic Orders will use an Admin Early/Late calc of any day
; before or After TODAY instead of minutes as in IM meds.
;*83 - Add ability to do Remove Early/Late tests on Sched Remove time
; -add a 10 param, sched remove time
; -add check for meds not removed for other orders (by OI)
;
EN(RESULTS,DFN,PSBXOR,PSBTYPE,PSBADMIN,PSBTAB,PSBUID,PSBASTS,PSBORSTS,PSBRMV,PSBRMT) ;
;
; 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,FOUND,LSTACTN,PSBLSTGV,PSBLADT,PSBLAIEN,X,CLORD ;*83
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 CLORD=$S($G(PSBCLORD)]"":1,1:0) ;if a Clinc ord, 1 else 0 *83
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
;
;patch/MRR removal does not follow The Rest of validation rules
; special tests for RM added *83
I ((PSBTAB="UDTAB")!(PSBTAB="PBTAB")),((PSBRMV="RM")!(PSBRMV="N")) D Q
.D:PSBRMV="N"
..S PSB=PSB+1,RESULTS(0)=PSB
..S RESULTS(PSB)="0^Okay to Undo"
.I PSBASTS="" Q ;status is not given - don't check for mismatch
.;check for admin status mismatch
.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 D Q ;Quit if -2 err, dont fall thru to RM logic
..S PSB=PSB+1,RESULTS(0)=PSB,RESULTS(PSB)="-2^Admin status mismatch"
.;
.; RM logic quits after it runs and does not fall thru
.;IM order Remove, Do variance check *83
.I PSBRMV="RM",'CLORD D Q
..S PSBOKAY=$$VARIANCE(PSBRMV,PSBRMT)
..S PSB=PSB+1,RESULTS(0)=PSB,RESULTS(PSB)=PSBOKAY
.;
.;CO order Remove, No variance check *83
.I PSBRMV="RM",CLORD D Q
..S RESULTS(0)=1,RESULTS(1)="0^Okay to Remove"
;
; The Rest of the validation rules
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
;
;test for non-one time orders admin prior to start date of order
;
;CO orders, check if start order date is > today
I CLORD,PSBSCHT'="O"&($P(PSBOST,".")>DT) S PSB=PSB+1,RESULTS(0)=PSB,RESULTS(PSB)="-1^Order Not Active" Q ;CO > today *83
;IM orders, check start order date/time > Now
I 'CLORD,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 ;IM > now *83
;All orders, check stop order date/time > Now
I (%>PSBOSP) S PSB=PSB+1,RESULTS(0)=PSB,RESULTS(PSB)="-1^Order Not Active, expired" Q
;
;tests sched types of continuous or prns that are MRRs
I (PSBSCHT="C")!((PSBSCHT="P")&(PSBMRRFL>0)) 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
.;set special action flag
.S PSBFLAG=0 I PSBRMV="M"!(PSBRMV="H")!(PSBRMV="R") S PSBFLAG=1
.;
.;*** Check for errors vs. last valid completed action this order.
.; completed = Given or Removed, end of a UD admin life cycle
.I $D(^PSB(53.79,"AORDX",DFN,PSBXOR_PSBTYPE)) D Q:X
..S X=0,LSTACTN="",PSBLAIEN=0
..S PSBLADT="",FOUND=0
..F S PSBLADT=$O(^PSB(53.79,"AORDX",DFN,PSBXOR_PSBTYPE,PSBLADT),-1) Q:'PSBLADT D Q:FOUND
...S PSBLAIEN=$O(^PSB(53.79,"AORDX",DFN,PSBXOR_PSBTYPE,PSBLADT,""),-1)
...S LSTACTN=$P($G(^PSB(53.79,PSBLAIEN,0)),U,9)
...I (LSTACTN="G")!(LSTACTN="RM") S FOUND=1 ;found a previous G/RM
..Q:'FOUND ;quit, no last valid completed type last action found
..;
..;MRR - Previous Admin NOT REMOVED tests
..I LSTACTN="G",PSBFLAG=0 D
...N DSPDRG S DSPDRG=$O(^PSB(53.79,PSBLAIEN,.5,0)) I 'DSPDRG Q
...I $P($G(^PSB(53.79,PSBLAIEN,.5,DSPDRG,0)),U,4)="PATCH" D NOTREMVD
...I 'X,$P($G(^PSB(53.79,PSBLAIEN,.5,DSPDRG,0)),U,6)>0 D NOTREMVD
..;
..;if trying to Give an earlier dose after a later admin Given *83
..S PSBLSTGV=$P(^PSB(53.79,PSBLAIEN,.1),U,3)
..I PSBADMIN<PSBLSTGV,PSBFLAG=0 D
...S X=1
...S PSBOKAY="-1^A later dose scheduled at ("_$$FMTE^XLFDT(PSBLSTGV,2)_") was given "_($$FMDIFF^XLFDT($$NOW^XLFDT,$P(^PSB(53.79,PSBLAIEN,0),U,6),2)\60)_" minutes ago."
.;****
.;
.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
.;*70 perform early/late admin testing for IM & CO orders
.;
.;*83 call tag for non-removal actions - IM orders only
.I 'CLORD,PSBRMV'="RM",'PSBFLAG S PSBOKAY=$$VARIANCE(PSBRMV,PSBADMIN)
.;
.D:CLORD ;CO order new logic
..N ADMINDT S ADMINDT=$P(PSBADMIN,".")
..S PSBOKAY="1^You are about to give a medication that "
..I ADMINDT>DT D Q
...S PSBOKAY=PSBOKAY_"is scheduled for "_$$DOW^XLFDT(ADMINDT)_", "_$$FMTE^XLFDT(ADMINDT,5)_"."
..I ADMINDT<DT D Q
...S PSBOKAY=PSBOKAY_"was scheduled for "_$$DOW^XLFDT(ADMINDT)_", "_$$FMTE^XLFDT(ADMINDT,5)_"."
..S PSBOKAY="0^Okay to administer"
.;*70 end early/late logic
;
; 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.
.I (+($G(PSBOKAY))<0)&(PSBMRRFL>0) Q ;MRR may need removal *83
.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:PSBUNIT>0&(PSBUNIT<1) PSBUNIT="0"_+PSBUNIT ;Add leading 0 for decimal values less than 1, PSB*3*61
....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
.S X=0
.I PSBGVN,$$GET^XPAR("DIV","PSB ADMIN MULTIPLE ONCALL") D Q:X
..I PSBDOSEF="PATCH" D NOTREMVD Q ;*83
..I PSBMRRFL>0 D NOTREMVD Q ;*83
.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 into 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
..;remove "RM" sts previous action test for this warning *83
..I (PSBSTUS="G")!(PSBSTUS="H")!(PSBSTUS="R") 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
.;
.;check for same OI medication MRR not removed, warning *83
.N LST
.I PSBMRRFL,$$OIREMVD(DFN,PSBOIT,.LST) D
..;find last ien in psbokay, so won't overwrite with new OI msgs *83
..N Q S Q=$O(PSBOKAY(""),-1)
..F X=0:0 S X=$O(LST(X)) Q:'X D
...S PSBOKAY(Q+X)="1^Medication "_$P(LST(X),U,2)_" for scheduled administration "_$P(LST(X),U)_" has NOT been removed. "
;
;adds fall thru err msg text to Results
S PSB=PSB+1,RESULTS(PSB)=PSBOKAY
;
;overwrite 0^okay text with 1^warning text IF array PSBOKAY populated
I RESULTS(1)["0^Okay",$D(PSBOKAY)>9 S PSB=0
F X=0:0 S X=$O(PSBOKAY(X)) Q:'X D
.S PSB=PSB+1,RESULTS(PSB)=PSBOKAY(X)
;
S RESULTS(0)=$O(RESULTS(999),-1) ;set to always agree to content
Q
;
NOTREMVD ;Standard "Not Removed" MRR error msg & special pre-warning test *83
S PSBOKAY=""
I PSBRMV'="RM" S PSBOKAY=$$VARIANCE(PSBRMV,PSBADMIN)
;check special case of Early Admin - move Early error msg to Results
;array so PSBOKAY can be reused for later dual -1 errmsg: early admin
;
I PSBOKAY["Admin",PSBOKAY["before" D
.S PSB=PSB+1,RESULTS(PSB)=PSBOKAY,RESULTS(0)=PSB
S X=1
S PSBOKAY="-1^Cannot Give medication until previous administration has been removed."
Q
;
VARIANCE(ACTION,DATETM) ;check for variance to exceed Early/Late window *83
N MSG
S PSBWIN1=$$GET^XPAR("DIV","PSB ADMIN BEFORE")*-1 ;Minutes before
S PSBWIN2=$$GET^XPAR("DIV","PSB ADMIN AFTER") ;Minutes After
D NOW^%DTC
S PSBMIN=$S($P(DATETM,".",2):$$DIFF^PSBUTL(DATETM,%),1:0)
;
D:ACTION'="RM" ;Not a Removal
.I PSBMIN<PSBWIN1 S MSG="1^Admin is "_(PSBMIN*-1)_" minutes before the scheduled administration time" Q
.I PSBMIN>PSBWIN2 S MSG="1^Admin is "_(PSBMIN)_" minutes after the scheduled administration time" Q
.S MSG="0^Okay to "_$S(ACTION="H":"Hold",ACTION="R":"Refuse",1:"administer")
;
D:ACTION="RM" ;Removal: use a new code #5 for RED txt (Early RM)
.S MSG="0^Okay to Remove"
.I PSBMIN<PSBWIN1 S MSG="5^Removal is "_(PSBMIN*-1)_" minutes before the scheduled removal time" Q
.I PSBMIN>PSBWIN2 S MSG="1^Removal is "_(PSBMIN)_" minutes after the scheduled removal time" Q
;
Q MSG
;
OIREMVD(DFN,OI,REM) ;Is another OI MRR not removed?
; Input:
; DFN = patient ien
; OI = Ordreable Item Ien
;Output:
; Function - false/true
; parm- REM(ien), IEN of file 53.79 array of meds needing Removal
; formatted: Sched Admin date/time ^ Disp drug name ^Ordno
; if One time sched, then set Sched Admin = actual given date/time
;
;check for previous MRR type 1 med not removed *83
N CNT,PSBBK,DTE,IEN,QQ,MEDNM,ORDNO,SCHADM
S PSBBK=$$GET^XPAR("DIV","PSB VDL PATCH DAYS")
S PSBBK=$$FMADD^XLFDT(DT,-$S(PSBBK>0:PSBBK,1:30))
S DTE="",CNT=0
F S DTE=$O(^PSB(53.79,"AOIP",DFN,OI,DTE),-1) Q:('DTE)!((DTE\1)<PSBBK) D
.S IEN=""
.F S IEN=$O(^PSB(53.79,"AOIP",DFN,OI,DTE,IEN),-1) Q:'IEN D
..Q:$P($G(^PSB(53.79,IEN,0)),U,9)'="G"
..S CNT=CNT+1
..S SCHADM=$$GET1^DIQ(53.79,+IEN,"SCHEDULED ADMINISTRATION TIME")
..S:'SCHADM SCHADM=$E($$GET1^DIQ(53.79,+IEN,"ACTION DATE/TIME"),1,18)
..S QQ=$O(^PSB(53.79,IEN,.5,0))
..S:QQ MEDNM=$$GET1^DIQ(53.795,QQ_","_IEN,"DISPENSE DRUG")
..S ORDNO=$$GET1^DIQ(53.79,+IEN,"ORDER REFERENCE NUMBER")
..S REM(CNT)=SCHADM_U_MEDNM_U_ORDNO
Q $D(REM)
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSBVDLVL 14725 printed Apr 09, 2024@20:44:55 Page 2
PSBVDLVL ;BIRMINGHAM/EFC-BCMA VIRTUAL DUE LIST FUNCTIONS ;03/06/16 3:06pm
+1 ;;3.0;BAR CODE MED ADMIN;**6,3,12,11,13,32,25,61,70,83,114**;Mar 2004;Build 3
+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 ;
+8 ;*70 - Clinic Orders will use an Admin Early/Late calc of any day
+9 ; before or After TODAY instead of minutes as in IM meds.
+10 ;*83 - Add ability to do Remove Early/Late tests on Sched Remove time
+11 ; -add a 10 param, sched remove time
+12 ; -add check for meds not removed for other orders (by OI)
+13 ;
EN(RESULTS,DFN,PSBXOR,PSBTYPE,PSBADMIN,PSBTAB,PSBUID,PSBASTS,PSBORSTS,PSBRMV,PSBRMT) ;
+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 ;*83
NEW PSBFLAG,FOUND,LSTACTN,PSBLSTGV,PSBLADT,PSBLAIEN,X,CLORD
+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 ;if a Clinc ord, 1 else 0 *83
SET CLORD=$SELECT($GET(PSBCLORD)]"":1,1:0)
+13 ; Default Flag will be overwritten by anything
SET RESULTS(0)=1
SET RESULTS(1)="-1^***Unable to determine administration"
+14 DO NOW^%DTC
+15 IF ((PSBOSTS="A")!(PSBOSTS="R"))&(PSBOSP<%)
SET PSBOSTS="E"
+16 IF PSBORSTS'=PSBOSTS
IF ((PSBSCHT'="O")&(PSBOSTS'="E"))
SET PSB=PSB+1
SET RESULTS(0)=PSB
SET RESULTS(PSB)="-2^ORDER STATUS MISMATCH"
QUIT
+17 ;
+18 ;patch/MRR removal does not follow The Rest of validation rules
+19 ; special tests for RM added *83
+20 IF ((PSBTAB="UDTAB")!(PSBTAB="PBTAB"))
IF ((PSBRMV="RM")!(PSBRMV="N"))
Begin DoDot:1
+21 if PSBRMV="N"
Begin DoDot:2
+22 SET PSB=PSB+1
SET RESULTS(0)=PSB
+23 SET RESULTS(PSB)="0^Okay to Undo"
End DoDot:2
+24 ;status is not given - don't check for mismatch
IF PSBASTS=""
QUIT
+25 ;check for admin status mismatch
+26 ;Quit if -2 err, dont fall thru to RM logic
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
Begin DoDot:2
+27 SET PSB=PSB+1
SET RESULTS(0)=PSB
SET RESULTS(PSB)="-2^Admin status mismatch"
End DoDot:2
QUIT
+28 ;
+29 ; RM logic quits after it runs and does not fall thru
+30 ;IM order Remove, Do variance check *83
+31 IF PSBRMV="RM"
IF 'CLORD
Begin DoDot:2
+32 SET PSBOKAY=$$VARIANCE(PSBRMV,PSBRMT)
+33 SET PSB=PSB+1
SET RESULTS(0)=PSB
SET RESULTS(PSB)=PSBOKAY
End DoDot:2
QUIT
+34 ;
+35 ;CO order Remove, No variance check *83
+36 IF PSBRMV="RM"
IF CLORD
Begin DoDot:2
+37 SET RESULTS(0)=1
SET RESULTS(1)="0^Okay to Remove"
End DoDot:2
QUIT
End DoDot:1
QUIT
+38 ;
+39 ; The Rest of the validation rules
+40 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
+41 ; validate IV bags Piggybacks have additional tests
IF PSBTYPE="V"
IF PSBUID'=""
Begin DoDot:1
+42 SET PSB=0
SET PSBSUID=PSBUID
DO EN^PSBPOIV(DFN,PSBXOR_PSBTYPE)
+43 SET X=""
FOR
SET X=$ORDER(^TMP("PSBAR",$JOB,X))
if X=""
QUIT
Begin DoDot:2
+44 IF PSBSUID'=X
QUIT
+45 SET PSBUIDS=^TMP("PSBAR",$JOB,X)
+46 ; 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
+47 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
+48 IF $PIECE(PSBUIDS,U,1)["W"
SET PSBWS=$PIECE(PSBUIDS,U,1)
FOR PSBWM=2:1
if $PIECE(PSBWS,";",PSBWM)=""
QUIT
Begin DoDot:3
+49 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
+50 SET PSB=PSB+1
SET RESULTS(0)=PSB
SET RESULTS(PSB)="0^Okay to administer"
End DoDot:2
+51 KILL ^TMP("PSBAR",$JOB)
End DoDot:1
if PSBTAB="IVTAB"
QUIT
+52 ;
+53 ; no IV orders
+54 ;
+55 DO NOW^%DTC
+56 IF PSBOSTS="H"
SET PSB=PSB+1
SET RESULTS(0)=PSB
SET RESULTS(PSB)="0^Order is on Provider Hold"
QUIT
+57 ;
+58 ;test for non-one time orders admin prior to start date of order
+59 ;
+60 ;CO orders, check if start order date is > today
+61 ;CO > today *83
IF CLORD
IF PSBSCHT'="O"&($PIECE(PSBOST,".")>DT)
SET PSB=PSB+1
SET RESULTS(0)=PSB
SET RESULTS(PSB)="-1^Order Not Active"
QUIT
+62 ;IM orders, check start order date/time > Now
+63 ;IM > now *83
IF 'CLORD
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
+64 ;All orders, check stop order date/time > Now
+65 IF (%>PSBOSP)
SET PSB=PSB+1
SET RESULTS(0)=PSB
SET RESULTS(PSB)="-1^Order Not Active, expired"
QUIT
+66 ;
+67 ;tests sched types of continuous or prns that are MRRs
+68 IF (PSBSCHT="C")!((PSBSCHT="P")&(PSBMRRFL>0))
Begin DoDot:1
+69 SET PSBOKAY="0^Okay to administer"
+70 IF PSBASTS["*UNKNOWN*"
SET PSBOKAY="-1^This administration has *UNKNOWN* status"
QUIT
+71 IF PSBOSTS'="A"
IF PSBOSTS'="R"
IF PSBOSTS'="O"
SET PSBOKAY="-1^Order Not Active"
QUIT
+72 IF PSBNGF
SET PSBOKAY="-1^marked DO NOT GIVE"
QUIT
+73 ;set special action flag
+74 SET PSBFLAG=0
IF PSBRMV="M"!(PSBRMV="H")!(PSBRMV="R")
SET PSBFLAG=1
+75 ;
+76 ;*** Check for errors vs. last valid completed action this order.
+77 ; completed = Given or Removed, end of a UD admin life cycle
+78 IF $DATA(^PSB(53.79,"AORDX",DFN,PSBXOR_PSBTYPE))
Begin DoDot:2
+79 SET X=0
SET LSTACTN=""
SET PSBLAIEN=0
+80 SET PSBLADT=""
SET FOUND=0
+81 FOR
SET PSBLADT=$ORDER(^PSB(53.79,"AORDX",DFN,PSBXOR_PSBTYPE,PSBLADT),-1)
if 'PSBLADT
QUIT
Begin DoDot:3
+82 SET PSBLAIEN=$ORDER(^PSB(53.79,"AORDX",DFN,PSBXOR_PSBTYPE,PSBLADT,""),-1)
+83 SET LSTACTN=$PIECE($GET(^PSB(53.79,PSBLAIEN,0)),U,9)
+84 ;found a previous G/RM
IF (LSTACTN="G")!(LSTACTN="RM")
SET FOUND=1
End DoDot:3
if FOUND
QUIT
+85 ;quit, no last valid completed type last action found
if 'FOUND
QUIT
+86 ;
+87 ;MRR - Previous Admin NOT REMOVED tests
+88 IF LSTACTN="G"
IF PSBFLAG=0
Begin DoDot:3
+89 NEW DSPDRG
SET DSPDRG=$ORDER(^PSB(53.79,PSBLAIEN,.5,0))
IF 'DSPDRG
QUIT
+90 IF $PIECE($GET(^PSB(53.79,PSBLAIEN,.5,DSPDRG,0)),U,4)="PATCH"
DO NOTREMVD
+91 IF 'X
IF $PIECE($GET(^PSB(53.79,PSBLAIEN,.5,DSPDRG,0)),U,6)>0
DO NOTREMVD
End DoDot:3
+92 ;
+93 ;if trying to Give an earlier dose after a later admin Given *83
+94 SET PSBLSTGV=$PIECE(^PSB(53.79,PSBLAIEN,.1),U,3)
+95 IF PSBADMIN<PSBLSTGV
IF PSBFLAG=0
Begin DoDot:3
+96 SET X=1
+97 SET PSBOKAY="-1^A later dose scheduled at ("_$$FMTE^XLFDT(PSBLSTGV,2)_") was given "_($$FMDIFF^XLFDT($$NOW^XLFDT,$PIECE(^PSB(53.79,PSBLAIEN,0),U,6),2)\60)_" minutes ago."
End DoDot:3
End DoDot:2
if X
QUIT
+98 ;****
+99 ;
+100 IF $DATA(^PSB(53.79,"AORD",DFN,PSBXOR_PSBTYPE,+PSBADMIN))
Begin DoDot:2
+101 SET X=$ORDER(^PSB(53.79,"AORD",DFN,PSBXOR_PSBTYPE,+PSBADMIN,""))
+102 LOCK +^PSB(53.79,+X):1
+103 IF $TEST
LOCK -^PSB(53.79,+X)
+104 IF '$TEST
SET PSBOKAY="-1^The "_$$GET1^DIQ(53.79,+X_",",.13)_" administration is being edited by another"
QUIT
+105 IF $GET(PSBASTS)]""
Begin DoDot:3
+106 IF $PIECE($GET(^PSB(53.79,+X,0)),U,9)=""
QUIT
+107 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
+108 ;*70 perform early/late admin testing for IM & CO orders
+109 ;
+110 ;*83 call tag for non-removal actions - IM orders only
+111 IF 'CLORD
IF PSBRMV'="RM"
IF 'PSBFLAG
SET PSBOKAY=$$VARIANCE(PSBRMV,PSBADMIN)
+112 ;
+113 ;CO order new logic
if CLORD
Begin DoDot:2
+114 NEW ADMINDT
SET ADMINDT=$PIECE(PSBADMIN,".")
+115 SET PSBOKAY="1^You are about to give a medication that "
+116 IF ADMINDT>DT
Begin DoDot:3
+117 SET PSBOKAY=PSBOKAY_"is scheduled for "_$$DOW^XLFDT(ADMINDT)_", "_$$FMTE^XLFDT(ADMINDT,5)_"."
End DoDot:3
QUIT
+118 IF ADMINDT<DT
Begin DoDot:3
+119 SET PSBOKAY=PSBOKAY_"was scheduled for "_$$DOW^XLFDT(ADMINDT)_", "_$$FMTE^XLFDT(ADMINDT,5)_"."
End DoDot:3
QUIT
+120 SET PSBOKAY="0^Okay to administer"
End DoDot:2
+121 ;*70 end early/late logic
End DoDot:1
+122 ;
+123 ; Validate a PRN Order
+124 if (PSBSCHT="P")
Begin DoDot:1
+125 IF PSBOSTS'="A"
IF PSBOSTS'="R"
IF PSBOSTS'="O"
SET PSBOKAY="-1^Order Not Active"
QUIT
+126 IF PSBNGF
SET PSBOKAY="-1^marked DO NOT GIVE"
QUIT
+127 ;A Patch may have to be removed.
IF (+($GET(PSBOKAY))<0)&(PSBDOSEF="PATCH")
QUIT
+128 ;MRR may need removal *83
IF (+($GET(PSBOKAY))<0)&(PSBMRRFL>0)
QUIT
+129 SET PSBOKAY="1^"
+130 ; Get Last Four Givens
+131 SET PSBDT=""
+132 FOR
SET PSBDT=$ORDER(^PSB(53.79,"AOIP",DFN,+PSBOIT,PSBDT),-1)
if PSBDT=""
QUIT
Begin DoDot:2
+133 SET PSBDA=""
+134 FOR
SET PSBDA=$ORDER(^PSB(53.79,"AOIP",DFN,+PSBOIT,PSBDT,PSBDA),-1)
if 'PSBDA
QUIT
Begin DoDot:3
+135 SET (PSBCNT1,PSBCNT2,PSBCNT3)=0
+136 SET PSBLADT=$$GET1^DIQ(53.79,PSBDA_",",.06,"I")
+137 SET PSBSTUS=$$GET1^DIQ(53.79,PSBDA_",",.09)
+138 if PSBSTUS=""
SET PSBSTUS="U"
+139 SET PSBSCH=$$GET1^DIQ(53.79,PSBDA_",",.12)
+140 SET PSBRSN=$$GET1^DIQ(53.79,PSBDA_",",.21)
+141 SET PSBINJ=$$GET1^DIQ(53.79,PSBDA_",",.16)
+142 if $PIECE(^PSB(53.79,PSBDA,0),U,9)="N"
QUIT
+143 FOR PSBZ=.5,.6,.7
FOR PSBY=0:0
SET PSBY=$ORDER(^PSB(53.79,PSBDA,PSBZ,PSBY))
if 'PSBY
QUIT
Begin DoDot:4
+144 if '$DATA(^PSB(53.79,PSBDA,PSBZ,PSBY))
QUIT
+145 SET PSBDD=$SELECT(PSBZ=.5:53.795,PSBZ=.6:53.796,1:53.797)
+146 ;Add leading 0 for decimal values less than 1, PSB*3*61
SET PSBUNIT=$$GET1^DIQ(PSBDD,PSBY_","_PSBDA_",",.03)
if PSBUNIT>0&(PSBUNIT<1)
SET PSBUNIT="0"_+PSBUNIT
+147 SET PSBUNFR=$$GET1^DIQ(PSBDD,PSBY_","_PSBDA_",",.04)
+148 IF PSBZ=.5
SET PSBCNT1=PSBCNT1+1
+149 IF PSBZ=.6
SET PSBCNT2=PSBCNT2+1
+150 IF PSBZ=.7
SET PSBCNT3=PSBCNT3+1
End DoDot:4
+151 ;Units given or free text not to display for multiple dispense drugs or additives and solution
+152 IF (PSBCNT1>1)!(PSBCNT2>0)!(PSBCNT3>0)
SET (PSBUNIT,PSBUNFR)=""
+153 SET X=PSBLADT_U
+154 SET X=X_PSBSTUS_U_PSBSCH_U_$GET(PSBRSN)_U_$GET(PSBINJ)_U_$GET(PSBUNIT)_U_$GET(PSBUNFR)
+155 SET PSBOKAY($ORDER(PSBOKAY(""),-1)+1)=3_U_X
+156 if $DATA(PSBOKAY(4))
SET PSBDT=0
End DoDot:3
End DoDot:2
+157 SET X1=$$LASTG^PSBCSUTL(DFN,+PSBOIT)
IF X1>0
SET PSBOKAY($ORDER(PSBOKAY(""),-1)+1)=4_U_X1
End DoDot:1
+158 ;
+159 ; Validate a One-Time Order
+160 if PSBSCHT="O"
Begin DoDot:1
+161 SET (PSBGVN,X,Y)=""
+162 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
+163 IF PSBGVN
SET PSBOKAY="-1^Dose Already on medication Log"
QUIT
+164 ; One Time are automatically expired so we don't check STATUS here
+165 IF PSBNGF
SET PSBOKAY="-1^marked DO NOT GIVE"
QUIT
+166 SET PSBOKAY="0^Okay to administer"
End DoDot:1
+167 ;
+168 ; Validate an On Call Order
+169 if PSBSCHT="OC"
Begin DoDot:1
+170 SET PSBOKAY="0^Okay to administer"
+171 SET (PSBGVN,X,Y)=""
+172 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
+173 IF PSBGVN&('$$GET^XPAR("DIV","PSB ADMIN MULTIPLE ONCALL"))
SET PSBOKAY="-1^Dose Already on medication Log"
QUIT
+174 IF PSBOSTS'="A"
IF PSBOSTS'="R"
IF PSBOSTS'="O"
SET PSBOKAY="-1^Order Not Active"
QUIT
+175 IF PSBNGF
SET PSBOKAY="-1^marked DO NOT GIVE"
QUIT
+176 SET X=0
+177 IF PSBGVN
IF $$GET^XPAR("DIV","PSB ADMIN MULTIPLE ONCALL")
Begin DoDot:2
+178 ;*83
IF PSBDOSEF="PATCH"
DO NOTREMVD
QUIT
+179 ;*83
IF PSBMRRFL>0
DO NOTREMVD
QUIT
End DoDot:2
if X
QUIT
+180 SET PSBOKAY="0^Okay to administer"
End DoDot:1
+181 ;
+182 if +PSBOKAY'<0
Begin DoDot:1
+183 NEW PSBDIFF,Y
+184 if (PSBSCHT="C")!(PSBSCHT="OC"&('$GET(PSBGVN)))
Begin DoDot:2
+185 ; On-call or cont and not on the log.
+186 SET Y=$ORDER(^PSB(53.79,"AOIP",DFN,PSBOIT,""),-1)
+187 ;Check for the status of the medication and insert status into text
+188 IF Y]""
SET X=$ORDER(^PSB(53.79,"AOIP",DFN,+PSBOIT,Y,""),-1)
SET PSBSTUS=$PIECE(^PSB(53.79,X,0),U,9)
+189 if Y']""
SET PSBSTUS=""
+190 IF PSBSTUS="N"
Begin DoDot:3
+191 SET X=$ORDER(^PSB(53.79,"AOIP",DFN,PSBOIT,Y,X),-1)
+192 if X']""
Begin DoDot:4
+193 SET Y=$ORDER(^PSB(53.79,"AOIP",DFN,PSBOIT,Y),-1)
IF Y']""
SET PSBQUIT=1
QUIT
+194 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
+195 SET PSBDIFF=$$FMDIFF^XLFDT($$NOW^XLFDT(),Y,2)
+196 ; Greater than 2 hours
if PSBDIFF>7200
QUIT
+197 ;remove "RM" sts previous action test for this warning *83
+198 IF (PSBSTUS="G")!(PSBSTUS="H")!(PSBSTUS="R")
Begin DoDot:3
+199 SET PSBSTUS=$$GET1^DIQ(53.79,X_",",.09)
+200 IF PSBSTUS'=""
Begin DoDot:4
+201 SET Y="1^*** NOTICE, "_PSBOITX_" was "_PSBSTUS_" "_(PSBDIFF\60)_" minutes ago."
+202 IF +PSBOKAY=1
SET PSBOKAY(1)=Y
+203 IF '$TEST
SET PSBOKAY=Y
End DoDot:4
End DoDot:3
End DoDot:2
+204 ;
+205 ;check for same OI medication MRR not removed, warning *83
+206 NEW LST
+207 IF PSBMRRFL
IF $$OIREMVD(DFN,PSBOIT,.LST)
Begin DoDot:2
+208 ;find last ien in psbokay, so won't overwrite with new OI msgs *83
+209 NEW Q
SET Q=$ORDER(PSBOKAY(""),-1)
+210 FOR X=0:0
SET X=$ORDER(LST(X))
if 'X
QUIT
Begin DoDot:3
+211 SET PSBOKAY(Q+X)="1^Medication "_$PIECE(LST(X),U,2)_" for scheduled administration "_$PIECE(LST(X),U)_" has NOT been removed. "
End DoDot:3
End DoDot:2
End DoDot:1
+212 ;
+213 ;adds fall thru err msg text to Results
+214 SET PSB=PSB+1
SET RESULTS(PSB)=PSBOKAY
+215 ;
+216 ;overwrite 0^okay text with 1^warning text IF array PSBOKAY populated
+217 IF RESULTS(1)["0^Okay"
IF $DATA(PSBOKAY)>9
SET PSB=0
+218 FOR X=0:0
SET X=$ORDER(PSBOKAY(X))
if 'X
QUIT
Begin DoDot:1
+219 SET PSB=PSB+1
SET RESULTS(PSB)=PSBOKAY(X)
End DoDot:1
+220 ;
+221 ;set to always agree to content
SET RESULTS(0)=$ORDER(RESULTS(999),-1)
+222 QUIT
+223 ;
NOTREMVD ;Standard "Not Removed" MRR error msg & special pre-warning test *83
+1 SET PSBOKAY=""
+2 IF PSBRMV'="RM"
SET PSBOKAY=$$VARIANCE(PSBRMV,PSBADMIN)
+3 ;check special case of Early Admin - move Early error msg to Results
+4 ;array so PSBOKAY can be reused for later dual -1 errmsg: early admin
+5 ;
+6 IF PSBOKAY["Admin"
IF PSBOKAY["before"
Begin DoDot:1
+7 SET PSB=PSB+1
SET RESULTS(PSB)=PSBOKAY
SET RESULTS(0)=PSB
End DoDot:1
+8 SET X=1
+9 SET PSBOKAY="-1^Cannot Give medication until previous administration has been removed."
+10 QUIT
+11 ;
VARIANCE(ACTION,DATETM) ;check for variance to exceed Early/Late window *83
+1 NEW MSG
+2 ;Minutes before
SET PSBWIN1=$$GET^XPAR("DIV","PSB ADMIN BEFORE")*-1
+3 ;Minutes After
SET PSBWIN2=$$GET^XPAR("DIV","PSB ADMIN AFTER")
+4 DO NOW^%DTC
+5 SET PSBMIN=$SELECT($PIECE(DATETM,".",2):$$DIFF^PSBUTL(DATETM,%),1:0)
+6 ;
+7 ;Not a Removal
if ACTION'="RM"
Begin DoDot:1
+8 IF PSBMIN<PSBWIN1
SET MSG="1^Admin is "_(PSBMIN*-1)_" minutes before the scheduled administration time"
QUIT
+9 IF PSBMIN>PSBWIN2
SET MSG="1^Admin is "_(PSBMIN)_" minutes after the scheduled administration time"
QUIT
+10 SET MSG="0^Okay to "_$SELECT(ACTION="H":"Hold",ACTION="R":"Refuse",1:"administer")
End DoDot:1
+11 ;
+12 ;Removal: use a new code #5 for RED txt (Early RM)
if ACTION="RM"
Begin DoDot:1
+13 SET MSG="0^Okay to Remove"
+14 IF PSBMIN<PSBWIN1
SET MSG="5^Removal is "_(PSBMIN*-1)_" minutes before the scheduled removal time"
QUIT
+15 IF PSBMIN>PSBWIN2
SET MSG="1^Removal is "_(PSBMIN)_" minutes after the scheduled removal time"
QUIT
End DoDot:1
+16 ;
+17 QUIT MSG
+18 ;
OIREMVD(DFN,OI,REM) ;Is another OI MRR not removed?
+1 ; Input:
+2 ; DFN = patient ien
+3 ; OI = Ordreable Item Ien
+4 ;Output:
+5 ; Function - false/true
+6 ; parm- REM(ien), IEN of file 53.79 array of meds needing Removal
+7 ; formatted: Sched Admin date/time ^ Disp drug name ^Ordno
+8 ; if One time sched, then set Sched Admin = actual given date/time
+9 ;
+10 ;check for previous MRR type 1 med not removed *83
+11 NEW CNT,PSBBK,DTE,IEN,QQ,MEDNM,ORDNO,SCHADM
+12 SET PSBBK=$$GET^XPAR("DIV","PSB VDL PATCH DAYS")
+13 SET PSBBK=$$FMADD^XLFDT(DT,-$SELECT(PSBBK>0:PSBBK,1:30))
+14 SET DTE=""
SET CNT=0
+15 FOR
SET DTE=$ORDER(^PSB(53.79,"AOIP",DFN,OI,DTE),-1)
if ('DTE)!((DTE\1)<PSBBK)
QUIT
Begin DoDot:1
+16 SET IEN=""
+17 FOR
SET IEN=$ORDER(^PSB(53.79,"AOIP",DFN,OI,DTE,IEN),-1)
if 'IEN
QUIT
Begin DoDot:2
+18 if $PIECE($GET(^PSB(53.79,IEN,0)),U,9)'="G"
QUIT
+19 SET CNT=CNT+1
+20 SET SCHADM=$$GET1^DIQ(53.79,+IEN,"SCHEDULED ADMINISTRATION TIME")
+21 if 'SCHADM
SET SCHADM=$EXTRACT($$GET1^DIQ(53.79,+IEN,"ACTION DATE/TIME"),1,18)
+22 SET QQ=$ORDER(^PSB(53.79,IEN,.5,0))
+23 if QQ
SET MEDNM=$$GET1^DIQ(53.795,QQ_","_IEN,"DISPENSE DRUG")
+24 SET ORDNO=$$GET1^DIQ(53.79,+IEN,"ORDER REFERENCE NUMBER")
+25 SET REM(CNT)=SCHADM_U_MEDNM_U_ORDNO
End DoDot:2
End DoDot:1
+26 QUIT $DATA(REM)
