Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: PSBVDLU1

PSBVDLU1.m

Go to the documentation of this file. 
  1. PSBVDLU1 ;BIRMINGHAM/EFC-VIRTUAL DUE LIST (VDL) UTILITIES ;Mar 2004
  1.  ;;3.0;BAR CODE MED ADMIN;**13,32**;Mar 2004;Build 32
  1.  ;
  1.  ; Reference/IA
  1.  ; EN^PSJBCMA1/2829
  1.  ;
  1. ODDSCH(PSBTABX) ;
  1.  I (PSBOST'<PSBWBEG)&(PSBOST'>PSBWEND) D ADD(PSBREC,PSBOTXT,PSBOST,PSBDDS,PSBSOLS,PSBADDS,PSBTABX)  ;Include start date/time as admin
  1.  S PSBQUIT=0,PSBCDT=PSBOST F  S PSBCDT=$$FMADD^XLFDT(PSBCDT,"","",PSBFREQ) Q:PSBQUIT=1  D
  1.  .I $P(PSBCDT,".",2)="" S PSBCDT=PSBCDT-1_".24"
  1.  .I PSBCDT>PSBWEND S PSBQUIT=1 Q
  1.  .I PSBCDT'<PSBWBEG,PSBCDT<PSBOSP D ADD(PSBREC,PSBOTXT,PSBCDT,PSBDDS,PSBSOLS,PSBADDS,PSBTABX) Q
  1.  Q
  1. GETFREQ(PSBDFN,PSBORDN) ;
  1.  K ^TMP("PSJ1",$J)
  1.  D EN^PSJBCMA1(PSBDFN,PSBORDN,1)
  1.  S PSBFREQ=$P(^TMP("PSJ1",$J,4),U,11)
  1.  S PSBSCHBR=$P(^TMP("PSJ1",$J,2),"^",5)
  1.  I $$PSBDCHK1^PSBVT1(PSBSCHBR) S PSBFREQ=""
  1.  K ^TMP("PSJ1",$J)
  1.  Q PSBFREQ
  1.  ;
  1. GETADMIN(PSBDFN,PSBORDN,PSBSTRT,PSBFREQ,PSBEVDT) ;
  1.  ;Determine administration times of an odd schedule for today
  1.  N PSBADMIN
  1.  K ^TMP("PSB",$J,"GETADMIN")
  1.  D EN^PSJBCMA1(PSBDFN,PSBORDN,1)
  1.  S PSBADMIN=$P(^TMP("PSJ1",$J,4),U,9),PSBFREQ=$P(^TMP("PSJ1",$J,4),U,11),^TMP("PSB",$J,"GETADMIN",0)=PSBADMIN
  1.  I $E(PSBFREQ)'?1N K ^TMP("PSJ1",$J) Q $G(^TMP("PSB",$J,"GETADMIN",0))
  1.  I PSBFREQ=0 K ^TMP("PSJ1",$J) Q $G(^TMP("PSB",$J,"GETADMIN",0))
  1.  I PSBSTRT'<PSBEVDT S PSBADMIN=$E($P(PSBSTRT,".",2)_"0000",1,4),^TMP("PSB",$J,"GETADMIN",0)=PSBADMIN
  1.  S PSBCDT=PSBSTRT,(PSBADTMX,PSBQUIT)=0 F  S PSBCDT=$$FMADD^XLFDT(PSBCDT,"","",PSBFREQ) D  Q:PSBQUIT=1
  1.  .I $P(PSBCDT,".",2)="" S PSBCDT=PSBCDT-1_".24"
  1.  .I (PSBCDT\1)>(PSBEVDT\1) S PSBQUIT=1 Q
  1.  .I (PSBCDT\1)=(PSBEVDT\1) S PSBADMIN=PSBADMIN_$S(PSBADMIN="":"",1:"-")_$E($P(PSBCDT,".",2)_"0000",1,4)
  1.  .S ^TMP("PSB",$J,"GETADMIN",PSBADTMX)=PSBADMIN
  1.  .S:($L(PSBADMIN)+5)>255 PSBADTMX=PSBADTMX+1,PSBADMIN=""
  1.  K ^TMP("PSJ1",$J),PSBADTMX
  1.  Q $G(^TMP("PSB",$J,"GETADMIN",0))
  1.  ;
  1. ADD(PSBREC,PSBSI,PSBDT,PSBDD,PSBSOL,PSBADD,PSBTAB) ;
  1.  ;
  1.  ; Description: Add order to ^TMP("PSB",$J,PSBTAB,...) for RPC Return RESULTS
  1.  ;
  1.  ; PSBREC=order hdr from above
  1.  ; PSBSI=special instructions
  1.  ; PSBDT=admin date/time
  1.  ; PSBDD=Dispense Drugs
  1.  ; PSBSOL=Solutions
  1.  ; PSBADD=Additives
  1.  ;
  1.  N PSB
  1.  S PSBDT=$E(PSBDT,1,12),PSBQR=0
  1.  S PSB=$O(^TMP("PSB",$J,PSBTAB,""),-1) ; Get next node
  1.  S $P(PSBREC,U,14)=PSBDT ; Admin Time sits in ^14
  1.  I $P(PSBREC,U,5)'="O" S X=$O(^PSB(53.79,"AORD",DFN,PSBONX,PSBDT,0)) D:X
  1.  .S $P(PSBREC,U,12)=X
  1.  .K PSBLCK L +^PSB(53.79,X):1  I  L -^PSB(53.79,X) S PSBLCK=1
  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)
  1.  .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
  1.  .I PSBSTUS="G",$G(PSBFLAG) D CHECK ;Get the correct dispense drug
  1.  I ($P(PSBREC,U,5)="O") D
  1.  .S X=$O(^PSB(53.79,"AORDX",DFN,PSBONX,"")) Q:X=""
  1.  .S Y=$O(^PSB(53.79,"AORDX",DFN,PSBONX,X,"")) Q:Y=""  S $P(PSBREC,U,12)=Y
  1.  .K PSBLCK L +^PSB(53.79,Y):1  I  L -^PSB(53.79,Y) S PSBLCK=1
  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)
  1.  .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
  1.  .I PSBSTUS="G",$G(PSBFLAG) D CHECK
  1.  Q:PSBQR=1
  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
  1.  S PSB=PSB+1,^TMP("PSB",$J,PSBTAB,PSB)=PSBREC ; Order Hdr
  1.  I $P(PSBREC,U,12)]"" S PSBONVDL($P(PSBREC,U,12))=""
  1.  S PSB=PSB+1,^TMP("PSB",$J,PSBTAB,PSB)=PSBSI ; Special Instructions
  1.  ; add dispense drugs
  1.  I $D(PSBDDA) S X="" F  S X=$O(PSBDDA(X)) Q:X=""  S PSB=PSB+1,^TMP("PSB",$J,PSBTAB,PSB)=PSBDDA(X)
  1.  S PSBCHDT=0
  1.  I (PSBTAB'["CVRSHT"),(PSBONX["V"),(PSBOSTS="D"),($G(PSBFOR)="") D  Q  ;get infusing bag from DCed but not DEed orders
  1.  .D PSJ^PSBVT(PSBX)
  1.  .D INFUSING^PSBVDLU2 I PSBCOMP=0 Q
  1.  .I $D(PSBSOLA) S X="" F  S X=$O(PSBSOLA(X)) Q:X=""  S PSB=PSB+1,^TMP("PSB",$J,PSBTAB,PSB)=PSBSOLA(X)
  1.  .I $D(PSBADA) S X="" F  S X=$O(PSBADA(X)) Q:X=""  S PSB=PSB+1,^TMP("PSB",$J,PSBTAB,PSB)=PSBADA(X)
  1.  .S X="" F  S X=$O(PSBPORA(PSBONX,X)) S PSBUID=$P(PSBPORA(PSBONX,X),U,1) Q:PSBUID]""  Q:X=""
  1.  .I PSBUID["P" Q
  1.  .I PSBUID["WS" D
  1.  ..S PSBNODE=$O(^PSB(53.79,"AUID",DFN,X,PSBUID,""))
  1.  ..S PSBUIDA(PSBUID)="ID"_U_PSBUID
  1.  ..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)
  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)
  1.  .S PSBSONX=PSBONX
  1.  .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))
  1.  .S PSBONX=PSBSONX
  1.  .S:$D(PSBUIDA(PSBUID)) PSB=PSB+2,^TMP("PSB",$J,PSBTAB,PSB-1)=PSBUIDA(PSBUID),^TMP("PSB",$J,PSBTAB,PSB)="END"
  1.  .D CLEAN^PSBVT,PSJ1^PSBVT(DFN,$O(PSBPORA("")))
  1.  ; add additives
  1.  I $D(PSBADA) S X="" F  S X=$O(PSBADA(X)) Q:X=""  S PSB=PSB+1,^TMP("PSB",$J,PSBTAB,PSB)=PSBADA(X)
  1.  ; add solutions
  1.  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)
  1.  I PSBONX["V" D EN^PSBPOIV(DFN,PSBONX)  ; get bags
  1.  I $D(^TMP("PSBAR",$J)) S PSBUID=DFN_"V"_99999 F  S PSBUID=$O(^TMP("PSBAR",$J,PSBUID),-1) Q:PSBUID=""  D
  1.  .S PSBUIDS=^TMP("PSBAR",$J,PSBUID)
  1.  .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
  1.  .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
  1.  .I $P(PSBUIDS,U,2)="C" Q  ; bag is completed
  1.  .I $P(PSBUIDS,U,2)="G" Q  ; bag is given (PBTAB)
  1.  .S PSB=PSB+1,^TMP("PSB",$J,PSBTAB,PSB)=$P(PSBUIDS,U,10,999)
  1.  K ^TMP("PSBAR",$J)
  1.  S PSB=PSB+1,^TMP("PSB",$J,PSBTAB,PSB)="END"
  1.  S ^TMP("PSB",$J,PSBTAB,0)=PSB
  1.  Q
  1.  ;
  1. CHECK S FILE=53.795,PSBNODE=.5,PSBIENS=X_","
  1.  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)
  1.  Q
  1.  ;
  1. VNURSE(PSBTAB) ;add initials of verifying pharmacist/verifying nurse
  1.  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
  1.  .K ^TMP("PSJ1",$J)
  1.  .D PSJ1^PSBVT(DFN,$P(X,U,2))
  1.  .S $P(^TMP("PSB",$J,PSBTAB,PSBLP),U,19)=$S(PSBVNI]"":PSBVNI,1:"***")
  1.  K PSBLP,PSBTAB
  1.  Q
  1.  ;
  1. OKAY(PSBSTRT,PSBADMIN,PSBSCH,PSBORDER,PSBDRUG,PSBFREQ,PSBOSTS) ;
  1.  ;
  1.  ; Description: Determines if an order schedule is valid for
  1.  ;  the date in PSBADMIN (i.e. Q4D, is it valid today)
  1.  ;
  1.  ; PSBSTRT:  Start Date of order (Time ignored)
  1.  ; PSBADMIN: Date of administration to check (Time ignored)
  1.  ; PSBSCH:  Schedule (i.e. MO-WE-FR@0900 or Q48H...)
  1.  ; PSBORDER: Order reference
  1.  ; PSBDRUG:  Drug ordered (Orderable Item)
  1.  ; PSBOSTS: The status of the order
  1.  ;
  1.  N PSBOKAY,PSBDAYS,PSBDOW
  1.  S PSBOSTS=$G(PSBOSTS)
  1.  ;
  1.  S PSBOKAY=0  ; Default Flag
  1.  I PSBFREQ'="",PSBFREQ'="D",PSBFREQ'>1440 Q 1
  1.  ;PRN and ONE TIMES show everyday
  1.  I (PSBSCHT="P")!(PSBSCHT="O") Q 1
  1.  S PSBDAYS=$$DAYS(PSBSCH)
  1.  ;
  1.  I PSBDAYS=1 S PSBOKAY=1 Q PSBOKAY  ; Order is everyday
  1.  ;
  1.  ; find out if today is a good day for multi days
  1.  S PSBOKAY=0,PSBRDTE=PSBSTRT
  1.  S PSBADBR=PSBADMIN\1
  1.  S PSBENR=(PSBADMIN\1)+1
  1.  I PSBDAYS>1 D  Q PSBOKAY
  1.  .I PSBADBR=(PSBSTRT\1) S PSBOKAY=1
  1.  .F  S PSBRDTE=$$FMADD^XLFDT(PSBRDTE,"","",PSBFREQ) Q:PSBRDTE>PSBENR  D
  1.  ..I $P(PSBRDTE,".",2)="" S PSBRDTE=PSBRDTE-1_".24"
  1.  ..I PSBRDTE\1=PSBADBR S PSBOKAY=1
  1.  ..I PSBOKAY="1" Q
  1.  ;
  1.  ; Try the MO-WE-FR@0800 thing as last resort
  1.  S X=PSBADMIN D H^%DTC I %Y=-1 D  Q PSBOKAY  ; Error
  1.  .S PSBOKAY=0
  1.  .Q:PSBOSTS="E"
  1.  .Q:$G(PSBMHND)="PSBOMH"
  1.  .D ERROR^PSBMLU($G(PSBORDER,"UNKNOWN"),$G(PSBDRUG,""),DFN,"Unable to determine schedule "_PSBSCH,PSBSCH)
  1.  S PSBDOW=$P("SU^MO^TU^WE^TH^FR^SA",U,%Y+1)
  1.  I $F(PSBSCH,PSBDOW)>0 S PSBOKAY=1 Q PSBOKAY
  1.  S PSBOKAY=0
  1.  Q PSBOKAY
  1.  ;
  1. DAYS(PSB) ; Return days between doses (-1: error, 1:everyday 2: QOD...)
  1.  ;
  1.  ; Is it a PRN
  1.  I PSB?.E1"PRN".E Q 1  ; Straight PRN - As Needed
  1.  ;
  1.  S PSB=$TR(PSB," ","")
  1.  I PSB?2.4N.E Q 1
  1.  S X=PSBFREQ/1440 Q X
  1.  ;
  1.  Q
  1.  ;
  1. LAST ;
  1.  S PSBCC=0
  1.  S ZZ="" F  S ZZ=$O(^PSB(53.79,X,.3,ZZ),-1) Q:'ZZ  Q:PSBFLAG=1  S PSBDATA2=$G(^(ZZ,0)) D
  1.  .S PSBCC=PSBCC+1
  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
  1.  Q
  1.  ;