IBJDF52 ;ALB/RB - CHAMPVA/TRICARE FOLLOW-UP REPORT (PRINT) ;15-APR-00
;;2.0;INTEGRATED BILLING;**123,159,240,618,739**;21-MAR-94;Build 3
;;Per VHA Directive 6402, this routine should not be modified.
;
EN ; - Print the Follow-up report.
S (IBQ,IBFLG)=0 D NOW^%DTC S IBRUN=$$DAT2^IBOUTL(%) G:IBRPT="S" SUM
I 'IBSD D DET(0) G SUM
I IBSEL["1" D DET(0)
S IBDIV=""
F S IBDIV=$O(VAUTD(IBDIV)) Q:IBDIV="" D DET(IBDIV) Q:IBQ
;
SUM I 'IBQ D PRT^IBJDF53 ; Print summary.
ENQ K I,IB0,IBC,IBCAT,IBCD,IBC1,IBC2,IBDIV,IBFLG,IBIN,IBKEY,IBN,IBPT,IBPAG
K IBQ,IBRUN,IBTYP,%
Q
;
DET(IBDIV) ; - Print report for a specific division.
; Input: IBDIV=Pointer to the division in file #40.8 & variable IBSEL1
S IBCAT=0
F S IBCAT=$O(IBCAT(IBCAT)) Q:'IBCAT D Q:IBQ
. S (IB0,IBIN,IBKEY,IBTYP)=""
. F IBTYP=1:1:4 D:IBSEL1[IBTYP Q:IBQ
. . I IBDIV,IBCAT=31 Q
. . I IBSD,'IBDIV,IBCAT'=31 Q
. . I '$D(^TMP("IBJDF5",$J,IBDIV,IBCAT,IBTYP)) D HDR1,NAR,PAUSE Q
. . S IBFLG=0
. . F S IBIN=$O(^TMP("IBJDF5",$J,IBDIV,IBCAT,IBTYP,IBIN)) Q:IBIN="" D Q:IBQ
. . . D HDR1,HDR2 Q:IBQ
. . . F S IBKEY=$O(^TMP("IBJDF5",$J,IBDIV,IBCAT,IBTYP,IBIN,IBKEY)) Q:IBKEY="" D Q:IBQ
. . . . S IBPT=$G(^TMP("IBJDF5",$J,IBDIV,IBCAT,IBTYP,IBIN,IBKEY))
. . . . D WPAT
. . . . F S IB0=$O(^TMP("IBJDF5",$J,IBDIV,IBCAT,IBTYP,IBIN,IBKEY,IB0)) Q:IB0="" D Q:IBQ
. . . . . S IBN=$G(^TMP("IBJDF5",$J,IBDIV,IBCAT,IBTYP,IBIN,IBKEY,IB0))
. . . . . I $Y>(IOSL-3) D PAUSE Q:IBQ D HDR1,HDR2 Q:IBQ D WPAT
. . . . . W ?59,IB0,?71,$$DAT1^IBOUTL(+IBN)
. . . . . W ?80,$$DAT1^IBOUTL($P(IBN,U,2))
. . . . . W ?89,$$DAT1^IBOUTL($P(IBN,U,3)),?98,$J($P(IBN,U,4),8,2)
. . . . . W ?107,$J($P(IBN,U,5),8,2),?116,$P(IBN,U,6),!
. . . . . ;
. . . . . ; - Display bill comment history, if necessary.
. . . . . I IBSH D WCOM
. . . D:'IBQ PAUSE
;
DETQ 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
;
HDR1 ; - Write the primary report header.
N FLG,X,IBCATNM
;
S FLG=1 I $G(IBFLG) S FLG=0
I '$G(IBFLG),$E(IOST,1,2)="C-"!$G(IBPAG) D
. W @IOF,*13 S IBFLG=0
. S IBPAG=$G(IBPAG)+1
I $G(IBFLG) D
. I $Y'>(IOSL-11) W !!! Q
. W @IOF,*13 S IBPAG=$G(IBPAG)+1,FLG=1
I '$G(IBPAG) S IBPAG=1
I IBDIV!FLG D
. W "CHAMPVA/TRICARE Follow-Up Report"
. I IBDIV W " for ",$P($G(^DG(40.8,IBDIV,0)),U)," "
. W ?75,"Run Date: ",IBRUN W:FLG ?123,"Page: ",$J(IBPAG,3)
S IBCATNM=$$ARCAT^IBJDF62(IBCAT) ; patch IB*2.0*618
S X="ALL ACTIVE "_$G(IBCATNM)_" RECEIVABLES " ; patch IB*2.0*618
I IBTYP'=4 S X=X_"("_$G(IBTPR(IBTYP))_") "
I IBSMN S X=X_"OVER "_IBSMN_" AND UNDER "_IBSMX_" DAYS OLD "
S X=X_" / BY PATIENT NAME" ;IB*2.0*739
S X=X_" ("_$S($G(IBSNA)="ALL":"ALL",1:"From "_$S(IBSNF="":"FIRST",1:IBSNF)_" to "_$S(IBSNL="zzzzz":"LAST",1:IBSNL))_")"
S X=X_" / "_$S('IBSAM:"NO ",1:"")_"MINIMUM BALANCE"
I IBSAM S X=X_$S(IBSAM:": $"_$FN(IBSAM,",",2),1:"")
S X=X_" / "_$S('IBSH:"NO ",IBSH1="A":"ALL ",1:"ONLY ")_"COMMENTS"
S X=X_$S($G(IBSH2):" NOT OLDER THAN "_IBSH2_" DAYS",1:"")
S X=X_" / '*' AFTER THE PATIENT NAME = VA EMPLOYEE"
F I=1:1 W !,$E(X,1,132) S X=$E(X,133,999) I X="" Q
;
W !!?71,"Dte Bill",?98,"Original Current"
W !,"Patient",?26,"Age" W:IBCAT'=31 ?43,"Other Insurance" ;IB*2.0*739
W ?59,"Bill Number Prepared",?80,"Bill Frm Bill To Amount Balance"
W:IBCAT'=31 ?116,"Subscriber ID"
W !,$$DASH(IOM),!
S IBQ=$$STOP^IBOUTL("CHAMPVA/TRICARE Follow-Up Report")
Q
;
HDR2 ; - Write the insurance company sub-header.
N X,X13
I $P(IBIN,"@@")'=0 W ?2,"Carrier: ",$P(IBIN,"@@")
S X=$G(^DIC(36,+$P(IBIN,"@@",2),.11)),X13=$G(^(.13))
I X]"" D
.W ", ",$P(X,U),", ",$P(X,U,4),", ",$P($G(^DIC(5,+$P(X,U,5),0)),U,2)," ",$P(X,U,6)
.I $P(X13,U,2)]"" W " Billing Phone: ",$P(X13,U,2) Q
.I $P(X13,U)]"" W " Main Phone: ",$P(X13,U)
;
Q
;
NAR ; - Write detail line (if '$D).
S IBFLG=1
W !!,"There are no active receivables for the parameters above."
Q
;
WPAT ; - Write patient data.
W !,$P(IBPT,U),?26,$J($P(IBPT,U,2),3),?43,$P(IBPT,U,4) ;IB*2.0*739
;W ?43,$P(IBPT,U,4)
Q
;
WCOM ; - Write bill comments
N CONT,DIWL,DIWR,IBC,IBCD,IBC1,IBC2,X
;
S (IBC,CONT,IBCD)=0,IBC1="",DIWL=1,DIWR=104 K ^UTILITY($J)
F S IBC=$O(^TMP("IBJDF5",$J,IBDIV,IBCAT,IBTYP,IBIN,IBKEY,IB0,IBC)) Q:'IBC D Q:IBQ
. F S IBC1=$O(^TMP("IBJDF5",$J,IBDIV,IBCAT,IBTYP,IBIN,IBKEY,IB0,IBC,IBC1)) Q:IBC1="" D Q:IBQ
. . S IBC2=^TMP("IBJDF5",$J,IBDIV,IBCAT,IBTYP,IBIN,IBKEY,IB0,IBC,IBC1)
. . I 'IBC1 S IBCD=IBC2 D WCD Q
. . I $Y>(IOSL-4) D WCPB Q:IBQ
. . S X=IBC2 I $E(X)=" ",$L(X)>1 S $E(X)=""
. . D ^DIWP
. . I 'CONT,$L(IBC2)<66 D WCTXT Q
. . S CONT=$L(IBC2)>65
. . I '$O(^TMP("IBJDF5",$J,IBDIV,IBCAT,IBTYP,IBIN,IBKEY,IB0,IBC,IBC1)) D
. . . D:$D(^UTILITY($J,"W")) WCTXT
K ^UTILITY($J,"W")
Q
;
WCTXT ; - Write comment text
N LIN,WLIN
S LIN=""
F S LIN=$O(^UTILITY($J,"W",1,LIN)) Q:LIN="" D Q:IBQ
. S WLIN=$G(^UTILITY($J,"W",1,LIN,0))
. I $Y>(IOSL-4) D WCPB Q:IBQ
. W:WLIN'="" ?26,WLIN,!
K ^UTILITY($J,"W")
Q
;
WCPB ; - Page Break in the middle of Comments
;
D PAUSE Q:IBQ D HDR1,HDR2 Q:IBQ
W ! D WPAT D WCD W:IBC1>1 ?26,"(continued)",!
Q
;
WCD ; - Write comment date.
W !?2,"Comment Date: ",$$DAT1^IBOUTL(IBCD)
Q
;
SSN(X) ; - Format the SSN.
Q $S(X:$E(X,1,3)_"-"_$E(X,4,5)_"-"_$E(X,6,10),1:"")
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBJDF52 5525 printed Sep 23, 2025@19:59:11 Page 2
IBJDF52 ;ALB/RB - CHAMPVA/TRICARE FOLLOW-UP REPORT (PRINT) ;15-APR-00
+1 ;;2.0;INTEGRATED BILLING;**123,159,240,618,739**;21-MAR-94;Build 3
+2 ;;Per VHA Directive 6402, this routine should not be modified.
+3 ;
EN ; - Print the Follow-up report.
+1 SET (IBQ,IBFLG)=0
DO NOW^%DTC
SET IBRUN=$$DAT2^IBOUTL(%)
if IBRPT="S"
GOTO SUM
+2 IF 'IBSD
DO DET(0)
GOTO SUM
+3 IF IBSEL["1"
DO DET(0)
+4 SET IBDIV=""
+5 FOR
SET IBDIV=$ORDER(VAUTD(IBDIV))
if IBDIV=""
QUIT
DO DET(IBDIV)
if IBQ
QUIT
+6 ;
SUM ; Print summary.
IF 'IBQ
DO PRT^IBJDF53
ENQ KILL I,IB0,IBC,IBCAT,IBCD,IBC1,IBC2,IBDIV,IBFLG,IBIN,IBKEY,IBN,IBPT,IBPAG
+1 KILL IBQ,IBRUN,IBTYP,%
+2 QUIT
+3 ;
DET(IBDIV) ; - Print report for a specific division.
+1 ; Input: IBDIV=Pointer to the division in file #40.8 & variable IBSEL1
+2 SET IBCAT=0
+3 FOR
SET IBCAT=$ORDER(IBCAT(IBCAT))
if 'IBCAT
QUIT
Begin DoDot:1
+4 SET (IB0,IBIN,IBKEY,IBTYP)=""
+5 FOR IBTYP=1:1:4
if IBSEL1[IBTYP
Begin DoDot:2
+6 IF IBDIV
IF IBCAT=31
QUIT
+7 IF IBSD
IF 'IBDIV
IF IBCAT'=31
QUIT
+8 IF '$DATA(^TMP("IBJDF5",$JOB,IBDIV,IBCAT,IBTYP))
DO HDR1
DO NAR
DO PAUSE
QUIT
+9 SET IBFLG=0
+10 FOR
SET IBIN=$ORDER(^TMP("IBJDF5",$JOB,IBDIV,IBCAT,IBTYP,IBIN))
if IBIN=""
QUIT
Begin DoDot:3
+11 DO HDR1
DO HDR2
if IBQ
QUIT
+12 FOR
SET IBKEY=$ORDER(^TMP("IBJDF5",$JOB,IBDIV,IBCAT,IBTYP,IBIN,IBKEY))
if IBKEY=""
QUIT
Begin DoDot:4
+13 SET IBPT=$GET(^TMP("IBJDF5",$JOB,IBDIV,IBCAT,IBTYP,IBIN,IBKEY))
+14 DO WPAT
+15 FOR
SET IB0=$ORDER(^TMP("IBJDF5",$JOB,IBDIV,IBCAT,IBTYP,IBIN,IBKEY,IB0))
if IB0=""
QUIT
Begin DoDot:5
+16 SET IBN=$GET(^TMP("IBJDF5",$JOB,IBDIV,IBCAT,IBTYP,IBIN,IBKEY,IB0))
+17 IF $Y>(IOSL-3)
DO PAUSE
if IBQ
QUIT
DO HDR1
DO HDR2
if IBQ
QUIT
DO WPAT
+18 WRITE ?59,IB0,?71,$$DAT1^IBOUTL(+IBN)
+19 WRITE ?80,$$DAT1^IBOUTL($PIECE(IBN,U,2))
+20 WRITE ?89,$$DAT1^IBOUTL($PIECE(IBN,U,3)),?98,$JUSTIFY($PIECE(IBN,U,4),8,2)
+21 WRITE ?107,$JUSTIFY($PIECE(IBN,U,5),8,2),?116,$PIECE(IBN,U,6),!
+22 ;
+23 ; - Display bill comment history, if necessary.
+24 IF IBSH
DO WCOM
End DoDot:5
if IBQ
QUIT
End DoDot:4
if IBQ
QUIT
+25 if 'IBQ
DO PAUSE
End DoDot:3
if IBQ
QUIT
End DoDot:2
if IBQ
QUIT
End DoDot:1
if IBQ
QUIT
+26 ;
DETQ QUIT
+1 ;
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 ;
HDR1 ; - Write the primary report header.
+1 NEW FLG,X,IBCATNM
+2 ;
+3 SET FLG=1
IF $GET(IBFLG)
SET FLG=0
+4 IF '$GET(IBFLG)
IF $EXTRACT(IOST,1,2)="C-"!$GET(IBPAG)
Begin DoDot:1
+5 WRITE @IOF,*13
SET IBFLG=0
+6 SET IBPAG=$GET(IBPAG)+1
End DoDot:1
+7 IF $GET(IBFLG)
Begin DoDot:1
+8 IF $Y'>(IOSL-11)
WRITE !!!
QUIT
+9 WRITE @IOF,*13
SET IBPAG=$GET(IBPAG)+1
SET FLG=1
End DoDot:1
+10 IF '$GET(IBPAG)
SET IBPAG=1
+11 IF IBDIV!FLG
Begin DoDot:1
+12 WRITE "CHAMPVA/TRICARE Follow-Up Report"
+13 IF IBDIV
WRITE " for ",$PIECE($GET(^DG(40.8,IBDIV,0)),U)," "
+14 WRITE ?75,"Run Date: ",IBRUN
if FLG
WRITE ?123,"Page: ",$JUSTIFY(IBPAG,3)
End DoDot:1
+15 ; patch IB*2.0*618
SET IBCATNM=$$ARCAT^IBJDF62(IBCAT)
+16 ; patch IB*2.0*618
SET X="ALL ACTIVE "_$GET(IBCATNM)_" RECEIVABLES "
+17 IF IBTYP'=4
SET X=X_"("_$GET(IBTPR(IBTYP))_") "
+18 IF IBSMN
SET X=X_"OVER "_IBSMN_" AND UNDER "_IBSMX_" DAYS OLD "
+19 ;IB*2.0*739
SET X=X_" / BY PATIENT NAME"
+20 SET X=X_" ("_$SELECT($GET(IBSNA)="ALL":"ALL",1:"From "_$SELECT(IBSNF="":"FIRST",1:IBSNF)_" to "_$SELECT(IBSNL="zzzzz":"LAST",1:IBSNL))_")"
+21 SET X=X_" / "_$SELECT('IBSAM:"NO ",1:"")_"MINIMUM BALANCE"
+22 IF IBSAM
SET X=X_$SELECT(IBSAM:": $"_$FNUMBER(IBSAM,",",2),1:"")
+23 SET X=X_" / "_$SELECT('IBSH:"NO ",IBSH1="A":"ALL ",1:"ONLY ")_"COMMENTS"
+24 SET X=X_$SELECT($GET(IBSH2):" NOT OLDER THAN "_IBSH2_" DAYS",1:"")
+25 SET X=X_" / '*' AFTER THE PATIENT NAME = VA EMPLOYEE"
+26 FOR I=1:1
WRITE !,$EXTRACT(X,1,132)
SET X=$EXTRACT(X,133,999)
IF X=""
QUIT
+27 ;
+28 WRITE !!?71,"Dte Bill",?98,"Original Current"
+29 ;IB*2.0*739
WRITE !,"Patient",?26,"Age"
if IBCAT'=31
WRITE ?43,"Other Insurance"
+30 WRITE ?59,"Bill Number Prepared",?80,"Bill Frm Bill To Amount Balance"
+31 if IBCAT'=31
WRITE ?116,"Subscriber ID"
+32 WRITE !,$$DASH(IOM),!
+33 SET IBQ=$$STOP^IBOUTL("CHAMPVA/TRICARE Follow-Up Report")
+34 QUIT
+35 ;
HDR2 ; - Write the insurance company sub-header.
+1 NEW X,X13
+2 IF $PIECE(IBIN,"@@")'=0
WRITE ?2,"Carrier: ",$PIECE(IBIN,"@@")
+3 SET X=$GET(^DIC(36,+$PIECE(IBIN,"@@",2),.11))
SET X13=$GET(^(.13))
+4 IF X]""
Begin DoDot:1
+5 WRITE ", ",$PIECE(X,U),", ",$PIECE(X,U,4),", ",$PIECE($GET(^DIC(5,+$PIECE(X,U,5),0)),U,2)," ",$PIECE(X,U,6)
+6 IF $PIECE(X13,U,2)]""
WRITE " Billing Phone: ",$PIECE(X13,U,2)
QUIT
+7 IF $PIECE(X13,U)]""
WRITE " Main Phone: ",$PIECE(X13,U)
End DoDot:1
+8 ;
+9 QUIT
+10 ;
NAR ; - Write detail line (if '$D).
+1 SET IBFLG=1
+2 WRITE !!,"There are no active receivables for the parameters above."
+3 QUIT
+4 ;
WPAT ; - Write patient data.
+1 ;IB*2.0*739
WRITE !,$PIECE(IBPT,U),?26,$JUSTIFY($PIECE(IBPT,U,2),3),?43,$PIECE(IBPT,U,4)
+2 ;W ?43,$P(IBPT,U,4)
+3 QUIT
+4 ;
WCOM ; - Write bill comments
+1 NEW CONT,DIWL,DIWR,IBC,IBCD,IBC1,IBC2,X
+2 ;
+3 SET (IBC,CONT,IBCD)=0
SET IBC1=""
SET DIWL=1
SET DIWR=104
KILL ^UTILITY($JOB)
+4 FOR
SET IBC=$ORDER(^TMP("IBJDF5",$JOB,IBDIV,IBCAT,IBTYP,IBIN,IBKEY,IB0,IBC))
if 'IBC
QUIT
Begin DoDot:1
+5 FOR
SET IBC1=$ORDER(^TMP("IBJDF5",$JOB,IBDIV,IBCAT,IBTYP,IBIN,IBKEY,IB0,IBC,IBC1))
if IBC1=""
QUIT
Begin DoDot:2
+6 SET IBC2=^TMP("IBJDF5",$JOB,IBDIV,IBCAT,IBTYP,IBIN,IBKEY,IB0,IBC,IBC1)
+7 IF 'IBC1
SET IBCD=IBC2
DO WCD
QUIT
+8 IF $Y>(IOSL-4)
DO WCPB
if IBQ
QUIT
+9 SET X=IBC2
IF $EXTRACT(X)=" "
IF $LENGTH(X)>1
SET $EXTRACT(X)=""
+10 DO ^DIWP
+11 IF 'CONT
IF $LENGTH(IBC2)<66
DO WCTXT
QUIT
+12 SET CONT=$LENGTH(IBC2)>65
+13 IF '$ORDER(^TMP("IBJDF5",$JOB,IBDIV,IBCAT,IBTYP,IBIN,IBKEY,IB0,IBC,IBC1))
Begin DoDot:3
+14 if $DATA(^UTILITY($JOB,"W"))
DO WCTXT
End DoDot:3
End DoDot:2
if IBQ
QUIT
End DoDot:1
if IBQ
QUIT
+15 KILL ^UTILITY($JOB,"W")
+16 QUIT
+17 ;
WCTXT ; - Write comment text
+1 NEW LIN,WLIN
+2 SET LIN=""
+3 FOR
SET LIN=$ORDER(^UTILITY($JOB,"W",1,LIN))
if LIN=""
QUIT
Begin DoDot:1
+4 SET WLIN=$GET(^UTILITY($JOB,"W",1,LIN,0))
+5 IF $Y>(IOSL-4)
DO WCPB
if IBQ
QUIT
+6 if WLIN'=""
WRITE ?26,WLIN,!
End DoDot:1
if IBQ
QUIT
+7 KILL ^UTILITY($JOB,"W")
+8 QUIT
+9 ;
WCPB ; - Page Break in the middle of Comments
+1 ;
+2 DO PAUSE
if IBQ
QUIT
DO HDR1
DO HDR2
if IBQ
QUIT
+3 WRITE !
DO WPAT
DO WCD
if IBC1>1
WRITE ?26,"(continued)",!
+4 QUIT
+5 ;
WCD ; - Write comment date.
+1 WRITE !?2,"Comment Date: ",$$DAT1^IBOUTL(IBCD)
+2 QUIT
+3 ;
SSN(X) ; - Format the SSN.
+1 QUIT $SELECT(X:$EXTRACT(X,1,3)_"-"_$EXTRACT(X,4,5)_"-"_$EXTRACT(X,6,10),1:"")
