PSODIR1 ;IHS/DSD - ASKS DATA FOR RX ORDER ENTRY CONT. ;7 Jan 2020 16:58:09
;;7.0;OUTPATIENT PHARMACY;**23,46,78,102,121,131,146,166,184,222,268,206,266,340,391,444,446,505,543,457,574,612,686,700**;DEC 1997;Build 261
;External reference ^PS(55 supported by DBIA 2228
;External reference ^PSDRUG( supported by DBIA 221
;External reference $$MXDAYSUP^PSSUTIL1 supported by DBIA 6229
;External reference $$HTFM^XLFDT supported by DBIA 10103
; Reference to $$ISCLOZ^PSJCLOZ in ICR #7176
;
PTSTAT(PSODIR) ;
PTSTATEN K DIC,DR,DIE S PSODIR("FIELD")=0
I $G(PSOTPBFG),$G(PSOFROM)="NEW" K PSORX("PATIENT STATUS"),PSODIR("PATIENT STATUS") N PSOFNDRX,PSOFNDFL,PSOFNDPS D
. S PSOFNDFL=0 F PSOFNDPS=0:0 S PSOFNDPS=$O(^PS(53,PSOFNDPS)) Q:'PSOFNDPS!(PSOFNDFL) D
.. S PSOFNDRX=$P($G(^PS(53,PSOFNDPS,0)),"^") S PSOFNDRX=$$UP^XLFSTR(PSOFNDRX) I PSOFNDRX="NON-VA" S PSOFNDFL=1 S (PSORX("PATIENT STATUS"),DIC("B"))=$P($G(^PS(53,PSOFNDPS,0)),"^")
I $G(PSOTPBFG),$G(PSOFROM)="NEW",$G(PSORX("PATIENT STATUS"))="" W !,"Could not find a 'NON-VA' Patient Status in the RX PATIENT STATUS file (#53)!" D PSTPB D S PSODIR("DFLG")=1 G PTSTATX
. K DIR S DIR(0)="E",DIR("A")="Press Return to continue" D ^DIR K DIR
I $G(PSOTPBFG),$G(PSOFROM)="NEW" G TPBB
N PSOX
S PSOX=$G(^PS(55,PSODFN,"PS")) I PSOX]"" S PSORX("PATIENT STATUS")=$P($G(^PS(53,PSOX,0)),"^"),DIC("B")=PSORX("PATIENT STATUS")
S:$G(PSODIR("PATIENT STATUS"))]"" DIC("B")=PSODIR("PATIENT STATUS")
TPBB ;
D ELIG^VADPT W !,"Eligibility: "_$P(VAEL(1),"^",2)_$S(+VAEL(3):" SC%: "_$P(VAEL(3),"^",2),1:"")
S N=0 F S N=$O(VAEL(1,N)) Q:'N W !,?10,$P(VAEL(1,N),"^",2)
S DIC("A")="RX PATIENT STATUS: "
S DIC(0)="QEAMZ",DIC=53 D ^DIC K DIC
I $G(PSOTPBFG),$G(PSOFROM)="NEW" N PSOPSDIR,PSOFNDZZ,PSOPSUPA S (PSOPSDIR,PSOPSUPA)=0 D I PSOPSDIR S:PSOPSUPA PSODIR("DFLG")=1 G:PSOPSUPA PTSTATX W ! D PSTPB G PTSTATEN
. I Y'>0!($D(DTOUT))!($D(DUOUT)) S (PSOPSDIR,PSOPSUPA)=1 Q
. S (PSODIR("PATIENT STATUS"),PSORX("PATIENT STATUS"))=+Y,PSODIR("PTST NODE")=Y(0)
. S PSOFNDZZ=$P($G(^PS(53,+Y,0)),"^") S PSOFNDZZ=$$UP^XLFSTR(PSOFNDZZ) I PSOFNDZZ'="NON-VA" S PSOPSDIR=1 K PSODIR("PATIENT STATUS"),PSORX("PATIENT STATUS"),PSODIR("PTST NODE")
I $G(PSOTPBFG),$G(PSOFROM)="NEW" G TPBSC
I X[U,$L(X)>1 D:'$G(PSOEDIT) JUMP G PTSTATX
I $D(DUOUT)!$D(DTOUT) S PSODIR("DFLG")=1 G PTSTATX
I Y=-1 W $C(7)," Required" G PTSTATEN
N PSOFNDX,PSOFNDXY,PSOFNDXX,PSOFNDYY
S PSOFNDXY=$G(Y),PSOFNDYY=$G(Y(0))
I '$G(PSOTPBFG),$G(PSOFROM)="NEW" S PSOFNDX=$P($G(^PS(53,+Y,0)),"^") S PSOFNDXX=$$UP^XLFSTR(PSOFNDX) I PSOFNDXX="NON-VA" K PSOFNDX,PSOFNDXY,PSOFNDYY,PSOFNDXX,Y W !!,"Cannot select 'NON-VA' Rx Patient Status!",! G PTSTATEN
S Y=$G(PSOFNDXY),Y(0)=$G(PSOFNDYY)
K PSOFNDXY,PSOFNDYY,PSOFNDX,PSOFNDXX
S (PSODIR("PATIENT STATUS"),PSORX("PATIENT STATUS"))=+Y
S PSODIR("PTST NODE")=Y(0)
TPBSC ;
I $G(PSOFDR),$P($G(OR0),"^",17)="C" G PTSTATX
L +^PS(55,PSODFN):$S(+$G(^DD("DILOCKTM"))>0:+^DD("DILOCKTM"),1:3) I '$T G PTSTATX
S DIE="55",DR="3////"_+Y,DA=PSODFN D ^DIE K DIE,DA,D0
L -^PS(55,PSODFN)
PTSTATX ;
K DTOUT,DUOUT,X,Y,DA Q
;
SIG(PSODIR) ;
I $G(PSOFDR),$G(PSODIR("SIG"))']"" D SIGOK G:$G(SIGOK)!($G(PSODIR("DFLG"))) SIGX
K DIR,DIC
S DIR(0)="52,10"
S:$G(PSODRUG("SIG"))]"" DIR("B")=PSODRUG("SIG")
S:$G(PSODIR("SIG"))]"" DIR("B")=PSODIR("SIG")
D DIR G:PSODIR("DFLG")!PSODIR("FIELD") SIGX
S PSODIR("SIG")=Y,SIGOK=0 K SIG
SIGX ;
K X,Y Q
;
QTY(PSODIR) ;
QTYA K DIR,DIC N RFL,RXIEN
I $G(CLOZPAT)=1 S DIR("A",1)="Patient Eligible for 14 day supply or 7 day supply with 1 refill"
I $G(CLOZPAT)=2 S DIR("A",1)="Patient Eligible 28 day supply or 14 day supply with 1 refill or 7 day supply with 3 refill"
S DIR(0)="52,7" S:$G(PSODRUG("IEN")) DIR("A")="QTY ( "_$G(PSODRUG("UNIT"))_" ) "_$S($P($G(^PSDRUG(+PSODRUG("IEN"),5)),"^")]"":$P(^PSDRUG(+PSODRUG("IEN"),5),"^"),1:"")
K QTYHLD I $G(PSODIR("QTY"))]"" S QTYHLD=PSODIR("QTY") K PSODIR("QTY")
D:'$G(PSOQTY) QTY^PSOSIG(.PSODIR)
I '$G(SPEED),$G(QTYHLD),'$G(PSODIR("QTY")) S PSODIR("QTY")=QTYHLD
K QTYHLD K:'$G(PSODIR("QTY")) PSODIR("QTY")
I $G(SPEED),$G(PSODIR("QTY"))']"" S PSODIR("QTY")=$P(^PSRX(PSORENW("OIRXN"),0),"^",7)
S:$G(PSODIR("QTY"))]"" DIR("B")=PSODIR("QTY")
; JCH - PSO*7.0*612 - BEGIN
I $G(CLOZPAT)>0 I $D(^XTMP("PSJ4D-"_+$G(PSODFN)))!$D(^XTMP("PSO4D-"_+$G(PSODFN))) K DIR("A",1)
; JCH - PSO*7.0*612 - END
D DIR
;/BLB/ PSO*7.0*505 ;MODIFIED QTY CHECK TO ALLOW LEADING ZEROS
I Y[".",$P(Y,".")<1 S Y="0"_"."_$P(Y,".",2)
G:PSODIR("DFLG")!PSODIR("FIELD") QTYX
I $G(Y),$G(PSODRUG("MAXDOSE"))]"",$G(PSODIR("DAYS SUPPLY")),(Y/+PSODIR("DAYS SUPPLY")>PSODRUG("MAXDOSE")) D G:$G(PSODIR("DFLG")) QTYX G QTYA
. W !,$C(7)," Greater than Maximum dose of "_PSODRUG("MAXDOSE")_" per day" D DAYSEN
I $G(PSOFDR),$P($G(OR0),"^",24),$G(PSODIR("QTY")),+Y>$G(PSODIR("QTY")) D G QTYX
. W !!,"Digitally Signed Order - QTY cannot be increased",!
. N DIR S DIR(0)="E",DIR("A")="Press Return to Continue" D ^DIR W !
S PSODIR("QTY")=Y
;
QTYX ;
K X,Y Q
;
COPIES(PSODIR) ;
K DIR,DIC
S DIR(0)="52,10.6"
S DIR("B")=$S($G(PSODIR("COPIES"))]"":PSODIR("COPIES"),1:1)
D DIR G:PSODIR("DFLG")!PSODIR("FIELD") COPIESX
S PSODIR("COPIES")=Y
COPIESX ;
K X,Y Q
;
DAYS(PSODIR) ;
DAYSEN K DIR,DIC N PSORFLS
;PSO*7*266
N S2DS,MXDAYSUP,DFDAYSUP,PSDAYSUP,CSDRUG,NEWTOTDS,PSOREGN S S2DS=0
S MXDAYSUP=90,CSDRUG=0
I $D(PSODRUG("IEN")) D
. S MXDAYSUP=$$MXDAYSUP^PSSUTIL1(PSODRUG("IEN"))
. S S2DS=$$CSDS^PSOSIGDS(PSODRUG("IEN")) I S2DS,$P($G(PSODIR("PTST NODE")),"^",3)>29 S S2DS=30
. S PSORFLS=$S($G(PSODIR("# OF REFILLS")):PSODIR("# OF REFILLS"),1:$P($G(PSODIR("RX0")),"^",9))
. I '$D(PSODRUG("DEA")) S PSODRUG("DEA")=$$GET1^DIQ(50,PSODRUG("IEN"),3,"")
. I (PSODRUG("DEA")["2")!(PSODRUG("DEA")["3")!(PSODRUG("DEA")["4")!(PSODRUG("DEA")["5") S CSDRUG=1
S PSOREGN="" ;p457
I $$ISCLOZ^PSJCLOZ(,,,,$G(PSODRUG("IEN"))) S PSOREGN=$$GET1^DIQ(55,PSODFN,53) ;p457
;S PSOREGN=$$GET1^DIQ(55,PSODFN,53) p457 commented out
S PSDAYSUP=$S(PSOREGN?1U6N!$D(^TMP($J,"CLOZFLG",PSODFN)):4,$G(CLOZPAT)=2:28,$G(CLOZPAT)=1:14,$G(CLOZPAT)=0:7,1:MXDAYSUP)
I (PSOREGN?2U5N)&($$GET1^DIQ(50,+$G(PSODRUG("IEN")),17.5)="PSOCLO1") D
. I $P($G(^XTMP("PSO4D-"_PSODFN,"PSOYS")),"^",4)'>0,($P($G(^XTMP("PSO4D-"_PSODFN,0)),"^",1))>$$HTFM^XLFDT($H,1) D
.. ;Begin: JCH - PSO*7*612
.. N PSOCLZN,PSOYSIEN,PSOCLODT S PSOCLZN=$$GET1^DIQ(55,PSODFN,53)
.. I PSOCLZN?2U5N S PSOYSIEN=$$FIND1^DIC(603.01,,"Q",PSOCLZN,"B") I PSOYSIEN S PSOCLODT=$$GET1^DIQ(603.01,+PSOYSIEN,3,"I") I (PSOCLODT=$$DT^XLFDT) Q
.. ;End: JCH - PSO*7*612
.. S PSDAYSUP=4 ; Special condition local override if no ANC results
S DIR(0)="N^1:"_PSDAYSUP
S DFDAYSUP=$S($D(CLOZPAT)&('$G(PSODIR("DAYS SUPPLY"))):7,$G(PSODIR("DAYS SUPPLY"))]"":PSODIR("DAYS SUPPLY"),S2DS>1:S2DS,$P($G(PSODIR("PTST NODE")),"^",3):$P(PSODIR("PTST NODE"),"^",3),1:30)
I DFDAYSUP>MXDAYSUP D S DFDAYSUP=MXDAYSUP
. W:$G(PSODIR("DAYS SUPPLY")) !!,$C(7),"Invalid DAYS SUPPLY value (",DFDAYSUP,"), resetting it to ",MXDAYSUP," (maximum allowed).",!
S DIR("B")=DFDAYSUP
S DIR("A")="DAYS SUPPLY",DIR("?")="Enter a whole number between 1 and "_PSDAYSUP
D DIR G:PSODIR("DFLG")!PSODIR("FIELD") DAYSX
I $G(Y),$G(PSODRUG("MAXDOSE"))]"",$G(PSODIR("QTY"))]"",(+PSODIR("QTY")/Y>PSODRUG("MAXDOSE")) D G DAYSEN
.W !,$C(7)," Greater than Maximum dose of "_PSODRUG("MAXDOSE")_" per day"
I $G(PSOFDR),$P($G(OR0),"^",24),$G(PSODIR("DAYS SUPPLY")),+Y>$G(PSODIR("DAYS SUPPLY")) D G DAYSX
. W !!,"Digitally Signed Order - Days Supply cannot be increased",!
. N DIR S DIR(0)="E",DIR("A")="Press Return to Continue" D ^DIR W !
I $G(PSONEW("FLD"))=8,PSODIR("DAYS SUPPLY")=Y Q
S:$G(PSODIR("DAYS SUPPLY")) PSODIR("DAYS SUPPLY OLD")=PSODIR("DAYS SUPPLY")
S PSODIR("DAYS SUPPLY")=Y
; Checking the # Of Refills field value after the Days Supply field was edited
I $D(PSODRUG("IEN")),$G(Y),$G(Y)>$S(PSORFLS<4:90,PSORFLS<6:89,PSORFLS<12:60,1:0) D
. N PTST
. S PTST=+$G(PSODIR("PATIENT STATUS")) S:'PTST PTST=$P($G(PSODIR("RX0")),"^",3)
. I 'PTST,$G(PSODFN) S PTST=+$G(^PS(55,PSODFN,"PS"))
. I PSORFLS>$$MAXNUMRF^PSOUTIL(PSODRUG("IEN"),Y,PTST,.CLOZPAT) D
.. W !,$C(7),"Invalid number of REFILLS for amount of DAYS SUPPLY.",!,"REFILL EDIT FORCED." D REFILL(.PSODIR)
.. S PSODIR("FLD",9)=PSODIR("# OF REFILLS")
S:$G(CLOZPAT)=0 (PSODIR("N# REF"),PSODIR("# OF REFILLS"))=0
D:$G(CLOZPAT)=2
. S:PSODIR("DAYS SUPPLY")=28 (PSODIR("N# REF"),PSODIR("# OF REFILLS"))=0
. S:PSODIR("DAYS SUPPLY")=14 (PSODIR("N# REF"),PSODIR("# OF REFILLS"))=1
. S:PSODIR("DAYS SUPPLY")=7 (PSODIR("N# REF"),PSODIR("# OF REFILLS"))=3
D:$G(CLOZPAT)=1
. S:PSODIR("DAYS SUPPLY")=14 (PSODIR("N# REF"),PSODIR("# OF REFILLS"))=0
. S:PSODIR("DAYS SUPPLY")=7 (PSODIR("N# REF"),PSODIR("# OF REFILLS"))=1
K QTYHLD S:$G(PSODIR("QTY")) QTYHLD=PSODIR("QTY") D QTY^PSOSIG(.PSODIR)
I $G(QTYHLD),'$G(PSODIR("QTY")) S PSODIR("QTY")=QTYHLD
K QTYHLD K:'$G(PSODIR("QTY")) PSODIR("QTY")
I $$ISCLOZ^PSJCLOZ(,,,,$G(PSODRUG("IEN"))) D EXPDT^PSOCLO1(.PSODIR,.CLOZPAT)
DAYSX ;
K X,Y Q
;
REFILL(PSODIR) ;
N PSODAYS,PSOX
S PSODAYS=+$G(PSODIR("DAYS SUPPLY"))
;Recalculating RFTT if it doesn't exist
I '$G(PSONEW) D
. N I I '$G(RFTT),$G(PSORXED("IRXN")) F I=0:0 S I=$O(^PSRX(PSORXED("IRXN"),1,I)) Q:'I S RFTT=$G(RFTT)+1
;
I $G(PSODIR("PTST NODE"))="" D
. N X,Y
. S X=$G(PSODIR("PATIENT STATUS")) I 'X,$D(RX0) S X=$P(RX0,"^",3)
. S DIC=53,DIC(0)="QXZ" D ^DIC K DIC
. S:+Y PSODIR("PTST NODE")=Y(0)
. S:'$G(PSODIR("PATIENT STATUS")) PSODIR("PATIENT STATUS")=+Y
S $P(PSODIR("PTST NODE"),"^",4)=+$P($G(PSODIR("PTST NODE")),"^",4)
I $G(OR0) G REFOR
K DIR,DIC,PSOX
; Controlled Substance
S PSODIR("CS")=0
I (PSODRUG("DEA")["2")!(PSODRUG("DEA")["3")!(PSODRUG("DEA")["4")!(PSODRUG("DEA")["5") D
. S $P(PSODIR("CS"),"^")=1 S:(PSODRUG("DEA")["2") $P(PSODIR("CS"),"^",2)=1
;
; Retrieving the Maximum Number of Refills allowed
S PSOX=$$MAXNUMRF^PSOUTIL(+$G(PSODRUG("IEN")),PSODAYS,+$G(PSODIR("PATIENT STATUS")),.CLOZPAT)
;
I '$D(CLOZPAT) I PSODRUG("DEA")["A"&(PSODRUG("DEA")'["B")!(PSODRUG("DEA")["F")!(PSODRUG("DEA")[1)!(PSODRUG("DEA")[2) D G REFILLX
. I PSODRUG("DEA")["A"&(PSODRUG("DEA")'["B")!(PSODRUG("DEA")[1)!(PSODRUG("DEA")[2)!'$O(^PSRX(+$G(PSODIR("IRXN")),1,0))!('$G(PSOLOKED)) D Q
.. S VALMSG="No refills allowed on "_$S(PSODRUG("DEA")["F":"this drug.",1:"Narcotics.") W !,VALMSG,!
.. S:$D(PSODIR("FIELD")) PSODIR("FIELD")=0 S PSODIR("# OF REFILLS")=0
. ; reset refills to the # given
. D RFRSET^PSODIR2
;
I $P($G(PSODIR("CS")),"^",2)=1 W !,"No refills allowed on Schedule 2 drugs...",! S:$D(PSODIR("FIELD")) PSODIR("FIELD")=0 S PSODIR("# OF REFILLS")=0 G REFILLX
;
;/RBN - Integration of 457 start
I $D(CLOZPAT) S PSOX=$S($G(CLOZPAT)=2&(PSODIR("DAYS SUPPLY")=14):1,$G(CLOZPAT)=2&(PSODIR("DAYS SUPPLY")=7):3,$G(CLOZPAT)=1&(PSODIR("DAYS SUPPLY")=7):1,1:0)
;/RBN - Integration of 457 end
;
;PSO*7*266 make sure PSOX is greater than RFTT
S DIR(0)="N^"_$S($G(RFTT):RFTT,1:0)_":"_$S(+$G(RFTT)>PSOX:RFTT,1:PSOX),DIR("A")="# OF REFILLS"
;PSO*7*340 Correct Default Value
S DIR("B")=$S($G(COPY)&('$G(PSOTITRX)):$G(PSODIR("# OF REFILLS")),$G(PSODIR("N# REF"))]"":PSODIR("N# REF"),$G(PSODIR("# OF REFILLS"))]"":PSODIR("# OF REFILLS"),$G(RFTT)>PSOX:RFTT,1:PSOX)
S DIR("?",1)="Enter a whole number. The maximum number of refills is based on"
S DIR("?")="the DAYS SUPPLY and the PATIENT STATUS fields."
D DIR G:PSODIR("DFLG")!PSODIR("FIELD") REFILLX
S (PSODIR("N# REF"),PSODIR("# OF REFILLS"))=Y
;
REFILLX ;
S:$G(PSODIR("# OF REFILLS"))']"" PSODIR("# OF REFILLS")=$S($G(PSODIR("N# REF"))]"":PSODIR("N# REF"),1:PSOX)
K X,Y,PSOX,DEA,PSOCS,RFTT ;PSO*7*340 Kill RFTT
Q
;OERR CALL
REFOR ;
D REFOR^PSODIR3
G REFILLX
Q
DIR ;
S (PSODIR("FIELD"),PSODIR("DFLG"))=0
G:$G(DIR(0))']"" DIRX
D ^DIR K DIR,DIE,DIC,DA
I $D(DUOUT)!($D(DTOUT))!($D(DIROUT)),$L($G(X))'>1!(Y="") S PSODIR("DFLG")=1 G DIRX
I $D(DIRUT)!($D(DIROUT)),$G(SPEED) S PSODIR("DFLG")=1 G DIRX
I $E(X,1)=U S PSODIR("DFLG")=1 G DIRX ;p686
I X[U,$L(X)>1 D JUMP
DIRX ;
K DIRUT,DTOUT,DUOUT,DIROUT Q
;
JUMP ;
I $G(PSOEDIT)!($G(OR0)) S PSODIR("DFLG")=1 Q
S X=$P(X,"^",2),DIC="^DD(52,",DIC(0)="QM" D ^DIC K DIC
I Y=-1 S PSODIR("FIELD")=PSODIR("FLD") G JUMPX
I $G(PSONEW1)=0 D JUMP^PSONEW1 G JUMPX
I $G(PSOREF1)=0 D JUMP^PSOREF1 G JUMPX
I $G(PSONEW3)=0 D JUMP^PSONEW3 G JUMPX
I $G(PSORENW3)=0 D JUMP^PSORENW3 G JUMPX
JUMPX ;
S X="^"_X Q
;
SIGOK ;review and decide on oerr sig
I '$O(SIG(0)) S SIGOK=0 Q
K SIGOK W !,"SIG: "
F SIG=0:0 S SIG=$O(SIG(SIG)) W SIG(SIG)_" ",!?5 Q:'$O(SIG(SIG))
K DIR,DIRUT,DUOUT,DTOUT S DIR("B")="YES",DIR(0)="Y",DIR("A")="Is this SIG correct" D ^DIR K DIR I $D(DIRUT) S PSODIR("DFLG")=1 K DIRUT,DUOUT,DTOUT Q
S SIGOK=Y I Y K PSODIR("SIG")
Q
PSTPB ;
W !,"New orders entered through this option must have a Patient Status of 'NON-VA'!",!
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSODIR1 12965 printed Apr 09, 2024@21:26:26 Page 2
PSODIR1 ;IHS/DSD - ASKS DATA FOR RX ORDER ENTRY CONT. ;7 Jan 2020 16:58:09
+1 ;;7.0;OUTPATIENT PHARMACY;**23,46,78,102,121,131,146,166,184,222,268,206,266,340,391,444,446,505,543,457,574,612,686,700**;DEC 1997;Build 261
+2 ;External reference ^PS(55 supported by DBIA 2228
+3 ;External reference ^PSDRUG( supported by DBIA 221
+4 ;External reference $$MXDAYSUP^PSSUTIL1 supported by DBIA 6229
+5 ;External reference $$HTFM^XLFDT supported by DBIA 10103
+6 ; Reference to $$ISCLOZ^PSJCLOZ in ICR #7176
+7 ;
PTSTAT(PSODIR) ;
PTSTATEN KILL DIC,DR,DIE
SET PSODIR("FIELD")=0
+1 IF $GET(PSOTPBFG)
IF $GET(PSOFROM)="NEW"
KILL PSORX("PATIENT STATUS"),PSODIR("PATIENT STATUS")
NEW PSOFNDRX,PSOFNDFL,PSOFNDPS
Begin DoDot:1
+2 SET PSOFNDFL=0
FOR PSOFNDPS=0:0
SET PSOFNDPS=$ORDER(^PS(53,PSOFNDPS))
if 'PSOFNDPS!(PSOFNDFL)
QUIT
Begin DoDot:2
+3 SET PSOFNDRX=$PIECE($GET(^PS(53,PSOFNDPS,0)),"^")
SET PSOFNDRX=$$UP^XLFSTR(PSOFNDRX)
IF PSOFNDRX="NON-VA"
SET PSOFNDFL=1
SET (PSORX("PATIENT STATUS"),DIC("B"))=$PIECE($GET(^PS(53,PSOFNDPS,0)),"^")
End DoDot:2
End DoDot:1
+4 IF $GET(PSOTPBFG)
IF $GET(PSOFROM)="NEW"
IF $GET(PSORX("PATIENT STATUS"))=""
WRITE !,"Could not find a 'NON-VA' Patient Status in the RX PATIENT STATUS file (#53)!"
DO PSTPB
Begin DoDot:1
+5 KILL DIR
SET DIR(0)="E"
SET DIR("A")="Press Return to continue"
DO ^DIR
KILL DIR
End DoDot:1
SET PSODIR("DFLG")=1
GOTO PTSTATX
+6 IF $GET(PSOTPBFG)
IF $GET(PSOFROM)="NEW"
GOTO TPBB
+7 NEW PSOX
+8 SET PSOX=$GET(^PS(55,PSODFN,"PS"))
IF PSOX]""
SET PSORX("PATIENT STATUS")=$PIECE($GET(^PS(53,PSOX,0)),"^")
SET DIC("B")=PSORX("PATIENT STATUS")
+9 if $GET(PSODIR("PATIENT STATUS"))]""
SET DIC("B")=PSODIR("PATIENT STATUS")
TPBB ;
+1 DO ELIG^VADPT
WRITE !,"Eligibility: "_$PIECE(VAEL(1),"^",2)_$SELECT(+VAEL(3):" SC%: "_$PIECE(VAEL(3),"^",2),1:"")
+2 SET N=0
FOR
SET N=$ORDER(VAEL(1,N))
if 'N
QUIT
WRITE !,?10,$PIECE(VAEL(1,N),"^",2)
+3 SET DIC("A")="RX PATIENT STATUS: "
+4 SET DIC(0)="QEAMZ"
SET DIC=53
DO ^DIC
KILL DIC
+5 IF $GET(PSOTPBFG)
IF $GET(PSOFROM)="NEW"
NEW PSOPSDIR,PSOFNDZZ,PSOPSUPA
SET (PSOPSDIR,PSOPSUPA)=0
Begin DoDot:1
+6 IF Y'>0!($DATA(DTOUT))!($DATA(DUOUT))
SET (PSOPSDIR,PSOPSUPA)=1
QUIT
+7 SET (PSODIR("PATIENT STATUS"),PSORX("PATIENT STATUS"))=+Y
SET PSODIR("PTST NODE")=Y(0)
+8 SET PSOFNDZZ=$PIECE($GET(^PS(53,+Y,0)),"^")
SET PSOFNDZZ=$$UP^XLFSTR(PSOFNDZZ)
IF PSOFNDZZ'="NON-VA"
SET PSOPSDIR=1
KILL PSODIR("PATIENT STATUS"),PSORX("PATIENT STATUS"),PSODIR("PTST NODE")
End DoDot:1
IF PSOPSDIR
if PSOPSUPA
SET PSODIR("DFLG")=1
if PSOPSUPA
GOTO PTSTATX
WRITE !
DO PSTPB
GOTO PTSTATEN
+9 IF $GET(PSOTPBFG)
IF $GET(PSOFROM)="NEW"
GOTO TPBSC
+10 IF X[U
IF $LENGTH(X)>1
if '$GET(PSOEDIT)
DO JUMP
GOTO PTSTATX
+11 IF $DATA(DUOUT)!$DATA(DTOUT)
SET PSODIR("DFLG")=1
GOTO PTSTATX
+12 IF Y=-1
WRITE $CHAR(7)," Required"
GOTO PTSTATEN
+13 NEW PSOFNDX,PSOFNDXY,PSOFNDXX,PSOFNDYY
+14 SET PSOFNDXY=$GET(Y)
SET PSOFNDYY=$GET(Y(0))
+15 IF '$GET(PSOTPBFG)
IF $GET(PSOFROM)="NEW"
SET PSOFNDX=$PIECE($GET(^PS(53,+Y,0)),"^")
SET PSOFNDXX=$$UP^XLFSTR(PSOFNDX)
IF PSOFNDXX="NON-VA"
KILL PSOFNDX,PSOFNDXY,PSOFNDYY,PSOFNDXX,Y
WRITE !!,"Cannot select 'NON-VA' Rx Patient Status!",!
GOTO PTSTATEN
+16 SET Y=$GET(PSOFNDXY)
SET Y(0)=$GET(PSOFNDYY)
+17 KILL PSOFNDXY,PSOFNDYY,PSOFNDX,PSOFNDXX
+18 SET (PSODIR("PATIENT STATUS"),PSORX("PATIENT STATUS"))=+Y
+19 SET PSODIR("PTST NODE")=Y(0)
TPBSC ;
+1 IF $GET(PSOFDR)
IF $PIECE($GET(OR0),"^",17)="C"
GOTO PTSTATX
+2 LOCK +^PS(55,PSODFN):$SELECT(+$GET(^DD("DILOCKTM"))>0:+^DD("DILOCKTM"),1:3)
IF '$TEST
GOTO PTSTATX
+3 SET DIE="55"
SET DR="3////"_+Y
SET DA=PSODFN
DO ^DIE
KILL DIE,DA,D0
+4 LOCK -^PS(55,PSODFN)
PTSTATX ;
+1 KILL DTOUT,DUOUT,X,Y,DA
QUIT
+2 ;
SIG(PSODIR) ;
+1 IF $GET(PSOFDR)
IF $GET(PSODIR("SIG"))']""
DO SIGOK
if $GET(SIGOK)!($GET(PSODIR("DFLG")))
GOTO SIGX
+2 KILL DIR,DIC
+3 SET DIR(0)="52,10"
+4 if $GET(PSODRUG("SIG"))]""
SET DIR("B")=PSODRUG("SIG")
+5 if $GET(PSODIR("SIG"))]""
SET DIR("B")=PSODIR("SIG")
+6 DO DIR
if PSODIR("DFLG")!PSODIR("FIELD")
GOTO SIGX
+7 SET PSODIR("SIG")=Y
SET SIGOK=0
KILL SIG
SIGX ;
+1 KILL X,Y
QUIT
+2 ;
QTY(PSODIR) ;
QTYA KILL DIR,DIC
NEW RFL,RXIEN
+1 IF $GET(CLOZPAT)=1
SET DIR("A",1)="Patient Eligible for 14 day supply or 7 day supply with 1 refill"
+2 IF $GET(CLOZPAT)=2
SET DIR("A",1)="Patient Eligible 28 day supply or 14 day supply with 1 refill or 7 day supply with 3 refill"
+3 SET DIR(0)="52,7"
if $GET(PSODRUG("IEN"))
SET DIR("A")="QTY ( "_$GET(PSODRUG("UNIT"))_" ) "_$SELECT($PIECE($GET(^PSDRUG(+PSODRUG("IEN"),5)),"^")]"":$PIECE(^PSDRUG(+PSODRUG("IEN"),5),"^"),1:"")
+4 KILL QTYHLD
IF $GET(PSODIR("QTY"))]""
SET QTYHLD=PSODIR("QTY")
KILL PSODIR("QTY")
+5 if '$GET(PSOQTY)
DO QTY^PSOSIG(.PSODIR)
+6 IF '$GET(SPEED)
IF $GET(QTYHLD)
IF '$GET(PSODIR("QTY"))
SET PSODIR("QTY")=QTYHLD
+7 KILL QTYHLD
if '$GET(PSODIR("QTY"))
KILL PSODIR("QTY")
+8 IF $GET(SPEED)
IF $GET(PSODIR("QTY"))']""
SET PSODIR("QTY")=$PIECE(^PSRX(PSORENW("OIRXN"),0),"^",7)
+9 if $GET(PSODIR("QTY"))]""
SET DIR("B")=PSODIR("QTY")
+10 ; JCH - PSO*7.0*612 - BEGIN
+11 IF $GET(CLOZPAT)>0
IF $DATA(^XTMP("PSJ4D-"_+$GET(PSODFN)))!$DATA(^XTMP("PSO4D-"_+$GET(PSODFN)))
KILL DIR("A",1)
+12 ; JCH - PSO*7.0*612 - END
+13 DO DIR
+14 ;/BLB/ PSO*7.0*505 ;MODIFIED QTY CHECK TO ALLOW LEADING ZEROS
+15 IF Y["."
IF $PIECE(Y,".")<1
SET Y="0"_"."_$PIECE(Y,".",2)
+16 if PSODIR("DFLG")!PSODIR("FIELD")
GOTO QTYX
+17 IF $GET(Y)
IF $GET(PSODRUG("MAXDOSE"))]""
IF $GET(PSODIR("DAYS SUPPLY"))
IF (Y/+PSODIR("DAYS SUPPLY")>PSODRUG("MAXDOSE"))
Begin DoDot:1
+18 WRITE !,$CHAR(7)," Greater than Maximum dose of "_PSODRUG("MAXDOSE")_" per day"
DO DAYSEN
End DoDot:1
if $GET(PSODIR("DFLG"))
GOTO QTYX
GOTO QTYA
+19 IF $GET(PSOFDR)
IF $PIECE($GET(OR0),"^",24)
IF $GET(PSODIR("QTY"))
IF +Y>$GET(PSODIR("QTY"))
Begin DoDot:1
+20 WRITE !!,"Digitally Signed Order - QTY cannot be increased",!
+21 NEW DIR
SET DIR(0)="E"
SET DIR("A")="Press Return to Continue"
DO ^DIR
WRITE !
End DoDot:1
GOTO QTYX
+22 SET PSODIR("QTY")=Y
+23 ;
QTYX ;
+1 KILL X,Y
QUIT
+2 ;
COPIES(PSODIR) ;
+1 KILL DIR,DIC
+2 SET DIR(0)="52,10.6"
+3 SET DIR("B")=$SELECT($GET(PSODIR("COPIES"))]"":PSODIR("COPIES"),1:1)
+4 DO DIR
if PSODIR("DFLG")!PSODIR("FIELD")
GOTO COPIESX
+5 SET PSODIR("COPIES")=Y
COPIESX ;
+1 KILL X,Y
QUIT
+2 ;
DAYS(PSODIR) ;
DAYSEN KILL DIR,DIC
NEW PSORFLS
+1 ;PSO*7*266
+2 NEW S2DS,MXDAYSUP,DFDAYSUP,PSDAYSUP,CSDRUG,NEWTOTDS,PSOREGN
SET S2DS=0
+3 SET MXDAYSUP=90
SET CSDRUG=0
+4 IF $DATA(PSODRUG("IEN"))
Begin DoDot:1
+5 SET MXDAYSUP=$$MXDAYSUP^PSSUTIL1(PSODRUG("IEN"))
+6 SET S2DS=$$CSDS^PSOSIGDS(PSODRUG("IEN"))
IF S2DS
IF $PIECE($GET(PSODIR("PTST NODE")),"^",3)>29
SET S2DS=30
+7 SET PSORFLS=$SELECT($GET(PSODIR("# OF REFILLS")):PSODIR("# OF REFILLS"),1:$PIECE($GET(PSODIR("RX0")),"^",9))
+8 IF '$DATA(PSODRUG("DEA"))
SET PSODRUG("DEA")=$$GET1^DIQ(50,PSODRUG("IEN"),3,"")
+9 IF (PSODRUG("DEA")["2")!(PSODRUG("DEA")["3")!(PSODRUG("DEA")["4")!(PSODRUG("DEA")["5")
SET CSDRUG=1
End DoDot:1
+10 ;p457
SET PSOREGN=""
+11 ;p457
IF $$ISCLOZ^PSJCLOZ(,,,,$GET(PSODRUG("IEN")))
SET PSOREGN=$$GET1^DIQ(55,PSODFN,53)
+12 ;S PSOREGN=$$GET1^DIQ(55,PSODFN,53) p457 commented out
+13 SET PSDAYSUP=$SELECT(PSOREGN?1U6N!$DATA(^TMP($JOB,"CLOZFLG",PSODFN)):4,$GET(CLOZPAT)=2:28,$GET(CLOZPAT)=1:14,$GET(CLOZPAT)=0:7,1:MXDAYSUP)
+14 IF (PSOREGN?2U5N)&($$GET1^DIQ(50,+$GET(PSODRUG("IEN")),17.5)="PSOCLO1")
Begin DoDot:1
+15 IF $PIECE($GET(^XTMP("PSO4D-"_PSODFN,"PSOYS")),"^",4)'>0
IF ($PIECE($GET(^XTMP("PSO4D-"_PSODFN,0)),"^",1))>$$HTFM^XLFDT($HOROLOG,1)
Begin DoDot:2
+16 ;Begin: JCH - PSO*7*612
+17 NEW PSOCLZN,PSOYSIEN,PSOCLODT
SET PSOCLZN=$$GET1^DIQ(55,PSODFN,53)
+18 IF PSOCLZN?2U5N
SET PSOYSIEN=$$FIND1^DIC(603.01,,"Q",PSOCLZN,"B")
IF PSOYSIEN
SET PSOCLODT=$$GET1^DIQ(603.01,+PSOYSIEN,3,"I")
IF (PSOCLODT=$$DT^XLFDT)
QUIT
+19 ;End: JCH - PSO*7*612
+20 ; Special condition local override if no ANC results
SET PSDAYSUP=4
End DoDot:2
End DoDot:1
+21 SET DIR(0)="N^1:"_PSDAYSUP
+22 SET DFDAYSUP=$SELECT($DATA(CLOZPAT)&('$GET(PSODIR("DAYS SUPPLY"))):7,$GET(PSODIR("DAYS SUPPLY"))]"":PSODIR("DAYS SUPPLY"),S2DS>1:S2DS,$PIECE($GET(PSODIR("PTST NODE")),"^",3):$PIECE(PSODIR("PTST NODE"),"^",3),1:30)
+23 IF DFDAYSUP>MXDAYSUP
Begin DoDot:1
+24 if $GET(PSODIR("DAYS SUPPLY"))
WRITE !!,$CHAR(7),"Invalid DAYS SUPPLY value (",DFDAYSUP,"), resetting it to ",MXDAYSUP," (maximum allowed).",!
End DoDot:1
SET DFDAYSUP=MXDAYSUP
+25 SET DIR("B")=DFDAYSUP
+26 SET DIR("A")="DAYS SUPPLY"
SET DIR("?")="Enter a whole number between 1 and "_PSDAYSUP
+27 DO DIR
if PSODIR("DFLG")!PSODIR("FIELD")
GOTO DAYSX
+28 IF $GET(Y)
IF $GET(PSODRUG("MAXDOSE"))]""
IF $GET(PSODIR("QTY"))]""
IF (+PSODIR("QTY")/Y>PSODRUG("MAXDOSE"))
Begin DoDot:1
+29 WRITE !,$CHAR(7)," Greater than Maximum dose of "_PSODRUG("MAXDOSE")_" per day"
End DoDot:1
GOTO DAYSEN
+30 IF $GET(PSOFDR)
IF $PIECE($GET(OR0),"^",24)
IF $GET(PSODIR("DAYS SUPPLY"))
IF +Y>$GET(PSODIR("DAYS SUPPLY"))
Begin DoDot:1
+31 WRITE !!,"Digitally Signed Order - Days Supply cannot be increased",!
+32 NEW DIR
SET DIR(0)="E"
SET DIR("A")="Press Return to Continue"
DO ^DIR
WRITE !
End DoDot:1
GOTO DAYSX
+33 IF $GET(PSONEW("FLD"))=8
IF PSODIR("DAYS SUPPLY")=Y
QUIT
+34 if $GET(PSODIR("DAYS SUPPLY"))
SET PSODIR("DAYS SUPPLY OLD")=PSODIR("DAYS SUPPLY")
+35 SET PSODIR("DAYS SUPPLY")=Y
+36 ; Checking the # Of Refills field value after the Days Supply field was edited
+37 IF $DATA(PSODRUG("IEN"))
IF $GET(Y)
IF $GET(Y)>$SELECT(PSORFLS<4:90,PSORFLS<6:89,PSORFLS<12:60,1:0)
Begin DoDot:1
+38 NEW PTST
+39 SET PTST=+$GET(PSODIR("PATIENT STATUS"))
if 'PTST
SET PTST=$PIECE($GET(PSODIR("RX0")),"^",3)
+40 IF 'PTST
IF $GET(PSODFN)
SET PTST=+$GET(^PS(55,PSODFN,"PS"))
+41 IF PSORFLS>$$MAXNUMRF^PSOUTIL(PSODRUG("IEN"),Y,PTST,.CLOZPAT)
Begin DoDot:2
+42 WRITE !,$CHAR(7),"Invalid number of REFILLS for amount of DAYS SUPPLY.",!,"REFILL EDIT FORCED."
DO REFILL(.PSODIR)
+43 SET PSODIR("FLD",9)=PSODIR("# OF REFILLS")
End DoDot:2
End DoDot:1
+44 if $GET(CLOZPAT)=0
SET (PSODIR("N# REF"),PSODIR("# OF REFILLS"))=0
+45 if $GET(CLOZPAT)=2
Begin DoDot:1
+46 if PSODIR("DAYS SUPPLY")=28
SET (PSODIR("N# REF"),PSODIR("# OF REFILLS"))=0
+47 if PSODIR("DAYS SUPPLY")=14
SET (PSODIR("N# REF"),PSODIR("# OF REFILLS"))=1
+48 if PSODIR("DAYS SUPPLY")=7
SET (PSODIR("N# REF"),PSODIR("# OF REFILLS"))=3
End DoDot:1
+49 if $GET(CLOZPAT)=1
Begin DoDot:1
+50 if PSODIR("DAYS SUPPLY")=14
SET (PSODIR("N# REF"),PSODIR("# OF REFILLS"))=0
+51 if PSODIR("DAYS SUPPLY")=7
SET (PSODIR("N# REF"),PSODIR("# OF REFILLS"))=1
End DoDot:1
+52 KILL QTYHLD
if $GET(PSODIR("QTY"))
SET QTYHLD=PSODIR("QTY")
DO QTY^PSOSIG(.PSODIR)
+53 IF $GET(QTYHLD)
IF '$GET(PSODIR("QTY"))
SET PSODIR("QTY")=QTYHLD
+54 KILL QTYHLD
if '$GET(PSODIR("QTY"))
KILL PSODIR("QTY")
+55 IF $$ISCLOZ^PSJCLOZ(,,,,$GET(PSODRUG("IEN")))
DO EXPDT^PSOCLO1(.PSODIR,.CLOZPAT)
DAYSX ;
+1 KILL X,Y
QUIT
+2 ;
REFILL(PSODIR) ;
+1 NEW PSODAYS,PSOX
+2 SET PSODAYS=+$GET(PSODIR("DAYS SUPPLY"))
+3 ;Recalculating RFTT if it doesn't exist
+4 IF '$GET(PSONEW)
Begin DoDot:1
+5 NEW I
IF '$GET(RFTT)
IF $GET(PSORXED("IRXN"))
FOR I=0:0
SET I=$ORDER(^PSRX(PSORXED("IRXN"),1,I))
if 'I
QUIT
SET RFTT=$GET(RFTT)+1
End DoDot:1
+6 ;
+7 IF $GET(PSODIR("PTST NODE"))=""
Begin DoDot:1
+8 NEW X,Y
+9 SET X=$GET(PSODIR("PATIENT STATUS"))
IF 'X
IF $DATA(RX0)
SET X=$PIECE(RX0,"^",3)
+10 SET DIC=53
SET DIC(0)="QXZ"
DO ^DIC
KILL DIC
+11 if +Y
SET PSODIR("PTST NODE")=Y(0)
+12 if '$GET(PSODIR("PATIENT STATUS"))
SET PSODIR("PATIENT STATUS")=+Y
End DoDot:1
+13 SET $PIECE(PSODIR("PTST NODE"),"^",4)=+$PIECE($GET(PSODIR("PTST NODE")),"^",4)
+14 IF $GET(OR0)
GOTO REFOR
+15 KILL DIR,DIC,PSOX
+16 ; Controlled Substance
+17 SET PSODIR("CS")=0
+18 IF (PSODRUG("DEA")["2")!(PSODRUG("DEA")["3")!(PSODRUG("DEA")["4")!(PSODRUG("DEA")["5")
Begin DoDot:1
+19 SET $PIECE(PSODIR("CS"),"^")=1
if (PSODRUG("DEA")["2")
SET $PIECE(PSODIR("CS"),"^",2)=1
End DoDot:1
+20 ;
+21 ; Retrieving the Maximum Number of Refills allowed
+22 SET PSOX=$$MAXNUMRF^PSOUTIL(+$GET(PSODRUG("IEN")),PSODAYS,+$GET(PSODIR("PATIENT STATUS")),.CLOZPAT)
+23 ;
+24 IF '$DATA(CLOZPAT)
IF PSODRUG("DEA")["A"&(PSODRUG("DEA")'["B")!(PSODRUG("DEA")["F")!(PSODRUG("DEA")[1)!(PSODRUG("DEA")[2)
Begin DoDot:1
+25 IF PSODRUG("DEA")["A"&(PSODRUG("DEA")'["B")!(PSODRUG("DEA")[1)!(PSODRUG("DEA")[2)!'$ORDER(^PSRX(+$GET(PSODIR("IRXN")),1,0))!('$GET(PSOLOKED))
Begin DoDot:2
+26 SET VALMSG="No refills allowed on "_$SELECT(PSODRUG("DEA")["F":"this drug.",1:"Narcotics.")
WRITE !,VALMSG,!
+27 if $DATA(PSODIR("FIELD"))
SET PSODIR("FIELD")=0
SET PSODIR("# OF REFILLS")=0
End DoDot:2
QUIT
+28 ; reset refills to the # given
+29 DO RFRSET^PSODIR2
End DoDot:1
GOTO REFILLX
+30 ;
+31 IF $PIECE($GET(PSODIR("CS")),"^",2)=1
WRITE !,"No refills allowed on Schedule 2 drugs...",!
if $DATA(PSODIR("FIELD"))
SET PSODIR("FIELD")=0
SET PSODIR("# OF REFILLS")=0
GOTO REFILLX
+32 ;
+33 ;/RBN - Integration of 457 start
+34 IF $DATA(CLOZPAT)
SET PSOX=$SELECT($GET(CLOZPAT)=2&(PSODIR("DAYS SUPPLY")=14):1,$GET(CLOZPAT)=2&(PSODIR("DAYS SUPPLY")=7):3,$GET(CLOZPAT)=1&(PSODIR("DAYS SUPPLY")=7):1,1:0)
+35 ;/RBN - Integration of 457 end
+36 ;
+37 ;PSO*7*266 make sure PSOX is greater than RFTT
+38 SET DIR(0)="N^"_$SELECT($GET(RFTT):RFTT,1:0)_":"_$SELECT(+$GET(RFTT)>PSOX:RFTT,1:PSOX)
SET DIR("A")="# OF REFILLS"
+39 ;PSO*7*340 Correct Default Value
+40 SET DIR("B")=$SELECT($GET(COPY)&('$GET(PSOTITRX)):$GET(PSODIR("# OF REFILLS")),$GET(PSODIR("N# REF"))]"":PSODIR("N# REF"),$GET(PSODIR("# OF REFILLS"))]"":PSODIR("# OF REFILLS"),$GET(RFTT)>PSOX:RFTT,1:PSOX)
+41 SET DIR("?",1)="Enter a whole number. The maximum number of refills is based on"
+42 SET DIR("?")="the DAYS SUPPLY and the PATIENT STATUS fields."
+43 DO DIR
if PSODIR("DFLG")!PSODIR("FIELD")
GOTO REFILLX
+44 SET (PSODIR("N# REF"),PSODIR("# OF REFILLS"))=Y
+45 ;
REFILLX ;
+1 if $GET(PSODIR("# OF REFILLS"))']""
SET PSODIR("# OF REFILLS")=$SELECT($GET(PSODIR("N# REF"))]"":PSODIR("N# REF"),1:PSOX)
+2 ;PSO*7*340 Kill RFTT
KILL X,Y,PSOX,DEA,PSOCS,RFTT
+3 QUIT
+4 ;OERR CALL
REFOR ;
+1 DO REFOR^PSODIR3
+2 GOTO REFILLX
+3 QUIT
DIR ;
+1 SET (PSODIR("FIELD"),PSODIR("DFLG"))=0
+2 if $GET(DIR(0))']""
GOTO DIRX
+3 DO ^DIR
KILL DIR,DIE,DIC,DA
+4 IF $DATA(DUOUT)!($DATA(DTOUT))!($DATA(DIROUT))
IF $LENGTH($GET(X))'>1!(Y="")
SET PSODIR("DFLG")=1
GOTO DIRX
+5 IF $DATA(DIRUT)!($DATA(DIROUT))
IF $GET(SPEED)
SET PSODIR("DFLG")=1
GOTO DIRX
+6 ;p686
IF $EXTRACT(X,1)=U
SET PSODIR("DFLG")=1
GOTO DIRX
+7 IF X[U
IF $LENGTH(X)>1
DO JUMP
DIRX ;
+1 KILL DIRUT,DTOUT,DUOUT,DIROUT
QUIT
+2 ;
JUMP ;
+1 IF $GET(PSOEDIT)!($GET(OR0))
SET PSODIR("DFLG")=1
QUIT
+2 SET X=$PIECE(X,"^",2)
SET DIC="^DD(52,"
SET DIC(0)="QM"
DO ^DIC
KILL DIC
+3 IF Y=-1
SET PSODIR("FIELD")=PSODIR("FLD")
GOTO JUMPX
+4 IF $GET(PSONEW1)=0
DO JUMP^PSONEW1
GOTO JUMPX
+5 IF $GET(PSOREF1)=0
DO JUMP^PSOREF1
GOTO JUMPX
+6 IF $GET(PSONEW3)=0
DO JUMP^PSONEW3
GOTO JUMPX
+7 IF $GET(PSORENW3)=0
DO JUMP^PSORENW3
GOTO JUMPX
JUMPX ;
+1 SET X="^"_X
QUIT
+2 ;
SIGOK ;review and decide on oerr sig
+1 IF '$ORDER(SIG(0))
SET SIGOK=0
QUIT
+2 KILL SIGOK
WRITE !,"SIG: "
+3 FOR SIG=0:0
SET SIG=$ORDER(SIG(SIG))
WRITE SIG(SIG)_" ",!?5
if '$ORDER(SIG(SIG))
QUIT
+4 KILL DIR,DIRUT,DUOUT,DTOUT
SET DIR("B")="YES"
SET DIR(0)="Y"
SET DIR("A")="Is this SIG correct"
DO ^DIR
KILL DIR
IF $DATA(DIRUT)
SET PSODIR("DFLG")=1
KILL DIRUT,DUOUT,DTOUT
QUIT
+5 SET SIGOK=Y
IF Y
KILL PSODIR("SIG")
+6 QUIT
PSTPB ;
+1 WRITE !,"New orders entered through this option must have a Patient Status of 'NON-VA'!",!
+2 QUIT
+3 ;
