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

PSOREJP2.m

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