PSORENW4 ;BIR/SAB - rx speed renew ;05-Jun-2014 08:45;DU
;;7.0;OUTPATIENT PHARMACY;**11,23,27,32,37,64,46,75,71,100,130,117,152,1004,1005,1009,148,264,225,301,1014,1016,1017**;DEC 1997;Build 40
;External reference to ^PSDRUG supported by DBIA 221
;External reference to ^PS(50.7 supported by DBIA 2223
;External references L, UL, PSOL, and PSOUL^PSSLOCK supported by DBIA 2789
;External reference to LK^ORX2 and ULK^ORX2 supported by DBIA 867
; Modified - IHS/CIA/PLS - 12/26/05 - Line PROCESS+18
; IHS/MSC/PLS - 12/09/10 - Added three lines at PROCESS+35
; 12/05/11 - Line PROCESS+1,PROCESS+3
; 06/24/13 - Line PROCESS+1
; 06/04/14 - Line PROCESS+33
SEL K PSODRUG ;PSO*7*301
I $P(PSOPAR,"^",4)=0 S VALMSG="Renewing is NOT Allowed. Check Site Parameters!",VALMBCK="" Q
N VALMCNT I '$G(PSOCNT) S VALMSG="This patient has no Prescriptions!",VALMBCK="" Q
S PSOPLCK=$$L^PSSLOCK(PSODFN,0) I '$G(PSOPLCK) D LOCK^PSOORCPY S VALMSG=$S($P($G(PSOPLCK),"^",2)'="":$P($G(PSOPLCK),"^",2)_" is working on this patient.",1:"Another person is entering orders for this patient.") K PSOPLCK S VALMBCK="" Q
K PSOPLCK S X=PSODFN_";DPT(" D LK^ORX2 I 'Y S VALMSG="Another person is entering orders for this patient.",VALMBCK="" D UL^PSSLOCK(PSODFN) Q
K PRC,PHI,PSORX("EDIT"),PSOFDR,DIR,DUOUT,DIRUT,PSORNSPD 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="" G SELQ
K DIR,DIRUT,DTOUT,PSOOELSE,DTOUT I +Y S (SPEED,PSOOELSE,PSORNSPD)=1 D FULL^VALM1 S LST=Y D
.S (PSODIR("DFLG"),PSODIR("FIELD"))=0,PSOOPT=3,(PSORENW("DFLG"),PSORENW("QFLG"),PSORX("DFLG"))=0 D INIT Q:PSORENW("DFLG")
.F ORD=1:1:$L(LST,",") Q:$P(LST,",",ORD)']"" S ORN=$P(LST,",",ORD) D:+PSOLST(ORN)=52 PROCESS S PSORENW("DFLG")=0
I '$G(PSOOELSE) S VALMBCK="" G SELQ
S VALMBCK="R"
D ^PSOBUILD,BLD^PSOORUT1 K DIR,DIRUT,DTOUT,DUOUT,LST,ORD,IEN,ORN,RPH,ST,REFL,REF,PSOACT,ORSV,PSORNW,PSORENW,PSONO,PSOCO,PSOCU,PSODIR,DSMSG,SPEED,PSORENW,PSOOELSE,PSOOPT,PSORX("FILL DATE"),PSORX("ISSUE DATE"),PSOID,PSOMSG,PSORX("DFLG"),PSOQTY
SELQ K PSORNSPD,RTE,DRET,PRC,PHI S X=PSODFN_";DPT(" D ULK^ORX2,UL^PSSLOCK(PSODFN),CLEAN^PSOVER1
Q
;
PROCESS ; Process one order at a time
;IHS/MSC/PLS - 06/24/2013
I $E($$GET1^DIQ(52,$P(PSOLST(ORN),U,2),.01),1)="X" D K DIR,PSOMSG D PAUSE^VALM1 Q
.W $C(7),!!,"Rx "_$$GET1^DIQ(52,$P(PSOLST(ORN),"^",2),.01)_" is an external prescription and can't be refilled!"
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 Rejects!" K DIR,PSOMSG 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),"^")),! K DIR,PSOMSG D PAUSE^VALM1 Q
N APSPDRG
K RET,DRET,PRC,PHI S PSORENW("OIRXN")=$P(PSOLST(ORN),"^",2),PSOFROM="NEW"
;IHS/MSC/MGH Text for REM medication. Patch 1013
S APSPDRG=$P($G(^PSRX(PSORENW("OIRXN"),0)),"^",6)
I +APSPDRG D REMMSG^APSPFUNC(APSPDRG)
S PSORENW("RX0")=^PSRX(PSORENW("OIRXN"),0),PSORENW("RX2")=^(2),PSORENW("RX3")=^(3),PSORENW("STA")=^("STA"),PSORENW("TN")=$G(^("TN")),SIGOK=$P($G(^PSRX(PSORENW("OIRXN"),"SIG")),"^",2)
I SIGOK F I=0:0 S I=$O(^PSRX(PSORENW("OIRXN"),"SIG1",I)) Q:'I S SIG(I)=^PSRX(PSORENW("OIRXN"),"SIG1",I,0)
S PSOIBOLD=$G(PSORENW("OIRXN")) D SETIB^PSORENW1
I '$G(PSORENW("PROVIDER")) D
.S PSORENW("PROVIDER")=$P(PSORENW("RX0"),"^",4)
.S:$P(PSORENW("RX3"),"^",3) PSORENW("COSIGNING PROVIDER")=$P(PSORENW("RX3"),"^",3)
S PSORX("PROVIDER NAME")=$P($G(^VA(200,PSORENW("PROVIDER"),0)),"^")
I '$G(PSORENW("CLINIC")) S PSORENW("CLINIC")=$P(PSORENW("RX0"),"^",5)
S PSORENW("REMARKS")="RENEWED FROM RX # "_$P(PSORENW("RX0"),"^")
S PSORENW("SIG")=$P($G(^PSRX(PSORENW("OIRXN"),"SIG")),"^")
S PSORENW("PSODFN")=$P(PSORENW("RX0"),"^",2)
S PSORENW("ORX #")=$P(PSORENW("RX0"),"^")
S PSORENW("DRUG IEN")=$P(PSORENW("RX0"),"^",6)
S PSORENW("QTY")=$P(PSORENW("RX0"),"^",7)
;S PSORENW("DAYS SUPPLY")=$P(PSORENW("RX0"),"^",8)
;S PSORENW("# OF REFILLS")=$P(PSORENW("RX0"),"^",9)
; IHS/CIA/PLS - 12/29/05 - Added IHS fields to array for RENEW prescription
N TALK
I $D(^PSRX(PSORENW("OIRXN"),9999999)) D
.S PSORENW("AWP")=$$AWP^APSQDAWP($P($G(PSORENW("RX2")),U,7),$G(PSORENW("DRUG IEN")),.TALK)
.S PSORENW("BST")=$P($G(^PSRX(PSORENW("OIRXN"),9999999)),U,7)
.S PSORENW("CM")=$P($G(^PSRX(PSORENW("OIRXN"),9999999)),U,2)
K PSORENW("NDC") ;IHS/MSC/PLS - 06/04/14
S PSORENW("INS")=$S($G(PSORENW("ENT"))]"":PSORENW("ENT"),1:$G(^PSRX(PSORENW("OIRXN"),"INS")))
S:$G(PSORENW("ENT"))']"" PSORENW("ENT")=0
F I=0:0 S I=$O(^PSRX(PSORENW("OIRXN"),6,I)) Q:'I S DOSE=^PSRX(PSORENW("OIRXN"),6,I,0) D
.S PSORENW("ENT")=PSORENW("ENT")+1,PSORENW("DOSE",PSORENW("ENT"))=$P(DOSE,"^")
.S PSORENW("UNITS",PSORENW("ENT"))=$P(DOSE,"^",3),PSORENW("DOSE ORDERED",PSORENW("ENT"))=$P(DOSE,"^",2),PSORENW("ROUTE",PSORENW("ENT"))=$P(DOSE,"^",7)
.S PSORENW("SCHEDULE",PSORENW("ENT"))=$P(DOSE,"^",8),PSORENW("DURATION",PSORENW("ENT"))=$P(DOSE,"^",5),PSORENW("CONJUNCTION",PSORENW("ENT"))=$P(DOSE,"^",6)
.S PSORENW("NOUN",PSORENW("ENT"))=$P(DOSE,"^",4),PSORENW("VERB",PSORENW("ENT"))=$P(DOSE,"^",9)
.I $G(^PSRX(PSORENW("OIRXN"),6,I,1))]"" S PSORENW("ODOSE",PSORENW("ENT"))=^PSRX(PSORENW("OIRXN"),6,I,1)
.K DOSE
I $P($G(^PSDRUG(PSORENW("DRUG IEN"),"CLOZ1")),"^")="PSOCLO1" N PSON S PSON=0 D I PSON K PSON D POZ,KLIB^PSORENW1 D PSOUL^PSSLOCK($P(PSOLST(ORN),"^",2)) Q
. I '$L($P(^VA(200,PSORENW("PROVIDER"),"PS"),"^",2)),'$L($P(^VA(200,PSORENW("PROVIDER"),"PS"),"^",3)) D Q
. . S PSON=1 W $C(7),!!,"Only providers with DEA# or a VA# can write prescriptions for clozapine.",!
. I '$D(^XUSEC("YSCL AUTHORIZED",PSORENW("PROVIDER"))) D
. . S PSON=1 W $C(7),!!,"Provider must hold YSCL AUTHORIZED key to write prescriptions for clozapine.",!
;IHS/MSC/JDS - 12/09/10 - Added next two lines for MDF
I '$$SCREEN^APSPMULT(+PSORENW("DRUG IEN"),,1) D D KLIB^PSORENW1 D PSOUL^PSSLOCK($P(PSOLST(ORN),"^",2)) Q
.W $C(7),!!,"Sorry, this drug is not currently available in this facility",!
I $G(PSORNW("MAIL/WINDOW"))]"" S PSORENW("MAIL/WINDOW")=PSORNW("MAIL/WINDOW")
I $O(^PSRX(PSORENW("OIRXN"),"PI",0)) D K T
.S PHI=^PSRX(PSORENW("OIRXN"),"PI",0),T=0
.F S T=$O(^PSRX(PSORENW("OIRXN"),"PI",T)) Q:'T S PHI(T)=^PSRX(PSORENW("OIRXN"),"PI",T,0)
;I $O(^PSRX(PSORENW("OIRXN"),"PRC",0)) D K T
;.S PRC=^PSRX(PSORENW("OIRXN"),"PRC",0),T=0
;.F S T=$O(^PSRX(PSORENW("OIRXN"),"PRC",T)) Q:'T S PRC(T)=^PSRX(PSORENW("OIRXN"),"PRC",T,0)
W !!,"Now Renewing Rx # "_PSORENW("ORX #")_" Drug: "_$P($G(^PSDRUG(+$G(PSORENW("DRUG IEN")),0)),"^"),!
I '$P($G(^PSDRUG($P(PSORENW("RX0"),"^",6),2)),"^") D G:$G(PSORENW("DFLG")) PROCESSX
.I $P($G(^PSRX(PSORENW("OIRXN"),"OR1")),"^") S PSODRUG("OI")=$P(^PSRX(PSORENW("OIRXN"),"OR1"),"^"),PSODRUG("OIN")=$P(^PS(50.7,+^("OR1"),0),"^") Q
.W !!,"Cannot Renew!! No Pharmacy Orderable Item!" S VALMSG="Cannot Renew!! No Pharmacy Orderable Item!",PSORX("DFLG")=1
D CHECK^PSORENW0 G:PSORENW("DFLG") PROCESSX
D FILDATE^PSORENW0
D DRUG^PSORENW0 G:PSORENW("DFLG") PROCESSX
D RXN^PSORENW0 G:PSORENW("DFLG") PROCESSX
D STOP^PSORENW1
DSPL K PSOEDT,PSOLM S PSDY=PSORENW("DAYS SUPPLY"),PSRF=PSORENW("# OF REFILLS")
F DEA=1:1 Q:$E(PSODRUG("DEA"),DEA)="" I $E(+PSODRUG("DEA"),DEA)>1,$E(+PSODRUG("DEA"),DEA)<6 S PSODIR("CS")=1
I $G(PSODIR("CS")) D
.S PSORENW("# OF REFILLS")=$S(PSDY<60:5,PSDY'<60&(PSDY'>89):2,PSDY=90:1,1:0)
.I PSORENW("# OF REFILLS")>PSRF S PSORENW("# OF REFILLS")=PSRF
D DSPLY^PSORENW3 G:PSORENW("DFLG") PROCESSX
D:$D(^XUSEC("PSORPH",DUZ))!('$P(PSOPAR,"^",2)) VER1^PSOORNE4(.PSORENW) G:PSORENW("DFLG")=1 PROCESSX
I $G(PSOQTY) D QTY^PSODIR1(.PSORENW) G:PSORENW("DFLG")=1 PROCESSX
D EN^PSORN52(.PSORENW)
D RNPSOSD^PSOUTIL
D CAN^PSORENW0,DCORD^PSONEW2
S PSORENW("# OF REFILLS")=PSRF K PSDY,PSRF,PSODIR("CS"),DEA,PSORENW("ENT")
S BBRN="",BBRN1=$O(^PSRX("B",PSORENW("NRX #"),BBRN)) I $P($G(^PSRX(BBRN1,0)),"^",11)["W" S BINGCRT="Y",BINGRTE="W",BBFLG=1,BBRX(1)=$G(BBRX(1))_BBRN1_","
PROCESSX I PSORENW("DFLG") D W:'$G(POERR) !,$C(7),"Rx NOT RENEWED. RENEWED RX DELETED",! S POERR("DFLG")=1 D CLEAN^PSOVER1
.K PHI,PRC,PSODRUG,SIG,PSORXED,SIGOK
.K PSORENW("DOSE"),PSORENW("DURATION"),PSORENW("DRUG IEN"),PSORENW("ENT"),PSORENW("INS"),PSORENW("NOUN"),PSORENW("ROUTE"),PSORENW("SCHEDULE"),PSORENW("SIG"),PSORENW("VERB"),PSORENW("UNITS")
.D POZ
K PSORDLOK I PSORENW("DFLG") S PSORDLOK=1
D:$G(PSORENW("OLD FILL DATE"))]"" SUSDATEK^PSOUTIL(.PSORENW)
K BBRN,BBRN1,PSODRUG,PSORX("PROVIDER NAME"),PSORX("CLINIC")
K PSOEDT,PSOLM S:$G(PSORENW("FROM"))="" (PSORENW("DFLG"),PSORENW("QFLG"))=0
I $G(PSORDLOK) D PSOUL^PSSLOCK($P(PSOLST(ORN),"^",2))
D KLIB^PSORENW1
K PSORDLOK
S RXN=$O(^TMP("PSORXN",$J,0)) I RXN D
.S RXN1=^TMP("PSORXN",$J,RXN) D EN^PSOHLSN1(RXN,$P(RXN1,"^"),$P(RXN1,"^",2),"",$P(RXN1,"^",3))
.I $P(^PSRX(RXN,"STA"),"^")=5 D EN^PSOHLSN1(RXN,"SC","ZS",$P(RXN1,"^",4))
K RXN,RXN1,^TMP("PSORXN",$J)
Q
INIT ;
D ASK Q:PSORENW("DFLG")
D NOORE^PSONEW(.PSORENW) Q:PSORENW("DFLG")
Q
ASK ;upfront questions
W !! D ISSDT^PSODIR2(.PSORENW) Q:PSORENW("DFLG") S PSORENW("ISSUE DATE")=PSOID
D FILLDT^PSODIR2(.PSORENW) K PSONEW("DAYS SUPPLY"),PSONEW("# OF REFILLS") Q:PSORENW("DFLG")
S PSORNW("FILL DATE")=PSORENW("FILL DATE")
D MW^PSODIR2(.PSORENW) Q:PSORENW("DFLG")
D PTSTAT^PSODIR1(.PSORENW) Q:PSORENW("DFLG")
D DAYS^PSODIR1(.PSORENW) Q:PSORENW("DFLG")
S PSODRUG("DEA")=0 D REFILL^PSODIR1(.PSORENW) K PSODRUG("DEA") Q:PSORENW("DFLG")
K DIR,DIRUT S DIR(0)="Y",DIR("B")="No",DIR("A")="Do you want to edit Renewed Rx(s) QTY " D ^DIR I $D(DIRUT) S PSORENW("DFLG")=1 K DIR,DIRUT Q
S PSOQTY=Y K DIR,DIRUT
D CLINIC^PSODIR2(.PSORENW) Q:PSORENW("DFLG")
D PROV^PSODIR(.PSORENW) S:PSORENW("DFLG") PSORENW("DFLG")=0
Q
;
POZ ;
K DIR S DIR(0)="E",DIR("A")="Press Return to Continue" D ^DIR K DIR,DIRUT,DTOUT
Q
PSORENW4 ;BIR/SAB - rx speed renew ;05-Jun-2014 08:45;DU
+1 ;;7.0;OUTPATIENT PHARMACY;**11,23,27,32,37,64,46,75,71,100,130,117,152,1004,1005,1009,148,264,225,301,1014,1016,1017**;DEC 1997;Build 40
+2 ;External reference to ^PSDRUG supported by DBIA 221
+3 ;External reference to ^PS(50.7 supported by DBIA 2223
+4 ;External references L, UL, PSOL, and PSOUL^PSSLOCK supported by DBIA 2789
+5 ;External reference to LK^ORX2 and ULK^ORX2 supported by DBIA 867
+6 ; Modified - IHS/CIA/PLS - 12/26/05 - Line PROCESS+18
+7 ; IHS/MSC/PLS - 12/09/10 - Added three lines at PROCESS+35
+8 ; 12/05/11 - Line PROCESS+1,PROCESS+3
+9 ; 06/24/13 - Line PROCESS+1
+10 ; 06/04/14 - Line PROCESS+33
SEL ;PSO*7*301
KILL PSODRUG
+1 IF $PIECE(PSOPAR,"^",4)=0
SET VALMSG="Renewing is NOT Allowed. Check Site Parameters!"
SET VALMBCK=""
QUIT
+2 NEW VALMCNT
IF '$GET(PSOCNT)
SET VALMSG="This patient has no Prescriptions!"
SET VALMBCK=""
QUIT
+3 SET PSOPLCK=$$L^PSSLOCK(PSODFN,0)
IF '$GET(PSOPLCK)
DO LOCK^PSOORCPY
SET VALMSG=$SELECT($PIECE($GET(PSOPLCK),"^",2)'="":$PIECE($GET(PSOPLCK),"^",2)_" is working on this patient.",1:"Another person is entering orders for this patient.")
KILL PSOPLCK
SET VALMBCK=""
QUIT
+4 KILL PSOPLCK
SET X=PSODFN_";DPT("
DO LK^ORX2
IF 'Y
SET VALMSG="Another person is entering orders for this patient."
SET VALMBCK=""
DO UL^PSSLOCK(PSODFN)
QUIT
+5 KILL PRC,PHI,PSORX("EDIT"),PSOFDR,DIR,DUOUT,DIRUT,PSORNSPD
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=""
GOTO SELQ
+6 KILL DIR,DIRUT,DTOUT,PSOOELSE,DTOUT
IF +Y
SET (SPEED,PSOOELSE,PSORNSPD)=1
DO FULL^VALM1
SET LST=Y
Begin DoDot:1
+7 SET (PSODIR("DFLG"),PSODIR("FIELD"))=0
SET PSOOPT=3
SET (PSORENW("DFLG"),PSORENW("QFLG"),PSORX("DFLG"))=0
DO INIT
IF PSORENW("DFLG")
QUIT
+8 FOR ORD=1:1:$LENGTH(LST,",")
IF $PIECE(LST,",",ORD)']""
QUIT
SET ORN=$PIECE(LST,",",ORD)
IF +PSOLST(ORN)=52
DO PROCESS
SET PSORENW("DFLG")=0
End DoDot:1
+9 IF '$GET(PSOOELSE)
SET VALMBCK=""
GOTO SELQ
+10 SET VALMBCK="R"
+11 DO ^PSOBUILD
DO BLD^PSOORUT1
KILL DIR,DIRUT,DTOUT,DUOUT,LST,ORD,IEN,ORN,RPH,ST,REFL,REF,PSOACT,ORSV,PSORNW,PSORENW,PSONO,PSOCO,PSOCU,PSODIR,DSMSG,SPEED,PSORENW,PSOOELSE,PSOOPT,PSORX("FILL DATE"),PSORX("ISSUE DATE"),PSOID,PSOMSG,PSORX("DFLG"),PSOQTY
SELQ KILL PSORNSPD,RTE,DRET,PRC,PHI
SET X=PSODFN_";DPT("
DO ULK^ORX2
DO UL^PSSLOCK(PSODFN)
DO CLEAN^PSOVER1
+1 QUIT
+2 ;
PROCESS ; Process one order at a time
+1 ;IHS/MSC/PLS - 06/24/2013
+2 IF $EXTRACT($$GET1^DIQ(52,$PIECE(PSOLST(ORN),U,2),.01),1)="X"
Begin DoDot:1
+3 WRITE $CHAR(7),!!,"Rx "_$$GET1^DIQ(52,$PIECE(PSOLST(ORN),"^",2),.01)_" is an external prescription and can't be refilled!"
End DoDot:1
KILL DIR,PSOMSG
DO PAUSE^VALM1
QUIT
+4 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 Rejects!"
KILL DIR,PSOMSG
DO PAUSE^VALM1
QUIT
+5 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),"^")),!
KILL DIR,PSOMSG
DO PAUSE^VALM1
QUIT
+6 NEW APSPDRG
+7 KILL RET,DRET,PRC,PHI
SET PSORENW("OIRXN")=$PIECE(PSOLST(ORN),"^",2)
SET PSOFROM="NEW"
+8 ;IHS/MSC/MGH Text for REM medication. Patch 1013
+9 SET APSPDRG=$PIECE($GET(^PSRX(PSORENW("OIRXN"),0)),"^",6)
+10 IF +APSPDRG
DO REMMSG^APSPFUNC(APSPDRG)
+11 SET PSORENW("RX0")=^PSRX(PSORENW("OIRXN"),0)
SET PSORENW("RX2")=^(2)
SET PSORENW("RX3")=^(3)
SET PSORENW("STA")=^("STA")
SET PSORENW("TN")=$GET(^("TN"))
SET SIGOK=$PIECE($GET(^PSRX(PSORENW("OIRXN"),"SIG")),"^",2)
+12 IF SIGOK
FOR I=0:0
SET I=$ORDER(^PSRX(PSORENW("OIRXN"),"SIG1",I))
IF 'I
QUIT
SET SIG(I)=^PSRX(PSORENW("OIRXN"),"SIG1",I,0)
+13 SET PSOIBOLD=$GET(PSORENW("OIRXN"))
DO SETIB^PSORENW1
+14 IF '$GET(PSORENW("PROVIDER"))
Begin DoDot:1
+15 SET PSORENW("PROVIDER")=$PIECE(PSORENW("RX0"),"^",4)
+16 IF $PIECE(PSORENW("RX3"),"^",3)
SET PSORENW("COSIGNING PROVIDER")=$PIECE(PSORENW("RX3"),"^",3)
End DoDot:1
+17 SET PSORX("PROVIDER NAME")=$PIECE($GET(^VA(200,PSORENW("PROVIDER"),0)),"^")
+18 IF '$GET(PSORENW("CLINIC"))
SET PSORENW("CLINIC")=$PIECE(PSORENW("RX0"),"^",5)
+19 SET PSORENW("REMARKS")="RENEWED FROM RX # "_$PIECE(PSORENW("RX0"),"^")
+20 SET PSORENW("SIG")=$PIECE($GET(^PSRX(PSORENW("OIRXN"),"SIG")),"^")
+21 SET PSORENW("PSODFN")=$PIECE(PSORENW("RX0"),"^",2)
+22 SET PSORENW("ORX #")=$PIECE(PSORENW("RX0"),"^")
+23 SET PSORENW("DRUG IEN")=$PIECE(PSORENW("RX0"),"^",6)
+24 SET PSORENW("QTY")=$PIECE(PSORENW("RX0"),"^",7)
+25 ;S PSORENW("DAYS SUPPLY")=$P(PSORENW("RX0"),"^",8)
+26 ;S PSORENW("# OF REFILLS")=$P(PSORENW("RX0"),"^",9)
+27 ; IHS/CIA/PLS - 12/29/05 - Added IHS fields to array for RENEW prescription
+28 NEW TALK
+29 IF $DATA(^PSRX(PSORENW("OIRXN"),9999999))
Begin DoDot:1
+30 SET PSORENW("AWP")=$$AWP^APSQDAWP($PIECE($GET(PSORENW("RX2")),U,7),$GET(PSORENW("DRUG IEN")),.TALK)
+31 SET PSORENW("BST")=$PIECE($GET(^PSRX(PSORENW("OIRXN"),9999999)),U,7)
+32 SET PSORENW("CM")=$PIECE($GET(^PSRX(PSORENW("OIRXN"),9999999)),U,2)
End DoDot:1
+33 ;IHS/MSC/PLS - 06/04/14
KILL PSORENW("NDC")
+34 SET PSORENW("INS")=$SELECT($GET(PSORENW("ENT"))]"":PSORENW("ENT"),1:$GET(^PSRX(PSORENW("OIRXN"),"INS")))
+35 IF $GET(PSORENW("ENT"))']""
SET PSORENW("ENT")=0
+36 FOR I=0:0
SET I=$ORDER(^PSRX(PSORENW("OIRXN"),6,I))
IF 'I
QUIT
SET DOSE=^PSRX(PSORENW("OIRXN"),6,I,0)
Begin DoDot:1
+37 SET PSORENW("ENT")=PSORENW("ENT")+1
SET PSORENW("DOSE",PSORENW("ENT"))=$PIECE(DOSE,"^")
+38 SET PSORENW("UNITS",PSORENW("ENT"))=$PIECE(DOSE,"^",3)
SET PSORENW("DOSE ORDERED",PSORENW("ENT"))=$PIECE(DOSE,"^",2)
SET PSORENW("ROUTE",PSORENW("ENT"))=$PIECE(DOSE,"^",7)
+39 SET PSORENW("SCHEDULE",PSORENW("ENT"))=$PIECE(DOSE,"^",8)
SET PSORENW("DURATION",PSORENW("ENT"))=$PIECE(DOSE,"^",5)
SET PSORENW("CONJUNCTION",PSORENW("ENT"))=$PIECE(DOSE,"^",6)
+40 SET PSORENW("NOUN",PSORENW("ENT"))=$PIECE(DOSE,"^",4)
SET PSORENW("VERB",PSORENW("ENT"))=$PIECE(DOSE,"^",9)
+41 IF $GET(^PSRX(PSORENW("OIRXN"),6,I,1))]""
SET PSORENW("ODOSE",PSORENW("ENT"))=^PSRX(PSORENW("OIRXN"),6,I,1)
+42 KILL DOSE
End DoDot:1
+43 IF $PIECE($GET(^PSDRUG(PSORENW("DRUG IEN"),"CLOZ1")),"^")="PSOCLO1"
NEW PSON
SET PSON=0
Begin DoDot:1
+44 IF '$LENGTH($PIECE(^VA(200,PSORENW("PROVIDER"),"PS"),"^",2))
IF '$LENGTH($PIECE(^VA(200,PSORENW("PROVIDER"),"PS"),"^",3))
Begin DoDot:2
+45 SET PSON=1
WRITE $CHAR(7),!!,"Only providers with DEA# or a VA# can write prescriptions for clozapine.",!
End DoDot:2
QUIT
+46 IF '$DATA(^XUSEC("YSCL AUTHORIZED",PSORENW("PROVIDER")))
Begin DoDot:2
+47 SET PSON=1
WRITE $CHAR(7),!!,"Provider must hold YSCL AUTHORIZED key to write prescriptions for clozapine.",!
End DoDot:2
End DoDot:1
IF PSON
KILL PSON
DO POZ
DO KLIB^PSORENW1
DO PSOUL^PSSLOCK($PIECE(PSOLST(ORN),"^",2))
QUIT
+48 ;IHS/MSC/JDS - 12/09/10 - Added next two lines for MDF
+49 IF '$$SCREEN^APSPMULT(+PSORENW("DRUG IEN"),,1)
Begin DoDot:1
+50 WRITE $CHAR(7),!!,"Sorry, this drug is not currently available in this facility",!
End DoDot:1
DO KLIB^PSORENW1
DO PSOUL^PSSLOCK($PIECE(PSOLST(ORN),"^",2))
QUIT
+51 IF $GET(PSORNW("MAIL/WINDOW"))]""
SET PSORENW("MAIL/WINDOW")=PSORNW("MAIL/WINDOW")
+52 IF $ORDER(^PSRX(PSORENW("OIRXN"),"PI",0))
Begin DoDot:1
+53 SET PHI=^PSRX(PSORENW("OIRXN"),"PI",0)
SET T=0
+54 FOR
SET T=$ORDER(^PSRX(PSORENW("OIRXN"),"PI",T))
IF 'T
QUIT
SET PHI(T)=^PSRX(PSORENW("OIRXN"),"PI",T,0)
End DoDot:1
KILL T
+55 ;I $O(^PSRX(PSORENW("OIRXN"),"PRC",0)) D K T
+56 ;.S PRC=^PSRX(PSORENW("OIRXN"),"PRC",0),T=0
+57 ;.F S T=$O(^PSRX(PSORENW("OIRXN"),"PRC",T)) Q:'T S PRC(T)=^PSRX(PSORENW("OIRXN"),"PRC",T,0)
+58 WRITE !!,"Now Renewing Rx # "_PSORENW("ORX #")_" Drug: "_$PIECE($GET(^PSDRUG(+$GET(PSORENW("DRUG IEN")),0)),"^"),!
+59 IF '$PIECE($GET(^PSDRUG($PIECE(PSORENW("RX0"),"^",6),2)),"^")
Begin DoDot:1
+60 IF $PIECE($GET(^PSRX(PSORENW("OIRXN"),"OR1")),"^")
SET PSODRUG("OI")=$PIECE(^PSRX(PSORENW("OIRXN"),"OR1"),"^")
SET PSODRUG("OIN")=$PIECE(^PS(50.7,+^("OR1"),0),"^")
QUIT
+61 WRITE !!,"Cannot Renew!! No Pharmacy Orderable Item!"
SET VALMSG="Cannot Renew!! No Pharmacy Orderable Item!"
SET PSORX("DFLG")=1
End DoDot:1
IF $GET(PSORENW("DFLG"))
GOTO PROCESSX
+62 DO CHECK^PSORENW0
IF PSORENW("DFLG")
GOTO PROCESSX
+63 DO FILDATE^PSORENW0
+64 DO DRUG^PSORENW0
IF PSORENW("DFLG")
GOTO PROCESSX
+65 DO RXN^PSORENW0
IF PSORENW("DFLG")
GOTO PROCESSX
+66 DO STOP^PSORENW1
DSPL KILL PSOEDT,PSOLM
SET PSDY=PSORENW("DAYS SUPPLY")
SET PSRF=PSORENW("# OF REFILLS")
+1 FOR DEA=1:1
IF $EXTRACT(PSODRUG("DEA"),DEA)=""
QUIT
IF $EXTRACT(+PSODRUG("DEA"),DEA)>1
IF $EXTRACT(+PSODRUG("DEA"),DEA)<6
SET PSODIR("CS")=1
+2 IF $GET(PSODIR("CS"))
Begin DoDot:1
+3 SET PSORENW("# OF REFILLS")=$SELECT(PSDY<60:5,PSDY'<60&(PSDY'>89):2,PSDY=90:1,1:0)
+4 IF PSORENW("# OF REFILLS")>PSRF
SET PSORENW("# OF REFILLS")=PSRF
End DoDot:1
+5 DO DSPLY^PSORENW3
IF PSORENW("DFLG")
GOTO PROCESSX
+6 IF $DATA(^XUSEC("PSORPH",DUZ))!('$PIECE(PSOPAR,"^",2))
DO VER1^PSOORNE4(.PSORENW)
IF PSORENW("DFLG")=1
GOTO PROCESSX
+7 IF $GET(PSOQTY)
DO QTY^PSODIR1(.PSORENW)
IF PSORENW("DFLG")=1
GOTO PROCESSX
+8 DO EN^PSORN52(.PSORENW)
+9 DO RNPSOSD^PSOUTIL
+10 DO CAN^PSORENW0
DO DCORD^PSONEW2
+11 SET PSORENW("# OF REFILLS")=PSRF
KILL PSDY,PSRF,PSODIR("CS"),DEA,PSORENW("ENT")
+12 SET BBRN=""
SET BBRN1=$ORDER(^PSRX("B",PSORENW("NRX #"),BBRN))
IF $PIECE($GET(^PSRX(BBRN1,0)),"^",11)["W"
SET BINGCRT="Y"
SET BINGRTE="W"
SET BBFLG=1
SET BBRX(1)=$GET(BBRX(1))_BBRN1_","
PROCESSX IF PSORENW("DFLG")
Begin DoDot:1
+1 KILL PHI,PRC,PSODRUG,SIG,PSORXED,SIGOK
+2 KILL PSORENW("DOSE"),PSORENW("DURATION"),PSORENW("DRUG IEN"),PSORENW("ENT"),PSORENW("INS"),PSORENW("NOUN"),PSORENW("ROUTE"),PSORENW("SCHEDULE"),PSORENW("SIG"),PSORENW("VERB"),PSORENW("UNITS")
+3 DO POZ
End DoDot:1
IF '$GET(POERR)
WRITE !,$CHAR(7),"Rx NOT RENEWED. RENEWED RX DELETED",!
SET POERR("DFLG")=1
DO CLEAN^PSOVER1
+4 KILL PSORDLOK
IF PSORENW("DFLG")
SET PSORDLOK=1
+5 IF $GET(PSORENW("OLD FILL DATE"))]""
DO SUSDATEK^PSOUTIL(.PSORENW)
+6 KILL BBRN,BBRN1,PSODRUG,PSORX("PROVIDER NAME"),PSORX("CLINIC")
+7 KILL PSOEDT,PSOLM
IF $GET(PSORENW("FROM"))=""
SET (PSORENW("DFLG"),PSORENW("QFLG"))=0
+8 IF $GET(PSORDLOK)
DO PSOUL^PSSLOCK($PIECE(PSOLST(ORN),"^",2))
+9 DO KLIB^PSORENW1
+10 KILL PSORDLOK
+11 SET RXN=$ORDER(^TMP("PSORXN",$JOB,0))
IF RXN
Begin DoDot:1
+12 SET RXN1=^TMP("PSORXN",$JOB,RXN)
DO EN^PSOHLSN1(RXN,$PIECE(RXN1,"^"),$PIECE(RXN1,"^",2),"",$PIECE(RXN1,"^",3))
+13 IF $PIECE(^PSRX(RXN,"STA"),"^")=5
DO EN^PSOHLSN1(RXN,"SC","ZS",$PIECE(RXN1,"^",4))
End DoDot:1
+14 KILL RXN,RXN1,^TMP("PSORXN",$JOB)
+15 QUIT
INIT ;
+1 DO ASK
IF PSORENW("DFLG")
QUIT
+2 DO NOORE^PSONEW(.PSORENW)
IF PSORENW("DFLG")
QUIT
+3 QUIT
ASK ;upfront questions
+1 WRITE !!
DO ISSDT^PSODIR2(.PSORENW)
IF PSORENW("DFLG")
QUIT
SET PSORENW("ISSUE DATE")=PSOID
+2 DO FILLDT^PSODIR2(.PSORENW)
KILL PSONEW("DAYS SUPPLY"),PSONEW("# OF REFILLS")
IF PSORENW("DFLG")
QUIT
+3 SET PSORNW("FILL DATE")=PSORENW("FILL DATE")
+4 DO MW^PSODIR2(.PSORENW)
IF PSORENW("DFLG")
QUIT
+5 DO PTSTAT^PSODIR1(.PSORENW)
IF PSORENW("DFLG")
QUIT
+6 DO DAYS^PSODIR1(.PSORENW)
IF PSORENW("DFLG")
QUIT
+7 SET PSODRUG("DEA")=0
DO REFILL^PSODIR1(.PSORENW)
KILL PSODRUG("DEA")
IF PSORENW("DFLG")
QUIT
+8 KILL DIR,DIRUT
SET DIR(0)="Y"
SET DIR("B")="No"
SET DIR("A")="Do you want to edit Renewed Rx(s) QTY "
DO ^DIR
IF $DATA(DIRUT)
SET PSORENW("DFLG")=1
KILL DIR,DIRUT
QUIT
+9 SET PSOQTY=Y
KILL DIR,DIRUT
+10 DO CLINIC^PSODIR2(.PSORENW)
IF PSORENW("DFLG")
QUIT
+11 DO PROV^PSODIR(.PSORENW)
IF PSORENW("DFLG")
SET PSORENW("DFLG")=0
+12 QUIT
+13 ;
POZ ;
+1 KILL DIR
SET DIR(0)="E"
SET DIR("A")="Press Return to Continue"
DO ^DIR
KILL DIR,DIRUT,DTOUT
+2 QUIT
