IBJDF53 ;ALB/RB - CHAMPVA/TRICARE FOLLOW-UP REPORT (SUMMARY);15-APR-00
;;2.0;INTEGRATED BILLING;**123,185,240,618**;21-MAR-94;Build 61
;;Per VHA Directive 6402, this routine should not be modified.
;
INIT ; - Initialize counters, if necessary.
; Pre-set variables IBCAT, IBDIV, IBSEL1 required.
N I,IB0
I '$D(IB(IBDIV,IBCAT)) D
. F IB0=1:1:4 I IBSEL1[IB0 F I=1:1:8 S IB(IBDIV,IBCAT,IB0,I)=0
;
Q
;
EN ; - Compile entry point from IBJDF51.
; Pre-set variables IB(, IBA, IBCAT, IBDIV, IBSEL1, IBTYP required.
N I,IB0,IBAGE,IBARD,IBOUT
;
; - Add totals for summary.
S IBARD=$$ACT^IBJDF2(IBA) G:'IBARD ENQ ; No activation date.
S IBOUT=0 F I=1:1:5 S IBOUT=IBOUT+$P($G(^PRCA(430,IBA,7)),U,I)
S IBAGE=$$FMDIFF^XLFDT(DT,IBARD),IB0=$$CAT(IBAGE)
F I=IBTYP,4 I IBSEL1[I D
. S $P(IB(IBDIV,IBCAT,I,IB0),U)=+IB(IBDIV,IBCAT,I,IB0)+1
. S $P(IB(IBDIV,IBCAT,I,IB0),U,2)=$P(IB(IBDIV,IBCAT,I,IB0),U,2)+IBOUT
;
ENQ Q
;
PRT ; - Print entry point from IBJDF52.
N IBDIV
;
; - Extract summary data.
I $G(IBXTRACT) D EXTMO(.IB) G ENQ1
;
S IBDIV=""
F S IBDIV=$O(IB(IBDIV)) Q:IBDIV="" D
. S IBCAT=0
. F S IBCAT=$O(IB(IBDIV,IBCAT)) Q:'IBCAT D SUM(.IBCAT) Q:IBQ
;
ENQ1 Q
;
EXTMO(IBS) ; Extract/transmit data to DM Extract Module
; IBS - Array containing the summary information
;
N IB,IBCT,IBI,IBJ,IBR,IBSQ,IBTP,IBZ
;
F IBI=1:1:6 F IBJ=1:1:16 S IB(IBI,IBJ)=$S(IBJ#2:0,1:"0.00")
;
S IBCT=""
F S IBCT=$O(IBS(0,IBCT)) Q:IBCT="" D
. S IBTP=0
. I IBCT=31 S IBTP=1 ; TRICARE Patient
. I IBCT=19 Q ; Sharing Agreements (NOT EXTRACTED)
. I IBCT=30 S IBTP=2 ; TRICARE
. I IBCT=75 S IBTP=2 ; TRICARE DES IB*2.0*618
. I IBCT=76 S IBTP=2 ; TRICARE SCI IB*2.0*618
. I IBCT=77 S IBTP=2 ; TRICARE TBI IB*2.0*618
. I IBCT=78 S IBTP=2 ; TRICARE BLIND IB*2.0*618
. I IBCT=79 S IBTP=2 ; TRICARE DENTAL IB*2.0*618
. I IBCT=80 S IBTP=2 ; TRICARE PHARMACY IB*2.0*618
. I IBCT=32 S IBTP=3 ; TRICARE THIRD PARTY
. I IBCT=28 S IBTP=4 ; CHAMPVA
. I IBCT=29 S IBTP=5 ; CHAMPVA THRID PARTY
. S IBSQ=1
. F IBI=1:1:7 D
. . S IBZ=$G(IBS(0,IBCT,4,IBI))
. . S IB(IBTP,IBSQ)=+IBZ
. . S IB(IBTP,IBSQ+1)=$FN(+$P(IBZ,"^",2),"",2)
. . S IB(IBTP,15)=IB(IBTP,15)+IBZ
. . S IB(IBTP,16)=IB(IBTP,16)+$P(IBZ,"^",2)
. . S IBSQ=IBSQ+2
. S IB(IBTP,16)=$FN(IB(IBTP,16),"",2)
;
F IBR=17:1:21 D E^IBJDE(IBR,0)
Q
;
SUM(IBCAT) ; - Print summary for AR category.
; Input: IBCAT=AR category pointer to file #430.2, and pre-set
; variables IBDIV and IBRPT
N IBDH,IBTYP,IBTYPH,I,J
N IBCATNM ; patch IB*2.0*618
;
S (IBFLG,IBTYP)=0 D HDR
F S IBTYP=$O(IB(IBDIV,IBCAT,IBTYP)) Q:'IBTYP D Q:IBQ
. S IBCATNM=$$ARCAT^IBJDF62(IBCAT) ; patch IB*2.0*618
. I $Y>(IOSL-16) D HDR Q:IBQ
. S IBTYPH=$G(IBCATNM)_" RECEIVABLES ("_$G(IBTPR(IBTYP))_")"
. W !!!?(80-$L(IBTYPH))\2,IBTYPH
. W !?(80-$L(IBTYPH)\2),$$DASH($L(IBTYPH))
. I IBDIV D
. . S IBDH="Division: "_$P($G(^DG(40.8,IBDIV,0)),U)
. . W !?(80-$L(IBDH)\2),IBDH
. W !!
. ;
. ; - Calculate totals first.
. F I=1:1:7 F J=1,2 S $P(IB(IBDIV,IBCAT,IBTYP,8),U,J)=$P(IB(IBDIV,IBCAT,IBTYP,8),U,J)+$P(IB(IBDIV,IBCAT,IBTYP,I),U,J)
. ;
. W "AR Category",?31,"# Receivables",?52,"Total Outstanding Balance",!
. W "-----------",?31,"-------------",?52,"-------------------------"
. I 'IB(IBDIV,IBCAT,IBTYP,8) D D PAUSE Q
. . W !!,"There are no active receivables",$S(IBDIV:" for this division",1:""),"."
. . S IBFLG=1
. ;
. ; - Primary loop to write results.
. S Y=$P(IB(IBDIV,IBCAT,IBTYP,8),U,2)
. F I=1:1:8 S X=$P($T(CATN+I),";;",2,99) D
. . W:I=8 ! W !,X,?30,$J(+IB(IBDIV,IBCAT,IBTYP,I),6)
. . W " (",$J(+IB(IBDIV,IBCAT,IBTYP,I)/+IB(IBDIV,IBCAT,IBTYP,8)*100,0,$S(I=8:0,1:2)),"%)"
. . S Z=$FN($P(IB(IBDIV,IBCAT,IBTYP,I),U,2),",",2)
. . W ?52,$J($S(I=1!(I=9):"$",1:"")_Z,15)
. . W " (",$J($S('Y:0,1:$P(IB(IBDIV,IBCAT,IBTYP,I),U,2)/Y*100),0,$S(I=8:0,1:2)),"%)"
. ;
. D PAUSE
;
SUMQ Q
;
HDR ; - Write the summary report header.
N X
;
I $E(IOST,1,2)="C-"!$G(IBPAG) W @IOF,*13
S IBPAG=$G(IBPAG)+1
W "CHAMPVA/TRICARE FOLLOW-UP SUMMARY REPORT"
W ?71,"Page: ",$J(IBPAG,3),!,"Run Date: ",IBRUN
S X=""
I IBRPT="D" D
. I IBSMN'="A" D
. . S X=" RECEIVABLES OVER "_IBSMN_" AND LESS THAN "_IBSMX_" DAYS OLD "
. I $G(IBSNA)'="ALL" D
. . S X=X_"/ PATIENTS FROM '"_$S(IBSNF="":"FIRST",1:IBSNF)_"' TO '"
. . S X=X_$S(IBSNL="zzzzz":"LAST",1:IBSNL)_"' "
. I $G(IBSAM) S X=X_"/ MINIMUM BALANCE: $"_$FN(IBSAM,",",2)_" "
S $E(X,1,2)=""
I X'="" F I=1:1 W !,$E(X,1,80) S X=$E(X,81,999) I X="" Q
;
Q
;
DASH(X) ; - Return a dashed line.
Q $TR($J("",X)," ","=")
;
PAUSE ; - Page break.
I $E(IOST,1,2)'="C-" Q
N IBX,DIR,DIRUT,DUOUT,DTOUT,DIROUT,X,Y
F IBX=$Y:1:(IOSL-3) W !
S DIR(0)="E" D ^DIR S:$D(DIRUT)!($D(DUOUT)) IBQ=1
Q
;
CAT(X) ; - Determine category to place receivable.
Q $S($G(X)<31:1,X<61:2,X<91:3,X<121:4,X<181:5,X<366:6,1:7)
;
CATN ; - List of category names.
;;Less than 30 days old
;;31-60 days
;;61-90 days
;;91-120 days
;;121-180 days
;;181-365 days
;;Over 365 days
;;Total
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBJDF53 5216 printed Sep 23, 2025@19:59:12 Page 2
IBJDF53 ;ALB/RB - CHAMPVA/TRICARE FOLLOW-UP REPORT (SUMMARY);15-APR-00
+1 ;;2.0;INTEGRATED BILLING;**123,185,240,618**;21-MAR-94;Build 61
+2 ;;Per VHA Directive 6402, this routine should not be modified.
+3 ;
INIT ; - Initialize counters, if necessary.
+1 ; Pre-set variables IBCAT, IBDIV, IBSEL1 required.
+2 NEW I,IB0
+3 IF '$DATA(IB(IBDIV,IBCAT))
Begin DoDot:1
+4 FOR IB0=1:1:4
IF IBSEL1[IB0
FOR I=1:1:8
SET IB(IBDIV,IBCAT,IB0,I)=0
End DoDot:1
+5 ;
+6 QUIT
+7 ;
EN ; - Compile entry point from IBJDF51.
+1 ; Pre-set variables IB(, IBA, IBCAT, IBDIV, IBSEL1, IBTYP required.
+2 NEW I,IB0,IBAGE,IBARD,IBOUT
+3 ;
+4 ; - Add totals for summary.
+5 ; No activation date.
SET IBARD=$$ACT^IBJDF2(IBA)
if 'IBARD
GOTO ENQ
+6 SET IBOUT=0
FOR I=1:1:5
SET IBOUT=IBOUT+$PIECE($GET(^PRCA(430,IBA,7)),U,I)
+7 SET IBAGE=$$FMDIFF^XLFDT(DT,IBARD)
SET IB0=$$CAT(IBAGE)
+8 FOR I=IBTYP,4
IF IBSEL1[I
Begin DoDot:1
+9 SET $PIECE(IB(IBDIV,IBCAT,I,IB0),U)=+IB(IBDIV,IBCAT,I,IB0)+1
+10 SET $PIECE(IB(IBDIV,IBCAT,I,IB0),U,2)=$PIECE(IB(IBDIV,IBCAT,I,IB0),U,2)+IBOUT
End DoDot:1
+11 ;
ENQ QUIT
+1 ;
PRT ; - Print entry point from IBJDF52.
+1 NEW IBDIV
+2 ;
+3 ; - Extract summary data.
+4 IF $GET(IBXTRACT)
DO EXTMO(.IB)
GOTO ENQ1
+5 ;
+6 SET IBDIV=""
+7 FOR
SET IBDIV=$ORDER(IB(IBDIV))
if IBDIV=""
QUIT
Begin DoDot:1
+8 SET IBCAT=0
+9 FOR
SET IBCAT=$ORDER(IB(IBDIV,IBCAT))
if 'IBCAT
QUIT
DO SUM(.IBCAT)
if IBQ
QUIT
End DoDot:1
+10 ;
ENQ1 QUIT
+1 ;
EXTMO(IBS) ; Extract/transmit data to DM Extract Module
+1 ; IBS - Array containing the summary information
+2 ;
+3 NEW IB,IBCT,IBI,IBJ,IBR,IBSQ,IBTP,IBZ
+4 ;
+5 FOR IBI=1:1:6
FOR IBJ=1:1:16
SET IB(IBI,IBJ)=$SELECT(IBJ#2:0,1:"0.00")
+6 ;
+7 SET IBCT=""
+8 FOR
SET IBCT=$ORDER(IBS(0,IBCT))
if IBCT=""
QUIT
Begin DoDot:1
+9 SET IBTP=0
+10 ; TRICARE Patient
IF IBCT=31
SET IBTP=1
+11 ; Sharing Agreements (NOT EXTRACTED)
IF IBCT=19
QUIT
+12 ; TRICARE
IF IBCT=30
SET IBTP=2
+13 ; TRICARE DES IB*2.0*618
IF IBCT=75
SET IBTP=2
+14 ; TRICARE SCI IB*2.0*618
IF IBCT=76
SET IBTP=2
+15 ; TRICARE TBI IB*2.0*618
IF IBCT=77
SET IBTP=2
+16 ; TRICARE BLIND IB*2.0*618
IF IBCT=78
SET IBTP=2
+17 ; TRICARE DENTAL IB*2.0*618
IF IBCT=79
SET IBTP=2
+18 ; TRICARE PHARMACY IB*2.0*618
IF IBCT=80
SET IBTP=2
+19 ; TRICARE THIRD PARTY
IF IBCT=32
SET IBTP=3
+20 ; CHAMPVA
IF IBCT=28
SET IBTP=4
+21 ; CHAMPVA THRID PARTY
IF IBCT=29
SET IBTP=5
+22 SET IBSQ=1
+23 FOR IBI=1:1:7
Begin DoDot:2
+24 SET IBZ=$GET(IBS(0,IBCT,4,IBI))
+25 SET IB(IBTP,IBSQ)=+IBZ
+26 SET IB(IBTP,IBSQ+1)=$FNUMBER(+$PIECE(IBZ,"^",2),"",2)
+27 SET IB(IBTP,15)=IB(IBTP,15)+IBZ
+28 SET IB(IBTP,16)=IB(IBTP,16)+$PIECE(IBZ,"^",2)
+29 SET IBSQ=IBSQ+2
End DoDot:2
+30 SET IB(IBTP,16)=$FNUMBER(IB(IBTP,16),"",2)
End DoDot:1
+31 ;
+32 FOR IBR=17:1:21
DO E^IBJDE(IBR,0)
+33 QUIT
+34 ;
SUM(IBCAT) ; - Print summary for AR category.
+1 ; Input: IBCAT=AR category pointer to file #430.2, and pre-set
+2 ; variables IBDIV and IBRPT
+3 NEW IBDH,IBTYP,IBTYPH,I,J
+4 ; patch IB*2.0*618
NEW IBCATNM
+5 ;
+6 SET (IBFLG,IBTYP)=0
DO HDR
+7 FOR
SET IBTYP=$ORDER(IB(IBDIV,IBCAT,IBTYP))
if 'IBTYP
QUIT
Begin DoDot:1
+8 ; patch IB*2.0*618
SET IBCATNM=$$ARCAT^IBJDF62(IBCAT)
+9 IF $Y>(IOSL-16)
DO HDR
if IBQ
QUIT
+10 SET IBTYPH=$GET(IBCATNM)_" RECEIVABLES ("_$GET(IBTPR(IBTYP))_")"
+11 WRITE !!!?(80-$LENGTH(IBTYPH))\2,IBTYPH
+12 WRITE !?(80-$LENGTH(IBTYPH)\2),$$DASH($LENGTH(IBTYPH))
+13 IF IBDIV
Begin DoDot:2
+14 SET IBDH="Division: "_$PIECE($GET(^DG(40.8,IBDIV,0)),U)
+15 WRITE !?(80-$LENGTH(IBDH)\2),IBDH
End DoDot:2
+16 WRITE !!
+17 ;
+18 ; - Calculate totals first.
+19 FOR I=1:1:7
FOR J=1,2
SET $PIECE(IB(IBDIV,IBCAT,IBTYP,8),U,J)=$PIECE(IB(IBDIV,IBCAT,IBTYP,8),U,J)+$PIECE(IB(IBDIV,IBCAT,IBTYP,I),U,J)
+20 ;
+21 WRITE "AR Category",?31,"# Receivables",?52,"Total Outstanding Balance",!
+22 WRITE "-----------",?31,"-------------",?52,"-------------------------"
+23 IF 'IB(IBDIV,IBCAT,IBTYP,8)
Begin DoDot:2
+24 WRITE !!,"There are no active receivables",$SELECT(IBDIV:" for this division",1:""),"."
+25 SET IBFLG=1
End DoDot:2
DO PAUSE
QUIT
+26 ;
+27 ; - Primary loop to write results.
+28 SET Y=$PIECE(IB(IBDIV,IBCAT,IBTYP,8),U,2)
+29 FOR I=1:1:8
SET X=$PIECE($TEXT(CATN+I),";;",2,99)
Begin DoDot:2
+30 if I=8
WRITE !
WRITE !,X,?30,$JUSTIFY(+IB(IBDIV,IBCAT,IBTYP,I),6)
+31 WRITE " (",$JUSTIFY(+IB(IBDIV,IBCAT,IBTYP,I)/+IB(IBDIV,IBCAT,IBTYP,8)*100,0,$SELECT(I=8:0,1:2)),"%)"
+32 SET Z=$FNUMBER($PIECE(IB(IBDIV,IBCAT,IBTYP,I),U,2),",",2)
+33 WRITE ?52,$JUSTIFY($SELECT(I=1!(I=9):"$",1:"")_Z,15)
+34 WRITE " (",$JUSTIFY($SELECT('Y:0,1:$PIECE(IB(IBDIV,IBCAT,IBTYP,I),U,2)/Y*100),0,$SELECT(I=8:0,1:2)),"%)"
End DoDot:2
+35 ;
+36 DO PAUSE
End DoDot:1
if IBQ
QUIT
+37 ;
SUMQ QUIT
+1 ;
HDR ; - Write the summary report header.
+1 NEW X
+2 ;
+3 IF $EXTRACT(IOST,1,2)="C-"!$GET(IBPAG)
WRITE @IOF,*13
+4 SET IBPAG=$GET(IBPAG)+1
+5 WRITE "CHAMPVA/TRICARE FOLLOW-UP SUMMARY REPORT"
+6 WRITE ?71,"Page: ",$JUSTIFY(IBPAG,3),!,"Run Date: ",IBRUN
+7 SET X=""
+8 IF IBRPT="D"
Begin DoDot:1
+9 IF IBSMN'="A"
Begin DoDot:2
+10 SET X=" RECEIVABLES OVER "_IBSMN_" AND LESS THAN "_IBSMX_" DAYS OLD "
End DoDot:2
+11 IF $GET(IBSNA)'="ALL"
Begin DoDot:2
+12 SET X=X_"/ PATIENTS FROM '"_$SELECT(IBSNF="":"FIRST",1:IBSNF)_"' TO '"
+13 SET X=X_$SELECT(IBSNL="zzzzz":"LAST",1:IBSNL)_"' "
End DoDot:2
+14 IF $GET(IBSAM)
SET X=X_"/ MINIMUM BALANCE: $"_$FNUMBER(IBSAM,",",2)_" "
End DoDot:1
+15 SET $EXTRACT(X,1,2)=""
+16 IF X'=""
FOR I=1:1
WRITE !,$EXTRACT(X,1,80)
SET X=$EXTRACT(X,81,999)
IF X=""
QUIT
+17 ;
+18 QUIT
+19 ;
DASH(X) ; - Return a dashed line.
+1 QUIT $TRANSLATE($JUSTIFY("",X)," ","=")
+2 ;
PAUSE ; - Page break.
+1 IF $EXTRACT(IOST,1,2)'="C-"
QUIT
+2 NEW IBX,DIR,DIRUT,DUOUT,DTOUT,DIROUT,X,Y
+3 FOR IBX=$Y:1:(IOSL-3)
WRITE !
+4 SET DIR(0)="E"
DO ^DIR
if $DATA(DIRUT)!($DATA(DUOUT))
SET IBQ=1
+5 QUIT
+6 ;
CAT(X) ; - Determine category to place receivable.
+1 QUIT $SELECT($GET(X)<31:1,X<61:2,X<91:3,X<121:4,X<181:5,X<366:6,1:7)
+2 ;
CATN ; - List of category names.
+1 ;;Less than 30 days old
+2 ;;31-60 days
+3 ;;61-90 days
+4 ;;91-120 days
+5 ;;121-180 days
+6 ;;181-365 days
+7 ;;Over 365 days
+8 ;;Total
