IBJDF1 ;ALB/CPM - THIRD PARTY FOLLOW-UP REPORT ;09-JAN-97
;;2.0;INTEGRATED BILLING;**69,118,128,205,554,618,663,739**;21-MAR-94;Build 3
;Per VA Directive 6402, this routine should not be modified.
;
EN ; - Option entry point.
;
W !!,"This report provides a tool for sites to use to perform follow-up"
W !,"activities for 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("?")="^S IBOFF=1 D HELP^IBJDF1H"
D ^DIR K DIR I $D(DIRUT)!$D(DTOUT)!$D(DUOUT)!$D(DIROUT) G ENQ
S IBSD=+Y K DIROUT,DTOUT,DUOUT,DIRUT
;
; - Issue prompt for division.
I IBSD D PSDR^IBODIV G:Y<0 ENQ
;
INS ; - Determine range of carriers.
W !!,"Run report for (S)PECIFIC insurance companies or a (R)ANGE: RANGE// "
R X:DTIME G:'$T!(X["^") ENQ S:X="" X="R" S X=$E(X)
I "RSrs"'[X S IBOFF=8 D HELP^IBJDF1H G INS
W " ",$S("Ss"[X:"SPECIFIC",1:"RANGE") G:"Rr"[X INS1 K IBSI
INS0 S DIC="^DIC(36,",DIC(0)="AEQMZ",DIC("S")="I '$G(^(5))"
S DIC("A")=" Select "_$S($G(IBSI):"another ",1:"")_"INSURANCE CO.: "
D ^DIC K DIC I Y'>0 G ENQ:'$G(IBSI),NAM
I $D(IBSI(+Y)) D G INS0
.W !!?3,"Already selected. Choose another insurance company.",!,*7
S IBSI(+Y)="" S:'$G(IBSI) IBSI=1 G INS0
INS1 R !?3,"START WITH INSURANCE COMPANY: FIRST// ",X:DTIME G:'$T!(X["^") ENQ
I $E(X)="?" S IBOFF=14 D HELP^IBJDF1H G INS1
S IBSIF=X
INS2 R !?8,"GO TO INSURANCE COMPANY: LAST// ",X:DTIME G:'$T!(X["^") ENQ
I $E(X)="?" S IBOFF=21 D HELP^IBJDF1H G INS2
I X="" S IBSIL="zzzzz" S:IBSIF="" IBSIA="ALL" G NAM
I X="@",IBSIF="@" S IBSIL="@",IBSIA="NULL" G NAM
I IBSIF'="@",IBSIF]X D G INS2
.W *7,!!?4,"The LAST value must follow the FIRST.",!
S IBSIL=X
;
NAM ; - Determine range of patients.
;S DIR(0)="SA^N:NAME;L:LAST 4" ;IB*2.0*739
;S DIR("A")="Sort Patients by (N)AME or (L)AST of the SSN: " ;IB*2.0*739
;S DIR("B")="NAME",DIR("T")=20,DIR("?")="^S IBOFF=29 D HELP^IBJDF1H" ;IB*2.0*739
;W ! D ^DIR K DIR G:Y=""!(X="^") ENQ S IBSN=Y,IBI=Y(0) ;IB*2.0*739
S IBSN="N",IBI="NAME" ;IB*2.0*739
NAM1 W !?3,"START WITH PATIENT ",IBI,": FIRST// " R X:DTIME G:'$T!(X["^") ENQ
I $E(X)="?" S IBOFF=36 D HELP^IBJDF1H G NAM1
S IBSNF=X
NAM2 W !?8,"GO TO PATIENT ",IBI,": LAST// " R X:DTIME G:'$T!(X["^") ENQ
I $E(X)="?" S IBOFF=43 D HELP^IBJDF1H G NAM2
I X="" S IBSNL="zzzzz" S:IBSNF="" IBSNA="ALL" G TYP
I X="@",IBSNF="@" S IBSNL="@",IBSNA="NULL" G TYP
I IBSNF'="@",IBSNF]X D G NAM2
.W *7,!!?7,"The LAST value must follow the FIRST.",!
S IBSNL=X
;
TYP ; - Select type of receivables to print.
; IB*2.0*554/DRF 10/20/2015 Add Non-VA care
; IB*2.0*? Changed Non-VA care to Community Care
W !!,"Choose which type of receivables to print:",!
S DIR(0)="LO^1:5^K:+$P(X,""-"",2)>5 X"
S DIR("A",1)=" 1 - INPATIENT"
S DIR("A",2)=" 2 - OUTPATIENT"
S DIR("A",3)=" 3 - PHARMACY REFILL"
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
;
AR ; - 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=51 D HELP^IBJDF1H G AR
W " ",$S("Rr"[X:"RANGE",1:"ALL")
S IBSMN=$S("Rr"[X:"R",1:"A") I IBSMN="A" G AMT
;
AGE ;-Determine the active receivable age range.
S DIR(0)="NA^1:99999",DIR("?")="^S IBOFF=59 D HELP^IBJDF1H"
S DIR("A")=" Enter the minimum age of the active receivable: "
D ^DIR K DIR I $D(DIRUT)!$D(DTOUT)!$D(DUOUT)!$D(DIROUT) G ENQ
S IBSMN=+Y W " ",IBSMN," DAYS" K DIROUT,DTOUT,DUOUT,DIRUT
;
S DIR(0)="NA^"_IBSMN_":99999",DIR("?")="^S IBOFF=64 D HELP^IBJDF1H"
S DIR("A")=" Enter the maximum age of the active receivable: "
S DIR("B")=IBSMN D ^DIR K DIR
I $D(DIRUT)!$D(DTOUT)!$D(DUOUT)!$D(DIROUT) G 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("?")="^S IBOFF=69 D HELP^IBJDF1H"
D ^DIR K DIR I $D(DIRUT)!$D(DTOUT)!$D(DUOUT)!$D(DIROUT) G ENQ
S IBSAM=+Y K DIROUT,DTOUT,DUOUT,DIRUT I 'IBSAM G BCH
;
AMT1 ; - Determine the minimum balance amount.
S DIR(0)="NA^1:9999999",DIR("?")="^S IBOFF=76 D HELP^IBJDF1H"
S DIR("A")=" Enter the minimum balance amount of the receivable: "
D ^DIR K DIR I $D(DIRUT)!$D(DTOUT)!$D(DUOUT)!$D(DIROUT) G ENQ
S IBSAM=+Y K DIROUT,DTOUT,DUOUT,DIRUT
;
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("?")="^S IBOFF=81 D HELP^IBJDF1H"
D ^DIR K DIR I $D(DIRUT)!$D(DTOUT)!$D(DUOUT)!$D(DIROUT) G ENQ
S IBSH=+Y K DIROUT,DTOUT,DUOUT,DIRUT
;
RC ; - Include receivables referred to Regional Counsel?
S DIR(0)="Y",DIR("B")="NO" W !
S DIR("A")="Include receivables referred to Regional Counsel"
S DIR("?")="^S IBOFF=90 D HELP^IBJDF1H"
D ^DIR I $D(DIRUT)!$D(DTOUT)!$D(DUOUT)!$D(DIROUT) G ENQ
S IBSRC=+Y K DIROUT,DTOUT,DUOUT,DIRUT
;
W !!,"This report requires a 132 column printer."
W !!,"Note: This report will search through all active receivables."
W !?6,"You should queue this report to run after normal business hours."
;
; - Select a device.
W ! S %ZIS="QM" D ^%ZIS G:POP ENQ
I $D(IO("Q")) D G ENQ
.S ZTRTN="DQ^IBJDF11",ZTDESC="IB - THIRD PARTY FOLLOW-UP REPORT"
.F I="IBS*","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
;
D DQ^IBJDF11 ; Compile and print the report.
;
ENQ K IBSD,IBSEL,IBSI,IBSIF,IBSIL,IBSIA,IBSN,IBSNF,IBSNL,IBOFF,IBSNA,IBSH
K IBSAM,IBSDATE,IBSMN,IBSMX,IBSRC,IBTEXT,IBI,POP,VAUTD,%ZIS,ZTDESC,ZTRTN,ZTSAVE,DIR
K DIROUT,DTOUT,DUOUT,DIRUT
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBJDF1 6457 printed Dec 13, 2024@02:22:43 Page 2
IBJDF1 ;ALB/CPM - THIRD PARTY FOLLOW-UP REPORT ;09-JAN-97
+1 ;;2.0;INTEGRATED BILLING;**69,118,128,205,554,618,663,739**;21-MAR-94;Build 3
+2 ;Per VA Directive 6402, this routine should not be modified.
+3 ;
EN ; - Option entry point.
+1 ;
+2 WRITE !!,"This report provides a tool for sites to use to perform follow-up"
+3 WRITE !,"activities for Third Party receivables.",!
+4 ;
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("?")="^S IBOFF=1 D HELP^IBJDF1H"
+11 DO ^DIR
KILL DIR
IF $DATA(DIRUT)!$DATA(DTOUT)!$DATA(DUOUT)!$DATA(DIROUT)
GOTO ENQ
+12 SET IBSD=+Y
KILL DIROUT,DTOUT,DUOUT,DIRUT
+13 ;
+14 ; - Issue prompt for division.
+15 IF IBSD
DO PSDR^IBODIV
if Y<0
GOTO ENQ
+16 ;
INS ; - Determine range of carriers.
+1 WRITE !!,"Run report for (S)PECIFIC insurance companies or a (R)ANGE: RANGE// "
+2 READ X:DTIME
if '$TEST!(X["^")
GOTO ENQ
if X=""
SET X="R"
SET X=$EXTRACT(X)
+3 IF "RSrs"'[X
SET IBOFF=8
DO HELP^IBJDF1H
GOTO INS
+4 WRITE " ",$SELECT("Ss"[X:"SPECIFIC",1:"RANGE")
if "Rr"[X
GOTO INS1
KILL IBSI
INS0 SET DIC="^DIC(36,"
SET DIC(0)="AEQMZ"
SET DIC("S")="I '$G(^(5))"
+1 SET DIC("A")=" Select "_$SELECT($GET(IBSI):"another ",1:"")_"INSURANCE CO.: "
+2 DO ^DIC
KILL DIC
IF Y'>0
if '$GET(IBSI)
GOTO ENQ
GOTO NAM
+3 IF $DATA(IBSI(+Y))
Begin DoDot:1
+4 WRITE !!?3,"Already selected. Choose another insurance company.",!,*7
End DoDot:1
GOTO INS0
+5 SET IBSI(+Y)=""
if '$GET(IBSI)
SET IBSI=1
GOTO INS0
INS1 READ !?3,"START WITH INSURANCE COMPANY: FIRST// ",X:DTIME
if '$TEST!(X["^")
GOTO ENQ
+1 IF $EXTRACT(X)="?"
SET IBOFF=14
DO HELP^IBJDF1H
GOTO INS1
+2 SET IBSIF=X
INS2 READ !?8,"GO TO INSURANCE COMPANY: LAST// ",X:DTIME
if '$TEST!(X["^")
GOTO ENQ
+1 IF $EXTRACT(X)="?"
SET IBOFF=21
DO HELP^IBJDF1H
GOTO INS2
+2 IF X=""
SET IBSIL="zzzzz"
if IBSIF=""
SET IBSIA="ALL"
GOTO NAM
+3 IF X="@"
IF IBSIF="@"
SET IBSIL="@"
SET IBSIA="NULL"
GOTO NAM
+4 IF IBSIF'="@"
IF IBSIF]X
Begin DoDot:1
+5 WRITE *7,!!?4,"The LAST value must follow the FIRST.",!
End DoDot:1
GOTO INS2
+6 SET IBSIL=X
+7 ;
NAM ; - Determine range of patients.
+1 ;S DIR(0)="SA^N:NAME;L:LAST 4" ;IB*2.0*739
+2 ;S DIR("A")="Sort Patients by (N)AME or (L)AST of the SSN: " ;IB*2.0*739
+3 ;S DIR("B")="NAME",DIR("T")=20,DIR("?")="^S IBOFF=29 D HELP^IBJDF1H" ;IB*2.0*739
+4 ;W ! D ^DIR K DIR G:Y=""!(X="^") ENQ S IBSN=Y,IBI=Y(0) ;IB*2.0*739
+5 ;IB*2.0*739
SET IBSN="N"
SET IBI="NAME"
NAM1 WRITE !?3,"START WITH PATIENT ",IBI,": FIRST// "
READ X:DTIME
if '$TEST!(X["^")
GOTO ENQ
+1 IF $EXTRACT(X)="?"
SET IBOFF=36
DO HELP^IBJDF1H
GOTO NAM1
+2 SET IBSNF=X
NAM2 WRITE !?8,"GO TO PATIENT ",IBI,": LAST// "
READ X:DTIME
if '$TEST!(X["^")
GOTO ENQ
+1 IF $EXTRACT(X)="?"
SET IBOFF=43
DO HELP^IBJDF1H
GOTO NAM2
+2 IF X=""
SET IBSNL="zzzzz"
if IBSNF=""
SET IBSNA="ALL"
GOTO TYP
+3 IF X="@"
IF IBSNF="@"
SET IBSNL="@"
SET IBSNA="NULL"
GOTO TYP
+4 IF IBSNF'="@"
IF IBSNF]X
Begin DoDot:1
+5 WRITE *7,!!?7,"The LAST value must follow the FIRST.",!
End DoDot:1
GOTO NAM2
+6 SET IBSNL=X
+7 ;
TYP ; - Select type of receivables to print.
+1 ; IB*2.0*554/DRF 10/20/2015 Add Non-VA care
+2 ; IB*2.0*? Changed Non-VA care to Community Care
+3 WRITE !!,"Choose which type of receivables to print:",!
+4 SET DIR(0)="LO^1:5^K:+$P(X,""-"",2)>5 X"
+5 SET DIR("A",1)=" 1 - INPATIENT"
+6 SET DIR("A",2)=" 2 - OUTPATIENT"
+7 SET DIR("A",3)=" 3 - PHARMACY REFILL"
+8 SET DIR("A",4)=" 4 - COMMUNITY CARE RECEIVABLES"
+9 SET DIR("A",5)=" 5 - ALL RECEIVABLES"
+10 SET DIR("A",6)=""
SET DIR("A")="Select"
SET DIR("B")=5
+11 DO ^DIR
KILL DIR
IF $DATA(DIRUT)!$DATA(DTOUT)!$DATA(DUOUT)!$DATA(DIROUT)
GOTO ENQ
+12 SET IBSEL=Y
KILL DIROUT,DTOUT,DUOUT,DIRUT
+13 ;
AR ; - 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// "
READ X:DTIME
+2 if '$TEST!(X["^")
GOTO ENQ
if X=""
SET X="A"
SET X=$EXTRACT(X)
+3 IF "ARar"'[X
SET IBOFF=51
DO HELP^IBJDF1H
GOTO AR
+4 WRITE " ",$SELECT("Rr"[X:"RANGE",1:"ALL")
+5 SET IBSMN=$SELECT("Rr"[X:"R",1:"A")
IF IBSMN="A"
GOTO AMT
+6 ;
AGE ;-Determine the active receivable age range.
+1 SET DIR(0)="NA^1:99999"
SET DIR("?")="^S IBOFF=59 D HELP^IBJDF1H"
+2 SET DIR("A")=" Enter the minimum age of the active receivable: "
+3 DO ^DIR
KILL DIR
IF $DATA(DIRUT)!$DATA(DTOUT)!$DATA(DUOUT)!$DATA(DIROUT)
GOTO ENQ
+4 SET IBSMN=+Y
WRITE " ",IBSMN," DAYS"
KILL DIROUT,DTOUT,DUOUT,DIRUT
+5 ;
+6 SET DIR(0)="NA^"_IBSMN_":99999"
SET DIR("?")="^S IBOFF=64 D HELP^IBJDF1H"
+7 SET DIR("A")=" Enter the maximum age of the active receivable: "
+8 SET DIR("B")=IBSMN
DO ^DIR
KILL DIR
+9 IF $DATA(DIRUT)!$DATA(DTOUT)!$DATA(DUOUT)!$DATA(DIROUT)
GOTO ENQ
+10 SET IBSMX=+Y
WRITE " ",IBSMX," DAYS"
KILL DIROUT,DTOUT,DUOUT,DIRUT
+11 ;
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("?")="^S IBOFF=69 D HELP^IBJDF1H"
+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 BCH
+6 ;
AMT1 ; - Determine the minimum balance amount.
+1 SET DIR(0)="NA^1:9999999"
SET DIR("?")="^S IBOFF=76 D HELP^IBJDF1H"
+2 SET DIR("A")=" Enter the minimum balance amount of the receivable: "
+3 DO ^DIR
KILL DIR
IF $DATA(DIRUT)!$DATA(DTOUT)!$DATA(DUOUT)!$DATA(DIROUT)
GOTO ENQ
+4 SET IBSAM=+Y
KILL DIROUT,DTOUT,DUOUT,DIRUT
+5 ;
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("?")="^S IBOFF=81 D HELP^IBJDF1H"
+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
+6 ;
RC ; - Include receivables referred to Regional Counsel?
+1 SET DIR(0)="Y"
SET DIR("B")="NO"
WRITE !
+2 SET DIR("A")="Include receivables referred to Regional Counsel"
+3 SET DIR("?")="^S IBOFF=90 D HELP^IBJDF1H"
+4 DO ^DIR
IF $DATA(DIRUT)!$DATA(DTOUT)!$DATA(DUOUT)!$DATA(DIROUT)
GOTO ENQ
+5 SET IBSRC=+Y
KILL DIROUT,DTOUT,DUOUT,DIRUT
+6 ;
+7 WRITE !!,"This report requires a 132 column printer."
+8 WRITE !!,"Note: This report will search through all active receivables."
+9 WRITE !?6,"You should queue this report to run after normal business hours."
+10 ;
+11 ; - Select a device.
+12 WRITE !
SET %ZIS="QM"
DO ^%ZIS
if POP
GOTO ENQ
+13 IF $DATA(IO("Q"))
Begin DoDot:1
+14 SET ZTRTN="DQ^IBJDF11"
SET ZTDESC="IB - THIRD PARTY FOLLOW-UP REPORT"
+15 FOR I="IBS*","VAUTD","VAUTD("
SET ZTSAVE(I)=""
+16 DO ^%ZTLOAD
+17 WRITE !!,$SELECT($DATA(ZTSK):"This job has been queued. The task number is "_ZTSK_".",1:"Unable to queue this job.")
+18 KILL ZTSK,IO("Q")
DO HOME^%ZIS
End DoDot:1
GOTO ENQ
+19 ;
+20 USE IO
+21 ;
+22 ; Compile and print the report.
DO DQ^IBJDF11
+23 ;
ENQ KILL IBSD,IBSEL,IBSI,IBSIF,IBSIL,IBSIA,IBSN,IBSNF,IBSNL,IBOFF,IBSNA,IBSH
+1 KILL IBSAM,IBSDATE,IBSMN,IBSMX,IBSRC,IBTEXT,IBI,POP,VAUTD,%ZIS,ZTDESC,ZTRTN,ZTSAVE,DIR
+2 KILL DIROUT,DTOUT,DUOUT,DIRUT
+3 QUIT
