PSODIR1 ;IHS/DSD/JCM - ASKS DATA FOR RX ORDER ENTRY CONT. ;06-Dec-2012 18:58;PLS
;;7.0;OUTPATIENT PHARMACY;**23,46,78,102,121,131,146,166,1005,1008,1011,184,222,268,206,266,1015**;DEC 1997;Build 62
;External reference ^PS(55-DBIA 2228, ^PSDRUG(-DBIA 221, XLFSTR-DBIA 10104
;External reference ^%DTC-DBIA 10000, ^DIC-DBIA 10006, ^DIR-DBIA 10026
;
; Modified - IHS/CIA/PLS - 12/05/03 - Line DAYSEN+1, REFILL+9, REFILL+20 and DIR+4.
; IHS/MSC/PLS - 12/10/08 - Line REFILL+8,REFILL+15
; REFOR+6
; 03/23/09 - Line REFOR+5
; 05/13/11 - Line REFILL+29
; 12/06/12 - Line DAYSEN+14
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
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")
D DIR 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
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
I $D(PSODRUG("IEN")) D
.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,"")
; IHS/CIA/PLS - 12/05/03 - Changed 90 to 365
;S DIR(0)="N^1:"_$S($G(CLOZPAT)=2:28,$G(CLOZPAT)=1:14,$G(CLOZPAT)=0:7,1:90)
S DIR(0)="N^1:"_$S($G(CLOZPAT)=2:28,$G(CLOZPAT)=1:14,$G(CLOZPAT)=0:7,1:365)
S DIR("B")=$S($D(CLOZPAT)&('$G(PSODIR("DAYS SUPPLY"))):7,$G(PSODIR("DAYS SUPPLY"))]"":PSODIR("DAYS SUPPLY"),$P($G(PSODIR("PTST NODE")),"^",3):$P(PSODIR("PTST NODE"),"^",3),1:30)
S DIR("A")="DAYS SUPPLY",DIR("?")="Enter a whole number between 1 and "_$S($G(CLOZPAT)=2:28,$G(CLOZPAT)=1:14,$G(CLOZPAT)=0:7,1:90)
D DIR G:PSODIR("DFLG")!PSODIR("FIELD") DAYSX
I $G(Y),$G(PSODRUG("MAXDOSE"))]"",$G(PSODIR("QTY"))]"",(+PSODIR("QTY")/Y>PSODRUG("MAXDOSE")) W !,$C(7)," Greater than Maximum dose of "_PSODRUG("MAXDOSE")_" per day" G DAYSEN
S PSODIR("DAYS SUPPLY")=Y
;PSO*7*266
;IHS/MSC/PLS - 12/06/2012 - Removed check
;I $D(PSODRUG("IEN")),$G(Y),($G(Y)>$S(PSORFLS<4:90,PSORFLS<6:89,PSORFLS<12:60,1:0)) 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")
D:$G(PSOFROM)="NEW"
.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")
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")
DAYSX K X,Y
Q
REFILL(PSODIR) ;
;PSO*7*266
I $G(PSODIR("PTST NODE"))="" D
.N X,Y
.S X=$G(PSODIR("PATIENT STATUS")) S:'X 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
S PSODIR("CS")=0 K DIR,DIC,PSOX
F DEA=1:1 Q:$E(PSODRUG("DEA"),DEA)="" I $E(+PSODRUG("DEA"),DEA)>1,$E(+PSODRUG("DEA"),DEA)<6 S $P(PSODIR("CS"),"^")=1 S:$E(+PSODRUG("DEA"),DEA)=2 $P(PSODIR("CS"),"^",2)=1
I PSODIR("CS") D
.S PSOX=5,PSOX1=$S($P($G(PSODIR("PTST NODE")),"^",4)>PSOX:PSOX,1:$P($G(PSODIR("PTST NODE")),"^",4)),PSOX=$S(PSOX1=5:PSOX,1:PSOX1)
.S PSOX=$S('PSOX:0,PSODIR("DAYS SUPPLY")=90:1,1:PSOX),PSDY=PSODIR("DAYS SUPPLY"),PSDY1=$S(PSDY<60:5,PSDY'<60&(PSDY'>89):2,PSDY=90:1,1:0) S PSOX=$S(PSOX'>PSDY1:PSOX,1:PSDY1)
E D
.;IHS/MSC/PLS - 12/10/08 - Changed maximum refills allowed from 11 to 15
.;S PSOX=11,PSOX1=$S($P($G(PSODIR("PTST NODE")),"^",4)>PSOX:PSOX,1:$P($G(PSODIR("PTST NODE")),"^",4)),PSOX=$S(PSOX1=11:PSOX,1:PSOX1)
.S PSOX=15,PSOX1=$S($P($G(PSODIR("PTST NODE")),"^",4)>PSOX:PSOX,1:$P($G(PSODIR("PTST NODE")),"^",4)),PSOX=$S(PSOX1=15:PSOX,1:PSOX1)
.; IHS/CIA/PLS - 12/05/03 - Changed days supply value
.; Checks for days supply if not less than 90 (was = 90) and
.; will still allow 3 refills. VA had max of 90, IHS edited the days
.; supply to allow max of 365.
.;S PSDY=PSODIR("DAYS SUPPLY"),PSDY1=$S(PSDY<60:11,PSDY'<60&(PSDY'>89):5,PSDY=90:3,1:0) S PSOX=$S(PSOX'>PSDY1:PSOX,1:PSDY1)
.;IHS/MSC/PLS - 12/10/08
.;S PSDY=+$G(PSODIR("DAYS SUPPLY")),PSDY1=$S(PSDY<60:11,PSDY<90:5,PSDY=90:3,PSDY<168:2,PSDY<365:1,1:0) S PSOX=$S(PSOX'>PSDY1:PSOX,1:PSDY1)
.S PSDY=+$G(PSODIR("DAYS SUPPLY")),PSDY1=$S(PSDY<60:15,PSDY<90:5,PSDY=90:3,PSDY<168:2,PSDY<365:1,1:0) S PSOX=$S(PSOX'>PSDY1:PSOX,1:PSDY1)
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
..Q
.;reset refills to the # given
.D RFRSET^PSODIR2
.Q
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
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)
;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"
S DIR("B")=$S($G(COPY):PSODIR("# OF REFILLS"),$G(PSODIR("N# REF"))]"":PSODIR("N# REF"),$G(PSODIR("# OF REFILLS"))]"":PSODIR("# OF REFILLS"),$G(PSOX1)]""&(PSOX>PSOX1):PSOX1,1:PSOX)
; IHS/CIA/PLS - 12/05/03 - Set default to zero.
S DIR("B")=0
S DIR("?")="Enter a whole number. The maximum is set by the DAYS SUPPLY field."
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"),$G(PSOX1)]""&($G(PSOX)>PSOX1):PSOX1,1:PSOX)
K X,Y,PSOX,PSOX1,PSDY,PSDY1,DEA,PSOCS
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
DIRS ; EP - IHS/CIA/PLS - 12/23/03 - New entry point DIRS added.
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 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
PSODIR1 ;IHS/DSD/JCM - ASKS DATA FOR RX ORDER ENTRY CONT. ;06-Dec-2012 18:58;PLS
+1 ;;7.0;OUTPATIENT PHARMACY;**23,46,78,102,121,131,146,166,1005,1008,1011,184,222,268,206,266,1015**;DEC 1997;Build 62
+2 ;External reference ^PS(55-DBIA 2228, ^PSDRUG(-DBIA 221, XLFSTR-DBIA 10104
+3 ;External reference ^%DTC-DBIA 10000, ^DIC-DBIA 10006, ^DIR-DBIA 10026
+4 ;
+5 ; Modified - IHS/CIA/PLS - 12/05/03 - Line DAYSEN+1, REFILL+9, REFILL+20 and DIR+4.
+6 ; IHS/MSC/PLS - 12/10/08 - Line REFILL+8,REFILL+15
+7 ; REFOR+6
+8 ; 03/23/09 - Line REFOR+5
+9 ; 05/13/11 - Line REFILL+29
+10 ; 12/06/12 - Line DAYSEN+14
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 KILL DTOUT,DUOUT,X,Y,DA
+1 QUIT
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 KILL X,Y
+1 QUIT
QTY(PSODIR) ;
QTYA KILL DIR,DIC
+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 DO DIR
IF PSODIR("DFLG")!PSODIR("FIELD")
GOTO QTYX
+11 IF $GET(Y)
IF $GET(PSODRUG("MAXDOSE"))]""
IF $GET(PSODIR("DAYS SUPPLY"))
IF (Y/+PSODIR("DAYS SUPPLY")>PSODRUG("MAXDOSE"))
Begin DoDot:1
+12 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
+13 SET PSODIR("QTY")=Y
QTYX KILL X,Y
+1 QUIT
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 KILL X,Y
+1 QUIT
DAYS(PSODIR) ;
DAYSEN KILL DIR,DIC
NEW PSORFLS
+1 ;PSO*7*266
+2 IF $DATA(PSODRUG("IEN"))
Begin DoDot:1
+3 SET PSORFLS=$SELECT($GET(PSODIR("# OF REFILLS")):PSODIR("# OF REFILLS"),1:$PIECE($GET(PSODIR("RX0")),"^",9))
+4 IF '$DATA(PSODRUG("DEA"))
SET PSODRUG("DEA")=$$GET1^DIQ(50,PSODRUG("IEN"),3,"")
End DoDot:1
+5 ; IHS/CIA/PLS - 12/05/03 - Changed 90 to 365
+6 ;S DIR(0)="N^1:"_$S($G(CLOZPAT)=2:28,$G(CLOZPAT)=1:14,$G(CLOZPAT)=0:7,1:90)
+7 SET DIR(0)="N^1:"_$SELECT($GET(CLOZPAT)=2:28,$GET(CLOZPAT)=1:14,$GET(CLOZPAT)=0:7,1:365)
+8 SET DIR("B")=$SELECT($DATA(CLOZPAT)&('$GET(PSODIR("DAYS SUPPLY"))):7,$GET(PSODIR("DAYS SUPPLY"))]"":PSODIR("DAYS SUPPLY"),$PIECE($GET(PSODIR("PTST NODE")),"^",3):$PIECE(PSODIR("PTST NODE"),"^",3),1:30)
+9 SET DIR("A")="DAYS SUPPLY"
SET DIR("?")="Enter a whole number between 1 and "_$SELECT($GET(CLOZPAT)=2:28,$GET(CLOZPAT)=1:14,$GET(CLOZPAT)=0:7,1:90)
+10 DO DIR
IF PSODIR("DFLG")!PSODIR("FIELD")
GOTO DAYSX
+11 IF $GET(Y)
IF $GET(PSODRUG("MAXDOSE"))]""
IF $GET(PSODIR("QTY"))]""
IF (+PSODIR("QTY")/Y>PSODRUG("MAXDOSE"))
WRITE !,$CHAR(7)," Greater than Maximum dose of "_PSODRUG("MAXDOSE")_" per day"
GOTO DAYSEN
+12 SET PSODIR("DAYS SUPPLY")=Y
+13 ;PSO*7*266
+14 ;IHS/MSC/PLS - 12/06/2012 - Removed check
+15 ;I $D(PSODRUG("IEN")),$G(Y),($G(Y)>$S(PSORFLS<4:90,PSORFLS<6:89,PSORFLS<12:60,1:0)) D
+16 ;.W !,$C(7),"Invalid number of REFILLS for amount of DAYS SUPPLY.",!,"REFILL EDIT FORCED." D REFILL(.PSODIR)
+17 ;.S PSODIR("FLD",9)=PSODIR("# OF REFILLS")
+18 IF $GET(PSOFROM)="NEW"
Begin DoDot:1
+19 KILL QTYHLD
IF $GET(PSODIR("QTY"))
SET QTYHLD=PSODIR("QTY")
DO QTY^PSOSIG(.PSODIR)
+20 IF $GET(QTYHLD)
IF '$GET(PSODIR("QTY"))
SET PSODIR("QTY")=QTYHLD
+21 KILL QTYHLD
IF '$GET(PSODIR("QTY"))
KILL PSODIR("QTY")
End DoDot:1
+22 IF $GET(CLOZPAT)=0
SET (PSODIR("N# REF"),PSODIR("# OF REFILLS"))=0
+23 IF $GET(CLOZPAT)=2
Begin DoDot:1
+24 IF PSODIR("DAYS SUPPLY")=28
SET (PSODIR("N# REF"),PSODIR("# OF REFILLS"))=0
+25 IF PSODIR("DAYS SUPPLY")=14
SET (PSODIR("N# REF"),PSODIR("# OF REFILLS"))=1
+26 IF PSODIR("DAYS SUPPLY")=7
SET (PSODIR("N# REF"),PSODIR("# OF REFILLS"))=3
End DoDot:1
+27 IF $GET(CLOZPAT)=1
Begin DoDot:1
+28 IF PSODIR("DAYS SUPPLY")=14
SET (PSODIR("N# REF"),PSODIR("# OF REFILLS"))=0
+29 IF PSODIR("DAYS SUPPLY")=7
SET (PSODIR("N# REF"),PSODIR("# OF REFILLS"))=1
End DoDot:1
+30 KILL QTYHLD
IF $GET(PSODIR("QTY"))
SET QTYHLD=PSODIR("QTY")
DO QTY^PSOSIG(.PSODIR)
+31 IF $GET(QTYHLD)
IF '$GET(PSODIR("QTY"))
SET PSODIR("QTY")=QTYHLD
+32 KILL QTYHLD
IF '$GET(PSODIR("QTY"))
KILL PSODIR("QTY")
DAYSX KILL X,Y
+1 QUIT
REFILL(PSODIR) ;
+1 ;PSO*7*266
+2 IF $GET(PSODIR("PTST NODE"))=""
Begin DoDot:1
+3 NEW X,Y
+4 SET X=$GET(PSODIR("PATIENT STATUS"))
IF 'X
SET X=$PIECE(RX0,"^",3)
+5 SET DIC=53
SET DIC(0)="QXZ"
DO ^DIC
KILL DIC
+6 IF +Y
SET PSODIR("PTST NODE")=Y(0)
+7 IF '$GET(PSODIR("PATIENT STATUS"))
SET PSODIR("PATIENT STATUS")=+Y
End DoDot:1
+8 SET $PIECE(PSODIR("PTST NODE"),"^",4)=+$PIECE($GET(PSODIR("PTST NODE")),"^",4)
+9 IF $GET(OR0)
GOTO REFOR
+10 SET PSODIR("CS")=0
KILL DIR,DIC,PSOX
+11 FOR DEA=1:1
IF $EXTRACT(PSODRUG("DEA"),DEA)=""
QUIT
IF $EXTRACT(+PSODRUG("DEA"),DEA)>1
IF $EXTRACT(+PSODRUG("DEA"),DEA)<6
SET $PIECE(PSODIR("CS"),"^")=1
IF $EXTRACT(+PSODRUG("DEA"),DEA)=2
SET $PIECE(PSODIR("CS"),"^",2)=1
+12 IF PSODIR("CS")
Begin DoDot:1
+13 SET PSOX=5
SET PSOX1=$SELECT($PIECE($GET(PSODIR("PTST NODE")),"^",4)>PSOX:PSOX,1:$PIECE($GET(PSODIR("PTST NODE")),"^",4))
SET PSOX=$SELECT(PSOX1=5:PSOX,1:PSOX1)
+14 SET PSOX=$SELECT('PSOX:0,PSODIR("DAYS SUPPLY")=90:1,1:PSOX)
SET PSDY=PSODIR("DAYS SUPPLY")
SET PSDY1=$SELECT(PSDY<60:5,PSDY'<60&(PSDY'>89):2,PSDY=90:1,1:0)
SET PSOX=$SELECT(PSOX'>PSDY1:PSOX,1:PSDY1)
End DoDot:1
+15 IF '$TEST
Begin DoDot:1
+16 ;IHS/MSC/PLS - 12/10/08 - Changed maximum refills allowed from 11 to 15
+17 ;S PSOX=11,PSOX1=$S($P($G(PSODIR("PTST NODE")),"^",4)>PSOX:PSOX,1:$P($G(PSODIR("PTST NODE")),"^",4)),PSOX=$S(PSOX1=11:PSOX,1:PSOX1)
+18 SET PSOX=15
SET PSOX1=$SELECT($PIECE($GET(PSODIR("PTST NODE")),"^",4)>PSOX:PSOX,1:$PIECE($GET(PSODIR("PTST NODE")),"^",4))
SET PSOX=$SELECT(PSOX1=15:PSOX,1:PSOX1)
+19 ; IHS/CIA/PLS - 12/05/03 - Changed days supply value
+20 ; Checks for days supply if not less than 90 (was = 90) and
+21 ; will still allow 3 refills. VA had max of 90, IHS edited the days
+22 ; supply to allow max of 365.
+23 ;S PSDY=PSODIR("DAYS SUPPLY"),PSDY1=$S(PSDY<60:11,PSDY'<60&(PSDY'>89):5,PSDY=90:3,1:0) S PSOX=$S(PSOX'>PSDY1:PSOX,1:PSDY1)
+24 ;IHS/MSC/PLS - 12/10/08
+25 ;S PSDY=+$G(PSODIR("DAYS SUPPLY")),PSDY1=$S(PSDY<60:11,PSDY<90:5,PSDY=90:3,PSDY<168:2,PSDY<365:1,1:0) S PSOX=$S(PSOX'>PSDY1:PSOX,1:PSDY1)
+26 SET PSDY=+$GET(PSODIR("DAYS SUPPLY"))
SET PSDY1=$SELECT(PSDY<60:15,PSDY<90:5,PSDY=90:3,PSDY<168:2,PSDY<365:1,1:0)
SET PSOX=$SELECT(PSOX'>PSDY1:PSOX,1:PSDY1)
End DoDot:1
+27 IF '$DATA(CLOZPAT)
IF PSODRUG("DEA")["A"&(PSODRUG("DEA")'["B")!(PSODRUG("DEA")["F")!(PSODRUG("DEA")[1)!(PSODRUG("DEA")[2)
Begin DoDot:1
+28 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
+29 SET VALMSG="No refills allowed on "_$SELECT(PSODRUG("DEA")["F":"this drug.",1:"Narcotics.")
WRITE !,VALMSG,!
+30 IF $DATA(PSODIR("FIELD"))
SET PSODIR("FIELD")=0
SET PSODIR("# OF REFILLS")=0
+31 QUIT
End DoDot:2
QUIT
+32 ;reset refills to the # given
+33 DO RFRSET^PSODIR2
+34 QUIT
End DoDot:1
GOTO REFILLX
+35 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
+36 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)
+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 SET DIR("B")=$SELECT($GET(COPY):PSODIR("# OF REFILLS"),$GET(PSODIR("N# REF"))]"":PSODIR("N# REF"),$GET(PSODIR("# OF REFILLS"))]"":PSODIR("# OF REFILLS"),$GET(PSOX1)]""&(PSOX>PSOX1):PSOX1,1:PSOX)
+40 ; IHS/CIA/PLS - 12/05/03 - Set default to zero.
+41 SET DIR("B")=0
+42 SET DIR("?")="Enter a whole number. The maximum is set by the DAYS SUPPLY field."
+43 DO DIR
IF PSODIR("DFLG")!PSODIR("FIELD")
GOTO REFILLX
+44 SET (PSODIR("N# REF"),PSODIR("# OF REFILLS"))=Y
REFILLX IF $GET(PSODIR("# OF REFILLS"))']""
SET PSODIR("# OF REFILLS")=$SELECT($GET(PSODIR("N# REF"))]"":PSODIR("N# REF"),$GET(PSOX1)]""&($GET(PSOX)>PSOX1):PSOX1,1:PSOX)
+1 KILL X,Y,PSOX,PSOX1,PSDY,PSDY1,DEA,PSOCS
+2 QUIT
+3 ;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
DIRS ; EP - IHS/CIA/PLS - 12/23/03 - New entry point DIRS added.
+1 IF $DATA(DUOUT)!($DATA(DTOUT))!($DATA(DIROUT))
IF $LENGTH($GET(X))'>1!(Y="")
SET PSODIR("DFLG")=1
GOTO DIRX
+2 IF $DATA(DIRUT)!($DATA(DIROUT))
IF $GET(SPEED)
SET PSODIR("DFLG")=1
GOTO DIRX
+3 IF X[U
IF $LENGTH(X)>1
DO JUMP
DIRX KILL DIRUT,DTOUT,DUOUT,DIROUT
+1 QUIT
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 SET X="^"_X
+1 QUIT
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
