PSBPOIV.m

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 ---PSBPOIV   9595     printed  Feb 18, 2025@23:07:24                                                                                                                                                                                                     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