source: FOIAVistA/trunk/r/BAR_CODE_MED_ADMIN-ALPB-PSB/PSBOMM.m@ 1800

PSBOMM ;BIRMINGHAM/EFC-MISSED MEDS ;Mar 2004
 ;;3.0;BAR CODE MED ADMIN;**26,32**;Mar 2004;Build 32
 ;Per VHA Directive 2004-038 (or future revisions regarding same), this routine should not be modified.
 ;
 ; Reference/IA
 ; ^DPT/10035
 ; EN^PSJBCMA/2828
 ; EN^PSJBCMA2/2830
EN ;
 N PSBSTRT,PSBSTOP,DFN,PSBODATE,PSBFLAG,PSBCNT,PSBEDIT,PSBFUTR
 S PSBSTART=$P(PSBRPT(.1),U,6)+$P(PSBRPT(.1),U,7),PSBSTOP=$P(PSBRPT(.1),U,8)+$P(PSBRPT(.1),U,9)
 D DEFLT^PSBOMM2
 K PSBOCRIT,PSBACRIT,PSBS
 S PSBOCRIT="^A^H"
 S:$P(PSBFUTR,U,8) PSBOCRIT=PSBOCRIT_"^D^DE" S:$P(PSBFUTR,U,7) PSBOCRIT=PSBOCRIT_"^E"
 S PSBACRIT="MG"
 S:$P(PSBFUTR,U,17) PSBACRIT=PSBACRIT_"H" S:$P(PSBFUTR,U,18) PSBACRIT=PSBACRIT_"R"
 S PSBINCC=0 S:$P(PSBRPT(.2),U,8) PSBINCC=1
 K ^TMP("PSJ",$J),^TMP("PSB",$J),^TMP("PSB1",$J)
 S PSBSTRT=$P(PSBRPT(.1),U,6)+$P(PSBRPT(.1),U,7)-.0000001
 F DFN=0:0 S DFN=$O(^TMP("PSBO",$J,DFN)) Q:'DFN  D EN1
 D PRINT
 K ^TMP("PSJ",$J),^TMP("PSB",$J),^TMP("PSBO",$J),PSBS
 Q
EN1 ;
 N PSBGBL,PSBHDR,PSBX,PSBDFN,PSBDT,PSBEVDT,PSBH
 K ^TMP("PSJ",$J) S PSBEVDT=PSBSTRT
 D EN^PSJBCMA(DFN,PSBSTRT)
 Q:^TMP("PSJ",$J,1,0)=-1
 S PSBX=""
 F  S PSBX=$O(^TMP("PSJ",$J,PSBX)) Q:PSBX=""  D
 .Q:^TMP("PSJ",$J,PSBX,0)=-1
 .D NOW^%DTC
 .D CLEAN^PSBVT
 .D PSJ^PSBVT(PSBX)
 .Q:PSBIVT="A"
 .Q:PSBIVT="H"
 .I PSBIVT["S",PSBISYR'=1 Q
 .I PSBIVT["C",PSBCHEMT'="P",PSBISYR'=1 Q
 .I PSBIVT["C",PSBCHEMT="A" Q
 .Q:PSBONX["P"
 .Q:PSBOSP<PSBSTART
 .I %>PSBOSP,PSBOSTS'="D",PSBOSTS'="DE",PSBOSTS'="H" S PSBOSTS="E"
 .I PSBSCHT="C" D  Q
 ..S (PSBYES,PSBODD)=0
 ..S PSBDOW="SU^MO^TU^WE^TH^FR^SA" F I=1:1:7 I $P(PSBDOW,"^",I)=$E(PSBSCH,1,2) S 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
 ..S PSBFREQ=$$GETFREQ^PSBVDLU1(DFN,PSBONX)
 ..I PSBFREQ="O" S PSBYES=1,PSBFREQ=1440
 ..I 'PSBYES,PSBADST="",PSBFREQ<1 Q
 ..I (PSBFREQ#1440'=0),(1440#PSBFREQ'=0) S PSBODD=1
 ..I PSBODD,PSBADST'="" Q
 ..Q:PSBOCRIT'[PSBOSTS
 ..Q:PSBNGF
 ..Q:PSBOSTS="N"
 ..Q:PSBSM
 ..S PSBS(DFN,PSBONX,$S(PSBOSTS="A":"Active",PSBOSTS="H":"On Hold",PSBOSTS="D":"DC'd",PSBOSTS="DE":"DC'd (Edit)",PSBOSTS="E":"Expired",1:" *Unknown* "))=""
 ..S PSBSTXP(PSBONX,$$DTFMT^PSBOMM2(PSBOSP))=""
 ..S PSBCADM=0
 ..I PSBADST="" D  Q:$G(PSBADST)=""  S PSBCADM=1
 ...S X=PSBOST D H^%DTC S X1=((%H*24)*60)+(%T/60)
 ...S X=PSBSTRT,X3=0 D H^%DTC S X2=((%H*24)*60)+(%T/60)
 ...I X2'<X1 S X3=X2-X1 S PSBOST=$$FMADD^XLFDT(PSBSTRT,,,(-1*(X3#PSBFREQ)))
 ...K PSBADST S PSBOST2=PSBOST,PSBDT2=PSBSTRT
 ...F XZ=0:1 S PSBADST(XZ,PSBDT2)=$$GETADMIN^PSBVDLU1(DFN,PSBONX,PSBOST2,PSBFREQ,PSBDT2) D  Q:PSBDT2>PSBSTOP
 ....I ($L(PSBADST(XZ,PSBDT2),"-")>$L($G(PSBADST),"-"))!($G(PSBADST)="") S PSBADST=PSBADST(XZ,PSBDT2)
 ....S Z=PSBDT2\1,J=$P(PSBADST(XZ,PSBDT2),"-",($L(PSBADST(XZ,PSBDT2),"-"))) S:J]"" PSBOST2=Z_"."_J
 ....S PSBDT2=($$FMADD^XLFDT(Z,1))+.2400
 ....S PSBDT2=$S($G(FLG):(PSBSTOP\1)+.2401,PSBDT2>PSBOSP:PSBOSP,1:PSBDT2) K FLG I PSBDT2=PSBOSP S FLG=1
 ..S Z=PSBADST I Z]"" K ^TMP("PSB",$J,"GETADMIN") S ^TMP("PSB",$J,"GETADMIN",0)=Z
 ..F Y=1:1:$L(Z,"-") D
 ...Q:($P(Z,"-",Y)'?2N)&($P(Z,"-",Y)'?4N)
 ..K PSBOACTL,^TMP("PSB1",$J) D EN^PSJBCMA2(DFN,PSBONX,1) I ^TMP("PSJ2",$J,0)'=1 M PSBOACTL=^TMP("PSJ2",$J) K ^TMP("PSJ2",$J)
 ..I 'PSBODD F XX=0:1 Q:'$D(^TMP("PSB",$J,"GETADMIN",XX))  S (PSBADST,Z)=$G(^TMP("PSB",$J,"GETADMIN",XX)) D
 ...D MISSED^PSBOMM2(Z,.PSBEDIT,PSBSTRT)
 ..I PSBODD F XX=0:1 Q:'$D(PSBADST(XX))  S XXX=$O(PSBADST(XX,"")) S (PSBADST,Z)=PSBADST(XX,XXX) D
 ...I Z]"" D MISSED^PSBOMM2(Z,.PSBEDIT,XXX)
 .K PSBHDDT,PSBUNHD,^TMP("PSB1",$J)
 .I PSBSCHT="O" D  Q
 ..Q:PSBOSTS="N"
 ..Q:PSBNGF
 ..Q:PSBSM
 ..Q:(PSBOSP=PSBOST)&(PSBOCRIT'["E")
 ..Q:PSBOST'<PSBSTOP
 ..S PSBDT="*** ONE-TIME ***"
 ..S (PSBSTXP(PSBONX,$$DTFMT^PSBOMM2(PSBOSP)),PSBSTXT(PSBONX,$$DTFMT^PSBOMM2(PSBOST)))=""
 ..S (PSBG,X,Y,PSBXSTS)="" K PSBEXST
 ..F  S X=$O(^PSB(53.79,"AOIP",DFN,PSBOIT,X),-1) Q:'X  D
 ...F  S Y=$O(^PSB(53.79,"AOIP",DFN,PSBOIT,X,Y),-1) Q:'Y  D
 ....S PSBXSTS=$P(^PSB(53.79,Y,0),U,9)
 ....I $P(^PSB(53.79,Y,.1),U)=PSBONX,PSBXSTS'="N",PSBXSTS'="M" S PSBG=1,PSBG(PSBONX,Y)="",(X,Y)=0
 ..I PSBG D PARTG1^PSBOMM2($O(PSBG(PSBONX,"")))
 ..D NOW^%DTC
 ..Q:(PSBOCRIT'[PSBOSTS)
 ..S PSBS(DFN,PSBONX,$S(PSBOSTS="A":"Active",PSBOSTS="H":"On Hold",PSBOSTS="D":"DC'd",PSBOSTS="DE":"DC'd (Edit)",PSBOSTS="E":"Expired",1:" * ERROR * "))=""
 ..D:'PSBG!(PSBACRIT[$G(PSBXSTS,1))
 ...S VAR=""
 ...K ^TMP("PSJ2",$J),^TMP("PSB1",$J),PSBOACTL D EN^PSJBCMA2(DFN,PSBONX,1) I ^TMP("PSJ2",$J,0)'=1 D
 ....M PSBOACTL=^TMP("PSJ2",$J)
 ....D UDONE^PSBOMM2
 ....I PSBFLAG=1 S VAR="(On Hold) "_$$DTFMT^PSBOMM2(PSBHDDT)
 ....I PSBFLAG=2 S VAR="(On Hold) "_$$DTFMT^PSBOMM2(PSBHDDT)_"  (Off Hold) "_$$DTFMT^PSBOMM2(PSBUNHD)
 ...I '$G(PSBEXST,0)!(PSBXSTS="M") S $P(^TMP("PSB",$J,DFN,"*** ONE-TIME ***",PSBOITX,PSBONX),U,1,4)=VAR
 ...I $G(PSBEXST,0) D
 ....S VAR1=$G(^TMP("PSB",$J,DFN,"*** ONE-TIME ***","* "_PSBOITX,PSBONX)) I VAR1]"" S $P(VAR1,U,1,4)=VAR_VAR1
 ...K PSBHDDT,PSBUNHD,^TMP("PSB1",$J),PSBCNT
 K PSBOACTL
 Q
PRINT ;
 N PSBHDR,PSBDT,PSBOITX,PSBONX,DFN
 K PSBNPG
 S Y=$S($P(PSBRPT(.1),U,8)]"":$P(PSBRPT(.1),U,8),1:$P(PSBRPT(.1),U,6))
 D:$P(PSBRPT(.1),U,1)="P"
 .S PSBHDR(1)="MISSED MEDICATIONS REPORT for "_$$FMTE^XLFDT($P(PSBRPT(.1),U,6)+$P(PSBRPT(.1),U,7))_" to "_$$FMTE^XLFDT(Y+$P(PSBRPT(.1),U,9))
 .S PSBHDR(2)="Order Status(es): --"
 .F Y=5,8,7 I $P(PSBFUTR,U,Y) S $P(PSBHDR(2),": ",2)=$P(PSBHDR(2),": ",2)_$S(PSBHDR(2)["--":"",1:"/ ")_$P("^^^^Active^^Expired^DC'd^^^^^^^^^^",U,Y)_" " S PSBHDR(2)=$TR(PSBHDR(2),"-","")
 .S PSBHDR(3)="Admin Status(es): --"
 .F Y=16,17,18 I $P(PSBFUTR,U,Y) S $P(PSBHDR(3),": ",2)=$P(PSBHDR(3),": ",2)_$S(PSBHDR(3)["--":"",1:"/ ")_$P("^^^^^^^^^^^^^^^Missing Dose^Held^Refused",U,Y)_" " S PSBHDR(3)=$TR(PSBHDR(3),"-","")
 .I PSBINCC S PSBHDR(4)="Include Comments/Reasons"
 .S DFN=$P(PSBRPT(.1),U,2)
 .W $$PTHDR()
 .I $G(PSBEDIT) W !?7,"*Administration Times have been edited*"
 .I $O(^TMP("PSB",$J,DFN,""))="" W !,"No Missed Medications Found",$$PTFTR^PSBOHDR() Q
 .S PSBDT=""
 .F  S PSBDT=$O(^TMP("PSB",$J,DFN,PSBDT)) Q:PSBDT=""  D
 ..W !
 ..S PSBOITX=""
 ..F  S PSBOITX=$O(^TMP("PSB",$J,DFN,PSBDT,PSBOITX)) Q:PSBOITX=""  D
 ...S PSBONX=""
 ...F  S PSBONX=$O(^TMP("PSB",$J,DFN,PSBDT,PSBOITX,PSBONX)) Q:PSBONX=""  D
 ....K VAR1,VAR2,VAR3,SP I $Y>(IOSL-9) W $$PTFTR^PSBOHDR(),$$PTHDR()
 ....S VAR1=$G(^TMP("PSB",$J,DFN,PSBDT,PSBOITX,PSBONX))
 ....S VAR2=$G(^TMP("PSB",$J,DFN,PSBDT,PSBOITX,PSBONX,"X"))
 ....S VAR3=$G(^TMP("PSB",$J,DFN,PSBDT,PSBOITX,PSBONX,.3))
 ....I PSBDT["ONE-TIME" D  Q
 .....W !
 .....W !,$O(PSBS(DFN,PSBONX,"")),?15,PSBDT,?43,PSBOITX,!
 .....I VAR1]"" W ?43,VAR1 S SP=1
 .....I VAR2]"" W:$G(SP) ! W ?43,VAR2
 .....I VAR3]"" W !,$$WRAP^PSBO(43,80,VAR3)
 .....W !,"Start Date/Time:  ",?18,$O(PSBSTXT(PSBONX,""))
 .....W !,"Stop Date/Time:  ",?18,$O(PSBSTXP(PSBONX,""))
 ....W !,$O(PSBS(DFN,PSBONX,"")),?15,$S(+PSBDT>0:$$DTFMT^PSBOMM2(PSBDT),1:PSBDT),?43,PSBOITX,?95,$O(PSBSTXP(PSBONX,"")),!
 ....I VAR1]"" W ?43,VAR1 S SP=1
 ....I VAR2]"" W:$G(SP) ! W ?43,VAR2
 ....I VAR3]"" W !,$$WRAP^PSBO(43,80,VAR3)
 .W $$PTFTR^PSBOHDR()
 .Q
 D:$P(PSBRPT(.1),U,1)="W"
 .S PSBHDR(1)="MISSED MEDICATIONS REPORT for "_$$FMTE^XLFDT($P(PSBRPT(.1),U,6)+$P(PSBRPT(.1),U,7))_" to "_$$FMTE^XLFDT(Y+$P(PSBRPT(.1),U,9))
 .S PSBHDR(2)="Order Status(es): --"
 .F Y=5,7,8 I $P(PSBFUTR,U,Y) S $P(PSBHDR(2),": ",2)=$P(PSBHDR(2),": ",2)_$S(PSBHDR(2)["--":"",1:"/ ")_$P("^^^^Active^^Expired^DC'd^^^^^^^^^^",U,Y)_" " S PSBHDR(2)=$TR(PSBHDR(2),"-","")
 .S PSBHDR(3)="Admin Status(es): --"
 .F Y=16,17,18 I $P(PSBFUTR,U,Y) S $P(PSBHDR(3),": ",2)=$P(PSBHDR(3),": ",2)_$S(PSBHDR(3)["--":"",1:"/ ")_$P("^^^^^^^^^^^^^^^Missing Dose^Held^Refused",U,Y)_" " S PSBHDR(3)=$TR(PSBHDR(3),"-","")
 .I PSBINCC S PSBHDR(4)="Include Comments/Reasons"
 .S PSBWARD=$P(PSBRPT(.1),U,3)
 .W $$WRDHDR()
 .I '$O(^TMP("PSB",$J,0)) W !,"No Missed Medications Found" Q
 .S PSBSORT=$P(PSBRPT(.1),U,5)
 .F DFN=0:0 S DFN=$O(^TMP("PSB",$J,DFN)) Q:'DFN  D
 ..S PSBDX=$S(PSBSORT="P":$P(^DPT(DFN,0),U),1:$G(^DPT(DFN,.1))_" "_$G(^(.101)))
 ..S:PSBDX="" PSBDX=$P(^DPT(DFN,0),U)
 ..S ^TMP("PSB",$J,"B",PSBDX,DFN)=""
 .S PSBDX=""
 .F  S PSBDX=$O(^TMP("PSB",$J,"B",PSBDX)) Q:PSBDX=""  D
 ..F DFN=0:0 S DFN=$O(^TMP("PSB",$J,"B",PSBDX,DFN)) Q:'DFN  D
 ...W !
 ...S PSBDT=""
 ...F  S PSBDT=$O(^TMP("PSB",$J,DFN,PSBDT)) Q:PSBDT=""  D
 ....W !
 ....W:PSBDT["ONE-TIME" !
 ....S PSBOITX=""
 ....F  S PSBOITX=$O(^TMP("PSB",$J,DFN,PSBDT,PSBOITX)) Q:PSBOITX=""  D
 .....S PSBONX=""
 .....F  S PSBONX=$O(^TMP("PSB",$J,DFN,PSBDT,PSBOITX,PSBONX)) Q:PSBONX=""  D
 ......K VAR1,VAR2,VAR3,SP I $Y>(IOSL-9) W $$WRDHDR()
 ......W !,$O(PSBS(DFN,PSBONX,"")),?15,$G(^DPT(DFN,.101),"**"),?35,$P(^DPT(DFN,0),U)," (",$E($P(^(0),U,9),6,9),")"
 ......S VAR1=$G(^TMP("PSB",$J,DFN,PSBDT,PSBOITX,PSBONX))
 ......S VAR2=$G(^TMP("PSB",$J,DFN,PSBDT,PSBOITX,PSBONX,"X"))
 ......S VAR3=$G(^TMP("PSB",$J,DFN,PSBDT,PSBOITX,PSBONX,.3))
 ......I PSBDT["ONE-TIME" D  Q
 .......W !,PSBDT,?30,PSBOITX S SP=1
 .......I VAR1]"" W !,?30,$P(VAR1,U,1) S SP=1
 .......I VAR2]"" W:$G(SP) ! W ?30,VAR2
 .......I VAR3]"" W !,$$WRAP^PSBO(30,95,VAR3)
 .......W !,"Start Date/Time:  ",?18,$O(PSBSTXT(PSBONX,""))
 .......W !,"Stop Date/Time:  ",?18,$O(PSBSTXP(PSBONX,""))
 .......W !
 ......W ?67,$S(+PSBDT>0:$$DTFMT^PSBOMM2(PSBDT),1:PSBDT),?85,PSBOITX S SP=1
 ......I VAR1]"" W !,?50,VAR1 S SP=1
 ......I VAR2]"" W:$G(SP) ! W ?50,VAR2
 ......I VAR3]"" W !,$$WRAP^PSBO(50,75,VAR3)
 Q
WRDHDR() ;
 D WARD^PSBOHDR(PSBWRD,.PSBHDR)
 W !,"Order Status",?15,"Room-Bed",?35,"Patient",?67,"Admin Date/Time",?85,"Medication"
 D LN1^PSBOMM2
 Q ""
PTHDR() ;
 D PT^PSBOHDR(DFN,.PSBHDR)
 W !,"Order Status",?15,"Administration Date/Time",?43,"Medication",?95,"Order Stop Date"
 D LN1^PSBOMM2
 Q ""