PSORENW4 ;BIR/SAB - rx speed renew ;Oct 20, 2022@15:42
;;7.0;OUTPATIENT PHARMACY;**11,23,27,32,37,64,46,75,71,100,130,117,152,148,264,225,301,390,313,411,444,504,508,550,457,639,441,683,545,731,753**;DEC 1997;Build 53
;External reference to ^PSDRUG( supported by DBIA 221
;External reference to ^PS(50.7 supported by DBIA 2223
;External reference to $$L^PSSLOCK supported by DBIA 2789
;External reference to UL^PSSLOCK supported by DBIA 2789
;External reference to PSOL^PSSLOCK supported by DBIA 2789
;External reference to PSOUL^PSSLOCK supported by DBIA 2789
;External reference to LK^ORX2 supported by DBIA 867
;External reference to ULK^ORX2 supported by DBIA 867
;External reference to ^PSRX supported by DBIA 3500
;External reference to ^VA(200 supported by DBIA 10060
SEL K PSODRUG ;PSO*7*301
N PSOSPRNW,PSOIBOLD S PSOSPRNW=1
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 LST="",DIR("A")="Select Orders by number",DIR(0)="LO^1:"_PSOCNT D ^DIR
K DIR I $D(DTOUT)!($D(DUOUT)) K DIRUT,DTOUT,DUOUT S VALMBCK="" G SELQ
;
K DIRUT,PSOOELSE I +Y S (SPEED,PSOOELSE,PSORNSPD)=1 D FULL^VALM1 S LST=Y
; begin NCC remediation *457, remove any Clozapine orders
I $G(LST)]"" F ORD=1:1:$L(LST,",") S ORN=$P(LST,",",ORD) D:ORN I PSOERR=2 S PSOERR=0
. S PSOERR=0
. N PSDRGIEN,ORDLN S ORDLN=$G(PSOLST(ORN)) Q:'(+ORDLN=52)
. ; Clozapine check
. S PSDRGIEN=$$GET1^DIQ(52,+$P(ORDLN,"^",2),6,"I") ; drug IEN
. Q:'PSDRGIEN I $$GET1^DIQ(50,PSDRGIEN,17.5)="PSOCLO1" D
.. S $P(LST,",",ORD)=0 ; order removed from LST
.. W !,$$GET1^DIQ(50,PSDRGIEN,.01) ; drug name
.. N DIR,ORUB,Y S Y("1")="^^Renew^RN",ORUB=1 D NS^XQORM4
.. S Y=$$GET1^DIQ(52,+$P(ORDLN,U,2),.01) ; Rx #
.. S PSOERR=2 S DIR(0)="E",DIR("A")="Rx #"_Y_" not processed. Press enter" D ^DIR
;
;PSO 683 skip discontinued by provider RXs
S (ORD,PSOLCNT)=0
I $G(LST)]"" D
. ; count remaining orders in LST
. F ORD=1:1:$L(LST,",")-1 D
.. Q:$P(LST,",",ORD)'>0
.. S PSOLCNT=PSOLCNT+1,ORN=$P(LST,",",ORD)
.. I (+PSOLST(ORN)=52&(^PSRX($P(PSOLST(ORN),U,2),"STA")=14)) D
... S PSOSKIP($P(PSOLST(ORN),U,2))="",$P(LST,",",ORD)=0,PSOLCNT=PSOLCNT-1 ; order removed from LST
.I $O(PSOSKIP(0)) D
.. W !
.. S ORD=0 F S ORD=$O(PSOSKIP(ORD)) Q:'ORD D
... S PSOSTA=$$GET1^DIQ(52,ORD,100)
... W $C(7),!," Cannot renew Rx # "_$$GET1^DIQ(52,ORD,.01)_", Rx is in "_PSOSTA_" status."
.. D PAUSE^VALM1
;END PSO 683
;
I 'PSOLCNT G SELQ ; no orders to process
; end NCC remediation *457
D ; process remaining orders
. 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,",") S ORN=$P(LST,",",ORD) D:ORN>0
.. D:+PSOLST(ORN)=52 PROCESS
.. S (PSOQUIT,PSORENW("DFLG"),POERR,POERR("DFLG"),PSORX("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,PSOSPRNW,X,PSOSKIP,PSOLCNT,PSOSTA
S X=PSODFN_";DPT(" D ULK^ORX2,UL^PSSLOCK(PSODFN),CLEAN^PSOVER1
Q
;
RXCS(RXIEN) ; Return the CS Federal Schedule associated with Rx# RXIEN
N DRGIEN,PSOY
S DRGIEN=+$$GET1^DIQ(52,RXIEN,6,"I")
Q $$DRGCS(DRGIEN)
;
DRGCS(DRGIEN) ; Return the CS Federal Schedule associated with Drug File entry DRGIEN
N DRGCS
Q:'$G(DRGIEN) ""
S DRGCS=$$GET1^DIQ(50,+$G(DRGIEN),3)
Q DRGCS
;
PROCESS ; Process one order at a time
N PSORXIEN,PSOCHECK,MAXNUMRF
S PSORXIEN=+$P($G(PSOLST(ORN)),"^",2)
;
I $$LMREJ^PSOREJU1(PSORXIEN) D K DIR,PSOMSG D PAUSE^VALM1 Q
. W $C(7),!!,"Rx# "_$$GET1^DIQ(52,PSORXIEN,.01)_" has OPEN/UNRESOLVED 3rd Party Payer Rejects!"
I $$TITRX^PSOUTL(PSORXIEN)="t" D K DIR,PSOMSG D PAUSE^VALM1 Q
. W $C(7),!!,"Rx# "_$$GET1^DIQ(52,PSORXIEN,.01)_" is marked as 'Titration Rx' and cannot be renewed."
; Checking whether the Provider still qualifies as prescriber for the renewed Rx
S PROVIEN=$S($G(PSORENW("PROVIDER")):PSORENW("PROVIDER"),1:+$$GET1^DIQ(52,PSORXIEN,4,"I"))
S PSOCHECK=$$CHKRXPRV^PSOUTIL(PSORXIEN,PROVIEN)
I 'PSOCHECK,(PSOCHECK'["DEA#"),(PSOCHECK'["Federal Schedule") D K DIR,PSOMSG D PAUSE^VALM1 Q
. W $C(7),!!,"Rx# "_$$GET1^DIQ(52,PSORXIEN,.01)_" - "_$P(PSOCHECK,"^",3)
I $$CSRX^PSOUTL(PSORXIEN)!'PSOCHECK D ; 731 - Use $$CSRX^PSOUTL instead of $$RXCS^PSORENW4
. N PSODRUG,PSOY,PSODRIEN D FULL^VALM1
. S PSODRIEN=+$$GET1^DIQ(52,PSORXIEN,6,"I"),PSOY(0)=$G(^PSDRUG(PSODRIEN,0)),PSOY=PSODRIEN
. S PSORX("CS")=$$DRGCS(PSODRIEN)
. D SET^PSODRG S PSORENW("DEA")=$$SLDEA^PSODIR(PROVIEN,.PSORX,$$RXDEA^PSOUTIL(+$G(PSORXIEN)),PSODRIEN)
. I $G(PSORENW("DEA"))="" S PSOCHECK="0^No valid DEA# selected^No valid DEA# selected"
. ;N DIR S DIR(0)="E",DIR("A")="Press return to continue" D ^DIR ; 731 - Remove extra prompt
. Q:$G(PSORENW("DEA"))=""
. S PSOCHECK=1
I 'PSOCHECK D K DIR,PSOMSG D PAUSE^VALM1 Q
. W $C(7),!!,"Rx# "_$$GET1^DIQ(52,PSORXIEN,.01)_" - "_$P(PSOCHECK,"^",3)
; Checking the Maximum Number of Refills Allowed
S MAXNUMRF=$$MAXNUMRF^PSOUTIL(+$$GET1^DIQ(52,PSORXIEN,6,"I"),+$G(PSORENW("DAYS SUPPLY")),+$G(PSORENW("PATIENT STATUS")),.CLOZPAT)
I PSORENW("# OF REFILLS")>MAXNUMRF D K DIR,PSOMSG D PAUSE^VALM1 Q
. W $C(7),!!,"Rx# "_$$GET1^DIQ(52,PSORXIEN,.01)_" - # of Refills requested exceeds maximum allowed ("_MAXNUMRF_") for this Rx"
; PSO*7*508 - check if the Rx is an eRx. If so, inform the user and ask to proceed.
N ERXORN,ERXIEN,ERXPROC S ERXORN=$$GET1^DIQ(52,$P(PSOLST(ORN),U,2),39.3)
S ERXIEN=$$CHKERX^PSOERXU1(ERXORN)
I ERXIEN S ERXPROC=$$PROVPMT^PSOERXU1(ERXIEN) Q:'ERXPROC
; PSO*7*508 - end
I $$CSRX^PSOUTL(PSORXIEN),$$FMADD^XLFDT($G(PSORENW("ISSUE DATE")),180)<DT D K DIR,PSOMSG D PAUSE^VALM1 Q
. W $C(7),!!,"Rx# "_$$GET1^DIQ(52,PSORXIEN,.01)_" - Rx is for a CS Drug and the Issue Date entered ("_$$FMTE^XLFDT(PSORENW("ISSUE DATE"))_") is",!,"greater than 6 months."
; Checking if Rx is locked by Another person
D PSOL^PSSLOCK(PSORXIEN) I '$G(PSOMSG) W $C(7),!!,$S($P($G(PSOMSG),"^",2)'="":$P($G(PSOMSG),"^",2),1:"Another person is editing Rx "_$P(^PSRX(PSORXIEN,0),"^")),! K DIR,PSOMSG D PAUSE^VALM1 Q
K RET,DRET,PRC,PHI S PSORENW("OIRXN")=PSORXIEN,PSOFROM="NEW"
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("INS")=$S($G(PSORENW("ENT"))]"":PSORENW("ENT"),1:$G(^PSRX(PSORENW("OIRXN"),"INS")))
S:$G(PSORENW("ENT"))']"" PSORENW("ENT")=0
N I 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),!!,$$CLKEYWRN^PSOCLUTL,!
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)
S PSORENW("MAIL EXEMPTION")=$$GET1^DIQ(52,PSORXIEN,100.2,"I") ;p753
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 POZ
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,BBFLG,BBRX,BINGCRT,BINGRTE 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
N MXRFLS
S MXRFLS=$$MAXNUMRF^PSOUTIL(+$G(PSODRUG("IEN")),+$G(PSORENW("DAYS SUPPLY")),+$P(^PSRX(PSORENW("OIRXN"),0),"^",3),.CLOZPAT)
I MXRFLS<PSORENW("# OF REFILLS") S PSORENW("# OF REFILLS")=MXRFLS
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
.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")
.I '$G(POERR) W !,$C(7),"Rx NOT RENEWED. RENEWED RX DELETED",! S POERR("DFLG")=1 D CLEAN^PSOVER1,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 N ZRXN S ZRXN=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))
.;saves drug allergy order chks pso*7*390
.I $D(^TMP("PSODAOC",$J,"ALLERGY")) D
..I $G(PSORX("DFLG"))!$G(PSORENW("DFLG")) K ^TMP("PSODAOC",$J) Q
..S RXN=ZRXN,PSODAOC="Rx Backdoor "_$S($P(^PSRX(RXN,"STA"),"^")=4:"NON-VERIFIED ",1:"")_"SPEED RENEW Order Acceptance_OP"
..S PSOARENW=1 D DAOC^PSONEW K PSOARENW
K ZRXN,RXN,RXN1,^TMP("PSORXN",$J),^TMP("PSODAOC",$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 MW^PSODIR2(.PSORENW) Q:PSORENW("DFLG")
D FILLDT^PSODIR2(.PSORENW) K PSONEW("DAYS SUPPLY"),PSONEW("# OF REFILLS") Q:PSORENW("DFLG")
S PSORNW("FILL DATE")=PSORENW("FILL DATE")
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,Y
D CLINIC^PSODIR2(.PSORENW) Q:PSORENW("DFLG")
D PROV^PSODIR(.PSORENW) S:PSORENW("DFLG") PSORENW("DFLG")=0
S PSORENW("MAIL EXEMPTION")="" ;p753
Q
;
POZ ;
K DIR S DIR(0)="E",DIR("A")="Press Return to Continue" D ^DIR K DIR,DIRUT,DTOUT
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSORENW4 13458 printed Oct 16, 2024@18:34:27 Page 2
PSORENW4 ;BIR/SAB - rx speed renew ;Oct 20, 2022@15:42
+1 ;;7.0;OUTPATIENT PHARMACY;**11,23,27,32,37,64,46,75,71,100,130,117,152,148,264,225,301,390,313,411,444,504,508,550,457,639,441,683,545,731,753**;DEC 1997;Build 53
+2 ;External reference to ^PSDRUG( supported by DBIA 221
+3 ;External reference to ^PS(50.7 supported by DBIA 2223
+4 ;External reference to $$L^PSSLOCK supported by DBIA 2789
+5 ;External reference to UL^PSSLOCK supported by DBIA 2789
+6 ;External reference to PSOL^PSSLOCK supported by DBIA 2789
+7 ;External reference to PSOUL^PSSLOCK supported by DBIA 2789
+8 ;External reference to LK^ORX2 supported by DBIA 867
+9 ;External reference to ULK^ORX2 supported by DBIA 867
+10 ;External reference to ^PSRX supported by DBIA 3500
+11 ;External reference to ^VA(200 supported by DBIA 10060
SEL ;PSO*7*301
KILL PSODRUG
+1 NEW PSOSPRNW,PSOIBOLD
SET PSOSPRNW=1
+2 IF $PIECE(PSOPAR,"^",4)=0
SET VALMSG="Renewing is NOT Allowed. Check Site Parameters!"
SET VALMBCK=""
QUIT
+3 NEW VALMCNT
IF '$GET(PSOCNT)
SET VALMSG="This patient has no Prescriptions!"
SET VALMBCK=""
QUIT
+4 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
+5 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
+6 KILL PRC,PHI,PSORX("EDIT"),PSOFDR,DIR,DUOUT,DIRUT,PSORNSPD
+7 SET LST=""
SET DIR("A")="Select Orders by number"
SET DIR(0)="LO^1:"_PSOCNT
DO ^DIR
+8 KILL DIR
IF $DATA(DTOUT)!($DATA(DUOUT))
KILL DIRUT,DTOUT,DUOUT
SET VALMBCK=""
GOTO SELQ
+9 ;
+10 KILL DIRUT,PSOOELSE
IF +Y
SET (SPEED,PSOOELSE,PSORNSPD)=1
DO FULL^VALM1
SET LST=Y
+11 ; begin NCC remediation *457, remove any Clozapine orders
+12 IF $GET(LST)]""
FOR ORD=1:1:$LENGTH(LST,",")
SET ORN=$PIECE(LST,",",ORD)
if ORN
Begin DoDot:1
+13 SET PSOERR=0
+14 NEW PSDRGIEN,ORDLN
SET ORDLN=$GET(PSOLST(ORN))
if '(+ORDLN=52)
QUIT
+15 ; Clozapine check
+16 ; drug IEN
SET PSDRGIEN=$$GET1^DIQ(52,+$PIECE(ORDLN,"^",2),6,"I")
+17 if 'PSDRGIEN
QUIT
IF $$GET1^DIQ(50,PSDRGIEN,17.5)="PSOCLO1"
Begin DoDot:2
+18 ; order removed from LST
SET $PIECE(LST,",",ORD)=0
+19 ; drug name
WRITE !,$$GET1^DIQ(50,PSDRGIEN,.01)
+20 NEW DIR,ORUB,Y
SET Y("1")="^^Renew^RN"
SET ORUB=1
DO NS^XQORM4
+21 ; Rx #
SET Y=$$GET1^DIQ(52,+$PIECE(ORDLN,U,2),.01)
+22 SET PSOERR=2
SET DIR(0)="E"
SET DIR("A")="Rx #"_Y_" not processed. Press enter"
DO ^DIR
End DoDot:2
End DoDot:1
IF PSOERR=2
SET PSOERR=0
+23 ;
+24 ;PSO 683 skip discontinued by provider RXs
+25 SET (ORD,PSOLCNT)=0
+26 IF $GET(LST)]""
Begin DoDot:1
+27 ; count remaining orders in LST
+28 FOR ORD=1:1:$LENGTH(LST,",")-1
Begin DoDot:2
+29 if $PIECE(LST,",",ORD)'>0
QUIT
+30 SET PSOLCNT=PSOLCNT+1
SET ORN=$PIECE(LST,",",ORD)
+31 IF (+PSOLST(ORN)=52&(^PSRX($PIECE(PSOLST(ORN),U,2),"STA")=14))
Begin DoDot:3
+32 ; order removed from LST
SET PSOSKIP($PIECE(PSOLST(ORN),U,2))=""
SET $PIECE(LST,",",ORD)=0
SET PSOLCNT=PSOLCNT-1
End DoDot:3
End DoDot:2
+33 IF $ORDER(PSOSKIP(0))
Begin DoDot:2
+34 WRITE !
+35 SET ORD=0
FOR
SET ORD=$ORDER(PSOSKIP(ORD))
if 'ORD
QUIT
Begin DoDot:3
+36 SET PSOSTA=$$GET1^DIQ(52,ORD,100)
+37 WRITE $CHAR(7),!," Cannot renew Rx # "_$$GET1^DIQ(52,ORD,.01)_", Rx is in "_PSOSTA_" status."
End DoDot:3
+38 DO PAUSE^VALM1
End DoDot:2
End DoDot:1
+39 ;END PSO 683
+40 ;
+41 ; no orders to process
IF 'PSOLCNT
GOTO SELQ
+42 ; end NCC remediation *457
+43 ; process remaining orders
Begin DoDot:1
+44 SET (PSODIR("DFLG"),PSODIR("FIELD"))=0
SET PSOOPT=3
SET (PSORENW("DFLG"),PSORENW("QFLG"),PSORX("DFLG"))=0
DO INIT
if PSORENW("DFLG")
QUIT
+45 FOR ORD=1:1:$LENGTH(LST,",")
SET ORN=$PIECE(LST,",",ORD)
if ORN>0
Begin DoDot:2
+46 if +PSOLST(ORN)=52
DO PROCESS
+47 SET (PSOQUIT,PSORENW("DFLG"),POERR,POERR("DFLG"),PSORX("DFLG"))=0
End DoDot:2
End DoDot:1
+48 IF '$GET(PSOOELSE)
SET VALMBCK=""
GOTO SELQ
+49 SET VALMBCK="R"
+50 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 ;
+1 KILL PSORNSPD,RTE,DRET,PRC,PHI,PSOSPRNW,X,PSOSKIP,PSOLCNT,PSOSTA
+2 SET X=PSODFN_";DPT("
DO ULK^ORX2
DO UL^PSSLOCK(PSODFN)
DO CLEAN^PSOVER1
+3 QUIT
+4 ;
RXCS(RXIEN) ; Return the CS Federal Schedule associated with Rx# RXIEN
+1 NEW DRGIEN,PSOY
+2 SET DRGIEN=+$$GET1^DIQ(52,RXIEN,6,"I")
+3 QUIT $$DRGCS(DRGIEN)
+4 ;
DRGCS(DRGIEN) ; Return the CS Federal Schedule associated with Drug File entry DRGIEN
+1 NEW DRGCS
+2 if '$GET(DRGIEN)
QUIT ""
+3 SET DRGCS=$$GET1^DIQ(50,+$GET(DRGIEN),3)
+4 QUIT DRGCS
+5 ;
PROCESS ; Process one order at a time
+1 NEW PSORXIEN,PSOCHECK,MAXNUMRF
+2 SET PSORXIEN=+$PIECE($GET(PSOLST(ORN)),"^",2)
+3 ;
+4 IF $$LMREJ^PSOREJU1(PSORXIEN)
Begin DoDot:1
+5 WRITE $CHAR(7),!!,"Rx# "_$$GET1^DIQ(52,PSORXIEN,.01)_" has OPEN/UNRESOLVED 3rd Party Payer Rejects!"
End DoDot:1
KILL DIR,PSOMSG
DO PAUSE^VALM1
QUIT
+6 IF $$TITRX^PSOUTL(PSORXIEN)="t"
Begin DoDot:1
+7 WRITE $CHAR(7),!!,"Rx# "_$$GET1^DIQ(52,PSORXIEN,.01)_" is marked as 'Titration Rx' and cannot be renewed."
End DoDot:1
KILL DIR,PSOMSG
DO PAUSE^VALM1
QUIT
+8 ; Checking whether the Provider still qualifies as prescriber for the renewed Rx
+9 SET PROVIEN=$SELECT($GET(PSORENW("PROVIDER")):PSORENW("PROVIDER"),1:+$$GET1^DIQ(52,PSORXIEN,4,"I"))
+10 SET PSOCHECK=$$CHKRXPRV^PSOUTIL(PSORXIEN,PROVIEN)
+11 IF 'PSOCHECK
IF (PSOCHECK'["DEA#")
IF (PSOCHECK'["Federal Schedule")
Begin DoDot:1
+12 WRITE $CHAR(7),!!,"Rx# "_$$GET1^DIQ(52,PSORXIEN,.01)_" - "_$PIECE(PSOCHECK,"^",3)
End DoDot:1
KILL DIR,PSOMSG
DO PAUSE^VALM1
QUIT
+13 ; 731 - Use $$CSRX^PSOUTL instead of $$RXCS^PSORENW4
IF $$CSRX^PSOUTL(PSORXIEN)!'PSOCHECK
Begin DoDot:1
+14 NEW PSODRUG,PSOY,PSODRIEN
DO FULL^VALM1
+15 SET PSODRIEN=+$$GET1^DIQ(52,PSORXIEN,6,"I")
SET PSOY(0)=$GET(^PSDRUG(PSODRIEN,0))
SET PSOY=PSODRIEN
+16 SET PSORX("CS")=$$DRGCS(PSODRIEN)
+17 DO SET^PSODRG
SET PSORENW("DEA")=$$SLDEA^PSODIR(PROVIEN,.PSORX,$$RXDEA^PSOUTIL(+$GET(PSORXIEN)),PSODRIEN)
+18 IF $GET(PSORENW("DEA"))=""
SET PSOCHECK="0^No valid DEA# selected^No valid DEA# selected"
+19 ;N DIR S DIR(0)="E",DIR("A")="Press return to continue" D ^DIR ; 731 - Remove extra prompt
+20 if $GET(PSORENW("DEA"))=""
QUIT
+21 SET PSOCHECK=1
End DoDot:1
+22 IF 'PSOCHECK
Begin DoDot:1
+23 WRITE $CHAR(7),!!,"Rx# "_$$GET1^DIQ(52,PSORXIEN,.01)_" - "_$PIECE(PSOCHECK,"^",3)
End DoDot:1
KILL DIR,PSOMSG
DO PAUSE^VALM1
QUIT
+24 ; Checking the Maximum Number of Refills Allowed
+25 SET MAXNUMRF=$$MAXNUMRF^PSOUTIL(+$$GET1^DIQ(52,PSORXIEN,6,"I"),+$GET(PSORENW("DAYS SUPPLY")),+$GET(PSORENW("PATIENT STATUS")),.CLOZPAT)
+26 IF PSORENW("# OF REFILLS")>MAXNUMRF
Begin DoDot:1
+27 WRITE $CHAR(7),!!,"Rx# "_$$GET1^DIQ(52,PSORXIEN,.01)_" - # of Refills requested exceeds maximum allowed ("_MAXNUMRF_") for this Rx"
End DoDot:1
KILL DIR,PSOMSG
DO PAUSE^VALM1
QUIT
+28 ; PSO*7*508 - check if the Rx is an eRx. If so, inform the user and ask to proceed.
+29 NEW ERXORN,ERXIEN,ERXPROC
SET ERXORN=$$GET1^DIQ(52,$PIECE(PSOLST(ORN),U,2),39.3)
+30 SET ERXIEN=$$CHKERX^PSOERXU1(ERXORN)
+31 IF ERXIEN
SET ERXPROC=$$PROVPMT^PSOERXU1(ERXIEN)
if 'ERXPROC
QUIT
+32 ; PSO*7*508 - end
+33 IF $$CSRX^PSOUTL(PSORXIEN)
IF $$FMADD^XLFDT($GET(PSORENW("ISSUE DATE")),180)<DT
Begin DoDot:1
+34 WRITE $CHAR(7),!!,"Rx# "_$$GET1^DIQ(52,PSORXIEN,.01)_" - Rx is for a CS Drug and the Issue Date entered ("_$$FMTE^XLFDT(PSORENW("ISSUE DATE"))_") is",!,"greater than 6 months."
End DoDot:1
KILL DIR,PSOMSG
DO PAUSE^VALM1
QUIT
+35 ; Checking if Rx is locked by Another person
+36 DO PSOL^PSSLOCK(PSORXIEN)
IF '$GET(PSOMSG)
WRITE $CHAR(7),!!,$SELECT($PIECE($GET(PSOMSG),"^",2)'="":$PIECE($GET(PSOMSG),"^",2),1:"Another person is editing Rx "_$PIECE(^PSRX(PSORXIEN,0),"^")),!
KILL DIR,PSOMSG
DO PAUSE^VALM1
QUIT
+37 KILL RET,DRET,PRC,PHI
SET PSORENW("OIRXN")=PSORXIEN
SET PSOFROM="NEW"
+38 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)
+39 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)
+40 SET PSOIBOLD=$GET(PSORENW("OIRXN"))
DO SETIB^PSORENW1
+41 IF '$GET(PSORENW("PROVIDER"))
Begin DoDot:1
+42 SET PSORENW("PROVIDER")=$PIECE(PSORENW("RX0"),"^",4)
+43 if $PIECE(PSORENW("RX3"),"^",3)
SET PSORENW("COSIGNING PROVIDER")=$PIECE(PSORENW("RX3"),"^",3)
End DoDot:1
+44 SET PSORX("PROVIDER NAME")=$PIECE($GET(^VA(200,PSORENW("PROVIDER"),0)),"^")
+45 IF '$GET(PSORENW("CLINIC"))
SET PSORENW("CLINIC")=$PIECE(PSORENW("RX0"),"^",5)
+46 SET PSORENW("REMARKS")="RENEWED FROM RX # "_$PIECE(PSORENW("RX0"),"^")
+47 SET PSORENW("SIG")=$PIECE($GET(^PSRX(PSORENW("OIRXN"),"SIG")),"^")
+48 SET PSORENW("PSODFN")=$PIECE(PSORENW("RX0"),"^",2)
+49 SET PSORENW("ORX #")=$PIECE(PSORENW("RX0"),"^")
+50 SET PSORENW("DRUG IEN")=$PIECE(PSORENW("RX0"),"^",6)
+51 SET PSORENW("QTY")=$PIECE(PSORENW("RX0"),"^",7)
+52 SET PSORENW("INS")=$SELECT($GET(PSORENW("ENT"))]"":PSORENW("ENT"),1:$GET(^PSRX(PSORENW("OIRXN"),"INS")))
+53 if $GET(PSORENW("ENT"))']""
SET PSORENW("ENT")=0
+54 NEW I
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
+55 SET PSORENW("ENT")=PSORENW("ENT")+1
SET PSORENW("DOSE",PSORENW("ENT"))=$PIECE(DOSE,"^")
+56 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)
+57 SET PSORENW("SCHEDULE",PSORENW("ENT"))=$PIECE(DOSE,"^",8)
SET PSORENW("DURATION",PSORENW("ENT"))=$PIECE(DOSE,"^",5)
SET PSORENW("CONJUNCTION",PSORENW("ENT"))=$PIECE(DOSE,"^",6)
+58 SET PSORENW("NOUN",PSORENW("ENT"))=$PIECE(DOSE,"^",4)
SET PSORENW("VERB",PSORENW("ENT"))=$PIECE(DOSE,"^",9)
+59 IF $GET(^PSRX(PSORENW("OIRXN"),6,I,1))]""
SET PSORENW("ODOSE",PSORENW("ENT"))=^PSRX(PSORENW("OIRXN"),6,I,1)
+60 KILL DOSE
End DoDot:1
+61 IF $PIECE($GET(^PSDRUG(PSORENW("DRUG IEN"),"CLOZ1")),"^")="PSOCLO1"
NEW PSON
SET PSON=0
Begin DoDot:1
+62 IF '$LENGTH($PIECE(^VA(200,PSORENW("PROVIDER"),"PS"),"^",2))
IF '$LENGTH($PIECE(^VA(200,PSORENW("PROVIDER"),"PS"),"^",3))
Begin DoDot:2
+63 SET PSON=1
WRITE $CHAR(7),!!,"Only providers with DEA# or a VA# can write prescriptions for clozapine.",!
End DoDot:2
QUIT
+64 IF '$DATA(^XUSEC("YSCL AUTHORIZED",PSORENW("PROVIDER")))
Begin DoDot:2
+65 SET PSON=1
WRITE $CHAR(7),!!,$$CLKEYWRN^PSOCLUTL,!
End DoDot:2
End DoDot:1
IF PSON
KILL PSON
DO POZ
DO KLIB^PSORENW1
DO PSOUL^PSSLOCK($PIECE(PSOLST(ORN),"^",2))
QUIT
+66 IF $GET(PSORNW("MAIL/WINDOW"))]""
SET PSORENW("MAIL/WINDOW")=PSORNW("MAIL/WINDOW")
+67 IF $ORDER(^PSRX(PSORENW("OIRXN"),"PI",0))
Begin DoDot:1
+68 SET PHI=^PSRX(PSORENW("OIRXN"),"PI",0)
SET T=0
+69 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
+70 ;p753
SET PSORENW("MAIL EXEMPTION")=$$GET1^DIQ(52,PSORXIEN,100.2,"I")
+71 WRITE !!,"Now Renewing Rx # "_PSORENW("ORX #")_" Drug: "_$PIECE($GET(^PSDRUG(+$GET(PSORENW("DRUG IEN")),0)),"^"),!
+72 IF '$PIECE($GET(^PSDRUG($PIECE(PSORENW("RX0"),"^",6),2)),"^")
Begin DoDot:1
+73 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
+74 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
+75 DO POZ
+76 DO CHECK^PSORENW0
if PSORENW("DFLG")
GOTO PROCESSX
+77 DO FILDATE^PSORENW0
+78 DO DRUG^PSORENW0
if PSORENW("DFLG")
GOTO PROCESSX
+79 DO RXN^PSORENW0
if PSORENW("DFLG")
GOTO PROCESSX
+80 DO STOP^PSORENW1
DSPL KILL PSOEDT,PSOLM,BBFLG,BBRX,BINGCRT,BINGRTE
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 NEW MXRFLS
+3 SET MXRFLS=$$MAXNUMRF^PSOUTIL(+$GET(PSODRUG("IEN")),+$GET(PSORENW("DAYS SUPPLY")),+$PIECE(^PSRX(PSORENW("OIRXN"),0),"^",3),.CLOZPAT)
+4 IF MXRFLS<PSORENW("# OF REFILLS")
SET PSORENW("# OF REFILLS")=MXRFLS
+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 ;
+1 IF PSORENW("DFLG")
Begin DoDot:1
+2 KILL PHI,PRC,PSODRUG,SIG,PSORXED,SIGOK
+3 KILL PSORENW("DOSE"),PSORENW("DURATION"),PSORENW("DRUG IEN"),PSORENW("ENT"),PSORENW("INS"),PSORENW("NOUN"),PSORENW("ROUTE"),PSORENW("SCHEDULE"),PSORENW("SIG"),PSORENW("VERB"),PSORENW("UNITS")
+4 IF '$GET(POERR)
WRITE !,$CHAR(7),"Rx NOT RENEWED. RENEWED RX DELETED",!
SET POERR("DFLG")=1
DO CLEAN^PSOVER1
DO POZ
End DoDot:1
+5 KILL PSORDLOK
IF PSORENW("DFLG")
SET PSORDLOK=1
+6 if $GET(PSORENW("OLD FILL DATE"))]""
DO SUSDATEK^PSOUTIL(.PSORENW)
+7 KILL BBRN,BBRN1,PSODRUG,PSORX("PROVIDER NAME"),PSORX("CLINIC")
+8 KILL PSOEDT,PSOLM
if $GET(PSORENW("FROM"))=""
SET (PSORENW("DFLG"),PSORENW("QFLG"))=0
+9 IF $GET(PSORDLOK)
DO PSOUL^PSSLOCK($PIECE(PSOLST(ORN),"^",2))
+10 DO KLIB^PSORENW1
+11 KILL PSORDLOK
+12 SET RXN=$ORDER(^TMP("PSORXN",$JOB,0))
IF RXN
NEW ZRXN
SET ZRXN=RXN
Begin DoDot:1
+13 SET RXN1=^TMP("PSORXN",$JOB,RXN)
DO EN^PSOHLSN1(RXN,$PIECE(RXN1,"^"),$PIECE(RXN1,"^",2),"",$PIECE(RXN1,"^",3))
+14 IF $PIECE(^PSRX(RXN,"STA"),"^")=5
DO EN^PSOHLSN1(RXN,"SC","ZS",$PIECE(RXN1,"^",4))
+15 ;saves drug allergy order chks pso*7*390
+16 IF $DATA(^TMP("PSODAOC",$JOB,"ALLERGY"))
Begin DoDot:2
+17 IF $GET(PSORX("DFLG"))!$GET(PSORENW("DFLG"))
KILL ^TMP("PSODAOC",$JOB)
QUIT
+18 SET RXN=ZRXN
SET PSODAOC="Rx Backdoor "_$SELECT($PIECE(^PSRX(RXN,"STA"),"^")=4:"NON-VERIFIED ",1:"")_"SPEED RENEW Order Acceptance_OP"
+19 SET PSOARENW=1
DO DAOC^PSONEW
KILL PSOARENW
End DoDot:2
End DoDot:1
+20 KILL ZRXN,RXN,RXN1,^TMP("PSORXN",$JOB),^TMP("PSODAOC",$JOB)
+21 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 MW^PSODIR2(.PSORENW)
if PSORENW("DFLG")
QUIT
+3 DO FILLDT^PSODIR2(.PSORENW)
KILL PSONEW("DAYS SUPPLY"),PSONEW("# OF REFILLS")
if PSORENW("DFLG")
QUIT
+4 SET PSORNW("FILL DATE")=PSORENW("FILL DATE")
+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,Y
+10 DO CLINIC^PSODIR2(.PSORENW)
if PSORENW("DFLG")
QUIT
+11 DO PROV^PSODIR(.PSORENW)
if PSORENW("DFLG")
SET PSORENW("DFLG")=0
+12 ;p753
SET PSORENW("MAIL EXEMPTION")=""
+13 QUIT
+14 ;
POZ ;
+1 KILL DIR
SET DIR(0)="E"
SET DIR("A")="Press Return to Continue"
DO ^DIR
KILL DIR,DIRUT,DTOUT
+2 QUIT
+3 ;
