PSGOE8 ;BIR/CML3 - EDIT ORDERS IN 53.1 ;12 June 2019 09:31:53
;;5.0;INPATIENT MEDICATIONS ;**47,50,65,72,110,111,188,192,113,223,269,287,315,338,366,327,380**;16 DEC 97;Build 10
;Per VHA Directive 2004-038, this routine should not be modified.
; Reference to ^PS(50.7 is supported by DBIA# 2180
; Reference to ^PS(51.1 is supported by DBIA 2177
; Reference to ^PS(51.2 is supported by DBIA# 2178
; Reference to ^PSDRUG is supported by DBIA# 2192
;
101 ;Orderable Item
S MSG=0,F2=101,PSGOOPD=PSGPD,PSGOOPDN=PSGPDN S:PSGOEEF(F2) BACK="101^PSGOE8"
S %=1 I $P(PSJSYSU,";",3)>1 W !!,$C(7),"WARNING! If you change the drug of an order, the Dosage Ordered and Dispense",!,"Drug(s) are deleted." F W !,"Do you wish to continue" S %=2 D YN^DICN Q:%
I %'=1 G DONE
A101 ;
I $$PNDREN($G(PSGORD)) D Q
. W !!?5,"Orderable Item may not be edited at this point." D PAUSE^VALM1
W !,"ORDERABLE ITEM: ",$S(PSGPD:PSGPDN_"// ",1:"") R X:DTIME I X="^"!'$T W:'$T $C(7) S PSGOEE=0 G DONE
;; START NCC T4 MODS >> 327*RJS
A201 I X="",PSGPD S X=PSGPDN I PSGPD'=PSGPDN,$L($$GET1^DIQ(50.7,PSGPD,.01)) G:'$G(ANQX) DONE
S PSGPDOLD=PSGPD,PSGPDNOLD=PSGPDN,PSGPDRGOLD=PSGPDRG
;; END NCC T4 MODS >> 327*RJS
I X="",PSGPD S X=PSGPDN I PSGPD'=PSGPDN,$D(^PS(50.7,PSGPD,0)) G DONE
I $S(X="@":1,X]"":0,1:'PSGPD) W $C(7)," (Required)" S X="?" D ENHLP^PSGOEM(53.1,101) G A101
I X?1."?" D ENHLP^PSGOEM(53.1,101)
I $E(X)="^" D ENFF^PSGOE82 G:Y>0 @Y G A101
;BHW;PSJ*5.0*192;Modify ^DIC call to use MIX^DIC and only B/C cross-references
K DIC,D S DIC="^PS(50.7,",DIC(0)="EMQZ",DIC("S")="I $$ENOISC^PSJUTL(Y,""U"")",D="B^C" D MIX^DIC1 K DIC,D I Y'>0 G A101
F S %=2 D DH,YN^DICN Q:%
I %'=1 G A101
S (PSGPDRG,PSGPD)=+Y,(PSGPDN,PSGPDRGN)=$$OINAME^PSJLMUTL(PSGPDRG)
S PSGNEDFD=$$GTNEDFD^PSGOE7("U",PSGPDRG)
S PSGPDNX=1,PSGDO="",(PSGPDRG,PSGPD)=+Y,(PSGPDN,PSGPDRGN)=$$OINAME^PSJLMUTL(PSGPDRG) K ^PS(53.45,PSJSYSP,2) S X=$O(^PSDRUG("ASP",PSGPD,0)) I X,'$O(^(X)) D
.S ^PS(53.45,PSJSYSP,2,0)="^53.4502P^1^1",^(1,0)=X,^PS(53.45,PSJSYSP,2,"B",X,1)=""
S PSGDRGTMP=X
D ENDRG^PSGOEF1(PSGPD,0)
;; START NCC T4 MODS >> 327*RJS
N CLOZFLG S CLOZFLG=$$ISCLOZ^PSJCLOZ(,PSGPD) I CLOZFLG D I $G(ANQX) K ANQX G A201
.N PSGDRG S ANQX=0,PSGDRG=$P(CLOZFLG,U,2) D CLOZ^PSJCLOZ(DFN,PSGDRG)
.I $G(ANQX) W ! S X=$E(PSGPDNOLD,0,4),PSGPDN=PSGPDNOLD,PSGPD=PSGPDOLD,PSGPDRG=PSGPDRGOLD K PSGDRGTMP,PSGPDOLD,PSGPDNOLD,PSGPDRGOLD
;; END NCC T4 MODS >> 327*RJS
I $S($D(DTOUT):1,$D(DUOUT):1,$D(DIRUT):1,1:0) G DONE
;G DONE
;
109 ; dosage ordered
S MSG=0,F2=109 S:$G(PSGOEEF(F2)) BACK="109^PSGOE8"
A109 ;
I $$PNDREN($G(PSGORD)) D Q
. W !!?5,"Dosage may not be edited at this point." D PAUSE^VALM1
S PSGOEEF(F2)=PSGOEE
D EDITDOSE^PSJDOSE S X=PSGDO S:X="" PSGDREQ=1 G DONE
W !,"DOSAGE ORDERED: ",$S(PSGDO]"":PSGDO_"// ",1:"") R X:DTIME I X="^"!'$T W:'$T $C(7) S PSGOEE=0 G DONE
I X=""&(PSGDO]"") S X=PSGDO
I $$CHECK(PSJSYSP)&(X="")&(PSGDO']"") W $C(7)," (Required) " G A109
I $$CHECK(PSJSYSP)&(X="@") W $C(7)," (Required) " G A109
I '$$CHECK(PSJSYSP)&(X="@") S PSGDO="" G DONE
I X?1."?" D ENHLP^PSGOEM(53.1,109) G A109
I $E(X)="^" D ENFF^PSGOE82 G:Y>0 @Y G A109
I $E(X,$L(X))=" " F S X=$E(X,1,$L(X)-1) Q:$E(X,$L(X))'=" "
I $S(X?.E1C.E:1,$L(X)>20:1,X="":0,X["^":1,X?1.P:1,1:X=+X) W $C(7)," ",$S(X?1.P!(X=""):"(Required)",1:"??") D ENHLP^PSGOEM(53.1,109) G A109
S PSGDO=X G DONE
;
3 ; med route
N PSGS0XT
S MSG=0,F2=3 S:PSGOEEF(F2) BACK="3^PSGOE8"
A3 I $$PNDREN($G(PSGORD)) D Q
. W !!?5,"Med Route may not be edited at this point." D PAUSE^VALM1
W !,"MED ROUTE: ",$S(PSGMR:PSGMRN_"// ",1:"") R X:DTIME I X="^"!'$T W:'$T $C(7) S PSGOEE=0 G DONE
I X="",PSGMR S X=PSGMRN I PSGMR'=PSGMRN,$D(^PS(51.2,PSGMR,0)) W " "_$P(^(0),"^",3) G DONE
I $S(X="@":1,X]"":0,1:'PSGMR) W $C(7)," (Required)" S X="?" D ENHLP^PSGOEM(53.1,3) G A3
I X="?" D MRSL^PSGOE4 ;*366
I X?1."??" D ENHLP^PSGOEM(53.1,3)
;I X?1."?" D ENHLP^PSGOEM(53.1,3)
I $E(X)="^" D ENFF^PSGOE82 G:Y>0 @Y G A3
D CKMRSL^PSGOE4 ;*366
K DIC S DIC="^PS(51.2,",DIC(0)="EMQZX",DIC("S")="I $P(^(0),""^"",4)" D ^DIC K DIC I Y'>0 G A3 ;*366
S PSGMR=+Y,PSGMRN=Y(0,0) G DONE
;
26 ; schedule
S MSG=0,F2=26 S:PSGOEEF(F2) BACK="26^PSGOE8"
A26 I $$PNDREN($G(PSGORD)) D Q
. W !!?5,"Schedule may not be edited at this point." D PAUSE^VALM1
W !,"SCHEDULE: ",$S(PSGSCH]"":PSGSCH_"// ",1:"") R X:DTIME I X="^"!'$T W:'$T $C(7) S PSGOEE=0 G DONE
S:X="" X=PSGSCH,PSGSCH="" I "@"[X W $C(7)," (Required)" S X="?" D ENHLP^PSGOEM(53.1,26) G A26
S DOW=0 I $$DOW^PSIVUTL($$ENLU^PSGMI(X)) S DOW=1
I X?1."?" D ENHLP^PSGOEM(53.1,26) G A26
I $E(X)="^" D ENFF^PSGOE82 G:Y>0 @Y G A26
;BHW;PSJ*5*188;Add flag and IEN return variable for PSGS0 (PSJ*5*134), Highlight Admin Times if they changed.
N PSGOES,PSJSLUP,PSGSFLG S PSJSLUP=1,PSGSFLG=1 D EN^PSGS0 I '$D(X) W $C(7)," ??" S X="?" D ENHLP^PSGOEM(53.1,26) G A26
I X'=PSGSCH D
. K PSGDUR,PSGRMVT,PSGRMV,ND2P1 ;*315 Removal times are tied to ADMIN times.
. N XX
. S PSGSCH=X
. I PSGS0Y'=PSGAT S PSGAT=PSGS0Y ;Change so that any schedule change will adjust the type and default the admin times - DRF
. D ;Change schedule type to agree with schedule
.. I $G(DOW) S PSGST="C",PSGSTN=$$ENSTN^PSGMI(PSGST) Q
.. I (PSGSCH[" PRN")!(PSGSCH="PRN") I $$PRNOK^PSGS0(PSGSCH) S PSGOST=PSGST,PSGST="P",PSGSTN=$$ENSTN^PSGMI(PSGST) Q
.. I '$G(PSGSCIEN),PSGSCH]"" S XX=+$O(^PS(51.1,"AC","PSJ",PSGSCH,0)),PSGSCIEN=XX
.. S PSGOST=$G(PSGST),PSGST=$P($G(^PS(51.1,PSGSCIEN,0)),"^",5) I PSGST="D" S PSGST="C" ;DOW schedules are converted to Continuous
.. S PSGSTN=$$ENSTN^PSGMI(PSGST)
. I $G(PSJSYSW0),($P(PSJSYSW0,U,5)'=2),'$G(PSGEFN(8)) W !!,"NOTE: This may cause the Admin Times and the Start Time to be out of sync."
. W !!,"NOTE: This change in schedule also changes the ADMIN TIMES and SCHEDULE TYPE.",!
. S MSG=1 S:'$G(PSGOEEF(39)) PSGOEEF(39)=1 ;*287 - Prevent infinite loop editing admin times
. I ($G(PSGRF)>1),PSGST="C" D
..S PSGF2=39,BACK="39^PSGOE81" D 39^PSGOE81 S BACK="26^PSGOE8",PSGF2=26,PSGOAT=PSGAT ;*315 Prompt for Admin to get DOA
..Q
. I $G(PSJNEWOE) D PAUSE^VALM1
I PSGST="O" S PSGOEEF(7)=1 I +$G(PSGRF) S PSGOEEF(25)=1 D 25^PSGOE81 S PSGF2=26
G DONE
;
7 ; schedule type
S MSG=0,F2=7 S:PSGOEEF(F2) BACK="7^PSGOE8"
A7 W !,"SCHEDULE TYPE: "_$S(PSGSTN]"":PSGSTN_"// ",1:"") R X:DTIME S X=$TR(X,"coprocf","COPROCF") I X="^"!'$T S PSGOEE=0 W $C(7) G DONE
I X="" S X=PSGST,PSGSTN=$$ENSTN^PSGMI(X) W:PSGSTN]"" " ",PSGSTN G DONE
S:X="F" X="R"
I ",?,??,C,O,OC,P,R,"'[(","_X_",") W " ??" G A7
I $$PRNOK^PSGS0($G(PSGSCH)),X="C" W " ??" G A7
I X="@"!(X?1."?") W:X="@" $C(7)," (Required)" S:X="@" X="?" D ENHLP^PSGOEM(53.1,7) G A7
I $E(X)="^" D ENFF^PSGOE82 G:Y>0 @Y G A7
;*223 Don't allow O sched type on C orders
I X="O",$$SCHTP(PSGSCH)'="O" W !," SCHEDULE ("_PSGSCH_") is not a ONE TIME Schedule." G A7
;*269 Don't allow C sched type on O orders
I X="C",$$SCHTP(PSGSCH)="O" W !," SCHEDULE ("_PSGSCH_") is not a CONTINUOUS Schedule." G A7
S PSGOST=PSGST
S PSGST=X,PSGSTN=$$ENSTN^PSGMI(X) W:PSGSTN]"" " ",PSGSTN
I X="P",$G(PSGAT)]"" S PSGOAT=PSGAT S PSGAT="" D
.W !!,"NOTE: This change in schedule type also changes the ADMIN TIMES.",!
.S MSG=1,PSGOEEF(39)=1
.I $G(PSJNEWOE) D PAUSE^VALM1
;
DONE ;
I PSGOEE G:'PSGOEEF(F2) @BACK S PSGOEE=PSGOEEF(F2)
K F,F0,F2 Q
;
DEL ; delete entry
W !?3,"SURE YOU WANT TO DELETE" S %=0 D YN^DICN I %'=1 W $C(7)," <NOTHING DELETED>"
Q
;
DH ;
W !!?2,"When the drug of an order is changed, the Dosage Ordered and Dispense Drug(s)",!,"for the order are no longer valid, and therefore deleted from the order.",!,"If possible, a new corresponding dispense drug will be added to the order."
W !!?2,"Answer 'YES' to continue with this change. Answer 'NO' to select another",!,"drug or to accept the drug as it was. Enter an '^' to exit this edit." Q
;
CHECK(PSJSYSP) ; Check to see if multiple dispense drugs
; Input - PSJSYSP
; Returns 0 = only one.
; 1 = more than one
; Checks Inactive Date and doesn't count if < or = today.
N PSJRSB,PSJINACT,PSJRBCNT S PSJRBCNT=0
F PSJRSB=0:0 S PSJRSB=$O(^PS(53.45,PSJSYSP,2,PSJRSB)) Q:'PSJRSB D
.S PSJINACT=$P(^PS(53.45,PSJSYSP,2,PSJRSB,0),"^",3)
.I (PSJINACT="")!((PSJINACT>0)&(PSJINACT>DT)) D
..S PSJRBCNT=$S('$D(PSJRBCNT):1,1:PSJRBCNT+1)
Q $S(PSJRBCNT>1:1,1:0)
;
PNDREN(PNDON) ;
I PNDON'["P" Q 0
S RNWL="^PS(53.1,"_+PNDON_",0)" S RNWL=$G(@(RNWL)) S RNWL=$S($P(RNWL,"^",24)="R":1,1:0)
Q RNWL
;
SCHTP(SCH) ; *223 Return SCHedule type
N X I SCH="" Q ""
S X=$O(^PS(51.1,"APPSJ",SCH,0))
Q:'$G(X) ""
Q $P(^PS(51.1,X,0),"^",5)
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSGOE8 8711 printed Oct 16, 2024@18:02:45 Page 2
PSGOE8 ;BIR/CML3 - EDIT ORDERS IN 53.1 ;12 June 2019 09:31:53
+1 ;;5.0;INPATIENT MEDICATIONS ;**47,50,65,72,110,111,188,192,113,223,269,287,315,338,366,327,380**;16 DEC 97;Build 10
+2 ;Per VHA Directive 2004-038, this routine should not be modified.
+3 ; Reference to ^PS(50.7 is supported by DBIA# 2180
+4 ; Reference to ^PS(51.1 is supported by DBIA 2177
+5 ; Reference to ^PS(51.2 is supported by DBIA# 2178
+6 ; Reference to ^PSDRUG is supported by DBIA# 2192
+7 ;
101 ;Orderable Item
+1 SET MSG=0
SET F2=101
SET PSGOOPD=PSGPD
SET PSGOOPDN=PSGPDN
if PSGOEEF(F2)
SET BACK="101^PSGOE8"
+2 SET %=1
IF $PIECE(PSJSYSU,";",3)>1
WRITE !!,$CHAR(7),"WARNING! If you change the drug of an order, the Dosage Ordered and Dispense",!,"Drug(s) are deleted."
FOR
WRITE !,"Do you wish to continue"
SET %=2
DO YN^DICN
if %
QUIT
+3 IF %'=1
GOTO DONE
A101 ;
+1 IF $$PNDREN($GET(PSGORD))
Begin DoDot:1
+2 WRITE !!?5,"Orderable Item may not be edited at this point."
DO PAUSE^VALM1
End DoDot:1
QUIT
+3 WRITE !,"ORDERABLE ITEM: ",$SELECT(PSGPD:PSGPDN_"// ",1:"")
READ X:DTIME
IF X="^"!'$TEST
if '$TEST
WRITE $CHAR(7)
SET PSGOEE=0
GOTO DONE
+4 ;; START NCC T4 MODS >> 327*RJS
A201 IF X=""
IF PSGPD
SET X=PSGPDN
IF PSGPD'=PSGPDN
IF $LENGTH($$GET1^DIQ(50.7,PSGPD,.01))
if '$GET(ANQX)
GOTO DONE
+1 SET PSGPDOLD=PSGPD
SET PSGPDNOLD=PSGPDN
SET PSGPDRGOLD=PSGPDRG
+2 ;; END NCC T4 MODS >> 327*RJS
+3 IF X=""
IF PSGPD
SET X=PSGPDN
IF PSGPD'=PSGPDN
IF $DATA(^PS(50.7,PSGPD,0))
GOTO DONE
+4 IF $SELECT(X="@":1,X]"":0,1:'PSGPD)
WRITE $CHAR(7)," (Required)"
SET X="?"
DO ENHLP^PSGOEM(53.1,101)
GOTO A101
+5 IF X?1."?"
DO ENHLP^PSGOEM(53.1,101)
+6 IF $EXTRACT(X)="^"
DO ENFF^PSGOE82
if Y>0
GOTO @Y
GOTO A101
+7 ;BHW;PSJ*5.0*192;Modify ^DIC call to use MIX^DIC and only B/C cross-references
+8 KILL DIC,D
SET DIC="^PS(50.7,"
SET DIC(0)="EMQZ"
SET DIC("S")="I $$ENOISC^PSJUTL(Y,""U"")"
SET D="B^C"
DO MIX^DIC1
KILL DIC,D
IF Y'>0
GOTO A101
+9 FOR
SET %=2
DO DH
DO YN^DICN
if %
QUIT
+10 IF %'=1
GOTO A101
+11 SET (PSGPDRG,PSGPD)=+Y
SET (PSGPDN,PSGPDRGN)=$$OINAME^PSJLMUTL(PSGPDRG)
+12 SET PSGNEDFD=$$GTNEDFD^PSGOE7("U",PSGPDRG)
+13 SET PSGPDNX=1
SET PSGDO=""
SET (PSGPDRG,PSGPD)=+Y
SET (PSGPDN,PSGPDRGN)=$$OINAME^PSJLMUTL(PSGPDRG)
KILL ^PS(53.45,PSJSYSP,2)
SET X=$ORDER(^PSDRUG("ASP",PSGPD,0))
IF X
IF '$ORDER(^(X))
Begin DoDot:1
+14 SET ^PS(53.45,PSJSYSP,2,0)="^53.4502P^1^1"
SET ^(1,0)=X
SET ^PS(53.45,PSJSYSP,2,"B",X,1)=""
End DoDot:1
+15 SET PSGDRGTMP=X
+16 DO ENDRG^PSGOEF1(PSGPD,0)
+17 ;; START NCC T4 MODS >> 327*RJS
+18 NEW CLOZFLG
SET CLOZFLG=$$ISCLOZ^PSJCLOZ(,PSGPD)
IF CLOZFLG
Begin DoDot:1
+19 NEW PSGDRG
SET ANQX=0
SET PSGDRG=$PIECE(CLOZFLG,U,2)
DO CLOZ^PSJCLOZ(DFN,PSGDRG)
+20 IF $GET(ANQX)
WRITE !
SET X=$EXTRACT(PSGPDNOLD,0,4)
SET PSGPDN=PSGPDNOLD
SET PSGPD=PSGPDOLD
SET PSGPDRG=PSGPDRGOLD
KILL PSGDRGTMP,PSGPDOLD,PSGPDNOLD,PSGPDRGOLD
End DoDot:1
IF $GET(ANQX)
KILL ANQX
GOTO A201
+21 ;; END NCC T4 MODS >> 327*RJS
+22 IF $SELECT($DATA(DTOUT):1,$DATA(DUOUT):1,$DATA(DIRUT):1,1:0)
GOTO DONE
+23 ;G DONE
+24 ;
109 ; dosage ordered
+1 SET MSG=0
SET F2=109
if $GET(PSGOEEF(F2))
SET BACK="109^PSGOE8"
A109 ;
+1 IF $$PNDREN($GET(PSGORD))
Begin DoDot:1
+2 WRITE !!?5,"Dosage may not be edited at this point."
DO PAUSE^VALM1
End DoDot:1
QUIT
+3 SET PSGOEEF(F2)=PSGOEE
+4 DO EDITDOSE^PSJDOSE
SET X=PSGDO
if X=""
SET PSGDREQ=1
GOTO DONE
+5 WRITE !,"DOSAGE ORDERED: ",$SELECT(PSGDO]"":PSGDO_"// ",1:"")
READ X:DTIME
IF X="^"!'$TEST
if '$TEST
WRITE $CHAR(7)
SET PSGOEE=0
GOTO DONE
+6 IF X=""&(PSGDO]"")
SET X=PSGDO
+7 IF $$CHECK(PSJSYSP)&(X="")&(PSGDO']"")
WRITE $CHAR(7)," (Required) "
GOTO A109
+8 IF $$CHECK(PSJSYSP)&(X="@")
WRITE $CHAR(7)," (Required) "
GOTO A109
+9 IF '$$CHECK(PSJSYSP)&(X="@")
SET PSGDO=""
GOTO DONE
+10 IF X?1."?"
DO ENHLP^PSGOEM(53.1,109)
GOTO A109
+11 IF $EXTRACT(X)="^"
DO ENFF^PSGOE82
if Y>0
GOTO @Y
GOTO A109
+12 IF $EXTRACT(X,$LENGTH(X))=" "
FOR
SET X=$EXTRACT(X,1,$LENGTH(X)-1)
if $EXTRACT(X,$LENGTH(X))'=" "
QUIT
+13 IF $SELECT(X?.E1C.E:1,$LENGTH(X)>20:1,X="":0,X["^":1,X?1.P:1,1:X=+X)
WRITE $CHAR(7)," ",$SELECT(X?1.P!(X=""):"(Required)",1:"??")
DO ENHLP^PSGOEM(53.1,109)
GOTO A109
+14 SET PSGDO=X
GOTO DONE
+15 ;
3 ; med route
+1 NEW PSGS0XT
+2 SET MSG=0
SET F2=3
if PSGOEEF(F2)
SET BACK="3^PSGOE8"
A3 IF $$PNDREN($GET(PSGORD))
Begin DoDot:1
+1 WRITE !!?5,"Med Route may not be edited at this point."
DO PAUSE^VALM1
End DoDot:1
QUIT
+2 WRITE !,"MED ROUTE: ",$SELECT(PSGMR:PSGMRN_"// ",1:"")
READ X:DTIME
IF X="^"!'$TEST
if '$TEST
WRITE $CHAR(7)
SET PSGOEE=0
GOTO DONE
+3 IF X=""
IF PSGMR
SET X=PSGMRN
IF PSGMR'=PSGMRN
IF $DATA(^PS(51.2,PSGMR,0))
WRITE " "_$PIECE(^(0),"^",3)
GOTO DONE
+4 IF $SELECT(X="@":1,X]"":0,1:'PSGMR)
WRITE $CHAR(7)," (Required)"
SET X="?"
DO ENHLP^PSGOEM(53.1,3)
GOTO A3
+5 ;*366
IF X="?"
DO MRSL^PSGOE4
+6 IF X?1."??"
DO ENHLP^PSGOEM(53.1,3)
+7 ;I X?1."?" D ENHLP^PSGOEM(53.1,3)
+8 IF $EXTRACT(X)="^"
DO ENFF^PSGOE82
if Y>0
GOTO @Y
GOTO A3
+9 ;*366
DO CKMRSL^PSGOE4
+10 ;*366
KILL DIC
SET DIC="^PS(51.2,"
SET DIC(0)="EMQZX"
SET DIC("S")="I $P(^(0),""^"",4)"
DO ^DIC
KILL DIC
IF Y'>0
GOTO A3
+11 SET PSGMR=+Y
SET PSGMRN=Y(0,0)
GOTO DONE
+12 ;
26 ; schedule
+1 SET MSG=0
SET F2=26
if PSGOEEF(F2)
SET BACK="26^PSGOE8"
A26 IF $$PNDREN($GET(PSGORD))
Begin DoDot:1
+1 WRITE !!?5,"Schedule may not be edited at this point."
DO PAUSE^VALM1
End DoDot:1
QUIT
+2 WRITE !,"SCHEDULE: ",$SELECT(PSGSCH]"":PSGSCH_"// ",1:"")
READ X:DTIME
IF X="^"!'$TEST
if '$TEST
WRITE $CHAR(7)
SET PSGOEE=0
GOTO DONE
+3 if X=""
SET X=PSGSCH
SET PSGSCH=""
IF "@"[X
WRITE $CHAR(7)," (Required)"
SET X="?"
DO ENHLP^PSGOEM(53.1,26)
GOTO A26
+4 SET DOW=0
IF $$DOW^PSIVUTL($$ENLU^PSGMI(X))
SET DOW=1
+5 IF X?1."?"
DO ENHLP^PSGOEM(53.1,26)
GOTO A26
+6 IF $EXTRACT(X)="^"
DO ENFF^PSGOE82
if Y>0
GOTO @Y
GOTO A26
+7 ;BHW;PSJ*5*188;Add flag and IEN return variable for PSGS0 (PSJ*5*134), Highlight Admin Times if they changed.
+8 NEW PSGOES,PSJSLUP,PSGSFLG
SET PSJSLUP=1
SET PSGSFLG=1
DO EN^PSGS0
IF '$DATA(X)
WRITE $CHAR(7)," ??"
SET X="?"
DO ENHLP^PSGOEM(53.1,26)
GOTO A26
+9 IF X'=PSGSCH
Begin DoDot:1
+10 ;*315 Removal times are tied to ADMIN times.
KILL PSGDUR,PSGRMVT,PSGRMV,ND2P1
+11 NEW XX
+12 SET PSGSCH=X
+13 ;Change so that any schedule change will adjust the type and default the admin times - DRF
IF PSGS0Y'=PSGAT
SET PSGAT=PSGS0Y
+14 ;Change schedule type to agree with schedule
Begin DoDot:2
+15 IF $GET(DOW)
SET PSGST="C"
SET PSGSTN=$$ENSTN^PSGMI(PSGST)
QUIT
+16 IF (PSGSCH[" PRN")!(PSGSCH="PRN")
IF $$PRNOK^PSGS0(PSGSCH)
SET PSGOST=PSGST
SET PSGST="P"
SET PSGSTN=$$ENSTN^PSGMI(PSGST)
QUIT
+17 IF '$GET(PSGSCIEN)
IF PSGSCH]""
SET XX=+$ORDER(^PS(51.1,"AC","PSJ",PSGSCH,0))
SET PSGSCIEN=XX
+18 ;DOW schedules are converted to Continuous
SET PSGOST=$GET(PSGST)
SET PSGST=$PIECE($GET(^PS(51.1,PSGSCIEN,0)),"^",5)
IF PSGST="D"
SET PSGST="C"
+19 SET PSGSTN=$$ENSTN^PSGMI(PSGST)
End DoDot:2
+20 IF $GET(PSJSYSW0)
IF ($PIECE(PSJSYSW0,U,5)'=2)
IF '$GET(PSGEFN(8))
WRITE !!,"NOTE: This may cause the Admin Times and the Start Time to be out of sync."
+21 WRITE !!,"NOTE: This change in schedule also changes the ADMIN TIMES and SCHEDULE TYPE.",!
+22 ;*287 - Prevent infinite loop editing admin times
SET MSG=1
if '$GET(PSGOEEF(39))
SET PSGOEEF(39)=1
+23 IF ($GET(PSGRF)>1)
IF PSGST="C"
Begin DoDot:2
+24 ;*315 Prompt for Admin to get DOA
SET PSGF2=39
SET BACK="39^PSGOE81"
DO 39^PSGOE81
SET BACK="26^PSGOE8"
SET PSGF2=26
SET PSGOAT=PSGAT
+25 QUIT
End DoDot:2
+26 IF $GET(PSJNEWOE)
DO PAUSE^VALM1
End DoDot:1
+27 IF PSGST="O"
SET PSGOEEF(7)=1
IF +$GET(PSGRF)
SET PSGOEEF(25)=1
DO 25^PSGOE81
SET PSGF2=26
+28 GOTO DONE
+29 ;
7 ; schedule type
+1 SET MSG=0
SET F2=7
if PSGOEEF(F2)
SET BACK="7^PSGOE8"
A7 WRITE !,"SCHEDULE TYPE: "_$SELECT(PSGSTN]"":PSGSTN_"// ",1:"")
READ X:DTIME
SET X=$TRANSLATE(X,"coprocf","COPROCF")
IF X="^"!'$TEST
SET PSGOEE=0
WRITE $CHAR(7)
GOTO DONE
+1 IF X=""
SET X=PSGST
SET PSGSTN=$$ENSTN^PSGMI(X)
if PSGSTN]""
WRITE " ",PSGSTN
GOTO DONE
+2 if X="F"
SET X="R"
+3 IF ",?,??,C,O,OC,P,R,"'[(","_X_",")
WRITE " ??"
GOTO A7
+4 IF $$PRNOK^PSGS0($GET(PSGSCH))
IF X="C"
WRITE " ??"
GOTO A7
+5 IF X="@"!(X?1."?")
if X="@"
WRITE $CHAR(7)," (Required)"
if X="@"
SET X="?"
DO ENHLP^PSGOEM(53.1,7)
GOTO A7
+6 IF $EXTRACT(X)="^"
DO ENFF^PSGOE82
if Y>0
GOTO @Y
GOTO A7
+7 ;*223 Don't allow O sched type on C orders
+8 IF X="O"
IF $$SCHTP(PSGSCH)'="O"
WRITE !," SCHEDULE ("_PSGSCH_") is not a ONE TIME Schedule."
GOTO A7
+9 ;*269 Don't allow C sched type on O orders
+10 IF X="C"
IF $$SCHTP(PSGSCH)="O"
WRITE !," SCHEDULE ("_PSGSCH_") is not a CONTINUOUS Schedule."
GOTO A7
+11 SET PSGOST=PSGST
+12 SET PSGST=X
SET PSGSTN=$$ENSTN^PSGMI(X)
if PSGSTN]""
WRITE " ",PSGSTN
+13 IF X="P"
IF $GET(PSGAT)]""
SET PSGOAT=PSGAT
SET PSGAT=""
Begin DoDot:1
+14 WRITE !!,"NOTE: This change in schedule type also changes the ADMIN TIMES.",!
+15 SET MSG=1
SET PSGOEEF(39)=1
+16 IF $GET(PSJNEWOE)
DO PAUSE^VALM1
End DoDot:1
+17 ;
DONE ;
+1 IF PSGOEE
if 'PSGOEEF(F2)
GOTO @BACK
SET PSGOEE=PSGOEEF(F2)
+2 KILL F,F0,F2
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 ;
DH ;
+1 WRITE !!?2,"When the drug of an order is changed, the Dosage Ordered and Dispense Drug(s)",!,"for the order are no longer valid, and therefore deleted from the order.",!,"If possible, a new corresponding dispense drug will be added to the order
."
+2 WRITE !!?2,"Answer 'YES' to continue with this change. Answer 'NO' to select another",!,"drug or to accept the drug as it was. Enter an '^' to exit this edit."
QUIT
+3 ;
CHECK(PSJSYSP) ; Check to see if multiple dispense drugs
+1 ; Input - PSJSYSP
+2 ; Returns 0 = only one.
+3 ; 1 = more than one
+4 ; Checks Inactive Date and doesn't count if < or = today.
+5 NEW PSJRSB,PSJINACT,PSJRBCNT
SET PSJRBCNT=0
+6 FOR PSJRSB=0:0
SET PSJRSB=$ORDER(^PS(53.45,PSJSYSP,2,PSJRSB))
if 'PSJRSB
QUIT
Begin DoDot:1
+7 SET PSJINACT=$PIECE(^PS(53.45,PSJSYSP,2,PSJRSB,0),"^",3)
+8 IF (PSJINACT="")!((PSJINACT>0)&(PSJINACT>DT))
Begin DoDot:2
+9 SET PSJRBCNT=$SELECT('$DATA(PSJRBCNT):1,1:PSJRBCNT+1)
End DoDot:2
End DoDot:1
+10 QUIT $SELECT(PSJRBCNT>1:1,1:0)
+11 ;
PNDREN(PNDON) ;
+1 IF PNDON'["P"
QUIT 0
+2 SET RNWL="^PS(53.1,"_+PNDON_",0)"
SET RNWL=$GET(@(RNWL))
SET RNWL=$SELECT($PIECE(RNWL,"^",24)="R":1,1:0)
+3 QUIT RNWL
+4 ;
SCHTP(SCH) ; *223 Return SCHedule type
+1 NEW X
IF SCH=""
QUIT ""
+2 SET X=$ORDER(^PS(51.1,"APPSJ",SCH,0))
+3 if '$GET(X)
QUIT ""
+4 QUIT $PIECE(^PS(51.1,X,0),"^",5)
+5 ;
