PRCABARP ;EDE/YMG - BILLING ADDRESS DISCREPANCY REPORT; 04/10/2022
;;4.5;Accounts Receivable;**403**;Mar 20, 1995;Build 5
;;Per VA Directive 6402, this routine should not be modified.
;
; Reference to BADADR^DGUTL3 in ICR #7321
; Reference to FILE #5 in ICR #10056
;
Q
;
EN ; entry point
N FILTER,POP,ZTDESC,ZTRTN,ZTSAVE,ZTSK,%ZIS
K ^TMP("PRCABARP",$J)
W !!,"Billing Address Discrepancy Report",!
; filter by?
S FILTER=$$ASKFLTR() I FILTER=-1 Q
D EXCMSG^RCTCSJR ; Display Excel display message
; ask for device
K IOP,IO("Q")
S %ZIS="MQ",%ZIS("B")="",POP=0 D ^%ZIS Q:POP
I $D(IO("Q")) D Q ; queued report
.S ZTDESC="Billing Address Discrepancy Report",ZTRTN="COMPILE^PRCABARP"
.S ZTSAVE("FILTER")="",ZTSAVE("ZTREQ")="@"
.D ^%ZTLOAD,HOME^%ZIS
.I $G(ZTSK) W !!,"Report compilation has started with task# ",ZTSK,".",! D PAUSE^RCRPRPU
.Q
D COMPILE
;
Q
;
ASKFLTR() ; display "filter by debtor name" prompt
;
; returns "1 ^ start name ^ end name" for filtering by debtor name
; (2nd piece = null to start at the 1st available name; 3rd piece = null to end with the last available name),
; 0 for no filter,
; -1 for user exit / timeout
;
N DIR,DIROUT,DIRUT,DTOUT,DUOUT,X,Y
N ENM,SNM
S DIR(0)="Y",DIR("B")="NO"
S DIR("A")="Filter By Debtor Name (Y/N)"
D ^DIR I $D(DIRUT)!$D(DTOUT)!$D(DUOUT)!$D(DIROUT) Q -1 ; user exit / timeout
I Y=0 Q 0 ; response is "No"
S DIR(0)="F^1:",DIR("B")="FIRST"
S DIR("A")="Start with name"
D ^DIR I $D(DIRUT)!$D(DTOUT)!$D(DUOUT)!$D(DIROUT) Q -1 ; user exit / timeout
S SNM=$S(Y="FIRST":"",1:Y)
;
S DIR(0)="F^1:^K:SNM]X X",DIR("B")="LAST"
S DIR("A")="Go to name"
D ^DIR I $D(DIRUT)!$D(DTOUT)!$D(DUOUT)!$D(DIROUT) Q -1 ; user exit / timeout
S ENM=$S(Y="LAST":"",1:Y)
Q "1"_U_SNM_U_ENM
;
COMPILE ; compile report
N BADADDR,CNT,CADDR,DADDR,DBTR,DCSD,DFN,DIEN,ENM,N1,PADDR,PATID,SITE,SNM,TADDR,TMP,UNKADDR,VADM,VAPA,Z
;
S CNT=0,(SNM,ENM)=""
I $P(FILTER,U) S SNM=$P(FILTER,U,2),ENM=$P(FILTER,U,3)
S SITE=+$$SITE^VASITE()
S DBTR=0 F S DBTR=$O(^RCD(340,"B",DBTR)) Q:DBTR="" D
.I $P(DBTR,";",2)'="DPT(" Q ; only include patients
.S DIEN="" F S DIEN=$O(^RCD(340,"B",DBTR,DIEN)) Q:'DIEN D
..S N1=$G(^RCD(340,DIEN,1)) I $TR($P(N1,U,1,6),U,"")="" Q ; quit if no address in file 340
..S DFN=$P(DBTR,";"),DCSD=0
..D DEM^VADPT
..; make sure that name is wihtin filtering range
..I SNM'="",VADM(1)'=SNM,VADM(1)']SNM Q
..I ENM'="",VADM(1)'=ENM,ENM']VADM(1) Q
..S PATID=$E(VADM(1))_$E($P(VADM(2),U),6,10)
..S DCSD=+VADM(6)>0 ; 1 if patient is deceased, 0 otherwise
..S UNKADDR=$P(N1,U,9) ; unknown address: 1 = yes, 0 = no
..; get debtor address
..S DADDR=$P(N1,U) I DADDR'="" D ; addr line 1
...F Z=2:1:3 S TMP=$P(N1,U,Z) S:TMP'="" DADDR=DADDR_" "_TMP ; addr lines 2,3
...S DADDR=DADDR_", "_$P(N1,U,4)_", "_$$GET1^DIQ(5,$P(N1,U,5)_",",1)_" "_$P(N1,U,6) ; city, state, zip
...Q
..; get patient addresses
..D ADD^VADPT
..; get confidential address, if exists
..S CADDR="" I VAPA(12),$P($G(VAPA(22,3)),U,3)="Y" S CADDR=VAPA(13) D:CADDR'="" ; addr line 1
...F Z=14:1:15 S:VAPA(Z)'="" CADDR=CADDR_" "_VAPA(Z) ; addr lines 2,3
...S CADDR=CADDR_","_VAPA(16)_", "_$$GET1^DIQ(5,$P(VAPA(17),U)_",",1)_" "_$P(VAPA(18),U) ; city, state, zip
...Q
..; get temporary / permanent address
..S TMP=VAPA(1) D:TMP'="" ; adr line 1
...F Z=2:1:3 S:VAPA(Z)'="" TMP=TMP_" "_VAPA(Z) ; addr lines 2,3
...S TMP=TMP_","_VAPA(4)_", "_$$GET1^DIQ(5,$P(VAPA(5),U)_",",1)_" "_$P(VAPA(6),U) ; city, state, zip
...; check if this is the permanent address
...I '+VAPA(9) S TADDR="",PADDR=TMP Q
...; it was temporary address, if we got here - need to get permanent address separately.
...S TADDR=TMP K VAPA S VAPA("P")="" D ADD^VADPT
...S PADDR=VAPA(1) D:PADDR'="" ; adr line 1
....F Z=2:1:3 S:VAPA(Z)'="" PADDR=PADDR_" "_VAPA(Z) ; addr lines 2,3
....S PADDR=PADDR_","_VAPA(4)_", "_$$GET1^DIQ(5,$P(VAPA(5),U)_",",1)_" "_$P(VAPA(6),U) ; city, state, zip
....Q
...Q
..S TMP=$$BADADR^DGUTL3(DFN),BADADDR=$S(TMP=1:"UNDELIVERABLE",TMP=2:"HOMELESS",TMP=3:"OTHER",TMP=4:"ADDRESS NOT FOUND",1:"N/A")
..S BADADDR=$$GET1^DIQ(2,DFN_",",.121,"E") ; bad address indicator (external)
..S CNT=CNT+1
..; add a new entry to ^TMP global
..S ^TMP("PRCABARP",$J,CNT)=SITE_U_VADM(1)_U_PATID_U_DCSD_U_BADADDR_U_UNKADDR ; station # ^ debtor name ^ patient id ^ deceased? (1/0) ^ bad address (2/.121) ^ unknown address (340/1.09)
..S ^TMP("PRCABARP",$J,CNT,"CADDR")=CADDR ; Confidential address
..S ^TMP("PRCABARP",$J,CNT,"DADDR")=DADDR ; AR address
..S ^TMP("PRCABARP",$J,CNT,"TADDR")=TADDR ; Temporary address
..S ^TMP("PRCABARP",$J,CNT,"PADDR")=PADDR ; Permanent address
..S ^TMP("PRCABARP",$J,"IDX",VADM(1),CNT)="" ; index on debtor name
..K VADM,VAPA
..Q
.Q
D PRINT
K ^TMP("PRCABARP",$J)
Q
;
PRINT ; print report
N BADADDR,CADDR,CNT,DATA,DADDR,EXTDT,NAME,PADDR,TADDR
;
U IO
S EXTDT=$$FMTE^XLFDT(DT)
W !,"Billing Address Discrepancy Report",U,EXTDT,U,$$FLTRSTR(FILTER)
W !,"Facility^Debtor^ID No.^Deceased?^Confidential Address^AR Debtor Address^Temporary Address^Permanent Address^Unknown AR Address?^Bad Address Indicator"
I '$D(^TMP("PRCABARP",$J)) W !!,"No records found." Q
S NAME="" F S NAME=$O(^TMP("PRCABARP",$J,"IDX",NAME)) Q:NAME="" D
.S CNT=0 F S CNT=$O(^TMP("PRCABARP",$J,"IDX",NAME,CNT)) Q:'CNT D
..S DATA=^TMP("PRCABARP",$J,CNT)
..S CADDR=$TR(^TMP("PRCABARP",$J,CNT,"CADDR"),U," ")
..S DADDR=$TR(^TMP("PRCABARP",$J,CNT,"DADDR"),U," ")
..S TADDR=$TR(^TMP("PRCABARP",$J,CNT,"TADDR"),U," ")
..S PADDR=$TR(^TMP("PRCABARP",$J,CNT,"PADDR"),U," ")
..S BADADDR=$P(DATA,U,5)
..W !,$P(DATA,U),U,NAME,U,$P(DATA,U,3),U,$S($P(DATA,U,4):"Y",1:"N"),U,CADDR,U,DADDR,U,TADDR,U,PADDR,U,$S($P(DATA,U,6):"Y",1:"N"),U,BADADDR
..Q
.Q
Q
;
FLTRSTR(FILTER) ; returns "Filtered by" string to print
Q "Filtered by: "_$S($P(FILTER,U)=1:"Debtor name (from "_$P(FILTER,U,2)_" to "_$P(FILTER,U,3)_")",1:"No filter")
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCABARP 6090 printed Sep 23, 2025@19:14:57 Page 2
PRCABARP ;EDE/YMG - BILLING ADDRESS DISCREPANCY REPORT; 04/10/2022
+1 ;;4.5;Accounts Receivable;**403**;Mar 20, 1995;Build 5
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;
+4 ; Reference to BADADR^DGUTL3 in ICR #7321
+5 ; Reference to FILE #5 in ICR #10056
+6 ;
+7 QUIT
+8 ;
EN ; entry point
+1 NEW FILTER,POP,ZTDESC,ZTRTN,ZTSAVE,ZTSK,%ZIS
+2 KILL ^TMP("PRCABARP",$JOB)
+3 WRITE !!,"Billing Address Discrepancy Report",!
+4 ; filter by?
+5 SET FILTER=$$ASKFLTR()
IF FILTER=-1
QUIT
+6 ; Display Excel display message
DO EXCMSG^RCTCSJR
+7 ; ask for device
+8 KILL IOP,IO("Q")
+9 SET %ZIS="MQ"
SET %ZIS("B")=""
SET POP=0
DO ^%ZIS
if POP
QUIT
+10 ; queued report
IF $DATA(IO("Q"))
Begin DoDot:1
+11 SET ZTDESC="Billing Address Discrepancy Report"
SET ZTRTN="COMPILE^PRCABARP"
+12 SET ZTSAVE("FILTER")=""
SET ZTSAVE("ZTREQ")="@"
+13 DO ^%ZTLOAD
DO HOME^%ZIS
+14 IF $GET(ZTSK)
WRITE !!,"Report compilation has started with task# ",ZTSK,".",!
DO PAUSE^RCRPRPU
+15 QUIT
End DoDot:1
QUIT
+16 DO COMPILE
+17 ;
+18 QUIT
+19 ;
ASKFLTR() ; display "filter by debtor name" prompt
+1 ;
+2 ; returns "1 ^ start name ^ end name" for filtering by debtor name
+3 ; (2nd piece = null to start at the 1st available name; 3rd piece = null to end with the last available name),
+4 ; 0 for no filter,
+5 ; -1 for user exit / timeout
+6 ;
+7 NEW DIR,DIROUT,DIRUT,DTOUT,DUOUT,X,Y
+8 NEW ENM,SNM
+9 SET DIR(0)="Y"
SET DIR("B")="NO"
+10 SET DIR("A")="Filter By Debtor Name (Y/N)"
+11 ; user exit / timeout
DO ^DIR
IF $DATA(DIRUT)!$DATA(DTOUT)!$DATA(DUOUT)!$DATA(DIROUT)
QUIT -1
+12 ; response is "No"
IF Y=0
QUIT 0
+13 SET DIR(0)="F^1:"
SET DIR("B")="FIRST"
+14 SET DIR("A")="Start with name"
+15 ; user exit / timeout
DO ^DIR
IF $DATA(DIRUT)!$DATA(DTOUT)!$DATA(DUOUT)!$DATA(DIROUT)
QUIT -1
+16 SET SNM=$SELECT(Y="FIRST":"",1:Y)
+17 ;
+18 SET DIR(0)="F^1:^K:SNM]X X"
SET DIR("B")="LAST"
+19 SET DIR("A")="Go to name"
+20 ; user exit / timeout
DO ^DIR
IF $DATA(DIRUT)!$DATA(DTOUT)!$DATA(DUOUT)!$DATA(DIROUT)
QUIT -1
+21 SET ENM=$SELECT(Y="LAST":"",1:Y)
+22 QUIT "1"_U_SNM_U_ENM
+23 ;
COMPILE ; compile report
+1 NEW BADADDR,CNT,CADDR,DADDR,DBTR,DCSD,DFN,DIEN,ENM,N1,PADDR,PATID,SITE,SNM,TADDR,TMP,UNKADDR,VADM,VAPA,Z
+2 ;
+3 SET CNT=0
SET (SNM,ENM)=""
+4 IF $PIECE(FILTER,U)
SET SNM=$PIECE(FILTER,U,2)
SET ENM=$PIECE(FILTER,U,3)
+5 SET SITE=+$$SITE^VASITE()
+6 SET DBTR=0
FOR
SET DBTR=$ORDER(^RCD(340,"B",DBTR))
if DBTR=""
QUIT
Begin DoDot:1
+7 ; only include patients
IF $PIECE(DBTR,";",2)'="DPT("
QUIT
+8 SET DIEN=""
FOR
SET DIEN=$ORDER(^RCD(340,"B",DBTR,DIEN))
if 'DIEN
QUIT
Begin DoDot:2
+9 ; quit if no address in file 340
SET N1=$GET(^RCD(340,DIEN,1))
IF $TRANSLATE($PIECE(N1,U,1,6),U,"")=""
QUIT
+10 SET DFN=$PIECE(DBTR,";")
SET DCSD=0
+11 DO DEM^VADPT
+12 ; make sure that name is wihtin filtering range
+13 IF SNM'=""
IF VADM(1)'=SNM
IF VADM(1)']SNM
QUIT
+14 IF ENM'=""
IF VADM(1)'=ENM
IF ENM']VADM(1)
QUIT
+15 SET PATID=$EXTRACT(VADM(1))_$EXTRACT($PIECE(VADM(2),U),6,10)
+16 ; 1 if patient is deceased, 0 otherwise
SET DCSD=+VADM(6)>0
+17 ; unknown address: 1 = yes, 0 = no
SET UNKADDR=$PIECE(N1,U,9)
+18 ; get debtor address
+19 ; addr line 1
SET DADDR=$PIECE(N1,U)
IF DADDR'=""
Begin DoDot:3
+20 ; addr lines 2,3
FOR Z=2:1:3
SET TMP=$PIECE(N1,U,Z)
if TMP'=""
SET DADDR=DADDR_" "_TMP
+21 ; city, state, zip
SET DADDR=DADDR_", "_$PIECE(N1,U,4)_", "_$$GET1^DIQ(5,$PIECE(N1,U,5)_",",1)_" "_$PIECE(N1,U,6)
+22 QUIT
End DoDot:3
+23 ; get patient addresses
+24 DO ADD^VADPT
+25 ; get confidential address, if exists
+26 ; addr line 1
SET CADDR=""
IF VAPA(12)
IF $PIECE($GET(VAPA(22,3)),U,3)="Y"
SET CADDR=VAPA(13)
if CADDR'=""
Begin DoDot:3
+27 ; addr lines 2,3
FOR Z=14:1:15
if VAPA(Z)'=""
SET CADDR=CADDR_" "_VAPA(Z)
+28 ; city, state, zip
SET CADDR=CADDR_","_VAPA(16)_", "_$$GET1^DIQ(5,$PIECE(VAPA(17),U)_",",1)_" "_$PIECE(VAPA(18),U)
+29 QUIT
End DoDot:3
+30 ; get temporary / permanent address
+31 ; adr line 1
SET TMP=VAPA(1)
if TMP'=""
Begin DoDot:3
+32 ; addr lines 2,3
FOR Z=2:1:3
if VAPA(Z)'=""
SET TMP=TMP_" "_VAPA(Z)
+33 ; city, state, zip
SET TMP=TMP_","_VAPA(4)_", "_$$GET1^DIQ(5,$PIECE(VAPA(5),U)_",",1)_" "_$PIECE(VAPA(6),U)
+34 ; check if this is the permanent address
+35 IF '+VAPA(9)
SET TADDR=""
SET PADDR=TMP
QUIT
+36 ; it was temporary address, if we got here - need to get permanent address separately.
+37 SET TADDR=TMP
KILL VAPA
SET VAPA("P")=""
DO ADD^VADPT
+38 ; adr line 1
SET PADDR=VAPA(1)
if PADDR'=""
Begin DoDot:4
+39 ; addr lines 2,3
FOR Z=2:1:3
if VAPA(Z)'=""
SET PADDR=PADDR_" "_VAPA(Z)
+40 ; city, state, zip
SET PADDR=PADDR_","_VAPA(4)_", "_$$GET1^DIQ(5,$PIECE(VAPA(5),U)_",",1)_" "_$PIECE(VAPA(6),U)
+41 QUIT
End DoDot:4
+42 QUIT
End DoDot:3
+43 SET TMP=$$BADADR^DGUTL3(DFN)
SET BADADDR=$SELECT(TMP=1:"UNDELIVERABLE",TMP=2:"HOMELESS",TMP=3:"OTHER",TMP=4:"ADDRESS NOT FOUND",1:"N/A")
+44 ; bad address indicator (external)
SET BADADDR=$$GET1^DIQ(2,DFN_",",.121,"E")
+45 SET CNT=CNT+1
+46 ; add a new entry to ^TMP global
+47 ; station # ^ debtor name ^ patient id ^ deceased? (1/0) ^ bad address (2/.121) ^ unknown address (340/1.09)
SET ^TMP("PRCABARP",$JOB,CNT)=SITE_U_VADM(1)_U_PATID_U_DCSD_U_BADADDR_U_UNKADDR
+48 ; Confidential address
SET ^TMP("PRCABARP",$JOB,CNT,"CADDR")=CADDR
+49 ; AR address
SET ^TMP("PRCABARP",$JOB,CNT,"DADDR")=DADDR
+50 ; Temporary address
SET ^TMP("PRCABARP",$JOB,CNT,"TADDR")=TADDR
+51 ; Permanent address
SET ^TMP("PRCABARP",$JOB,CNT,"PADDR")=PADDR
+52 ; index on debtor name
SET ^TMP("PRCABARP",$JOB,"IDX",VADM(1),CNT)=""
+53 KILL VADM,VAPA
+54 QUIT
End DoDot:2
+55 QUIT
End DoDot:1
+56 DO PRINT
+57 KILL ^TMP("PRCABARP",$JOB)
+58 QUIT
+59 ;
PRINT ; print report
+1 NEW BADADDR,CADDR,CNT,DATA,DADDR,EXTDT,NAME,PADDR,TADDR
+2 ;
+3 USE IO
+4 SET EXTDT=$$FMTE^XLFDT(DT)
+5 WRITE !,"Billing Address Discrepancy Report",U,EXTDT,U,$$FLTRSTR(FILTER)
+6 WRITE !,"Facility^Debtor^ID No.^Deceased?^Confidential Address^AR Debtor Address^Temporary Address^Permanent Address^Unknown AR Address?^Bad Address Indicator"
+7 IF '$DATA(^TMP("PRCABARP",$JOB))
WRITE !!,"No records found."
QUIT
+8 SET NAME=""
FOR
SET NAME=$ORDER(^TMP("PRCABARP",$JOB,"IDX",NAME))
if NAME=""
QUIT
Begin DoDot:1
+9 SET CNT=0
FOR
SET CNT=$ORDER(^TMP("PRCABARP",$JOB,"IDX",NAME,CNT))
if 'CNT
QUIT
Begin DoDot:2
+10 SET DATA=^TMP("PRCABARP",$JOB,CNT)
+11 SET CADDR=$TRANSLATE(^TMP("PRCABARP",$JOB,CNT,"CADDR"),U," ")
+12 SET DADDR=$TRANSLATE(^TMP("PRCABARP",$JOB,CNT,"DADDR"),U," ")
+13 SET TADDR=$TRANSLATE(^TMP("PRCABARP",$JOB,CNT,"TADDR"),U," ")
+14 SET PADDR=$TRANSLATE(^TMP("PRCABARP",$JOB,CNT,"PADDR"),U," ")
+15 SET BADADDR=$PIECE(DATA,U,5)
+16 WRITE !,$PIECE(DATA,U),U,NAME,U,$PIECE(DATA,U,3),U,$SELECT($PIECE(DATA,U,4):"Y",1:"N"),U,CADDR,U,DADDR,U,TADDR,U,PADDR,U,$SELECT($PIECE(DATA,U,6):"Y",1:"N"),U,BADADDR
+17 QUIT
End DoDot:2
+18 QUIT
End DoDot:1
+19 QUIT
+20 ;
FLTRSTR(FILTER) ; returns "Filtered by" string to print
+1 QUIT "Filtered by: "_$SELECT($PIECE(FILTER,U)=1:"Debtor name (from "_$PIECE(FILTER,U,2)_" to "_$PIECE(FILTER,U,3)_")",1:"No filter")
