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

IBOSRX.m

Go to the documentation of this file. 
  1. IBOSRX ;ALB/ESG - POTENTIAL SECONDARY RX CLAIMS REPORT ;6-JUL-10
  1.  ;;2.0;INTEGRATED BILLING;**411**;21-MAR-94;Build 29
  1.  ;;Per VHA Directive 2004-038, this routine should not be modified.
  1.  ;
  1.  ; DBIA 5361 entry point at COLLECT
  1.  ;
  1.  ; Collect and return potential secondary rx claims
  1.  ; Input: SDT = Start date FM format
  1.  ;        EDT = End date FM format
  1.  ;
  1.  ; Return:
  1.  ; ^TMP("BPSRPT9A",$J,n) = RX IEN^RX#^FILL#^BILL#^DFN^DATE^PRIMARY INS NAME^399 ien^TOTAL CHARGES
  1.  ; ^TMP("BPSRPT9A",$J,n,n,1) = INSURANCE COMPANY IEN^INSURANCE COMPANY NAME
  1.  ; ^TMP("BPSRPT9A",$J,n,n,2) = INSURANCE COMPANY ADDRESS
  1.  ; ^TMP("BPSRPT9A",$J,n,n,7) = COB INDICATOR^COB DESC
  1.  ;
  1.  Q
  1.  ;
  1. COLLECT(SDT,EDT) ; entry point DBIA 5361
  1.  ;
  1.  N CNT,IBSDT,IBBILL,IB0,INS,IBPINS,IBINS,IBRET,RIEN,RXD,RX,FL,RXIEN,SECBLFND,RBIEN,RBD,IB,ST,IBTOTCH
  1.  ;
  1.  ; scratch global should be killed by the calling routine
  1.  ;
  1.  S IBSDT=$O(^DGCR(399,"D",SDT),-1)
  1.  F  S IBSDT=$O(^DGCR(399,"D",IBSDT)) Q:'IBSDT!(IBSDT>EDT)  D
  1.  . S IBBILL=0
  1.  . F  S IBBILL=$O(^DGCR(399,"D",IBSDT,IBBILL)) Q:'IBBILL  D
  1.  .. ;
  1.  .. ; consider only pharmacy bills
  1.  .. Q:'$D(^IBA(362.4,"C",IBBILL))
  1.  .. ;
  1.  .. S IB0=$G(^DGCR(399,IBBILL,0))
  1.  .. I '$F(".3.4.","."_$P(IB0,U,13)_".") Q           ; must be auth/print/tx
  1.  .. I $$COBN^IBCEF(IBBILL)'=1 Q                     ; must be primary
  1.  .. S INS=+$G(^DGCR(399,IBBILL,"I1"))
  1.  .. S IBPINS=$P($G(^DIC(36,INS,0)),U,1)             ; primary ins co name
  1.  .. S IBTOTCH=+$P($G(^DGCR(399,IBBILL,"U1")),U,1)   ; total charges on claim
  1.  .. ;
  1.  .. ; check insurances for this patient on this date
  1.  .. K IBINS
  1.  .. S IBRET=$$INSUR^IBBAPI($P(IB0,U,2),IBSDT,"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.  .. ; now loop thru all Rx's on this claim - paper claims may have more than one
  1.  .. S RIEN=0 F  S RIEN=$O(^IBA(362.4,"C",IBBILL,RIEN)) Q:'RIEN  D
  1.  ... S RXD=$G(^IBA(362.4,RIEN,0))
  1.  ... S RX=$P(RXD,U,1) Q:RX=""       ; RX#
  1.  ... S FL=+$P(RXD,U,10)             ; fill#
  1.  ... S RXIEN=+$P(RXD,U,5)           ; RX ien to file# 52
  1.  ... ;
  1.  ... S SECBLFND=0   ; flag indicating if secondary bill was found or not for this Rx/fill#
  1.  ... ;
  1.  ... ; now loop thru all entries in this file for this RX
  1.  ... S RBIEN=0 F  S RBIEN=$O(^IBA(362.4,"B",RX,RBIEN)) Q:'RBIEN  I RBIEN'=RIEN D  Q:SECBLFND
  1.  .... S RBD=$G(^IBA(362.4,RBIEN,0))
  1.  .... I +$P(RBD,U,10)'=FL Q               ; fill# check
  1.  .... S IB=+$P(RBD,U,2)                   ; claim#
  1.  .... I $$COBN^IBCEF(IB)'>1 Q             ; looking for payer seq 2 or 3
  1.  .... S ST=$P($G(^DGCR(399,IB,0)),U,13)   ; claim status
  1.  .... I '$F(".3.4.","."_ST_".") Q         ; must be auth/print/tx
  1.  .... ;
  1.  .... ; found a secondary claim!
  1.  .... S SECBLFND=1
  1.  .... Q
  1.  ... ;
  1.  ... ; if we found a secondary claim for this Rx/fill# then get out
  1.  ... I SECBLFND Q
  1.  ... ;
  1.  ... S CNT=$O(^TMP("BPSRPT9A",$J,""),-1)+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
  1.  ... M ^TMP("BPSRPT9A",$J,CNT)=IBINS("IBBAPI","INSUR")
  1.  ... Q
  1.  .. Q
  1.  . Q
  1.  Q
  1.  ;