RCRCVLB ;ALB/CMS - RC VIEW ACTIVE LIST BUILD ; 09-AUG-97
V ;;4.5;Accounts Receivable;**63,159**;Mar 20, 1995
;;Per VHA Directive 10-93-142, this routine should not be modified.
Q
EN ; entry point from RCRCVL
; Returns: RCSBN,RCSBN(CNT,PRCABN)
; or: RCCAT(catname),RCSI(dbt#),RCSPT,RCSIA,RCSIF,RCSIL,RCSAGN,RCSAGX,RCSAMT,RCSRC
; or: if muti-divisions RCDIV(0),RCDIV(selected 40.8IEN)
; or: RCOUT
N CNT,DA,DIC,PRCA,PRCABN,RCLQ,RCLQA,RCY,RCS,TCNT,T,X,Y
N RCDIV,RCCNT,RCSD,RCRN,RCSN,RCSNF,RCLCNT,RCSNL,RCSNA,RCSAR,RCSH
N DIR,DIROUT,DTOUT,DUOUT,DIRUT
K RCSBN,RCCAT,RCSI,RCSIF,RCSIL,RCSAGN,RCSAGX,RCSAMT,RCSPT,RCSRC,RCOUT
;
;Get Divisions
D RCDIV^RCRCDIV(.RCDIV)
;Select one division if multiple
I $O(RCDIV(0)) D DIVS^RCRCDIV I $G(RCOUT)=1 G ENQ
;
W !!,"Build List of Possible Third Party Referrals"
S DIR("A",1)="Build a list by"
S DIR("A",2)="1. Selected AR Third Party Bill(s)"
S DIR("A",3)="2. Selected Patient(s)"
S DIR("A",4)="3. Selected AR Insurance Debtor(s) or"
S DIR("A",5)=" Insurance Range"
S DIR("A",6)=" "
S DIR("A")=" Select Number: "
S DIR(0)="SAXB^1:Third Party Bills;2:Patients;3:Insurance Debtors"
S DIR("B")=1
D ^DIR I $D(DIRUT)!$D(DTOUT)!$D(DUOUT)!$D(DIROUT) S RCOUT=1 G ENQ
I $E(Y)="^" S RCOUT=1 G ENQ
S RCRN=Y
K DIR,DIROUT,DTOUT,DUOUT,DIRUT
;
I RCRN=1 D BILL G ENQ
I RCRN=2 D PT I '$G(RCOUT) D ASK
I RCRN=3 D INS I '$G(RCOUT) D ASK
ENQ W !
I $G(RCOUT)=1 K RCSBN,RCCAT,RCDIV,RCSI,RCSIA,RCSIF,RCSIL,RCSAGN,RCSAGX,RCSPT,RCSAMT,RCSRC
K DIR,DIROUT,DTOUT,DUOUT,DIRUT
Q
;
;
BILL ; - issue prompt for AR Bill Selection(s)
; - also called from Modify List Protocol
K DIC,DA,X,Y,%Y W !
S DIC("A")="Select Active TP Accounts Receivable Bill No.: "
S DIC="^PRCA(430,",DIC(0)="AQMEZ"
S DIC("S")="I $P(^(0),U,8)=16,$P($G(^PRCA(430.2,+$P(^(0),U,2),0)),U,6)=""T"""
S CNT=0 F D Q:($G(PRCABN)<0)!($G(RCOUT))
.D ^DIC S PRCABN=Y
.I $G(PRCABN)<0 Q
.I $G(PRCABN)="^" S RCOUT=1 Q
.I +$G(RCDIV(0)),'$$DIV^RCRCDIV(PRCABN) W !," <<Bill is not in selected division.>>",!
.S CNT=CNT+1,RCSBN=CNT
.S RCSBN(+PRCABN)=CNT
.S DIC("A")="Select another Active TP Accounts Receivable Bill No.: "
.QUIT
I '$O(RCSBN(0)) S RCOUT=1
K PRCABN,DIC,DA,X,Y,%Y
BILLQ Q
;
PT ; - Issue prompt for Patients
N DIC,X,Y
I $O(RCSPT(0)) S DIC("A")="Select another PATIENT: "
S DIC="^DPT(",DIC(0)="QMEAZ"
W ! D ^DIC K DIC I $E(Y)="^" S RCOUT=1 G PTQ
I Y<0,'$O(RCSPT(0)) S RCOUT=1
I Y<0 G PTQ
S RCSPT(+Y)=Y G PT
PTQ Q
;
INS ; - determine range of carriers
R !!,"Build List for (S)elected Third Party Debtor(s) or a (R)ange: Range// ",X:DTIME
I ('$T)!(X["^") S RCOUT=1 G INSQ
S:X="" X="R" S X=$E(X)
I "SRsr"'[X W !!,?15,"Enter 'S' or 'R' or '^' to exit." G INS
W $S("sS"[X:" Selected",1:" Range") S RCSI=X
I "Rr"[RCSI G INS1
;
S DIC("A")="Select THIRD PARTY AR DEBTOR: "
INSA S DIC="^RCD(340,",DIC(0)="QEAZ",DIC("S")="I $P(^(0),U,1)[""DIC(36,"""
W ! D ^DIC K DIC I $E(Y)="^" S RCOUT=1 G INSQ
I Y<0,$O(RCSI(0)) G INSQ
I Y<0,'$O(RCSI(0)) G INS
S RCSI(+Y)=Y
S DIC("A")="Select another THIRD PARTY AR DEBTOR: "
G INSA
;
INS1 W !!!," START WITH DEBTOR: FIRST// " R X:DTIME
I ('$T)!(X["^") S RCOUT=1 G INSQ
I $E(X)="?" W !,?5,"Enter the name of the Insurance Company to start with." G INS1
S RCSIF=X
INS2 W !," GO TO DEBTOR: LAST// " R X:DTIME
I ('$T)!(X["^") S RCOUT=1 G INSQ
I $E(X)="?" W !,?5,"Enter the name of the Insurance Company to end with." G INS2
I X="" S RCSIL="zzzzz" S:RCSIF="" RCSIA="ALL" G INSQ
I X="@",RCSIF="@" S RCSIL="@",RCSIA="NULL" G INSQ
I RCSIF'="@",RCSIF]X W *7,!!," The LAST value must follow the FIRST.",! G INS1
S RCSIL=X
INSQ Q
;
ASK ;Ask optional questions
;
; - Build list for Selected Categories
S RCCAT="" D RCCAT^RCRCUTL(.RCCAT)
S (CNT,X)=0 K DIR
F S X=$O(RCCAT(X)) Q:'X D
.S CNT=CNT+1 S DIR("A",CNT)=CNT_" "_$P(RCCAT(X),U,2)
S TCNT=CNT,CNT=CNT+1,DIR("A",CNT)=" "
S CNT=CNT+1,DIR("A",CNT)=" *Only Reimburs.Health Bills can be electronically referred at this time."
S CNT=CNT+1,DIR("A",CNT)=" "
S DIR("A")=" Enter response"
W !!,"AR Categories to Include in Build List"
W !," Select from the following:",!
S DIR(0)="L^1:"_TCNT
D ^DIR I $E(Y)="^" S RCOUT=1 G ASKQ
K RCCAT F I=1:1:TCNT I $P(Y,",",I) S RCCAT($P(DIR("A",$P(Y,",",I))," ",2))=""
I $D(DIRUT)!$D(DTOUT)!$D(DUOUT)!$D(DIROUT) G ASKQ
K DIR,DIROUT,DTOUT,DUOUT,DIRUT
;
AGE ; - determine the active receivable min age
S DIR(0)="NOA^1:99999",DIR("?")="Enter a number between (1-99999) or press return"
S DIR("A")=" (Optional) Enter the minimum age of the receivables: "
W !! D ^DIR S RCSAGN=+Y I $D(DTOUT)!$D(DUOUT)!$D(DIROUT) S RCOUT=1 G ASKQ
W:+RCSAGN !," -Bill age over ",RCSAGN," days."
K DIR,DIROUT,DTOUT,DUOUT,DIRUT
;
; - determine the active receivable max age
S DIR(0)="NOA^1:99999",DIR("?")="Enter a number between (1-99999) or press return"
S DIR("A")=" (Optional) Enter the maximum age of the receivables: "
W !! D ^DIR S RCSAGX=+Y I $D(DTOUT)!$D(DUOUT)!$D(DIROUT) S RCOUT=1 G ASKQ
W:+RCSAGX !," -Bill age under ",RCSAGX," days."
K DIR,DIROUT,DTOUT,DUOUT,DIRUT
;
I $G(RCSAGX),+$G(RCSAGN)>+$G(RCSAGX) W !!,"Minimum age should be less than the Max. age.",!! G AGE
;
; - determine the active receivable minimum Amount
S DIR(0)="NOA^1:99999:2",DIR("?")="Enter a number between (1-99999) or press return"
S DIR("A")=" (Optional) Enter the minimum amount of the receivables: "
W !! D ^DIR S RCSAMT=+Y I $D(DTOUT)!$D(DUOUT)!$D(DIROUT) S RCOUT=1 G ASKQ
W:RCSAMT !," -Current Balance Over $",RCSAMT
K DIR,DIROUT,DTOUT,DUOUT,DIRUT
;
; - exclude receivables currently referred to Regional Counsel?
S DIR(0)="Y",DIR("B")="Yes"
S DIR("?")="Include receivables with a Referral Date in List"
S DIR("A")="Include currently referred receivables"
W !! D ^DIR S RCSRC=+Y
I $D(DIRUT)!$D(DTOUT)!$D(DUOUT)!$D(DIROUT) S RCOUT=1 G ASKQ
K DIR,DIROUT,DTOUT,DUOUT,DIRUT
;
ASKQ Q
;
;RCRCVLB
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRCRCVLB 6065 printed Sep 23, 2025@19:24:06 Page 2
RCRCVLB ;ALB/CMS - RC VIEW ACTIVE LIST BUILD ; 09-AUG-97
V ;;4.5;Accounts Receivable;**63,159**;Mar 20, 1995
+1 ;;Per VHA Directive 10-93-142, this routine should not be modified.
+2 QUIT
EN ; entry point from RCRCVL
+1 ; Returns: RCSBN,RCSBN(CNT,PRCABN)
+2 ; or: RCCAT(catname),RCSI(dbt#),RCSPT,RCSIA,RCSIF,RCSIL,RCSAGN,RCSAGX,RCSAMT,RCSRC
+3 ; or: if muti-divisions RCDIV(0),RCDIV(selected 40.8IEN)
+4 ; or: RCOUT
+5 NEW CNT,DA,DIC,PRCA,PRCABN,RCLQ,RCLQA,RCY,RCS,TCNT,T,X,Y
+6 NEW RCDIV,RCCNT,RCSD,RCRN,RCSN,RCSNF,RCLCNT,RCSNL,RCSNA,RCSAR,RCSH
+7 NEW DIR,DIROUT,DTOUT,DUOUT,DIRUT
+8 KILL RCSBN,RCCAT,RCSI,RCSIF,RCSIL,RCSAGN,RCSAGX,RCSAMT,RCSPT,RCSRC,RCOUT
+9 ;
+10 ;Get Divisions
+11 DO RCDIV^RCRCDIV(.RCDIV)
+12 ;Select one division if multiple
+13 IF $ORDER(RCDIV(0))
DO DIVS^RCRCDIV
IF $GET(RCOUT)=1
GOTO ENQ
+14 ;
+15 WRITE !!,"Build List of Possible Third Party Referrals"
+16 SET DIR("A",1)="Build a list by"
+17 SET DIR("A",2)="1. Selected AR Third Party Bill(s)"
+18 SET DIR("A",3)="2. Selected Patient(s)"
+19 SET DIR("A",4)="3. Selected AR Insurance Debtor(s) or"
+20 SET DIR("A",5)=" Insurance Range"
+21 SET DIR("A",6)=" "
+22 SET DIR("A")=" Select Number: "
+23 SET DIR(0)="SAXB^1:Third Party Bills;2:Patients;3:Insurance Debtors"
+24 SET DIR("B")=1
+25 DO ^DIR
IF $DATA(DIRUT)!$DATA(DTOUT)!$DATA(DUOUT)!$DATA(DIROUT)
SET RCOUT=1
GOTO ENQ
+26 IF $EXTRACT(Y)="^"
SET RCOUT=1
GOTO ENQ
+27 SET RCRN=Y
+28 KILL DIR,DIROUT,DTOUT,DUOUT,DIRUT
+29 ;
+30 IF RCRN=1
DO BILL
GOTO ENQ
+31 IF RCRN=2
DO PT
IF '$GET(RCOUT)
DO ASK
+32 IF RCRN=3
DO INS
IF '$GET(RCOUT)
DO ASK
ENQ WRITE !
+1 IF $GET(RCOUT)=1
KILL RCSBN,RCCAT,RCDIV,RCSI,RCSIA,RCSIF,RCSIL,RCSAGN,RCSAGX,RCSPT,RCSAMT,RCSRC
+2 KILL DIR,DIROUT,DTOUT,DUOUT,DIRUT
+3 QUIT
+4 ;
+5 ;
BILL ; - issue prompt for AR Bill Selection(s)
+1 ; - also called from Modify List Protocol
+2 KILL DIC,DA,X,Y,%Y
WRITE !
+3 SET DIC("A")="Select Active TP Accounts Receivable Bill No.: "
+4 SET DIC="^PRCA(430,"
SET DIC(0)="AQMEZ"
+5 SET DIC("S")="I $P(^(0),U,8)=16,$P($G(^PRCA(430.2,+$P(^(0),U,2),0)),U,6)=""T"""
+6 SET CNT=0
FOR
Begin DoDot:1
+7 DO ^DIC
SET PRCABN=Y
+8 IF $GET(PRCABN)<0
QUIT
+9 IF $GET(PRCABN)="^"
SET RCOUT=1
QUIT
+10 IF +$GET(RCDIV(0))
IF '$$DIV^RCRCDIV(PRCABN)
WRITE !," <<Bill is not in selected division.>>",!
+11 SET CNT=CNT+1
SET RCSBN=CNT
+12 SET RCSBN(+PRCABN)=CNT
+13 SET DIC("A")="Select another Active TP Accounts Receivable Bill No.: "
+14 QUIT
End DoDot:1
if ($GET(PRCABN)<0)!($GET(RCOUT))
QUIT
+15 IF '$ORDER(RCSBN(0))
SET RCOUT=1
+16 KILL PRCABN,DIC,DA,X,Y,%Y
BILLQ QUIT
+1 ;
PT ; - Issue prompt for Patients
+1 NEW DIC,X,Y
+2 IF $ORDER(RCSPT(0))
SET DIC("A")="Select another PATIENT: "
+3 SET DIC="^DPT("
SET DIC(0)="QMEAZ"
+4 WRITE !
DO ^DIC
KILL DIC
IF $EXTRACT(Y)="^"
SET RCOUT=1
GOTO PTQ
+5 IF Y<0
IF '$ORDER(RCSPT(0))
SET RCOUT=1
+6 IF Y<0
GOTO PTQ
+7 SET RCSPT(+Y)=Y
GOTO PT
PTQ QUIT
+1 ;
INS ; - determine range of carriers
+1 READ !!,"Build List for (S)elected Third Party Debtor(s) or a (R)ange: Range// ",X:DTIME
+2 IF ('$TEST)!(X["^")
SET RCOUT=1
GOTO INSQ
+3 if X=""
SET X="R"
SET X=$EXTRACT(X)
+4 IF "SRsr"'[X
WRITE !!,?15,"Enter 'S' or 'R' or '^' to exit."
GOTO INS
+5 WRITE $SELECT("sS"[X:" Selected",1:" Range")
SET RCSI=X
+6 IF "Rr"[RCSI
GOTO INS1
+7 ;
+8 SET DIC("A")="Select THIRD PARTY AR DEBTOR: "
INSA SET DIC="^RCD(340,"
SET DIC(0)="QEAZ"
SET DIC("S")="I $P(^(0),U,1)[""DIC(36,"""
+1 WRITE !
DO ^DIC
KILL DIC
IF $EXTRACT(Y)="^"
SET RCOUT=1
GOTO INSQ
+2 IF Y<0
IF $ORDER(RCSI(0))
GOTO INSQ
+3 IF Y<0
IF '$ORDER(RCSI(0))
GOTO INS
+4 SET RCSI(+Y)=Y
+5 SET DIC("A")="Select another THIRD PARTY AR DEBTOR: "
+6 GOTO INSA
+7 ;
INS1 WRITE !!!," START WITH DEBTOR: FIRST// "
READ X:DTIME
+1 IF ('$TEST)!(X["^")
SET RCOUT=1
GOTO INSQ
+2 IF $EXTRACT(X)="?"
WRITE !,?5,"Enter the name of the Insurance Company to start with."
GOTO INS1
+3 SET RCSIF=X
INS2 WRITE !," GO TO DEBTOR: LAST// "
READ X:DTIME
+1 IF ('$TEST)!(X["^")
SET RCOUT=1
GOTO INSQ
+2 IF $EXTRACT(X)="?"
WRITE !,?5,"Enter the name of the Insurance Company to end with."
GOTO INS2
+3 IF X=""
SET RCSIL="zzzzz"
if RCSIF=""
SET RCSIA="ALL"
GOTO INSQ
+4 IF X="@"
IF RCSIF="@"
SET RCSIL="@"
SET RCSIA="NULL"
GOTO INSQ
+5 IF RCSIF'="@"
IF RCSIF]X
WRITE *7,!!," The LAST value must follow the FIRST.",!
GOTO INS1
+6 SET RCSIL=X
INSQ QUIT
+1 ;
ASK ;Ask optional questions
+1 ;
+2 ; - Build list for Selected Categories
+3 SET RCCAT=""
DO RCCAT^RCRCUTL(.RCCAT)
+4 SET (CNT,X)=0
KILL DIR
+5 FOR
SET X=$ORDER(RCCAT(X))
if 'X
QUIT
Begin DoDot:1
+6 SET CNT=CNT+1
SET DIR("A",CNT)=CNT_" "_$PIECE(RCCAT(X),U,2)
End DoDot:1
+7 SET TCNT=CNT
SET CNT=CNT+1
SET DIR("A",CNT)=" "
+8 SET CNT=CNT+1
SET DIR("A",CNT)=" *Only Reimburs.Health Bills can be electronically referred at this time."
+9 SET CNT=CNT+1
SET DIR("A",CNT)=" "
+10 SET DIR("A")=" Enter response"
+11 WRITE !!,"AR Categories to Include in Build List"
+12 WRITE !," Select from the following:",!
+13 SET DIR(0)="L^1:"_TCNT
+14 DO ^DIR
IF $EXTRACT(Y)="^"
SET RCOUT=1
GOTO ASKQ
+15 KILL RCCAT
FOR I=1:1:TCNT
IF $PIECE(Y,",",I)
SET RCCAT($PIECE(DIR("A",$PIECE(Y,",",I))," ",2))=""
+16 IF $DATA(DIRUT)!$DATA(DTOUT)!$DATA(DUOUT)!$DATA(DIROUT)
GOTO ASKQ
+17 KILL DIR,DIROUT,DTOUT,DUOUT,DIRUT
+18 ;
AGE ; - determine the active receivable min age
+1 SET DIR(0)="NOA^1:99999"
SET DIR("?")="Enter a number between (1-99999) or press return"
+2 SET DIR("A")=" (Optional) Enter the minimum age of the receivables: "
+3 WRITE !!
DO ^DIR
SET RCSAGN=+Y
IF $DATA(DTOUT)!$DATA(DUOUT)!$DATA(DIROUT)
SET RCOUT=1
GOTO ASKQ
+4 if +RCSAGN
WRITE !," -Bill age over ",RCSAGN," days."
+5 KILL DIR,DIROUT,DTOUT,DUOUT,DIRUT
+6 ;
+7 ; - determine the active receivable max age
+8 SET DIR(0)="NOA^1:99999"
SET DIR("?")="Enter a number between (1-99999) or press return"
+9 SET DIR("A")=" (Optional) Enter the maximum age of the receivables: "
+10 WRITE !!
DO ^DIR
SET RCSAGX=+Y
IF $DATA(DTOUT)!$DATA(DUOUT)!$DATA(DIROUT)
SET RCOUT=1
GOTO ASKQ
+11 if +RCSAGX
WRITE !," -Bill age under ",RCSAGX," days."
+12 KILL DIR,DIROUT,DTOUT,DUOUT,DIRUT
+13 ;
+14 IF $GET(RCSAGX)
IF +$GET(RCSAGN)>+$GET(RCSAGX)
WRITE !!,"Minimum age should be less than the Max. age.",!!
GOTO AGE
+15 ;
+16 ; - determine the active receivable minimum Amount
+17 SET DIR(0)="NOA^1:99999:2"
SET DIR("?")="Enter a number between (1-99999) or press return"
+18 SET DIR("A")=" (Optional) Enter the minimum amount of the receivables: "
+19 WRITE !!
DO ^DIR
SET RCSAMT=+Y
IF $DATA(DTOUT)!$DATA(DUOUT)!$DATA(DIROUT)
SET RCOUT=1
GOTO ASKQ
+20 if RCSAMT
WRITE !," -Current Balance Over $",RCSAMT
+21 KILL DIR,DIROUT,DTOUT,DUOUT,DIRUT
+22 ;
+23 ; - exclude receivables currently referred to Regional Counsel?
+24 SET DIR(0)="Y"
SET DIR("B")="Yes"
+25 SET DIR("?")="Include receivables with a Referral Date in List"
+26 SET DIR("A")="Include currently referred receivables"
+27 WRITE !!
DO ^DIR
SET RCSRC=+Y
+28 IF $DATA(DIRUT)!$DATA(DTOUT)!$DATA(DUOUT)!$DATA(DIROUT)
SET RCOUT=1
GOTO ASKQ
+29 KILL DIR,DIROUT,DTOUT,DUOUT,DIRUT
+30 ;
ASKQ QUIT
+1 ;
+2 ;RCRCVLB
