Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: PSBOMM2

PSBOMM2.m

Go to the documentation of this file.
  1. PSBOMM2 ;BIRMINGHAM/EFC-MISSED MEDS ;2/6/21 17:43
  1. ;;3.0;BAR CODE MED ADMIN;**26,32,51,62,74,88,106**;Mar 2004;Build 43
  1. ;Per VA Directive 6402, this routine should not be modified.
  1. ;
  1. ;*106 move Clinic report code from psbomm to here due to routine size was exceeded in psbomm
  1. ;
  1. MISSED(PSBADMN,PSBEDIT,PSBXDT) ;
  1. N PSBMISD,PSBAUDT,PSBSTRT2
  1. S PSBSTRT2=(PSBXDT\1) F D Q:PSBODD S PSBSTRT2=$$FMADD^XLFDT(PSBSTRT2,1) Q:PSBSTRT2>PSBSTOP
  1. .F Y=1:1:$L(PSBADMN,"-") S PSBDT=+("."_$P(PSBADMN,"-",Y))+(PSBSTRT2) D
  1. ..S PSBMISD=$$CHECK(PSBDT)
  1. ..;Check Audited Admin Times for Missed Med
  1. ..I PSBMISD F I=1:1:$P(PSBOACTL(0),U,4) I $P($G(PSBOACTL(I,1)),U,3)["ADMIN TIMES" D Q:'PSBMISD
  1. ...Q:$P(PSBOACTL(I,1),U)<PSBSTRT2
  1. ...;Q:$P(PSBOACTL(I,1),U)>((PSBSTOP\1)+.2400) - remove ending date check, all audits should affect report, PSB*3*88
  1. ...Q:$P(PSBOACTL(I,1),U)<PSBDT
  1. ...S PSBAUDT=+("."_$P(PSBOACTL(I,2),"-",Y))+(PSBSTRT2\1)
  1. ...S PSBMISD=$$CHECK(PSBAUDT),PSBEDIT=1
  1. ..I PSBMISD D
  1. ...Q:'$$OKAY^PSBVDLU1(PSBOST,PSBSTRT2,PSBSCH,PSBONX,$P(^TMP("PSJ",$J,PSBX,3),U,2),PSBFREQ,PSBOSTS)
  1. ...S:'$D(^TMP("PSB",$J,DFN,PSBDT,"* "_PSBOITX,PSBONX)) ^TMP("PSB",$J,DFN,PSBDT,PSBOITX,PSBONX)=""
  1. ...D UDCONT
  1. Q
  1. CHECK(PSBDT) ;
  1. I PSBDT<PSBOST Q 0 ; Order Start Date
  1. I PSBDT'<PSBOSP Q 0 ; Order Stop Date
  1. I PSBDT<PSBSTRT Q 0 ; Report Window
  1. I PSBDT>PSBSTOP Q 0 ; Report Window
  1. I $D(^PSB(53.79,"AORD",DFN,PSBONX,PSBDT)) D Q:PSBSTUS'="N" $G(PART,0)
  1. .K PART S PSBIX=$O(^PSB(53.79,"AORD",DFN,PSBONX,PSBDT,"")),PSBSTUS=$P(^PSB(53.79,PSBIX,0),U,9)
  1. .I PSBOCRIT[PSBOSTS D:(PSBACRIT[PSBSTUS) Q
  1. ..I (PSBSTUS="G")&$D(^PSB(53.79,PSBIX,.5)) D
  1. ...S X=0 F S X=$O(^PSB(53.79,PSBIX,.5,X)) Q:+X=0 D
  1. ....I $P(^PSB(53.79,PSBIX,.5,X,0),U,2)>$P(^PSB(53.79,PSBIX,.5,X,0),U,3) D S PSBOITX=$E(PSBOITX,3,999)
  1. .....S PSBOITX="* "_PSBOITX S ^TMP("PSB",$J,DFN,PSBDT,PSBOITX,PSBONX,"X")="Units Ordered: "_$P(^PSB(53.79,PSBIX,.5,X,0),U,2)_" Units Given: "_$P(^PSB(53.79,PSBIX,.5,X,0),U,3)_" Admin. Status: * Partial (Given)"
  1. .....S PART=1
  1. .....D:PSBINCC GCMNTS(PSBIX)
  1. ..I PSBSTUS'="G" I PSBACRIT[PSBSTUS S PART=1 S ^TMP("PSB",$J,DFN,PSBDT,PSBOITX,PSBONX,"X")="Admin. Status: ("_$S(PSBSTUS="":" *UNKNOWN* ",PSBSTUS="M":"Missing Dose",PSBSTUS="H":"Held",PSBSTUS="R":"Refused")_")" D:PSBINCC GCMNTS(PSBIX)
  1. Q 1
  1. UDCONT ;
  1. S PSBFLAG=0,J=1
  1. K ^TMP("PSB1",$J)
  1. F I=1:1:$P(PSBOACTL(0),U,4) D
  1. . I $P($G(PSBOACTL(I,1)),U,4)["ON HOLD"!($P($G(PSBOACTL(I,1)),U,4)="HOLD") S ^TMP("PSB1",$J,DFN,J)="HOLD"_U_$E($P($G(PSBOACTL(I,1)),U,1),1,12)
  1. . I $P($G(PSBOACTL(I,1)),U,4)["TAKEN OFF HOLD"!($P($G(PSBOACTL(I,1)),U,4)["UNHOLD") S $P(^TMP("PSB1",$J,DFN,J),U,3)="OFF HOLD"_U_$E($P($G(PSBOACTL(I,1)),U,1),1,12),J=J+1
  1. D:$D(^TMP("PSB1",$J,DFN))&($P(PSBOACTL(0),U,4)'=1)
  1. .S J=0 F S J=$O(^TMP("PSB1",$J,DFN,J)) Q:'J Q:PSBFLAG D
  1. ..S PSBHDDT=$P(^TMP("PSB1",$J,DFN,J),U,2)
  1. ..S PSBHDST=$P(^TMP("PSB1",$J,DFN,J),U)
  1. ..S PSBOFDT=$P(^TMP("PSB1",$J,DFN,J),U,4)
  1. ..S PSBOFST=$P(^TMP("PSB1",$J,DFN,J),U,3)
  1. ..I PSBDT>PSBHDDT,PSBHDST="HOLD",PSBOFST'="" I PSBDT<PSBOFDT,PSBOFST="OFF HOLD" S PSBFLAG=2,PSBUNHD=PSBOFDT
  1. ..I PSBDT>PSBHDDT,PSBHDST="HOLD",PSBOFST="" S PSBFLAG=1
  1. K PSBCNT,TMP("PSB1",$J)
  1. S PSBOITX2=PSBOITX
  1. I $D(^TMP("PSB",$J,DFN,PSBDT,"* "_PSBOITX,PSBONX)) S PSBOITX="* "_PSBOITX
  1. I PSBFLAG=1 S ^TMP("PSB",$J,DFN,PSBDT,PSBOITX,PSBONX)="(On Hold) "_$$DTFMT(PSBHDDT)
  1. I PSBFLAG=2 S ^TMP("PSB",$J,DFN,PSBDT,PSBOITX,PSBONX)="(On Hold) "_$$DTFMT(PSBHDDT)_" "_"(Off Hold) "_$$DTFMT(PSBUNHD)
  1. S PSBOITX=PSBOITX2
  1. Q
  1. ;
  1. UDONE ;
  1. S PSBFLAG=0,J=1
  1. F I=1:1:$P(PSBOACTL(0),U,4) D
  1. .I $P($G(PSBOACTL(I,1)),U,4)["ON HOLD"!($P($G(PSBOACTL(I,1)),U,4)="HOLD") S ^TMP("PSB1",$J,DFN,J)="HOLD"_U_$E($P($G(PSBOACTL(I,1)),U,1),1,12)
  1. .I $P($G(PSBOACTL(I,1)),U,4)["TAKEN OFF HOLD"!($P($G(PSBOACTL(I,1)),U,4)["UNHOLD") S $P(^TMP("PSB1",$J,DFN,J),U,3)="OFF HOLD"_U_$E($P($G(PSBOACTL(I,1)),U,1),1,12),J=J+1
  1. D:$D(^TMP("PSB1",$J,DFN))&($P(PSBOACTL(0),U,4)'=1)
  1. .S J="" F S J=$O(^TMP("PSB1",$J,DFN,J)) Q:'J Q:PSBFLAG D
  1. ..S PSBHDDT=$P(^TMP("PSB1",$J,DFN,J),U,2)
  1. ..S PSBHDST=$P(^TMP("PSB1",$J,DFN,J),U)
  1. ..S PSBOFDT=$P(^TMP("PSB1",$J,DFN,J),U,4)
  1. ..S PSBOFST=$P(^TMP("PSB1",$J,DFN,J),U,3)
  1. ..I PSBOSTS="A",PSBHDST="HOLD",PSBOFST'="",'$D(^TMP("PSB1",$J,DFN,J+1)) I PSBSTOP>PSBOFDT,PSBOFST="OFF HOLD" S PSBFLAG=2,PSBUNHD=PSBOFDT
  1. ..I PSBOSTS="A",PSBHDST="HOLD",PSBOFST'="",PSBOFDT'<PSBSTOP S PSBFLAG=1
  1. ..I PSBOSTS="H",PSBHDST="HOLD",'$D(^TMP("PSB1",$J,DFN,J+1)) S PSBFLAG=1
  1. K PSBCNT,^TMP("PSB1",$J)
  1. S PSBOITX2=PSBOITX
  1. I $D(^TMP("PSB",$J,DFN,PSBDT,"* "_PSBOITX,PSBONX)) S PSBOITX="* "_PSBOITX
  1. I PSBFLAG=1 S ^TMP("PSB",$J,DFN,PSBDT,PSBOITX,PSBONX)="(On Hold) "_$$DTFMT(PSBHDDT)
  1. I PSBFLAG=2 S ^TMP("PSB",$J,DFN,PSBDT,PSBOITX,PSBONX)="(On Hold) "_$$DTFMT(PSBHDDT)_" "_"(Off Hold) "_$$DTFMT(PSBUNHD)
  1. S PSBOITX=PSBOITX2
  1. Q
  1. GCMNTS(XIEN) ;
  1. Q:'$D(^PSB(53.79,XIEN,.3,1))
  1. N X
  1. S X=$O(^PSB(53.79,XIEN,.3,""),-1) Q:+X=0 S ^TMP("PSB",$J,DFN,PSBDT,PSBOITX,PSBONX,.3)="Comment: "_$P(^PSB(53.79,XIEN,.3,X,0),U)
  1. Q
  1. PARTG1(XIEN) ;
  1. I $D(^PSB(53.79,XIEN)) D
  1. .S PSBSTUS=$P(^PSB(53.79,XIEN,0),U,9)
  1. .I PSBOCRIT[PSBOSTS I PSBACRIT[PSBSTUS D S PSBEXST=1 Q
  1. ..I (PSBSTUS="G")&$D(^PSB(53.79,XIEN,.5)) D
  1. ...S X=0 F S X=$O(^PSB(53.79,XIEN,.5,X)) Q:+X=0 D
  1. ....I $P(^PSB(53.79,XIEN,.5,X,0),U,2)>$P(^PSB(53.79,XIEN,.5,X,0),U,3) D S PSBOITX=$E(PSBOITX,3,999),PSBGVN=0
  1. .....S PSBOITX="* "_PSBOITX S ^TMP("PSB",$J,DFN,PSBDT,PSBOITX,PSBONX,"X")="Units Ordered: "_$P(^PSB(53.79,XIEN,.5,X,0),U,2)_" Units Given: "_$P(^PSB(53.79,XIEN,.5,X,0),U,3)_" Admin. Status: * Partial (Given)"
  1. .....I PSBINCC D GCMNTS(XIEN)
  1. ..I PSBSTUS'="G" D S PSBGVN=0
  1. ...I PSBACRIT[PSBSTUS S ^TMP("PSB",$J,DFN,PSBDT,PSBOITX,PSBONX,"X")="Admin. Status: ("_$S(PSBSTUS="":" *UNKNOWN* ",PSBSTUS="M":"Missing Dose",PSBSTUS="H":"Held",PSBSTUS="R":"Refused")_")"
  1. ...I PSBINCC D GCMNTS(XIEN)
  1. Q
  1. LN1 ;
  1. W !,$TR($J("",IOM)," ","-")
  1. Q
  1. DEFLT ;
  1. S PSBFUTR=$TR(PSBRPT(1),"~","^")
  1. Q:PSBRPT(1)]""
  1. S PSBFUTR="^^^^1^^1^1^^^^^^^^1^1^1" ;default MM Report settings Per GUI MM report...
  1. S X01=""
  1. D RPC^PSBPAR(.X01,"GETPAR","ALL","PSB RPT INCL COMMENTS")
  1. S $P(PSBRPT(.2),U,8)=+X01(0)
  1. K PSBSTOP S PSBSTOP=$P(PSBRPT(.1),U,6)+$P(PSBRPT(.1),U,9)
  1. Q
  1. DTFMT(DT) ;
  1. N Y,X
  1. I +DT'>0 S DTFMT=DT Q DTFMT
  1. S Y=DT,X=$E($P(Y,".",2)_"0000",1,4)
  1. S DTFMT=$TR($J(+$E(Y,4,5),2)_"/"_$J(+$E(Y,6,7),2)_"/"_($E(Y,1,3)+1700)," ","0")_"@"_X
  1. Q DTFMT
  1. ;
  1. CLINIC ;Clinic report *106
  1. W $$CLNHDR()
  1. I '$O(^TMP("PSB",$J,0)) W !,"No Missed Medications Found" Q
  1. S PSBSORT=$P(PSBRPT(.1),U,5)
  1. F DFN=0:0 S DFN=$O(^TMP("PSB",$J,DFN)) Q:'DFN D
  1. .S PSBDX=$S(PSBSORT="P":$P(^DPT(DFN,0),U),1:$G(^DPT(DFN,.1))_" "_$G(^(.101)))
  1. .S:PSBDX="" PSBDX=$P(^DPT(DFN,0),U)
  1. .S ^TMP("PSB",$J,"B",PSBDX,DFN)=""
  1. S PSBDX=""
  1. F S PSBDX=$O(^TMP("PSB",$J,"B",PSBDX)) Q:PSBDX="" D
  1. .F DFN=0:0 S DFN=$O(^TMP("PSB",$J,"B",PSBDX,DFN)) Q:'DFN D
  1. ..W !
  1. ..S PSBDT=""
  1. ..F S PSBDT=$O(^TMP("PSB",$J,DFN,PSBDT)) Q:PSBDT="" D
  1. ...W !
  1. ...K VAR1,VAR2,VAR3 ;reset held/refused to prevent line feed
  1. ...W:PSBDT["ONE-TIME" !
  1. ...S PSBOITX=""
  1. ...F S PSBOITX=$O(^TMP("PSB",$J,DFN,PSBDT,PSBOITX)) Q:PSBOITX="" D
  1. ....S PSBONX=""
  1. ....F S PSBONX=$O(^TMP("PSB",$J,DFN,PSBDT,PSBOITX,PSBONX)) Q:PSBONX="" D
  1. .....;if previously held/refused lines printed, need line feed *58
  1. .....I ($G(VAR1)]"")!($G(VAR2)]"")!($G(VAR3)]"") W:'$G(RMV) ! K RMV
  1. .....K VAR1,VAR2,VAR3,SP I $Y>(IOSL-9) W $$CLNHDR()
  1. .....D PSJ1^PSBVT(DFN,PSBONX)
  1. .....S PSBVNI=$S(PSBVNI]"":PSBVNI,1:"***")
  1. .....; print remove line 1st *83
  1. .....S RMV=0
  1. .....D:$D(^TMP("PSB",$J,DFN,PSBDT,PSBOITX,PSBONX,"RM"))
  1. ......W !,$O(PSBS(DFN,PSBONX,"")),?11,PSBVNI,?17,$P(^DPT(DFN,0),U)
  1. ......W ?49,$S(+PSBDT>0:$$DTFMT^PSBOMM2(PSBDT),1:PSBDT),?66,PSBOITX
  1. ......W ?103,PSBCLORD
  1. ......W !,?69,"(Remove)" S RMV=1
  1. .....;print Give if exists for a RM just printed, or no RM printed
  1. .....I 'RMV!(RMV&$D(^TMP("PSB",$J,DFN,PSBDT,PSBOITX,PSBONX))=11) D
  1. ......W !,$O(PSBS(DFN,PSBONX,"")),?11,PSBVNI,?17,$P(^DPT(DFN,0),U)
  1. ......W:PSBDT'["ONE-TIME" ?49,$S(+PSBDT>0:$$DTFMT^PSBOMM2(PSBDT),1:PSBDT),?66,PSBOITX
  1. ......W:PSBDT'["ONE-TIME" ?103,PSBCLORD
  1. .....;*106 adds the hazardous handle/dispose notices
  1. .....I (PSBHAZDS=1)!(PSBHAZHN=1) W !
  1. .....I PSBHAZHN=1 W ?92,"<<HAZ HANDLE>> " ;*106 hazhn
  1. .....I PSBHAZDS=1 W ?92,"<<HAZ DISPOSE>>" ;*106 hazds, if hazhn printed 1st, then this will print after that and not at 92, desired.
  1. .....S VAR1=$G(^TMP("PSB",$J,DFN,PSBDT,PSBOITX,PSBONX))
  1. .....S VAR2=$G(^TMP("PSB",$J,DFN,PSBDT,PSBOITX,PSBONX,"X"))
  1. .....S VAR3=$G(^TMP("PSB",$J,DFN,PSBDT,PSBOITX,PSBONX,.3))
  1. .....I PSBDT["ONE-TIME" D Q
  1. ......W !,PSBDT,?37,PSBOITX S SP=1 W:PSBCLINORD ?103,PSBCLORD
  1. ......I VAR1]"" W !,?37,$P(VAR1,U,1) S SP=1
  1. ......I VAR2]"" W:$G(SP) ! W ?37,VAR2
  1. ......I VAR3]"" W !,$$WRAP^PSBO(37,102,VAR3)
  1. ......W !?3,"Start Date/Time: ",?21,$O(PSBSTXT(PSBONX,DFN,"")) ;DFN added to PSBSTXT array in PSB*3*52
  1. ......W !?3,"Stop Date/Time: ",?21,$O(PSBSTXP(PSBONX,DFN,"")) ;DFN added to PSBSTXP array in PSB*3*52
  1. ......W !
  1. .....;detail line additional info
  1. .....S SP=1
  1. .....I VAR1]"" W !,?57,VAR1 S SP=1
  1. .....I VAR2]"" W:$G(SP) ! W ?57,VAR2
  1. .....I VAR3]"" W !,$$WRAP^PSBO(57,82,VAR3)
  1. Q
  1. ;
  1. CLNHDR() ; *106
  1. D CLINIC^PSBOHDR(.PSBRPT,.PSBHDR,,,PSBSRCHL)
  1. W !,"Order Sts",?11,"Ver",?17,"Patient",?49,"Missed Date/Time",?66,"Medication",?103,"Location"
  1. D LN1^PSBOMM2
  1. Q ""