Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: PSORENW4

PSORENW4.m

Go to the documentation of this file.
PSORENW4 ;BIR/SAB - rx speed renew ;6 June 2019 16:18:07
 ;;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**;DEC 1997;Build 4
 ;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
 ;
 S Y=0 I $G(LST)]"" F ORD=1:1:$L(LST,",") S:$P(LST,",",ORD)>0 Y=Y+1  ; count remaining orders in LST
 I 'Y 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
 S X=PSODFN_";DPT(" D ULK^ORX2,UL^PSSLOCK(PSODFN),CLEAN^PSOVER1
 Q
 ;
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 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)
 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 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,Y
 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
 ;