- 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 Jan 18, 2025@03:34:57 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 ;