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

BPSRPT9A.m

Go to the documentation of this file. 
  1. BPSRPT9A ;BHAM ISC/BNT - ECME REPORTS UTILITIES ;19-SEPT-08
  1.  ;;1.0;E CLAIMS MGMT ENGINE;**8,9,18,20,27**;JUN 2004;Build 15
  1.  ;;Per VA Directive 6402, this routine should not be modified.
  1.  ;
  1.  ; Use of COLLECT^IBOSRX supported by IA 5361
  1.  ; Use of $$INSUR^IBBAPI supported by IA 4419
  1.  ; Use of $$RNB^IBNCPDPI supported by IA 4729
  1.  ; Use of $$BILINF^IBNCPUT3 supported by IA 5355
  1.  ; Use of  $$HPD^IBCNHUT1 supported by IA #6061
  1.  ; Use of $$BILLABLE^IBNCPDP supported by IA #6243
  1.  Q
  1.  ;
  1.  ; Collect the Potential Secondary Rx Claims Report data
  1. GETSEC(BPDT,BPARR,BPSEXCEL) ;
  1.  N CNT,IBARR S CNT=0
  1.  N BPSX,BPSY
  1.  N BPS56 S BPS56=0
  1.  I '$D(ZTQUEUED),$E(IOST,1,2)="C-" W !!,"Collecting Potential Secondary data ..."
  1.  K ^TMP("BPSRPT9A",$J)
  1.  D COLLECT^IBOSRX($P(BPDT,U),$P(BPDT,U,2))   ; get IB claim data (DBIA 5361)
  1.  D GATHER($P(BPDT,U,1),$P(BPDT,U,2))         ; get ECME claim data - esg 7/6/10
  1.  I '$D(^TMP("BPSRPT9A",$J)) Q
  1.  F  S CNT=$O(^TMP("BPSRPT9A",$J,CNT)) Q:CNT=""  D
  1.  . N DATA,RXI,RXN,RXF,DOS,BILL,DFN,PATNAME,BPDIV,INSC,X,COB,PINS,BP59S,BP59P,IBIFN,TOTCHG,BAL,BPSRESP,BPSPAID,BPSINFO,BPSRET
  1.  . S DATA=$G(^TMP("BPSRPT9A",$J,CNT))
  1.  . S RXI=$P(DATA,U,1),RXN=$P(DATA,U,2),RXF=$P(DATA,U,3),BILL=$P(DATA,U,4),DFN=$P(DATA,U,5),DOS=$P(DATA,U,6),PINS=$P(DATA,U,7)
  1.  . S IBIFN=$P(DATA,U,8),TOTCHG=$P(DATA,U,9)
  1.  . Q:(RXI="")!(RXN="")!(RXF="")!(BILL="")!(DFN="")!(DOS="")!(PINS="")
  1.  . S PATNAME=$$GET1^DIQ(2,DFN,.01)
  1.  . ;
  1.  . ; Drop the claim off this report if the Secondary claim is closed in ECME
  1.  . ; esg - 7/6/10
  1.  . S BP59S=+$$IEN59^BPSOSRX(RXI,RXF,2)  ; possible ien to file 9002313.59 for the secondary claim
  1.  . I $$CLOSED02^BPSSCR03(+$P($G(^BPST(BP59S,0)),U,4)) Q
  1.  . ;
  1.  . ; Drop the claim off this report if the Secondary claim is Payable
  1.  . ; bnt - 7/14/10
  1.  . S BP59P=+$$IEN59^BPSOSRX(RXI,RXF,1)  ; possible ien to file 9002313.59 for the primary claim
  1.  . I $$PAYBLSEC^BPSUTIL2(BP59P) Q
  1.  . ;
  1.  . ; Drop the claim off this report if the primary payer paid the full amount
  1.  . ; esg - 8/3/10
  1.  . I IBIFN,TOTCHG D  I BAL'>0 Q    ; check balance due on entries with payable primary claims
  1.  .. S BPSRESP=+$P($G(^BPST(BP59P,0)),U,5)  ; response file ien
  1.  .. S BPSPAID=0
  1.  .. I BPSRESP S BPSPAID=$$DFF2EXT^BPSECFM($P($G(^BPSR(BPSRESP,1000,1,500)),U,9))   ; paid amt
  1.  .. S BAL=TOTCHG-BPSPAID    ; balance due:  total charges - primary payer paid amt
  1.  .. Q
  1.  . ;
  1.  . S BPDIV=$$GETDIV^BPSOSQC(RXI,RXF) Q:'BPDIV  ;Outpatient Site #59 ien
  1.  . S BPS56=+$O(^BPS(9002313.56,"C",BPDIV,0)) Q:'BPS56  ;BPS PHARMACIES #9002313.56 ien
  1.  . ;filter divisions
  1.  . I BPPHARM=1,'$D(BPPHARM(BPS56)) Q
  1.  . S BPDIV(BPDIV)=$$DIVNAME^BPSSCRDS(BPS56)
  1.  . ;
  1.  . S PSRT=$S($P($P(BPSORT,U,1),":")="N":PATNAME,$P($P(BPSORT,U,1),":")="P":PINS,$P($P(BPSORT,U,1),":")="S":$S('BPCRON:-DOS,1:DOS),1:BPDIV(BPDIV))
  1.  . S SSRT=$S($P($P(BPSORT,U,2),":")="N":PATNAME,$P($P(BPSORT,U,2),":")="P":PINS,$P($P(BPSORT,U,2),":")="S":$S('BPCRON:-DOS,1:DOS),$P($P(BPSORT,U,2),":")="D":BPDIV(BPDIV),1:0)
  1.  . S TSRT=$S($P($P(BPSORT,U,3),":")="N":PATNAME,$P($P(BPSORT,U,3),":")="P":PINS,$P($P(BPSORT,U,3),":")="S":$S('BPCRON:-DOS,1:DOS),$P($P(BPSORT,U,3),":")="D":BPDIV(BPDIV),1:0)
  1.  . Q:((SSRT="")!(PSRT="")!(TSRT=""))
  1.  . ; BPS*1*18:  Modify ePharmacy Screens/Reports to Include the Validated HPID/OEID - IB ICR #6061 (get ins ien using IB ICR#5355)
  1.  . S BPSRET=$$BILINF^IBNCPUT3(IBIFN,.BPSINFO)
  1.  . I 'BPSEXCEL S BPARR(PSRT,SSRT,TSRT,CNT)=BPDIV(BPDIV)_U_BILL_U_RXN_U_RXF_U_$$FMTE^XLFDT(DOS,"2D")_U_PATNAME_U_"p"_U_PINS_U_$$SSN4^BPSRPT6(DFN)_U_$$HPD^IBCNHUT1($G(BPSINFO("INS IEN")),1)
  1.  . E  S BPARR(PSRT,SSRT,TSRT,CNT)=BPDIV(BPDIV)_U_BILL_U_RXN_U_RXF_U_PATNAME_U_$$SSN4^BPSRPT6(DFN)_U_"p"_U_$$FMTE^XLFDT(DOS,"2D")_U_PINS_U_$$HPD^IBCNHUT1($G(BPSINFO("INS IEN")),1)
  1.  . S (X,INSC)=0
  1.  . F  S X=$O(^TMP("BPSRPT9A",$J,CNT,X)) Q:X=""  D
  1.  . . S BPSX=$G(^TMP("BPSRPT9A",$J,CNT,X,7))
  1.  . . S COB=$S($P(BPSX,U)=1:"p",$P(BPSX,U)=2:"s",$P(BPSX,U)=3:"t",1:"-")
  1.  . . S BPSY=$P($G(^TMP("BPSRPT9A",$J,CNT,X,1)),U,2)
  1.  . . Q:BPSY[PINS
  1.  . . ; BPS*1*18:  Modify ePharmacy Screens/Reports to Include the Validated HPID/OEID - IB ICR #6061
  1.  . . I 'BPSEXCEL S BPARR(PSRT,SSRT,TSRT,CNT,X)=COB_U_BPSY_U_$$HPD^IBCNHUT1($P($G(^TMP("BPSRPT9A",$J,CNT,X,1)),U),1)
  1.  . . E  S BPARR(PSRT,SSRT,TSRT,CNT,X)=BPDIV(BPDIV)_U_""_U_RXN_U_RXF_U_PATNAME_U_$$SSN4^BPSRPT6(DFN)_U_COB_U_$$FMTE^XLFDT(DOS,"2D")_U_BPSY_U_$$HPD^IBCNHUT1($G(BPSINFO("INS IEN")),1)
  1.  K ^TMP("BPSRPT9A",$J)
  1.  Q
  1.  ;
  1.  ; Collect the Potential Claims Report for Dual Eligible
  1.  ; Build array with report data
  1.  ; BPARR(n)=DIVISION NAME^RX#^FILL^FILL DATE^PATIENT NAME
  1.  ; BPARR(n,"INS",1)=PRIMARY INS NAME^PRIMARY INS ADDRESS
  1.  ; BPARR(n,"INS",2)=SECONDARY INS NAME^SECONDARY INS ADDRESS
  1.  ; BPARR(n,"ELIG")=ELIG 1^ELIG 2^...
  1. GETTRI(BPDT,BPARR) ;
  1.  N RXI,RXN,RXF,RXFDT,LIST,RXLIST,BPQUIT,CNT,BPSFLDN,BPHPD,RXELIG
  1.  S REF=$NA(^TMP($J,"BPSRPT9","AD"))
  1.  S BPSFLDN=".01;2;6"
  1.  K @REF
  1.  S (RXFDT,BPDRUG,CNT)=0,LIST="BPSRPT9"
  1.  I '$D(ZTQUEUED),$E(IOST,1,2)="C-" W !!,"Collecting Dual Eligible data ..."
  1.  D REF^PSO52EX($P(BPDT,U),$P(BPDT,U,2),LIST)
  1.  I '$D(@REF) Q
  1.  F  S RXFDT=$O(@REF@(RXFDT)) Q:RXFDT=""  D
  1.  . S RXI=0 F  S RXI=$O(@REF@(RXFDT,RXI)) Q:RXI=""  D
  1.  . . S RXF=-1 F  S RXF=$O(@REF@(RXFDT,RXI,RXF)) Q:RXF=""  D
  1.  . . . N BPELIG,VAEL,BPDRUG,BPIE,DFN,ARR,BPDIV,PSRT,SSRT,TSRT,BPS56,PSC,SSC,TSC
  1.  . . . S (BPQUIT,BPDIV,BPS56)=0
  1.  . . . ; Check Pharmacy Division against selected Divisions
  1.  . . . S BPDIV=$$GETDIV^BPSOSQC(RXI,RXF) Q:'BPDIV  ;Outpatient Site #59 ien
  1.  . . . S BPS56=+$O(^BPS(9002313.56,"C",BPDIV,0)) Q:'BPS56  ;BPS PHARMACIES #9002313.56 ien
  1.  . . . ;filter divisions
  1.  . . . I BPPHARM=1,'$D(BPPHARM(BPS56)) Q
  1.  . . . D RXAPI^BPSUTIL1(RXI,BPSFLDN,"ARR","IE")
  1.  . . . S DFN=ARR(52,RXI,2,"I") Q:'DFN
  1.  . . . D ELIG^VADPT
  1.  . . . ; Check for TRICARE, SHARING AGREEMENT, or CHAMPVA
  1.  . . . S BPELIG=$P(VAEL(1),U,2)
  1.  . . . S BPQUIT=$S(BPELIG="TRICARE":0,BPELIG="SHARING AGREEMENT":0,BPELIG="CHAMPVA":0,1:1)
  1.  . . . S BPELIG(1)=$E(BPELIG,1,4)
  1.  . . . S X=-1 F  S X=$O(VAEL(1,X)) Q:X=""  D
  1.  . . . . S BPELIG=$P(VAEL(1,X),U,2)
  1.  . . . . S BPQUIT=$S(BPELIG="TRICARE":0,BPELIG="SHARING AGREEMENT":0,BPELIG="CHAMPVA":0,1:1)
  1.  . . . . S BPELIG(1)=BPELIG(1)_U_$E(BPELIG,1,4)
  1.  . . . Q:$S(BPELIG(1)["TRIC":0,BPELIG(1)["SHAR":0,BPELIG(1)["CHAM":0,1:1)
  1.  . . . S BPDRUG=ARR(52,RXI,6,"I") Q:'BPDRUG
  1.  . . . ;
  1.  . . . ; exclude drugs that are exempt from billing - BPS*1*20 - use the IB billable API
  1.  . . . I RXF S RXELIG=$$REFAPI1^BPSUTIL1(RXI,RXF,85,"I")    ; 52.1,85 billing eligibility indicator
  1.  . . . I 'RXF S RXELIG=$$RXAPI1^BPSUTIL1(RXI,85,"I")        ;   52,85 billing eligibility indicator
  1.  . . . I '$$BILLABLE^IBNCPDP(BPDRUG,RXELIG) Q               ; drug is non-billable - IA# 6243
  1.  . . . ;
  1.  . . . ; exclude Rx if it is non-billable - esg 8/4/10
  1.  . . . I +$$RNB^IBNCPDPI(RXI,RXF) Q
  1.  . . . ;
  1.  . . . ; exclude Rx if it is not released - esg 8/5/10
  1.  . . . I '$$RELDATE^BPSBCKJ(RXI,RXF) Q
  1.  . . . ;
  1.  . . . ; exclude Rx if Inpatient and non-billable at time of Release
  1.  . . . I $$INP(RXI,RXF) Q
  1.  . . . ;
  1.  . . . ; Make sure not already ECME billed
  1.  . . . Q:$$STATUS^BPSOSRX(RXI,RXF)'=""
  1.  . . . ; Check for TRICARE and CHAMPVA type insurance group
  1.  . . . N BPIBA,X,BPOK,BPINS,I
  1.  . . . I '$$INSUR^IBBAPI(DFN,RXFDT,"P",.BPIBA,"*") Q
  1.  . . . S (X,BPOK)=0 F I=1:1 S X=$O(BPIBA("IBBAPI","INSUR",X)) Q:X=""  D
  1.  . . . . I $D(BPELIG1("T"))!(BPELIG1=0),$P(BPIBA("IBBAPI","INSUR",X,21),U,2)="TRICARE" S BPOK=1
  1.  . . . . I $D(BPELIG1("C"))!(BPELIG1=0),$P(BPIBA("IBBAPI","INSUR",X,21),U,2)="CHAMPVA" S BPOK=1
  1.  . . . . N BPCOB S BPCOB=$P(BPIBA("IBBAPI","INSUR",X,7),U) S:BPCOB="" BPCOB=1
  1.  . . . . ; BPS*1*18:  Modify ePharmacy Screens/Reports to Include the Validated HPID/OEID - IB ICR #6061
  1.  . . . . S BPINS(DFN,BPCOB)=$P(BPIBA("IBBAPI","INSUR",X,1),U,2)_U_BPIBA("IBBAPI","INSUR",X,2)_U_$$HPD^IBCNHUT1($P(BPIBA("IBBAPI","INSUR",X,1),U),1)
  1.  . . . Q:'BPOK
  1.  . . . ; Build the return array since all filters have passed
  1.  . . . S CNT=CNT+1,BPDIV(BPDIV)=$$DIVNAME^BPSSCRDS(BPS56)
  1.  . . . ;
  1.  . . . S PSC=$P($P(BPSORT,U,1),":",1)    ; primary sort choice
  1.  . . . S SSC=$P($P(BPSORT,U,2),":",1)    ; secondary sort choice
  1.  . . . S TSC=$P($P(BPSORT,U,3),":",1)    ; tertiary sort choice
  1.  . . . ;
  1.  . . . ; primary sort value
  1.  . . . S PSRT=$S(PSC="N":$E(ARR(52,RXI,2,"E"),1,20),PSC="P":$P($G(BPINS(DFN,+$O(BPINS(DFN,0)))),U),PSC="S":$S('BPCRON:-RXFDT,1:RXFDT),PSC="E":BPELIG(1),1:BPDIV(BPDIV))
  1.  . . . ;
  1.  . . . ; secondary sort value
  1.  . . . S SSRT=$S(SSC="N":$E(ARR(52,RXI,2,"E"),1,20),SSC="P":$P($G(BPINS(DFN,+$O(BPINS(DFN,0)))),U),SSC="S":$S('BPCRON:-RXFDT,1:RXFDT),SSC="D":BPDIV(BPDIV),SSC="E":BPELIG(1),1:0)
  1.  . . . ;
  1.  . . . ; tertiary sort value
  1.  . . . S TSRT=$S(TSC="N":$E(ARR(52,RXI,2,"E"),1,20),TSC="P":$P($G(BPINS(DFN,+$O(BPINS(DFN,0)))),U),TSC="S":$S('BPCRON:-RXFDT,1:RXFDT),TSC="D":BPDIV(BPDIV),TSC="E":BPELIG(1),1:0)
  1.  . . . ;
  1.  . . . Q:((SSRT="")!(PSRT="")!(TSRT=""))
  1.  . . . S BPARR(PSRT,SSRT,TSRT,CNT)=BPDIV(BPDIV)_U_ARR(52,RXI,.01,"E")_U_RXF_U_$$FMTE^XLFDT(RXFDT,"2D")_U_$E(ARR(52,RXI,2,"E"),1,20)_U_$$SSN4^BPSRPT6(DFN)
  1.  . . . I $D(BPINS(DFN,1)) S BPARR(PSRT,SSRT,TSRT,CNT,"INS",1)=BPINS(DFN,1)
  1.  . . . I $D(BPINS(DFN,2)) S BPARR(PSRT,SSRT,TSRT,CNT,"INS",2)=BPINS(DFN,2)
  1.  . . . S BPARR(PSRT,SSRT,TSRT,CNT,"ELIG")=BPELIG(1)
  1.  K @REF,REF
  1.  I $D(BPARR) S BPARR(0)=CNT
  1.  Q
  1.  ;
  1. GATHER(SDT,EDT) ; Gather cases where we have closed ECME primary claims and available secondary insurance
  1.  ; Input: SDT - FileMan start date
  1.  ;        EDT - FileMan end date
  1.  ;
  1.  N SDTYMD,EDTYMD,BPDOS,BP02,BP59,BPST0,BPST1,DFN,BPDTFD,RXIEN,RXFIL,IBINS,IBRET,BPRX,BPSPINS,CNT
  1.  S SDTYMD=$$FM2YMD^BPSSCR04(SDT) I 'SDTYMD S SDTYMD=0          ; start date in YMD format
  1.  S EDTYMD=$$FM2YMD^BPSSCR04(EDT) I 'EDTYMD S EDTYMD=99999999   ; end date in YMD format
  1.  S BPDOS=$O(^BPSC("AF",SDTYMD),-1) F  S BPDOS=$O(^BPSC("AF",BPDOS)) Q:'BPDOS!(BPDOS>EDTYMD)  D
  1.  . S BP02=0 F  S BP02=$O(^BPSC("AF",BPDOS,BP02)) Q:'BP02  D
  1.  .. S BP59=+$O(^BPST("AE",BP02,0)) Q:'BP59
  1.  .. S BPST0=$G(^BPST(BP59,0))
  1.  .. S BPST1=$G(^BPST(BP59,1))
  1.  .. I $P(BPST0,U,14)'=1 Q               ; looking for primary claims
  1.  .. I '$$CLOSED02^BPSSCR03(BP02) Q      ; looking for closed claims
  1.  .. S DFN=+$P(BPST0,U,6)
  1.  .. S BPDTFD=$$YMD2FM^BPSSCR04(BPDOS)   ; FM date of service
  1.  .. ;
  1.  .. ; make sure the Rx is released
  1.  .. S RXIEN=+$P(BPST1,U,11)
  1.  .. S RXFIL=+$P(BPST1,U,1)
  1.  .. I '$$RELDATE^BPSBCKJ(RXIEN,RXFIL) Q
  1.  .. ;
  1.  .. ; check insurances for this patient on this date
  1.  .. K IBINS
  1.  .. S IBRET=$$INSUR^IBBAPI(DFN,BPDTFD,"P",.IBINS,"1,2,7")
  1.  .. I '$D(IBINS("IBBAPI","INSUR",2)) Q   ; do not have at least 2 Rx policies so get out
  1.  .. ;
  1.  .. ; save this entry in the scratch global
  1.  .. S BPRX=$$RXAPI1^BPSUTIL1(RXIEN,.01,"I")    ; ext Rx#
  1.  .. S BPSPINS=$$INSNAME^BPSSCRU6(BP59)         ; ins co name
  1.  .. S CNT=$O(^TMP("BPSRPT9A",$J,""),-1)+1
  1.  .. S ^TMP("BPSRPT9A",$J,CNT)=RXIEN_U_BPRX_U_RXFIL_U_"(P) Rej"_U_DFN_U_BPDTFD_U_BPSPINS_U_0_U_0
  1.  .. M ^TMP("BPSRPT9A",$J,CNT)=IBINS("IBBAPI","INSUR")
  1.  .. Q
  1.  . Q
  1. GATHERX ;
  1.  Q
  1.  ;
  1. INP(BPRXN,BPRFL) ; Is this an inpatient, NON-BILLABLE Rx as of the Release Date?
  1.  N INP,VAHOW,VAROOT,BPRXIN,VAIP,BPRXREL,BPMW
  1.  S INP=0
  1.  ;
  1.  S VAROOT="BPRXIN"
  1.  S BPRXREL=$$RELDATE^BPSBCKJ(BPRXN,BPRFL)\1     ; release date
  1.  I 'BPRXREL S BPRXREL=DT
  1.  S VAIP("D")=BPRXREL         ; if pt was an inpatient at any time during this day
  1.  D IN5^VADPT                 ; DBIA 10061 - inpatient episode API
  1.  I '$G(BPRXIN(1)) G INPX     ; not an inpatient on this day
  1.  ;
  1.  ; check Rx release date = discharge date. This is billable so get out (esg 9/13/10)
  1.  I BPRXREL=(+$G(BPRXIN(17,1))\1) G INPX
  1.  ;
  1.  ; if Rx/fill is MAIL, then this is billable so get out (esg 9/13/10)
  1.  I BPRFL S BPMW=$$REFAPI1^BPSUTIL1(BPRXN,BPRFL,2,"I")   ; 52.1,2 MAIL/WINDOW field
  1.  I 'BPRFL S BPMW=$$RXAPI1^BPSUTIL1(BPRXN,11,"I")        ; 52,11 MAIL/WINDOW field
  1.  I BPMW="M" G INPX
  1.  ;
  1.  ; inpatient and non-billable
  1.  S INP=1
  1. INPX ;
  1.  Q INP
  1.  ;