PSGOE41 ;BIR/CML - REGULAR ORDER ENTRY (CONT.) ;Dec 15, 2021@09:56:53
;;5.0;INPATIENT MEDICATIONS;**50,63,64,69,58,111,136,113,267,315,334,373,366,327,319,399,454**;16 DEC 97;Build 6
;Per VHA Directive 2004-038, this routine should not be modified.
; Reference to ^DICN via DBIA 10009
; Reference to %DT via DBIA 10003
; Reference to %DTC via DBIA 10000
; Reference to ^PS(51.1 via DBIA 2177
; Reference to ^PS(50.7 via DBIA# 2180
; Reference to ^YSCLTST2 via DBIA# 4556
;
39 ; admin times
G:$P(PSGNEDFD,"^",3)="P"!($P(PSGNEDFD,"^",3)="OC") 8
I $$ODD^PSGS0(PSGS0XT) D PSGDUR G 8
W !,"ADMIN TIMES: "_$S(PSGS0Y:PSGS0Y_"// ",1:"") R X:DTIME I X="^"!'$T W:'$T $C(7) S PSGOROE1=1,PSGDUR="" G DONE
I X="",PSGS0Y]"" S PSGNOHI=1,X=PSGS0Y ;*315 If admin time default was taken then don't highlight admin time.
I X="",$G(PSGS0XT)="D" I $L(PSGSCH,"@")=2,$P(PSGSCH,"@",2) S (PSGAT,PSGS0Y)=$P(PSGSCH,"@",2) G 8
I X?1."?" D ENHLP^PSGOEM(53.1,39) G 39
I X="@" D DEL G:%'=1 39 S (PSGFOK(39),PSGS0Y)="" G 39
S PSGF2=39 I $E(X)="^" D FF G:Y>0 @Y G 39
I (PSGS0XT="D")&('$G(X)!(X["@"&($P($G(X),"@",2)))) I ((",P,R,")'[(","_$G(PSGST)_",")) D G 39
.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)
.Q
I $G(PSGS0XT)'="D",$G(PSGS0XT)'="P",$G(PSGS0XT)'="OC" D TIMES G:'$D(X) 39 D PSGDUR G:'$D(X) 39 G:$G(X)="^" DONE ;*315
I $G(PSGS0XT)="O",X="" S (PSGAT,PSGS0Y)=X,PSGFOK(39)="" G 8
D ENCHK^PSGS0 I '$D(X) W $C(7)," ??" G 39
S (PSGAT,PSGS0Y)=X,PSGFOK(39)=""
;
8 ; special instructions
S PSGSI=$$EDITSI^PSJBCMA5($G(PSGP),$G(PSGORD))
S PSGF2=8 I $E(X)="^" D FF G:Y>0 @Y G 8
I X="@",PSGSI="" W $C(7)," ??" S X="?" D ENHLP^PSGOEM(53.1,8) G 8
I X="@" D DEL G:%'=1 8 S (PSGFOK(8),PSGSI)="" G:'$G(PSGOE3) 10
I X?1."?" D ENHLP^PSGOEM(53.1,8) G 8
S PSGSI=$S((PSGSI>0&(PSGSI<3)):$G(^PS(53.45,+PSJSYSP,5,1,0))_" "_$G(^PS(53.45,+PSJSYSP,5,2,0)),PSGSI>2:"Instructions too long. See Order View or BCMA for full text",1:"")
S:PSGSI=" " PSGSI="" I PSGSI]"" S PSGSI=$$ENBCMA^PSJUTL("U"),PSGFOK(8)=""
Q:$G(PSGOE3)
132 ;*399-IND
I $G(PSGOEE) I $D(Y) N BKY S BKY=Y
D IND^PSGOE42(PSGPDRG) G:$G(PSGOROE1) DONE I $G(PSGOEE) S:$D(BKY) Y=BKY Q
I X?1"^".E D FF G:Y>0 @Y G 132
10 ; start date/time
I $P($G(PSJCLAPP),"^",2)'="",$G(PSGNESD)="" S PSGNESD=$P(PSJCLAPP,"^",2),PSGNESDO=$$ENDD^PSGMI(PSGNESD) S PSGSD=PSGNESDO G A10 ;P319 set StartDateTime to ApptDateTime
D ^PSGNE3
S:'$D(PSGNESDO) PSGNESDO=$$ENDD^PSGMI(PSGNESD) S PSGSD=PSGNESDO
A10 ; start date/time edit
S PSGSDEDT=1 ; This variable indicates a Manual Edit of the Start/Date Time.
W !,"START DATE/TIME: "_PSGSD_"// " R X:DTIME I X="^"!'$T W:'$T $C(7) S PSGOROE1=1 G DONE
I X="",PSGNESD W " "_PSGSD G O25
I X="P" D ENPREV^PSGDL W:'$D(X) $C(7) G:'$D(X) A10 S PSGNESD=+X,PSGSD=$$ENDD^PSGMI(+X) W " ",PSGSD G O25
S PSGF2=10 I X="@"!(X?1."?") W:X="@" $C(7)," (Required)" S:X="@" X="?" D ENHLP^PSGOEM(53.1,10)
I $E(X)="^" D FF 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(53.1,10) G A10
; RBD PSJ*5*373 Soft stop when Start Date more than 7 days after Order's LOGIN DATE
S X1=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
S PSGNESD=+Y,PSGSD=$$ENDD^PSGMI(+Y),(PSGNEFD,PSGFD)=""
;
O25 ;
S PSGFOK(10)="" I $P(PSGNEDFD,"^",3)="O" S PSGNEFD=$$ENOSD^PSJDCU(PSJSYSW0,PSGNESD,PSGP) I PSGNEFD]"" S PSGFD=$$ENDD^PSGMI(PSGNEFD)
;
25 ; stop date
Q:$G(PSGOE3)
I 'PSGNEFD D ENFD^PSGNE3(PSGDT) S PSGFD=PSGNEFDO
; HEC/hrubovcak PSJ*5*327 begin
N CLOZFLG,CLOZPAT,PSGCFLG,PSGEMRG,PSGTDTD,WRDPDYS
S CLOZFLG=$$ISCLOZ^PSJCLOZ(,,,,PSGDRG) I CLOZFLG D
. N WRDPDYS S WRDPDYS=U ; ward parameter days
. ; if one-time default to INPATIENT WARD PARAMETERS value for stop date
. I $G(PSGST)="O",$G(PSJPWD) D
.. N IEN S IEN=+$O(^PS(59.6,"B",PSJPWD,0)) Q:'IEN ; get IEN in file #59.6
.. S WRDPDYS=$P($G(^PS(59.6,IEN,0)),U,28) ; (#3) DAYS UNTIL STOP FOR ONE-TIME [28N]
. I WRDPDYS S PSGNEFD=$$FMADD^XLFDT(PSGNESD,WRDPDYS),PSGFD=$$ENDD^PSGMI(PSGNEFD) Q
. S PSGNEFD=X,PSGFD=$$ENDD^PSGMI(PSGNEFD)
. S PSGCFLG=1,PSGOVRD=$$OVERRIDE^YSCLTST2(PSGP) ; PSGCFLG prevents message in YSCLTST2
. S PSGCFLG=0
. I $D(ANQDATA),$P(ANQDATA,"^",3)=9 D
.. N X,X1,X2,X3 S X3=$G(PSGNESD),X1=X3,X2=4 D C^%DTC S PSGNEFD=X,PSGFD=$$ENDD^PSGMI(PSGNEFD)
.. S PSGOLDED=PSGFD,PSGNEFDOLD=PSGNEFD,PSGTDTD=1
. I $$GET1^DIQ(55,PSGP,53)?1U6N D ; stop date for temporary clozapine registration
.. N X S X=$$FMADD^XLFDT(PSGNESD,4),PSGNEFD=X,PSGFD=$$ENDD^PSGMI(PSGNEFD)
.. S PSGOLDED=PSGFD,PSGNEFDOLD=PSGNEFD,PSGEMRG=1
. D CLOZPAT^PSJCLOZ
. I $D(CLOZPAT),'$G(PSGEMRG),'$G(PSGTDTD) D ; stop date
.. N X,X1,X2
.. S X1=PSGNESD,X2=$S($G(CLOZPAT)=2:28,$G(CLOZPAT)=1:14,$G(CLOZPAT)=0:7,1:90)
.. D C^%DTC S PSGNEFD=X,PSGFD=$$ENDD^PSGMI(PSGNEFD)
.. S PSGCFLG=0,PSGOLDED=PSGFD,PSGNEFDOLD=PSGNEFD
; PSJ*5*327 end
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 (PSGNEFD,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)
;
A25 ;
W !,"STOP DATE/TIME: "_$S(PSGFD]"":PSGFD_"// ",1:"") R X:DTIME I X="^"!'$T W:'$T $C(7) S PSGOROE1=1 G DONE
I X="",PSGNEFD W " "_PSGFD S PSGFOK(25)="" G W25
S PSGF2=25 I $E(X)="^" D FF 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 EN1^PSGDL
K %DT S %DT="ERTX",%DT(0)=PSGNESD D ^%DT K %DT I Y'>0 W $C(7),!!?13,"*** WARNING! INVALID STOP DATE OR PRIOR TO START DATE! ***",! G A25
; re-ask if Stop Date more than 367 days after Start Date
S X1=+Y,X2=PSGNESD D ^%DTC
I X>367 W $C(7),!!?13,"*** STOP DATE cannot be more than 367 days from START DATE ***",! G A25
;
I CLOZFLG D I $G(PSGCFLG) S PSGCFLG=0 G A25
. N X2 S X2=$S($G(CLOZPAT)=2:28,$G(CLOZPAT)=1:14,$G(CLOZPAT)=0:7,1:90)
. I $G(PSGEMRG)!$G(PSGTDTD) S X2=4
. I $P(Y,".")>$P(PSGNEFD,".") D S PSGCFLG=1 Q
.. W !!,"*** STOP DATE/TIME NOT TO EXCEED "_X2_" DAYS! ***",!
. S (PSGFDX,PSGFD,PSGNEFD)=+Y,PSGFDN=$$ENDD^PSGMI(PSGFD)_"^"_$$ENDTC^PSGMI(PSGFD)
;
A255 ;
I $G(PSGCFLG) S PSGCFLG=0 G A25
S PSGNEFD=+Y,PSGFD=$$ENDD^PSGMI(+Y),PSGFOK(25)=""
K PSGEMRG,PSGTDTD
;
W25 ;
N Z
D DOSE I $G(Z)]"",Z>PSGNEFD D G A25
.W !,"There must be an admin time that falls between the Start Date/Time"
.W !,"and the Stop Date/Time."
I PSGNEFD<PSGDT W $C(7),!!?13,"*** WARNING! THE STOP DATE ENTERED IS IN THE PAST! ***",!
D EFDNEW^PSJUTL ;Display Expected First Dose;BHW;PSJ*5*136
I $G(PSGDUR),'$G(PSGOROE1) D VERTIMES ;*315
NEXT ;
S:'+$G(PSGRF) PSGRF=+$$GET1^DIQ(50.7,$G(PSGPDRG),12,"I")
G:'$D(PSGAARR) 1^PSGOE42
;
DONE ;
I PSGOROE1 K Y W $C(7)," ...order not entered..."
K F,F0,F1,PSGF2,F3,PSG,SDT,PSGEMRG,PSGCLOZ Q
;
FF ; up-arrow to another field
D ENFF^PSGOEM
I Y=132 S Y="132^PSGOE41" Q
I Y>0,Y'=39,Y'=8,Y'=10,Y'=25 S Y=Y_"^PSGOE4"_$S("^109^13^3^7^26^"[("^"_Y_"^"):"",1:2) S:$P(Y,U)=2 FB=PSGF2_"^PSGOE41"
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",X="" W !,"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 W !,"This is a One Time Order - only one admin 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 D Q
. I $L(X,"-")'=1 W !,"This order requires one admin 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 W !,"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.
Q:$G(PSGST)="OC"!($G(PSGST)="P")
N INFO,X
S Z="",INFO=($G(PSGNESD))_U_($G(PSGNEFD))_U_($G(PSGSCH))_U_($G(PSGST))_U_($G(PSGDRG))_U_($G(PSGS0Y))
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 PSGOROE1=1,X="^" K PSGFOK(39) Q
I RP="",$G(PSGS0XT)="D" I $L(PSGSCH,"@")=2,$P(PSGSCH,"@",2) S (PSGAT,PSGRMV)=$P(PSGSCH,"@",2) G 8
I RP="@",PSGRF'=3 D DEL G:%'=1 PSGDUR S (PSGFOK(39),PSGS0Y,PSGDUR,PSGRMVT)="",PSGRMV=-1 S:$$GET1^DIQ(53.1,+$G(PSGORD),137) (PSGDUR,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 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:$G(PSGDERR)=1
I PSGRF=3,(+RP<1) W !,"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:""),PSGAT=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:'$G(PSGOE3)!'+$G(PSGDUR)
;
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)="",$G(PSGS0Y)="" 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 ;
N Y
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 39
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[HPSGOE41 14840 printed Dec 13, 2024@02:01:53 Page 2
PSGOE41 ;BIR/CML - REGULAR ORDER ENTRY (CONT.) ;Dec 15, 2021@09:56:53
+1 ;;5.0;INPATIENT MEDICATIONS;**50,63,64,69,58,111,136,113,267,315,334,373,366,327,319,399,454**;16 DEC 97;Build 6
+2 ;Per VHA Directive 2004-038, this routine should not be modified.
+3 ; Reference to ^DICN via DBIA 10009
+4 ; Reference to %DT via DBIA 10003
+5 ; Reference to %DTC via DBIA 10000
+6 ; Reference to ^PS(51.1 via DBIA 2177
+7 ; Reference to ^PS(50.7 via DBIA# 2180
+8 ; Reference to ^YSCLTST2 via DBIA# 4556
+9 ;
39 ; admin times
+1 if $PIECE(PSGNEDFD,"^",3)="P"!($PIECE(PSGNEDFD,"^",3)="OC")
GOTO 8
+2 IF $$ODD^PSGS0(PSGS0XT)
DO PSGDUR
GOTO 8
+3 WRITE !,"ADMIN TIMES: "_$SELECT(PSGS0Y:PSGS0Y_"// ",1:"")
READ X:DTIME
IF X="^"!'$TEST
if '$TEST
WRITE $CHAR(7)
SET PSGOROE1=1
SET PSGDUR=""
GOTO DONE
+4 ;*315 If admin time default was taken then don't highlight admin time.
IF X=""
IF PSGS0Y]""
SET PSGNOHI=1
SET X=PSGS0Y
+5 IF X=""
IF $GET(PSGS0XT)="D"
IF $LENGTH(PSGSCH,"@")=2
IF $PIECE(PSGSCH,"@",2)
SET (PSGAT,PSGS0Y)=$PIECE(PSGSCH,"@",2)
GOTO 8
+6 IF X?1."?"
DO ENHLP^PSGOEM(53.1,39)
GOTO 39
+7 IF X="@"
DO DEL
if %'=1
GOTO 39
SET (PSGFOK(39),PSGS0Y)=""
GOTO 39
+8 SET PSGF2=39
IF $EXTRACT(X)="^"
DO FF
if Y>0
GOTO @Y
GOTO 39
+9 IF (PSGS0XT="D")&('$GET(X)!(X["@"&($PIECE($GET(X),"@",2))))
IF ((",P,R,")'[(","_$GET(PSGST)_","))
Begin DoDot:1
+10 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)
+11 QUIT
End DoDot:1
GOTO 39
+12 ;*315
IF $GET(PSGS0XT)'="D"
IF $GET(PSGS0XT)'="P"
IF $GET(PSGS0XT)'="OC"
DO TIMES
if '$DATA(X)
GOTO 39
DO PSGDUR
if '$DATA(X)
GOTO 39
if $GET(X)="^"
GOTO DONE
+13 IF $GET(PSGS0XT)="O"
IF X=""
SET (PSGAT,PSGS0Y)=X
SET PSGFOK(39)=""
GOTO 8
+14 DO ENCHK^PSGS0
IF '$DATA(X)
WRITE $CHAR(7)," ??"
GOTO 39
+15 SET (PSGAT,PSGS0Y)=X
SET PSGFOK(39)=""
+16 ;
8 ; special instructions
+1 SET PSGSI=$$EDITSI^PSJBCMA5($GET(PSGP),$GET(PSGORD))
+2 SET PSGF2=8
IF $EXTRACT(X)="^"
DO FF
if Y>0
GOTO @Y
GOTO 8
+3 IF X="@"
IF PSGSI=""
WRITE $CHAR(7)," ??"
SET X="?"
DO ENHLP^PSGOEM(53.1,8)
GOTO 8
+4 IF X="@"
DO DEL
if %'=1
GOTO 8
SET (PSGFOK(8),PSGSI)=""
if '$GET(PSGOE3)
GOTO 10
+5 IF X?1."?"
DO ENHLP^PSGOEM(53.1,8)
GOTO 8
+6 SET PSGSI=$SELECT((PSGSI>0&(PSGSI<3)):$GET(^PS(53.45,+PSJSYSP,5,1,0))_" "_$GET(^PS(53.45,+PSJSYSP,5,2,0)),PSGSI>2:"Instructions too long. See Order View or BCMA for full text",1:"")
+7 if PSGSI=" "
SET PSGSI=""
IF PSGSI]""
SET PSGSI=$$ENBCMA^PSJUTL("U")
SET PSGFOK(8)=""
+8 if $GET(PSGOE3)
QUIT
132 ;*399-IND
+1 IF $GET(PSGOEE)
IF $DATA(Y)
NEW BKY
SET BKY=Y
+2 DO IND^PSGOE42(PSGPDRG)
if $GET(PSGOROE1)
GOTO DONE
IF $GET(PSGOEE)
if $DATA(BKY)
SET Y=BKY
QUIT
+3 IF X?1"^".E
DO FF
if Y>0
GOTO @Y
GOTO 132
10 ; start date/time
+1 ;P319 set StartDateTime to ApptDateTime
IF $PIECE($GET(PSJCLAPP),"^",2)'=""
IF $GET(PSGNESD)=""
SET PSGNESD=$PIECE(PSJCLAPP,"^",2)
SET PSGNESDO=$$ENDD^PSGMI(PSGNESD)
SET PSGSD=PSGNESDO
GOTO A10
+2 DO ^PSGNE3
+3 if '$DATA(PSGNESDO)
SET PSGNESDO=$$ENDD^PSGMI(PSGNESD)
SET PSGSD=PSGNESDO
A10 ; start date/time edit
+1 ; This variable indicates a Manual Edit of the Start/Date Time.
SET PSGSDEDT=1
+2 WRITE !,"START DATE/TIME: "_PSGSD_"// "
READ X:DTIME
IF X="^"!'$TEST
if '$TEST
WRITE $CHAR(7)
SET PSGOROE1=1
GOTO DONE
+3 IF X=""
IF PSGNESD
WRITE " "_PSGSD
GOTO O25
+4 IF X="P"
DO ENPREV^PSGDL
if '$DATA(X)
WRITE $CHAR(7)
if '$DATA(X)
GOTO A10
SET PSGNESD=+X
SET PSGSD=$$ENDD^PSGMI(+X)
WRITE " ",PSGSD
GOTO O25
+5 SET PSGF2=10
IF X="@"!(X?1."?")
if X="@"
WRITE $CHAR(7)," (Required)"
if X="@"
SET X="?"
DO ENHLP^PSGOEM(53.1,10)
+6 IF $EXTRACT(X)="^"
DO FF
if Y>0
GOTO @Y
GOTO A10
+7 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(53.1,10)
GOTO A10
+8 ; RBD PSJ*5*373 Soft stop when Start Date more than 7 days after Order's LOGIN DATE
+9 SET X1=PSGDT
SET X2=+7
DO C^%DTC
+10 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
+11 SET PSGNESD=+Y
SET PSGSD=$$ENDD^PSGMI(+Y)
SET (PSGNEFD,PSGFD)=""
+12 ;
O25 ;
+1 SET PSGFOK(10)=""
IF $PIECE(PSGNEDFD,"^",3)="O"
SET PSGNEFD=$$ENOSD^PSJDCU(PSJSYSW0,PSGNESD,PSGP)
IF PSGNEFD]""
SET PSGFD=$$ENDD^PSGMI(PSGNEFD)
+2 ;
25 ; stop date
+1 if $GET(PSGOE3)
QUIT
+2 IF 'PSGNEFD
DO ENFD^PSGNE3(PSGDT)
SET PSGFD=PSGNEFDO
+3 ; HEC/hrubovcak PSJ*5*327 begin
+4 NEW CLOZFLG,CLOZPAT,PSGCFLG,PSGEMRG,PSGTDTD,WRDPDYS
+5 SET CLOZFLG=$$ISCLOZ^PSJCLOZ(,,,,PSGDRG)
IF CLOZFLG
Begin DoDot:1
+6 ; ward parameter days
NEW WRDPDYS
SET WRDPDYS=U
+7 ; if one-time default to INPATIENT WARD PARAMETERS value for stop date
+8 IF $GET(PSGST)="O"
IF $GET(PSJPWD)
Begin DoDot:2
+9 ; get IEN in file #59.6
NEW IEN
SET IEN=+$ORDER(^PS(59.6,"B",PSJPWD,0))
if 'IEN
QUIT
+10 ; (#3) DAYS UNTIL STOP FOR ONE-TIME [28N]
SET WRDPDYS=$PIECE($GET(^PS(59.6,IEN,0)),U,28)
End DoDot:2
+11 IF WRDPDYS
SET PSGNEFD=$$FMADD^XLFDT(PSGNESD,WRDPDYS)
SET PSGFD=$$ENDD^PSGMI(PSGNEFD)
QUIT
+12 SET PSGNEFD=X
SET PSGFD=$$ENDD^PSGMI(PSGNEFD)
+13 ; PSGCFLG prevents message in YSCLTST2
SET PSGCFLG=1
SET PSGOVRD=$$OVERRIDE^YSCLTST2(PSGP)
+14 SET PSGCFLG=0
+15 IF $DATA(ANQDATA)
IF $PIECE(ANQDATA,"^",3)=9
Begin DoDot:2
+16 NEW X,X1,X2,X3
SET X3=$GET(PSGNESD)
SET X1=X3
SET X2=4
DO C^%DTC
SET PSGNEFD=X
SET PSGFD=$$ENDD^PSGMI(PSGNEFD)
+17 SET PSGOLDED=PSGFD
SET PSGNEFDOLD=PSGNEFD
SET PSGTDTD=1
End DoDot:2
+18 ; stop date for temporary clozapine registration
IF $$GET1^DIQ(55,PSGP,53)?1U6N
Begin DoDot:2
+19 NEW X
SET X=$$FMADD^XLFDT(PSGNESD,4)
SET PSGNEFD=X
SET PSGFD=$$ENDD^PSGMI(PSGNEFD)
+20 SET PSGOLDED=PSGFD
SET PSGNEFDOLD=PSGNEFD
SET PSGEMRG=1
End DoDot:2
+21 DO CLOZPAT^PSJCLOZ
+22 ; stop date
IF $DATA(CLOZPAT)
IF '$GET(PSGEMRG)
IF '$GET(PSGTDTD)
Begin DoDot:2
+23 NEW X,X1,X2
+24 SET X1=PSGNESD
SET X2=$SELECT($GET(CLOZPAT)=2:28,$GET(CLOZPAT)=1:14,$GET(CLOZPAT)=0:7,1:90)
+25 DO C^%DTC
SET PSGNEFD=X
SET PSGFD=$$ENDD^PSGMI(PSGNEFD)
+26 SET PSGCFLG=0
SET PSGOLDED=PSGFD
SET PSGNEFDOLD=PSGNEFD
End DoDot:2
End DoDot:1
+27 ; PSJ*5*327 end
+28 ;*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")
+29 IF +$GET(PSGRF)
IF $$FIND1^DIC(51.1,,"X",$GET(PSGSCH))
Begin DoDot:1
+30 ;Handle "Fill on Request"
if PSGTMPST=($GET(PSGST)="R")
SET PSGST=$$GET1^DIQ(51.1,$$FIND1^DIC(51.1,,"X",$GET(PSGSCH)),5,"I")
+31 QUIT
End DoDot:1
+32 IF $GET(PSGTMPST)="O"
IF +$GET(PSGRF)
SET (PSGNEFD,PSGFD)=""
Begin DoDot:1
+33 IF +$GET(PSGRF)=1
SET MSG(1)="This NOW order has an Orderable Item for which a removal is required"
Begin DoDot:2
+34 SET MSG(2)=" at the next administration."
+35 SET MSG(3)="The Stop DATE/TIME entered should be the next anticipated administration for the medication."
SET MSG(3,"F")="!"
+36 QUIT
End DoDot:2
+37 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
+38 SET MSG(2)="prior to the next administration."
SET MSG(2,"F")="!"
+39 SET MSG(3)="If Early Removal is needed, enter Removal Time in Stop DATE/TIME field."
SET MSG(3,"F")="!"
+40 SET MSG(4)="If an Early Removal is not required, the Stop DATE/TIME entered"
+41 SET MSG(5)="should be the next anticipated administration for the medication."
SET MSG(5,"F")="!"
+42 QUIT
End DoDot:2
+43 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
+44 SET MSG(2)=" to the next administration."
SET MSG(2,"F")="!"
+45 SET MSG(3)="Please Enter the Stop DATE/TIME to reflect the Removal Time for this medication."
SET MSG(3,"F")="!"
+46 QUIT
End DoDot:2
+47 DO EN^DDIOL(.MSG)
End DoDot:1
+48 ;
A25 ;
+1 WRITE !,"STOP DATE/TIME: "_$SELECT(PSGFD]"":PSGFD_"// ",1:"")
READ X:DTIME
IF X="^"!'$TEST
if '$TEST
WRITE $CHAR(7)
SET PSGOROE1=1
GOTO DONE
+2 IF X=""
IF PSGNEFD
WRITE " "_PSGFD
SET PSGFOK(25)=""
GOTO W25
+3 SET PSGF2=25
IF $EXTRACT(X)="^"
DO FF
if Y>0
GOTO @Y
GOTO A25
+4 IF X="@"!(X?1."?")
if X="@"
WRITE $CHAR(7)," (Required)"
if X="@"
SET X="?"
DO ENHLP^PSGOEM(53.1,25)
+5 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 EN1^PSGDL
+6 KILL %DT
SET %DT="ERTX"
SET %DT(0)=PSGNESD
DO ^%DT
KILL %DT
IF Y'>0
WRITE $CHAR(7),!!?13,"*** WARNING! INVALID STOP DATE OR PRIOR TO START DATE! ***",!
GOTO A25
+7 ; re-ask if Stop Date more than 367 days after Start Date
+8 SET X1=+Y
SET X2=PSGNESD
DO ^%DTC
+9 IF X>367
WRITE $CHAR(7),!!?13,"*** STOP DATE cannot be more than 367 days from START DATE ***",!
GOTO A25
+10 ;
+11 IF CLOZFLG
Begin DoDot:1
+12 NEW X2
SET X2=$SELECT($GET(CLOZPAT)=2:28,$GET(CLOZPAT)=1:14,$GET(CLOZPAT)=0:7,1:90)
+13 IF $GET(PSGEMRG)!$GET(PSGTDTD)
SET X2=4
+14 IF $PIECE(Y,".")>$PIECE(PSGNEFD,".")
Begin DoDot:2
+15 WRITE !!,"*** STOP DATE/TIME NOT TO EXCEED "_X2_" DAYS! ***",!
End DoDot:2
SET PSGCFLG=1
QUIT
+16 SET (PSGFDX,PSGFD,PSGNEFD)=+Y
SET PSGFDN=$$ENDD^PSGMI(PSGFD)_"^"_$$ENDTC^PSGMI(PSGFD)
End DoDot:1
IF $GET(PSGCFLG)
SET PSGCFLG=0
GOTO A25
+17 ;
A255 ;
+1 IF $GET(PSGCFLG)
SET PSGCFLG=0
GOTO A25
+2 SET PSGNEFD=+Y
SET PSGFD=$$ENDD^PSGMI(+Y)
SET PSGFOK(25)=""
+3 KILL PSGEMRG,PSGTDTD
+4 ;
W25 ;
+1 NEW Z
+2 DO DOSE
IF $GET(Z)]""
IF Z>PSGNEFD
Begin DoDot:1
+3 WRITE !,"There must be an admin time that falls between the Start Date/Time"
+4 WRITE !,"and the Stop Date/Time."
End DoDot:1
GOTO A25
+5 IF PSGNEFD<PSGDT
WRITE $CHAR(7),!!?13,"*** WARNING! THE STOP DATE ENTERED IS IN THE PAST! ***",!
+6 ;Display Expected First Dose;BHW;PSJ*5*136
DO EFDNEW^PSJUTL
+7 ;*315
IF $GET(PSGDUR)
IF '$GET(PSGOROE1)
DO VERTIMES
NEXT ;
+1 if '+$GET(PSGRF)
SET PSGRF=+$$GET1^DIQ(50.7,$GET(PSGPDRG),12,"I")
+2 if '$DATA(PSGAARR)
GOTO 1^PSGOE42
+3 ;
DONE ;
+1 IF PSGOROE1
KILL Y
WRITE $CHAR(7)," ...order not entered..."
+2 KILL F,F0,F1,PSGF2,F3,PSG,SDT,PSGEMRG,PSGCLOZ
QUIT
+3 ;
FF ; up-arrow to another field
+1 DO ENFF^PSGOEM
+2 IF Y=132
SET Y="132^PSGOE41"
QUIT
+3 IF Y>0
IF Y'=39
IF Y'=8
IF Y'=10
IF Y'=25
SET Y=Y_"^PSGOE4"_$SELECT("^109^13^3^7^26^"[("^"_Y_"^"):"",1:2)
if $PIECE(Y,U)=2
SET FB=PSGF2_"^PSGOE41"
+4 QUIT
+5 ;
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
TIMES ;At least one admin time, not more than interval allows.
+1 ;No times
IF $GET(PSGS0XT)'="O"
IF X=""
WRITE !,"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
WRITE !,"This is a One Time Order - only one admin 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
Begin DoDot:1
+16 IF $LENGTH(X,"-")'=1
WRITE !,"This order requires one admin time."
KILL X
QUIT
End DoDot:1
QUIT
+17 ;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
+18 ;Too few times ;P454 Add Kill/Quit
IF MAX'<1
IF $LENGTH(X,"-")<MAX
WRITE !,"The number of admin times entered is fewer than indicated by the schedule."
KILL X
QUIT
+19 QUIT
DOSE ;Make certain at least one dose is given.
+1 if $GET(PSGST)="OC"!($GET(PSGST)="P")
QUIT
+2 NEW INFO,X
+3 SET Z=""
SET INFO=($GET(PSGNESD))_U_($GET(PSGNEFD))_U_($GET(PSGSCH))_U_($GET(PSGST))_U_($GET(PSGDRG))_U_($GET(PSGS0Y))
+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 PSGOROE1=1
SET X="^"
KILL PSGFOK(39)
QUIT
+14 IF RP=""
IF $GET(PSGS0XT)="D"
IF $LENGTH(PSGSCH,"@")=2
IF $PIECE(PSGSCH,"@",2)
SET (PSGAT,PSGRMV)=$PIECE(PSGSCH,"@",2)
GOTO 8
+15 IF RP="@"
IF PSGRF'=3
DO DEL
if %'=1
GOTO PSGDUR
SET (PSGFOK(39),PSGS0Y,PSGDUR,PSGRMVT)=""
SET PSGRMV=-1
if $$GET1^DIQ(53.1,+$GET(PSGORD),137)
SET (PSGDUR,PSGRMVT)="@"
QUIT
+16 IF (RP'="")
IF (RP'="@")
IF ($EXTRACT(RP)'="^")
IF ($EXTRACT(RP)'="?")
if (RP'?1N.2N)!(+(RP)<1)
SET RP="?"
+17 IF RP?1."?"
DO DURHLP^PSGOEM(RP,PSGRF)
GOTO PSGDUR
+18 IF $EXTRACT(RP)="^"
DO FF
if Y>0
GOTO @Y
GOTO PSGDUR
+19 ; exclude BID,TID or QID schedules
IF (+RP>0)
IF 'PSGIDF
Begin DoDot:1
+20 SET PSGDUR=(RP*60)
SET PSGRMV=$GET(PSGS0XT)-PSGDUR
+21 ;,PSGRMV G PSGDUR
IF PSGRMV<1
WRITE !,"DURATION OF ADMINISTRATION MATCHES OR EXCEEDS ORDER FREQUENCY"
SET RP=""
SET PSGDERR=1
KILL PSGDUR
+22 QUIT
End DoDot:1
IF PSGRMV<1
KILL PSGRMV
GOTO PSGDUR
+23 if $GET(PSGDERR)=1
QUIT
+24 IF PSGRF=3
IF (+RP<1)
WRITE !,"ENTRY IS REQUIRED"
SET RP=""
GOTO PSGDUR
+25 IF PSGRF=2
IF (+RP<1)
Begin DoDot:1
+26 WRITE !,"You have not entered Duration of Administration for this medication order, "
+27 WRITE !,"therefore the BCMA user will not be prompted to remove the medication prior "
+28 WRITE !,"to the next Admin Time."
+29 SET PSGRMV=-1
SET RP=0
+30 QUIT
End DoDot:1
+31 ;Only for TPD schedules
IF PSGIDF
IF (+RP>0)
Begin DoDot:1
+32 NEW F,P,PSGARR
+33 SET PSGADT=$SELECT($GET(PSGDUR)=-1:X,$GET(PSGS0Y):PSGS0Y,$GET(PSGAT):PSGAT,1:"")
SET PSGAT=PSGADT
+34 SET PSGARR=$LENGTH($GET(PSGADT),"-")
+35 FOR P=1:1:PSGARR
Begin DoDot:2
+36 SET PSGARR(P)=($PIECE(PSGADT,"-",P)/100)
if (P>1)
SET F(P)=PSGARR(P)-PSGARR(P-1)
+37 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!"
+38 QUIT
End DoDot:2
+39 QUIT
End DoDot:1
+40 if (+RP>0)
SET PSGDUR=(RP*60)
+41 if (+RP>0)
WRITE ?60,RP," HOURS"
+42 if $GET(WMSG)
DO EN^DDIOL($PIECE(WMSG,U,2))
DO EN^DDIOL(WMSG(1))
+43 if '$GET(PSGOE3)!'+$GET(PSGDUR)
QUIT
+44 ;
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)=""
IF $GET(PSGS0Y)=""
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 NEW Y
+2 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
+3 IF 'Y
KILL X
SET PSGDUR=-1
GOTO 39
+4 NEW P
SET P=1
SET PSGRMVT=$PIECE(PSGRARR(P),"(",1)
+5 FOR
SET P=$ORDER(PSGRARR(P))
if P=""
QUIT
Begin DoDot:1
+6 SET PSGRMVT=PSGRMVT_"-"_$PIECE(PSGRARR(P),"(",1)
+7 QUIT
End DoDot:1
+8 QUIT
+9 ;
