- 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 Feb 18, 2025@23:30:29 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 ;