PSGOE91 ;BIR/CML - ACTIVE ORDER EDIT (CONT.) ;May 03, 2023@17:45
;;5.0;INPATIENT MEDICATIONS;**50,64,58,110,111,136,113,179,265,267,285,315,334,373,366,327,441,451,454,455**;16 DEC 97;Build 2
;;Per VHA Directive 2004-038, this routine should not be modified.
;Reference to ^PS(55 in ICR #2191.
;Reference to ^PS(50.7 in ICR #2180
;Reference to ^PS(51.1 in ICR #2177
;Reference to YSCLTST2 in ICR #4556
;
41 ; admin times
;S MSG=0,PSGF2=41,ORIG=$G(PSGAT) S:PSGOEEF(PSGF2) BACK="41^PSGOE91"
;*315 next 5 lines
N PSGDOA
S MSG=0,PSGF2=41,ORIG=$G(PSGAT),PSGDOA=$G(PSGDUR) S:PSGOEEF(PSGF2) BACK="41^PSGOE91"
I (PSGST="P")!$$PRNOK^PSGS0($G(PSGSCH)) G DONE
I $$ODD^PSGS0(PSGS0XT) D PSGDUR G DONE
A41 I $G(PSJORD),$G(PSGP) I $$COMPLEX^PSJOE(PSGP,PSJORD) S PSGOEE=0 D G DONE
.W !!?5,"ADMIN TIMES may not be edited for active complex orders." D PAUSE^VALM1
W !,"ADMIN TIMES: "_$S(PSGAT:PSGAT_"// ",1:"") R X:DTIME I X="^"!('$T) W:'$T $C(7) S PSGOEE=0 S:X="^" (X,PSGAT)=$G(ORIG),PSGDUR="" G DONE
I X="" S:$G(PSGAT) X=PSGAT,PSGNOHI=1 ;*315 If admin time default was taken then don't highlight admin time.
I $E(X)="^" D ENFF^PSGOE92 G:Y>0 @Y G A41
I X="@" I (PSGS0XT="D")!(PSGSCH["@") I ((",P,R,OC,O,")'[(","_$G(PSGST)_",")) D G A41
.W $C(7)," ??" S X="?" W:PSGS0XT="D"!(PSGSCH["@") !,"This is a 'DAY OF THE WEEK' schedule and MUST have admin times." D ENHLP^PSGOEM(55.06,41)
I X="@" D DEL G:%'=1 A41 S PSGAT="",X=""
I ((PSGST="O")!($G(PSGST)="OC")!($G(PSGST)="P")!$$ODD^PSGS0($P($G(ZZND),"^",3))!($P($G(ZZND),"^",5)="O")),X="" D G DONE
.S (PSGS0Y,PSGAT)=X
.I (($G(PSGRF))&($G(PSGST)="O")) N PSGRO S PSGOEEF(34)=1,PSGOEEF(41)=1,PSGRO=1 D 34
.Q
I $G(PSGS0XT) I '$$ODD^PSGS0(PSGS0XT),$G(PSGST)'="P",$G(PSGST)'="OC",'$$PRNOK^PSGS0(PSGSCH) I ($G(PSGST)'="O") D TIMES G:'$D(X) A41 D PSGDUR G:'$D(X) A41 G:$G(X)="^" DONE ;*315
I X?1."?" D ENHLP^PSGOEM(55.06,41) G A41
D ENCHK^PSGS0 I '$D(X) W $C(7)," ??" S X="?" D ENHLP^PSGOEM(55.06,41) G A41
S PSGOAT=PSGAT
S (PSGS0Y,PSGAT)=X G DONE
;
8 ; special instructions
S MSG=0,PSGF2=8 S:PSGOEEF(PSGF2) BACK="8^PSGOE91"
A8 I $G(PSGP),$G(PSGORD) I $$COMPLEX^PSJOE(PSGP,PSGORD) D
.N X,Y,PARENT S PARENT=$S(PSGORD["U":$$GET1^DIQ(55.06,+PSGORD_","_PSGP,125,"I"),1:$$GET1^DIQ(53.1,+PSGORD,125,"I"))
.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,PSGORD)
I $E(X)=U D ENFF^PSGOE92 G:Y>0 @Y G A8
S PSGSI=$$EDITSI^PSJBCMA5($G(PSGP),$G(PSGORD)) I $G(PSGP),$G(PSGORD) I '$$DIFFSI^PSJBCMA5(PSGP,PSGORD) S PSGOEE=0 G DONE
S PSGSI=$S((PSGSI>0&(PSGSI<4)):$$GET1^DIQ(53.455,"1,"_+PSJSYSP,.01)_" "_$$GET1^DIQ(53.455,"2,"_+PSJSYSP,.01),PSGSI>3:"Instructions too long. See Order View or BCMA for full text.",1:"")
S:PSGSI=" " PSGSI="" I PSGSI]"" S PSGSI=$$ENBCMA^PSJUTL("U") G DONE
Q
;
10 ; start date/time edit
S MSG=0,PSGF2=10 S:PSGOEEF(PSGF2) BACK="10^PSGOE91"
A10 ; start date/time edit
S PSGSDEDT=1 ; This variable indicates a Manual Edit of the Start/Date Time.
I $G(PSJORD),$G(PSGP) I $$COMPLEX^PSJOE(PSGP,PSJORD) S PSGOEE=0 D G DONE
. W !!?5,"Start Date/Time may not be edited for active complex orders." D PAUSE^VALM1
K PSGSDX
W !,"START DATE/TIME: "_$S($P(PSGSDN,"^")]"":$P(PSGSDN,"^")_"// ",1:"") R X:DTIME I X="^"!'$T W:'$T $C(7) S PSGOEE=0 G DONE
I X="",PSGSD W " "_$P(PSGSDN,"^") G DONE ;P451
;I X="P" D ENPREV^PSGDL W:'$D(X) $C(7) G:'$D(X) A10 S PSGSD=+X,PSGSDN=$$ENDD^PSGMI(PSGSD)_"^"_$$ENDTC^PSGMI(PSGSD) W " ",$P(PSGSDN,"^") G DONE ;373
I X="P" D ENPREV^PSGDL W:'$D(X) $C(7) G:'$D(X) A10 S PSGSD=+X,PSGSDN=$$ENDD^PSGMI(PSGSD)_"^"_$$ENDTC2^PSGMI(PSGSD) W " ",$P(PSGSDN,"^") G DONE ;373
I X="@"!(X?1."?") W:X="@" $C(7)," (Required)" S:X="@" X="?" D ENHLP^PSGOEM(55.06,10)
I $E(X)="^" D ENFF^PSGOE92 G:Y>0 @Y G A10
NEW TMPX S TMPX=X,X1=PSGDT,X2=-7 D C^%DTC K %DT S %DT="ERTX",%DT(0)=X,X=TMPX D ^%DT K %DT I Y'>0 D ENHLP^PSGOEM(55.06,10) G A10
I PSGFD<Y W $C(7),!?5,"*** THE START DATE CANNOT BE AFTER THE STOP DATE! ***",! S MSG=1 G A10
; RBD PSJ*5*373 Soft stop when Start Date more than 7 days after Order's LOGIN DATE
S X1=+$G(PSGDT),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
N X1,X2,DIFF,PSGEMRG,PSGBACK S X1=PSGFD,X2=Y D ^%DTC S DIFF=X
N CLOZFLG S CLOZFLG=$$ISCLOZ^PSJCLOZ(,,PSGP,+$G(PSJORD))
;S PSGEMRG=$S($$GET1^DIQ(55,DFN,53)?2U5N:1,1:0),PSGBACK=0
S PSGEMRG=0,PSGBACK=0
I ($$GET1^DIQ(55,DFN,53)?2U5N),($P($G(^XTMP("PSJ4D-"_DFN,0)),"^",1))>$$HTFM^XLFDT($H,1) S PSGEMRG=1
I PSGEMRG,$G(CLOZFLG),DIFF>4 D G A10 ; Emergency Registration period not to exceed 4 days
.W !!?13,"*** EMERGENCY SUPPLY NOT TO EXCEED 4 DAYS! ***",!
I 'PSGEMRG,$G(CLOZFLG) D G:PSGBACK A10
.N CLOZPAT,X2,PSGCFLG,PSGANC D CLOZPAT^PSJCLOZ
.S PSGCFLG=1,PSGANC=$$CL^YSCLTST2(DFN)
.I '$$OVERRIDE^YSCLTST2(DFN),'+$P(PSGANC,"^",4) S X2=4
.E S X2=$S($G(CLOZPAT)=2:28,$G(CLOZPAT)=1:14,$G(CLOZPAT)=0:7,1:90)
.I DIFF>X2 W !!,"*** SUPPLY PERIOD NOT TO EXCEED "_X2_" DAYS! ***",! S PSGBACK=1
;S (PSGSDX,PSGSD)=+Y,PSGSDN=$$ENDD^PSGMI(PSGSD)_"^"_$$ENDTC^PSGMI(PSGSD) G DONE ;373
S (PSGSDX,PSGSD)=+Y,PSGSDN=$$ENDD^PSGMI(PSGSD)_"^"_$$ENDTC2^PSGMI(PSGSD) G DONE ;373
;
34 ; stop date
S MSG=0,PSGF2=34 S:PSGOEEF(PSGF2) BACK="34^PSGOE91"
A34 ;
;
K PSGFDX N PSGEMRG
I $G(PSJORD),$G(PSGP) I $$COMPLEX^PSJOE(PSGP,PSJORD),'$$LASTCHLD^PSJCLOZ(PSGP,PSJORD) S PSGOEE=0 D G DONE
.W !!?5,"Stop Date/Time may not be edited for active complex orders." D PAUSE^VALM1
;; START NCC REMEDIATION RJS*327
N CLOZFLG S CLOZFLG=$$ISCLOZ^PSJCLOZ(,,PSGP,+$G(PSJORD))
I $G(CLOZFLG) N CLOZPAT,PSGDRG S PSGDRG=$P(CLOZFLG,U,2) D CLOZPAT^PSJCLOZ
I $D(CLOZPAT) N PSGOLDED,PSGFDNOLD S PSGOLDED=PSGFD,PSGFDNOLD=PSGFDN
;; END NCC REMEDIATION RJS*327
N MSG,PSGTMPST S PSGTMPST=$G(PSGST) S:'+$G(PSGRF) PSGRF=+$$GET1^DIQ(50.7,$G(PSGPDRG),12,"I") ;*315 One time orders for MRR's require message to instruct pharmacists
I +$G(PSGRF),$$FIND1^DIC(51.1,,"X",$G(PSGSCH)) D
.S:PSGTMPST=($G(PSGST)="R") PSGST=$$GET1^DIQ(51.1,$$FIND1^DIC(51.1,,"X",$G(PSGSCH)),5,"I") ;Handle "Fill on Request"
.Q
I $G(PSGTMPST)="O",+$G(PSGRF) S (PSGFDN,PSGFD)="" D
.I +$G(PSGRF)=1 S MSG(1)="This NOW order has an Orderable Item for which a removal is required" D
..S MSG(2)=" at the next administration."
..S MSG(3)="The Stop DATE/TIME entered should be the next anticipated administration for the medication.",MSG(3,"F")="!"
..Q
.I +$G(PSGRF)=2 S MSG(1)="This NOW order has an Orderable Item for which a removal period is optional",MSG(1,"F")="!!" D
..S MSG(2)="prior to the next administration.",MSG(2,"F")="!"
..S MSG(3)="If Early Removal is needed, enter Removal Time in Stop DATE/TIME field.",MSG(3,"F")="!"
..S MSG(4)="If an Early Removal is not required, the Stop DATE/TIME entered"
..S MSG(5)="should be the next anticipated administration for the medication.",MSG(5,"F")="!"
..Q
.I +$G(PSGRF)=3 S MSG(1)="This NOW order has an Orderable Item that requires a removal period prior",MSG(1,"F")="!!" D
..S MSG(2)=" to the next administration.",MSG(2,"F")="!"
..S MSG(3)="Please Enter the Stop DATE/TIME to reflect the Removal Time for this medication.",MSG(3,"F")="!"
..Q
.D EN^DDIOL(.MSG)
.Q
I $D(PSGFDORG) S PSGFDN=PSGFDORG,PSGFD=PSGFDORX
I '$D(PSGFDORG) N PSGFDORG,PSGFDORX S PSGFDORG=PSGFDN,PSGFDORX=PSGFD
W !,"STOP DATE/TIME: "_$S($P(PSGFDN,"^")]"":$P(PSGFDN,"^")_"// ",1:"") R X:DTIME I X="^"!'$T W:'$T $C(7) S PSGOEE=0 G DONE
I X="",PSGFD W " "_$P(PSGFDN,"^") G W34
I $E(X)="^" D ENFF^PSGOE92 G:Y>0 @Y G A34
I X="@"!(X?1."?") W:X="@" $C(7)," (Required)" S:X="@" X="?" D ENHLP^PSGOEM(55.06,34)
I X=+X,(X>0),(X'>2000000) G A34:'$$ENDL^PSGDL(PSGSCH,X) K PSGDLS S PSGDL=X W " ...dose limit..." D ENE^PSGDL
K %DT S %DT="ERTX",%DT(0)=PSGSD D ^%DT K %DT I Y'>0 W $C(7),!!?13,"*** WARNING! INVALID STOP DATE OR PRIOR TO START DATE! ***",! G A34
; RBD PSJ*5*373 Hard stop when Stop Date more than 367 days after Start Date
S X1=+Y,X2=PSGSD D ^%DTC
I X>367 W $C(7),!!?13,"*** STOP DATE cannot be more than 367 days from START DATE ***",! G A34
;S (PSGFDX,PSGFD)=+Y,PSGFDN=$$ENDD^PSGMI(PSGFD)_"^"_$$ENDTC^PSGMI(PSGFD) ;373
S (PSGFDX,PSGFD)=+Y,PSGFDN=$$ENDD^PSGMI(PSGFD)_"^"_$$ENDTC2^PSGMI(PSGFD) ;373
;/RJS Begin changes for emergency registration of clozapine patient Set end date to start date + 4 days at midnight.
S PSGEMRG=$$GET1^DIQ(55,DFN,53)?1U6N
I $G(CLOZFLG) N PSGBACK D G:$G(PSGBACK) A34
.N PSGANC,PSGOVRD,PSGCFLG S PSGCFLG=1
.S:$$OVERRIDE^YSCLTST2(DFN) PSGOVRD=1
.S PSGANC=$$CL^YSCLTST2(DFN)
.N X,X1,X2 S X1=+Y,X2=PSGSD D ^%DTC
.I '$G(PSGOVRD),'+$P(PSGANC,"^",4) S X2=4
.E I PSGEMRG S X2=4
.E S X2=$S($G(CLOZPAT)=2:28,$G(CLOZPAT)=1:14,$G(CLOZPAT)=0:7,1:90)
.I X>X2 S PSGBACK=1 D
..I X2=4
..I PSGEMRG W !!?13,"*** EMERGENCY SUPPLY NOT TO EXCEED 4 DAYS! ***",! Q
..W !!,"*** STOP DATE/TIME NOT TO EXCEED "_X2_" DAYS! ***",!
K:$G(PSGEMRG) PSGEMRG
;/RJS End verify that stop date does not exceed maximum days supply based on lab frequency.
;; END NCC REMEDIATION RJS*327
W34 ;Compare to Start Date
N Z,MSG
D DOSE I $G(Z)]"",Z>$S($G(PSGFD):PSGFD,1:$G(PSGNEFD)) D G A34
.S MSG(1)="There is no administration time that falls between the Start Date/Time"
.S MSG(2)="and the Stop Date/Time."
.D EN^DDIOL(.MSG)
I PSGFD<PSGDT W $C(7),!!?13,"*** WARNING! THE STOP DATE ENTERED IS IN THE PAST! ***",! S MSG=1
Q:+$G(PSGRO)
;
DONE ;
;Display Expected First Dose;BHW;PSJ*5*136
;BHW;PSJ*5*179; - Remove EFD call. Added to PSGOEE.
I PSGOEE G:'$G(PSGOEEF(PSGF2)) @BACK S PSGOEE=PSGOEEF(PSGF2) ;P451
D:+$G(PSGDUR) VERTIMES ;*315
S:'+$G(PSGRF) PSGRF=+$$GET1^DIQ(50.7,$G(PSGPDRG),12,"I")
K F,F0,F1,PSGF2,F3,PSG,SDT,ORIG Q
;
FF ; up-arrow to another field
D ENFF^PSGOEM I Y>0,Y'=41,Y'=8,Y'=10,Y'=34 S Y=Y_"^PSGOE9"_$S("^109^13^3^7^26^"[("^"_Y_"^"):"",1:2) S:Y=2 FB=PSGF2_"^PSGOE91"
Q
;
DEL ; delete entry
W !?3,"SURE YOU WANT TO DELETE" S %=0 D YN^DICN I %'=1 W $C(7)," <NOTHING DELETED>"
Q
;
TIMES ;At least one admin time, not more than interval allows.
I $G(PSGST)'="O",($G(PSGST)'="OC"),($G(PSGST)'="R") I X="" D EN^DDIOL("This order requires at least one administration time.") K X Q ;No times
N H,I,MAX
;I PSGSCH]"" S H=$$FIND1^DIC(51.1,,"X",PSGSCH) I H S I=$$GET1^DIQ(51.1,H,2,"I")
I PSGSCH]"" S H=+$O(^PS(51.1,"AC","PSJ",PSGSCH,0)) I H S I=$$GET1^DIQ(51.1,H,2,"I")
I $G(PSGST)="O",$L(X,"-")>1 D EN^DDIOL("This is a One Time Order. Only one administration time is permitted.") K X Q
I $G(PSGST)="O" Q ;Done validating One Time
I +$G(I)=0 Q ;No frequency - can not check frequency related items
;P454 messages to the user
I $D(X) D Q:'$G(X)
. I (X'["-") D
. . I (X'?2N),(X'?4N) W !,"ADMIN TIMES must be entered in a 2 or 4 digit numeric format" K X Q
. E D
. . N LEN,TOT,CHK S LEN=$L($P(X,"-"))
. . F TOT=1:1:$L(X,"-") S CHK=$P(X,"-",TOT) Q:CHK="" I ((CHK'?2N)&(CHK'?4N))!(LEN'=$L(CHK)) W !,"All ADMIN TIMES must be the same 2 or 4 digit numeric format" W !,"(i.e. 09-13 or 0900-1300)" K X Q
S MAX=1440/I
I MAX<1,$L(X,"-")>1 D EN^DDIOL("This order requires one administration time.") K X Q
I MAX'<1,$L(X,"-")>MAX D EN^DDIOL("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 EN^DDIOL("The number of admin times entered is fewer than indicated by the schedule.") Q ;Too few times ;P455 remove K
Q
;
DOSE ;Make certain at least one dose is given.
N INFO,X
S Z="",INFO=($S($G(PSGSD):PSGSD,1:$G(PSGNESD)))_U_($S($G(PSGFD):PSGFD,1:$G(PSGNEFD)))_U_($G(PSGSCH))_U_($G(PSGST))_U_($G(PSGDRG))_U_($G(PSGS0Y))
Q:$G(PSGST)="OC"!($G(PSGST)="P")
I '$L($G(PSGP)) N PSGP S PSGP=""
S Z=$$ENQ^PSJORP2(PSGP,INFO) ;Expected first dose.
Q
;*315 New tags
PSGDUR ; Prompt for Removal times if admin times are on 24hr rotations and Site Params are enabled.
; check parameter files for removal criteria quit if removal rotation not enabled (<2)
; if enabled determine type (hard vers soft stop)
;0 = no removal (current cap/tab functionality)
;1 = removal at next admin (current patch functionality)
;2 = removal prior to next admin; soft stop (pharmacist optional prompt to designate duration of administration)
;3 = removal prior to next admin; hard stop (pharmacist required prompt to designate duration of administration)
; prompt for removal if = 2 then allow skip, if = 3 then force entry
;
S PSGRF=+$$GET1^DIQ(50.7,$G(PSGPDRG),12,"I") Q:((PSGRF<2)!($G(PSGST)="O")!($G(PSGST)="P")!($G(PSGST)="OC")) ; no removal flag or no removal rotation
Q:$G(PSGS0XT)>1440 ; Duration of Administration valid only for 24 hours - subject to change in future.
N RP,PSGIDF,WMSG,PSGDERR S (PSGIDF,PSGDERR)=0 S:$G(PSGDUR)>0 RP=(PSGDUR/60) S:"BID,TID,QID"[$G(PSGSCH) PSGIDF=1 ; Use separate validation for Times per day type orders
S PSGF2=41
W !,"DURATION OF ADMINISTRATION (HRS): "_$S($G(RP):RP_"// ",1:"") R RP:DTIME I RP="^"!'$T W:'$T $C(7) S PSGDUR=$G(PSGDOA),X="^",PSGOEE=0 Q
I RP="" S:$G(PSGDUR)>0 RP=($G(PSGDUR)/60)
I RP="",$G(PSGS0XT)="D",$L(PSGSCH,"@")=2,$P(PSGSCH,"@",2) S (PSGAT,PSGRMVT)=$P(PSGSCH,"@",2) G 8
I RP="@",PSGRF'=3 D DEL G:%'=1 PSGDUR S PSGS0Y="",(PSGDUR,PSGRMVT)="@",PSGRMV=-1 Q
I (RP'=""),(RP'="@"),($E(RP)'="^"),($E(RP)'="?") S:(RP'?1N.2N)!(+(RP)<1) RP="?"
I RP?1."?" D DURHLP^PSGOEM(RP,PSGRF) G PSGDUR
I $E(RP)="^" D FF G:Y>0 @Y G PSGDUR
I (+RP>0),'PSGIDF D I PSGRMV<1 K PSGRMV G PSGDUR ; exclude BID,TID or QID schedules
. S PSGDUR=(RP*60),PSGRMV=$G(PSGS0XT)-PSGDUR
. I PSGRMV<1 W !,"DURATION OF ADMINISTRATION MATCHES OR EXCEEDS ORDER FREQUENCY" S RP="",PSGDERR=1 K PSGDUR ;,PSGRMV G PSGDUR Q
.Q
Q:$G(PSGDERR)=1
I PSGRF=3,(+RP<1) W $C(7),!,"ENTRY IS REQUIRED" S RP="" G PSGDUR
I PSGRF=2,(+RP<1) D
.W !,"You have not entered Duration of Administration for this medication order, "
.W !,"therefore the BCMA user will not be prompted to remove the medication prior "
.W !,"to the next Admin Time."
.S PSGRMV=-1,RP=0
.Q
I PSGIDF,(+RP>0) D ;Only for TPD schedules
.N F,P,PSGARR
.S PSGADT=$S($G(PSGDUR)=-1:X,$G(PSGS0Y):PSGS0Y,$G(PSGAT):PSGAT,1:""),PSGS0Y=PSGADT
.S PSGARR=$L($G(PSGADT),"-")
.F P=1:1:PSGARR D
..S PSGARR(P)=($P(PSGADT,"-",P)/100) S:(P>1) F(P)=PSGARR(P)-PSGARR(P-1)
..I $G(F(P)),($G(F(P))'=RP) S WMSG=1_U_"Duration of Administration does not correspond to one or more",WMSG(1)="of this order's scheduled Administration Times!"
..Q
.Q
S:(+RP>0) PSGDUR=(RP*60)
W:(+RP>0) ?60,RP," HOURS"
D:$G(WMSG) EN^DDIOL($P(WMSG,U,2)),EN^DDIOL(WMSG(1))
Q
;
VERTIMES ; Redisplay Admin and Removal times *315
S PSGRF=+$$GET1^DIQ(50.7,$G(PSGPDRG),12,"I") Q:(PSGRF<2)!($G(PSGST)="O")
N PSGADT,PSGRARR,PSGAARR
;If we have a frequency and this is odd type order then we need to start calculations with order start time.
I $G(PSGS0XT),$G(PSGNESD),+$G(PSGDUR),$G(PSGAT)="" D Q
.N L
.S (PSGAARR,PSGRARR)=1,PSGADT=$P($P(PSGNESD,U,1),".",2),L=$L(PSGADT)
.S PSGRARR(1)=(((((PSGADT*60)+PSGDUR)/60)#24)*100) S:PSGRARR(1)=0 PSGRARR(1)=2400 S:$L(PSGRARR(1))=3 PSGRARR(1)="0"_PSGRARR(1)
.S PSGRARR(1)=$E(PSGRARR(1),1,L)_"(R)"
.S PSGAARR(1)=PSGADT,PSGAARR(1)=$E(PSGAARR(1),1,L)_"(A)"
.D WRITE
.Q
;
S (PSGRARR,PSGAARR)=$S($G(PSGAT):$L(PSGAT,"-"),1:$L(PSGS0Y,"-"))
N P,L
F P=1:1:PSGRARR D
.S PSGADT=$S($G(PSGAT):$P(PSGAT,"-",P),1:$P(PSGS0Y,"-",P)),L=$L(PSGADT)
.S PSGADT=$S($L(PSGADT)=4:PSGADT/100,1:PSGADT*1)
.S PSGRARR(P)=(((((PSGADT*60)+PSGDUR)/60)#24)*100) S:PSGRARR(P)=0 PSGRARR(P)=2400 S:$L(PSGRARR(P))=3 PSGRARR(P)="0"_PSGRARR(P)
.S PSGRARR(P)=$E(PSGRARR(P),1,L)_"(R)"
.S PSGAARR(P)=(PSGADT*100) S:$L(PSGAARR(P))=3 PSGAARR(P)="0"_PSGAARR(P)
.S PSGAARR(P)=$E(PSGAARR(P),1,L)_"(A)"
.Q
D WRITE
Q
;
WRITE ;
W !!,"Verify Admin and removal times",!
W !,"(A)DMINISTRATION -(R)EMOVAL TIMES"
W !,"___________________________________________________________________________",!
F P=1:1:PSGAARR W PSGAARR(P)_"-"_PSGRARR(P) W:P'=PSGAARR " , "
D ASK
Q
;
ASK ;
;PSJ*5.0*441: Add DIR to the N string.
N Y,DIR
S DIR("A")="Is this correct",DIR(0)="Y" D ^DIR I $D(DUOUT)!$D(DTOUT) W:'$T $C(7) S PSGOEE=0 K PSGDUR G DONE
I 'Y K X S PSGDUR=-1,PSGFOK(8)="" G A41
N P S P=1,PSGRMVT=$P(PSGRARR(P),"(",1)
F S P=$O(PSGRARR(P)) Q:P="" D
.S PSGRMVT=PSGRMVT_"-"_$P(PSGRARR(P),"(",1)
.Q
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSGOE91 16568 printed Sep 23, 2025@19:38:09 Page 2
PSGOE91 ;BIR/CML - ACTIVE ORDER EDIT (CONT.) ;May 03, 2023@17:45
+1 ;;5.0;INPATIENT MEDICATIONS;**50,64,58,110,111,136,113,179,265,267,285,315,334,373,366,327,441,451,454,455**;16 DEC 97;Build 2
+2 ;;Per VHA Directive 2004-038, this routine should not be modified.
+3 ;Reference to ^PS(55 in ICR #2191.
+4 ;Reference to ^PS(50.7 in ICR #2180
+5 ;Reference to ^PS(51.1 in ICR #2177
+6 ;Reference to YSCLTST2 in ICR #4556
+7 ;
41 ; admin times
+1 ;S MSG=0,PSGF2=41,ORIG=$G(PSGAT) S:PSGOEEF(PSGF2) BACK="41^PSGOE91"
+2 ;*315 next 5 lines
+3 NEW PSGDOA
+4 SET MSG=0
SET PSGF2=41
SET ORIG=$GET(PSGAT)
SET PSGDOA=$GET(PSGDUR)
if PSGOEEF(PSGF2)
SET BACK="41^PSGOE91"
+5 IF (PSGST="P")!$$PRNOK^PSGS0($GET(PSGSCH))
GOTO DONE
+6 IF $$ODD^PSGS0(PSGS0XT)
DO PSGDUR
GOTO DONE
A41 IF $GET(PSJORD)
IF $GET(PSGP)
IF $$COMPLEX^PSJOE(PSGP,PSJORD)
SET PSGOEE=0
Begin DoDot:1
+1 WRITE !!?5,"ADMIN TIMES may not be edited for active complex orders."
DO PAUSE^VALM1
End DoDot:1
GOTO DONE
+2 WRITE !,"ADMIN TIMES: "_$SELECT(PSGAT:PSGAT_"// ",1:"")
READ X:DTIME
IF X="^"!('$TEST)
if '$TEST
WRITE $CHAR(7)
SET PSGOEE=0
if X="^"
SET (X,PSGAT)=$GET(ORIG)
SET PSGDUR=""
GOTO DONE
+3 ;*315 If admin time default was taken then don't highlight admin time.
IF X=""
if $GET(PSGAT)
SET X=PSGAT
SET PSGNOHI=1
+4 IF $EXTRACT(X)="^"
DO ENFF^PSGOE92
if Y>0
GOTO @Y
GOTO A41
+5 IF X="@"
IF (PSGS0XT="D")!(PSGSCH["@")
IF ((",P,R,OC,O,")'[(","_$GET(PSGST)_","))
Begin DoDot:1
+6 WRITE $CHAR(7)," ??"
SET X="?"
if PSGS0XT="D"!(PSGSCH["@")
WRITE !,"This is a 'DAY OF THE WEEK' schedule and MUST have admin times."
DO ENHLP^PSGOEM(55.06,41)
End DoDot:1
GOTO A41
+7 IF X="@"
DO DEL
if %'=1
GOTO A41
SET PSGAT=""
SET X=""
+8 IF ((PSGST="O")!($GET(PSGST)="OC")!($GET(PSGST)="P")!$$ODD^PSGS0($PIECE($GET(ZZND),"^",3))!($PIECE($GET(ZZND),"^",5)="O"))
IF X=""
Begin DoDot:1
+9 SET (PSGS0Y,PSGAT)=X
+10 IF (($GET(PSGRF))&($GET(PSGST)="O"))
NEW PSGRO
SET PSGOEEF(34)=1
SET PSGOEEF(41)=1
SET PSGRO=1
DO 34
+11 QUIT
End DoDot:1
GOTO DONE
+12 ;*315
IF $GET(PSGS0XT)
IF '$$ODD^PSGS0(PSGS0XT)
IF $GET(PSGST)'="P"
IF $GET(PSGST)'="OC"
IF '$$PRNOK^PSGS0(PSGSCH)
IF ($GET(PSGST)'="O")
DO TIMES
if '$DATA(X)
GOTO A41
DO PSGDUR
if '$DATA(X)
GOTO A41
if $GET(X)="^"
GOTO DONE
+13 IF X?1."?"
DO ENHLP^PSGOEM(55.06,41)
GOTO A41
+14 DO ENCHK^PSGS0
IF '$DATA(X)
WRITE $CHAR(7)," ??"
SET X="?"
DO ENHLP^PSGOEM(55.06,41)
GOTO A41
+15 SET PSGOAT=PSGAT
+16 SET (PSGS0Y,PSGAT)=X
GOTO DONE
+17 ;
8 ; special instructions
+1 SET MSG=0
SET PSGF2=8
if PSGOEEF(PSGF2)
SET BACK="8^PSGOE91"
A8 IF $GET(PSGP)
IF $GET(PSGORD)
IF $$COMPLEX^PSJOE(PSGP,PSGORD)
Begin DoDot:1
+1 NEW X,Y,PARENT
SET PARENT=$SELECT(PSGORD["U":$$GET1^DIQ(55.06,+PSGORD_","_PSGP,125,"I"),1:$$GET1^DIQ(53.1,+PSGORD,125,"I"))
+2 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,PSGORD)
End DoDot:1
+3 IF $EXTRACT(X)=U
DO ENFF^PSGOE92
if Y>0
GOTO @Y
GOTO A8
+4 SET PSGSI=$$EDITSI^PSJBCMA5($GET(PSGP),$GET(PSGORD))
IF $GET(PSGP)
IF $GET(PSGORD)
IF '$$DIFFSI^PSJBCMA5(PSGP,PSGORD)
SET PSGOEE=0
GOTO DONE
+5 SET PSGSI=$SELECT((PSGSI>0&(PSGSI<4)):$$GET1^DIQ(53.455,"1,"_+PSJSYSP,.01)_" "_$$GET1^DIQ(53.455,"2,"_+PSJSYSP,.01),PSGSI>3:"Instructions too long. See Order View or BCMA for full text.",1:"")
+6 if PSGSI=" "
SET PSGSI=""
IF PSGSI]""
SET PSGSI=$$ENBCMA^PSJUTL("U")
GOTO DONE
+7 QUIT
+8 ;
10 ; start date/time edit
+1 SET MSG=0
SET PSGF2=10
if PSGOEEF(PSGF2)
SET BACK="10^PSGOE91"
A10 ; start date/time edit
+1 ; This variable indicates a Manual Edit of the Start/Date Time.
SET PSGSDEDT=1
+2 IF $GET(PSJORD)
IF $GET(PSGP)
IF $$COMPLEX^PSJOE(PSGP,PSJORD)
SET PSGOEE=0
Begin DoDot:1
+3 WRITE !!?5,"Start Date/Time may not be edited for active complex orders."
DO PAUSE^VALM1
End DoDot:1
GOTO DONE
+4 KILL PSGSDX
+5 WRITE !,"START DATE/TIME: "_$SELECT($PIECE(PSGSDN,"^")]"":$PIECE(PSGSDN,"^")_"// ",1:"")
READ X:DTIME
IF X="^"!'$TEST
if '$TEST
WRITE $CHAR(7)
SET PSGOEE=0
GOTO DONE
+6 ;P451
IF X=""
IF PSGSD
WRITE " "_$PIECE(PSGSDN,"^")
GOTO DONE
+7 ;I X="P" D ENPREV^PSGDL W:'$D(X) $C(7) G:'$D(X) A10 S PSGSD=+X,PSGSDN=$$ENDD^PSGMI(PSGSD)_"^"_$$ENDTC^PSGMI(PSGSD) W " ",$P(PSGSDN,"^") G DONE ;373
+8 ;373
IF X="P"
DO ENPREV^PSGDL
if '$DATA(X)
WRITE $CHAR(7)
if '$DATA(X)
GOTO A10
SET PSGSD=+X
SET PSGSDN=$$ENDD^PSGMI(PSGSD)_"^"_$$ENDTC2^PSGMI(PSGSD)
WRITE " ",$PIECE(PSGSDN,"^")
GOTO DONE
+9 IF X="@"!(X?1."?")
if X="@"
WRITE $CHAR(7)," (Required)"
if X="@"
SET X="?"
DO ENHLP^PSGOEM(55.06,10)
+10 IF $EXTRACT(X)="^"
DO ENFF^PSGOE92
if Y>0
GOTO @Y
GOTO A10
+11 NEW TMPX
SET TMPX=X
SET X1=PSGDT
SET X2=-7
DO C^%DTC
KILL %DT
SET %DT="ERTX"
SET %DT(0)=X
SET X=TMPX
DO ^%DT
KILL %DT
IF Y'>0
DO ENHLP^PSGOEM(55.06,10)
GOTO A10
+12 IF PSGFD<Y
WRITE $CHAR(7),!?5,"*** THE START DATE CANNOT BE AFTER THE STOP DATE! ***",!
SET MSG=1
GOTO A10
+13 ; RBD PSJ*5*373 Soft stop when Start Date more than 7 days after Order's LOGIN DATE
+14 SET X1=+$GET(PSGDT)
SET X2=+7
DO C^%DTC
+15 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
+16 NEW X1,X2,DIFF,PSGEMRG,PSGBACK
SET X1=PSGFD
SET X2=Y
DO ^%DTC
SET DIFF=X
+17 NEW CLOZFLG
SET CLOZFLG=$$ISCLOZ^PSJCLOZ(,,PSGP,+$GET(PSJORD))
+18 ;S PSGEMRG=$S($$GET1^DIQ(55,DFN,53)?2U5N:1,1:0),PSGBACK=0
+19 SET PSGEMRG=0
SET PSGBACK=0
+20 IF ($$GET1^DIQ(55,DFN,53)?2U5N)
IF ($PIECE($GET(^XTMP("PSJ4D-"_DFN,0)),"^",1))>$$HTFM^XLFDT($HOROLOG,1)
SET PSGEMRG=1
+21 ; Emergency Registration period not to exceed 4 days
IF PSGEMRG
IF $GET(CLOZFLG)
IF DIFF>4
Begin DoDot:1
+22 WRITE !!?13,"*** EMERGENCY SUPPLY NOT TO EXCEED 4 DAYS! ***",!
End DoDot:1
GOTO A10
+23 IF 'PSGEMRG
IF $GET(CLOZFLG)
Begin DoDot:1
+24 NEW CLOZPAT,X2,PSGCFLG,PSGANC
DO CLOZPAT^PSJCLOZ
+25 SET PSGCFLG=1
SET PSGANC=$$CL^YSCLTST2(DFN)
+26 IF '$$OVERRIDE^YSCLTST2(DFN)
IF '+$PIECE(PSGANC,"^",4)
SET X2=4
+27 IF '$TEST
SET X2=$SELECT($GET(CLOZPAT)=2:28,$GET(CLOZPAT)=1:14,$GET(CLOZPAT)=0:7,1:90)
+28 IF DIFF>X2
WRITE !!,"*** SUPPLY PERIOD NOT TO EXCEED "_X2_" DAYS! ***",!
SET PSGBACK=1
End DoDot:1
if PSGBACK
GOTO A10
+29 ;S (PSGSDX,PSGSD)=+Y,PSGSDN=$$ENDD^PSGMI(PSGSD)_"^"_$$ENDTC^PSGMI(PSGSD) G DONE ;373
+30 ;373
SET (PSGSDX,PSGSD)=+Y
SET PSGSDN=$$ENDD^PSGMI(PSGSD)_"^"_$$ENDTC2^PSGMI(PSGSD)
GOTO DONE
+31 ;
34 ; stop date
+1 SET MSG=0
SET PSGF2=34
if PSGOEEF(PSGF2)
SET BACK="34^PSGOE91"
A34 ;
+1 ;
+2 KILL PSGFDX
NEW PSGEMRG
+3 IF $GET(PSJORD)
IF $GET(PSGP)
IF $$COMPLEX^PSJOE(PSGP,PSJORD)
IF '$$LASTCHLD^PSJCLOZ(PSGP,PSJORD)
SET PSGOEE=0
Begin DoDot:1
+4 WRITE !!?5,"Stop Date/Time may not be edited for active complex orders."
DO PAUSE^VALM1
End DoDot:1
GOTO DONE
+5 ;; START NCC REMEDIATION RJS*327
+6 NEW CLOZFLG
SET CLOZFLG=$$ISCLOZ^PSJCLOZ(,,PSGP,+$GET(PSJORD))
+7 IF $GET(CLOZFLG)
NEW CLOZPAT,PSGDRG
SET PSGDRG=$PIECE(CLOZFLG,U,2)
DO CLOZPAT^PSJCLOZ
+8 IF $DATA(CLOZPAT)
NEW PSGOLDED,PSGFDNOLD
SET PSGOLDED=PSGFD
SET PSGFDNOLD=PSGFDN
+9 ;; END NCC REMEDIATION RJS*327
+10 ;*315 One time orders for MRR's require message to instruct pharmacists
NEW MSG,PSGTMPST
SET PSGTMPST=$GET(PSGST)
if '+$GET(PSGRF)
SET PSGRF=+$$GET1^DIQ(50.7,$GET(PSGPDRG),12,"I")
+11 IF +$GET(PSGRF)
IF $$FIND1^DIC(51.1,,"X",$GET(PSGSCH))
Begin DoDot:1
+12 ;Handle "Fill on Request"
if PSGTMPST=($GET(PSGST)="R")
SET PSGST=$$GET1^DIQ(51.1,$$FIND1^DIC(51.1,,"X",$GET(PSGSCH)),5,"I")
+13 QUIT
End DoDot:1
+14 IF $GET(PSGTMPST)="O"
IF +$GET(PSGRF)
SET (PSGFDN,PSGFD)=""
Begin DoDot:1
+15 IF +$GET(PSGRF)=1
SET MSG(1)="This NOW order has an Orderable Item for which a removal is required"
Begin DoDot:2
+16 SET MSG(2)=" at the next administration."
+17 SET MSG(3)="The Stop DATE/TIME entered should be the next anticipated administration for the medication."
SET MSG(3,"F")="!"
+18 QUIT
End DoDot:2
+19 IF +$GET(PSGRF)=2
SET MSG(1)="This NOW order has an Orderable Item for which a removal period is optional"
SET MSG(1,"F")="!!"
Begin DoDot:2
+20 SET MSG(2)="prior to the next administration."
SET MSG(2,"F")="!"
+21 SET MSG(3)="If Early Removal is needed, enter Removal Time in Stop DATE/TIME field."
SET MSG(3,"F")="!"
+22 SET MSG(4)="If an Early Removal is not required, the Stop DATE/TIME entered"
+23 SET MSG(5)="should be the next anticipated administration for the medication."
SET MSG(5,"F")="!"
+24 QUIT
End DoDot:2
+25 IF +$GET(PSGRF)=3
SET MSG(1)="This NOW order has an Orderable Item that requires a removal period prior"
SET MSG(1,"F")="!!"
Begin DoDot:2
+26 SET MSG(2)=" to the next administration."
SET MSG(2,"F")="!"
+27 SET MSG(3)="Please Enter the Stop DATE/TIME to reflect the Removal Time for this medication."
SET MSG(3,"F")="!"
+28 QUIT
End DoDot:2
+29 DO EN^DDIOL(.MSG)
+30 QUIT
End DoDot:1
+31 IF $DATA(PSGFDORG)
SET PSGFDN=PSGFDORG
SET PSGFD=PSGFDORX
+32 IF '$DATA(PSGFDORG)
NEW PSGFDORG,PSGFDORX
SET PSGFDORG=PSGFDN
SET PSGFDORX=PSGFD
+33 WRITE !,"STOP DATE/TIME: "_$SELECT($PIECE(PSGFDN,"^")]"":$PIECE(PSGFDN,"^")_"// ",1:"")
READ X:DTIME
IF X="^"!'$TEST
if '$TEST
WRITE $CHAR(7)
SET PSGOEE=0
GOTO DONE
+34 IF X=""
IF PSGFD
WRITE " "_$PIECE(PSGFDN,"^")
GOTO W34
+35 IF $EXTRACT(X)="^"
DO ENFF^PSGOE92
if Y>0
GOTO @Y
GOTO A34
+36 IF X="@"!(X?1."?")
if X="@"
WRITE $CHAR(7)," (Required)"
if X="@"
SET X="?"
DO ENHLP^PSGOEM(55.06,34)
+37 IF X=+X
IF (X>0)
IF (X'>2000000)
if '$$ENDL^PSGDL(PSGSCH,X)
GOTO A34
KILL PSGDLS
SET PSGDL=X
WRITE " ...dose limit..."
DO ENE^PSGDL
+38 KILL %DT
SET %DT="ERTX"
SET %DT(0)=PSGSD
DO ^%DT
KILL %DT
IF Y'>0
WRITE $CHAR(7),!!?13,"*** WARNING! INVALID STOP DATE OR PRIOR TO START DATE! ***",!
GOTO A34
+39 ; RBD PSJ*5*373 Hard stop when Stop Date more than 367 days after Start Date
+40 SET X1=+Y
SET X2=PSGSD
DO ^%DTC
+41 IF X>367
WRITE $CHAR(7),!!?13,"*** STOP DATE cannot be more than 367 days from START DATE ***",!
GOTO A34
+42 ;S (PSGFDX,PSGFD)=+Y,PSGFDN=$$ENDD^PSGMI(PSGFD)_"^"_$$ENDTC^PSGMI(PSGFD) ;373
+43 ;373
SET (PSGFDX,PSGFD)=+Y
SET PSGFDN=$$ENDD^PSGMI(PSGFD)_"^"_$$ENDTC2^PSGMI(PSGFD)
+44 ;/RJS Begin changes for emergency registration of clozapine patient Set end date to start date + 4 days at midnight.
+45 SET PSGEMRG=$$GET1^DIQ(55,DFN,53)?1U6N
+46 IF $GET(CLOZFLG)
NEW PSGBACK
Begin DoDot:1
+47 NEW PSGANC,PSGOVRD,PSGCFLG
SET PSGCFLG=1
+48 if $$OVERRIDE^YSCLTST2(DFN)
SET PSGOVRD=1
+49 SET PSGANC=$$CL^YSCLTST2(DFN)
+50 NEW X,X1,X2
SET X1=+Y
SET X2=PSGSD
DO ^%DTC
+51 IF '$GET(PSGOVRD)
IF '+$PIECE(PSGANC,"^",4)
SET X2=4
+52 IF '$TEST
IF PSGEMRG
SET X2=4
+53 IF '$TEST
SET X2=$SELECT($GET(CLOZPAT)=2:28,$GET(CLOZPAT)=1:14,$GET(CLOZPAT)=0:7,1:90)
+54 IF X>X2
SET PSGBACK=1
Begin DoDot:2
+55 IF X2=4
+56 IF PSGEMRG
WRITE !!?13,"*** EMERGENCY SUPPLY NOT TO EXCEED 4 DAYS! ***",!
QUIT
+57 WRITE !!,"*** STOP DATE/TIME NOT TO EXCEED "_X2_" DAYS! ***",!
End DoDot:2
End DoDot:1
if $GET(PSGBACK)
GOTO A34
+58 if $GET(PSGEMRG)
KILL PSGEMRG
+59 ;/RJS End verify that stop date does not exceed maximum days supply based on lab frequency.
+60 ;; END NCC REMEDIATION RJS*327
W34 ;Compare to Start Date
+1 NEW Z,MSG
+2 DO DOSE
IF $GET(Z)]""
IF Z>$SELECT($GET(PSGFD):PSGFD,1:$GET(PSGNEFD))
Begin DoDot:1
+3 SET MSG(1)="There is no administration time that falls between the Start Date/Time"
+4 SET MSG(2)="and the Stop Date/Time."
+5 DO EN^DDIOL(.MSG)
End DoDot:1
GOTO A34
+6 IF PSGFD<PSGDT
WRITE $CHAR(7),!!?13,"*** WARNING! THE STOP DATE ENTERED IS IN THE PAST! ***",!
SET MSG=1
+7 if +$GET(PSGRO)
QUIT
+8 ;
DONE ;
+1 ;Display Expected First Dose;BHW;PSJ*5*136
+2 ;BHW;PSJ*5*179; - Remove EFD call. Added to PSGOEE.
+3 ;P451
IF PSGOEE
if '$GET(PSGOEEF(PSGF2))
GOTO @BACK
SET PSGOEE=PSGOEEF(PSGF2)
+4 ;*315
if +$GET(PSGDUR)
DO VERTIMES
+5 if '+$GET(PSGRF)
SET PSGRF=+$$GET1^DIQ(50.7,$GET(PSGPDRG),12,"I")
+6 KILL F,F0,F1,PSGF2,F3,PSG,SDT,ORIG
QUIT
+7 ;
FF ; up-arrow to another field
+1 DO ENFF^PSGOEM
IF Y>0
IF Y'=41
IF Y'=8
IF Y'=10
IF Y'=34
SET Y=Y_"^PSGOE9"_$SELECT("^109^13^3^7^26^"[("^"_Y_"^"):"",1:2)
if Y=2
SET FB=PSGF2_"^PSGOE91"
+2 QUIT
+3 ;
DEL ; delete entry
+1 WRITE !?3,"SURE YOU WANT TO DELETE"
SET %=0
DO YN^DICN
IF %'=1
WRITE $CHAR(7)," <NOTHING DELETED>"
+2 QUIT
+3 ;
TIMES ;At least one admin time, not more than interval allows.
+1 ;No times
IF $GET(PSGST)'="O"
IF ($GET(PSGST)'="OC")
IF ($GET(PSGST)'="R")
IF X=""
DO EN^DDIOL("This order requires at least one administration time.")
KILL X
QUIT
+2 NEW H,I,MAX
+3 ;I PSGSCH]"" S H=$$FIND1^DIC(51.1,,"X",PSGSCH) I H S I=$$GET1^DIQ(51.1,H,2,"I")
+4 IF PSGSCH]""
SET H=+$ORDER(^PS(51.1,"AC","PSJ",PSGSCH,0))
IF H
SET I=$$GET1^DIQ(51.1,H,2,"I")
+5 IF $GET(PSGST)="O"
IF $LENGTH(X,"-")>1
DO EN^DDIOL("This is a One Time Order. Only one administration time is permitted.")
KILL X
QUIT
+6 ;Done validating One Time
IF $GET(PSGST)="O"
QUIT
+7 ;No frequency - can not check frequency related items
IF +$GET(I)=0
QUIT
+8 ;P454 messages to the user
+9 IF $DATA(X)
Begin DoDot:1
+10 IF (X'["-")
Begin DoDot:2
+11 IF (X'?2N)
IF (X'?4N)
WRITE !,"ADMIN TIMES must be entered in a 2 or 4 digit numeric format"
KILL X
QUIT
End DoDot:2
+12 IF '$TEST
Begin DoDot:2
+13 NEW LEN,TOT,CHK
SET LEN=$LENGTH($PIECE(X,"-"))
+14 FOR TOT=1:1:$LENGTH(X,"-")
SET CHK=$PIECE(X,"-",TOT)
if CHK=""
QUIT
IF ((CHK'?2N)&(CHK'?4N))!(LEN'=$LENGTH(CHK))
WRITE !,"All ADMIN TIMES must be the same 2 or 4 digit numeric format"
WRITE !,"(i.e. 09-13 or 0900-1300)"
KILL X
QUIT
End DoDot:2
End DoDot:1
if '$GET(X)
QUIT
+15 SET MAX=1440/I
+16 IF MAX<1
IF $LENGTH(X,"-")>1
DO EN^DDIOL("This order requires one administration time.")
KILL X
QUIT
+17 ;Too many times
IF MAX'<1
IF $LENGTH(X,"-")>MAX
DO EN^DDIOL("The number of admin times entered is greater than indicated by the schedule.")
KILL X
QUIT
+18 ;Too few times ;P455 remove K
IF MAX'<1
IF $LENGTH(X,"-")<MAX
DO EN^DDIOL("The number of admin times entered is fewer than indicated by the schedule.")
QUIT
+19 QUIT
+20 ;
DOSE ;Make certain at least one dose is given.
+1 NEW INFO,X
+2 SET Z=""
SET INFO=($SELECT($GET(PSGSD):PSGSD,1:$GET(PSGNESD)))_U_($SELECT($GET(PSGFD):PSGFD,1:$GET(PSGNEFD)))_U_($GET(PSGSCH))_U_($GET(PSGST))_U_($GET(PSGDRG))_U_($GET(PSGS0Y))
+3 if $GET(PSGST)="OC"!($GET(PSGST)="P")
QUIT
+4 IF '$LENGTH($GET(PSGP))
NEW PSGP
SET PSGP=""
+5 ;Expected first dose.
SET Z=$$ENQ^PSJORP2(PSGP,INFO)
+6 QUIT
+7 ;*315 New tags
PSGDUR ; Prompt for Removal times if admin times are on 24hr rotations and Site Params are enabled.
+1 ; check parameter files for removal criteria quit if removal rotation not enabled (<2)
+2 ; if enabled determine type (hard vers soft stop)
+3 ;0 = no removal (current cap/tab functionality)
+4 ;1 = removal at next admin (current patch functionality)
+5 ;2 = removal prior to next admin; soft stop (pharmacist optional prompt to designate duration of administration)
+6 ;3 = removal prior to next admin; hard stop (pharmacist required prompt to designate duration of administration)
+7 ; prompt for removal if = 2 then allow skip, if = 3 then force entry
+8 ;
+9 ; no removal flag or no removal rotation
SET PSGRF=+$$GET1^DIQ(50.7,$GET(PSGPDRG),12,"I")
if ((PSGRF<2)!($GET(PSGST)="O")!($GET(PSGST)="P")!($GET(PSGST)="OC"))
QUIT
+10 ; Duration of Administration valid only for 24 hours - subject to change in future.
if $GET(PSGS0XT)>1440
QUIT
+11 ; Use separate validation for Times per day type orders
NEW RP,PSGIDF,WMSG,PSGDERR
SET (PSGIDF,PSGDERR)=0
if $GET(PSGDUR)>0
SET RP=(PSGDUR/60)
if "BID,TID,QID"[$GET(PSGSCH)
SET PSGIDF=1
+12 SET PSGF2=41
+13 WRITE !,"DURATION OF ADMINISTRATION (HRS): "_$SELECT($GET(RP):RP_"// ",1:"")
READ RP:DTIME
IF RP="^"!'$TEST
if '$TEST
WRITE $CHAR(7)
SET PSGDUR=$GET(PSGDOA)
SET X="^"
SET PSGOEE=0
QUIT
+14 IF RP=""
if $GET(PSGDUR)>0
SET RP=($GET(PSGDUR)/60)
+15 IF RP=""
IF $GET(PSGS0XT)="D"
IF $LENGTH(PSGSCH,"@")=2
IF $PIECE(PSGSCH,"@",2)
SET (PSGAT,PSGRMVT)=$PIECE(PSGSCH,"@",2)
GOTO 8
+16 IF RP="@"
IF PSGRF'=3
DO DEL
if %'=1
GOTO PSGDUR
SET PSGS0Y=""
SET (PSGDUR,PSGRMVT)="@"
SET PSGRMV=-1
QUIT
+17 IF (RP'="")
IF (RP'="@")
IF ($EXTRACT(RP)'="^")
IF ($EXTRACT(RP)'="?")
if (RP'?1N.2N)!(+(RP)<1)
SET RP="?"
+18 IF RP?1."?"
DO DURHLP^PSGOEM(RP,PSGRF)
GOTO PSGDUR
+19 IF $EXTRACT(RP)="^"
DO FF
if Y>0
GOTO @Y
GOTO PSGDUR
+20 ; exclude BID,TID or QID schedules
IF (+RP>0)
IF 'PSGIDF
Begin DoDot:1
+21 SET PSGDUR=(RP*60)
SET PSGRMV=$GET(PSGS0XT)-PSGDUR
+22 ;,PSGRMV G PSGDUR Q
IF PSGRMV<1
WRITE !,"DURATION OF ADMINISTRATION MATCHES OR EXCEEDS ORDER FREQUENCY"
SET RP=""
SET PSGDERR=1
KILL PSGDUR
+23 QUIT
End DoDot:1
IF PSGRMV<1
KILL PSGRMV
GOTO PSGDUR
+24 if $GET(PSGDERR)=1
QUIT
+25 IF PSGRF=3
IF (+RP<1)
WRITE $CHAR(7),!,"ENTRY IS REQUIRED"
SET RP=""
GOTO PSGDUR
+26 IF PSGRF=2
IF (+RP<1)
Begin DoDot:1
+27 WRITE !,"You have not entered Duration of Administration for this medication order, "
+28 WRITE !,"therefore the BCMA user will not be prompted to remove the medication prior "
+29 WRITE !,"to the next Admin Time."
+30 SET PSGRMV=-1
SET RP=0
+31 QUIT
End DoDot:1
+32 ;Only for TPD schedules
IF PSGIDF
IF (+RP>0)
Begin DoDot:1
+33 NEW F,P,PSGARR
+34 SET PSGADT=$SELECT($GET(PSGDUR)=-1:X,$GET(PSGS0Y):PSGS0Y,$GET(PSGAT):PSGAT,1:"")
SET PSGS0Y=PSGADT
+35 SET PSGARR=$LENGTH($GET(PSGADT),"-")
+36 FOR P=1:1:PSGARR
Begin DoDot:2
+37 SET PSGARR(P)=($PIECE(PSGADT,"-",P)/100)
if (P>1)
SET F(P)=PSGARR(P)-PSGARR(P-1)
+38 IF $GET(F(P))
IF ($GET(F(P))'=RP)
SET WMSG=1_U_"Duration of Administration does not correspond to one or more"
SET WMSG(1)="of this order's scheduled Administration Times!"
+39 QUIT
End DoDot:2
+40 QUIT
End DoDot:1
+41 if (+RP>0)
SET PSGDUR=(RP*60)
+42 if (+RP>0)
WRITE ?60,RP," HOURS"
+43 if $GET(WMSG)
DO EN^DDIOL($PIECE(WMSG,U,2))
DO EN^DDIOL(WMSG(1))
+44 QUIT
+45 ;
VERTIMES ; Redisplay Admin and Removal times *315
+1 SET PSGRF=+$$GET1^DIQ(50.7,$GET(PSGPDRG),12,"I")
if (PSGRF<2)!($GET(PSGST)="O")
QUIT
+2 NEW PSGADT,PSGRARR,PSGAARR
+3 ;If we have a frequency and this is odd type order then we need to start calculations with order start time.
+4 IF $GET(PSGS0XT)
IF $GET(PSGNESD)
IF +$GET(PSGDUR)
IF $GET(PSGAT)=""
Begin DoDot:1
+5 NEW L
+6 SET (PSGAARR,PSGRARR)=1
SET PSGADT=$PIECE($PIECE(PSGNESD,U,1),".",2)
SET L=$LENGTH(PSGADT)
+7 SET PSGRARR(1)=(((((PSGADT*60)+PSGDUR)/60)#24)*100)
if PSGRARR(1)=0
SET PSGRARR(1)=2400
if $LENGTH(PSGRARR(1))=3
SET PSGRARR(1)="0"_PSGRARR(1)
+8 SET PSGRARR(1)=$EXTRACT(PSGRARR(1),1,L)_"(R)"
+9 SET PSGAARR(1)=PSGADT
SET PSGAARR(1)=$EXTRACT(PSGAARR(1),1,L)_"(A)"
+10 DO WRITE
+11 QUIT
End DoDot:1
QUIT
+12 ;
+13 SET (PSGRARR,PSGAARR)=$SELECT($GET(PSGAT):$LENGTH(PSGAT,"-"),1:$LENGTH(PSGS0Y,"-"))
+14 NEW P,L
+15 FOR P=1:1:PSGRARR
Begin DoDot:1
+16 SET PSGADT=$SELECT($GET(PSGAT):$PIECE(PSGAT,"-",P),1:$PIECE(PSGS0Y,"-",P))
SET L=$LENGTH(PSGADT)
+17 SET PSGADT=$SELECT($LENGTH(PSGADT)=4:PSGADT/100,1:PSGADT*1)
+18 SET PSGRARR(P)=(((((PSGADT*60)+PSGDUR)/60)#24)*100)
if PSGRARR(P)=0
SET PSGRARR(P)=2400
if $LENGTH(PSGRARR(P))=3
SET PSGRARR(P)="0"_PSGRARR(P)
+19 SET PSGRARR(P)=$EXTRACT(PSGRARR(P),1,L)_"(R)"
+20 SET PSGAARR(P)=(PSGADT*100)
if $LENGTH(PSGAARR(P))=3
SET PSGAARR(P)="0"_PSGAARR(P)
+21 SET PSGAARR(P)=$EXTRACT(PSGAARR(P),1,L)_"(A)"
+22 QUIT
End DoDot:1
+23 DO WRITE
+24 QUIT
+25 ;
WRITE ;
+1 WRITE !!,"Verify Admin and removal times",!
+2 WRITE !,"(A)DMINISTRATION -(R)EMOVAL TIMES"
+3 WRITE !,"___________________________________________________________________________",!
+4 FOR P=1:1:PSGAARR
WRITE PSGAARR(P)_"-"_PSGRARR(P)
if P'=PSGAARR
WRITE " , "
+5 DO ASK
+6 QUIT
+7 ;
ASK ;
+1 ;PSJ*5.0*441: Add DIR to the N string.
+2 NEW Y,DIR
+3 SET DIR("A")="Is this correct"
SET DIR(0)="Y"
DO ^DIR
IF $DATA(DUOUT)!$DATA(DTOUT)
if '$TEST
WRITE $CHAR(7)
SET PSGOEE=0
KILL PSGDUR
GOTO DONE
+4 IF 'Y
KILL X
SET PSGDUR=-1
SET PSGFOK(8)=""
GOTO A41
+5 NEW P
SET P=1
SET PSGRMVT=$PIECE(PSGRARR(P),"(",1)
+6 FOR
SET P=$ORDER(PSGRARR(P))
if P=""
QUIT
Begin DoDot:1
+7 SET PSGRMVT=PSGRMVT_"-"_$PIECE(PSGRARR(P),"(",1)
+8 QUIT
End DoDot:1
+9 QUIT
+10 ;
