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