PSIVEDT ;BIR/MLM-EDIT IV ORDER ;02-Apr-2013 19:38;PLS
;;5.0; INPATIENT MEDICATIONS ;**4,110,127,133,134,1015**;16 DEC 97;Build 62
;
; Reference to ^DD(53.1 is supported by DBIA 2256.
; Reference to ^PS(52.7 is supported by DBIA 2173.
; Reference to ^PS(52.6 is supported by DBIA 1231.
; Reference to ^PS(51.2 is supported by DBIA 2178.
; Reference to ^PS(50.7 is supported by DBIA 2180.
; Reference to ^PS(55 is supported by DBIA 2191.
;
; Modified - IHS/MSC/PB - 4/20/12 - added line at EDIT+1
; - 4/20/12 - added line tag 9999999
; - 9/14/12 - modified line edit+5
; - 2/11/13 - modified line OFFSET+7 to read Beyond Use Date
; - 3/22/13 - changed prompt at 9999999+6 to read Beyond Use Days
; - 3/25/13 - added line OFFSET+6 to set the default value of the Beyond Use Days prompt
; - Modified EDIT + 1 to set APSPON to +$G(ON) commented out the line to add field 9999999 to the EDIT variable.
; - 04/02/13 - Line EDIT+6
EDIT ;
;IHS/MSC/PB line below modified to check the iv room parameter to determine if
;the expiration date prints on the iv label.
;IHS/MSC/PB - Line below changed to correct a problem with saving and then resetting the value of the variable ON should have set APSPON=$G(ON) not +$G(ON)
;I $P($G(^PS(59.5,+P("IVRM"),9999999)),"^")=1 S APSPON=+$G(ON) S:$G(EDIT)'[9999999 EDIT=EDIT_U_9999999
;I $P($G(^PS(59.5,+P("IVRM"),9999999)),"^")=1 S APSPON=$G(ON) S:$G(EDIT)'[9999999 EDIT=EDIT_U_9999999
I +$G(^PS(59.5,+P("IVRM"),9999999)) S APSPON=$G(ON) S:$G(EDIT)'[9999999 EDIT=EDIT_U_9999999 ;IHS/MSC/PLS - 04/02/12
I $G(DFN)&($G(PSJORD)["V") I $$COMPLEX^PSJOE(DFN,PSJORD) D
. N X,Y,PARENT,P2ND S P2ND=$S($G(^PS(55,PSGP,"IV",+PSJORD,.2)):$G(^PS(55,PSGP,"IV",+PSJORD,.2)),1:$G(^PS(55,PSGP,5,+PSJORD,.2)))
. S PARENT=$P(P2ND,"^",8)
. I PARENT D FULL^VALM1 W !!?5,"This order is part of a complex order. Please review the following ",!?5,"associated orders before changing this order." D CMPLX^PSJCOM1(PSGP,PARENT,PSJORD)
S DONE=0
F PSIVE=1:1 S:DONE&$E(PSIVAC)="C" OREND=1 Q:PSIVE>$L(EDIT,U)!(DONE) Q:'$L($P(EDIT,U,PSIVE)) D @(+$P(EDIT,U,PSIVE)) S:$E(PSIVAC,2)="N" PSIVOK=PSIVOK_U_$P(EDIT,U,PSIVE) I $E(X)=U,$L(X)>1 S:PSIVE>1 PSIVE=PSIVE-1 F D FF Q:Y<0 D @Y Q:$E(X)'=U
K EDIT,PSIVOK,PSGDIV
Q
;
1 ; Provider.
I $G(P("RES"))="R" I $G(PSJORD)["P",$P($G(^PS(53.1,+$G(ON),0)),"^",24)="R" D Q
. W !!?5,"This is Renewal order. Provider may not be edited at this point." D PAUSE^VALM1
I $G(DFN)&($G(ON)["V") I $$COMPLEX^PSJOE(DFN,ON) D Q
.Q:$G(PSJBKDR) W !!?5,"This is a Complex Order. Provider may not be edited at this point." D PAUSE^VALM1
S P(6)=$S('$G(^VA(200,+P(6),"PS")):"",'$P(^("PS"),U,4):P(6),$P(^("PS"),U,4)<DT:"",1:P(6))
W !,"PROVIDER: "_$S($P(P(6),U,2)]"":$P(P(6),U,2)_"//",1:"") R X:DTIME S:'$T X=U S:X=U DONE=1 I $E(X)=U!(X=""&P(6)) Q
I X["???",($E(P("OT"))="I"),(PSIVAC["C") D ORFLDS^PSIVEDT1 G 1
I X]"" K DIC S DIC=200,DIC(0)="EQMZ",DIC("S")="I $D(^(""PS"")),^(""PS""),$S('$P(^(""PS""),U,4):1,$P(^(""PS""),U,4)>DT:1,1:0)" D ^DIC K DIC I Y>0 S P(6)=+Y_U_Y(0,0) Q
S F1=53.1,F2=1 D ENHLP^PSIVORC1 W $C(7),!!,"A Provider must be entered.",!! G 1
Q
;
3 ; Med Route.
I $G(P("RES"))="R" I $G(PSJORD)["P",$P($G(^PS(53.1,+ON,0)),"^",24)="R" D Q
. W !!?5,"Med Route may not be edited at this point." D PAUSE^VALM1
I $G(DFN)&($G(ON)["V") I $$COMPLEX^PSJOE(DFN,ON) D Q
.Q:$G(PSJBKDR) W !!?5,"This is a Complex Order. Med Route may not be edited at this point." D PAUSE^VALM1
S P(6)=$S('$G(^VA(200,+P(6),"PS")):"",'$P(^("PS"),U,4):P(6),$P(^("PS"),U,4)<DT:"",1:P(6))
I P("MR")="" D
.N AD,SOL,OI,RT,RTCNT
.S AD=0 F S AD=$O(DRG("AD",AD)) Q:'AD S OI=$P(DRG("AD",AD),"^",6) I OI S OI(OI)=""
.S SOL=0 F S SOL=$O(DRG("SOL",SOL)) Q:'SOL S OI=$P(DRG("SOL",SOL),"^",6) I OI S OI(OI)=""
.S OI="" F S OI=$O(OI(OI)) Q:'OI S RT=$P(^PS(50.7,OI,0),"^",6) S:RT="" RT="NONE" S RT(RT)=$P($G(^PS(51.2,+RT,0)),"^",3)
.S RT="" F RTCNT=0:1 S RT=$O(RT(RT)) Q:RT=""
.Q:RTCNT>1
.S RT=$O(RT("")) I RT]"" S P("MR")=RT_"^"_$G(RT(RT))
W !,"MED ROUTE: "_$S($P(P("MR"),U,2)]"":$P(P("MR"),U,2)_"//",1:"") R X:DTIME S:'$T X=U S:X=U DONE=1 I X=U!(X=""&P("MR"))!($E(X)=U) Q
I X["???",($E(P("OT"))="I"),(PSIVAC["C") D ORFLDS^PSIVEDT1 G 3
I X]"" K DIC S DIC=51.2,DIC(0)="EQMZ",DIC("S")="I $P(^(0),U,4)" D ^DIC K DIC I Y>0 S P("MR")=+Y_U_$P(Y(0),U,3) Q
S F1=53.1,F2=3 D ENHLP^PSIVORC1 W $C(7),!!,"A Med Route must be entered." G 3
Q
;
10 ; Start Date.
D 10^PSIVEDT1
Q
;
25 ; Stop Date.
D 25^PSIVEDT1
Q
26 ; Schedule
D 26^PSIVEDT1
Q
;
39 ; Admin Times.
D 39^PSIVEDT1
Q
;
57 ; Additive.
I $G(P("RES"))="R" I $G(PSJORD)["P",$P($G(^PS(53.1,+ON,0)),"^",24)="R" D Q
. W !!?5,"Additive may not be edited at this point." D PAUSE^VALM1
I $G(DFN)&($G(ON)["V") I $$COMPLEX^PSJOE(DFN,ON) D Q
.Q:$G(PSJBKDR) W !!?5,"This is a Complex Order. Provider may not be edited at this point." D PAUSE^VALM1
I $E(PSIVAC)="O" W !!,"Only additives marked for use in IV Fluid Order Entry may be selected."
S FIL=52.6,DRGT="AD",DRGTN="ADDITIVE" D DRG^PSIVEDRG,DKILL
Q
;
58 ; Solution.
I $G(P("RES"))="R" I $G(PSJORD)["P",$P($G(^PS(53.1,+ON,0)),"^",24)="R" D Q
. W !!?5,"Solution may not be edited at this point." D PAUSE^VALM1
S FIL=52.7,DRGT="SOL",DRGTN="SOLUTION" D DRG^PSIVEDRG
;
DKILL ; Kill for drug edit.
K DRGI,DRGN,DRGT,DRGTN,FIL,PSIVSTR
Q
;
59 ; Infusion Rate.
D 59^PSIVEDT1
Q
;
62 ; IV Room.
N DIR S DIR(0)="PA^59.5",DIR("A")="IV Room: ",DIR("??")="^S F1=59.5,F2=.01 D ENHLP^PSIVORC1" S:P("IVRM") DIR("B")=$P(P("IVRM"),U,2)
D ^DIR Q:$D(DIRUT) I Y>0 S P("IVRM")=Y W $P($P(Y,U,2),X,2)
Q
;
63 ; Remarks.
D 63^PSIVEDT1
Q
;
64 ; Other Print Info.
D 64^PSIVEDT1
Q
;
66 ; Provider's comments.
N DA,DIE,DIR S DA=PSIVUP,DIE="^PS(53.45,",DR=4 D ^DIE S PSGSI=X,Y=1
Q
;
101 ; Orderable Item.
I $G(P("RES"))="R" I $G(PSJORD)["P",$P($G(^PS(53.1,+ON,0)),"^",24)="R" D Q
. W !!?5,"This is Renewal order. Orderable Item may not be edited at this point." D PAUSE^VALM1
I $G(DFN)&($G(ON)["V") I $$COMPLEX^PSJOE(DFN,ON) D Q
.Q:$G(PSJBKDR) W !!?5,"This is a Complex Order. Orderable Item may not be edited at this point." D PAUSE^VALM1
W !,"Orderable Item: "_$S(P("PD"):$P(P("PD"),U,2)_"//",1:"") R X:DTIME S:'$T X=U S:X=U DONE=1 I $E(X)=U!(X=""&P("PD")) Q
I X]"" N DIC S DIC="^PS(50.7,",DIC(0)="EMQZ",DIC("B")=$S(P("PD")]"":+$P(("PD"),U),1:""),DIC("S")="S PSJSCT=1 I $$DRGSC^PSIVUTL(Y,PSJSCT) K PSJSCT" D ^DIC K DIC I Y>0 S P("PD")=Y Q
W $C(7),!!,"Orderable Item is required!",!! G 101
Q
109 ; Dosage Ordered.
W !,"DOSAGE ORDERED: "_$S(P("DO")]"":P("DO")_"//",1:"") R X:DTIME S:'$T X=U S:X=U DONE=1 I $E(X)=U!(P("DO")]""&(X="")) Q
I X="???" D ORFLDS^PSIVEDT1 G 109
D:X]"" CHK^DIE(53.1,109,"",X,.X) I $G(X)="^" W $C(7),!!,"Enter the dosage in which the Orderable Item entered should be dispensed.",! W "Answer must be 1-20 characters in length." G 109
S P("DO")=X
Q
;
FF ; up-arrow to another field.
N DIC S X=$P(X,U,2),DIC="^DD(53.1,",DIC(0)="QEM",DIC("S")="I U_PSIVOK_U[(U_+Y_U)" D ^DIC K DIC S Y=+Y
Q
;
NEWDRG ; Ask if adding a new drug.
K DIR S DIR(0)="Y",DIR("A")="Are you adding "_$P(TDRG,U,2)_" as a new "_$S(DRGT="AD":"additive",1:"solution")_" for this order",DIR("B")="NO" D ^DIR I $D(DTOUT)!$D(DUOUT) Q
I Y S (DRGI,DRG(DRGT,0))=DRG(DRGT,0)+1,DRG=TDRG,DRG(DRGT,+DRGI)=+DRG_U_$P(DRG,U,2) I DRGT="SOL" S X=$G(^PS(52.7,+DRG,0)),$P(DRG(DRGT,DRG),U,3)=$P(X,U,3)
Q
9999999 ;IHS/MSC/PB - 4/25/12 added to allow edits of the stability offset value - 4/20/12 PB
S II="A",OFFSET=31 F S II=$O(DRG(II)) Q:II="" S JJ=0 F S JJ=$O(DRG(II,JJ)) Q:JJ'>0 D
.Q:$P(DRG(II,JJ),"^",7)=""
.S:$P(DRG(II,JJ),"^",7)<OFFSET OFFSET=$P(DRG(II,JJ),"^",7)
S:OFFSET=31 OFFSET=0
;;IHS/MSC/PB - 3/23/13 added line below to set the current offset value as default
S:$G(^PS(53.1,+$G(ON),9999999))>0 OFFSET=$G(^PS(53.1,+ON,9999999))
;IHS/MSC/PB - 2/11/13 changed the prompt below to be Beyond Use Date
;W !,"Stability Offset Value: "_OFFSET_"//" R X:DTIME
;IHS/MSC/PB - 3/22/13 changed Date to Days
;W !,"Beyond Use Date: "_OFFSET_"//" R X:DTIME
I $D(P("OFFSET")) S OFFSET=P("OFFSET")
W !,"Beyond Use Days: "_OFFSET_"//" R X:DTIME
I X="^" S OFFSET=OFFSET Q
I X>30 W !,"Max value is 30..." G 9999999
I X<0 W !,"Minimum value is 0 (zero)..." G 9999999
I X="?" W !,"Number of days into the future from IV Label print where the IV will expire." G 9999999
S:X'="" OFFSET=X
S ON=APSPON,P("OFFSET")=OFFSET
;ADD CODE TO PUT VALUE INTO 53.1
S DA=+ON,DIE="^PS(53.1,",DR="9999999.01////"_$G(OFFSET) D ^DIE K DIE,DA,DR
;
Q
PSIVEDT ;BIR/MLM-EDIT IV ORDER ;02-Apr-2013 19:38;PLS
+1 ;;5.0; INPATIENT MEDICATIONS ;**4,110,127,133,134,1015**;16 DEC 97;Build 62
+2 ;
+3 ; Reference to ^DD(53.1 is supported by DBIA 2256.
+4 ; Reference to ^PS(52.7 is supported by DBIA 2173.
+5 ; Reference to ^PS(52.6 is supported by DBIA 1231.
+6 ; Reference to ^PS(51.2 is supported by DBIA 2178.
+7 ; Reference to ^PS(50.7 is supported by DBIA 2180.
+8 ; Reference to ^PS(55 is supported by DBIA 2191.
+9 ;
+10 ; Modified - IHS/MSC/PB - 4/20/12 - added line at EDIT+1
+11 ; - 4/20/12 - added line tag 9999999
+12 ; - 9/14/12 - modified line edit+5
+13 ; - 2/11/13 - modified line OFFSET+7 to read Beyond Use Date
+14 ; - 3/22/13 - changed prompt at 9999999+6 to read Beyond Use Days
+15 ; - 3/25/13 - added line OFFSET+6 to set the default value of the Beyond Use Days prompt
+16 ; - Modified EDIT + 1 to set APSPON to +$G(ON) commented out the line to add field 9999999 to the EDIT variable.
+17 ; - 04/02/13 - Line EDIT+6
EDIT ;
+1 ;IHS/MSC/PB line below modified to check the iv room parameter to determine if
+2 ;the expiration date prints on the iv label.
+3 ;IHS/MSC/PB - Line below changed to correct a problem with saving and then resetting the value of the variable ON should have set APSPON=$G(ON) not +$G(ON)
+4 ;I $P($G(^PS(59.5,+P("IVRM"),9999999)),"^")=1 S APSPON=+$G(ON) S:$G(EDIT)'[9999999 EDIT=EDIT_U_9999999
+5 ;I $P($G(^PS(59.5,+P("IVRM"),9999999)),"^")=1 S APSPON=$G(ON) S:$G(EDIT)'[9999999 EDIT=EDIT_U_9999999
+6 ;IHS/MSC/PLS - 04/02/12
IF +$GET(^PS(59.5,+P("IVRM"),9999999))
SET APSPON=$GET(ON)
IF $GET(EDIT)'[9999999
SET EDIT=EDIT_U_9999999
+7 IF $GET(DFN)&($GET(PSJORD)["V")
IF $$COMPLEX^PSJOE(DFN,PSJORD)
Begin DoDot:1
+8 NEW X,Y,PARENT,P2ND
SET P2ND=$SELECT($GET(^PS(55,PSGP,"IV",+PSJORD,.2)):$GET(^PS(55,PSGP,"IV",+PSJORD,.2)),1:$GET(^PS(55,PSGP,5,+PSJORD,.2)))
+9 SET PARENT=$PIECE(P2ND,"^",8)
+10 IF PARENT
DO FULL^VALM1
WRITE !!?5,"This order is part of a complex order. Please review the following ",!?5,"associated orders before changing this order."
DO CMPLX^PSJCOM1(PSGP,PARENT,PSJORD)
End DoDot:1
+11 SET DONE=0
+12 FOR PSIVE=1:1
IF DONE&$EXTRACT(PSIVAC)="C"
SET OREND=1
IF PSIVE>$LENGTH(EDIT,U)!(DONE)
QUIT
IF '$LENGTH($PIECE(EDIT,U,PSIVE))
QUIT
DO @(+$PIECE(EDIT,U,PSIVE))
IF $EXTRACT(PSIVAC,2)="N"
SET PSIVOK=PSIVOK_U_$PIECE(EDIT,U,PSIVE)
IF $EXTRACT(X)=U
IF $LENGTH(X)>1
IF PSIVE>1
SET PSIVE=PSIVE-1
FOR
DO FF
IF Y<0
QUIT
DO @Y
IF $EXTRACT(X)'=U
QUIT
+13 KILL EDIT,PSIVOK,PSGDIV
+14 QUIT
+15 ;
1 ; Provider.
+1 IF $GET(P("RES"))="R"
IF $GET(PSJORD)["P"
IF $PIECE($GET(^PS(53.1,+$GET(ON),0)),"^",24)="R"
Begin DoDot:1
+2 WRITE !!?5,"This is Renewal order. Provider may not be edited at this point."
DO PAUSE^VALM1
End DoDot:1
QUIT
+3 IF $GET(DFN)&($GET(ON)["V")
IF $$COMPLEX^PSJOE(DFN,ON)
Begin DoDot:1
+4 IF $GET(PSJBKDR)
QUIT
WRITE !!?5,"This is a Complex Order. Provider may not be edited at this point."
DO PAUSE^VALM1
End DoDot:1
QUIT
+5 SET P(6)=$SELECT('$GET(^VA(200,+P(6),"PS")):"",'$PIECE(^("PS"),U,4):P(6),$PIECE(^("PS"),U,4)<DT:"",1:P(6))
+6 WRITE !,"PROVIDER: "_$SELECT($PIECE(P(6),U,2)]"":$PIECE(P(6),U,2)_"//",1:"")
READ X:DTIME
IF '$TEST
SET X=U
IF X=U
SET DONE=1
IF $EXTRACT(X)=U!(X=""&P(6))
QUIT
+7 IF X["???"
IF ($EXTRACT(P("OT"))="I")
IF (PSIVAC["C")
DO ORFLDS^PSIVEDT1
GOTO 1
+8 IF X]""
KILL DIC
SET DIC=200
SET DIC(0)="EQMZ"
SET DIC("S")="I $D(^(""PS"")),^(""PS""),$S('$P(^(""PS""),U,4):1,$P(^(""PS""),U,4)>DT:1,1:0)"
DO ^DIC
KILL DIC
IF Y>0
SET P(6)=+Y_U_Y(0,0)
QUIT
+9 SET F1=53.1
SET F2=1
DO ENHLP^PSIVORC1
WRITE $CHAR(7),!!,"A Provider must be entered.",!!
GOTO 1
+10 QUIT
+11 ;
3 ; Med Route.
+1 IF $GET(P("RES"))="R"
IF $GET(PSJORD)["P"
IF $PIECE($GET(^PS(53.1,+ON,0)),"^",24)="R"
Begin DoDot:1
+2 WRITE !!?5,"Med Route may not be edited at this point."
DO PAUSE^VALM1
End DoDot:1
QUIT
+3 IF $GET(DFN)&($GET(ON)["V")
IF $$COMPLEX^PSJOE(DFN,ON)
Begin DoDot:1
+4 IF $GET(PSJBKDR)
QUIT
WRITE !!?5,"This is a Complex Order. Med Route may not be edited at this point."
DO PAUSE^VALM1
End DoDot:1
QUIT
+5 SET P(6)=$SELECT('$GET(^VA(200,+P(6),"PS")):"",'$PIECE(^("PS"),U,4):P(6),$PIECE(^("PS"),U,4)<DT:"",1:P(6))
+6 IF P("MR")=""
Begin DoDot:1
+7 NEW AD,SOL,OI,RT,RTCNT
+8 SET AD=0
FOR
SET AD=$ORDER(DRG("AD",AD))
IF 'AD
QUIT
SET OI=$PIECE(DRG("AD",AD),"^",6)
IF OI
SET OI(OI)=""
+9 SET SOL=0
FOR
SET SOL=$ORDER(DRG("SOL",SOL))
IF 'SOL
QUIT
SET OI=$PIECE(DRG("SOL",SOL),"^",6)
IF OI
SET OI(OI)=""
+10 SET OI=""
FOR
SET OI=$ORDER(OI(OI))
IF 'OI
QUIT
SET RT=$PIECE(^PS(50.7,OI,0),"^",6)
IF RT=""
SET RT="NONE"
SET RT(RT)=$PIECE($GET(^PS(51.2,+RT,0)),"^",3)
+11 SET RT=""
FOR RTCNT=0:1
SET RT=$ORDER(RT(RT))
IF RT=""
QUIT
+12 IF RTCNT>1
QUIT
+13 SET RT=$ORDER(RT(""))
IF RT]""
SET P("MR")=RT_"^"_$GET(RT(RT))
End DoDot:1
+14 WRITE !,"MED ROUTE: "_$SELECT($PIECE(P("MR"),U,2)]"":$PIECE(P("MR"),U,2)_"//",1:"")
READ X:DTIME
IF '$TEST
SET X=U
IF X=U
SET DONE=1
IF X=U!(X=""&P("MR"))!($EXTRACT(X)=U)
QUIT
+15 IF X["???"
IF ($EXTRACT(P("OT"))="I")
IF (PSIVAC["C")
DO ORFLDS^PSIVEDT1
GOTO 3
+16 IF X]""
KILL DIC
SET DIC=51.2
SET DIC(0)="EQMZ"
SET DIC("S")="I $P(^(0),U,4)"
DO ^DIC
KILL DIC
IF Y>0
SET P("MR")=+Y_U_$PIECE(Y(0),U,3)
QUIT
+17 SET F1=53.1
SET F2=3
DO ENHLP^PSIVORC1
WRITE $CHAR(7),!!,"A Med Route must be entered."
GOTO 3
+18 QUIT
+19 ;
10 ; Start Date.
+1 DO 10^PSIVEDT1
+2 QUIT
+3 ;
25 ; Stop Date.
+1 DO 25^PSIVEDT1
+2 QUIT
26 ; Schedule
+1 DO 26^PSIVEDT1
+2 QUIT
+3 ;
39 ; Admin Times.
+1 DO 39^PSIVEDT1
+2 QUIT
+3 ;
57 ; Additive.
+1 IF $GET(P("RES"))="R"
IF $GET(PSJORD)["P"
IF $PIECE($GET(^PS(53.1,+ON,0)),"^",24)="R"
Begin DoDot:1
+2 WRITE !!?5,"Additive may not be edited at this point."
DO PAUSE^VALM1
End DoDot:1
QUIT
+3 IF $GET(DFN)&($GET(ON)["V")
IF $$COMPLEX^PSJOE(DFN,ON)
Begin DoDot:1
+4 IF $GET(PSJBKDR)
QUIT
WRITE !!?5,"This is a Complex Order. Provider may not be edited at this point."
DO PAUSE^VALM1
End DoDot:1
QUIT
+5 IF $EXTRACT(PSIVAC)="O"
WRITE !!,"Only additives marked for use in IV Fluid Order Entry may be selected."
+6 SET FIL=52.6
SET DRGT="AD"
SET DRGTN="ADDITIVE"
DO DRG^PSIVEDRG
DO DKILL
+7 QUIT
+8 ;
58 ; Solution.
+1 IF $GET(P("RES"))="R"
IF $GET(PSJORD)["P"
IF $PIECE($GET(^PS(53.1,+ON,0)),"^",24)="R"
Begin DoDot:1
+2 WRITE !!?5,"Solution may not be edited at this point."
DO PAUSE^VALM1
End DoDot:1
QUIT
+3 SET FIL=52.7
SET DRGT="SOL"
SET DRGTN="SOLUTION"
DO DRG^PSIVEDRG
+4 ;
DKILL ; Kill for drug edit.
+1 KILL DRGI,DRGN,DRGT,DRGTN,FIL,PSIVSTR
+2 QUIT
+3 ;
59 ; Infusion Rate.
+1 DO 59^PSIVEDT1
+2 QUIT
+3 ;
62 ; IV Room.
+1 NEW DIR
SET DIR(0)="PA^59.5"
SET DIR("A")="IV Room: "
SET DIR("??")="^S F1=59.5,F2=.01 D ENHLP^PSIVORC1"
IF P("IVRM")
SET DIR("B")=$PIECE(P("IVRM"),U,2)
+2 DO ^DIR
IF $DATA(DIRUT)
QUIT
IF Y>0
SET P("IVRM")=Y
WRITE $PIECE($PIECE(Y,U,2),X,2)
+3 QUIT
+4 ;
63 ; Remarks.
+1 DO 63^PSIVEDT1
+2 QUIT
+3 ;
64 ; Other Print Info.
+1 DO 64^PSIVEDT1
+2 QUIT
+3 ;
66 ; Provider's comments.
+1 NEW DA,DIE,DIR
SET DA=PSIVUP
SET DIE="^PS(53.45,"
SET DR=4
DO ^DIE
SET PSGSI=X
SET Y=1
+2 QUIT
+3 ;
101 ; Orderable Item.
+1 IF $GET(P("RES"))="R"
IF $GET(PSJORD)["P"
IF $PIECE($GET(^PS(53.1,+ON,0)),"^",24)="R"
Begin DoDot:1
+2 WRITE !!?5,"This is Renewal order. Orderable Item may not be edited at this point."
DO PAUSE^VALM1
End DoDot:1
QUIT
+3 IF $GET(DFN)&($GET(ON)["V")
IF $$COMPLEX^PSJOE(DFN,ON)
Begin DoDot:1
+4 IF $GET(PSJBKDR)
QUIT
WRITE !!?5,"This is a Complex Order. Orderable Item may not be edited at this point."
DO PAUSE^VALM1
End DoDot:1
QUIT
+5 WRITE !,"Orderable Item: "_$SELECT(P("PD"):$PIECE(P("PD"),U,2)_"//",1:"")
READ X:DTIME
IF '$TEST
SET X=U
IF X=U
SET DONE=1
IF $EXTRACT(X)=U!(X=""&P("PD"))
QUIT
+6 IF X]""
NEW DIC
SET DIC="^PS(50.7,"
SET DIC(0)="EMQZ"
SET DIC("B")=$SELECT(P("PD")]"":+$PIECE(("PD"),U),1:"")
SET DIC("S")="S PSJSCT=1 I $$DRGSC^PSIVUTL(Y,PSJSCT) K PSJSCT"
DO ^DIC
KILL DIC
IF Y>0
SET P("PD")=Y
QUIT
+7 WRITE $CHAR(7),!!,"Orderable Item is required!",!!
GOTO 101
+8 QUIT
109 ; Dosage Ordered.
+1 WRITE !,"DOSAGE ORDERED: "_$SELECT(P("DO")]"":P("DO")_"//",1:"")
READ X:DTIME
IF '$TEST
SET X=U
IF X=U
SET DONE=1
IF $EXTRACT(X)=U!(P("DO")]""&(X=""))
QUIT
+2 IF X="???"
DO ORFLDS^PSIVEDT1
GOTO 109
+3 IF X]""
DO CHK^DIE(53.1,109,"",X,.X)
IF $GET(X)="^"
WRITE $CHAR(7),!!,"Enter the dosage in which the Orderable Item entered should be dispensed.",!
WRITE "Answer must be 1-20 characters in length."
GOTO 109
+4 SET P("DO")=X
+5 QUIT
+6 ;
FF ; up-arrow to another field.
+1 NEW DIC
SET X=$PIECE(X,U,2)
SET DIC="^DD(53.1,"
SET DIC(0)="QEM"
SET DIC("S")="I U_PSIVOK_U[(U_+Y_U)"
DO ^DIC
KILL DIC
SET Y=+Y
+2 QUIT
+3 ;
NEWDRG ; Ask if adding a new drug.
+1 KILL DIR
SET DIR(0)="Y"
SET DIR("A")="Are you adding "_$PIECE(TDRG,U,2)_" as a new "_$SELECT(DRGT="AD":"additive",1:"solution")_" for this order"
SET DIR("B")="NO"
DO ^DIR
IF $DATA(DTOUT)!$DATA(DUOUT)
QUIT
+2 IF Y
SET (DRGI,DRG(DRGT,0))=DRG(DRGT,0)+1
SET DRG=TDRG
SET DRG(DRGT,+DRGI)=+DRG_U_$PIECE(DRG,U,2)
IF DRGT="SOL"
SET X=$GET(^PS(52.7,+DRG,0))
SET $PIECE(DRG(DRGT,DRG),U,3)=$PIECE(X,U,3)
+3 QUIT
9999999 ;IHS/MSC/PB - 4/25/12 added to allow edits of the stability offset value - 4/20/12 PB
+1 SET II="A"
SET OFFSET=31
FOR
SET II=$ORDER(DRG(II))
IF II=""
QUIT
SET JJ=0
FOR
SET JJ=$ORDER(DRG(II,JJ))
IF JJ'>0
QUIT
Begin DoDot:1
+2 IF $PIECE(DRG(II,JJ),"^",7)=""
QUIT
+3 IF $PIECE(DRG(II,JJ),"^",7)<OFFSET
SET OFFSET=$PIECE(DRG(II,JJ),"^",7)
End DoDot:1
+4 IF OFFSET=31
SET OFFSET=0
+5 ;;IHS/MSC/PB - 3/23/13 added line below to set the current offset value as default
+6 IF $GET(^PS(53.1,+$GET(ON),9999999))>0
SET OFFSET=$GET(^PS(53.1,+ON,9999999))
+7 ;IHS/MSC/PB - 2/11/13 changed the prompt below to be Beyond Use Date
+8 ;W !,"Stability Offset Value: "_OFFSET_"//" R X:DTIME
+9 ;IHS/MSC/PB - 3/22/13 changed Date to Days
+10 ;W !,"Beyond Use Date: "_OFFSET_"//" R X:DTIME
+11 IF $DATA(P("OFFSET"))
SET OFFSET=P("OFFSET")
+12 WRITE !,"Beyond Use Days: "_OFFSET_"//"
READ X:DTIME
+13 IF X="^"
SET OFFSET=OFFSET
QUIT
+14 IF X>30
WRITE !,"Max value is 30..."
GOTO 9999999
+15 IF X<0
WRITE !,"Minimum value is 0 (zero)..."
GOTO 9999999
+16 IF X="?"
WRITE !,"Number of days into the future from IV Label print where the IV will expire."
GOTO 9999999
+17 IF X'=""
SET OFFSET=X
+18 SET ON=APSPON
SET P("OFFSET")=OFFSET
+19 ;ADD CODE TO PUT VALUE INTO 53.1
+20 SET DA=+ON
SET DIE="^PS(53.1,"
SET DR="9999999.01////"_$GET(OFFSET)
DO ^DIE
KILL DIE,DA,DR
+21 ;
+22 QUIT
