- 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 Jan 18, 2025@02:42:38 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)