IBJDF42 ;ALB/RB - FIRST PARTY FOLLOW-UP REPORT (PRINT);15-APR-00
;;2.0;INTEGRATED BILLING;**123,204,568,618,651,705,739**;21-MAR-94;Build 3
;;Per VA Directive 6402, this routine should not be modified.
;
EN ; - Print the Follow-up report.
;
S IBCT(1)="INELIGIBLE",IBCT(2)="EMERG/HUMAN.",IBCT(18)="C MEANS TEST"
S IBCT(22)="RX COPAY/SC",IBCT(23)="RX COPAY/NSC"
S IBCT(33)="ADHC LTC"
S IBCT(34)="DOM LTC"
S IBCT(35)="RESPITE INPT LTC"
S IBCT(36)="RESPITE OPT LTC"
S IBCT(37)="GERIATRIC INPT LTC"
S IBCT(38)="GERIATRIC OPT LTC"
S IBCT(39)="NURSING HOME LTC"
;
; PRCA*4.5*338 Adding new categories for community care
;
; next are the new AR categories
S IBCT(61)="CHOICE INPT"
S IBCT(62)="CHOICE RX CO-PAYMENT"
S IBCT(63)="CC INPT"
S IBCT(64)="CC RX CO-PAYMENT"
S IBCT(65)="CCN INPT"
S IBCT(66)="CCN RX CO-PAYMENT"
S IBCT(67)="CC MTF INPT"
S IBCT(68)="CC MTF RX CO-PAYMENT"
S IBCT(69)="CC NURSING HOME CARE - LTC"
S IBCT(70)="CC RESPITE CARE"
S IBCT(71)="CCN NURSING HOME CARE - LTC"
S IBCT(72)="CCN RESPITE CARE"
S IBCT(73)="CHOICE NURSING HOME CARE - LTC"
S IBCT(74)="CHOICE RESPITE CARE"
S IBCT(81)="CHOICE OPT"
S IBCT(82)="CC OPT"
S IBCT(83)="CCN OPT"
S IBCT(84)="CC MTF OPT"
S IBCT(85)="CC URGENT CARE" ;IB*2.0*651 - added
;
S IBQ=0 D NOW^%DTC S IBRUN=$$DAT2^IBOUTL(%) G:IBRPT="S" SUM
I IBRPT="O" G OSUM
S IBPRTFLG=0 D DET D PAUSE:'IBPRTFLG I IBQ!'IBPRTFLG G ENQ
;
D PAUSE I IBQ G ENQ
;
SUM I 'IBQ D PRT^IBJDF43 ; Print summary.
OSUM I 'IBQ D OSUM^IBJDF43 ; Print Overall Summary
ENQ K IB0,IBAI,IBC,IBCAT,IBCD,IBC1,IBC2,IBCT,IBCNT,IBN,IBP,IBPAG,IBQ,IBRUN,IBS
K IBST,IBTOT,%,DFN,IBPRTFLG
Q
;
DET ; - Print report for a specific category.
;
D HDR1 G:IBQ DETQ
S (IBPT,IB,IBCAT,IB0)=""
F S IBPT=$O(^TMP("IBJDF4",$J,IBPT)) Q:IBPT="" D Q:IBQ
. I $O(^TMP("IBJDF4",$J,IBPT,0))="" Q
. S IBP=$G(^TMP("IBJDF4",$J,IBPT))
. I $Y>(IOSL-14) D PAUSE Q:IBQ D HDR1 Q:IBQ
. D WPAT
. F IB=16,19 D Q:IBQ
. . I IBSTA="A",IB'=16 Q
. . I IBSTA="S",IB=16 Q
. . I '$D(^TMP("IBJDF4",$J,IBPT,IB)) D Q
. . . I $Y>(IOSL-5) D PAUSE Q:IBQ D HDR1,WPAT,HDR2 Q:IBQ
. . . W !,"-> NO "_$S(IB=16:"ACTIVE",1:"SUSPENDED")_" BILLS."
. . I $Y>(IOSL-9) D PAUSE Q:IBQ D HDR1,WPAT Q:IBQ
. . D HDR2
. . K IBFLG S IBTOT="",IBCNT=0
. . F S IBCAT=$O(^TMP("IBJDF4",$J,IBPT,IB,IBCAT)) Q:IBCAT="" D Q:IBQ
. . . F S IB0=$O(^TMP("IBJDF4",$J,IBPT,IB,IBCAT,IB0)) Q:IB0="" D Q:IBQ
. . . . S IBN=$G(^TMP("IBJDF4",$J,IBPT,IB,IBCAT,IB0))
. . . . I $Y>(IOSL-5) D PAUSE Q:IBQ D HDR1,WPAT,HDR2 Q:IBQ
. . . . D WBIL Q:IBQ
. . . . S IBCNT=IBCNT+1
. . . I 'IBQ,$O(^TMP("IBJDF4",$J,IBPT,IB,IBCAT))="" D
. . . . D TOT W !
. . ; - Display bill comment history, if selected.
. . S IBPRTFLG=1
. . D WCOM(IBPT,IB)
;
I 'IBPRTFLG D
. W !!!!!!,"There are no receivables for the parameters entered."
;
DETQ Q
;
WPAT ; - Write patient data.
N I,X
S DFN=$P(IBPT,"@@",2),IBAI=$G(^TMP("IBJDF4",$J,IBPT,0,"A"))
W !!,"Patient Name : ",$P(IBP,U) W:IBAI["V" " *"
W !,"Means Test Status: ",$P(IBP,U,4) ;IB*2.0*739
W:$P(IBP,U,5)'="" " ("_$P(IBP,U,5)_")"
W ?58,"Medicaid: ",$$GET1^DIQ(2,DFN,.381)
W !,"RX Copay Status : ",$P(IBP,U,6)
W:$P(IBP,U,7)'="" " ("_$P(IBP,U,7)_")"
W:$P(IBP,U,8) ?53,"Date of Death: ",$$DAT1^IBOUTL($P(IBP,U,8))
W !,"Eligibilities : " S X=$$ELIG($P(IBP,U,3))
F I=1:1 Q:X="" W ?19,$E(X,1,61) S X=$E(X,62,999) I X'="" W !
S X=$$INFO(IBAI)
I X'="" D
. W !,"Additional Info : "
. F I=1:1 Q:X="" W ?19,$E(X,1,61) S X=$E(X,62,999) I X'="" W !
;
Q
;
WBIL ; - Write bill data.
W ! W:'$D(IBFLG(IBCAT)) $E(IBCT(IBCAT),1,11) W ?13,IB0 ;IB*2.0*618 - Limit length to 11 chars
W:$P(IBN,"^",6) ?25,$J("("_$P(IBN,"^",6)_")",4)
W ?30,$$DAT1^IBOUTL(+IBN)
W ?39,$J($FN($P(IBN,U,2),",",2),10),?50,$J($FN($P(IBN,U,3),",",2),10)
W ?61,$J($FN($P(IBN,U,4),",",2),9),?71,$J($FN($P(IBN,U,5),",",2),9)
I "SB"[IBSTA,$P(IBN,U,7)]"" W ?82,IBSUS($P(IBN,U,7))
S $P(IBTOT,"^")=$P(IBTOT,"^")+$P(IBN,U,2)
S $P(IBTOT,"^",2)=$P(IBTOT,"^",2)+$P(IBN,U,3)
S $P(IBTOT,"^",3)=$P(IBTOT,"^",3)+$P(IBN,U,4)
S $P(IBTOT,"^",4)=$P(IBTOT,"^",4)+$P(IBN,U,5)
S IBFLG(IBCAT)=""
Q
;
WCOM(IBPT,IB) ; - Write bill comments.
N CMDT,CONT,DIWL,DIWR,IBIDX,IBTR,IBLN,IBX,X
;
S (IBIDX,IBTR,IBLN)="",DIWL=1,DIWR=64 K ^UTILITY($J,"W")
F S IBIDX=$O(^TMP("IBJDF4",$J,IBPT,0,"C",IB,IBIDX)) Q:IBIDX="" D Q:IBQ
. I $Y>(IOSL-6) D WCPB Q:IBQ
. D WCD(IBIDX)
. F S IBTR=$O(^TMP("IBJDF4",$J,IBPT,0,"C",IB,IBIDX,IBTR)) Q:IBTR="" D Q:IBQ
. . S CMDT=$G(^TMP("IBJDF4",$J,IBPT,0,"C",IB,IBIDX,IBTR))
. . I $Y>(IOSL-4) D WCPB Q:IBQ
. . S CONT=0 D WCD(,1,)
. . F S IBLN=$O(^TMP("IBJDF4",$J,IBPT,0,"C",IB,IBIDX,IBTR,IBLN)) Q:IBLN="" D Q:IBQ
. . . S IBX=$G(^TMP("IBJDF4",$J,IBPT,0,"C",IB,IBIDX,IBTR,IBLN))
. . . I $E(IBX)=" ",$L(IBX)>1 S $E(IBX)=""
. . . S X=IBX D ^DIWP
. . . I 'CONT,$L(IBX)<66 D WCTX
. . . S CONT=$L(IBX)>65
. . . I '$O(^TMP("IBJDF4",$J,IBPT,0,"C",IB,IBIDX,IBTR,IBLN)) D
. . . . D:$D(^UTILITY($J,"W")) WCTX
K ^UTILITY($J,"W")
Q
;
WCD(I,D,C) ; - Write the comment date.
; Input: I - Index # "(I)"
; D - Print the Date " - MM/DD/YY"
; C - Print the Cont. "(Continued)"
;
W:$G(I) !,"(",I,")" W:$G(D) ?3," - ",$$DAT1^IBOUTL(CMDT),": "
W:$G(C) "(Continued)",!
Q
;
WCTX ; - Write the comment text.
N LIN,WLIN,Z
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)) Q:WLIN=""
. W ?16,WLIN
. I '$O(^UTILITY($J,"W",1,LIN)) W ! Q
. I $Y>(IOSL-4) D WCPB,WCD(IBIDX,1,1) Q
. W !
K ^UTILITY($J,"W")
Q
;
WCPB ; - Page Break in the middle of the Comments
D PAUSE Q:IBQ D HDR1,WPAT W !!
Q
;
HDR1 ; - Write the report header.
N X,I
W:'$G(IBPAG) ! I $E(IOST,1,2)="C-"!$G(IBPAG) W @IOF,*13
S IBPAG=$G(IBPAG)+1 W "First Party Follow-Up Report"
W ?34,"Run Date: ",IBRUN,?71,"Page: ",$J(IBPAG,3)
S X="ALL "_$S(IBSTA'="S":"ACTIVE",1:"")_$S(IBSTA="B":" AND ",1:"")
S X=X_$S(IBSTA'="A":"SUSPENDED",1:"")_" RECEIVABLES"
I IBSMN'="A" S X=X_" OVER "_IBSMN_" AND UNDER "_IBSMX_" DAYS OLD"
S X=X_" / BY "_$S(IBSN="N":"NAME",1:"LAST 4 SSN")
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"
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):" LESS THAN "_IBSH2_" DAYS OLD",1:"")
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
;
S IBQ=$$STOP^IBOUTL("First Party Follow-Up Report")
Q
;
TYPE(SEL) ; Returns a string with the type of receivables (description)
; selected or NULL if ALL receivable type have been selected.
; SEL - User input for the parameter "Type of Receivable"
;
N TYPE,I,X
I SEL="1,2,3," Q ""
S TYPE="",X="EMERGENCY/HUMANITARIAN^INELIGIBLE^C-MEANS TEST & RX COPAY"
F I=2:1:($L(SEL,",")-1) D
. S TYPE=TYPE_$S(I=($L(SEL,",")-1)&(TYPE'=""):" AND ",1:", ")
. S TYPE=TYPE_$P(X,"^",+$P(SEL,",",I))
S $E(TYPE,1)=""
;
Q TYPE
;
HDR2 ; - Write bill sub-header.
W ! I IBSTA="B" W !,$S(IB=16:"ACTIVE",1:"SUSPENDED")
W ! I IBSTA="B" W $S(IB=16:"======",1:"=========")
W:IBSH ?26,"COM" W ?30,"Last",?40,"Current",?51,"Principal"
W !,"Category",?13,"Bill Number",?26,"REF"
W ?30,"Payment",?40,"Balance",?51,"Balance",?62,"Interest",?72,"Admin."
I "BS"[IBSTA W ?82,"Suspended Type"
W !,$$DASH(96,1)
Q
;
TOT ; - Write balance total for patient.
N I,J
I IBCNT>1 W ! F I=40,51,62,72 W ?I,$E("---------",1,$S(I>60:8,1:9))
W:IBCNT'>1 !
W !,"Account Balance: $"_$FN($P(IBP,"^",10),",",2)
I IBCNT'>1 Q
S J=1 F I=39,50,60,70 W ?I,$J($FN($P(IBTOT,"^",J),",",2),10) S J=J+1
Q
;
DASH(X,Y) ; - Return a dashed line.
Q $TR($J("",X)," ",$S(Y:"-",1:"="))
;
ELIG(X) ; - Return eligibility code name.
; X - Eligibility codes separated by semi-collon (;)
;
N ELIG,I
S ELIG="" F I=1:1:$L(X,";") D
. I '$P(X,";",I) Q
. S ELIG=ELIG_", "_$E($P($G(^DIC(8,+$P(X,";",I),0)),U),1,20)
S $E(ELIG,1,2)=""
;
Q ELIG
;
INFO(X) ; - Return the patient Additional Information about the Patient Accout
; X - Flags representing the observations
;
N INFO,I
S INFO="" F I=1:1:$L(X) D
. I $E(X,I)="V" S INFO=INFO_", '*' - VA EMPLOYEE"
. I $E(X,I)="R" S INFO=INFO_", REFERRED TO RC"
. I $E(X,I)="D" S INFO=INFO_", REFERRED TO DMC"
. I $E(X,I)="T" S INFO=INFO_", REFERRED TO TOP"
. I $E(X,I)="P" S INFO=INFO_", UNDER REPAYMENT PLAN"
. I $E(X,I)="F" S INFO=INFO_", UNDER DEFAULTED REPAYMENT PLAN"
S $E(INFO,1,2)=""
;
Q INFO
;
SSN(X) ; - Format the SSN.
Q $S(X]"":$E(X,1,3)_"-"_$E(X,4,5)_"-"_$E(X,6,10),1:"")
;
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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBJDF42 9050 printed Nov 22, 2024@17:32:54 Page 2
IBJDF42 ;ALB/RB - FIRST PARTY FOLLOW-UP REPORT (PRINT);15-APR-00
+1 ;;2.0;INTEGRATED BILLING;**123,204,568,618,651,705,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 ;
+2 SET IBCT(1)="INELIGIBLE"
SET IBCT(2)="EMERG/HUMAN."
SET IBCT(18)="C MEANS TEST"
+3 SET IBCT(22)="RX COPAY/SC"
SET IBCT(23)="RX COPAY/NSC"
+4 SET IBCT(33)="ADHC LTC"
+5 SET IBCT(34)="DOM LTC"
+6 SET IBCT(35)="RESPITE INPT LTC"
+7 SET IBCT(36)="RESPITE OPT LTC"
+8 SET IBCT(37)="GERIATRIC INPT LTC"
+9 SET IBCT(38)="GERIATRIC OPT LTC"
+10 SET IBCT(39)="NURSING HOME LTC"
+11 ;
+12 ; PRCA*4.5*338 Adding new categories for community care
+13 ;
+14 ; next are the new AR categories
+15 SET IBCT(61)="CHOICE INPT"
+16 SET IBCT(62)="CHOICE RX CO-PAYMENT"
+17 SET IBCT(63)="CC INPT"
+18 SET IBCT(64)="CC RX CO-PAYMENT"
+19 SET IBCT(65)="CCN INPT"
+20 SET IBCT(66)="CCN RX CO-PAYMENT"
+21 SET IBCT(67)="CC MTF INPT"
+22 SET IBCT(68)="CC MTF RX CO-PAYMENT"
+23 SET IBCT(69)="CC NURSING HOME CARE - LTC"
+24 SET IBCT(70)="CC RESPITE CARE"
+25 SET IBCT(71)="CCN NURSING HOME CARE - LTC"
+26 SET IBCT(72)="CCN RESPITE CARE"
+27 SET IBCT(73)="CHOICE NURSING HOME CARE - LTC"
+28 SET IBCT(74)="CHOICE RESPITE CARE"
+29 SET IBCT(81)="CHOICE OPT"
+30 SET IBCT(82)="CC OPT"
+31 SET IBCT(83)="CCN OPT"
+32 SET IBCT(84)="CC MTF OPT"
+33 ;IB*2.0*651 - added
SET IBCT(85)="CC URGENT CARE"
+34 ;
+35 SET IBQ=0
DO NOW^%DTC
SET IBRUN=$$DAT2^IBOUTL(%)
if IBRPT="S"
GOTO SUM
+36 IF IBRPT="O"
GOTO OSUM
+37 SET IBPRTFLG=0
DO DET
if 'IBPRTFLG
DO PAUSE
IF IBQ!'IBPRTFLG
GOTO ENQ
+38 ;
+39 DO PAUSE
IF IBQ
GOTO ENQ
+40 ;
SUM ; Print summary.
IF 'IBQ
DO PRT^IBJDF43
OSUM ; Print Overall Summary
IF 'IBQ
DO OSUM^IBJDF43
ENQ KILL IB0,IBAI,IBC,IBCAT,IBCD,IBC1,IBC2,IBCT,IBCNT,IBN,IBP,IBPAG,IBQ,IBRUN,IBS
+1 KILL IBST,IBTOT,%,DFN,IBPRTFLG
+2 QUIT
+3 ;
DET ; - Print report for a specific category.
+1 ;
+2 DO HDR1
if IBQ
GOTO DETQ
+3 SET (IBPT,IB,IBCAT,IB0)=""
+4 FOR
SET IBPT=$ORDER(^TMP("IBJDF4",$JOB,IBPT))
if IBPT=""
QUIT
Begin DoDot:1
+5 IF $ORDER(^TMP("IBJDF4",$JOB,IBPT,0))=""
QUIT
+6 SET IBP=$GET(^TMP("IBJDF4",$JOB,IBPT))
+7 IF $Y>(IOSL-14)
DO PAUSE
if IBQ
QUIT
DO HDR1
if IBQ
QUIT
+8 DO WPAT
+9 FOR IB=16,19
Begin DoDot:2
+10 IF IBSTA="A"
IF IB'=16
QUIT
+11 IF IBSTA="S"
IF IB=16
QUIT
+12 IF '$DATA(^TMP("IBJDF4",$JOB,IBPT,IB))
Begin DoDot:3
+13 IF $Y>(IOSL-5)
DO PAUSE
if IBQ
QUIT
DO HDR1
DO WPAT
DO HDR2
if IBQ
QUIT
+14 WRITE !,"-> NO "_$SELECT(IB=16:"ACTIVE",1:"SUSPENDED")_" BILLS."
End DoDot:3
QUIT
+15 IF $Y>(IOSL-9)
DO PAUSE
if IBQ
QUIT
DO HDR1
DO WPAT
if IBQ
QUIT
+16 DO HDR2
+17 KILL IBFLG
SET IBTOT=""
SET IBCNT=0
+18 FOR
SET IBCAT=$ORDER(^TMP("IBJDF4",$JOB,IBPT,IB,IBCAT))
if IBCAT=""
QUIT
Begin DoDot:3
+19 FOR
SET IB0=$ORDER(^TMP("IBJDF4",$JOB,IBPT,IB,IBCAT,IB0))
if IB0=""
QUIT
Begin DoDot:4
+20 SET IBN=$GET(^TMP("IBJDF4",$JOB,IBPT,IB,IBCAT,IB0))
+21 IF $Y>(IOSL-5)
DO PAUSE
if IBQ
QUIT
DO HDR1
DO WPAT
DO HDR2
if IBQ
QUIT
+22 DO WBIL
if IBQ
QUIT
+23 SET IBCNT=IBCNT+1
End DoDot:4
if IBQ
QUIT
+24 IF 'IBQ
IF $ORDER(^TMP("IBJDF4",$JOB,IBPT,IB,IBCAT))=""
Begin DoDot:4
+25 DO TOT
WRITE !
End DoDot:4
End DoDot:3
if IBQ
QUIT
+26 ; - Display bill comment history, if selected.
+27 SET IBPRTFLG=1
+28 DO WCOM(IBPT,IB)
End DoDot:2
if IBQ
QUIT
End DoDot:1
if IBQ
QUIT
+29 ;
+30 IF 'IBPRTFLG
Begin DoDot:1
+31 WRITE !!!!!!,"There are no receivables for the parameters entered."
End DoDot:1
+32 ;
DETQ QUIT
+1 ;
WPAT ; - Write patient data.
+1 NEW I,X
+2 SET DFN=$PIECE(IBPT,"@@",2)
SET IBAI=$GET(^TMP("IBJDF4",$JOB,IBPT,0,"A"))
+3 WRITE !!,"Patient Name : ",$PIECE(IBP,U)
if IBAI["V"
WRITE " *"
+4 ;IB*2.0*739
WRITE !,"Means Test Status: ",$PIECE(IBP,U,4)
+5 if $PIECE(IBP,U,5)'=""
WRITE " ("_$PIECE(IBP,U,5)_")"
+6 WRITE ?58,"Medicaid: ",$$GET1^DIQ(2,DFN,.381)
+7 WRITE !,"RX Copay Status : ",$PIECE(IBP,U,6)
+8 if $PIECE(IBP,U,7)'=""
WRITE " ("_$PIECE(IBP,U,7)_")"
+9 if $PIECE(IBP,U,8)
WRITE ?53,"Date of Death: ",$$DAT1^IBOUTL($PIECE(IBP,U,8))
+10 WRITE !,"Eligibilities : "
SET X=$$ELIG($PIECE(IBP,U,3))
+11 FOR I=1:1
if X=""
QUIT
WRITE ?19,$EXTRACT(X,1,61)
SET X=$EXTRACT(X,62,999)
IF X'=""
WRITE !
+12 SET X=$$INFO(IBAI)
+13 IF X'=""
Begin DoDot:1
+14 WRITE !,"Additional Info : "
+15 FOR I=1:1
if X=""
QUIT
WRITE ?19,$EXTRACT(X,1,61)
SET X=$EXTRACT(X,62,999)
IF X'=""
WRITE !
End DoDot:1
+16 ;
+17 QUIT
+18 ;
WBIL ; - Write bill data.
+1 ;IB*2.0*618 - Limit length to 11 chars
WRITE !
if '$DATA(IBFLG(IBCAT))
WRITE $EXTRACT(IBCT(IBCAT),1,11)
WRITE ?13,IB0
+2 if $PIECE(IBN,"^",6)
WRITE ?25,$JUSTIFY("("_$PIECE(IBN,"^",6)_")",4)
+3 WRITE ?30,$$DAT1^IBOUTL(+IBN)
+4 WRITE ?39,$JUSTIFY($FNUMBER($PIECE(IBN,U,2),",",2),10),?50,$JUSTIFY($FNUMBER($PIECE(IBN,U,3),",",2),10)
+5 WRITE ?61,$JUSTIFY($FNUMBER($PIECE(IBN,U,4),",",2),9),?71,$JUSTIFY($FNUMBER($PIECE(IBN,U,5),",",2),9)
+6 IF "SB"[IBSTA
IF $PIECE(IBN,U,7)]""
WRITE ?82,IBSUS($PIECE(IBN,U,7))
+7 SET $PIECE(IBTOT,"^")=$PIECE(IBTOT,"^")+$PIECE(IBN,U,2)
+8 SET $PIECE(IBTOT,"^",2)=$PIECE(IBTOT,"^",2)+$PIECE(IBN,U,3)
+9 SET $PIECE(IBTOT,"^",3)=$PIECE(IBTOT,"^",3)+$PIECE(IBN,U,4)
+10 SET $PIECE(IBTOT,"^",4)=$PIECE(IBTOT,"^",4)+$PIECE(IBN,U,5)
+11 SET IBFLG(IBCAT)=""
+12 QUIT
+13 ;
WCOM(IBPT,IB) ; - Write bill comments.
+1 NEW CMDT,CONT,DIWL,DIWR,IBIDX,IBTR,IBLN,IBX,X
+2 ;
+3 SET (IBIDX,IBTR,IBLN)=""
SET DIWL=1
SET DIWR=64
KILL ^UTILITY($JOB,"W")
+4 FOR
SET IBIDX=$ORDER(^TMP("IBJDF4",$JOB,IBPT,0,"C",IB,IBIDX))
if IBIDX=""
QUIT
Begin DoDot:1
+5 IF $Y>(IOSL-6)
DO WCPB
if IBQ
QUIT
+6 DO WCD(IBIDX)
+7 FOR
SET IBTR=$ORDER(^TMP("IBJDF4",$JOB,IBPT,0,"C",IB,IBIDX,IBTR))
if IBTR=""
QUIT
Begin DoDot:2
+8 SET CMDT=$GET(^TMP("IBJDF4",$JOB,IBPT,0,"C",IB,IBIDX,IBTR))
+9 IF $Y>(IOSL-4)
DO WCPB
if IBQ
QUIT
+10 SET CONT=0
DO WCD(,1,)
+11 FOR
SET IBLN=$ORDER(^TMP("IBJDF4",$JOB,IBPT,0,"C",IB,IBIDX,IBTR,IBLN))
if IBLN=""
QUIT
Begin DoDot:3
+12 SET IBX=$GET(^TMP("IBJDF4",$JOB,IBPT,0,"C",IB,IBIDX,IBTR,IBLN))
+13 IF $EXTRACT(IBX)=" "
IF $LENGTH(IBX)>1
SET $EXTRACT(IBX)=""
+14 SET X=IBX
DO ^DIWP
+15 IF 'CONT
IF $LENGTH(IBX)<66
DO WCTX
+16 SET CONT=$LENGTH(IBX)>65
+17 IF '$ORDER(^TMP("IBJDF4",$JOB,IBPT,0,"C",IB,IBIDX,IBTR,IBLN))
Begin DoDot:4
+18 if $DATA(^UTILITY($JOB,"W"))
DO WCTX
End DoDot:4
End DoDot:3
if IBQ
QUIT
End DoDot:2
if IBQ
QUIT
End DoDot:1
if IBQ
QUIT
+19 KILL ^UTILITY($JOB,"W")
+20 QUIT
+21 ;
WCD(I,D,C) ; - Write the comment date.
+1 ; Input: I - Index # "(I)"
+2 ; D - Print the Date " - MM/DD/YY"
+3 ; C - Print the Cont. "(Continued)"
+4 ;
+5 if $GET(I)
WRITE !,"(",I,")"
if $GET(D)
WRITE ?3," - ",$$DAT1^IBOUTL(CMDT),": "
+6 if $GET(C)
WRITE "(Continued)",!
+7 QUIT
+8 ;
WCTX ; - Write the comment text.
+1 NEW LIN,WLIN,Z
+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))
if WLIN=""
QUIT
+5 WRITE ?16,WLIN
+6 IF '$ORDER(^UTILITY($JOB,"W",1,LIN))
WRITE !
QUIT
+7 IF $Y>(IOSL-4)
DO WCPB
DO WCD(IBIDX,1,1)
QUIT
+8 WRITE !
End DoDot:1
if IBQ
QUIT
+9 KILL ^UTILITY($JOB,"W")
+10 QUIT
+11 ;
WCPB ; - Page Break in the middle of the Comments
+1 DO PAUSE
if IBQ
QUIT
DO HDR1
DO WPAT
WRITE !!
+2 QUIT
+3 ;
HDR1 ; - Write the report header.
+1 NEW X,I
+2 if '$GET(IBPAG)
WRITE !
IF $EXTRACT(IOST,1,2)="C-"!$GET(IBPAG)
WRITE @IOF,*13
+3 SET IBPAG=$GET(IBPAG)+1
WRITE "First Party Follow-Up Report"
+4 WRITE ?34,"Run Date: ",IBRUN,?71,"Page: ",$JUSTIFY(IBPAG,3)
+5 SET X="ALL "_$SELECT(IBSTA'="S":"ACTIVE",1:"")_$SELECT(IBSTA="B":" AND ",1:"")
+6 SET X=X_$SELECT(IBSTA'="A":"SUSPENDED",1:"")_" RECEIVABLES"
+7 IF IBSMN'="A"
SET X=X_" OVER "_IBSMN_" AND UNDER "_IBSMX_" DAYS OLD"
+8 SET X=X_" / BY "_$SELECT(IBSN="N":"NAME",1:"LAST 4 SSN")
+9 SET X=X_" ("_$SELECT($GET(IBSNA)="ALL":"ALL",1:"From "_$SELECT(IBSNF="":"FIRST",1:IBSNF)_" to "_$SELECT(IBSNL="zzzzz":"LAST",1:IBSNL))_")"
+10 SET X=X_" / "_$SELECT('IBSAM:"NO ",1:"")_"MINIMUM BALANCE"
+11 SET X=X_$SELECT(IBSAM:": $"_$FNUMBER(IBSAM,",",2),1:"")
+12 SET X=X_" / "_$SELECT('IBSH:"NO ",IBSH1="A":"ALL ",1:"ONLY ")_"COMMENTS"
+13 SET X=X_$SELECT($GET(IBSH2):" LESS THAN "_IBSH2_" DAYS OLD",1:"")
+14 SET X=X_" / RECEIVABLES REFERRED TO RC "_$SELECT('IBSRC:"NOT ",1:"")_"INCLUDED"
+15 FOR I=1:1
WRITE !,$EXTRACT(X,1,80)
SET X=$EXTRACT(X,81,999)
IF X=""
QUIT
+16 ;
+17 SET IBQ=$$STOP^IBOUTL("First Party Follow-Up Report")
+18 QUIT
+19 ;
TYPE(SEL) ; Returns a string with the type of receivables (description)
+1 ; selected or NULL if ALL receivable type have been selected.
+2 ; SEL - User input for the parameter "Type of Receivable"
+3 ;
+4 NEW TYPE,I,X
+5 IF SEL="1,2,3,"
QUIT ""
+6 SET TYPE=""
SET X="EMERGENCY/HUMANITARIAN^INELIGIBLE^C-MEANS TEST & RX COPAY"
+7 FOR I=2:1:($LENGTH(SEL,",")-1)
Begin DoDot:1
+8 SET TYPE=TYPE_$SELECT(I=($LENGTH(SEL,",")-1)&(TYPE'=""):" AND ",1:", ")
+9 SET TYPE=TYPE_$PIECE(X,"^",+$PIECE(SEL,",",I))
End DoDot:1
+10 SET $EXTRACT(TYPE,1)=""
+11 ;
+12 QUIT TYPE
+13 ;
HDR2 ; - Write bill sub-header.
+1 WRITE !
IF IBSTA="B"
WRITE !,$SELECT(IB=16:"ACTIVE",1:"SUSPENDED")
+2 WRITE !
IF IBSTA="B"
WRITE $SELECT(IB=16:"======",1:"=========")
+3 if IBSH
WRITE ?26,"COM"
WRITE ?30,"Last",?40,"Current",?51,"Principal"
+4 WRITE !,"Category",?13,"Bill Number",?26,"REF"
+5 WRITE ?30,"Payment",?40,"Balance",?51,"Balance",?62,"Interest",?72,"Admin."
+6 IF "BS"[IBSTA
WRITE ?82,"Suspended Type"
+7 WRITE !,$$DASH(96,1)
+8 QUIT
+9 ;
TOT ; - Write balance total for patient.
+1 NEW I,J
+2 IF IBCNT>1
WRITE !
FOR I=40,51,62,72
WRITE ?I,$EXTRACT("---------",1,$SELECT(I>60:8,1:9))
+3 if IBCNT'>1
WRITE !
+4 WRITE !,"Account Balance: $"_$FNUMBER($PIECE(IBP,"^",10),",",2)
+5 IF IBCNT'>1
QUIT
+6 SET J=1
FOR I=39,50,60,70
WRITE ?I,$JUSTIFY($FNUMBER($PIECE(IBTOT,"^",J),",",2),10)
SET J=J+1
+7 QUIT
+8 ;
DASH(X,Y) ; - Return a dashed line.
+1 QUIT $TRANSLATE($JUSTIFY("",X)," ",$SELECT(Y:"-",1:"="))
+2 ;
ELIG(X) ; - Return eligibility code name.
+1 ; X - Eligibility codes separated by semi-collon (;)
+2 ;
+3 NEW ELIG,I
+4 SET ELIG=""
FOR I=1:1:$LENGTH(X,";")
Begin DoDot:1
+5 IF '$PIECE(X,";",I)
QUIT
+6 SET ELIG=ELIG_", "_$EXTRACT($PIECE($GET(^DIC(8,+$PIECE(X,";",I),0)),U),1,20)
End DoDot:1
+7 SET $EXTRACT(ELIG,1,2)=""
+8 ;
+9 QUIT ELIG
+10 ;
INFO(X) ; - Return the patient Additional Information about the Patient Accout
+1 ; X - Flags representing the observations
+2 ;
+3 NEW INFO,I
+4 SET INFO=""
FOR I=1:1:$LENGTH(X)
Begin DoDot:1
+5 IF $EXTRACT(X,I)="V"
SET INFO=INFO_", '*' - VA EMPLOYEE"
+6 IF $EXTRACT(X,I)="R"
SET INFO=INFO_", REFERRED TO RC"
+7 IF $EXTRACT(X,I)="D"
SET INFO=INFO_", REFERRED TO DMC"
+8 IF $EXTRACT(X,I)="T"
SET INFO=INFO_", REFERRED TO TOP"
+9 IF $EXTRACT(X,I)="P"
SET INFO=INFO_", UNDER REPAYMENT PLAN"
+10 IF $EXTRACT(X,I)="F"
SET INFO=INFO_", UNDER DEFAULTED REPAYMENT PLAN"
End DoDot:1
+11 SET $EXTRACT(INFO,1,2)=""
+12 ;
+13 QUIT INFO
+14 ;
SSN(X) ; - Format the SSN.
+1 QUIT $SELECT(X]"":$EXTRACT(X,1,3)_"-"_$EXTRACT(X,4,5)_"-"_$EXTRACT(X,6,10),1:"")
+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
