PSGOE81 ;BIR/CML - NON-VERIFIED ORDER EDIT (CONT.) ;May 03, 2023@17:45
;;5.0;INPATIENT MEDICATIONS;**26,50,64,58,82,110,111,136,113,267,315,334,373,366,327,441,451,454**;16 DEC 97;Build 6
;Per VHA Directive 2004-038, this routine should not be modified.
;Reference to ^PS(50.7 in ICR #2180
;Reference to ^PS(51.1 in ICR #2177
;
39 ; admin times
N PSGDOA
S MSG=0,PSGF2=39 S:PSGOEEF(PSGF2) BACK="39^PSGOE81",ORIG=$G(PSGAT),PSGDOA=$G(PSGDUR)
A39 ;*315 next 2 lines
I (PSGST="P")!$$PRNOK^PSGS0($G(PSGSCH)) G DONE
I $$ODD^PSGS0(PSGS0XT) D PSGDUR G DONE
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 ;*315
I X="" S:(($G(PSGS0XT)="D")&'$G(PSGS0Y)) PSGOEE=0 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^PSGOE82 G:Y>0 @Y G A39
I X=" "!(X?1."?") D ENHLP^PSGOEM(53.1,39) G A39
I PSGS0XT="D"&'$G(X) I ((",P,R,")'[(","_$G(PSGST)_",")) D G A39
.W $C(7)," ??" S X="?" W !,"This is a 'DAY OF THE WEEK' schedule and MUST have admin times." D ENHLP^PSGOEM(53.1,39)
I X="@" D DEL G:%'=1 A39 S PSGAT="",X=""
I $G(PSGS0XT),'$$ODD^PSGS0(PSGS0XT),$G(PSGS0XT)'="P",$G(PSGS0XT)'="OC",'$$PRNOK^PSGS0(PSGSCH),($G(PSGST)'="O") D TIMES G:'$D(X) A39 D PSGDUR G:'$D(X) A39 G:$G(X)="^" DONE ;*315
I (($G(PSGST)="O")!($G(PSGST)="OC")),X="" D G DONE
.S (PSGS0Y,PSGAT)=X
.I (($G(PSGRF))&($G(PSGST)="O")) N PSGRO S (PSGRO,PSGOEEF(25))=1,PSGOEEF(39)=1 D 25
.Q
D ENCHK^PSGS0 I '$D(X) W $C(7) G A39
S PSGOAT=PSGAT
S (PSGS0Y,PSGAT)=X G DONE
;
8 ; special instructions
S MSG=0,PSGF2=8 S:PSGOEEF(PSGF2) BACK="8^PSGOE81"
A8 ; special instructions
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)):$G(^PS(53.45,+PSJSYSP,5,1,0))_" "_$G(^PS(53.45,+PSJSYSP,5,2,0)),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^PSGOE81"
A10 ; start date/time edit
S PSGSDEDT=1 ; This variable indicates a Manual Edit of the Start/Date Time.
K PSGSDX N DUR,DURMIN,TMPFD
I $G(PSGORD)["P",$G(PSGP) I $$LASTREN^PSJLMPRI(PSGP,PSGORD) D Q
.W !?5,"Start Date may not be edited at this point. " D PAUSE^VALM1
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
I X="P" D ENPREV^PSGDL W:'$D(X) $C(7) G:'$D(X) A10 D G DONE
.S PSGSD=+X,PSGSDN=$$ENDD^PSGMI(PSGSD)_"^"_$$ENDTC^PSGMI(PSGSD)
.W " ",$P(PSGSDN,"^")
I X="@"!(X?1."?") W:X="@" $C(7)," (Required)" S:X="@" X="?" D ENHLP^PSGOEM(53.1,10)
I $E(X)="^" D ENFF^PSGOE82 G:Y>0 @Y G A10
NEW TMPX S TMPX=X,X1=+$G(PSGLI),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(53.1,10) G A10
I PSGFD<Y D G A10
.W $C(7),!?5,"*** THE START DATE CANNOT BE AFTER THE STOP DATE! ***",! S MSG=1
; RBD PSJ*5*373 Soft stop when Start Date more than 7 days after Order's LOGIN DATE
S X1=+$G(PSGLI),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,CLOZFLG S X1=PSGFD,X2=Y D ^%DTC S DIFF=X
I $G(PSGORD) S CLOZFLG=$$ISCLOZ^PSJCLOZ(+PSGORD) I 1
E S CLOZFLG=$$ISCLOZ^PSJCLOZ(,,,,PSGDRG)
;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 D CLOZPAT^PSJCLOZ
.S X2=$S($P($G(ANQDATA),"^",3)=9:4,$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,PSGNESD)=+Y,PSGSDN=$$ENDD^PSGMI(PSGSD)_"^"_$$ENDTC^PSGMI(PSGSD) ;373
S (PSGSDX,PSGSD,PSGNESD)=+Y,PSGSDN=$$ENDD^PSGMI(PSGSD)_"^"_$$ENDTC2^PSGMI(PSGSD) ;373
I $G(PSGORD)["P",$G(PSGP) S DUR=$$GETDUR^PSJLIVMD(PSGP,+PSGORD,"P",1) I DUR]"" S DURMIN=$$DURMIN^PSJLIVMD(DUR) I DURMIN D
. ;S TMPFD=$$FMADD^XLFDT(PSGSD,,,DURMIN) K:(TMPFD<PSGSD) TMPFD I $G(TMPFD) S PSGFD=TMPFD,PSGFDN=$$ENDD^PSGMI(PSGFD)_"^"_$$ENDTC^PSGMI(PSGFD) ;373
. S TMPFD=$$FMADD^XLFDT(PSGSD,,,DURMIN) K:(TMPFD<PSGSD) TMPFD I $G(TMPFD) S PSGFD=TMPFD,PSGFDN=$$ENDD^PSGMI(PSGFD)_"^"_$$ENDTC2^PSGMI(PSGFD) ;373
G DONE
;
25 ; stop date
S MSG=0,PSGF2=25 S:PSGOEEF(PSGF2) BACK="25^PSGOE81"
A25 ;
;; START NCC REMEDIATION RJS*327
N CLOZFLG,CLOZPAT
I $G(PSGORD) S CLOZFLG=$$ISCLOZ^PSJCLOZ(+PSGORD) I 1
E S CLOZFLG=$$ISCLOZ^PSJCLOZ(,,,,PSGDRG)
I $G(CLOZFLG) N CLOZPAT,PSGDRG S PSGDRG=$P(CLOZFLG,U,2) D CLOZPAT^PSJCLOZ
I $G(CLOZFLG) 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 $$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
K PSGFDX N PSGEMRG
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 S X=$P(PSGFDN,"^")
I $E(X)="^" D ENFF^PSGOE82 G:Y>0 @Y G A25
I X="@"!(X?1."?") W:X="@" $C(7)," (Required)" S:X="@" X="?" D ENHLP^PSGOEM(53.1,25)
I X=+X,(X>0),(X'>2000000) G A25:'$$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 A25
; 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 A25
;S (PSGFDX,PSGFD,PSGNEFD)=+Y,PSGFDN=$$ENDD^PSGMI(PSGFD)_"^"_$$ENDTC^PSGMI(PSGFD) ;373
S (PSGFDX,PSGFD,PSGNEFD)=+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.
N PSGGTF S PSGGTF=0
I ($$GET1^DIQ(55,DFN,53)?1U6N)!($$GET1^DIQ(55,DFN,53)?2U5N),$G(CLOZFLG) D G:PSGGTF A25 ;def 418867 RJS*327
.I $P($G(^XTMP("PSJ4D-"_DFN,0)),"^",1)>$$HTFM^XLFDT($H,1) D
..N X1,X2 S X1=+Y,X2=PSGSD D ^%DTC
..S PSGEMRG=1 Q:X'>4
..I X>4 D
...W !!?13,"*** EMERGENCY SUPPLY NOT TO EXCEED 4 DAYS! ***",!
...S $P(PSGFD,".",2)=2359,X1=PSGSD,X2=4 D C^%DTC S PSGFD=X
...S $P(PSGFDN,"^",1)=$$ENDD^PSGMI(PSGFD),$P(PSGFDN,"^",2)=PSGFD
...S PSGGTF=1
;/RJS End changes for emergency registration of clozapine patient Set end date to start date + 4 days at midnight.
;/RJS Begin verify that stop date does not exceed maximum days supply based on lab frequency
A255 I '$G(PSGEMRG),$G(CLOZFLG) N PSGBACK D G:$G(PSGBACK) A25
.N PSGCFLG S PSGCFLG=1
.N X,X1,X2
.S X2=$S($P($G(ANQDATA),"^",3)=9:4,$G(CLOZPAT)=2:28,$G(CLOZPAT)=1:14,$G(CLOZPAT)=0:7,1:90)
.S X1=+Y D
..N X2 S X2=PSGSD D ^%DTC S X1=PSGSD
.I X>X2 W !!,"*** STOP DATE/TIME NOT TO EXCEED "_X2_" DAYS! ***",! S PSGBACK=1 Q
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
S (PSGFDX,PSGFD,PSGNEFD)=+Y,PSGFDN=$$ENDD^PSGMI(PSGFD)_"^"_$$ENDTC^PSGMI(PSGFD)
W25 ;
N Z,MSG
D DOSE I $G(Z)]"",Z>PSGNEFD D G A25
. 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
D EFDNV^PSJUTL
I PSGOEE G:'$G(PSGOEEF(PSGF2)) @BACK S PSGOEE=PSGOEEF(PSGF2) ;P451
D:+$G(PSGDUR) VERTIMES ;*315
K ORIG,PSGOLDED,PSGNEFDOLD,PSGFDNOLD
S:'+$G(PSGRF) PSGRF=+$$GET1^DIQ(50.7,$G(PSGPDRG),12,"I")
Q
;
FF ; up-arrow to another field
D ENFF^PSGOEM I Y>0,Y'=39,Y'=8,Y'=10,Y'=25 S Y=Y_"^PSGOE8"_$S("^109^13^3^7^26^"[("^"_Y_"^"):"",1:2) S:Y=2 FB=PSGF2_"^PSGOE81"
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(PSGS0XT)'="O"),($G(PSGST)'="OC"),'$$PRNOK^PSGS0(PSGSCH) I X="" D EN^DDIOL("This order requires at least one administration time.") K X Q ;No times
N H,I,MAX
I PSGSCH]"" I $D(^PS(51.1,"AC","PSJ",PSGSCH)) S H=+$O(^PS(51.1,"AC","PSJ",PSGSCH,0)) S I=$P($G(^PS(51.1,H,0)),"^",3)
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.") K X Q ;Too few times ;P454 Add Kill/Quit
Q
;
DOSE ;Make certain at least one dose is given.
N INFO,X
S Z="",INFO=$S($G(PSGNESD):PSGNESD,1:$G(PSGSD))_U_($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=39
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 S:+$$GET1^DIQ(53.1,+$G(PSGORD),137) (PSGDUR,PSGRMV,PSGRMVT)="@" 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 PSGMRV 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:$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(PSGAT):PSGAT,$G(PSGS0Y):PSGS0Y,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
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 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 G A39
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[HPSGOE81 16331 printed Dec 13, 2024@02:01:59 Page 2
PSGOE81 ;BIR/CML - NON-VERIFIED ORDER EDIT (CONT.) ;May 03, 2023@17:45
+1 ;;5.0;INPATIENT MEDICATIONS;**26,50,64,58,82,110,111,136,113,267,315,334,373,366,327,441,451,454**;16 DEC 97;Build 6
+2 ;Per VHA Directive 2004-038, this routine should not be modified.
+3 ;Reference to ^PS(50.7 in ICR #2180
+4 ;Reference to ^PS(51.1 in ICR #2177
+5 ;
39 ; admin times
+1 NEW PSGDOA
+2 SET MSG=0
SET PSGF2=39
if PSGOEEF(PSGF2)
SET BACK="39^PSGOE81"
SET ORIG=$GET(PSGAT)
SET PSGDOA=$GET(PSGDUR)
A39 ;*315 next 2 lines
+1 IF (PSGST="P")!$$PRNOK^PSGS0($GET(PSGSCH))
GOTO DONE
+2 IF $$ODD^PSGS0(PSGS0XT)
DO PSGDUR
GOTO DONE
+3 ;*315
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
+4 ;*315 If admin time default was taken then don't highlight admin time.
IF X=""
if (($GET(PSGS0XT)="D")&'$GET(PSGS0Y))
SET PSGOEE=0
if $GET(PSGAT)
SET X=PSGAT
SET PSGNOHI=1
+5 IF $EXTRACT(X)="^"
DO ENFF^PSGOE82
if Y>0
GOTO @Y
GOTO A39
+6 IF X=" "!(X?1."?")
DO ENHLP^PSGOEM(53.1,39)
GOTO A39
+7 IF PSGS0XT="D"&'$GET(X)
IF ((",P,R,")'[(","_$GET(PSGST)_","))
Begin DoDot:1
+8 WRITE $CHAR(7)," ??"
SET X="?"
WRITE !,"This is a 'DAY OF THE WEEK' schedule and MUST have admin times."
DO ENHLP^PSGOEM(53.1,39)
End DoDot:1
GOTO A39
+9 IF X="@"
DO DEL
if %'=1
GOTO A39
SET PSGAT=""
SET X=""
+10 ;*315
IF $GET(PSGS0XT)
IF '$$ODD^PSGS0(PSGS0XT)
IF $GET(PSGS0XT)'="P"
IF $GET(PSGS0XT)'="OC"
IF '$$PRNOK^PSGS0(PSGSCH)
IF ($GET(PSGST)'="O")
DO TIMES
if '$DATA(X)
GOTO A39
DO PSGDUR
if '$DATA(X)
GOTO A39
if $GET(X)="^"
GOTO DONE
+11 IF (($GET(PSGST)="O")!($GET(PSGST)="OC"))
IF X=""
Begin DoDot:1
+12 SET (PSGS0Y,PSGAT)=X
+13 IF (($GET(PSGRF))&($GET(PSGST)="O"))
NEW PSGRO
SET (PSGRO,PSGOEEF(25))=1
SET PSGOEEF(39)=1
DO 25
+14 QUIT
End DoDot:1
GOTO DONE
+15 DO ENCHK^PSGS0
IF '$DATA(X)
WRITE $CHAR(7)
GOTO A39
+16 SET PSGOAT=PSGAT
+17 SET (PSGS0Y,PSGAT)=X
GOTO DONE
+18 ;
8 ; special instructions
+1 SET MSG=0
SET PSGF2=8
if PSGOEEF(PSGF2)
SET BACK="8^PSGOE81"
A8 ; special instructions
+1 SET PSGSI=$$EDITSI^PSJBCMA5($GET(PSGP),$GET(PSGORD))
IF $GET(PSGP)
IF $GET(PSGORD)
IF '$$DIFFSI^PSJBCMA5(PSGP,PSGORD)
SET PSGOEE=0
GOTO DONE
+2 SET PSGSI=$SELECT((PSGSI>0&(PSGSI<4)):$GET(^PS(53.45,+PSJSYSP,5,1,0))_" "_$GET(^PS(53.45,+PSJSYSP,5,2,0)),PSGSI>3:"Instructions too long. See Order View or BCMA for full text",1:"")
+3 if PSGSI=" "
SET PSGSI=""
IF PSGSI]""
SET PSGSI=$$ENBCMA^PSJUTL("U")
GOTO DONE
+4 QUIT
+5 ;
10 ; start date/time edit
+1 SET MSG=0
SET PSGF2=10
if PSGOEEF(PSGF2)
SET BACK="10^PSGOE81"
A10 ; start date/time edit
+1 ; This variable indicates a Manual Edit of the Start/Date Time.
SET PSGSDEDT=1
+2 KILL PSGSDX
NEW DUR,DURMIN,TMPFD
+3 IF $GET(PSGORD)["P"
IF $GET(PSGP)
IF $$LASTREN^PSJLMPRI(PSGP,PSGORD)
Begin DoDot:1
+4 WRITE !?5,"Start Date may not be edited at this point. "
DO PAUSE^VALM1
End DoDot:1
QUIT
+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 IF X=""
IF PSGSD
WRITE " "_$PIECE(PSGSDN,"^")
GOTO DONE
+7 IF X="P"
DO ENPREV^PSGDL
if '$DATA(X)
WRITE $CHAR(7)
if '$DATA(X)
GOTO A10
Begin DoDot:1
+8 SET PSGSD=+X
SET PSGSDN=$$ENDD^PSGMI(PSGSD)_"^"_$$ENDTC^PSGMI(PSGSD)
+9 WRITE " ",$PIECE(PSGSDN,"^")
End DoDot:1
GOTO DONE
+10 IF X="@"!(X?1."?")
if X="@"
WRITE $CHAR(7)," (Required)"
if X="@"
SET X="?"
DO ENHLP^PSGOEM(53.1,10)
+11 IF $EXTRACT(X)="^"
DO ENFF^PSGOE82
if Y>0
GOTO @Y
GOTO A10
+12 NEW TMPX
SET TMPX=X
SET X1=+$GET(PSGLI)
SET X2=-7
DO C^%DTC
KILL %DT
SET %DT="ERTX"
SET %DT(0)=X
SET X=TMPX
+13 DO ^%DT
KILL %DT
IF Y'>0
DO ENHLP^PSGOEM(53.1,10)
GOTO A10
+14 IF PSGFD<Y
Begin DoDot:1
+15 WRITE $CHAR(7),!?5,"*** THE START DATE CANNOT BE AFTER THE STOP DATE! ***",!
SET MSG=1
End DoDot:1
GOTO A10
+16 ; RBD PSJ*5*373 Soft stop when Start Date more than 7 days after Order's LOGIN DATE
+17 SET X1=+$GET(PSGLI)
SET X2=+7
DO C^%DTC
+18 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
+19 NEW X1,X2,DIFF,PSGEMRG,PSGBACK,CLOZFLG
SET X1=PSGFD
SET X2=Y
DO ^%DTC
SET DIFF=X
+20 IF $GET(PSGORD)
SET CLOZFLG=$$ISCLOZ^PSJCLOZ(+PSGORD)
IF 1
+21 IF '$TEST
SET CLOZFLG=$$ISCLOZ^PSJCLOZ(,,,,PSGDRG)
+22 ;S PSGEMRG=$S($$GET1^DIQ(55,DFN,53)?2U5N:1,1:0),PSGBACK=0
+23 SET PSGEMRG=0
SET PSGBACK=0
+24 IF ($$GET1^DIQ(55,DFN,53)?2U5N)
IF ($PIECE($GET(^XTMP("PSJ4D-"_DFN,0)),"^",1))>$$HTFM^XLFDT($HOROLOG,1)
SET PSGEMRG=1
+25 ; Emergency Registration period not to exceed 4 days
IF PSGEMRG
IF $GET(CLOZFLG)
IF DIFF>4
Begin DoDot:1
+26 WRITE !!?13,"*** EMERGENCY SUPPLY NOT TO EXCEED 4 DAYS! ***",!
End DoDot:1
GOTO A10
+27 IF 'PSGEMRG
IF $GET(CLOZFLG)
Begin DoDot:1
+28 NEW CLOZPAT,X2
DO CLOZPAT^PSJCLOZ
+29 SET X2=$SELECT($PIECE($GET(ANQDATA),"^",3)=9:4,$GET(CLOZPAT)=2:28,$GET(CLOZPAT)=1:14,$GET(CLOZPAT)=0:7,1:90)
+30 IF DIFF>X2
WRITE !!,"*** SUPPLY PERIOD NOT TO EXCEED "_X2_" DAYS! ***",!
SET PSGBACK=1
End DoDot:1
if PSGBACK
GOTO A10
+31 ;S (PSGSDX,PSGSD,PSGNESD)=+Y,PSGSDN=$$ENDD^PSGMI(PSGSD)_"^"_$$ENDTC^PSGMI(PSGSD) ;373
+32 ;373
SET (PSGSDX,PSGSD,PSGNESD)=+Y
SET PSGSDN=$$ENDD^PSGMI(PSGSD)_"^"_$$ENDTC2^PSGMI(PSGSD)
+33 IF $GET(PSGORD)["P"
IF $GET(PSGP)
SET DUR=$$GETDUR^PSJLIVMD(PSGP,+PSGORD,"P",1)
IF DUR]""
SET DURMIN=$$DURMIN^PSJLIVMD(DUR)
IF DURMIN
Begin DoDot:1
+34 ;S TMPFD=$$FMADD^XLFDT(PSGSD,,,DURMIN) K:(TMPFD<PSGSD) TMPFD I $G(TMPFD) S PSGFD=TMPFD,PSGFDN=$$ENDD^PSGMI(PSGFD)_"^"_$$ENDTC^PSGMI(PSGFD) ;373
+35 ;373
SET TMPFD=$$FMADD^XLFDT(PSGSD,,,DURMIN)
if (TMPFD<PSGSD)
KILL TMPFD
IF $GET(TMPFD)
SET PSGFD=TMPFD
SET PSGFDN=$$ENDD^PSGMI(PSGFD)_"^"_$$ENDTC2^PSGMI(PSGFD)
End DoDot:1
+36 GOTO DONE
+37 ;
25 ; stop date
+1 SET MSG=0
SET PSGF2=25
if PSGOEEF(PSGF2)
SET BACK="25^PSGOE81"
A25 ;
+1 ;; START NCC REMEDIATION RJS*327
+2 NEW CLOZFLG,CLOZPAT
+3 IF $GET(PSGORD)
SET CLOZFLG=$$ISCLOZ^PSJCLOZ(+PSGORD)
IF 1
+4 IF '$TEST
SET CLOZFLG=$$ISCLOZ^PSJCLOZ(,,,,PSGDRG)
+5 IF $GET(CLOZFLG)
NEW CLOZPAT,PSGDRG
SET PSGDRG=$PIECE(CLOZFLG,U,2)
DO CLOZPAT^PSJCLOZ
+6 IF $GET(CLOZFLG)
NEW PSGOLDED,PSGFDNOLD
SET PSGOLDED=PSGFD
SET PSGFDNOLD=PSGFDN
+7 ;; END NCC REMEDIATION RJS*327
+8 ;*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")
+9 IF $$FIND1^DIC(51.1,,"X",$GET(PSGSCH))
Begin DoDot:1
+10 ;Handle "Fill on Request"
if PSGTMPST=($GET(PSGST)="R")
SET PSGST=$$GET1^DIQ(51.1,$$FIND1^DIC(51.1,,"X",$GET(PSGSCH)),5,"I")
+11 QUIT
End DoDot:1
+12 IF $GET(PSGTMPST)="O"
IF +$GET(PSGRF)
SET (PSGFDN,PSGFD)=""
Begin DoDot:1
+13 IF +$GET(PSGRF)=1
SET MSG(1)="This NOW order has an Orderable Item for which a removal is required"
Begin DoDot:2
+14 SET MSG(2)=" at the next administration."
+15 SET MSG(3)="The Stop DATE/TIME entered should be the next anticipated administration for the medication."
SET MSG(3,"F")="!"
+16 QUIT
End DoDot:2
+17 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
+18 SET MSG(2)="prior to the next administration."
SET MSG(2,"F")="!"
+19 SET MSG(3)="If Early Removal is needed, enter Removal Time in Stop DATE/TIME field."
SET MSG(3,"F")="!"
+20 SET MSG(4)="If an Early Removal is not required, the Stop DATE/TIME entered"
+21 SET MSG(5)="should be the next anticipated administration for the medication."
SET MSG(5,"F")="!"
+22 QUIT
End DoDot:2
+23 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
+24 SET MSG(2)=" to the next administration."
SET MSG(2,"F")="!"
+25 SET MSG(3)="Please Enter the Stop DATE/TIME to reflect the Removal Time for this medication."
SET MSG(3,"F")="!"
+26 QUIT
End DoDot:2
+27 DO EN^DDIOL(.MSG)
+28 QUIT
End DoDot:1
+29 KILL PSGFDX
NEW PSGEMRG
+30 IF $DATA(PSGFDORG)
SET PSGFDN=PSGFDORG
SET PSGFD=PSGFDORX
+31 IF '$DATA(PSGFDORG)
NEW PSGFDORG,PSGFDORX
SET PSGFDORG=PSGFDN
SET PSGFDORX=PSGFD
+32 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
+33 IF X=""
IF PSGFD
SET X=$PIECE(PSGFDN,"^")
+34 IF $EXTRACT(X)="^"
DO ENFF^PSGOE82
if Y>0
GOTO @Y
GOTO A25
+35 IF X="@"!(X?1."?")
if X="@"
WRITE $CHAR(7)," (Required)"
if X="@"
SET X="?"
DO ENHLP^PSGOEM(53.1,25)
+36 IF X=+X
IF (X>0)
IF (X'>2000000)
if '$$ENDL^PSGDL(PSGSCH,X)
GOTO A25
KILL PSGDLS
SET PSGDL=X
WRITE " ...dose limit..."
DO ENE^PSGDL
+37 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 A25
+38 ; RBD PSJ*5*373 Hard stop when Stop Date more than 367 days after Start Date
+39 SET X1=+Y
SET X2=PSGSD
DO ^%DTC
+40 IF X>367
WRITE $CHAR(7),!!?13,"*** STOP DATE cannot be more than 367 days from START DATE ***",!
GOTO A25
+41 ;S (PSGFDX,PSGFD,PSGNEFD)=+Y,PSGFDN=$$ENDD^PSGMI(PSGFD)_"^"_$$ENDTC^PSGMI(PSGFD) ;373
+42 ;373
SET (PSGFDX,PSGFD,PSGNEFD)=+Y
SET PSGFDN=$$ENDD^PSGMI(PSGFD)_"^"_$$ENDTC2^PSGMI(PSGFD)
+43 ;/RJS Begin changes for emergency registration of clozapine patient Set end date to start date + 4 days at midnight.
+44 NEW PSGGTF
SET PSGGTF=0
+45 ;def 418867 RJS*327
IF ($$GET1^DIQ(55,DFN,53)?1U6N)!($$GET1^DIQ(55,DFN,53)?2U5N)
IF $GET(CLOZFLG)
Begin DoDot:1
+46 IF $PIECE($GET(^XTMP("PSJ4D-"_DFN,0)),"^",1)>$$HTFM^XLFDT($HOROLOG,1)
Begin DoDot:2
+47 NEW X1,X2
SET X1=+Y
SET X2=PSGSD
DO ^%DTC
+48 SET PSGEMRG=1
if X'>4
QUIT
+49 IF X>4
Begin DoDot:3
+50 WRITE !!?13,"*** EMERGENCY SUPPLY NOT TO EXCEED 4 DAYS! ***",!
+51 SET $PIECE(PSGFD,".",2)=2359
SET X1=PSGSD
SET X2=4
DO C^%DTC
SET PSGFD=X
+52 SET $PIECE(PSGFDN,"^",1)=$$ENDD^PSGMI(PSGFD)
SET $PIECE(PSGFDN,"^",2)=PSGFD
+53 SET PSGGTF=1
End DoDot:3
End DoDot:2
End DoDot:1
if PSGGTF
GOTO A25
+54 ;/RJS End changes for emergency registration of clozapine patient Set end date to start date + 4 days at midnight.
+55 ;/RJS Begin verify that stop date does not exceed maximum days supply based on lab frequency
A255 IF '$GET(PSGEMRG)
IF $GET(CLOZFLG)
NEW PSGBACK
Begin DoDot:1
+1 NEW PSGCFLG
SET PSGCFLG=1
+2 NEW X,X1,X2
+3 SET X2=$SELECT($PIECE($GET(ANQDATA),"^",3)=9:4,$GET(CLOZPAT)=2:28,$GET(CLOZPAT)=1:14,$GET(CLOZPAT)=0:7,1:90)
+4 SET X1=+Y
Begin DoDot:2
+5 NEW X2
SET X2=PSGSD
DO ^%DTC
SET X1=PSGSD
End DoDot:2
+6 IF X>X2
WRITE !!,"*** STOP DATE/TIME NOT TO EXCEED "_X2_" DAYS! ***",!
SET PSGBACK=1
QUIT
End DoDot:1
if $GET(PSGBACK)
GOTO A25
+7 if ($GET(PSGEMRG))
KILL PSGEMRG
+8 ;/RJS End verify that stop date does not exceed maximum days supply based on lab frequency.
+9 ;; END NCC REMEDIATION RJS*327
+10 SET (PSGFDX,PSGFD,PSGNEFD)=+Y
SET PSGFDN=$$ENDD^PSGMI(PSGFD)_"^"_$$ENDTC^PSGMI(PSGFD)
W25 ;
+1 NEW Z,MSG
+2 DO DOSE
IF $GET(Z)]""
IF Z>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 A25
+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 DO EFDNV^PSJUTL
+3 ;P451
IF PSGOEE
if '$GET(PSGOEEF(PSGF2))
GOTO @BACK
SET PSGOEE=PSGOEEF(PSGF2)
+4 ;*315
if +$GET(PSGDUR)
DO VERTIMES
+5 KILL ORIG,PSGOLDED,PSGNEFDOLD,PSGFDNOLD
+6 if '+$GET(PSGRF)
SET PSGRF=+$$GET1^DIQ(50.7,$GET(PSGPDRG),12,"I")
+7 QUIT
+8 ;
FF ; up-arrow to another field
+1 DO ENFF^PSGOEM
IF Y>0
IF Y'=39
IF Y'=8
IF Y'=10
IF Y'=25
SET Y=Y_"^PSGOE8"_$SELECT("^109^13^3^7^26^"[("^"_Y_"^"):"",1:2)
if Y=2
SET FB=PSGF2_"^PSGOE81"
+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(PSGS0XT)'="O")
IF ($GET(PSGST)'="OC")
IF '$$PRNOK^PSGS0(PSGSCH)
IF X=""
DO EN^DDIOL("This order requires at least one administration time.")
KILL X
QUIT
+2 NEW H,I,MAX
+3 IF PSGSCH]""
IF $DATA(^PS(51.1,"AC","PSJ",PSGSCH))
SET H=+$ORDER(^PS(51.1,"AC","PSJ",PSGSCH,0))
SET I=$PIECE($GET(^PS(51.1,H,0)),"^",3)
+4 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
+5 ;Done validating One Time
IF $GET(PSGST)="O"
QUIT
+6 ;No frequency - can not check frequency related items
IF +$GET(I)=0
QUIT
+7 ;P454 messages to the user
+8 IF $DATA(X)
Begin DoDot:1
+9 IF (X'["-")
Begin DoDot:2
+10 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
+11 IF '$TEST
Begin DoDot:2
+12 NEW LEN,TOT,CHK
SET LEN=$LENGTH($PIECE(X,"-"))
+13 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
+14 SET MAX=1440/I
+15 IF MAX<1
IF $LENGTH(X,"-")>1
DO EN^DDIOL("This order requires one administration time.")
KILL X
QUIT
+16 ;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
+17 ;Too few times ;P454 Add Kill/Quit
IF MAX'<1
IF $LENGTH(X,"-")<MAX
DO EN^DDIOL("The number of admin times entered is fewer than indicated by the schedule.")
KILL X
QUIT
+18 QUIT
+19 ;
DOSE ;Make certain at least one dose is given.
+1 NEW INFO,X
+2 SET Z=""
SET INFO=$SELECT($GET(PSGNESD):PSGNESD,1:$GET(PSGSD))_U_($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 ;
+8 ;*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=39
+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,PSGDUR,PSGRMVT)=""
SET PSGRMV=-1
if +$$GET1^DIQ(53.1,+$GET(PSGORD),137)
SET (PSGDUR,PSGRMV,PSGRMVT)="@"
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
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 PSGMRV
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(PSGAT):PSGAT,$GET(PSGS0Y):PSGS0Y,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
+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 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
GOTO A39
+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 ;
