- 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
