- 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 Mar 13, 2025@21:27:43 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:"")
