Routine: PSIVORC1

PSIVORC1 ;BIR/MLM - PROCESS INCOMPLETE IV ORDER - CONT ;13 Jan 98  11:36 AM

 ;;5.0;INPATIENT MEDICATIONS;**1,37,69,110,157,134,181,263,270,279,281**;16 DEC 97;Build 113

 ; Reference to ^DD("DD" is supported by DBIA 10017.

 ; Reference to ^DD( is supported by DBIA 2255.

 ; Reference to ^VA(200 is supported by DBIA 10060.

 ; Reference to ^%DT is supported by DBIA 10003.

 ; Reference to ^%DTC is supported by DBIA 10000.

 ; Reference to ^DID is supported by DBIA 2052.

 ; Reference to ^VALM is supported by DBIA 10118.

 ; Reference to ^PS(51.1 supported by DBIA #2177.

 ; Reference to ^PS(55 is supported by DBIA# 2191.

53 ; IV Type

 I $G(PSGORD)["P",$G(PSGAT),($G(P(9))]"") D

 .N X,PSGS0Y,PSGS0XT,ZZ,LYN,ZZND,ZZNDW S X=P(9) S PSGS0Y="",ZZ=0 D FIND^DIC(51.1,,,,X,,"APPSJ",,,"LYN")

 .S ZZ=$O(LYN("DILIST",2,ZZ)) I ZZ S ZZ=+LYN("DILIST",2,ZZ) I ZZ S ZZND=$G(^PS(51.1,ZZ,0)) S PSGST=$P(ZZND,U,5),PSGS0XT=$P(ZZND,U,3) I $G(PSJPWD) D

 ..N ZZNDW S ZZNDW=$G(^PS(51.1,ZZ,1,PSJPWD,0)) I $P(ZZNDW,"^",2)]"" S PSGS0Y=$P(ZZNDW,"^",2),$P(ZZND,"^",2)=PSGS0Y

 .S ZZ=0 F  S ZZ=$O(LYN("DILIST",1,ZZ)) Q:'ZZ  I $G(LYN("DILIST",1,ZZ))'=X K LYN("DILIST",1,ZZ),LYN("DILIST",2,ZZ),LYN("DILIST","ID",ZZ,1)

 .I $D(PSJPWD) S ZZ=0 F  S ZZ=$O(LYN("DILIST",2,ZZ)) Q:'ZZ  I $P($G(^PS(51.1,+LYN("DILIST",2,ZZ),1,+PSJPWD,0)),U,2)]"" S PSGS0Y=$P($G(^(0)),U,2)

 .I '$G(PSGS0Y) S ZZ=0 F  S ZZ=$O(LYN("DILIST",2,ZZ)) Q:'ZZ  Q:PSGS0Y]""  I $G(LYN("DILIST","ID",ZZ,1))]"" S PSGS0Y=$G(LYN("DILIST","ID",ZZ,1))

 .Q:(PSGS0Y=PSGAT)!'$G(PSGS0Y)!($G(IVCAT)="C")

 .S PSGNSTAT=1 W $C(7),!!,"PLEASE NOTE:  This order's admin times (",PSGAT,")"

 .W !?13," do not match the ward times (",PSGS0Y,")"

 .W !?13," for this administration schedule (",P(9),")",!

 .S DIR(0)="EA",DIR("A")="Press Return to continue..." D ^DIR K DIR  W !

 S DONE=0 N DIR S DIR(0)="SNA^A:ADMIXTURE;C:CHEMOTHERAPY;H:HYPERAL;P:PIGGYBACK;S:SYRINGE",DIR("A")="IV TYPE: "

 I $G(P("RES"))'="R",$G(PSGORD)["P" N IVCAT,IVTYPTMP S IVCAT=$P($G(^PS(53.1,+PSGORD,2.5)),"^",5) S IVTYPTMP=$S((P(9)]""):"P",$G(P(5)):"P",$G(P(23))="P":"P",1:"")

 S DIR("B")=$S($G(IVCAT)="C"!($G(IVTYPTMP)="A"):"ADMIXTURE",$G(IVCAT)="I"!($G(IVTYPTMP)="P"):"PIGGYBACK",1:"ADMIXTURE")

 D DIRQ,^DIR S:$D(DTOUT)!(X="^") DONE=1 Q:DONE  G:$E(X)="^" 53 S P(4)=Y D:"CS"[P(4) @P(4)

 ;*PSJ*5*270 - Remove bottle from IVPB

 N PSG53 I Y="P" D

 .N ADCNT,PSGBTL F ADCNT=0:0 S ADCNT=$O(^PS(53.1,+PSGORD,"AD",ADCNT)) Q:('ADCNT)!$G(PSGBTL)  D

 ..I $P(^PS(53.1,+PSGORD,"AD",ADCNT,0),U,3)]"" S PSGBTL=1

 .I '$G(PSGBTL) Q

 .W !!,"A bottle value is not allowed with a Piggyback IV order.  Do you wish to delete the bottle value(s)"

 .S %=1 D YN^DICN I %'=1 S PSG53=1 Q

 .N DIE,DA,DR

 .F ADCNT=0:0 S ADCNT=$O(^PS(53.1,+PSGORD,"AD",ADCNT)) Q:'ADCNT  D

 ..S $P(DRG("AD",ADCNT),U,4)=""

 I $G(PSG53) G 53

 ;*End PSJ*5*270

 N PSGINFAT S PSGINFAT=0 I ((P(4)="P")!$G(P(5))!($G(P(23))="P")) I P(8)["@" D

 .W !!,"Infusion Rate contains ""@"" (not allowed with an Intermittent IV order)",!

 .D 59 S:'(P(8)["@") P("NUMLBL")="" I P(8)["@" S PSGINFAT=1

 I $G(PSGINFAT) G 53

 I PSIVAC'="PN" D ENT^PSIVCAL K %DT S X=P(2),%DT="RTX" D ^%DT S P(2)=+Y D ENSTOP^PSIVCAL K %DT S X=P(3),%DT="RTX" D ^%DT S P(3)=+Y

OTYP ; Get order type, display type.

 S P("DTYP")=$S(P(4)="":0,P(4)="P"!(P(23)="P")!(P(5)):1,P(4)="H":2,1:3) S:PSIVAC'="CF" P("OT")=$S(P(4)="A":"F",P(4)="H":"H",1:"I")

C ; Edit Chemo order

 N DIR S DIR(0)="SA^A:ADMIXTURE;P:PIGGYBACK;S:SYRINGE",DIR("A")="CHEMOTHERAPY TYPE: " D DIRQ,^DIR S:$D(DTOUT)!(X=U) DONE=1 Q:$E(X)="^"!(DONE)  S P(23)=Y D:P(23)["S" S

S ; Edit Syringe order

56 ; Intermittent Syringe

 N DIR S DIR(0)="Y",DIR("??")="^S F1=53.1,F2=56 D ENHLP^PSIVORC1",DIR("A")="INTERMITTENT SYRINGE" D ^DIR Q:$D(DIRUT)  S P(5)=Y

55 ; Syringe Size

 N DA,DIR S DIR(0)="53.1,55" D ^DIR I $D(DTOUT)!$D(DUOUT) S DONE=1 Q

 S P("SYRS")=Y

DIRQ ; Set DIR("?") for IV Type prompt.

 S DIR("?")="Enter a code from the list above.",DIR("??")="^S F1=55.01,F2="_$S(DIR("A")["CHEMO":106,1:.04)_" D ENHLP^PSIVORC1"

 S DIR("?",1)="CHOOSE FROM:",Y=$P(DIR(0),U,2) F X=1:1:5 S DIR("?",X+1)="              "_$P($P(Y,";",X),":")_"    "_$P($P(Y,";",X),":",2)

CKFLDS ; Find required fields missing data.

 NEW PSIVASX,PSIVASY,FIL,DRGTMP

 S EDIT="" F PSIVASX="AD","SOL" D

 .I '$D(DRG(PSIVASX)) S EDIT=EDIT_U_$S(PSIVASX="AD":57,1:58) Q

 .S DNE=0 F PSIVASY=0:0 S PSIVASY=$O(DRG(PSIVASX,PSIVASY)) Q:'PSIVASY!DNE  D

 .. I $P(DRG(PSIVASX,PSIVASY),U,3)="" S EDIT=EDIT_U_$S(PSIVASX="AD":57,1:58),DNE=1

 .. I $P(DRG(PSIVASX,PSIVASY),U,4)="See Comments",(EDIT'["57") S EDIT=EDIT_U_$S(PSIVASX="AD":57,1:58),DNE=1

 S:'P("MR") EDIT=EDIT_U_3 F X=8,6,2,3 I P(X)="" S EDIT=EDIT_U_$S(X=8:59,X=6:1,X=2:10,X=3:25,1:"")

 I P("DTYP")=1 S:P(9)="" EDIT=EDIT_U_26 S:P(11)="" EDIT=EDIT_U_39

 S:$E(EDIT,1)=U EDIT=$E(EDIT,2,999)

DONE ; Kill variables and exit

 K ACTION,AD,DFN,DNE,DONE,DONE1,DRG,DRGI,DRGN,DRGT,DRGTN,EDIT,ERR,F1,F2,FIL,HDT,J,LN,LN2,ND,ON,ON1,ON55,ORIFN,P,P16,PC,PDM,PG,PN,PNME,PNOW,PSGLMT,PSGODDD

 K PSGSS,PSGSSH,PSIV,PSIVAC,PSIVAT,PSIVCV,PSIVE,PSIVHD,PSIVLN,PSIVOK,PSIVOLD,PSIVORUT,PSIVREA,PSIVSC1,PSIVSTR,PSIVSTRT,PSIVTYPE,PSIVUP,PSIVX,PSIVX1

 K PSJIVORF,PSJORF,PSJORIFN,PSJORL,PSJORNP,PSJORPF,PSJORSTS,PSJIVOF,PSJNKF,PSJORD,RB,RF,SOL,STOP,TYP,UL80,WD,WDN,WG,^TMP("PSIV",$J) D ENIVKV^PSGSETU

ENHLP ; order entry fields' help

 N PSJHP,PSJX,PSJD

 ;From within this routine, F1 and F2 will refer to file 53.1,field 56, file 55.01,field 106, or file 55.01,field .04

 D FIELD^DID(F1,F2,"","HELP-PROMPT","PSJHP")

 I X="?",$D(PSJHP("HELP-PROMPT")) S F=$G(PSJHP("HELP-PROMPT")) W !?5 F F0=1:1:$L(F," ") S F3=$P(F," ",F0) W:$L(F3)+$X>78 !?5 W F3_" "

 W:$D(^DD(F1,F2,12)) !,"("_^(12)_")" D FIELD^DID(F1,F2,"","XECUTABLE HELP","PSJX") I $D(PSJX("XECUTABLE HELP")) X PSJX("XECUTABLE HELP")

 ; new code

 D FIELD^DID(F1,F2,"","DESCRIPTION","PSJD") NEW F

 G:$S($G(X)="?":1,1:'$O(PSJD("DESCRIPTION",0))) SC F F=0:0 S F=$O(PSJD("DESCRIPTION",F)) Q:'F  I $D(PSJD("DESCRIPTION",F)) W !?2,PSJD("DESCRIPTION",F)

SC ;

 I F2=5!(F2=6) W !,"CHOOSE FROM:",!?8,0,?16,"NO",!?8,1,?16,"YES" Q

COMPLTE ;

 NEW PSIVDSFG S PSIVDSFG=0

 S P16=0,PSIVEXAM=1,(PSIVNOL,PSIVCT)=1 D GTOT^PSIVUTL(P(4)) D ^PSIVCHK I $D(DUOUT) W $C(7),!,"Order Unchanged.",! Q

 G:'$D(PSIVFN1) EDIT1

 I ERR=1 S Y=0 G EDIT1

 D CKORD^PSIVORC2 I $G(PSJFNDS)!$S($G(PSIVDSFG):0,PSIVCHG:1,1:0)!$$INFRATE^PSJMISC(DFN,ON,P(8),P("DTYP")) D

 . K PSJFNDS

 . I $$SEECMENT^PSIVEDRG() S PSGORQF=1 W !!,"*** One or more Additives has an invalid value for the bottle number(s).",! D PAUSE^PSJMISC() Q

 . S PSJDSVFY=1

 . D IN^PSJOCDS($G(ON),"IV","")

 . Q:$G(PSGORQF)

 . Q:'PSIVCHG

 D NOW^%DTC S P("LOG")=$E(%,1,12),P("CLRK")=DUZ_U_$P($G(^VA(200,DUZ,0)),U),P("INS")=""

 Q:$G(PSGORQF)

 W ! D ^PSIVORLB K PSIVEXAM S Y=P(2)

 W !,"Start date: " X ^DD("DD") W $P(Y,"@")," ",$P(Y,"@",2),?30," Stop date: " S Y=P(3) X ^DD("DD") W $P(Y,"@")," ",$P(Y,"@",2),!

EDIT ;

 I ERR=1 W !,"Please re-edit this order" K DIR S DIR(0)="E" D ^DIR K DIR W:'Y $C(7),"order unchanged." Q:'Y  S Y=0 G EDIT1

 ;PSJ*5*157 EFD FOR IV

 D EFDIV^PSJUTL($G(ZZND))

 W:$G(PSIVCHG) !,"*** This change will cause a new order to be created. ***"

 K DIR S DIR(0)="Y",DIR("A")="Is this O.K.",DIR("B")=$S(ERR:"NO",1:"YES"),DIR("?",1)="Enter ""Y"" to make this an active order (only allowed if no errors were"

 S DIR("?")="found in order), ""N"" to edit the order, or ""^"" to leave order unchanged.",DIR("??")="^S HELP=""EDIT"" D ^PSIVHLP"

 D ^DIR K DIR I $D(DIRUT) K DIRUT W $C(7),"Order unchanged." Q

 ;*  Kill Unit dose variables when calling from ^PSJLIFNI.

 I +Y,$G(PSJLIFNI) D

 . K ND,ND4,ND6,NDP2

 . K PSGAT,PSGCANFL,PSGDI,PSGDO,PSGDT,PSGEB,PSGEBN,PSGEFN,PSGFD,PSGFDN

 . K PSGHSM,PSGLI,PSGLIN,PSGLMT,PSGMR,PSGMRN,PSGNEDFD,PSGNEF,PSGNEFD

 . K PSGNESD,PSGOAT,PSGODO,PSGODT,PSGEA,PSGOEAV,PSGOEEF

 . K PSGOEEWF,PSGOEEG,PSGOEF,PSGOENG,PSGOES,PSGOFD,PSGOFDN,PSGOHSM

 . K PSGOINST,PSGOMR,PSGOMRN,PSGONC

 . K PSGOPD,PSOPDN,PSGOPR,PSGOPRN,PSGOSD,PSGOSDN,PSGOSI,PSGOSM

 . K PSGOST,PSGOSTN

 . K PSGPD,PSGPDN,PSGPDRG,PSGDRGN,PSGPFLG,PSGPI,PSGPR,PSGPRIO,PSGPRN

 . K PSGPTMP,PSGRRF,PSG0XT,PSGS0Y,PSGSCH,PSGSD,PSGSDN,PSGSI,PSGSM

 . K PSGST,PSGSTAT,PSGSTN,PSJACNWP,PSJACOK,PSJCOI

EDIT1 ;

 NEW XFLG,PSIVY S PSIVY=$G(Y)

 NEW X S X=$G(^TMP("PSJI",$J,0)),VALMBG=$S((X<17):1,1:(X-(X#16)))

 N PSINVON S PSINVON=ON I PSINVON["P" N PRVON S PRVON=$P($G(^PS(53.1,+ON,0)),"^",25) I PRVON["V" S PSINVON=PRVON

 I PSIVY=0!'$G(PSIVFN1) S PSIVFN1=1 D EN^VALM("PSJ LM IV AC/EDIT") Q

 S PSIVCHG=0 D EDCHK^PSIVORC2 K PSIVCHG I $G(PSJCOM) S ^TMP("PSJCOM",$J,+ON,17)=$G(P("NUMLBL")) K P("NUMLBL")

 S VALMBCK="Q",PSIVACEP=1

59 ; Infusion Rate

 N P8BADDEF S P8BADDEF=0

 I $G(P("RES"))="R" I $G(ON)["P",$P($G(^PS(53.1,+ON,0)),"^",24)="R" D  Q

 . Q:'$G(PSIVRENW)  W !!?5,"This is a Renewal Order. Infusion Rate may not be edited at this point." D PAUSE^VALM1

 W !,"INFUSION RATE: ",$G(P(8))_"//" R X:DTIME S:'$T X=U S:X=U DONE=1 I $S($E(X)=U:1,X]"":0,1:'(P(8)["@")) D:'$G(DONE) EXPINF^PSIVEDT1(.X) G:$G(P8BADDEF) 59 Q

 I (("C^P"[P(4))!(("C^S"[P(4))&(P(5)=1)))&((X["@")!((X="")&(P(8)["@"))) D  G 59

 .W $C(7),!!?2,"'@' is not permitted for Intermittent IV's",!

 I (X["^") D  G 59

 .W $C(7),!!?2,"'^' is not permitted",!

 I X=""&(("C^P"[P(4))!(("C^S"[P(4))&(P(5)=1))) Q

 I X="@" D DEL^PSIVEDRG S:%=1 P(8)="" G 59

 I X["???",($E(P("OT"))="I"),(PSIVAC["C") D ORFLDS^PSIVEDT1 G 59

 I X["?" S F1=53.1,F2=59 D ENHLP^PSIVORC1 G 59

 D EXPINF^PSIVEDT1(.X)

 I ($L(X)>30!($L(X)=1)),(X'?1N) D  G 59

 .W $C(7),!!?3,"Free text entries must contain a minimum of 2 characters",!?3,"and a maximum of 30 characters",!

 I X]"" D ENI^PSIVSP W:'$D(X) $C(7)," ??" G:'$D(X) 59 S P(8)=X

 I P(8)="" W $C(7),!!,"An infusion rate must be entered!" G 59

PSBPOIV ; Invalid IV bags based on BCMA IV parameters

 Q:'$G(DFN)  Q:'$G(ON55)  Q:'($G(ON55)["V")  Q:'$D(^PS(55,DFN,"IV",+ON55,0))

 I $P($G(^PS(55,DFN,"IV",+ON55,2)),"^",5)!($G(P("RES"))="R")!($G(P("FRES"))="R") D PSBPOIV^PSJIBAG(DFN,ON55)

SETNML55 ; Set NUMBER OF LABELS into ^PS(55,DFN,"IV",+ON55,0

 ;          Added to PROTOCOL PSJI LM VERIFY after call to VF^PSJLIACT

 ;          Made necessary by 11th hour code conflicts caused by MOCHA 2.0

 Q:'$D(P("NUMLBL"))  Q:'$G(DFN)  Q:'($G(ON55)["V")  Q:'$G(^PS(55,DFN,"IV",+ON55,0))

 S $P(^PS(55,DFN,"IV",+ON55,11),"^",1)=$G(P("NUMLBL"))

SETNL531 ;  Set NUMBER OF LABELS into ^PS(53.1,+PSGORD,8

 ;          Added to PROTOCOL PSJI LM VERIFY after call to VF^PSJLIACT

 ;          Made necessary by 11th hour code conflicts caused by MOCHA 2.0

 Q:'$D(P("NUMLBL"))  Q:'$G(DFN)  Q:'$G(PSGORD)  Q:'$G(^PS(53.1,+PSGORD,0))  ; $D is intentional - may edit from something to nothing

 S $P(^PS(53.1,+PSGORD,17),"^",1)=$G(P("NUMLBL"))

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSIVORC1   10822     printed  Feb 18, 2025@23:31                                                                                                                                                                                                      Page 2

PSIVORC1  ;BIR/MLM - PROCESS INCOMPLETE IV ORDER - CONT ;13 Jan 98  11:36 AM

 +1       ;;5.0;INPATIENT MEDICATIONS;**1,37,69,110,157,134,181,263,270,279,281**;16 DEC 97;Build 113

 +2       ;

 +3       ; Reference to ^DD("DD" is supported by DBIA 10017.

 +4       ; Reference to ^DD( is supported by DBIA 2255.

 +5       ; Reference to ^VA(200 is supported by DBIA 10060.

 +6       ; Reference to ^%DT is supported by DBIA 10003.

 +7       ; Reference to ^%DTC is supported by DBIA 10000.

 +8       ; Reference to ^DID is supported by DBIA 2052.

 +9       ; Reference to ^VALM is supported by DBIA 10118.

 +10      ; Reference to ^PS(51.1 supported by DBIA #2177.

 +11      ; Reference to ^PS(55 is supported by DBIA# 2191.

 +12      ;

53        ; IV Type

 +1        IF $GET(PSGORD)["P"

               IF $GET(PSGAT)

                   IF ($GET(P(9))]"")

                       Begin DoDot:1

 +2                        NEW X,PSGS0Y,PSGS0XT,ZZ,LYN,ZZND,ZZNDW

                           SET X=P(9)

                           SET PSGS0Y=""

                           SET ZZ=0

                           DO FIND^DIC(51.1,,,,X,,"APPSJ",,,"LYN")

 +3                        SET ZZ=$ORDER(LYN("DILIST",2,ZZ))

                           IF ZZ

                               SET ZZ=+LYN("DILIST",2,ZZ)

                               IF ZZ

                                   SET ZZND=$GET(^PS(51.1,ZZ,0))

                                   SET PSGST=$PIECE(ZZND,U,5)

                                   SET PSGS0XT=$PIECE(ZZND,U,3)

                                   IF $GET(PSJPWD)

                                       Begin DoDot:2

 +4                                        NEW ZZNDW

                                           SET ZZNDW=$GET(^PS(51.1,ZZ,1,PSJPWD,0))

                                           IF $PIECE(ZZNDW,"^",2)]""

                                               SET PSGS0Y=$PIECE(ZZNDW,"^",2)

                                               SET $PIECE(ZZND,"^",2)=PSGS0Y

                                       End DoDot:2

 +5                        SET ZZ=0

FOR

                               SET ZZ=$ORDER(LYN("DILIST",1,ZZ))

                               if 'ZZ

                                   QUIT

                               IF $GET(LYN("DILIST",1,ZZ))'=X

                                   KILL LYN("DILIST",1,ZZ),LYN("DILIST",2,ZZ),LYN("DILIST","ID",ZZ,1)

 +6                        IF $DATA(PSJPWD)

                               SET ZZ=0

FOR

                                   SET ZZ=$ORDER(LYN("DILIST",2,ZZ))

                                   if 'ZZ

                                       QUIT

                                   IF $PIECE($GET(^PS(51.1,+LYN("DILIST",2,ZZ),1,+PSJPWD,0)),U,2)]""

                                       SET PSGS0Y=$PIECE($GET(^(0)),U,2)

 +7                        IF '$GET(PSGS0Y)

                               SET ZZ=0

FOR

                                   SET ZZ=$ORDER(LYN("DILIST",2,ZZ))

                                   if 'ZZ

                                       QUIT

                                   if PSGS0Y]""

                                       QUIT

                                   IF $GET(LYN("DILIST","ID",ZZ,1))]""

                                       SET PSGS0Y=$GET(LYN("DILIST","ID",ZZ,1))

 +8                        if (PSGS0Y=PSGAT)!'$GET(PSGS0Y)!($GET(IVCAT)="C")

                               QUIT

 +9                        SET PSGNSTAT=1

                           WRITE $CHAR(7),!!,"PLEASE NOTE:  This order's admin times (",PSGAT,")"

 +10                       WRITE !?13," do not match the ward times (",PSGS0Y,")"

 +11                       WRITE !?13," for this administration schedule (",P(9),")",!

 +12                       SET DIR(0)="EA"

                           SET DIR("A")="Press Return to continue..."

                           DO ^DIR

                           KILL DIR

                           WRITE !

                       End DoDot:1

 +13       SET DONE=0

           NEW DIR

           SET DIR(0)="SNA^A:ADMIXTURE;C:CHEMOTHERAPY;H:HYPERAL;P:PIGGYBACK;S:SYRINGE"

           SET DIR("A")="IV TYPE: "

 +14       IF $GET(P("RES"))'="R"

               IF $GET(PSGORD)["P"

                   NEW IVCAT,IVTYPTMP

                   SET IVCAT=$PIECE($GET(^PS(53.1,+PSGORD,2.5)),"^",5)

                   SET IVTYPTMP=$SELECT((P(9)]""):"P",$GET(P(5)):"P",$GET(P(23))="P":"P",1:"")

 +15       SET DIR("B")=$SELECT($GET(IVCAT)="C"!($GET(IVTYPTMP)="A"):"ADMIXTURE",$GET(IVCAT)="I"!($GET(IVTYPTMP)="P"):"PIGGYBACK",1:"ADMIXTURE")

 +16       DO DIRQ

           DO ^DIR

           if $DATA(DTOUT)!(X="^")

               SET DONE=1

           if DONE

               QUIT

           if $EXTRACT(X)="^"

               GOTO 53

           SET P(4)=Y

           if "CS"[P(4)

               DO @P(4)

 +17      ;*PSJ*5*270 - Remove bottle from IVPB

 +18       NEW PSG53

           IF Y="P"

               Begin DoDot:1

 +19               NEW ADCNT,PSGBTL

                   FOR ADCNT=0:0

                       SET ADCNT=$ORDER(^PS(53.1,+PSGORD,"AD",ADCNT))

                       if ('ADCNT)!$GET(PSGBTL)

                           QUIT

                       Begin DoDot:2

 +20                       IF $PIECE(^PS(53.1,+PSGORD,"AD",ADCNT,0),U,3)]""

                               SET PSGBTL=1

                       End DoDot:2

 +21               IF '$GET(PSGBTL)

                       QUIT

 +22               WRITE !!,"A bottle value is not allowed with a Piggyback IV order.  Do you wish to delete the bottle value(s)"

 +23               SET %=1

                   DO YN^DICN

                   IF %'=1

                       SET PSG53=1

                       QUIT

 +24               NEW DIE,DA,DR

 +25               FOR ADCNT=0:0

                       SET ADCNT=$ORDER(^PS(53.1,+PSGORD,"AD",ADCNT))

                       if 'ADCNT

                           QUIT

                       Begin DoDot:2

 +26                       SET $PIECE(DRG("AD",ADCNT),U,4)=""

                       End DoDot:2

               End DoDot:1

 +27       IF $GET(PSG53)

               GOTO 53

 +28      ;*End PSJ*5*270

 +29       NEW PSGINFAT

           SET PSGINFAT=0

           IF ((P(4)="P")!$GET(P(5))!($GET(P(23))="P"))

               IF P(8)["@"

                   Begin DoDot:1

 +30                   WRITE !!,"Infusion Rate contains ""@"" (not allowed with an Intermittent IV order)",!

 +31                   DO 59

                       if '(P(8)["@")

                           SET P("NUMLBL")=""

                       IF P(8)["@"

                           SET PSGINFAT=1

                   End DoDot:1

 +32       IF $GET(PSGINFAT)

               GOTO 53

 +33       IF PSIVAC'="PN"

               DO ENT^PSIVCAL

               KILL %DT

               SET X=P(2)

               SET %DT="RTX"

               DO ^%DT

               SET P(2)=+Y

               DO ENSTOP^PSIVCAL

               KILL %DT

               SET X=P(3)

               SET %DT="RTX"

               DO ^%DT

               SET P(3)=+Y

OTYP      ; Get order type, display type.

 +1        SET P("DTYP")=$SELECT(P(4)="":0,P(4)="P"!(P(23)="P")!(P(5)):1,P(4)="H":2,1:3)

           if PSIVAC'="CF"

               SET P("OT")=$SELECT(P(4)="A":"F",P(4)="H":"H",1:"I")

 +2        QUIT

 +3       ;

C         ; Edit Chemo order

 +1        NEW DIR

           SET DIR(0)="SA^A:ADMIXTURE;P:PIGGYBACK;S:SYRINGE"

           SET DIR("A")="CHEMOTHERAPY TYPE: "

           DO DIRQ

           DO ^DIR

           if $DATA(DTOUT)!(X=U)

               SET DONE=1

           if $EXTRACT(X)="^"!(DONE)

               QUIT

           SET P(23)=Y

           if P(23)["S"

               DO S

 +2        QUIT

 +3       ;

S         ; Edit Syringe order

56        ; Intermittent Syringe

 +1        NEW DIR

           SET DIR(0)="Y"

           SET DIR("??")="^S F1=53.1,F2=56 D ENHLP^PSIVORC1"

           SET DIR("A")="INTERMITTENT SYRINGE"

           DO ^DIR

           if $DATA(DIRUT)

               QUIT

           SET P(5)=Y

 +2       ;

55        ; Syringe Size

 +1        NEW DA,DIR

           SET DIR(0)="53.1,55"

           DO ^DIR

           IF $DATA(DTOUT)!$DATA(DUOUT)

               SET DONE=1

               QUIT

 +2        SET P("SYRS")=Y

 +3        QUIT

 +4       ;

DIRQ      ; Set DIR("?") for IV Type prompt.

 +1        SET DIR("?")="Enter a code from the list above."

           SET DIR("??")="^S F1=55.01,F2="_$SELECT(DIR("A")["CHEMO":106,1:.04)_" D ENHLP^PSIVORC1"

 +2        SET DIR("?",1)="CHOOSE FROM:"

           SET Y=$PIECE(DIR(0),U,2)

           FOR X=1:1:5

               SET DIR("?",X+1)="              "_$PIECE($PIECE(Y,";",X),":")_"    "_$PIECE($PIECE(Y,";",X),":",2)

 +3        QUIT

 +4       ;

CKFLDS    ; Find required fields missing data.

 +1        NEW PSIVASX,PSIVASY,FIL,DRGTMP

 +2        SET EDIT=""

           FOR PSIVASX="AD","SOL"

               Begin DoDot:1

 +3                IF '$DATA(DRG(PSIVASX))

                       SET EDIT=EDIT_U_$SELECT(PSIVASX="AD":57,1:58)

                       QUIT

 +4                SET DNE=0

                   FOR PSIVASY=0:0

                       SET PSIVASY=$ORDER(DRG(PSIVASX,PSIVASY))

                       if 'PSIVASY!DNE

                           QUIT

                       Begin DoDot:2

 +5                        IF $PIECE(DRG(PSIVASX,PSIVASY),U,3)=""

                               SET EDIT=EDIT_U_$SELECT(PSIVASX="AD":57,1:58)

                               SET DNE=1

 +6                        IF $PIECE(DRG(PSIVASX,PSIVASY),U,4)="See Comments"

                               IF (EDIT'["57")

                                   SET EDIT=EDIT_U_$SELECT(PSIVASX="AD":57,1:58)

                                   SET DNE=1

                       End DoDot:2

               End DoDot:1

 +7        if 'P("MR")

               SET EDIT=EDIT_U_3

           FOR X=8,6,2,3

               IF P(X)=""

                   SET EDIT=EDIT_U_$SELECT(X=8:59,X=6:1,X=2:10,X=3:25,1:"")

 +8        IF P("DTYP")=1

               if P(9)=""

                   SET EDIT=EDIT_U_26

               if P(11)=""

                   SET EDIT=EDIT_U_39

 +9        if $EXTRACT(EDIT,1)=U

               SET EDIT=$EXTRACT(EDIT,2,999)

 +10       QUIT

 +11      ;

DONE      ; Kill variables and exit

 +1        KILL ACTION,AD,DFN,DNE,DONE,DONE1,DRG,DRGI,DRGN,DRGT,DRGTN,EDIT,ERR,F1,F2,FIL,HDT,J,LN,LN2,ND,ON,ON1,ON55,ORIFN,P,P16,PC,PDM,PG,PN,PNME,PNOW,PSGLMT,PSGODDD

 +2        KILL PSGSS,PSGSSH,PSIV,PSIVAC,PSIVAT,PSIVCV,PSIVE,PSIVHD,PSIVLN,PSIVOK,PSIVOLD,PSIVORUT,PSIVREA,PSIVSC1,PSIVSTR,PSIVSTRT,PSIVTYPE,PSIVUP,PSIVX,PSIVX1

 +3        KILL PSJIVORF,PSJORF,PSJORIFN,PSJORL,PSJORNP,PSJORPF,PSJORSTS,PSJIVOF,PSJNKF,PSJORD,RB,RF,SOL,STOP,TYP,UL80,WD,WDN,WG,^TMP("PSIV",$JOB)

           DO ENIVKV^PSGSETU

 +4        QUIT

ENHLP     ; order entry fields' help

 +1        NEW PSJHP,PSJX,PSJD

 +2       ;From within this routine, F1 and F2 will refer to file 53.1,field 56, file 55.01,field 106, or file 55.01,field .04

 +3        DO FIELD^DID(F1,F2,"","HELP-PROMPT","PSJHP")

 +4        IF X="?"

               IF $DATA(PSJHP("HELP-PROMPT"))

                   SET F=$GET(PSJHP("HELP-PROMPT"))

                   WRITE !?5

                   FOR F0=1:1:$LENGTH(F," ")

                       SET F3=$PIECE(F," ",F0)

                       if $LENGTH(F3)+$X>78

                           WRITE !?5

                       WRITE F3_" "

 +5       ;

 +6        if $DATA(^DD(F1,F2,12))

               WRITE !,"("_^(12)_")"

           DO FIELD^DID(F1,F2,"","XECUTABLE HELP","PSJX")

           IF $DATA(PSJX("XECUTABLE HELP"))

               XECUTE PSJX("XECUTABLE HELP")

 +7       ;

 +8       ; new code

 +9        DO FIELD^DID(F1,F2,"","DESCRIPTION","PSJD")

           NEW F

 +10       if $SELECT($GET(X)="?"

               GOTO SC

           FOR F=0:0

               SET F=$ORDER(PSJD("DESCRIPTION",F))

               if 'F

                   QUIT

               IF $DATA(PSJD("DESCRIPTION",F))

                   WRITE !?2,PSJD("DESCRIPTION",F)

SC        ;

 +1        IF F2=5!(F2=6)

               WRITE !,"CHOOSE FROM:",!?8,0,?16,"NO",!?8,1,?16,"YES"

               QUIT

 +2        QUIT

COMPLTE   ;

 +1        NEW PSIVDSFG

           SET PSIVDSFG=0

 +2        SET P16=0

           SET PSIVEXAM=1

           SET (PSIVNOL,PSIVCT)=1

           DO GTOT^PSIVUTL(P(4))

           DO ^PSIVCHK

           IF $DATA(DUOUT)

               WRITE $CHAR(7),!,"Order Unchanged.",!

               QUIT

 +3        if '$DATA(PSIVFN1)

               GOTO EDIT1

 +4        IF ERR=1

               SET Y=0

               GOTO EDIT1

 +5        DO CKORD^PSIVORC2

           IF $GET(PSJFNDS)!$SELECT($GET(PSIVDSFG):0,PSIVCHG:1,1:0)!$$INFRATE^PSJMISC(DFN,ON,P(8),P("DTYP"))

               Begin DoDot:1

 +6                KILL PSJFNDS

 +7                IF $$SEECMENT^PSIVEDRG()

                       SET PSGORQF=1

                       WRITE !!,"*** One or more Additives has an invalid value for the bottle number(s).",!

                       DO PAUSE^PSJMISC()

                       QUIT

 +8                SET PSJDSVFY=1

 +9                DO IN^PSJOCDS($GET(ON),"IV","")

 +10               if $GET(PSGORQF)

                       QUIT

 +11               if 'PSIVCHG

                       QUIT

               End DoDot:1

 +12       DO NOW^%DTC

           SET P("LOG")=$EXTRACT(%,1,12)

           SET P("CLRK")=DUZ_U_$PIECE($GET(^VA(200,DUZ,0)),U)

           SET P("INS")=""

 +13       if $GET(PSGORQF)

               QUIT

 +14       WRITE !

           DO ^PSIVORLB

           KILL PSIVEXAM

           SET Y=P(2)

 +15       WRITE !,"Start date: "

           XECUTE ^DD("DD")

           WRITE $PIECE(Y,"@")," ",$PIECE(Y,"@",2),?30," Stop date: "

           SET Y=P(3)

           XECUTE ^DD("DD")

           WRITE $PIECE(Y,"@")," ",$PIECE(Y,"@",2),!

EDIT      ;

 +1        IF ERR=1

               WRITE !,"Please re-edit this order"

               KILL DIR

               SET DIR(0)="E"

               DO ^DIR

               KILL DIR

               if 'Y

                   WRITE $CHAR(7),"order unchanged."

               if 'Y

                   QUIT

               SET Y=0

               GOTO EDIT1

 +2       ;PSJ*5*157 EFD FOR IV

 +3        DO EFDIV^PSJUTL($GET(ZZND))

 +4        if $GET(PSIVCHG)

               WRITE !,"*** This change will cause a new order to be created. ***"

 +5        KILL DIR

           SET DIR(0)="Y"

           SET DIR("A")="Is this O.K."

           SET DIR("B")=$SELECT(ERR:"NO",1:"YES")

           SET DIR("?",1)="Enter ""Y"" to make this an active order (only allowed if no errors were"

 +6        SET DIR("?")="found in order), ""N"" to edit the order, or ""^"" to leave order unchanged."

           SET DIR("??")="^S HELP=""EDIT"" D ^PSIVHLP"

 +7        DO ^DIR

           KILL DIR

           IF $DATA(DIRUT)

               KILL DIRUT

               WRITE $CHAR(7),"Order unchanged."

               QUIT

 +8       ;*  Kill Unit dose variables when calling from ^PSJLIFNI.

 +9        IF +Y

               IF $GET(PSJLIFNI)

                   Begin DoDot:1

 +10                   KILL ND,ND4,ND6,NDP2

 +11                   KILL PSGAT,PSGCANFL,PSGDI,PSGDO,PSGDT,PSGEB,PSGEBN,PSGEFN,PSGFD,PSGFDN

 +12                   KILL PSGHSM,PSGLI,PSGLIN,PSGLMT,PSGMR,PSGMRN,PSGNEDFD,PSGNEF,PSGNEFD

 +13                   KILL PSGNESD,PSGOAT,PSGODO,PSGODT,PSGEA,PSGOEAV,PSGOEEF

 +14                   KILL PSGOEEWF,PSGOEEG,PSGOEF,PSGOENG,PSGOES,PSGOFD,PSGOFDN,PSGOHSM

 +15                   KILL PSGOINST,PSGOMR,PSGOMRN,PSGONC

 +16                   KILL PSGOPD,PSOPDN,PSGOPR,PSGOPRN,PSGOSD,PSGOSDN,PSGOSI,PSGOSM

 +17                   KILL PSGOST,PSGOSTN

 +18                   KILL PSGPD,PSGPDN,PSGPDRG,PSGDRGN,PSGPFLG,PSGPI,PSGPR,PSGPRIO,PSGPRN

 +19                   KILL PSGPTMP,PSGRRF,PSG0XT,PSGS0Y,PSGSCH,PSGSD,PSGSDN,PSGSI,PSGSM

 +20                   KILL PSGST,PSGSTAT,PSGSTN,PSJACNWP,PSJACOK,PSJCOI

                   End DoDot:1

EDIT1     ;

 +1        NEW XFLG,PSIVY

           SET PSIVY=$GET(Y)

 +2        NEW X

           SET X=$GET(^TMP("PSJI",$JOB,0))

           SET VALMBG=$SELECT((X<17):1,1:(X-(X#16)))

 +3        NEW PSINVON

           SET PSINVON=ON

           IF PSINVON["P"

               NEW PRVON

               SET PRVON=$PIECE($GET(^PS(53.1,+ON,0)),"^",25)

               IF PRVON["V"

                   SET PSINVON=PRVON

 +4        IF PSIVY=0!'$GET(PSIVFN1)

               SET PSIVFN1=1

               DO EN^VALM("PSJ LM IV AC/EDIT")

               QUIT

 +5        SET PSIVCHG=0

           DO EDCHK^PSIVORC2

           KILL PSIVCHG

           IF $GET(PSJCOM)

               SET ^TMP("PSJCOM",$JOB,+ON,17)=$GET(P("NUMLBL"))

               KILL P("NUMLBL")

 +6        SET VALMBCK="Q"

           SET PSIVACEP=1

 +7        QUIT

59        ; Infusion Rate

 +1        NEW P8BADDEF

           SET P8BADDEF=0

 +2        IF $GET(P("RES"))="R"

               IF $GET(ON)["P"

                   IF $PIECE($GET(^PS(53.1,+ON,0)),"^",24)="R"

                       Begin DoDot:1

 +3                        if '$GET(PSIVRENW)

                               QUIT

                           WRITE !!?5,"This is a Renewal Order. Infusion Rate may not be edited at this point."

                           DO PAUSE^VALM1

                       End DoDot:1

                       QUIT

 +4        WRITE !,"INFUSION RATE: ",$GET(P(8))_"//"

           READ X:DTIME

           if '$TEST

               SET X=U

           if X=U

               SET DONE=1

           IF $SELECT($EXTRACT(X)=U:1,X]"":0,1:'(P(8)["@"))

               if '$GET(DONE)

                   DO EXPINF^PSIVEDT1(.X)

               if $GET(P8BADDEF)

                   GOTO 59

               QUIT

 +5        IF (("C^P"[P(4))!(("C^S"[P(4))&(P(5)=1)))&((X["@")!((X="")&(P(8)["@")))

               Begin DoDot:1

 +6                WRITE $CHAR(7),!!?2,"'@' is not permitted for Intermittent IV's",!

               End DoDot:1

               GOTO 59

 +7        IF (X["^")

               Begin DoDot:1

 +8                WRITE $CHAR(7),!!?2,"'^' is not permitted",!

               End DoDot:1

               GOTO 59

 +9        IF X=""&(("C^P"[P(4))!(("C^S"[P(4))&(P(5)=1)))

               QUIT

 +10       IF X="@"

               DO DEL^PSIVEDRG

               if %=1

                   SET P(8)=""

               GOTO 59

 +11       IF X["???"

               IF ($EXTRACT(P("OT"))="I")

                   IF (PSIVAC["C")

                       DO ORFLDS^PSIVEDT1

                       GOTO 59

 +12       IF X["?"

               SET F1=53.1

               SET F2=59

               DO ENHLP^PSIVORC1

               GOTO 59

 +13       DO EXPINF^PSIVEDT1(.X)

 +14       IF ($LENGTH(X)>30!($LENGTH(X)=1))

               IF (X'?1N)

                   Begin DoDot:1

 +15                   WRITE $CHAR(7),!!?3,"Free text entries must contain a minimum of 2 characters",!?3,"and a maximum of 30 characters",!

                   End DoDot:1

                   GOTO 59

 +16       IF X]""

               DO ENI^PSIVSP

               if '$DATA(X)

                   WRITE $CHAR(7)," ??"

               if '$DATA(X)

                   GOTO 59

               SET P(8)=X

 +17       IF P(8)=""

               WRITE $CHAR(7),!!,"An infusion rate must be entered!"

               GOTO 59

 +18       QUIT

PSBPOIV   ; Invalid IV bags based on BCMA IV parameters

 +1        if '$GET(DFN)

               QUIT

           if '$GET(ON55)

               QUIT

           if '($GET(ON55)["V")

               QUIT

           if '$DATA(^PS(55,DFN,"IV",+ON55,0))

               QUIT

 +2        IF $PIECE($GET(^PS(55,DFN,"IV",+ON55,2)),"^",5)!($GET(P("RES"))="R")!($GET(P("FRES"))="R")

               DO PSBPOIV^PSJIBAG(DFN,ON55)

 +3        QUIT

 +4       ;

SETNML55  ; Set NUMBER OF LABELS into ^PS(55,DFN,"IV",+ON55,0

 +1       ;          Added to PROTOCOL PSJI LM VERIFY after call to VF^PSJLIACT

 +2       ;          Made necessary by 11th hour code conflicts caused by MOCHA 2.0

 +3        if '$DATA(P("NUMLBL"))

               QUIT

           if '$GET(DFN)

               QUIT

           if '($GET(ON55)["V")

               QUIT

           if '$GET(^PS(55,DFN,"IV",+ON55,0))

               QUIT

 +4        SET $PIECE(^PS(55,DFN,"IV",+ON55,11),"^",1)=$GET(P("NUMLBL"))

 +5        QUIT

SETNL531  ;  Set NUMBER OF LABELS into ^PS(53.1,+PSGORD,8

 +1       ;          Added to PROTOCOL PSJI LM VERIFY after call to VF^PSJLIACT

 +2       ;          Made necessary by 11th hour code conflicts caused by MOCHA 2.0

 +3       ; $D is intentional - may edit from something to nothing

           if '$DATA(P("NUMLBL"))

               QUIT

           if '$GET(DFN)

               QUIT

           if '$GET(PSGORD)

               QUIT

           if '$GET(^PS(53.1,+PSGORD,0))

               QUIT

 +4        SET $PIECE(^PS(53.1,+PSGORD,17),"^",1)=$GET(P("NUMLBL"))

 +5        QUIT

PSIVORC1.m