PSBCSUTL.m

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)