- PSBVDLU1 ;BIRMINGHAM/EFC-VIRTUAL DUE LIST (VDL) UTILITIES ;03/06/16 3:06pm
- ;;3.0;BAR CODE MED ADMIN;**13,32,68,70,83,92,145**;Mar 2004;Build 2
- ;Per VA Directive 6402, this routine should not be modified.
- ;
- ; Reference/IA
- ; EN^PSJBCMA/2828
- ; EN^PSJBCMA1/2829
- ; GETSIOPI^PSJBCMA5/5763
- ;
- ;*68 - add call to add special instructions (SI) entries to the
- ; ^TMP("PSB") global that ends up in the RESULTS ARRAY of
- ; RPC PSB GETORDERTAB.
- ;*70 - add tags to rebuild TMP array built by PSJBCMA to filter
- ; in or out Clinic Orders per request.
- ;*83 - define new var PSBDOA (duration On time in min for MRR meds)
- ; and add flag and remove time to PSBREC(34 & 35)
- ;
- ODDSCH(PSBTABX) ;
- I (PSBOST'<PSBWBEG)&(PSBOST'>PSBWEND) D ADD(PSBREC,PSBOTXT,PSBOST,PSBDDS,PSBSOLS,PSBADDS,PSBTABX) ;Include start date/time as admin
- S PSBQUIT=0,PSBCDT=PSBOST F S PSBCDT=$$FMADD^XLFDT(PSBCDT,"","",PSBFREQ) Q:PSBQUIT=1 D
- .I $P(PSBCDT,".",2)="" S PSBCDT=PSBCDT-1_".24"
- .I PSBCDT>PSBWEND S PSBQUIT=1 Q
- .I PSBCDT'<PSBWBEG,PSBCDT<PSBOSP D ADD(PSBREC,PSBOTXT,PSBCDT,PSBDDS,PSBSOLS,PSBADDS,PSBTABX) Q
- Q
- GETFREQ(PSBDFN,PSBORDN) ;
- K ^TMP("PSJ1",$J)
- D EN^PSJBCMA1(PSBDFN,PSBORDN,1)
- S PSBFREQ=$P(^TMP("PSJ1",$J,4),U,11)
- S PSBSCHBR=$P(^TMP("PSJ1",$J,2),"^",5)
- I $$PSBDCHK1^PSBVT1(PSBSCHBR) S PSBFREQ=""
- K ^TMP("PSJ1",$J)
- Q PSBFREQ
- ;
- GETADMIN(PSBDFN,PSBORDN,PSBSTRT,PSBFREQ,PSBEVDT) ;
- ;Determine administration times of an odd schedule for today
- N PSBADMIN
- K ^TMP("PSB",$J,"GETADMIN")
- D EN^PSJBCMA1(PSBDFN,PSBORDN,1)
- S PSBADMIN=$P(^TMP("PSJ1",$J,4),U,9),PSBFREQ=$P(^TMP("PSJ1",$J,4),U,11),^TMP("PSB",$J,"GETADMIN",0)=PSBADMIN
- I $E(PSBFREQ)'?1N K ^TMP("PSJ1",$J) Q $G(^TMP("PSB",$J,"GETADMIN",0))
- I PSBFREQ=0 K ^TMP("PSJ1",$J) Q $G(^TMP("PSB",$J,"GETADMIN",0))
- I PSBSTRT'<PSBEVDT S PSBADMIN=$E($P(PSBSTRT,".",2)_"0000",1,4),^TMP("PSB",$J,"GETADMIN",0)=PSBADMIN
- S PSBCDT=PSBSTRT,(PSBADTMX,PSBQUIT)=0 F S PSBCDT=$$FMADD^XLFDT(PSBCDT,"","",PSBFREQ) D Q:PSBQUIT=1
- .I $P(PSBCDT,".",2)="" S PSBCDT=PSBCDT-1_".24"
- .I (PSBCDT\1)>(PSBEVDT\1) S PSBQUIT=1 Q
- .I (PSBCDT\1)=(PSBEVDT\1) S PSBADMIN=PSBADMIN_$S(PSBADMIN="":"",1:"-")_$E($P(PSBCDT,".",2)_"0000",1,4)
- .S ^TMP("PSB",$J,"GETADMIN",PSBADTMX)=PSBADMIN
- .S:($L(PSBADMIN)+5)>255 PSBADTMX=PSBADTMX+1,PSBADMIN=""
- K ^TMP("PSJ1",$J),PSBADTMX
- Q $G(^TMP("PSB",$J,"GETADMIN",0))
- ;
- ADD(PSBREC,PSBSI,PSBDT,PSBDD,PSBSOL,PSBADD,PSBTAB) ;
- ;
- ; Description: Add order to ^TMP("PSB",$J,PSBTAB,...) for RPC Return RESULTS
- ;
- ; PSBREC=order hdr from above
- ; PSBSI=special instructions
- ; PSBDT=admin date/time
- ; PSBDD=Dispense Drugs
- ; PSBSOL=Solutions
- ; PSBADD=Additives
- ;
- N PSB
- S PSBDT=$E(PSBDT,1,12),PSBQR=0
- S PSB=$O(^TMP("PSB",$J,PSBTAB,""),-1) ; Get next node
- S $P(PSBREC,U,14)=PSBDT ; Admin Time sits in ^14
- ;
- ; *83 If MRR Med, add Remove code & Remove time, (34,35)
- D REMOVETM(PSBMRRFL,PSBSCHT)
- ;
- I $P(PSBREC,U,5)'="O" S X=$O(^PSB(53.79,"AORD",DFN,PSBONX,PSBDT,0)) D:X
- .S $P(PSBREC,U,12)=X
- .K PSBLCK L +^PSB(53.79,X):1 I L -^PSB(53.79,X) S PSBLCK=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)
- .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
- .I PSBSTUS="G",$G(PSBFLAG) D CHECK ;Get the correct dispense drug
- I ($P(PSBREC,U,5)="O") D
- .S X=$O(^PSB(53.79,"AORDX",DFN,PSBONX,"")) Q:X=""
- .S Y=$O(^PSB(53.79,"AORDX",DFN,PSBONX,X,"")) Q:Y="" S $P(PSBREC,U,12)=Y
- .K PSBLCK L +^PSB(53.79,Y):1 I L -^PSB(53.79,Y) S PSBLCK=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)
- .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
- .I PSBSTUS="G",$G(PSBFLAG) D CHECK
- Q:PSBQR=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
- S PSB=PSB+1,^TMP("PSB",$J,PSBTAB,PSB)=PSBREC ; Order Hdr
- I $P(PSBREC,U,12)]"" S PSBONVDL($P(PSBREC,U,12))=""
- S PSB=PSB+1,^TMP("PSB",$J,PSBTAB,PSB)=PSBSI ; Special Instructions
- ; add dispense drugs
- I $D(PSBDDA) S X="" F S X=$O(PSBDDA(X)) Q:X="" S PSB=PSB+1,^TMP("PSB",$J,PSBTAB,PSB)=PSBDDA(X)
- S PSBCHDT=0
- I (PSBTAB'["CVRSHT"),(PSBONX["V"),(PSBOSTS="D"),($G(PSBFOR)="") D Q ;get infusing bag from DCed but not DEed orders
- .D PSJ^PSBVT(PSBX)
- .D INFUSING^PSBVDLU2 I PSBCOMP=0 Q
- .I $D(PSBSOLA) S X="" F S X=$O(PSBSOLA(X)) Q:X="" S PSB=PSB+1,^TMP("PSB",$J,PSBTAB,PSB)=PSBSOLA(X)
- .I $D(PSBADA) S X="" F S X=$O(PSBADA(X)) Q:X="" S PSB=PSB+1,^TMP("PSB",$J,PSBTAB,PSB)=PSBADA(X)
- .S X="" F S X=$O(PSBPORA(PSBONX,X)) S PSBUID=$P(PSBPORA(PSBONX,X),U,1) Q:PSBUID]"" Q:X=""
- .I PSBUID["P" Q
- .I PSBUID["WS" D
- ..S PSBNODE=$O(^PSB(53.79,"AUID",DFN,X,PSBUID,""))
- ..S PSBUIDA(PSBUID)="ID"_U_PSBUID
- ..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)
- ..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)
- .S PSBSONX=PSBONX
- .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))
- .S PSBONX=PSBSONX
- .S:$D(PSBUIDA(PSBUID)) PSB=PSB+2,^TMP("PSB",$J,PSBTAB,PSB-1)=PSBUIDA(PSBUID),^TMP("PSB",$J,PSBTAB,PSB)="END"
- .D CLEAN^PSBVT,PSJ1^PSBVT(DFN,$O(PSBPORA("")))
- ; add additives
- I $D(PSBADA) S X="" F S X=$O(PSBADA(X)) Q:X="" S PSB=PSB+1,^TMP("PSB",$J,PSBTAB,PSB)=PSBADA(X)
- ; add solutions
- 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)
- I PSBONX["V" D EN^PSBPOIV(DFN,PSBONX) ; get bags
- I $D(^TMP("PSBAR",$J)) S PSBUID=DFN_"V"_99999 F S PSBUID=$O(^TMP("PSBAR",$J,PSBUID),-1) Q:PSBUID="" D
- .S PSBUIDS=^TMP("PSBAR",$J,PSBUID)
- .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
- .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
- .I $P(PSBUIDS,U,2)="C" Q ; bag is completed
- .I $P(PSBUIDS,U,2)="G" Q ; bag is given (PBTAB)
- .S PSB=PSB+1,^TMP("PSB",$J,PSBTAB,PSB)=$P(PSBUIDS,U,10,999)
- K ^TMP("PSBAR",$J)
- D:PSBSIOPI GETSI(DFN,PSBONX,PSBTAB) ;*68
- S PSB=PSB+1,^TMP("PSB",$J,PSBTAB,PSB)="END"
- S ^TMP("PSB",$J,PSBTAB,0)=PSB
- Q
- ;
- CHECK S FILE=53.795,PSBNODE=.5,PSBIENS=X_","
- 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)
- Q
- ;
- VNURSE(PSBTAB) ;add initials of verifying pharmacist/verifying nurse
- 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
- .K ^TMP("PSJ1",$J)
- .D PSJ1^PSBVT(DFN,$P(X,U,2))
- .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
- K PSBLP,PSBTAB
- Q
- ;
- OKAY(PSBSTRT,PSBADMIN,PSBSCH,PSBORDER,PSBDRUG,PSBFREQ,PSBOSTS) ;
- ;
- ; Description: Determines if an order schedule is valid for
- ; the date in PSBADMIN (i.e. Q4D, is it valid today)
- ;
- ; PSBSTRT: Start Date of order (Time ignored)
- ; PSBADMIN: Date of administration to check (Time ignored)
- ; PSBSCH: Schedule (i.e. MO-WE-FR@0900 or Q48H...)
- ; PSBORDER: Order reference
- ; PSBDRUG: Drug ordered (Orderable Item)
- ; PSBOSTS: The status of the order
- ;
- N PSBOKAY,PSBDAYS,PSBDOW
- S PSBOSTS=$G(PSBOSTS)
- ;
- S PSBOKAY=0 ; Default Flag
- I PSBFREQ'="",PSBFREQ'="D",PSBFREQ'>1440 Q 1
- ;PRN and ONE TIMES show everyday
- I (PSBSCHT="P")!(PSBSCHT="O") Q 1
- S PSBDAYS=$$DAYS(PSBSCH)
- ;
- I PSBDAYS=1 S PSBOKAY=1 Q PSBOKAY ; Order is everyday
- ;
- ; find out if today is a good day for multi days
- S PSBOKAY=0,PSBRDTE=PSBSTRT
- S PSBADBR=PSBADMIN\1
- S PSBENR=(PSBADMIN\1)+1
- I PSBDAYS>1 D Q PSBOKAY
- .I PSBADBR=(PSBSTRT\1) S PSBOKAY=1
- .F S PSBRDTE=$$FMADD^XLFDT(PSBRDTE,"","",PSBFREQ) Q:PSBRDTE>PSBENR D
- ..I $P(PSBRDTE,".",2)="" S PSBRDTE=PSBRDTE-1_".24"
- ..I PSBRDTE\1=PSBADBR S PSBOKAY=1
- ..I PSBOKAY="1" Q
- ;
- ; Try the MO-WE-FR@0800 thing as last resort
- S X=PSBADMIN D H^%DTC I %Y=-1 D Q PSBOKAY ; Error
- .S PSBOKAY=0
- .Q:PSBOSTS="E"
- .Q:$G(PSBMHND)="PSBOMH"
- .D ERROR^PSBMLU($G(PSBORDER,"UNKNOWN"),$G(PSBDRUG,""),DFN,"Unable to determine schedule "_PSBSCH,PSBSCH)
- ;PSB*3*145 Prevent Saturday schedule from being given on Tuesday
- N PSBSCH1 S PSBSCH1=PSBSCH
- I PSBSCH1["SATU" S PSBSCH1=$TR(PSBSCH1,"SATU","SATA")
- S PSBDOW=$P("SU^MO^TU^WE^TH^FR^SA",U,%Y+1)
- ;I $F(PSBSCH,PSBDOW)>0 S PSBOKAY=1 Q PSBOKAY
- I $F(PSBSCH1,PSBDOW)>0 S PSBOKAY=1 Q PSBOKAY
- S PSBOKAY=0
- Q PSBOKAY
- ;
- DAYS(PSB) ; Return days between doses (-1: error, 1:everyday 2: QOD...)
- ;
- ; Is it a PRN
- I PSB?.E1"PRN".E Q 1 ; Straight PRN - As Needed
- ;
- S PSB=$TR(PSB," ","")
- I PSB?2.4N.E Q 1
- S X=PSBFREQ/1440 Q X
- ;
- Q
- ;
- LAST ;
- S PSBCC=0
- S ZZ="" F S ZZ=$O(^PSB(53.79,X,.3,ZZ),-1) Q:'ZZ Q:PSBFLAG=1 S PSBDATA2=$G(^(ZZ,0)) D
- .S PSBCC=PSBCC+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
- Q
- ;
- GETSI(DFN,ORD,TAB) ;Get Special Instructions/Other Print Info from IM ;*68
- ;
- ; This Tag will load the SIOPI WP text into the TMP global used by
- ; the PSB GETORDERTAB RPC, which ends up in the RESULTS array passed
- ; back to the BCMA GUI.
- ;
- N QQ
- K ^TMP("PSJBCMA5",$J,DFN,ORD)
- D GETSIOPI^PSJBCMA5(DFN,ORD,1)
- Q:'$D(^TMP("PSJBCMA5",$J,DFN,ORD))
- F QQ=0:0 S QQ=$O(^TMP("PSJBCMA5",$J,DFN,ORD,QQ)) Q:'QQ D
- .S PSB=PSB+1
- .S ^TMP("PSB",$J,TAB,PSB)="SI^"_^TMP("PSJBCMA5",$J,DFN,ORD,QQ)
- K ^TMP("PSJBCMA5",$J,DFN,ORD)
- Q
- ;
- INCLUDCO ;Rebuild TMP global from PSJBCMA, RETAIN CLINC ORDERS ONLY *70
- N QQ,IMCNT,COCNT
- S (IMCNT,COCNT)=0 K ^TMP("PSJTMP",$J)
- F QQ=0:0 S QQ=$O(^TMP("PSJ",$J,QQ)) Q:'QQ D
- . I $P($G(^TMP("PSJ",$J,QQ,0)),U,11)]"" D
- .. S COCNT=COCNT+1
- .. M ^TMP("PSJTMP",$J,COCNT)=^TMP("PSJ",$J,QQ)
- K ^TMP("PSJ",$J) M ^TMP("PSJ",$J)=^TMP("PSJTMP",$J)
- K ^TMP("PSJTMP",$J)
- S:'$D(^TMP("PSJ",$J)) ^TMP("PSJ",$J,1,0)=-1
- Q
- ;
- REMOVECO ;Rebuild TMP global from PSJBCMA, RETAIN IM ORDERS ONLY *70
- N QQ,IMCNT
- S IMCNT=0 K ^TMP("PSJTMP",$J)
- F QQ=0:0 S QQ=$O(^TMP("PSJ",$J,QQ)) Q:'QQ D
- . I $P($G(^TMP("PSJ",$J,QQ,0)),U,11)="" D Q
- .. S IMCNT=IMCNT+1
- .. M ^TMP("PSJTMP",$J,IMCNT)=^TMP("PSJ",$J,QQ)
- K ^TMP("PSJ",$J) M ^TMP("PSJ",$J)=^TMP("PSJTMP",$J)
- K ^TMP("PSJTMP",$J)
- S:'$D(^TMP("PSJ",$J)) ^TMP("PSJ",$J,1,0)=-1
- Q
- ;
- MODELITE() ;
- N ORDCNT,CLIN,ORDNO,STRT,STOP,STAT,PSBIMNOW,PSBIMDT
- S ORDCNT=""
- K ^TMP("PSJ",$J)
- S PSBIMNOW=+$E($$NOW^XLFDT,1,10),PSBIMDT=$P(PSBIMNOW,".")
- D EN^PSJBCMA(DFN,PSBIMNOW,PSBIMDT)
- Q:^TMP("PSJ",$J,1,0)=-1 ""
- F QQ=0:0 S QQ=$O(^TMP("PSJ",$J,QQ)) Q:'QQ D
- . S CLIN=$P(^TMP("PSJ",$J,QQ,0),U,11)
- . S ORDNO=$P(^TMP("PSJ",$J,QQ,0),U,3)
- . S STRT=$P($P(^TMP("PSJ",$J,QQ,1),U,4),".")
- . S STOP=$P($P(^TMP("PSJ",$J,QQ,1),U,5),".")
- . S STAT=$P(^TMP("PSJ",$J,QQ,1),U,7)
- . D:CLIN]""
- .. 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
- . D:CLIN=""
- .. 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
- Q ORDCNT
- ;
- INITTAB ;*70
- K ^TMP("PSB",$J,PSBTAB)
- S ^TMP("PSB",$J,PSBTAB,0)=1
- S ^TMP("PSB",$J,PSBTAB,1)="-1^No Administration(s) due at this time."
- Q
- ;
- FINDORD(BWDFWD,DFN,PSBDT,PSBTAB) ;Search a patient's orders Bwd or Fwd *70
- ; Find the next day that contains an Active admin time not Given.
- ;
- N QQ,SPDT,STARTDT,STDT,STOPDT,STPDT
- S PSBSIOPI="",PSBCLINORD=1
- N NODE1,ENDDT,STRDT,STOPDT,STDT,SPDT,STARTDT,STOPDT,SDT,QUIT,REC,QQ
- N PSBWBEG,PSBWEND,PSBWADM,FOUND,GIVE,PDT
- K ^TMP("PSJ",$J)
- D EN^PSJBCMA(DFN,PSBDT,PSBDT),INCLUDCO^PSBVDLU1
- Q:^TMP("PSJ",$J,1,0)=-1 -1
- ;
- ;read thru psj tmp and create start date xref
- F QQ=0:0 S QQ=$O(^TMP("PSJ",$J,QQ)) Q:'QQ D
- . S NODE1=$G(^TMP("PSJ",$J,QQ,1))
- . Q:$P(NODE1,U,7)'="A" ;not active sts
- . S STRDT=$P($P(NODE1,U,4),"."),STDT(STRDT)=""
- . S STPDT=$P($P(NODE1,U,5),"."),SPDT(STPDT)=""
- S STARTDT=+$O(STDT(0))
- Q:(BWDFWD=-1)&('STARTDT) -1
- S STOPDT=+$O(SPDT(999999999),-1)
- Q:(BWDFWD=1)&('STOPDT) -1
- ;
- D:BWDFWD=-1 LOOPBWD
- D:BWDFWD=1 LOOPFWD
- Q PDT
- ;
- LOOPBWD ; Loop thru days backwards and quit when pass End date. *70
- S (REC,QUIT,FOUND)=0
- F QQ=BWDFWD:BWDFWD S PDT=$$FMADD^XLFDT(PSBDT,QQ) Q:PDT<STARTDT D Q:FOUND!QUIT
- . I PDT<STARTDT S QUIT=1 Q
- . D INITTAB^PSBVDLU1
- . S PSBWBEG=$P(PDT,".")_".0000"
- . S PSBWEND=$P(PDT,".")_".2400"
- . S PSBWADM=99999
- . S PSBWADM=$$FMADD^XLFDT(PDT,"","",+PSBWADM)
- . D:PSBTAB="UDTAB" EN^PSBVDLUD(DFN,PDT)
- . D:PSBTAB="PBTAB" EN^PSBVDLPB(DFN,PDT)
- . S FOUND=+$G(^TMP("PSB",$J,PSBTAB,2)) ;=dfn, if data found
- . S GIVE=$P($G(^TMP("PSB",$J,PSBTAB,2)),U,13) ;get give sts
- . S:GIVE="G" FOUND=0 ;skip, as was given
- S:'FOUND PDT=-1
- Q
- ;
- LOOPFWD ; Loop thru days forwards and quit when pass End date. *70
- S (REC,QUIT,FOUND)=0
- F QQ=BWDFWD:BWDFWD S PDT=$$FMADD^XLFDT(PSBDT,QQ) Q:PDT>STOPDT D Q:FOUND!QUIT
- . I PDT>STOPDT S QUIT=1 Q
- . D INITTAB^PSBVDLU1
- . S PSBWBEG=$P(PDT,".")_".0000"
- . S PSBWEND=$P(PDT,".")_".2400"
- . S PSBWADM=99999
- . S PSBWADM=$$FMADD^XLFDT(PDT,"","",+PSBWADM)
- . D:PSBTAB="UDTAB" EN^PSBVDLUD(DFN,PDT)
- . D:PSBTAB="PBTAB" EN^PSBVDLPB(DFN,PDT)
- . S FOUND=+$G(^TMP("PSB",$J,PSBTAB,2)) ;=dfn, if data found
- . S GIVE=$P($G(^TMP("PSB",$J,PSBTAB,2)),U,13) ;get give sts
- . S:GIVE="G" FOUND=0 ;skip, as was given
- S:'FOUND PDT=-1
- Q
- ;
- PATCHON(DFN,ORDR) ;check if any patches are still Given & Not Removed per this patient
- ; Return values:
- ; Func: True/False (1/0) for patches do exist on a patient.
- ; ORDR(): array element "C"linic or "I"npatient order = 1 when
- ; at least 1 order of this type exists.
- ;
- N ON,DAYSBK,ORDNO,STOPDT,IMCL
- S ON=0,ORDR("C")=0,ORDR("I")=0
- Q:'$D(^PSB(53.79,"APATCH",DFN)) ON
- F QQ=0:0 S QQ=$O(^PSB(53.79,"APATCH",DFN,QQ)) Q:'QQ D
- . F RR=0:0 S RR=$O(^PSB(53.79,"APATCH",DFN,QQ,RR)) Q:'RR D
- .. I $P(^PSB(53.79,RR,0),U,9)="G" D
- ... S ORDNO=$P(^PSB(53.79,RR,.1),"^")
- ... D CLEAN^PSBVT
- ... D PSJ1^PSBVT(DFN,ORDNO) Q:'$G(PSBOSP)
- ... S STOPDT=PSBOSP
- ... S DAYSBK=+($$GET^XPAR("DIV","PSB VDL PATCH DAYS"))
- ...; simulate PSBVDLPA logic to look back Kernel param days
- ... I DAYSBK D NOW^%DTC I $$FMADD^XLFDT($P(STOPDT,"."),DAYSBK)<X Q
- ... S ON=1
- ... S IMCL=$S($G(PSBCLORD)]"":"C",1:"I"),ORDR(IMCL)=1
- ... D CLEAN^PSBVT
- Q ON
- ;
- INFUSING(DFN,ORDR) ;check if any IV's have bags infusing per this patient
- ; Return values:
- ; Func: True/False (1/0) for patches do exist on a patient.
- ; ORDR(): array element "C"linic or "I"npatient order = 1 when
- ; at least 1 order of this type exists.
- ;
- N ON,DAYSBK,ORDNO,STOPDT,IMCL,PSBCLIEN
- S ON=0,ORDR("C")=0,ORDR("I")=0
- Q:'$D(^PSB(53.79,"AINFUSING",DFN)) ON
- F QQ=0:0 S QQ=$O(^PSB(53.79,"AINFUSING",DFN,QQ)) Q:'QQ D
- . F RR=0:0 S RR=$O(^PSB(53.79,"AINFUSING",DFN,QQ,RR)) Q:'RR D
- .. S ORDNO=$P(^PSB(53.79,RR,.1),"^")
- .. D CLEAN^PSBVT
- .. D PSJ1^PSBVT(DFN,ORDNO) Q:'$G(PSBOSP)
- .. S STOPDT=PSBOSP
- .. ; simulate IV VDL logic to look 3 days back for IM meds or 7 days
- .. ; for CO med.
- .. D NOW^%DTC
- .. I '$G(PSBCLIEN),$$FMADD^XLFDT($P(STOPDT,"."),3)<X Q
- .. I $G(PSBCLIEN),$$FMADD^XLFDT($P(STOPDT,"."),7)<X Q
- .. S ON=1
- .. S IMCL=$S($G(PSBCLORD)]"":"C",1:"I"),ORDR(IMCL)=1
- .. D CLEAN^PSBVT
- Q ON
- ;
- STOPPED(DFN,ORDR) ;check if any IV's have bags infusing per this patient
- ; Return values:
- ; Func: True/False (1/0) for patches do exist on a patient.
- ; ORDR(): array element "C"linic or "I"npatient order = 1 when
- ; at least 1 order of this type exists.
- ;
- N ON,DAYSBK,ORDNO,STOPDT,IMCL,PSBCLIEN
- S ON=0,ORDR("C")=0,ORDR("I")=0
- Q:'$D(^PSB(53.79,"ASTOPPED",DFN)) ON
- F QQ=0:0 S QQ=$O(^PSB(53.79,"ASTOPPED",DFN,QQ)) Q:'QQ D
- . F RR=0:0 S RR=$O(^PSB(53.79,"ASTOPPED",DFN,QQ,RR)) Q:'RR D
- .. S ORDNO=$P(^PSB(53.79,RR,.1),"^")
- .. D CLEAN^PSBVT
- .. D PSJ1^PSBVT(DFN,ORDNO) Q:'$G(PSBOSP)
- .. S STOPDT=PSBOSP
- .. ; simulate IV VDL logic to look 3 days back for IM meds or 7 days
- .. ; for CO med.
- .. D NOW^%DTC
- .. I 'PSBCLIEN,$$FMADD^XLFDT($P(STOPDT,"."),3)<X Q
- .. I PSBCLIEN,$$FMADD^XLFDT($P(STOPDT,"."),7)<X Q
- .. S ON=1
- .. S IMCL=$S($G(PSBCLORD)]"":"C",1:"I"),ORDR(IMCL)=1
- .. D CLEAN^PSBVT
- Q ON
- ;
- REMOVETM(MRR,STYP) ;** Check if MRR med & add to Results array (34,35) *83
- ;
- ; Add MRR code to Results(34) and if MRR > 0 then add remove time
- ; to Results(35).
- ;
- N RMDT,RMTIM
- S $P(PSBREC,U,34)=MRR ;set MRR flag in 34
- ;
- Q:'MRR ;Quit, not MRR med, no remove time
- Q:(PSBSCHT="OC")!(PSBSCHT="P") ;Quit, schd types have no admin times
- Q:$P(PSBREC,U,35) ;Quit, already set from get MRR rtns
- ;
- ; Remove date/time Calculation method will correctly compute a future
- ; Remove date/time per this admin time, by using the FMADD function
- ; to add the DOA value to the admin time. DOA value is the time the
- ; med is to be on the patient and must be removed after that time.
- ;
- ; **Notice: Sched Type of "O", Remove time = Order Stop date/time
- ;
- ; e.g. if sched is Q7D and Freq=10080, then DOA=10080 also, and is
- ; returned by PSJBCMA1
- ;
- S ADMTIM=$P(PSBREC,U,14) ;admin time
- S:PSBDOA RMTIM=$$FMADD^XLFDT(ADMTIM,,,PSBDOA) ;calc RM time if DOA
- I (PSBDOA<1!(PSBOSP>$$NOW^XLFDT)),STYP="O" S RMTIM=PSBOSP ;RM time for One-Time, non-expired orders, PSB*3*92
- S $P(PSBREC,U,35)=$G(RMTIM) ;Add RM date/time
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSBVDLU1 18317 printed Jan 18, 2025@02:42:34 Page 2
- 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
- +2 ;Per VA Directive 6402, this routine should not be modified.
- +3 ;
- +4 ; Reference/IA
- +5 ; EN^PSJBCMA/2828
- +6 ; EN^PSJBCMA1/2829
- +7 ; GETSIOPI^PSJBCMA5/5763
- +8 ;
- +9 ;*68 - add call to add special instructions (SI) entries to the
- +10 ; ^TMP("PSB") global that ends up in the RESULTS ARRAY of
- +11 ; RPC PSB GETORDERTAB.
- +12 ;*70 - add tags to rebuild TMP array built by PSJBCMA to filter
- +13 ; in or out Clinic Orders per request.
- +14 ;*83 - define new var PSBDOA (duration On time in min for MRR meds)
- +15 ; and add flag and remove time to PSBREC(34 & 35)
- +16 ;
- ODDSCH(PSBTABX) ;
- +1 ;Include start date/time as admin
- IF (PSBOST'<PSBWBEG)&(PSBOST'>PSBWEND)
- DO ADD(PSBREC,PSBOTXT,PSBOST,PSBDDS,PSBSOLS,PSBADDS,PSBTABX)
- +2 SET PSBQUIT=0
- SET PSBCDT=PSBOST
- FOR
- SET PSBCDT=$$FMADD^XLFDT(PSBCDT,"","",PSBFREQ)
- if PSBQUIT=1
- QUIT
- Begin DoDot:1
- +3 IF $PIECE(PSBCDT,".",2)=""
- SET PSBCDT=PSBCDT-1_".24"
- +4 IF PSBCDT>PSBWEND
- SET PSBQUIT=1
- QUIT
- +5 IF PSBCDT'<PSBWBEG
- IF PSBCDT<PSBOSP
- DO ADD(PSBREC,PSBOTXT,PSBCDT,PSBDDS,PSBSOLS,PSBADDS,PSBTABX)
- QUIT
- End DoDot:1
- +6 QUIT
- GETFREQ(PSBDFN,PSBORDN) ;
- +1 KILL ^TMP("PSJ1",$JOB)
- +2 DO EN^PSJBCMA1(PSBDFN,PSBORDN,1)
- +3 SET PSBFREQ=$PIECE(^TMP("PSJ1",$JOB,4),U,11)
- +4 SET PSBSCHBR=$PIECE(^TMP("PSJ1",$JOB,2),"^",5)
- +5 IF $$PSBDCHK1^PSBVT1(PSBSCHBR)
- SET PSBFREQ=""
- +6 KILL ^TMP("PSJ1",$JOB)
- +7 QUIT PSBFREQ
- +8 ;
- GETADMIN(PSBDFN,PSBORDN,PSBSTRT,PSBFREQ,PSBEVDT) ;
- +1 ;Determine administration times of an odd schedule for today
- +2 NEW PSBADMIN
- +3 KILL ^TMP("PSB",$JOB,"GETADMIN")
- +4 DO EN^PSJBCMA1(PSBDFN,PSBORDN,1)
- +5 SET PSBADMIN=$PIECE(^TMP("PSJ1",$JOB,4),U,9)
- SET PSBFREQ=$PIECE(^TMP("PSJ1",$JOB,4),U,11)
- SET ^TMP("PSB",$JOB,"GETADMIN",0)=PSBADMIN
- +6 IF $EXTRACT(PSBFREQ)'?1N
- KILL ^TMP("PSJ1",$JOB)
- QUIT $GET(^TMP("PSB",$JOB,"GETADMIN",0))
- +7 IF PSBFREQ=0
- KILL ^TMP("PSJ1",$JOB)
- QUIT $GET(^TMP("PSB",$JOB,"GETADMIN",0))
- +8 IF PSBSTRT'<PSBEVDT
- SET PSBADMIN=$EXTRACT($PIECE(PSBSTRT,".",2)_"0000",1,4)
- SET ^TMP("PSB",$JOB,"GETADMIN",0)=PSBADMIN
- +9 SET PSBCDT=PSBSTRT
- SET (PSBADTMX,PSBQUIT)=0
- FOR
- SET PSBCDT=$$FMADD^XLFDT(PSBCDT,"","",PSBFREQ)
- Begin DoDot:1
- +10 IF $PIECE(PSBCDT,".",2)=""
- SET PSBCDT=PSBCDT-1_".24"
- +11 IF (PSBCDT\1)>(PSBEVDT\1)
- SET PSBQUIT=1
- QUIT
- +12 IF (PSBCDT\1)=(PSBEVDT\1)
- SET PSBADMIN=PSBADMIN_$SELECT(PSBADMIN="":"",1:"-")_$EXTRACT($PIECE(PSBCDT,".",2)_"0000",1,4)
- +13 SET ^TMP("PSB",$JOB,"GETADMIN",PSBADTMX)=PSBADMIN
- +14 if ($LENGTH(PSBADMIN)+5)>255
- SET PSBADTMX=PSBADTMX+1
- SET PSBADMIN=""
- End DoDot:1
- if PSBQUIT=1
- QUIT
- +15 KILL ^TMP("PSJ1",$JOB),PSBADTMX
- +16 QUIT $GET(^TMP("PSB",$JOB,"GETADMIN",0))
- +17 ;
- ADD(PSBREC,PSBSI,PSBDT,PSBDD,PSBSOL,PSBADD,PSBTAB) ;
- +1 ;
- +2 ; Description: Add order to ^TMP("PSB",$J,PSBTAB,...) for RPC Return RESULTS
- +3 ;
- +4 ; PSBREC=order hdr from above
- +5 ; PSBSI=special instructions
- +6 ; PSBDT=admin date/time
- +7 ; PSBDD=Dispense Drugs
- +8 ; PSBSOL=Solutions
- +9 ; PSBADD=Additives
- +10 ;
- +11 NEW PSB
- +12 SET PSBDT=$EXTRACT(PSBDT,1,12)
- SET PSBQR=0
- +13 ; Get next node
- SET PSB=$ORDER(^TMP("PSB",$JOB,PSBTAB,""),-1)
- +14 ; Admin Time sits in ^14
- SET $PIECE(PSBREC,U,14)=PSBDT
- +15 ;
- +16 ; *83 If MRR Med, add Remove code & Remove time, (34,35)
- +17 DO REMOVETM(PSBMRRFL,PSBSCHT)
- +18 ;
- +19 IF $PIECE(PSBREC,U,5)'="O"
- SET X=$ORDER(^PSB(53.79,"AORD",DFN,PSBONX,PSBDT,0))
- if X
- Begin DoDot:1
- +20 SET $PIECE(PSBREC,U,12)=X
- +21 KILL PSBLCK
- LOCK +^PSB(53.79,X):1
- IF $TEST
- LOCK -^PSB(53.79,X)
- SET PSBLCK=1
- +22 SET PSBSTUS=$PIECE(^PSB(53.79,X,0),U,9)
- SET $PIECE(PSBREC,U,13)=$SELECT(PSBSTUS="N":"",(PSBSTUS="")&$GET(PSBLCK):"U",1:PSBSTUS)
- SET $PIECE(PSBREC,U,23)=$PIECE(^PSB(53.79,X,0),U,10)
- SET $PIECE(PSBREC,U,24)=$PIECE(^PSB(53.79,X,0),U,7)
- +23 IF $DATA(^PSB(53.79,X))
- IF PSBDOSEF="PATCH"
- IF PSBSTUS="G"
- IF PSBDT=$PIECE(^PSB(53.79,X,.1),U,3)
- IF PSBQRR=0
- SET PSBQR=1
- +24 ;Get the correct dispense drug
- IF PSBSTUS="G"
- IF $GET(PSBFLAG)
- DO CHECK
- End DoDot:1
- +25 IF ($PIECE(PSBREC,U,5)="O")
- Begin DoDot:1
- +26 SET X=$ORDER(^PSB(53.79,"AORDX",DFN,PSBONX,""))
- if X=""
- QUIT
- +27 SET Y=$ORDER(^PSB(53.79,"AORDX",DFN,PSBONX,X,""))
- if Y=""
- QUIT
- SET $PIECE(PSBREC,U,12)=Y
- +28 KILL PSBLCK
- LOCK +^PSB(53.79,Y):1
- IF $TEST
- LOCK -^PSB(53.79,Y)
- SET PSBLCK=1
- +29 SET PSBSTUS=$PIECE(^PSB(53.79,Y,0),U,9)
- SET $PIECE(PSBREC,U,13)=$SELECT(PSBSTUS="N":"",(PSBSTUS="")&$GET(PSBLCK):"U",1:PSBSTUS)
- SET $PIECE(PSBREC,U,24)=$PIECE(^PSB(53.79,Y,0),U,7)
- +30 IF $DATA(^PSB(53.79,Y))
- IF PSBDOSEF="PATCH"
- IF PSBSTUS="G"
- IF PSBDT=$PIECE(^PSB(53.79,Y,.1),U,3)
- IF PSBQRR=0
- SET PSBQR=1
- +31 IF PSBSTUS="G"
- IF $GET(PSBFLAG)
- DO CHECK
- End DoDot:1
- +32 if PSBQR=1
- QUIT
- +33 ;
- +34 SET $PIECE(PSBREC,U,25)=0
- IF $GET(PSBTRFL)
- IF $PIECE(PSBREC,U,11)]""
- IF $PIECE(PSBREC,U,11)'<$GET(PSBNTDT)
- IF $PIECE(PSBREC,U,11)'>$GET(PSBTRDT)
- SET $PIECE(PSBREC,U,25)=1
- +35 ; Order Hdr
- SET PSB=PSB+1
- SET ^TMP("PSB",$JOB,PSBTAB,PSB)=PSBREC
- +36 IF $PIECE(PSBREC,U,12)]""
- SET PSBONVDL($PIECE(PSBREC,U,12))=""
- +37 ; Special Instructions
- SET PSB=PSB+1
- SET ^TMP("PSB",$JOB,PSBTAB,PSB)=PSBSI
- +38 ; add dispense drugs
- +39 IF $DATA(PSBDDA)
- SET X=""
- FOR
- SET X=$ORDER(PSBDDA(X))
- if X=""
- QUIT
- SET PSB=PSB+1
- SET ^TMP("PSB",$JOB,PSBTAB,PSB)=PSBDDA(X)
- +40 SET PSBCHDT=0
- +41 ;get infusing bag from DCed but not DEed orders
- IF (PSBTAB'["CVRSHT")
- IF (PSBONX["V")
- IF (PSBOSTS="D")
- IF ($GET(PSBFOR)="")
- Begin DoDot:1
- +42 DO PSJ^PSBVT(PSBX)
- +43 DO INFUSING^PSBVDLU2
- IF PSBCOMP=0
- QUIT
- +44 IF $DATA(PSBSOLA)
- SET X=""
- FOR
- SET X=$ORDER(PSBSOLA(X))
- if X=""
- QUIT
- SET PSB=PSB+1
- SET ^TMP("PSB",$JOB,PSBTAB,PSB)=PSBSOLA(X)
- +45 IF $DATA(PSBADA)
- SET X=""
- FOR
- SET X=$ORDER(PSBADA(X))
- if X=""
- QUIT
- SET PSB=PSB+1
- SET ^TMP("PSB",$JOB,PSBTAB,PSB)=PSBADA(X)
- +46 SET X=""
- FOR
- SET X=$ORDER(PSBPORA(PSBONX,X))
- SET PSBUID=$PIECE(PSBPORA(PSBONX,X),U,1)
- if PSBUID]""
- QUIT
- if X=""
- QUIT
- +47 IF PSBUID["P"
- QUIT
- +48 IF PSBUID["WS"
- Begin DoDot:2
- +49 SET PSBNODE=$ORDER(^PSB(53.79,"AUID",DFN,X,PSBUID,""))
- +50 SET PSBUIDA(PSBUID)="ID"_U_PSBUID
- +51 SET X=0
- FOR
- SET X=$ORDER(^PSB(53.79,PSBNODE,.6,X))
- if 'X
- QUIT
- SET PSBUIDA(PSBUID)=PSBUIDA(PSBUID)_U_"ADD;"_$PIECE(^PSB(53.79,PSBNODE,.6,X,0),U,1)
- +52 SET X=0
- FOR
- SET X=$ORDER(^PSB(53.79,PSBNODE,.7,X))
- if 'X
- QUIT
- SET PSBUIDA(PSBUID)=PSBUIDA(PSBUID)_U_"SOL;"_$PIECE(^PSB(53.79,PSBNODE,.7,X,0),U,1)
- End DoDot:2
- +53 SET PSBSONX=PSBONX
- +54 IF '$DATA(PSBUIDA(PSBUID))
- SET PSBCKOR=""
- FOR
- SET PSBCKOR=$ORDER(PSBPORA(PSBSONX,PSBCKOR))
- if PSBCKOR=""
- QUIT
- DO CLEAN^PSBVT
- DO PSJ1^PSBVT(DFN,PSBCKOR)
- if $DATA(PSBUIDA(PSBUID))
- QUIT
- +55 SET PSBONX=PSBSONX
- +56 if $DATA(PSBUIDA(PSBUID))
- SET PSB=PSB+2
- SET ^TMP("PSB",$JOB,PSBTAB,PSB-1)=PSBUIDA(PSBUID)
- SET ^TMP("PSB",$JOB,PSBTAB,PSB)="END"
- +57 DO CLEAN^PSBVT
- DO PSJ1^PSBVT(DFN,$ORDER(PSBPORA("")))
- End DoDot:1
- QUIT
- +58 ; add additives
- +59 IF $DATA(PSBADA)
- SET X=""
- FOR
- SET X=$ORDER(PSBADA(X))
- if X=""
- QUIT
- SET PSB=PSB+1
- SET ^TMP("PSB",$JOB,PSBTAB,PSB)=PSBADA(X)
- +60 ; add solutions
- +61 IF $DATA(PSBSOLA)
- SET X=""
- FOR
- SET X=$ORDER(PSBSOLA(X))
- if X=""
- QUIT
- SET $PIECE(PSBSOLA(X),U,5)=""
- SET PSB=PSB+1
- SET ^TMP("PSB",$JOB,PSBTAB,PSB)=PSBSOLA(X)
- +62 ; get bags
- IF PSBONX["V"
- DO EN^PSBPOIV(DFN,PSBONX)
- +63 IF $DATA(^TMP("PSBAR",$JOB))
- SET PSBUID=DFN_"V"_99999
- FOR
- SET PSBUID=$ORDER(^TMP("PSBAR",$JOB,PSBUID),-1)
- if PSBUID=""
- QUIT
- Begin DoDot:1
- +64 SET PSBUIDS=^TMP("PSBAR",$JOB,PSBUID)
- +65 ; bag has invalid IV parameter, is not infusing or stopped
- IF $PIECE(PSBUIDS,U,1)="I"
- IF $PIECE(PSBUIDS,U,2)'="I"
- IF $PIECE(PSBUIDS,U,2)'="S"
- QUIT
- +66 ; label is no longer valid, bag is not infusing or stopped
- IF $PIECE(PSBUIDS,U,2)'="I"
- IF $PIECE(PSBUIDS,U,2)'="S"
- IF $PIECE(PSBUIDS,U,8)'=""
- QUIT
- +67 ; bag is completed
- IF $PIECE(PSBUIDS,U,2)="C"
- QUIT
- +68 ; bag is given (PBTAB)
- IF $PIECE(PSBUIDS,U,2)="G"
- QUIT
- +69 SET PSB=PSB+1
- SET ^TMP("PSB",$JOB,PSBTAB,PSB)=$PIECE(PSBUIDS,U,10,999)
- End DoDot:1
- +70 KILL ^TMP("PSBAR",$JOB)
- +71 ;*68
- if PSBSIOPI
- DO GETSI(DFN,PSBONX,PSBTAB)
- +72 SET PSB=PSB+1
- SET ^TMP("PSB",$JOB,PSBTAB,PSB)="END"
- +73 SET ^TMP("PSB",$JOB,PSBTAB,0)=PSB
- +74 QUIT
- +75 ;
- CHECK SET FILE=53.795
- SET PSBNODE=.5
- SET PSBIENS=X_","
- +1 FOR I=0:0
- SET I=$ORDER(^PSB(53.79,X,PSBNODE,I))
- if 'I
- QUIT
- SET $PIECE(PSBDDS,U,3,4)=$$GET1^DIQ(FILE,I_","_PSBIENS,.01,"I")_U_$$GET1^DIQ(FILE,I_","_PSBIENS,.01)
- +2 QUIT
- +3 ;
- VNURSE(PSBTAB) ;add initials of verifying pharmacist/verifying nurse
- +1 FOR PSBLP=1:1:$PIECE(^TMP("PSB",$JOB,PSBTAB,0),U,1)
- SET X=^TMP("PSB",$JOB,PSBTAB,PSBLP)
- IF $PIECE(X,U)=DFN
- Begin DoDot:1
- +2 KILL ^TMP("PSJ1",$JOB)
- +3 DO PSJ1^PSBVT(DFN,$PIECE(X,U,2))
- +4 ;Use first and last initial from name field if Initial field blank, PSB*3*92
- SET $PIECE(^TMP("PSB",$JOB,PSBTAB,PSBLP),U,19)=$SELECT(PSBVNI]"":PSBVNI,PSBVNX]"":$EXTRACT($PIECE(PSBVNX,",",2))_$EXTRACT(PSBVNX),1:"***")
- End DoDot:1
- +5 KILL PSBLP,PSBTAB
- +6 QUIT
- +7 ;
- OKAY(PSBSTRT,PSBADMIN,PSBSCH,PSBORDER,PSBDRUG,PSBFREQ,PSBOSTS) ;
- +1 ;
- +2 ; Description: Determines if an order schedule is valid for
- +3 ; the date in PSBADMIN (i.e. Q4D, is it valid today)
- +4 ;
- +5 ; PSBSTRT: Start Date of order (Time ignored)
- +6 ; PSBADMIN: Date of administration to check (Time ignored)
- +7 ; PSBSCH: Schedule (i.e. MO-WE-FR@0900 or Q48H...)
- +8 ; PSBORDER: Order reference
- +9 ; PSBDRUG: Drug ordered (Orderable Item)
- +10 ; PSBOSTS: The status of the order
- +11 ;
- +12 NEW PSBOKAY,PSBDAYS,PSBDOW
- +13 SET PSBOSTS=$GET(PSBOSTS)
- +14 ;
- +15 ; Default Flag
- SET PSBOKAY=0
- +16 IF PSBFREQ'=""
- IF PSBFREQ'="D"
- IF PSBFREQ'>1440
- QUIT 1
- +17 ;PRN and ONE TIMES show everyday
- +18 IF (PSBSCHT="P")!(PSBSCHT="O")
- QUIT 1
- +19 SET PSBDAYS=$$DAYS(PSBSCH)
- +20 ;
- +21 ; Order is everyday
- IF PSBDAYS=1
- SET PSBOKAY=1
- QUIT PSBOKAY
- +22 ;
- +23 ; find out if today is a good day for multi days
- +24 SET PSBOKAY=0
- SET PSBRDTE=PSBSTRT
- +25 SET PSBADBR=PSBADMIN\1
- +26 SET PSBENR=(PSBADMIN\1)+1
- +27 IF PSBDAYS>1
- Begin DoDot:1
- +28 IF PSBADBR=(PSBSTRT\1)
- SET PSBOKAY=1
- +29 FOR
- SET PSBRDTE=$$FMADD^XLFDT(PSBRDTE,"","",PSBFREQ)
- if PSBRDTE>PSBENR
- QUIT
- Begin DoDot:2
- +30 IF $PIECE(PSBRDTE,".",2)=""
- SET PSBRDTE=PSBRDTE-1_".24"
- +31 IF PSBRDTE\1=PSBADBR
- SET PSBOKAY=1
- +32 IF PSBOKAY="1"
- QUIT
- End DoDot:2
- End DoDot:1
- QUIT PSBOKAY
- +33 ;
- +34 ; Try the MO-WE-FR@0800 thing as last resort
- +35 ; Error
- SET X=PSBADMIN
- DO H^%DTC
- IF %Y=-1
- Begin DoDot:1
- +36 SET PSBOKAY=0
- +37 if PSBOSTS="E"
- QUIT
- +38 if $GET(PSBMHND)="PSBOMH"
- QUIT
- +39 DO ERROR^PSBMLU($GET(PSBORDER,"UNKNOWN"),$GET(PSBDRUG,""),DFN,"Unable to determine schedule "_PSBSCH,PSBSCH)
- End DoDot:1
- QUIT PSBOKAY
- +40 ;PSB*3*145 Prevent Saturday schedule from being given on Tuesday
- +41 NEW PSBSCH1
- SET PSBSCH1=PSBSCH
- +42 IF PSBSCH1["SATU"
- SET PSBSCH1=$TRANSLATE(PSBSCH1,"SATU","SATA")
- +43 SET PSBDOW=$PIECE("SU^MO^TU^WE^TH^FR^SA",U,%Y+1)
- +44 ;I $F(PSBSCH,PSBDOW)>0 S PSBOKAY=1 Q PSBOKAY
- +45 IF $FIND(PSBSCH1,PSBDOW)>0
- SET PSBOKAY=1
- QUIT PSBOKAY
- +46 SET PSBOKAY=0
- +47 QUIT PSBOKAY
- +48 ;
- DAYS(PSB) ; Return days between doses (-1: error, 1:everyday 2: QOD...)
- +1 ;
- +2 ; Is it a PRN
- +3 ; Straight PRN - As Needed
- IF PSB?.E1"PRN".E
- QUIT 1
- +4 ;
- +5 SET PSB=$TRANSLATE(PSB," ","")
- +6 IF PSB?2.4N.E
- QUIT 1
- +7 SET X=PSBFREQ/1440
- QUIT X
- +8 ;
- +9 QUIT
- +10 ;
- LAST ;
- +1 SET PSBCC=0
- +2 SET ZZ=""
- FOR
- SET ZZ=$ORDER(^PSB(53.79,X,.3,ZZ),-1)
- if 'ZZ
- QUIT
- if PSBFLAG=1
- QUIT
- SET PSBDATA2=$GET(^(ZZ,0))
- Begin DoDot:1
- +3 SET PSBCC=PSBCC+1
- +4 IF (PSBCC=2)!($PIECE($PIECE(PSBDATA2,U)," ")="Refused:")!($PIECE($PIECE(PSBDATA2,U)," ")="Held:")
- SET $PIECE(PSBREC,U,11)=$PIECE(PSBDATA2,U,3)
- SET PSBFLAG=1
- End DoDot:1
- +5 QUIT
- +6 ;
- GETSI(DFN,ORD,TAB) ;Get Special Instructions/Other Print Info from IM ;*68
- +1 ;
- +2 ; This Tag will load the SIOPI WP text into the TMP global used by
- +3 ; the PSB GETORDERTAB RPC, which ends up in the RESULTS array passed
- +4 ; back to the BCMA GUI.
- +5 ;
- +6 NEW QQ
- +7 KILL ^TMP("PSJBCMA5",$JOB,DFN,ORD)
- +8 DO GETSIOPI^PSJBCMA5(DFN,ORD,1)
- +9 if '$DATA(^TMP("PSJBCMA5",$JOB,DFN,ORD))
- QUIT
- +10 FOR QQ=0:0
- SET QQ=$ORDER(^TMP("PSJBCMA5",$JOB,DFN,ORD,QQ))
- if 'QQ
- QUIT
- Begin DoDot:1
- +11 SET PSB=PSB+1
- +12 SET ^TMP("PSB",$JOB,TAB,PSB)="SI^"_^TMP("PSJBCMA5",$JOB,DFN,ORD,QQ)
- End DoDot:1
- +13 KILL ^TMP("PSJBCMA5",$JOB,DFN,ORD)
- +14 QUIT
- +15 ;
- INCLUDCO ;Rebuild TMP global from PSJBCMA, RETAIN CLINC ORDERS ONLY *70
- +1 NEW QQ,IMCNT,COCNT
- +2 SET (IMCNT,COCNT)=0
- KILL ^TMP("PSJTMP",$JOB)
- +3 FOR QQ=0:0
- SET QQ=$ORDER(^TMP("PSJ",$JOB,QQ))
- if 'QQ
- QUIT
- Begin DoDot:1
- +4 IF $PIECE($GET(^TMP("PSJ",$JOB,QQ,0)),U,11)]""
- Begin DoDot:2
- +5 SET COCNT=COCNT+1
- +6 MERGE ^TMP("PSJTMP",$JOB,COCNT)=^TMP("PSJ",$JOB,QQ)
- End DoDot:2
- End DoDot:1
- +7 KILL ^TMP("PSJ",$JOB)
- MERGE ^TMP("PSJ",$JOB)=^TMP("PSJTMP",$JOB)
- +8 KILL ^TMP("PSJTMP",$JOB)
- +9 if '$DATA(^TMP("PSJ",$JOB))
- SET ^TMP("PSJ",$JOB,1,0)=-1
- +10 QUIT
- +11 ;
- REMOVECO ;Rebuild TMP global from PSJBCMA, RETAIN IM ORDERS ONLY *70
- +1 NEW QQ,IMCNT
- +2 SET IMCNT=0
- KILL ^TMP("PSJTMP",$JOB)
- +3 FOR QQ=0:0
- SET QQ=$ORDER(^TMP("PSJ",$JOB,QQ))
- if 'QQ
- QUIT
- Begin DoDot:1
- +4 IF $PIECE($GET(^TMP("PSJ",$JOB,QQ,0)),U,11)=""
- Begin DoDot:2
- +5 SET IMCNT=IMCNT+1
- +6 MERGE ^TMP("PSJTMP",$JOB,IMCNT)=^TMP("PSJ",$JOB,QQ)
- End DoDot:2
- QUIT
- End DoDot:1
- +7 KILL ^TMP("PSJ",$JOB)
- MERGE ^TMP("PSJ",$JOB)=^TMP("PSJTMP",$JOB)
- +8 KILL ^TMP("PSJTMP",$JOB)
- +9 if '$DATA(^TMP("PSJ",$JOB))
- SET ^TMP("PSJ",$JOB,1,0)=-1
- +10 QUIT
- +11 ;
- MODELITE() ;
- +1 NEW ORDCNT,CLIN,ORDNO,STRT,STOP,STAT,PSBIMNOW,PSBIMDT
- +2 SET ORDCNT=""
- +3 KILL ^TMP("PSJ",$JOB)
- +4 SET PSBIMNOW=+$EXTRACT($$NOW^XLFDT,1,10)
- SET PSBIMDT=$PIECE(PSBIMNOW,".")
- +5 DO EN^PSJBCMA(DFN,PSBIMNOW,PSBIMDT)
- +6 if ^TMP("PSJ",$JOB,1,0)=-1
- QUIT ""
- +7 FOR QQ=0:0
- SET QQ=$ORDER(^TMP("PSJ",$JOB,QQ))
- if 'QQ
- QUIT
- Begin DoDot:1
- +8 SET CLIN=$PIECE(^TMP("PSJ",$JOB,QQ,0),U,11)
- +9 SET ORDNO=$PIECE(^TMP("PSJ",$JOB,QQ,0),U,3)
- +10 SET STRT=$PIECE($PIECE(^TMP("PSJ",$JOB,QQ,1),U,4),".")
- +11 SET STOP=$PIECE($PIECE(^TMP("PSJ",$JOB,QQ,1),U,5),".")
- +12 SET STAT=$PIECE(^TMP("PSJ",$JOB,QQ,1),U,7)
- +13 if CLIN]""
- Begin DoDot:2
- +14 ;modelite display for held, renewed, and on call PSB*3*92
- IF ORDNO'["P"
- IF (STAT="A"!(STAT="H")!(STAT="R")!(STAT="O"))
- IF STRT'>DT
- IF STOP'<DT
- SET $PIECE(ORDCNT,U,2)=1
- End DoDot:2
- +15 if CLIN=""
- Begin DoDot:2
- +16 ;modelite display for held and renewed, and on call PSB*3*92
- IF ORDNO'["P"
- IF (STAT="A"!(STAT="H")!(STAT="R")!(STAT="O"))
- IF STRT'>DT
- IF STOP'<DT
- SET $PIECE(ORDCNT,U)=1
- End DoDot:2
- End DoDot:1
- +17 QUIT ORDCNT
- +18 ;
- INITTAB ;*70
- +1 KILL ^TMP("PSB",$JOB,PSBTAB)
- +2 SET ^TMP("PSB",$JOB,PSBTAB,0)=1
- +3 SET ^TMP("PSB",$JOB,PSBTAB,1)="-1^No Administration(s) due at this time."
- +4 QUIT
- +5 ;
- 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.
- +2 ;
- +3 NEW QQ,SPDT,STARTDT,STDT,STOPDT,STPDT
- +4 SET PSBSIOPI=""
- SET PSBCLINORD=1
- +5 NEW NODE1,ENDDT,STRDT,STOPDT,STDT,SPDT,STARTDT,STOPDT,SDT,QUIT,REC,QQ
- +6 NEW PSBWBEG,PSBWEND,PSBWADM,FOUND,GIVE,PDT
- +7 KILL ^TMP("PSJ",$JOB)
- +8 DO EN^PSJBCMA(DFN,PSBDT,PSBDT)
- DO INCLUDCO^PSBVDLU1
- +9 if ^TMP("PSJ",$JOB,1,0)=-1
- QUIT -1
- +10 ;
- +11 ;read thru psj tmp and create start date xref
- +12 FOR QQ=0:0
- SET QQ=$ORDER(^TMP("PSJ",$JOB,QQ))
- if 'QQ
- QUIT
- Begin DoDot:1
- +13 SET NODE1=$GET(^TMP("PSJ",$JOB,QQ,1))
- +14 ;not active sts
- if $PIECE(NODE1,U,7)'="A"
- QUIT
- +15 SET STRDT=$PIECE($PIECE(NODE1,U,4),".")
- SET STDT(STRDT)=""
- +16 SET STPDT=$PIECE($PIECE(NODE1,U,5),".")
- SET SPDT(STPDT)=""
- End DoDot:1
- +17 SET STARTDT=+$ORDER(STDT(0))
- +18 if (BWDFWD=-1)&('STARTDT)
- QUIT -1
- +19 SET STOPDT=+$ORDER(SPDT(999999999),-1)
- +20 if (BWDFWD=1)&('STOPDT)
- QUIT -1
- +21 ;
- +22 if BWDFWD=-1
- DO LOOPBWD
- +23 if BWDFWD=1
- DO LOOPFWD
- +24 QUIT PDT
- +25 ;
- LOOPBWD ; Loop thru days backwards and quit when pass End date. *70
- +1 SET (REC,QUIT,FOUND)=0
- +2 FOR QQ=BWDFWD:BWDFWD
- SET PDT=$$FMADD^XLFDT(PSBDT,QQ)
- if PDT<STARTDT
- QUIT
- Begin DoDot:1
- +3 IF PDT<STARTDT
- SET QUIT=1
- QUIT
- +4 DO INITTAB^PSBVDLU1
- +5 SET PSBWBEG=$PIECE(PDT,".")_".0000"
- +6 SET PSBWEND=$PIECE(PDT,".")_".2400"
- +7 SET PSBWADM=99999
- +8 SET PSBWADM=$$FMADD^XLFDT(PDT,"","",+PSBWADM)
- +9 if PSBTAB="UDTAB"
- DO EN^PSBVDLUD(DFN,PDT)
- +10 if PSBTAB="PBTAB"
- DO EN^PSBVDLPB(DFN,PDT)
- +11 ;=dfn, if data found
- SET FOUND=+$GET(^TMP("PSB",$JOB,PSBTAB,2))
- +12 ;get give sts
- SET GIVE=$PIECE($GET(^TMP("PSB",$JOB,PSBTAB,2)),U,13)
- +13 ;skip, as was given
if GIVE="G"
SET FOUND=0
End DoDot:1
if FOUND!QUIT
QUIT
+14 if 'FOUND
SET PDT=-1
+15 QUIT
+16 ;
LOOPFWD ; Loop thru days forwards and quit when pass End date. *70
+1 SET (REC,QUIT,FOUND)=0
+2 FOR QQ=BWDFWD:BWDFWD
SET PDT=$$FMADD^XLFDT(PSBDT,QQ)
if PDT>STOPDT
QUIT
Begin DoDot:1
+3 IF PDT>STOPDT
SET QUIT=1
QUIT
+4 DO INITTAB^PSBVDLU1
+5 SET PSBWBEG=$PIECE(PDT,".")_".0000"
+6 SET PSBWEND=$PIECE(PDT,".")_".2400"
+7 SET PSBWADM=99999
+8 SET PSBWADM=$$FMADD^XLFDT(PDT,"","",+PSBWADM)
+9 if PSBTAB="UDTAB"
DO EN^PSBVDLUD(DFN,PDT)
+10 if PSBTAB="PBTAB"
DO EN^PSBVDLPB(DFN,PDT)
+11 ;=dfn, if data found
SET FOUND=+$GET(^TMP("PSB",$JOB,PSBTAB,2))
+12 ;get give sts
SET GIVE=$PIECE($GET(^TMP("PSB",$JOB,PSBTAB,2)),U,13)
+13 ;skip, as was given
if GIVE="G"
SET FOUND=0
End DoDot:1
if FOUND!QUIT
QUIT
+14 if 'FOUND
SET PDT=-1
+15 QUIT
+16 ;
PATCHON(DFN,ORDR) ;check if any patches are still Given & Not Removed per this patient
+1 ; Return values:
+2 ; Func: True/False (1/0) for patches do exist on a patient.
+3 ; ORDR(): array element "C"linic or "I"npatient order = 1 when
+4 ; at least 1 order of this type exists.
+5 ;
+6 NEW ON,DAYSBK,ORDNO,STOPDT,IMCL
+7 SET ON=0
SET ORDR("C")=0
SET ORDR("I")=0
+8 if '$DATA(^PSB(53.79,"APATCH",DFN))
QUIT ON
+9 FOR QQ=0:0
SET QQ=$ORDER(^PSB(53.79,"APATCH",DFN,QQ))
if 'QQ
QUIT
Begin DoDot:1
+10 FOR RR=0:0
SET RR=$ORDER(^PSB(53.79,"APATCH",DFN,QQ,RR))
if 'RR
QUIT
Begin DoDot:2
+11 IF $PIECE(^PSB(53.79,RR,0),U,9)="G"
Begin DoDot:3
+12 SET ORDNO=$PIECE(^PSB(53.79,RR,.1),"^")
+13 DO CLEAN^PSBVT
+14 DO PSJ1^PSBVT(DFN,ORDNO)
if '$GET(PSBOSP)
QUIT
+15 SET STOPDT=PSBOSP
+16 SET DAYSBK=+($$GET^XPAR("DIV","PSB VDL PATCH DAYS"))
+17 ; simulate PSBVDLPA logic to look back Kernel param days
+18 IF DAYSBK
DO NOW^%DTC
IF $$FMADD^XLFDT($PIECE(STOPDT,"."),DAYSBK)<X
QUIT
+19 SET ON=1
+20 SET IMCL=$SELECT($GET(PSBCLORD)]"":"C",1:"I")
SET ORDR(IMCL)=1
+21 DO CLEAN^PSBVT
End DoDot:3
End DoDot:2
End DoDot:1
+22 QUIT ON
+23 ;
INFUSING(DFN,ORDR) ;check if any IV's have bags infusing per this patient
+1 ; Return values:
+2 ; Func: True/False (1/0) for patches do exist on a patient.
+3 ; ORDR(): array element "C"linic or "I"npatient order = 1 when
+4 ; at least 1 order of this type exists.
+5 ;
+6 NEW ON,DAYSBK,ORDNO,STOPDT,IMCL,PSBCLIEN
+7 SET ON=0
SET ORDR("C")=0
SET ORDR("I")=0
+8 if '$DATA(^PSB(53.79,"AINFUSING",DFN))
QUIT ON
+9 FOR QQ=0:0
SET QQ=$ORDER(^PSB(53.79,"AINFUSING",DFN,QQ))
if 'QQ
QUIT
Begin DoDot:1
+10 FOR RR=0:0
SET RR=$ORDER(^PSB(53.79,"AINFUSING",DFN,QQ,RR))
if 'RR
QUIT
Begin DoDot:2
+11 SET ORDNO=$PIECE(^PSB(53.79,RR,.1),"^")
+12 DO CLEAN^PSBVT
+13 DO PSJ1^PSBVT(DFN,ORDNO)
if '$GET(PSBOSP)
QUIT
+14 SET STOPDT=PSBOSP
+15 ; simulate IV VDL logic to look 3 days back for IM meds or 7 days
+16 ; for CO med.
+17 DO NOW^%DTC
+18 IF '$GET(PSBCLIEN)
IF $$FMADD^XLFDT($PIECE(STOPDT,"."),3)<X
QUIT
+19 IF $GET(PSBCLIEN)
IF $$FMADD^XLFDT($PIECE(STOPDT,"."),7)<X
QUIT
+20 SET ON=1
+21 SET IMCL=$SELECT($GET(PSBCLORD)]"":"C",1:"I")
SET ORDR(IMCL)=1
+22 DO CLEAN^PSBVT
End DoDot:2
End DoDot:1
+23 QUIT ON
+24 ;
STOPPED(DFN,ORDR) ;check if any IV's have bags infusing per this patient
+1 ; Return values:
+2 ; Func: True/False (1/0) for patches do exist on a patient.
+3 ; ORDR(): array element "C"linic or "I"npatient order = 1 when
+4 ; at least 1 order of this type exists.
+5 ;
+6 NEW ON,DAYSBK,ORDNO,STOPDT,IMCL,PSBCLIEN
+7 SET ON=0
SET ORDR("C")=0
SET ORDR("I")=0
+8 if '$DATA(^PSB(53.79,"ASTOPPED",DFN))
QUIT ON
+9 FOR QQ=0:0
SET QQ=$ORDER(^PSB(53.79,"ASTOPPED",DFN,QQ))
if 'QQ
QUIT
Begin DoDot:1
+10 FOR RR=0:0
SET RR=$ORDER(^PSB(53.79,"ASTOPPED",DFN,QQ,RR))
if 'RR
QUIT
Begin DoDot:2
+11 SET ORDNO=$PIECE(^PSB(53.79,RR,.1),"^")
+12 DO CLEAN^PSBVT
+13 DO PSJ1^PSBVT(DFN,ORDNO)
if '$GET(PSBOSP)
QUIT
+14 SET STOPDT=PSBOSP
+15 ; simulate IV VDL logic to look 3 days back for IM meds or 7 days
+16 ; for CO med.
+17 DO NOW^%DTC
+18 IF 'PSBCLIEN
IF $$FMADD^XLFDT($PIECE(STOPDT,"."),3)<X
QUIT
+19 IF PSBCLIEN
IF $$FMADD^XLFDT($PIECE(STOPDT,"."),7)<X
QUIT
+20 SET ON=1
+21 SET IMCL=$SELECT($GET(PSBCLORD)]"":"C",1:"I")
SET ORDR(IMCL)=1
+22 DO CLEAN^PSBVT
End DoDot:2
End DoDot:1
+23 QUIT ON
+24 ;
REMOVETM(MRR,STYP) ;** Check if MRR med & add to Results array (34,35) *83
+1 ;
+2 ; Add MRR code to Results(34) and if MRR > 0 then add remove time
+3 ; to Results(35).
+4 ;
+5 NEW RMDT,RMTIM
+6 ;set MRR flag in 34
SET $PIECE(PSBREC,U,34)=MRR
+7 ;
+8 ;Quit, not MRR med, no remove time
if 'MRR
QUIT
+9 ;Quit, schd types have no admin times
if (PSBSCHT="OC")!(PSBSCHT="P")
QUIT
+10 ;Quit, already set from get MRR rtns
if $PIECE(PSBREC,U,35)
QUIT
+11 ;
+12 ; Remove date/time Calculation method will correctly compute a future
+13 ; Remove date/time per this admin time, by using the FMADD function
+14 ; to add the DOA value to the admin time. DOA value is the time the
+15 ; med is to be on the patient and must be removed after that time.
+16 ;
+17 ; **Notice: Sched Type of "O", Remove time = Order Stop date/time
+18 ;
+19 ; e.g. if sched is Q7D and Freq=10080, then DOA=10080 also, and is
+20 ; returned by PSJBCMA1
+21 ;
+22 ;admin time
SET ADMTIM=$PIECE(PSBREC,U,14)
+23 ;calc RM time if DOA
if PSBDOA
SET RMTIM=$$FMADD^XLFDT(ADMTIM,,,PSBDOA)
+24 ;RM time for One-Time, non-expired orders, PSB*3*92
IF (PSBDOA<1!(PSBOSP>$$NOW^XLFDT))
IF STYP="O"
SET RMTIM=PSBOSP
+25 ;Add RM date/time
SET $PIECE(PSBREC,U,35)=$GET(RMTIM)
+26 QUIT