- 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 Feb 18, 2025@23:06:24 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