IBOA32 ;ALB/CPM - PRINT ALL BILLS FOR A PATIENT (CON'T) ;28-JAN-92
;;2.0;INTEGRATED BILLING;**7,95,347,433,451,645,669**;21-MAR-94;Build 20
;;Per VA Directive 6402, this routine should not be modified.
;
;MAP TO DGCRA32
;
; Print out IB Actions onto the list.
D:($Y>(IOSL-5)) HDR^IBOA31 Q:IBQUIT
N IBND,IBND1,X,IBX,IENS,IBRXN,IBRX,IBRF,IBRDT,IBPFLAG,IBIEN,IBTYPE
S IBND=$G(^IB($E(IBIFN,1,$L(IBIFN)-1),0)),IBND1=$G(^(1))
S (IBRXN,IBRX,IBRF,IBRDT,IBX)=0
I $P(IBND,"^",4)["52:" S IBRXN=$P($P(IBND,"^",4),":",2),IBRX=$P($P(IBND,"^",8),"-"),IBRF=$P($P(IBND,"^",4),":",3)
I IBRF>0 S IBRDT=$$SUBFILE^IBRXUTL(+IBRXN,IBRF,52,.01)
E S IBRDT=$$FILE^IBRXUTL(+IBRXN,22),IBX=$$APPT^IBCU3(IBRDT,DFN)
; IB*2.0*451 - Check for EEOB on associated 3rd party bills and attach EOB indicator '%' if applicable
S IBPFLAG="" I $P(IBND,"^",11)'="" S IBPFLAG=$$IBEEOBCK^IBJDF41($P(IBND,"^",11),DFN) ; Pass AR BILL#, Pat ID
W !,IBPFLAG,$S($P(IBND,"^",11)]"":$P($P(IBND,"^",11),"-",2),$P(IBND,"^",5)=99:"",$P(IBND,"^",5)=10:"",1:"Pending")
; IB*2.0*451 - make space for EEOB indicator '%' next to the bill #
W:'IBEXCEL ?9,$$DAT1^IBOUTL($S($P(IBND,"^",11)="":"",$P(IBND,"^",5)>2&($P(IBND,"^",5)'=99):$P(IBND1,"^",4)\1,1:""))
W:IBEXCEL U,$$DAT1^IBOUTL($S($P(IBND,"^",11)="":"",$P(IBND,"^",5)>2&($P(IBND,"^",5)'=99):$P(IBND1,"^",4)\1,1:""))
; Patch IB*2.0*645 - adding community care - action types
S IBIEN=$G(^IBE(350.1,+$P(IBND,"^",3),0))
S IBIEN=+$P(IBND,"^",3)
S IBTYPE=$$GETATYPE(IBIEN)
I 'IBEXCEL D Q
. W ?19,IBTYPE
. W ?38,$E($S($P(IBND,"^",4)["350:":$E($P(IBND,"^",8),1,14),$P(IBND,"^",3)<7:"Rx:"_IBRX_$S(IBRF>0:"("_IBRF_")",1:""),$P(IBND1,"^",5):"CHAMPVA SUBSIST",1:"AUT MEANS TEST"),1,14)
. W:IBX=1 ?54,"*"
. W ?55,$$DAT1^IBOUTL(-IBDT)
. W ?65,$$DAT1^IBOUTL($S(IBRXN>0:IBRDT,$P(IBND,"^",14):$P(IBND,"^",14),1:$P(IBND1,"^",2)\1))
. W ?75,$$DAT1^IBOUTL($S($P(IBND,"^",15):$P(IBND,"^",15),1:$P(IBND1,"^",2)\1))
. W ?90,"N/A",?95,$E($P($G(^IBE(350.21,+$P(IBND,"^",5),0)),"^",2),1,17)
;Otherwise, EXCEL output
W U,IBTYPE
W U,$E($S($P(IBND,"^",4)["350:":$E($P(IBND,"^",8),1,14),$P(IBND,"^",3)<7:"Rx:"_IBRX_$S(IBRF>0:"("_IBRF_")",1:""),$P(IBND1,"^",5):"CHAMPVA SUBSIST",1:"AUT MEANS TEST"),1,14),U
W:IBX=1 "*"
W $$DAT1^IBOUTL(-IBDT)
W U,$$DAT1^IBOUTL($S(IBRXN>0:IBRDT,$P(IBND,"^",14):$P(IBND,"^",14),1:$P(IBND1,"^",2)\1))
W U,$$DAT1^IBOUTL($S($P(IBND,"^",15):$P(IBND,"^",15),1:$P(IBND1,"^",2)\1))
W U,"N/A",U,$E($P($G(^IBE(350.21,+$P(IBND,"^",5),0)),"^",2),1,17)
Q
;
UTIL ; Gather all IB Actions for a patient.
N DATE,IBN,X,A,B,C,D,E,IBNX,IBNIEN
S IBN=0 F S IBN=$O(^IB("C",DFN,IBN)) Q:'IBN S X=$G(^IB(IBN,0)) D:X
. I 'IBIBRX,$E($G(^IBE(350.1,+$P(X,"^",3),0)),1,3)="PSO" Q
. Q:$P(X,"^",8)["ADMISSION"
. Q:'$D(^IB("APDT",IBN))
. S (C,D)="",C=$O(^IB("APDT",IBN,C)),D=$O(^IB("APDT",IBN,C,D))
. S E=$P($G(^IB(D,0)),U,3)
. S A=$P($G(^IBE(350.1,E,0)),U,5)
. S IBNX=$S(A=2:$P($Q(^IB("APDT",IBN,C,D)),")",1),A=3:$P($Q(^IB("APDT",IBN,C,D)),")",1),1:IBN)
. ; Quit if the reference returned by the $Q is not for the same Patient. (IB*2.0*669
. I A=2!(A=3) S IBNIEN=$P(IBNX,",",4)
. I A'=2&(A'=3) S IBNIEN=IBNX
. Q:$P($G(^IB(IBNIEN,0)),U,2)'=DFN
. ; End of IB*2.0*669 changes
. I (A=2)!(A=3) D
.. I IBNX["[""" S IBNX="^"_$P(IBNX,"]",2)
. I $P(IBNX,",",4)>0 S IBNX=$P(IBNX,",",4)
. S DATE=$P($G(^IB(+$P(X,"^",16),0)),"^",17)
. S:'DATE DATE=$P($G(^IB(IBNX,1)),"^",5)
. S:'DATE DATE=$P($G(^IB(IBNX,1)),"^",2)\1
. S:DATE ^UTILITY($J,-DATE,IBNX_"X")=""
Q
;
GETATYPE(IBIEN) ; Patch IB*2.0*645 - added community care - action types
S IBTYPE=$P(^IBE(350.1,IBIEN,0),"^") I $E(IBTYPE,1,2)="DG" Q $E($P(IBTYPE," ",2,99),1,17)
I $E(IBTYPE,1,3)="PSO" Q $E($P(IBTYPE," ",2,99),1,17)
Q $E(IBTYPE,1,17)
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBOA32 3788 printed Oct 16, 2024@18:25:51 Page 2
IBOA32 ;ALB/CPM - PRINT ALL BILLS FOR A PATIENT (CON'T) ;28-JAN-92
+1 ;;2.0;INTEGRATED BILLING;**7,95,347,433,451,645,669**;21-MAR-94;Build 20
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;
+4 ;MAP TO DGCRA32
+5 ;
+6 ; Print out IB Actions onto the list.
+7 if ($Y>(IOSL-5))
DO HDR^IBOA31
if IBQUIT
QUIT
+8 NEW IBND,IBND1,X,IBX,IENS,IBRXN,IBRX,IBRF,IBRDT,IBPFLAG,IBIEN,IBTYPE
+9 SET IBND=$GET(^IB($EXTRACT(IBIFN,1,$LENGTH(IBIFN)-1),0))
SET IBND1=$GET(^(1))
+10 SET (IBRXN,IBRX,IBRF,IBRDT,IBX)=0
+11 IF $PIECE(IBND,"^",4)["52:"
SET IBRXN=$PIECE($PIECE(IBND,"^",4),":",2)
SET IBRX=$PIECE($PIECE(IBND,"^",8),"-")
SET IBRF=$PIECE($PIECE(IBND,"^",4),":",3)
+12 IF IBRF>0
SET IBRDT=$$SUBFILE^IBRXUTL(+IBRXN,IBRF,52,.01)
+13 IF '$TEST
SET IBRDT=$$FILE^IBRXUTL(+IBRXN,22)
SET IBX=$$APPT^IBCU3(IBRDT,DFN)
+14 ; IB*2.0*451 - Check for EEOB on associated 3rd party bills and attach EOB indicator '%' if applicable
+15 ; Pass AR BILL#, Pat ID
SET IBPFLAG=""
IF $PIECE(IBND,"^",11)'=""
SET IBPFLAG=$$IBEEOBCK^IBJDF41($PIECE(IBND,"^",11),DFN)
+16 WRITE !,IBPFLAG,$SELECT($PIECE(IBND,"^",11)]"":$PIECE($PIECE(IBND,"^",11),"-",2),$PIECE(IBND,"^",5)=99:"",$PIECE(IBND,"^",5)=10:"",1:"Pending")
+17 ; IB*2.0*451 - make space for EEOB indicator '%' next to the bill #
+18 if 'IBEXCEL
WRITE ?9,$$DAT1^IBOUTL($SELECT($PIECE(IBND,"^",11)="":"",$PIECE(IBND,"^",5)>2&($PIECE(IBND,"^",5)'=99):$PIECE(IBND1,"^",4)\1,1:""))
+19 if IBEXCEL
WRITE U,$$DAT1^IBOUTL($SELECT($PIECE(IBND,"^",11)="":"",$PIECE(IBND,"^",5)>2&($PIECE(IBND,"^",5)'=99):$PIECE(IBND1,"^",4)\1,1:""))
+20 ; Patch IB*2.0*645 - adding community care - action types
+21 SET IBIEN=$GET(^IBE(350.1,+$PIECE(IBND,"^",3),0))
+22 SET IBIEN=+$PIECE(IBND,"^",3)
+23 SET IBTYPE=$$GETATYPE(IBIEN)
+24 IF 'IBEXCEL
Begin DoDot:1
+25 WRITE ?19,IBTYPE
+26 WRITE ?38,$EXTRACT($SELECT($PIECE(IBND,"^",4)["350:":$EXTRACT($PIECE(IBND,"^",8),1,14),$PIECE(IBND,"^",3)<7:"Rx:"_IBRX_$SELECT(IBRF>0:"("_IBRF_")",1:""),$PIECE(IBND1,"^",5):"CHAMPVA SUBSIST",1:"AUT MEANS TEST"),1,14)
+27 if IBX=1
WRITE ?54,"*"
+28 WRITE ?55,$$DAT1^IBOUTL(-IBDT)
+29 WRITE ?65,$$DAT1^IBOUTL($SELECT(IBRXN>0:IBRDT,$PIECE(IBND,"^",14):$PIECE(IBND,"^",14),1:$PIECE(IBND1,"^",2)\1))
+30 WRITE ?75,$$DAT1^IBOUTL($SELECT($PIECE(IBND,"^",15):$PIECE(IBND,"^",15),1:$PIECE(IBND1,"^",2)\1))
+31 WRITE ?90,"N/A",?95,$EXTRACT($PIECE($GET(^IBE(350.21,+$PIECE(IBND,"^",5),0)),"^",2),1,17)
End DoDot:1
QUIT
+32 ;Otherwise, EXCEL output
+33 WRITE U,IBTYPE
+34 WRITE U,$EXTRACT($SELECT($PIECE(IBND,"^",4)["350:":$EXTRACT($PIECE(IBND,"^",8),1,14),$PIECE(IBND,"^",3)<7:"Rx:"_IBRX_$SELECT(IBRF>0:"("_IBRF_")",1:""),$PIECE(IBND1,"^",5):"CHAMPVA SUBSIST",1:"AUT MEANS TEST"),1,14),U
+35 if IBX=1
WRITE "*"
+36 WRITE $$DAT1^IBOUTL(-IBDT)
+37 WRITE U,$$DAT1^IBOUTL($SELECT(IBRXN>0:IBRDT,$PIECE(IBND,"^",14):$PIECE(IBND,"^",14),1:$PIECE(IBND1,"^",2)\1))
+38 WRITE U,$$DAT1^IBOUTL($SELECT($PIECE(IBND,"^",15):$PIECE(IBND,"^",15),1:$PIECE(IBND1,"^",2)\1))
+39 WRITE U,"N/A",U,$EXTRACT($PIECE($GET(^IBE(350.21,+$PIECE(IBND,"^",5),0)),"^",2),1,17)
+40 QUIT
+41 ;
UTIL ; Gather all IB Actions for a patient.
+1 NEW DATE,IBN,X,A,B,C,D,E,IBNX,IBNIEN
+2 SET IBN=0
FOR
SET IBN=$ORDER(^IB("C",DFN,IBN))
if 'IBN
QUIT
SET X=$GET(^IB(IBN,0))
if X
Begin DoDot:1
+3 IF 'IBIBRX
IF $EXTRACT($GET(^IBE(350.1,+$PIECE(X,"^",3),0)),1,3)="PSO"
QUIT
+4 if $PIECE(X,"^",8)["ADMISSION"
QUIT
+5 if '$DATA(^IB("APDT",IBN))
QUIT
+6 SET (C,D)=""
SET C=$ORDER(^IB("APDT",IBN,C))
SET D=$ORDER(^IB("APDT",IBN,C,D))
+7 SET E=$PIECE($GET(^IB(D,0)),U,3)
+8 SET A=$PIECE($GET(^IBE(350.1,E,0)),U,5)
+9 SET IBNX=$SELECT(A=2:$PIECE($QUERY(^IB("APDT",IBN,C,D)),")",1),A=3:$PIECE($QUERY(^IB("APDT",IBN,C,D)),")",1),1:IBN)
+10 ; Quit if the reference returned by the $Q is not for the same Patient. (IB*2.0*669
+11 IF A=2!(A=3)
SET IBNIEN=$PIECE(IBNX,",",4)
+12 IF A'=2&(A'=3)
SET IBNIEN=IBNX
+13 if $PIECE($GET(^IB(IBNIEN,0)),U,2)'=DFN
QUIT
+14 ; End of IB*2.0*669 changes
+15 IF (A=2)!(A=3)
Begin DoDot:2
+16 IF IBNX["["""
SET IBNX="^"_$PIECE(IBNX,"]",2)
End DoDot:2
+17 IF $PIECE(IBNX,",",4)>0
SET IBNX=$PIECE(IBNX,",",4)
+18 SET DATE=$PIECE($GET(^IB(+$PIECE(X,"^",16),0)),"^",17)
+19 if 'DATE
SET DATE=$PIECE($GET(^IB(IBNX,1)),"^",5)
+20 if 'DATE
SET DATE=$PIECE($GET(^IB(IBNX,1)),"^",2)\1
+21 if DATE
SET ^UTILITY($JOB,-DATE,IBNX_"X")=""
End DoDot:1
+22 QUIT
+23 ;
GETATYPE(IBIEN) ; Patch IB*2.0*645 - added community care - action types
+1 SET IBTYPE=$PIECE(^IBE(350.1,IBIEN,0),"^")
IF $EXTRACT(IBTYPE,1,2)="DG"
QUIT $EXTRACT($PIECE(IBTYPE," ",2,99),1,17)
+2 IF $EXTRACT(IBTYPE,1,3)="PSO"
QUIT $EXTRACT($PIECE(IBTYPE," ",2,99),1,17)
+3 QUIT $EXTRACT(IBTYPE,1,17)
