PSBCSUTL ;BIRMINGHAM/TEJ- BCMA-HSC COVER SHEET UTILITIES ;03/06/16 3:06pm
;;3.0;BAR CODE MED ADMIN;**16,13,38,32,50,60,58,68,70,80,83,106**;Mar 2004;Build 43
;Per VHA Directive 2004-038 (or future revisions regarding same), this routine should not be modified.
;
; Reference/IA
; EN^PSJBCMA/2828
; IN5^VADPT/10061
; $$GET^XPAR/2263
; ^%DTC/10000
; $$FMADD^XLFDT/10103
; $$GET1^DIQ/2056
; EN1^GMVDCEXT/4251
; GETPROVL^PSGSICH1/5653
; INTRDIC^PSGSICH1/5654
;
;*58 - add 30th piece to Results for Override/Intervention flag 1/0
;*68 - add new parameter to use new SI/OPI word processing fields
;*70 - add Clinic order request IN param flag (true/false 0/1).
; also add to return array ORD line 32 piece Clinic name for CO.
; for CO mode: set to -7 days for pulling pull meds & viewing
; Expired/DC'd orders; set to +7 days to view future orders.
;*83 - call new PSBVDLRM, new call FIXADM^PSBUTL for Inserting G
; action code in Results back to coversheet to trigger Removal.
;*106- add Hazardous to Handle & Dispose flags 36 & 37
;
; ** Warning: PSBSIOPI & PSBCLINORD will be used as global variables
;
RPC(RESULTS,DFN,EXPWIN,PSBSIOPI,PSBCLINORD) ;
N PSBONVDL ;*83 used by psbvdlpa & psbvdlrm
K RESULTS,^TMP("PSB",$J),^TMP("PSJ",$J)
S EXPWIN=+$G(EXPWIN) ;*70
S PSBSIOPI=+$G(PSBSIOPI) ;*68 init to 0 if not present or 1 if sent
S PSBCLINORD=+$G(PSBCLINORD) ;*70 init to 0 if null
S PSBTAB="CVRSHT"
N PSBCNT S PSBTRFL=0,PSBDFNX=DFN
D PAINCMT(DFN) ;;Correct Comment if Pain Score entered in BCMA was marked "Entered in Error" in Vitals. (PSB*3*50)
S RESULTS=$NAME(^TMP("PSB",$J,PSBTAB))
K ^TMP("PSB",$J,PSBTAB) S ^TMP("PSB",$J,PSBTAB,0)=1 D LIGHTS(PSBDFNX)
S ^TMP("PSB",$J,PSBTAB,0)=1,^TMP("PSB",$J,PSBTAB,1)=^TMP("PSB",$J,PSBTAB,1)
Q:$P(^TMP("PSB",$J,PSBTAB,1),U,4)=-1
D NOW^%DTC S PSBNOW=+$E(%,1,10),PSBDT=$P(%,".",1)
;set range
;*70 - use diff window values for CO mode vs IM mode
I PSBCLINORD D
. S:'EXPWIN EXPWIN=24*7 ;not passed in def to 7 days
. S PSBWBEG=$P($$FMADD^XLFDT(PSBNOW,-EXPWIN\24),".")
. S PSBWEND=$P($$FMADD^XLFDT(PSBNOW,EXPWIN\24),".")
E D
. S:'EXPWIN EXPWIN=24 ;not passed in def to 24 hr
. S PSBWBEG=$$FMADD^XLFDT(PSBNOW,"",-EXPWIN)
. S PSBWEND=$$FMADD^XLFDT(PSBNOW,"",EXPWIN)
;
S PSBWADM=$$GET^XPAR("DIV","PSB ADMIN BEFORE"),PSBMHBCK=$$GET^XPAR("ALL","PSB MED HIST DAYS BACK",,"B") I +PSBMHBCK=0 S PSBMHBCK=30
D NOW^%DTC S PSBWADM=$$FMADD^XLFDT(%,"","",+PSBWADM),PSBMHBCK=$$FMADD^XLFDT(%,-1*(PSBMHBCK))
;use lst movemnt for API
S VAIP("D")="LAST" D IN5^VADPT S PSBTRDT=+VAIP(3),PSBTRTYP=$P(VAIP(2),U,2),PSBMVTYP=$P(VAIP(4),U,2) K VAIP
S PSBPTTR=$$GET^XPAR("DIV","PSB PATIENT TRANSFER") I PSBPTTR="" S PSBPTTR=72
D NOW^%DTC S PSBNTDT=$$FMADD^XLFDT(%,"",-PSBPTTR) I PSBNTDT'>PSBTRDT S PSBTRFL=1
;*70 go back 7 days to pull meds for clinic orders
S X1=$P(PSBNOW,"."),X2=$S(PSBCLINORD:-7,1:-3) D C^%DTC
D EN^PSJBCMA(PSBDFNX,X,$S(PSBMHBCK<PSBWBEG:PSBMHBCK,PSBWBEG<PSBMHBCK:PSBWBEG,1:PSBMHBCK))
;Filter in/out Clinic Orders *70
D:PSBCLINORD
. I $D(PSBRPT(2)) D FILTERCO^PSBO Q
. D INCLUDCO^PSBVDLU1
D:'PSBCLINORD REMOVECO^PSBVDLU1
;Devlop Outp
S PSBTBOUT=0
I ^TMP("PSJ",$J,1,0)>0 F PSBX=0:0 S PSBX=$O(^TMP("PSJ",$J,PSBX)) Q:('PSBX)!(PSBTBOUT) D
.S:(PSBTAB'="CVRSHT")&($G(^TMP("PSB",$J,"CVRSHT",2))>0) PSBTBOUT=1
.D CLEAN^PSBVT,PSJ^PSBVT(PSBX),NOW^%DTC
.Q:PSBONX["P" Q:(PSBOSP<PSBWBEG)&'(PSBONX["V") ;in rnge?
.S (PSBREC,PSBONTAB)=""
.S $P(PSBREC,U,1)=PSBDFN ;Dfn
.S $P(PSBREC,U,2)=PSBONX ;OrdX
.S $P(PSBREC,U,3)=PSBON ;Ord#
.S $P(PSBREC,U,4)=PSBOTYP ;v/u/p
.S $P(PSBREC,U,5)=PSBSCHT ;Schtyp
.S $P(PSBREC,U,6)=PSBSCH ;Sch
.S $P(PSBREC,U,7)=$S(PSBHSM:"HSM",PSBSM:"SM",1:"") ; slfmed
.S $P(PSBREC,U,8)=PSBOITX ;Drgnm
.S $P(PSBREC,U,9)=PSBDOSE_" "_PSBIFR ;Dose
.S $P(PSBREC,U,10)=PSBMR ;med route
.;Lst Gvn -AOIP xRef
.S (PSBCNT,PSBFLAG)=0,(Y,PSBSTUS)="" K PSBHSTA,PSBHSTAX
.F XZ=1:1:20 S Y=$O(^PSB(53.79,"AOIP",PSBDFN,PSBOIT,Y),-1),(PSBCNT,PSBFLAG)=0 Q:Y="" D
..S:Y>0 $P(PSBREC,U,11)=Y
..S X="" F S X=$O(^PSB(53.79,"AOIP",PSBDFN,PSBOIT,Y,X),-1) Q:X="" D
...S PSBSTUS=$P(^PSB(53.79,X,0),U,9) S:$G(PSBSTUS)="" PSBSTUS="X" I (PSBSTUS'="N") S PSBFLAG=1,PSBHSTA(Y,$G(PSBSTUS))="ORIG"_U_X
...D:PSBSTUS="N"
....S ($P(PSBREC,U,11),Z)=""
....F S Z=$O(^PSB(53.79,X,.9,Z),-1) Q:'Z Q:PSBFLAG=1 S PSBDATA=$G(^(Z,0)) D
.....I (PSBDATA["Set to 'NOT GIVEN'")!(PSBDATA["Set to 'GIVEN'")!(PSBDATA["Set to 'REFUSED'")!(PSBDATA["Set to 'HELD'")!(PSBDATA["Set to 'MISSING DOSE'")!(PSBDATA["Set to 'REMOVED'") S PSBCNT=PSBCNT+1
.....I (PSBDATA["STATUS 'HELD'")!(PSBDATA["STATUS 'GIVEN'")!(PSBDATA["STATUS 'REFUSED'")!(PSBDATA["STATUS 'MISSING DOSE'")!(PSBDATA["STATUS 'REMOVED'") S PSBCNT=PSBCNT+1
.....I PSBCNT#2=0,PSBDATA["'REFUSED'" S PSBSTUS="R" D LAST^PSBVDLU1
.....I PSBCNT#2=0,PSBDATA["'HELD'" S PSBSTUS="H" D LAST^PSBVDLU1
.....I PSBCNT#2=0,PSBDATA["'MISSING DOSE'" S PSBSTUS="M" D LAST^PSBVDLU1
.....I PSBCNT#2=0,PSBDATA["'REMOVED'" S PSBSTUS="RM" D LAST^PSBVDLU1
.....I PSBFLAG=1,'$D(PSBHSTA($P(PSBREC,U,11),$G(PSBSTUS))) S PSBHSTA($P(PSBREC,U,11),$G(PSBSTUS))=Z_U_X
.I $D(PSBHSTA) S $P(PSBREC,U,11)=$O(PSBHSTA(""),-1),PSBSTUS=$O(PSBHSTA($P(PSBREC,U,11),""),-1) M PSBHSTAX(PSBOIT)=PSBHSTA K PSBHSTA ;last action date/time
.S $P(PSBREC,U,12)="" ;ien - below
.S $P(PSBREC,U,13)="" ;sttus - below
.S $P(PSBREC,U,14)="" ;admn dte - below
.S $P(PSBREC,U,15)=PSBOIT ;OI Pointer
.S $P(PSBREC,U,16)=PSBNJECT ;njctble med route flag
.;Var dosg
.I $P(PSBREC,U,9)?1.4N1"-"1.4N.E S $P(PSBREC,U,17)=1
.E S $P(PSBREC,U,17)=0
.S:PSBDOSEF?1"CAP".E!(PSBDOSEF?1"TAB".E)!(PSBDOSEF="PATCH") $P(PSBREC,U,18)=PSBDOSEF ;DosgFrm
.D PSJ1^PSBVT(PSBDFN,PSBONX)
.S PSBPB=$$IVPTAB^PSBVDLU3(PSBOTYP,PSBIVT,PSBISYR,PSBCHEMT,+$G(PSBIVPSH)),PSBLVIV=0
.Q:PSBPB&(PSBOSP<PSBWBEG)
.S:(PSBONX["V"&'PSBPB) PSBLVIV=1
.S $P(PSBREC,U,19)=$S(PSBVNI]"":PSBVNI,PSBVNI']"":"***") ;VerfNrsInts
.S $P(PSBREC,U,20)=PSBSTUS S:$P(PSBREC,U,11)="" $P(PSBREC,U,20)="" ;LstActn
.S $P(PSBREC,U,21)=PSBOST
.S $P(PSBREC,U,22)=PSBOSTS
.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 $P(PSBREC,U,26)=PSBOSP ;OrdStpDt/Tm
.S $P(PSBREC,U,27)=$$LASTG($P(PSBREC,U,1),$P(PSBREC,U,15))
.S $P(PSBREC,U,28)=$S((PSBONX["U")&('PSBPB):1,PSBPB:2,(PSBONX["V")&'PSBPB:3,1:"")
.;*58 determine if override exists, send 1/0 (true/false)
.N PSBARR D GETPROVL^PSGSICH1(DFN,PSBONX,.PSBARR)
.I $O(PSBARR(""))="" D INTRDIC^PSGSICH1(DFN,PSBONX,.PSBARR,2)
.S $P(PSBREC,U,29)=$S($O(PSBARR(""))]"":1,1:0)
.;*70 add Clinic name & ien ptr to piece 32 and 33 for CO's, remember
.; "ORD" is inserted later as piece 1 which offsets all here by +1
.S $P(PSBREC,U,31)=$G(PSBCLORD)
.S $P(PSBREC,U,32)=$G(PSBCLIEN)
.; piece 34-35 reserved for Remove meds and set by PSBVDLU1
.S $P(PSBREC,U,36)=$G(PSBHAZHN) ;Hazardous to Handle *106
.S $P(PSBREC,U,37)=$G(PSBHAZDS) ;Hazardous to Dispose *106
.;get all Admn(s) - DD info.
.S (PSBDDS,PSBSOLS,PSBADDS,PSBFLAG)="0"
.;PSB*3*60 adds additional checks to ensure an expired order is within the coversheet time parameter and an "END" is only added to the temp global after an order is added
.I PSBLVIV D XFERBAGS^PSBCSUTY,LVIV^PSBCSUTY I $G(PSBEXPRD) S X1=$O(^TMP("PSB",$J,PSBTAB,""),-1) S:^TMP("PSB",$J,PSBTAB,X1)'="END"&(X1>1) ^TMP("PSB",$J,PSBTAB,X1+1)="END" Q ;PSB*3*60
.D GETADMX^PSBCSUTY
.F Y=0:0 S Y=$O(PSBDDA(Y)) Q:'Y D
..I $P(PSBDDA(Y),U,5)=$P(%,".") S PSBFLAG=1 ;drug nactvt
..Q:$P(PSBDDA(Y),U,5)&($P(PSBDDA(Y),U,5)<%) ;nactv
..S:$P(PSBDDA(Y),U,4)="" $P(PSBDDA(Y),U,4)=1
..S PSBDDS=PSBDDS_U_$P(PSBDDA(Y),U,1,4),$P(PSBDDS,U,1)=PSBDDS+1
.;OnCa O PRN
.I ("^O^OC^P^"[(U_PSBSCHT_U))!(PSBLVIV) D S ($P(PSBREC,U,12),$P(PSBREC,U,14))="" Q
..S (PSBIENX,PSBGOT1)="",PSBADMTM="" F S PSBADMTM=$O(^PSB(53.79,"AORDX",PSBDFNX,PSBONX,PSBADMTM)) Q:(PSBADMTM="") D
...Q:(PSBADMTM<PSBMHBCK)&'PSBLVIV
...F S PSBIENX=$O(^PSB(53.79,"AORDX",PSBDFNX,PSBONX,PSBADMTM,PSBIENX)) Q:PSBIENX="" D
....S $P(PSBREC,U,12)=PSBIENX,$P(PSBREC,U,14)=PSBADMTM,$P(PSBREC,U,23)=$$GET1^DIQ(53.79,PSBIENX_",","IV UNIQUE ID")
....S PSBQRR=1 I PSBWBEG<PSBOSP D ADD^PSBVDLU1(PSBREC,PSBOTXT,PSBADMTM,PSBDDS,PSBSOLS,PSBADDS,"CVRSHT") S PSBGOT1=1 ;PSB*3*60
..I ('+PSBGOT1)&(PSBOSP'<PSBWBEG) D ADD^PSBVDLU1(PSBREC,PSBOTXT,PSBNOW\1_".",PSBDDS,PSBSOLS,PSBADDS,"CVRSHT") S PSBGOT1=1
..I ('+PSBGOT1)&($D(PSBADMX(PSBONX)))&(PSBWBEG<PSBOSP) D ADD^PSBVDLU1(PSBREC,PSBOTXT,PSBNOW\1_".",PSBDDS,PSBSOLS,PSBADDS,"CVRSHT") ;PSB*3*60
..S PSBGLBX=$O(^TMP("PSB",$J,PSBTAB,""),-1) S:^TMP("PSB",$J,PSBTAB,PSBGLBX)'="END"&(PSBGLBX>1) ^TMP("PSB",$J,PSBTAB,PSBGLBX+1)="END" ;PSB*3*60
.;cont - proces AdmnTm
.S (PSBYES,PSBODD,PSBYTF)=0 S:$$PSBDCHK1^PSBVT1(PSBSCH) PSBYES=1
.I PSBYES,PSBADST="" Q
.F I=1:1 Q:$P(PSBSCH,"-",I)="" I $P(PSBSCH,"-",I)?2N!($P(PSBSCH,"-",I)?4N) S PSBYES=1,PSBYTF=1
.I PSBSCHT="C",PSBYTF="1",PSBADST="" Q
.S PSBFREQ=$$GETFREQ^PSBVDLU1(DFN,PSBONX)
.I PSBFREQ="O" S PSBFREQ=1440
.I PSBFREQ="D" S PSBFREQ=""
.S:PSBLVIV PSBYES=1
.I 'PSBYES,PSBFREQ<1 Q
.I (PSBADST="")&(+PSBFREQ>0) D ODDSCH^PSBVDLU1(PSBTAB) Q
.I +PSBFREQ>0 I (PSBFREQ#1440'=0),(1440#PSBFREQ'=0) S PSBODD=1
.I PSBODD,PSBADST'="" Q
.S PSBDTX=PSBWBEG\1,PSBGOT1=0
.F PSBXX=1:1:2 D S PSBDTX=$$FMADD^XLFDT(PSBDTX,"",24) ;incrmnt 1 day!
..F PSBY=1:1:$L(PSBADST,"-") Q:$P(PSBADST,"-",PSBY)="" D
...S PSB=+(PSBDTX_"."_$P(PSBADST,"-",PSBY))
...I (PSB'<PSBWBEG)&(PSB'>PSBWEND) D ;wndow?
....D:(PSB'<PSBOST)&(PSB<PSBOSP) ;actv?
.....D:$$OKAY^PSBVDLU1(PSBOST,PSB,PSBSCH,PSBONX,PSBOITX,PSBFREQ,PSBOSTS) ;dt?
......D ADD^PSBVDLU1(PSBREC,PSBOTXT,PSB,PSBDDS,PSBSOLS,PSBADDS,"CVRSHT") S PSBGOT1=1
...S PSB=+(PSBWEND\1_"."_$P(PSBADST,"-",PSBY))
...I (PSB'<PSBWBEG)&(PSB'>PSBWEND) D ;wndow?
....D:(PSB'<PSBOST)&(PSB<PSBOSP) ;actv?
.....D:$$OKAY^PSBVDLU1(PSBOST,PSB,PSBSCH,PSBONX,PSBOITX,PSBFREQ,PSBOSTS) ;dt?
......D ADD^PSBVDLU1(PSBREC,PSBOTXT,PSB,PSBDDS,PSBSOLS,PSBADDS,"CVRSHT") S PSBGOT1=1
.I ('PSBGOT1)&(PSBOSP'<PSBWBEG) D ADD^PSBVDLU1(PSBREC,PSBOTXT,+(PSBWEND\1_"."_$P(PSBADST,"-")),PSBDDS,PSBSOLS,PSBADDS,"CVRSHT")
.K PSBSTUS
D EN^PSBVDLPA
D EN^PSBVDLRM ;*83 new rtn
I $G(^TMP("PSB",$J,PSBTAB,2))]"" S PSBI1=$O(^TMP("PSB",$J,PSBTAB,""),-1) I ^TMP("PSB",$J,PSBTAB,PSBI1)'="END" S ^TMP("PSB",$J,PSBTAB,PSBI1+1)="END"
S ^TMP("PSB",$J,PSBTAB,0)=$O(^TMP("PSB",$J,PSBTAB,""),-1)
I $G(^TMP("PSB",$J,PSBTAB,2))']"" S $P(^TMP("PSB",$J,PSBTAB,1),U,4)="-1^No orders to display on Coversheet" ;*70 was "To" now "to"
I $G(^TMP("PSB",$J,PSBTAB,2))]"" S $P(^TMP("PSB",$J,PSBTAB,1),U,4)="1^COVERSHEET DATA FOLLOWS" D ADD^PSBCSUTX
D FIXADM^PSBUTL ;*83
D CLEAN
Q
LASTG(PSBPATPT,PSBOIPT) ;LstGvn-(inpt: DFN,OrItm IEN)
K PSBHSTG S Y="",LASTG="" F XZ=1:1:20 S Y=$O(^PSB(53.79,"AOIP",PSBPATPT,PSBOIPT,Y),-1),(PSBCNT,PSBFLAG)=0 Q:Y="" D
.S:Y>0 LASTG="",X="" F S X=$O(^PSB(53.79,"AOIP",PSBPATPT,PSBOIPT,Y,X),-1) Q:X="" D
..S PSBSTX=$P(^PSB(53.79,X,0),U,9) S:PSBSTX']"" PSBHSTG(Y)=-1 I PSBSTX="G" S PSBHSTG(Y)="G"
..Q:PSBSTX="N"
..D:(PSBSTX'="G")
...S Z="" F S Z=$O(^PSB(53.79,X,.9,Z),-1) Q:'Z Q:PSBFLAG=1 S PSBDATA=$G(^(Z,0)) D
....I (PSBDATA["Set to 'GIVEN'") S PSBCNT=PSBCNT+1
....I (PSBDATA["STATUS 'GIVEN'") S PSBCNT=PSBCNT+1
....I PSBCNT#2=0,PSBDATA'["'GIVEN'" Q
....I '$D(PSBHSTG($P(PSBDATA,U))) S PSBFLAG=1,PSBHSTG($P(PSBDATA,U))=""
I $D(PSBHSTG) S LASTG="" F S LASTG=$O(PSBHSTG(LASTG),-1) Q:+LASTG=0 Q:PSBHSTG(LASTG)="G" I PSBHSTG(LASTG)=-1 S LASTG="" Q
Q LASTG
PAINCMT(DFN) ;;Add comment if Pain Score entered in BCMA was marked "Entered in Error" in Vitals.
;;This will run through all the patients appointments, check their comments to see if they had a Pain Vital entered through BCMA, and check if that Vital was marked "Entered in Error."
Q:'$D(^DPT(DFN,0))
N PSBCMT,PSBGMR,PSBCMTGLB,PSBIEN,PSBCMTM,PSBVITM,PSBTMDF,PSBBDT,PSBEDT,PSBEFTM,PSBCMFL,PSBEXTM,PSBERFL,PSBPNSC,PSBNOW,PSBDFN,PSBPRNDT,PSBSTRTDT,PSBMDHST,PSBEFFL,PSBCOMMENT,X,X1,X2,PSBDUZ,PSBPAIN
K ^TMP("PSBGMV",$J)
D NOW^%DTC S PSBEDT=%
S PSBMDHST=+($$GET^XPAR("ALL","PSB MED HIST DAYS BACK",,"B")) S:+$G(PSBMDHST)=0 PSBMDHST=30
S X1=$P(PSBEDT,"."),X2=-(PSBMDHST) D C^%DTC S PSBMDHST=X
S PSBSTRTDT=$S($G(PSBSTRT)]0:PSBSTRT,1:PSBMDHST)
S PSBPRNDT=PSBSTRTDT F S PSBPRNDT=$O(^PSB(53.79,"APRN",DFN,PSBPRNDT)) Q:'PSBPRNDT D
.S PSBIEN=0 F S PSBIEN=$O(^PSB(53.79,"APRN",DFN,PSBPRNDT,PSBIEN)) Q:'PSBIEN D
..S PSBCMT=0 F S PSBCMT=$O(^PSB(53.79,PSBIEN,.3,PSBCMT)) Q:'PSBCMT S PSBCMTGLB=^PSB(53.79,PSBIEN,.3,PSBCMT,0) D
...I $P($G(PSBCMTGLB),U)["Pain Score of" S PSBPAIN=$E($P(PSBCMTGLB,U),15) D
....I $E($P($G(PSBCMTGLB),U),1,14)="*Pain Score of" S PSBCMFL=""
....I $E($P($G(PSBCMTGLB),U),1,15)="**Pain Score of" S PSBEFFL=""
....S PSBCMTM=$P($G(PSBCMTGLB),U,3)
....S PSBBDT=$E(PSBCMTM,1,12)
....S PSBEXTM=$$FMTE^XLFDT(PSBBDT,"5Z")
....I '$D(^TMP("PSBGMV",$J)) D EN1^GMVDCEXT("^TMP(""PSBGMV"",$J)",DFN,2,,1,PSBSTRTDT,PSBEDT,,1)
....S PSBGMR=0 F S PSBGMR=$O(^TMP("PSBGMV",$J,PSBGMR)) Q:PSBGMR="" I $P(^TMP("PSBGMV",$J,PSBGMR),U,4)="PN" D
.....S PSBVITM=$P(^TMP("PSBGMV",$J,PSBGMR),U,5)
.....S PSBTMDF=$$FMDIFF^XLFDT(PSBVITM,PSBCMTM,2)
.....I PSBTMDF>=-($S($G(DILOCKTM)>0:DILOCKTM,1:3)),PSBTMDF<=$S($G(DILOCKTM)>0:DILOCKTM,1:3) S PSBDUZ=$P(^TMP("PSBGMV",$J,PSBGMR),U,10) D ;User who marked Pain Score Entered in error, PSB*3*80
......I $P(^TMP("PSBGMV",$J,PSBGMR),U,9)=1 S PSBPNSC=$P(^TMP("PSBGMV",$J,PSBGMR),U,8),PSBERFL="" D
.......I $D(PSBERFL),'$D(PSBCMFL),$G(PSBDUZ),PSBPAIN=PSBPNSC D
........S PSBCOMMENT="*Pain Score of "_PSBPNSC_" entered in Vitals via BCMA at "_PSBEXTM_" may have been marked 'Entered in Error'. See Vitals Package for an updated Score." D PNCMNT(PSBIEN,PSBCOMMENT,PSBDUZ) S PSBCMFL=""
..K PSBCMFL,PSBERFL
..S PSBEFTM=$P($G(^PSB(53.79,PSBIEN,.2)),U,4) Q:PSBEFTM=""
..S PSBBDT=$E(PSBEFTM,1,12),PSBPAIN=$E($P(^PSB(53.79,PSBIEN,.2),U,2),15)
..S PSBEXTM=$$FMTE^XLFDT(PSBBDT,"5Z")
..D:'$D(^TMP("PSBGMV",$J)) EN1^GMVDCEXT("^TMP(""PSBGMV"",$J)",DFN,2,,1,PSBSTRTDT,PSBEDT,,1)
..S PSBGMR=0 F S PSBGMR=$O(^TMP("PSBGMV",$J,PSBGMR)) Q:PSBGMR="" I $P(^TMP("PSBGMV",$J,PSBGMR),U,4)="PN" D
...S PSBVITM=$P(^TMP("PSBGMV",$J,PSBGMR),U,5)
...S PSBTMDF=$$FMDIFF^XLFDT(PSBVITM,PSBEFTM,2)
...I PSBTMDF>=-($S($G(DILOCKTM)>0:DILOCKTM,1:3)),PSBTMDF<=$S($G(DILOCKTM)>0:DILOCKTM,1:3) S PSBDUZ=$P(^TMP("PSBGMV",$J,PSBGMR),U,10) D ;User who marked Pain Score Entered in error, PSB*3*80
....I $P(^TMP("PSBGMV",$J,PSBGMR),U,9)=1 S PSBPNSC=$P(^TMP("PSBGMV",$J,PSBGMR),U,8),PSBERFL="" D
.....I $D(PSBERFL),'$D(PSBEFFL),$G(PSBDUZ),PSBPAIN=PSBPNSC D
......S PSBCOMMENT="**Pain Score of "_PSBPNSC_" entered in Vitals via BCMA at "_PSBEXTM_" may have been marked 'Entered in Error'. See Vitals Package for an updated Score." D PNCMNT(PSBIEN,PSBCOMMENT,PSBDUZ) S PSBEFFL=""
..K PSBERFL,PSBEFFL
K ^TMP("PSBGMV",$J)
Q
PNCMNT(DA,PSBCMT,PSBDUZ) ;Add pain score comment, PSB*3*80
N PSBFDA,PSBIEN,PSBNOW
S PSBIEN="+1,"_DA_","
D NOW^%DTC S PSBNOW=%
D VAL^PSBML(53.793,PSBIEN,.01,PSBCMT)
S PSBFDA(53.793,PSBIEN,.02)=PSBDUZ
S PSBFDA(53.793,PSBIEN,.03)=PSBNOW
D FILEIT^PSBML
Q
LIGHTS(PSBDFN) ;
D RPC^PSBVDLTB(,PSBDFN,"NO TAB",,PSBSIOPI,PSBCLINORD) S PSBTAB="CVRSHT"
M ^TMP("PSB",$J,PSBTAB,1)=^TMP("PSB",$J,"NO TAB",1) K ^TMP("PSB",$J,"NO TAB")
Q
CLEAN ;
D CLEAN^PSBVT
K PSBACT,PSBACTBY,PSBACTDT,PSBACTPT,PSBADDS,PSBBAGID,PSBCHDT,PSBCHKV,PSBCNT1,PSBCNT2,PSBDDS,PSBDFNX,PSBWEND
K PSBDT,PSBFLAG,PSBHSTAX,PSBI1,PSBIEN,PSBIENX,PSBLSTS,PSBMAUD,PSBMVTYP,PSBMWC,PSBNOW,PSBNTDT,PSBONMBR,PSBY,PSBXX
K PSBONXS,PSBORREC,PSBPDT,PSBPRNRE,PSBPTTR,PSBQR,PSBRDOW,PSBREC,PSBRECHD,PSBSCHBR,PSBSCHTM,PSBSOLS,PSBTAB,PSBADMTM,PSBDTX
K PSBTBOUT,PSBTRDT,PSBTRFL,PSBTRTYP,PSBUID,PSBUIDS,PSBX,PSBXIEN,PSBX2,PSBYEA,PSBYEA1,PSBYTF,PSBYES,VAIP,PSBWADM,PSBWBEG
K PSBXREC,PSBGOT1,PSBCDT,PSBQUIT,PSBUSED,PSBLST4X,PSBADMX,PSBI2,PSBXXX,PSBI,PSBPB,PSBSHWTB,PSBONTAB,PSBDONE,^TMP("PSJ",$J)
K PSBNXTDU,LASTG,LSTTIME,PSBMHBCK,PSBHSTG,PSBNXTDT,NEXTADM,PSBLVIV
K PSBHAZ,PSBHAZHN,PSBHAZDS ;*106
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSBCSUTL 16343 printed Dec 13, 2024@01:40:01 Page 2
PSBCSUTL ;BIRMINGHAM/TEJ- BCMA-HSC COVER SHEET UTILITIES ;03/06/16 3:06pm
+1 ;;3.0;BAR CODE MED ADMIN;**16,13,38,32,50,60,58,68,70,80,83,106**;Mar 2004;Build 43
+2 ;Per VHA Directive 2004-038 (or future revisions regarding same), this routine should not be modified.
+3 ;
+4 ; Reference/IA
+5 ; EN^PSJBCMA/2828
+6 ; IN5^VADPT/10061
+7 ; $$GET^XPAR/2263
+8 ; ^%DTC/10000
+9 ; $$FMADD^XLFDT/10103
+10 ; $$GET1^DIQ/2056
+11 ; EN1^GMVDCEXT/4251
+12 ; GETPROVL^PSGSICH1/5653
+13 ; INTRDIC^PSGSICH1/5654
+14 ;
+15 ;*58 - add 30th piece to Results for Override/Intervention flag 1/0
+16 ;*68 - add new parameter to use new SI/OPI word processing fields
+17 ;*70 - add Clinic order request IN param flag (true/false 0/1).
+18 ; also add to return array ORD line 32 piece Clinic name for CO.
+19 ; for CO mode: set to -7 days for pulling pull meds & viewing
+20 ; Expired/DC'd orders; set to +7 days to view future orders.
+21 ;*83 - call new PSBVDLRM, new call FIXADM^PSBUTL for Inserting G
+22 ; action code in Results back to coversheet to trigger Removal.
+23 ;*106- add Hazardous to Handle & Dispose flags 36 & 37
+24 ;
+25 ; ** Warning: PSBSIOPI & PSBCLINORD will be used as global variables
+26 ;
RPC(RESULTS,DFN,EXPWIN,PSBSIOPI,PSBCLINORD) ;
+1 ;*83 used by psbvdlpa & psbvdlrm
NEW PSBONVDL
+2 KILL RESULTS,^TMP("PSB",$JOB),^TMP("PSJ",$JOB)
+3 ;*70
SET EXPWIN=+$GET(EXPWIN)
+4 ;*68 init to 0 if not present or 1 if sent
SET PSBSIOPI=+$GET(PSBSIOPI)
+5 ;*70 init to 0 if null
SET PSBCLINORD=+$GET(PSBCLINORD)
+6 SET PSBTAB="CVRSHT"
+7 NEW PSBCNT
SET PSBTRFL=0
SET PSBDFNX=DFN
+8 ;;Correct Comment if Pain Score entered in BCMA was marked "Entered in Error" in Vitals. (PSB*3*50)
DO PAINCMT(DFN)
+9 SET RESULTS=$NAME(^TMP("PSB",$JOB,PSBTAB))
+10 KILL ^TMP("PSB",$JOB,PSBTAB)
SET ^TMP("PSB",$JOB,PSBTAB,0)=1
DO LIGHTS(PSBDFNX)
+11 SET ^TMP("PSB",$JOB,PSBTAB,0)=1
SET ^TMP("PSB",$JOB,PSBTAB,1)=^TMP("PSB",$JOB,PSBTAB,1)
+12 if $PIECE(^TMP("PSB",$JOB,PSBTAB,1),U,4)=-1
QUIT
+13 DO NOW^%DTC
SET PSBNOW=+$EXTRACT(%,1,10)
SET PSBDT=$PIECE(%,".",1)
+14 ;set range
+15 ;*70 - use diff window values for CO mode vs IM mode
+16 IF PSBCLINORD
Begin DoDot:1
+17 ;not passed in def to 7 days
if 'EXPWIN
SET EXPWIN=24*7
+18 SET PSBWBEG=$PIECE($$FMADD^XLFDT(PSBNOW,-EXPWIN\24),".")
+19 SET PSBWEND=$PIECE($$FMADD^XLFDT(PSBNOW,EXPWIN\24),".")
End DoDot:1
+20 IF '$TEST
Begin DoDot:1
+21 ;not passed in def to 24 hr
if 'EXPWIN
SET EXPWIN=24
+22 SET PSBWBEG=$$FMADD^XLFDT(PSBNOW,"",-EXPWIN)
+23 SET PSBWEND=$$FMADD^XLFDT(PSBNOW,"",EXPWIN)
End DoDot:1
+24 ;
+25 SET PSBWADM=$$GET^XPAR("DIV","PSB ADMIN BEFORE")
SET PSBMHBCK=$$GET^XPAR("ALL","PSB MED HIST DAYS BACK",,"B")
IF +PSBMHBCK=0
SET PSBMHBCK=30
+26 DO NOW^%DTC
SET PSBWADM=$$FMADD^XLFDT(%,"","",+PSBWADM)
SET PSBMHBCK=$$FMADD^XLFDT(%,-1*(PSBMHBCK))
+27 ;use lst movemnt for API
+28 SET VAIP("D")="LAST"
DO IN5^VADPT
SET PSBTRDT=+VAIP(3)
SET PSBTRTYP=$PIECE(VAIP(2),U,2)
SET PSBMVTYP=$PIECE(VAIP(4),U,2)
KILL VAIP
+29 SET PSBPTTR=$$GET^XPAR("DIV","PSB PATIENT TRANSFER")
IF PSBPTTR=""
SET PSBPTTR=72
+30 DO NOW^%DTC
SET PSBNTDT=$$FMADD^XLFDT(%,"",-PSBPTTR)
IF PSBNTDT'>PSBTRDT
SET PSBTRFL=1
+31 ;*70 go back 7 days to pull meds for clinic orders
+32 SET X1=$PIECE(PSBNOW,".")
SET X2=$SELECT(PSBCLINORD:-7,1:-3)
DO C^%DTC
+33 DO EN^PSJBCMA(PSBDFNX,X,$SELECT(PSBMHBCK<PSBWBEG:PSBMHBCK,PSBWBEG<PSBMHBCK:PSBWBEG,1:PSBMHBCK))
+34 ;Filter in/out Clinic Orders *70
+35 if PSBCLINORD
Begin DoDot:1
+36 IF $DATA(PSBRPT(2))
DO FILTERCO^PSBO
QUIT
+37 DO INCLUDCO^PSBVDLU1
End DoDot:1
+38 if 'PSBCLINORD
DO REMOVECO^PSBVDLU1
+39 ;Devlop Outp
+40 SET PSBTBOUT=0
+41 IF ^TMP("PSJ",$JOB,1,0)>0
FOR PSBX=0:0
SET PSBX=$ORDER(^TMP("PSJ",$JOB,PSBX))
if ('PSBX)!(PSBTBOUT)
QUIT
Begin DoDot:1
+42 if (PSBTAB'="CVRSHT")&($GET(^TMP("PSB",$JOB,"CVRSHT",2))>0)
SET PSBTBOUT=1
+43 DO CLEAN^PSBVT
DO PSJ^PSBVT(PSBX)
DO NOW^%DTC
+44 ;in rnge?
if PSBONX["P"
QUIT
if (PSBOSP<PSBWBEG)&'(PSBONX["V")
QUIT
+45 SET (PSBREC,PSBONTAB)=""
+46 ;Dfn
SET $PIECE(PSBREC,U,1)=PSBDFN
+47 ;OrdX
SET $PIECE(PSBREC,U,2)=PSBONX
+48 ;Ord#
SET $PIECE(PSBREC,U,3)=PSBON
+49 ;v/u/p
SET $PIECE(PSBREC,U,4)=PSBOTYP
+50 ;Schtyp
SET $PIECE(PSBREC,U,5)=PSBSCHT
+51 ;Sch
SET $PIECE(PSBREC,U,6)=PSBSCH
+52 ; slfmed
SET $PIECE(PSBREC,U,7)=$SELECT(PSBHSM:"HSM",PSBSM:"SM",1:"")
+53 ;Drgnm
SET $PIECE(PSBREC,U,8)=PSBOITX
+54 ;Dose
SET $PIECE(PSBREC,U,9)=PSBDOSE_" "_PSBIFR
+55 ;med route
SET $PIECE(PSBREC,U,10)=PSBMR
+56 ;Lst Gvn -AOIP xRef
+57 SET (PSBCNT,PSBFLAG)=0
SET (Y,PSBSTUS)=""
KILL PSBHSTA,PSBHSTAX
+58 FOR XZ=1:1:20
SET Y=$ORDER(^PSB(53.79,"AOIP",PSBDFN,PSBOIT,Y),-1)
SET (PSBCNT,PSBFLAG)=0
if Y=""
QUIT
Begin DoDot:2
+59 if Y>0
SET $PIECE(PSBREC,U,11)=Y
+60 SET X=""
FOR
SET X=$ORDER(^PSB(53.79,"AOIP",PSBDFN,PSBOIT,Y,X),-1)
if X=""
QUIT
Begin DoDot:3
+61 SET PSBSTUS=$PIECE(^PSB(53.79,X,0),U,9)
if $GET(PSBSTUS)=""
SET PSBSTUS="X"
IF (PSBSTUS'="N")
SET PSBFLAG=1
SET PSBHSTA(Y,$GET(PSBSTUS))="ORIG"_U_X
+62 if PSBSTUS="N"
Begin DoDot:4
+63 SET ($PIECE(PSBREC,U,11),Z)=""
+64 FOR
SET Z=$ORDER(^PSB(53.79,X,.9,Z),-1)
if 'Z
QUIT
if PSBFLAG=1
QUIT
SET PSBDATA=$GET(^(Z,0))
Begin DoDot:5
+65 IF (PSBDATA["Set to 'NOT GIVEN'")!(PSBDATA["Set to 'GIVEN'")!(PSBDATA["Set to 'REFUSED'")!(PSBDATA["Set to 'HELD'")!(PSBDATA["Set to 'MISSING DOSE'")!(PSBDATA["Set to 'REMOVED'")
SET PSBCNT=PSBCNT+1
+66 IF (PSBDATA["STATUS 'HELD'")!(PSBDATA["STATUS 'GIVEN'")!(PSBDATA["STATUS 'REFUSED'")!(PSBDATA["STATUS 'MISSING DOSE'")!(PSBDATA["STATUS 'REMOVED'")
SET PSBCNT=PSBCNT+1
+67 IF PSBCNT#2=0
IF PSBDATA["'REFUSED'"
SET PSBSTUS="R"
DO LAST^PSBVDLU1
+68 IF PSBCNT#2=0
IF PSBDATA["'HELD'"
SET PSBSTUS="H"
DO LAST^PSBVDLU1
+69 IF PSBCNT#2=0
IF PSBDATA["'MISSING DOSE'"
SET PSBSTUS="M"
DO LAST^PSBVDLU1
+70 IF PSBCNT#2=0
IF PSBDATA["'REMOVED'"
SET PSBSTUS="RM"
DO LAST^PSBVDLU1
+71 IF PSBFLAG=1
IF '$DATA(PSBHSTA($PIECE(PSBREC,U,11),$GET(PSBSTUS)))
SET PSBHSTA($PIECE(PSBREC,U,11),$GET(PSBSTUS))=Z_U_X
End DoDot:5
End DoDot:4
End DoDot:3
End DoDot:2
+72 ;last action date/time
IF $DATA(PSBHSTA)
SET $PIECE(PSBREC,U,11)=$ORDER(PSBHSTA(""),-1)
SET PSBSTUS=$ORDER(PSBHSTA($PIECE(PSBREC,U,11),""),-1)
MERGE PSBHSTAX(PSBOIT)=PSBHSTA
KILL PSBHSTA
+73 ;ien - below
SET $PIECE(PSBREC,U,12)=""
+74 ;sttus - below
SET $PIECE(PSBREC,U,13)=""
+75 ;admn dte - below
SET $PIECE(PSBREC,U,14)=""
+76 ;OI Pointer
SET $PIECE(PSBREC,U,15)=PSBOIT
+77 ;njctble med route flag
SET $PIECE(PSBREC,U,16)=PSBNJECT
+78 ;Var dosg
+79 IF $PIECE(PSBREC,U,9)?1.4N1"-"1.4N.E
SET $PIECE(PSBREC,U,17)=1
+80 IF '$TEST
SET $PIECE(PSBREC,U,17)=0
+81 ;DosgFrm
if PSBDOSEF?1"CAP".E!(PSBDOSEF?1"TAB".E)!(PSBDOSEF="PATCH")
SET $PIECE(PSBREC,U,18)=PSBDOSEF
+82 DO PSJ1^PSBVT(PSBDFN,PSBONX)
+83 SET PSBPB=$$IVPTAB^PSBVDLU3(PSBOTYP,PSBIVT,PSBISYR,PSBCHEMT,+$GET(PSBIVPSH))
SET PSBLVIV=0
+84 if PSBPB&(PSBOSP<PSBWBEG)
QUIT
+85 if (PSBONX["V"&'PSBPB)
SET PSBLVIV=1
+86 ;VerfNrsInts
SET $PIECE(PSBREC,U,19)=$SELECT(PSBVNI]"":PSBVNI,PSBVNI']"":"***")
+87 ;LstActn
SET $PIECE(PSBREC,U,20)=PSBSTUS
if $PIECE(PSBREC,U,11)=""
SET $PIECE(PSBREC,U,20)=""
+88 SET $PIECE(PSBREC,U,21)=PSBOST
+89 SET $PIECE(PSBREC,U,22)=PSBOSTS
+90 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
+91 ;OrdStpDt/Tm
SET $PIECE(PSBREC,U,26)=PSBOSP
+92 SET $PIECE(PSBREC,U,27)=$$LASTG($PIECE(PSBREC,U,1),$PIECE(PSBREC,U,15))
+93 SET $PIECE(PSBREC,U,28)=$SELECT((PSBONX["U")&('PSBPB):1,PSBPB:2,(PSBONX["V")&'PSBPB:3,1:"")
+94 ;*58 determine if override exists, send 1/0 (true/false)
+95 NEW PSBARR
DO GETPROVL^PSGSICH1(DFN,PSBONX,.PSBARR)
+96 IF $ORDER(PSBARR(""))=""
DO INTRDIC^PSGSICH1(DFN,PSBONX,.PSBARR,2)
+97 SET $PIECE(PSBREC,U,29)=$SELECT($ORDER(PSBARR(""))]"":1,1:0)
+98 ;*70 add Clinic name & ien ptr to piece 32 and 33 for CO's, remember
+99 ; "ORD" is inserted later as piece 1 which offsets all here by +1
+100 SET $PIECE(PSBREC,U,31)=$GET(PSBCLORD)
+101 SET $PIECE(PSBREC,U,32)=$GET(PSBCLIEN)
+102 ; piece 34-35 reserved for Remove meds and set by PSBVDLU1
+103 ;Hazardous to Handle *106
SET $PIECE(PSBREC,U,36)=$GET(PSBHAZHN)
+104 ;Hazardous to Dispose *106
SET $PIECE(PSBREC,U,37)=$GET(PSBHAZDS)
+105 ;get all Admn(s) - DD info.
+106 SET (PSBDDS,PSBSOLS,PSBADDS,PSBFLAG)="0"
+107 ;PSB*3*60 adds additional checks to ensure an expired order is within the coversheet time parameter and an "END" is only added to the temp global after an order is added
+108 ;PSB*3*60
IF PSBLVIV
DO XFERBAGS^PSBCSUTY
DO LVIV^PSBCSUTY
IF $GET(PSBEXPRD)
SET X1=$ORDER(^TMP("PSB",$JOB,PSBTAB,""),-1)
if ^TMP("PSB",$JOB,PSBTAB,X1)'="END"&(X1>1)
SET ^TMP("PSB",$JOB,PSBTAB,X1+1)="END"
QUIT
+109 DO GETADMX^PSBCSUTY
+110 FOR Y=0:0
SET Y=$ORDER(PSBDDA(Y))
if 'Y
QUIT
Begin DoDot:2
+111 ;drug nactvt
IF $PIECE(PSBDDA(Y),U,5)=$PIECE(%,".")
SET PSBFLAG=1
+112 ;nactv
if $PIECE(PSBDDA(Y),U,5)&($PIECE(PSBDDA(Y),U,5)<%)
QUIT
+113 if $PIECE(PSBDDA(Y),U,4)=""
SET $PIECE(PSBDDA(Y),U,4)=1
+114 SET PSBDDS=PSBDDS_U_$PIECE(PSBDDA(Y),U,1,4)
SET $PIECE(PSBDDS,U,1)=PSBDDS+1
End DoDot:2
+115 ;OnCa O PRN
+116 IF ("^O^OC^P^"[(U_PSBSCHT_U))!(PSBLVIV)
Begin DoDot:2
+117 SET (PSBIENX,PSBGOT1)=""
SET PSBADMTM=""
FOR
SET PSBADMTM=$ORDER(^PSB(53.79,"AORDX",PSBDFNX,PSBONX,PSBADMTM))
if (PSBADMTM="")
QUIT
Begin DoDot:3
+118 if (PSBADMTM<PSBMHBCK)&'PSBLVIV
QUIT
+119 FOR
SET PSBIENX=$ORDER(^PSB(53.79,"AORDX",PSBDFNX,PSBONX,PSBADMTM,PSBIENX))
if PSBIENX=""
QUIT
Begin DoDot:4
+120 SET $PIECE(PSBREC,U,12)=PSBIENX
SET $PIECE(PSBREC,U,14)=PSBADMTM
SET $PIECE(PSBREC,U,23)=$$GET1^DIQ(53.79,PSBIENX_",","IV UNIQUE ID")
+121 ;PSB*3*60
SET PSBQRR=1
IF PSBWBEG<PSBOSP
DO ADD^PSBVDLU1(PSBREC,PSBOTXT,PSBADMTM,PSBDDS,PSBSOLS,PSBADDS,"CVRSHT")
SET PSBGOT1=1
End DoDot:4
End DoDot:3
+122 IF ('+PSBGOT1)&(PSBOSP'<PSBWBEG)
DO ADD^PSBVDLU1(PSBREC,PSBOTXT,PSBNOW\1_".",PSBDDS,PSBSOLS,PSBADDS,"CVRSHT")
SET PSBGOT1=1
+123 ;PSB*3*60
IF ('+PSBGOT1)&($DATA(PSBADMX(PSBONX)))&(PSBWBEG<PSBOSP)
DO ADD^PSBVDLU1(PSBREC,PSBOTXT,PSBNOW\1_".",PSBDDS,PSBSOLS,PSBADDS,"CVRSHT")
+124 ;PSB*3*60
SET PSBGLBX=$ORDER(^TMP("PSB",$JOB,PSBTAB,""),-1)
if ^TMP("PSB",$JOB,PSBTAB,PSBGLBX)'="END"&(PSBGLBX>1)
SET ^TMP("PSB",$JOB,PSBTAB,PSBGLBX+1)="END"
End DoDot:2
SET ($PIECE(PSBREC,U,12),$PIECE(PSBREC,U,14))=""
QUIT
+125 ;cont - proces AdmnTm
+126 SET (PSBYES,PSBODD,PSBYTF)=0
if $$PSBDCHK1^PSBVT1(PSBSCH)
SET PSBYES=1
+127 IF PSBYES
IF PSBADST=""
QUIT
+128 FOR I=1:1
if $PIECE(PSBSCH,"-",I)=""
QUIT
IF $PIECE(PSBSCH,"-",I)?2N!($PIECE(PSBSCH,"-",I)?4N)
SET PSBYES=1
SET PSBYTF=1
+129 IF PSBSCHT="C"
IF PSBYTF="1"
IF PSBADST=""
QUIT
+130 SET PSBFREQ=$$GETFREQ^PSBVDLU1(DFN,PSBONX)
+131 IF PSBFREQ="O"
SET PSBFREQ=1440
+132 IF PSBFREQ="D"
SET PSBFREQ=""
+133 if PSBLVIV
SET PSBYES=1
+134 IF 'PSBYES
IF PSBFREQ<1
QUIT
+135 IF (PSBADST="")&(+PSBFREQ>0)
DO ODDSCH^PSBVDLU1(PSBTAB)
QUIT
+136 IF +PSBFREQ>0
IF (PSBFREQ#1440'=0)
IF (1440#PSBFREQ'=0)
SET PSBODD=1
+137 IF PSBODD
IF PSBADST'=""
QUIT
+138 SET PSBDTX=PSBWBEG\1
SET PSBGOT1=0
+139 ;incrmnt 1 day!
FOR PSBXX=1:1:2
Begin DoDot:2
+140 FOR PSBY=1:1:$LENGTH(PSBADST,"-")
if $PIECE(PSBADST,"-",PSBY)=""
QUIT
Begin DoDot:3
+141 SET PSB=+(PSBDTX_"."_$PIECE(PSBADST,"-",PSBY))
+142 ;wndow?
IF (PSB'<PSBWBEG)&(PSB'>PSBWEND)
Begin DoDot:4
+143 ;actv?
if (PSB'<PSBOST)&(PSB<PSBOSP)
Begin DoDot:5
+144 ;dt?
if $$OKAY^PSBVDLU1(PSBOST,PSB,PSBSCH,PSBONX,PSBOITX,PSBFREQ,PSBOSTS)
Begin DoDot:6
+145 DO ADD^PSBVDLU1(PSBREC,PSBOTXT,PSB,PSBDDS,PSBSOLS,PSBADDS,"CVRSHT")
SET PSBGOT1=1
End DoDot:6
End DoDot:5
End DoDot:4
+146 SET PSB=+(PSBWEND\1_"."_$PIECE(PSBADST,"-",PSBY))
+147 ;wndow?
IF (PSB'<PSBWBEG)&(PSB'>PSBWEND)
Begin DoDot:4
+148 ;actv?
if (PSB'<PSBOST)&(PSB<PSBOSP)
Begin DoDot:5
+149 ;dt?
if $$OKAY^PSBVDLU1(PSBOST,PSB,PSBSCH,PSBONX,PSBOITX,PSBFREQ,PSBOSTS)
Begin DoDot:6
+150 DO ADD^PSBVDLU1(PSBREC,PSBOTXT,PSB,PSBDDS,PSBSOLS,PSBADDS,"CVRSHT")
SET PSBGOT1=1
End DoDot:6
End DoDot:5
End DoDot:4
End DoDot:3
End DoDot:2
SET PSBDTX=$$FMADD^XLFDT(PSBDTX,"",24)
+151 IF ('PSBGOT1)&(PSBOSP'<PSBWBEG)
DO ADD^PSBVDLU1(PSBREC,PSBOTXT,+(PSBWEND\1_"."_$PIECE(PSBADST,"-")),PSBDDS,PSBSOLS,PSBADDS,"CVRSHT")
+152 KILL PSBSTUS
End DoDot:1
+153 DO EN^PSBVDLPA
+154 ;*83 new rtn
DO EN^PSBVDLRM
+155 IF $GET(^TMP("PSB",$JOB,PSBTAB,2))]""
SET PSBI1=$ORDER(^TMP("PSB",$JOB,PSBTAB,""),-1)
IF ^TMP("PSB",$JOB,PSBTAB,PSBI1)'="END"
SET ^TMP("PSB",$JOB,PSBTAB,PSBI1+1)="END"
+156 SET ^TMP("PSB",$JOB,PSBTAB,0)=$ORDER(^TMP("PSB",$JOB,PSBTAB,""),-1)
+157 ;*70 was "To" now "to"
IF $GET(^TMP("PSB",$JOB,PSBTAB,2))']""
SET $PIECE(^TMP("PSB",$JOB,PSBTAB,1),U,4)="-1^No orders to display on Coversheet"
+158 IF $GET(^TMP("PSB",$JOB,PSBTAB,2))]""
SET $PIECE(^TMP("PSB",$JOB,PSBTAB,1),U,4)="1^COVERSHEET DATA FOLLOWS"
DO ADD^PSBCSUTX
+159 ;*83
DO FIXADM^PSBUTL
+160 DO CLEAN
+161 QUIT
LASTG(PSBPATPT,PSBOIPT) ;LstGvn-(inpt: DFN,OrItm IEN)
+1 KILL PSBHSTG
SET Y=""
SET LASTG=""
FOR XZ=1:1:20
SET Y=$ORDER(^PSB(53.79,"AOIP",PSBPATPT,PSBOIPT,Y),-1)
SET (PSBCNT,PSBFLAG)=0
if Y=""
QUIT
Begin DoDot:1
+2 if Y>0
SET LASTG=""
SET X=""
FOR
SET X=$ORDER(^PSB(53.79,"AOIP",PSBPATPT,PSBOIPT,Y,X),-1)
if X=""
QUIT
Begin DoDot:2
+3 SET PSBSTX=$PIECE(^PSB(53.79,X,0),U,9)
if PSBSTX']""
SET PSBHSTG(Y)=-1
IF PSBSTX="G"
SET PSBHSTG(Y)="G"
+4 if PSBSTX="N"
QUIT
+5 if (PSBSTX'="G")
Begin DoDot:3
+6 SET Z=""
FOR
SET Z=$ORDER(^PSB(53.79,X,.9,Z),-1)
if 'Z
QUIT
if PSBFLAG=1
QUIT
SET PSBDATA=$GET(^(Z,0))
Begin DoDot:4
+7 IF (PSBDATA["Set to 'GIVEN'")
SET PSBCNT=PSBCNT+1
+8 IF (PSBDATA["STATUS 'GIVEN'")
SET PSBCNT=PSBCNT+1
+9 IF PSBCNT#2=0
IF PSBDATA'["'GIVEN'"
QUIT
+10 IF '$DATA(PSBHSTG($PIECE(PSBDATA,U)))
SET PSBFLAG=1
SET PSBHSTG($PIECE(PSBDATA,U))=""
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+11 IF $DATA(PSBHSTG)
SET LASTG=""
FOR
SET LASTG=$ORDER(PSBHSTG(LASTG),-1)
if +LASTG=0
QUIT
if PSBHSTG(LASTG)="G"
QUIT
IF PSBHSTG(LASTG)=-1
SET LASTG=""
QUIT
+12 QUIT LASTG
PAINCMT(DFN) ;;Add comment if Pain Score entered in BCMA was marked "Entered in Error" in Vitals.
+1 ;;This will run through all the patients appointments, check their comments to see if they had a Pain Vital entered through BCMA, and check if that Vital was marked "Entered in Error."
+2 if '$DATA(^DPT(DFN,0))
QUIT
+3 NEW PSBCMT,PSBGMR,PSBCMTGLB,PSBIEN,PSBCMTM,PSBVITM,PSBTMDF,PSBBDT,PSBEDT,PSBEFTM,PSBCMFL,PSBEXTM,PSBERFL,PSBPNSC,PSBNOW,PSBDFN,PSBPRNDT,PSBSTRTDT,PSBMDHST,PSBEFFL,PSBCOMMENT,X,X1,X2,PSBDUZ,PSBPAIN
+4 KILL ^TMP("PSBGMV",$JOB)
+5 DO NOW^%DTC
SET PSBEDT=%
+6 SET PSBMDHST=+($$GET^XPAR("ALL","PSB MED HIST DAYS BACK",,"B"))
if +$GET(PSBMDHST)=0
SET PSBMDHST=30
+7 SET X1=$PIECE(PSBEDT,".")
SET X2=-(PSBMDHST)
DO C^%DTC
SET PSBMDHST=X
+8 SET PSBSTRTDT=$SELECT($GET(PSBSTRT)]0:PSBSTRT,1:PSBMDHST)
+9 SET PSBPRNDT=PSBSTRTDT
FOR
SET PSBPRNDT=$ORDER(^PSB(53.79,"APRN",DFN,PSBPRNDT))
if 'PSBPRNDT
QUIT
Begin DoDot:1
+10 SET PSBIEN=0
FOR
SET PSBIEN=$ORDER(^PSB(53.79,"APRN",DFN,PSBPRNDT,PSBIEN))
if 'PSBIEN
QUIT
Begin DoDot:2
+11 SET PSBCMT=0
FOR
SET PSBCMT=$ORDER(^PSB(53.79,PSBIEN,.3,PSBCMT))
if 'PSBCMT
QUIT
SET PSBCMTGLB=^PSB(53.79,PSBIEN,.3,PSBCMT,0)
Begin DoDot:3
+12 IF $PIECE($GET(PSBCMTGLB),U)["Pain Score of"
SET PSBPAIN=$EXTRACT($PIECE(PSBCMTGLB,U),15)
Begin DoDot:4
+13 IF $EXTRACT($PIECE($GET(PSBCMTGLB),U),1,14)="*Pain Score of"
SET PSBCMFL=""
+14 IF $EXTRACT($PIECE($GET(PSBCMTGLB),U),1,15)="**Pain Score of"
SET PSBEFFL=""
+15 SET PSBCMTM=$PIECE($GET(PSBCMTGLB),U,3)
+16 SET PSBBDT=$EXTRACT(PSBCMTM,1,12)
+17 SET PSBEXTM=$$FMTE^XLFDT(PSBBDT,"5Z")
+18 IF '$DATA(^TMP("PSBGMV",$JOB))
DO EN1^GMVDCEXT("^TMP(""PSBGMV"",$J)",DFN,2,,1,PSBSTRTDT,PSBEDT,,1)
+19 SET PSBGMR=0
FOR
SET PSBGMR=$ORDER(^TMP("PSBGMV",$JOB,PSBGMR))
if PSBGMR=""
QUIT
IF $PIECE(^TMP("PSBGMV",$JOB,PSBGMR),U,4)="PN"
Begin DoDot:5
+20 SET PSBVITM=$PIECE(^TMP("PSBGMV",$JOB,PSBGMR),U,5)
+21 SET PSBTMDF=$$FMDIFF^XLFDT(PSBVITM,PSBCMTM,2)
+22 ;User who marked Pain Score Entered in error, PSB*3*80
IF PSBTMDF>=-($SELECT($GET(DILOCKTM)>0:DILOCKTM,1:3))
IF PSBTMDF<=$SELECT($GET(DILOCKTM)>0:DILOCKTM,1:3)
SET PSBDUZ=$PIECE(^TMP("PSBGMV",$JOB,PSBGMR),U,10)
Begin DoDot:6
+23 IF $PIECE(^TMP("PSBGMV",$JOB,PSBGMR),U,9)=1
SET PSBPNSC=$PIECE(^TMP("PSBGMV",$JOB,PSBGMR),U,8)
SET PSBERFL=""
Begin DoDot:7
+24 IF $DATA(PSBERFL)
IF '$DATA(PSBCMFL)
IF $GET(PSBDUZ)
IF PSBPAIN=PSBPNSC
Begin DoDot:8
+25 SET PSBCOMMENT="*Pain Score of "_PSBPNSC_" entered in Vitals via BCMA at "_PSBEXTM_" may have been marked 'Entered in Error'. See Vitals Package for an updated
Score."
DO PNCMNT(PSBIEN,PSBCOMMENT,PSBDUZ)
SET PSBCMFL=""
End DoDot:8
End DoDot:7
End DoDot:6
End DoDot:5
End DoDot:4
End DoDot:3
+26 KILL PSBCMFL,PSBERFL
+27 SET PSBEFTM=$PIECE($GET(^PSB(53.79,PSBIEN,.2)),U,4)
if PSBEFTM=""
QUIT
+28 SET PSBBDT=$EXTRACT(PSBEFTM,1,12)
SET PSBPAIN=$EXTRACT($PIECE(^PSB(53.79,PSBIEN,.2),U,2),15)
+29 SET PSBEXTM=$$FMTE^XLFDT(PSBBDT,"5Z")
+30 if '$DATA(^TMP("PSBGMV",$JOB))
DO EN1^GMVDCEXT("^TMP(""PSBGMV"",$J)",DFN,2,,1,PSBSTRTDT,PSBEDT,,1)
+31 SET PSBGMR=0
FOR
SET PSBGMR=$ORDER(^TMP("PSBGMV",$JOB,PSBGMR))
if PSBGMR=""
QUIT
IF $PIECE(^TMP("PSBGMV",$JOB,PSBGMR),U,4)="PN"
Begin DoDot:3
+32 SET PSBVITM=$PIECE(^TMP("PSBGMV",$JOB,PSBGMR),U,5)
+33 SET PSBTMDF=$$FMDIFF^XLFDT(PSBVITM,PSBEFTM,2)
+34 ;User who marked Pain Score Entered in error, PSB*3*80
IF PSBTMDF>=-($SELECT($GET(DILOCKTM)>0:DILOCKTM,1:3))
IF PSBTMDF<=$SELECT($GET(DILOCKTM)>0:DILOCKTM,1:3)
SET PSBDUZ=$PIECE(^TMP("PSBGMV",$JOB,PSBGMR),U,10)
Begin DoDot:4
+35 IF $PIECE(^TMP("PSBGMV",$JOB,PSBGMR),U,9)=1
SET PSBPNSC=$PIECE(^TMP("PSBGMV",$JOB,PSBGMR),U,8)
SET PSBERFL=""
Begin DoDot:5
+36 IF $DATA(PSBERFL)
IF '$DATA(PSBEFFL)
IF $GET(PSBDUZ)
IF PSBPAIN=PSBPNSC
Begin DoDot:6
+37 SET PSBCOMMENT="**Pain Score of "_PSBPNSC_" entered in Vitals via BCMA at "_PSBEXTM_" may have been marked 'Entered in Error'. See Vitals Package for an updated Score."
DO PNCMNT(PSBIEN,PSBCOMMENT,PSBDUZ)
SET PSBEFFL=""
End DoDot:6
End DoDot:5
End DoDot:4
End DoDot:3
+38 KILL PSBERFL,PSBEFFL
End DoDot:2
End DoDot:1
+39 KILL ^TMP("PSBGMV",$JOB)
+40 QUIT
PNCMNT(DA,PSBCMT,PSBDUZ) ;Add pain score comment, PSB*3*80
+1 NEW PSBFDA,PSBIEN,PSBNOW
+2 SET PSBIEN="+1,"_DA_","
+3 DO NOW^%DTC
SET PSBNOW=%
+4 DO VAL^PSBML(53.793,PSBIEN,.01,PSBCMT)
+5 SET PSBFDA(53.793,PSBIEN,.02)=PSBDUZ
+6 SET PSBFDA(53.793,PSBIEN,.03)=PSBNOW
+7 DO FILEIT^PSBML
+8 QUIT
LIGHTS(PSBDFN) ;
+1 DO RPC^PSBVDLTB(,PSBDFN,"NO TAB",,PSBSIOPI,PSBCLINORD)
SET PSBTAB="CVRSHT"
+2 MERGE ^TMP("PSB",$JOB,PSBTAB,1)=^TMP("PSB",$JOB,"NO TAB",1)
KILL ^TMP("PSB",$JOB,"NO TAB")
+3 QUIT
CLEAN ;
+1 DO CLEAN^PSBVT
+2 KILL PSBACT,PSBACTBY,PSBACTDT,PSBACTPT,PSBADDS,PSBBAGID,PSBCHDT,PSBCHKV,PSBCNT1,PSBCNT2,PSBDDS,PSBDFNX,PSBWEND
+3 KILL PSBDT,PSBFLAG,PSBHSTAX,PSBI1,PSBIEN,PSBIENX,PSBLSTS,PSBMAUD,PSBMVTYP,PSBMWC,PSBNOW,PSBNTDT,PSBONMBR,PSBY,PSBXX
+4 KILL PSBONXS,PSBORREC,PSBPDT,PSBPRNRE,PSBPTTR,PSBQR,PSBRDOW,PSBREC,PSBRECHD,PSBSCHBR,PSBSCHTM,PSBSOLS,PSBTAB,PSBADMTM,PSBDTX
+5 KILL PSBTBOUT,PSBTRDT,PSBTRFL,PSBTRTYP,PSBUID,PSBUIDS,PSBX,PSBXIEN,PSBX2,PSBYEA,PSBYEA1,PSBYTF,PSBYES,VAIP,PSBWADM,PSBWBEG
+6 KILL PSBXREC,PSBGOT1,PSBCDT,PSBQUIT,PSBUSED,PSBLST4X,PSBADMX,PSBI2,PSBXXX,PSBI,PSBPB,PSBSHWTB,PSBONTAB,PSBDONE,^TMP("PSJ",$JOB)
+7 KILL PSBNXTDU,LASTG,LSTTIME,PSBMHBCK,PSBHSTG,PSBNXTDT,NEXTADM,PSBLVIV
+8 ;*106
KILL PSBHAZ,PSBHAZHN,PSBHAZDS
+9 QUIT
