IBOSRX ;ALB/ESG - POTENTIAL SECONDARY RX CLAIMS REPORT ;6-JUL-10
;;2.0;INTEGRATED BILLING;**411**;21-MAR-94;Build 29
;;Per VHA Directive 2004-038, this routine should not be modified.
;
; DBIA 5361 entry point at COLLECT
;
; Collect and return potential secondary rx claims
; Input: SDT = Start date FM format
; EDT = End date FM format
;
; Return:
; ^TMP("BPSRPT9A",$J,n) = RX IEN^RX#^FILL#^BILL#^DFN^DATE^PRIMARY INS NAME^399 ien^TOTAL CHARGES
; ^TMP("BPSRPT9A",$J,n,n,1) = INSURANCE COMPANY IEN^INSURANCE COMPANY NAME
; ^TMP("BPSRPT9A",$J,n,n,2) = INSURANCE COMPANY ADDRESS
; ^TMP("BPSRPT9A",$J,n,n,7) = COB INDICATOR^COB DESC
;
Q
;
COLLECT(SDT,EDT) ; entry point DBIA 5361
;
N CNT,IBSDT,IBBILL,IB0,INS,IBPINS,IBINS,IBRET,RIEN,RXD,RX,FL,RXIEN,SECBLFND,RBIEN,RBD,IB,ST,IBTOTCH
;
; scratch global should be killed by the calling routine
;
S IBSDT=$O(^DGCR(399,"D",SDT),-1)
F S IBSDT=$O(^DGCR(399,"D",IBSDT)) Q:'IBSDT!(IBSDT>EDT) D
. S IBBILL=0
. F S IBBILL=$O(^DGCR(399,"D",IBSDT,IBBILL)) Q:'IBBILL D
.. ;
.. ; consider only pharmacy bills
.. Q:'$D(^IBA(362.4,"C",IBBILL))
.. ;
.. S IB0=$G(^DGCR(399,IBBILL,0))
.. I '$F(".3.4.","."_$P(IB0,U,13)_".") Q ; must be auth/print/tx
.. I $$COBN^IBCEF(IBBILL)'=1 Q ; must be primary
.. S INS=+$G(^DGCR(399,IBBILL,"I1"))
.. S IBPINS=$P($G(^DIC(36,INS,0)),U,1) ; primary ins co name
.. S IBTOTCH=+$P($G(^DGCR(399,IBBILL,"U1")),U,1) ; total charges on claim
.. ;
.. ; check insurances for this patient on this date
.. K IBINS
.. S IBRET=$$INSUR^IBBAPI($P(IB0,U,2),IBSDT,"P",.IBINS,"1,2,7")
.. I '$D(IBINS("IBBAPI","INSUR",2)) Q ; do not have at least 2 Rx policies so get out
.. ;
.. ; now loop thru all Rx's on this claim - paper claims may have more than one
.. S RIEN=0 F S RIEN=$O(^IBA(362.4,"C",IBBILL,RIEN)) Q:'RIEN D
... S RXD=$G(^IBA(362.4,RIEN,0))
... S RX=$P(RXD,U,1) Q:RX="" ; RX#
... S FL=+$P(RXD,U,10) ; fill#
... S RXIEN=+$P(RXD,U,5) ; RX ien to file# 52
... ;
... S SECBLFND=0 ; flag indicating if secondary bill was found or not for this Rx/fill#
... ;
... ; now loop thru all entries in this file for this RX
... S RBIEN=0 F S RBIEN=$O(^IBA(362.4,"B",RX,RBIEN)) Q:'RBIEN I RBIEN'=RIEN D Q:SECBLFND
.... S RBD=$G(^IBA(362.4,RBIEN,0))
.... I +$P(RBD,U,10)'=FL Q ; fill# check
.... S IB=+$P(RBD,U,2) ; claim#
.... I $$COBN^IBCEF(IB)'>1 Q ; looking for payer seq 2 or 3
.... S ST=$P($G(^DGCR(399,IB,0)),U,13) ; claim status
.... I '$F(".3.4.","."_ST_".") Q ; must be auth/print/tx
.... ;
.... ; found a secondary claim!
.... S SECBLFND=1
.... Q
... ;
... ; if we found a secondary claim for this Rx/fill# then get out
... I SECBLFND Q
... ;
... S CNT=$O(^TMP("BPSRPT9A",$J,""),-1)+1
... S ^TMP("BPSRPT9A",$J,CNT)=RXIEN_U_RX_U_FL_U_$P(IB0,U,1)_U_$P(IB0,U,2)_U_IBSDT_U_IBPINS_U_IBBILL_U_IBTOTCH
... M ^TMP("BPSRPT9A",$J,CNT)=IBINS("IBBAPI","INSUR")
... Q
.. Q
. Q
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBOSRX 3117 printed Apr 09, 2024@21:32:45 Page 2
IBOSRX ;ALB/ESG - POTENTIAL SECONDARY RX CLAIMS REPORT ;6-JUL-10
+1 ;;2.0;INTEGRATED BILLING;**411**;21-MAR-94;Build 29
+2 ;;Per VHA Directive 2004-038, this routine should not be modified.
+3 ;
+4 ; DBIA 5361 entry point at COLLECT
+5 ;
+6 ; Collect and return potential secondary rx claims
+7 ; Input: SDT = Start date FM format
+8 ; EDT = End date FM format
+9 ;
+10 ; Return:
+11 ; ^TMP("BPSRPT9A",$J,n) = RX IEN^RX#^FILL#^BILL#^DFN^DATE^PRIMARY INS NAME^399 ien^TOTAL CHARGES
+12 ; ^TMP("BPSRPT9A",$J,n,n,1) = INSURANCE COMPANY IEN^INSURANCE COMPANY NAME
+13 ; ^TMP("BPSRPT9A",$J,n,n,2) = INSURANCE COMPANY ADDRESS
+14 ; ^TMP("BPSRPT9A",$J,n,n,7) = COB INDICATOR^COB DESC
+15 ;
+16 QUIT
+17 ;
COLLECT(SDT,EDT) ; entry point DBIA 5361
+1 ;
+2 NEW CNT,IBSDT,IBBILL,IB0,INS,IBPINS,IBINS,IBRET,RIEN,RXD,RX,FL,RXIEN,SECBLFND,RBIEN,RBD,IB,ST,IBTOTCH
+3 ;
+4 ; scratch global should be killed by the calling routine
+5 ;
+6 SET IBSDT=$ORDER(^DGCR(399,"D",SDT),-1)
+7 FOR
SET IBSDT=$ORDER(^DGCR(399,"D",IBSDT))
if 'IBSDT!(IBSDT>EDT)
QUIT
Begin DoDot:1
+8 SET IBBILL=0
+9 FOR
SET IBBILL=$ORDER(^DGCR(399,"D",IBSDT,IBBILL))
if 'IBBILL
QUIT
Begin DoDot:2
+10 ;
+11 ; consider only pharmacy bills
+12 if '$DATA(^IBA(362.4,"C",IBBILL))
QUIT
+13 ;
+14 SET IB0=$GET(^DGCR(399,IBBILL,0))
+15 ; must be auth/print/tx
IF '$FIND(".3.4.","."_$PIECE(IB0,U,13)_".")
QUIT
+16 ; must be primary
IF $$COBN^IBCEF(IBBILL)'=1
QUIT
+17 SET INS=+$GET(^DGCR(399,IBBILL,"I1"))
+18 ; primary ins co name
SET IBPINS=$PIECE($GET(^DIC(36,INS,0)),U,1)
+19 ; total charges on claim
SET IBTOTCH=+$PIECE($GET(^DGCR(399,IBBILL,"U1")),U,1)
+20 ;
+21 ; check insurances for this patient on this date
+22 KILL IBINS
+23 SET IBRET=$$INSUR^IBBAPI($PIECE(IB0,U,2),IBSDT,"P",.IBINS,"1,2,7")
+24 ; do not have at least 2 Rx policies so get out
IF '$DATA(IBINS("IBBAPI","INSUR",2))
QUIT
+25 ;
+26 ; now loop thru all Rx's on this claim - paper claims may have more than one
+27 SET RIEN=0
FOR
SET RIEN=$ORDER(^IBA(362.4,"C",IBBILL,RIEN))
if 'RIEN
QUIT
Begin DoDot:3
+28 SET RXD=$GET(^IBA(362.4,RIEN,0))
+29 ; RX#
SET RX=$PIECE(RXD,U,1)
if RX=""
QUIT
+30 ; fill#
SET FL=+$PIECE(RXD,U,10)
+31 ; RX ien to file# 52
SET RXIEN=+$PIECE(RXD,U,5)
+32 ;
+33 ; flag indicating if secondary bill was found or not for this Rx/fill#
SET SECBLFND=0
+34 ;
+35 ; now loop thru all entries in this file for this RX
+36 SET RBIEN=0
FOR
SET RBIEN=$ORDER(^IBA(362.4,"B",RX,RBIEN))
if 'RBIEN
QUIT
IF RBIEN'=RIEN
Begin DoDot:4
+37 SET RBD=$GET(^IBA(362.4,RBIEN,0))
+38 ; fill# check
IF +$PIECE(RBD,U,10)'=FL
QUIT
+39 ; claim#
SET IB=+$PIECE(RBD,U,2)
+40 ; looking for payer seq 2 or 3
IF $$COBN^IBCEF(IB)'>1
QUIT
+41 ; claim status
SET ST=$PIECE($GET(^DGCR(399,IB,0)),U,13)
+42 ; must be auth/print/tx
IF '$FIND(".3.4.","."_ST_".")
QUIT
+43 ;
+44 ; found a secondary claim!
+45 SET SECBLFND=1
+46 QUIT
End DoDot:4
if SECBLFND
QUIT
+47 ;
+48 ; if we found a secondary claim for this Rx/fill# then get out
+49 IF SECBLFND
QUIT
+50 ;
+51 SET CNT=$ORDER(^TMP("BPSRPT9A",$JOB,""),-1)+1
+52 SET ^TMP("BPSRPT9A",$JOB,CNT)=RXIEN_U_RX_U_FL_U_$PIECE(IB0,U,1)_U_$PIECE(IB0,U,2)_U_IBSDT_U_IBPINS_U_IBBILL_U_IBTOTCH
+53 MERGE ^TMP("BPSRPT9A",$JOB,CNT)=IBINS("IBBAPI","INSUR")
+54 QUIT
End DoDot:3
+55 QUIT
End DoDot:2
+56 QUIT
End DoDot:1
+57 QUIT
+58 ;
