PSIVEDT1 ;BIR/MLM - EDIT IV ORDER (CONT) ;Nov 2, 2021@12:47:00
;;5.0;INPATIENT MEDICATIONS;**3,7,41,47,50,64,58,116,110,111,113,267,279,305,194,373,411,416,399**;16 DEC 97;Build 64
;
; Reference to ^PS(55 is supported by DBIA# 2191.
; Reference to ^PS(51.1 is supported by DBIA# 2177.
;
10 ; Start Date
I $G(P("APPT")) S P(2)=P("APPT") ;p411 - set Start Date to Visit Date
D:'P(2)&P("IVRM")!($G(PSJREN)) ENT^PSIVCAL
A10 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. Start Date may not be edited at this point." D PAUSE^VALM1
I $G(ON)["V"!($G(ON)["U") I $$COMPLEX^PSJOE(DFN,ON) D Q
.Q:$G(PSJBKDR) W !!?5,"This is a Complex Order. Start Date may not be edited at this point." D PAUSE^VALM1
S Y=P(2) X ^DD("DD") W !,"START DATE/TIME: "_$S(Y]"":Y_"// ",1:"") R X:DTIME S:'$T X=U S:X=U DONE=1 I $E(X)=U!(P(2)&X="") Q
I X["???",($E(P("OT"))="I"),(PSIVAC["C") D ORFLDS G 10
I X="@"!(X?1."?") W:X="@" $C(7)," (Required)" S F1=53.1,F2=10 S:X="@" X="?" D ENHLP^PSIVORC1 G A10
K %DT S:X="" X=P(2) S %DT="ERTX" D ^%DT K %DT G:Y'>0 A10
I $G(P("RES"))="R",(+Y<+$P($G(^PS(55,DFN,"IV",+$G(P("OLDON")),0)),U,2)) D G 10
.; naked ref below refers to line above
.S Y=$P(^(0),U,2) X ^DD("DD") W $C(7),!!,"Start date of order being renewed is ",Y,".",!,"Start date of renewal order must be AFTER start date of order being renewed.",!
S X1=$G(P("LOG")),X2=-7 D C^%DTC I +Y<X W $C(7),!!,"Start date/time may not be entered prior to 7 days from the order's LOGIN DATE.",! G A10
; RBD PSJ*5*373 Soft stop when Start Date more than 7 days after Order's LOGIN DATE
S X1=$G(P("LOG")),X2=+7 D C^%DTC
I +Y>X W !!,$C(7),"Start date/time should not be entered for more than 7 days after the",!,"order's LOGIN DATE.",! K DIR D WAIT^VALM1
S P(2)=+Y,PSGSDX=1
Q
;
25 ; Stop Date
G:$D(PSGFDX) A25
I P("IVRM")]"",$S(P(3)<P(2):1,$G(PSIVAC)["E":0,1:1) S PSIVSITE=$G(^PS(59.5,+P("IVRM"),1)),$P(PSIVSITE,"^",20,21)=$G(^PS(59.5,+P("IVRM"),5)) D ENSTOP^PSIVCAL
A25 I $G(ON)["V"!($G(ON)["U") I $$COMPLEX^PSJOE(DFN,ON) D Q
.Q:$G(PSJBKDR) W !!?5,"This is a Complex Order. Stop Date may not be edited at this point." D PAUSE^VALM1
S Y=P(3) X ^DD("DD") W !,"STOP DATE/TIME: "_$S(Y]"":Y_"// ",1:"") R X:DTIME S:'$T X=U S:X=U DONE=1 Q:X=""&P(2) I $E(X)=U!(X=""&P(2)) Q
I X["???",($E(P("OT"))="I"),(PSIVAC["C") D ORFLDS G 25
I X="@"!(X["?") W $C(7)," (Required)" S F1=53.1,F2=25,X="?" D ENHLP^PSIVORC1 G A25
K %DT S:X="" X=$G(Y) S:X="" X=P(3) S %DT="ERTX" D:X'=+X ^%DT
I X=+X,X>0,X'>2000000 G A25:'$$ENDL^PSGDL(P(9),X) D ENDL^PSIVSP
D DOSE
I $G(X)="" S X=Y
I $G(X)="" S X=P(3)
I $G(Z)]"",Z>X D G A25
. W !,"There is no administration time that falls between the Start Date/Time"
. W !,"and Stop Date/Time.",!
S X=Y S:Y<1!Y'["." X="" G:Y'>0 A25
; RBD PSJ*5*373 Hard stop when Stop Date more than 367 days after Start Date
S X1=+Y,X2=P(2) D ^%DTC
I X>367 W $C(7),!!?13,"*** STOP DATE cannot be more than 367 days from START DATE ***",! G A25
S P(3)=+Y,PSGFDX=1
Q
;
26 ; Schedule
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. Schedule may not be edited at this point." D PAUSE^VALM1
I $G(ON)["V"!($G(ON)["U") I $$COMPLEX^PSJOE(DFN,ON) D Q
.Q:$G(PSJBKDR) W !!?5,"This is a Complex Order. Schedule may not be edited at this point." D PAUSE^VALM1
W !,"SCHEDULE: ",$S(P(9)]"":P(9)_"// ",1:"") R X:DTIME S:'$T X=U S:X=U DONE=1 I $E(X)=U!(X="") Q
I X="@" D DEL^PSIVEDRG S:%=1 P(9)="" G 26
I '$$SCHREQ^PSJLIVFD(.P) S P(7)="" I $P(X,"@",2)=0 D G 26
.W $C(7),!!?2,"'@0' is not permitted for Continuous IV's",!
I X["???",($E(P("OT"))="I"),(PSIVAC["C") D ORFLDS G 26
;*194 Allow multi-word schedules
I X?1."?"!($L(X)>22)!($L(X," ")>$S(X["PRN":4,1:3)) S F1=55.01,F2=.09 D ENHLP^PSIVORC1 G 26
S CHG=0 I P(9)]"",X'=P(9) S CHG=1
S P(7)="" K PSGOES D EN^PSIVSP S:XT<0 X="" I $G(X)="" W $C(7),"??" G 26
I CHG D
. S P(9)=X,P(11)=Y,P(15)=XT
. I $$ODD^PSGS0(P(15)) S P(11)=""
. W !!?5,"This change in schedule also changes the Administration Times and Schedule Type of this order."
. S DIR("A")="Enter RETURN to continue or '^' to exit:"
. D PAUSE^VALM1
K CHG
Q
;
39 ; Admin Times
S ORIG=$G(P(11))
A39 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. Administration times may not be edited at this point." D PAUSE^VALM1
I $G(ON)["V"!($G(ON)["U") I $$COMPLEX^PSJOE(DFN,ON) D Q
.Q:$G(PSJBKDR) W !!?5,"This is a Complex Order. Admin Times may not be edited at this point." D PAUSE^VALM1
I $G(P(9))=""!($G(P(9))[" PRN")!($G(P(9))="PRN") Q ;No schedule or PRN schedule
I $$ODD^PSGS0(P(15)) S P(11)="" Q
W !,"ADMINISTRATION TIMES: ",$S(P(11)]"":P(11)_"//",1:"") R X:DTIME S:'$T X=U S:X=U DONE=1 I '($G(P(15))="D"&'DONE) I $E(X)=U S (X,P(11))=ORIG Q
I X="",P(11)]"" S X=P(11)
I ($G(P(15))="D"!($G(P(9))["@"))&('$G(X)!(X["@")) W $C(7)," ??" S X="?" W:(P(15)="D"!(X["@")) !,"This is a 'DAY OF THE WEEK' schedule and MUST have admin times." G A39
I X="@" D DEL^PSIVEDRG S:%=1 P(11)="" G A39
I X?1."?" D ENHLP^PSGOEM(53.1,39) G A39
I X["???",($E(P("OT"))="I"),(PSIVAC["C") D ORFLDS G A39
I $G(P(15))'="D",$G(P(15))'="P",'$$ONCALL(P(9)) D TIMES I '$D(X) G A39
K:X[""""!($A(X)=45) X W:$G(X)="^"!('$D(X)) $C(7)," ??" G:$G(X)="^"!('$D(X)) A39 S P(11)=X D:$G(PSIVCAL) ENT^PSIVCAL,ENSTOP^PSIVCAL K PSIVCAL
Q
;
59 ; Infusion Rate
;*305
N P8BADDEF S P8BADDEF=0 K PSJEXMSG
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: ",$S(P(8)]"":$P(P(8),"@")_"//",1:"") 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(.X) D:'$G(DONE) NUMLAB(.P) G:$G(P8BADDEF) 59 Q
S X=$TR(X,$C(0,1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,19,20,21,22,23,24,25,26,27,28,29,30,31,127)) ; Strip out control characters
I ((P(4)="P")!((P(4)="C")&(P(23)="P"))!(("C^S"[P(4))&(P(5)=1)))&(X["@") 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=""&((P(4)="P")!((P(4)="C")&(P(23)="P"))!(("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 G 59
I X["?" S F1=53.1,F2=59 D ENHLP^PSIVORC1 G 59
D EXPINF(.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
D NUMLAB(.P)
Q
;
NUMLAB(P) ; Prompt for Number of Labels
N PSJILBS
NUMLAB2 ; Loop ;*305
; Quit if no Infusion Rate
Q:($G(P(8))="")
I ((P(4)="P")!((P(4)="C")&(P(23)="P"))!(("C^S"[P(4))&(P(5)=1))) D Q
.I $G(X)="",$G(P(8))["@" S P(8)=$P(P(8),"@")
K DIR S PSJILBS=$P($G(P(8)),"@",2) S:'(PSJILBS?1.N) PSJILBS=$G(P("NUMLBL")) I $G(PSJILBS)?1.N S DIR("B")=PSJILBS
D NLBHLP(1)
S DIR(0)="FAO",DIR("A")="NUMBER OF LABELS PER DAY: " D ^DIR Q:X="^"
I X="@" D DEL^PSIVEDRG S:%=1 P("NUMLBL")="",P(8)=$P(P(8),"@") G NUMLAB2
I X?1."?" D NLBHLP G NUMLAB2
I X?1.2N S P("NUMLBL")=+X,P(8)=$P(P(8),"@")_"@"_P("NUMLBL") Q
I X="",(P(8)'?1N.N.1".".1N1" ml/hr") D G NUMLAB2
.W $C(7),!!,"Number of Labels is required for continuous IV's with free text Infusion Rate.",!
Q:X=""
I X'?1.2N D G NUMLAB2
.W $C(7),!!,"Type a number between 0 and 99, 0 decimal digits",!
Q
;
63 ; Remarks
N DIR S X="",DIR(0)="53.1,63" S:P("REM")]"" DIR("B")=P("REM") D ^DIR I X="^"!$D(DTOUT) S DONE=1 Q
I X="@" D DEL^PSIVEDRG S:%=1 P("REM")="" G 63
I X]"",$E(X)'="^" S P("REM")=X
Q
;
64 ; Other Print Info
N OPIMSG,PSJOPILN,PSJOPIT,PSJTMPTX,TMPLIN,PSJOVRMX
S PSJOPILN=$$EDITOPI^PSJBCMA5(DFN) S OPIMSG="Instructions too long. See Order View or BCMA for full text."
S PSJTMPTX="",PSJOVRMX=0
S TMPLIN=0 F S TMPLIN=$O(^PS(53.45,$G(PSJSYSP),6,TMPLIN)) Q:'TMPLIN!PSJOVRMX D
.S:($L(PSJTMPTX)+$L($G(^PS(53.45,$G(DUZ),6,TMPLIN,0))))>60 PSJOVRMX=1 Q:$G(PSJOVRMX) D
..S PSJTMPTX=$G(PSJTMPTX)_$S($L($G(PSJTMPTX)):" ",1:"")_$G(^PS(53.45,$G(DUZ),6,TMPLIN,0))
S PSJTMPTX=$S($G(PSJOVRMX):OPIMSG,1:$G(PSJTMPTX))
S P("OPI")=PSJTMPTX I (PSJOPILN>0) S P("OPI")=$$ENBCMA^PSJUTL("V")
I PSJTMPTX="",PSJOPILN="" S P("OPI")=$$ENBCMA^PSJUTL("V") ;P416
Q
;
IND ;*399-IND
N INDLST,DIR,SEL,I,J,K,L,M,N,O,INDI,CHK,CNT K DUOUT,DTOUT,DIROUT,DIRUT
S (CHK,CNT,J)=0
S O=0 S:'$D(DRG("AD")) O=1
F I="AD","SOL" S J=0 F S J=$O(DRG(I,J)) Q:'J S K=$P(DRG(I,J),U,6) D:K
. K ^TMP($J,"PSJDIND")
. D INDCATN^PSS50P7(K,"PSJDIND")
. Q:'$O(^TMP($J,"PSJDIND",0))
. S L=0 F S L=$O(^TMP($J,"PSJDIND",L)) Q:'L D
. . S N=$P($G(^TMP($J,"PSJDIND",L)),"^") S:N]"" M(N)=""
K ^TMP($J,"PSJDIND")
I '$D(M) S Y=99 G CIND
S INDI="" F S INDI=$O(M(INDI)) Q:INDI="" D
. I $G(P("IND"))]"",INDI=P("IND") S CHK=1
. S CNT=CNT+1,DIR("L",CNT)=" "_CNT_$S(CNT<10:" ",1:" ")_INDI S:CNT=1 SEL=CNT_":"_INDI S:CNT>1 SEL=SEL_";"_CNT_":"_INDI
W !,"INDICATION:"
S DIR(0)="SO^"_SEL_";99:Free Text entry",DIR("A")="Select INDICATION from the list"
S DIR("L")=" 99 Free Text entry"
S:CHK DIR("B")=P("IND") S:'CHK&(P("IND")]"") DIR("B")=99
S DIR("?")="This field contains the Indication For Use and must be 3-40 characters in length"
D ^DIR
I X="^"!($G(DTOUT))!($G(DIROUT)) S DONE=1 Q
I Y=99 S:CHK P("IND")="" G CIND
I X="@",$G(P("IND"))]"" D DEL^PSIVEDRG G:%'=1 IND S P("IND")="" Q
I X="@" S P("IND")="" G IND
S:Y>0 P("IND")=Y(0)
Q
;
CIND ;
I Y=99 N I,J,IND,DA D G:$G(Y)=99 CIND
. K X,Y,DIRUT,DTOUT,DUOUT,DIROUT,DIR
. S:$G(P("IND"))]"" DIR("B")=P("IND")
. S DIR(0)="53.1,132",DIR("A")="INDICATION" D ^DIR
. I X="^"!($G(DTOUT))!($G(DIROUT)) S DONE=1 Q
. I X="@",$G(P("IND"))]"" D DEL^PSIVEDRG G:%'=1 IND S P("IND")="" Q
. I X="@" S P("IND")="" G IND
. I $L(X," ")=1,$L(X)>32 W $C(7),!?5,"MAX OF 32 CHARACTERS ALLOWED WITHOUT SPACES.",! S Y=99 Q
. S IND="" F I=1:1:$L(X," ") Q:I="" S J=$P(X," ",I) D I '$D(X) S Y=99 Q
. .I $L(J)>32 W $C(7),!?5,"MAX OF 32 CHARACTERS ALLOWED BETWEEN SPACES.",! K X Q
. .S:J]"" IND=$S($G(IND)]"":IND_" ",1:"")_J
. Q:$G(Y)=99
. S P("IND")=$$ENLU^PSGMI(IND)
Q
;
ORFLDS ; Display OE/RR fields during edit.
D FULL^VALM1
W !!,"Orderable Item: ",$P(P("PD"),U,2),!,"Give: ",$P(P("MR"),U,2)," ",P(9),!!
Q
;
TIMES ;At least one admin time, not more than interval allows.
I $G(P(15)) Q:$$ODD^PSGS0(P(15))
I $G(P(15))="C"!$$CONTIN($G(P(9))) I '$$ONCALL($G(P(9))),X="" W !,"This order requires at least one administration time." K X Q ;No times
N H,I,MAX
I $G(P(15))="O"!$$ONETIME($G(P(9))) I $L(X,"-")>1 W !," This is a One Time Order - only one administration time is permitted." K X Q
I $G(P(15))="O"!$$ONETIME($G(P(9))) Q ;Done validating One Time
I $G(P(9))]"" S H=+$O(^PS(51.1,"B",P(9),0)) S I=$P($G(^PS(51.1,H,0)),"^",3)
I +I=0 Q ;No frequency - can not check frequency related items
S MAX=1440/I
I MAX<1,$L(X,"-")>1 W !,"This order requires one administration time." K X Q
I MAX'<1,$L(X,"-")>MAX W !,"The number of admin times entered is greater than indicated by the schedule." K X Q ;Too many times
I MAX'<1,$L(X,"-")<MAX D ;Too few times
. W !,"The number of admin times entered is fewer than indicated by the schedule."
. N X,DIR
. D PAUSE^VALM1
Q
;
DOSE ;Make certain at least one dose is given.
N INFO,Y,PNINE
S PNINE=P(9)
S INFO=$G(P(2))_U_$G(P(3))_U_$G(P(9))_U_$P($G(PSGZZND),"^",5)_U_$P($G(P("PD")),"^")_U_$G(P(11))
I '$L($G(PSGP)) N PSGP S PSGP=""
S Z=$$ENQ^PSJORP2(PSGP,INFO) ;Expected first dose.
S P(9)=PNINE
Q
;
ONCALL(SCHD) ; Check if a schedule is type On Call (all schedules with a given name must have the same schedule type)
N NXT,SCHARR
S OCCHK=0
Q:$G(SCHD)="" OCCHK
Q:'$D(^PS(51.1,"APPSJ",SCHD)) OCCHK
S NXT=0 F S NXT=$O(^PS(51.1,"APPSJ",SCHD,NXT)) Q:'NXT S TYP=$P($G(^PS(51.1,+NXT,0)),"^",5) S:TYP]"" SCHARR(TYP)=""
I '$D(SCHARR("OC")) S OCCHK=0 Q OCCHK
I $O(SCHARR("OC"))]""!($O(SCHARR("OC"),-1)]"") S OCCHK=0 Q OCCHK
I $D(SCHARR("OC")) S OCCHK=1
Q OCCHK
;
ONETIME(SCHD) ; Check if a schedule is type On Call (all schedules with a given name must have the same schedule type)
N NXT,SCHARR
S OCCHK=0
Q:$G(SCHD)="" OCCHK
Q:'$D(^PS(51.1,"APPSJ",SCHD)) OCCHK
S NXT=0 F S NXT=$O(^PS(51.1,"APPSJ",SCHD,NXT)) Q:'NXT S TYP=$P($G(^PS(51.1,+NXT,0)),"^",5) S:TYP]"" SCHARR(TYP)=""
I '$D(SCHARR("O")) S OCCHK=0 Q OCCHK
I $O(SCHARR("O"))]""!($O(SCHARR("O"),-1)]"") S OCCHK=0 Q OCCHK
I $D(SCHARR("O")) S OCCHK=1
Q OCCHK
;
CONTIN(SCHD) ; Check if a schedule is type On Call (all schedules with a given name must have the same schedule type)
N NXT,SCHARR
S OCCHK=0
Q:$G(SCHD)="" OCCHK
Q:'$D(^PS(51.1,"APPSJ",SCHD)) OCCHK
S NXT=0 F S NXT=$O(^PS(51.1,"APPSJ",SCHD,NXT)) Q:'NXT S TYP=$P($G(^PS(51.1,+NXT,0)),"^",5) S:TYP]"" SCHARR(TYP)=""
I '$D(SCHARR("C")) S OCCHK=0 Q OCCHK
I $O(SCHARR("C"))]""!($O(SCHARR("C"),-1)]"") S OCCHK=0 Q OCCHK
I $D(SCHARR("C")) S OCCHK=1
Q OCCHK
;
NLBHLP(OUT) ; Help text for Number of Labels per day
I OUT=1 D Q
.S DIR("?",1)="Enter the # of labels per day that will be needed."
.S DIR("?",2)=""
.S DIR("?",3)="Example: 0 = 0 labels per day."
.S DIR("?",4)=" 2 = 2 labels per day."
.S DIR("?",5)="Note: Number of Labels per day is required for continuous IV orders"
.S DIR("?",6)=" with free text Infusion Rate. Number of labels per day is not"
.S DIR("?",7)=" permitted for Intermittent (IVPB) type orders; for Intermittent"
.S DIR("?",8)=" orders, the schedule and administration time(s) will be used to"
.S DIR("?")=" determine the number of labels needed."
;
W !,"Enter the # of labels per day that will be needed."
W !,"Example: 0 = 0 labels per day."
W !," 2 = 2 labels per day."
W !!,"Note: Number of Labels per day is required for continuous IV orders"
W !," with free text Infusion Rate. Number of labels per day is not"
W !," permitted for Intermittent (IVPB) type orders; for Intermittent"
W !," orders, the schedule and administration time(s) will be used to"
W !," determine the number of labels needed."
Q
;
EXPINF(P8,SILENT) ; Expand Infusion Rate
;*305
Q:$G(P8)!($G(PSJEXMSG)) N P8TMP S P8TMP=$$UP^XLFSTR($P(P8,"@"))
N EXPANDED S EXPANDED="" D INFCHK^PSJLIVFD(P8TMP,.EXPANDED)
I (EXPANDED=$P(P8,"@"))!(EXPANDED=P8TMP) Q
S PSJEXMSG=1 I '$G(SILENT) W " Now expanding text"
I P8["@" S $P(P8,"@")=EXPANDED
I P8'["@" S P8=EXPANDED
I '$G(SILENT) W:$G(PSJEXMSG) !," Input expanded to ",EXPANDED
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSIVEDT1 14950 printed Sep 23, 2025@19:40:13 Page 2
PSIVEDT1 ;BIR/MLM - EDIT IV ORDER (CONT) ;Nov 2, 2021@12:47:00
+1 ;;5.0;INPATIENT MEDICATIONS;**3,7,41,47,50,64,58,116,110,111,113,267,279,305,194,373,411,416,399**;16 DEC 97;Build 64
+2 ;
+3 ; Reference to ^PS(55 is supported by DBIA# 2191.
+4 ; Reference to ^PS(51.1 is supported by DBIA# 2177.
+5 ;
10 ; Start Date
+1 ;p411 - set Start Date to Visit Date
IF $GET(P("APPT"))
SET P(2)=P("APPT")
+2 if 'P(2)&P("IVRM")!($GET(PSJREN))
DO ENT^PSIVCAL
A10 IF $GET(P("RES"))="R"
IF $GET(ON)["P"
IF $PIECE($GET(^PS(53.1,+ON,0)),"^",24)="R"
Begin DoDot:1
+1 if '$GET(PSIVRENW)
QUIT
WRITE !!?5,"This is a Renewal Order. Start Date may not be edited at this point."
DO PAUSE^VALM1
End DoDot:1
QUIT
+2 IF $GET(ON)["V"!($GET(ON)["U")
IF $$COMPLEX^PSJOE(DFN,ON)
Begin DoDot:1
+3 if $GET(PSJBKDR)
QUIT
WRITE !!?5,"This is a Complex Order. Start Date may not be edited at this point."
DO PAUSE^VALM1
End DoDot:1
QUIT
+4 SET Y=P(2)
XECUTE ^DD("DD")
WRITE !,"START DATE/TIME: "_$SELECT(Y]"":Y_"// ",1:"")
READ X:DTIME
if '$TEST
SET X=U
if X=U
SET DONE=1
IF $EXTRACT(X)=U!(P(2)&X="")
QUIT
+5 IF X["???"
IF ($EXTRACT(P("OT"))="I")
IF (PSIVAC["C")
DO ORFLDS
GOTO 10
+6 IF X="@"!(X?1."?")
if X="@"
WRITE $CHAR(7)," (Required)"
SET F1=53.1
SET F2=10
if X="@"
SET X="?"
DO ENHLP^PSIVORC1
GOTO A10
+7 KILL %DT
if X=""
SET X=P(2)
SET %DT="ERTX"
DO ^%DT
KILL %DT
if Y'>0
GOTO A10
+8 IF $GET(P("RES"))="R"
IF (+Y<+$PIECE($GET(^PS(55,DFN,"IV",+$GET(P("OLDON")),0)),U,2))
Begin DoDot:1
+9 ; naked ref below refers to line above
+10 SET Y=$PIECE(^(0),U,2)
XECUTE ^DD("DD")
WRITE $CHAR(7),!!,"Start date of order being renewed is ",Y,".",!,"Start date of renewal order must be AFTER start date of order being renewed.",!
End DoDot:1
GOTO 10
+11 SET X1=$GET(P("LOG"))
SET X2=-7
DO C^%DTC
IF +Y<X
WRITE $CHAR(7),!!,"Start date/time may not be entered prior to 7 days from the order's LOGIN DATE.",!
GOTO A10
+12 ; RBD PSJ*5*373 Soft stop when Start Date more than 7 days after Order's LOGIN DATE
+13 SET X1=$GET(P("LOG"))
SET X2=+7
DO C^%DTC
+14 IF +Y>X
WRITE !!,$CHAR(7),"Start date/time should not be entered for more than 7 days after the",!,"order's LOGIN DATE.",!
KILL DIR
DO WAIT^VALM1
+15 SET P(2)=+Y
SET PSGSDX=1
+16 QUIT
+17 ;
25 ; Stop Date
+1 if $DATA(PSGFDX)
GOTO A25
+2 IF P("IVRM")]""
IF $SELECT(P(3)<P(2):1,$GET(PSIVAC)["E":0,1:1)
SET PSIVSITE=$GET(^PS(59.5,+P("IVRM"),1))
SET $PIECE(PSIVSITE,"^",20,21)=$GET(^PS(59.5,+P("IVRM"),5))
DO ENSTOP^PSIVCAL
A25 IF $GET(ON)["V"!($GET(ON)["U")
IF $$COMPLEX^PSJOE(DFN,ON)
Begin DoDot:1
+1 if $GET(PSJBKDR)
QUIT
WRITE !!?5,"This is a Complex Order. Stop Date may not be edited at this point."
DO PAUSE^VALM1
End DoDot:1
QUIT
+2 SET Y=P(3)
XECUTE ^DD("DD")
WRITE !,"STOP DATE/TIME: "_$SELECT(Y]"":Y_"// ",1:"")
READ X:DTIME
if '$TEST
SET X=U
if X=U
SET DONE=1
if X=""&P(2)
QUIT
IF $EXTRACT(X)=U!(X=""&P(2))
QUIT
+3 IF X["???"
IF ($EXTRACT(P("OT"))="I")
IF (PSIVAC["C")
DO ORFLDS
GOTO 25
+4 IF X="@"!(X["?")
WRITE $CHAR(7)," (Required)"
SET F1=53.1
SET F2=25
SET X="?"
DO ENHLP^PSIVORC1
GOTO A25
+5 KILL %DT
if X=""
SET X=$GET(Y)
if X=""
SET X=P(3)
SET %DT="ERTX"
if X'=+X
DO ^%DT
+6 IF X=+X
IF X>0
IF X'>2000000
if '$$ENDL^PSGDL(P(9),X)
GOTO A25
DO ENDL^PSIVSP
+7 DO DOSE
+8 IF $GET(X)=""
SET X=Y
+9 IF $GET(X)=""
SET X=P(3)
+10 IF $GET(Z)]""
IF Z>X
Begin DoDot:1
+11 WRITE !,"There is no administration time that falls between the Start Date/Time"
+12 WRITE !,"and Stop Date/Time.",!
End DoDot:1
GOTO A25
+13 SET X=Y
if Y<1!Y'["."
SET X=""
if Y'>0
GOTO A25
+14 ; RBD PSJ*5*373 Hard stop when Stop Date more than 367 days after Start Date
+15 SET X1=+Y
SET X2=P(2)
DO ^%DTC
+16 IF X>367
WRITE $CHAR(7),!!?13,"*** STOP DATE cannot be more than 367 days from START DATE ***",!
GOTO A25
+17 SET P(3)=+Y
SET PSGFDX=1
+18 QUIT
+19 ;
26 ; Schedule
+1 IF $GET(P("RES"))="R"
IF $GET(ON)["P"
IF $PIECE($GET(^PS(53.1,+ON,0)),"^",24)="R"
Begin DoDot:1
+2 if '$GET(PSIVRENW)
QUIT
WRITE !!?5,"This is a Renewal Order. Schedule may not be edited at this point."
DO PAUSE^VALM1
End DoDot:1
QUIT
+3 IF $GET(ON)["V"!($GET(ON)["U")
IF $$COMPLEX^PSJOE(DFN,ON)
Begin DoDot:1
+4 if $GET(PSJBKDR)
QUIT
WRITE !!?5,"This is a Complex Order. Schedule may not be edited at this point."
DO PAUSE^VALM1
End DoDot:1
QUIT
+5 WRITE !,"SCHEDULE: ",$SELECT(P(9)]"":P(9)_"// ",1:"")
READ X:DTIME
if '$TEST
SET X=U
if X=U
SET DONE=1
IF $EXTRACT(X)=U!(X="")
QUIT
+6 IF X="@"
DO DEL^PSIVEDRG
if %=1
SET P(9)=""
GOTO 26
+7 IF '$$SCHREQ^PSJLIVFD(.P)
SET P(7)=""
IF $PIECE(X,"@",2)=0
Begin DoDot:1
+8 WRITE $CHAR(7),!!?2,"'@0' is not permitted for Continuous IV's",!
End DoDot:1
GOTO 26
+9 IF X["???"
IF ($EXTRACT(P("OT"))="I")
IF (PSIVAC["C")
DO ORFLDS
GOTO 26
+10 ;*194 Allow multi-word schedules
+11 IF X?1."?"!($LENGTH(X)>22)!($LENGTH(X," ")>$SELECT(X["PRN":4,1:3))
SET F1=55.01
SET F2=.09
DO ENHLP^PSIVORC1
GOTO 26
+12 SET CHG=0
IF P(9)]""
IF X'=P(9)
SET CHG=1
+13 SET P(7)=""
KILL PSGOES
DO EN^PSIVSP
if XT<0
SET X=""
IF $GET(X)=""
WRITE $CHAR(7),"??"
GOTO 26
+14 IF CHG
Begin DoDot:1
+15 SET P(9)=X
SET P(11)=Y
SET P(15)=XT
+16 IF $$ODD^PSGS0(P(15))
SET P(11)=""
+17 WRITE !!?5,"This change in schedule also changes the Administration Times and Schedule Type of this order."
+18 SET DIR("A")="Enter RETURN to continue or '^' to exit:"
+19 DO PAUSE^VALM1
End DoDot:1
+20 KILL CHG
+21 QUIT
+22 ;
39 ; Admin Times
+1 SET ORIG=$GET(P(11))
A39 IF $GET(P("RES"))="R"
IF $GET(ON)["P"
IF ($PIECE($GET(^PS(53.1,+ON,0)),"^",24)="R")
Begin DoDot:1
+1 if '$GET(PSIVRENW)
QUIT
WRITE !!?5,"This is a Renewal Order. Administration times may not be edited at this point."
DO PAUSE^VALM1
End DoDot:1
QUIT
+2 IF $GET(ON)["V"!($GET(ON)["U")
IF $$COMPLEX^PSJOE(DFN,ON)
Begin DoDot:1
+3 if $GET(PSJBKDR)
QUIT
WRITE !!?5,"This is a Complex Order. Admin Times may not be edited at this point."
DO PAUSE^VALM1
End DoDot:1
QUIT
+4 ;No schedule or PRN schedule
IF $GET(P(9))=""!($GET(P(9))[" PRN")!($GET(P(9))="PRN")
QUIT
+5 IF $$ODD^PSGS0(P(15))
SET P(11)=""
QUIT
+6 WRITE !,"ADMINISTRATION TIMES: ",$SELECT(P(11)]"":P(11)_"//",1:"")
READ X:DTIME
if '$TEST
SET X=U
if X=U
SET DONE=1
IF '($GET(P(15))="D"&'DONE)
IF $EXTRACT(X)=U
SET (X,P(11))=ORIG
QUIT
+7 IF X=""
IF P(11)]""
SET X=P(11)
+8 IF ($GET(P(15))="D"!($GET(P(9))["@"))&('$GET(X)!(X["@"))
WRITE $CHAR(7)," ??"
SET X="?"
if (P(15)="D"!(X["@"))
WRITE !,"This is a 'DAY OF THE WEEK' schedule and MUST have admin times."
GOTO A39
+9 IF X="@"
DO DEL^PSIVEDRG
if %=1
SET P(11)=""
GOTO A39
+10 IF X?1."?"
DO ENHLP^PSGOEM(53.1,39)
GOTO A39
+11 IF X["???"
IF ($EXTRACT(P("OT"))="I")
IF (PSIVAC["C")
DO ORFLDS
GOTO A39
+12 IF $GET(P(15))'="D"
IF $GET(P(15))'="P"
IF '$$ONCALL(P(9))
DO TIMES
IF '$DATA(X)
GOTO A39
+13 if X[""""!($ASCII(X)=45)
KILL X
if $GET(X)="^"!('$DATA(X))
WRITE $CHAR(7)," ??"
if $GET(X)="^"!('$DATA(X))
GOTO A39
SET P(11)=X
if $GET(PSIVCAL)
DO ENT^PSIVCAL
DO ENSTOP^PSIVCAL
KILL PSIVCAL
+14 QUIT
+15 ;
59 ; Infusion Rate
+1 ;*305
+2 NEW P8BADDEF
SET P8BADDEF=0
KILL PSJEXMSG
+3 IF $GET(P("RES"))="R"
IF $GET(ON)["P"
IF $PIECE($GET(^PS(53.1,+ON,0)),"^",24)="R"
Begin DoDot:1
+4 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
+5 WRITE !,"INFUSION RATE: ",$SELECT(P(8)]"":$PIECE(P(8),"@")_"//",1:"")
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(.X)
if '$GET(DONE)
DO NUMLAB(.P)
if $GET(P8BADDEF)
GOTO 59
QUIT
+6 ; Strip out control characters
SET X=$TRANSLATE(X,$CHAR(0,1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,19,20,21,22,23,24,25,26,27,28,29,30,31,127))
+7 IF ((P(4)="P")!((P(4)="C")&(P(23)="P"))!(("C^S"[P(4))&(P(5)=1)))&(X["@")
Begin DoDot:1
+8 WRITE $CHAR(7),!!?2,"'@' is not permitted for Intermittent IV's",!
End DoDot:1
GOTO 59
+9 IF (X["^")
Begin DoDot:1
+10 WRITE $CHAR(7),!!?2,"'^' is not permitted",!
End DoDot:1
GOTO 59
+11 IF X=""&((P(4)="P")!((P(4)="C")&(P(23)="P"))!(("C^S"[P(4))&(P(5)=1)))
QUIT
+12 IF X="@"
DO DEL^PSIVEDRG
if %=1
SET P(8)=""
GOTO 59
+13 IF X["???"
IF ($EXTRACT(P("OT"))="I")
IF (PSIVAC["C")
DO ORFLDS
GOTO 59
+14 IF X["?"
SET F1=53.1
SET F2=59
DO ENHLP^PSIVORC1
GOTO 59
+15 DO EXPINF(.X)
+16 IF ($LENGTH(X)>30!($LENGTH(X)=1))
IF (X'?1N)
Begin DoDot:1
+17 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
+18 IF X]""
DO ENI^PSIVSP
if '$DATA(X)
WRITE $CHAR(7)," ??"
if '$DATA(X)
GOTO 59
SET P(8)=X
+19 IF P(8)=""
WRITE $CHAR(7),!!,"An infusion rate must be entered!"
GOTO 59
+20 DO NUMLAB(.P)
+21 QUIT
+22 ;
NUMLAB(P) ; Prompt for Number of Labels
+1 NEW PSJILBS
NUMLAB2 ; Loop ;*305
+1 ; Quit if no Infusion Rate
+2 if ($GET(P(8))="")
QUIT
+3 IF ((P(4)="P")!((P(4)="C")&(P(23)="P"))!(("C^S"[P(4))&(P(5)=1)))
Begin DoDot:1
+4 IF $GET(X)=""
IF $GET(P(8))["@"
SET P(8)=$PIECE(P(8),"@")
End DoDot:1
QUIT
+5 KILL DIR
SET PSJILBS=$PIECE($GET(P(8)),"@",2)
if '(PSJILBS?1.N)
SET PSJILBS=$GET(P("NUMLBL"))
IF $GET(PSJILBS)?1.N
SET DIR("B")=PSJILBS
+6 DO NLBHLP(1)
+7 SET DIR(0)="FAO"
SET DIR("A")="NUMBER OF LABELS PER DAY: "
DO ^DIR
if X="^"
QUIT
+8 IF X="@"
DO DEL^PSIVEDRG
if %=1
SET P("NUMLBL")=""
SET P(8)=$PIECE(P(8),"@")
GOTO NUMLAB2
+9 IF X?1."?"
DO NLBHLP
GOTO NUMLAB2
+10 IF X?1.2N
SET P("NUMLBL")=+X
SET P(8)=$PIECE(P(8),"@")_"@"_P("NUMLBL")
QUIT
+11 IF X=""
IF (P(8)'?1N.N.1".".1N1" ml/hr")
Begin DoDot:1
+12 WRITE $CHAR(7),!!,"Number of Labels is required for continuous IV's with free text Infusion Rate.",!
End DoDot:1
GOTO NUMLAB2
+13 if X=""
QUIT
+14 IF X'?1.2N
Begin DoDot:1
+15 WRITE $CHAR(7),!!,"Type a number between 0 and 99, 0 decimal digits",!
End DoDot:1
GOTO NUMLAB2
+16 QUIT
+17 ;
63 ; Remarks
+1 NEW DIR
SET X=""
SET DIR(0)="53.1,63"
if P("REM")]""
SET DIR("B")=P("REM")
DO ^DIR
IF X="^"!$DATA(DTOUT)
SET DONE=1
QUIT
+2 IF X="@"
DO DEL^PSIVEDRG
if %=1
SET P("REM")=""
GOTO 63
+3 IF X]""
IF $EXTRACT(X)'="^"
SET P("REM")=X
+4 QUIT
+5 ;
64 ; Other Print Info
+1 NEW OPIMSG,PSJOPILN,PSJOPIT,PSJTMPTX,TMPLIN,PSJOVRMX
+2 SET PSJOPILN=$$EDITOPI^PSJBCMA5(DFN)
SET OPIMSG="Instructions too long. See Order View or BCMA for full text."
+3 SET PSJTMPTX=""
SET PSJOVRMX=0
+4 SET TMPLIN=0
FOR
SET TMPLIN=$ORDER(^PS(53.45,$GET(PSJSYSP),6,TMPLIN))
if 'TMPLIN!PSJOVRMX
QUIT
Begin DoDot:1
+5 if ($LENGTH(PSJTMPTX)+$LENGTH($GET(^PS(53.45,$GET(DUZ),6,TMPLIN,0))))>60
SET PSJOVRMX=1
if $GET(PSJOVRMX)
QUIT
Begin DoDot:2
+6 SET PSJTMPTX=$GET(PSJTMPTX)_$SELECT($LENGTH($GET(PSJTMPTX)):" ",1:"")_$GET(^PS(53.45,$GET(DUZ),6,TMPLIN,0))
End DoDot:2
End DoDot:1
+7 SET PSJTMPTX=$SELECT($GET(PSJOVRMX):OPIMSG,1:$GET(PSJTMPTX))
+8 SET P("OPI")=PSJTMPTX
IF (PSJOPILN>0)
SET P("OPI")=$$ENBCMA^PSJUTL("V")
+9 ;P416
IF PSJTMPTX=""
IF PSJOPILN=""
SET P("OPI")=$$ENBCMA^PSJUTL("V")
+10 QUIT
+11 ;
IND ;*399-IND
+1 NEW INDLST,DIR,SEL,I,J,K,L,M,N,O,INDI,CHK,CNT
KILL DUOUT,DTOUT,DIROUT,DIRUT
+2 SET (CHK,CNT,J)=0
+3 SET O=0
if '$DATA(DRG("AD"))
SET O=1
+4 FOR I="AD","SOL"
SET J=0
FOR
SET J=$ORDER(DRG(I,J))
if 'J
QUIT
SET K=$PIECE(DRG(I,J),U,6)
if K
Begin DoDot:1
+5 KILL ^TMP($JOB,"PSJDIND")
+6 DO INDCATN^PSS50P7(K,"PSJDIND")
+7 if '$ORDER(^TMP($JOB,"PSJDIND",0))
QUIT
+8 SET L=0
FOR
SET L=$ORDER(^TMP($JOB,"PSJDIND",L))
if 'L
QUIT
Begin DoDot:2
+9 SET N=$PIECE($GET(^TMP($JOB,"PSJDIND",L)),"^")
if N]""
SET M(N)=""
End DoDot:2
End DoDot:1
+10 KILL ^TMP($JOB,"PSJDIND")
+11 IF '$DATA(M)
SET Y=99
GOTO CIND
+12 SET INDI=""
FOR
SET INDI=$ORDER(M(INDI))
if INDI=""
QUIT
Begin DoDot:1
+13 IF $GET(P("IND"))]""
IF INDI=P("IND")
SET CHK=1
+14 SET CNT=CNT+1
SET DIR("L",CNT)=" "_CNT_$SELECT(CNT<10:" ",1:" ")_INDI
if CNT=1
SET SEL=CNT_":"_INDI
if CNT>1
SET SEL=SEL_";"_CNT_":"_INDI
End DoDot:1
+15 WRITE !,"INDICATION:"
+16 SET DIR(0)="SO^"_SEL_";99:Free Text entry"
SET DIR("A")="Select INDICATION from the list"
+17 SET DIR("L")=" 99 Free Text entry"
+18 if CHK
SET DIR("B")=P("IND")
if 'CHK&(P("IND")]"")
SET DIR("B")=99
+19 SET DIR("?")="This field contains the Indication For Use and must be 3-40 characters in length"
+20 DO ^DIR
+21 IF X="^"!($GET(DTOUT))!($GET(DIROUT))
SET DONE=1
QUIT
+22 IF Y=99
if CHK
SET P("IND")=""
GOTO CIND
+23 IF X="@"
IF $GET(P("IND"))]""
DO DEL^PSIVEDRG
if %'=1
GOTO IND
SET P("IND")=""
QUIT
+24 IF X="@"
SET P("IND")=""
GOTO IND
+25 if Y>0
SET P("IND")=Y(0)
+26 QUIT
+27 ;
CIND ;
+1 IF Y=99
NEW I,J,IND,DA
Begin DoDot:1
+2 KILL X,Y,DIRUT,DTOUT,DUOUT,DIROUT,DIR
+3 if $GET(P("IND"))]""
SET DIR("B")=P("IND")
+4 SET DIR(0)="53.1,132"
SET DIR("A")="INDICATION"
DO ^DIR
+5 IF X="^"!($GET(DTOUT))!($GET(DIROUT))
SET DONE=1
QUIT
+6 IF X="@"
IF $GET(P("IND"))]""
DO DEL^PSIVEDRG
if %'=1
GOTO IND
SET P("IND")=""
QUIT
+7 IF X="@"
SET P("IND")=""
GOTO IND
+8 IF $LENGTH(X," ")=1
IF $LENGTH(X)>32
WRITE $CHAR(7),!?5,"MAX OF 32 CHARACTERS ALLOWED WITHOUT SPACES.",!
SET Y=99
QUIT
+9 SET IND=""
FOR I=1:1:$LENGTH(X," ")
if I=""
QUIT
SET J=$PIECE(X," ",I)
Begin DoDot:2
+10 IF $LENGTH(J)>32
WRITE $CHAR(7),!?5,"MAX OF 32 CHARACTERS ALLOWED BETWEEN SPACES.",!
KILL X
QUIT
+11 if J]""
SET IND=$SELECT($GET(IND)]"":IND_" ",1:"")_J
End DoDot:2
IF '$DATA(X)
SET Y=99
QUIT
+12 if $GET(Y)=99
QUIT
+13 SET P("IND")=$$ENLU^PSGMI(IND)
End DoDot:1
if $GET(Y)=99
GOTO CIND
+14 QUIT
+15 ;
ORFLDS ; Display OE/RR fields during edit.
+1 DO FULL^VALM1
+2 WRITE !!,"Orderable Item: ",$PIECE(P("PD"),U,2),!,"Give: ",$PIECE(P("MR"),U,2)," ",P(9),!!
+3 QUIT
+4 ;
TIMES ;At least one admin time, not more than interval allows.
+1 IF $GET(P(15))
if $$ODD^PSGS0(P(15))
QUIT
+2 ;No times
IF $GET(P(15))="C"!$$CONTIN($GET(P(9)))
IF '$$ONCALL($GET(P(9)))
IF X=""
WRITE !,"This order requires at least one administration time."
KILL X
QUIT
+3 NEW H,I,MAX
+4 IF $GET(P(15))="O"!$$ONETIME($GET(P(9)))
IF $LENGTH(X,"-")>1
WRITE !," This is a One Time Order - only one administration time is permitted."
KILL X
QUIT
+5 ;Done validating One Time
IF $GET(P(15))="O"!$$ONETIME($GET(P(9)))
QUIT
+6 IF $GET(P(9))]""
SET H=+$ORDER(^PS(51.1,"B",P(9),0))
SET I=$PIECE($GET(^PS(51.1,H,0)),"^",3)
+7 ;No frequency - can not check frequency related items
IF +I=0
QUIT
+8 SET MAX=1440/I
+9 IF MAX<1
IF $LENGTH(X,"-")>1
WRITE !,"This order requires one administration time."
KILL X
QUIT
+10 ;Too many times
IF MAX'<1
IF $LENGTH(X,"-")>MAX
WRITE !,"The number of admin times entered is greater than indicated by the schedule."
KILL X
QUIT
+11 ;Too few times
IF MAX'<1
IF $LENGTH(X,"-")<MAX
Begin DoDot:1
+12 WRITE !,"The number of admin times entered is fewer than indicated by the schedule."
+13 NEW X,DIR
+14 DO PAUSE^VALM1
End DoDot:1
+15 QUIT
+16 ;
DOSE ;Make certain at least one dose is given.
+1 NEW INFO,Y,PNINE
+2 SET PNINE=P(9)
+3 SET INFO=$GET(P(2))_U_$GET(P(3))_U_$GET(P(9))_U_$PIECE($GET(PSGZZND),"^",5)_U_$PIECE($GET(P("PD")),"^")_U_$GET(P(11))
+4 IF '$LENGTH($GET(PSGP))
NEW PSGP
SET PSGP=""
+5 ;Expected first dose.
SET Z=$$ENQ^PSJORP2(PSGP,INFO)
+6 SET P(9)=PNINE
+7 QUIT
+8 ;
ONCALL(SCHD) ; Check if a schedule is type On Call (all schedules with a given name must have the same schedule type)
+1 NEW NXT,SCHARR
+2 SET OCCHK=0
+3 if $GET(SCHD)=""
QUIT OCCHK
+4 if '$DATA(^PS(51.1,"APPSJ",SCHD))
QUIT OCCHK
+5 SET NXT=0
FOR
SET NXT=$ORDER(^PS(51.1,"APPSJ",SCHD,NXT))
if 'NXT
QUIT
SET TYP=$PIECE($GET(^PS(51.1,+NXT,0)),"^",5)
if TYP]""
SET SCHARR(TYP)=""
+6 IF '$DATA(SCHARR("OC"))
SET OCCHK=0
QUIT OCCHK
+7 IF $ORDER(SCHARR("OC"))]""!($ORDER(SCHARR("OC"),-1)]"")
SET OCCHK=0
QUIT OCCHK
+8 IF $DATA(SCHARR("OC"))
SET OCCHK=1
+9 QUIT OCCHK
+10 ;
ONETIME(SCHD) ; Check if a schedule is type On Call (all schedules with a given name must have the same schedule type)
+1 NEW NXT,SCHARR
+2 SET OCCHK=0
+3 if $GET(SCHD)=""
QUIT OCCHK
+4 if '$DATA(^PS(51.1,"APPSJ",SCHD))
QUIT OCCHK
+5 SET NXT=0
FOR
SET NXT=$ORDER(^PS(51.1,"APPSJ",SCHD,NXT))
if 'NXT
QUIT
SET TYP=$PIECE($GET(^PS(51.1,+NXT,0)),"^",5)
if TYP]""
SET SCHARR(TYP)=""
+6 IF '$DATA(SCHARR("O"))
SET OCCHK=0
QUIT OCCHK
+7 IF $ORDER(SCHARR("O"))]""!($ORDER(SCHARR("O"),-1)]"")
SET OCCHK=0
QUIT OCCHK
+8 IF $DATA(SCHARR("O"))
SET OCCHK=1
+9 QUIT OCCHK
+10 ;
CONTIN(SCHD) ; Check if a schedule is type On Call (all schedules with a given name must have the same schedule type)
+1 NEW NXT,SCHARR
+2 SET OCCHK=0
+3 if $GET(SCHD)=""
QUIT OCCHK
+4 if '$DATA(^PS(51.1,"APPSJ",SCHD))
QUIT OCCHK
+5 SET NXT=0
FOR
SET NXT=$ORDER(^PS(51.1,"APPSJ",SCHD,NXT))
if 'NXT
QUIT
SET TYP=$PIECE($GET(^PS(51.1,+NXT,0)),"^",5)
if TYP]""
SET SCHARR(TYP)=""
+6 IF '$DATA(SCHARR("C"))
SET OCCHK=0
QUIT OCCHK
+7 IF $ORDER(SCHARR("C"))]""!($ORDER(SCHARR("C"),-1)]"")
SET OCCHK=0
QUIT OCCHK
+8 IF $DATA(SCHARR("C"))
SET OCCHK=1
+9 QUIT OCCHK
+10 ;
NLBHLP(OUT) ; Help text for Number of Labels per day
+1 IF OUT=1
Begin DoDot:1
+2 SET DIR("?",1)="Enter the # of labels per day that will be needed."
+3 SET DIR("?",2)=""
+4 SET DIR("?",3)="Example: 0 = 0 labels per day."
+5 SET DIR("?",4)=" 2 = 2 labels per day."
+6 SET DIR("?",5)="Note: Number of Labels per day is required for continuous IV orders"
+7 SET DIR("?",6)=" with free text Infusion Rate. Number of labels per day is not"
+8 SET DIR("?",7)=" permitted for Intermittent (IVPB) type orders; for Intermittent"
+9 SET DIR("?",8)=" orders, the schedule and administration time(s) will be used to"
+10 SET DIR("?")=" determine the number of labels needed."
End DoDot:1
QUIT
+11 ;
+12 WRITE !,"Enter the # of labels per day that will be needed."
+13 WRITE !,"Example: 0 = 0 labels per day."
+14 WRITE !," 2 = 2 labels per day."
+15 WRITE !!,"Note: Number of Labels per day is required for continuous IV orders"
+16 WRITE !," with free text Infusion Rate. Number of labels per day is not"
+17 WRITE !," permitted for Intermittent (IVPB) type orders; for Intermittent"
+18 WRITE !," orders, the schedule and administration time(s) will be used to"
+19 WRITE !," determine the number of labels needed."
+20 QUIT
+21 ;
EXPINF(P8,SILENT) ; Expand Infusion Rate
+1 ;*305
+2 if $GET(P8)!($GET(PSJEXMSG))
QUIT
NEW P8TMP
SET P8TMP=$$UP^XLFSTR($PIECE(P8,"@"))
+3 NEW EXPANDED
SET EXPANDED=""
DO INFCHK^PSJLIVFD(P8TMP,.EXPANDED)
+4 IF (EXPANDED=$PIECE(P8,"@"))!(EXPANDED=P8TMP)
QUIT
+5 SET PSJEXMSG=1
IF '$GET(SILENT)
WRITE " Now expanding text"
+6 IF P8["@"
SET $PIECE(P8,"@")=EXPANDED
+7 IF P8'["@"
SET P8=EXPANDED
+8 IF '$GET(SILENT)
if $GET(PSJEXMSG)
WRITE !," Input expanded to ",EXPANDED
+9 QUIT
+10 ;
