PSBOMH ;BIRMINGHAM/EFC-MAH ;03/06/16 3:06pm
;;3.0;BAR CODE MED ADMIN;**5,9,38,57,67,68,70,76,83,116**;Mar 2004;Build 2
;Per VHA Directive 2004-038, this routine should not be modified.
;
; Reference/IA
; EN^PSJBCMA/2828
; EN^PSJBCMA2/2830
; File 200/10060
; ^DIWP/10011
;
;*68 - remove old special instruction text encoding, defer to PSBOMH2
;*70 - add Clinic name to PSBO array for printing on grid via PSBOMH2
; in ^TMP(""PSB",$J,"ORDERS",PSBX,"INST") global
;*83 - add remove logic to print RM and associated Gives in grid and
; also remove string in order summary area.
;
EN ; Called from DQ^PSBO
N PSBGBL,DFN,Q,X ;*83
S PSBGBL=$NAME(^TMP("PSBO",$J,"B"))
F S PSBGBL=$Q(@PSBGBL) Q:PSBGBL="" Q:$QS(PSBGBL,2)'=$J Q:$QS(PSBGBL,1)'["PSBO" D
.S DFN=$QS(PSBGBL,5)
.S (PSBSTRT,X)=$P(PSBRPT(.1),U,6) D H^%DTC S PSBSTH=%H
.S (PSBSTOP,X)=$P(PSBRPT(.1),U,8)+.235959 D H^%DTC S PSBSPH=%H
.S PSBCNT=0 F I=PSBSTH:1:PSBSPH S PSBAR(I)=PSBSTH+((PSBCNT\7)*7),PSBCNT=PSBCNT+1
.D EN1
K PSBCNT,PSBAR
D CLEAN^PSBVT ;*83
Q
EN1 ; Expects DFN,STRT,STOP
N PSBGBL,PSBHDR,PSBX,PSBFLAG,PSBHLDFL,PSBADST1,PSBOST1,PSBCLINIC,PSBORSTP ;*70
K ^TMP("PSJ",$J),^TMP("PSB",$J)
S PSBEVDT=PSBSTRT
D EN^PSJBCMA(DFN,PSBSTRT)
N PSBCLINORD S PSBCLINORD=2 ;*70 Combind mode headers
I $G(^TMP("PSJ",$J,1,0))=-1 D Q ; No Ord
.D PT^PSBOHDR(DFN,.PSBHDR) W !!,"****NO MEDICATIONS FOUND****"
S PSBX=""
F S PSBX=$O(^TMP("PSJ",$J,PSBX)) Q:PSBX="" D
.Q:$P(^TMP("PSJ",$J,PSBX,0),U,3)?.N1"P" ; No Pnd
.S PSBORSTP=$P(^TMP("PSJ",$J,PSBX,1),U,5) S:$P(^TMP("PSJ",$J,PSBX,1),U,15)>PSBORSTP PSBORSTP=$P(^TMP("PSJ",$J,PSBX,1),U,15)
.Q:PSBORSTP<PSBSTRT!($P(^TMP("PSJ",$J,PSBX,1),U,4)>PSBSTOP) ;display orders active in date range of report
.S X=$P(^TMP("PSJ",$J,PSBX,1),U,2)
.S ^TMP("PSB",$J,"ORDERS",$P(^TMP("PSJ",$J,PSBX,0),U,3))=X
I '$D(^TMP("PSB",$J,"ORDERS")) D Q ;No Orders
.D PT^PSBOHDR(DFN,.PSBHDR) W !!,"****NO MEDICATIONS FOUND****"
S PSBMHND="PSBOMH"
; Act on Orders
S PSBX="" F S PSBX=$O(^TMP("PSB",$J,"ORDERS",PSBX)) Q:PSBX="" S PSBTYPE=^(PSBX) D
.S:PSBTYPE'="C" PSBTYPE="P"
.D CLEAN^PSBVT
.D PSJ1^PSBVT(DFN,PSBX)
.S PSBCLINIC=PSBCLORD
.S X1=((PSBEVDT)\1) S X2=-1 D C^%DTC S PSBCNTST=X
.S X1=((PSBSTOP)\1) S X2=1 D C^%DTC S PSBXSTOP=X
.S PSBVALB=""
.S PSBVALB=$$IVPTAB^PSBVDLU3(PSBOTYP,PSBIVT,PSBISYR,PSBCHEMT,PSBIVPSH)
.S PSBZ=""
.S X1=PSBXSTOP,X2=PSBCNTST D ^%DTC S PSBNCT=X
.F PSBZ=1:1:PSBNCT S X1=PSBCNTST S X2=1 D C^%DTC S PSBCNTST=X D
..I (PSBX["V")!(PSBX'["V") D
...I PSBCNTST'>(PSBOST\1) S ^TMP("PSB",$J,"ORDERS",PSBONX,"NTDUE",PSBCNTST)=""
...;add check for admin time before start time in PSB*3*57
...S PSBADST1=$E($P($G(PSBADST),"-",$L($G(PSBADST),"-"))_"00",1,4),PSBOST1=$E($P(PSBOST,".",2)_"0000",1,4) ;PSB*3*67
...I PSBCNTST=(PSBOST\1)&(PSBADST1>=PSBOST1) K ^TMP("PSB",$J,"ORDERS",PSBONX,"NTDUE",PSBCNTST) ;PSB*3*67 - PSB*3*76 adds "=" for stop date/time check
...I PSBCNTST=(PSBOST\1),'$P($G(PSBADST),"-") K ^TMP("PSB",$J,"ORDERS",PSBONX,"NTDUE",PSBCNTST) ;PSB*3*67
...I PSBCNTST>(PSBOSP\1) S ^TMP("PSB",$J,"ORDERS",PSBONX,"NTDUE",PSBCNTST)=""
...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)=""
..S PSBDODD=""
..I (PSBFREQ#1440'=0),(1440#PSBFREQ'=0) S PSBDODD=1
..I ((PSBX'["V")!(PSBVALB="1")),((PSBDODD="1")&(PSBADST'="")) S ^TMP("PSB",$J,"ORDERS",PSBONX,"NTDUE",PSBCNTST)=""
..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
.S (PSBYES,PSBODD,PSBFLAG,PSBYTFN,PSBDAYN)=0
.S:$$PSBDCHK1^PSBVT1(PSBSCH) PSBYES=1,PSBDAYN=1
.I PSBYES,PSBADST="",PSBSCHT'="O",PSBSCHT'="OC",PSBSCHT'="P" Q
.F I=1:1 Q:$P(PSBSCH,"-",I)="" I $P(PSBSCH,"-",I)?2N!($P(PSBSCH,"-",I)?4N) S PSBYES=1,PSBYTFN=1
.I (PSBFREQ="O")!(PSBTYPE="P") S PSBYES=1
.I (PSBFREQ#1440'=0),(1440#PSBFREQ'=0) S PSBODD=1
.;flg / admn t
.S:PSBONX["U" PSBFLAG=1
.I PSBIVT="A" S PSBADST="0000"
.I PSBIVT="H" S PSBADST="0000"
.I PSBIVT="C",PSBCHEMT="P" S:PSBADST="" PSBFLAG=1
.I PSBIVT="C",PSBISYR=1 S:PSBADST="" PSBFLAG=1
.I PSBIVT="C",PSBCHEMT="A" S PSBADST="0000"
.I PSBIVT="C",PSBISYR=0 S PSBADST="0000"
.I PSBIVT="P",($G(PSBADST)=0) S:PSBADST="" PSBFLAG=1
.I PSBIVT="P" S:PSBADST="" PSBFLAG=1
.I PSBIVT="S",PSBISYR=0 S PSBADST="0000"
.I PSBIVT="S",PSBISYR=1 S:PSBADST="" PSBFLAG=1
.I PSBFREQ="D" S PSBFREQ=""
.I 'PSBYES,PSBADST="",PSBFREQ<1 Q
.S (PSBEE,PSBZZ)=0
.I (PSBVALB="1")!(PSBX'["V") D Q:(PSBEE!PSBZZ)=1
..I PSBSCHT="C",PSBYTFN="1",PSBADST="" S PSBEE=1
..I PSBSCHT="C",PSBDAYN'="1",PSBYTFN'="1",PSBADST'="",PSBFREQ<1 S PSBZZ=1
.I 'PSBODD,PSBFLAG,PSBTYPE="C",PSBADST="" S PSBADST=$$GETADMIN^PSBVDLU1(DFN,PSBONX,PSBOST,PSBFREQ,PSBSTOP)
.E I PSBADST'="" K ^TMP("PSB",$J,"GETADMIN") S ^TMP("PSB",$J,"GETADMIN",0)=PSBADST
.;Calc adm/frq
.S PSBDT=PSBSTRT
.K PSBO,^UTILITY($J)
.F X=1:1:8 S PSBO(X)=""
.S DIWL=0,DIWR=32,DIWF="C32"
.S X=$P(PSBOSTX," ")_" "_$P(PSBOSPX," ") D ^DIWP
.S X="@"_$P(PSBOSTX," ",3)_" @"_$P(PSBOSPX," ",3)_" " D ^DIWP
.S X="" D ^DIWP
.S X=PSBOITX D ^DIWP
.; DD,SOL,ADD
.S X=""
.F Y=0:0 S Y=$O(PSBDDA(Y)) Q:'Y S X=X_$S(X]"":", ",1:"")_$P(PSBDDA(Y),U,3)
.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)
.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)
.S X=" "_X,DIWF="I2C32" D ^DIWP S DIWF="C32"
.S PSBTXT=" Give: "_PSBDOSE_" "_PSBMRAB_" "_PSBSCH_" "_PSBIFR
.F S PSBWORD=$P(PSBTXT," ",1),PSBTXT=$P(PSBTXT," ",2,250) D Q:PSBTXT=""
..F Q:'$L(PSBWORD) S X=$E(PSBWORD,1,30),PSBWORD=$E(PSBWORD,30,250) D ^DIWP
.K ^TMP("PSJ",$J) D EN^PSJBCMA2(DFN,PSBX) I ^TMP("PSJ",$J,0)'=-1 D ;get activity log
..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
...Q:X["EDITED"!(X["VERIF") ;
...S:$P(X,U,4)["PLACED ON HOLD" PSBHLDFL=1 ;Set Hold Flag
...S:$P(X,U,4)["TAKEN OFF HOLD" PSBHLDFL=0 ;Remove Hold Flag
...S Z=0
...I X'["OFF HOLD",X'["UNHOLD",X'["REINSTATE" S Z=1 ; inc iv's
...S PSBHLDX=PSBHLDX+$S(Z>0:1,1:0)
...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
..F PSBHLDX=1:1 S X=$G(PSBHLD(PSBHLDX)) Q:'X D ;if a hold index - process
...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.
...Q:PSBHLDN>PSBSTOP Q:(PSBHLDF<PSBSTRT)&(PSBHLDF'="")
...F PSBHLDT=PSBSTRT\1:1:PSBSTOP\1 I (PSBHLDT'<(PSBHLDN\1)),(PSBHLDT'>PSBSTOP) D
....I X["DISCONTINUED" K ^TMP("PSB",$J,"ORDERS",PSBONX,"HOLD",PSBHLDT) S ^TMP("PSB",$J,"ORDERS",PSBONX,"DISC",PSBHLDT)=""
....I (X["HOLD")&($G(PSBHLDFL))&((PSBHLDN\1)'>PSBHLDT)&((PSBHLDF'<PSBHLDT)!(PSBHLDF="")) S ^TMP("PSB",$J,"ORDERS",PSBONX,"HOLD",PSBHLDT)="" ;Check additional flag for PSB*3*57
....I X["REINSTATE" K ^TMP("PSB",$J,"ORDERS",PSBONX,"DISC",PSBHLDT) I PSBOSTS="H" S ^TMP("PSB",$J,"ORDERS",PSBONX,"HOLD",PSBHLDT)=""
...F PSBHLDXP=1:10:$P(PSBHLD(PSBHLDX),U,11)]""+10 D
....S PSBDESC=$P(PSBHLD(PSBHLDX),U,PSBHLDXP+3),X=$S(PSBDESC["DISCONTINUE":"***",1:"")
....S X=" "_X_PSBDESC D ^DIWP ;output activity text
....S X="",PSBHLDI=$P(PSBHLD(PSBHLDX),U,PSBHLDXP+4) I PSBHLDI'="" S X=$$GET1^DIQ(200,PSBHLDI,"INITIAL")
....S:X="" X="99" ;no init present
....I X'="99" S X=" "_X D ^DIWP ;get init & store
....S Y=$P(PSBHLD(PSBHLDX),U,PSBHLDXP) D DD^%DT S X=Y D ^DIWP ;format hold date / write
..K PSBHLD,PSBHLDF,PSBHLDN,PSBHLDT,PSBHLDX,PSBHLDXP,PSBHLDI,PSBDISX,PSBDISC,PSBDISXP,PSBDISI,PSBDIST,PSBDISN,PSBDESC
.F X=0:0 S X=$O(^UTILITY($J,"W",0,X)) Q:'X S PSBO(X)=$G(^(X,0)) D
.;
.;Insert removal times print text, insure 4 digit times *83
.; if removal time null, probably due to MRR type 1 so calculate
.I $G(PSBRMST)]"" S PSBRMST=$$CNVRT4^PSBUTL(PSBRMST,"-")
.I PSBMRRFL,$G(PSBRMST)="" S PSBRMST=$$REMSTR^PSBUTL(PSBADST,PSBDOA,PSBSCHT,PSBOSP,PSBOPRSP)
.D:$G(PSBRMST)]""
..S X=$O(PSBO(""),-1)+1
..F Q=1:1:$L(PSBRMST,"-") D
...I Q=1 S PSBO(X)=" Removal Times: "_$P(PSBRMST,"-",Q) Q
...S X=X+1,PSBO(X)=" "_$P(PSBRMST,"-",Q)
.;
.S X=$O(PSBO(""),-1) S X=$S(X<8:8,1:X+1)
.S PSBO(X)=" RPH: "_PSBVPHI_" RN: "_PSBVNI
.S PSBVAL=$$IVPTAB^PSBVDLU3(PSBOTYP,PSBIVT,PSBISYR,PSBCHEMT,PSBIVPSH)
.I PSBODD="1",PSBADST'="" D
..I (PSBVAL="1")!(PSBX'["V") D ;checks iv/pb and u dose
...S PSBO(X+1)=""
...S PSBO(X+2)="NOTE - ODD SCHEDULE NO LONGER",PSBO(X+3)=" ALLOWS ADMIN TIMES."
.K ^UTILITY($J)
. ;*70 If no location, and not inpatient, and Manual Med Entry, relay this information
.S PSBO(0)=$S(PSBCLINIC]"":PSBCLINIC,1:"INPATIENT") ;clinic nam *70
.S XORDERS=$S(PSBO(0)="INPATIENT":1,1:2) ;IM or CO *70
.M ^TMP("PSB",$J,"ORDERS",PSBX,"INST")=PSBO
.D:PSBTYPE="C"
..F D Q:PSBDT>PSBSTOP
...S X=PSBDT D H^%DTC S PSBWEEK=%H
...S ^TMP("PSB",$J,PSBWEEK,PSBONX)=""
...; Odd schd - msg
...S PSBIDOW=0 I PSBONX["U"!("PCS"[PSBIVT) S PSBIDOW=1
...I PSBADST="",PSBIDOW,(PSBODD) D
....S ^TMP("PSB",$J,"ORDERS",PSBONX,"AT",0)=7
....S ^TMP("PSB",$J,"ORDERS",PSBONX,"AT",1)="odd"
....S ^TMP("PSB",$J,"ORDERS",PSBONX,"AT",2)="sched"
....S ^TMP("PSB",$J,"ORDERS",PSBONX,"AT",3)=$E(PSBSCH,1,5)
....S ^TMP("PSB",$J,"ORDERS",PSBONX,"AT",4)="no"
....S ^TMP("PSB",$J,"ORDERS",PSBONX,"AT",5)="fixed"
....S ^TMP("PSB",$J,"ORDERS",PSBONX,"AT",6)="admin"
....S ^TMP("PSB",$J,"ORDERS",PSBONX,"AT",7)="times"
...I PSBADST'="",PSBADST'="0000",+$G(PSBFREQ)>0,+$G(PSBFREQ)<45 D
....S ^TMP("PSB",$J,"ORDERS",PSBONX,"AT",0)=5
....S ^TMP("PSB",$J,"ORDERS",PSBONX,"AT",1)="Due"
....S ^TMP("PSB",$J,"ORDERS",PSBONX,"AT",2)="every"
....S ^TMP("PSB",$J,"ORDERS",PSBONX,"AT",3)=$E(PSBFREQ,1,5)
....S ^TMP("PSB",$J,"ORDERS",PSBONX,"AT",4)="mins."
....S ^TMP("PSB",$J,"ORDERS",PSBONX,"AT",5)=" "
...S PSBATCNT=0 ; # times to print...
...I PSBADST'="",((+$G(PSBFREQ)>44)!(PSBFREQ="")!(PSBADST="0000")) F PSBXX=0:1 Q:$G(^TMP("PSB",$J,"GETADMIN",PSBXX))="" D
....S PSBADST2=$G(^TMP("PSB",$J,"GETADMIN",PSBXX))
....F Y=1:1:$L(PSBADST2,"-") D
.....Q:($P(PSBADST2,"-",Y)'?2N)&($P(PSBADST2,"-",Y)'?4N) S PSBATCNT=PSBATCNT+1,^TMP("PSB",$J,"ORDERS",PSBONX,"AT",PSBATCNT)=$P(PSBADST2,"-",Y)
...;*70 Insert Xorders IM or CO flag (1 or 2) into Sort control
...I PSBADST'="",PSBFREQ>44 S ^TMP("PSB",$J,"ORDERS",PSBONX,"AT",0)=PSBATCNT
...S ^TMP("PSB",$J,PSBWEEK,"SORT",XORDERS,PSBTYPE,PSBOITX,PSBX)=""
...F PSBDOW=0:1:6 D Q:X>(PSBSTOP-1)
....S %H=PSBWEEK+PSBDOW D YMD^%DTC
....S ^TMP("PSB",$J,PSBWEEK,PSBONX,X,0)=0
....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))
...S %H=PSBWEEK+7 D YMD^%DTC S PSBDT=X
.D:PSBTYPE'="C"
..S X=PSBDT D H^%DTC S PSBWEEK=%H
..S (^TMP("PSB",$J,PSBWEEK,PSBONX),^TMP("PSB",$J,PSBWEEK,PSBONX,"AT",0))=""
..;*70 Insert Xorders IM or CO flag (1 or 2) into Sort control
..S ^TMP("PSB",$J,PSBWEEK,"SORT",XORDERS,PSBTYPE,PSBOITX,PSBX)=""
D EN^PSBOMH1
D EN^PSBOMH2
Q
INSTR S PSBINIT=PSBINIT_"*"
S PSBNAME=PSBNAME_"/"_$P(^PSB(53.79,PSBIEN,.9,$P(PSBDT,"."),0),U,3)_" "_$$GET1^DIQ(53.79,PSBIEN_",",.06)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSBOMH 11658 printed Apr 09, 2024@20:46:04 Page 2
PSBOMH ;BIRMINGHAM/EFC-MAH ;03/06/16 3:06pm
+1 ;;3.0;BAR CODE MED ADMIN;**5,9,38,57,67,68,70,76,83,116**;Mar 2004;Build 2
+2 ;Per VHA Directive 2004-038, this routine should not be modified.
+3 ;
+4 ; Reference/IA
+5 ; EN^PSJBCMA/2828
+6 ; EN^PSJBCMA2/2830
+7 ; File 200/10060
+8 ; ^DIWP/10011
+9 ;
+10 ;*68 - remove old special instruction text encoding, defer to PSBOMH2
+11 ;*70 - add Clinic name to PSBO array for printing on grid via PSBOMH2
+12 ; in ^TMP(""PSB",$J,"ORDERS",PSBX,"INST") global
+13 ;*83 - add remove logic to print RM and associated Gives in grid and
+14 ; also remove string in order summary area.
+15 ;
EN ; Called from DQ^PSBO
+1 ;*83
NEW PSBGBL,DFN,Q,X
+2 SET PSBGBL=$NAME(^TMP("PSBO",$JOB,"B"))
+3 FOR
SET PSBGBL=$QUERY(@PSBGBL)
if PSBGBL=""
QUIT
if $QSUBSCRIPT(PSBGBL,2)'=$JOB
QUIT
if $QSUBSCRIPT(PSBGBL,1)'["PSBO"
QUIT
Begin DoDot:1
+4 SET DFN=$QSUBSCRIPT(PSBGBL,5)
+5 SET (PSBSTRT,X)=$PIECE(PSBRPT(.1),U,6)
DO H^%DTC
SET PSBSTH=%H
+6 SET (PSBSTOP,X)=$PIECE(PSBRPT(.1),U,8)+.235959
DO H^%DTC
SET PSBSPH=%H
+7 SET PSBCNT=0
FOR I=PSBSTH:1:PSBSPH
SET PSBAR(I)=PSBSTH+((PSBCNT\7)*7)
SET PSBCNT=PSBCNT+1
+8 DO EN1
End DoDot:1
+9 KILL PSBCNT,PSBAR
+10 ;*83
DO CLEAN^PSBVT
+11 QUIT
EN1 ; Expects DFN,STRT,STOP
+1 ;*70
NEW PSBGBL,PSBHDR,PSBX,PSBFLAG,PSBHLDFL,PSBADST1,PSBOST1,PSBCLINIC,PSBORSTP
+2 KILL ^TMP("PSJ",$JOB),^TMP("PSB",$JOB)
+3 SET PSBEVDT=PSBSTRT
+4 DO EN^PSJBCMA(DFN,PSBSTRT)
+5 ;*70 Combind mode headers
NEW PSBCLINORD
SET PSBCLINORD=2
+6 ; No Ord
IF $GET(^TMP("PSJ",$JOB,1,0))=-1
Begin DoDot:1
+7 DO PT^PSBOHDR(DFN,.PSBHDR)
WRITE !!,"****NO MEDICATIONS FOUND****"
End DoDot:1
QUIT
+8 SET PSBX=""
+9 FOR
SET PSBX=$ORDER(^TMP("PSJ",$JOB,PSBX))
if PSBX=""
QUIT
Begin DoDot:1
+10 ; No Pnd
if $PIECE(^TMP("PSJ",$JOB,PSBX,0),U,3)?.N1"P"
QUIT
+11 SET PSBORSTP=$PIECE(^TMP("PSJ",$JOB,PSBX,1),U,5)
if $PIECE(^TMP("PSJ",$JOB,PSBX,1),U,15)>PSBORSTP
SET PSBORSTP=$PIECE(^TMP("PSJ",$JOB,PSBX,1),U,15)
+12 ;display orders active in date range of report
if PSBORSTP<PSBSTRT!($PIECE(^TMP("PSJ",$JOB,PSBX,1),U,4)>PSBSTOP)
QUIT
+13 SET X=$PIECE(^TMP("PSJ",$JOB,PSBX,1),U,2)
+14 SET ^TMP("PSB",$JOB,"ORDERS",$PIECE(^TMP("PSJ",$JOB,PSBX,0),U,3))=X
End DoDot:1
+15 ;No Orders
IF '$DATA(^TMP("PSB",$JOB,"ORDERS"))
Begin DoDot:1
+16 DO PT^PSBOHDR(DFN,.PSBHDR)
WRITE !!,"****NO MEDICATIONS FOUND****"
End DoDot:1
QUIT
+17 SET PSBMHND="PSBOMH"
+18 ; Act on Orders
+19 SET PSBX=""
FOR
SET PSBX=$ORDER(^TMP("PSB",$JOB,"ORDERS",PSBX))
if PSBX=""
QUIT
SET PSBTYPE=^(PSBX)
Begin DoDot:1
+20 if PSBTYPE'="C"
SET PSBTYPE="P"
+21 DO CLEAN^PSBVT
+22 DO PSJ1^PSBVT(DFN,PSBX)
+23 SET PSBCLINIC=PSBCLORD
+24 SET X1=((PSBEVDT)\1)
SET X2=-1
DO C^%DTC
SET PSBCNTST=X
+25 SET X1=((PSBSTOP)\1)
SET X2=1
DO C^%DTC
SET PSBXSTOP=X
+26 SET PSBVALB=""
+27 SET PSBVALB=$$IVPTAB^PSBVDLU3(PSBOTYP,PSBIVT,PSBISYR,PSBCHEMT,PSBIVPSH)
+28 SET PSBZ=""
+29 SET X1=PSBXSTOP
SET X2=PSBCNTST
DO ^%DTC
SET PSBNCT=X
+30 FOR PSBZ=1:1:PSBNCT
SET X1=PSBCNTST
SET X2=1
DO C^%DTC
SET PSBCNTST=X
Begin DoDot:2
+31 IF (PSBX["V")!(PSBX'["V")
Begin DoDot:3
+32 IF PSBCNTST'>(PSBOST\1)
SET ^TMP("PSB",$JOB,"ORDERS",PSBONX,"NTDUE",PSBCNTST)=""
+33 ;add check for admin time before start time in PSB*3*57
+34 ;PSB*3*67
SET PSBADST1=$EXTRACT($PIECE($GET(PSBADST),"-",$LENGTH($GET(PSBADST),"-"))_"00",1,4)
SET PSBOST1=$EXTRACT($PIECE(PSBOST,".",2)_"0000",1,4)
+35 ;PSB*3*67 - PSB*3*76 adds "=" for stop date/time check
IF PSBCNTST=(PSBOST\1)&(PSBADST1>=PSBOST1)
KILL ^TMP("PSB",$JOB,"ORDERS",PSBONX,"NTDUE",PSBCNTST)
+36 ;PSB*3*67
IF PSBCNTST=(PSBOST\1)
IF '$PIECE($GET(PSBADST),"-")
KILL ^TMP("PSB",$JOB,"ORDERS",PSBONX,"NTDUE",PSBCNTST)
+37 IF PSBCNTST>(PSBOSP\1)
SET ^TMP("PSB",$JOB,"ORDERS",PSBONX,"NTDUE",PSBCNTST)=""
+38 IF PSBCNTST=(PSBOSP\1)&($GET(^TMP("PSB",$JOB,"ORDERS",PSBONX,"NTDUE",PSBCNTST)))
KILL ^TMP("PSB",$JOB,"ORDERS",PSBONX,"NTDUE",PSBCNTST)
SET ^TMP("PSB",$JOB,"ORDERS",PSBONX,"NTDUE",PSBCNTST)=""
End DoDot:3
+39 SET PSBDODD=""
+40 IF (PSBFREQ#1440'=0)
IF (1440#PSBFREQ'=0)
SET PSBDODD=1
+41 IF ((PSBX'["V")!(PSBVALB="1"))
IF ((PSBDODD="1")&(PSBADST'=""))
SET ^TMP("PSB",$JOB,"ORDERS",PSBONX,"NTDUE",PSBCNTST)=""
+42 ;W t TMP
IF ((PSBX'["V")!(PSBVALB="1"))
IF ('$$OKAY^PSBVDLU1(PSBOST,PSBCNTST,PSBSCH,PSBON,PSBOITX,PSBFREQ,PSBOSTS))
SET ^TMP("PSB",$JOB,"ORDERS",PSBONX,"NTDUE",PSBCNTST)=""
End DoDot:2
+43 SET (PSBYES,PSBODD,PSBFLAG,PSBYTFN,PSBDAYN)=0
+44 if $$PSBDCHK1^PSBVT1(PSBSCH)
SET PSBYES=1
SET PSBDAYN=1
+45 IF PSBYES
IF PSBADST=""
IF PSBSCHT'="O"
IF PSBSCHT'="OC"
IF PSBSCHT'="P"
QUIT
+46 FOR I=1:1
if $PIECE(PSBSCH,"-",I)=""
QUIT
IF $PIECE(PSBSCH,"-",I)?2N!($PIECE(PSBSCH,"-",I)?4N)
SET PSBYES=1
SET PSBYTFN=1
+47 IF (PSBFREQ="O")!(PSBTYPE="P")
SET PSBYES=1
+48 IF (PSBFREQ#1440'=0)
IF (1440#PSBFREQ'=0)
SET PSBODD=1
+49 ;flg / admn t
+50 if PSBONX["U"
SET PSBFLAG=1
+51 IF PSBIVT="A"
SET PSBADST="0000"
+52 IF PSBIVT="H"
SET PSBADST="0000"
+53 IF PSBIVT="C"
IF PSBCHEMT="P"
if PSBADST=""
SET PSBFLAG=1
+54 IF PSBIVT="C"
IF PSBISYR=1
if PSBADST=""
SET PSBFLAG=1
+55 IF PSBIVT="C"
IF PSBCHEMT="A"
SET PSBADST="0000"
+56 IF PSBIVT="C"
IF PSBISYR=0
SET PSBADST="0000"
+57 IF PSBIVT="P"
IF ($GET(PSBADST)=0)
if PSBADST=""
SET PSBFLAG=1
+58 IF PSBIVT="P"
if PSBADST=""
SET PSBFLAG=1
+59 IF PSBIVT="S"
IF PSBISYR=0
SET PSBADST="0000"
+60 IF PSBIVT="S"
IF PSBISYR=1
if PSBADST=""
SET PSBFLAG=1
+61 IF PSBFREQ="D"
SET PSBFREQ=""
+62 IF 'PSBYES
IF PSBADST=""
IF PSBFREQ<1
QUIT
+63 SET (PSBEE,PSBZZ)=0
+64 IF (PSBVALB="1")!(PSBX'["V")
Begin DoDot:2
+65 IF PSBSCHT="C"
IF PSBYTFN="1"
IF PSBADST=""
SET PSBEE=1
+66 IF PSBSCHT="C"
IF PSBDAYN'="1"
IF PSBYTFN'="1"
IF PSBADST'=""
IF PSBFREQ<1
SET PSBZZ=1
End DoDot:2
if (PSBEE!PSBZZ)=1
QUIT
+67 IF 'PSBODD
IF PSBFLAG
IF PSBTYPE="C"
IF PSBADST=""
SET PSBADST=$$GETADMIN^PSBVDLU1(DFN,PSBONX,PSBOST,PSBFREQ,PSBSTOP)
+68 IF '$TEST
IF PSBADST'=""
KILL ^TMP("PSB",$JOB,"GETADMIN")
SET ^TMP("PSB",$JOB,"GETADMIN",0)=PSBADST
+69 ;Calc adm/frq
+70 SET PSBDT=PSBSTRT
+71 KILL PSBO,^UTILITY($JOB)
+72 FOR X=1:1:8
SET PSBO(X)=""
+73 SET DIWL=0
SET DIWR=32
SET DIWF="C32"
+74 SET X=$PIECE(PSBOSTX," ")_" "_$PIECE(PSBOSPX," ")
DO ^DIWP
+75 SET X="@"_$PIECE(PSBOSTX," ",3)_" @"_$PIECE(PSBOSPX," ",3)_" "
DO ^DIWP
+76 SET X=""
DO ^DIWP
+77 SET X=PSBOITX
DO ^DIWP
+78 ; DD,SOL,ADD
+79 SET X=""
+80 FOR Y=0:0
SET Y=$ORDER(PSBDDA(Y))
if 'Y
QUIT
SET X=X_$SELECT(X]"":", ",1:"")_$PIECE(PSBDDA(Y),U,3)
+81 FOR Y=0:0
SET Y=$ORDER(PSBADA(Y))
if 'Y
QUIT
SET X=X_$SELECT(X]"":", ",1:"")_$PIECE(PSBADA(Y),U,3)_" "_$PIECE(PSBADA(Y),U,4)_$PIECE(PSBADA(Y),U,5)
+82 FOR Y=0:0
SET Y=$ORDER(PSBSOLA(Y))
if 'Y
QUIT
SET X=X_$SELECT(X]"":", ",1:"")_$PIECE(PSBSOLA(Y),U,3)_" "_$PIECE(PSBSOLA(Y),U,4)
+83 SET X=" "_X
SET DIWF="I2C32"
DO ^DIWP
SET DIWF="C32"
+84 SET PSBTXT=" Give: "_PSBDOSE_" "_PSBMRAB_" "_PSBSCH_" "_PSBIFR
+85 FOR
SET PSBWORD=$PIECE(PSBTXT," ",1)
SET PSBTXT=$PIECE(PSBTXT," ",2,250)
Begin DoDot:2
+86 FOR
if '$LENGTH(PSBWORD)
QUIT
SET X=$EXTRACT(PSBWORD,1,30)
SET PSBWORD=$EXTRACT(PSBWORD,30,250)
DO ^DIWP
End DoDot:2
if PSBTXT=""
QUIT
+87 ;get activity log
KILL ^TMP("PSJ",$JOB)
DO EN^PSJBCMA2(DFN,PSBX)
IF ^TMP("PSJ",$JOB,0)'=-1
Begin DoDot:2
+88 ;loop activities
SET (PSBDISX,PSBHLDX)=0
FOR I=1:1:$PIECE(^TMP("PSJ",$JOB,0),U,4)
SET X=$GET(^TMP("PSJ",$JOB,I,1))
Begin DoDot:3
+89 ;
if X["EDITED"!(X["VERIF")
QUIT
+90 ;Set Hold Flag
if $PIECE(X,U,4)["PLACED ON HOLD"
SET PSBHLDFL=1
+91 ;Remove Hold Flag
if $PIECE(X,U,4)["TAKEN OFF HOLD"
SET PSBHLDFL=0
+92 SET Z=0
+93 ; inc iv's
IF X'["OFF HOLD"
IF X'["UNHOLD"
IF X'["REINSTATE"
SET Z=1
+94 SET PSBHLDX=PSBHLDX+$SELECT(Z>0:1,1:0)
+95 ;set up for multiple on hold entries save start & stop as pair if exists
SET $PIECE(PSBHLD(PSBHLDX),U,$SELECT(Z>0:1,1:11))=^TMP("PSJ",$JOB,I,1)
End DoDot:3
+96 ;if a hold index - process
FOR PSBHLDX=1:1
SET X=$GET(PSBHLD(PSBHLDX))
if 'X
QUIT
Begin DoDot:3
+97 ;get on/off hold, dates, IEN number(for UD orders) of person.
SET PSBHLDN=$PIECE(PSBHLD(PSBHLDX),U,1)
SET PSBHLDF=$PIECE(PSBHLD(PSBHLDX),U,11)
+98 if PSBHLDN>PSBSTOP
QUIT
if (PSBHLDF<PSBSTRT)&(PSBHLDF'="")
QUIT
+99 FOR PSBHLDT=PSBSTRT\1:1:PSBSTOP\1
IF (PSBHLDT'<(PSBHLDN\1))
IF (PSBHLDT'>PSBSTOP)
Begin DoDot:4
+100 IF X["DISCONTINUED"
KILL ^TMP("PSB",$JOB,"ORDERS",PSBONX,"HOLD",PSBHLDT)
SET ^TMP("PSB",$JOB,"ORDERS",PSBONX,"DISC",PSBHLDT)=""
+101 ;Check additional flag for PSB*3*57
IF (X["HOLD")&($GET(PSBHLDFL))&((PSBHLDN\1)'>PSBHLDT)&((PSBHLDF'<PSBHLDT)!(PSBHLDF=""))
SET ^TMP("PSB",$JOB,"ORDERS",PSBONX,"HOLD",PSBHLDT)=""
+102 IF X["REINSTATE"
KILL ^TMP("PSB",$JOB,"ORDERS",PSBONX,"DISC",PSBHLDT)
IF PSBOSTS="H"
SET ^TMP("PSB",$JOB,"ORDERS",PSBONX,"HOLD",PSBHLDT)=""
End DoDot:4
+103 FOR PSBHLDXP=1:10:$PIECE(PSBHLD(PSBHLDX),U,11)]""+10
Begin DoDot:4
+104 SET PSBDESC=$PIECE(PSBHLD(PSBHLDX),U,PSBHLDXP+3)
SET X=$SELECT(PSBDESC["DISCONTINUE":"***",1:"")
+105 ;output activity text
SET X=" "_X_PSBDESC
DO ^DIWP
+106 SET X=""
SET PSBHLDI=$PIECE(PSBHLD(PSBHLDX),U,PSBHLDXP+4)
IF PSBHLDI'=""
SET X=$$GET1^DIQ(200,PSBHLDI,"INITIAL")
+107 ;no init present
if X=""
SET X="99"
+108 ;get init & store
IF X'="99"
SET X=" "_X
DO ^DIWP
+109 ;format hold date / write
SET Y=$PIECE(PSBHLD(PSBHLDX),U,PSBHLDXP)
DO DD^%DT
SET X=Y
DO ^DIWP
End DoDot:4
End DoDot:3
+110 KILL PSBHLD,PSBHLDF,PSBHLDN,PSBHLDT,PSBHLDX,PSBHLDXP,PSBHLDI,PSBDISX,PSBDISC,PSBDISXP,PSBDISI,PSBDIST,PSBDISN,PSBDESC
End DoDot:2
+111 FOR X=0:0
SET X=$ORDER(^UTILITY($JOB,"W",0,X))
if 'X
QUIT
SET PSBO(X)=$GET(^(X,0))
Begin DoDot:2
End DoDot:2
+112 ;
+113 ;Insert removal times print text, insure 4 digit times *83
+114 ; if removal time null, probably due to MRR type 1 so calculate
+115 IF $GET(PSBRMST)]""
SET PSBRMST=$$CNVRT4^PSBUTL(PSBRMST,"-")
+116 IF PSBMRRFL
IF $GET(PSBRMST)=""
SET PSBRMST=$$REMSTR^PSBUTL(PSBADST,PSBDOA,PSBSCHT,PSBOSP,PSBOPRSP)
+117 if $GET(PSBRMST)]""
Begin DoDot:2
+118 SET X=$ORDER(PSBO(""),-1)+1
+119 FOR Q=1:1:$LENGTH(PSBRMST,"-")
Begin DoDot:3
+120 IF Q=1
SET PSBO(X)=" Removal Times: "_$PIECE(PSBRMST,"-",Q)
QUIT
+121 SET X=X+1
SET PSBO(X)=" "_$PIECE(PSBRMST,"-",Q)
End DoDot:3
End DoDot:2
+122 ;
+123 SET X=$ORDER(PSBO(""),-1)
SET X=$SELECT(X<8:8,1:X+1)
+124 SET PSBO(X)=" RPH: "_PSBVPHI_" RN: "_PSBVNI
+125 SET PSBVAL=$$IVPTAB^PSBVDLU3(PSBOTYP,PSBIVT,PSBISYR,PSBCHEMT,PSBIVPSH)
+126 IF PSBODD="1"
IF PSBADST'=""
Begin DoDot:2
+127 ;checks iv/pb and u dose
IF (PSBVAL="1")!(PSBX'["V")
Begin DoDot:3
+128 SET PSBO(X+1)=""
+129 SET PSBO(X+2)="NOTE - ODD SCHEDULE NO LONGER"
SET PSBO(X+3)=" ALLOWS ADMIN TIMES."
End DoDot:3
End DoDot:2
+130 KILL ^UTILITY($JOB)
+131 ;*70 If no location, and not inpatient, and Manual Med Entry, relay this information
+132 ;clinic nam *70
SET PSBO(0)=$SELECT(PSBCLINIC]"":PSBCLINIC,1:"INPATIENT")
+133 ;IM or CO *70
SET XORDERS=$SELECT(PSBO(0)="INPATIENT":1,1:2)
+134 MERGE ^TMP("PSB",$JOB,"ORDERS",PSBX,"INST")=PSBO
+135 if PSBTYPE="C"
Begin DoDot:2
+136 FOR
Begin DoDot:3
+137 SET X=PSBDT
DO H^%DTC
SET PSBWEEK=%H
+138 SET ^TMP("PSB",$JOB,PSBWEEK,PSBONX)=""
+139 ; Odd schd - msg
+140 SET PSBIDOW=0
IF PSBONX["U"!("PCS"[PSBIVT)
SET PSBIDOW=1
+141 IF PSBADST=""
IF PSBIDOW
IF (PSBODD)
Begin DoDot:4
+142 SET ^TMP("PSB",$JOB,"ORDERS",PSBONX,"AT",0)=7
+143 SET ^TMP("PSB",$JOB,"ORDERS",PSBONX,"AT",1)="odd"
+144 SET ^TMP("PSB",$JOB,"ORDERS",PSBONX,"AT",2)="sched"
+145 SET ^TMP("PSB",$JOB,"ORDERS",PSBONX,"AT",3)=$EXTRACT(PSBSCH,1,5)
+146 SET ^TMP("PSB",$JOB,"ORDERS",PSBONX,"AT",4)="no"
+147 SET ^TMP("PSB",$JOB,"ORDERS",PSBONX,"AT",5)="fixed"
+148 SET ^TMP("PSB",$JOB,"ORDERS",PSBONX,"AT",6)="admin"
+149 SET ^TMP("PSB",$JOB,"ORDERS",PSBONX,"AT",7)="times"
End DoDot:4
+150 IF PSBADST'=""
IF PSBADST'="0000"
IF +$GET(PSBFREQ)>0
IF +$GET(PSBFREQ)<45
Begin DoDot:4
+151 SET ^TMP("PSB",$JOB,"ORDERS",PSBONX,"AT",0)=5
+152 SET ^TMP("PSB",$JOB,"ORDERS",PSBONX,"AT",1)="Due"
+153 SET ^TMP("PSB",$JOB,"ORDERS",PSBONX,"AT",2)="every"
+154 SET ^TMP("PSB",$JOB,"ORDERS",PSBONX,"AT",3)=$EXTRACT(PSBFREQ,1,5)
+155 SET ^TMP("PSB",$JOB,"ORDERS",PSBONX,"AT",4)="mins."
+156 SET ^TMP("PSB",$JOB,"ORDERS",PSBONX,"AT",5)=" "
End DoDot:4
+157 ; # times to print...
SET PSBATCNT=0
+158 IF PSBADST'=""
IF ((+$GET(PSBFREQ)>44)!(PSBFREQ="")!(PSBADST="0000"))
FOR PSBXX=0:1
if $GET(^TMP("PSB",$JOB,"GETADMIN",PSBXX))=""
QUIT
Begin DoDot:4
+159 SET PSBADST2=$GET(^TMP("PSB",$JOB,"GETADMIN",PSBXX))
+160 FOR Y=1:1:$LENGTH(PSBADST2,"-")
Begin DoDot:5
+161 if ($PIECE(PSBADST2,"-",Y)'?2N)&($PIECE(PSBADST2,"-",Y)'?4N)
QUIT
SET PSBATCNT=PSBATCNT+1
SET ^TMP("PSB",$JOB,"ORDERS",PSBONX,"AT",PSBATCNT)=$PIECE(PSBADST2,"-",Y)
End DoDot:5
End DoDot:4
+162 ;*70 Insert Xorders IM or CO flag (1 or 2) into Sort control
+163 IF PSBADST'=""
IF PSBFREQ>44
SET ^TMP("PSB",$JOB,"ORDERS",PSBONX,"AT",0)=PSBATCNT
+164 SET ^TMP("PSB",$JOB,PSBWEEK,"SORT",XORDERS,PSBTYPE,PSBOITX,PSBX)=""
+165 FOR PSBDOW=0:1:6
Begin DoDot:4
+166 SET %H=PSBWEEK+PSBDOW
DO YMD^%DTC
+167 SET ^TMP("PSB",$JOB,PSBWEEK,PSBONX,X,0)=0
+168 IF '$DATA(^TMP("PSB",$JOB,PSBWEEK,"HDR",X))
SET ^TMP("PSB",$JOB,PSBWEEK,"HDR",X)=$EXTRACT(X,4,5)_"/"_$EXTRACT(X,6,7)_"/"_(1700+$EXTRACT(X,1,3))
End DoDot:4
if X>(PSBSTOP-1)
QUIT
+169 SET %H=PSBWEEK+7
DO YMD^%DTC
SET PSBDT=X
End DoDot:3
if PSBDT>PSBSTOP
QUIT
End DoDot:2
+170 if PSBTYPE'="C"
Begin DoDot:2
+171 SET X=PSBDT
DO H^%DTC
SET PSBWEEK=%H
+172 SET (^TMP("PSB",$JOB,PSBWEEK,PSBONX),^TMP("PSB",$JOB,PSBWEEK,PSBONX,"AT",0))=""
+173 ;*70 Insert Xorders IM or CO flag (1 or 2) into Sort control
+174 SET ^TMP("PSB",$JOB,PSBWEEK,"SORT",XORDERS,PSBTYPE,PSBOITX,PSBX)=""
End DoDot:2
End DoDot:1
+175 DO EN^PSBOMH1
+176 DO EN^PSBOMH2
+177 QUIT
INSTR SET PSBINIT=PSBINIT_"*"
+1 SET PSBNAME=PSBNAME_"/"_$PIECE(^PSB(53.79,PSBIEN,.9,$PIECE(PSBDT,"."),0),U,3)_" "_$$GET1^DIQ(53.79,PSBIEN_",",.06)
+2 QUIT
