PSOREF ;BIR/SAB - refill data entry ; Feb 14, 2023@10:12:23
;;7.0;OUTPATIENT PHARMACY;**1,23,27,36,46,78,130,131,148,206,313,441,710,712**;DEC 1997;Build 20
; Reference to ^PSDRUG in ICR #221
; Reference to PSOL^PSSLOCK,PSOUL^PSSLOCK in ICR #2789
;
EOJ ;
K PSOMSG,PSOREF,PSORX("BAR CODE"),PSOLIST,LFD,MAX,MIN,NODE,PS,PSOERR,REF,RF,RXO,RXN,RXP,RXS,SD,VAERR,PSORX("FILL DATE"),PTRX
D PSOUL^PSSLOCK($P(PSOLST(ORN),"^",2))
Q
OERR ;single refil
I $$LMREJ^PSOREJU1($P(PSOLST(ORN),"^",2),,.VALMSG,.VALMBCK) Q
I $D(RXRP($P(PSOLST(ORN),"^",2))) S VALMBCK="",VALMSG="A Reprint Label has been requested!" W $C(7) Q
I $D(RXPR($P(PSOLST(ORN),"^",2))) S VALMBCK="",VALMSG="A Partial has already been requested!" W $C(7) Q
I $D(RXRS($P(PSOLST(ORN),"^",2))) S VALMBCK="",VALMSG="Rx is being pulled from suspense!" W $C(7) Q
I $D(RXFL($P(PSOLST(ORN),"^",2))) S PTRX=$P(PSOLST(ORN),"^",2) D ^PSOCMOPT I '$G(PSOXFLAG) K PSOXFLAG S VALMBCK="",VALMSG="Fill already requested for CMOP!" Q
I $$TITRX^PSOUTL($P(PSOLST(ORN),"^",2))="t" S VALMBCK="",VALMSG="Cannot refill 'Titration Rx'." W $C(7) Q
K PSOXFLAG
D PSOL^PSSLOCK($P(PSOLST(ORN),"^",2)) I '$G(PSOMSG) S VALMSG=$S($P($G(PSOMSG),"^",2)'="":$P($G(PSOMSG),"^",2),1:"Another person is editing this order."),VALMBCK="" K PSOMSG Q
N RXN K PSORX("FILL DATE") D FULL^VALM1 S:$G(PSOFROM)'="NEW" PSOFROM="REFILL" S PSOREF("DFLG")=0,PSOREF("IRXN")=$P(PSOLST(ORN),"^",2),PSOREF("QFLG")=0
K PSOID D ^PSOREF1 I PSOREF("DFLG") D EOJ S VALMBCK="R" Q
D ^PSOREF0
W ! K DIR,DIRUT,DTOUT,DUOUT S DIR(0)="E",DIR("A")="Press Return to Continue" D ^DIR K DIR,DIRUT,DTOUT,DUOUT S PSORXED=1 D ^PSOBUILD,ACT^PSOORNE2 K PSORXED S VALMBCK="Q" D EOJ
Q
SPEED ;speed refill
K LST,PSORX("FILL DATE") N VALMCNT I '$G(PSOCNT) S VALMSG="This patient has no Prescriptions!" S VALMBCK="" Q
K DIR,DIRUT S DIR(0)="Y",DIR("B")="NO",DIR("A")="Barcode Refill",DIR("?")="If you want to use a barcode reader to process refills enter 'Y'."
D ^DIR K DIR,DUOUT,DTOUT I $D(DIRUT) S VALMBCK="" Q
G BCREF:Y
K PSOREF,PSOFDR,DIR,DUOUT,DIRUT S DIR("A")="Select Orders by number",DIR(0)="LO^1:"_PSOCNT D ^DIR I $D(DTOUT)!($D(DUOUT)) K DIR,DIRUT,DTOUT,DUOUT S VALMBCK="" Q
K DIR,DIRUT,DTOUT,PSOOELSE,DTOUT I +Y S (ASK,SPEED,PSOOELSE)=1 D FULL^VALM1 S LST=Y D I $G(PSOREF("DFLG"))!($G(PSOREF("QFLG"))) D ^PSOBUILD,BLD^PSOORUT1 G SPEEDX
.N ORD,ORN
.F ORD=1:1:$L(LST,",") Q:$P(LST,",",ORD)']""!($G(PSOREF("QFLG"))) S ORN=$P(LST,",",ORD) D:+PSOLST(ORN)=52
..I $$LMREJ^PSOREJU1($P(PSOLST(ORN),"^",2)) W $C(7),!!,"Rx "_$$GET1^DIQ(52,$P(PSOLST(ORN),"^",2),.01)_" has OPEN/UNRESOLVED 3rd Party Payer Reject!" K DIR D PAUSE^VALM1 Q
..I $$TITRX^PSOUTL($P(PSOLST(ORN),"^",2))="t" D Q
...W $C(7),!!,"Rx# "_$$GET1^DIQ(52,$P(PSOLST(ORN),"^",2),.01)_" is marked as 'Titration Rx' and cannot be refilled."
...K DIR D PAUSE^VALM1 Q
..D PSOL^PSSLOCK($P(PSOLST(ORN),"^",2)) I '$G(PSOMSG) W $C(7),!!,$S($P($G(PSOMSG),"^",2)'="":$P($G(PSOMSG),"^",2),1:"Another person is editing Rx "_$P(^PSRX($P(PSOLST(ORN),"^",2),0),"^")),! D PAUSE^VALM1 K PSOMSG Q
..K PSOMSG I $D(RXRP($P(PSOLST(ORN),"^",2))) W $C(7),!!,"A Reprint Label has been requested!" D ULK D PAUSE^VALM1 Q
..I $D(RXPR($P(PSOLST(ORN),"^",2))) W $C(7),!!,"A Partial has already been requested!" D ULK D PAUSE^VALM1 Q
..I $D(RXFL($P(PSOLST(ORN),"^",2))) S PTRX=$P(PSOLST(ORN),"^",2) D ^PSOCMOPT I '$G(PSOXFLAG) K PSOXFLAG W $C(7),!!,"A CMOP fill has already been requested for Rx "_$P($G(^PSRX($P(PSOLST(ORN),"^",2),0)),"^") D ULK D PAUSE^VALM1 Q
..K PSOXFLAG I $D(RXRS($P(PSOLST(ORN),"^",2))) W $C(7),!!,"Rx is being pulled from suspense!" D ULK D PAUSE^VALM1 Q
..I $P($G(^PSRX($P(PSOLST(ORN),"^",2),"STA")),"^")=11 D D ULK Q
...W $C(7),!!?5,"RX "_$P($G(^PSRX($P(PSOLST(ORN),"^",2),0)),"^")_" is in an EXPIRED status." W ! K DIR S DIR(0)="E",DIR("A")="Press Return to Continue" D ^DIR K DIR
..S PSOREF("IRXN")=$P(PSOLST(ORN),"^",2) I ASK D ^PSOREF1 S ASK=0 D:$G(PSOREF("QFLG")) ULK Q:$G(PSOREF("QFLG"))
..N RXN D FULL^VALM1 S:$G(PSOFROM)'="NEW" PSOFROM="REFILL" S PSOREF("DFLG")=0,PSOREF("IRXN")=$P(PSOLST(ORN),"^",2)
..I PSOREF("DFLG") D EOJ S VALMBCK="R" Q
..D ^PSOREF0 D ULK
S:'$G(PSOOELSE) VALMBCK=""
S PSORXED=1 D ^PSOBUILD,BLD^PSOORUT1
SPEEDX K PSOREF,PSORX("BAR CODE"),PSOLIST,LFD,MAX,MIN,NODE,PS,PSOERR,REF,RF,RXO,RXN,RXP,RXS,SD,VAERR,PSORX("FILL DATE")
K LST,SPEED,PSORXED,PSOREF,PSOFDR,PSOOELSE,ASK S:'$D(VALMBCK) VALMBCK="R"
K PSORX("FILL DATE"),PSORX("MAIL/WINDOW"),PSORX("METHOD OF PICK-UP")
Q
BCREF ;barcode refills
K LST,DIR,DIRUT,DUOUT,DTOUT D FULL^VALM1
ASK S DIR(0)="FO^5:245^K:X'?3N1""-""1.N X",DIR("A")="WAND BARCODE"
S DIR("?",1)="Wand the barcoded number of the prescription to be processed."
S DIR("?",2)="The number should be of the form NNN-NNNNNN",DIR("?",3)="where the number before the dash is your station number."
S DIR("?")="Enter ""^"", or a RETURN to quit."
D ^DIR I $D(DUOUT)!($D(DTOUT)) S VALMBCK="" G BCREFX
I $G(X)']"",'$G(LST) S VALMBCK="" G BCREFX
I $D(DIRUT),+$G(LST) D S VALMBCK="R" G BCREFX
.K DIR,DIRUT,DTOUT,PSOOELSE,DTOUT
.S (BCREF,ASK,SPEED,PSOOELSE)=1 D FULL^VALM1 D
..F ORD=1:1:$L(LST,",") Q:$P(LST,",",ORD)']""!($G(PSOREF("QFLG"))) S ORN=$P(LST,",",ORD) D:+PSOLST(ORN)=52
...I $$LMREJ^PSOREJU1($P(PSOLST(ORN),"^",2)) W $C(7),!!,"Rx "_$$GET1^DIQ(52,$P(PSOLST(ORN),"^",2),.01)_" has OPEN/UNRESOLVED 3rd Party Payer Reject!" K DIR D PAUSE^VALM1 Q
...I $$TITRX^PSOUTL($P(PSOLST(ORN),"^",2))="t" D Q
....W $C(7),!!,"Rx# "_$$GET1^DIQ(52,$P(PSOLST(ORN),"^",2),.01)_" is marked as 'Titration Rx' and cannot be refilled."
....K DIR D PAUSE^VALM1 Q
...D PSOL^PSSLOCK($P(PSOLST(ORN),"^",2)) I '$G(PSOMSG) W $C(7),!!,$S($P($G(PSOMSG),"^",2)'="":$P($G(PSOMSG),"^",2),1:"Another person is editing Rx "_$P(^PSRX($P(PSOLST(ORN),"^",2),0),"^")),! D PAUSE^VALM1 K PSOMSG Q
...K PSOMSG I $D(RXRP($P(PSOLST(ORN),"^",2))) W $C(7),!!,"A Reprint Label has been requested for Rx "_$P(^PSRX($P(PSOLST(ORN),"^",2),0),"^"),! D ULK D PAUSE^VALM1 Q
...I $D(RXPR($P(PSOLST(ORN),"^",2))) W $C(7),!!,"A Partial has already been requested for Rx "_$P(^PSRX($P(PSOLST(ORN),"^",2),0),"^"),! D ULK D PAUSE^VALM1 Q
...I $D(RXFL($P(PSOLST(ORN),"^",2))) S PTRX=$P(PSOLST(ORN),"^",2) D ^PSOCMOPT I '$G(PSOXFLAG) K PSOXFLAG W $C(7),!!,"A CMOP fill has already been requested for Rx "_$P($G(^PSRX($P(PSOLST(ORN),"^",2),0)),"^") D ULK D PAUSE^VALM1 Q
...K PSOXFLAG I $D(RXRS($P(PSOLST(ORN),"^",2))) W $C(7),!!,"Rx "_$P(^PSRX($P(PSOLST(ORN),"^",2),0),"^")_" is being pulled from suspense!" D ULK D PAUSE^VALM1 Q
...S PSOREF("IRXN")=$P(PSOLST(ORN),"^",2) I ASK D ^PSOREF1 S ASK=0 D:$G(PSOREF("DFLG")) ULK Q:$G(PSOREF("DFLG"))
...N RXN D FULL^VALM1 S:$G(PSOFROM)'="NEW" PSOFROM="REFILL" S PSOREF("DFLG")=0,PSOREF("IRXN")=$P(PSOLST(ORN),"^",2)
...I PSOREF("DFLG") D EOJ S VALMBCK="R" Q
...D ^PSOREF0 D ULK
F RX=1:1:PSOCNT I $P(PSOLST(RX),"^",2)=$P(X,"-",2) D Q
.I $D(PSOBBC(RX)) Q
.S LST=$G(LST)_RX_",",PSOBBC(RX)=1
G ASK
BCREFX K BCREF,ASK,LST,SPEED,RX,PSOBBC,DIR,DIRUT,PSORXED,PSOREF,PSOFDR,PSOOELSE S PSORXED=1 D ^PSOBUILD,BLD^PSOORUT1
S VALMBCK="R" Q
REFILL(PLACER) ;passes flag to CPRS for front door refill request
;PLACER=PHARMACY NUMBER
N PSORFRM,PSOLC,PSODRG,PSODRUG0,RXN,ST,PSODEA,DIV
I $G(PLACER)["S"!('$G(PLACER)) Q "-1^Not a Valid Outpatient Medication Order."
S RXN=PLACER I '$D(^PSRX(RXN,0)) Q "-1^Not a Valid Outpatient Medication Order."
S RX0=^PSRX(RXN,0),PSODRG=$P(^PSRX(RXN,0),"^",6),ST=+^("STA"),PSODRUG0=^PSDRUG(PSODRG,0),PSODEA=$P($G(^(0)),"^",3),DIV=$P(^PSRX(RXN,2),"^",9),PSORFRM=$P(RX0,"^",9)
I PSODEA["2" Q "0^Schedule 2 Drug. Order cannot be refilled."
I '$P($G(^PSRX(RXN,"OR1")),"^"),'$P($G(^PSDRUG(PSODRG,2)),"^") Q "0^Cannot Refill. Drug not matched to a Pharmacy Orderable Item."
I '$P($G(^PSRX(RXN,"OR1")),"^"),$P($G(^PSDRUG(PSODRG,2)),"^") S $P(^PSRX(RXN,"OR1"),"^")=$P(^PSDRUG(PSODRG,2),"^")
S CLOZPAT=$S($P($G(^PSDRUG(PSODRG,"CLOZ1")),"^")="PSOCLO1":1,1:0)
I 'CLOZPAT I PSODEA["A"&(PSODEA'["B")!(PSODEA["F")!(PSODEA[1)!(PSODEA[2) Q "0^"_$S(PSODEA["A":"Narcotic Drug. ",1:"")_"Order Non-Refillable."
K CLOZPAT I DT>$P($G(^PSRX(RXN,2)),"^",6) Q "0^Non-Refillable. Prescription has Expired."
I $P(^PSRX(RXN,3),"^",2)>$P(^PSRX(RXN,2),"^",6) Q "0^Next Refill Date Past Expiration Date. New Order Required."
I '$P($G(^PS(59,DIV,1)),"^",11),$G(^PSDRUG(PSODRG,"I"))]"",DT>$G(^("I")) Q "0^Inactive Drug, Non Refillable."
I ST Q "0^Prescription is in a Non-Refillable Status."
I $P($G(^PSDRUG(PSODRG,2)),"^",3)'["O" Q "0^Cannot Refill. Drug No Longer Used by Outpatient Pharmacy."
S PSORFRM=$P(RX0,"^",9) N PSOJ F PSOJ=0:0 S PSOJ=$O(^PSRX(RXN,1,PSOJ)) Q:'PSOJ S PSORFRM=PSORFRM-1
I $G(^PSRX(RXN,"PARK")) N RFGO S RFGO=$$REFNO(RXN) I 'RFGO Q "0^No Refills remaining. New Med order required." ;*712
I PSORFRM<1,'$G(RFGO) Q "0^No Refills remaining. New Med order required."
I $P(^PSRX(RXN,3),"^"),DT=$P(^PSRX(RXN,3),"^") Q "0^Can't Refill, Fill Date already exists for "_$E($P(^PSRX(RXN,3),"^"),4,5)_"/"_$E($P(^PSRX(RXN,3),"^"),6,7)_"/"_$E($P(^PSRX(RXN,3),"^"),2,3)_"."
I $P(^PSRX(RXN,3),"^"),DT<$P(^PSRX(RXN,3),"^") Q "0^Can't Refill, later Refill Date already exists for "_$E($P(^PSRX(RXN,3),"^"),4,5)_"/"_$E($P(^PSRX(RXN,3),"^"),6,7)_"/"_$E($P(^PSRX(RXN,3),"^"),2,3)_"."
I $O(^PS(52.41,"ARF",RXN,0)) Q "0^Pending Refill Request already exists."
Q 1
;
ULK D PSOUL^PSSLOCK($P(PSOLST(ORN),"^",2))
Q
;
REFNO(DA) ;
N RSDT,LBLP,PSOCMOP,RXF,I,RXC
S (I,RXF,RSDT,LBLP)=0,RXC=$P(^PSRX(DA,0),"^",9)
F S I=$O(^PSRX(DA,1,I)) Q:'I S RXF=I,RSDT=$P(^PSRX(DA,1,RXF,0),"^",18)
S:'RXF RSDT=$P(^PSRX(DA,2),"^",13)
I 'RSDT D CHKLBL^PSOPRKA(DA,RXF)
I 'RSDT,'LBLP D ^PSOCMOPA
I RXF=0,RXC>0 S RXF=RXC
I RSDT!(LBLP)!($D(PSOCMOP)) Q:'RXF 0 I RXF,PSORFRM<1 Q 0
Q 1
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSOREF 9832 printed Dec 13, 2024@02:33:27 Page 2
PSOREF ;BIR/SAB - refill data entry ; Feb 14, 2023@10:12:23
+1 ;;7.0;OUTPATIENT PHARMACY;**1,23,27,36,46,78,130,131,148,206,313,441,710,712**;DEC 1997;Build 20
+2 ; Reference to ^PSDRUG in ICR #221
+3 ; Reference to PSOL^PSSLOCK,PSOUL^PSSLOCK in ICR #2789
+4 ;
EOJ ;
+1 KILL PSOMSG,PSOREF,PSORX("BAR CODE"),PSOLIST,LFD,MAX,MIN,NODE,PS,PSOERR,REF,RF,RXO,RXN,RXP,RXS,SD,VAERR,PSORX("FILL DATE"),PTRX
+2 DO PSOUL^PSSLOCK($PIECE(PSOLST(ORN),"^",2))
+3 QUIT
OERR ;single refil
+1 IF $$LMREJ^PSOREJU1($PIECE(PSOLST(ORN),"^",2),,.VALMSG,.VALMBCK)
QUIT
+2 IF $DATA(RXRP($PIECE(PSOLST(ORN),"^",2)))
SET VALMBCK=""
SET VALMSG="A Reprint Label has been requested!"
WRITE $CHAR(7)
QUIT
+3 IF $DATA(RXPR($PIECE(PSOLST(ORN),"^",2)))
SET VALMBCK=""
SET VALMSG="A Partial has already been requested!"
WRITE $CHAR(7)
QUIT
+4 IF $DATA(RXRS($PIECE(PSOLST(ORN),"^",2)))
SET VALMBCK=""
SET VALMSG="Rx is being pulled from suspense!"
WRITE $CHAR(7)
QUIT
+5 IF $DATA(RXFL($PIECE(PSOLST(ORN),"^",2)))
SET PTRX=$PIECE(PSOLST(ORN),"^",2)
DO ^PSOCMOPT
IF '$GET(PSOXFLAG)
KILL PSOXFLAG
SET VALMBCK=""
SET VALMSG="Fill already requested for CMOP!"
QUIT
+6 IF $$TITRX^PSOUTL($PIECE(PSOLST(ORN),"^",2))="t"
SET VALMBCK=""
SET VALMSG="Cannot refill 'Titration Rx'."
WRITE $CHAR(7)
QUIT
+7 KILL PSOXFLAG
+8 DO PSOL^PSSLOCK($PIECE(PSOLST(ORN),"^",2))
IF '$GET(PSOMSG)
SET VALMSG=$SELECT($PIECE($GET(PSOMSG),"^",2)'="":$PIECE($GET(PSOMSG),"^",2),1:"Another person is editing this order.")
SET VALMBCK=""
KILL PSOMSG
QUIT
+9 NEW RXN
KILL PSORX("FILL DATE")
DO FULL^VALM1
if $GET(PSOFROM)'="NEW"
SET PSOFROM="REFILL"
SET PSOREF("DFLG")=0
SET PSOREF("IRXN")=$PIECE(PSOLST(ORN),"^",2)
SET PSOREF("QFLG")=0
+10 KILL PSOID
DO ^PSOREF1
IF PSOREF("DFLG")
DO EOJ
SET VALMBCK="R"
QUIT
+11 DO ^PSOREF0
+12 WRITE !
KILL DIR,DIRUT,DTOUT,DUOUT
SET DIR(0)="E"
SET DIR("A")="Press Return to Continue"
DO ^DIR
KILL DIR,DIRUT,DTOUT,DUOUT
SET PSORXED=1
DO ^PSOBUILD
DO ACT^PSOORNE2
KILL PSORXED
SET VALMBCK="Q"
DO EOJ
+13 QUIT
SPEED ;speed refill
+1 KILL LST,PSORX("FILL DATE")
NEW VALMCNT
IF '$GET(PSOCNT)
SET VALMSG="This patient has no Prescriptions!"
SET VALMBCK=""
QUIT
+2 KILL DIR,DIRUT
SET DIR(0)="Y"
SET DIR("B")="NO"
SET DIR("A")="Barcode Refill"
SET DIR("?")="If you want to use a barcode reader to process refills enter 'Y'."
+3 DO ^DIR
KILL DIR,DUOUT,DTOUT
IF $DATA(DIRUT)
SET VALMBCK=""
QUIT
+4 if Y
GOTO BCREF
+5 KILL PSOREF,PSOFDR,DIR,DUOUT,DIRUT
SET DIR("A")="Select Orders by number"
SET DIR(0)="LO^1:"_PSOCNT
DO ^DIR
IF $DATA(DTOUT)!($DATA(DUOUT))
KILL DIR,DIRUT,DTOUT,DUOUT
SET VALMBCK=""
QUIT
+6 KILL DIR,DIRUT,DTOUT,PSOOELSE,DTOUT
IF +Y
SET (ASK,SPEED,PSOOELSE)=1
DO FULL^VALM1
SET LST=Y
Begin DoDot:1
+7 NEW ORD,ORN
+8 FOR ORD=1:1:$LENGTH(LST,",")
if $PIECE(LST,",",ORD)']""!($GET(PSOREF("QFLG")))
QUIT
SET ORN=$PIECE(LST,",",ORD)
if +PSOLST(ORN)=52
Begin DoDot:2
+9 IF $$LMREJ^PSOREJU1($PIECE(PSOLST(ORN),"^",2))
WRITE $CHAR(7),!!,"Rx "_$$GET1^DIQ(52,$PIECE(PSOLST(ORN),"^",2),.01)_" has OPEN/UNRESOLVED 3rd Party Payer Reject!"
KILL DIR
DO PAUSE^VALM1
QUIT
+10 IF $$TITRX^PSOUTL($PIECE(PSOLST(ORN),"^",2))="t"
Begin DoDot:3
+11 WRITE $CHAR(7),!!,"Rx# "_$$GET1^DIQ(52,$PIECE(PSOLST(ORN),"^",2),.01)_" is marked as 'Titration Rx' and cannot be refilled."
+12 KILL DIR
DO PAUSE^VALM1
QUIT
End DoDot:3
QUIT
+13 DO PSOL^PSSLOCK($PIECE(PSOLST(ORN),"^",2))
IF '$GET(PSOMSG)
WRITE $CHAR(7),!!,$SELECT($PIECE($GET(PSOMSG),"^",2)'="":$PIECE($GET(PSOMSG),"^",2),1:"Another person is editing Rx "_$PIECE(^PSRX($PIECE(PSOLST(ORN),"^",2),0),"^")),!
DO PAUSE^VALM1
KILL PSOMSG
QUIT
+14 KILL PSOMSG
IF $DATA(RXRP($PIECE(PSOLST(ORN),"^",2)))
WRITE $CHAR(7),!!,"A Reprint Label has been requested!"
DO ULK
DO PAUSE^VALM1
QUIT
+15 IF $DATA(RXPR($PIECE(PSOLST(ORN),"^",2)))
WRITE $CHAR(7),!!,"A Partial has already been requested!"
DO ULK
DO PAUSE^VALM1
QUIT
+16 IF $DATA(RXFL($PIECE(PSOLST(ORN),"^",2)))
SET PTRX=$PIECE(PSOLST(ORN),"^",2)
DO ^PSOCMOPT
IF '$GET(PSOXFLAG)
KILL PSOXFLAG
WRITE $CHAR(7),!!,"A CMOP fill has already been requested for Rx "_$PIECE($GET(^PSRX($PIECE(PSOLST(ORN),"^",2),0)),"^")
DO ULK
DO PAUSE^VALM1
QUIT
+17 KILL PSOXFLAG
IF $DATA(RXRS($PIECE(PSOLST(ORN),"^",2)))
WRITE $CHAR(7),!!,"Rx is being pulled from suspense!"
DO ULK
DO PAUSE^VALM1
QUIT
+18 IF $PIECE($GET(^PSRX($PIECE(PSOLST(ORN),"^",2),"STA")),"^")=11
Begin DoDot:3
+19 WRITE $CHAR(7),!!?5,"RX "_$PIECE($GET(^PSRX($PIECE(PSOLST(ORN),"^",2),0)),"^")_" is in an EXPIRED status."
WRITE !
KILL DIR
SET DIR(0)="E"
SET DIR("A")="Press Return to Continue"
DO ^DIR
KILL DIR
End DoDot:3
DO ULK
QUIT
+20 SET PSOREF("IRXN")=$PIECE(PSOLST(ORN),"^",2)
IF ASK
DO ^PSOREF1
SET ASK=0
if $GET(PSOREF("QFLG"))
DO ULK
if $GET(PSOREF("QFLG"))
QUIT
+21 NEW RXN
DO FULL^VALM1
if $GET(PSOFROM)'="NEW"
SET PSOFROM="REFILL"
SET PSOREF("DFLG")=0
SET PSOREF("IRXN")=$PIECE(PSOLST(ORN),"^",2)
+22 IF PSOREF("DFLG")
DO EOJ
SET VALMBCK="R"
QUIT
+23 DO ^PSOREF0
DO ULK
End DoDot:2
End DoDot:1
IF $GET(PSOREF("DFLG"))!($GET(PSOREF("QFLG")))
DO ^PSOBUILD
DO BLD^PSOORUT1
GOTO SPEEDX
+24 if '$GET(PSOOELSE)
SET VALMBCK=""
+25 SET PSORXED=1
DO ^PSOBUILD
DO BLD^PSOORUT1
SPEEDX KILL PSOREF,PSORX("BAR CODE"),PSOLIST,LFD,MAX,MIN,NODE,PS,PSOERR,REF,RF,RXO,RXN,RXP,RXS,SD,VAERR,PSORX("FILL DATE")
+1 KILL LST,SPEED,PSORXED,PSOREF,PSOFDR,PSOOELSE,ASK
if '$DATA(VALMBCK)
SET VALMBCK="R"
+2 KILL PSORX("FILL DATE"),PSORX("MAIL/WINDOW"),PSORX("METHOD OF PICK-UP")
+3 QUIT
BCREF ;barcode refills
+1 KILL LST,DIR,DIRUT,DUOUT,DTOUT
DO FULL^VALM1
ASK SET DIR(0)="FO^5:245^K:X'?3N1""-""1.N X"
SET DIR("A")="WAND BARCODE"
+1 SET DIR("?",1)="Wand the barcoded number of the prescription to be processed."
+2 SET DIR("?",2)="The number should be of the form NNN-NNNNNN"
SET DIR("?",3)="where the number before the dash is your station number."
+3 SET DIR("?")="Enter ""^"", or a RETURN to quit."
+4 DO ^DIR
IF $DATA(DUOUT)!($DATA(DTOUT))
SET VALMBCK=""
GOTO BCREFX
+5 IF $GET(X)']""
IF '$GET(LST)
SET VALMBCK=""
GOTO BCREFX
+6 IF $DATA(DIRUT)
IF +$GET(LST)
Begin DoDot:1
+7 KILL DIR,DIRUT,DTOUT,PSOOELSE,DTOUT
+8 SET (BCREF,ASK,SPEED,PSOOELSE)=1
DO FULL^VALM1
Begin DoDot:2
+9 FOR ORD=1:1:$LENGTH(LST,",")
if $PIECE(LST,",",ORD)']""!($GET(PSOREF("QFLG")))
QUIT
SET ORN=$PIECE(LST,",",ORD)
if +PSOLST(ORN)=52
Begin DoDot:3
+10 IF $$LMREJ^PSOREJU1($PIECE(PSOLST(ORN),"^",2))
WRITE $CHAR(7),!!,"Rx "_$$GET1^DIQ(52,$PIECE(PSOLST(ORN),"^",2),.01)_" has OPEN/UNRESOLVED 3rd Party Payer Reject!"
KILL DIR
DO PAUSE^VALM1
QUIT
+11 IF $$TITRX^PSOUTL($PIECE(PSOLST(ORN),"^",2))="t"
Begin DoDot:4
+12 WRITE $CHAR(7),!!,"Rx# "_$$GET1^DIQ(52,$PIECE(PSOLST(ORN),"^",2),.01)_" is marked as 'Titration Rx' and cannot be refilled."
+13 KILL DIR
DO PAUSE^VALM1
QUIT
End DoDot:4
QUIT
+14 DO PSOL^PSSLOCK($PIECE(PSOLST(ORN),"^",2))
IF '$GET(PSOMSG)
WRITE $CHAR(7),!!,$SELECT($PIECE($GET(PSOMSG),"^",2)'="":$PIECE($GET(PSOMSG),"^",2),1:"Another person is editing Rx "_$PIECE(^PSRX($PIECE(PSOLST(ORN),"^",2),0),"^")),!
DO PAUSE^VALM1
KILL PSOMSG
QUIT
+15 KILL PSOMSG
IF $DATA(RXRP($PIECE(PSOLST(ORN),"^",2)))
WRITE $CHAR(7),!!,"A Reprint Label has been requested for Rx "_$PIECE(^PSRX($PIECE(PSOLST(ORN),"^",2),0),"^"),!
DO ULK
DO PAUSE^VALM1
QUIT
+16 IF $DATA(RXPR($PIECE(PSOLST(ORN),"^",2)))
WRITE $CHAR(7),!!,"A Partial has already been requested for Rx "_$PIECE(^PSRX($PIECE(PSOLST(ORN),"^",2),0),"^"),!
DO ULK
DO PAUSE^VALM1
QUIT
+17 IF $DATA(RXFL($PIECE(PSOLST(ORN),"^",2)))
SET PTRX=$PIECE(PSOLST(ORN),"^",2)
DO ^PSOCMOPT
IF '$GET(PSOXFLAG)
KILL PSOXFLAG
WRITE $CHAR(7),!!,"A CMOP fill has already been requested for Rx "_$PIECE($GET(^PSRX($PIECE(PSOLST(ORN),"^",2),0)),"^")
DO ULK
DO PAUSE^VALM1
QUIT
+18 KILL PSOXFLAG
IF $DATA(RXRS($PIECE(PSOLST(ORN),"^",2)))
WRITE $CHAR(7),!!,"Rx "_$PIECE(^PSRX($PIECE(PSOLST(ORN),"^",2),0),"^")_" is being pulled from suspense!"
DO ULK
DO PAUSE^VALM1
QUIT
+19 SET PSOREF("IRXN")=$PIECE(PSOLST(ORN),"^",2)
IF ASK
DO ^PSOREF1
SET ASK=0
if $GET(PSOREF("DFLG"))
DO ULK
if $GET(PSOREF("DFLG"))
QUIT
+20 NEW RXN
DO FULL^VALM1
if $GET(PSOFROM)'="NEW"
SET PSOFROM="REFILL"
SET PSOREF("DFLG")=0
SET PSOREF("IRXN")=$PIECE(PSOLST(ORN),"^",2)
+21 IF PSOREF("DFLG")
DO EOJ
SET VALMBCK="R"
QUIT
+22 DO ^PSOREF0
DO ULK
End DoDot:3
End DoDot:2
End DoDot:1
SET VALMBCK="R"
GOTO BCREFX
+23 FOR RX=1:1:PSOCNT
IF $PIECE(PSOLST(RX),"^",2)=$PIECE(X,"-",2)
Begin DoDot:1
+24 IF $DATA(PSOBBC(RX))
QUIT
+25 SET LST=$GET(LST)_RX_","
SET PSOBBC(RX)=1
End DoDot:1
QUIT
+26 GOTO ASK
BCREFX KILL BCREF,ASK,LST,SPEED,RX,PSOBBC,DIR,DIRUT,PSORXED,PSOREF,PSOFDR,PSOOELSE
SET PSORXED=1
DO ^PSOBUILD
DO BLD^PSOORUT1
+1 SET VALMBCK="R"
QUIT
REFILL(PLACER) ;passes flag to CPRS for front door refill request
+1 ;PLACER=PHARMACY NUMBER
+2 NEW PSORFRM,PSOLC,PSODRG,PSODRUG0,RXN,ST,PSODEA,DIV
+3 IF $GET(PLACER)["S"!('$GET(PLACER))
QUIT "-1^Not a Valid Outpatient Medication Order."
+4 SET RXN=PLACER
IF '$DATA(^PSRX(RXN,0))
QUIT "-1^Not a Valid Outpatient Medication Order."
+5 SET RX0=^PSRX(RXN,0)
SET PSODRG=$PIECE(^PSRX(RXN,0),"^",6)
SET ST=+^("STA")
SET PSODRUG0=^PSDRUG(PSODRG,0)
SET PSODEA=$PIECE($GET(^(0)),"^",3)
SET DIV=$PIECE(^PSRX(RXN,2),"^",9)
SET PSORFRM=$PIECE(RX0,"^",9)
+6 IF PSODEA["2"
QUIT "0^Schedule 2 Drug. Order cannot be refilled."
+7 IF '$PIECE($GET(^PSRX(RXN,"OR1")),"^")
IF '$PIECE($GET(^PSDRUG(PSODRG,2)),"^")
QUIT "0^Cannot Refill. Drug not matched to a Pharmacy Orderable Item."
+8 IF '$PIECE($GET(^PSRX(RXN,"OR1")),"^")
IF $PIECE($GET(^PSDRUG(PSODRG,2)),"^")
SET $PIECE(^PSRX(RXN,"OR1"),"^")=$PIECE(^PSDRUG(PSODRG,2),"^")
+9 SET CLOZPAT=$SELECT($PIECE($GET(^PSDRUG(PSODRG,"CLOZ1")),"^")="PSOCLO1":1,1:0)
+10 IF 'CLOZPAT
IF PSODEA["A"&(PSODEA'["B")!(PSODEA["F")!(PSODEA[1)!(PSODEA[2)
QUIT "0^"_$SELECT(PSODEA["A":"Narcotic Drug. ",1:"")_"Order Non-Refillable."
+11 KILL CLOZPAT
IF DT>$PIECE($GET(^PSRX(RXN,2)),"^",6)
QUIT "0^Non-Refillable. Prescription has Expired."
+12 IF $PIECE(^PSRX(RXN,3),"^",2)>$PIECE(^PSRX(RXN,2),"^",6)
QUIT "0^Next Refill Date Past Expiration Date. New Order Required."
+13 IF '$PIECE($GET(^PS(59,DIV,1)),"^",11)
IF $GET(^PSDRUG(PSODRG,"I"))]""
IF DT>$GET(^("I"))
QUIT "0^Inactive Drug, Non Refillable."
+14 IF ST
QUIT "0^Prescription is in a Non-Refillable Status."
+15 IF $PIECE($GET(^PSDRUG(PSODRG,2)),"^",3)'["O"
QUIT "0^Cannot Refill. Drug No Longer Used by Outpatient Pharmacy."
+16 SET PSORFRM=$PIECE(RX0,"^",9)
NEW PSOJ
FOR PSOJ=0:0
SET PSOJ=$ORDER(^PSRX(RXN,1,PSOJ))
if 'PSOJ
QUIT
SET PSORFRM=PSORFRM-1
+17 ;*712
IF $GET(^PSRX(RXN,"PARK"))
NEW RFGO
SET RFGO=$$REFNO(RXN)
IF 'RFGO
QUIT "0^No Refills remaining. New Med order required."
+18 IF PSORFRM<1
IF '$GET(RFGO)
QUIT "0^No Refills remaining. New Med order required."
+19 IF $PIECE(^PSRX(RXN,3),"^")
IF DT=$PIECE(^PSRX(RXN,3),"^")
QUIT "0^Can't Refill, Fill Date already exists for "_$EXTRACT($PIECE(^PSRX(RXN,3),"^"),4,5)_"/"_$EXTRACT($PIECE(^PSRX(RXN,3),"^"),6,7)_"/"_$EXTRACT($PIECE(^PSRX(RXN,3),"^"),2,3)_"."
+20 IF $PIECE(^PSRX(RXN,3),"^")
IF DT<$PIECE(^PSRX(RXN,3),"^")
QUIT "0^Can't Refill, later Refill Date already exists for "_$EXTRACT($PIECE(^PSRX(RXN,3),"^"),4,5)_"/"_$EXTRACT($PIECE(^PSRX(RXN,3),"^"),6,7)_"/"_$EXTRACT($PIECE(^PSRX(RXN,3),"^"),2,3)_"."
+21 IF $ORDER(^PS(52.41,"ARF",RXN,0))
QUIT "0^Pending Refill Request already exists."
+22 QUIT 1
+23 ;
ULK DO PSOUL^PSSLOCK($PIECE(PSOLST(ORN),"^",2))
+1 QUIT
+2 ;
REFNO(DA) ;
+1 NEW RSDT,LBLP,PSOCMOP,RXF,I,RXC
+2 SET (I,RXF,RSDT,LBLP)=0
SET RXC=$PIECE(^PSRX(DA,0),"^",9)
+3 FOR
SET I=$ORDER(^PSRX(DA,1,I))
if 'I
QUIT
SET RXF=I
SET RSDT=$PIECE(^PSRX(DA,1,RXF,0),"^",18)
+4 if 'RXF
SET RSDT=$PIECE(^PSRX(DA,2),"^",13)
+5 IF 'RSDT
DO CHKLBL^PSOPRKA(DA,RXF)
+6 IF 'RSDT
IF 'LBLP
DO ^PSOCMOPA
+7 IF RXF=0
IF RXC>0
SET RXF=RXC
+8 IF RSDT!(LBLP)!($DATA(PSOCMOP))
if 'RXF
QUIT 0
IF RXF
IF PSORFRM<1
QUIT 0
+9 QUIT 1
+10 ;
