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

PSBOMH.m

Go to the documentation of this file. 
  1. PSBOMH ;BIRMINGHAM/EFC-MAH ;Mar 2004
  1.  ;;3.0;BAR CODE MED ADMIN;**5,9,38**;Mar 2004;Build 8
  1.  ;Per VHA Directive 2004-038, this routine should not be modified.
  1.  ;
  1.  ; Reference/IA
  1.  ; EN^PSJBCMA/2828
  1.  ; EN^PSJBCMA2/2830
  1.  ; File 200/10060
  1.  ; ^DIWP/10011
  1.  ;
  1. EN ; Called from DQ^PSBO
  1.  N PSBGBL,DFN
  1.  S PSBGBL=$NAME(^TMP("PSBO",$J,"B"))
  1.  F  S PSBGBL=$Q(@PSBGBL) Q:PSBGBL=""  Q:$QS(PSBGBL,2)'=$J  Q:$QS(PSBGBL,1)'["PSBO"  D
  1.  .S DFN=$QS(PSBGBL,5)
  1.  .S (PSBSTRT,X)=$P(PSBRPT(.1),U,6) D H^%DTC S PSBSTH=%H
  1.  .S (PSBSTOP,X)=$P(PSBRPT(.1),U,8)+.235959 D H^%DTC S PSBSPH=%H
  1.  .S PSBCNT=0 F I=PSBSTH:1:PSBSPH S PSBAR(I)=PSBSTH+((PSBCNT\7)*7),PSBCNT=PSBCNT+1
  1.  .D EN1
  1.  K PSBCNT,PSBAR Q
  1. EN1 ; Expects DFN,STRT,STOP
  1.  N PSBGBL,PSBHDR,PSBX,PSBFLAG
  1.  K ^TMP("PSJ",$J),^TMP("PSB",$J)
  1.  S PSBEVDT=PSBSTRT
  1.  D EN^PSJBCMA(DFN,PSBSTRT)
  1.  I $G(^TMP("PSJ",$J,1,0))=-1 D PT^PSBOHDR(DFN,.PSBHDR) W !!,"****NO MEDICATIONS FOUND****" Q  ; No Ord
  1.  S PSBX=""
  1.  F  S PSBX=$O(^TMP("PSJ",$J,PSBX)) Q:PSBX=""  D
  1.  .Q:$P(^TMP("PSJ",$J,PSBX,0),U,3)?.N1"P"  ; No Pnd
  1.  .Q:$P(^TMP("PSJ",$J,PSBX,1),U,5)<PSBSTRT!($P(^TMP("PSJ",$J,PSBX,1),U,4)>PSBSTOP)  ;display orders active in date range of report
  1.  .S X=$P(^TMP("PSJ",$J,PSBX,1),U,2)
  1.  .S ^TMP("PSB",$J,"ORDERS",$P(^TMP("PSJ",$J,PSBX,0),U,3))=X
  1.  I '$D(^TMP("PSB",$J,"ORDERS")) D PT^PSBOHDR(DFN,.PSBHDR) W !!,"****NO MEDICATIONS FOUND****" Q    ; No Orders
  1.  S PSBMHND="PSBOMH"
  1.  ; Act on Orders
  1.  S PSBX="" F  S PSBX=$O(^TMP("PSB",$J,"ORDERS",PSBX)) Q:PSBX=""  S PSBTYPE=^(PSBX) D
  1.  .S:PSBTYPE'="C" PSBTYPE="P"
  1.  .D CLEAN^PSBVT
  1.  .D PSJ1^PSBVT(DFN,PSBX)
  1.  .S X1=((PSBEVDT)\1)  S X2=-1  D C^%DTC  S PSBCNTST=X
  1.  .S X1=((PSBSTOP)\1)  S X2=1  D C^%DTC  S PSBXSTOP=X
  1.  .S PSBVALB=""
  1.  .S PSBVALB=$$IVPTAB^PSBVDLU3(PSBOTYP,PSBIVT,PSBISYR,PSBCHEMT,PSBIVPSH)
  1.  .S PSBZ=""
  1.  .S X1=PSBXSTOP,X2=PSBCNTST D ^%DTC S PSBNCT=X
  1.  .F PSBZ=1:1:PSBNCT S X1=PSBCNTST  S X2=1  D C^%DTC  S PSBCNTST=X  D
  1.  ..I (PSBX["V")!(PSBX'["V")  D
  1.  ...I PSBCNTST'>(PSBOST\1) S ^TMP("PSB",$J,"ORDERS",PSBONX,"NTDUE",PSBCNTST)=""
  1.  ...I PSBCNTST=(PSBOST\1)!($G(^TMP("PSB",$J,"ORDERS",PSBONX,"NTDUE",PSBCNTST))) K ^TMP("PSB",$J,"ORDERS",PSBONX,"NTDUE",PSBCNTST)
  1.  ...I PSBCNTST>(PSBOSP\1) S ^TMP("PSB",$J,"ORDERS",PSBONX,"NTDUE",PSBCNTST)=""
  1.  ...I PSBCNTST=(PSBOSP\1)&($G(^TMP("PSB",$J,"ORDERS",PSBONX,"NTDUE",PSBCNTST))) K ^TMP("PSB",$J,"ORDERS",PSBONX,"NTDUE",PSBCNTST) S ^TMP("PSB",$J,"ORDERS",PSBONX,"NTDUE",PSBCNTST)=""
  1.  ..S PSBDODD=""
  1.  ..I (PSBFREQ#1440'=0),(1440#PSBFREQ'=0) S PSBDODD=1
  1.  ..I ((PSBX'["V")!(PSBVALB="1")),((PSBDODD="1")&(PSBADST'="")) S ^TMP("PSB",$J,"ORDERS",PSBONX,"NTDUE",PSBCNTST)=""
  1.  ..I ((PSBX'["V")!(PSBVALB="1")),('$$OKAY^PSBVDLU1(PSBOST,PSBCNTST,PSBSCH,PSBON,PSBOITX,PSBFREQ,PSBOSTS)) S ^TMP("PSB",$J,"ORDERS",PSBONX,"NTDUE",PSBCNTST)=""  ;W t TMP
  1.  .S (PSBYES,PSBODD,PSBFLAG,PSBYTFN,PSBDAYN)=0
  1.  .S:$$PSBDCHK1^PSBVT1(PSBSCH) PSBYES=1,PSBDAYN=1
  1.  .I PSBYES,PSBADST="",PSBSCHT'="O",PSBSCHT'="OC",PSBSCHT'="P" Q 
  1.  .F I=1:1 Q:$P(PSBSCH,"-",I)=""  I $P(PSBSCH,"-",I)?2N!($P(PSBSCH,"-",I)?4N) S PSBYES=1,PSBYTFN=1
  1.  .I (PSBFREQ="O")!(PSBTYPE="P") S PSBYES=1
  1.  .I (PSBFREQ#1440'=0),(1440#PSBFREQ'=0) S PSBODD=1
  1.  .;flg / admn t
  1.  .S:PSBONX["U" PSBFLAG=1
  1.  .I PSBIVT="A" S PSBADST="0000"
  1.  .I PSBIVT="H" S PSBADST="0000"
  1.  .I PSBIVT="C",PSBCHEMT="P" S:PSBADST="" PSBFLAG=1
  1.  .I PSBIVT="C",PSBISYR=1 S:PSBADST="" PSBFLAG=1
  1.  .I PSBIVT="C",PSBCHEMT="A" S PSBADST="0000"
  1.  .I PSBIVT="C",PSBISYR=0 S PSBADST="0000"
  1.  .I PSBIVT="P",($G(PSBADST)=0) S:PSBADST="" PSBFLAG=1
  1.  .I PSBIVT="P" S:PSBADST="" PSBFLAG=1
  1.  .I PSBIVT="S",PSBISYR=0 S PSBADST="0000"
  1.  .I PSBIVT="S",PSBISYR=1 S:PSBADST="" PSBFLAG=1
  1.  .I PSBFREQ="D" S PSBFREQ=""
  1.  .I 'PSBYES,PSBADST="",PSBFREQ<1 Q
  1.  .S (PSBEE,PSBZZ)=0
  1.  .I (PSBVALB="1")!(PSBX'["V") D  Q:(PSBEE!PSBZZ)=1
  1.  ..I PSBSCHT="C",PSBYTFN="1",PSBADST=""  S PSBEE=1
  1.  ..I PSBSCHT="C",PSBDAYN'="1",PSBYTFN'="1",PSBADST'="",PSBFREQ<1  S PSBZZ=1
  1.  .I 'PSBODD,PSBFLAG,PSBTYPE="C",PSBADST="" S PSBADST=$$GETADMIN^PSBVDLU1(DFN,PSBONX,PSBOST,PSBFREQ,PSBSTOP)
  1.  .E  I PSBADST'="" K ^TMP("PSB",$J,"GETADMIN") S ^TMP("PSB",$J,"GETADMIN",0)=PSBADST
  1.  .;Calc adm/frq
  1.  .S PSBDT=PSBSTRT
  1.  .K PSBO,^UTILITY($J)
  1.  .F X=1:1:8 S PSBO(X)=""
  1.  .S DIWL=0,DIWR=32,DIWF="C32"
  1.  .S X=$P(PSBOSTX," ")_"          "_$P(PSBOSPX," ") D ^DIWP
  1.  .S X="@"_$P(PSBOSTX," ",3)_"              @"_$P(PSBOSPX," ",3)_"   " D ^DIWP
  1.  .S X="" D ^DIWP
  1.  .S X=PSBOITX D ^DIWP
  1.  .; DD,SOL,ADD
  1.  .S X=""
  1.  .F Y=0:0 S Y=$O(PSBDDA(Y)) Q:'Y  S X=X_$S(X]"":", ",1:"")_$P(PSBDDA(Y),U,3)
  1.  .F Y=0:0 S Y=$O(PSBADA(Y)) Q:'Y  S X=X_$S(X]"":", ",1:"")_$P(PSBADA(Y),U,3)_" "_$P(PSBADA(Y),U,4)_$P(PSBADA(Y),U,5)
  1.  .F Y=0:0 S Y=$O(PSBSOLA(Y)) Q:'Y  S X=X_$S(X]"":", ",1:"")_$P(PSBSOLA(Y),U,3)_" "_$P(PSBSOLA(Y),U,4)
  1.  .S X=" "_X,DIWF="I2C32" D ^DIWP S DIWF="C32"
  1.  .S PSBTXT=" Give: "_PSBDOSE_" "_PSBMRAB_" "_PSBSCH_" "_PSBIFR
  1.  .F  S PSBWORD=$P(PSBTXT," ",1),PSBTXT=$P(PSBTXT," ",2,250) D  Q:PSBTXT=""
  1.  ..F  Q:'$L(PSBWORD)  S X=$E(PSBWORD,1,30),PSBWORD=$E(PSBWORD,30,250) D ^DIWP
  1.  .K ^TMP("PSJ",$J) D EN^PSJBCMA2(DFN,PSBX) I ^TMP("PSJ",$J,0)'=-1 D   ;get activity log
  1.  ..S (PSBDISX,PSBHLDX)=0 F I=1:1:$P(^TMP("PSJ",$J,0),U,4) S X=$G(^TMP("PSJ",$J,I,1)) D  ;loop activities
  1.  ...Q:X["EDITED"!(X["VERIF")  ;
  1.  ...S Z=0
  1.  ...I X'["OFF HOLD",X'["UNHOLD",X'["REINSTATE" S Z=1 ; inc iv's
  1.  ...S PSBHLDX=PSBHLDX+$S(Z>0:1,1:0)
  1.  ...S $P(PSBHLD(PSBHLDX),U,$S(Z>0:1,1:11))=^TMP("PSJ",$J,I,1)  ;set up for multiple on hold entries save start & stop as pair if exists 
  1.  ..F PSBHLDX=1:1 S X=$G(PSBHLD(PSBHLDX)) Q:'X  D  ;if a hold index - process 
  1.  ...S PSBHLDN=$P(PSBHLD(PSBHLDX),U,1),PSBHLDF=$P(PSBHLD(PSBHLDX),U,11)  ;get on/off hold, dates, IEN number(for UD orders) of person. 
  1.  ...Q:PSBHLDN>PSBSTOP  Q:(PSBHLDF<PSBSTRT)&(PSBHLDF'="") 
  1.  ...F PSBHLDT=PSBSTRT\1:1:PSBSTOP\1 I (PSBHLDT'<(PSBHLDN\1)),(PSBHLDT'>PSBSTOP) D
  1.  ....I X["DISCONTINUED" K ^TMP("PSB",$J,"ORDERS",PSBONX,"HOLD",PSBHLDT) S ^TMP("PSB",$J,"ORDERS",PSBONX,"DISC",PSBHLDT)=""
  1.  ....I (X["HOLD")&((PSBHLDN\1)'>PSBHLDT)&((PSBHLDF'<PSBHLDT)!(PSBHLDF="")) S ^TMP("PSB",$J,"ORDERS",PSBONX,"HOLD",PSBHLDT)=""
  1.  ....I X["REINSTATE" K ^TMP("PSB",$J,"ORDERS",PSBONX,"DISC",PSBHLDT) I PSBOSTS="H" S ^TMP("PSB",$J,"ORDERS",PSBONX,"HOLD",PSBHLDT)=""
  1.  ...F PSBHLDXP=1:10:$P(PSBHLD(PSBHLDX),U,11)]""+10 D
  1.  ....S PSBDESC=$P(PSBHLD(PSBHLDX),U,PSBHLDXP+3),X=$S(PSBDESC["DISCONTINUE":"***",1:"")
  1.  ....S X=" "_X_PSBDESC D ^DIWP  ;output activity text 
  1.  ....S X="",PSBHLDI=$P(PSBHLD(PSBHLDX),U,PSBHLDXP+4) I PSBHLDI'="" S X=$$GET1^DIQ(200,PSBHLDI,"INITIAL")
  1.  ....S:X="" X="99" ;no init present
  1.  ....I X'="99" S X=" "_X D ^DIWP   ;get init & store
  1.  ....S Y=$P(PSBHLD(PSBHLDX),U,PSBHLDXP) D DD^%DT S X=Y D ^DIWP  ;format hold date / write 
  1.  ..K PSBHLD,PSBHLDF,PSBHLDN,PSBHLDT,PSBHLDX,PSBHLDXP,PSBHLDI,PSBDISX,PSBDISC,PSBDISXP,PSBDISI,PSBDIST,PSBDISN,PSBDESC
  1.  .I PSBOTXT]"" D
  1.  ..I $E(PSBOTXT,1)="!"  S $E(PSBOTXT,1)=""
  1.  ..S PSBOTXT=" Spec Inst: "_PSBOTXT
  1.  ..F  S PSBWORD=$P(PSBOTXT," ",1),PSBOTXT=$P(PSBOTXT," ",2,250) D  Q:PSBOTXT=""
  1.  ...F  Q:'$L(PSBWORD)  S X=$E(PSBWORD,1,30),PSBWORD=$E(PSBWORD,30,250) D ^DIWP
  1.  .F X=0:0 S X=$O(^UTILITY($J,"W",0,X)) Q:'X  S PSBO(X)=$G(^(X,0)) D
  1.  .S X=$O(PSBO(""),-1) S X=$S(X<8:8,1:X+1)
  1.  .S PSBO(X)=" RPH: "_PSBVPHI_"  RN: "_PSBVNI
  1.  .S PSBVAL=$$IVPTAB^PSBVDLU3(PSBOTYP,PSBIVT,PSBISYR,PSBCHEMT,PSBIVPSH)
  1.  .I PSBODD="1",PSBADST'="" D
  1.  ..I (PSBVAL="1")!(PSBX'["V") D   ;checks iv/pb and u dose
  1.  ...S PSBO(X+1)=""
  1.  ...S PSBO(X+2)="NOTE - ODD SCHEDULE NO LONGER",PSBO(X+3)="       ALLOWS ADMIN TIMES."
  1.  .K ^UTILITY($J)
  1.  .M ^TMP("PSB",$J,"ORDERS",PSBX,"INST")=PSBO
  1.  .D:PSBTYPE="C"
  1.  ..F  D  Q:PSBDT>PSBSTOP
  1.  ...S X=PSBDT D H^%DTC S PSBWEEK=%H
  1.  ...S ^TMP("PSB",$J,PSBWEEK,PSBONX)=""
  1.  ...; Odd schd - msg
  1.  ...S PSBIDOW=0 I PSBONX["U"!("PCS"[PSBIVT) S PSBIDOW=1
  1.  ...I PSBADST="",PSBIDOW,(PSBODD) D
  1.  ....S ^TMP("PSB",$J,"ORDERS",PSBONX,"AT",0)=7
  1.  ....S ^TMP("PSB",$J,"ORDERS",PSBONX,"AT",1)="odd"
  1.  ....S ^TMP("PSB",$J,"ORDERS",PSBONX,"AT",2)="sched"
  1.  ....S ^TMP("PSB",$J,"ORDERS",PSBONX,"AT",3)=$E(PSBSCH,1,5)
  1.  ....S ^TMP("PSB",$J,"ORDERS",PSBONX,"AT",4)="no"
  1.  ....S ^TMP("PSB",$J,"ORDERS",PSBONX,"AT",5)="fixed"
  1.  ....S ^TMP("PSB",$J,"ORDERS",PSBONX,"AT",6)="admin"
  1.  ....S ^TMP("PSB",$J,"ORDERS",PSBONX,"AT",7)="times"
  1.  ...I PSBADST'="",PSBADST'="0000",+$G(PSBFREQ)>0,+$G(PSBFREQ)<45 D
  1.  ....S ^TMP("PSB",$J,"ORDERS",PSBONX,"AT",0)=5
  1.  ....S ^TMP("PSB",$J,"ORDERS",PSBONX,"AT",1)="Due"
  1.  ....S ^TMP("PSB",$J,"ORDERS",PSBONX,"AT",2)="every"
  1.  ....S ^TMP("PSB",$J,"ORDERS",PSBONX,"AT",3)=$E(PSBFREQ,1,5)
  1.  ....S ^TMP("PSB",$J,"ORDERS",PSBONX,"AT",4)="mins."
  1.  ....S ^TMP("PSB",$J,"ORDERS",PSBONX,"AT",5)=" "
  1.  ...S PSBATCNT=0    ; # times to print...
  1.  ...I PSBADST'="",((+$G(PSBFREQ)>44)!(PSBFREQ="")!(PSBADST="0000")) F PSBXX=0:1  Q:$G(^TMP("PSB",$J,"GETADMIN",PSBXX))=""  D
  1.  ....S PSBADST2=$G(^TMP("PSB",$J,"GETADMIN",PSBXX))
  1.  ....F Y=1:1:$L(PSBADST2,"-") D
  1.  .....Q:($P(PSBADST2,"-",Y)'?2N)&($P(PSBADST2,"-",Y)'?4N)  S PSBATCNT=PSBATCNT+1,^TMP("PSB",$J,"ORDERS",PSBONX,"AT",PSBATCNT)=$P(PSBADST2,"-",Y)
  1.  ...I PSBADST'="",PSBFREQ>44 S ^TMP("PSB",$J,"ORDERS",PSBONX,"AT",0)=PSBATCNT
  1.  ...S ^TMP("PSB",$J,PSBWEEK,"SORT",PSBTYPE,PSBOITX,PSBX)=""
  1.  ...F PSBDOW=0:1:6 D  Q:X>(PSBSTOP-1)
  1.  ....S %H=PSBWEEK+PSBDOW D YMD^%DTC
  1.  ....S ^TMP("PSB",$J,PSBWEEK,PSBONX,X,0)=0
  1.  ....I '$D(^TMP("PSB",$J,PSBWEEK,"HDR",X)) S ^TMP("PSB",$J,PSBWEEK,"HDR",X)=$E(X,4,5)_"/"_$E(X,6,7)_"/"_(1700+$E(X,1,3))
  1.  ...S %H=PSBWEEK+7 D YMD^%DTC S PSBDT=X
  1.  .D:PSBTYPE'="C"
  1.  ..S X=PSBDT D H^%DTC S PSBWEEK=%H
  1.  ..S (^TMP("PSB",$J,PSBWEEK,PSBONX),^TMP("PSB",$J,PSBWEEK,PSBONX,"AT",0))="",^TMP("PSB",$J,PSBWEEK,"SORT",PSBTYPE,PSBOITX,PSBX)=""
  1.  D EN^PSBOMH1,EN^PSBOMH2
  1.  Q
  1. INSTR S PSBINIT=PSBINIT_"*"
  1.  S PSBNAME=PSBNAME_"/"_$P(^PSB(53.79,PSBIEN,.9,$P(PSBDT,"."),0),U,3)_"  "_$$GET1^DIQ(53.79,PSBIEN_",",.06)
  1.  Q
  1.  ;