- PSOREJP2 ;BIRM/MFR - Third Party Rejects View/Process ;04/28/05
- ;;7.0;OUTPATIENT PHARMACY;**148,247,260,287,289,358,385,403,421,427,448,482,512,528,549,561**;DEC 1997;Build 41
- ;Reference to ^PSSLOCK supported by IA #2789
- ;Reference to GETDAT^BPSBUTL supported by IA #4719
- ;Reference to ^PS(55 supported by IA #2228
- ;Reference to ^DIC(36 supported by ICR #6142
- ;
- N PSORJSRT,PSOPTFLT,PSODRFLT,PSORXFLT,PSOBYFLD,PSOSTFLT,DIR,DIRUT,DUOUT,DTOUT
- N PSOINFLT,PSODTRNG,PSOINGRP,PSOTRITG,PSOCVATG,PSORCFLT
- S PSORJASC=1,PSOINGRP=0,PSOTRITG=1,PSOCVATG=1
- ;
- ; - Division/Site selection
- D SEL^PSOREJU1("DIVISION","^PS(59,",.PSOREJST,$$GET1^DIQ(59,+$G(PSOSITE),.01)) I $G(PSOREJST)="^" G EXIT
- ;
- ; - Date range selection
- W ! S PSODTRNG=$$DTRNG("T-90","T") I PSODTRNG="^" G EXIT
- ;
- SEL ; - Field Selection (Patient/Drug/Rx)
- S DIR(0)="S^P:PATIENT;D:DRUG;R:Rx;I:INSURANCE;C:REJECT CODE",DIR("B")="P"
- S DIR("A")="By (P)atient, (D)rug, (R)x, (I)nsurance or Reject (C)ode" D ^DIR I $D(DIRUT) G EXIT
- S PSOBYFLD=Y,DIR("B")=""
- ;
- I PSOBYFLD="P" D I $G(PSOPTFLT)="^" G SEL
- . S (PSODRFLT,PSORXFLT,PSOINFLT,PSORCFLT)="ALL",PSORJSRT="DR"
- . D SEL^PSOREJU1("PATIENT","^DPT(",.PSOPTFLT)
- ;
- I PSOBYFLD="D" D I $G(PSODRFLT)="^" G SEL
- . S (PSOPTFLT,PSORXFLT,PSOINFLT,PSORCFLT)="ALL",PSORJSRT="PA"
- . D SEL^PSOREJU1("DRUG","^PSDRUG(",.PSODRFLT)
- ;
- I PSOBYFLD="C" D I $G(PSORCFLT)="^" G SEL
- . S (PSODRFLT,PSOPTFLT,PSORXFLT,PSOINFLT)="ALL",PSORJSRT="PA"
- . D SEL^PSOREJU1("REJECT CODE","^BPSF(9002313.93,",.PSORCFLT)
- ;
- I PSOBYFLD="R" D I $D(DIRUT)!'$G(PSORXFLT) G SEL
- . S (PSOPTFLT,PSODRFLT,PSOINFLT,PSORCFLT)="ALL",PSORJSRT="PA"
- . N DIR,DIRUT,PSODRUG,PSOQUIT,PSORX,PSORXD,RXIEN,X
- . K PSOSTFLT,PSORXFLT
- . S DIR(0)="FAO^1:30"
- . S DIR("A")=" PRESCRIPTION: "
- . S DIR("?",1)=" A prescription number or ECME number may be entered. To look-up a"
- . S DIR("?",2)=" prescription by the ECME number, please enter ""E."" followed by the ECME"
- . S DIR("?")=" number with or without any leading zeros."
- . ;
- . W ! D ^DIR I X=""!$D(DIRUT) Q
- . S X=$$UP^XLFSTR(X),PSOQUIT=0
- . ;
- . ; Prescription Number
- . I $E(X,1,2)'="E." S RXIEN=+$$RXLKP^PSOSPML4(X) I RXIEN<0 Q
- . ;
- . ; ECME Number
- . I $E(X,1,2)="E." D I PSOQUIT Q
- . . S RXIEN=+$$RXNUM^PSOBPSU2($E(X,3,$L(X)))
- . . I RXIEN<0 W " ??" S PSOQUIT=1 Q
- . . S DIC=52,DR=".01;6",DA=RXIEN,DIQ="PSORXD",DIQ(0)="E"
- . . D DIQ^PSODI(52,DIC,DR,DA,.DIQ)
- . . S PSORX=$G(PSORXD(52,DA,.01,"E"))
- . . S PSODRUG=$G(PSORXD(52,DA,6,"E"))
- . . W ?31,PSORX_" "_PSODRUG
- . ;
- . I '$O(^PSRX(RXIEN,"REJ",0)) D Q
- . . W !?40,"Prescription does not have rejects!",$C(7)
- . ;
- . S PSORXFLT=RXIEN
- ;
- ; Insurance Company Lookup - ICR 6142
- I PSOBYFLD="I" D I $G(PSOINFLT)="^" G SEL
- . S (PSOPTFLT,PSODRFLT,PSORXFLT,PSORCFLT)="ALL",PSORJSRT="PA"
- . D SEL^PSOREJU1("INSURANCE","^DIC(36,",.PSOINFLT)
- ;
- ; - Status Selection (UNRESOLVED or RESOLVED)
- I $G(PSOSTFLT)="" D I $D(DIRUT) G EXIT
- . S DIR(0)="S^U:UNRESOLVED;R:RESOLVED;B:BOTH",DIR("B")="B"
- . S DIR("A")="(U)NRESOLVED, (R)RESOLVED or (B)OTH REJECT statuses" D ^DIR
- . S PSOSTFLT=Y
- ;
- D LST^PSOREJP0("VP")
- ;
- EXIT Q
- ;
- CLO ; - Ignore a REJECT hidden action
- N PSOTRIC,X,PSOETEC,PSOIT
- ;
- I '$D(FILL) S FILL=+$$GET1^DIQ(52.25,REJ_","_RX,5)
- S PSOTRIC="",PSOTRIC=$$TRIC^PSOREJP1(RX,FILL,PSOTRIC)
- ;
- ;reference to ^XUSEC( supported by IA 10076
- I PSOTRIC,'$D(^XUSEC("PSO TRICARE/CHAMPVA",DUZ)) S VALMSG="Action Requires <PSO TRICARE/CHAMPVA> security key",VALMBCK="R" Q
- ;if TRICARE or CHAMPVA and user has security key, prompt to continue or not
- ;
- ; Check for Ignore Threshold
- S PSOIT=$$IGNORE^PSOREJU1(RX,FILL)
- I $P(PSOIT,"^")=0 D Q
- . S VALMBCK="R"
- . I $P(PSOIT,"^",2)'="" D
- . . W !!,"Gross Amount Due is $"_$P(PSOIT,"^",2)_". IGNORE requires EPHARMACY SITE MANAGER key."
- . . D WAIT^VALM1
- ;
- I PSOTRIC,'$$CONT^PSOREJU1() S VALMBCK="R" Q
- ;
- I $$CLOSED^PSOREJP1(RX,REJ) D Q
- . S VALMSG="This Reject is marked resolved!",VALMBCK="R"
- N DIR,COM
- D FULL^VALM1
- I '$$SIG^PSOREJU1() S VALMBCK="R" Q
- W !
- S:PSOTRIC COM=$$TCOM^PSOREJP3(RX,FILL) S:'PSOTRIC COM=$$COM^PSOREJU1()
- I COM="^" S VALMBCK="R" Q
- W !
- S DIR(0)="Y",DIR("A")=" Confirm? ",DIR("B")="NO"
- S DIR("A",1)=" When you confirm this REJECT will be marked RESOLVED."
- S DIR("A",2)=" "
- D ^DIR I $G(Y)=0!$D(DIRUT) S VALMBCK="R" Q
- W ?40,"[Closing..." D CLOSE^PSOREJUT(RX,FILL,REJ,DUZ,6,COM,"","","","","",1) W "OK]",!,$C(7) H 1
- I $D(PSOSTFLT),PSOSTFLT'="B" S CHANGE=1
- ;
- I $$PTLBL(RX,FILL) D PRINT^PSOREJP3(RX,FILL)
- I PSOTRIC D
- .S PSOETEC=$$PSOETEC^PSOREJP5(RX,FILL)
- .D AUDIT^PSOTRI(RX,FILL,,COM,$S(PSOETEC:"N",1:"R"),$S(PSOTRIC=1:"T",PSOTRIC=2:"C",1:""))
- ;
- Q
- ;
- OPN ; - Re-open a Closed/Resolved Reject
- I '$$CLOSED^PSOREJP1(RX,REJ) D Q
- . S VALMSG="This Reject is NOT marked resolved!",VALMBCK="R"
- ;cnf, PSO*7*358, check for discontinued and not released
- ; 12 - DISCONTINUED
- ; 14 - DISCONTINUED BY PROVIDER
- ; 15 - DISCONTINUED (EDIT)
- N DCSTAT,PSOREL
- S DCSTAT=$$GET1^DIQ(52,RX,100,"I")
- S PSOREL=0 D
- . I 'FILL S PSOREL=+$$GET1^DIQ(52,RX,31,"I")
- . I FILL S PSOREL=+$$GET1^DIQ(52.1,FILL_","_RX,17,"I")
- I 'PSOREL,"/12/14/15/"[("/"_DCSTAT_"/") S VALMSG="Discontinued Rx has not been released.",VALMBCK="R" Q
- N DIR,COM,REJDATA,NEWDATA,X,REOPEN
- D FULL^VALM1
- I '$$SIG^PSOREJU1() S VALMBCK="R" Q
- W !
- S DIR(0)="Y",DIR("A")=" Confirm",DIR("B")="NO"
- S DIR("A",1)=" When you confirm this REJECT will be marked UNRESOLVED."
- S DIR("A",2)=" "
- D ^DIR I $G(Y)=0!$D(DIRUT) S VALMBCK="R" Q
- ;
- W ?40,"[Re-opening..."
- K REJDATA D GET^PSOREJU2(RX,FILL,.REJDATA,REJ,1) D SETOPN^PSOREJU2(RX,REJ)
- K NEWDATA M NEWDATA=REJDATA(REJ) S NEWDATA("PHARMACIST")=DUZ
- S REOPEN=1 D SAVE^PSOREJUT(RX,FILL,.NEWDATA,REOPEN)
- I $G(NEWDATA("REJECT IEN")),$D(REJDATA(REJ,"COMMENTS")) D
- . S COM=0 F S COM=$O(REJDATA(REJ,"COMMENTS",COM)) Q:'COM D
- . . S X(1)=REJDATA(REJ,"COMMENTS",COM,"COMMENTS")
- . . S X(2)=REJDATA(REJ,"COMMENTS",COM,"DATE/TIME")
- . . S X(3)=REJDATA(REJ,"COMMENTS",COM,"USER")
- . . D SAVECOM^PSOREJP3(RX,NEWDATA("REJECT IEN"),X(1),X(2),X(3))
- D RETRXF^PSOREJU2(RX,FILL,0)
- W "OK]",!,$C(7) H 1
- S CHANGE=1
- Q
- ;
- SDC ; - Suspense Date Calculation
- D CHG(1)
- Q
- ;
- CSD ;CSD - Change Suspense Date action entry point
- D CHG(0)
- Q
- ;
- CHG(SDC) ; - Change Suspense Date action
- ;Local:
- ; SDC - indicates if the suspense date is being manually changed or calculated.
- ; RX - RX IEN
- ; REJ - Reject indicator
- ;
- I '$G(SDC) S SDC=0
- I $$CLOSED^PSOREJP1(RX,REJ) D Q
- . S VALMSG="This Reject is marked resolved!",VALMBCK="R" W $C(7)
- ;
- N SUSDT,PSOMSG,Y,SUSRX,%DT,DA,DIE,DR,ISSDT,EXPDT,PSOMSG,CUTDT,FILDT,RFL,COB
- ;
- S RFL=+$$GET1^DIQ(52.25,REJ_","_RX,5),SUSDT=$$RXSUDT^PSOBPSUT(RX,RFL)
- I RFL>0 S FILDT=$$GET1^DIQ(52.1,RFL_","_RX,.01,"I")
- E S FILDT=$$GET1^DIQ(52,RX,22,"I")
- I SUSDT="" S VALMSG="Prescription is not suspended!",VALMBCK="R" W $C(7) Q
- I $$RXRLDT^PSOBPSUT(RX,RFL) S VALMSG="Prescription has been released already!",VALMBCK="R" W $C(7) Q
- ;cnf, PSO*7*358, add PSOET logic for TRICARE/CHAMPVA non-billable
- S PSOET=$$PSOET^PSOREJP3(RX,RFL)
- I PSOET S VALMSG=$S(SDC=1:"SDC",1:"CSD")_" not allowed for "_$$ELIGDISP^PSOREJP1(RX,RFL)_" Non-Billable claim.",VALMBCK="R" Q
- ;
- D PSOL^PSSLOCK(RX) I '$G(PSOMSG) S VALMSG=$P(PSOMSG,"^",2),VALMBCK="R" W $C(7) Q
- ;
- S ISSDT=$$GET1^DIQ(52,RX,1,"I"),EXPDT=$$GET1^DIQ(52,RX,26,"I")
- S SUSRX=$O(^PS(52.5,"B",RX,0))
- ;
- D FULL^VALM1
- I SDC D I SUSDT=0 D PSOUL^PSSLOCK(RX) S VALMBCK="R" Q
- . S COB=$$GET1^DIQ(52.25,REJ_","_RX,27,"I")
- . I 'COB S COB=1
- . S SUSDT=$$CALCSD(RX,RFL,COB)
- ;
- ; Display a message to the user if the Bypass 3/4 Day Supply flag is set.
- ;
- I $$FLAG^PSOBPSU4(RX,RFL)="YES" D
- . W !!,"Currently, Bypass 3/4 Day Supply is set to YES. If you continue, the"
- . W !,"prescription fill will transmit to CMOP on the new Suspense Date entered.",!
- . Q
- ;
- SUDT ; Asks for the new Suspense Date
- N X1,X2
- S X1=FILDT,X2=89 D C^%DTC S CUTDT=X
- I SDC,SUSDT,SUSDT<DT W !,*7," **CALCULATED SUSPENSE DATE IS IN THE PAST: ",$$FMTE^XLFDT(SUSDT),"**" S SUSDT=""
- E S %DT("B")=$$FMTE^XLFDT(SUSDT)
- S %DT="EA",%DT("A")=$S(SDC:"NEW ",1:"")_"SUSPENSE DATE: "
- W ! D ^%DT I Y<0!($D(DTOUT)) D PSOUL^PSSLOCK(RX) S VALMBCK="R" I (SDC) W !,"ACTION NOT TAKEN!" Q
- I Y<ISSDT D G SUDT
- . W !!?5,"Suspense Date cannot be before Issue Date: ",$$FMTE^XLFDT(ISSDT),".",$C(7)
- I Y>EXPDT D G SUDT
- . W !!?5,"Suspense Date cannot be after Expiration Date: ",$$FMTE^XLFDT(EXPDT),".",$C(7)
- I Y>CUTDT D G SUDT
- . W !!?5,"Suspense Date cannot be after fill date plus 90 days: "_$$FMTE^XLFDT(CUTDT),".",$C(7)
- S SUSDT=Y
- ;
- N DIR,DIRUT W !
- S DIR("A",1)=" When you confirm, this REJECT will be marked resolved. A"
- S DIR("A",2)=" new claim will be re-submitted to the 3rd party payer"
- I $$GET1^DIQ(52.5,SUSRX,3)="" D
- . I SUSDT>DT D
- . . S DIR("A",3)=" when the prescription label for this fill is printed"
- . . S DIR("A",4)=" from suspense on "_$$FMTE^XLFDT(SUSDT)_"."
- . . S DIR("A",5)=" "
- . . S DIR("A",6)=" Note: THE LABEL FOR THIS PRESCRIPTION FILL WILL NOT BE"
- . . S DIR("A",7)=" PRINTED LOCAL FROM SUSPENSE BEFORE "_$$FMTE^XLFDT(SUSDT)_"."
- . E D
- . . S DIR("A",3)=" the next time local labels are printed from suspense."
- E D
- . I SUSDT>DT D
- . . S DIR("A",3)=" when the prescription is transmitted to CMOP on "
- . . S DIR("A",4)=" "_$$FMTE^XLFDT(SUSDT)_"."
- . . S DIR("A",5)=" "
- . . S DIR("A",6)=" Note: THIS PRESCRIPTION FILL WILL NOT BE TRANSMITTED TO"
- . . S DIR("A",7)=" CMOP BEFORE "_$$FMTE^XLFDT(SUSDT)_"."
- . E D
- . . S DIR("A",3)=" when this prescription fill is transmitted to CMOP on"
- . . S DIR("A",4)=" the next CMOP transmission."
- ;
- S DIR("A",$O(DIR("A",""),-1)+1)=" "
- S DIR(0)="Y",DIR("A")=" Confirm? ",DIR("B")="YES"
- D ^DIR I $G(Y)=0!$D(DIRUT) S VALMBCK="R" D PSOUL^PSSLOCK(RX) Q
- ;
- ; - Suspense/Fill Date updates
- I SUSDT'=$$RXSUDT^PSOBPSUT(RX,RFL) D
- . N DA,DIE,DR,PSOX,SFN,INDT,DEAD
- . S DA=SUSRX,DIE="^PS(52.5,",DR=".02///"_SUSDT D ^DIE
- . S SFN=SUSRX,DEAD=0,INDT=SUSDT D CHANGE^PSOSUCH1(RX,RFL)
- ;
- ; - Flagging the prescription to be re-submitted to ECME on the next CMOP/Print from Suspense
- D RETRXF^PSOREJU2(RX,RFL,1)
- W ?40,"[Closing..."
- D CLOSE^PSOREJUT(RX,RFL,REJ,DUZ,8,"Fill Date changed to "_$$FMTE^XLFDT(SUSDT)_". A new claim will be re-submitted on this date.")
- W "OK]",!,$C(7) H 1 I $D(PSOSTFLT),PSOSTFLT'="B" S CHANGE=1
- D PSOUL^PSSLOCK(RX)
- Q
- ;
- PTLBL(RX,RFL) ; Conditionally prompts user with 'Print Label?' prompt.
- ; If User responds YES to 'Print Label' value of 1 is returned.
- ; If User responds NO to 'Print Label' value of 0 is returned.
- N CMP,LBL,PSOACT,PSOBPS,PSOTRIC,PTLBL,REPRINT
- ;
- I $G(RFL)="" S RFL=$$LSTRFL^PSOBPSU1(RX)
- ;
- ; PSOBPS and PSOTRIC are used to check eligibility. Eligibility checking
- ; is only needed for non-billable Rxs (ie PSOBPS'="e")
- S PSOBPS=$$ECME^PSOBPSUT(RX)
- S PSOTRIC=$$TRIC^PSOREJP1(RX,RFL,.PSOTRIC)
- ;
- I $$FIND^PSOREJUT(RX,RFL) Q 0 ; Has OPEN/UNRESOLVED 3rd pary payer reject
- I $$GET1^DIQ(52,RX,100,"I") Q 0 ; Rx status not ACTIVE
- I $$RXRLDT^PSOBPSUT(RX,RFL),PSOBPS="e" Q 0 ; Rx Released - billable
- I $$RXRLDT^PSOBPSUT(RX,RFL),PSOBPS'="e",'PSOTRIC Q 0 ; Rx Released - non-billable
- ;
- ; If CMOP Suspense Label printed for this Fill, don't allow reprint here
- S PTLBL=1
- S PSOACT=0
- F S PSOACT=$O(^PSRX(RX,"A",PSOACT)) Q:'PSOACT D Q:'PTLBL
- . I +$$GET1^DIQ(52.3,PSOACT_","_RX,.04,"I")'=RFL Q
- . I $$GET1^DIQ(52.3,PSOACT_","_RX,.05,"E")["CMOP Suspense Label Printed" S PTLBL=0
- I 'PTLBL Q 0
- ;
- ; If there is an entry in the CMOP Event multiple, and it is for the
- ; current Fill, check the status. If 0/Transmitted, 1/Dispensed, or
- ; 2/Retransmitted, then do not allow the label to be printed.
- ;
- S CMP=0
- F S CMP=$O(^PSRX(RX,4,CMP)) Q:'CMP D Q:'PTLBL
- . I +$$GET1^DIQ(52.01,CMP_","_RX,2,"I")'=RFL Q
- . I "0,1,2"[$$GET1^DIQ(52.01,CMP_","_RX,3,"I") S PTLBL=0
- I 'PTLBL Q 0
- ;
- ; - Label already printed for Rx fill?
- S LBL=0
- F S LBL=$O(^PSRX(RX,"L",LBL)) Q:'LBL D Q:'PTLBL
- . I +$$GET1^DIQ(52.032,LBL_","_RX,1,"I")'=RFL Q
- . I '$$RXRLDT^PSOBPSUT(RX,RFL),+$$GET1^DIQ(52.032,LBL_","_RX,1,"I")=RFL,PSOBPS="e" S REPRINT=1 Q
- . I $G(PSOTRIC)&($$RXRLDT^PSOBPSUT(RX,RFL)),PSOBPS'="e" S REPRINT=1 Q
- . I $$GET1^DIQ(52.032,LBL_","_RX,4,"I") Q
- . I $$GET1^DIQ(52.032,LBL_","_RX,2)["INTERACTION" Q
- . S PTLBL=0
- ;
- I 'PTLBL Q 0
- ;
- N DIR,DIRUT,Y
- W !
- S DIR(0)="Y"
- S DIR("A")=$S('$G(REPRINT):"Print Label",1:"Reprint Label")
- S DIR("B")="YES"
- I PSOBPS="e" K DIR("B")
- D ^DIR
- I $G(Y)=0!$D(DIRUT) S PTLBL=0
- ;
- Q PTLBL
- ;
- DTRNG(BGN,END) ; Date Range Selection
- ;Input: (o) BGN - Default Begin Date
- ; (o) END - Default End Date
- ;
- N %DT,DTOUT,DUOUT,DTRNG,X,Y
- S DTRNG=""
- S %DT="AEST",%DT("A")="BEGIN REJECT DATE: ",%DT("B")=$G(BGN) K:$G(BGN)="" %DT("B") D ^%DT
- I $G(DUOUT)!$G(DTOUT)!($G(Y)=-1) Q "^"
- S $P(DTRNG,U)=Y
- ;
- W ! K %DT
- S %DT="AEST",%DT("A")="END REJECT DATE: ",%DT("B")=$G(END),%DT(0)=Y K:$G(END)="" %DT("B") D ^%DT
- I $G(DUOUT)!$G(DTOUT)!($G(Y)=-1) Q "^"
- ;
- ;Define Entry
- S $P(DTRNG,U,2)=Y
- ;
- Q DTRNG
- ;
- CALCSD(RX,FIL,COB) ;
- ; CALCSD - Prompt the user for Last Date of Service, Last Days Supply and
- ; then calculate the suspense date based on these input.
- ; Input
- ; RX - Prescription IEN
- ; FIL - Fill Number
- ; COB - Coordination of Benefits
- ; Return
- ; The calculated suspense date
- ;
- N DIR,X,Y,DUOUT,DTOUT,DIRUT,DIROUT,LDOS,LDSUP,LDS
- I '$G(RX) Q 0
- I $G(FIL)="" Q 0
- I '$G(COB) S COB=1
- ;
- D PREVRX(RX,FIL,COB,.LDOS,.LDS) ; get the previous Rx last date of service and last days supply
- ; Prompt for Last DOS
- S DIR(0)="D",DIR("A")="LAST DATE OF SERVICE"
- I LDOS S DIR("B")=$$FMTE^XLFDT($G(LDOS))
- D ^DIR
- I $D(DIRUT) W !,"ACTION NOT TAKEN!" Q 0
- S LDOS=Y W " ("_$$FMTE^XLFDT($G(LDOS))_")"
- ;
- ; Prompt for Last Days Supply
- S LDSUP=LDS
- K DIR
- S DIR(0)="N",DIR("A")="LAST DAYS SUPPLY"
- I LDSUP]"" S DIR("B")=+LDSUP
- D ^DIR
- I $D(DIRUT) W !,"ACTION NOT TAKEN!" Q 0
- ;
- ; Calculate the suspense date to be Last DOS plus 3/4 of the Last Days Supply
- ; Fractions are rounded up
- S LDSUP=Y*.75
- S:LDSUP["." LDSUP=(LDSUP+1)\1
- Q $$FMADD^XLFDT(LDOS,LDSUP)
- ;
- PREVRX(RX,RFL,COB,LDOS,LDAYS,PREVRX) ; Gather last date of service and last days supply from previous rx
- ; input: RX - Current RX
- ; RFL - Refill
- ; COB - Coordination of benefits
- ; output: LDOS - (pass by reference) Last date of service in fileman format, or ""
- ; LDAYS - (pass by reference) Last days supply in numeric format, or ""
- ; PREVRX - (pass by reference) Previous Rx for same drug, if any
- ;
- S (LDOS,LDAYS,PREVRX)=""
- I '$G(RX) G PREVRXQ
- I $G(RFL)="" G PREVRXQ
- I '$G(COB) S COB=1
- ;
- ; Original fill. Check previous Rx's.
- ;
- I RFL=0 D
- . N X
- . S X=$$LAST120(RX,COB) ; other Rx 120 day time window
- . S LDOS=$P(X,U,1) ; last date of service (older rx)
- . S LDAYS=$P(X,U,2) ; last days supply (older rx)
- . S PREVRX=$P(X,U,3) ; Previous Rx, if any
- . Q
- ;
- ; refill - same RX. Get previus fill information
- ;
- I RFL>0 D
- . N FL
- . F FL=(RFL-1):-1:0 D Q:LDOS ; start with the previous fill (RFL-1)
- .. I $$STATUS^PSOBPSUT(RX,FL)="" Q ; no ECME activity - skip
- .. I $$FIND^PSOREJUT(RX,FL,,,1) Q ; unresolved reject on worklist - skip
- .. D GETDAT^BPSBUTL(RX,FL,COB,.LDOS,.LDAYS) ; DBIA 4719
- .. Q
- . Q
- ;
- PREVRXQ ;
- Q
- ;
- LAST120(RX,COB) ;
- ; For the original fill, get the default DOS/Days Supply by getting
- ; most recent DOS from the other RXs within a time window for the same
- ; patient and drug and dosage Time window - Prescription has an
- ; expiration date that is in the future or within the last 120 days
- ; Input
- ; RX - Prescription IEN
- ; COB - coordination of benefits indicator (defaults to 1 if not passed)
- ; Output
- ; Last Date of Service ^ Last Days Supply ^ Previous Rx
- ;
- N DOSAGE,DOSAGE1,DRUG,DRUG1,DSUP,DSUP1,EXPDT,FL
- N LDOS,LDS,LSTFIL,PAT,PREVFL,PREVRX,QTY,QTY1,RX0,RX1,X1,X2
- ;
- I '$G(COB) S COB=1
- S LDOS="",LDS="",PREVRX=""
- S RX0=$G(^PSRX(RX,0)) ; Main 0 node.
- S PAT=$P(RX0,U,2),DRUG=$P(RX0,U,6)
- I 'PAT!'DRUG Q "^^"
- S QTY=+$P(RX0,U,7),DSUP=+$P(RX0,U,8),DOSAGE=""
- I QTY,DSUP S DOSAGE=QTY/DSUP ; Dosage is ratio of Qty to Days Supply.
- S EXPDT=$$FMADD^XLFDT(DT,-121)
- F S EXPDT=$O(^PS(55,PAT,"P","A",EXPDT)) Q:'EXPDT D ; IA 2228.
- . S RX1=""
- . F S RX1=$O(^PS(55,PAT,"P","A",EXPDT,RX1)) Q:'RX1 I RX'=RX1 D
- . . S DRUG1=$P($G(^PSRX(+RX1,0)),U,6)
- . . I DRUG'=DRUG1 Q ; If not the same drug, skip this other Rx.
- . . ;
- . . S LSTFIL=$$LSTRFL^PSOBPSU1(RX1) ; Start with last fill# of this other Rx.
- . . S X1="",X2="" ; For this other Rx, initialize the temp variables for last DOS and last days supply.
- . . F FL=LSTFIL:-1:0 D Q:X1 ; Loop backwards until we find the latest valid DOS.
- . . . D CHECKIT(RX1,FL,COB,.X1,.X2)
- . . . Q
- . . ;
- . . I X1>LDOS S LDOS=X1,LDS=X2,PREVRX=RX1,PREVFL=FL
- . . Q
- . Q
- ;
- ; If a previous Rx passed all other checks, then check the dosage. If
- ; the dosage is not the same, then clear out the variables and treat as
- ; if no previous Rx was found.
- ;
- I PREVRX'="" D
- . S QTY1=$S(PREVFL=0:+$P($G(^PSRX(PREVRX,0)),U,7),1:+$P($G(^PSRX(PREVRX,1,PREVFL,0)),U,4))
- . S DSUP1=$S(PREVFL=0:+$P($G(^PSRX(PREVRX,0)),U,8),1:+$P($G(^PSRX(PREVRX,1,PREVFL,0)),U,10))
- . S DOSAGE1=""
- . I QTY1,DSUP1 S DOSAGE1=QTY1/DSUP1
- . I DOSAGE'=DOSAGE1 S (LDOS,LDS,PREVRX)=""
- . Q
- ;
- I PREVRX'="" S PREVRX=$$GET1^DIQ(52,PREVRX_",",.01) ; Pull external Rx#.
- Q LDOS_U_LDS_U_PREVRX
- ;
- ; CHECKIT was added to consolidate checks that were previously being
- ; performed in two different procedures (PREVRX, LAST120).
- ;
- CHECKIT(RX,FL,COB,LDOS,LDAYS) ; Check 1 Rx/Fill for days' supply calc.
- ;
- ; Input: (r) RX - Rx IEN (#52)
- ; (o) FL - Refill#
- ; (o) COB - Payer sequence
- ; Output: LDOS - Date of service for this Rx/Fill
- ; LDAYS - Days' supply for this Rx/Fill
- ; The CHECKIT procedure determines whether a given Rx and Fill can be
- ; used in determining whether the 3/4 days' supply requirement has
- ; been met for another Rx/Fill. The Rx/Fill being checked here must
- ; meet several criteria, including the following checked by this
- ; procedure:
- ; - The Rx/Fill must be released.
- ; - The Rx status must not be Non-Verified.
- ; - The RX must not have an Expiration Date earlier than 120 days
- ; before today.
- ; - The Rx/Fill must have ECME activity.
- ; - The Rx/Fill must not have any unresolved rejects.
- ;
- N EXPDT
- I '$$RXRLDT^PSOBPSUT(RX,FL) Q ; If not released, Quit.
- I $$GET1^DIQ(52,RX,100,"I")=1 Q ; If Status is NON-VERIFIED, Quit.
- S EXPDT=$$GET1^DIQ(52,RX,26,"I") ; If Expiration Date of Rx is more
- I EXPDT,$$FMDIFF^XLFDT(DT,EXPDT)>120 Q ; than 120 days ago, Quit.
- I $$STATUS^PSOBPSUT(RX,FL)="" Q ; If no ECME activity, Quit.
- I $$FIND^PSOREJUT(RX,FL,,,1) Q ; If any unresolved rejects, Quit.
- ;
- ; Pull the Date of Service and Days' Supply for this Rx/Fill.
- ;
- D GETDAT^BPSBUTL(RX,FL,COB,.LDOS,.LDAYS) ; IA 4719.
- Q
- ;
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSOREJP2 19566 printed Feb 18, 2025@23:59:58 Page 2
- PSOREJP2 ;BIRM/MFR - Third Party Rejects View/Process ;04/28/05
- +1 ;;7.0;OUTPATIENT PHARMACY;**148,247,260,287,289,358,385,403,421,427,448,482,512,528,549,561**;DEC 1997;Build 41
- +2 ;Reference to ^PSSLOCK supported by IA #2789
- +3 ;Reference to GETDAT^BPSBUTL supported by IA #4719
- +4 ;Reference to ^PS(55 supported by IA #2228
- +5 ;Reference to ^DIC(36 supported by ICR #6142
- +6 ;
- +7 NEW PSORJSRT,PSOPTFLT,PSODRFLT,PSORXFLT,PSOBYFLD,PSOSTFLT,DIR,DIRUT,DUOUT,DTOUT
- +8 NEW PSOINFLT,PSODTRNG,PSOINGRP,PSOTRITG,PSOCVATG,PSORCFLT
- +9 SET PSORJASC=1
- SET PSOINGRP=0
- SET PSOTRITG=1
- SET PSOCVATG=1
- +10 ;
- +11 ; - Division/Site selection
- +12 DO SEL^PSOREJU1("DIVISION","^PS(59,",.PSOREJST,$$GET1^DIQ(59,+$GET(PSOSITE),.01))
- IF $GET(PSOREJST)="^"
- GOTO EXIT
- +13 ;
- +14 ; - Date range selection
- +15 WRITE !
- SET PSODTRNG=$$DTRNG("T-90","T")
- IF PSODTRNG="^"
- GOTO EXIT
- +16 ;
- SEL ; - Field Selection (Patient/Drug/Rx)
- +1 SET DIR(0)="S^P:PATIENT;D:DRUG;R:Rx;I:INSURANCE;C:REJECT CODE"
- SET DIR("B")="P"
- +2 SET DIR("A")="By (P)atient, (D)rug, (R)x, (I)nsurance or Reject (C)ode"
- DO ^DIR
- IF $DATA(DIRUT)
- GOTO EXIT
- +3 SET PSOBYFLD=Y
- SET DIR("B")=""
- +4 ;
- +5 IF PSOBYFLD="P"
- Begin DoDot:1
- +6 SET (PSODRFLT,PSORXFLT,PSOINFLT,PSORCFLT)="ALL"
- SET PSORJSRT="DR"
- +7 DO SEL^PSOREJU1("PATIENT","^DPT(",.PSOPTFLT)
- End DoDot:1
- IF $GET(PSOPTFLT)="^"
- GOTO SEL
- +8 ;
- +9 IF PSOBYFLD="D"
- Begin DoDot:1
- +10 SET (PSOPTFLT,PSORXFLT,PSOINFLT,PSORCFLT)="ALL"
- SET PSORJSRT="PA"
- +11 DO SEL^PSOREJU1("DRUG","^PSDRUG(",.PSODRFLT)
- End DoDot:1
- IF $GET(PSODRFLT)="^"
- GOTO SEL
- +12 ;
- +13 IF PSOBYFLD="C"
- Begin DoDot:1
- +14 SET (PSODRFLT,PSOPTFLT,PSORXFLT,PSOINFLT)="ALL"
- SET PSORJSRT="PA"
- +15 DO SEL^PSOREJU1("REJECT CODE","^BPSF(9002313.93,",.PSORCFLT)
- End DoDot:1
- IF $GET(PSORCFLT)="^"
- GOTO SEL
- +16 ;
- +17 IF PSOBYFLD="R"
- Begin DoDot:1
- +18 SET (PSOPTFLT,PSODRFLT,PSOINFLT,PSORCFLT)="ALL"
- SET PSORJSRT="PA"
- +19 NEW DIR,DIRUT,PSODRUG,PSOQUIT,PSORX,PSORXD,RXIEN,X
- +20 KILL PSOSTFLT,PSORXFLT
- +21 SET DIR(0)="FAO^1:30"
- +22 SET DIR("A")=" PRESCRIPTION: "
- +23 SET DIR("?",1)=" A prescription number or ECME number may be entered. To look-up a"
- +24 SET DIR("?",2)=" prescription by the ECME number, please enter ""E."" followed by the ECME"
- +25 SET DIR("?")=" number with or without any leading zeros."
- +26 ;
- +27 WRITE !
- DO ^DIR
- IF X=""!$DATA(DIRUT)
- QUIT
- +28 SET X=$$UP^XLFSTR(X)
- SET PSOQUIT=0
- +29 ;
- +30 ; Prescription Number
- +31 IF $EXTRACT(X,1,2)'="E."
- SET RXIEN=+$$RXLKP^PSOSPML4(X)
- IF RXIEN<0
- QUIT
- +32 ;
- +33 ; ECME Number
- +34 IF $EXTRACT(X,1,2)="E."
- Begin DoDot:2
- +35 SET RXIEN=+$$RXNUM^PSOBPSU2($EXTRACT(X,3,$LENGTH(X)))
- +36 IF RXIEN<0
- WRITE " ??"
- SET PSOQUIT=1
- QUIT
- +37 SET DIC=52
- SET DR=".01;6"
- SET DA=RXIEN
- SET DIQ="PSORXD"
- SET DIQ(0)="E"
- +38 DO DIQ^PSODI(52,DIC,DR,DA,.DIQ)
- +39 SET PSORX=$GET(PSORXD(52,DA,.01,"E"))
- +40 SET PSODRUG=$GET(PSORXD(52,DA,6,"E"))
- +41 WRITE ?31,PSORX_" "_PSODRUG
- End DoDot:2
- IF PSOQUIT
- QUIT
- +42 ;
- +43 IF '$ORDER(^PSRX(RXIEN,"REJ",0))
- Begin DoDot:2
- +44 WRITE !?40,"Prescription does not have rejects!",$CHAR(7)
- End DoDot:2
- QUIT
- +45 ;
- +46 SET PSORXFLT=RXIEN
- End DoDot:1
- IF $DATA(DIRUT)!'$GET(PSORXFLT)
- GOTO SEL
- +47 ;
- +48 ; Insurance Company Lookup - ICR 6142
- +49 IF PSOBYFLD="I"
- Begin DoDot:1
- +50 SET (PSOPTFLT,PSODRFLT,PSORXFLT,PSORCFLT)="ALL"
- SET PSORJSRT="PA"
- +51 DO SEL^PSOREJU1("INSURANCE","^DIC(36,",.PSOINFLT)
- End DoDot:1
- IF $GET(PSOINFLT)="^"
- GOTO SEL
- +52 ;
- +53 ; - Status Selection (UNRESOLVED or RESOLVED)
- +54 IF $GET(PSOSTFLT)=""
- Begin DoDot:1
- +55 SET DIR(0)="S^U:UNRESOLVED;R:RESOLVED;B:BOTH"
- SET DIR("B")="B"
- +56 SET DIR("A")="(U)NRESOLVED, (R)RESOLVED or (B)OTH REJECT statuses"
- DO ^DIR
- +57 SET PSOSTFLT=Y
- End DoDot:1
- IF $DATA(DIRUT)
- GOTO EXIT
- +58 ;
- +59 DO LST^PSOREJP0("VP")
- +60 ;
- EXIT QUIT
- +1 ;
- CLO ; - Ignore a REJECT hidden action
- +1 NEW PSOTRIC,X,PSOETEC,PSOIT
- +2 ;
- +3 IF '$DATA(FILL)
- SET FILL=+$$GET1^DIQ(52.25,REJ_","_RX,5)
- +4 SET PSOTRIC=""
- SET PSOTRIC=$$TRIC^PSOREJP1(RX,FILL,PSOTRIC)
- +5 ;
- +6 ;reference to ^XUSEC( supported by IA 10076
- +7 IF PSOTRIC
- IF '$DATA(^XUSEC("PSO TRICARE/CHAMPVA",DUZ))
- SET VALMSG="Action Requires <PSO TRICARE/CHAMPVA> security key"
- SET VALMBCK="R"
- QUIT
- +8 ;if TRICARE or CHAMPVA and user has security key, prompt to continue or not
- +9 ;
- +10 ; Check for Ignore Threshold
- +11 SET PSOIT=$$IGNORE^PSOREJU1(RX,FILL)
- +12 IF $PIECE(PSOIT,"^")=0
- Begin DoDot:1
- +13 SET VALMBCK="R"
- +14 IF $PIECE(PSOIT,"^",2)'=""
- Begin DoDot:2
- +15 WRITE !!,"Gross Amount Due is $"_$PIECE(PSOIT,"^",2)_". IGNORE requires EPHARMACY SITE MANAGER key."
- +16 DO WAIT^VALM1
- End DoDot:2
- End DoDot:1
- QUIT
- +17 ;
- +18 IF PSOTRIC
- IF '$$CONT^PSOREJU1()
- SET VALMBCK="R"
- QUIT
- +19 ;
- +20 IF $$CLOSED^PSOREJP1(RX,REJ)
- Begin DoDot:1
- +21 SET VALMSG="This Reject is marked resolved!"
- SET VALMBCK="R"
- End DoDot:1
- QUIT
- +22 NEW DIR,COM
- +23 DO FULL^VALM1
- +24 IF '$$SIG^PSOREJU1()
- SET VALMBCK="R"
- QUIT
- +25 WRITE !
- +26 if PSOTRIC
- SET COM=$$TCOM^PSOREJP3(RX,FILL)
- if 'PSOTRIC
- SET COM=$$COM^PSOREJU1()
- +27 IF COM="^"
- SET VALMBCK="R"
- QUIT
- +28 WRITE !
- +29 SET DIR(0)="Y"
- SET DIR("A")=" Confirm? "
- SET DIR("B")="NO"
- +30 SET DIR("A",1)=" When you confirm this REJECT will be marked RESOLVED."
- +31 SET DIR("A",2)=" "
- +32 DO ^DIR
- IF $GET(Y)=0!$DATA(DIRUT)
- SET VALMBCK="R"
- QUIT
- +33 WRITE ?40,"[Closing..."
- DO CLOSE^PSOREJUT(RX,FILL,REJ,DUZ,6,COM,"","","","","",1)
- WRITE "OK]",!,$CHAR(7)
- HANG 1
- +34 IF $DATA(PSOSTFLT)
- IF PSOSTFLT'="B"
- SET CHANGE=1
- +35 ;
- +36 IF $$PTLBL(RX,FILL)
- DO PRINT^PSOREJP3(RX,FILL)
- +37 IF PSOTRIC
- Begin DoDot:1
- +38 SET PSOETEC=$$PSOETEC^PSOREJP5(RX,FILL)
- +39 DO AUDIT^PSOTRI(RX,FILL,,COM,$SELECT(PSOETEC:"N",1:"R"),$SELECT(PSOTRIC=1:"T",PSOTRIC=2:"C",1:""))
- End DoDot:1
- +40 ;
- +41 QUIT
- +42 ;
- OPN ; - Re-open a Closed/Resolved Reject
- +1 IF '$$CLOSED^PSOREJP1(RX,REJ)
- Begin DoDot:1
- +2 SET VALMSG="This Reject is NOT marked resolved!"
- SET VALMBCK="R"
- End DoDot:1
- QUIT
- +3 ;cnf, PSO*7*358, check for discontinued and not released
- +4 ; 12 - DISCONTINUED
- +5 ; 14 - DISCONTINUED BY PROVIDER
- +6 ; 15 - DISCONTINUED (EDIT)
- +7 NEW DCSTAT,PSOREL
- +8 SET DCSTAT=$$GET1^DIQ(52,RX,100,"I")
- +9 SET PSOREL=0
- Begin DoDot:1
- +10 IF 'FILL
- SET PSOREL=+$$GET1^DIQ(52,RX,31,"I")
- +11 IF FILL
- SET PSOREL=+$$GET1^DIQ(52.1,FILL_","_RX,17,"I")
- End DoDot:1
- +12 IF 'PSOREL
- IF "/12/14/15/"[("/"_DCSTAT_"/")
- SET VALMSG="Discontinued Rx has not been released."
- SET VALMBCK="R"
- QUIT
- +13 NEW DIR,COM,REJDATA,NEWDATA,X,REOPEN
- +14 DO FULL^VALM1
- +15 IF '$$SIG^PSOREJU1()
- SET VALMBCK="R"
- QUIT
- +16 WRITE !
- +17 SET DIR(0)="Y"
- SET DIR("A")=" Confirm"
- SET DIR("B")="NO"
- +18 SET DIR("A",1)=" When you confirm this REJECT will be marked UNRESOLVED."
- +19 SET DIR("A",2)=" "
- +20 DO ^DIR
- IF $GET(Y)=0!$DATA(DIRUT)
- SET VALMBCK="R"
- QUIT
- +21 ;
- +22 WRITE ?40,"[Re-opening..."
- +23 KILL REJDATA
- DO GET^PSOREJU2(RX,FILL,.REJDATA,REJ,1)
- DO SETOPN^PSOREJU2(RX,REJ)
- +24 KILL NEWDATA
- MERGE NEWDATA=REJDATA(REJ)
- SET NEWDATA("PHARMACIST")=DUZ
- +25 SET REOPEN=1
- DO SAVE^PSOREJUT(RX,FILL,.NEWDATA,REOPEN)
- +26 IF $GET(NEWDATA("REJECT IEN"))
- IF $DATA(REJDATA(REJ,"COMMENTS"))
- Begin DoDot:1
- +27 SET COM=0
- FOR
- SET COM=$ORDER(REJDATA(REJ,"COMMENTS",COM))
- if 'COM
- QUIT
- Begin DoDot:2
- +28 SET X(1)=REJDATA(REJ,"COMMENTS",COM,"COMMENTS")
- +29 SET X(2)=REJDATA(REJ,"COMMENTS",COM,"DATE/TIME")
- +30 SET X(3)=REJDATA(REJ,"COMMENTS",COM,"USER")
- +31 DO SAVECOM^PSOREJP3(RX,NEWDATA("REJECT IEN"),X(1),X(2),X(3))
- End DoDot:2
- End DoDot:1
- +32 DO RETRXF^PSOREJU2(RX,FILL,0)
- +33 WRITE "OK]",!,$CHAR(7)
- HANG 1
- +34 SET CHANGE=1
- +35 QUIT
- +36 ;
- SDC ; - Suspense Date Calculation
- +1 DO CHG(1)
- +2 QUIT
- +3 ;
- CSD ;CSD - Change Suspense Date action entry point
- +1 DO CHG(0)
- +2 QUIT
- +3 ;
- CHG(SDC) ; - Change Suspense Date action
- +1 ;Local:
- +2 ; SDC - indicates if the suspense date is being manually changed or calculated.
- +3 ; RX - RX IEN
- +4 ; REJ - Reject indicator
- +5 ;
- +6 IF '$GET(SDC)
- SET SDC=0
- +7 IF $$CLOSED^PSOREJP1(RX,REJ)
- Begin DoDot:1
- +8 SET VALMSG="This Reject is marked resolved!"
- SET VALMBCK="R"
- WRITE $CHAR(7)
- End DoDot:1
- QUIT
- +9 ;
- +10 NEW SUSDT,PSOMSG,Y,SUSRX,%DT,DA,DIE,DR,ISSDT,EXPDT,PSOMSG,CUTDT,FILDT,RFL,COB
- +11 ;
- +12 SET RFL=+$$GET1^DIQ(52.25,REJ_","_RX,5)
- SET SUSDT=$$RXSUDT^PSOBPSUT(RX,RFL)
- +13 IF RFL>0
- SET FILDT=$$GET1^DIQ(52.1,RFL_","_RX,.01,"I")
- +14 IF '$TEST
- SET FILDT=$$GET1^DIQ(52,RX,22,"I")
- +15 IF SUSDT=""
- SET VALMSG="Prescription is not suspended!"
- SET VALMBCK="R"
- WRITE $CHAR(7)
- QUIT
- +16 IF $$RXRLDT^PSOBPSUT(RX,RFL)
- SET VALMSG="Prescription has been released already!"
- SET VALMBCK="R"
- WRITE $CHAR(7)
- QUIT
- +17 ;cnf, PSO*7*358, add PSOET logic for TRICARE/CHAMPVA non-billable
- +18 SET PSOET=$$PSOET^PSOREJP3(RX,RFL)
- +19 IF PSOET
- SET VALMSG=$SELECT(SDC=1:"SDC",1:"CSD")_" not allowed for "_$$ELIGDISP^PSOREJP1(RX,RFL)_" Non-Billable claim."
- SET VALMBCK="R"
- QUIT
- +20 ;
- +21 DO PSOL^PSSLOCK(RX)
- IF '$GET(PSOMSG)
- SET VALMSG=$PIECE(PSOMSG,"^",2)
- SET VALMBCK="R"
- WRITE $CHAR(7)
- QUIT
- +22 ;
- +23 SET ISSDT=$$GET1^DIQ(52,RX,1,"I")
- SET EXPDT=$$GET1^DIQ(52,RX,26,"I")
- +24 SET SUSRX=$ORDER(^PS(52.5,"B",RX,0))
- +25 ;
- +26 DO FULL^VALM1
- +27 IF SDC
- Begin DoDot:1
- +28 SET COB=$$GET1^DIQ(52.25,REJ_","_RX,27,"I")
- +29 IF 'COB
- SET COB=1
- +30 SET SUSDT=$$CALCSD(RX,RFL,COB)
- End DoDot:1
- IF SUSDT=0
- DO PSOUL^PSSLOCK(RX)
- SET VALMBCK="R"
- QUIT
- +31 ;
- +32 ; Display a message to the user if the Bypass 3/4 Day Supply flag is set.
- +33 ;
- +34 IF $$FLAG^PSOBPSU4(RX,RFL)="YES"
- Begin DoDot:1
- +35 WRITE !!,"Currently, Bypass 3/4 Day Supply is set to YES. If you continue, the"
- +36 WRITE !,"prescription fill will transmit to CMOP on the new Suspense Date entered.",!
- +37 QUIT
- End DoDot:1
- +38 ;
- SUDT ; Asks for the new Suspense Date
- +1 NEW X1,X2
- +2 SET X1=FILDT
- SET X2=89
- DO C^%DTC
- SET CUTDT=X
- +3 IF SDC
- IF SUSDT
- IF SUSDT<DT
- WRITE !,*7," **CALCULATED SUSPENSE DATE IS IN THE PAST: ",$$FMTE^XLFDT(SUSDT),"**"
- SET SUSDT=""
- +4 IF '$TEST
- SET %DT("B")=$$FMTE^XLFDT(SUSDT)
- +5 SET %DT="EA"
- SET %DT("A")=$SELECT(SDC:"NEW ",1:"")_"SUSPENSE DATE: "
- +6 WRITE !
- DO ^%DT
- IF Y<0!($DATA(DTOUT))
- DO PSOUL^PSSLOCK(RX)
- SET VALMBCK="R"
- IF (SDC)
- WRITE !,"ACTION NOT TAKEN!"
- QUIT
- +7 IF Y<ISSDT
- Begin DoDot:1
- +8 WRITE !!?5,"Suspense Date cannot be before Issue Date: ",$$FMTE^XLFDT(ISSDT),".",$CHAR(7)
- End DoDot:1
- GOTO SUDT
- +9 IF Y>EXPDT
- Begin DoDot:1
- +10 WRITE !!?5,"Suspense Date cannot be after Expiration Date: ",$$FMTE^XLFDT(EXPDT),".",$CHAR(7)
- End DoDot:1
- GOTO SUDT
- +11 IF Y>CUTDT
- Begin DoDot:1
- +12 WRITE !!?5,"Suspense Date cannot be after fill date plus 90 days: "_$$FMTE^XLFDT(CUTDT),".",$CHAR(7)
- End DoDot:1
- GOTO SUDT
- +13 SET SUSDT=Y
- +14 ;
- +15 NEW DIR,DIRUT
- WRITE !
- +16 SET DIR("A",1)=" When you confirm, this REJECT will be marked resolved. A"
- +17 SET DIR("A",2)=" new claim will be re-submitted to the 3rd party payer"
- +18 IF $$GET1^DIQ(52.5,SUSRX,3)=""
- Begin DoDot:1
- +19 IF SUSDT>DT
- Begin DoDot:2
- +20 SET DIR("A",3)=" when the prescription label for this fill is printed"
- +21 SET DIR("A",4)=" from suspense on "_$$FMTE^XLFDT(SUSDT)_"."
- +22 SET DIR("A",5)=" "
- +23 SET DIR("A",6)=" Note: THE LABEL FOR THIS PRESCRIPTION FILL WILL NOT BE"
- +24 SET DIR("A",7)=" PRINTED LOCAL FROM SUSPENSE BEFORE "_$$FMTE^XLFDT(SUSDT)_"."
- End DoDot:2
- +25 IF '$TEST
- Begin DoDot:2
- +26 SET DIR("A",3)=" the next time local labels are printed from suspense."
- End DoDot:2
- End DoDot:1
- +27 IF '$TEST
- Begin DoDot:1
- +28 IF SUSDT>DT
- Begin DoDot:2
- +29 SET DIR("A",3)=" when the prescription is transmitted to CMOP on "
- +30 SET DIR("A",4)=" "_$$FMTE^XLFDT(SUSDT)_"."
- +31 SET DIR("A",5)=" "
- +32 SET DIR("A",6)=" Note: THIS PRESCRIPTION FILL WILL NOT BE TRANSMITTED TO"
- +33 SET DIR("A",7)=" CMOP BEFORE "_$$FMTE^XLFDT(SUSDT)_"."
- End DoDot:2
- +34 IF '$TEST
- Begin DoDot:2
- +35 SET DIR("A",3)=" when this prescription fill is transmitted to CMOP on"
- +36 SET DIR("A",4)=" the next CMOP transmission."
- End DoDot:2
- End DoDot:1
- +37 ;
- +38 SET DIR("A",$ORDER(DIR("A",""),-1)+1)=" "
- +39 SET DIR(0)="Y"
- SET DIR("A")=" Confirm? "
- SET DIR("B")="YES"
- +40 DO ^DIR
- IF $GET(Y)=0!$DATA(DIRUT)
- SET VALMBCK="R"
- DO PSOUL^PSSLOCK(RX)
- QUIT
- +41 ;
- +42 ; - Suspense/Fill Date updates
- +43 IF SUSDT'=$$RXSUDT^PSOBPSUT(RX,RFL)
- Begin DoDot:1
- +44 NEW DA,DIE,DR,PSOX,SFN,INDT,DEAD
- +45 SET DA=SUSRX
- SET DIE="^PS(52.5,"
- SET DR=".02///"_SUSDT
- DO ^DIE
- +46 SET SFN=SUSRX
- SET DEAD=0
- SET INDT=SUSDT
- DO CHANGE^PSOSUCH1(RX,RFL)
- End DoDot:1
- +47 ;
- +48 ; - Flagging the prescription to be re-submitted to ECME on the next CMOP/Print from Suspense
- +49 DO RETRXF^PSOREJU2(RX,RFL,1)
- +50 WRITE ?40,"[Closing..."
- +51 DO CLOSE^PSOREJUT(RX,RFL,REJ,DUZ,8,"Fill Date changed to "_$$FMTE^XLFDT(SUSDT)_". A new claim will be re-submitted on this date.")
- +52 WRITE "OK]",!,$CHAR(7)
- HANG 1
- IF $DATA(PSOSTFLT)
- IF PSOSTFLT'="B"
- SET CHANGE=1
- +53 DO PSOUL^PSSLOCK(RX)
- +54 QUIT
- +55 ;
- PTLBL(RX,RFL) ; Conditionally prompts user with 'Print Label?' prompt.
- +1 ; If User responds YES to 'Print Label' value of 1 is returned.
- +2 ; If User responds NO to 'Print Label' value of 0 is returned.
- +3 NEW CMP,LBL,PSOACT,PSOBPS,PSOTRIC,PTLBL,REPRINT
- +4 ;
- +5 IF $GET(RFL)=""
- SET RFL=$$LSTRFL^PSOBPSU1(RX)
- +6 ;
- +7 ; PSOBPS and PSOTRIC are used to check eligibility. Eligibility checking
- +8 ; is only needed for non-billable Rxs (ie PSOBPS'="e")
- +9 SET PSOBPS=$$ECME^PSOBPSUT(RX)
- +10 SET PSOTRIC=$$TRIC^PSOREJP1(RX,RFL,.PSOTRIC)
- +11 ;
- +12 ; Has OPEN/UNRESOLVED 3rd pary payer reject
- IF $$FIND^PSOREJUT(RX,RFL)
- QUIT 0
- +13 ; Rx status not ACTIVE
- IF $$GET1^DIQ(52,RX,100,"I")
- QUIT 0
- +14 ; Rx Released - billable
- IF $$RXRLDT^PSOBPSUT(RX,RFL)
- IF PSOBPS="e"
- QUIT 0
- +15 ; Rx Released - non-billable
- IF $$RXRLDT^PSOBPSUT(RX,RFL)
- IF PSOBPS'="e"
- IF 'PSOTRIC
- QUIT 0
- +16 ;
- +17 ; If CMOP Suspense Label printed for this Fill, don't allow reprint here
- +18 SET PTLBL=1
- +19 SET PSOACT=0
- +20 FOR
- SET PSOACT=$ORDER(^PSRX(RX,"A",PSOACT))
- if 'PSOACT
- QUIT
- Begin DoDot:1
- +21 IF +$$GET1^DIQ(52.3,PSOACT_","_RX,.04,"I")'=RFL
- QUIT
- +22 IF $$GET1^DIQ(52.3,PSOACT_","_RX,.05,"E")["CMOP Suspense Label Printed"
- SET PTLBL=0
- End DoDot:1
- if 'PTLBL
- QUIT
- +23 IF 'PTLBL
- QUIT 0
- +24 ;
- +25 ; If there is an entry in the CMOP Event multiple, and it is for the
- +26 ; current Fill, check the status. If 0/Transmitted, 1/Dispensed, or
- +27 ; 2/Retransmitted, then do not allow the label to be printed.
- +28 ;
- +29 SET CMP=0
- +30 FOR
- SET CMP=$ORDER(^PSRX(RX,4,CMP))
- if 'CMP
- QUIT
- Begin DoDot:1
- +31 IF +$$GET1^DIQ(52.01,CMP_","_RX,2,"I")'=RFL
- QUIT
- +32 IF "0,1,2"[$$GET1^DIQ(52.01,CMP_","_RX,3,"I")
- SET PTLBL=0
- End DoDot:1
- if 'PTLBL
- QUIT
- +33 IF 'PTLBL
- QUIT 0
- +34 ;
- +35 ; - Label already printed for Rx fill?
- +36 SET LBL=0
- +37 FOR
- SET LBL=$ORDER(^PSRX(RX,"L",LBL))
- if 'LBL
- QUIT
- Begin DoDot:1
- +38 IF +$$GET1^DIQ(52.032,LBL_","_RX,1,"I")'=RFL
- QUIT
- +39 IF '$$RXRLDT^PSOBPSUT(RX,RFL)
- IF +$$GET1^DIQ(52.032,LBL_","_RX,1,"I")=RFL
- IF PSOBPS="e"
- SET REPRINT=1
- QUIT
- +40 IF $GET(PSOTRIC)&($$RXRLDT^PSOBPSUT(RX,RFL))
- IF PSOBPS'="e"
- SET REPRINT=1
- QUIT
- +41 IF $$GET1^DIQ(52.032,LBL_","_RX,4,"I")
- QUIT
- +42 IF $$GET1^DIQ(52.032,LBL_","_RX,2)["INTERACTION"
- QUIT
- +43 SET PTLBL=0
- End DoDot:1
- if 'PTLBL
- QUIT
- +44 ;
- +45 IF 'PTLBL
- QUIT 0
- +46 ;
- +47 NEW DIR,DIRUT,Y
- +48 WRITE !
- +49 SET DIR(0)="Y"
- +50 SET DIR("A")=$SELECT('$GET(REPRINT):"Print Label",1:"Reprint Label")
- +51 SET DIR("B")="YES"
- +52 IF PSOBPS="e"
- KILL DIR("B")
- +53 DO ^DIR
- +54 IF $GET(Y)=0!$DATA(DIRUT)
- SET PTLBL=0
- +55 ;
- +56 QUIT PTLBL
- +57 ;
- DTRNG(BGN,END) ; Date Range Selection
- +1 ;Input: (o) BGN - Default Begin Date
- +2 ; (o) END - Default End Date
- +3 ;
- +4 NEW %DT,DTOUT,DUOUT,DTRNG,X,Y
- +5 SET DTRNG=""
- +6 SET %DT="AEST"
- SET %DT("A")="BEGIN REJECT DATE: "
- SET %DT("B")=$GET(BGN)
- if $GET(BGN)=""
- KILL %DT("B")
- DO ^%DT
- +7 IF $GET(DUOUT)!$GET(DTOUT)!($GET(Y)=-1)
- QUIT "^"
- +8 SET $PIECE(DTRNG,U)=Y
- +9 ;
- +10 WRITE !
- KILL %DT
- +11 SET %DT="AEST"
- SET %DT("A")="END REJECT DATE: "
- SET %DT("B")=$GET(END)
- SET %DT(0)=Y
- if $GET(END)=""
- KILL %DT("B")
- DO ^%DT
- +12 IF $GET(DUOUT)!$GET(DTOUT)!($GET(Y)=-1)
- QUIT "^"
- +13 ;
- +14 ;Define Entry
- +15 SET $PIECE(DTRNG,U,2)=Y
- +16 ;
- +17 QUIT DTRNG
- +18 ;
- CALCSD(RX,FIL,COB) ;
- +1 ; CALCSD - Prompt the user for Last Date of Service, Last Days Supply and
- +2 ; then calculate the suspense date based on these input.
- +3 ; Input
- +4 ; RX - Prescription IEN
- +5 ; FIL - Fill Number
- +6 ; COB - Coordination of Benefits
- +7 ; Return
- +8 ; The calculated suspense date
- +9 ;
- +10 NEW DIR,X,Y,DUOUT,DTOUT,DIRUT,DIROUT,LDOS,LDSUP,LDS
- +11 IF '$GET(RX)
- QUIT 0
- +12 IF $GET(FIL)=""
- QUIT 0
- +13 IF '$GET(COB)
- SET COB=1
- +14 ;
- +15 ; get the previous Rx last date of service and last days supply
- DO PREVRX(RX,FIL,COB,.LDOS,.LDS)
- +16 ; Prompt for Last DOS
- +17 SET DIR(0)="D"
- SET DIR("A")="LAST DATE OF SERVICE"
- +18 IF LDOS
- SET DIR("B")=$$FMTE^XLFDT($GET(LDOS))
- +19 DO ^DIR
- +20 IF $DATA(DIRUT)
- WRITE !,"ACTION NOT TAKEN!"
- QUIT 0
- +21 SET LDOS=Y
- WRITE " ("_$$FMTE^XLFDT($GET(LDOS))_")"
- +22 ;
- +23 ; Prompt for Last Days Supply
- +24 SET LDSUP=LDS
- +25 KILL DIR
- +26 SET DIR(0)="N"
- SET DIR("A")="LAST DAYS SUPPLY"
- +27 IF LDSUP]""
- SET DIR("B")=+LDSUP
- +28 DO ^DIR
- +29 IF $DATA(DIRUT)
- WRITE !,"ACTION NOT TAKEN!"
- QUIT 0
- +30 ;
- +31 ; Calculate the suspense date to be Last DOS plus 3/4 of the Last Days Supply
- +32 ; Fractions are rounded up
- +33 SET LDSUP=Y*.75
- +34 if LDSUP["."
- SET LDSUP=(LDSUP+1)\1
- +35 QUIT $$FMADD^XLFDT(LDOS,LDSUP)
- +36 ;
- PREVRX(RX,RFL,COB,LDOS,LDAYS,PREVRX) ; Gather last date of service and last days supply from previous rx
- +1 ; input: RX - Current RX
- +2 ; RFL - Refill
- +3 ; COB - Coordination of benefits
- +4 ; output: LDOS - (pass by reference) Last date of service in fileman format, or ""
- +5 ; LDAYS - (pass by reference) Last days supply in numeric format, or ""
- +6 ; PREVRX - (pass by reference) Previous Rx for same drug, if any
- +7 ;
- +8 SET (LDOS,LDAYS,PREVRX)=""
- +9 IF '$GET(RX)
- GOTO PREVRXQ
- +10 IF $GET(RFL)=""
- GOTO PREVRXQ
- +11 IF '$GET(COB)
- SET COB=1
- +12 ;
- +13 ; Original fill. Check previous Rx's.
- +14 ;
- +15 IF RFL=0
- Begin DoDot:1
- +16 NEW X
- +17 ; other Rx 120 day time window
- SET X=$$LAST120(RX,COB)
- +18 ; last date of service (older rx)
- SET LDOS=$PIECE(X,U,1)
- +19 ; last days supply (older rx)
- SET LDAYS=$PIECE(X,U,2)
- +20 ; Previous Rx, if any
- SET PREVRX=$PIECE(X,U,3)
- +21 QUIT
- End DoDot:1
- +22 ;
- +23 ; refill - same RX. Get previus fill information
- +24 ;
- +25 IF RFL>0
- Begin DoDot:1
- +26 NEW FL
- +27 ; start with the previous fill (RFL-1)
- FOR FL=(RFL-1):-1:0
- Begin DoDot:2
- +28 ; no ECME activity - skip
- IF $$STATUS^PSOBPSUT(RX,FL)=""
- QUIT
- +29 ; unresolved reject on worklist - skip
- IF $$FIND^PSOREJUT(RX,FL,,,1)
- QUIT
- +30 ; DBIA 4719
- DO GETDAT^BPSBUTL(RX,FL,COB,.LDOS,.LDAYS)
- +31 QUIT
- End DoDot:2
- if LDOS
- QUIT
- +32 QUIT
- End DoDot:1
- +33 ;
- PREVRXQ ;
- +1 QUIT
- +2 ;
- LAST120(RX,COB) ;
- +1 ; For the original fill, get the default DOS/Days Supply by getting
- +2 ; most recent DOS from the other RXs within a time window for the same
- +3 ; patient and drug and dosage Time window - Prescription has an
- +4 ; expiration date that is in the future or within the last 120 days
- +5 ; Input
- +6 ; RX - Prescription IEN
- +7 ; COB - coordination of benefits indicator (defaults to 1 if not passed)
- +8 ; Output
- +9 ; Last Date of Service ^ Last Days Supply ^ Previous Rx
- +10 ;
- +11 NEW DOSAGE,DOSAGE1,DRUG,DRUG1,DSUP,DSUP1,EXPDT,FL
- +12 NEW LDOS,LDS,LSTFIL,PAT,PREVFL,PREVRX,QTY,QTY1,RX0,RX1,X1,X2
- +13 ;
- +14 IF '$GET(COB)
- SET COB=1
- +15 SET LDOS=""
- SET LDS=""
- SET PREVRX=""
- +16 ; Main 0 node.
- SET RX0=$GET(^PSRX(RX,0))
- +17 SET PAT=$PIECE(RX0,U,2)
- SET DRUG=$PIECE(RX0,U,6)
- +18 IF 'PAT!'DRUG
- QUIT "^^"
- +19 SET QTY=+$PIECE(RX0,U,7)
- SET DSUP=+$PIECE(RX0,U,8)
- SET DOSAGE=""
- +20 ; Dosage is ratio of Qty to Days Supply.
- IF QTY
- IF DSUP
- SET DOSAGE=QTY/DSUP
- +21 SET EXPDT=$$FMADD^XLFDT(DT,-121)
- +22 ; IA 2228.
- FOR
- SET EXPDT=$ORDER(^PS(55,PAT,"P","A",EXPDT))
- if 'EXPDT
- QUIT
- Begin DoDot:1
- +23 SET RX1=""
- +24 FOR
- SET RX1=$ORDER(^PS(55,PAT,"P","A",EXPDT,RX1))
- if 'RX1
- QUIT
- IF RX'=RX1
- Begin DoDot:2
- +25 SET DRUG1=$PIECE($GET(^PSRX(+RX1,0)),U,6)
- +26 ; If not the same drug, skip this other Rx.
- IF DRUG'=DRUG1
- QUIT
- +27 ;
- +28 ; Start with last fill# of this other Rx.
- SET LSTFIL=$$LSTRFL^PSOBPSU1(RX1)
- +29 ; For this other Rx, initialize the temp variables for last DOS and last days supply.
- SET X1=""
- SET X2=""
- +30 ; Loop backwards until we find the latest valid DOS.
- FOR FL=LSTFIL:-1:0
- Begin DoDot:3
- +31 DO CHECKIT(RX1,FL,COB,.X1,.X2)
- +32 QUIT
- End DoDot:3
- if X1
- QUIT
- +33 ;
- +34 IF X1>LDOS
- SET LDOS=X1
- SET LDS=X2
- SET PREVRX=RX1
- SET PREVFL=FL
- +35 QUIT
- End DoDot:2
- +36 QUIT
- End DoDot:1
- +37 ;
- +38 ; If a previous Rx passed all other checks, then check the dosage. If
- +39 ; the dosage is not the same, then clear out the variables and treat as
- +40 ; if no previous Rx was found.
- +41 ;
- +42 IF PREVRX'=""
- Begin DoDot:1
- +43 SET QTY1=$SELECT(PREVFL=0:+$PIECE($GET(^PSRX(PREVRX,0)),U,7),1:+$PIECE($GET(^PSRX(PREVRX,1,PREVFL,0)),U,4))
- +44 SET DSUP1=$SELECT(PREVFL=0:+$PIECE($GET(^PSRX(PREVRX,0)),U,8),1:+$PIECE($GET(^PSRX(PREVRX,1,PREVFL,0)),U,10))
- +45 SET DOSAGE1=""
- +46 IF QTY1
- IF DSUP1
- SET DOSAGE1=QTY1/DSUP1
- +47 IF DOSAGE'=DOSAGE1
- SET (LDOS,LDS,PREVRX)=""
- +48 QUIT
- End DoDot:1
- +49 ;
- +50 ; Pull external Rx#.
- IF PREVRX'=""
- SET PREVRX=$$GET1^DIQ(52,PREVRX_",",.01)
- +51 QUIT LDOS_U_LDS_U_PREVRX
- +52 ;
- +53 ; CHECKIT was added to consolidate checks that were previously being
- +54 ; performed in two different procedures (PREVRX, LAST120).
- +55 ;
- CHECKIT(RX,FL,COB,LDOS,LDAYS) ; Check 1 Rx/Fill for days' supply calc.
- +1 ;
- +2 ; Input: (r) RX - Rx IEN (#52)
- +3 ; (o) FL - Refill#
- +4 ; (o) COB - Payer sequence
- +5 ; Output: LDOS - Date of service for this Rx/Fill
- +6 ; LDAYS - Days' supply for this Rx/Fill
- +7 ; The CHECKIT procedure determines whether a given Rx and Fill can be
- +8 ; used in determining whether the 3/4 days' supply requirement has
- +9 ; been met for another Rx/Fill. The Rx/Fill being checked here must
- +10 ; meet several criteria, including the following checked by this
- +11 ; procedure:
- +12 ; - The Rx/Fill must be released.
- +13 ; - The Rx status must not be Non-Verified.
- +14 ; - The RX must not have an Expiration Date earlier than 120 days
- +15 ; before today.
- +16 ; - The Rx/Fill must have ECME activity.
- +17 ; - The Rx/Fill must not have any unresolved rejects.
- +18 ;
- +19 NEW EXPDT
- +20 ; If not released, Quit.
- IF '$$RXRLDT^PSOBPSUT(RX,FL)
- QUIT
- +21 ; If Status is NON-VERIFIED, Quit.
- IF $$GET1^DIQ(52,RX,100,"I")=1
- QUIT
- +22 ; If Expiration Date of Rx is more
- SET EXPDT=$$GET1^DIQ(52,RX,26,"I")
- +23 ; than 120 days ago, Quit.
- IF EXPDT
- IF $$FMDIFF^XLFDT(DT,EXPDT)>120
- QUIT
- +24 ; If no ECME activity, Quit.
- IF $$STATUS^PSOBPSUT(RX,FL)=""
- QUIT
- +25 ; If any unresolved rejects, Quit.
- IF $$FIND^PSOREJUT(RX,FL,,,1)
- QUIT
- +26 ;
- +27 ; Pull the Date of Service and Days' Supply for this Rx/Fill.
- +28 ;
- +29 ; IA 4719.
- DO GETDAT^BPSBUTL(RX,FL,COB,.LDOS,.LDAYS)
- +30 QUIT
- +31 ;