IBJDF2 ;ALB/CPM - THIRD PARTY FOLLOW-UP SUMMARY REPORT ;Feb 09, 2018@10:11:43
;;2.0;INTEGRATED BILLING;**69,91,100,118,133,205,554,597,568,618,663**;21-MAR-94;Build 27
;;Per VA Directive 6402, this routine should not be modified.
;
EN ; - Option entry point.
;
W !!,"This report provides a summary of all outstanding Third Party receivables.",!
;
DATE ; - Choose date to use for calculation
W !!,"Calculate report using (D)ATE OF CARE or (A)CTIVE IN AR (days): (A)CTIVE IN AR// " R X:DTIME
G:'$T!(X["^") ENQ S:X="" X="A" S X=$E(X)
I "ADad"'[X S IBOFF=99 D HELP^IBJDF1H G DATE
W " ",$S("Dd"[X:"DATE OF CARE",1:"(DAYS) ACTIVE IN AR")
S IBSDATE=$S("Dd"[X:"D",1:"A")
;
; - Sort by division.
S DIR(0)="Y",DIR("B")="NO"
S DIR("A")="Do you wish to sort this report by division"
S DIR("?")="^D DHLP^IBJDF2"
D ^DIR K DIR I $D(DIRUT)!$D(DTOUT)!$D(DUOUT)!$D(DIROUT) G ENQ
S IBSORT=+Y K DIROUT,DTOUT,DUOUT,DIRUT
;
; - Issue prompt for division.
I IBSORT D PSDR^IBODIV G:Y<0 ENQ
;
TYP ; - Select type of summaries to print.
; IB*2.0*554 DRF 10/19/2015 Add Non-VA care
W !!,"Choose which type of summaries to print:",!
S DIR(0)="LO^1:5^K:+$P(X,""-"",2)>5 X"
S DIR("A",1)=" 1 - INPATIENT RECEIVABLES"
S DIR("A",2)=" 2 - OUTPATIENT RECEIVABLES"
S DIR("A",3)=" 3 - PHARMACY REFILL RECEIVABLES"
S DIR("A",4)=" 4 - COMMUNITY CARE RECEIVABLES"
S DIR("A",5)=" 5 - ALL RECEIVABLES"
S DIR("A",6)="",DIR("A")="Select",DIR("B")=5
D ^DIR K DIR I $D(DIRUT)!$D(DTOUT)!$D(DUOUT)!$D(DIROUT) G ENQ
S IBSEL=Y K DIROUT,DTOUT,DUOUT,DIRUT
;
W !!,"This report only requires an 80 column printer."
W !!,"Note: This report requires a search through all active receivables."
W !?6,"You should queue this report to run after normal business hours.",!
;
; - Select a device.
S %ZIS="QM" D ^%ZIS G:POP ENQ
I $D(IO("Q")) D G ENQ
.S ZTRTN="DQ^IBJDF2",ZTDESC="IB - FOLLOW-UP SUMMARY REPORT"
.F I="IBSEL","IBSDATE","IBSORT","VAUTD","VAUTD(" S ZTSAVE(I)=""
.D ^%ZTLOAD
.W !!,$S($D(ZTSK):"This job has been queued. The task number is "_ZTSK_".",1:"Unable to queue this job.")
.K ZTSK,IO("Q") D HOME^%ZIS
;
U IO
;
DQ ; - Tasked entry point.
;
I $G(IBXTRACT) D E^IBJDE(9,1) ; Change extract status.
;
K IB F I=1,2,3,4,5 I IBSEL[I D
.I 'IBSORT D Q
..F J=1:1:9 S IB(0,I,J)=""
.I 'VAUTD D Q
..S J=0 F S J=$O(VAUTD(J)) Q:'J F K=1:1:9 S IB(J,I,K)=""
.S J=0 F S J=$O(^DG(40.8,J)) Q:'J F K=1:1:9 S IB(J,I,K)=""
;
; - Find data required for the report.
S (IBQ,IBA)=0 F S IBA=$O(^PRCA(430,"AC",16,IBA)) Q:'IBA D Q:IBQ
.;
.I IBA#100=0 S IBQ=$$STOP^IBOUTL("Third Party Follow-Up Summary Report") Q:IBQ
.;
.;IB*2.0*618 moved ahead of AR Cat check to ensure bill exists before performing lookup in CHKARNUM
.S:"Aa"[IBSDATE IBARD=$$ACT(IBA) S:"Dd"[IBSDATE IBARD=$$DATE1(IBA) I 'IBARD Q ; No activation date.
.I '$D(^DGCR(399,IBA,0)) Q ; No corresponding claim to this AR.
.;
.S IBAR=$G(^PRCA(430,IBA,0))
.;**IB*2.0*618 - Change add new AR Categories and AR Category/
.; Rate Types
.S IBARNUM=$$GET1^DIQ(430.2,$P(IBAR,U,2)_",",6) ; Get AR Cat Num
.Q:'$$CHKARNUM^IBJDF11(IBARNUM) ;Confirm RI Bill, quit if not
.;
.; - Get division if necessary.
.I 'IBSORT S IBDIV=0
.E S IBDIV=$$DIV(IBA) I 'IBDIV S IBDIV=+$$PRIM^VASITE()
.I IBSORT,'VAUTD Q:'$D(VAUTD(IBDIV)) ; Not a selected division.
.;
.; - Determine whether bill is inpatient, outpatient, or RX refill.
.S IBTYP=$P($G(^DGCR(399,IBA,0)),U,5),IBTYP=$S(IBTYP>2:2,1:1)
.S:$D(^IBA(362.4,"C",IBA)) IBTYP=3
.I $P(IBAR,U,2)=45 S IBTYP=4 ;IB*2*554/DRF Look for Non-VA
.S IBTYP=$S(IBARNUM=50:4,IBARNUM=51:4,IBARNUM=52:4,IBARNUM=53:4,1:IBTYP) ;CC types
.I IBSEL'[IBTYP,IBSEL'[5 Q
.;
.; - Handle claims referred to Regional Counsel.
.S IBOUT=+$G(^PRCA(430,IBA,7))
.I $P($G(^PRCA(430,IBA,6)),U,4) D Q
..F I=IBTYP,5 I IBSEL[I D
...S $P(IB(IBDIV,I,8),U)=+IB(IBDIV,I,8)+1
...S $P(IB(IBDIV,I,8),U,2)=$P(IB(IBDIV,I,8),U,2)+IBOUT
.;
.; - Determine age and outstanding balance.
.S IBAGE=$$FMDIFF^XLFDT(DT,IBARD),IBCAT=$$CAT(IBAGE)
.;
.F I=IBTYP,5 I IBSEL[I D
..S $P(IB(IBDIV,I,IBCAT),U)=+IB(IBDIV,I,IBCAT)+1
..S $P(IB(IBDIV,I,IBCAT),U,2)=$P(IB(IBDIV,I,IBCAT),U,2)+IBOUT
;
I IBQ G ENQ
;
; - Extract summary data.
; *597 fix array subscripts for all types
I $G(IBXTRACT) D G ENQ
.F I=1:1:8 D
..F J=1,2 S $P(IB(0,5,9),U,J)=$P(IB(0,5,9),U,J)+$P(IB(0,5,I),U,J)
.S I=0 F J=1:1:9 D
..S I=I+1,IB(I)=+IB(0,5,J),I=I+1,IB(I)=$J(+$P(IB(0,5,J),U,2),0,2)
.D E^IBJDE(9,0)
;
; - Print the reports.
S (IBPAG,IBQ)=0 D NOW^%DTC S IBRUN=$$DAT2^IBOUTL(%)
I 'IBSORT D SUM(0) G ENQ
;
S IBDIV=0 F S IBDIV=$O(IB(IBDIV)) Q:'IBDIV D SUM(IBDIV) Q:IBQ
;
ENQ I $D(ZTQUEUED) S ZTREQ="@" G ENQ1
;
D ^%ZISC
ENQ1 K IB,IBOFF,IBQ,IBSDATE,IBSEL,IBSORT,IBTEXT,IBA,IBAR,IBARD,IBDIV,IBAGE,IBOUT,IBCAT,IBPAG,IBRUN
K IBDH,IBTYP,IBTYPH,%,%ZIS,DFN,I,J,K,POP,VAUTD,X,Y,Z,ZTDESC,ZTRTN,ZTSAVE,IBARNUM
K DIROUT,DTOUT,DUOUT,DIRUT
Q
;
SUM(IBDIV) ; - Print the report.
; Input: IBDIV=Pointer to the division in file #40.8
;
S IBTYP=0 F S IBTYP=$O(IB(IBDIV,IBTYP)) Q:'IBTYP D Q:IBQ
.I $E(IOST,1,2)="C-"!(IBPAG) W @IOF,*13
.S IBPAG=IBPAG+1 I $E(IOST,1,2)'="C-" W !?68,"Page: ",IBPAG
.W !!?22,"THIRD PARTY FOLLOW-UP SUMMARY REPORT"
.S IBTYPH=$S(IBTYP=1:"INPATIENT",IBTYP=2:"OUTPATIENT",IBTYP=3:"RX REFILL",IBTYP=4:"NON-VA",1:"ALL REIMBURSABLE")_" RECEIVABLES"_$S(IBSDATE="D":" ( date of care )",1:" ( days in AR )")
.W !?(80-$L(IBTYPH))\2,IBTYPH
.I IBDIV S IBDH="Division: "_$P($G(^DG(40.8,IBDIV,0)),U) W !?(80-$L(IBDH)\2),IBDH
.W !!?24,"Run Date: ",IBRUN,!?24,$$DASH(31),!!
.;
.; - Calculate totals first.
.F I=1:1:8 F J=1,2 S $P(IB(IBDIV,IBTYP,9),U,J)=$P(IB(IBDIV,IBTYP,9),U,J)+$P(IB(IBDIV,IBTYP,I),U,J)
.;
.W "AR Category",?31,"# Receivables",?52,"Total Outstanding Balance"
.W !,"-----------",?31,"-------------",?52,"-------------------------",!
.;
.I 'IB(IBDIV,IBTYP,9) W !,"There are no active receivables",$S(IBDIV:" for this division",1:""),"." D PAUSE Q
.;
.; - Primary loop to write results.
.S Y=$P(IB(IBDIV,IBTYP,9),U,2) F I=1:1:9 S X=$P($T(CATN+I),";;",2,99) D
..W:I=9 ! W !,X,?30,$J(+IB(IBDIV,IBTYP,I),6)
..W " (",$J(+IB(IBDIV,IBTYP,I)/+IB(IBDIV,IBTYP,9)*100,0,$S(I=9:0,1:2)),"%)"
..S Z=$FN($P(IB(IBDIV,IBTYP,I),U,2),",",2)
..W ?52,$J($S(I=1!(I=9):"$",1:"")_Z,15)
..W " (",$J($S('Y:0,1:$P(IB(IBDIV,IBTYP,I),U,2)/Y*100),0,$S(I=9:0,1:2)),"%)"
.;
.D PAUSE
;
SUMQ 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
;
DHLP ; - 'Display Registration User' help.
W !,"Enter <CR> to summarize all receivables without regard to division,"
W !,"or YES to select those divisions for which a separate report should"
W !,"be created."
Q
;
CAT(X) ; - Determine category to place receivable.
Q $S($G(X)<31:1,X<61:2,X<91:3,X<121:4,X<181:5,X<366:6,1:7)
;
ACT(X) ; - Determine the activation date for a receivable.
N Y S Y=0 I '$G(X) G ACTQ
S Y=$P($G(^PRCA(430,X,6)),U,21) I Y G ACTQ
S Y=$P($G(^PRCA(430,X,9)),U,3) I Y G ACTQ
S Y=$P($G(^PRCA(430,X,0)),U,10)
ACTQ Q Y
;
DATE1(X) ; - Determine the Date of Care
N Y S Y=0 I '$G(X) G DATEQ
S Y=$P($G(^DGCR(399,X,"U")),U,2) I Y G DATEQ
DATEQ Q Y
;
DIV(IBX) ; - Determine the division for a claim.
; Input: IBX=Pointer to a claim in file #399
; Output: IBY=Pointer to a division in file #40.8,
; or 0 if not determined
;
N DFN,IBADM,IBEV,IBD,IBPTF,IBU,IBY,IBC,IBTY,VAINDT,VADMVT
S IBY=0,IBC=$G(^DGCR(399,+$G(IBX),0)) I $P(IBC,U)="" G DIVQ
S DFN=+$P(IBC,U,2),IBEV=+$P(IBC,U,3)\1,IBTY=$P(IBC,U,5)
;
S IBY=+$P(IBC,U,22) I +IBY G DIVQ ; use bill default division if defined
;
; - For Pharmacy or Prosthetics claims, use the primary division.
I $D(^IBA(362.4,"AIFN"_IBX))!$D(^IBA(362.5,"AIFN"_IBX)) D G DIVQ
.S IBY=$$PRIM^VASITE(DT) S:IBY'>0 IBY=0
;
; - Check all visit dates if outpatient claim.
I IBTY>2 D G DIVQ
.S IBY=$$OPT(IBEV,DFN) Q:IBY
.S IBD=0 F S IBD=$O(^DGCR(399,IBX,"OP",IBD)) Q:'IBD S IBY=$$OPT(IBD,DFN) Q:IBY
;
; - Check inpatient claim.
S IBPTF=+$P(IBC,U,8),IBU=$G(^DGCR(399,IBX,"U"))
I IBPTF S IBADM=$O(^DGPM("APTF",IBPTF,0)) I IBADM S IBY=$$INP(IBADM) G:IBY DIVQ
S VAINDT=+IBU\1_.23 D ADM^VADPT2 I VADMVT S IBY=$$INP(VADMVT) G:IBY DIVQ
S VAINDT=$S($P(IBEV,".",2):IBEV,1:+IBEV\1_.23) D ADM^VADPT2 I VADMVT S IBY=$$INP(VADMVT)
;
DIVQ ; - If a division cannot be determined, use the primary division.
I 'IBY S IBY=$$PRIM^VASITE(DT) S:IBY'>0 IBY=0
Q IBY
;
INP(X) ; - Return division for a movement.
Q +$P($G(^DIC(42,+$P($G(^DGPM(+$G(X),0)),U,6),0)),U,11)
;
OPT(X,DFN) ; - Return division for a patient's outpatient visit date.
N IBFR,IBTO,IBY,IBY1,IBZ,IBZERR
S IBY=0 I '$G(X) G OPTQ
S IBFR=X,IBTO=X\1_".99"
F S IBZ=$$EXOE^SDOE(DFN,IBFR,IBTO,,"IBZERR") K IBZERR Q:'IBZ S IBY1=$$SCE^IBSDU(IBZ) D Q:IBY
.I $P(IBY1,U,11) S IBY=$P(IBY1,U,11) Q
.S IBFR=IBY1+.000001
OPTQ Q IBY
;
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 Third Party Receivables
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBJDF2 9476 printed Jan 18, 2025@03:23:59 Page 2
IBJDF2 ;ALB/CPM - THIRD PARTY FOLLOW-UP SUMMARY REPORT ;Feb 09, 2018@10:11:43
+1 ;;2.0;INTEGRATED BILLING;**69,91,100,118,133,205,554,597,568,618,663**;21-MAR-94;Build 27
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;
EN ; - Option entry point.
+1 ;
+2 WRITE !!,"This report provides a summary of all outstanding Third Party receivables.",!
+3 ;
DATE ; - Choose date to use for calculation
+1 WRITE !!,"Calculate report using (D)ATE OF CARE or (A)CTIVE IN AR (days): (A)CTIVE IN AR// "
READ X:DTIME
+2 if '$TEST!(X["^")
GOTO ENQ
if X=""
SET X="A"
SET X=$EXTRACT(X)
+3 IF "ADad"'[X
SET IBOFF=99
DO HELP^IBJDF1H
GOTO DATE
+4 WRITE " ",$SELECT("Dd"[X:"DATE OF CARE",1:"(DAYS) ACTIVE IN AR")
+5 SET IBSDATE=$SELECT("Dd"[X:"D",1:"A")
+6 ;
+7 ; - Sort by division.
+8 SET DIR(0)="Y"
SET DIR("B")="NO"
+9 SET DIR("A")="Do you wish to sort this report by division"
+10 SET DIR("?")="^D DHLP^IBJDF2"
+11 DO ^DIR
KILL DIR
IF $DATA(DIRUT)!$DATA(DTOUT)!$DATA(DUOUT)!$DATA(DIROUT)
GOTO ENQ
+12 SET IBSORT=+Y
KILL DIROUT,DTOUT,DUOUT,DIRUT
+13 ;
+14 ; - Issue prompt for division.
+15 IF IBSORT
DO PSDR^IBODIV
if Y<0
GOTO ENQ
+16 ;
TYP ; - Select type of summaries to print.
+1 ; IB*2.0*554 DRF 10/19/2015 Add Non-VA care
+2 WRITE !!,"Choose which type of summaries to print:",!
+3 SET DIR(0)="LO^1:5^K:+$P(X,""-"",2)>5 X"
+4 SET DIR("A",1)=" 1 - INPATIENT RECEIVABLES"
+5 SET DIR("A",2)=" 2 - OUTPATIENT RECEIVABLES"
+6 SET DIR("A",3)=" 3 - PHARMACY REFILL RECEIVABLES"
+7 SET DIR("A",4)=" 4 - COMMUNITY CARE RECEIVABLES"
+8 SET DIR("A",5)=" 5 - ALL RECEIVABLES"
+9 SET DIR("A",6)=""
SET DIR("A")="Select"
SET DIR("B")=5
+10 DO ^DIR
KILL DIR
IF $DATA(DIRUT)!$DATA(DTOUT)!$DATA(DUOUT)!$DATA(DIROUT)
GOTO ENQ
+11 SET IBSEL=Y
KILL DIROUT,DTOUT,DUOUT,DIRUT
+12 ;
+13 WRITE !!,"This report only requires an 80 column printer."
+14 WRITE !!,"Note: This report requires a search through all active receivables."
+15 WRITE !?6,"You should queue this report to run after normal business hours.",!
+16 ;
+17 ; - Select a device.
+18 SET %ZIS="QM"
DO ^%ZIS
if POP
GOTO ENQ
+19 IF $DATA(IO("Q"))
Begin DoDot:1
+20 SET ZTRTN="DQ^IBJDF2"
SET ZTDESC="IB - FOLLOW-UP SUMMARY REPORT"
+21 FOR I="IBSEL","IBSDATE","IBSORT","VAUTD","VAUTD("
SET ZTSAVE(I)=""
+22 DO ^%ZTLOAD
+23 WRITE !!,$SELECT($DATA(ZTSK):"This job has been queued. The task number is "_ZTSK_".",1:"Unable to queue this job.")
+24 KILL ZTSK,IO("Q")
DO HOME^%ZIS
End DoDot:1
GOTO ENQ
+25 ;
+26 USE IO
+27 ;
DQ ; - Tasked entry point.
+1 ;
+2 ; Change extract status.
IF $GET(IBXTRACT)
DO E^IBJDE(9,1)
+3 ;
+4 KILL IB
FOR I=1,2,3,4,5
IF IBSEL[I
Begin DoDot:1
+5 IF 'IBSORT
Begin DoDot:2
+6 FOR J=1:1:9
SET IB(0,I,J)=""
End DoDot:2
QUIT
+7 IF 'VAUTD
Begin DoDot:2
+8 SET J=0
FOR
SET J=$ORDER(VAUTD(J))
if 'J
QUIT
FOR K=1:1:9
SET IB(J,I,K)=""
End DoDot:2
QUIT
+9 SET J=0
FOR
SET J=$ORDER(^DG(40.8,J))
if 'J
QUIT
FOR K=1:1:9
SET IB(J,I,K)=""
End DoDot:1
+10 ;
+11 ; - Find data required for the report.
+12 SET (IBQ,IBA)=0
FOR
SET IBA=$ORDER(^PRCA(430,"AC",16,IBA))
if 'IBA
QUIT
Begin DoDot:1
+13 ;
+14 IF IBA#100=0
SET IBQ=$$STOP^IBOUTL("Third Party Follow-Up Summary Report")
if IBQ
QUIT
+15 ;
+16 ;IB*2.0*618 moved ahead of AR Cat check to ensure bill exists before performing lookup in CHKARNUM
+17 ; No activation date.
if "Aa"[IBSDATE
SET IBARD=$$ACT(IBA)
if "Dd"[IBSDATE
SET IBARD=$$DATE1(IBA)
IF 'IBARD
QUIT
+18 ; No corresponding claim to this AR.
IF '$DATA(^DGCR(399,IBA,0))
QUIT
+19 ;
+20 SET IBAR=$GET(^PRCA(430,IBA,0))
+21 ;**IB*2.0*618 - Change add new AR Categories and AR Category/
+22 ; Rate Types
+23 ; Get AR Cat Num
SET IBARNUM=$$GET1^DIQ(430.2,$PIECE(IBAR,U,2)_",",6)
+24 ;Confirm RI Bill, quit if not
if '$$CHKARNUM^IBJDF11(IBARNUM)
QUIT
+25 ;
+26 ; - Get division if necessary.
+27 IF 'IBSORT
SET IBDIV=0
+28 IF '$TEST
SET IBDIV=$$DIV(IBA)
IF 'IBDIV
SET IBDIV=+$$PRIM^VASITE()
+29 ; Not a selected division.
IF IBSORT
IF 'VAUTD
if '$DATA(VAUTD(IBDIV))
QUIT
+30 ;
+31 ; - Determine whether bill is inpatient, outpatient, or RX refill.
+32 SET IBTYP=$PIECE($GET(^DGCR(399,IBA,0)),U,5)
SET IBTYP=$SELECT(IBTYP>2:2,1:1)
+33 if $DATA(^IBA(362.4,"C",IBA))
SET IBTYP=3
+34 ;IB*2*554/DRF Look for Non-VA
IF $PIECE(IBAR,U,2)=45
SET IBTYP=4
+35 ;CC types
SET IBTYP=$SELECT(IBARNUM=50:4,IBARNUM=51:4,IBARNUM=52:4,IBARNUM=53:4,1:IBTYP)
+36 IF IBSEL'[IBTYP
IF IBSEL'[5
QUIT
+37 ;
+38 ; - Handle claims referred to Regional Counsel.
+39 SET IBOUT=+$GET(^PRCA(430,IBA,7))
+40 IF $PIECE($GET(^PRCA(430,IBA,6)),U,4)
Begin DoDot:2
+41 FOR I=IBTYP,5
IF IBSEL[I
Begin DoDot:3
+42 SET $PIECE(IB(IBDIV,I,8),U)=+IB(IBDIV,I,8)+1
+43 SET $PIECE(IB(IBDIV,I,8),U,2)=$PIECE(IB(IBDIV,I,8),U,2)+IBOUT
End DoDot:3
End DoDot:2
QUIT
+44 ;
+45 ; - Determine age and outstanding balance.
+46 SET IBAGE=$$FMDIFF^XLFDT(DT,IBARD)
SET IBCAT=$$CAT(IBAGE)
+47 ;
+48 FOR I=IBTYP,5
IF IBSEL[I
Begin DoDot:2
+49 SET $PIECE(IB(IBDIV,I,IBCAT),U)=+IB(IBDIV,I,IBCAT)+1
+50 SET $PIECE(IB(IBDIV,I,IBCAT),U,2)=$PIECE(IB(IBDIV,I,IBCAT),U,2)+IBOUT
End DoDot:2
End DoDot:1
if IBQ
QUIT
+51 ;
+52 IF IBQ
GOTO ENQ
+53 ;
+54 ; - Extract summary data.
+55 ; *597 fix array subscripts for all types
+56 IF $GET(IBXTRACT)
Begin DoDot:1
+57 FOR I=1:1:8
Begin DoDot:2
+58 FOR J=1,2
SET $PIECE(IB(0,5,9),U,J)=$PIECE(IB(0,5,9),U,J)+$PIECE(IB(0,5,I),U,J)
End DoDot:2
+59 SET I=0
FOR J=1:1:9
Begin DoDot:2
+60 SET I=I+1
SET IB(I)=+IB(0,5,J)
SET I=I+1
SET IB(I)=$JUSTIFY(+$PIECE(IB(0,5,J),U,2),0,2)
End DoDot:2
+61 DO E^IBJDE(9,0)
End DoDot:1
GOTO ENQ
+62 ;
+63 ; - Print the reports.
+64 SET (IBPAG,IBQ)=0
DO NOW^%DTC
SET IBRUN=$$DAT2^IBOUTL(%)
+65 IF 'IBSORT
DO SUM(0)
GOTO ENQ
+66 ;
+67 SET IBDIV=0
FOR
SET IBDIV=$ORDER(IB(IBDIV))
if 'IBDIV
QUIT
DO SUM(IBDIV)
if IBQ
QUIT
+68 ;
ENQ IF $DATA(ZTQUEUED)
SET ZTREQ="@"
GOTO ENQ1
+1 ;
+2 DO ^%ZISC
ENQ1 KILL IB,IBOFF,IBQ,IBSDATE,IBSEL,IBSORT,IBTEXT,IBA,IBAR,IBARD,IBDIV,IBAGE,IBOUT,IBCAT,IBPAG,IBRUN
+1 KILL IBDH,IBTYP,IBTYPH,%,%ZIS,DFN,I,J,K,POP,VAUTD,X,Y,Z,ZTDESC,ZTRTN,ZTSAVE,IBARNUM
+2 KILL DIROUT,DTOUT,DUOUT,DIRUT
+3 QUIT
+4 ;
SUM(IBDIV) ; - Print the report.
+1 ; Input: IBDIV=Pointer to the division in file #40.8
+2 ;
+3 SET IBTYP=0
FOR
SET IBTYP=$ORDER(IB(IBDIV,IBTYP))
if 'IBTYP
QUIT
Begin DoDot:1
+4 IF $EXTRACT(IOST,1,2)="C-"!(IBPAG)
WRITE @IOF,*13
+5 SET IBPAG=IBPAG+1
IF $EXTRACT(IOST,1,2)'="C-"
WRITE !?68,"Page: ",IBPAG
+6 WRITE !!?22,"THIRD PARTY FOLLOW-UP SUMMARY REPORT"
+7 SET IBTYPH=$SELECT(IBTYP=1:"INPATIENT",IBTYP=2:"OUTPATIENT",IBTYP=3:"RX REFILL",IBTYP=4:"NON-VA",1:"ALL REIMBURSABLE")_" RECEIVABLES"_$SELECT(IBSDATE="D":" ( date of care )",1:" ( days in AR )")
+8 WRITE !?(80-$LENGTH(IBTYPH))\2,IBTYPH
+9 IF IBDIV
SET IBDH="Division: "_$PIECE($GET(^DG(40.8,IBDIV,0)),U)
WRITE !?(80-$LENGTH(IBDH)\2),IBDH
+10 WRITE !!?24,"Run Date: ",IBRUN,!?24,$$DASH(31),!!
+11 ;
+12 ; - Calculate totals first.
+13 FOR I=1:1:8
FOR J=1,2
SET $PIECE(IB(IBDIV,IBTYP,9),U,J)=$PIECE(IB(IBDIV,IBTYP,9),U,J)+$PIECE(IB(IBDIV,IBTYP,I),U,J)
+14 ;
+15 WRITE "AR Category",?31,"# Receivables",?52,"Total Outstanding Balance"
+16 WRITE !,"-----------",?31,"-------------",?52,"-------------------------",!
+17 ;
+18 IF 'IB(IBDIV,IBTYP,9)
WRITE !,"There are no active receivables",$SELECT(IBDIV:" for this division",1:""),"."
DO PAUSE
QUIT
+19 ;
+20 ; - Primary loop to write results.
+21 SET Y=$PIECE(IB(IBDIV,IBTYP,9),U,2)
FOR I=1:1:9
SET X=$PIECE($TEXT(CATN+I),";;",2,99)
Begin DoDot:2
+22 if I=9
WRITE !
WRITE !,X,?30,$JUSTIFY(+IB(IBDIV,IBTYP,I),6)
+23 WRITE " (",$JUSTIFY(+IB(IBDIV,IBTYP,I)/+IB(IBDIV,IBTYP,9)*100,0,$SELECT(I=9:0,1:2)),"%)"
+24 SET Z=$FNUMBER($PIECE(IB(IBDIV,IBTYP,I),U,2),",",2)
+25 WRITE ?52,$JUSTIFY($SELECT(I=1!(I=9):"$",1:"")_Z,15)
+26 WRITE " (",$JUSTIFY($SELECT('Y:0,1:$PIECE(IB(IBDIV,IBTYP,I),U,2)/Y*100),0,$SELECT(I=9:0,1:2)),"%)"
End DoDot:2
+27 ;
+28 DO PAUSE
End DoDot:1
if IBQ
QUIT
+29 ;
SUMQ 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 ;
DHLP ; - 'Display Registration User' help.
+1 WRITE !,"Enter <CR> to summarize all receivables without regard to division,"
+2 WRITE !,"or YES to select those divisions for which a separate report should"
+3 WRITE !,"be created."
+4 QUIT
+5 ;
CAT(X) ; - Determine category to place receivable.
+1 QUIT $SELECT($GET(X)<31:1,X<61:2,X<91:3,X<121:4,X<181:5,X<366:6,1:7)
+2 ;
ACT(X) ; - Determine the activation date for a receivable.
+1 NEW Y
SET Y=0
IF '$GET(X)
GOTO ACTQ
+2 SET Y=$PIECE($GET(^PRCA(430,X,6)),U,21)
IF Y
GOTO ACTQ
+3 SET Y=$PIECE($GET(^PRCA(430,X,9)),U,3)
IF Y
GOTO ACTQ
+4 SET Y=$PIECE($GET(^PRCA(430,X,0)),U,10)
ACTQ QUIT Y
+1 ;
DATE1(X) ; - Determine the Date of Care
+1 NEW Y
SET Y=0
IF '$GET(X)
GOTO DATEQ
+2 SET Y=$PIECE($GET(^DGCR(399,X,"U")),U,2)
IF Y
GOTO DATEQ
DATEQ QUIT Y
+1 ;
DIV(IBX) ; - Determine the division for a claim.
+1 ; Input: IBX=Pointer to a claim in file #399
+2 ; Output: IBY=Pointer to a division in file #40.8,
+3 ; or 0 if not determined
+4 ;
+5 NEW DFN,IBADM,IBEV,IBD,IBPTF,IBU,IBY,IBC,IBTY,VAINDT,VADMVT
+6 SET IBY=0
SET IBC=$GET(^DGCR(399,+$GET(IBX),0))
IF $PIECE(IBC,U)=""
GOTO DIVQ
+7 SET DFN=+$PIECE(IBC,U,2)
SET IBEV=+$PIECE(IBC,U,3)\1
SET IBTY=$PIECE(IBC,U,5)
+8 ;
+9 ; use bill default division if defined
SET IBY=+$PIECE(IBC,U,22)
IF +IBY
GOTO DIVQ
+10 ;
+11 ; - For Pharmacy or Prosthetics claims, use the primary division.
+12 IF $DATA(^IBA(362.4,"AIFN"_IBX))!$DATA(^IBA(362.5,"AIFN"_IBX))
Begin DoDot:1
+13 SET IBY=$$PRIM^VASITE(DT)
if IBY'>0
SET IBY=0
End DoDot:1
GOTO DIVQ
+14 ;
+15 ; - Check all visit dates if outpatient claim.
+16 IF IBTY>2
Begin DoDot:1
+17 SET IBY=$$OPT(IBEV,DFN)
if IBY
QUIT
+18 SET IBD=0
FOR
SET IBD=$ORDER(^DGCR(399,IBX,"OP",IBD))
if 'IBD
QUIT
SET IBY=$$OPT(IBD,DFN)
if IBY
QUIT
End DoDot:1
GOTO DIVQ
+19 ;
+20 ; - Check inpatient claim.
+21 SET IBPTF=+$PIECE(IBC,U,8)
SET IBU=$GET(^DGCR(399,IBX,"U"))
+22 IF IBPTF
SET IBADM=$ORDER(^DGPM("APTF",IBPTF,0))
IF IBADM
SET IBY=$$INP(IBADM)
if IBY
GOTO DIVQ
+23 SET VAINDT=+IBU\1_.23
DO ADM^VADPT2
IF VADMVT
SET IBY=$$INP(VADMVT)
if IBY
GOTO DIVQ
+24 SET VAINDT=$SELECT($PIECE(IBEV,".",2):IBEV,1:+IBEV\1_.23)
DO ADM^VADPT2
IF VADMVT
SET IBY=$$INP(VADMVT)
+25 ;
DIVQ ; - If a division cannot be determined, use the primary division.
+1 IF 'IBY
SET IBY=$$PRIM^VASITE(DT)
if IBY'>0
SET IBY=0
+2 QUIT IBY
+3 ;
INP(X) ; - Return division for a movement.
+1 QUIT +$PIECE($GET(^DIC(42,+$PIECE($GET(^DGPM(+$GET(X),0)),U,6),0)),U,11)
+2 ;
OPT(X,DFN) ; - Return division for a patient's outpatient visit date.
+1 NEW IBFR,IBTO,IBY,IBY1,IBZ,IBZERR
+2 SET IBY=0
IF '$GET(X)
GOTO OPTQ
+3 SET IBFR=X
SET IBTO=X\1_".99"
+4 FOR
SET IBZ=$$EXOE^SDOE(DFN,IBFR,IBTO,,"IBZERR")
KILL IBZERR
if 'IBZ
QUIT
SET IBY1=$$SCE^IBSDU(IBZ)
Begin DoDot:1
+5 IF $PIECE(IBY1,U,11)
SET IBY=$PIECE(IBY1,U,11)
QUIT
+6 SET IBFR=IBY1+.000001
End DoDot:1
if IBY
QUIT
OPTQ QUIT IBY
+1 ;
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 Third Party Receivables
