PSORENW0 ;IHS/DSD/JCM-renew main driver continuation ;23-Aug-2012 16:17;PLS
;;7.0;OUTPATIENT PHARMACY;**11,27,32,59,64,46,71,96,100,130,1008,1013,237,206,1014,1016**;DEC 1997;Build 74
;External reference to ^PS(50.7 supported by DBIA 2223
;External reference to ^PSDRUG supported by DBIA 221
;External references PSOL and PSOUL^PSSLOCK supported by DBIA 2789
;
;PSO*237 was not adding to Clozapine Override file, fix
; Modified - IHS/CIA/PLS - 01/06/04 - Line PROCESS+6 and new CANC label
; - 04/05/04 - Line EDIT+1
; - 04/20/04 - FILDATE+6
; - 10/23/09 - FILDATE+8
; - 11/01/11 - RXN+2,GETRXN EP
; - 08/23/12 - Added line RXN+14 to strip the X from the new Rx number
; for a renew where it was previously auto finished and the
; mail/window flag changes to Window when renewed
PROCESS ;
D ^PSORENW1
D INST2^PSORENW
I $D(PSORX("BAR CODE")),PSODFN'=PSORENW("PSODFN") D NEWPT
S PSORENW("DFLG")=0,PSORENW("FILL DATE")=PSORNW("FILL DATE")
I $G(PSORNW("MAIL/WINDOW"))]"" S PSORENW("MAIL/WINDOW")=PSORNW("MAIL/WINDOW")
; IHS/CIA/PLS - 01/06/04 Removed last line feed
;W !!,"Now Renewing Rx # "_PSORENW("ORX #")_" Drug: "_$P($G(^PSDRUG(+$G(PSORENW("DRUG IEN")),0)),"^"),!
W !!,"Now Renewing Rx # "_PSORENW("ORX #")_" Drug: "_$P($G(^PSDRUG(+$G(PSORENW("DRUG IEN")),0)),"^")
D PRINT^APSQLAB W ! ; IHS/CIA/PLS - 01/06/04 - Output Lab Data
D CANC ; IHS/CIA/PLS - 01/06/04 - Output comments for cancelled scripts
D CHECK G:PSORENW("DFLG") PROCESSX
D FILDATE
D DRUG G:PSORENW("DFLG")!PSORX("DFLG") PROCESSX
D RXN G:PSORENW("DFLG") PROCESSX
D STOP^PSORENW1,OERR^PSORENW1:$G(PSOFDR)
DSPL K PSOEDT,PSOLM D DSPLY^PSORENW3 G:PSORENW("DFLG") PROCESSX
S PSORENW("QFLG")=0 D:'$G(PSOFDR) EDIT
G:PSORENW("DFLG")!$G(PSORX("FN")) PROCESSX
G:'$G(PSORX("FN"))&('$G(PSORENW("QFLG"))) DSPL
D:$D(^XUSEC("PSORPH",DUZ))!('$P(PSOPAR,"^",2)) VER1^PSOORNE4(.PSORENW) I PSORENW("DFLG")=1 G PROCESSX
I $G(NEWDOSE),PSORENW("ENT")>0 K NEWDOSE G DSPL
D EN^PSORN52(.PSORENW)
D RNPSOSD^PSOUTIL
D CAN,DCORD^PSONEW2
S BBRN="",BBRN1=$O(^PSRX("B",PSORENW("NRX #"),BBRN)) I $P($G(^PSRX(BBRN1,0)),"^",11)["W" S BINGCRT="Y",BINGRTE="W"
;PSO*237 add to Clozapine Override file
ANQ I $G(ANQDATA)]"" D NOW^%DTC G:$D(^PS(52.52,"B",%)) ANQ D
. K DD,DO S DIC="^PS(52.52,",DIC(0)="L",DLAYGO=52.52,X=%
. D FILE^DICN K DIC,DLAYGO,DD,DO,DA,DR
. N PS52 S (PS52,DA)=+Y,DIE="^PS(52.52,",DR="1////"_PSORENW("IRXN")
. D ^DIE K DIE,DA,DR
. S $P(^PS(52.52,PS52,0),"^",3,6)=ANQDATA
. K ANQDATA,X,Y,%,ANQREM
;
PROCESSX I PSORENW("DFLG")!$G(PSRX("DFLG")) S PSOBBCLK=1 W:'$G(POERR) !,$C(7),"RENEWED RX DELETED",! D:$P($G(PSOLST(+$G(ORN))),"^",2) PSOUL^PSSLOCK($P(PSOLST(ORN),"^",2)) S POERR("DFLG")=1 D CLEAN^PSOVER1
D:$G(PSORENW("OLD FILL DATE"))]"" SUSDATEK^PSOUTIL(.PSORENW)
K PRC,PHI,PSOQUIT,BBRN,BBRN1,PSORENW,PSODRUG,PSORX("PROVIDER NAME"),PSORX("CLINIC"),PSORX("FN")
K PSOEDT,PSOLM S:$G(PSORENW("FROM"))="" (PSORENW("DFLG"),PSORENW("QFLG"))=0
D CLEAN^PSOVER1
Q
;
; IHS/CIA/PLS - 01/06/04 - Write comments for cancelled scripts
CANC ; EP
N PSOASUB
I '$D(IORVON) N IORVOFF,IORVON S X="IORVOFF;IORVON" D ENDR^%ZISS
S PSOASUB=$O(^PSRX(PSORENW("OIRXN"),"A","A"),-1) Q:PSOASUB="" D
.I $P(^PSRX(PSORENW("OIRXN"),"A",PSOASUB,0),U,2)="C" D
.W IORVON,"This Prescription was cancelled with comments: ",!,$P(^(0),U,5),IORVOFF D DIR
Q
CHECK ;
I '$D(PSORX("BAR CODE")),PSORENW("PSODFN")'=PSODFN D G CHECKX
.W !!,?5,$C(7),"Can't renew Rx # "_$P(PSORENW("RX0"),"^")_", it is not for this patient." S PSORENW("DFLG")=1
.S:$G(POERR) VALMSG="Can't renew Rx # "_$P(PSORENW("RX0"),"^")_", not for this patient.",VALMBCK="R"
;Invalid dosage check
N PSOOCPRX,PSOOLPF,PSOOLPD,PSONOSIG S PSOOCPRX=PSORENW("OIRXN") D CDOSE
I PSOOLPF!(PSONOSIG) D G CHECKX
.S PSORENW("DFLG")=1
.W !!,$C(7),"Cannot renew Rx # "_$P(PSORENW("RX0"),"^")_$S(PSOOLPF:", invalid dosage of "_$G(PSOOLPD),1:", Missing Sig")
.S:$G(POERR) VALMSG="Cannot renew Rx # "_$P(PSORENW("RX0"),"^")_$S(PSOOLPF:", invalid Dosage of "_$G(PSOOLPD),1:", Missing Sig") S VALMBCK="R"
.I '$G(PSORNSPD) W ! K DIR S DIR(0)="E",DIR("A")="Press Return to Continue" D ^DIR K DIR
.I $G(PSORNSPD) W !
;
S (PSOS,PSOX,PSOY)="" K ACOM,DIR,DIRUT,DIRUT,DUOUT
I $G(PSOSD) F S PSOS=$O(PSOSD(PSOS)) Q:PSOS="" F S PSOX=$O(PSOSD(PSOS,PSOX)) Q:PSOX']""!(PSORENW("DFLG")) I PSORENW("OIRXN")=+PSOSD(PSOS,PSOX) S PSOY=PSOSD(PSOS,PSOX) I $TR($P(PSOY,"^",3),"B")]"" D K ACOM,DIR,DIRUT,DIRUT,DUOUT
. S PSORENW("DFLG")=1
. W !,$C(7),"Cannot renew Rx # ",$P(PSORENW("RX0"),"^")
. S PSOREA=$P(PSOY,"^",3),PSOSTAT=+PSORENW("STA")
. D STATUS^PSOUTIL(PSOREA,PSOSTAT) K PSOREA,PSOSTAT
.I $G(ACOM)]"" D
..S DRG=$P(^PSDRUG($P(^PSRX(PSORENW("OIRXN"),0),"^",6),0),"^")
..W ! S DIR(0)="Y",DIR("A",1)="Do you want to Discontinue this Pending Order",DIR("A")="for "_DRG,DIR("B")="No"
..D ^DIR I 'Y!($D(DIRUT)) Q
..D NOOR^PSOCAN4 Q:$D(DIRUT) D DE^PSOORFI2
.Q
I PSOY="",'$G(PSOORRNW) D
.W !,$C(7),"Cannot renew Rx # ",$P(PSORENW("RX0"),"^")," later Rx exists." S PSORENW("DFLG")=1
.S:$G(POERR) VALMSG="Cannot renew Rx # "_$P(PSORENW("RX0"),"^")_" later Rx exists.",VALMBCK="R"
K PSOX,PSOY G:PSORENW("DFLG") CHECKX
;
I $A($E(PSORENW("ORX #"),$L(PSORENW("ORX #"))))'<90 D Q
. W !,$C(7),"Cannot renew Rx # "_PSORENW("ORX #")_", Max number of renewals reached."
.S:$G(POERR)!('$G(SPEED)) (ACOM,VALMSG)="Cannot renew Rx # "_PSORENW("ORX #")_", Max number reached.",VALMBCK="R"
. S PSORENW("DFLG")=1
.I $G(OR0)]"" D
..S DRG=$P(^PSDRUG($P(^PSRX(PSORENW("OIRXN"),0),"^",6),0),"^")
..W ! S DIR(0)="Y",DIR("A",1)="Do you want to Discontinue this Pending Order",DIR("A")="for "_DRG,DIR("B")="No"
..D ^DIR I 'Y!($D(DIRUT)) Q
..D NOOR^PSOCAN4 Q:$D(DIRUT) D DE^PSOORFI2
.K ACOM Q
D CHKDIV G:PSORENW("DFLG") CHECKX
;
D CHKPRV^PSOUTIL
CHECKX Q
;
CHKDIV ;
G:$P(PSORENW("RX2"),"^",9)=+PSOSITE CHKDIVX
W !?5,$C(7),"RX # ",$P(PSORENW("RX0"),"^")," is for (",$P(^PS(59,$P(PSORENW("RX2"),"^",9),0),"^"),") division."
I '$P($G(PSOSYS),"^",2) S PSORENW("DFLG")=1 G CHKDIVX
D:$P($G(PSOSYS),"^",3) DIR
CHKDIVX Q
;
DRUG ;
K PSOY
S PSOY=PSORENW("DRUG IEN"),PSOY(0)=^PSDRUG(PSOY,0)
I '$P($G(^PSDRUG(PSOY,2)),"^") D Q:$G(PSORX("DFLG"))
.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 SET^PSODRG
D POST^PSODRG S:PSORX("DFLG") PSORENW("DFLG")=1 ;remove order checks for v7. do allergy checks only
;D ^PSODRDUP Q:$G(PSORX("DFLG")) ; Set PSORX("DFLG")=1 if process to stop
S PSONOOR=PSORENW("NOO")
;I $G(PSODRUG("NDF")) S NDF=$P(PSODRUG("NDF"),"A"),VAP=$P(PSODRUG("NDF"),"A",2),PTR=NDF_"."_VAP D CHK^PSODGAL(PSODFN,"DR",PTR) K NDF,VAP,PTR
;I '$G(PSODRUG("NDF")) D CHK1^PSODGAL(PSODFN)
K PSORX("INTERVENE")
S:$D(PSONEW("STATUS")) PSORENW("STATUS")=PSONEW("STATUS")
K PSOY,PSONEW("STATUS")
Q
;
RXN ;
K PSOX
;IHS/MSC/PLS - 11/01/11 - Added next 8 lines
I $P(PSORENW("RX2"),U,9)'=+PSOSITE D Q
.N RXN
.I $$GETRXN(PSOSITE,.RXN) D
..S PSORENW("NRX #")=$G(RXN)
.E D
..W !,"Unable to assign a prescription number for the new pharmacy division."
..D DIRZ^APSPUTIL()
..S VALMSG="Cannot renew Rx # "_PSORENW("ORX #")_", Prescription number not available.",VALMBCK="R" S PSORENW("DFLG")=1
S PSOX=$E(PSORENW("ORX #"),$L(PSORENW("ORX #")))
S PSORENW("NRX #")=$S(PSOX?1N:PSORENW("ORX #")_"A",1:$E(PSORENW("ORX #"),1,$L(PSORENW("ORX #"))-1)_$C($A(PSOX)+1))
;IHS/MSC/PB - 8/23/12 - Added next line to strip the X from the new Rx number for a renew where it was previously auto finished and the mail/window flag changes to Window
I $E(PSORENW("NRX #"),1)="X",$G(PSORENW("MAIL/WINDOW"))="W" S PSORENW("NRX #")=$E(PSORENW("NRX #"),2,$L(PSORENW("NRX #")))
RETRY I $O(^PSRX("B",PSORENW("NRX #"),0)) D G:'$G(PSORENW("DFLG")) RETRY
.W:$A($E(PSORENW("NRX #"),$L(PSORENW("ORX #"))))'=90 !,"Rx # "_PSORENW("NRX #")_" is already on file."
.S:$G(PSOFDR) VALMSG="Rx # "_PSORENW("NRX #")_" is already on file."
.I $A($E(PSORENW("NRX #"),$L(PSORENW("ORX #"))))=90 D
..W !,"Rx # "_PSORENW("NRX #")_" is already on file. Cannot renew Rx #"_PSORENW("ORX #")_".",!,"A new Rx must be entered.",!
..S:$G(PSOFDR) VALMSG="Rx # "_PSORENW("NRX #")_" is already on file. Cannot renew Rx #"_PSORENW("ORX #")_". A new Rx must be entered."
..K DIR S DIR(0)="E",DIR("A")="Press Return to Continue" D ^DIR K DIR
..S:$G(POERR)!($G(PSOFDR)) VALMSG="Cannot renew Rx # "_PSORENW("ORX #")_", Max number reached.",VALMBCK="R" S PSORENW("DFLG")=1
.S PSOX=$E(PSORENW("NRX #"),$L(PSORENW("NRX #")))
.S PSORENW("NRX #")=$S(PSOX?1N:PSORENW("NRX #")_"A",1:$E(PSORENW("NRX #"),1,$L(PSORENW("NRX #"))-1)_$C($A(PSOX)+1))
RXNX K PSOX
Q
;
FILDATE ;
S PSORENW("IRXN")=PSORENW("OIRXN")
D NEXT^PSOUTIL(.PSORENW)
I PSORENW("FILL DATE")<$P(PSORENW("RX3"),"^",2) D
.D RENFDT^PSOUTIL(.PSORENW)
.I PSORENW("FILL DATE")<DT,PSORENW("FILL DATE")<PSORNW("FILL DATE") S (Y,PSORENW("FILL DATE"))=DT X ^DD("DD") S PSORX("FILL DATE")=Y K Y
I $G(PSORENW("FILL DATE"))>DT D
.I '$$GET1^DIQ(59,PSOSITE_",",.091,"I") S PSORENW("FILL DATE")=DT ; IHS/CIA/PLS - 04/20/04 - Force Fill Date to Today if Suspense Function not used
.E I '$$GET1^DIQ(59,PSOSITE_",",.16,"I") S PSORENW("FILL DATE")=DT ;IHS/MSC/PLS - 10/23/2009 - Force Fill Date to Today if Suspense Function YES and Auto Suspense NO
K PSORENW("IRXN")
Q
;
EDIT ;
; IHS/CIA/PLS - 04/05/04 - Warn future fill dates.
I $G(PSORENW("FILL DATE"))>DT D
.W !!,"WARNING: The prescription has a Fill Date in the future!",!
K DIR,X,Y
S DIR(0)="Y",DIR("B")=$S($G(DUZ("AG"))'="I":"Y",$G(PSEXDT):"Y",1:"N")
S DIR("A")="Edit renewed Rx ",DIR("?")="Answer YES to edit the renewed Rx, NO not to."
D ^DIR K DIR S:$D(DIRUT) PSORENW("DFLG")=1
G:PSORENW("DFLG") EDITX
K PSOQUIT,PSORX("FN") I Y D INIT^PSORENW3,EN^PSOORNE4(.PSORENW) S:$G(PSOQUIT) PSORENW("DFLG")=1 I '$G(PSORX("FN")) D FULL^VALM1 Q
Q:$G(PSORX("FN"))
EDITX S PSOEDT=1,VALMBCK="Q" K X,Y,DIRUT,DTOUT,DUOUT S PSORENW("QFLG")=1
Q
;
DELETE ;
K DA,DIK
S DA=$O(^PS(52.5,"B",PSORENW("OIRXN"),0)),DIK="^PS(52.5,"
D ^DIK K DIK,DIC
Q
;
CAN ;
K REA,DA,MSG
S REA="C",DA=PSORENW("OIRXN")
S MSG="Renewed"_$S($G(PSOFDR):" from CPRS",1:"")
S PSCAN(PSORENW("ORX #"))=DA_"^C"
D CAN^PSOCAN
K REA,DA,MSG,PSCAN
Q
;
DIR ;
S DIR(0)="Y",DIR("A")="CONTINUE ",DIR("B")="N"
S DIR("?")="Answer YES to Continue, NO to bypass"
D ^DIR K DIR
S:$D(DIRUT)!('Y) PSORENW("DFLG")=1
DIRX K DIRUT,DTOUT,DUOUT,X,Y
Q
NEWPT ;
S PSOQFLG=0
S PSODFN=PSORENW("PSODFN")
D ^PSOPTPST I PSOQFLG S PSORENW("DFLG")=1,PSOQFLG=0 G NEWPTX
D PROFILE^PSOREF1
NEWPTX Q
;
EN(PSORENW) ; Entry Point for Batch Barcode Option
S PSORENRX=$G(PSOBBC("OIRXN"))
I $G(PSORENRX) D PSOL^PSSLOCK(PSORENRX) I '$G(PSOMSG) D K DIR,PSOMSG W ! S DIR("A")="Press Return to continue",DIR(0)="E" D ^DIR K DIR W ! Q
.I $P($G(PSOMSG),"^",2)'="" W $C(7),!!,$P(PSOMSG,"^",2) Q
.W $C(7),!!,"Another person is editing Rx "_$P($G(^PSRX(PSORENRX,0)),"^")
K PSOMSG,PSOBBCLK S PSOBARCD=1 D PROCESS K PSOBARCD
D KLIB^PSORENW1
I $G(PSORENRX),$G(PSOBBCLK) D PSOUL^PSSLOCK(PSORENRX)
K PSORENRX,PSOBBCLK
Q
CDOSE ;Validate Dosage field on Renewel, Copy, Edit
;PSOOCPRX must be set to internal Rx number
Q:'$G(PSOOCPRX)
N PSOOLP,PSOOKZ
S PSOOLP="",(PSOOLPF,PSONOSIG)=0 F S PSOOLP=$O(^PSRX(PSOOCPRX,6,PSOOLP)) Q:PSOOLP=""!(PSOOLPF) I $P($G(^PSRX(PSOOCPRX,6,PSOOLP,0)),"^")["0.." S PSOOLPD=$P($G(^(0)),"^"),PSOOLPF=1
Q:PSOOLPF
S PSOOKZ=0
I $P($G(^PSRX(PSOOCPRX,"SIG")),"^",2) S PSOOLP="" F S PSOOLP=$O(^PSRX(PSOOCPRX,"SIG1",PSOOLP)) Q:PSOOLP=""!(PSOOKZ) I $G(^PSRX(PSOOCPRX,"SIG1",PSOOLP,0))'="" S PSOOKZ=1
I '$P($G(^PSRX(PSOOCPRX,"SIG")),"^",2),$P($G(^("SIG")),"^")'="" S PSOOKZ=1
I 'PSOOKZ S PSONOSIG=1
Q
; Return new Rx number
GETRXN(PSOSITE,NEWRXN) ;EP-
N PSONEW,RES
D AUTO^PSONRXN
I 'PSONEW("QFLG") D
.S NEWRXN=PSONEW("RX #")
.S RES=1
E D
.S RES=0
Q RES
PSORENW0 ;IHS/DSD/JCM-renew main driver continuation ;23-Aug-2012 16:17;PLS
+1 ;;7.0;OUTPATIENT PHARMACY;**11,27,32,59,64,46,71,96,100,130,1008,1013,237,206,1014,1016**;DEC 1997;Build 74
+2 ;External reference to ^PS(50.7 supported by DBIA 2223
+3 ;External reference to ^PSDRUG supported by DBIA 221
+4 ;External references PSOL and PSOUL^PSSLOCK supported by DBIA 2789
+5 ;
+6 ;PSO*237 was not adding to Clozapine Override file, fix
+7 ; Modified - IHS/CIA/PLS - 01/06/04 - Line PROCESS+6 and new CANC label
+8 ; - 04/05/04 - Line EDIT+1
+9 ; - 04/20/04 - FILDATE+6
+10 ; - 10/23/09 - FILDATE+8
+11 ; - 11/01/11 - RXN+2,GETRXN EP
+12 ; - 08/23/12 - Added line RXN+14 to strip the X from the new Rx number
+13 ; for a renew where it was previously auto finished and the
+14 ; mail/window flag changes to Window when renewed
PROCESS ;
+1 DO ^PSORENW1
+2 DO INST2^PSORENW
+3 IF $DATA(PSORX("BAR CODE"))
IF PSODFN'=PSORENW("PSODFN")
DO NEWPT
+4 SET PSORENW("DFLG")=0
SET PSORENW("FILL DATE")=PSORNW("FILL DATE")
+5 IF $GET(PSORNW("MAIL/WINDOW"))]""
SET PSORENW("MAIL/WINDOW")=PSORNW("MAIL/WINDOW")
+6 ; IHS/CIA/PLS - 01/06/04 Removed last line feed
+7 ;W !!,"Now Renewing Rx # "_PSORENW("ORX #")_" Drug: "_$P($G(^PSDRUG(+$G(PSORENW("DRUG IEN")),0)),"^"),!
+8 WRITE !!,"Now Renewing Rx # "_PSORENW("ORX #")_" Drug: "_$PIECE($GET(^PSDRUG(+$GET(PSORENW("DRUG IEN")),0)),"^")
+9 ; IHS/CIA/PLS - 01/06/04 - Output Lab Data
DO PRINT^APSQLAB
WRITE !
+10 ; IHS/CIA/PLS - 01/06/04 - Output comments for cancelled scripts
DO CANC
+11 DO CHECK
IF PSORENW("DFLG")
GOTO PROCESSX
+12 DO FILDATE
+13 DO DRUG
IF PSORENW("DFLG")!PSORX("DFLG")
GOTO PROCESSX
+14 DO RXN
IF PSORENW("DFLG")
GOTO PROCESSX
+15 DO STOP^PSORENW1
IF $GET(PSOFDR)
DO OERR^PSORENW1
DSPL KILL PSOEDT,PSOLM
DO DSPLY^PSORENW3
IF PSORENW("DFLG")
GOTO PROCESSX
+1 SET PSORENW("QFLG")=0
IF '$GET(PSOFDR)
DO EDIT
+2 IF PSORENW("DFLG")!$GET(PSORX("FN"))
GOTO PROCESSX
+3 IF '$GET(PSORX("FN"))&('$GET(PSORENW("QFLG")))
GOTO DSPL
+4 IF $DATA(^XUSEC("PSORPH",DUZ))!('$PIECE(PSOPAR,"^",2))
DO VER1^PSOORNE4(.PSORENW)
IF PSORENW("DFLG")=1
GOTO PROCESSX
+5 IF $GET(NEWDOSE)
IF PSORENW("ENT")>0
KILL NEWDOSE
GOTO DSPL
+6 DO EN^PSORN52(.PSORENW)
+7 DO RNPSOSD^PSOUTIL
+8 DO CAN
DO DCORD^PSONEW2
+9 SET BBRN=""
SET BBRN1=$ORDER(^PSRX("B",PSORENW("NRX #"),BBRN))
IF $PIECE($GET(^PSRX(BBRN1,0)),"^",11)["W"
SET BINGCRT="Y"
SET BINGRTE="W"
+10 ;PSO*237 add to Clozapine Override file
ANQ IF $GET(ANQDATA)]""
DO NOW^%DTC
IF $DATA(^PS(52.52,"B",%))
GOTO ANQ
Begin DoDot:1
+1 KILL DD,DO
SET DIC="^PS(52.52,"
SET DIC(0)="L"
SET DLAYGO=52.52
SET X=%
+2 DO FILE^DICN
KILL DIC,DLAYGO,DD,DO,DA,DR
+3 NEW PS52
SET (PS52,DA)=+Y
SET DIE="^PS(52.52,"
SET DR="1////"_PSORENW("IRXN")
+4 DO ^DIE
KILL DIE,DA,DR
+5 SET $PIECE(^PS(52.52,PS52,0),"^",3,6)=ANQDATA
+6 KILL ANQDATA,X,Y,%,ANQREM
End DoDot:1
+7 ;
PROCESSX IF PSORENW("DFLG")!$GET(PSRX("DFLG"))
SET PSOBBCLK=1
IF '$GET(POERR)
WRITE !,$CHAR(7),"RENEWED RX DELETED",!
IF $PIECE($GET(PSOLST(+$GET(ORN))),"^",2)
DO PSOUL^PSSLOCK($PIECE(PSOLST(ORN),"^",2))
SET POERR("DFLG")=1
DO CLEAN^PSOVER1
+1 IF $GET(PSORENW("OLD FILL DATE"))]""
DO SUSDATEK^PSOUTIL(.PSORENW)
+2 KILL PRC,PHI,PSOQUIT,BBRN,BBRN1,PSORENW,PSODRUG,PSORX("PROVIDER NAME"),PSORX("CLINIC"),PSORX("FN")
+3 KILL PSOEDT,PSOLM
IF $GET(PSORENW("FROM"))=""
SET (PSORENW("DFLG"),PSORENW("QFLG"))=0
+4 DO CLEAN^PSOVER1
+5 QUIT
+6 ;
+7 ; IHS/CIA/PLS - 01/06/04 - Write comments for cancelled scripts
CANC ; EP
+1 NEW PSOASUB
+2 IF '$DATA(IORVON)
NEW IORVOFF,IORVON
SET X="IORVOFF;IORVON"
DO ENDR^%ZISS
+3 SET PSOASUB=$ORDER(^PSRX(PSORENW("OIRXN"),"A","A"),-1)
IF PSOASUB=""
QUIT
Begin DoDot:1
+4 IF $PIECE(^PSRX(PSORENW("OIRXN"),"A",PSOASUB,0),U,2)="C"
Begin DoDot:2
End DoDot:2
+5 WRITE IORVON,"This Prescription was cancelled with comments: ",!,$PIECE(^(0),U,5),IORVOFF
DO DIR
End DoDot:1
+6 QUIT
CHECK ;
+1 IF '$DATA(PSORX("BAR CODE"))
IF PSORENW("PSODFN")'=PSODFN
Begin DoDot:1
+2 WRITE !!,?5,$CHAR(7),"Can't renew Rx # "_$PIECE(PSORENW("RX0"),"^")_", it is not for this patient."
SET PSORENW("DFLG")=1
+3 IF $GET(POERR)
SET VALMSG="Can't renew Rx # "_$PIECE(PSORENW("RX0"),"^")_", not for this patient."
SET VALMBCK="R"
End DoDot:1
GOTO CHECKX
+4 ;Invalid dosage check
+5 NEW PSOOCPRX,PSOOLPF,PSOOLPD,PSONOSIG
SET PSOOCPRX=PSORENW("OIRXN")
DO CDOSE
+6 IF PSOOLPF!(PSONOSIG)
Begin DoDot:1
+7 SET PSORENW("DFLG")=1
+8 WRITE !!,$CHAR(7),"Cannot renew Rx # "_$PIECE(PSORENW("RX0"),"^")_$SELECT(PSOOLPF:", invalid dosage of "_$GET(PSOOLPD),1:", Missing Sig")
+9 IF $GET(POERR)
SET VALMSG="Cannot renew Rx # "_$PIECE(PSORENW("RX0"),"^")_$SELECT(PSOOLPF:", invalid Dosage of "_$GET(PSOOLPD),1:", Missing Sig")
SET VALMBCK="R"
+10 IF '$GET(PSORNSPD)
WRITE !
KILL DIR
SET DIR(0)="E"
SET DIR("A")="Press Return to Continue"
DO ^DIR
KILL DIR
+11 IF $GET(PSORNSPD)
WRITE !
End DoDot:1
GOTO CHECKX
+12 ;
+13 SET (PSOS,PSOX,PSOY)=""
KILL ACOM,DIR,DIRUT,DIRUT,DUOUT
+14 IF $GET(PSOSD)
FOR
SET PSOS=$ORDER(PSOSD(PSOS))
IF PSOS=""
QUIT
FOR
SET PSOX=$ORDER(PSOSD(PSOS,PSOX))
IF PSOX']""!(PSORENW("DFLG"))
QUIT
IF PSORENW("OIRXN")=+PSOSD(PSOS,PSOX)
SET PSOY=PSOSD(PSOS,PSOX)
IF $TRANSLATE($PIECE(PSOY,"^",3),"B")]""
Begin DoDot:1
+15 SET PSORENW("DFLG")=1
+16 WRITE !,$CHAR(7),"Cannot renew Rx # ",$PIECE(PSORENW("RX0"),"^")
+17 SET PSOREA=$PIECE(PSOY,"^",3)
SET PSOSTAT=+PSORENW("STA")
+18 DO STATUS^PSOUTIL(PSOREA,PSOSTAT)
KILL PSOREA,PSOSTAT
+19 IF $GET(ACOM)]""
Begin DoDot:2
+20 SET DRG=$PIECE(^PSDRUG($PIECE(^PSRX(PSORENW("OIRXN"),0),"^",6),0),"^")
+21 WRITE !
SET DIR(0)="Y"
SET DIR("A",1)="Do you want to Discontinue this Pending Order"
SET DIR("A")="for "_DRG
SET DIR("B")="No"
+22 DO ^DIR
IF 'Y!($DATA(DIRUT))
QUIT
+23 DO NOOR^PSOCAN4
IF $DATA(DIRUT)
QUIT
DO DE^PSOORFI2
End DoDot:2
+24 QUIT
End DoDot:1
KILL ACOM,DIR,DIRUT,DIRUT,DUOUT
+25 IF PSOY=""
IF '$GET(PSOORRNW)
Begin DoDot:1
+26 WRITE !,$CHAR(7),"Cannot renew Rx # ",$PIECE(PSORENW("RX0"),"^")," later Rx exists."
SET PSORENW("DFLG")=1
+27 IF $GET(POERR)
SET VALMSG="Cannot renew Rx # "_$PIECE(PSORENW("RX0"),"^")_" later Rx exists."
SET VALMBCK="R"
End DoDot:1
+28 KILL PSOX,PSOY
IF PSORENW("DFLG")
GOTO CHECKX
+29 ;
+30 IF $ASCII($EXTRACT(PSORENW("ORX #"),$LENGTH(PSORENW("ORX #"))))'<90
Begin DoDot:1
+31 WRITE !,$CHAR(7),"Cannot renew Rx # "_PSORENW("ORX #")_", Max number of renewals reached."
+32 IF $GET(POERR)!('$GET(SPEED))
SET (ACOM,VALMSG)="Cannot renew Rx # "_PSORENW("ORX #")_", Max number reached."
SET VALMBCK="R"
+33 SET PSORENW("DFLG")=1
+34 IF $GET(OR0)]""
Begin DoDot:2
+35 SET DRG=$PIECE(^PSDRUG($PIECE(^PSRX(PSORENW("OIRXN"),0),"^",6),0),"^")
+36 WRITE !
SET DIR(0)="Y"
SET DIR("A",1)="Do you want to Discontinue this Pending Order"
SET DIR("A")="for "_DRG
SET DIR("B")="No"
+37 DO ^DIR
IF 'Y!($DATA(DIRUT))
QUIT
+38 DO NOOR^PSOCAN4
IF $DATA(DIRUT)
QUIT
DO DE^PSOORFI2
End DoDot:2
+39 KILL ACOM
QUIT
End DoDot:1
QUIT
+40 DO CHKDIV
IF PSORENW("DFLG")
GOTO CHECKX
+41 ;
+42 DO CHKPRV^PSOUTIL
CHECKX QUIT
+1 ;
CHKDIV ;
+1 IF $PIECE(PSORENW("RX2"),"^",9)=+PSOSITE
GOTO CHKDIVX
+2 WRITE !?5,$CHAR(7),"RX # ",$PIECE(PSORENW("RX0"),"^")," is for (",$PIECE(^PS(59,$PIECE(PSORENW("RX2"),"^",9),0),"^"),") division."
+3 IF '$PIECE($GET(PSOSYS),"^",2)
SET PSORENW("DFLG")=1
GOTO CHKDIVX
+4 IF $PIECE($GET(PSOSYS),"^",3)
DO DIR
CHKDIVX QUIT
+1 ;
DRUG ;
+1 KILL PSOY
+2 SET PSOY=PSORENW("DRUG IEN")
SET PSOY(0)=^PSDRUG(PSOY,0)
+3 IF '$PIECE($GET(^PSDRUG(PSOY,2)),"^")
Begin DoDot:1
+4 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
+5 WRITE !!,"Cannot Renew!! No Pharmacy Orderable Item!"
SET VALMSG="Cannot Renew!! No Pharmacy Orderable Item!"
SET PSORX("DFLG")=1
End DoDot:1
IF $GET(PSORX("DFLG"))
QUIT
+6 DO SET^PSODRG
+7 ;remove order checks for v7. do allergy checks only
DO POST^PSODRG
IF PSORX("DFLG")
SET PSORENW("DFLG")=1
+8 ;D ^PSODRDUP Q:$G(PSORX("DFLG")) ; Set PSORX("DFLG")=1 if process to stop
+9 SET PSONOOR=PSORENW("NOO")
+10 ;I $G(PSODRUG("NDF")) S NDF=$P(PSODRUG("NDF"),"A"),VAP=$P(PSODRUG("NDF"),"A",2),PTR=NDF_"."_VAP D CHK^PSODGAL(PSODFN,"DR",PTR) K NDF,VAP,PTR
+11 ;I '$G(PSODRUG("NDF")) D CHK1^PSODGAL(PSODFN)
+12 KILL PSORX("INTERVENE")
+13 IF $DATA(PSONEW("STATUS"))
SET PSORENW("STATUS")=PSONEW("STATUS")
+14 KILL PSOY,PSONEW("STATUS")
+15 QUIT
+16 ;
RXN ;
+1 KILL PSOX
+2 ;IHS/MSC/PLS - 11/01/11 - Added next 8 lines
+3 IF $PIECE(PSORENW("RX2"),U,9)'=+PSOSITE
Begin DoDot:1
+4 NEW RXN
+5 IF $$GETRXN(PSOSITE,.RXN)
Begin DoDot:2
+6 SET PSORENW("NRX #")=$GET(RXN)
End DoDot:2
+7 IF '$TEST
Begin DoDot:2
+8 WRITE !,"Unable to assign a prescription number for the new pharmacy division."
+9 DO DIRZ^APSPUTIL()
+10 SET VALMSG="Cannot renew Rx # "_PSORENW("ORX #")_", Prescription number not available."
SET VALMBCK="R"
SET PSORENW("DFLG")=1
End DoDot:2
End DoDot:1
QUIT
+11 SET PSOX=$EXTRACT(PSORENW("ORX #"),$LENGTH(PSORENW("ORX #")))
+12 SET PSORENW("NRX #")=$SELECT(PSOX?1N:PSORENW("ORX #")_"A",1:$EXTRACT(PSORENW("ORX #"),1,$LENGTH(PSORENW("ORX #"))-1)_$CHAR($ASCII(PSOX)+1))
+13 ;IHS/MSC/PB - 8/23/12 - Added next line to strip the X from the new Rx number for a renew where it was previously auto finished and the mail/window flag changes to Window
+14 IF $EXTRACT(PSORENW("NRX #"),1)="X"
IF $GET(PSORENW("MAIL/WINDOW"))="W"
SET PSORENW("NRX #")=$EXTRACT(PSORENW("NRX #"),2,$LENGTH(PSORENW("NRX #")))
RETRY IF $ORDER(^PSRX("B",PSORENW("NRX #"),0))
Begin DoDot:1
+1 IF $ASCII($EXTRACT(PSORENW("NRX #"),$LENGTH(PSORENW("ORX #"))))'=90
WRITE !,"Rx # "_PSORENW("NRX #")_" is already on file."
+2 IF $GET(PSOFDR)
SET VALMSG="Rx # "_PSORENW("NRX #")_" is already on file."
+3 IF $ASCII($EXTRACT(PSORENW("NRX #"),$LENGTH(PSORENW("ORX #"))))=90
Begin DoDot:2
+4 WRITE !,"Rx # "_PSORENW("NRX #")_" is already on file. Cannot renew Rx #"_PSORENW("ORX #")_".",!,"A new Rx must be entered.",!
+5 IF $GET(PSOFDR)
SET VALMSG="Rx # "_PSORENW("NRX #")_" is already on file. Cannot renew Rx #"_PSORENW("ORX #")_". A new Rx must be entered."
+6 KILL DIR
SET DIR(0)="E"
SET DIR("A")="Press Return to Continue"
DO ^DIR
KILL DIR
+7 IF $GET(POERR)!($GET(PSOFDR))
SET VALMSG="Cannot renew Rx # "_PSORENW("ORX #")_", Max number reached."
SET VALMBCK="R"
SET PSORENW("DFLG")=1
End DoDot:2
+8 SET PSOX=$EXTRACT(PSORENW("NRX #"),$LENGTH(PSORENW("NRX #")))
+9 SET PSORENW("NRX #")=$SELECT(PSOX?1N:PSORENW("NRX #")_"A",1:$EXTRACT(PSORENW("NRX #"),1,$LENGTH(PSORENW("NRX #"))-1)_$CHAR($ASCII(PSOX)+1))
End DoDot:1
IF '$GET(PSORENW("DFLG"))
GOTO RETRY
RXNX KILL PSOX
+1 QUIT
+2 ;
FILDATE ;
+1 SET PSORENW("IRXN")=PSORENW("OIRXN")
+2 DO NEXT^PSOUTIL(.PSORENW)
+3 IF PSORENW("FILL DATE")<$PIECE(PSORENW("RX3"),"^",2)
Begin DoDot:1
+4 DO RENFDT^PSOUTIL(.PSORENW)
+5 IF PSORENW("FILL DATE")<DT
IF PSORENW("FILL DATE")<PSORNW("FILL DATE")
SET (Y,PSORENW("FILL DATE"))=DT
XECUTE ^DD("DD")
SET PSORX("FILL DATE")=Y
KILL Y
End DoDot:1
+6 IF $GET(PSORENW("FILL DATE"))>DT
Begin DoDot:1
+7 ; IHS/CIA/PLS - 04/20/04 - Force Fill Date to Today if Suspense Function not used
IF '$$GET1^DIQ(59,PSOSITE_",",.091,"I")
SET PSORENW("FILL DATE")=DT
+8 ;IHS/MSC/PLS - 10/23/2009 - Force Fill Date to Today if Suspense Function YES and Auto Suspense NO
IF '$TEST
IF '$$GET1^DIQ(59,PSOSITE_",",.16,"I")
SET PSORENW("FILL DATE")=DT
End DoDot:1
+9 KILL PSORENW("IRXN")
+10 QUIT
+11 ;
EDIT ;
+1 ; IHS/CIA/PLS - 04/05/04 - Warn future fill dates.
+2 IF $GET(PSORENW("FILL DATE"))>DT
Begin DoDot:1
+3 WRITE !!,"WARNING: The prescription has a Fill Date in the future!",!
End DoDot:1
+4 KILL DIR,X,Y
+5 SET DIR(0)="Y"
SET DIR("B")=$SELECT($GET(DUZ("AG"))'="I":"Y",$GET(PSEXDT):"Y",1:"N")
+6 SET DIR("A")="Edit renewed Rx "
SET DIR("?")="Answer YES to edit the renewed Rx, NO not to."
+7 DO ^DIR
KILL DIR
IF $DATA(DIRUT)
SET PSORENW("DFLG")=1
+8 IF PSORENW("DFLG")
GOTO EDITX
+9 KILL PSOQUIT,PSORX("FN")
IF Y
DO INIT^PSORENW3
DO EN^PSOORNE4(.PSORENW)
IF $GET(PSOQUIT)
SET PSORENW("DFLG")=1
IF '$GET(PSORX("FN"))
DO FULL^VALM1
QUIT
+10 IF $GET(PSORX("FN"))
QUIT
EDITX SET PSOEDT=1
SET VALMBCK="Q"
KILL X,Y,DIRUT,DTOUT,DUOUT
SET PSORENW("QFLG")=1
+1 QUIT
+2 ;
DELETE ;
+1 KILL DA,DIK
+2 SET DA=$ORDER(^PS(52.5,"B",PSORENW("OIRXN"),0))
SET DIK="^PS(52.5,"
+3 DO ^DIK
KILL DIK,DIC
+4 QUIT
+5 ;
CAN ;
+1 KILL REA,DA,MSG
+2 SET REA="C"
SET DA=PSORENW("OIRXN")
+3 SET MSG="Renewed"_$SELECT($GET(PSOFDR):" from CPRS",1:"")
+4 SET PSCAN(PSORENW("ORX #"))=DA_"^C"
+5 DO CAN^PSOCAN
+6 KILL REA,DA,MSG,PSCAN
+7 QUIT
+8 ;
DIR ;
+1 SET DIR(0)="Y"
SET DIR("A")="CONTINUE "
SET DIR("B")="N"
+2 SET DIR("?")="Answer YES to Continue, NO to bypass"
+3 DO ^DIR
KILL DIR
+4 IF $DATA(DIRUT)!('Y)
SET PSORENW("DFLG")=1
DIRX KILL DIRUT,DTOUT,DUOUT,X,Y
+1 QUIT
NEWPT ;
+1 SET PSOQFLG=0
+2 SET PSODFN=PSORENW("PSODFN")
+3 DO ^PSOPTPST
IF PSOQFLG
SET PSORENW("DFLG")=1
SET PSOQFLG=0
GOTO NEWPTX
+4 DO PROFILE^PSOREF1
NEWPTX QUIT
+1 ;
EN(PSORENW) ; Entry Point for Batch Barcode Option
+1 SET PSORENRX=$GET(PSOBBC("OIRXN"))
+2 IF $GET(PSORENRX)
DO PSOL^PSSLOCK(PSORENRX)
IF '$GET(PSOMSG)
Begin DoDot:1
+3 IF $PIECE($GET(PSOMSG),"^",2)'=""
WRITE $CHAR(7),!!,$PIECE(PSOMSG,"^",2)
QUIT
+4 WRITE $CHAR(7),!!,"Another person is editing Rx "_$PIECE($GET(^PSRX(PSORENRX,0)),"^")
End DoDot:1
KILL DIR,PSOMSG
WRITE !
SET DIR("A")="Press Return to continue"
SET DIR(0)="E"
DO ^DIR
KILL DIR
WRITE !
QUIT
+5 KILL PSOMSG,PSOBBCLK
SET PSOBARCD=1
DO PROCESS
KILL PSOBARCD
+6 DO KLIB^PSORENW1
+7 IF $GET(PSORENRX)
IF $GET(PSOBBCLK)
DO PSOUL^PSSLOCK(PSORENRX)
+8 KILL PSORENRX,PSOBBCLK
+9 QUIT
CDOSE ;Validate Dosage field on Renewel, Copy, Edit
+1 ;PSOOCPRX must be set to internal Rx number
+2 IF '$GET(PSOOCPRX)
QUIT
+3 NEW PSOOLP,PSOOKZ
+4 SET PSOOLP=""
SET (PSOOLPF,PSONOSIG)=0
FOR
SET PSOOLP=$ORDER(^PSRX(PSOOCPRX,6,PSOOLP))
IF PSOOLP=""!(PSOOLPF)
QUIT
IF $PIECE($GET(^PSRX(PSOOCPRX,6,PSOOLP,0)),"^")["0.."
SET PSOOLPD=$PIECE($GET(^(0)),"^")
SET PSOOLPF=1
+5 IF PSOOLPF
QUIT
+6 SET PSOOKZ=0
+7 IF $PIECE($GET(^PSRX(PSOOCPRX,"SIG")),"^",2)
SET PSOOLP=""
FOR
SET PSOOLP=$ORDER(^PSRX(PSOOCPRX,"SIG1",PSOOLP))
IF PSOOLP=""!(PSOOKZ)
QUIT
IF $GET(^PSRX(PSOOCPRX,"SIG1",PSOOLP,0))'=""
SET PSOOKZ=1
+8 IF '$PIECE($GET(^PSRX(PSOOCPRX,"SIG")),"^",2)
IF $PIECE($GET(^("SIG")),"^")'=""
SET PSOOKZ=1
+9 IF 'PSOOKZ
SET PSONOSIG=1
+10 QUIT
+11 ; Return new Rx number
GETRXN(PSOSITE,NEWRXN) ;EP-
+1 NEW PSONEW,RES
+2 DO AUTO^PSONRXN
+3 IF 'PSONEW("QFLG")
Begin DoDot:1
+4 SET NEWRXN=PSONEW("RX #")
+5 SET RES=1
End DoDot:1
+6 IF '$TEST
Begin DoDot:1
+7 SET RES=0
End DoDot:1
+8 QUIT RES
