PSOREF0 ;IHS/JCM - REFILL CON'T ; July 31, 2023@17:05:28
;;7.0;OUTPATIENT PHARMACY;**14,152,180,186,204,306,382,388,501,441,677,712**;DEC 1997;Build 20
;
; Reference to ^PSDRUG in ICR #221
;
;PSO*186 add check for DEA Special handling field refill restrictions
PROCESS ;
K PSODF S PSOREF("RX0")=^PSRX(PSOREF("IRXN"),0),PSOREF("RX2")=^(2),PSOREF("RX3")=^(3),PSOREF("STA")=+$G(^("STA")),PSOREF("SIG")=$P($G(^("SIG")),"^"),PSOREF("PSODFN")=$P(PSOREF("RX0"),"^",2)
S PSOREF("DAYS SUPPLY")=$P(PSOREF("RX0"),"^",8)
I $D(PSORX("BAR CODE")),PSODFN'=PSOREF("PSODFN") D NEWPT
W !,"Now refilling Rx# ",$P(PSOREF("RX0"),"^")_" Drug: "_$P(^PSDRUG($P(PSOREF("RX0"),"^",6),0),"^")
K ZD(PSOREF("IRXN")) ;*306
S PSOREF("DFLG")=0 D DSPLY G:PSOREF("DFLG") PROCESSX
I $G(PSOHRC) S PSOREF("QS")="S",PSOREF("MAIL/WINDOW")="M",PSORX("MAIL/WINDOW")="M",PSOHRCF=1 K VALMHDR
D CHECK G:$G(PSODF) PROCESS G:PSOREF("DFLG") PROCESSX D EN^PSOR52(.PSOREF)
I $G(UNPARK) D ^PSOBUILD G PROCESSX
G:$G(PSODF) PROCESS G:PSOREF("DFLG") PROCESSX
; NEW REFILLS CAN'T BE FILED AS PARKED
I $G(^PSRX(PSOREF("IRXN"),"PARK")) D KILLPARK^PSOPRK(PSOREF("IRXN")),RXACT^PSOPRK(PSOREF("IRXN"),"UPK")
;D EN^PSOR52(.PSOREF)
S:$G(PSOREF("MAIL/WINDOW"))["W" BINGRTE="W",BINGCRT=1
PROCESSX D:$G(PSOREF("OLD FILL DATE"))]"" SUSDATEK^PSOUTIL(.PSOREF)
S:$G(UNPARK) PSOREF("DFLG")=0
Q
DSPLY ;W !!,$P(PSOREF("RX0"),"^"),?12," ",$P(^PSDRUG($P(PSOREF("RX0"),"^",6),0),"^"),?45," SIG: "_PSOREF("SIG"),?60," QTY: ",$P(PSOREF("RX0"),"^",7)
K FSIG,BSIG I $P($G(^PSRX(PSOREF("IRXN"),"SIG")),"^",2) D FSIG^PSOUTLA("R",PSOREF("IRXN"),54) F PSREV=1:1 Q:'$D(FSIG(PSREV)) S BSIG(PSREV)=FSIG(PSREV)
K FSIG,PSREV I '$P($G(^PSRX(PSOREF("IRXN"),"SIG")),"^",2) D EN2^PSOUTLA1(PSOREF("IRXN"),54)
W !!,"Qty: ",$P(PSOREF("RX0"),"^",7),?19,"Sig: ",$G(BSIG(1))
I $O(BSIG(1)) F PSREV=1:0 S PSREV=$O(BSIG(PSREV)) Q:'PSREV W !?24,$G(BSIG(PSREV))
K BSIG,PSREV
DSPLYX Q
CHECK ;
I '$G(ORRFILL) N UNPARK S UNPARK=0
I '$P(PSOPAR,"^",11),$G(^PSDRUG($P(PSOREF("RX0"),"^",6),"I"))]"",DT>$G(^("I")) D G CKQ
.W $C(7),!!," *** Drug is inactive for Rx # "_$P(PSOREF("RX0"),"^")_" cannot be refilled ***",!
I '$D(PSORX("BAR CODE")),PSOREF("PSODFN")'=PSODFN W !!,?5,$C(7),"Can't refill Rx # "_$P(PSOREF("RX0"),"^")_", it is not for this patient." G CKQ
S (PSOY,STA)=""
I $G(PSOSD) F S STA=$O(PSOSD(STA)) Q:STA=""!(PSOREF("DFLG")) D ;I UNPARK G CHECKX
.S PSOX="" F S PSOX=$O(PSOSD(STA,PSOX)) Q:PSOX=""!(PSOREF("DFLG")) D
..I PSOREF("IRXN")=+PSOSD(STA,PSOX) S PSOY=PSOSD(STA,PSOX) I $P(PSOY,"^",4)]"" D
... S UNPARK=0 ;441 PAPI
... D CHKPARK^PSOPRKA(PSOREF("IRXN"),.RESULT) I +RESULT D UNPARK S PSOREF("DFLG")=1 Q
... S PSOREF("DFLG")=1 W:'$G(PSOERR) !,$C(7),"Cannot refill Rx # "_$P(PSOREF("RX0"),"^") S PSOREA=$P(PSOY,"^",4),PSOSTAT=PSOREF("STA")
... D STATUS^PSOUTIL(PSOREA,PSOSTAT) K PSOREA,PSOSTAT
... Q
I PSOY="" W !,$C(7),"Cannot refill, Rx is discontinued or expired. Later Rx may exist.",! D I $G(PSODF) Q
.D LOOK^PSOREF2 I $G(PSODF) Q
.S PSOREF("DFLG")=1
I '$G(PSOREF("DFLG")),'UNPARK D ;I UNPARK G CHECKX ;441 PAPI
. S UNPARK=0
. I $P(PSOY,"^",2)=0,$G(^PSRX(PSOREF("IRXN"),"PARK")) S PSOREF("DFLG")=1 K PSOX,PSOY D UNPARK
K PSOX,PSOY G:PSOREF("DFLG") CHECKX
I 'UNPARK I $O(^PS(52.5,"B",PSOREF("IRXN"),0)),'$G(^PS(52.5,+$O(^PS(52.5,"B",PSOREF("IRXN"),0)),"P")) W !,$C(7),"Rx is in suspense and cannot be refilled" S PSOREF("DFLG")=1 G CHECKX
;
S PSOREF("RXSTATUS")=PSOREF("STA")
I PSOREF("RXSTATUS"),PSOREF("RXSTATUS")'=6 D G CHECKX
. S PSOY=";"_PSOREF("RXSTATUS"),PSOX=$P(^DD(52,100,0),"^",3),PSOY=$F(PSOX,PSOY),PSOY=$P($E(PSOX,PSOY,999),";",1)
. W !,$C(7),"Rx is in "_PSOY_" status, cannot be refilled" S PSOREF("DFLG")=1
D CHKDIV G:PSOREF("DFLG") CHECKX
D NUMBER I PSOREF("NUMBER")>$P(PSOREF("RX0"),"^",9) W !?5,"Can't refill, no refills remaining." S PSOREF("DFLG")=1 G CHECKX
;
;PSO*7*186 check DEA, SPEC HNDLG field, in case changed, and apply
N PSODRG,PSODEA,PSODAY,PSOCHECK
S PSODRG=$G(^PSDRUG($P(PSOREF("RX0"),U,6),0)),PSODEA=$P(PSODRG,U,3)
S PSODAY=$P(PSOREF("RX0"),U,8)
S PSOCHECK=$$DEACHK^PSOUTLA1(PSOREF("IRXN"),PSODEA,PSODAY)
I PSOCHECK S PSOREF("DFLG")=1 W $C(7),!! D G CHECKX
. I PSOCHECK=1 W "Requested refill exceeds maximum allowable days supply for Rx.",! Q ;*388
. W "Current drug DEA/SPECIAL HANDLING code does not allow refills.",! ;*388
. N DIR,DIRUT,DUOUT,DTOUT S DIR(0)="E",DIR("A")="Press Return to Continue" D ^DIR ;*501
;
D DATES
CHECKX Q
CKQ ;
S PSOREF("DFLG")=1 D PAUSE^VALM1 G CHECKX
Q
;
CHKDIV G:$P(PSOREF("RX2"),"^",9)=+PSOSITE&'$G(PSOBBC("PSOVEXRX")) CHKDIVX ;p677 multi division update for telephone refill process
W !?5,$C(7),"RX # ",$P(PSOREF("RX0"),"^")," is for (",$P(^PS(59,$P(PSOREF("RX2"),"^",9),0),"^"),") division."
I '$P($G(PSOSYS),"^",2) S (PSOREF("DFLG"),PSOMHV)=1 W !,"********* Not Refilled *********" G CHKDIVX
D:$P($G(PSOSYS),"^",3) DIR
CHKDIVX Q
;
NUMBER K PSOX,PSOY S PSOREF("# OF REFILLS")=0
;I '$P(PSOREF("RX0"),"^",9) S PSOREF("NUMBER")=0 Q
;I '$O(^PSRX(PSOREF("IRXN"),"L",0)) S PSOREF("NUMBER")=0 Q
I $G(^PSRX(PSOREF("IRXN"),1,0))]"" F PSOX=0:0 S PSOX=$O(^PSRX(PSOREF("IRXN"),1,PSOX)) Q:'PSOX S PSOREF("# OF REFILLS")=PSOX
S PSOREF("NUMBER")=PSOREF("# OF REFILLS")+1
Q
;
DATES S PSOREF("STOP DATE")=$P(PSOREF("RX2"),"^",6) D NEXT^PSOUTIL(.PSOREF)
D:$G(PSOBBC("QFLG"))&($P(PSOPAR,"^",6)) EDATE Q:$G(PSOREF("DFLG"))
S PSOREF("FILL DATE")=$S($G(PSOREF("FILL DATE")):PSOREF("FILL DATE"),1:DT)
I $P(PSOPAR,"^",6),PSOREF("FILL DATE")<$P(PSOREF("RX3"),"^",2) D SUSDATE^PSOUTIL(.PSOREF)
;
I PSOREF("FILL DATE")>PSOREF("STOP DATE") D
. W !!?5,$C(7),"Can't refill, Refill Date ",$E(PSOREF("FILL DATE"),4,5),"/",$E(PSOREF("FILL DATE"),6,7),"/"
. W $E(PSOREF("FILL DATE"),2,3)," is past Expiration Date ",$E(PSOREF("STOP DATE"),4,5),"/",$E(PSOREF("STOP DATE"),6,7),"/"
. W $E(PSOREF("STOP DATE"),2,3) S PSOREF("DFLG")=1
EDATE S PSOREF("LAST REFILL DATE")=$P(PSOREF("RX3"),"^",1)
I PSOREF("LAST REFILL DATE"),PSOREF("FILL DATE")=PSOREF("LAST REFILL DATE") D G DATESX
. W !?5,"Can't refill, Fill Date already exists for ",$E(PSOREF("FILL DATE"),4,5),"/",$E(PSOREF("FILL DATE"),6,7),"/",$E(PSOREF("FILL DATE"),2,3)
. S PSOREF("DFLG")=1
I PSOREF("LAST REFILL DATE"),PSOREF("FILL DATE")<PSOREF("LAST REFILL DATE") D G DATESX
. W !?5,"Can't refill, later Refill Date already exists for ",$E(PSOREF("LAST REFILL DATE"),4,5),"/",$E(PSOREF("LAST REFILL DATE"),6,7),"/",$E(PSOREF("LAST REFILL DATE"),2,3)
. S PSOREF("DFLG")=1
I '$P(PSOPAR,"^",6),'$D(PSOREF("EAOK")),$P(PSOREF("RX3"),"^",2)>PSOREF("FILL DATE") D
. S PSOX1=(PSOREF("NUMBER")+1)*PSOREF("DAYS SUPPLY")-10
. W !?5,$C(7),"LESS THAN ",PSOX1," DAYS FOR ",PSOREF("NUMBER")+1," FILLS",! D DIR K PSOX1
I '$P(PSOPAR,"^",6),$G(PSOREF("EAOK"))=0,$P(PSOREF("RX3"),"^",2)>PSOREF("FILL DATE") D
. S Y=$P(PSOREF("RX3"),"^",2) D DD^%DT W !!,$C(7),"Cannot be refilled until "_Y_"." S (PSOREF("DFLG"),PSOMHV)=1 K Y
DATESX Q
DIR K DIR,X,Y S DIR(0)="Y",DIR("A")="Continue ",DIR("B")="N",DIR("?")="Answer YES to Refill, NO to bypass"
D ^DIR K DIR S:$D(DIRUT)!('Y) (PSOREF("DFLG"),PSOMHV)=1 K DIRUT,DTOUT,DUOUT,X,Y
Q
NEWPT S PSOQFLG=0,(DFN,PSODFN)=PSOREF("PSODFN") D ^PSOPTPST I PSOQFLG S PSOREF("DFLG")=1,PSOQFLG=0 G NEWPTX
D PROFILE^PSOREF1
NEWPTX Q
;
UNPARK ; 441 PAPI
N ERRMSG
D UNPARK^PSOPRKA(PSOREF("IRXN"),PSODFN,.ERRMSG) ; UNPARK regardless of original or refill
W !,"Rx # "_$P(PSOREF("RX0"),"^")," Unparked."
I $G(ERRMSG(1))'="" D
. W $C(7)," ",ERRMSG(1) ; message if unable to fill/refill
. N DIR,DIRUT,DUOUT,DTOUT S DIR(0)="E",DIR("A")="Press Return to Continue" D ^DIR
Q
;
EN(PSOREF) ; Entry Point for Batch Barcode Option
D PROCESS K DRUG,PSODF
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSOREF0 7830 printed Nov 22, 2024@17:43:26 Page 2
PSOREF0 ;IHS/JCM - REFILL CON'T ; July 31, 2023@17:05:28
+1 ;;7.0;OUTPATIENT PHARMACY;**14,152,180,186,204,306,382,388,501,441,677,712**;DEC 1997;Build 20
+2 ;
+3 ; Reference to ^PSDRUG in ICR #221
+4 ;
+5 ;PSO*186 add check for DEA Special handling field refill restrictions
PROCESS ;
+1 KILL PSODF
SET PSOREF("RX0")=^PSRX(PSOREF("IRXN"),0)
SET PSOREF("RX2")=^(2)
SET PSOREF("RX3")=^(3)
SET PSOREF("STA")=+$GET(^("STA"))
SET PSOREF("SIG")=$PIECE($GET(^("SIG")),"^")
SET PSOREF("PSODFN")=$PIECE(PSOREF("RX0"),"^",2)
+2 SET PSOREF("DAYS SUPPLY")=$PIECE(PSOREF("RX0"),"^",8)
+3 IF $DATA(PSORX("BAR CODE"))
IF PSODFN'=PSOREF("PSODFN")
DO NEWPT
+4 WRITE !,"Now refilling Rx# ",$PIECE(PSOREF("RX0"),"^")_" Drug: "_$PIECE(^PSDRUG($PIECE(PSOREF("RX0"),"^",6),0),"^")
+5 ;*306
KILL ZD(PSOREF("IRXN"))
+6 SET PSOREF("DFLG")=0
DO DSPLY
if PSOREF("DFLG")
GOTO PROCESSX
+7 IF $GET(PSOHRC)
SET PSOREF("QS")="S"
SET PSOREF("MAIL/WINDOW")="M"
SET PSORX("MAIL/WINDOW")="M"
SET PSOHRCF=1
KILL VALMHDR
+8 DO CHECK
if $GET(PSODF)
GOTO PROCESS
if PSOREF("DFLG")
GOTO PROCESSX
DO EN^PSOR52(.PSOREF)
+9 IF $GET(UNPARK)
DO ^PSOBUILD
GOTO PROCESSX
+10 if $GET(PSODF)
GOTO PROCESS
if PSOREF("DFLG")
GOTO PROCESSX
+11 ; NEW REFILLS CAN'T BE FILED AS PARKED
+12 IF $GET(^PSRX(PSOREF("IRXN"),"PARK"))
DO KILLPARK^PSOPRK(PSOREF("IRXN"))
DO RXACT^PSOPRK(PSOREF("IRXN"),"UPK")
+13 ;D EN^PSOR52(.PSOREF)
+14 if $GET(PSOREF("MAIL/WINDOW"))["W"
SET BINGRTE="W"
SET BINGCRT=1
PROCESSX if $GET(PSOREF("OLD FILL DATE"))]""
DO SUSDATEK^PSOUTIL(.PSOREF)
+1 if $GET(UNPARK)
SET PSOREF("DFLG")=0
+2 QUIT
DSPLY ;W !!,$P(PSOREF("RX0"),"^"),?12," ",$P(^PSDRUG($P(PSOREF("RX0"),"^",6),0),"^"),?45," SIG: "_PSOREF("SIG"),?60," QTY: ",$P(PSOREF("RX0"),"^",7)
+1 KILL FSIG,BSIG
IF $PIECE($GET(^PSRX(PSOREF("IRXN"),"SIG")),"^",2)
DO FSIG^PSOUTLA("R",PSOREF("IRXN"),54)
FOR PSREV=1:1
if '$DATA(FSIG(PSREV))
QUIT
SET BSIG(PSREV)=FSIG(PSREV)
+2 KILL FSIG,PSREV
IF '$PIECE($GET(^PSRX(PSOREF("IRXN"),"SIG")),"^",2)
DO EN2^PSOUTLA1(PSOREF("IRXN"),54)
+3 WRITE !!,"Qty: ",$PIECE(PSOREF("RX0"),"^",7),?19,"Sig: ",$GET(BSIG(1))
+4 IF $ORDER(BSIG(1))
FOR PSREV=1:0
SET PSREV=$ORDER(BSIG(PSREV))
if 'PSREV
QUIT
WRITE !?24,$GET(BSIG(PSREV))
+5 KILL BSIG,PSREV
DSPLYX QUIT
CHECK ;
+1 IF '$GET(ORRFILL)
NEW UNPARK
SET UNPARK=0
+2 IF '$PIECE(PSOPAR,"^",11)
IF $GET(^PSDRUG($PIECE(PSOREF("RX0"),"^",6),"I"))]""
IF DT>$GET(^("I"))
Begin DoDot:1
+3 WRITE $CHAR(7),!!," *** Drug is inactive for Rx # "_$PIECE(PSOREF("RX0"),"^")_" cannot be refilled ***",!
End DoDot:1
GOTO CKQ
+4 IF '$DATA(PSORX("BAR CODE"))
IF PSOREF("PSODFN")'=PSODFN
WRITE !!,?5,$CHAR(7),"Can't refill Rx # "_$PIECE(PSOREF("RX0"),"^")_", it is not for this patient."
GOTO CKQ
+5 SET (PSOY,STA)=""
+6 ;I UNPARK G CHECKX
IF $GET(PSOSD)
FOR
SET STA=$ORDER(PSOSD(STA))
if STA=""!(PSOREF("DFLG"))
QUIT
Begin DoDot:1
+7 SET PSOX=""
FOR
SET PSOX=$ORDER(PSOSD(STA,PSOX))
if PSOX=""!(PSOREF("DFLG"))
QUIT
Begin DoDot:2
+8 IF PSOREF("IRXN")=+PSOSD(STA,PSOX)
SET PSOY=PSOSD(STA,PSOX)
IF $PIECE(PSOY,"^",4)]""
Begin DoDot:3
+9 ;441 PAPI
SET UNPARK=0
+10 DO CHKPARK^PSOPRKA(PSOREF("IRXN"),.RESULT)
IF +RESULT
DO UNPARK
SET PSOREF("DFLG")=1
QUIT
+11 SET PSOREF("DFLG")=1
if '$GET(PSOERR)
WRITE !,$CHAR(7),"Cannot refill Rx # "_$PIECE(PSOREF("RX0"),"^")
SET PSOREA=$PIECE(PSOY,"^",4)
SET PSOSTAT=PSOREF("STA")
+12 DO STATUS^PSOUTIL(PSOREA,PSOSTAT)
KILL PSOREA,PSOSTAT
+13 QUIT
End DoDot:3
End DoDot:2
End DoDot:1
+14 IF PSOY=""
WRITE !,$CHAR(7),"Cannot refill, Rx is discontinued or expired. Later Rx may exist.",!
Begin DoDot:1
+15 DO LOOK^PSOREF2
IF $GET(PSODF)
QUIT
+16 SET PSOREF("DFLG")=1
End DoDot:1
IF $GET(PSODF)
QUIT
+17 ;I UNPARK G CHECKX ;441 PAPI
IF '$GET(PSOREF("DFLG"))
IF 'UNPARK
Begin DoDot:1
+18 SET UNPARK=0
+19 IF $PIECE(PSOY,"^",2)=0
IF $GET(^PSRX(PSOREF("IRXN"),"PARK"))
SET PSOREF("DFLG")=1
KILL PSOX,PSOY
DO UNPARK
End DoDot:1
+20 KILL PSOX,PSOY
if PSOREF("DFLG")
GOTO CHECKX
+21 IF 'UNPARK
IF $ORDER(^PS(52.5,"B",PSOREF("IRXN"),0))
IF '$GET(^PS(52.5,+$ORDER(^PS(52.5,"B",PSOREF("IRXN"),0)),"P"))
WRITE !,$CHAR(7),"Rx is in suspense and cannot be refilled"
SET PSOREF("DFLG")=1
GOTO CHECKX
+22 ;
+23 SET PSOREF("RXSTATUS")=PSOREF("STA")
+24 IF PSOREF("RXSTATUS")
IF PSOREF("RXSTATUS")'=6
Begin DoDot:1
+25 SET PSOY=";"_PSOREF("RXSTATUS")
SET PSOX=$PIECE(^DD(52,100,0),"^",3)
SET PSOY=$FIND(PSOX,PSOY)
SET PSOY=$PIECE($EXTRACT(PSOX,PSOY,999),";",1)
+26 WRITE !,$CHAR(7),"Rx is in "_PSOY_" status, cannot be refilled"
SET PSOREF("DFLG")=1
End DoDot:1
GOTO CHECKX
+27 DO CHKDIV
if PSOREF("DFLG")
GOTO CHECKX
+28 DO NUMBER
IF PSOREF("NUMBER")>$PIECE(PSOREF("RX0"),"^",9)
WRITE !?5,"Can't refill, no refills remaining."
SET PSOREF("DFLG")=1
GOTO CHECKX
+29 ;
+30 ;PSO*7*186 check DEA, SPEC HNDLG field, in case changed, and apply
+31 NEW PSODRG,PSODEA,PSODAY,PSOCHECK
+32 SET PSODRG=$GET(^PSDRUG($PIECE(PSOREF("RX0"),U,6),0))
SET PSODEA=$PIECE(PSODRG,U,3)
+33 SET PSODAY=$PIECE(PSOREF("RX0"),U,8)
+34 SET PSOCHECK=$$DEACHK^PSOUTLA1(PSOREF("IRXN"),PSODEA,PSODAY)
+35 IF PSOCHECK
SET PSOREF("DFLG")=1
WRITE $CHAR(7),!!
Begin DoDot:1
+36 ;*388
IF PSOCHECK=1
WRITE "Requested refill exceeds maximum allowable days supply for Rx.",!
QUIT
+37 ;*388
WRITE "Current drug DEA/SPECIAL HANDLING code does not allow refills.",!
+38 ;*501
NEW DIR,DIRUT,DUOUT,DTOUT
SET DIR(0)="E"
SET DIR("A")="Press Return to Continue"
DO ^DIR
End DoDot:1
GOTO CHECKX
+39 ;
+40 DO DATES
CHECKX QUIT
CKQ ;
+1 SET PSOREF("DFLG")=1
DO PAUSE^VALM1
GOTO CHECKX
+2 QUIT
+3 ;
CHKDIV ;p677 multi division update for telephone refill process
if $PIECE(PSOREF("RX2"),"^",9)=+PSOSITE&'$GET(PSOBBC("PSOVEXRX"))
GOTO CHKDIVX
+1 WRITE !?5,$CHAR(7),"RX # ",$PIECE(PSOREF("RX0"),"^")," is for (",$PIECE(^PS(59,$PIECE(PSOREF("RX2"),"^",9),0),"^"),") division."
+2 IF '$PIECE($GET(PSOSYS),"^",2)
SET (PSOREF("DFLG"),PSOMHV)=1
WRITE !,"********* Not Refilled *********"
GOTO CHKDIVX
+3 if $PIECE($GET(PSOSYS),"^",3)
DO DIR
CHKDIVX QUIT
+1 ;
NUMBER KILL PSOX,PSOY
SET PSOREF("# OF REFILLS")=0
+1 ;I '$P(PSOREF("RX0"),"^",9) S PSOREF("NUMBER")=0 Q
+2 ;I '$O(^PSRX(PSOREF("IRXN"),"L",0)) S PSOREF("NUMBER")=0 Q
+3 IF $GET(^PSRX(PSOREF("IRXN"),1,0))]""
FOR PSOX=0:0
SET PSOX=$ORDER(^PSRX(PSOREF("IRXN"),1,PSOX))
if 'PSOX
QUIT
SET PSOREF("# OF REFILLS")=PSOX
+4 SET PSOREF("NUMBER")=PSOREF("# OF REFILLS")+1
+5 QUIT
+6 ;
DATES SET PSOREF("STOP DATE")=$PIECE(PSOREF("RX2"),"^",6)
DO NEXT^PSOUTIL(.PSOREF)
+1 if $GET(PSOBBC("QFLG"))&($PIECE(PSOPAR,"^",6))
DO EDATE
if $GET(PSOREF("DFLG"))
QUIT
+2 SET PSOREF("FILL DATE")=$SELECT($GET(PSOREF("FILL DATE")):PSOREF("FILL DATE"),1:DT)
+3 IF $PIECE(PSOPAR,"^",6)
IF PSOREF("FILL DATE")<$PIECE(PSOREF("RX3"),"^",2)
DO SUSDATE^PSOUTIL(.PSOREF)
+4 ;
+5 IF PSOREF("FILL DATE")>PSOREF("STOP DATE")
Begin DoDot:1
+6 WRITE !!?5,$CHAR(7),"Can't refill, Refill Date ",$EXTRACT(PSOREF("FILL DATE"),4,5),"/",$EXTRACT(PSOREF("FILL DATE"),6,7),"/"
+7 WRITE $EXTRACT(PSOREF("FILL DATE"),2,3)," is past Expiration Date ",$EXTRACT(PSOREF("STOP DATE"),4,5),"/",$EXTRACT(PSOREF("STOP DATE"),6,7),"/"
+8 WRITE $EXTRACT(PSOREF("STOP DATE"),2,3)
SET PSOREF("DFLG")=1
End DoDot:1
EDATE SET PSOREF("LAST REFILL DATE")=$PIECE(PSOREF("RX3"),"^",1)
+1 IF PSOREF("LAST REFILL DATE")
IF PSOREF("FILL DATE")=PSOREF("LAST REFILL DATE")
Begin DoDot:1
+2 WRITE !?5,"Can't refill, Fill Date already exists for ",$EXTRACT(PSOREF("FILL DATE"),4,5),"/",$EXTRACT(PSOREF("FILL DATE"),6,7),"/",$EXTRACT(PSOREF("FILL DATE"),2,3)
+3 SET PSOREF("DFLG")=1
End DoDot:1
GOTO DATESX
+4 IF PSOREF("LAST REFILL DATE")
IF PSOREF("FILL DATE")<PSOREF("LAST REFILL DATE")
Begin DoDot:1
+5 WRITE !?5,"Can't refill, later Refill Date already exists for ",$EXTRACT(PSOREF("LAST REFILL DATE"),4,5),"/",$EXTRACT(PSOREF("LAST REFILL DATE"),6,7),"/",$EXTRACT(PSOREF("LAST REFILL DATE"),2,3)
+6 SET PSOREF("DFLG")=1
End DoDot:1
GOTO DATESX
+7 IF '$PIECE(PSOPAR,"^",6)
IF '$DATA(PSOREF("EAOK"))
IF $PIECE(PSOREF("RX3"),"^",2)>PSOREF("FILL DATE")
Begin DoDot:1
+8 SET PSOX1=(PSOREF("NUMBER")+1)*PSOREF("DAYS SUPPLY")-10
+9 WRITE !?5,$CHAR(7),"LESS THAN ",PSOX1," DAYS FOR ",PSOREF("NUMBER")+1," FILLS",!
DO DIR
KILL PSOX1
End DoDot:1
+10 IF '$PIECE(PSOPAR,"^",6)
IF $GET(PSOREF("EAOK"))=0
IF $PIECE(PSOREF("RX3"),"^",2)>PSOREF("FILL DATE")
Begin DoDot:1
+11 SET Y=$PIECE(PSOREF("RX3"),"^",2)
DO DD^%DT
WRITE !!,$CHAR(7),"Cannot be refilled until "_Y_"."
SET (PSOREF("DFLG"),PSOMHV)=1
KILL Y
End DoDot:1
DATESX QUIT
DIR KILL DIR,X,Y
SET DIR(0)="Y"
SET DIR("A")="Continue "
SET DIR("B")="N"
SET DIR("?")="Answer YES to Refill, NO to bypass"
+1 DO ^DIR
KILL DIR
if $DATA(DIRUT)!('Y)
SET (PSOREF("DFLG"),PSOMHV)=1
KILL DIRUT,DTOUT,DUOUT,X,Y
+2 QUIT
NEWPT SET PSOQFLG=0
SET (DFN,PSODFN)=PSOREF("PSODFN")
DO ^PSOPTPST
IF PSOQFLG
SET PSOREF("DFLG")=1
SET PSOQFLG=0
GOTO NEWPTX
+1 DO PROFILE^PSOREF1
NEWPTX QUIT
+1 ;
UNPARK ; 441 PAPI
+1 NEW ERRMSG
+2 ; UNPARK regardless of original or refill
DO UNPARK^PSOPRKA(PSOREF("IRXN"),PSODFN,.ERRMSG)
+3 WRITE !,"Rx # "_$PIECE(PSOREF("RX0"),"^")," Unparked."
+4 IF $GET(ERRMSG(1))'=""
Begin DoDot:1
+5 ; message if unable to fill/refill
WRITE $CHAR(7)," ",ERRMSG(1)
+6 NEW DIR,DIRUT,DUOUT,DTOUT
SET DIR(0)="E"
SET DIR("A")="Press Return to Continue"
DO ^DIR
End DoDot:1
+7 QUIT
+8 ;
EN(PSOREF) ; Entry Point for Batch Barcode Option
+1 DO PROCESS
KILL DRUG,PSODF
+2 QUIT
