IBJDF12 ;ALB/CPM - THIRD PARTY FOLLOW-UP REPORT (PRINT) ;10-JAN-97
;;2.0;INTEGRATED BILLING;**69,118,128,123,204,205,554,618,663,739**;21-MAR-94;Build 3
;Per VA Directive 6402, this routine should not be modified.
;
EN ; - Print the Follow-up report.
S IBQ=0 D NOW^%DTC S IBRUN=$$DAT2^IBOUTL(%)
I 'IBSD D DET(0),PAUSE:'IBQ G ENQ
S IBDIV=0 F S IBDIV=$O(VAUTD(IBDIV)) Q:'IBDIV D DET(IBDIV),PAUSE:'IBQ Q:IBQ
;
ENQ K IBPAG,IBRUN,IBDIV,IBWIN,IBWPT,IBWDP,IBQ,IBH,IBZ,IBC,IBC1,IBC2,IBCD,%
Q
;
DET(IBDIV) ; - Print report for a specific division.
; Input: IBDIV=Pointer to the division in file #40.8
S IBPAG=0
I '$D(^TMP("IBJDF1",$J,IBDIV)) D G DETQ
.S IBSEL=5 D HDR1 I IBQ Q
.W !!,"There are no active receivables "
.I IBSMN W IBSMN,$S(IBSMX>IBSMN:" to "_IBSMX,1:"")," days old "
.I IBDIV W "for this division."
;
S IBTYP=0 F S IBTYP=$O(^TMP("IBJDF1",$J,IBDIV,IBTYP)) Q:'IBTYP D Q:IBQ
.D HDR1 I IBQ Q
.S IBWIN="" F S IBWIN=$O(^TMP("IBJDF1",$J,IBDIV,IBTYP,IBWIN)) Q:IBWIN="" D Q:IBQ
..I $Y>(IOSL-5) D PAUSE Q:IBQ D HDR1 Q:IBQ
..D HDR2
..S IBWPT="" F S IBWPT=$O(^TMP("IBJDF1",$J,IBDIV,IBTYP,IBWIN,IBWPT)) Q:IBWPT="" D Q:IBQ
...S (IBH,IBWDP)="" F S IBWDP=$O(^TMP("IBJDF1",$J,IBDIV,IBTYP,IBWIN,IBWPT,IBWDP)) W:IBWDP="" ! Q:IBWDP="" S IBZ=$G(^(IBWDP)) D Q:IBQ
....I $Y>(IOSL-3) D PAUSE Q:IBQ D HDR1,HDR2 Q:IBQ S IBH=0
....W ! I 'IBH D WPAT S IBH=1
....D WBIL Q:IBQ
....;
....; - Display bill comment history, if necessary.
....I IBSH D WCOM Q:IBQ
;
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 I $D(DIRUT)!($D(DUOUT)) S IBQ=1
Q
;
HDR1 ; - Write the primary report header.
I $E(IOST,1,2)="C-"!(IBPAG) W @IOF,*13
S IBPAG=IBPAG+1
W "Third Party Follow-Up Report"_$S(IBSDATE="D":" ( date of care )",1:" ( days in AR )")
I IBDIV W " for ",$P($G(^DG(40.8,IBDIV,0)),U)
W ?88,"Run Date: ",IBRUN,?123,"Page: ",$J(IBPAG,3)
; IB*2*554/DRF - Add NON-VA to header/IB*2.0*618 Changed to Community Care
W !,"All active ",$S(IBSEL[1:"INPATIENT ",IBTYP[2:"OUTPATIENT ",IBSEL[3:"RX REFILL ",IBSEL[4:"COMMUNITY CARE ",1:""),"receivables "
I IBSMN W IBSMN,$S(IBSMX>IBSMN:" to "_IBSMX,1:"")," days old "
I IBSAM W "with balances of at least $",IBSAM
W !!?37,"Other",?51,"Date",?92,"Original",?103,"Current"
W !,"Patient (Age)",?37,"Carrier",?51,"Prepared",?61,"Bill No.",?73,"Bill Fr. Bill To",?94,"Amount",?103,"Balance",?114,"Subscriber ID" ;IB*2.0*739
W !,$$DASH(IOM)
I IBSRC W !,"Note: '(n)' or '(*)' next to balance means AR was referred to Regional Counsel"
W ! S IBQ=$$STOP^IBOUTL("Third Party Follow-Up Report")
Q
;
HDR2 ; - Write the insurance company sub-header.
N X,X13 W !?3,"Carrier: ",$P(IBWIN,"@@")
S X=$G(^DIC(36,+$P(IBWIN,"@@",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
;
WPAT ; - Write patient data.
W $P(IBZ,U),?37,$P(IBZ,U,3) ;IB*2.0*739
Q
;
WBIL ; - Write bill data.
W ?51,$$DAT1^IBOUTL(+IBWDP),?60,$P(IBWDP,"@@",2)
W ?73,$$DAT1^IBOUTL($P(IBZ,U,4)),?82,$$DAT1^IBOUTL($P(IBZ,U,5))
W ?90,$J($P(IBZ,U,6),10,2),?100,$J(+$P(IBZ,U,7),10,2)
I $P($P(IBZ,U,7),"~",2) D
. I $P($P(IBZ,U,7),"~",2)<6 W "(",$P($P(IBZ,U,7),"~",2),")" Q
. W "(*)"
I $P(IBZ,U,8)'=$P(IBZ,U,2) W ?114,$E($P(IBZ,U,8),1,18) ;Only print if ID is not SSN IB*2.0*739
Q
;
WCOM ; - Write the comments
N CONT,DIWL,DIWR,IBC,IBC1,IBC2,X
;
S (IBC,CONT)=0,DIWL=1,DIWR=104 K ^UTILITY($J,"W")
F S IBC=$O(^TMP("IBJDF1",$J,IBDIV,IBTYP,IBWIN,IBWPT,IBWDP,IBC)) Q:'IBC D Q:IBQ
. I $Y>(IOSL-4) D PAUSE Q:IBQ D HDR1,HDR2 Q:IBQ W ! D WPAT,WBIL
. S IBC1=""
. F S IBC1=$O(^TMP("IBJDF1",$J,IBDIV,IBTYP,IBWIN,IBWPT,IBWDP,IBC,IBC1)) Q:IBC1="" D Q:IBQ
. . S IBC2=^TMP("IBJDF1",$J,IBDIV,IBTYP,IBWIN,IBWPT,IBWDP,IBC,IBC1)
. . I $Y>(IOSL-4) D WCPB Q:IBQ
. . I 'IBC1 S IBCD=IBC2 D WCD Q
. . 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("IBJDF1",$J,IBDIV,IBTYP,IBWIN,IBWPT,IBWDP,IBC,IBC1)) D
. . . D:$D(^UTILITY($J,"W")) WCTXT
K ^UTILITY($J,"W")
Q
;
WCD ; - Write comment date.
W !?2,"Comment Date: ",$$DAT1^IBOUTL(IBCD)
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,WBIL D WCD W:IBC1>1 ?26,"(continued)",!
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[HIBJDF12 4959 printed Oct 16, 2024@18:23:23 Page 2
IBJDF12 ;ALB/CPM - THIRD PARTY FOLLOW-UP REPORT (PRINT) ;10-JAN-97
+1 ;;2.0;INTEGRATED BILLING;**69,118,128,123,204,205,554,618,663,739**;21-MAR-94;Build 3
+2 ;Per VA Directive 6402, this routine should not be modified.
+3 ;
EN ; - Print the Follow-up report.
+1 SET IBQ=0
DO NOW^%DTC
SET IBRUN=$$DAT2^IBOUTL(%)
+2 IF 'IBSD
DO DET(0)
if 'IBQ
DO PAUSE
GOTO ENQ
+3 SET IBDIV=0
FOR
SET IBDIV=$ORDER(VAUTD(IBDIV))
if 'IBDIV
QUIT
DO DET(IBDIV)
if 'IBQ
DO PAUSE
if IBQ
QUIT
+4 ;
ENQ KILL IBPAG,IBRUN,IBDIV,IBWIN,IBWPT,IBWDP,IBQ,IBH,IBZ,IBC,IBC1,IBC2,IBCD,%
+1 QUIT
+2 ;
DET(IBDIV) ; - Print report for a specific division.
+1 ; Input: IBDIV=Pointer to the division in file #40.8
+2 SET IBPAG=0
+3 IF '$DATA(^TMP("IBJDF1",$JOB,IBDIV))
Begin DoDot:1
+4 SET IBSEL=5
DO HDR1
IF IBQ
QUIT
+5 WRITE !!,"There are no active receivables "
+6 IF IBSMN
WRITE IBSMN,$SELECT(IBSMX>IBSMN:" to "_IBSMX,1:"")," days old "
+7 IF IBDIV
WRITE "for this division."
End DoDot:1
GOTO DETQ
+8 ;
+9 SET IBTYP=0
FOR
SET IBTYP=$ORDER(^TMP("IBJDF1",$JOB,IBDIV,IBTYP))
if 'IBTYP
QUIT
Begin DoDot:1
+10 DO HDR1
IF IBQ
QUIT
+11 SET IBWIN=""
FOR
SET IBWIN=$ORDER(^TMP("IBJDF1",$JOB,IBDIV,IBTYP,IBWIN))
if IBWIN=""
QUIT
Begin DoDot:2
+12 IF $Y>(IOSL-5)
DO PAUSE
if IBQ
QUIT
DO HDR1
if IBQ
QUIT
+13 DO HDR2
+14 SET IBWPT=""
FOR
SET IBWPT=$ORDER(^TMP("IBJDF1",$JOB,IBDIV,IBTYP,IBWIN,IBWPT))
if IBWPT=""
QUIT
Begin DoDot:3
+15 SET (IBH,IBWDP)=""
FOR
SET IBWDP=$ORDER(^TMP("IBJDF1",$JOB,IBDIV,IBTYP,IBWIN,IBWPT,IBWDP))
if IBWDP=""
WRITE !
if IBWDP=""
QUIT
SET IBZ=$GET(^(IBWDP))
Begin DoDot:4
+16 IF $Y>(IOSL-3)
DO PAUSE
if IBQ
QUIT
DO HDR1
DO HDR2
if IBQ
QUIT
SET IBH=0
+17 WRITE !
IF 'IBH
DO WPAT
SET IBH=1
+18 DO WBIL
if IBQ
QUIT
+19 ;
+20 ; - Display bill comment history, if necessary.
+21 IF IBSH
DO WCOM
if IBQ
QUIT
End DoDot:4
if IBQ
QUIT
End DoDot:3
if IBQ
QUIT
End DoDot:2
if IBQ
QUIT
End DoDot:1
if IBQ
QUIT
+22 ;
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 IF $EXTRACT(IOST,1,2)="C-"!(IBPAG)
WRITE @IOF,*13
+2 SET IBPAG=IBPAG+1
+3 WRITE "Third Party Follow-Up Report"_$SELECT(IBSDATE="D":" ( date of care )",1:" ( days in AR )")
+4 IF IBDIV
WRITE " for ",$PIECE($GET(^DG(40.8,IBDIV,0)),U)
+5 WRITE ?88,"Run Date: ",IBRUN,?123,"Page: ",$JUSTIFY(IBPAG,3)
+6 ; IB*2*554/DRF - Add NON-VA to header/IB*2.0*618 Changed to Community Care
+7 WRITE !,"All active ",$SELECT(IBSEL[1:"INPATIENT ",IBTYP[2:"OUTPATIENT ",IBSEL[3:"RX REFILL ",IBSEL[4:"COMMUNITY CARE ",1:""),"receivables "
+8 IF IBSMN
WRITE IBSMN,$SELECT(IBSMX>IBSMN:" to "_IBSMX,1:"")," days old "
+9 IF IBSAM
WRITE "with balances of at least $",IBSAM
+10 WRITE !!?37,"Other",?51,"Date",?92,"Original",?103,"Current"
+11 ;IB*2.0*739
WRITE !,"Patient (Age)",?37,"Carrier",?51,"Prepared",?61,"Bill No.",?73,"Bill Fr. Bill To",?94,"Amount",?103,"Balance",?114,"Subscriber ID"
+12 WRITE !,$$DASH(IOM)
+13 IF IBSRC
WRITE !,"Note: '(n)' or '(*)' next to balance means AR was referred to Regional Counsel"
+14 WRITE !
SET IBQ=$$STOP^IBOUTL("Third Party Follow-Up Report")
+15 QUIT
+16 ;
HDR2 ; - Write the insurance company sub-header.
+1 NEW X,X13
WRITE !?3,"Carrier: ",$PIECE(IBWIN,"@@")
+2 SET X=$GET(^DIC(36,+$PIECE(IBWIN,"@@",2),.11))
SET X13=$GET(^(.13))
+3 IF X]""
Begin DoDot:1
+4 WRITE ", ",$PIECE(X,U),", ",$PIECE(X,U,4),", ",$PIECE($GET(^DIC(5,+$PIECE(X,U,5),0)),U,2)," ",$PIECE(X,U,6)
+5 IF $PIECE(X13,U,2)]""
WRITE " Billing Phone: ",$PIECE(X13,U,2)
QUIT
+6 IF $PIECE(X13,U)]""
WRITE " Main Phone: ",$PIECE(X13,U)
End DoDot:1
+7 QUIT
+8 ;
WPAT ; - Write patient data.
+1 ;IB*2.0*739
WRITE $PIECE(IBZ,U),?37,$PIECE(IBZ,U,3)
+2 QUIT
+3 ;
WBIL ; - Write bill data.
+1 WRITE ?51,$$DAT1^IBOUTL(+IBWDP),?60,$PIECE(IBWDP,"@@",2)
+2 WRITE ?73,$$DAT1^IBOUTL($PIECE(IBZ,U,4)),?82,$$DAT1^IBOUTL($PIECE(IBZ,U,5))
+3 WRITE ?90,$JUSTIFY($PIECE(IBZ,U,6),10,2),?100,$JUSTIFY(+$PIECE(IBZ,U,7),10,2)
+4 IF $PIECE($PIECE(IBZ,U,7),"~",2)
Begin DoDot:1
+5 IF $PIECE($PIECE(IBZ,U,7),"~",2)<6
WRITE "(",$PIECE($PIECE(IBZ,U,7),"~",2),")"
QUIT
+6 WRITE "(*)"
End DoDot:1
+7 ;Only print if ID is not SSN IB*2.0*739
IF $PIECE(IBZ,U,8)'=$PIECE(IBZ,U,2)
WRITE ?114,$EXTRACT($PIECE(IBZ,U,8),1,18)
+8 QUIT
+9 ;
WCOM ; - Write the comments
+1 NEW CONT,DIWL,DIWR,IBC,IBC1,IBC2,X
+2 ;
+3 SET (IBC,CONT)=0
SET DIWL=1
SET DIWR=104
KILL ^UTILITY($JOB,"W")
+4 FOR
SET IBC=$ORDER(^TMP("IBJDF1",$JOB,IBDIV,IBTYP,IBWIN,IBWPT,IBWDP,IBC))
if 'IBC
QUIT
Begin DoDot:1
+5 IF $Y>(IOSL-4)
DO PAUSE
if IBQ
QUIT
DO HDR1
DO HDR2
if IBQ
QUIT
WRITE !
DO WPAT
DO WBIL
+6 SET IBC1=""
+7 FOR
SET IBC1=$ORDER(^TMP("IBJDF1",$JOB,IBDIV,IBTYP,IBWIN,IBWPT,IBWDP,IBC,IBC1))
if IBC1=""
QUIT
Begin DoDot:2
+8 SET IBC2=^TMP("IBJDF1",$JOB,IBDIV,IBTYP,IBWIN,IBWPT,IBWDP,IBC,IBC1)
+9 IF $Y>(IOSL-4)
DO WCPB
if IBQ
QUIT
+10 IF 'IBC1
SET IBCD=IBC2
DO WCD
QUIT
+11 SET X=IBC2
IF $EXTRACT(X)=" "
IF $LENGTH(X)>1
SET $EXTRACT(X)=""
+12 DO ^DIWP
+13 IF 'CONT
IF $LENGTH(IBC2)<66
DO WCTXT
QUIT
+14 SET CONT=$LENGTH(IBC2)>65
+15 IF '$ORDER(^TMP("IBJDF1",$JOB,IBDIV,IBTYP,IBWIN,IBWPT,IBWDP,IBC,IBC1))
Begin DoDot:3
+16 if $DATA(^UTILITY($JOB,"W"))
DO WCTXT
End DoDot:3
End DoDot:2
if IBQ
QUIT
End DoDot:1
if IBQ
QUIT
+17 KILL ^UTILITY($JOB,"W")
+18 QUIT
+19 ;
WCD ; - Write comment date.
+1 WRITE !?2,"Comment Date: ",$$DAT1^IBOUTL(IBCD)
+2 QUIT
+3 ;
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 WBIL
DO WCD
if IBC1>1
WRITE ?26,"(continued)",!
+4 QUIT
+5 ;
SSN(X) ; - Format the SSN.
+1 QUIT $SELECT(X]"":$EXTRACT(X,1,3)_"-"_$EXTRACT(X,4,5)_"-"_$EXTRACT(X,6,10),1:"")
