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 ;03/06/16 3:06pm
  1. ;;3.0;BAR CODE MED ADMIN;**13,32,68,70,83,92,145**;Mar 2004;Build 2
  1. ;Per VA Directive 6402, this routine should not be modified.
  1. ;
  1. ; Reference/IA
  1. ; EN^PSJBCMA/2828
  1. ; EN^PSJBCMA1/2829
  1. ; GETSIOPI^PSJBCMA5/5763
  1. ;
  1. ;*68 - add call to add special instructions (SI) entries to the
  1. ; ^TMP("PSB") global that ends up in the RESULTS ARRAY of
  1. ; RPC PSB GETORDERTAB.
  1. ;*70 - add tags to rebuild TMP array built by PSJBCMA to filter
  1. ; in or out Clinic Orders per request.
  1. ;*83 - define new var PSBDOA (duration On time in min for MRR meds)
  1. ; and add flag and remove time to PSBREC(34 & 35)
  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. ;
  1. ; *83 If MRR Med, add Remove code & Remove time, (34,35)
  1. D REMOVETM(PSBMRRFL,PSBSCHT)
  1. ;
  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. ;
  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. D:PSBSIOPI GETSI(DFN,PSBONX,PSBTAB) ;*68
  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,PSBVNX]"":$E($P(PSBVNX,",",2))_$E(PSBVNX),1:"***") ;Use first and last initial from name field if Initial field blank, PSB*3*92
  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. ;PSB*3*145 Prevent Saturday schedule from being given on Tuesday
  1. N PSBSCH1 S PSBSCH1=PSBSCH
  1. I PSBSCH1["SATU" S PSBSCH1=$TR(PSBSCH1,"SATU","SATA")
  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. I $F(PSBSCH1,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. ;
  1. GETSI(DFN,ORD,TAB) ;Get Special Instructions/Other Print Info from IM ;*68
  1. ;
  1. ; This Tag will load the SIOPI WP text into the TMP global used by
  1. ; the PSB GETORDERTAB RPC, which ends up in the RESULTS array passed
  1. ; back to the BCMA GUI.
  1. ;
  1. N QQ
  1. K ^TMP("PSJBCMA5",$J,DFN,ORD)
  1. D GETSIOPI^PSJBCMA5(DFN,ORD,1)
  1. Q:'$D(^TMP("PSJBCMA5",$J,DFN,ORD))
  1. F QQ=0:0 S QQ=$O(^TMP("PSJBCMA5",$J,DFN,ORD,QQ)) Q:'QQ D
  1. .S PSB=PSB+1
  1. .S ^TMP("PSB",$J,TAB,PSB)="SI^"_^TMP("PSJBCMA5",$J,DFN,ORD,QQ)
  1. K ^TMP("PSJBCMA5",$J,DFN,ORD)
  1. Q
  1. ;
  1. INCLUDCO ;Rebuild TMP global from PSJBCMA, RETAIN CLINC ORDERS ONLY *70
  1. N QQ,IMCNT,COCNT
  1. S (IMCNT,COCNT)=0 K ^TMP("PSJTMP",$J)
  1. F QQ=0:0 S QQ=$O(^TMP("PSJ",$J,QQ)) Q:'QQ D
  1. . I $P($G(^TMP("PSJ",$J,QQ,0)),U,11)]"" D
  1. .. S COCNT=COCNT+1
  1. .. M ^TMP("PSJTMP",$J,COCNT)=^TMP("PSJ",$J,QQ)
  1. K ^TMP("PSJ",$J) M ^TMP("PSJ",$J)=^TMP("PSJTMP",$J)
  1. K ^TMP("PSJTMP",$J)
  1. S:'$D(^TMP("PSJ",$J)) ^TMP("PSJ",$J,1,0)=-1
  1. Q
  1. ;
  1. REMOVECO ;Rebuild TMP global from PSJBCMA, RETAIN IM ORDERS ONLY *70
  1. N QQ,IMCNT
  1. S IMCNT=0 K ^TMP("PSJTMP",$J)
  1. F QQ=0:0 S QQ=$O(^TMP("PSJ",$J,QQ)) Q:'QQ D
  1. . I $P($G(^TMP("PSJ",$J,QQ,0)),U,11)="" D Q
  1. .. S IMCNT=IMCNT+1
  1. .. M ^TMP("PSJTMP",$J,IMCNT)=^TMP("PSJ",$J,QQ)
  1. K ^TMP("PSJ",$J) M ^TMP("PSJ",$J)=^TMP("PSJTMP",$J)
  1. K ^TMP("PSJTMP",$J)
  1. S:'$D(^TMP("PSJ",$J)) ^TMP("PSJ",$J,1,0)=-1
  1. Q
  1. ;
  1. MODELITE() ;
  1. N ORDCNT,CLIN,ORDNO,STRT,STOP,STAT,PSBIMNOW,PSBIMDT
  1. S ORDCNT=""
  1. K ^TMP("PSJ",$J)
  1. S PSBIMNOW=+$E($$NOW^XLFDT,1,10),PSBIMDT=$P(PSBIMNOW,".")
  1. D EN^PSJBCMA(DFN,PSBIMNOW,PSBIMDT)
  1. Q:^TMP("PSJ",$J,1,0)=-1 ""
  1. F QQ=0:0 S QQ=$O(^TMP("PSJ",$J,QQ)) Q:'QQ D
  1. . S CLIN=$P(^TMP("PSJ",$J,QQ,0),U,11)
  1. . S ORDNO=$P(^TMP("PSJ",$J,QQ,0),U,3)
  1. . S STRT=$P($P(^TMP("PSJ",$J,QQ,1),U,4),".")
  1. . S STOP=$P($P(^TMP("PSJ",$J,QQ,1),U,5),".")
  1. . S STAT=$P(^TMP("PSJ",$J,QQ,1),U,7)
  1. . D:CLIN]""
  1. .. I ORDNO'["P",(STAT="A"!(STAT="H")!(STAT="R")!(STAT="O")),STRT'>DT,STOP'<DT S $P(ORDCNT,U,2)=1 ;modelite display for held, renewed, and on call PSB*3*92
  1. . D:CLIN=""
  1. .. I ORDNO'["P",(STAT="A"!(STAT="H")!(STAT="R")!(STAT="O")),STRT'>DT,STOP'<DT S $P(ORDCNT,U)=1 ;modelite display for held and renewed, and on call PSB*3*92
  1. Q ORDCNT
  1. ;
  1. INITTAB ;*70
  1. K ^TMP("PSB",$J,PSBTAB)
  1. S ^TMP("PSB",$J,PSBTAB,0)=1
  1. S ^TMP("PSB",$J,PSBTAB,1)="-1^No Administration(s) due at this time."
  1. Q
  1. ;
  1. FINDORD(BWDFWD,DFN,PSBDT,PSBTAB) ;Search a patient's orders Bwd or Fwd *70
  1. ; Find the next day that contains an Active admin time not Given.
  1. ;
  1. N QQ,SPDT,STARTDT,STDT,STOPDT,STPDT
  1. S PSBSIOPI="",PSBCLINORD=1
  1. N NODE1,ENDDT,STRDT,STOPDT,STDT,SPDT,STARTDT,STOPDT,SDT,QUIT,REC,QQ
  1. N PSBWBEG,PSBWEND,PSBWADM,FOUND,GIVE,PDT
  1. K ^TMP("PSJ",$J)
  1. D EN^PSJBCMA(DFN,PSBDT,PSBDT),INCLUDCO^PSBVDLU1
  1. Q:^TMP("PSJ",$J,1,0)=-1 -1
  1. ;
  1. ;read thru psj tmp and create start date xref
  1. F QQ=0:0 S QQ=$O(^TMP("PSJ",$J,QQ)) Q:'QQ D
  1. . S NODE1=$G(^TMP("PSJ",$J,QQ,1))
  1. . Q:$P(NODE1,U,7)'="A" ;not active sts
  1. . S STRDT=$P($P(NODE1,U,4),"."),STDT(STRDT)=""
  1. . S STPDT=$P($P(NODE1,U,5),"."),SPDT(STPDT)=""
  1. S STARTDT=+$O(STDT(0))
  1. Q:(BWDFWD=-1)&('STARTDT) -1
  1. S STOPDT=+$O(SPDT(999999999),-1)
  1. Q:(BWDFWD=1)&('STOPDT) -1
  1. ;
  1. D:BWDFWD=-1 LOOPBWD
  1. D:BWDFWD=1 LOOPFWD
  1. Q PDT
  1. ;
  1. LOOPBWD ; Loop thru days backwards and quit when pass End date. *70
  1. S (REC,QUIT,FOUND)=0
  1. F QQ=BWDFWD:BWDFWD S PDT=$$FMADD^XLFDT(PSBDT,QQ) Q:PDT<STARTDT D Q:FOUND!QUIT
  1. . I PDT<STARTDT S QUIT=1 Q
  1. . D INITTAB^PSBVDLU1
  1. . S PSBWBEG=$P(PDT,".")_".0000"
  1. . S PSBWEND=$P(PDT,".")_".2400"
  1. . S PSBWADM=99999
  1. . S PSBWADM=$$FMADD^XLFDT(PDT,"","",+PSBWADM)
  1. . D:PSBTAB="UDTAB" EN^PSBVDLUD(DFN,PDT)
  1. . D:PSBTAB="PBTAB" EN^PSBVDLPB(DFN,PDT)
  1. . S FOUND=+$G(^TMP("PSB",$J,PSBTAB,2)) ;=dfn, if data found
  1. . S GIVE=$P($G(^TMP("PSB",$J,PSBTAB,2)),U,13) ;get give sts
  1. . S:GIVE="G" FOUND=0 ;skip, as was given
  1. S:'FOUND PDT=-1
  1. Q
  1. ;
  1. LOOPFWD ; Loop thru days forwards and quit when pass End date. *70
  1. S (REC,QUIT,FOUND)=0
  1. F QQ=BWDFWD:BWDFWD S PDT=$$FMADD^XLFDT(PSBDT,QQ) Q:PDT>STOPDT D Q:FOUND!QUIT
  1. . I PDT>STOPDT S QUIT=1 Q
  1. . D INITTAB^PSBVDLU1
  1. . S PSBWBEG=$P(PDT,".")_".0000"
  1. . S PSBWEND=$P(PDT,".")_".2400"
  1. . S PSBWADM=99999
  1. . S PSBWADM=$$FMADD^XLFDT(PDT,"","",+PSBWADM)
  1. . D:PSBTAB="UDTAB" EN^PSBVDLUD(DFN,PDT)
  1. . D:PSBTAB="PBTAB" EN^PSBVDLPB(DFN,PDT)
  1. . S FOUND=+$G(^TMP("PSB",$J,PSBTAB,2)) ;=dfn, if data found
  1. . S GIVE=$P($G(^TMP("PSB",$J,PSBTAB,2)),U,13) ;get give sts
  1. . S:GIVE="G" FOUND=0 ;skip, as was given
  1. S:'FOUND PDT=-1
  1. Q
  1. ;
  1. PATCHON(DFN,ORDR) ;check if any patches are still Given & Not Removed per this patient
  1. ; Return values:
  1. ; Func: True/False (1/0) for patches do exist on a patient.
  1. ; ORDR(): array element "C"linic or "I"npatient order = 1 when
  1. ; at least 1 order of this type exists.
  1. ;
  1. N ON,DAYSBK,ORDNO,STOPDT,IMCL
  1. S ON=0,ORDR("C")=0,ORDR("I")=0
  1. Q:'$D(^PSB(53.79,"APATCH",DFN)) ON
  1. F QQ=0:0 S QQ=$O(^PSB(53.79,"APATCH",DFN,QQ)) Q:'QQ D
  1. . F RR=0:0 S RR=$O(^PSB(53.79,"APATCH",DFN,QQ,RR)) Q:'RR D
  1. .. I $P(^PSB(53.79,RR,0),U,9)="G" D
  1. ... S ORDNO=$P(^PSB(53.79,RR,.1),"^")
  1. ... D CLEAN^PSBVT
  1. ... D PSJ1^PSBVT(DFN,ORDNO) Q:'$G(PSBOSP)
  1. ... S STOPDT=PSBOSP
  1. ... S DAYSBK=+($$GET^XPAR("DIV","PSB VDL PATCH DAYS"))
  1. ...; simulate PSBVDLPA logic to look back Kernel param days
  1. ... I DAYSBK D NOW^%DTC I $$FMADD^XLFDT($P(STOPDT,"."),DAYSBK)<X Q
  1. ... S ON=1
  1. ... S IMCL=$S($G(PSBCLORD)]"":"C",1:"I"),ORDR(IMCL)=1
  1. ... D CLEAN^PSBVT
  1. Q ON
  1. ;
  1. INFUSING(DFN,ORDR) ;check if any IV's have bags infusing per this patient
  1. ; Return values:
  1. ; Func: True/False (1/0) for patches do exist on a patient.
  1. ; ORDR(): array element "C"linic or "I"npatient order = 1 when
  1. ; at least 1 order of this type exists.
  1. ;
  1. N ON,DAYSBK,ORDNO,STOPDT,IMCL,PSBCLIEN
  1. S ON=0,ORDR("C")=0,ORDR("I")=0
  1. Q:'$D(^PSB(53.79,"AINFUSING",DFN)) ON
  1. F QQ=0:0 S QQ=$O(^PSB(53.79,"AINFUSING",DFN,QQ)) Q:'QQ D
  1. . F RR=0:0 S RR=$O(^PSB(53.79,"AINFUSING",DFN,QQ,RR)) Q:'RR D
  1. .. S ORDNO=$P(^PSB(53.79,RR,.1),"^")
  1. .. D CLEAN^PSBVT
  1. .. D PSJ1^PSBVT(DFN,ORDNO) Q:'$G(PSBOSP)
  1. .. S STOPDT=PSBOSP
  1. .. ; simulate IV VDL logic to look 3 days back for IM meds or 7 days
  1. .. ; for CO med.
  1. .. D NOW^%DTC
  1. .. I '$G(PSBCLIEN),$$FMADD^XLFDT($P(STOPDT,"."),3)<X Q
  1. .. I $G(PSBCLIEN),$$FMADD^XLFDT($P(STOPDT,"."),7)<X Q
  1. .. S ON=1
  1. .. S IMCL=$S($G(PSBCLORD)]"":"C",1:"I"),ORDR(IMCL)=1
  1. .. D CLEAN^PSBVT
  1. Q ON
  1. ;
  1. STOPPED(DFN,ORDR) ;check if any IV's have bags infusing per this patient
  1. ; Return values:
  1. ; Func: True/False (1/0) for patches do exist on a patient.
  1. ; ORDR(): array element "C"linic or "I"npatient order = 1 when
  1. ; at least 1 order of this type exists.
  1. ;
  1. N ON,DAYSBK,ORDNO,STOPDT,IMCL,PSBCLIEN
  1. S ON=0,ORDR("C")=0,ORDR("I")=0
  1. Q:'$D(^PSB(53.79,"ASTOPPED",DFN)) ON
  1. F QQ=0:0 S QQ=$O(^PSB(53.79,"ASTOPPED",DFN,QQ)) Q:'QQ D
  1. . F RR=0:0 S RR=$O(^PSB(53.79,"ASTOPPED",DFN,QQ,RR)) Q:'RR D
  1. .. S ORDNO=$P(^PSB(53.79,RR,.1),"^")
  1. .. D CLEAN^PSBVT
  1. .. D PSJ1^PSBVT(DFN,ORDNO) Q:'$G(PSBOSP)
  1. .. S STOPDT=PSBOSP
  1. .. ; simulate IV VDL logic to look 3 days back for IM meds or 7 days
  1. .. ; for CO med.
  1. .. D NOW^%DTC
  1. .. I 'PSBCLIEN,$$FMADD^XLFDT($P(STOPDT,"."),3)<X Q
  1. .. I PSBCLIEN,$$FMADD^XLFDT($P(STOPDT,"."),7)<X Q
  1. .. S ON=1
  1. .. S IMCL=$S($G(PSBCLORD)]"":"C",1:"I"),ORDR(IMCL)=1
  1. .. D CLEAN^PSBVT
  1. Q ON
  1. ;
  1. REMOVETM(MRR,STYP) ;** Check if MRR med & add to Results array (34,35) *83
  1. ;
  1. ; Add MRR code to Results(34) and if MRR > 0 then add remove time
  1. ; to Results(35).
  1. ;
  1. N RMDT,RMTIM
  1. S $P(PSBREC,U,34)=MRR ;set MRR flag in 34
  1. ;
  1. Q:'MRR ;Quit, not MRR med, no remove time
  1. Q:(PSBSCHT="OC")!(PSBSCHT="P") ;Quit, schd types have no admin times
  1. Q:$P(PSBREC,U,35) ;Quit, already set from get MRR rtns
  1. ;
  1. ; Remove date/time Calculation method will correctly compute a future
  1. ; Remove date/time per this admin time, by using the FMADD function
  1. ; to add the DOA value to the admin time. DOA value is the time the
  1. ; med is to be on the patient and must be removed after that time.
  1. ;
  1. ; **Notice: Sched Type of "O", Remove time = Order Stop date/time
  1. ;
  1. ; e.g. if sched is Q7D and Freq=10080, then DOA=10080 also, and is
  1. ; returned by PSJBCMA1
  1. ;
  1. S ADMTIM=$P(PSBREC,U,14) ;admin time
  1. S:PSBDOA RMTIM=$$FMADD^XLFDT(ADMTIM,,,PSBDOA) ;calc RM time if DOA
  1. I (PSBDOA<1!(PSBOSP>$$NOW^XLFDT)),STYP="O" S RMTIM=PSBOSP ;RM time for One-Time, non-expired orders, PSB*3*92
  1. S $P(PSBREC,U,35)=$G(RMTIM) ;Add RM date/time
  1. Q