PSBCSUTL ;BIRMINGHAM/TEJ- BCMA-HSC COVER SHEET UTILITIES ;Mar 2004
;;3.0;BAR CODE MED ADMIN;**16,13,38,32,50**;Mar 2004;Build 78
;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
RPC(RESULTS,DFN,EXPWIN) ;
K RESULTS,^TMP("PSB",$J),^TMP("PSJ",$J)
S PSBXWIN=$G(EXPWIN,24)
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
S PSBWBEG=$$FMADD^XLFDT(PSBNOW,"",-PSBXWIN),PSBWEND=$$FMADD^XLFDT(PSBNOW,"",PSBXWIN)
S PSBTBEG=$$FMADD^XLFDT(PSBNOW,"",-12),PSBTEND=$$FMADD^XLFDT(PSBNOW,"",12)
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
S X1=$P(PSBNOW,"."),X2=-3 D C^%DTC
D EN^PSJBCMA(PSBDFNX,X,$S(PSBMHBCK<PSBWBEG:PSBMHBCK,PSBWBEG<PSBMHBCK:PSBWBEG,1:PSBMHBCK))
;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:"")
.;get all Admn(s) - DD info.
.S (PSBDDS,PSBSOLS,PSBADDS,PSBFLAG)="0"
.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" ^TMP("PSB",$J,PSBTAB,X1+1)="END" Q
.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 D ADD^PSBVDLU1(PSBREC,PSBOTXT,PSBADMTM,PSBDDS,PSBSOLS,PSBADDS,"CVRSHT") S PSBGOT1=1
..I ('+PSBGOT1)&(PSBOSP'<PSBWBEG) D ADD^PSBVDLU1(PSBREC,PSBOTXT,PSBNOW\1_".",PSBDDS,PSBSOLS,PSBADDS,"CVRSHT") S PSBGOT1=1
..I ('+PSBGOT1)&($D(PSBADMX(PSBONX))) D ADD^PSBVDLU1(PSBREC,PSBOTXT,PSBNOW\1_".",PSBDDS,PSBSOLS,PSBADDS,"CVRSHT")
..S PSBGLBX=$O(^TMP("PSB",$J,PSBTAB,""),-1) S:^TMP("PSB",$J,PSBTAB,PSBGLBX)'="END" ^TMP("PSB",$J,PSBTAB,PSBGLBX+1)="END"
.;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
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"
I $G(^TMP("PSB",$J,PSBTAB,2))]"" S $P(^TMP("PSB",$J,PSBTAB,1),U,4)="1^COVERSHEET DATA FOLLOWS" D ADD^PSBCSUTX
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
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" 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) D
......I $P(^TMP("PSBGMV",$J,PSBGMR),U,9)=1 S PSBPNSC=$P(^TMP("PSBGMV",$J,PSBGMR),U,8),PSBERFL=""
..I $D(PSBERFL),'$D(PSBCMFL) 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 COMMENT^PSBML(PSBIEN,PSBCOMMENT)
..K PSBCMFL,PSBERFL
..S PSBEFTM=$P($G(^PSB(53.79,PSBIEN,.2)),U,4) Q:PSBEFTM=""
..S PSBBDT=$E(PSBEFTM,1,12)
..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) D
....I $P(^TMP("PSBGMV",$J,PSBGMR),U,9)=1 S PSBPNSC=$P(^TMP("PSBGMV",$J,PSBGMR),U,8),PSBERFL=""
..I $D(PSBERFL),'$D(PSBEFFL) 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 COMMENT^PSBML(PSBIEN,PSBCOMMENT)
..K PSBERFL,PSBEFFL
K ^TMP("PSBGMV",$J)
Q
LIGHTS(PSBDFN) ;
D RPC^PSBVDLTB(,PSBDFN,"NO TAB",) 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
Q
PSBCSUTL ;BIRMINGHAM/TEJ- BCMA-HSC COVER SHEET UTILITIES ;Mar 2004
+1 ;;3.0;BAR CODE MED ADMIN;**16,13,38,32,50**;Mar 2004;Build 78
+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
RPC(RESULTS,DFN,EXPWIN) ;
+1 KILL RESULTS,^TMP("PSB",$JOB),^TMP("PSJ",$JOB)
+2 SET PSBXWIN=$GET(EXPWIN,24)
+3 SET PSBTAB="CVRSHT"
+4 NEW PSBCNT
SET PSBTRFL=0
SET PSBDFNX=DFN
+5 ;;Correct Comment if Pain Score entered in BCMA was marked "Entered in Error" in Vitals. (PSB*3*50)
DO PAINCMT(DFN)
+6 SET RESULTS=$NAME(^TMP("PSB",$JOB,PSBTAB))
+7 KILL ^TMP("PSB",$JOB,PSBTAB)
SET ^TMP("PSB",$JOB,PSBTAB,0)=1
DO LIGHTS(PSBDFNX)
+8 SET ^TMP("PSB",$JOB,PSBTAB,0)=1
SET ^TMP("PSB",$JOB,PSBTAB,1)=^TMP("PSB",$JOB,PSBTAB,1)
+9 IF $PIECE(^TMP("PSB",$JOB,PSBTAB,1),U,4)=-1
QUIT
+10 DO NOW^%DTC
SET PSBNOW=+$EXTRACT(%,1,10)
SET PSBDT=$PIECE(%,".",1)
+11 ;set range
+12 SET PSBWBEG=$$FMADD^XLFDT(PSBNOW,"",-PSBXWIN)
SET PSBWEND=$$FMADD^XLFDT(PSBNOW,"",PSBXWIN)
+13 SET PSBTBEG=$$FMADD^XLFDT(PSBNOW,"",-12)
SET PSBTEND=$$FMADD^XLFDT(PSBNOW,"",12)
+14 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
+15 DO NOW^%DTC
SET PSBWADM=$$FMADD^XLFDT(%,"","",+PSBWADM)
SET PSBMHBCK=$$FMADD^XLFDT(%,-1*(PSBMHBCK))
+16 ;use lst movemnt for API
+17 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
+18 SET PSBPTTR=$$GET^XPAR("DIV","PSB PATIENT TRANSFER")
IF PSBPTTR=""
SET PSBPTTR=72
+19 DO NOW^%DTC
SET PSBNTDT=$$FMADD^XLFDT(%,"",-PSBPTTR)
IF PSBNTDT'>PSBTRDT
SET PSBTRFL=1
+20 SET X1=$PIECE(PSBNOW,".")
SET X2=-3
DO C^%DTC
+21 DO EN^PSJBCMA(PSBDFNX,X,$SELECT(PSBMHBCK<PSBWBEG:PSBMHBCK,PSBWBEG<PSBMHBCK:PSBWBEG,1:PSBMHBCK))
+22 ;Devlop Outp
+23 SET PSBTBOUT=0
+24 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
+25 IF (PSBTAB'="CVRSHT")&($GET(^TMP("PSB",$JOB,"CVRSHT",2))>0)
SET PSBTBOUT=1
+26 DO CLEAN^PSBVT
DO PSJ^PSBVT(PSBX)
DO NOW^%DTC
+27 ;in rnge?
IF PSBONX["P"
QUIT
IF (PSBOSP<PSBWBEG)&'(PSBONX["V")
QUIT
+28 SET (PSBREC,PSBONTAB)=""
+29 ;Dfn
SET $PIECE(PSBREC,U,1)=PSBDFN
+30 ;OrdX
SET $PIECE(PSBREC,U,2)=PSBONX
+31 ;Ord#
SET $PIECE(PSBREC,U,3)=PSBON
+32 ;v/u/p
SET $PIECE(PSBREC,U,4)=PSBOTYP
+33 ;Schtyp
SET $PIECE(PSBREC,U,5)=PSBSCHT
+34 ;Sch
SET $PIECE(PSBREC,U,6)=PSBSCH
+35 ; slfmed
SET $PIECE(PSBREC,U,7)=$SELECT(PSBHSM:"HSM",PSBSM:"SM",1:"")
+36 ;Drgnm
SET $PIECE(PSBREC,U,8)=PSBOITX
+37 ;Dose
SET $PIECE(PSBREC,U,9)=PSBDOSE_" "_PSBIFR
+38 ;med route
SET $PIECE(PSBREC,U,10)=PSBMR
+39 ;Lst Gvn -AOIP xRef
+40 SET (PSBCNT,PSBFLAG)=0
SET (Y,PSBSTUS)=""
KILL PSBHSTA,PSBHSTAX
+41 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
+42 IF Y>0
SET $PIECE(PSBREC,U,11)=Y
+43 SET X=""
FOR
SET X=$ORDER(^PSB(53.79,"AOIP",PSBDFN,PSBOIT,Y,X),-1)
IF X=""
QUIT
Begin DoDot:3
+44 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
+45 IF PSBSTUS="N"
Begin DoDot:4
+46 SET ($PIECE(PSBREC,U,11),Z)=""
+47 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
+48 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
+49 IF (PSBDATA["STATUS 'HELD'")!(PSBDATA["STATUS 'GIVEN'")!(PSBDATA["STATUS 'REFUSED'")!(PSBDATA["STATUS 'MISSING DOSE'")!(PSBDATA["STATUS 'REMOVED'")
SET PSBCNT=PSBCNT+1
+50 IF PSBCNT#2=0
IF PSBDATA["'REFUSED'"
SET PSBSTUS="R"
DO LAST^PSBVDLU1
+51 IF PSBCNT#2=0
IF PSBDATA["'HELD'"
SET PSBSTUS="H"
DO LAST^PSBVDLU1
+52 IF PSBCNT#2=0
IF PSBDATA["'MISSING DOSE'"
SET PSBSTUS="M"
DO LAST^PSBVDLU1
+53 IF PSBCNT#2=0
IF PSBDATA["'REMOVED'"
SET PSBSTUS="RM"
DO LAST^PSBVDLU1
+54 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
+55 ;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
+56 ;ien - below
SET $PIECE(PSBREC,U,12)=""
+57 ;sttus - below
SET $PIECE(PSBREC,U,13)=""
+58 ;admn dte - below
SET $PIECE(PSBREC,U,14)=""
+59 ;OI Pointer
SET $PIECE(PSBREC,U,15)=PSBOIT
+60 ;njctble med route flag
SET $PIECE(PSBREC,U,16)=PSBNJECT
+61 ;Var dosg
+62 IF $PIECE(PSBREC,U,9)?1.4N1"-"1.4N.E
SET $PIECE(PSBREC,U,17)=1
+63 IF '$TEST
SET $PIECE(PSBREC,U,17)=0
+64 ;DosgFrm
IF PSBDOSEF?1"CAP".E!(PSBDOSEF?1"TAB".E)!(PSBDOSEF="PATCH")
SET $PIECE(PSBREC,U,18)=PSBDOSEF
+65 DO PSJ1^PSBVT(PSBDFN,PSBONX)
+66 SET PSBPB=$$IVPTAB^PSBVDLU3(PSBOTYP,PSBIVT,PSBISYR,PSBCHEMT,+$GET(PSBIVPSH))
SET PSBLVIV=0
+67 IF PSBPB&(PSBOSP<PSBWBEG)
QUIT
+68 IF (PSBONX["V"&'PSBPB)
SET PSBLVIV=1
+69 ;VerfNrsInts
SET $PIECE(PSBREC,U,19)=$SELECT(PSBVNI]"":PSBVNI,PSBVNI']"":"***")
+70 ;LstActn
SET $PIECE(PSBREC,U,20)=PSBSTUS
IF $PIECE(PSBREC,U,11)=""
SET $PIECE(PSBREC,U,20)=""
+71 SET $PIECE(PSBREC,U,21)=PSBOST
+72 SET $PIECE(PSBREC,U,22)=PSBOSTS
+73 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
+74 ;OrdStpDt/Tm
SET $PIECE(PSBREC,U,26)=PSBOSP
+75 SET $PIECE(PSBREC,U,27)=$$LASTG($PIECE(PSBREC,U,1),$PIECE(PSBREC,U,15))
+76 SET $PIECE(PSBREC,U,28)=$SELECT((PSBONX["U")&('PSBPB):1,PSBPB:2,(PSBONX["V")&'PSBPB:3,1:"")
+77 ;get all Admn(s) - DD info.
+78 SET (PSBDDS,PSBSOLS,PSBADDS,PSBFLAG)="0"
+79 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"
SET ^TMP("PSB",$JOB,PSBTAB,X1+1)="END"
QUIT
+80 DO GETADMX^PSBCSUTY
+81 FOR Y=0:0
SET Y=$ORDER(PSBDDA(Y))
IF 'Y
QUIT
Begin DoDot:2
+82 ;drug nactvt
IF $PIECE(PSBDDA(Y),U,5)=$PIECE(%,".")
SET PSBFLAG=1
+83 ;nactv
IF $PIECE(PSBDDA(Y),U,5)&($PIECE(PSBDDA(Y),U,5)<%)
QUIT
+84 IF $PIECE(PSBDDA(Y),U,4)=""
SET $PIECE(PSBDDA(Y),U,4)=1
+85 SET PSBDDS=PSBDDS_U_$PIECE(PSBDDA(Y),U,1,4)
SET $PIECE(PSBDDS,U,1)=PSBDDS+1
End DoDot:2
+86 ;OnCa O PRN
+87 IF ("^O^OC^P^"[(U_PSBSCHT_U))!(PSBLVIV)
Begin DoDot:2
+88 SET (PSBIENX,PSBGOT1)=""
SET PSBADMTM=""
FOR
SET PSBADMTM=$ORDER(^PSB(53.79,"AORDX",PSBDFNX,PSBONX,PSBADMTM))
IF (PSBADMTM="")
QUIT
Begin DoDot:3
+89 IF (PSBADMTM<PSBMHBCK)&'PSBLVIV
QUIT
+90 FOR
SET PSBIENX=$ORDER(^PSB(53.79,"AORDX",PSBDFNX,PSBONX,PSBADMTM,PSBIENX))
IF PSBIENX=""
QUIT
Begin DoDot:4
+91 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")
+92 SET PSBQRR=1
DO ADD^PSBVDLU1(PSBREC,PSBOTXT,PSBADMTM,PSBDDS,PSBSOLS,PSBADDS,"CVRSHT")
SET PSBGOT1=1
End DoDot:4
End DoDot:3
+93 IF ('+PSBGOT1)&(PSBOSP'<PSBWBEG)
DO ADD^PSBVDLU1(PSBREC,PSBOTXT,PSBNOW\1_".",PSBDDS,PSBSOLS,PSBADDS,"CVRSHT")
SET PSBGOT1=1
+94 IF ('+PSBGOT1)&($DATA(PSBADMX(PSBONX)))
DO ADD^PSBVDLU1(PSBREC,PSBOTXT,PSBNOW\1_".",PSBDDS,PSBSOLS,PSBADDS,"CVRSHT")
+95 SET PSBGLBX=$ORDER(^TMP("PSB",$JOB,PSBTAB,""),-1)
IF ^TMP("PSB",$JOB,PSBTAB,PSBGLBX)'="END"
SET ^TMP("PSB",$JOB,PSBTAB,PSBGLBX+1)="END"
End DoDot:2
SET ($PIECE(PSBREC,U,12),$PIECE(PSBREC,U,14))=""
QUIT
+96 ;cont - proces AdmnTm
+97 SET (PSBYES,PSBODD,PSBYTF)=0
IF $$PSBDCHK1^PSBVT1(PSBSCH)
SET PSBYES=1
+98 IF PSBYES
IF PSBADST=""
QUIT
+99 FOR I=1:1
IF $PIECE(PSBSCH,"-",I)=""
QUIT
IF $PIECE(PSBSCH,"-",I)?2N!($PIECE(PSBSCH,"-",I)?4N)
SET PSBYES=1
SET PSBYTF=1
+100 IF PSBSCHT="C"
IF PSBYTF="1"
IF PSBADST=""
QUIT
+101 SET PSBFREQ=$$GETFREQ^PSBVDLU1(DFN,PSBONX)
+102 IF PSBFREQ="O"
SET PSBFREQ=1440
+103 IF PSBFREQ="D"
SET PSBFREQ=""
+104 IF PSBLVIV
SET PSBYES=1
+105 IF 'PSBYES
IF PSBFREQ<1
QUIT
+106 IF (PSBADST="")&(+PSBFREQ>0)
DO ODDSCH^PSBVDLU1(PSBTAB)
QUIT
+107 IF +PSBFREQ>0
IF (PSBFREQ#1440'=0)
IF (1440#PSBFREQ'=0)
SET PSBODD=1
+108 IF PSBODD
IF PSBADST'=""
QUIT
+109 SET PSBDTX=PSBWBEG\1
SET PSBGOT1=0
+110 ;incrmnt 1 day!
FOR PSBXX=1:1:2
Begin DoDot:2
+111 FOR PSBY=1:1:$LENGTH(PSBADST,"-")
IF $PIECE(PSBADST,"-",PSBY)=""
QUIT
Begin DoDot:3
+112 SET PSB=+(PSBDTX_"."_$PIECE(PSBADST,"-",PSBY))
+113 ;wndow?
IF (PSB'<PSBWBEG)&(PSB'>PSBWEND)
Begin DoDot:4
+114 ;actv?
IF (PSB'<PSBOST)&(PSB<PSBOSP)
Begin DoDot:5
+115 ;dt?
IF $$OKAY^PSBVDLU1(PSBOST,PSB,PSBSCH,PSBONX,PSBOITX,PSBFREQ,PSBOSTS)
Begin DoDot:6
+116 DO ADD^PSBVDLU1(PSBREC,PSBOTXT,PSB,PSBDDS,PSBSOLS,PSBADDS,"CVRSHT")
SET PSBGOT1=1
End DoDot:6
End DoDot:5
End DoDot:4
+117 SET PSB=+(PSBWEND\1_"."_$PIECE(PSBADST,"-",PSBY))
+118 ;wndow?
IF (PSB'<PSBWBEG)&(PSB'>PSBWEND)
Begin DoDot:4
+119 ;actv?
IF (PSB'<PSBOST)&(PSB<PSBOSP)
Begin DoDot:5
+120 ;dt?
IF $$OKAY^PSBVDLU1(PSBOST,PSB,PSBSCH,PSBONX,PSBOITX,PSBFREQ,PSBOSTS)
Begin DoDot:6
+121 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)
+122 IF ('PSBGOT1)&(PSBOSP'<PSBWBEG)
DO ADD^PSBVDLU1(PSBREC,PSBOTXT,+(PSBWEND\1_"."_$PIECE(PSBADST,"-")),PSBDDS,PSBSOLS,PSBADDS,"CVRSHT")
+123 KILL PSBSTUS
End DoDot:1
+124 DO EN^PSBVDLPA
+125 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"
+126 SET ^TMP("PSB",$JOB,PSBTAB,0)=$ORDER(^TMP("PSB",$JOB,PSBTAB,""),-1)
+127 IF $GET(^TMP("PSB",$JOB,PSBTAB,2))']""
SET $PIECE(^TMP("PSB",$JOB,PSBTAB,1),U,4)="-1^No orders To display on Coversheet"
+128 IF $GET(^TMP("PSB",$JOB,PSBTAB,2))]""
SET $PIECE(^TMP("PSB",$JOB,PSBTAB,1),U,4)="1^COVERSHEET DATA FOLLOWS"
DO ADD^PSBCSUTX
+129 DO CLEAN
+130 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
+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"
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 IF PSBTMDF>=-($SELECT($GET(DILOCKTM)>0:DILOCKTM,1:3))
IF PSBTMDF<=$SELECT($GET(DILOCKTM)>0:DILOCKTM,1:3)
Begin DoDot:6
+23 IF $PIECE(^TMP("PSBGMV",$JOB,PSBGMR),U,9)=1
SET PSBPNSC=$PIECE(^TMP("PSBGMV",$JOB,PSBGMR),U,8)
SET PSBERFL=""
End DoDot:6
End DoDot:5
End DoDot:4
End DoDot:3
+24 IF $DATA(PSBERFL)
IF '$DATA(PSBCMFL)
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 COMMENT^PSBML(PSBIEN,PSBCOMMENT)
+25 KILL PSBCMFL,PSBERFL
+26 SET PSBEFTM=$PIECE($GET(^PSB(53.79,PSBIEN,.2)),U,4)
IF PSBEFTM=""
QUIT
+27 SET PSBBDT=$EXTRACT(PSBEFTM,1,12)
+28 SET PSBEXTM=$$FMTE^XLFDT(PSBBDT,"5Z")
+29 IF '$DATA(^TMP("PSBGMV",$JOB))
DO EN1^GMVDCEXT("^TMP(""PSBGMV"",$J)",DFN,2,,1,PSBSTRTDT,PSBEDT,,1)
+30 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
+31 SET PSBVITM=$PIECE(^TMP("PSBGMV",$JOB,PSBGMR),U,5)
+32 SET PSBTMDF=$$FMDIFF^XLFDT(PSBVITM,PSBEFTM,2)
+33 IF PSBTMDF>=-($SELECT($GET(DILOCKTM)>0:DILOCKTM,1:3))
IF PSBTMDF<=$SELECT($GET(DILOCKTM)>0:DILOCKTM,1:3)
Begin DoDot:4
+34 IF $PIECE(^TMP("PSBGMV",$JOB,PSBGMR),U,9)=1
SET PSBPNSC=$PIECE(^TMP("PSBGMV",$JOB,PSBGMR),U,8)
SET PSBERFL=""
End DoDot:4
End DoDot:3
+35 IF $DATA(PSBERFL)
IF '$DATA(PSBEFFL)
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 COMMENT^PSBML(PSBIEN,PSBCOMMENT)
+36 KILL PSBERFL,PSBEFFL
End DoDot:2
End DoDot:1
+37 KILL ^TMP("PSBGMV",$JOB)
+38 QUIT
LIGHTS(PSBDFN) ;
+1 DO RPC^PSBVDLTB(,PSBDFN,"NO TAB",)
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 QUIT
