PSOORED4 ;BIR/SAB - Edit front door dosing ;07/13/00
;;7.0;OUTPATIENT PHARMACY;**46,91,78,99,111,117,133,159,148**;DEC 1997
;External reference ^PS(51 supported by DBIA 2224
;External reference to PS(51.2 supported by DBIA 2226
;External reference to PS(51.1 supported by DBIA 2225
;called from psoornew
;
DOSE(PSORXED) ;
I '$G(PSODRUG("IEN")) W !,"DRUG NAME REQUIRED!" D 2^PSOORNW1 I '$G(PSODRUG("IEN")) S VALMSG="No Dispense Drug Selected" Q
K ROU,STRE,UNITN,PSODOSE M PSODOSE=PSORXED
D KV K FIELD,DOSEOR,DUPD,X,Y,UNITS S ENT=1,OLENT=PSORXED("ENT")
ASK I $G(ORD) W !!,"Possible SIG: " D
.;Coded only for outside orders with no Patient Instructions
.I $O(SIG(""))="",$G(ORD),$P($G(^PS(52.41,ORD,"EXT")),"^")'="" D SIGS^PSOHCPRS
.S INST=0 F S INST=$O(SIG(INST)) Q:'INST S MIG=SIG(INST) D
..F SG=1:1:$L(MIG," ") W:$X+$L($P(MIG," ",SG)_" ")>IOM !?14 W $P(MIG," ",SG)_" "
K SG,INST,MIG
S ROU="PSOORED4",II=ENT D ASK^PSOBKDED K ROU,II I $G(JUMP) K JUMP G JUMP
G:$D(DIRUT) EXQ
;
I $G(VERB)]"" S PSORXED("VERB",ENT)=VERB G DUPD
VER D VER^PSOOREDX I X[U,$L(X)>1 S FIELD="VER" G JUMP
G:$D(DTOUT)!($D(DUOUT)) EXQ
I X="@" K PSORXED("VERB",ENT),VERB G DUPD
S:X'="" (PSORXED("VERB",ENT),VERB)=X
DUPD ;
I $G(PSORXED("DOSE",ENT))'?.N&($G(PSORXED("DOSE",ENT))'?.N1".".N)!'DOSE("LD") K PSORXED("DOSE ORDERED",ENT),DUPD G NOU1
D DUPD^PSOOREDX
S DIR("B")=$S($G(PSORXED("DOSE ORDERED",ENT))]"":PSORXED("DOSE ORDERED",ENT),1:1) S:$E($G(DIR("B")),1)="." DIR("B")="0"_$G(DIR("B")) K:DIR("B")="" DIR("B")
D ^DIR I X[U,$L(X)>1 S FIELD="DUPD" G JUMP
G:$D(DTOUT)!($D(DUOUT)) EXQ
I X="@"!(X=0) W !,"Dispense Units Per Dose is Required!!",! G DUPD
D STR^PSOOREDX
NOU1 G:'$G(PSORXED("DOSE ORDERED",ENT)) RTE
D CNON^PSOORED3
N PSONDEF
I $G(NOUN)]"" S PSORXED("NOUN",ENT)=NOUN
NOU D NOU^PSOOREDX I X[U,$L(X)>1 S FIELD="NOU" G JUMP
G:$D(DTOUT)!($D(DUOUT)) EXQ
I X="@" K PSORXED("NOUN",ENT),NOUN G RTE
I X'="",$G(PSONDEF)="" S NOUN=X
I X'="",$G(PSONDEF)'=X S NOUN=X
S:X'="" PSORXED("NOUN",ENT)=X
;
RTE K JUMP S ROU="PSOORED4" D RTE^PSOBKDED K ROU
I $G(JUMP) K JUMP G JUMP
G:$D(DTOUT)!($D(DUOUT)) EXQ
;
SCH D SCH^PSOBKDED I X[U,$L(X)>1 S FIELD="SCH" G JUMP
G:$D(DTOUT)!($D(DUOUT)) EXQ
S SCH=Y D SCH^PSOSIG I $G(SCH)']"" G SCH
S PSORXED("SCHEDULE",ENT)=SCH W " ("_SCHEX_")" K SCH,SCHEX,X,Y,PSOSCH
S:PSORXED("ENT")<ENT PSORXED("ENT")=ENT
;
DUR D KV K EXP S DIR(0)="52.0113,4",DIR("A")="LIMITED DURATION (IN DAYS, HOURS OR MINUTES)"
S DIR("B")=$S($G(PSORXED("DURATION",ENT))]"":PSORXED("DURATION",ENT),1:"") K:DIR("B")="" DIR("B")
D ^DIR I X[U,$L(X)>1 S FIELD="DUR" G JUMP
G:$D(DTOUT)!($D(DUOUT)) EXQ
D DUR1^PSOOREDX
;
CON D CON^PSOOREDX I X[U,$L(X)>1 S FIELD="CON" G JUMP
G:$D(DTOUT)!($D(DUOUT)) EXQ
I X="@",$G(PSORXED("CONJUNCTION",ENT))="" W !,?10,"Invalid Entry - nothing to delete!!" G CON
S:X'=""&(X'="@") PSORXED("CONJUNCTION",ENT)=Y
I X="@",$D(PSORXED("CONJUNCTION",ENT)) D CON1^PSOOREDX G:$D(DIRUT) EXQ G:'Y CON N CKX S CKX=1 D UPD^PSOOREDX G CON
I $G(PSORXED("CONJUNCTION",ENT))]"" S ENT=ENT+1 K DIR G ASK
S X=$G(PSORXED("INS")) D SIG^PSOHELP S:$G(INS1)]"" PSORXED("SIG")=$E(INS1,2,9999999)
D EN^PSOFSIG(.PSORXED),VERI I $G(CKX),'$G(PSOSIGFL) D MP1 K CKX
I $G(PSOSIGFL)=1 S PSORXED("ENT")=ENT,SIGOK=1,VALMSG="This change will create a new prescription!",NCPDPFLG=1
K QTYHLD S:$G(PSORXED("QTY")) QTYHLD=PSORXED("QTY") D QTY^PSOSIG(.PSORXED) I $G(PSORXED("QTY")) S QTY=1
I $G(QTYHLD),'$G(PSORXED("QTY")) S PSORXED("QTY")=QTYHLD
K QTYHLD
I '$G(PSORXED("QTY")),$P(OR0,"^",10) S PSORXED("QTY")=$P(OR0,"^",10)
EX ;
K PSOBDR,PSOBDRG,PSOSCH,DUPD,STRE,UNITN,SCH,VERB,NOUN,DOSEOR,RTE,DUR,X,Y,ENTS,PSODOSE,OLENT,FIELD,FLDNM,AR,NM,ENT,STRE,UNITN,PSODOSE,ERTE,ROU
KV K DTOUT,DUOUT,DIR,DIRUT
Q
EXQ ;
K PSORXED,PSOSIGFL M PSORXED=PSODOSE D EN^PSOFSIG(.PSORXED) D MP1
I $D(PSOBDR) M PSODRUG=PSOBDR K PSOBDR,PSOBDRG
G EX Q
MP1 D MP1^PSOOREDX
Q
VERI ;checks for changes to dosing instructions
S ENTS=0
F I=0:0 S I=$O(PSORXED("DOSE",I)) Q:'I S ENTS=$G(ENTS)+1
I ENTS<OLENT!(ENTS>OLENT) S PSOSIGFL=1 Q
F I=1:1:OLENT D
.I PSODOSE("DOSE",I)'=$G(PSORXED("DOSE",I)) S PSOSIGFL=1
.I $G(PSODOSE("DURATION",I))]"" D
..S DURATION=$S($E(PSODOSE("DURATION",I),1)'?.N:$E(PSODOSE("DURATION",I),2,99)_$E(PSODOSE("DURATION",I),1),1:PSODOSE("DURATION",I))
..I +DURATION'=+$G(PSORXED("DURATION",I)) S PSOSIGFL=1
.I $G(PSODOSE("CONJUNCTION",I))'=$G(PSORXED("CONJUNCTION",I)) S PSOSIGFL=1
.I PSODOSE("ROUTE",I)'=$G(PSORXED("ROUTE",I)) S PSOSIGFL=1
.I PSODOSE("SCHEDULE",I)'=$G(PSORXED("SCHEDULE",I)) S PSOSIGFL=1
K DURATION Q
JUMP ;jump to fields
I $L($E(X,2,99))<3 W !,"Field Name Must Be At Least 3 Characters in Length",! G @FIELD
D FNM^PSOOREDX
I FLDNM']"" K X,NM,FLDNM W !,"INVALID FIELD NAME. PLEASE TRY AGAIN!",! G @FIELD
F AR=1:1:PSORXED("ENT") W !,AR_". "_$P(FLDNM,"^",2)_": "_$S(NM="ROU"&($G(PSORXED($P(FLDNM,"^"),AR))):$P(^PS(51.2,PSORXED($P(FLDNM,"^"),AR),0),"^"),1:$G(PSORXED($P(FLDNM,"^"),AR))) S AR1=AR
D KV S DIR("A",1)="* Indicates which fields will create a New Order",DIR("A")="Select Field to Edit by number",DIR(0)="NO^1:"_AR1 D ^DIR G:$D(DIRUT) @FIELD
D JFN^PSOOREDX G:FLDNM="" @FIELD G @FLDNM
G EX
Q
HLP ;help text for med route
D FULL^VALM1 W !,"Please enter how patient will use the medication!"
S DIC=51.2,X="??",DIC(0)="M",DIC("S")="I $P(^PS(51.2,+Y,0),""^"",4)" D ^DIC K DIC,X,Y
Q
SCHLP ;
D FULL^VALM1 W !,"You can choose an entry from the Administration Schedule File (#51.1),",!,"Medication Instruction File (#51) or enter free text."
W !,"The free text entry cannot contain more than 2 spaces or be greater than 20",!,"characters in length."
W ! S DIR(0)="S^A:Administration Schedule File;M:Medication Instruction File;B:Both;F:Free Text",DIR("B")="Both"
S DIR("A")="Do you want to list from" D ^DIR I Y="F"!($G(DIRUT)) K X,Y G X
S LBL=Y G @LBL
A ;display 51.1 entries only
B K X,Y,DIC S X="??",DIC="^PS(51.1,",DIC(0)="QES",DIC("W")="D DICW^PSOORED4",D="APPSJ" W ! D IX^DIC
K DIC,X I LBL="A"!($G(DTOUT)) K LBL G X
I Y=-1!($G(DUOUT)) K DIR,DTOUT,DUOUT S DIR(0)="Y",DIR("B")="No",DIR("A")="Do you want to continue with the Medication Instruction File"
D ^DIR I 'Y!($G(DTOUT)) K DIR,X,Y G X
M K X,Y,DIC S DIC=51,X="??",DIC(0)="M" D ^DIC K DIC,X,Y,DTOUT,DUOUT,LBL
X S DIR("?")="^D SCHLP^PSOORED4",DIR("A")="Schedule: ",DIR(0)="FA^1:20^I X[""""""""!(X?.E1C.E)!($A(X)=45)!($L(X,"" "")>3)!($L(X)>20)!($L(X)<1) K X"
S DIR("B")=$S($D(PSOSCH)&('$D(PSORXED("SCHEDULE",ENT))):PSOSCH,$G(PSORXED("SCHEDULE",ENT))]"":PSORXED("SCHEDULE",ENT),1:"") K:DIR("B")="" DIR("B")
Q
DICW ;
S Z=$P(^PS(51.1,+Y,0),"^",5),Z=$S(Z="O":-1,Z="S":1,Z="R":-2,1:0) W:Z " ",$S(Z>0:"SHIFT",Z=-2:"RANGE",1:"ONE-TIME")
I Z'<0,$D(PSJW),$D(^(PSJPP'="PSJ"+1,PSJW,0)),$P(^(0),"^",Z+2)]"" W " ",$P(^(0),"^",Z+2)
;Naked reference on DICW+2 is from DICW+1, ^PS(51.1,+Y,0)
Q
PSOORED4 ;BIR/SAB - Edit front door dosing ;07/13/00
+1 ;;7.0;OUTPATIENT PHARMACY;**46,91,78,99,111,117,133,159,148**;DEC 1997
+2 ;External reference ^PS(51 supported by DBIA 2224
+3 ;External reference to PS(51.2 supported by DBIA 2226
+4 ;External reference to PS(51.1 supported by DBIA 2225
+5 ;called from psoornew
+6 ;
DOSE(PSORXED) ;
+1 IF '$GET(PSODRUG("IEN"))
WRITE !,"DRUG NAME REQUIRED!"
DO 2^PSOORNW1
IF '$GET(PSODRUG("IEN"))
SET VALMSG="No Dispense Drug Selected"
QUIT
+2 KILL ROU,STRE,UNITN,PSODOSE
MERGE PSODOSE=PSORXED
+3 DO KV
KILL FIELD,DOSEOR,DUPD,X,Y,UNITS
SET ENT=1
SET OLENT=PSORXED("ENT")
ASK IF $GET(ORD)
WRITE !!,"Possible SIG: "
Begin DoDot:1
+1 ;Coded only for outside orders with no Patient Instructions
+2 IF $ORDER(SIG(""))=""
IF $GET(ORD)
IF $PIECE($GET(^PS(52.41,ORD,"EXT")),"^")'=""
DO SIGS^PSOHCPRS
+3 SET INST=0
FOR
SET INST=$ORDER(SIG(INST))
IF 'INST
QUIT
SET MIG=SIG(INST)
Begin DoDot:2
+4 FOR SG=1:1:$LENGTH(MIG," ")
IF $X+$LENGTH($PIECE(MIG," ",SG)_" ")>IOM
WRITE !?14
WRITE $PIECE(MIG," ",SG)_" "
End DoDot:2
End DoDot:1
+5 KILL SG,INST,MIG
+6 SET ROU="PSOORED4"
SET II=ENT
DO ASK^PSOBKDED
KILL ROU,II
IF $GET(JUMP)
KILL JUMP
GOTO JUMP
+7 IF $DATA(DIRUT)
GOTO EXQ
+8 ;
+9 IF $GET(VERB)]""
SET PSORXED("VERB",ENT)=VERB
GOTO DUPD
VER DO VER^PSOOREDX
IF X[U
IF $LENGTH(X)>1
SET FIELD="VER"
GOTO JUMP
+1 IF $DATA(DTOUT)!($DATA(DUOUT))
GOTO EXQ
+2 IF X="@"
KILL PSORXED("VERB",ENT),VERB
GOTO DUPD
+3 IF X'=""
SET (PSORXED("VERB",ENT),VERB)=X
DUPD ;
+1 IF $GET(PSORXED("DOSE",ENT))'?.N&($GET(PSORXED("DOSE",ENT))'?.N1".".N)!'DOSE("LD")
KILL PSORXED("DOSE ORDERED",ENT),DUPD
GOTO NOU1
+2 DO DUPD^PSOOREDX
+3 SET DIR("B")=$SELECT($GET(PSORXED("DOSE ORDERED",ENT))]"":PSORXED("DOSE ORDERED",ENT),1:1)
IF $EXTRACT($GET(DIR("B")),1)="."
SET DIR("B")="0"_$GET(DIR("B"))
IF DIR("B")=""
KILL DIR("B")
+4 DO ^DIR
IF X[U
IF $LENGTH(X)>1
SET FIELD="DUPD"
GOTO JUMP
+5 IF $DATA(DTOUT)!($DATA(DUOUT))
GOTO EXQ
+6 IF X="@"!(X=0)
WRITE !,"Dispense Units Per Dose is Required!!",!
GOTO DUPD
+7 DO STR^PSOOREDX
NOU1 IF '$GET(PSORXED("DOSE ORDERED",ENT))
GOTO RTE
+1 DO CNON^PSOORED3
+2 NEW PSONDEF
+3 IF $GET(NOUN)]""
SET PSORXED("NOUN",ENT)=NOUN
NOU DO NOU^PSOOREDX
IF X[U
IF $LENGTH(X)>1
SET FIELD="NOU"
GOTO JUMP
+1 IF $DATA(DTOUT)!($DATA(DUOUT))
GOTO EXQ
+2 IF X="@"
KILL PSORXED("NOUN",ENT),NOUN
GOTO RTE
+3 IF X'=""
IF $GET(PSONDEF)=""
SET NOUN=X
+4 IF X'=""
IF $GET(PSONDEF)'=X
SET NOUN=X
+5 IF X'=""
SET PSORXED("NOUN",ENT)=X
+6 ;
RTE KILL JUMP
SET ROU="PSOORED4"
DO RTE^PSOBKDED
KILL ROU
+1 IF $GET(JUMP)
KILL JUMP
GOTO JUMP
+2 IF $DATA(DTOUT)!($DATA(DUOUT))
GOTO EXQ
+3 ;
SCH DO SCH^PSOBKDED
IF X[U
IF $LENGTH(X)>1
SET FIELD="SCH"
GOTO JUMP
+1 IF $DATA(DTOUT)!($DATA(DUOUT))
GOTO EXQ
+2 SET SCH=Y
DO SCH^PSOSIG
IF $GET(SCH)']""
GOTO SCH
+3 SET PSORXED("SCHEDULE",ENT)=SCH
WRITE " ("_SCHEX_")"
KILL SCH,SCHEX,X,Y,PSOSCH
+4 IF PSORXED("ENT")<ENT
SET PSORXED("ENT")=ENT
+5 ;
DUR DO KV
KILL EXP
SET DIR(0)="52.0113,4"
SET DIR("A")="LIMITED DURATION (IN DAYS, HOURS OR MINUTES)"
+1 SET DIR("B")=$SELECT($GET(PSORXED("DURATION",ENT))]"":PSORXED("DURATION",ENT),1:"")
IF DIR("B")=""
KILL DIR("B")
+2 DO ^DIR
IF X[U
IF $LENGTH(X)>1
SET FIELD="DUR"
GOTO JUMP
+3 IF $DATA(DTOUT)!($DATA(DUOUT))
GOTO EXQ
+4 DO DUR1^PSOOREDX
+5 ;
CON DO CON^PSOOREDX
IF X[U
IF $LENGTH(X)>1
SET FIELD="CON"
GOTO JUMP
+1 IF $DATA(DTOUT)!($DATA(DUOUT))
GOTO EXQ
+2 IF X="@"
IF $GET(PSORXED("CONJUNCTION",ENT))=""
WRITE !,?10,"Invalid Entry - nothing to delete!!"
GOTO CON
+3 IF X'=""&(X'="@")
SET PSORXED("CONJUNCTION",ENT)=Y
+4 IF X="@"
IF $DATA(PSORXED("CONJUNCTION",ENT))
DO CON1^PSOOREDX
IF $DATA(DIRUT)
GOTO EXQ
IF 'Y
GOTO CON
NEW CKX
SET CKX=1
DO UPD^PSOOREDX
GOTO CON
+5 IF $GET(PSORXED("CONJUNCTION",ENT))]""
SET ENT=ENT+1
KILL DIR
GOTO ASK
+6 SET X=$GET(PSORXED("INS"))
DO SIG^PSOHELP
IF $GET(INS1)]""
SET PSORXED("SIG")=$EXTRACT(INS1,2,9999999)
+7 DO EN^PSOFSIG(.PSORXED)
DO VERI
IF $GET(CKX)
IF '$GET(PSOSIGFL)
DO MP1
KILL CKX
+8 IF $GET(PSOSIGFL)=1
SET PSORXED("ENT")=ENT
SET SIGOK=1
SET VALMSG="This change will create a new prescription!"
SET NCPDPFLG=1
+9 KILL QTYHLD
IF $GET(PSORXED("QTY"))
SET QTYHLD=PSORXED("QTY")
DO QTY^PSOSIG(.PSORXED)
IF $GET(PSORXED("QTY"))
SET QTY=1
+10 IF $GET(QTYHLD)
IF '$GET(PSORXED("QTY"))
SET PSORXED("QTY")=QTYHLD
+11 KILL QTYHLD
+12 IF '$GET(PSORXED("QTY"))
IF $PIECE(OR0,"^",10)
SET PSORXED("QTY")=$PIECE(OR0,"^",10)
EX ;
+1 KILL PSOBDR,PSOBDRG,PSOSCH,DUPD,STRE,UNITN,SCH,VERB,NOUN,DOSEOR,RTE,DUR,X,Y,ENTS,PSODOSE,OLENT,FIELD,FLDNM,AR,NM,ENT,STRE,UNITN,PSODOSE,ERTE,ROU
KV KILL DTOUT,DUOUT,DIR,DIRUT
+1 QUIT
EXQ ;
+1 KILL PSORXED,PSOSIGFL
MERGE PSORXED=PSODOSE
DO EN^PSOFSIG(.PSORXED)
DO MP1
+2 IF $DATA(PSOBDR)
MERGE PSODRUG=PSOBDR
KILL PSOBDR,PSOBDRG
+3 GOTO EX
QUIT
MP1 DO MP1^PSOOREDX
+1 QUIT
VERI ;checks for changes to dosing instructions
+1 SET ENTS=0
+2 FOR I=0:0
SET I=$ORDER(PSORXED("DOSE",I))
IF 'I
QUIT
SET ENTS=$GET(ENTS)+1
+3 IF ENTS<OLENT!(ENTS>OLENT)
SET PSOSIGFL=1
QUIT
+4 FOR I=1:1:OLENT
Begin DoDot:1
+5 IF PSODOSE("DOSE",I)'=$GET(PSORXED("DOSE",I))
SET PSOSIGFL=1
+6 IF $GET(PSODOSE("DURATION",I))]""
Begin DoDot:2
+7 SET DURATION=$SELECT($EXTRACT(PSODOSE("DURATION",I),1)'?.N:$EXTRACT(PSODOSE("DURATION",I),2,99)_$EXTRACT(PSODOSE("DURATION",I),1),1:PSODOSE("DURATION",I))
+8 IF +DURATION'=+$GET(PSORXED("DURATION",I))
SET PSOSIGFL=1
End DoDot:2
+9 IF $GET(PSODOSE("CONJUNCTION",I))'=$GET(PSORXED("CONJUNCTION",I))
SET PSOSIGFL=1
+10 IF PSODOSE("ROUTE",I)'=$GET(PSORXED("ROUTE",I))
SET PSOSIGFL=1
+11 IF PSODOSE("SCHEDULE",I)'=$GET(PSORXED("SCHEDULE",I))
SET PSOSIGFL=1
End DoDot:1
+12 KILL DURATION
QUIT
JUMP ;jump to fields
+1 IF $LENGTH($EXTRACT(X,2,99))<3
WRITE !,"Field Name Must Be At Least 3 Characters in Length",!
GOTO @FIELD
+2 DO FNM^PSOOREDX
+3 IF FLDNM']""
KILL X,NM,FLDNM
WRITE !,"INVALID FIELD NAME. PLEASE TRY AGAIN!",!
GOTO @FIELD
+4 FOR AR=1:1:PSORXED("ENT")
WRITE !,AR_". "_$PIECE(FLDNM,"^",2)_": "_$SELECT(NM="ROU"&($GET(PSORXED($PIECE(FLDNM,"^"),AR))):$PIECE(^PS(51.2,PSORXED($PIECE(FLDNM,"^"),AR),0),"^"),1:$GET(PSORXED($PIECE(FLDNM,"^"),AR)))
SET AR1=AR
+5 DO KV
SET DIR("A",1)="* Indicates which fields will create a New Order"
SET DIR("A")="Select Field to Edit by number"
SET DIR(0)="NO^1:"_AR1
DO ^DIR
IF $DATA(DIRUT)
GOTO @FIELD
+6 DO JFN^PSOOREDX
IF FLDNM=""
GOTO @FIELD
GOTO @FLDNM
+7 GOTO EX
+8 QUIT
HLP ;help text for med route
+1 DO FULL^VALM1
WRITE !,"Please enter how patient will use the medication!"
+2 SET DIC=51.2
SET X="??"
SET DIC(0)="M"
SET DIC("S")="I $P(^PS(51.2,+Y,0),""^"",4)"
DO ^DIC
KILL DIC,X,Y
+3 QUIT
SCHLP ;
+1 DO FULL^VALM1
WRITE !,"You can choose an entry from the Administration Schedule File (#51.1),",!,"Medication Instruction File (#51) or enter free text."
+2 WRITE !,"The free text entry cannot contain more than 2 spaces or be greater than 20",!,"characters in length."
+3 WRITE !
SET DIR(0)="S^A:Administration Schedule File;M:Medication Instruction File;B:Both;F:Free Text"
SET DIR("B")="Both"
+4 SET DIR("A")="Do you want to list from"
DO ^DIR
IF Y="F"!($GET(DIRUT))
KILL X,Y
GOTO X
+5 SET LBL=Y
GOTO @LBL
A ;display 51.1 entries only
B KILL X,Y,DIC
SET X="??"
SET DIC="^PS(51.1,"
SET DIC(0)="QES"
SET DIC("W")="D DICW^PSOORED4"
SET D="APPSJ"
WRITE !
DO IX^DIC
+1 KILL DIC,X
IF LBL="A"!($GET(DTOUT))
KILL LBL
GOTO X
+2 IF Y=-1!($GET(DUOUT))
KILL DIR,DTOUT,DUOUT
SET DIR(0)="Y"
SET DIR("B")="No"
SET DIR("A")="Do you want to continue with the Medication Instruction File"
+3 DO ^DIR
IF 'Y!($GET(DTOUT))
KILL DIR,X,Y
GOTO X
M KILL X,Y,DIC
SET DIC=51
SET X="??"
SET DIC(0)="M"
DO ^DIC
KILL DIC,X,Y,DTOUT,DUOUT,LBL
X SET DIR("?")="^D SCHLP^PSOORED4"
SET DIR("A")="Schedule: "
SET DIR(0)="FA^1:20^I X[""""""""!(X?.E1C.E)!($A(X)=45)!($L(X,"" "")>3)!($L(X)>20)!($L(X)<1) K X"
+1 SET DIR("B")=$SELECT($DATA(PSOSCH)&('$DATA(PSORXED("SCHEDULE",ENT))):PSOSCH,$GET(PSORXED("SCHEDULE",ENT))]"":PSORXED("SCHEDULE",ENT),1:"")
IF DIR("B")=""
KILL DIR("B")
+2 QUIT
DICW ;
+1 SET Z=$PIECE(^PS(51.1,+Y,0),"^",5)
SET Z=$SELECT(Z="O":-1,Z="S":1,Z="R":-2,1:0)
IF Z
WRITE " ",$SELECT(Z>0:"SHIFT",Z=-2:"RANGE",1:"ONE-TIME")
+2 IF Z'<0
IF $DATA(PSJW)
IF $DATA(^(PSJPP'="PSJ"+1,PSJW,0))
IF $PIECE(^(0),"^",Z+2)]""
WRITE " ",$PIECE(^(0),"^",Z+2)
+3 ;Naked reference on DICW+2 is from DICW+1, ^PS(51.1,+Y,0)
+4 QUIT
