PSIVEDT ;BIR/MLM - EDIT IV ORDER ;Nov 23, 2021@09:57:57
;;5.0;INPATIENT MEDICATIONS;**4,110,127,133,134,181,252,281,366,319,399,372**;16 DEC 97;Build 153
;
; Reference to ^PS(53.1 is supported by DBIA 2256.
; Reference to ^PS(52.7 is supported by DBIA 2173.
; 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.
; Reference to ^PSSJORDF is supported by DBIA 2418.
; Reference to $$SDEA^XUSER supported by DBIA #2343.
;
EDIT ;
;Store the DRG array. If it changed then to do an OC
NEW TMPDRG,PSJFLG57,PSIVE,PSIALLFL
D SAVEDRG^PSIVEDRG(.TMPDRG,.DRG)
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
I $G(PSGORQF) K PSIVEDIT S PSJOCCHK=1,PSIVENO=1 ;RTC 151046
I '$G(PSGORQF),$G(PSJOCCHK) K PSJOCCHK,PSIVENO D OC^PSIVOC
K EDIT,PSIVOK,PSGDI
;If quit then restore DRG( to pre-edit state
I $G(PSGORQF) D SAVEDRG^PSIVEDRG(.DRG,.TMPDRG)
Q
;
1 ; Provider.
N BKP6 S BKP6="" S:P(6) BKP6=P(6)
N1 ;
N PSADCNT,PSPROV ; ** Patch 545 **
;
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
;*366 - check provider credentials
S P(6)=$S($$ACTPRO^PSGOE1(+P(6)):P(6),1:"")
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="") S PSPROV=+$G(P(6)) G:$$IVDEA(.DRG,PSPROV,.P) N1 Q:P(6)
I X=U,P(6)="",BKP6]"" S P(6)=BKP6 W $C(7),!!?5,"INVALID PROVIDER." D PAUSE^VALM1 Q
Q:X="^"
I X["???",($E(P("OT"))="I"),(PSIVAC["C") D ORFLDS^PSIVEDT1 G N1
; Patch 545
I X]"" K DIC S DIC=200,DIC(0)="EQMZ",DIC("S")="I $$ACTPRO^PSGOE1(+Y)" D ^DIC K DIC I Y>0 S P(6)=+Y_U_Y(0,0) G:$$IVDEA(.DRG,.Y,.P) N1 Q
S F1=53.1,F2=1 D ENHLP^PSIVORC1 W $C(7),!!,"A Provider must be entered.",!! G N1
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))
;*366 - OIZ to collect the OIs, CT for count
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))
;*366
N OIZ,MRTFN S OIZ=0,MRTFN="PSITP" K ^TMP(MRTFN,$J)
D MROL ;to collect overlapping MR list
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
;*366 - to check for "?" and to select from the short list
I X["???",($E(P("OT"))="I"),(PSIVAC["C") D ORFLDS^PSIVEDT1 G 3
I X="?",$G(OIZ) D MRSL G:X=U 3 G CNT
D:$G(OIZ) CKMRSL K ^TMP(MRTFN,$J),OIZ,MRTFN
CNT ;
I X]"" K DIC S DIC=51.2,DIC(0)="EQMZX",DIC("S")="I $P(^(0),U,4)" D ^DIC K DIC I Y>0 S P("MR")=+Y_U_$P(Y(0),U,3) S:$E($G(PSJOCFG),1,2)="FN" PSJFNDS=1 Q ;366
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
I $E($G(PSJOCFG),1,2)="FN" S PSJFNDS=1
Q
;
25 ; Stop Date.
D 25^PSIVEDT1
I $E($G(PSJOCFG),1,2)="FN" S PSJFNDS=1
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."
; Reference to ^PS(52.6 is supported by DBIA 1231.
S FIL=52.6,DRGT="AD",DRGTN="ADDITIVE" D DRG^PSIVEDRG,DKILL
;I $G(X)="^" G DKILL
;If Solution prompt is next then wait to do dose checks after all solutions are entered.
;PSJFLG57 is set so OC is triggered when the user entered ^ADDITIVE.
I $$COMPARE^PSJMISC(.DRG,.TMPDRG) D
. D ENSTOP^PSIVCAL
. I $S($G(PSJFLG57):1,($G(EDIT)'["58"):1,1:0) K PSJFLG57,PSJOCCHK D OC^PSIVOC S:$G(EDIT)]"" PSJENHOC=1
I $G(X)="^" G DKILL
Q
;
58 ; Solution.
NEW PSJCMPFG
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
;I $G(X)="^" G DKILL
;I $G(X)']"^",$$COMPARE^PSJMISC(.DRG,.TMPDRG) D OC^PSIVOC
S PSJCMPFG=$$COMPARE^PSJMISC(.DRG,.TMPDRG)
I 'PSJCMPFG,$$COMPARE^PSJMISC(.DRG,.TMPDRG,1) D
. NEW X,PSJALLGY
. K PSJALLGY
. D SETDD^PSIVOC(1)
. D GMRAOC^PSJOC S:'$G(PSGORQF) PSIALLFL=1
. K PSJALLGY
Q:$G(PSGORQF)
I PSJCMPFG K PSJOCCHK D ENSTOP^PSIVCAL D OC^PSIVOC S:$G(EDIT)]"" PSJENHOC=1
K PSJCMPFG
I $G(X)="^" G DKILL
;
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,DR 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
;
113 ; Clinic appointment. ;*p319
D 50^PSGOE82
Q
;
126 ; Clinic date. ;*p319
D 51^PSGOE82
Q
;
132 ;*399-IND
D IND^PSIVEDT1
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
I Y=57 S PSJFLG57=1
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
;
MRSL ;check for OI med route short list;*366
N I S I=0 F S I=$O(^TMP(MRTFN,$J,I)) Q:'I W !,?10,I_" "_$P(^TMP(MRTFN,$J,I,0),U)_" "_$P(^TMP(MRTFN,$J,I,0),U,3)
N DIC S DIC("A")="Select MED ROUTE: ",DIC="^TMP(MRTFN,$J,",DIC(0)="AEQZ" D ^DIC
Q:Y=-1
I X=" " S X="^" Q
S X=$P(Y,"^",2)
Q
;
CKMRSL ;;check for med route short list leading letters ;*366
N DIC S DIC("T")="",DIC="^TMP(MRTFN,$J,",DIC(0)="EM" D ^DIC
Q:Y=-1
S X=$P(Y,"^",2)
Q
;
MROL ;
N I,OI,CT
S (I,CT)=0 F S I=$O(DRG("AD",I)) Q:'I S OI=$P(DRG("AD",I),"^",6) I OI S CT=CT+1,OIZ(CT)=OI
S I=0 F S I=$O(DRG("SOL",I)) Q:'I S OI=$P(DRG("SOL",I),"^",6) I OI S CT=CT+1,OIZ(CT)=OI
S OIZ(0)=CT
D START1^PSSJORDF(.OIZ,"")
S OIZ=$O(OIZ("A"),-1)
I OIZ D
. S ^TMP(MRTFN,$J,0)=U_U_OIZ_U_OIZ
. N ZZ S I=0 F S I=$O(OIZ(I)) Q:'I D
. . S ZZ($P(OIZ(I),U,2))=$P(OIZ(I),U,2)_U_$P(OIZ(I),U)_U_$P(OIZ(I),U,3,5)
. S (I,CT)=0 F S I=$O(ZZ(I)) Q:I="" D
. . S CT=CT+1,^TMP(MRTFN,$J,CT,0)=ZZ(I),^TMP(MRTFN,$J,"B",I,CT)=""
Q
;
IVDEA(DRG,PROVIEN,P) ; Check that provider PROVIEN is authorized to prescribe CS schedules in DRG("AD") and DRG("SOL")
;**************************************************************
;***************************************************************
;^PS(52.6: DRG("AD",0)=1
; DRG("AD",1)="26^MORPHINE^10 MG^^1^435"
;^PS(52.7: DRG("SOL",0)=1
; DRG("SOL",1)="33^DEXTROSE 5%^100 ML^^^196"
;
S PSDEAFLG=0
Q:'$G(PROVIEN) 0
Q:'$D(DRG) 0
;
; Check Additives
N SCHDCHK S SCHDCHK=""
S ADCNT=0 F S ADCNT=$O(DRG("AD",ADCNT)) Q:'ADCNT D
.;S PSPPKG=$S(PSJPROT=1:"U",PSJPROT=3:"UI",1:"") Q:PSPPKG=""
. N PSADIEN,PSADOI S PSADIEN=+$G(DRG("AD",ADCNT)) Q:'PSADIEN
. S PSADOI=$$GET1^DIQ(52.6,PSADIEN,15,"I")
. S PSIVDEA=$$OIDEA^PSSOPKI(PSADOI,"I"),PSDEA=$P(PSIVDEA,";",2) I (PSDEA>=2),(PSDEA<=5) S PDEA=$$SDEA^XUSER(,+PROVIEN,PSDEA,,"I")
. I ($G(PDEA)=2)!($G(PDEA)=1)!(+$G(PDEA)=4) S PSDEAFLG=+$G(PSDEAFLG)+1,P(6)="",PROVIEN="" D
.. I PDEA=2 W !,"Provider not authorized to prescribe medications in Federal Schedule "_PSDEA_".",!,"Please contact the provider.",! Q
.. W $C(7),!!,"Provider must have a valid DEA# or VA# to write prescriptions for this drug.",!
;
; Check Solutions
S SOLCNT=0 F S SOLCNT=$O(DRG("SOL",SOLCNT)) Q:'SOLCNT D
.;S PSPPKG=$S(PSJPROT=1:"U",PSJPROT=3:"UI",1:"") Q:PSPPKG=""
. N PSADIEN,PSADOI,PDEA S PSADIEN=+$G(DRG("SOL",SOLCNT)) Q:'PSADIEN
. S PSADOI=$$GET1^DIQ(52.7,PSADIEN,9,"I")
. S PSIVDEA=$$OIDEA^PSSOPKI(PSADOI,"I"),PSDEA=$P(PSIVDEA,";",2) I (PSDEA>=2),(PSDEA<=5) S PDEA=$$SDEA^XUSER(,+PROVIEN,PSDEA,,"I")
. I ($G(PDEA)=2)!($G(PDEA)=1)!(+$G(PDEA)=4) S PSDEAFLG=+$G(PSDEAFLG)+1,P(6)="",PROVIEN="" D
.. I PDEA=2 W !,"Provider not authorized to prescribe medications in Federal Schedule "_PSDEA_".",!,"Please contact the provider.",! Q
.. W $C(7),!!,"Provider must have a valid DEA# or VA# to write prescriptions for this drug.",!
Q PSDEAFLG
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSIVEDT 11452 printed Sep 23, 2025@19:40:12 Page 2
PSIVEDT ;BIR/MLM - EDIT IV ORDER ;Nov 23, 2021@09:57:57
+1 ;;5.0;INPATIENT MEDICATIONS;**4,110,127,133,134,181,252,281,366,319,399,372**;16 DEC 97;Build 153
+2 ;
+3 ; Reference to ^PS(53.1 is supported by DBIA 2256.
+4 ; Reference to ^PS(52.7 is supported by DBIA 2173.
+5 ; Reference to ^PS(51.2 is supported by DBIA 2178.
+6 ; Reference to ^PS(50.7 is supported by DBIA 2180.
+7 ; Reference to ^PS(55 is supported by DBIA 2191.
+8 ; Reference to ^PSSJORDF is supported by DBIA 2418.
+9 ; Reference to $$SDEA^XUSER supported by DBIA #2343.
+10 ;
EDIT ;
+1 ;Store the DRG array. If it changed then to do an OC
+2 NEW TMPDRG,PSJFLG57,PSIVE,PSIALLFL
+3 DO SAVEDRG^PSIVEDRG(.TMPDRG,.DRG)
+4 IF $GET(DFN)&($GET(PSJORD)["V")
IF $$COMPLEX^PSJOE(DFN,PSJORD)
Begin DoDot:1
+5 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)))
+6 SET PARENT=$PIECE(P2ND,"^",8)
+7 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
+8 SET DONE=0
+9 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
+10 ;RTC 151046
IF $GET(PSGORQF)
KILL PSIVEDIT
SET PSJOCCHK=1
SET PSIVENO=1
+11 IF '$GET(PSGORQF)
IF $GET(PSJOCCHK)
KILL PSJOCCHK,PSIVENO
DO OC^PSIVOC
+12 KILL EDIT,PSIVOK,PSGDI
+13 ;If quit then restore DRG( to pre-edit state
+14 IF $GET(PSGORQF)
DO SAVEDRG^PSIVEDRG(.DRG,.TMPDRG)
+15 QUIT
+16 ;
1 ; Provider.
+1 NEW BKP6
SET BKP6=""
if P(6)
SET BKP6=P(6)
N1 ;
+1 ; ** Patch 545 **
NEW PSADCNT,PSPROV
+2 ;
+3 IF $GET(P("RES"))="R"
IF $GET(PSJORD)["P"
IF $PIECE($GET(^PS(53.1,+$GET(ON),0)),"^",24)="R"
Begin DoDot:1
+4 WRITE !!?5,"This is Renewal order. Provider may not be edited at this point."
DO PAUSE^VALM1
End DoDot:1
QUIT
+5 IF $GET(DFN)&($GET(ON)["V")
IF $$COMPLEX^PSJOE(DFN,ON)
Begin DoDot:1
+6 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
+7 ;*366 - check provider credentials
+8 SET P(6)=$SELECT($$ACTPRO^PSGOE1(+P(6)):P(6),1:"")
+9 WRITE !,"PROVIDER: "_$SELECT($PIECE(P(6),U,2)]"":$PIECE(P(6),U,2)_"//",1:"")
READ X:DTIME
+10 if '$TEST
SET X=U
if X=U
SET DONE=1
IF $EXTRACT(X)=U!(X="")
SET PSPROV=+$GET(P(6))
if $$IVDEA(.DRG,PSPROV,.P)
GOTO N1
if P(6)
QUIT
+11 IF X=U
IF P(6)=""
IF BKP6]""
SET P(6)=BKP6
WRITE $CHAR(7),!!?5,"INVALID PROVIDER."
DO PAUSE^VALM1
QUIT
+12 if X="^"
QUIT
+13 IF X["???"
IF ($EXTRACT(P("OT"))="I")
IF (PSIVAC["C")
DO ORFLDS^PSIVEDT1
GOTO N1
+14 ; Patch 545
+15 IF X]""
KILL DIC
SET DIC=200
SET DIC(0)="EQMZ"
SET DIC("S")="I $$ACTPRO^PSGOE1(+Y)"
DO ^DIC
KILL DIC
IF Y>0
SET P(6)=+Y_U_Y(0,0)
if $$IVDEA(.DRG,.Y,.P)
GOTO N1
QUIT
+16 SET F1=53.1
SET F2=1
DO ENHLP^PSIVORC1
WRITE $CHAR(7),!!,"A Provider must be entered.",!!
GOTO N1
+17 QUIT
+18 ;
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 ;S P(6)=$S('$G(^VA(200,+P(6),"PS")):"",'$P(^("PS"),U,4):P(6),$P(^("PS"),U,4)<DT:"",1:P(6))
+6 ;*366 - OIZ to collect the OIs, CT for count
+7 IF P("MR")=""
Begin DoDot:1
+8 NEW AD,SOL,OI,RT,RTCNT
+9 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)=""
+10 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)=""
+11 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)
+12 SET RT=""
FOR RTCNT=0:1
SET RT=$ORDER(RT(RT))
if RT=""
QUIT
+13 if RTCNT>1
QUIT
+14 SET RT=$ORDER(RT(""))
IF RT]""
SET P("MR")=RT_"^"_$GET(RT(RT))
End DoDot:1
+15 ;*366
+16 NEW OIZ,MRTFN
SET OIZ=0
SET MRTFN="PSITP"
KILL ^TMP(MRTFN,$JOB)
+17 ;to collect overlapping MR list
DO MROL
+18 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
+19 ;*366 - to check for "?" and to select from the short list
+20 IF X["???"
IF ($EXTRACT(P("OT"))="I")
IF (PSIVAC["C")
DO ORFLDS^PSIVEDT1
GOTO 3
+21 IF X="?"
IF $GET(OIZ)
DO MRSL
if X=U
GOTO 3
GOTO CNT
+22 if $GET(OIZ)
DO CKMRSL
KILL ^TMP(MRTFN,$JOB),OIZ,MRTFN
CNT ;
+1 ;366
IF X]""
KILL DIC
SET DIC=51.2
SET DIC(0)="EQMZX"
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)
if $EXTRACT($GET(PSJOCFG),1,2)="FN"
SET PSJFNDS=1
QUIT
+2 SET F1=53.1
SET F2=3
DO ENHLP^PSIVORC1
WRITE $CHAR(7),!!,"A Med Route must be entered."
GOTO 3
+3 QUIT
+4 ;
10 ; Start Date.
+1 DO 10^PSIVEDT1
+2 IF $EXTRACT($GET(PSJOCFG),1,2)="FN"
SET PSJFNDS=1
+3 QUIT
+4 ;
25 ; Stop Date.
+1 DO 25^PSIVEDT1
+2 IF $EXTRACT($GET(PSJOCFG),1,2)="FN"
SET PSJFNDS=1
+3 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 ; Reference to ^PS(52.6 is supported by DBIA 1231.
+7 SET FIL=52.6
SET DRGT="AD"
SET DRGTN="ADDITIVE"
DO DRG^PSIVEDRG
DO DKILL
+8 ;I $G(X)="^" G DKILL
+9 ;If Solution prompt is next then wait to do dose checks after all solutions are entered.
+10 ;PSJFLG57 is set so OC is triggered when the user entered ^ADDITIVE.
+11 IF $$COMPARE^PSJMISC(.DRG,.TMPDRG)
Begin DoDot:1
+12 DO ENSTOP^PSIVCAL
+13 IF $SELECT($GET(PSJFLG57):1,($GET(EDIT)'["58"):1,1:0)
KILL PSJFLG57,PSJOCCHK
DO OC^PSIVOC
if $GET(EDIT)]""
SET PSJENHOC=1
End DoDot:1
+14 IF $GET(X)="^"
GOTO DKILL
+15 QUIT
+16 ;
58 ; Solution.
+1 NEW PSJCMPFG
+2 IF $GET(P("RES"))="R"
IF $GET(PSJORD)["P"
IF $PIECE($GET(^PS(53.1,+ON,0)),"^",24)="R"
Begin DoDot:1
+3 WRITE !!?5,"Solution may not be edited at this point."
DO PAUSE^VALM1
End DoDot:1
QUIT
+4 SET FIL=52.7
SET DRGT="SOL"
SET DRGTN="SOLUTION"
DO DRG^PSIVEDRG
+5 ;I $G(X)="^" G DKILL
+6 ;I $G(X)']"^",$$COMPARE^PSJMISC(.DRG,.TMPDRG) D OC^PSIVOC
+7 SET PSJCMPFG=$$COMPARE^PSJMISC(.DRG,.TMPDRG)
+8 IF 'PSJCMPFG
IF $$COMPARE^PSJMISC(.DRG,.TMPDRG,1)
Begin DoDot:1
+9 NEW X,PSJALLGY
+10 KILL PSJALLGY
+11 DO SETDD^PSIVOC(1)
+12 DO GMRAOC^PSJOC
if '$GET(PSGORQF)
SET PSIALLFL=1
+13 KILL PSJALLGY
End DoDot:1
+14 if $GET(PSGORQF)
QUIT
+15 IF PSJCMPFG
KILL PSJOCCHK
DO ENSTOP^PSIVCAL
DO OC^PSIVOC
if $GET(EDIT)]""
SET PSJENHOC=1
+16 KILL PSJCMPFG
+17 IF $GET(X)="^"
GOTO DKILL
+18 ;
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,DR
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 ;
113 ; Clinic appointment. ;*p319
+1 DO 50^PSGOE82
+2 QUIT
+3 ;
126 ; Clinic date. ;*p319
+1 DO 51^PSGOE82
+2 QUIT
+3 ;
132 ;*399-IND
+1 DO IND^PSIVEDT1
+2 QUIT
+3 ;
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 IF Y=57
SET PSJFLG57=1
+3 QUIT
+4 ;
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
+4 ;
MRSL ;check for OI med route short list;*366
+1 NEW I
SET I=0
FOR
SET I=$ORDER(^TMP(MRTFN,$JOB,I))
if 'I
QUIT
WRITE !,?10,I_" "_$PIECE(^TMP(MRTFN,$JOB,I,0),U)_" "_$PIECE(^TMP(MRTFN,$JOB,I,0),U,3)
+2 NEW DIC
SET DIC("A")="Select MED ROUTE: "
SET DIC="^TMP(MRTFN,$J,"
SET DIC(0)="AEQZ"
DO ^DIC
+3 if Y=-1
QUIT
+4 IF X=" "
SET X="^"
QUIT
+5 SET X=$PIECE(Y,"^",2)
+6 QUIT
+7 ;
CKMRSL ;;check for med route short list leading letters ;*366
+1 NEW DIC
SET DIC("T")=""
SET DIC="^TMP(MRTFN,$J,"
SET DIC(0)="EM"
DO ^DIC
+2 if Y=-1
QUIT
+3 SET X=$PIECE(Y,"^",2)
+4 QUIT
+5 ;
MROL ;
+1 NEW I,OI,CT
+2 SET (I,CT)=0
FOR
SET I=$ORDER(DRG("AD",I))
if 'I
QUIT
SET OI=$PIECE(DRG("AD",I),"^",6)
IF OI
SET CT=CT+1
SET OIZ(CT)=OI
+3 SET I=0
FOR
SET I=$ORDER(DRG("SOL",I))
if 'I
QUIT
SET OI=$PIECE(DRG("SOL",I),"^",6)
IF OI
SET CT=CT+1
SET OIZ(CT)=OI
+4 SET OIZ(0)=CT
+5 DO START1^PSSJORDF(.OIZ,"")
+6 SET OIZ=$ORDER(OIZ("A"),-1)
+7 IF OIZ
Begin DoDot:1
+8 SET ^TMP(MRTFN,$JOB,0)=U_U_OIZ_U_OIZ
+9 NEW ZZ
SET I=0
FOR
SET I=$ORDER(OIZ(I))
if 'I
QUIT
Begin DoDot:2
+10 SET ZZ($PIECE(OIZ(I),U,2))=$PIECE(OIZ(I),U,2)_U_$PIECE(OIZ(I),U)_U_$PIECE(OIZ(I),U,3,5)
End DoDot:2
+11 SET (I,CT)=0
FOR
SET I=$ORDER(ZZ(I))
if I=""
QUIT
Begin DoDot:2
+12 SET CT=CT+1
SET ^TMP(MRTFN,$JOB,CT,0)=ZZ(I)
SET ^TMP(MRTFN,$JOB,"B",I,CT)=""
End DoDot:2
End DoDot:1
+13 QUIT
+14 ;
IVDEA(DRG,PROVIEN,P) ; Check that provider PROVIEN is authorized to prescribe CS schedules in DRG("AD") and DRG("SOL")
+1 ;**************************************************************
+2 ;***************************************************************
+3 ;^PS(52.6: DRG("AD",0)=1
+4 ; DRG("AD",1)="26^MORPHINE^10 MG^^1^435"
+5 ;^PS(52.7: DRG("SOL",0)=1
+6 ; DRG("SOL",1)="33^DEXTROSE 5%^100 ML^^^196"
+7 ;
+8 SET PSDEAFLG=0
+9 if '$GET(PROVIEN)
QUIT 0
+10 if '$DATA(DRG)
QUIT 0
+11 ;
+12 ; Check Additives
+13 NEW SCHDCHK
SET SCHDCHK=""
+14 SET ADCNT=0
FOR
SET ADCNT=$ORDER(DRG("AD",ADCNT))
if 'ADCNT
QUIT
Begin DoDot:1
+15 ;S PSPPKG=$S(PSJPROT=1:"U",PSJPROT=3:"UI",1:"") Q:PSPPKG=""
+16 NEW PSADIEN,PSADOI
SET PSADIEN=+$GET(DRG("AD",ADCNT))
if 'PSADIEN
QUIT
+17 SET PSADOI=$$GET1^DIQ(52.6,PSADIEN,15,"I")
+18 SET PSIVDEA=$$OIDEA^PSSOPKI(PSADOI,"I")
SET PSDEA=$PIECE(PSIVDEA,";",2)
IF (PSDEA>=2)
IF (PSDEA<=5)
SET PDEA=$$SDEA^XUSER(,+PROVIEN,PSDEA,,"I")
+19 IF ($GET(PDEA)=2)!($GET(PDEA)=1)!(+$GET(PDEA)=4)
SET PSDEAFLG=+$GET(PSDEAFLG)+1
SET P(6)=""
SET PROVIEN=""
Begin DoDot:2
+20 IF PDEA=2
WRITE !,"Provider not authorized to prescribe medications in Federal Schedule "_PSDEA_".",!,"Please contact the provider.",!
QUIT
+21 WRITE $CHAR(7),!!,"Provider must have a valid DEA# or VA# to write prescriptions for this drug.",!
End DoDot:2
End DoDot:1
+22 ;
+23 ; Check Solutions
+24 SET SOLCNT=0
FOR
SET SOLCNT=$ORDER(DRG("SOL",SOLCNT))
if 'SOLCNT
QUIT
Begin DoDot:1
+25 ;S PSPPKG=$S(PSJPROT=1:"U",PSJPROT=3:"UI",1:"") Q:PSPPKG=""
+26 NEW PSADIEN,PSADOI,PDEA
SET PSADIEN=+$GET(DRG("SOL",SOLCNT))
if 'PSADIEN
QUIT
+27 SET PSADOI=$$GET1^DIQ(52.7,PSADIEN,9,"I")
+28 SET PSIVDEA=$$OIDEA^PSSOPKI(PSADOI,"I")
SET PSDEA=$PIECE(PSIVDEA,";",2)
IF (PSDEA>=2)
IF (PSDEA<=5)
SET PDEA=$$SDEA^XUSER(,+PROVIEN,PSDEA,,"I")
+29 IF ($GET(PDEA)=2)!($GET(PDEA)=1)!(+$GET(PDEA)=4)
SET PSDEAFLG=+$GET(PSDEAFLG)+1
SET P(6)=""
SET PROVIEN=""
Begin DoDot:2
+30 IF PDEA=2
WRITE !,"Provider not authorized to prescribe medications in Federal Schedule "_PSDEA_".",!,"Please contact the provider.",!
QUIT
+31 WRITE $CHAR(7),!!,"Provider must have a valid DEA# or VA# to write prescriptions for this drug.",!
End DoDot:2
End DoDot:1
+32 QUIT PSDEAFLG
