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

PSBODL.m

Go to the documentation of this file. 
  1. PSBODL ;BIRMINGHAM/EFC-DUE LIST ;Mar 2004
  1.  ;;3.0;BAR CODE MED ADMIN;**5,9,38,32,25**;Mar 2004;Build 6
  1.  ;Per VHA Directive 2004-038 (or future revisions regarding same), this routine should not be modified. 
  1.  ;
  1.  ; Reference/IA
  1.  ; EN^PSJBCMA/2828
  1.  ; $$GET^XPAR/2263
  1.  ; ^XLFDT/10103
  1.  ;
  1. EN ; Prt DL
  1.  N PSBGBL,PSBHDR,IOINHI,IOINORM,PSBGIVEN,PSBIEN,PSBLGDT,PSBEVDT,DFN,PSBFLAG
  1.  S X="IOINHI;IOINORM" D ENDR^%ZISS S X=""
  1.  I '$D(^TMP("PSBO",$J,"B")) S ^TMP("PSBO",$J,"B","EMPTY")=""
  1.  S PSBGBL="^TMP(""PSBO"",$J,""B"")"
  1.  I $G(PSBRPT(.4)) S $P(PSBRPT(.2),U,8)=1
  1.  F  S PSBGBL=$Q(@PSBGBL) Q:PSBGBL=""  Q:$QS(PSBGBL,1)'="PSBO"!($QS(PSBGBL,2)'=$J)  D
  1.  .S DFN=$QS(PSBGBL,5)
  1.  .K PSBHDR
  1.  .S PSBHDR(1)="MEDICATION DUE LIST for "
  1.  .S (Y,PSBEVDT)=$P(PSBRPT(.1),U,6) D D^DIQ S Z=Y,PSBHDR(1)=PSBHDR(1)_Y_"@" S Y=$P(PSBRPT(.1),U,7) S PSBHDR(1)=PSBHDR(1)_$E(Y_"0000",2,5)
  1.  .S PSBEVDT2=$P(PSBRPT(.1),U,6) S Y=$P(PSBRPT(.1),U,9) S:Y]"" PSBHDR(1)=PSBHDR(1)_" to "_Z_"@"_$E(Y_"0000",2,5)
  1.  .S PSBHDR(2)="Schedule Type(s): --"
  1.  .F Y=1:1:4 I $P(PSBRPT(.2),U,Y) S $P(PSBHDR(2),": ",2)=$P(PSBHDR(2),": ",2)_$S(PSBHDR(2)["--":"",1:"/ ")_$P("Continuous^PRN^On-Call^One-Time",U,Y)_" " S PSBHDR(2)=$TR(PSBHDR(2),"-","")
  1.  .S PSBHDR(3)="Order Type(s): --"
  1.  .F Y=6,7,8 I $P(PSBRPT(.2),U,Y) S $P(PSBHDR(3),": ",2)=$P(PSBHDR(3),": ",2)_$S(PSBHDR(3)["--":"",1:"/ ")_$P("^^^^^IV^Unit Dose^Future Orders",U,Y)_" " S PSBHDR(3)=$TR(PSBHDR(3),"-","")
  1.  .I $QS(PSBGBL,4)="EMPTY" D  Q
  1.  ..S X="" F  S X=$O(PSBHDR(X)) Q:X=""  D  W !!?10,"** NO DATA FOR ENTIRE NURSE/WARD LOCATION **",! Q
  1.  ...W !,PSBHDR(X)
  1.  .D PRINT(DFN)
  1.  K ^TMP("PSJ",$J),^TMP("PSB",$J),^TMP("PSBO",$J)
  1.  Q
  1. PRINT(DFN) ;^TMP($J.
  1.  N PSBGBL,PSBOSTRT,PSBOSTOP,PSBINDX,PSBTYPE,PSBSCH,PSBSCHT
  1.  N PSBMED,PSBORD,PSB,PSBX,PSBY,PSBZ,PSBSTOP,PSBSTRT,PSBSM,PSBNUM,PSBAT
  1.  N PSBADMIN,PSBADM,PSBSTAT,PSBWFLAG
  1.  W $$HDR()
  1.  S PSBOSTRT=$P(PSBRPT(.1),U,6)+$P(PSBRPT(.1),U,7)
  1.  S PSBOSTOP=$P(PSBRPT(.1),U,6)+$P(PSBRPT(.1),U,9)
  1.  K ^TMP("PSJ",$J),^TMP("PSB",$J)
  1.  D EN^PSJBCMA(DFN,PSBOSTRT,"")
  1.  I $G(^TMP("PSJ",$J,1,0))=-1 W !!?10,"** NO SPECIFIED MEDICATIONS TO PRINT **",!,$$BLANKS(),$$FTR^PSBODL1() Q
  1.  S PSBI1=0 F  S PSBODATE=$$FMADD^XLFDT(PSBEVDT,PSBI1) Q:PSBODATE>PSBEVDT2  D
  1.  .S PSBI1=1
  1.  .S Y=PSBODATE D D^DIQ
  1.  .W !!,"Administration Date: "_Y,!
  1.  .S PSBINDX=0
  1.  .F  S PSBINDX=$O(^TMP("PSJ",$J,PSBINDX)) Q:'PSBINDX  D
  1.  ..S PSBTYPE=$P(^TMP("PSJ",$J,PSBINDX,0),U,3),PSBTYPE=$E(PSBTYPE,$L(PSBTYPE))
  1.  ..Q:PSBTYPE=""!(PSBTYPE="P")  ; No Pend this ver
  1.  ..S PSBSTAT=^TMP("PSJ",$J,PSBINDX,1)
  1.  ..I $P(PSBSTAT,U,7)["D"!($P(PSBSTAT,U,7)="E")!($P(PSBSTAT,U,8)) Q
  1.  ..Q:PSBTYPE="U"&('$P(PSBRPT(.2),U,7))
  1.  ..Q:PSBTYPE="V"&('$P(PSBRPT(.2),U,6))
  1.  ..S PSBTYPE=$S(PSBTYPE="U":"UD-",PSBTYPE="V":"IV-",1:"**")
  1.  ..S Y=$P(PSBSTAT,U,2)
  1.  ..Q:Y="C"&('$P(PSBRPT(.2),U,1))
  1.  ..Q:Y="P"&('$P(PSBRPT(.2),U,2))
  1.  ..Q:Y="OC"&('$P(PSBRPT(.2),U,3))
  1.  ..Q:Y="O"&('$P(PSBRPT(.2),U,4))
  1.  ..S PSBSCHT=Y
  1.  ..S:PSBSCHT="" PSBSCHT="*"
  1.  ..S PSBMED=$P(^TMP("PSJ",$J,PSBINDX,3),U,2)
  1.  ..S PSBORD=$P(^TMP("PSJ",$J,PSBINDX,0),U,3)
  1.  ..S ^TMP("PSB",$J,"B",PSBTYPE,PSBSCHT,PSBMED,PSBORD)=""
  1.  .I '$D(^TMP("PSB",$J,"B")) W !!?10,"** NO SPECIFIED MEDICATIONS TO PRINT **",!,$$BLANKS(),$$FTR^PSBODL1() Q
  1.  .S PSBGBL=$NAME(^TMP("PSB",$J,"B")),PSBWFLAG=0
  1.  .F  S PSBGBL=$Q(@PSBGBL) Q:PSBGBL=""  Q:($QS(PSBGBL,1)'="PSB")!($QS(PSBGBL,2)'=$J)!($QS(PSBGBL,3)'="B")  D
  1.  ..K PSBORD,PSBFUTRO
  1.  ..S PSBTYPE=$QS(PSBGBL,4)
  1.  ..S PSBSCHT=$QS(PSBGBL,5)
  1.  ..S PSBMED=$QS(PSBGBL,6)
  1.  ..S PSBORD=$QS(PSBGBL,7)
  1.  ..D CLEAN^PSBVT
  1.  ..D PSJ1^PSBVT(DFN,PSBORD)
  1.  ..D NOW^%DTC S PSBNOW=%
  1.  ..Q:PSBOSP<PSBOSTRT
  1.  ..Q:(PSBOSP<PSBOSTRT)&(PSBSCHT'="O")
  1.  ..Q:(PSBOSP'>PSBNOW)
  1.  ..S (PSBYES,PSBODD,PSBDAYB,PSBSCBR)=0
  1.  ..S:$$PSBDCHK1^PSBVT1(PSBSCH) PSBYES=1,PSBDAYB=1
  1.  ..F I=1:1 Q:$P(PSBSCH,"-",I)=""  I $P(PSBSCH,"-",I)?2N!($P(PSBSCH,"-",I)?4N) S PSBYES=1,PSBSCBR=1
  1.  ..I PSBYES,PSBADST="",PSBSCHT'="O",PSBSCHT'="OC",PSBSCHT'="P" D  Q
  1.  ...D ERROR^PSBMLU(PSBONX,PSBOITX,DFN,"Admin times required",PSBSCH)
  1.  ..I PSBSCHT="OC" S PSBYES=1
  1.  ..I PSBSCHT="P" S PSBYES=1
  1.  ..I "PCS"'[PSBIVT S PSBYES=1
  1.  ..I PSBIVT["S",PSBISYR'=1 S PSBYES=1
  1.  ..I PSBIVT["C",PSBCHEMT'="P",PSBISYR'=1 S PSBYES=1
  1.  ..I PSBIVT["C",PSBCHEMT="A" S PSBYES=1
  1.  ..I PSBFREQ="O" S PSBFREQ=1440
  1.  ..I PSBFREQ="D" S PSBFREQ=""
  1.  ..I PSBSCHT="P" S PSBFREQ=1440
  1.  ..I PSBSCHT="O" S PSBFREQ=1440
  1.  ..I 'PSBYES,PSBFREQ<1 D ERROR^PSBMLU(PSBONX,PSBOITX,DFN,"Invalid frequency received from order",PSBSCH) Q
  1.  ..S PSBVALB=$$IVPTAB^PSBVDLU3(PSBOTYP,PSBIVT,PSBISYR,PSBCHEMT,PSBIVPSH)
  1.  ..I 'PSBDAYB,'PSBSCBR,PSBSCHT="C",PSBVALB="1",PSBADST'="",PSBFREQ<1 D ERROR^PSBMLU(PSBONX,PSBOITX,DFN,"Invalid frequency received from order",PSBSCH) Q
  1.  ..I +PSBFREQ>0 I (PSBFREQ#1440'=0),(1440#PSBFREQ'=0) S PSBODD=1
  1.  ..I PSBODD,PSBADST'="" D ERROR^PSBMLU(PSBONX,PSBOITX,DFN,"Administration Times on ODD SCHEDULE",PSBSCH) Q
  1.  ..I PSBADST'="" D
  1.  ...F PSBY=1:1:$L(PSBADST,"-")  D
  1.  ....D:($P(PSBADST,"-",PSBY)'?2N)&($P(PSBADST,"-",PSBY)'?4N)
  1.  .....D ERROR^PSBMLU(PSBONX,PSBOITX,DFN,"Invalid Admin times",PSBSCH)
  1.  ..I PSBSCHT="C",PSBOTYP="U" Q:'$$OKAY^PSBVDLU1(PSBOST,PSBODATE,PSBSCH,PSBONX,PSBOITX,PSBFREQ,)
  1.  ..I PSBSCHT="C",$$IVPTAB^PSBVDLU3(PSBOTYP,PSBIVT,PSBISYR,PSBCHEMT,PSBIVPSH),'$$OKAY^PSBVDLU1(PSBOST,PSBODATE,PSBSCH,PSBONX,PSBOITX,PSBFREQ) Q
  1.  ..I PSBSCHT="O" D  Q:PSBGVN
  1.  ...S (PSBGVN,X,Y)=""
  1.  ...F  S X=$O(^PSB(53.79,"AOIP",DFN,PSBOIT,X),-1) Q:'X  D
  1.  ....F  S Y=$O(^PSB(53.79,"AOIP",DFN,PSBOIT,X,Y),-1) Q:'Y  D
  1.  .....I $P(^PSB(53.79,Y,.1),U)=PSBONX,$P(^PSB(53.79,Y,0),U,9)="G" S PSBGVN=1,(X,Y)=0
  1.  ..S PSBRMN=1
  1.  ..I PSBSCHT="O" D
  1.  ...Q:(PSBOST'=PSBOSP)
  1.  ...Q:(PSBOSP<PSBOSTRT)
  1.  ...Q:((%'>PSBOST)!(%'=PSBOST))
  1.  ...S PSBRMN=0
  1.  ..Q:'PSBRMN
  1.  ..I PSBOST>$$FMADD^XLFDT(PSBNOW,"","",+($$GET^XPAR("DIV","PSB ADMIN BEFORE"))) S ^TMP("PSBO",$J,DFN,PSBORD,PSBTYPE)="" Q
  1.  ..I PSBSCHT="OC" D  Q:PSBGVN&('$$GET^XPAR("DIV","PSB ADMIN MULTIPLE ONCALL"))
  1.  ...S (PSBGVN,X,Y)=""
  1.  ...F  S X=$O(^PSB(53.79,"AOIP",DFN,PSBOIT,X),-1) Q:'X  D
  1.  ....F  S Y=$O(^PSB(53.79,"AOIP",DFN,PSBOIT,X,Y),-1) Q:'Y  D
  1.  .....I $P(^PSB(53.79,Y,.1),U)=PSBONX,$P(^PSB(53.79,Y,0),U,9)="G" S PSBGVN=1,(X,Y)=0
  1.  ..S PSBLGDT="",X=""
  1.  ..F  S X=$O(^PSB(53.79,"AOIP",DFN,+PSBOIT,X),-1) Q:'X  D  Q:PSBLGDT
  1.  ...S PSBIEN=""
  1.  ...F  S PSBIEN=$O(^PSB(53.79,"AOIP",DFN,+PSBOIT,X,PSBIEN),-1) Q:PSBIEN=""  D  Q:PSBLGDT
  1.  ....S:$P($G(^PSB(53.79,PSBIEN,0)),U,9)="G" PSBLGDT=X
  1.  ..S PSBADMIN="" K ^TMP("PSB",$J,"GETADMIN")
  1.  ..I PSBSCHT="C" D  Q:PSBADMIN=""
  1.  ...S PSBX=PSBADST,PSBFLAG=1
  1.  ...D:PSBX=""
  1.  ....I PSBIVT="C",PSBCHEMT="A" S PSBX="0000",PSBFLAG=0
  1.  ....I PSBIVT="C",PSBISYR=0 S PSBX="0000",PSBFLAG=0
  1.  ....I PSBIVT="S",PSBISYR'=1 S PSBX="0000",PSBFLAG=0
  1.  ....I "HA"[PSBIVT S:PSBIVT]"" PSBX="0000",PSBFLAG=0
  1.  ...I ((PSBIVT="S")!(PSBIVT="C")),(PSBISYR=1) S:+($G(PSBX))=0 PSBX=""
  1.  ...I (PSBIVT="C"),(PSBCHEMT="P") S:+($G(PSBX))=0 PSBX=""
  1.  ...I PSBOTYP="U",PSBX="0000" S PSBX=""
  1.  ...I PSBIVT="P" S:+($G(PSBX))=0 PSBX=""
  1.  ...I PSBX="" S:($G(PSBFREQ)>29)!(PSBFREQ="D") PSBX=$$GETADMIN^PSBVDLU1(DFN,PSBONX,PSBOST,PSBFREQ,PSBODATE)
  1.  ...E  S ^TMP("PSB",$J,"GETADMIN",0)=PSBX
  1.  ...D:PSBX'=""
  1.  ....F PSBXX=0:1 Q:'$D(^TMP("PSB",$J,"GETADMIN",PSBXX))  S PSBX=$G(^TMP("PSB",$J,"GETADMIN",PSBXX)) D
  1.  .....F PSBY=1:1:$L(PSBX,"-")  D
  1.  ......S PSBAT=+(PSBODATE_"."_$P(PSBX,"-",PSBY))
  1.  ......I PSBFLAG Q:PSBAT<PSBOSTRT!(PSBAT>PSBOSTOP)
  1.  ......D VAL^PSBMLVAL(.PSBZ,DFN,PSBON,PSBOTYP,PSBAT)
  1.  ......I (PSBZ(0)<0)&(PSBCNT=1) S ^TMP("PSBO",$J,DFN,PSBORD,PSBTYPE,PSBAT)="" Q
  1.  ......I (PSBAT'["."),($G(PSBORD)["V") I (PSBOST<PSBOSTOP),(PSBOST'<PSBOSTRT) S ^TMP("PSBO",$J,DFN,PSBORD,PSBTYPE,PSBAT)="" Q
  1.  ......Q:+PSBZ(0)<0
  1.  ......I $G(PSBOST)'>$G(PSBAT) D
  1.  .......Q:($G(PSBOSP)'>$G(PSBAT))
  1.  .......S PSBADMIN=PSBADMIN_$S(PSBADMIN]"":"-",1:"")_$P(PSBX,"-",PSBY)
  1.  ......E  I ($P($G(PSBOST),".")'>$P($G(PSBAT),"."))&($P($G(PSBAT),".",2)="") S PSBADMIN=PSBADMIN_$S(PSBADMIN]"":"-",1:"")_$P(PSBX,"-",PSBY)
  1.  ...I +$G(PSBFREQ)>0,$G(PSBFREQ)<30,PSBADMIN'="0000" S PSBADMIN="Due every "_$G(PSBFREQ)_" minutes."
  1.  ..I $Y>(IOSL-(12+($L(PSBADMIN)/27))) W !?(IOM-36\2),"(Medications Continued on Next Page)",$$FTR^PSBODL1(),$$HDR()
  1.  ..I PSBSM S PSBSM=$S(PSBSMX:"H",1:"")_"SM"
  1.  ..E  S PSBSM=""
  1.  ..W !,$J(PSBSM,3),?6,PSBTYPE,$E(PSBSCHT,1,4),?12 S PSBWFLAG=1
  1.  ..S X="",Y=0
  1.  ..D WRAPPUP^PSBODL1
  1.  .I '$G(PSBWFLAG) W !!,?10,"** NO SPECIFIED MEDICATIONS TO PRINT **"
  1.  .W $$BLANKS(),$$FTR^PSBODL1()
  1.  .S PSBORD=$O(^TMP("PSBO",$J,DFN,""),-1)
  1.  .I +$G(PSBORD)>0,$P(PSBRPT(.4),U,1),$D(^TMP("PSBO",$J,DFN,PSBORD)) D EN^PSBODL1
  1.  Q
  1. HDR() ;
  1.  D PT^PSBOHDR(DFN,.PSBHDR)
  1.  W !,"Self",?85,"Last",?100,"Start",?110,"Stop",?120,"Verifying"
  1.  W !,"Med",?6,"Sched",?14,"Medication",?50,"Dose",?78,"Route",?85,"Given",?100,"Date",?110,"Date",?120,"Rph/Rn"
  1.  W !,?100,"@Time",?110,"@Time"
  1.  W !,$TR($J("",IOM)," ","-")
  1.  Q ""
  1. BLANKS() ;
  1.  Q:'$P(PSBRPT(.2),U,5) ""
  1.  W !
  1.  D:$Y>(IOSL-26)
  1.  .W ?(IOM-42\2),"(Changes/Addendums to Orders on Next Page)"
  1.  .W $$FTR^PSBODL1(),$$HDR() ; New page - no room for blanks
  1.  I IOSL<100 F  Q:$Y>(IOSL-26)  W !
  1.  W ?(IOM-28\2),"Changes/Addendums to orders"
  1.  F X=1:1:4 D
  1.  .W !,$TR($J("",IOM)," ","-")
  1.  .W !!?3,"CON ___ PRN ___"
  1.  .W ?20,"Drug: ",$TR($J("",22)," ","_")
  1.  .W ?50,"Give: ",$TR($J("",42)," ","_")
  1.  .W ?100,"Start: _________ Stop: _________"
  1.  .W !?20,"Spec"
  1.  .W !?3,"OT  ___ OC  ___"
  1.  .W ?20,"Inst: ",$TR($J("",72)," ","_")
  1.  .W ?100,"Initials: ______ Date: _________"
  1.  W !,$TR($J("",IOM)," ","-")
  1.  Q ""