IBJDF43 ;ALB/RB - FIRST PARTY FOLLOW-UP REPORT (COMPILE/PRINT SUMMARY);15-APR-00
;;2.0;INTEGRATED BILLING;**123,568,705,715**;21-MAR-94;Build 25
;;Per VA Directive 6402, this routine should not be modified.
;
INIT ; - Initialize counters (Called by IBJDF41)
; Pre-set variables IB, IB(, IBCAT, IBSRC required.
N I,IB0 S IB0=$S(IB=40:19,1:IB)
;
I '$D(IB(IBCAT,IB0)) D
.I IBSTA="A",IB0'=16 Q ; Active AR's only.
.I IBSTA="S",IB0=16 Q ; Suspended AR's only.
.F I=1:1:$S(IBSRC:8,1:7),9 S IB(IBCAT,IB0,I)=0
Q
;
EN ; - Compile entry point from IBJDF41.
; Pre-set variables IB, IB(, IBA, IBCAT, IBSRC required.
N I,IB0,IBAGE,IBARD,IBCAT1,IBOUT S IB0=$S(IB=40:19,1:IB)
;
; - Add totals for summary.
I IBSTA="S" S IBSUSTYP=$$SUST^IBJDF41(IBA) I IBSELST'[(","_IBSUSTYP_",") G ENQ ;Filter by suspended type IB*2*568/DRF
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)
;
; - Handle claims referred to Regional Counsel.
I IBSRC,$P($G(^PRCA(430,IBA,6)),U,4) D G ENQ
.S $P(IB(IBCAT,IB0,8),U)=$P(IB(IBCAT,IB0,8),U)+1
.S $P(IB(IBCAT,IB0,8),U,2)=$P(IB(IBCAT,IB0,8),U,2)+IBOUT
;
I 'IBSRC,$P($G(^PRCA(430,IBA,6)),U,4) G ENQ ;Filter by regional counsel IB*2*568/DRF
S IBAGE=$$FMDIFF^XLFDT(DT,IBARD),IBCAT1=$$CAT^IBJDF2(IBAGE)
S $P(IB(IBCAT,IB0,IBCAT1),U)=$P(IB(IBCAT,IB0,IBCAT1),U)+1
S $P(IB(IBCAT,IB0,IBCAT1),U,2)=$P(IB(IBCAT,IB0,IBCAT1),U,2)+IBOUT
;
ENQ K IBPRTFLG,IBPAG,IBRUN,J,Z Q
;
PRT ; - Print entry point from IBJDF42.
;
; - Extract summary data.
I $G(IBXTRACT) D EXTMO(.IB) G ENQ1
;
; - Print the summary report.
D SUM
;
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:5 F IBJ=1:1:18 S IB(IBI,IBJ)=$S(IBJ#2:0,1:"0.00")
;
S IBCT=""
F S IBCT=$O(IBS(IBCT)) Q:IBCT="" D
. S IBTP=0
. I IBCT=2 S IBTP=1 ; Emergency/Humatiatiran
. I IBCT=1 S IBTP=2 ; Ineligible
. I IBCT=18 S IBTP=3 ; C - Means Test
. I IBCT=22 S IBTP=4 ; RX CO-Payment/SC VET
. I IBCT=23 S IBTP=5 ; RX CO-Payment/NSC VET
. S IBSQ=1
. F IBI=1:1:8 D
. . S IBZ=$G(IBS(IBCT,16,IBI))
. . S IB(IBTP,IBSQ)=+IBZ
. . S IB(IBTP,IBSQ+1)=$FN(+$P(IBZ,"^",2),"",2)
. . S IB(IBTP,17)=IB(IBTP,17)+IBZ
. . S IB(IBTP,18)=IB(IBTP,18)+$P(IBZ,"^",2)
. . S IBSQ=IBSQ+2
. S IB(IBTP,18)=$FN(IB(IBTP,18),"",2)
;
F IBR=12:1:16 D E^IBJDE(IBR,0)
Q
;
SUM ; - Print summary for AR category.
; Input: IBCAT=AR category pointer to file #430.2
S IBS=$S(IBSRC:8,1:7)
S (IBCAT,IB,IBPRTFLG)=0
F S IBCAT=$O(IB(IBCAT)) Q:'IBCAT D Q:IBQ
. D HDR
. F S IB=$O(IB(IBCAT,IB)) Q:'IB D Q:IBQ
. . ; - Calculate totals first.
. . F I=1:1:IBS D Q:IBQ
. . . F J=1,2 S $P(IB(IBCAT,IB,9),U,J)=$P(IB(IBCAT,IB,9),U,J)+$P(IB(IBCAT,IB,I),U,J)
. . ;
. . I $Y>(IOSL-16) D HDR Q:IBQ
. . ;
. . S X=$S(IB=16:"ACTIVE ",1:"SUSPENDED ")
. . S X=X_$P($G(^PRCA(430.2,IBCAT,0)),U)
. . W !!!!?(80-$L(X)\2),X,!?(80-$L(X)\2),$$DASH($L(X)),!!
. . ;
. . W "AR Category",?31,"# Receivables",?52,"Total Outstanding Balance",!
. . W "-----------",?31,"-------------",?52,"-------------------------",!
. . I 'IB(IBCAT,IB,9) W !,"There are no statistics for this category." D PAUSE Q
. . ;
. . ; - Primary loop to write results.
. . S Y=$P(IB(IBCAT,IB,9),U,2)
. . F I=1:1:IBS,9 S X=$P($T(CATN+I),";;",2,99) D
. . . W:I=9 ! W !,X,?30,$J(+IB(IBCAT,IB,I),6)
. . . W " (",$J($S(+IB(IBCAT,IB,9)'=0:+IB(IBCAT,IB,I)/+IB(IBCAT,IB,9)*100,1:0),0,$S(I=9:0,1:2)),"%)" ; IB*2.0*705
. . . S Z=$FN($P(IB(IBCAT,IB,I),U,2),",",2)
. . . W ?52,$J($S(I=1!(I=9):"$",1:"")_Z,15)
. . . W " (",$J($S('Y:0,1:$P(IB(IBCAT,IB,I),U,2)/Y*100),0,$S(I=9:0,1:2)),"%)"
. . ;
. . S IBPRTFLG=1 D PAUSE
;
I 'IBPRTFLG D
. W !!!!!!,"There are no receivables for the parameters entered."
;
SUMQ Q
;
HDR ; - Write the summary report header.
W:'$G(IBPAG) ! I $E(IOST,1,2)="C-"!$G(IBPAG) W @IOF,*13
S IBPAG=$G(IBPAG)+1
W "FIRST PARTY FOLLOW-UP SUMMARY REPORT Run Date: ",IBRUN
W ?71,"Page: ",$J(IBPAG,3)
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 X=X_"/ RECEIVABLES REFERRED TO RC "_$S('IBSRC:"NOT ",1:"")_"INCLUDED"
S $E(X,1,2)=""
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
;
OSUM ; Print Overall Summary
;Undeclared Input Parameters
; IB - Array of data gathered
;
N IBS,IBCAT,IBDLT,IBI,IBDATA
S IBS=$S(IBSRC:8,1:7)
S IB("OSUM")=0,IB("OSUM",9)="0^0"
S IBCAT=""
F S IBCAT=$O(IB(IBCAT)) Q:'IBCAT D
. S IBDLT=0
. F S IBDLT=$O(IB(IBCAT,IBDLT)) Q:'IBDLT D
. . S IBI=0
. . F S IBI=$O(IB(IBCAT,IBDLT,IBI)) Q:IBI>8 D
. . . S IBDATA=$G(IB(IBCAT,IBDLT,IBI))
. . . S $P(IB("OSUM",IBI),U,1)=$P($G(IB("OSUM",IBI)),U,1)+$P(IBDATA,U,1)
. . . S $P(IB("OSUM",IBI),U,2)=$P($G(IB("OSUM",IBI)),U,2)+$P(IBDATA,U,2)
. . . S $P(IB("OSUM",9),U,1)=$P(IB("OSUM",9),U,1)+$P(IBDATA,U,1)
. . . S $P(IB("OSUM",9),U,2)=$P(IB("OSUM",9),U,2)+$P(IBDATA,U,2)
;
; - Print Custom Header
D OSHDR
N X,Y,Z,I
S Y=$P(IB("OSUM",9),U,2)
F I=1:1:IBS,9 S X=$P($T(CATN+I),";;",2,99) D
.I $G(IB("OSUM",I))="" Q ; IB*2.0*715
.W:I=9 ! W !,X,?30,$J($P(IB("OSUM",I),U),6)
.W " (",$J($S(+IB("OSUM",9)'=0:$P(IB("OSUM",I),U)/+IB("OSUM",9)*100,1:0),0,$S(I=9:0,1:2)),"%)" ; IB*2.0*705
.S Z=$FN($P(IB("OSUM",I),U,2),",",2)
.W ?52,$J($S(I=1!(I=9):"$",1:"")_Z,15)
.W " (",$J($S('Y:0,1:$P(IB("OSUM",I),U,2)/Y*100),0,$S(I=9:0,1:2)),"%)"
D PAUSE
;
OSUMQ Q
;
OSHDR ; - Custom Header for Overall Summary
I '$D(IBRUN) D
.D NOW^%DTC S IBRUN=$$DAT2^IBOUTL(%)
W:'$G(IBPAG) ! I $E(IOST,1,2)="C-"!$G(IBPAG) W @IOF,*13
S IBPAG=$G(IBPAG)+1
W "FIRST PARTY FOLLOW-UP SUMMARY REPORT Run Date: ",IBRUN
W ?71,"Page: ",$J(IBPAG,3)
S X="Overall Summary"
S X=X_"/ RECEIVABLES REFERRED TO RC "_$S('IBSRC:"NOT ",1:"")_"INCLUDED"
F I=1:1 W !,$E(X,1,80) S X=$E(X,81,999) I X="" Q
W !!!!?(80-$L(X)\2),X,!?(80-$L(X)\2),$$DASH^IBJDF43($L(X)),!!
W "AR Category",?31,"# Receivables",?52,"Total Outstanding Balance",!
W "-----------",?31,"-------------",?52,"-------------------------",!
Q
;
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
;;Referred to Regional Counsel
;;Total First Party Receivables
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBJDF43 6983 printed Dec 13, 2024@02:22:51 Page 2
IBJDF43 ;ALB/RB - FIRST PARTY FOLLOW-UP REPORT (COMPILE/PRINT SUMMARY);15-APR-00
+1 ;;2.0;INTEGRATED BILLING;**123,568,705,715**;21-MAR-94;Build 25
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;
INIT ; - Initialize counters (Called by IBJDF41)
+1 ; Pre-set variables IB, IB(, IBCAT, IBSRC required.
+2 NEW I,IB0
SET IB0=$SELECT(IB=40:19,1:IB)
+3 ;
+4 IF '$DATA(IB(IBCAT,IB0))
Begin DoDot:1
+5 ; Active AR's only.
IF IBSTA="A"
IF IB0'=16
QUIT
+6 ; Suspended AR's only.
IF IBSTA="S"
IF IB0=16
QUIT
+7 FOR I=1:1:$SELECT(IBSRC:8,1:7),9
SET IB(IBCAT,IB0,I)=0
End DoDot:1
+8 QUIT
+9 ;
EN ; - Compile entry point from IBJDF41.
+1 ; Pre-set variables IB, IB(, IBA, IBCAT, IBSRC required.
+2 NEW I,IB0,IBAGE,IBARD,IBCAT1,IBOUT
SET IB0=$SELECT(IB=40:19,1:IB)
+3 ;
+4 ; - Add totals for summary.
+5 ;Filter by suspended type IB*2*568/DRF
IF IBSTA="S"
SET IBSUSTYP=$$SUST^IBJDF41(IBA)
IF IBSELST'[(","_IBSUSTYP_",")
GOTO ENQ
+6 ; No activation date.
SET IBARD=$$ACT^IBJDF2(IBA)
if 'IBARD
GOTO ENQ
+7 SET IBOUT=0
FOR I=1:1:5
SET IBOUT=IBOUT+$PIECE($GET(^PRCA(430,IBA,7)),U,I)
+8 ;
+9 ; - Handle claims referred to Regional Counsel.
+10 IF IBSRC
IF $PIECE($GET(^PRCA(430,IBA,6)),U,4)
Begin DoDot:1
+11 SET $PIECE(IB(IBCAT,IB0,8),U)=$PIECE(IB(IBCAT,IB0,8),U)+1
+12 SET $PIECE(IB(IBCAT,IB0,8),U,2)=$PIECE(IB(IBCAT,IB0,8),U,2)+IBOUT
End DoDot:1
GOTO ENQ
+13 ;
+14 ;Filter by regional counsel IB*2*568/DRF
IF 'IBSRC
IF $PIECE($GET(^PRCA(430,IBA,6)),U,4)
GOTO ENQ
+15 SET IBAGE=$$FMDIFF^XLFDT(DT,IBARD)
SET IBCAT1=$$CAT^IBJDF2(IBAGE)
+16 SET $PIECE(IB(IBCAT,IB0,IBCAT1),U)=$PIECE(IB(IBCAT,IB0,IBCAT1),U)+1
+17 SET $PIECE(IB(IBCAT,IB0,IBCAT1),U,2)=$PIECE(IB(IBCAT,IB0,IBCAT1),U,2)+IBOUT
+18 ;
ENQ KILL IBPRTFLG,IBPAG,IBRUN,J,Z
QUIT
+1 ;
PRT ; - Print entry point from IBJDF42.
+1 ;
+2 ; - Extract summary data.
+3 IF $GET(IBXTRACT)
DO EXTMO(.IB)
GOTO ENQ1
+4 ;
+5 ; - Print the summary report.
+6 DO SUM
+7 ;
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:5
FOR IBJ=1:1:18
SET IB(IBI,IBJ)=$SELECT(IBJ#2:0,1:"0.00")
+6 ;
+7 SET IBCT=""
+8 FOR
SET IBCT=$ORDER(IBS(IBCT))
if IBCT=""
QUIT
Begin DoDot:1
+9 SET IBTP=0
+10 ; Emergency/Humatiatiran
IF IBCT=2
SET IBTP=1
+11 ; Ineligible
IF IBCT=1
SET IBTP=2
+12 ; C - Means Test
IF IBCT=18
SET IBTP=3
+13 ; RX CO-Payment/SC VET
IF IBCT=22
SET IBTP=4
+14 ; RX CO-Payment/NSC VET
IF IBCT=23
SET IBTP=5
+15 SET IBSQ=1
+16 FOR IBI=1:1:8
Begin DoDot:2
+17 SET IBZ=$GET(IBS(IBCT,16,IBI))
+18 SET IB(IBTP,IBSQ)=+IBZ
+19 SET IB(IBTP,IBSQ+1)=$FNUMBER(+$PIECE(IBZ,"^",2),"",2)
+20 SET IB(IBTP,17)=IB(IBTP,17)+IBZ
+21 SET IB(IBTP,18)=IB(IBTP,18)+$PIECE(IBZ,"^",2)
+22 SET IBSQ=IBSQ+2
End DoDot:2
+23 SET IB(IBTP,18)=$FNUMBER(IB(IBTP,18),"",2)
End DoDot:1
+24 ;
+25 FOR IBR=12:1:16
DO E^IBJDE(IBR,0)
+26 QUIT
+27 ;
SUM ; - Print summary for AR category.
+1 ; Input: IBCAT=AR category pointer to file #430.2
+2 SET IBS=$SELECT(IBSRC:8,1:7)
+3 SET (IBCAT,IB,IBPRTFLG)=0
+4 FOR
SET IBCAT=$ORDER(IB(IBCAT))
if 'IBCAT
QUIT
Begin DoDot:1
+5 DO HDR
+6 FOR
SET IB=$ORDER(IB(IBCAT,IB))
if 'IB
QUIT
Begin DoDot:2
+7 ; - Calculate totals first.
+8 FOR I=1:1:IBS
Begin DoDot:3
+9 FOR J=1,2
SET $PIECE(IB(IBCAT,IB,9),U,J)=$PIECE(IB(IBCAT,IB,9),U,J)+$PIECE(IB(IBCAT,IB,I),U,J)
End DoDot:3
if IBQ
QUIT
+10 ;
+11 IF $Y>(IOSL-16)
DO HDR
if IBQ
QUIT
+12 ;
+13 SET X=$SELECT(IB=16:"ACTIVE ",1:"SUSPENDED ")
+14 SET X=X_$PIECE($GET(^PRCA(430.2,IBCAT,0)),U)
+15 WRITE !!!!?(80-$LENGTH(X)\2),X,!?(80-$LENGTH(X)\2),$$DASH($LENGTH(X)),!!
+16 ;
+17 WRITE "AR Category",?31,"# Receivables",?52,"Total Outstanding Balance",!
+18 WRITE "-----------",?31,"-------------",?52,"-------------------------",!
+19 IF 'IB(IBCAT,IB,9)
WRITE !,"There are no statistics for this category."
DO PAUSE
QUIT
+20 ;
+21 ; - Primary loop to write results.
+22 SET Y=$PIECE(IB(IBCAT,IB,9),U,2)
+23 FOR I=1:1:IBS,9
SET X=$PIECE($TEXT(CATN+I),";;",2,99)
Begin DoDot:3
+24 if I=9
WRITE !
WRITE !,X,?30,$JUSTIFY(+IB(IBCAT,IB,I),6)
+25 ; IB*2.0*705
WRITE " (",$JUSTIFY($SELECT(+IB(IBCAT,IB,9)'=0:+IB(IBCAT,IB,I)/+IB(IBCAT,IB,9)*100,1:0),0,$SELECT(I=9:0,1:2)),"%)"
+26 SET Z=$FNUMBER($PIECE(IB(IBCAT,IB,I),U,2),",",2)
+27 WRITE ?52,$JUSTIFY($SELECT(I=1!(I=9):"$",1:"")_Z,15)
+28 WRITE " (",$JUSTIFY($SELECT('Y:0,1:$PIECE(IB(IBCAT,IB,I),U,2)/Y*100),0,$SELECT(I=9:0,1:2)),"%)"
End DoDot:3
+29 ;
+30 SET IBPRTFLG=1
DO PAUSE
End DoDot:2
if IBQ
QUIT
End DoDot:1
if IBQ
QUIT
+31 ;
+32 IF 'IBPRTFLG
Begin DoDot:1
+33 WRITE !!!!!!,"There are no receivables for the parameters entered."
End DoDot:1
+34 ;
SUMQ QUIT
+1 ;
HDR ; - Write the summary report header.
+1 if '$GET(IBPAG)
WRITE !
IF $EXTRACT(IOST,1,2)="C-"!$GET(IBPAG)
WRITE @IOF,*13
+2 SET IBPAG=$GET(IBPAG)+1
+3 WRITE "FIRST PARTY FOLLOW-UP SUMMARY REPORT Run Date: ",IBRUN
+4 WRITE ?71,"Page: ",$JUSTIFY(IBPAG,3)
+5 SET X=""
+6 IF IBRPT="D"
Begin DoDot:1
+7 IF IBSMN'="A"
Begin DoDot:2
+8 SET X=" RECEIVABLES OVER "_IBSMN_" AND LESS THAN "_IBSMX_" DAYS OLD "
End DoDot:2
+9 IF $GET(IBSNA)'="ALL"
Begin DoDot:2
+10 SET X=X_"/ PATIENTS FROM '"_$SELECT(IBSNF="":"FIRST",1:IBSNF)_"' TO '"
+11 SET X=X_$SELECT(IBSNL="zzzzz":"LAST",1:IBSNL)_"' "
End DoDot:2
+12 IF $GET(IBSAM)
SET X=X_"/ MINIMUM BALANCE: $"_$FNUMBER(IBSAM,",",2)_" "
End DoDot:1
+13 SET X=X_"/ RECEIVABLES REFERRED TO RC "_$SELECT('IBSRC:"NOT ",1:"")_"INCLUDED"
+14 SET $EXTRACT(X,1,2)=""
+15 FOR I=1:1
WRITE !,$EXTRACT(X,1,80)
SET X=$EXTRACT(X,81,999)
IF X=""
QUIT
+16 ;
+17 QUIT
+18 ;
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 ;
OSUM ; Print Overall Summary
+1 ;Undeclared Input Parameters
+2 ; IB - Array of data gathered
+3 ;
+4 NEW IBS,IBCAT,IBDLT,IBI,IBDATA
+5 SET IBS=$SELECT(IBSRC:8,1:7)
+6 SET IB("OSUM")=0
SET IB("OSUM",9)="0^0"
+7 SET IBCAT=""
+8 FOR
SET IBCAT=$ORDER(IB(IBCAT))
if 'IBCAT
QUIT
Begin DoDot:1
+9 SET IBDLT=0
+10 FOR
SET IBDLT=$ORDER(IB(IBCAT,IBDLT))
if 'IBDLT
QUIT
Begin DoDot:2
+11 SET IBI=0
+12 FOR
SET IBI=$ORDER(IB(IBCAT,IBDLT,IBI))
if IBI>8
QUIT
Begin DoDot:3
+13 SET IBDATA=$GET(IB(IBCAT,IBDLT,IBI))
+14 SET $PIECE(IB("OSUM",IBI),U,1)=$PIECE($GET(IB("OSUM",IBI)),U,1)+$PIECE(IBDATA,U,1)
+15 SET $PIECE(IB("OSUM",IBI),U,2)=$PIECE($GET(IB("OSUM",IBI)),U,2)+$PIECE(IBDATA,U,2)
+16 SET $PIECE(IB("OSUM",9),U,1)=$PIECE(IB("OSUM",9),U,1)+$PIECE(IBDATA,U,1)
+17 SET $PIECE(IB("OSUM",9),U,2)=$PIECE(IB("OSUM",9),U,2)+$PIECE(IBDATA,U,2)
End DoDot:3
End DoDot:2
End DoDot:1
+18 ;
+19 ; - Print Custom Header
+20 DO OSHDR
+21 NEW X,Y,Z,I
+22 SET Y=$PIECE(IB("OSUM",9),U,2)
+23 FOR I=1:1:IBS,9
SET X=$PIECE($TEXT(CATN+I),";;",2,99)
Begin DoDot:1
+24 ; IB*2.0*715
IF $GET(IB("OSUM",I))=""
QUIT
+25 if I=9
WRITE !
WRITE !,X,?30,$JUSTIFY($PIECE(IB("OSUM",I),U),6)
+26 ; IB*2.0*705
WRITE " (",$JUSTIFY($SELECT(+IB("OSUM",9)'=0:$PIECE(IB("OSUM",I),U)/+IB("OSUM",9)*100,1:0),0,$SELECT(I=9:0,1:2)),"%)"
+27 SET Z=$FNUMBER($PIECE(IB("OSUM",I),U,2),",",2)
+28 WRITE ?52,$JUSTIFY($SELECT(I=1!(I=9):"$",1:"")_Z,15)
+29 WRITE " (",$JUSTIFY($SELECT('Y:0,1:$PIECE(IB("OSUM",I),U,2)/Y*100),0,$SELECT(I=9:0,1:2)),"%)"
End DoDot:1
+30 DO PAUSE
+31 ;
OSUMQ QUIT
+1 ;
OSHDR ; - Custom Header for Overall Summary
+1 IF '$DATA(IBRUN)
Begin DoDot:1
+2 DO NOW^%DTC
SET IBRUN=$$DAT2^IBOUTL(%)
End DoDot:1
+3 if '$GET(IBPAG)
WRITE !
IF $EXTRACT(IOST,1,2)="C-"!$GET(IBPAG)
WRITE @IOF,*13
+4 SET IBPAG=$GET(IBPAG)+1
+5 WRITE "FIRST PARTY FOLLOW-UP SUMMARY REPORT Run Date: ",IBRUN
+6 WRITE ?71,"Page: ",$JUSTIFY(IBPAG,3)
+7 SET X="Overall Summary"
+8 SET X=X_"/ RECEIVABLES REFERRED TO RC "_$SELECT('IBSRC:"NOT ",1:"")_"INCLUDED"
+9 FOR I=1:1
WRITE !,$EXTRACT(X,1,80)
SET X=$EXTRACT(X,81,999)
IF X=""
QUIT
+10 WRITE !!!!?(80-$LENGTH(X)\2),X,!?(80-$LENGTH(X)\2),$$DASH^IBJDF43($LENGTH(X)),!!
+11 WRITE "AR Category",?31,"# Receivables",?52,"Total Outstanding Balance",!
+12 WRITE "-----------",?31,"-------------",?52,"-------------------------",!
+13 QUIT
+14 ;
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 ;;Referred to Regional Counsel
+9 ;;Total First Party Receivables
