RCTCSP6 ;ALB/YG - Cross-Servicing Re-Referred Bills Report;03/15/14 3:34 PM
;;4.5;Accounts Receivable;**350,433**;Mar 20, 1995;Build 7
;;Per VA Directive 6402, this routine should not be modified.
;
;
MAIN ;PRCA*4.5*350
;
BILLREP ;Cross-servicing bill report, prints individual bills that make up a cross-servicing account
N DIC,DEBTOR,ZTSAVE,ZTDESC,ZTRTN,POP,DTFRMTO,PROMPT,EXCEL,RUNDATE,PAGE,DFN
S RUNDATE=$$FMTE^XLFDT($$NOW^XLFDT,"9MP")
K ^TMP("RCTCSP1",$J)
S PAGE=0
W !,"*** Cross-Servicing Re-Referred Bills Report ***",!
W !,"The Cross-Servicing Re-Referred Bills Report provides a list of all bills"
W !,"that have been re-referred to Cross-Servicing.",!
;S DIC=340,DIC(0)="AEQM",DIC("S")="I $D(^RCD(340,""TCSP"",+Y))" D ^DIC
;Q:Y<1 S DEBTOR=+Y
;S DTFRMTO=$$DTFRMTO^RCTCSP2 Q:'DTFRMTO ;Get date range as per PRCA*4.5*315
S DTFRMTO=$$DATE2^RCDMCUT2(" Enter the Date Range for Bills that have been Re-Referred for Cross-Servicing: ",,"T-7")
S EXCEL=0,PROMPT="CAPTURE Report data to an Excel Document",DIR(0)="Y",DIR("?")="^D HEXC^RCTCSJR"
;S EXCEL=$$SELECT^RCTCSJR(PROMPT,"NO")
S EXCEL=$$EXCEL^RCDMCUT2
I "01"'[EXCEL Q
I EXCEL D EXCMSG^RCTCSJR ; Display Excel display message
I 'EXCEL W !,"It is recommended that you Queue this report to a device that is 132 characters wide. "
S %ZIS="MQ" D ^%ZIS G:POP BILLREPQ ;PRC*4.5*336
I $D(IO("Q")) D G BILLREPQ
.S ZTSAVE("DEBTOR")="",ZTSAVE("DTFRMTO")="",ZTSAVE("EXCEL")=""
.S ZTRTN="BILLREPP^RCTCSP6",ZTDESC="CROSS-SERVICING BILL REPORT"
.D ^%ZTLOAD,HOME^%ZIS
.I $G(ZTSK) W !!,"Report compilation has started with task# ",ZTSK,".",! S DIR(0)="E" D ^DIR K DIR
.Q
;
BILLREPP ;Call to build array of bills referred
U IO
N BILL,B7,B14,B15,B16,D4,FND,BAMT,DIRUT,TNM,TID,TDT,DASH,CSTAT,PAGE,DASH,TMP,I,DATE,DTFRM,DTTO,DATDATE,REASON,COMMENT,USER,OAMT,LIEN,NAME,NODE,SSN,PTID,RCARCAT
K ^TMP("RCTCSP6",$J)
S DASH="",$P(DASH,"-",78)="" ;(as per PRCA*4.5*315)
S (DATE,DTFRM)=$$FMADD^XLFDT(+$P(DTFRMTO,U,2)),DTTO=$P(DTFRMTO,U,3)
S (BAMT,BILL,PAGE)=0
; rewritten to sort by "TCSP" (#151 date referred to TCSP) not the "AB" xref... PRCA*4.5*315 (TV8)
F S BILL=$O(^PRCA(430,"TCSP",BILL)) Q:BILL=""!($D(DIRUT)) D:$$RR^RCTCSPU(BILL)
.S DEBTOR=$P($G(^PRCA(430,BILL,0)),U,9)
.S DFN=$P($G(^RCD(340,DEBTOR,0)),U) Q:DFN'[";DPT"
.S DFN=+DFN
.D DEM^VADPT
.I $G(VAERR)>0 D KVAR^VADPT Q
.S NAME=$G(VADM(1))
.I NAME']"" D KVAR^VADPT Q
.S SSN=$P(VADM(2),U,1)
.S PTID=$E(VADM(1),1)_$S(SSN'="":$E(SSN,6,9),1:"0000") ;PRCA*4.5*433
.Q:'+$G(^PRCA(430,BILL,15))
.S DATDATE=$P($G(^PRCA(430,BILL,15)),U) Q:DATDATE<DTFRM!(DATDATE>DTTO)
.S B7=$G(^PRCA(430,BILL,7))
.S BAMT=0 F I=1:1:5 S BAMT=BAMT+$P(B7,U,I)
.S ^TMP("RCTCSP6",$J,DEBTOR,BILL)=BAMT_U_NAME_U_SSN
D BILLREPH
S DEBTOR="" F S DEBTOR=$O(^TMP("RCTCSP6",$J,DEBTOR)) Q:'DEBTOR!($D(DIRUT)) D Q:$D(DIRUT)
. S BILL=0 F S BILL=$O(^TMP("RCTCSP6",$J,DEBTOR,BILL)) Q:'BILL D Q:$D(DIRUT)
..Q:'+$G(^PRCA(430,BILL,15))
..S RCARCAT=$$GET1^DIQ(430,BILL,2,"E") ;PRCA*4.5*433
..S NODE=^TMP("RCTCSP6",$J,DEBTOR,BILL),BAMT=$P(NODE,U),NAME=$P(NODE,U,2),SSN=$P(NODE,U,3)
..S FND=1 W !,$P(^PRCA(430,BILL,0),U) ; Bill
..I 'EXCEL W ?12,$E(RCARCAT,1,9) ;PRCA*4.5*433
..I EXCEL W U,$E(RCARCAT,1,9) ;PRCA*4.5*433
..S CSTAT=$P(^(0),U,8),B7=$G(^(7)),B15=$G(^(15)),B16=$G(^(16))
..I 'EXCEL W ?22,$E(NAME,1,17) ; Name ;PRCA*4.5*433
..I EXCEL W U,NAME
..I 'EXCEL W ?40,PTID ; Patient ID ;PRCA*4.5*433
..I EXCEL W U,PTID
..I 'EXCEL W ?46,$$FMTE^XLFDT($P(B15,U,1),"2Z") ; Rerefer date ;PRCA*4.5*433
..I EXCEL W U,$$FMTE^XLFDT($P(B15,U,1),"2Z")
..S OAMT=$P(B16,U,9) I OAMT'>0 S OAMT=$P($G(^PRCA(430,BILL,30)),U,10)
..I 'EXCEL W ?57,$J("$"_$FN(OAMT,",",2),11) ; Original Amt ;PRCA*4.5*433
..I EXCEL W U,"$"_$FN(OAMT,",",2)
..I 'EXCEL W ?70,$J("$"_$FN(BAMT,",",2),11) ; Curr Amt ;PRCA*4.5*433
..I EXCEL W U,"$"_$FN(BAMT,",",2)
..I 'EXCEL,OAMT-BAMT'=0 W ?82,$J("$"_$FN(OAMT-BAMT,",",2),11) ; diff amt ;PRCA*4.5*433
..I EXCEL W U W:OAMT-BAMT'=0 "$",$FN(OAMT-BAMT,",",2)
..S LIEN=$O(^PRCA(430,BILL,15.5,"B",0,""),-1)
..S REASON=$P(^PRCA(430,BILL,15.5,LIEN,0),U,4)
..S REASON=$S(REASON="T":"Treas RVSL",REASON="R":"Recall Error",REASON="D":"DFLT RPP",REASON="O":"Other")
..S USER=$P(^PRCA(430,BILL,15.5,LIEN,0),U,3),USER=$P(^VA(200,USER,0),U)
..I 'EXCEL W ?95,$E(REASON,1,15) ;PRCA*4.5*433
..I EXCEL W U,REASON
..I 'EXCEL W ?109,$E(USER,1,16) ;PRCA*4.5*433
..I EXCEL W U,USER
..;check for end of page here, if necessary form feed and print header
..I ($Y+3)>IOSL D
...I $E(IOST,1,2)="C-" S DIR(0)="E" K DIRUT D ^DIR Q:$D(DIRUT)
...D BILLREPH
I $E(IOST,1,2)="C-",'$D(DIRUT) R !!,"END OF REPORT...PRESS RETURN TO CONTINUE",X:DTIME W @IOF
D ^%ZISC
S:$D(ZTQUEUED) ZTREQ="@"
K ^TMP("RCTCSP6",$J)
K IOP,%ZIS,ZTQUEUED
BILLREPQ Q
;
BILLREPH ;header for cross-servicing bill report
W @IOF
S PAGE=PAGE+1
I 'EXCEL D
. W @IOF,"Cross-Servicing Re-Referred Bills Report -- Run Date: ",RUNDATE," --"
. W ?122,"Page "_PAGE
. W !," Re-Referred Dates from ",$$FMTE^XLFDT(DTFRM,"9D")," to ",$$FMTE^XLFDT(DTTO,"9D")
. W !
;I 'EXCEL W "PAGE "_PAGE,?24,"CROSS-SERVICING BILL REPORT",?60,$$FMTE^XLFDT(DT,"2Z"),!,DASH
;I EXCEL W "PAGE "_PAGE_U_"CROSS-SERVICING BILL REPORT"_U_U_$$FMTE^XLFDT(DT,"2Z")
;N RCHDR,RCSSN
;S RCHDR=$$ACCNTHDR^RCDPAPLM(DEBTOR),RCSSN=$S($P(RCHDR,U,2)["P":$E($P(RCHDR,U,2),7,11),1:$E($P(RCHDR,U,2),6,9)) ;Pseudo SSN shouldn't be allowed but we allowed for it to print
;I EXCEL W !,"Bill #",U,"Debtor Name",U,"SSN",U,"Re-Refer Date",U,"Orig Amt",U,"Curr Amt",U,"Diff Amt",U,"Reason",U,"User ID" Q
I EXCEL W !,"Bill #",U,"AR Cat",U,"Debtor Name",U,"PT ID",U,"Re-Refer Date",U,"Orig Amt",U,"Curr Amt",U,"Diff Amt",U,"Reason",U,"User ID" Q ;PRCA*4.5*433
;W !,"Bill #",?19,"Debtor Name",?37,"SSN",?43,"Re-Refer Date",?57,"Orig Amt",?72,"Curr Amt",?87,"Diff Amt",?102,"Reason",?120,"User ID"
W !,"Bill #",?12,"AR Cat",?22,"Debtor Name",?40,"PT ID",?46,"Re-Refer Dt",?58,"Orig Amt",?71,"Curr Amt",?83,"Diff Amt",?95,"Reason",?110,"User ID" ;PRCA*4.5*433
D ULINE^RCDMCUT2("=",$G(IOM))
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRCTCSP6 6164 printed Dec 13, 2024@01:48:52 Page 2
RCTCSP6 ;ALB/YG - Cross-Servicing Re-Referred Bills Report;03/15/14 3:34 PM
+1 ;;4.5;Accounts Receivable;**350,433**;Mar 20, 1995;Build 7
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;
+4 ;
MAIN ;PRCA*4.5*350
+1 ;
BILLREP ;Cross-servicing bill report, prints individual bills that make up a cross-servicing account
+1 NEW DIC,DEBTOR,ZTSAVE,ZTDESC,ZTRTN,POP,DTFRMTO,PROMPT,EXCEL,RUNDATE,PAGE,DFN
+2 SET RUNDATE=$$FMTE^XLFDT($$NOW^XLFDT,"9MP")
+3 KILL ^TMP("RCTCSP1",$JOB)
+4 SET PAGE=0
+5 WRITE !,"*** Cross-Servicing Re-Referred Bills Report ***",!
+6 WRITE !,"The Cross-Servicing Re-Referred Bills Report provides a list of all bills"
+7 WRITE !,"that have been re-referred to Cross-Servicing.",!
+8 ;S DIC=340,DIC(0)="AEQM",DIC("S")="I $D(^RCD(340,""TCSP"",+Y))" D ^DIC
+9 ;Q:Y<1 S DEBTOR=+Y
+10 ;S DTFRMTO=$$DTFRMTO^RCTCSP2 Q:'DTFRMTO ;Get date range as per PRCA*4.5*315
+11 SET DTFRMTO=$$DATE2^RCDMCUT2(" Enter the Date Range for Bills that have been Re-Referred for Cross-Servicing: ",,"T-7")
+12 SET EXCEL=0
SET PROMPT="CAPTURE Report data to an Excel Document"
SET DIR(0)="Y"
SET DIR("?")="^D HEXC^RCTCSJR"
+13 ;S EXCEL=$$SELECT^RCTCSJR(PROMPT,"NO")
+14 SET EXCEL=$$EXCEL^RCDMCUT2
+15 IF "01"'[EXCEL
QUIT
+16 ; Display Excel display message
IF EXCEL
DO EXCMSG^RCTCSJR
+17 IF 'EXCEL
WRITE !,"It is recommended that you Queue this report to a device that is 132 characters wide. "
+18 ;PRC*4.5*336
SET %ZIS="MQ"
DO ^%ZIS
if POP
GOTO BILLREPQ
+19 IF $DATA(IO("Q"))
Begin DoDot:1
+20 SET ZTSAVE("DEBTOR")=""
SET ZTSAVE("DTFRMTO")=""
SET ZTSAVE("EXCEL")=""
+21 SET ZTRTN="BILLREPP^RCTCSP6"
SET ZTDESC="CROSS-SERVICING BILL REPORT"
+22 DO ^%ZTLOAD
DO HOME^%ZIS
+23 IF $GET(ZTSK)
WRITE !!,"Report compilation has started with task# ",ZTSK,".",!
SET DIR(0)="E"
DO ^DIR
KILL DIR
+24 QUIT
End DoDot:1
GOTO BILLREPQ
+25 ;
BILLREPP ;Call to build array of bills referred
+1 USE IO
+2 NEW BILL,B7,B14,B15,B16,D4,FND,BAMT,DIRUT,TNM,TID,TDT,DASH,CSTAT,PAGE,DASH,TMP,I,DATE,DTFRM,DTTO,DATDATE,REASON,COMMENT,USER,OAMT,LIEN,NAME,NODE,SSN,PTID,RCARCAT
+3 KILL ^TMP("RCTCSP6",$JOB)
+4 ;(as per PRCA*4.5*315)
SET DASH=""
SET $PIECE(DASH,"-",78)=""
+5 SET (DATE,DTFRM)=$$FMADD^XLFDT(+$PIECE(DTFRMTO,U,2))
SET DTTO=$PIECE(DTFRMTO,U,3)
+6 SET (BAMT,BILL,PAGE)=0
+7 ; rewritten to sort by "TCSP" (#151 date referred to TCSP) not the "AB" xref... PRCA*4.5*315 (TV8)
+8 FOR
SET BILL=$ORDER(^PRCA(430,"TCSP",BILL))
if BILL=""!($DATA(DIRUT))
QUIT
if $$RR^RCTCSPU(BILL)
Begin DoDot:1
+9 SET DEBTOR=$PIECE($GET(^PRCA(430,BILL,0)),U,9)
+10 SET DFN=$PIECE($GET(^RCD(340,DEBTOR,0)),U)
if DFN'[";DPT"
QUIT
+11 SET DFN=+DFN
+12 DO DEM^VADPT
+13 IF $GET(VAERR)>0
DO KVAR^VADPT
QUIT
+14 SET NAME=$GET(VADM(1))
+15 IF NAME']""
DO KVAR^VADPT
QUIT
+16 SET SSN=$PIECE(VADM(2),U,1)
+17 ;PRCA*4.5*433
SET PTID=$EXTRACT(VADM(1),1)_$SELECT(SSN'="":$EXTRACT(SSN,6,9),1:"0000")
+18 if '+$GET(^PRCA(430,BILL,15))
QUIT
+19 SET DATDATE=$PIECE($GET(^PRCA(430,BILL,15)),U)
if DATDATE<DTFRM!(DATDATE>DTTO)
QUIT
+20 SET B7=$GET(^PRCA(430,BILL,7))
+21 SET BAMT=0
FOR I=1:1:5
SET BAMT=BAMT+$PIECE(B7,U,I)
+22 SET ^TMP("RCTCSP6",$JOB,DEBTOR,BILL)=BAMT_U_NAME_U_SSN
End DoDot:1
+23 DO BILLREPH
+24 SET DEBTOR=""
FOR
SET DEBTOR=$ORDER(^TMP("RCTCSP6",$JOB,DEBTOR))
if 'DEBTOR!($DATA(DIRUT))
QUIT
Begin DoDot:1
+25 SET BILL=0
FOR
SET BILL=$ORDER(^TMP("RCTCSP6",$JOB,DEBTOR,BILL))
if 'BILL
QUIT
Begin DoDot:2
+26 if '+$GET(^PRCA(430,BILL,15))
QUIT
+27 ;PRCA*4.5*433
SET RCARCAT=$$GET1^DIQ(430,BILL,2,"E")
+28 SET NODE=^TMP("RCTCSP6",$JOB,DEBTOR,BILL)
SET BAMT=$PIECE(NODE,U)
SET NAME=$PIECE(NODE,U,2)
SET SSN=$PIECE(NODE,U,3)
+29 ; Bill
SET FND=1
WRITE !,$PIECE(^PRCA(430,BILL,0),U)
+30 ;PRCA*4.5*433
IF 'EXCEL
WRITE ?12,$EXTRACT(RCARCAT,1,9)
+31 ;PRCA*4.5*433
IF EXCEL
WRITE U,$EXTRACT(RCARCAT,1,9)
+32 SET CSTAT=$PIECE(^(0),U,8)
SET B7=$GET(^(7))
SET B15=$GET(^(15))
SET B16=$GET(^(16))
+33 ; Name ;PRCA*4.5*433
IF 'EXCEL
WRITE ?22,$EXTRACT(NAME,1,17)
+34 IF EXCEL
WRITE U,NAME
+35 ; Patient ID ;PRCA*4.5*433
IF 'EXCEL
WRITE ?40,PTID
+36 IF EXCEL
WRITE U,PTID
+37 ; Rerefer date ;PRCA*4.5*433
IF 'EXCEL
WRITE ?46,$$FMTE^XLFDT($PIECE(B15,U,1),"2Z")
+38 IF EXCEL
WRITE U,$$FMTE^XLFDT($PIECE(B15,U,1),"2Z")
+39 SET OAMT=$PIECE(B16,U,9)
IF OAMT'>0
SET OAMT=$PIECE($GET(^PRCA(430,BILL,30)),U,10)
+40 ; Original Amt ;PRCA*4.5*433
IF 'EXCEL
WRITE ?57,$JUSTIFY("$"_$FNUMBER(OAMT,",",2),11)
+41 IF EXCEL
WRITE U,"$"_$FNUMBER(OAMT,",",2)
+42 ; Curr Amt ;PRCA*4.5*433
IF 'EXCEL
WRITE ?70,$JUSTIFY("$"_$FNUMBER(BAMT,",",2),11)
+43 IF EXCEL
WRITE U,"$"_$FNUMBER(BAMT,",",2)
+44 ; diff amt ;PRCA*4.5*433
IF 'EXCEL
IF OAMT-BAMT'=0
WRITE ?82,$JUSTIFY("$"_$FNUMBER(OAMT-BAMT,",",2),11)
+45 IF EXCEL
WRITE U
if OAMT-BAMT'=0
WRITE "$",$FNUMBER(OAMT-BAMT,",",2)
+46 SET LIEN=$ORDER(^PRCA(430,BILL,15.5,"B",0,""),-1)
+47 SET REASON=$PIECE(^PRCA(430,BILL,15.5,LIEN,0),U,4)
+48 SET REASON=$SELECT(REASON="T":"Treas RVSL",REASON="R":"Recall Error",REASON="D":"DFLT RPP",REASON="O":"Other")
+49 SET USER=$PIECE(^PRCA(430,BILL,15.5,LIEN,0),U,3)
SET USER=$PIECE(^VA(200,USER,0),U)
+50 ;PRCA*4.5*433
IF 'EXCEL
WRITE ?95,$EXTRACT(REASON,1,15)
+51 IF EXCEL
WRITE U,REASON
+52 ;PRCA*4.5*433
IF 'EXCEL
WRITE ?109,$EXTRACT(USER,1,16)
+53 IF EXCEL
WRITE U,USER
+54 ;check for end of page here, if necessary form feed and print header
+55 IF ($Y+3)>IOSL
Begin DoDot:3
+56 IF $EXTRACT(IOST,1,2)="C-"
SET DIR(0)="E"
KILL DIRUT
DO ^DIR
if $DATA(DIRUT)
QUIT
+57 DO BILLREPH
End DoDot:3
End DoDot:2
if $DATA(DIRUT)
QUIT
End DoDot:1
if $DATA(DIRUT)
QUIT
+58 IF $EXTRACT(IOST,1,2)="C-"
IF '$DATA(DIRUT)
READ !!,"END OF REPORT...PRESS RETURN TO CONTINUE",X:DTIME
WRITE @IOF
+59 DO ^%ZISC
+60 if $DATA(ZTQUEUED)
SET ZTREQ="@"
+61 KILL ^TMP("RCTCSP6",$JOB)
+62 KILL IOP,%ZIS,ZTQUEUED
BILLREPQ QUIT
+1 ;
BILLREPH ;header for cross-servicing bill report
+1 WRITE @IOF
+2 SET PAGE=PAGE+1
+3 IF 'EXCEL
Begin DoDot:1
+4 WRITE @IOF,"Cross-Servicing Re-Referred Bills Report -- Run Date: ",RUNDATE," --"
+5 WRITE ?122,"Page "_PAGE
+6 WRITE !," Re-Referred Dates from ",$$FMTE^XLFDT(DTFRM,"9D")," to ",$$FMTE^XLFDT(DTTO,"9D")
+7 WRITE !
End DoDot:1
+8 ;I 'EXCEL W "PAGE "_PAGE,?24,"CROSS-SERVICING BILL REPORT",?60,$$FMTE^XLFDT(DT,"2Z"),!,DASH
+9 ;I EXCEL W "PAGE "_PAGE_U_"CROSS-SERVICING BILL REPORT"_U_U_$$FMTE^XLFDT(DT,"2Z")
+10 ;N RCHDR,RCSSN
+11 ;S RCHDR=$$ACCNTHDR^RCDPAPLM(DEBTOR),RCSSN=$S($P(RCHDR,U,2)["P":$E($P(RCHDR,U,2),7,11),1:$E($P(RCHDR,U,2),6,9)) ;Pseudo SSN shouldn't be allowed but we allowed for it to print
+12 ;I EXCEL W !,"Bill #",U,"Debtor Name",U,"SSN",U,"Re-Refer Date",U,"Orig Amt",U,"Curr Amt",U,"Diff Amt",U,"Reason",U,"User ID" Q
+13 ;PRCA*4.5*433
IF EXCEL
WRITE !,"Bill #",U,"AR Cat",U,"Debtor Name",U,"PT ID",U,"Re-Refer Date",U,"Orig Amt",U,"Curr Amt",U,"Diff Amt",U,"Reason",U,"User ID"
QUIT
+14 ;W !,"Bill #",?19,"Debtor Name",?37,"SSN",?43,"Re-Refer Date",?57,"Orig Amt",?72,"Curr Amt",?87,"Diff Amt",?102,"Reason",?120,"User ID"
+15 ;PRCA*4.5*433
WRITE !,"Bill #",?12,"AR Cat",?22,"Debtor Name",?40,"PT ID",?46,"Re-Refer Dt",?58,"Orig Amt",?71,"Curr Amt",?83,"Diff Amt",?95,"Reason",?110,"User ID"
+16 DO ULINE^RCDMCUT2("=",$GET(IOM))
+17 QUIT
+18 ;
