PSBVDLPB ;BIRMINGHAM/EFC-BCMA IV VIRTUAL DUE LIST ;Mar 2004
;;3.0;BAR CODE MED ADMIN;**11,13,38,32**;Mar 2004;Build 32
;Per VHA Directive 2004-038 (or future revisions regarding same), this routine should not be modified.
;
; Reference/IA
; EN^PSJBCMA/2828
; $$GET^XPAR/2263
; File 200/10060
;
EN(DFN,PSBDT) ; Default Order List Return for Today
;
; RPC: PSB GETORDERLIST
;
; Description:
; Returns the current IV order set for today to display on the
; client VDL
;
;
N PSBDATA,PSBTBOUT
S PSBTBOUT=0,PSBDOADD=0
S:PSBTAB="PBTAB" PSBDOADD=1
;
;This routine now re-uses the ^TMP("PSJ",$J global built in PSBVDLTB
;
I $G(^TMP("PSJ",$J,1,0))=-1 Q ; No orders
;
F PSBX=0:0 S PSBX=$O(^TMP("PSJ",$J,PSBX)) Q:('PSBX)!(PSBTBOUT) D
.D CLEAN^PSBVT,PSJ^PSBVT(PSBX)
.;
.; << Standard checks for ALL orders >>
.;
.Q:PSBONX["P" ; No Pending Orders
.Q:'$$IVPTAB^PSBVDLU3(PSBOTYP,PSBIVT,PSBISYR,PSBCHEMT,PSBIVPSH)
.Q:PSBOST>PSBWADM ; Order Start Date/Time > admin window
.Q:PSBOSP<PSBWBEG ; For all Order Stop Date/Time < vdl window
.Q:PSBOSTS["D" ; Is it DC'd
.Q:PSBNGF ; Is it marked DO NOT GIVE!
.; Non One-Times with stop date/time < now
.;
.D NOW^%DTC
.Q:PSBOSP<%
.;
.; include Active, Renewed, ReInstated and On Call
.; (Is it not one time)&(Is it not active or renewed or On Call)
.Q:PSBSCHT'="O"&((PSBOSTS'="A")&(PSBOSTS'="R")&(PSBOSTS'="RE")&(PSBOSTS'="O")&(PSBOSTS'="H"))
.;
.; Is One Time Given
.;
.I PSBSCHT="O" D Q:PSBGVN
..S (PSBGVN,X,Y)=""
..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 S:($P(^PSB(53.79,Y,.1),U)=PSBONX)&($P(^PSB(53.79,Y,0),U,9)="G") PSBGVN=1,(X,Y)=0
.;
.; How long does One Time remain on VDL ?
.S PSBRMN=1
.I PSBSCHT="O",PSBOSP'=PSBOST,%>PSBOSP S PSBRMN=0
.Q:'PSBRMN
.;
.; Is On-Call Given, Can it be given more than once
.;
.I PSBSCHT="OC" D Q:PSBGVN&('$$GET^XPAR("DIV","PSB ADMIN MULTIPLE ONCALL"))
..S (PSBGVN,X,Y)=""
..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 S:($P(^PSB(53.79,Y,.1),U)=PSBON)&($P(^PSB(53.79,Y,0),U,9)="G") PSBGVN=1,(X,Y)=0
.;
.S PSBSTRT=PSBOST ; Order Start Date/Time
.S PSBSTOP=PSBOSP ; Order Stop Date/Time
.;
.S PSBREC=""
.S $P(PSBREC,U,1)=DFN ; dfn
.S $P(PSBREC,U,2)=PSBONX ; Order
.S $P(PSBREC,U,3)=+PSBON ; order ien
.S $P(PSBREC,U,4)=PSBOTYP ; iv/ud/pending
.S $P(PSBREC,U,5)=PSBSCHT ; schedule type
.S $P(PSBREC,U,6)=PSBSCH ; schedule
.S Y=""
.S:PSBSM Y="SM"
.S:PSBHSM Y="HSM"
.S $P(PSBREC,U,7)=Y ; self med
.S $P(PSBREC,U,8)=PSBOITX ; drugname
.S $P(PSBREC,U,9)=PSBDOSE_" "_PSBIFR ; dosage
.S $P(PSBREC,U,10)=PSBMR ;med route
.; Last Given from the AOIP X-Ref - not given status not excepted
.S (YZ,PSBSTUS,PSBADMER)="" K PSBHSTA,PSBHSTAX
.F XZ=1:1:20 S YZ=$O(^PSB(53.79,"AOIP",DFN,PSBOIT,YZ),-1),(PSBCNT,PSBFLAG)=0 Q:YZ="" D
..S:YZ>0 $P(PSBREC,U,11)=YZ
..S X="" F S X=$O(^PSB(53.79,"AOIP",DFN,PSBOIT,YZ,X),-1) Q:X="" D
...K PSBLCK L +^PSB(53.79,X):1 I L -^PSB(53.79,X) S PSBLCK=1
...S PSBSTUS=$P(^PSB(53.79,X,0),U,9)
...I $G(PSBSTUS)="" S:'$G(PSBLCK) PSBSTUS="X" I $G(PSBLCK) S PSBADMER=1 D
....K PSBPARM3,PSBPARM5,PSBPARM6,PSBPARM7
....S PSBPARM6=X,Y=$P(^PSB(53.79,X,.1),U,3) D DD^%DT S PSBPARM3=Y,Y=$P(^PSB(53.79,X,0),U,6) D DD^%DT S PSBPARM5=Y
....S PSBPARM7=$P(^PSB(53.79,X,0),U,7) S PSBPARM7="( # "_PSBPARM7_" ) "_$$GET1^DIQ(200,PSBPARM7_",",.01)
....K PSBXTMP S PSBXTMP=PSBONX
....D CLEAN^PSBVT,PSJ1^PSBVT(DFN,$$GET1^DIQ(53.79,PSBPARM6_",",.11))
....D ERROR^PSBMLU(PSBONX,PSBOITX,DFN,PSBPARM3_" admin's ACTION STATUS is ""UNKNOWN"".",PSBSCH,PSBPARM5,PSBPARM6,PSBPARM7) ; SEND AN E-MAIL
....D CLEAN^PSBVT,PSJ1^PSBVT(DFN,PSBXTMP) ;Reset Variables
....S X=PSBPARM6 K PSBPARM3,PSBPARM5,PSBPARM6,PSBPARM7
...K PSBLCK S:(PSBSTUS']"") PSBSTUS="U" I PSBSTUS'="N",($G(PSBSTUS)'="X") S PSBFLAG=1,PSBHSTA(YZ,$G(PSBSTUS))="ORIG"_U_X
...D:PSBSTUS="N"
....S $P(PSBREC,U,11)=""
....S Z="" F S Z=$O(^PSB(53.79,X,.9,Z),-1) Q:'Z Q:PSBFLAG=1 S PSBDATA=$G(^(Z,0)) D
.....I (PSBDATA["Set to 'NOT GIVEN'")!(PSBDATA["Set to 'GIVEN'")!(PSBDATA["Set to 'REFUSED'")!(PSBDATA["Set to 'HELD'")!(PSBDATA["Set to 'MISSING DOSE'")!(PSBDATA["Set to 'REMOVED'") S PSBCNT=PSBCNT+1
.....I (PSBDATA["STATUS 'HELD'")!(PSBDATA["STATUS 'GIVEN'")!(PSBDATA["STATUS 'REFUSED'")!(PSBDATA["STATUS 'MISSING DOSE'")!(PSBDATA["STATUS 'REMOVED'") S PSBCNT=PSBCNT+1
.....I PSBCNT#2=0,PSBDATA["'REFUSED'" S PSBSTUS="R" D LAST^PSBVDLU1
.....I PSBCNT#2=0,PSBDATA["'HELD'" S PSBSTUS="H" D LAST^PSBVDLU1
.....I PSBCNT#2=0,PSBDATA["'MISSING DOSE'" S PSBSTUS="M" D LAST^PSBVDLU1
.....I PSBCNT#2=0,PSBDATA["'REMOVED'" S PSBSTUS="RM" D LAST^PSBVDLU1
.....I PSBFLAG=1,'$D(PSBHSTA($P(PSBREC,U,11),$G(PSBSTUS))) S PSBHSTA($P(PSBREC,U,11),$G(PSBSTUS))=Z_U_X
.I $D(PSBHSTA) S $P(PSBREC,U,11)=$O(PSBHSTA(""),-1),PSBSTUS=$O(PSBHSTA($P(PSBREC,U,11),""),-1) M PSBHSTAX(PSBOIT)=PSBHSTA K PSBHSTA ;last action date/time
.S $P(PSBREC,U,12)="" ;med log ien inserted below for actual date
.S $P(PSBREC,U,13)="" ;med log status inserted below for actual date
.S $P(PSBREC,U,14)="" ;admin date inserted below
.S $P(PSBREC,U,15)=PSBOIT ; OI Pointer
.S $P(PSBREC,U,16)=PSBNJECT ;Set injectable med route flag
.; Variable dosage entered as ####-####?
.I $P(PSBREC,U,9)?1.4N1"-"1.4N.E S $P(PSBREC,U,17)=1
.E S $P(PSBREC,U,17)=0
.S $P(PSBREC,U,18)=PSBIVT ;IV TYPE - dosage form
.S $P(PSBREC,U,20)=$S((PSBSTUS="X")!(PSBSTUS="N"):"",1:PSBSTUS) ;last action status
.S $P(PSBREC,U,21)=PSBOST
.S $P(PSBREC,U,22)=PSBOSTS
.S $P(PSBREC,U,26)=PSBSTOP
.S $P(PSBREC,U,27)=$$LASTG^PSBCSUTL(DFN,PSBOIT)
.;
.; Gather Dispense Drugs
.D NOW^%DTC
.S (PSBDDS,PSBSOLS,PSBADDS)="0"
.F Y=0:0 S Y=$O(PSBDDA(Y)) Q:'Y D
..Q:$P(PSBDDA(Y),U,4)&($P(PSBDDA(Y),U,4)<%) ; Inactive
..S:$P(PSBDDA(Y),U,3)="" $P(PSBDDA(Y),U,3)=1
..S PSBDDS=PSBDDS_U_$P(PSBDDA(Y),U,1,3)
..S $P(PSBDDS,U,1)=PSBDDS+1
.; On-Call One Time PRN orders
.S PSBQRR=0
.I "^O^OC^P^"[(U_PSBSCHT_U) D Q
..I 'PSBDOADD S PSBTBOUT=1,^TMP("PSB",$J,"PBTAB",0)=2,^TMP("PSB",$J,"PBTAB",1)=1,^TMP("PSB",$J,"PBTAB",2)=1 Q
..D ADD^PSBVDLU1(PSBREC,PSBOTXT,PSBNOW\1,PSBDDS,PSBSOLS,PSBADDS,"PBTAB")
.;
.; IV's - don't worry about admin times if blank
.I PSBONX["V","PSC"'[PSBIVT,PSBADST="" D Q
..I 'PSBDOADD S PSBTBOUT=1,^TMP("PSB",$J,"PBTAB",0)=2,^TMP("PSB",$J,"PBTAB",1)=1,^TMP("PSB",$J,"PBTAB",2)=1 Q
..D ADD^PSBVDLU1(PSBREC,PSBOTXT,PSBNOW\1_".",PSBDDS,PSBSOLS,PSBADDS,"PBTAB")
.;
.; Now we deal with only continuous
.; process admintimes
.S (PSBYES,PSBODD,PSBYTF)=0
.S:$$PSBDCHK1^PSBVT1(PSBSCH) PSBYES=1
.I PSBYES,PSBADST="" D ERROR^PSBMLU(PSBONX,PSBOITX,DFN,"Admin times required",PSBSCH) Q
.F I=1:1 Q:$P(PSBSCH,"-",I)="" I $P(PSBSCH,"-",I)?2N!($P(PSBSCH,"-",I)?4N) S PSBYES=1,PSBYTF=1
.I PSBSCHT="C",PSBYTF="1",PSBADST="" D ERROR^PSBMLU(PSBONX,PSBOITX,DFN,"Admin times required",PSBSCH) Q
.S PSBFREQ=$$GETFREQ^PSBVDLU1(DFN,PSBONX)
.I PSBFREQ="O" S PSBFREQ=1440
.I PSBFREQ="D" S PSBFREQ=""
.I 'PSBYES,PSBFREQ<1 D ERROR^PSBMLU(PSBONX,PSBOITX,DFN,"Invalid frequency received from order",PSBSCH) Q
.S PSBADMIN=PSBADST
.I (PSBADMIN="")&(+PSBFREQ>0) D ODDSCH^PSBVDLU1("PBTAB") Q ;calculate admin times based on frequency
.; No admin times, MAYDAY MAYDAY!!
.I +PSBFREQ>0 I (PSBFREQ#1440'=0),(1440#PSBFREQ'=0) S PSBODD=1
.I PSBODD,PSBADST'="" D ERROR^PSBMLU(PSBONX,PSBOITX,DFN,"Administration Times on ODD SCHEDULE",PSBSCH) Q
.; process admin times against beginning and ending date
.; build all orders for both days.
.F PSBY=1:1 Q:$P(PSBADMIN,"-",PSBY)="" D
..;For invalid admin times
..I ($P(PSBADST,"-",PSBY)'?2N)&($P(PSBADST,"-",PSBY)'?4N) D ERROR^PSBMLU(PSBONX,PSBOITX,DFN,"Invalid Admin times",PSBSCH)
..; apply this time to the beginning window date
..S PSB=+(PSBWBEG\1_"."_$P(PSBADMIN,"-",PSBY))
..D:(PSB'<PSBWBEG)&(PSB'>PSBWEND) ; Make sure it is in the window
...D:(PSB'<PSBSTRT)&(PSB<PSBSTOP) ; Make sure this time is active
....D:$$OKAY^PSBVDLU1(PSBSTRT,PSB,PSBSCH,PSBON,PSBOITX,PSBFREQ,PSBOSTS) ; Okay on this date?
.....I 'PSBDOADD S PSBTBOUT=1,^TMP("PSB",$J,"PBTAB",0)=2,^TMP("PSB",$J,"PBTAB",1)=1,^TMP("PSB",$J,"PBTAB",2)=1 Q
.....D ADD^PSBVDLU1(PSBREC,PSBOTXT,PSB,PSBDDS,PSBSOLS,PSBADDS,"PBTAB")
..;
..Q:(PSBWBEG\1)=(PSBWEND\1) ; Window only has one day rare but possible
..;
..; apply this time to the ending window date
..S PSB=+(PSBWEND\1_"."_$P(PSBADMIN,"-",PSBY))
..D:(PSB'<PSBWBEG)&(PSB'>PSBWEND) ; Make sure it is in the window
...D:(PSB'<PSBSTRT)&(PSB<PSBSTOP) ; Make sure this time is active
....D:$$OKAY^PSBVDLU1(PSBSTRT,PSB,PSBSCH,PSBON,PSBOITX,PSBFREQ,PSBOSTS) ; Okay on this date?
.....I 'PSBDOADD S PSBTBOUT=1,^TMP("PSB",$J,"PBTAB",0)=2,^TMP("PSB",$J,"PBTAB",1)=1,^TMP("PSB",$J,"PBTAB",2)=1 Q
.....D ADD^PSBVDLU1(PSBREC,PSBOTXT,PSB,PSBDDS,PSBSOLS,PSBADDS,"PBTAB")
;
;add initials of verifying pharmacist/verifying nurse
D:PSBDOADD VNURSE^PSBVDLU1("PBTAB")
Q
;
PSBVDLPB ;BIRMINGHAM/EFC-BCMA IV VIRTUAL DUE LIST ;Mar 2004
+1 ;;3.0;BAR CODE MED ADMIN;**11,13,38,32**;Mar 2004;Build 32
+2 ;Per VHA Directive 2004-038 (or future revisions regarding same), this routine should not be modified.
+3 ;
+4 ; Reference/IA
+5 ; EN^PSJBCMA/2828
+6 ; $$GET^XPAR/2263
+7 ; File 200/10060
+8 ;
EN(DFN,PSBDT) ; Default Order List Return for Today
+1 ;
+2 ; RPC: PSB GETORDERLIST
+3 ;
+4 ; Description:
+5 ; Returns the current IV order set for today to display on the
+6 ; client VDL
+7 ;
+8 ;
+9 NEW PSBDATA,PSBTBOUT
+10 SET PSBTBOUT=0
SET PSBDOADD=0
+11 IF PSBTAB="PBTAB"
SET PSBDOADD=1
+12 ;
+13 ;This routine now re-uses the ^TMP("PSJ",$J global built in PSBVDLTB
+14 ;
+15 ; No orders
IF $GET(^TMP("PSJ",$JOB,1,0))=-1
QUIT
+16 ;
+17 FOR PSBX=0:0
SET PSBX=$ORDER(^TMP("PSJ",$JOB,PSBX))
IF ('PSBX)!(PSBTBOUT)
QUIT
Begin DoDot:1
+18 DO CLEAN^PSBVT
DO PSJ^PSBVT(PSBX)
+19 ;
+20 ; << Standard checks for ALL orders >>
+21 ;
+22 ; No Pending Orders
IF PSBONX["P"
QUIT
+23 IF '$$IVPTAB^PSBVDLU3(PSBOTYP,PSBIVT,PSBISYR,PSBCHEMT,PSBIVPSH)
QUIT
+24 ; Order Start Date/Time > admin window
IF PSBOST>PSBWADM
QUIT
+25 ; For all Order Stop Date/Time < vdl window
IF PSBOSP<PSBWBEG
QUIT
+26 ; Is it DC'd
IF PSBOSTS["D"
QUIT
+27 ; Is it marked DO NOT GIVE!
IF PSBNGF
QUIT
+28 ; Non One-Times with stop date/time < now
+29 ;
+30 DO NOW^%DTC
+31 IF PSBOSP<%
QUIT
+32 ;
+33 ; include Active, Renewed, ReInstated and On Call
+34 ; (Is it not one time)&(Is it not active or renewed or On Call)
+35 IF PSBSCHT'="O"&((PSBOSTS'="A")&(PSBOSTS'="R")&(PSBOSTS'="RE")&(PSBOSTS'="O")&(PSBOSTS'="H"))
QUIT
+36 ;
+37 ; Is One Time Given
+38 ;
+39 IF PSBSCHT="O"
Begin DoDot:2
+40 SET (PSBGVN,X,Y)=""
+41 FOR
SET X=$ORDER(^PSB(53.79,"AOIP",DFN,PSBOIT,X),-1)
IF 'X
QUIT
Begin DoDot:3
+42 FOR
SET Y=$ORDER(^PSB(53.79,"AOIP",DFN,PSBOIT,X,Y),-1)
IF 'Y
QUIT
IF ($PIECE(^PSB(53.79,Y,.1),U)=PSBONX)&($PIECE(^PSB(53.79,Y,0),U,9)="G")
SET PSBGVN=1
SET (X,Y)=0
End DoDot:3
End DoDot:2
IF PSBGVN
QUIT
+43 ;
+44 ; How long does One Time remain on VDL ?
+45 SET PSBRMN=1
+46 IF PSBSCHT="O"
IF PSBOSP'=PSBOST
IF %>PSBOSP
SET PSBRMN=0
+47 IF 'PSBRMN
QUIT
+48 ;
+49 ; Is On-Call Given, Can it be given more than once
+50 ;
+51 IF PSBSCHT="OC"
Begin DoDot:2
+52 SET (PSBGVN,X,Y)=""
+53 FOR
SET X=$ORDER(^PSB(53.79,"AOIP",DFN,PSBOIT,X),-1)
IF 'X
QUIT
Begin DoDot:3
+54 FOR
SET Y=$ORDER(^PSB(53.79,"AOIP",DFN,PSBOIT,X,Y),-1)
IF 'Y
QUIT
IF ($PIECE(^PSB(53.79,Y,.1),U)=PSBON)&($PIECE(^PSB(53.79,Y,0),U,9)="G")
SET PSBGVN=1
SET (X,Y)=0
End DoDot:3
End DoDot:2
IF PSBGVN&('$$GET^XPAR("DIV","PSB ADMIN MULTIPLE ONCALL"))
QUIT
+55 ;
+56 ; Order Start Date/Time
SET PSBSTRT=PSBOST
+57 ; Order Stop Date/Time
SET PSBSTOP=PSBOSP
+58 ;
+59 SET PSBREC=""
+60 ; dfn
SET $PIECE(PSBREC,U,1)=DFN
+61 ; Order
SET $PIECE(PSBREC,U,2)=PSBONX
+62 ; order ien
SET $PIECE(PSBREC,U,3)=+PSBON
+63 ; iv/ud/pending
SET $PIECE(PSBREC,U,4)=PSBOTYP
+64 ; schedule type
SET $PIECE(PSBREC,U,5)=PSBSCHT
+65 ; schedule
SET $PIECE(PSBREC,U,6)=PSBSCH
+66 SET Y=""
+67 IF PSBSM
SET Y="SM"
+68 IF PSBHSM
SET Y="HSM"
+69 ; self med
SET $PIECE(PSBREC,U,7)=Y
+70 ; drugname
SET $PIECE(PSBREC,U,8)=PSBOITX
+71 ; dosage
SET $PIECE(PSBREC,U,9)=PSBDOSE_" "_PSBIFR
+72 ;med route
SET $PIECE(PSBREC,U,10)=PSBMR
+73 ; Last Given from the AOIP X-Ref - not given status not excepted
+74 SET (YZ,PSBSTUS,PSBADMER)=""
KILL PSBHSTA,PSBHSTAX
+75 FOR XZ=1:1:20
SET YZ=$ORDER(^PSB(53.79,"AOIP",DFN,PSBOIT,YZ),-1)
SET (PSBCNT,PSBFLAG)=0
IF YZ=""
QUIT
Begin DoDot:2
+76 IF YZ>0
SET $PIECE(PSBREC,U,11)=YZ
+77 SET X=""
FOR
SET X=$ORDER(^PSB(53.79,"AOIP",DFN,PSBOIT,YZ,X),-1)
IF X=""
QUIT
Begin DoDot:3
+78 KILL PSBLCK
LOCK +^PSB(53.79,X):1
IF $TEST
LOCK -^PSB(53.79,X)
SET PSBLCK=1
+79 SET PSBSTUS=$PIECE(^PSB(53.79,X,0),U,9)
+80 IF $GET(PSBSTUS)=""
IF '$GET(PSBLCK)
SET PSBSTUS="X"
IF $GET(PSBLCK)
SET PSBADMER=1
Begin DoDot:4
+81 KILL PSBPARM3,PSBPARM5,PSBPARM6,PSBPARM7
+82 SET PSBPARM6=X
SET Y=$PIECE(^PSB(53.79,X,.1),U,3)
DO DD^%DT
SET PSBPARM3=Y
SET Y=$PIECE(^PSB(53.79,X,0),U,6)
DO DD^%DT
SET PSBPARM5=Y
+83 SET PSBPARM7=$PIECE(^PSB(53.79,X,0),U,7)
SET PSBPARM7="( # "_PSBPARM7_" ) "_$$GET1^DIQ(200,PSBPARM7_",",.01)
+84 KILL PSBXTMP
SET PSBXTMP=PSBONX
+85 DO CLEAN^PSBVT
DO PSJ1^PSBVT(DFN,$$GET1^DIQ(53.79,PSBPARM6_",",.11))
+86 ; SEND AN E-MAIL
DO ERROR^PSBMLU(PSBONX,PSBOITX,DFN,PSBPARM3_" admin's ACTION STATUS is ""UNKNOWN"".",PSBSCH,PSBPARM5,PSBPARM6,PSBPARM7)
+87 ;Reset Variables
DO CLEAN^PSBVT
DO PSJ1^PSBVT(DFN,PSBXTMP)
+88 SET X=PSBPARM6
KILL PSBPARM3,PSBPARM5,PSBPARM6,PSBPARM7
End DoDot:4
+89 KILL PSBLCK
IF (PSBSTUS']"")
SET PSBSTUS="U"
IF PSBSTUS'="N"
IF ($GET(PSBSTUS)'="X")
SET PSBFLAG=1
SET PSBHSTA(YZ,$GET(PSBSTUS))="ORIG"_U_X
+90 IF PSBSTUS="N"
Begin DoDot:4
+91 SET $PIECE(PSBREC,U,11)=""
+92 SET Z=""
FOR
SET Z=$ORDER(^PSB(53.79,X,.9,Z),-1)
IF 'Z
QUIT
IF PSBFLAG=1
QUIT
SET PSBDATA=$GET(^(Z,0))
Begin DoDot:5
+93 IF (PSBDATA["Set to 'NOT GIVEN'")!(PSBDATA["Set to 'GIVEN'")!(PSBDATA["Set to 'REFUSED'")!(PSBDATA["Set to 'HELD'")!(PSBDATA["Set to 'MISSING DOSE'")!(PSBDATA["Set to 'REMOVED'")
SET PSBCNT=PSBCNT+1
+94 IF (PSBDATA["STATUS 'HELD'")!(PSBDATA["STATUS 'GIVEN'")!(PSBDATA["STATUS 'REFUSED'")!(PSBDATA["STATUS 'MISSING DOSE'")!(PSBDATA["STATUS 'REMOVED'")
SET PSBCNT=PSBCNT+1
+95 IF PSBCNT#2=0
IF PSBDATA["'REFUSED'"
SET PSBSTUS="R"
DO LAST^PSBVDLU1
+96 IF PSBCNT#2=0
IF PSBDATA["'HELD'"
SET PSBSTUS="H"
DO LAST^PSBVDLU1
+97 IF PSBCNT#2=0
IF PSBDATA["'MISSING DOSE'"
SET PSBSTUS="M"
DO LAST^PSBVDLU1
+98 IF PSBCNT#2=0
IF PSBDATA["'REMOVED'"
SET PSBSTUS="RM"
DO LAST^PSBVDLU1
+99 IF PSBFLAG=1
IF '$DATA(PSBHSTA($PIECE(PSBREC,U,11),$GET(PSBSTUS)))
SET PSBHSTA($PIECE(PSBREC,U,11),$GET(PSBSTUS))=Z_U_X
End DoDot:5
End DoDot:4
End DoDot:3
End DoDot:2
+100 ;last action date/time
IF $DATA(PSBHSTA)
SET $PIECE(PSBREC,U,11)=$ORDER(PSBHSTA(""),-1)
SET PSBSTUS=$ORDER(PSBHSTA($PIECE(PSBREC,U,11),""),-1)
MERGE PSBHSTAX(PSBOIT)=PSBHSTA
KILL PSBHSTA
+101 ;med log ien inserted below for actual date
SET $PIECE(PSBREC,U,12)=""
+102 ;med log status inserted below for actual date
SET $PIECE(PSBREC,U,13)=""
+103 ;admin date inserted below
SET $PIECE(PSBREC,U,14)=""
+104 ; OI Pointer
SET $PIECE(PSBREC,U,15)=PSBOIT
+105 ;Set injectable med route flag
SET $PIECE(PSBREC,U,16)=PSBNJECT
+106 ; Variable dosage entered as ####-####?
+107 IF $PIECE(PSBREC,U,9)?1.4N1"-"1.4N.E
SET $PIECE(PSBREC,U,17)=1
+108 IF '$TEST
SET $PIECE(PSBREC,U,17)=0
+109 ;IV TYPE - dosage form
SET $PIECE(PSBREC,U,18)=PSBIVT
+110 ;last action status
SET $PIECE(PSBREC,U,20)=$SELECT((PSBSTUS="X")!(PSBSTUS="N"):"",1:PSBSTUS)
+111 SET $PIECE(PSBREC,U,21)=PSBOST
+112 SET $PIECE(PSBREC,U,22)=PSBOSTS
+113 SET $PIECE(PSBREC,U,26)=PSBSTOP
+114 SET $PIECE(PSBREC,U,27)=$$LASTG^PSBCSUTL(DFN,PSBOIT)
+115 ;
+116 ; Gather Dispense Drugs
+117 DO NOW^%DTC
+118 SET (PSBDDS,PSBSOLS,PSBADDS)="0"
+119 FOR Y=0:0
SET Y=$ORDER(PSBDDA(Y))
IF 'Y
QUIT
Begin DoDot:2
+120 ; Inactive
IF $PIECE(PSBDDA(Y),U,4)&($PIECE(PSBDDA(Y),U,4)<%)
QUIT
+121 IF $PIECE(PSBDDA(Y),U,3)=""
SET $PIECE(PSBDDA(Y),U,3)=1
+122 SET PSBDDS=PSBDDS_U_$PIECE(PSBDDA(Y),U,1,3)
+123 SET $PIECE(PSBDDS,U,1)=PSBDDS+1
End DoDot:2
+124 ; On-Call One Time PRN orders
+125 SET PSBQRR=0
+126 IF "^O^OC^P^"[(U_PSBSCHT_U)
Begin DoDot:2
+127 IF 'PSBDOADD
SET PSBTBOUT=1
SET ^TMP("PSB",$JOB,"PBTAB",0)=2
SET ^TMP("PSB",$JOB,"PBTAB",1)=1
SET ^TMP("PSB",$JOB,"PBTAB",2)=1
QUIT
+128 DO ADD^PSBVDLU1(PSBREC,PSBOTXT,PSBNOW\1,PSBDDS,PSBSOLS,PSBADDS,"PBTAB")
End DoDot:2
QUIT
+129 ;
+130 ; IV's - don't worry about admin times if blank
+131 IF PSBONX["V"
IF "PSC"'[PSBIVT
IF PSBADST=""
Begin DoDot:2
+132 IF 'PSBDOADD
SET PSBTBOUT=1
SET ^TMP("PSB",$JOB,"PBTAB",0)=2
SET ^TMP("PSB",$JOB,"PBTAB",1)=1
SET ^TMP("PSB",$JOB,"PBTAB",2)=1
QUIT
+133 DO ADD^PSBVDLU1(PSBREC,PSBOTXT,PSBNOW\1_".",PSBDDS,PSBSOLS,PSBADDS,"PBTAB")
End DoDot:2
QUIT
+134 ;
+135 ; Now we deal with only continuous
+136 ; process admintimes
+137 SET (PSBYES,PSBODD,PSBYTF)=0
+138 IF $$PSBDCHK1^PSBVT1(PSBSCH)
SET PSBYES=1
+139 IF PSBYES
IF PSBADST=""
DO ERROR^PSBMLU(PSBONX,PSBOITX,DFN,"Admin times required",PSBSCH)
QUIT
+140 FOR I=1:1
IF $PIECE(PSBSCH,"-",I)=""
QUIT
IF $PIECE(PSBSCH,"-",I)?2N!($PIECE(PSBSCH,"-",I)?4N)
SET PSBYES=1
SET PSBYTF=1
+141 IF PSBSCHT="C"
IF PSBYTF="1"
IF PSBADST=""
DO ERROR^PSBMLU(PSBONX,PSBOITX,DFN,"Admin times required",PSBSCH)
QUIT
+142 SET PSBFREQ=$$GETFREQ^PSBVDLU1(DFN,PSBONX)
+143 IF PSBFREQ="O"
SET PSBFREQ=1440
+144 IF PSBFREQ="D"
SET PSBFREQ=""
+145 IF 'PSBYES
IF PSBFREQ<1
DO ERROR^PSBMLU(PSBONX,PSBOITX,DFN,"Invalid frequency received from order",PSBSCH)
QUIT
+146 SET PSBADMIN=PSBADST
+147 ;calculate admin times based on frequency
IF (PSBADMIN="")&(+PSBFREQ>0)
DO ODDSCH^PSBVDLU1("PBTAB")
QUIT
+148 ; No admin times, MAYDAY MAYDAY!!
+149 IF +PSBFREQ>0
IF (PSBFREQ#1440'=0)
IF (1440#PSBFREQ'=0)
SET PSBODD=1
+150 IF PSBODD
IF PSBADST'=""
DO ERROR^PSBMLU(PSBONX,PSBOITX,DFN,"Administration Times on ODD SCHEDULE",PSBSCH)
QUIT
+151 ; process admin times against beginning and ending date
+152 ; build all orders for both days.
+153 FOR PSBY=1:1
IF $PIECE(PSBADMIN,"-",PSBY)=""
QUIT
Begin DoDot:2
+154 ;For invalid admin times
+155 IF ($PIECE(PSBADST,"-",PSBY)'?2N)&($PIECE(PSBADST,"-",PSBY)'?4N)
DO ERROR^PSBMLU(PSBONX,PSBOITX,DFN,"Invalid Admin times",PSBSCH)
+156 ; apply this time to the beginning window date
+157 SET PSB=+(PSBWBEG\1_"."_$PIECE(PSBADMIN,"-",PSBY))
+158 ; Make sure it is in the window
IF (PSB'<PSBWBEG)&(PSB'>PSBWEND)
Begin DoDot:3
+159 ; Make sure this time is active
IF (PSB'<PSBSTRT)&(PSB<PSBSTOP)
Begin DoDot:4
+160 ; Okay on this date?
IF $$OKAY^PSBVDLU1(PSBSTRT,PSB,PSBSCH,PSBON,PSBOITX,PSBFREQ,PSBOSTS)
Begin DoDot:5
+161 IF 'PSBDOADD
SET PSBTBOUT=1
SET ^TMP("PSB",$JOB,"PBTAB",0)=2
SET ^TMP("PSB",$JOB,"PBTAB",1)=1
SET ^TMP("PSB",$JOB,"PBTAB",2)=1
QUIT
+162 DO ADD^PSBVDLU1(PSBREC,PSBOTXT,PSB,PSBDDS,PSBSOLS,PSBADDS,"PBTAB")
End DoDot:5
End DoDot:4
End DoDot:3
+163 ;
+164 ; Window only has one day rare but possible
IF (PSBWBEG\1)=(PSBWEND\1)
QUIT
+165 ;
+166 ; apply this time to the ending window date
+167 SET PSB=+(PSBWEND\1_"."_$PIECE(PSBADMIN,"-",PSBY))
+168 ; Make sure it is in the window
IF (PSB'<PSBWBEG)&(PSB'>PSBWEND)
Begin DoDot:3
+169 ; Make sure this time is active
IF (PSB'<PSBSTRT)&(PSB<PSBSTOP)
Begin DoDot:4
+170 ; Okay on this date?
IF $$OKAY^PSBVDLU1(PSBSTRT,PSB,PSBSCH,PSBON,PSBOITX,PSBFREQ,PSBOSTS)
Begin DoDot:5
+171 IF 'PSBDOADD
SET PSBTBOUT=1
SET ^TMP("PSB",$JOB,"PBTAB",0)=2
SET ^TMP("PSB",$JOB,"PBTAB",1)=1
SET ^TMP("PSB",$JOB,"PBTAB",2)=1
QUIT
+172 DO ADD^PSBVDLU1(PSBREC,PSBOTXT,PSB,PSBDDS,PSBSOLS,PSBADDS,"PBTAB")
End DoDot:5
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+173 ;
+174 ;add initials of verifying pharmacist/verifying nurse
+175 IF PSBDOADD
DO VNURSE^PSBVDLU1("PBTAB")
+176 QUIT
+177 ;
