PSBPOIV ;BIRMINGHAM/EFC-IV PARAMETER VALIDATION ;12/7/12 3:39pm
;;3.0;BAR CODE MED ADMIN;**2,66,70**;Mar 2004;Build 101
;;Per VHA Directive 2004-038 (or future revisions regarding same), this routine should not be modified.
;
; Reference/IA
; ^DIC(42/2440
; EN^PSJBCMA2/2830
; VADPT/10061
; $$GET^XPAR/2263
;
;*70 - Change the way IV Bag parameters are retrieved slightly.
; If patient is admitted use the Ward to find DIVision IV params
; If not admitted find DIV associated with the Clinic order and
; get that DIV IV params. Else use logged in User's DIV.
;
EN(PSBDFN,PSBORD) ;
;
S DFN=PSBDFN,(PSBMI,PSBMW,PSBMWC,PSBMAUD)=0,(PSBMIDT,PSBMIM)="",PSBONXS=PSBORD_"^"
K ^TMP("PSBAR",$J) S ^TMP("PSBAR",$J,"W",0)=0
D CLEAN^PSBVT,PSJ1^PSBVT(DFN,PSBORD,1)
; get IV parameters for the current ward
S PSBCSTR="^ADDITIVE^STRENGTH^BOTTLE^SOLUTION^VOLUME^INFUSION RATE^MED ROUTE^SCHEDULE^ADMIN TIME^REMARKS^OTHER PRINT INFO^PROVIDER^START DATE/TIME^STOP DATE/TIME^PROVIDER COMMENTS"
D INP^VADPT S PSBWARD=$P(VAIN(4),"^"),PSBWDIV=PSBWARD D KVAR^VADPT
I $G(PSBWARD)'="",$D(^PSB(53.66,"B",PSBWARD)) D ; if IV paramaters defined for ward use them
.S PSBWARD=$O(^PSB(53.66,"B",PSBWARD,""))
.S:$D(^PSB(53.66,PSBWARD,1,"B",PSBIVT)) PSBIVPAR=^PSB(53.66,PSBWARD,1,$O(^PSB(53.66,PSBWARD,1,"B",PSBIVT,""),-1),0)
N PSBFLAG,PSBDFLT,PSBORLOC
I ($G(PSBCLORD)]"") D
.N DIC,X,Y S DIC="^SC(",DIC(0)="XZ" S X=PSBCLORD D ^DIC S:(Y>0) PSBORLOC=+Y
;
; If IV parameters not defined for Ward or Clinic, then get defaults for division
I '$D(PSBIVPAR) S PSBIVPAR=PSBIVT D
.D:$D(PSBWDIV)!$G(PSBORLOC) ;Get the appropriate DIV for Ward or Clinic and DIVISIONAL IV PARAMETERS
..S PSBWDIV=$$GET1^DIQ(42,PSBWDIV_",",.015,"I") ;Ward DIV *70
..I '$G(PSBWARD),$G(PSBORLOC) S PSBWDIV=$$GET1^DIQ(44,PSBORLOC_",",3.5,"I") ;Clinic DIV *70
..I $G(PSBWDIV)']"" S PSBWDIV="DIV"
..E S PSBWDIV=$P($$SITE^VASITE(DT,PSBWDIV),U,1),PSBWDIV="DIV.`"_PSBWDIV
..S PSBDFLT="^I^I^I^I^I^W^I^I^I^I^W^I^I^I^I" ;Set default IV Bag Parameters variable
..F X=2:1 Q:$P(PSBCSTR,U,X)="" S PSBIVPAR=PSBIVPAR_U_$P($P($$GET^XPAR(PSBWDIV,"PSBIV "_$P(PSBCSTR,U,X),PSBIVT,"B"),U,2),"-",1) I $P(PSBIVPAR,U,X)="" D ;If null, set default - PSB*3*66
...S $P(PSBIVPAR,U,X)=$P(PSBDFLT,U,X),PSBFLAG="" ;If null, set default - PSB*3*66
..K PSBWDIV ; Kill temp variable.
;
F PSBC1=1:1 Q:$P(PSBONXS,U,PSBC1)="" D ; process all orders
.D CLEAN^PSBVT,PSJ1^PSBVT(DFN,$P(PSBONXS,U,PSBC1),1)
.K PSBPONX2 I $G(PSBPONX)]"",$G(PSBPONX)["P" S PSBPONX2=PSBPONX D ; Must compare "active" orders for changes made - look beyond "pendings"
..F D CLEAN^PSBVT,PSJ1^PSBVT(DFN,PSBPONX2,1) S PSBPONX2=PSBPONX Q:(PSBPONX2="")!(PSBPONX2'["P") ;
..D CLEAN^PSBVT,PSJ1^PSBVT(DFN,$P(PSBONXS,U,PSBC1),1) ; Refresh data
..S:$D(PSBPONX2) PSBPONX=PSBPONX2 K PSBPONX2
.Q:($L(U_PSBONXS,U_PSBPONX_U)-1)>0
.I $G(PSBPONX)]"" S PSBONXS=PSBONXS_PSBPONX_U
.K ^TMP("PSJ2",$J) S PSBMAUD=0 D EN^PSJBCMA2(PSBDFN,PSBONX,1) ; check IV parameters against activity log for this order when no "I"nvalid message
.I PSBMI=0 F X=1:1 Q:'$D(^TMP("PSJ2",$J,X)) S PSBCHKV=U_$P(^TMP("PSJ2",$J,X,1),U,3)_U I PSBCSTR[PSBCHKV D MSG(PSBCHKV,$P(^TMP("PSJ2",$J,X,1),U,1)) S PSBMAUD=1
.K ^TMP("PSJ2",$J)
.I PSBMI=0,$G(PSBPONX)]"" D SAVEPAR,CHKORD ; check IV parameters against previous order when no "I"nvalid message
.D CLEAN^PSBVT,PSJ1^PSBVT(DFN,$P(PSBONXS,U,PSBC1),1) ; restore variable for this order
.; okay - we have invalids and warnings through this order so process bags for this order
.I '$D(PSBUIDA) Q ; got errors and warning but no bags printed for this order - go to the next
.S PSBUID="" F S PSBUID=$O(PSBUIDA(PSBUID),-1) Q:PSBUID="" D
..F PSBC2=1:1 S PSBMONX=$P(PSBONXS,U,PSBC2) Q:PSBMONX="" D ; check if bag is in 53.79
...I $D(^PSB(53.79,"AUID",PSBDFN,PSBMONX,PSBUID)) D
....S PSBIEN=$O(^PSB(53.79,"AUID",PSBDFN,PSBMONX,PSBUID,""))
....S PSBPDT=$P(PSBLBLA(PSBUID),U,1),PSBLSTS=$P(PSBLBLA(PSBUID),3)
....S $P(X,U,2)=$P(^PSB(53.79,PSBIEN,0),U,9) ; add action status
....S $P(X,U,3)=$P(^PSB(53.79,PSBIEN,0),U,6) ; add action date/time
....S $P(X,U,4)=$P(^PSB(53.79,PSBIEN,.1),U,1) ; add order ID was administered for
..S $P(X,U,5)=PSBONX ; add order ID was printed for
..S $P(X,U,6)=PSBOSTS ; add order status
..S $P(X,U,7)=$P(PSBLBLA(PSBUID),U,1) ; add date/time ID was printed
..S $P(X,U,8)=$P(PSBLBLA(PSBUID),U,3) ; add lable status from pharmacy
..S $P(X,U,9)="" ; 9 open for later development
..S $P(X,U,10)=PSBUIDA(PSBUID) ; add return from PSJ1
..D BWAR
..I PSBMW=1 S PSBMWS="W;" F I=1:1:^TMP("PSBAR",$J,"W",0) D S $P(X,U,1)=$P(PSBMWS,";",1,$L(PSBMWS,";")-1)
...I $P(PSBLBLA(PSBUID),U,1)'>$P(^TMP("PSBAR",$J,"W",I),U,2) D
....S:(PSBONX=$P(PSBONXS,U,1))&(PSBMAUD=1) PSBMWS=PSBMWS_I_";"
....S:PSBONX'=$P(PSBONXS,U,1) PSBMWS=PSBMWS_I_";"
..I PSBMIDT'="",$P(PSBLBLA(PSBUID),U,1)<PSBMIDT D
...S:(PSBONX=$P(PSBONXS,U,1))&(PSBMAUD=1) $P(X,U,1)="I"
...S:(PSBONX'=$P(PSBONXS,U,1)) $P(X,U,1)="I"
..S ^TMP("PSBAR",$J,PSBUID)=X K X
D CLEAN^PSBVT
K PSBC1,PSBC2,PSBSCHV,PSBCSTR,PSBIVPAR,PSBMI,PSBMIDT,PSBMIM,PSBMONX,PSBMW,PSBSPAR,PSBUID,PSBWARD
K PSBADA,PSBSOLA,PSBOTMP
I ^TMP("PSBAR",$J,"W",0)=0 K ^TMP("PSBAR",$J,"W",0)
D PSJ1^PSBVT(DFN,PSBORD,1) ; restore variables for calling order
Q
;
SAVEPAR ; save parameters from current order
K PSBOTMP
I $D(PSBADA) M PSBOTMP("ADD")=PSBADA E S PSBOTMP("ADD")="" ; additive, strength, bottle
I $D(PSBSOLA) M PSBOTMP("SOL")=PSBSOLA E S PSBOTMP("SOL")="" ; solution, volume,
K PSBADA,PSBSOLA
S PSBOTMP("INFUSION RATE")=$G(PSBIFR),PSBOTMP("MED ROUTE")=$G(PSBMR)
S PSBOTMP("SCHEDULE")=$G(PSBSCH),PSBOTMP("ADMIN TIME")=$G(PSBADST)
S PSBOTMP("REMARKS")=$G(PSBRMRK),PSBOTMP("OTHER PRINT INFO")=$G(PSBOTXT)
S PSBOTMP("PROVIDER")=PSBMD,PSBOTMP("START DATE/TIME")=PSBOST
S PSBOTMP("STOP DATE/TIME")=PSBOSP
D CLEAN^PSBVT,PSJ1^PSBVT(DFN,$P(PSBONXS,U,PSBC1+1),1) ; setup previous order variables
Q
;
CHKORD ; check previous order against current order
I $D(PSBADA)!($D(PSBOTMP("ADD"))) D CHKADD Q:PSBMI=1
I $D(PSBSOLA)!($D(PSBOTMP("SOL"))) D CHKSOL Q:PSBMI=1
I PSBIFR'=PSBOTMP("INFUSION RATE") D MSG("INFUSION RATE",PSBOSP) Q:PSBMI=1
I PSBMR'=PSBOTMP("MED ROUTE") D MSG("MED ROUTE",PSBOSP) Q:PSBMI=1
I PSBSCH'=PSBOTMP("SCHEDULE") D MSG("SCHEDULE",PSBOSP) Q:PSBMI=1
I PSBADST'=PSBOTMP("ADMIN TIME") D MSG("ADMIN TIME",PSBOSP) Q:PSBMI=1
I PSBRMRK'=PSBOTMP("REMARKS") D MSG("REMARKS",PSBOSP) Q:PSBMI=1
I PSBOTXT'=PSBOTMP("OTHER PRINT INFO") D MSG("OTHER PRINT INFO",PSBOSP) Q:PSBMI=1
I PSBMD'=PSBOTMP("PROVIDER") D MSG("PROVIDER",PSBOSP) Q:PSBMI=1
I PSBOTMP("START DATE/TIME")<$$FMADD^XLFDT(PSBOST,,,-1)!(PSBOTMP("START DATE/TIME")>$$FMADD^XLFDT(PSBOST,,,1)) D MSG("START DATE/TIME",PSBOSP) Q:PSBMI=1
;I $E(PSBOST,1,10)'=$E(PSBOTMP("START DATE/TIME"),1,10) D MSG("START DATE/TIME",PSBOSP) Q:PSBMI=1
I $E(PSBOSP,1,10)'=$E(PSBOTMP("STOP DATE/TIME"),1,10) D MSG("STOP DATE/TIME",PSBOSP)
Q
CHKADD ;
N X,Y
I '$D(PSBADA),'$D(PSBOTMP("ADD")) Q ; no additives
I $O(PSBADA(""),-1)>$O(PSBOTMP("ADD",""),-1) D MSG("ADDITIVE",PSBOSP) Q ;previous order has addtives not in current order
I $O(PSBADA(""),-1)<$O(PSBOTMP("ADD",""),-1) D MSG("ADDITIVE",PSBOSP) Q ;previous order missing additives in current order
S X="" F S X=$O(PSBADA(X)) Q:X="" D Q ; check that additives, strength, and bottle are the same
.I PSBADA(X)=PSBOTMP("ADD",X) Q ; everything the same
.I $P(PSBADA(X),U,2)'=$P(PSBOTMP("ADD",X),U,2) D MSG("ADDITIVE",PSBOSP) Q
.I $P(PSBADA(X),U,4)'=$P(PSBOTMP("ADD",X),U,4) D MSG("STRENGTH",PSBOSP) Q
Q
;
CHKSOL ;
N X,Y
I '$D(PSBSOLA),'$D(PSBOTMP("SOL")) Q ; no solutions
I $O(PSBSOLA(""),-1)>$O(PSBOTMP("SOL",""),-1) D MSG("SOLUTION",PSBOSP) Q ;previous order has solutions not in current order
I $O(PSBSOLA(""),-1)<$O(PSBOTMP("SOL",""),-1) D MSG("SOLUTION",PSBOSP) Q ;previous order missing solutions in current order
S X="" F S X=$O(PSBSOLA(X)) Q:X="" D Q ; check that solutions volume are the same
.I PSBSOLA(X)=PSBOTMP("SOL",X) Q ; everything the same
.I $P(PSBSOLA(X),U,2)'=$P(PSBOTMP("SOL",X),U,2) D MSG("SOLUTION",PSBOSP) Q
.I $P(PSBSOLA(X),U,4)'=$P(PSBOTMP("SOL",X),U,4) D MSG("VOLUME",PSBOSP) Q
Q
;
BWAR ;
N X,Y,Z,PSBONX
S X=^TMP("PSBAR",$J,"W",0)+1
S Z="" F Z=1:1 S PSBONX=$P(PSBONXS,U,Z) Q:$G(PSBONX)="" D ; Display "Warning"s for changes
.I '$D(PSBMWAR(PSBONX)) Q
.S Y="" F S Y=$O(PSBMWAR(PSBONX,Y)) Q:Y'?.N1".".N D
..S Z="",PSBYS="" F S Z=$O(PSBMWAR(PSBONX,Y,Z)) Q:Z="" S PSBYS=PSBYS_Z_";"
..S PSBYS=$P(PSBYS,";",1,$L(PSBYS,";")-1)
..S ^TMP("PSBAR",$J,"W",X)=PSBONX_U_Y_U_"2^The "_PSBYS_" was changed on",^TMP("PSBAR",$J,"W",0)=X,X=X+1
.K PSBMWAR(PSBONX)
Q
;
MSG(PSBMVAR,PSBDATE) ;
;I PSBMI=1 Q ;already have an invalid don't need anymore - Removed by Patch PSB*3*66 for multiple edits issue.
F Y=1:1 S PSBSPAR=$P(PSBCSTR,U,Y) I PSBSPAR=$TR(PSBMVAR,"^") D Q
.I $P(PSBIVPAR,U,Y)="W" D
..S PSBMVAR=$TR(PSBMVAR,"^")
..I PSBMW=0 S PSBMW=1
..S PSBMWC=PSBMWC+1,PSBMWM="2^The "_PSBSPAR_" has been changed."
..I $D(PSBMWAR(PSBONX,PSBMVAR)) S PSBOLDT=$O(PSBMWAR(PSBONX,PSBMVAR,"")) I PSBOLDT<$E(PSBDATE,1,12) K PSBMWAR(PSBONX,PSBMVAR,PSBOLDT)
..S PSBMWAR(PSBONX,PSBMVAR,$E(PSBDATE,1,12))=""
..S PSBMWAR(PSBONX,$E(PSBDATE,1,12),PSBMVAR)=""
.I $P(PSBIVPAR,U,Y)="I" S PSBMI=1,PSBMIDT=PSBDATE,PSBMIM="-1^IV invalid "_PSBSPAR_".",^TMP("PSBAR",$J,"I")=PSBONX_U_PSBMIDT_U_PSBMIM
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSBPOIV 9595 printed Nov 22, 2024@16:51:13 Page 2
PSBPOIV ;BIRMINGHAM/EFC-IV PARAMETER VALIDATION ;12/7/12 3:39pm
+1 ;;3.0;BAR CODE MED ADMIN;**2,66,70**;Mar 2004;Build 101
+2 ;;Per VHA Directive 2004-038 (or future revisions regarding same), this routine should not be modified.
+3 ;
+4 ; Reference/IA
+5 ; ^DIC(42/2440
+6 ; EN^PSJBCMA2/2830
+7 ; VADPT/10061
+8 ; $$GET^XPAR/2263
+9 ;
+10 ;*70 - Change the way IV Bag parameters are retrieved slightly.
+11 ; If patient is admitted use the Ward to find DIVision IV params
+12 ; If not admitted find DIV associated with the Clinic order and
+13 ; get that DIV IV params. Else use logged in User's DIV.
+14 ;
EN(PSBDFN,PSBORD) ;
+1 ;
+2 SET DFN=PSBDFN
SET (PSBMI,PSBMW,PSBMWC,PSBMAUD)=0
SET (PSBMIDT,PSBMIM)=""
SET PSBONXS=PSBORD_"^"
+3 KILL ^TMP("PSBAR",$JOB)
SET ^TMP("PSBAR",$JOB,"W",0)=0
+4 DO CLEAN^PSBVT
DO PSJ1^PSBVT(DFN,PSBORD,1)
+5 ; get IV parameters for the current ward
+6 SET PSBCSTR="^ADDITIVE^STRENGTH^BOTTLE^SOLUTION^VOLUME^INFUSION RATE^MED ROUTE^SCHEDULE^ADMIN TIME^REMARKS^OTHER PRINT INFO^PROVIDER^START DATE/TIME^STOP DATE/TIME^PROVIDER COMMENTS"
+7 DO INP^VADPT
SET PSBWARD=$PIECE(VAIN(4),"^")
SET PSBWDIV=PSBWARD
DO KVAR^VADPT
+8 ; if IV paramaters defined for ward use them
IF $GET(PSBWARD)'=""
IF $DATA(^PSB(53.66,"B",PSBWARD))
Begin DoDot:1
+9 SET PSBWARD=$ORDER(^PSB(53.66,"B",PSBWARD,""))
+10 if $DATA(^PSB(53.66,PSBWARD,1,"B",PSBIVT))
SET PSBIVPAR=^PSB(53.66,PSBWARD,1,$ORDER(^PSB(53.66,PSBWARD,1,"B",PSBIVT,""),-1),0)
End DoDot:1
+11 NEW PSBFLAG,PSBDFLT,PSBORLOC
+12 IF ($GET(PSBCLORD)]"")
Begin DoDot:1
+13 NEW DIC,X,Y
SET DIC="^SC("
SET DIC(0)="XZ"
SET X=PSBCLORD
DO ^DIC
if (Y>0)
SET PSBORLOC=+Y
End DoDot:1
+14 ;
+15 ; If IV parameters not defined for Ward or Clinic, then get defaults for division
+16 IF '$DATA(PSBIVPAR)
SET PSBIVPAR=PSBIVT
Begin DoDot:1
+17 ;Get the appropriate DIV for Ward or Clinic and DIVISIONAL IV PARAMETERS
if $DATA(PSBWDIV)!$GET(PSBORLOC)
Begin DoDot:2
+18 ;Ward DIV *70
SET PSBWDIV=$$GET1^DIQ(42,PSBWDIV_",",.015,"I")
+19 ;Clinic DIV *70
IF '$GET(PSBWARD)
IF $GET(PSBORLOC)
SET PSBWDIV=$$GET1^DIQ(44,PSBORLOC_",",3.5,"I")
+20 IF $GET(PSBWDIV)']""
SET PSBWDIV="DIV"
+21 IF '$TEST
SET PSBWDIV=$PIECE($$SITE^VASITE(DT,PSBWDIV),U,1)
SET PSBWDIV="DIV.`"_PSBWDIV
+22 ;Set default IV Bag Parameters variable
SET PSBDFLT="^I^I^I^I^I^W^I^I^I^I^W^I^I^I^I"
+23 ;If null, set default - PSB*3*66
FOR X=2:1
if $PIECE(PSBCSTR,U,X)=""
QUIT
SET PSBIVPAR=PSBIVPAR_U_$PIECE($PIECE($$GET^XPAR(PSBWDIV,"PSBIV "_$PIECE(PSBCSTR,U,X),PSBIVT,"B"),U,2),"-",1)
IF $PIECE(PSBIVPAR,U,X)=""
Begin DoDot:3
+24 ;If null, set default - PSB*3*66
SET $PIECE(PSBIVPAR,U,X)=$PIECE(PSBDFLT,U,X)
SET PSBFLAG=""
End DoDot:3
+25 ; Kill temp variable.
KILL PSBWDIV
End DoDot:2
End DoDot:1
+26 ;
+27 ; process all orders
FOR PSBC1=1:1
if $PIECE(PSBONXS,U,PSBC1)=""
QUIT
Begin DoDot:1
+28 DO CLEAN^PSBVT
DO PSJ1^PSBVT(DFN,$PIECE(PSBONXS,U,PSBC1),1)
+29 ; Must compare "active" orders for changes made - look beyond "pendings"
KILL PSBPONX2
IF $GET(PSBPONX)]""
IF $GET(PSBPONX)["P"
SET PSBPONX2=PSBPONX
Begin DoDot:2
+30 ;
FOR
DO CLEAN^PSBVT
DO PSJ1^PSBVT(DFN,PSBPONX2,1)
SET PSBPONX2=PSBPONX
if (PSBPONX2="")!(PSBPONX2'["P")
QUIT
+31 ; Refresh data
DO CLEAN^PSBVT
DO PSJ1^PSBVT(DFN,$PIECE(PSBONXS,U,PSBC1),1)
+32 if $DATA(PSBPONX2)
SET PSBPONX=PSBPONX2
KILL PSBPONX2
End DoDot:2
+33 if ($LENGTH(U_PSBONXS,U_PSBPONX_U)-1)>0
QUIT
+34 IF $GET(PSBPONX)]""
SET PSBONXS=PSBONXS_PSBPONX_U
+35 ; check IV parameters against activity log for this order when no "I"nvalid message
KILL ^TMP("PSJ2",$JOB)
SET PSBMAUD=0
DO EN^PSJBCMA2(PSBDFN,PSBONX,1)
+36 IF PSBMI=0
FOR X=1:1
if '$DATA(^TMP("PSJ2",$JOB,X))
QUIT
SET PSBCHKV=U_$PIECE(^TMP("PSJ2",$JOB,X,1),U,3)_U
IF PSBCSTR[PSBCHKV
DO MSG(PSBCHKV,$PIECE(^TMP("PSJ2",$JOB,X,1),U,1))
SET PSBMAUD=1
+37 KILL ^TMP("PSJ2",$JOB)
+38 ; check IV parameters against previous order when no "I"nvalid message
IF PSBMI=0
IF $GET(PSBPONX)]""
DO SAVEPAR
DO CHKORD
+39 ; restore variable for this order
DO CLEAN^PSBVT
DO PSJ1^PSBVT(DFN,$PIECE(PSBONXS,U,PSBC1),1)
+40 ; okay - we have invalids and warnings through this order so process bags for this order
+41 ; got errors and warning but no bags printed for this order - go to the next
IF '$DATA(PSBUIDA)
QUIT
+42 SET PSBUID=""
FOR
SET PSBUID=$ORDER(PSBUIDA(PSBUID),-1)
if PSBUID=""
QUIT
Begin DoDot:2
+43 ; check if bag is in 53.79
FOR PSBC2=1:1
SET PSBMONX=$PIECE(PSBONXS,U,PSBC2)
if PSBMONX=""
QUIT
Begin DoDot:3
+44 IF $DATA(^PSB(53.79,"AUID",PSBDFN,PSBMONX,PSBUID))
Begin DoDot:4
+45 SET PSBIEN=$ORDER(^PSB(53.79,"AUID",PSBDFN,PSBMONX,PSBUID,""))
+46 SET PSBPDT=$PIECE(PSBLBLA(PSBUID),U,1)
SET PSBLSTS=$PIECE(PSBLBLA(PSBUID),3)
+47 ; add action status
SET $PIECE(X,U,2)=$PIECE(^PSB(53.79,PSBIEN,0),U,9)
+48 ; add action date/time
SET $PIECE(X,U,3)=$PIECE(^PSB(53.79,PSBIEN,0),U,6)
+49 ; add order ID was administered for
SET $PIECE(X,U,4)=$PIECE(^PSB(53.79,PSBIEN,.1),U,1)
End DoDot:4
End DoDot:3
+50 ; add order ID was printed for
SET $PIECE(X,U,5)=PSBONX
+51 ; add order status
SET $PIECE(X,U,6)=PSBOSTS
+52 ; add date/time ID was printed
SET $PIECE(X,U,7)=$PIECE(PSBLBLA(PSBUID),U,1)
+53 ; add lable status from pharmacy
SET $PIECE(X,U,8)=$PIECE(PSBLBLA(PSBUID),U,3)
+54 ; 9 open for later development
SET $PIECE(X,U,9)=""
+55 ; add return from PSJ1
SET $PIECE(X,U,10)=PSBUIDA(PSBUID)
+56 DO BWAR
+57 IF PSBMW=1
SET PSBMWS="W;"
FOR I=1:1:^TMP("PSBAR",$JOB,"W",0)
Begin DoDot:3
+58 IF $PIECE(PSBLBLA(PSBUID),U,1)'>$PIECE(^TMP("PSBAR",$JOB,"W",I),U,2)
Begin DoDot:4
+59 if (PSBONX=$PIECE(PSBONXS,U,1))&(PSBMAUD=1)
SET PSBMWS=PSBMWS_I_";"
+60 if PSBONX'=$PIECE(PSBONXS,U,1)
SET PSBMWS=PSBMWS_I_";"
End DoDot:4
End DoDot:3
SET $PIECE(X,U,1)=$PIECE(PSBMWS,";",1,$LENGTH(PSBMWS,";")-1)
+61 IF PSBMIDT'=""
IF $PIECE(PSBLBLA(PSBUID),U,1)<PSBMIDT
Begin DoDot:3
+62 if (PSBONX=$PIECE(PSBONXS,U,1))&(PSBMAUD=1)
SET $PIECE(X,U,1)="I"
+63 if (PSBONX'=$PIECE(PSBONXS,U,1))
SET $PIECE(X,U,1)="I"
End DoDot:3
+64 SET ^TMP("PSBAR",$JOB,PSBUID)=X
KILL X
End DoDot:2
End DoDot:1
+65 DO CLEAN^PSBVT
+66 KILL PSBC1,PSBC2,PSBSCHV,PSBCSTR,PSBIVPAR,PSBMI,PSBMIDT,PSBMIM,PSBMONX,PSBMW,PSBSPAR,PSBUID,PSBWARD
+67 KILL PSBADA,PSBSOLA,PSBOTMP
+68 IF ^TMP("PSBAR",$JOB,"W",0)=0
KILL ^TMP("PSBAR",$JOB,"W",0)
+69 ; restore variables for calling order
DO PSJ1^PSBVT(DFN,PSBORD,1)
+70 QUIT
+71 ;
SAVEPAR ; save parameters from current order
+1 KILL PSBOTMP
+2 ; additive, strength, bottle
IF $DATA(PSBADA)
MERGE PSBOTMP("ADD")=PSBADA
IF '$TEST
SET PSBOTMP("ADD")=""
+3 ; solution, volume,
IF $DATA(PSBSOLA)
MERGE PSBOTMP("SOL")=PSBSOLA
IF '$TEST
SET PSBOTMP("SOL")=""
+4 KILL PSBADA,PSBSOLA
+5 SET PSBOTMP("INFUSION RATE")=$GET(PSBIFR)
SET PSBOTMP("MED ROUTE")=$GET(PSBMR)
+6 SET PSBOTMP("SCHEDULE")=$GET(PSBSCH)
SET PSBOTMP("ADMIN TIME")=$GET(PSBADST)
+7 SET PSBOTMP("REMARKS")=$GET(PSBRMRK)
SET PSBOTMP("OTHER PRINT INFO")=$GET(PSBOTXT)
+8 SET PSBOTMP("PROVIDER")=PSBMD
SET PSBOTMP("START DATE/TIME")=PSBOST
+9 SET PSBOTMP("STOP DATE/TIME")=PSBOSP
+10 ; setup previous order variables
DO CLEAN^PSBVT
DO PSJ1^PSBVT(DFN,$PIECE(PSBONXS,U,PSBC1+1),1)
+11 QUIT
+12 ;
CHKORD ; check previous order against current order
+1 IF $DATA(PSBADA)!($DATA(PSBOTMP("ADD")))
DO CHKADD
if PSBMI=1
QUIT
+2 IF $DATA(PSBSOLA)!($DATA(PSBOTMP("SOL")))
DO CHKSOL
if PSBMI=1
QUIT
+3 IF PSBIFR'=PSBOTMP("INFUSION RATE")
DO MSG("INFUSION RATE",PSBOSP)
if PSBMI=1
QUIT
+4 IF PSBMR'=PSBOTMP("MED ROUTE")
DO MSG("MED ROUTE",PSBOSP)
if PSBMI=1
QUIT
+5 IF PSBSCH'=PSBOTMP("SCHEDULE")
DO MSG("SCHEDULE",PSBOSP)
if PSBMI=1
QUIT
+6 IF PSBADST'=PSBOTMP("ADMIN TIME")
DO MSG("ADMIN TIME",PSBOSP)
if PSBMI=1
QUIT
+7 IF PSBRMRK'=PSBOTMP("REMARKS")
DO MSG("REMARKS",PSBOSP)
if PSBMI=1
QUIT
+8 IF PSBOTXT'=PSBOTMP("OTHER PRINT INFO")
DO MSG("OTHER PRINT INFO",PSBOSP)
if PSBMI=1
QUIT
+9 IF PSBMD'=PSBOTMP("PROVIDER")
DO MSG("PROVIDER",PSBOSP)
if PSBMI=1
QUIT
+10 IF PSBOTMP("START DATE/TIME")<$$FMADD^XLFDT(PSBOST,,,-1)!(PSBOTMP("START DATE/TIME")>$$FMADD^XLFDT(PSBOST,,,1))
DO MSG("START DATE/TIME",PSBOSP)
if PSBMI=1
QUIT
+11 ;I $E(PSBOST,1,10)'=$E(PSBOTMP("START DATE/TIME"),1,10) D MSG("START DATE/TIME",PSBOSP) Q:PSBMI=1
+12 IF $EXTRACT(PSBOSP,1,10)'=$EXTRACT(PSBOTMP("STOP DATE/TIME"),1,10)
DO MSG("STOP DATE/TIME",PSBOSP)
+13 QUIT
CHKADD ;
+1 NEW X,Y
+2 ; no additives
IF '$DATA(PSBADA)
IF '$DATA(PSBOTMP("ADD"))
QUIT
+3 ;previous order has addtives not in current order
IF $ORDER(PSBADA(""),-1)>$ORDER(PSBOTMP("ADD",""),-1)
DO MSG("ADDITIVE",PSBOSP)
QUIT
+4 ;previous order missing additives in current order
IF $ORDER(PSBADA(""),-1)<$ORDER(PSBOTMP("ADD",""),-1)
DO MSG("ADDITIVE",PSBOSP)
QUIT
+5 ; check that additives, strength, and bottle are the same
SET X=""
FOR
SET X=$ORDER(PSBADA(X))
if X=""
QUIT
Begin DoDot:1
+6 ; everything the same
IF PSBADA(X)=PSBOTMP("ADD",X)
QUIT
+7 IF $PIECE(PSBADA(X),U,2)'=$PIECE(PSBOTMP("ADD",X),U,2)
DO MSG("ADDITIVE",PSBOSP)
QUIT
+8 IF $PIECE(PSBADA(X),U,4)'=$PIECE(PSBOTMP("ADD",X),U,4)
DO MSG("STRENGTH",PSBOSP)
QUIT
End DoDot:1
QUIT
+9 QUIT
+10 ;
CHKSOL ;
+1 NEW X,Y
+2 ; no solutions
IF '$DATA(PSBSOLA)
IF '$DATA(PSBOTMP("SOL"))
QUIT
+3 ;previous order has solutions not in current order
IF $ORDER(PSBSOLA(""),-1)>$ORDER(PSBOTMP("SOL",""),-1)
DO MSG("SOLUTION",PSBOSP)
QUIT
+4 ;previous order missing solutions in current order
IF $ORDER(PSBSOLA(""),-1)<$ORDER(PSBOTMP("SOL",""),-1)
DO MSG("SOLUTION",PSBOSP)
QUIT
+5 ; check that solutions volume are the same
SET X=""
FOR
SET X=$ORDER(PSBSOLA(X))
if X=""
QUIT
Begin DoDot:1
+6 ; everything the same
IF PSBSOLA(X)=PSBOTMP("SOL",X)
QUIT
+7 IF $PIECE(PSBSOLA(X),U,2)'=$PIECE(PSBOTMP("SOL",X),U,2)
DO MSG("SOLUTION",PSBOSP)
QUIT
+8 IF $PIECE(PSBSOLA(X),U,4)'=$PIECE(PSBOTMP("SOL",X),U,4)
DO MSG("VOLUME",PSBOSP)
QUIT
End DoDot:1
QUIT
+9 QUIT
+10 ;
BWAR ;
+1 NEW X,Y,Z,PSBONX
+2 SET X=^TMP("PSBAR",$JOB,"W",0)+1
+3 ; Display "Warning"s for changes
SET Z=""
FOR Z=1:1
SET PSBONX=$PIECE(PSBONXS,U,Z)
if $GET(PSBONX)=""
QUIT
Begin DoDot:1
+4 IF '$DATA(PSBMWAR(PSBONX))
QUIT
+5 SET Y=""
FOR
SET Y=$ORDER(PSBMWAR(PSBONX,Y))
if Y'?.N1".".N
QUIT
Begin DoDot:2
+6 SET Z=""
SET PSBYS=""
FOR
SET Z=$ORDER(PSBMWAR(PSBONX,Y,Z))
if Z=""
QUIT
SET PSBYS=PSBYS_Z_";"
+7 SET PSBYS=$PIECE(PSBYS,";",1,$LENGTH(PSBYS,";")-1)
+8 SET ^TMP("PSBAR",$JOB,"W",X)=PSBONX_U_Y_U_"2^The "_PSBYS_" was changed on"
SET ^TMP("PSBAR",$JOB,"W",0)=X
SET X=X+1
End DoDot:2
+9 KILL PSBMWAR(PSBONX)
End DoDot:1
+10 QUIT
+11 ;
MSG(PSBMVAR,PSBDATE) ;
+1 ;I PSBMI=1 Q ;already have an invalid don't need anymore - Removed by Patch PSB*3*66 for multiple edits issue.
+2 FOR Y=1:1
SET PSBSPAR=$PIECE(PSBCSTR,U,Y)
IF PSBSPAR=$TRANSLATE(PSBMVAR,"^")
Begin DoDot:1
+3 IF $PIECE(PSBIVPAR,U,Y)="W"
Begin DoDot:2
+4 SET PSBMVAR=$TRANSLATE(PSBMVAR,"^")
+5 IF PSBMW=0
SET PSBMW=1
+6 SET PSBMWC=PSBMWC+1
SET PSBMWM="2^The "_PSBSPAR_" has been changed."
+7 IF $DATA(PSBMWAR(PSBONX,PSBMVAR))
SET PSBOLDT=$ORDER(PSBMWAR(PSBONX,PSBMVAR,""))
IF PSBOLDT<$EXTRACT(PSBDATE,1,12)
KILL PSBMWAR(PSBONX,PSBMVAR,PSBOLDT)
+8 SET PSBMWAR(PSBONX,PSBMVAR,$EXTRACT(PSBDATE,1,12))=""
+9 SET PSBMWAR(PSBONX,$EXTRACT(PSBDATE,1,12),PSBMVAR)=""
End DoDot:2
+10 IF $PIECE(PSBIVPAR,U,Y)="I"
SET PSBMI=1
SET PSBMIDT=PSBDATE
SET PSBMIM="-1^IV invalid "_PSBSPAR_"."
SET ^TMP("PSBAR",$JOB,"I")=PSBONX_U_PSBMIDT_U_PSBMIM
End DoDot:1
QUIT
+11 QUIT
