IBJDF5 ;ALB/RB - CHAMPVA/TRICARE FOLLOW-UP REPORT;15-APR-00
;;2.0;INTEGRATED BILLING;**123,185,240,452,739**;21-MAR-94;Build 3
;;Per VHA Directive 2004-038, this routine should not be modified.
;
EN ; - Option entry point.
;
; - Select AR categories to print.
S IBPRT="Choose which category of receivables to print:"
K IBCTG
S IBCTG(1)="TRICARE PATIENT"
S IBCTG(2)="SHARING AGREEMENTS"
S IBCTG(3)="TRICARE"
S IBCTG(4)="TRICARE THIRD PARTY"
S IBCTG(5)="CHAMPVA"
S IBCTG(6)="CHAMPVA THIRD PARTY"
S IBCTG(7)="ALL OF THE ABOVE"
S IBSEL=$$MLTP^IBJD(IBPRT,.IBCTG,1) I 'IBSEL G ENQ
;
S IBSD=0 I IBSEL="1," G TYP
;
; - Sort by division, if necessary.
S IBSD=$$SDIV^IBJD() G:IBSD["^" ENQ G:'IBSD TYP
;
; - Issue prompt for division.
I IBSD,IBSEL[1 D
. W !!,"NOTE: TRICARE Patient receivables will NOT be sorted"
. W !?6,"by division!",!,*7
;
TYP ; - Select type of receivables to print.
; - Select AR categories to print.
S IBPRT="Choose which type of receivables to print:"
K IBTPR
S IBTPR(1)="INPATIENT"
S IBTPR(2)="OUTPATIENT"
S IBTPR(3)="PHARMACY REFILL"
S IBTPR(4)="ALL RECEIVABLES"
S IBSEL1=$$MLTP^IBJD(IBPRT,.IBTPR,1) I 'IBSEL1 G ENQ
;
; - Select a detailed or summary report.
D DS^IBJD G ENQ:IBRPT["^",DEV:IBRPT="S"
;
;Force sort by name
S IBSN="N" ;IB*2.0*739
;
; - Determine the range
S X=$$INTV^IBJD("PATIENT "_$S(IBSN="N":"NAME",1:"LAST 4")) G ENQ:X="^"
S IBSNF=$P(X,"^",1),IBSNL=$P(X,"^",2),IBSNA=$P(X,"^",3)
;
AGE ; - Determine if the active receivable must be within an age range.
W !!,"Include (A)LL active AR's or those within an AGE (R)ANGE: ALL// "
R X:DTIME G:'$T!(X["^") ENQ S:X="" X="A" S X=$E(X)
I "ARar"'[X S IBOFF=1 D HELP^IBJDF5H G AGE
W " ",$S("Rr"[X:"RANGE",1:"ALL")
S IBSMN=$S("Rr"[X:"R",1:"A") G:IBSMN="A" AMT
;
; - Determine the active receivable age range.
S DIR(0)="NA^1:99999"
S DIR("A")="Enter the minimum age of the active receivable: "
S DIR("T")=DTIME,DIR("?")="^S IBOFF=9 D HELP^IBJDF5H"
D ^DIR K DIR G:$D(DIRUT)!$D(DTOUT)!$D(DUOUT)!$D(DIROUT) ENQ
S IBSMN=+Y W " ",IBSMN," DAYS" K DIROUT,DTOUT,DUOUT,DIRUT
;
S DIR(0)="NA^"_IBSMN_":99999"
S DIR("A")="Enter the maximum age of the active receivable: "
S DIR("B")=IBSMN,DIR("T")=DTIME,DIR("?")="^S IBOFF=14 D HELP^IBJDF5H"
D ^DIR K DIR G:$D(DIRUT)!$D(DTOUT)!$D(DUOUT)!$D(DIROUT) ENQ
S IBSMX=+Y W " ",IBSMX," DAYS" K DIROUT,DTOUT,DUOUT,DIRUT
;
AMT ; - Print receivables with a minimum balance.
S DIR(0)="Y",DIR("B")="NO" W !
S DIR("A")="Print receivables with a minimum balance"
S DIR("T")=DTIME,DIR("?")="^S IBOFF=19 D HELP^IBJDF5H"
D ^DIR K DIR G:$D(DIRUT)!$D(DTOUT)!$D(DUOUT)!$D(DIROUT) ENQ
S IBSAM=+Y K DIROUT,DTOUT,DUOUT,DIRUT G:'IBSAM EXCEL
;
AMT1 ; - Determine the minimum balance amount.
S DIR(0)="NA^1:9999999"
S DIR("A")="Enter the minimum balance amount of the receivable: "
S DIR("T")=DTIME,DIR("?")="^S IBOFF=26 D HELP^IBJDF5H"
D ^DIR K DIR G:$D(DIRUT)!$D(DTOUT)!$D(DUOUT)!$D(DIROUT) ENQ
S IBSAM=+Y K DIROUT,DTOUT,DUOUT,DIRUT
;
EXCEL ; - Determine whether to gather data for Excel report.
S IBEXCEL=$$EXCEL^IBJD() I Y S (IBEXCEL,IBSH)=1,IBSH1="M" G DEV
;
BCH ; - Determine whether to include the bill comment history.
S DIR(0)="Y",DIR("B")="NO" W !
S DIR("A")="Include the bill comment history with each receivable"
S DIR("T")=DTIME,DIR("?")="^S IBOFF=31 D HELP^IBJDF5H"
D ^DIR K DIR G:$D(DIRUT)!$D(DTOUT)!$D(DUOUT)!$D(DIROUT) ENQ
S IBSH=+Y K DIROUT,DTOUT,DUOUT,DIRUT G:'IBSH DEV
;
S DIR(0)="SA^A:ALL;M:MOST RECENT"
S DIR("A")="Print (A)LL comments or the (M)OST RECENT comment: "
S DIR("B")="ALL",DIR("T")=DTIME,DIR("?")="^S IBOFF=40 D HELP^IBJDF5H"
D ^DIR K DIR G:$D(DIRUT)!$D(DTOUT)!$D(DUOUT)!$D(DIROUT) ENQ
S IBSH1=Y K DIROUT,DTOUT,DUOUT,DIRUT G:IBSH1="A" DEV
;
S DIR(0)="NAO^1:999"
S DIR("A")="Minimum age of most recent bill comment (optional): "
S DIR("T")=DTIME,DIR("?")="^S IBOFF=47 D HELP^IBJDF5H"
D ^DIR K DIR G:$D(DTOUT)!$D(DUOUT)!$D(DIROUT) ENQ
S IBSH2=+Y W:IBSH2 " days" K DIROUT,DTOUT,DUOUT
;
DEV ; - Select a device.
I '$G(IBEXCEL) D
. S X=$S(IBRPT="S":80,1:132)
. W !!,"You will need a ",X," column printer for this report!",!
. W !,"Note: This report will search through all active receivables."
. W !," You should queue it to run after normal business hours.",!
;
I $G(IBEXCEL) D EXMSG^IBJD
;
W ! S %ZIS="QM" D ^%ZIS G:POP ENQ
I $D(IO("Q")) D G ENQ
.S ZTRTN="DQ^IBJDF5",ZTDESC="IB - CHAMPVA/TRICARE FOLLOW-UP REPORT"
.F I="IB*","VAUTD","VAUTD(" S ZTSAVE(I)=""
.D ^%ZTLOAD
.I $G(ZTSK) W !!,"This job has been queued. The task no. is ",ZTSK,"."
.E W !!,"Unable to queue this job."
.K ZTSK,IO("Q") D HOME^%ZIS
;
U IO
;
; If called by the Extraction Module, change extract status for the 6
; reports: TRICARE Patient, Sharing Agreements, TRICARE, TRICARE 3rd
; Party, CHAMPVA and CHAMPVA 3rd Party
DQ I $G(IBXTRACT) F I=17:1:21 D E^IBJDE(I,1)
;
D ST^IBJDF51 ; Compile and print the report.
;
ENQ K IBSD,IBSEL,IBSEL1,IBSN,IBSNF,IBSNL,IBSNA,IBOFF,IBSH,IBSH1,IBSH2,IBSAM
K IBPRT,IBCTG,IBRPT,IBTPR,IBSMN,IBSMX,IBTEXT,IBI,IBEXCEL,DIROUT,DTOUT
K DTOUT,DIRUT,POP,VAUTD,%ZIS,ZTDESC,ZTRTN,ZTSAVE,I,X,Y
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBJDF5 5284 printed Sep 23, 2025@19:59:09 Page 2
IBJDF5 ;ALB/RB - CHAMPVA/TRICARE FOLLOW-UP REPORT;15-APR-00
+1 ;;2.0;INTEGRATED BILLING;**123,185,240,452,739**;21-MAR-94;Build 3
+2 ;;Per VHA Directive 2004-038, this routine should not be modified.
+3 ;
EN ; - Option entry point.
+1 ;
+2 ; - Select AR categories to print.
+3 SET IBPRT="Choose which category of receivables to print:"
+4 KILL IBCTG
+5 SET IBCTG(1)="TRICARE PATIENT"
+6 SET IBCTG(2)="SHARING AGREEMENTS"
+7 SET IBCTG(3)="TRICARE"
+8 SET IBCTG(4)="TRICARE THIRD PARTY"
+9 SET IBCTG(5)="CHAMPVA"
+10 SET IBCTG(6)="CHAMPVA THIRD PARTY"
+11 SET IBCTG(7)="ALL OF THE ABOVE"
+12 SET IBSEL=$$MLTP^IBJD(IBPRT,.IBCTG,1)
IF 'IBSEL
GOTO ENQ
+13 ;
+14 SET IBSD=0
IF IBSEL="1,"
GOTO TYP
+15 ;
+16 ; - Sort by division, if necessary.
+17 SET IBSD=$$SDIV^IBJD()
if IBSD["^"
GOTO ENQ
if 'IBSD
GOTO TYP
+18 ;
+19 ; - Issue prompt for division.
+20 IF IBSD
IF IBSEL[1
Begin DoDot:1
+21 WRITE !!,"NOTE: TRICARE Patient receivables will NOT be sorted"
+22 WRITE !?6,"by division!",!,*7
End DoDot:1
+23 ;
TYP ; - Select type of receivables to print.
+1 ; - Select AR categories to print.
+2 SET IBPRT="Choose which type of receivables to print:"
+3 KILL IBTPR
+4 SET IBTPR(1)="INPATIENT"
+5 SET IBTPR(2)="OUTPATIENT"
+6 SET IBTPR(3)="PHARMACY REFILL"
+7 SET IBTPR(4)="ALL RECEIVABLES"
+8 SET IBSEL1=$$MLTP^IBJD(IBPRT,.IBTPR,1)
IF 'IBSEL1
GOTO ENQ
+9 ;
+10 ; - Select a detailed or summary report.
+11 DO DS^IBJD
if IBRPT["^"
GOTO ENQ
if IBRPT="S"
GOTO DEV
+12 ;
+13 ;Force sort by name
+14 ;IB*2.0*739
SET IBSN="N"
+15 ;
+16 ; - Determine the range
+17 SET X=$$INTV^IBJD("PATIENT "_$SELECT(IBSN="N":"NAME",1:"LAST 4"))
if X="^"
GOTO ENQ
+18 SET IBSNF=$PIECE(X,"^",1)
SET IBSNL=$PIECE(X,"^",2)
SET IBSNA=$PIECE(X,"^",3)
+19 ;
AGE ; - Determine if the active receivable must be within an age range.
+1 WRITE !!,"Include (A)LL active AR's or those within an AGE (R)ANGE: ALL// "
+2 READ X:DTIME
if '$TEST!(X["^")
GOTO ENQ
if X=""
SET X="A"
SET X=$EXTRACT(X)
+3 IF "ARar"'[X
SET IBOFF=1
DO HELP^IBJDF5H
GOTO AGE
+4 WRITE " ",$SELECT("Rr"[X:"RANGE",1:"ALL")
+5 SET IBSMN=$SELECT("Rr"[X:"R",1:"A")
if IBSMN="A"
GOTO AMT
+6 ;
+7 ; - Determine the active receivable age range.
+8 SET DIR(0)="NA^1:99999"
+9 SET DIR("A")="Enter the minimum age of the active receivable: "
+10 SET DIR("T")=DTIME
SET DIR("?")="^S IBOFF=9 D HELP^IBJDF5H"
+11 DO ^DIR
KILL DIR
if $DATA(DIRUT)!$DATA(DTOUT)!$DATA(DUOUT)!$DATA(DIROUT)
GOTO ENQ
+12 SET IBSMN=+Y
WRITE " ",IBSMN," DAYS"
KILL DIROUT,DTOUT,DUOUT,DIRUT
+13 ;
+14 SET DIR(0)="NA^"_IBSMN_":99999"
+15 SET DIR("A")="Enter the maximum age of the active receivable: "
+16 SET DIR("B")=IBSMN
SET DIR("T")=DTIME
SET DIR("?")="^S IBOFF=14 D HELP^IBJDF5H"
+17 DO ^DIR
KILL DIR
if $DATA(DIRUT)!$DATA(DTOUT)!$DATA(DUOUT)!$DATA(DIROUT)
GOTO ENQ
+18 SET IBSMX=+Y
WRITE " ",IBSMX," DAYS"
KILL DIROUT,DTOUT,DUOUT,DIRUT
+19 ;
AMT ; - Print receivables with a minimum balance.
+1 SET DIR(0)="Y"
SET DIR("B")="NO"
WRITE !
+2 SET DIR("A")="Print receivables with a minimum balance"
+3 SET DIR("T")=DTIME
SET DIR("?")="^S IBOFF=19 D HELP^IBJDF5H"
+4 DO ^DIR
KILL DIR
if $DATA(DIRUT)!$DATA(DTOUT)!$DATA(DUOUT)!$DATA(DIROUT)
GOTO ENQ
+5 SET IBSAM=+Y
KILL DIROUT,DTOUT,DUOUT,DIRUT
if 'IBSAM
GOTO EXCEL
+6 ;
AMT1 ; - Determine the minimum balance amount.
+1 SET DIR(0)="NA^1:9999999"
+2 SET DIR("A")="Enter the minimum balance amount of the receivable: "
+3 SET DIR("T")=DTIME
SET DIR("?")="^S IBOFF=26 D HELP^IBJDF5H"
+4 DO ^DIR
KILL DIR
if $DATA(DIRUT)!$DATA(DTOUT)!$DATA(DUOUT)!$DATA(DIROUT)
GOTO ENQ
+5 SET IBSAM=+Y
KILL DIROUT,DTOUT,DUOUT,DIRUT
+6 ;
EXCEL ; - Determine whether to gather data for Excel report.
+1 SET IBEXCEL=$$EXCEL^IBJD()
IF Y
SET (IBEXCEL,IBSH)=1
SET IBSH1="M"
GOTO DEV
+2 ;
BCH ; - Determine whether to include the bill comment history.
+1 SET DIR(0)="Y"
SET DIR("B")="NO"
WRITE !
+2 SET DIR("A")="Include the bill comment history with each receivable"
+3 SET DIR("T")=DTIME
SET DIR("?")="^S IBOFF=31 D HELP^IBJDF5H"
+4 DO ^DIR
KILL DIR
if $DATA(DIRUT)!$DATA(DTOUT)!$DATA(DUOUT)!$DATA(DIROUT)
GOTO ENQ
+5 SET IBSH=+Y
KILL DIROUT,DTOUT,DUOUT,DIRUT
if 'IBSH
GOTO DEV
+6 ;
+7 SET DIR(0)="SA^A:ALL;M:MOST RECENT"
+8 SET DIR("A")="Print (A)LL comments or the (M)OST RECENT comment: "
+9 SET DIR("B")="ALL"
SET DIR("T")=DTIME
SET DIR("?")="^S IBOFF=40 D HELP^IBJDF5H"
+10 DO ^DIR
KILL DIR
if $DATA(DIRUT)!$DATA(DTOUT)!$DATA(DUOUT)!$DATA(DIROUT)
GOTO ENQ
+11 SET IBSH1=Y
KILL DIROUT,DTOUT,DUOUT,DIRUT
if IBSH1="A"
GOTO DEV
+12 ;
+13 SET DIR(0)="NAO^1:999"
+14 SET DIR("A")="Minimum age of most recent bill comment (optional): "
+15 SET DIR("T")=DTIME
SET DIR("?")="^S IBOFF=47 D HELP^IBJDF5H"
+16 DO ^DIR
KILL DIR
if $DATA(DTOUT)!$DATA(DUOUT)!$DATA(DIROUT)
GOTO ENQ
+17 SET IBSH2=+Y
if IBSH2
WRITE " days"
KILL DIROUT,DTOUT,DUOUT
+18 ;
DEV ; - Select a device.
+1 IF '$GET(IBEXCEL)
Begin DoDot:1
+2 SET X=$SELECT(IBRPT="S":80,1:132)
+3 WRITE !!,"You will need a ",X," column printer for this report!",!
+4 WRITE !,"Note: This report will search through all active receivables."
+5 WRITE !," You should queue it to run after normal business hours.",!
End DoDot:1
+6 ;
+7 IF $GET(IBEXCEL)
DO EXMSG^IBJD
+8 ;
+9 WRITE !
SET %ZIS="QM"
DO ^%ZIS
if POP
GOTO ENQ
+10 IF $DATA(IO("Q"))
Begin DoDot:1
+11 SET ZTRTN="DQ^IBJDF5"
SET ZTDESC="IB - CHAMPVA/TRICARE FOLLOW-UP REPORT"
+12 FOR I="IB*","VAUTD","VAUTD("
SET ZTSAVE(I)=""
+13 DO ^%ZTLOAD
+14 IF $GET(ZTSK)
WRITE !!,"This job has been queued. The task no. is ",ZTSK,"."
+15 IF '$TEST
WRITE !!,"Unable to queue this job."
+16 KILL ZTSK,IO("Q")
DO HOME^%ZIS
End DoDot:1
GOTO ENQ
+17 ;
+18 USE IO
+19 ;
+20 ; If called by the Extraction Module, change extract status for the 6
+21 ; reports: TRICARE Patient, Sharing Agreements, TRICARE, TRICARE 3rd
+22 ; Party, CHAMPVA and CHAMPVA 3rd Party
DQ IF $GET(IBXTRACT)
FOR I=17:1:21
DO E^IBJDE(I,1)
+1 ;
+2 ; Compile and print the report.
DO ST^IBJDF51
+3 ;
ENQ KILL IBSD,IBSEL,IBSEL1,IBSN,IBSNF,IBSNL,IBSNA,IBOFF,IBSH,IBSH1,IBSH2,IBSAM
+1 KILL IBPRT,IBCTG,IBRPT,IBTPR,IBSMN,IBSMX,IBTEXT,IBI,IBEXCEL,DIROUT,DTOUT
+2 KILL DTOUT,DIRUT,POP,VAUTD,%ZIS,ZTDESC,ZTRTN,ZTSAVE,I,X,Y
+3 QUIT
