RCTCSP1 ;ALBANY/BDB-CROSS-SERVICING TRANSMISSION ;03/15/14 3:34 PM
;;4.5;Accounts Receivable;**301,331,315,339,341,336,350,343,433**;Mar 20, 1995;Build 7
;;Per VA Directive 6402, this routine should not be modified.
;
;PRCA*4.5*331 Modify code to ensure that the debtor address info
; is correct on transmission of foreign veterans
; debtor/bills to Treasury.
;
;PRCA*4.5*336 Remove IOP set from device request as it causes
; issue when set after %ZIS call and then jumping
; to new option using ^%ZIS call.
; Also, Set CS call switch for correct address
; when debtor file (340) does not have address
; node 1.
; Also, ensure that the phone number defaults
; to 10 spaces if non-numeric.
;
;PRCA*4.5*343 Ensure a phone number of all zeros defaults
; to a null entry.
;
;PRCA*4.5*433 Add AR Category to Cross Servicing Report
Q
;
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
K ^TMP("RCTCSP1",$J)
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 EXCEL=0,PROMPT="CAPTURE Report data to an Excel Document",DIR(0)="Y",DIR("?")="^D HEXC^RCTCSJR"
S EXCEL=$$SELECT^RCTCSJR(PROMPT,"NO") I "01"'[EXCEL S STOP=1 Q
I EXCEL=1 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. " ;PRCA*4.5*433
K IOP,IO("Q") S %ZIS="MQ",%ZIS("B")="" 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^RCTCSP1",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,TAMT,DIRUT,TNM,TID,TDT,DASH,CSTAT,PAGE,TMP,I,DATE,DTFRM,DTTO,DATDATE
K ^TMP("RCTCSP1",$J)
S DASH="",$P(DASH,"-",97)="" ;PRCA*4.5*433
S (DATE,DTFRM)=$$FMADD^XLFDT(+$P(DTFRMTO,U,2)),DTTO=$P(DTFRMTO,U,3)
S (BAMT,TAMT,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
.Q:$P($G(^PRCA(430,BILL,0)),U,9)'=DEBTOR
.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 TAMT=TAMT+BAMT
.S ^TMP("RCTCSP1",$J,DEBTOR,BILL)=BAMT
D BILLREPH
S DEBTOR="" F S DEBTOR=$O(^TMP("RCTCSP1",$J,DEBTOR)) Q:'DEBTOR!($D(DIRUT)) D
. S BILL=0 F S BILL=$O(^TMP("RCTCSP1",$J,DEBTOR,BILL)) Q:'BILL D
..Q:'+$G(^PRCA(430,BILL,15))
..S FND=1 W !,$P(^PRCA(430,BILL,0),U) S CSTAT=$P(^(0),U,8),B7=$G(^(7)),B15=$G(^(15)),B16=$G(^(16))
..I 'EXCEL W ?12,$P(^PRCA(430.3,CSTAT,0),U,2)
..I EXCEL W U_$P(^PRCA(430.3,CSTAT,0),U,2)
..I 'EXCEL W ?15
..I EXCEL W U
..W $E($P(^PRCA(430.2,$P(^PRCA(430,BILL,0),U,2),0),U),1,10) ;AR CAT PRCA*4.5*433
..I 'EXCEL W ?27 ;PRCA*4.5*433
..I EXCEL W U ;PRCA*4.5*433
..W $J($P(B16,U,9),8,2)
..S BAMT=^TMP("RCTCSP1",$J,DEBTOR,BILL)
..I 'EXCEL W ?37 ;PRCA*4.5*433
..I EXCEL W U
..W $J(BAMT,8,2)
..I 'EXCEL W ?47,$J($P(B7,U,1),9,2),?57,$J($P(B7,U,2),9,2),?67,$J($P(B7,U,3),9,2),?77,$J($P(B7,U,4),9,2) ;PRCA*4.5*433
..I EXCEL W U,$J($P(B7,U,1),8,2)_U_$J($P(B7,U,2),7,2)_U_$J($P(B7,U,3),7,2)_U_$J($P(B7,U,4),8,2)
..S TMP=$$FMTE^XLFDT($P(B15,U,1),"2Z") ;Format date to n/n/nn (as per PRCA*4.5*315)
..I 'EXCEL W ?87,TMP ;$P(TMP,", ",1)_","_$P(TMP,", ",2) ;
..I EXCEL W U_TMP
..;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-" R !!,"END OF REPORT...PRESS RETURN TO CONTINUE",X:DTIME W @IOF
D ^%ZISC
S:$D(ZTQUEUED) ZTREQ="@"
K ^TMP("RCTCSP1",$J)
K IOP,%ZIS,ZTQUEUED
BILLREPQ Q
;
BILLREPH ;header for cross-servicing bill report
W @IOF
S PAGE=PAGE+1
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 D Q
. W !!,"DEBTOR: ",$E($P(RCHDR,U,1),1,18),?26,"SSN: ",RCSSN,?45,"CURRENT CS DEBT: ",$J(TAMT,8,2),!,DASH
. W !,"BILL NO.",?12,"ST",?15,"AR CAT",?27,"ORIG AMT",?37,"CURR AMT",?47,"PRIN",?57,"INT",?67,"ADMIN",?77,"COURT",?87,"CS REF DT" ;PRCA*4.5*433
. W !,"-----------",?12,"--",?15,"----------",?27,"--------",?37,"--------",?47,"---------",?57,"---------",?67,"---------",?77,"---------",?87,"---------" ;PRCA*4.5*433
W !,"DEBTOR: "_$E($P(RCHDR,U,1),1,18)_U_U_"SSN: "_RCSSN_U_U_U_"CURRENT CS DEBT: "_$J(TAMT,8,2)
W !,"BILL NO."_U_"ST"_U_"AR CAT"_U_"ORIG AMT"_U_"CURR AMT"_U_"PRIN"_U_"INT"_U_"ADMIN"_U_"COURT"_U_"CS REF DATE"
Q
;
CSRPRT ;Print Cross-Servicing Report, prints sorted individual bills that make up a cross-servicing account
;
K ^TMP("RCTCSP1",$J)
N DIC,RCSORT,PAGE,DASH,DTOUT,DIRUT,DUOUT,DIROUT,RCIEN,RCDEBTOR,RCREFDT,RCSSN,RCORIG,RCCAMT,RCREFDT,RCBILL,ITEM,DBTR,SDT,SSN,NCIEN,TERMDIG
S PAGE=0,DASH="",$P(DASH,"-",89)=""
W !
S DIR(0)="S^1:Bill Number;2:Debtor Name;3:CS Referred Date",DIR("A")="Sort by" D ^DIR K DIR
S RCSORT=Y Q:($D(DTOUT)!$D(DUOUT)!$D(DIROUT))
; The following sections were rewritten to eliminate using ^DIP - (as per PRCA*4.5*315 reformat dates and SSN)
S DTFRMTO=$$DTFRMTO^RCTCSP2 Q:'DTFRMTO ;Get date range as per PRCA*4.5*315
S (DATE,DTFRM)=$$FMADD^XLFDT(+$P(DTFRMTO,U,2)),DTTO=$P(DTFRMTO,U,3)
S EXCEL=0,PROMPT="CAPTURE Report data to an Excel Document",DIR(0)="Y",DIR("?")="^D HEXC^RCTCSJR"
S EXCEL=$$SELECT^RCTCSJR(PROMPT,"NO") I "01"'[EXCEL S STOP=1 Q
I EXCEL=1 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. " ;PRCA*4.5*433
K IOP,IO("Q") S %ZIS="MQ",%ZIS("B")="" D ^%ZIS Q:POP ;PRC*4.5*336
I $D(IO("Q")) D Q
.S ZTSAVE("RCSORT")="",ZTSAVE("DTFRMTO")="",ZTSAVE("EXCEL")="",ZTSAVE("PROMPT")="",ZTSAVE("PAGE")="",ZTSAVE("DASH")=""
.S ZTRTN="CSRPRTR^RCTCSP1",ZTDESC="PRINT CROSS-SERVICING 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
CSRPRTR ; compile/print job - either foreground or background
U IO
K ^TMP("RCTCSP1",$J)
;
I RCSORT=1 D
. D CSRPRTH1^RCTCSP1A
. S (DATE,DTFRM)=$$FMADD^XLFDT(+$P(DTFRMTO,U,2)),DTTO=$P(DTFRMTO,U,3)
. S RCIEN="" F S RCIEN=$O(^PRCA(430,"TCSP",RCIEN)) Q:RCIEN="" D
.. Q:'$D(^PRCA(430,RCIEN,15)) ;cross servicing data fields
..Q:$P($G(^PRCA(430,RCIEN,15)),U)<DTFRM!($P($G(^PRCA(430,RCIEN,15)),U)>DTTO)
..K LIST,MSG,RCLIST D GETS^DIQ(430,RCIEN_",",".01;2;9;121,141,161;169;151;11","IE","LIST","MSG") S RCLIST=$NA(LIST(430,RCIEN_",")) ;PRCA*4.5*433 added field 2
..;Q:$G(@RCLIST@(141,"E"))'="" ;Date sent to TOP
..S SSN=$E($$SSN^RCFN01(@RCLIST@(9,"I")),6,9) S SSN=$S(SSN'="":SSN,1:" ") ;PRCA*4.5*433
..I SSN S TERMDIG=$E(@RCLIST@(9,"E"),1)_SSN ;PRCA*4.5*433
..I 'SSN S TERMDIG=SSN ;PRCA*4.5*433
..; SSN=$E($$SSN^RCFN01(@RCLIST@(9,"I")),6,9) S SSN=$S(SSN'="":SSN,1:" "),TERMDIG=$E(@RCLIST@(9,"E"),1)_SSN
..I EXCEL D Q
...S ^TMP("RCTCSP1",$J,RCIEN,@RCLIST@(.01,"E"))=@RCLIST@(.01,"E")_U_$E(@RCLIST@(2,"E"),1,10)_U_$E(@RCLIST@(9,"E"),1,19)_U_TERMDIG_U_$J(@RCLIST@(169,"E"),8,2)_U_$$FMTE^XLFDT(@RCLIST@(151,"I"),"2Z") ;PRCA*4.5*433
...S ^TMP("RCTCSP1",$J,RCIEN,@RCLIST@(.01,"E"))=^TMP("RCTCSP1",$J,RCIEN,@RCLIST@(.01,"E"))_U_$J(@RCLIST@(11,"E"),8,2) ;PRCA*4.5*433
...Q
..S ^TMP("RCTCSP1",$J,RCIEN,@RCLIST@(.01,"E"))=@RCLIST@(.01,"E")_U_$E(@RCLIST@(2,"E"),1,10)_U_$E(@RCLIST@(9,"E"),1,19)_U_TERMDIG_U_$J(@RCLIST@(169,"E"),8,2)_U_$$FMTE^XLFDT(@RCLIST@(151,"I"),"2Z") ;PRCA*4.5*433
..S ^TMP("RCTCSP1",$J,RCIEN,@RCLIST@(.01,"E"))=^TMP("RCTCSP1",$J,RCIEN,@RCLIST@(.01,"E"))_U_$J(@RCLIST@(11,"E"),8,2) ;PRCA*4.5*433
.;
.; print report for sort 1
.S (NCIEN,ITEM)="" F S NCIEN=$O(^TMP("RCTCSP1",$J,NCIEN)) Q:NCIEN=""!$D(DIRUT) F S ITEM=$O(^TMP("RCTCSP1",$J,NCIEN,ITEM)) Q:ITEM=""!$D(DIRUT) D Q:$D(DIRUT)
..I EXCEL W !,$P(^TMP("RCTCSP1",$J,NCIEN,ITEM),U)_U_$P(^TMP("RCTCSP1",$J,NCIEN,ITEM),U,2)_U_$P(^TMP("RCTCSP1",$J,NCIEN,ITEM),U,3)
..I EXCEL W U_$P(^TMP("RCTCSP1",$J,NCIEN,ITEM),U,4)_U_$P(^TMP("RCTCSP1",$J,NCIEN,ITEM),U,5)_U_$P(^TMP("RCTCSP1",$J,NCIEN,ITEM),U,6)_U_$P(^TMP("RCTCSP1",$J,NCIEN,ITEM),U,7) ;PRCA*4.5*433
..I EXCEL Q
..; non-Excel output
..W !,$P(^TMP("RCTCSP1",$J,NCIEN,ITEM),U),?14,$P(^TMP("RCTCSP1",$J,NCIEN,ITEM),U,2),?25,$P(^TMP("RCTCSP1",$J,NCIEN,ITEM),U,3) ;PRCA*4.5*433
..W ?46,$P(^TMP("RCTCSP1",$J,NCIEN,ITEM),U,4),?54,$P(^TMP("RCTCSP1",$J,NCIEN,ITEM),U,5),?69,$P(^TMP("RCTCSP1",$J,NCIEN,ITEM),U,6),?79,$P(^TMP("RCTCSP1",$J,NCIEN,ITEM),U,7) ;PRCA*4.5*433
..; page break check
..I ($Y+3)>IOSL D
...I $E(IOST,1,2)="C-" S DIR(0)="E" K DIRUT D ^DIR K DIR Q:$D(DIRUT)
...D CSRPRTH1^RCTCSP1A
...Q
..Q
.Q
;
I RCSORT=2 D
. D CSRPRTH2^RCTCSP1A
. S (DATE,DTFRM)=$$FMADD^XLFDT(+$P(DTFRMTO,U,2),-1),DTTO=$P(DTFRMTO,U,3)
. S RCIEN="" F S RCIEN=$O(^PRCA(430,"TCSP",RCIEN)) Q:RCIEN="" D
..Q:'$D(^PRCA(430,RCIEN,15)) ;cross servicing data fields
..Q:$P($G(^PRCA(430,RCIEN,15)),U)<DTFRM!($P($G(^PRCA(430,RCIEN,15)),U)>DTTO)
..K LIST,MSG,RCLIST D GETS^DIQ(430,RCIEN_",",".01;2;9;121,141,161;169;151;11","IE","LIST","MSG") S RCLIST=$NA(LIST(430,RCIEN_",")) ;PRCA*4.5*433 added field 2
..;Q:$G(@RCLIST@(121,"E"))'="" ;Date sent to DMC
..;Q:$G(@RCLIST@(141,"E"))'="" ;Date sent to TOP
..S SSN=$E($$SSN^RCFN01(@RCLIST@(9,"I")),6,9) S SSN=$S(SSN'="":SSN,1:" ") ;PRCA*4.5*433
..I SSN S TERMDIG=$E(@RCLIST@(9,"E"),1)_SSN ;PRCA*4.5*433
..I 'SSN S TERMDIG=SSN ;PRCA*4.5*433
..I EXCEL D Q
...S ^TMP("RCTCSP1",$J,@RCLIST@(9,"E"),RCIEN)=$E(@RCLIST@(9,"E"),1,19)_U_$E(@RCLIST@(2,"E"),1,10)_U_@RCLIST@(.01,"E")_U_TERMDIG_U_$J(@RCLIST@(169,"E"),8,2)_U_$$FMTE^XLFDT(@RCLIST@(151,"I"),"2Z")_U_$J(@RCLIST@(11,"E"),8,2) Q ;PRCA*4.5*433
..S ^TMP("RCTCSP1",$J,@RCLIST@(9,"E"),RCIEN)=$E(@RCLIST@(9,"E"),1,19)_U_$E(@RCLIST@(2,"E"),1,10)_U_@RCLIST@(.01,"E")_U_SSN_U_$J(@RCLIST@(169,"E"),8,2)_U_$$FMTE^XLFDT(@RCLIST@(151,"I"),"2Z")_U_$J(@RCLIST@(11,"E"),8,2) ;PRCA*4.5*433
.;
.; print report for sort 2
.S (DBTR,NCIEN)="" F S DBTR=$O(^TMP("RCTCSP1",$J,DBTR)) Q:DBTR=""!$D(DIRUT) F S NCIEN=$O(^TMP("RCTCSP1",$J,DBTR,NCIEN)) Q:NCIEN=""!$D(DIRUT) D Q:$D(DIRUT)
..I EXCEL W !,$P(^TMP("RCTCSP1",$J,DBTR,NCIEN),U,1,4)_U_$P(^TMP("RCTCSP1",$J,DBTR,NCIEN),U,5)_U_$P(^TMP("RCTCSP1",$J,DBTR,NCIEN),U,6)_U_$P(^TMP("RCTCSP1",$J,DBTR,NCIEN),U,7) ;PRCA*4.5*433
..I EXCEL Q
..; non-Excel output
..W !,$P(^TMP("RCTCSP1",$J,DBTR,NCIEN),U),?21,$P(^TMP("RCTCSP1",$J,DBTR,NCIEN),U,2),?33,$P(^TMP("RCTCSP1",$J,DBTR,NCIEN),U,3),?46,$P(^TMP("RCTCSP1",$J,DBTR,NCIEN),U,4) ;PRCA*4.5*433
..W ?54,$P(^TMP("RCTCSP1",$J,DBTR,NCIEN),U,5),?69,$P(^TMP("RCTCSP1",$J,DBTR,NCIEN),U,6),?80,$P(^TMP("RCTCSP1",$J,DBTR,NCIEN),U,7) ;PRCA*4.5*433
..; page break check
..I ($Y+3)>IOSL D
...I $E(IOST,1,2)="C-" S DIR(0)="E" K DIRUT D ^DIR K DIR Q:$D(DIRUT)
...D CSRPRTH2^RCTCSP1A
...Q
..Q
.Q
;
I RCSORT=3 D
.D CSRPRTH3^RCTCSP1A
.S (DATE,DTFRM)=$$FMADD^XLFDT(+$P(DTFRMTO,U,2),-1),DTTO=$P(DTFRMTO,U,3)
.S RCIEN="" F S RCIEN=$O(^PRCA(430,"TCSP",RCIEN)) Q:RCIEN="" D
..Q:'$D(^PRCA(430,RCIEN,15)) ;cross servicing data fields
..Q:$P(^PRCA(430,RCIEN,15),U)<DTFRM!($P(^PRCA(430,RCIEN,15),U)>DTTO)
..K LIST,MSG,RCLIST D GETS^DIQ(430,RCIEN_",",".01;2;9;121,141,161;169;151;11","IE","LIST","MSG") S RCLIST=$NA(LIST(430,RCIEN_",")) ;PRCA*4.5*433 Added field 2
..;Q:$G(@RCLIST@(121,"E"))'="" ;Date sent to DMC
..;Q:$G(@RCLIST@(141,"E"))'="" ;Date sent to TOP
..;S SSN=$E($$SSN^RCFN01(@RCLIST@(9,"I")),6,9) S SSN=$S(SSN'="":SSN,1:" "),TERMDIG=$E(@RCLIST@(9,"E"),1)_SSN
..S SSN=$E($$SSN^RCFN01(@RCLIST@(9,"I")),6,9) S SSN=$S(SSN'="":SSN,1:" ") ;PRCA*4.5*433
..I SSN S TERMDIG=$E(@RCLIST@(9,"E"),1)_SSN ;PRCA*4.5*433
..I 'SSN S TERMDIG=SSN ;PRCA*4.5*433
..I EXCEL S ^TMP("RCTCSP1",$J,@RCLIST@(151,"I"),RCIEN)=$$FMTE^XLFDT(@RCLIST@(151,"I"),"2Z")_U_$E(@RCLIST@(2,"E"),1,10)_U_$E(@RCLIST@(9,"E"),1,19)_U_@RCLIST@(.01,"E")_U_TERMDIG_U_$J(@RCLIST@(169,"E"),8,2)_U_$J(@RCLIST@(11,"E"),8,2) ;PRCA*4.5*433
..I 'EXCEL D ;PRCA*4.5*433
... S ^TMP("RCTCSP1",$J,@RCLIST@(151,"I"),RCIEN)=$$FMTE^XLFDT(@RCLIST@(151,"I"),"2Z")_U_$E(@RCLIST@(2,"E"),1,10)_U_$E(@RCLIST@(9,"E"),1,19)_U_@RCLIST@(.01,"E")_U_TERMDIG_U_$J(@RCLIST@(169,"E"),8,2)_U_$J(@RCLIST@(11,"E"),8,2) ;PRCA*4.5*433
.;
.; print report for sort 3
.S (SDT,NCIEN)="" F S SDT=$O(^TMP("RCTCSP1",$J,SDT)) Q:SDT=""!$D(DIRUT) F S NCIEN=$O(^TMP("RCTCSP1",$J,SDT,NCIEN)) Q:NCIEN=""!$D(DIRUT) D Q:$D(DIRUT)
..I EXCEL W !,$P(^TMP("RCTCSP1",$J,SDT,NCIEN),U)_U_$P(^TMP("RCTCSP1",$J,SDT,NCIEN),U,2)_U_$P(^TMP("RCTCSP1",$J,SDT,NCIEN),U,3)_U_$P(^TMP("RCTCSP1",$J,SDT,NCIEN),U,4) ;PRCA*4.5*433
..I EXCEL W U_$P(^TMP("RCTCSP1",$J,SDT,NCIEN),U,5)_U_$P(^TMP("RCTCSP1",$J,SDT,NCIEN),U,6)_U_$P(^TMP("RCTCSP1",$J,SDT,NCIEN),U,7) ;PRCA*4.5*433
..I EXCEL Q
..; non-Excel output
..W !,$P(^TMP("RCTCSP1",$J,SDT,NCIEN),U),?13,$P(^TMP("RCTCSP1",$J,SDT,NCIEN),U,2),?25,$P(^TMP("RCTCSP1",$J,SDT,NCIEN),U,3),?47 ;PRCA*4.5*433
..W $P(^TMP("RCTCSP1",$J,SDT,NCIEN),U,4),?60,$P(^TMP("RCTCSP1",$J,SDT,NCIEN),U,5),?68,$P(^TMP("RCTCSP1",$J,SDT,NCIEN),U,6),?80,$P(^TMP("RCTCSP1",$J,SDT,NCIEN),U,7) ;PRCA*4.5*433
..; page break check
..I ($Y+3)>IOSL D
...I $E(IOST,1,2)="C-" S DIR(0)="E" K DIRUT D ^DIR K DIR Q:$D(DIRUT)
...D CSRPRTH3^RCTCSP1A
...Q
..Q
.Q
;
;end of report
I $E(IOST,1,2)="C-",'$D(DIRUT) R !!,"END OF REPORT...PRESS RETURN TO CONTINUE",X:DTIME W @IOF
;
K ^TMP("RCTCSP1",$J) ; kill scratch
D ^%ZISC ; close device
I $D(ZTQUEUED) S ZTREQ="@" ; purge the task
Q
;
REC5B ;Create record 5B for Treasury
;
D REC5B^RCTCSP1A ;PRCA*4.5*433 Functinality of tag REC5B moved routine RCTCSP1A for SACC size compliance
;
DATE8(X) ;changes fileman date into 8 digit date yyyymmdd
I +X S X=X+17000000
S X=$E(X,1,8)
Q X
;
AMOUNT(X,TT) ;changes amount to zero filled, right justified
;Zeroes are positive
;Increase adjustment are positive (TT=73,74)
;All other tranactions are negative (reduce bill balance)
S X=$TR($J(X,0,2),".")
S X=$E($S(+X=0:0,TT=73!(TT=74):0,1:"-")_"00000000000",1,14-$L(X))_X
Q X
;
BLANK(X) ;returns 'x' blank spaces
N BLANK
S BLANK="",$P(BLANK," ",X+1)=""
Q BLANK
;
RJZF(X,Y) ;right justify zero fill width Y
S X=$E("000000000000",1,Y-$L(X))_X
Q X
;
LJSF(X,Y) ;left justified space filled
S X=$E(X,1,Y)
S X=X_$$BLANK(Y-$L(X))
Q X
;
TAXID(DEBTOR) ;computes TAXID to place on documents
N TAXID,DIC,DA,DR,DIQ
S TAXID=$$SSN^RCFN01(DEBTOR)
S TAXID=$$LJSF(TAXID,9)
Q TAXID
;
ADDR(RCDFN,RCCSW) ; returns patient file address
N DFN,ADDRCS,STATEIEN,STATEAB,VAPA,ADDR340,PRCAYY,PRCAPHON
S DFN=RCDFN
D ADD^VADPT
S STATEIEN=+VAPA(5),STATEAB=$$GET1^DIQ(5,STATEIEN,1)
S ADDRCS=VAPA(1)_U_VAPA(2)_U_VAPA(4)_U_STATEAB_U_VAPA(6)_U_VAPA(8)_U_+VAPA(25)
S ADDR340=$P($$DADD^RCAMADD(DEBTOR,,RCCSW),U,1,8) ;PRCA*4.5*336
I $P(ADDRCS,U,7)>2 S $P(ADDR340,U,6)=" " ;PRCA*4.5*331/336
S ADDR340=$P(ADDR340,U,1,2)_"^"_$P(ADDR340,U,4,7)_U_$S($P(ADDRCS,U,7)'="":$P(ADDRCS,U,7),1:1) ;PRCA*4.5*331
I $P(ADDR340,U,7)="" S $P(ADDR340,U,7)=$P(ADDRCS,U,7) ;PRCA*4.5*331
I $P(ADDR340,U,7)>2 S $P(ADDR340,U,4)=" " ;PRCA*4.5*331/336
S PRCAYY="",PRCAPHON=$P(ADDR340,U,6) F I=1:1:$L(PRCAPHON) I $E(PRCAPHON,I)?1N S PRCAYY=PRCAYY_$E($P(ADDR340,U,6),I)
S PRCAPHON=PRCAYY I $L(PRCAPHON)'=10!(+PRCAPHON=0) S VAPA(8)=" ",$P(ADDR340,U,6)=" " ;PRCA*4.5*336/PRCA*4.5*343
S ADDRCS=ADDR340
Q ADDRCS
;
DEM(RCDFN) ; returns patient file information
N DFN,VADM
S DFN=RCDFN
D DEM^VADPT
; return string sex:m/f ^ dob: yyyymmdd ^ ssn ^ deceased ^ Debtor Name
Q $P(VADM(5),U,1)_U_$P(VADM(3),U,1)_U_$P(VADM(2),U,1)_U_VADM(6)
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRCTCSP1 16659 printed Sep 23, 2025@19:24:54 Page 2
RCTCSP1 ;ALBANY/BDB-CROSS-SERVICING TRANSMISSION ;03/15/14 3:34 PM
+1 ;;4.5;Accounts Receivable;**301,331,315,339,341,336,350,343,433**;Mar 20, 1995;Build 7
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;
+4 ;PRCA*4.5*331 Modify code to ensure that the debtor address info
+5 ; is correct on transmission of foreign veterans
+6 ; debtor/bills to Treasury.
+7 ;
+8 ;PRCA*4.5*336 Remove IOP set from device request as it causes
+9 ; issue when set after %ZIS call and then jumping
+10 ; to new option using ^%ZIS call.
+11 ; Also, Set CS call switch for correct address
+12 ; when debtor file (340) does not have address
+13 ; node 1.
+14 ; Also, ensure that the phone number defaults
+15 ; to 10 spaces if non-numeric.
+16 ;
+17 ;PRCA*4.5*343 Ensure a phone number of all zeros defaults
+18 ; to a null entry.
+19 ;
+20 ;PRCA*4.5*433 Add AR Category to Cross Servicing Report
+21 QUIT
+22 ;
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
+2 KILL ^TMP("RCTCSP1",$JOB)
+3 SET DIC=340
SET DIC(0)="AEQM"
SET DIC("S")="I $D(^RCD(340,""TCSP"",+Y))"
DO ^DIC
+4 if Y<1
QUIT
SET DEBTOR=+Y
+5 ;Get date range as per PRCA*4.5*315
SET DTFRMTO=$$DTFRMTO^RCTCSP2
if 'DTFRMTO
QUIT
+6 SET EXCEL=0
SET PROMPT="CAPTURE Report data to an Excel Document"
SET DIR(0)="Y"
SET DIR("?")="^D HEXC^RCTCSJR"
+7 SET EXCEL=$$SELECT^RCTCSJR(PROMPT,"NO")
IF "01"'[EXCEL
SET STOP=1
QUIT
+8 ; Display Excel display message
IF EXCEL=1
DO EXCMSG^RCTCSJR
+9 ;PRCA*4.5*433
IF 'EXCEL
WRITE !,"It is recommended that you Queue this report to a device that is 132 characters wide. "
+10 ;PRC*4.5*336
KILL IOP,IO("Q")
SET %ZIS="MQ"
SET %ZIS("B")=""
DO ^%ZIS
if POP
GOTO BILLREPQ
+11 IF $DATA(IO("Q"))
Begin DoDot:1
+12 SET ZTSAVE("DEBTOR")=""
SET ZTSAVE("DTFRMTO")=""
SET ZTSAVE("EXCEL")=""
+13 SET ZTRTN="BILLREPP^RCTCSP1"
SET ZTDESC="CROSS-SERVICING BILL REPORT"
+14 DO ^%ZTLOAD
DO HOME^%ZIS
+15 IF $GET(ZTSK)
WRITE !!,"Report compilation has started with task# ",ZTSK,".",!
SET DIR(0)="E"
DO ^DIR
KILL DIR
+16 QUIT
End DoDot:1
GOTO BILLREPQ
+17 ;
BILLREPP ;Call to build array of bills referred
+1 USE IO
+2 NEW BILL,B7,B14,B15,B16,D4,FND,BAMT,TAMT,DIRUT,TNM,TID,TDT,DASH,CSTAT,PAGE,TMP,I,DATE,DTFRM,DTTO,DATDATE
+3 KILL ^TMP("RCTCSP1",$JOB)
+4 ;PRCA*4.5*433
SET DASH=""
SET $PIECE(DASH,"-",97)=""
+5 SET (DATE,DTFRM)=$$FMADD^XLFDT(+$PIECE(DTFRMTO,U,2))
SET DTTO=$PIECE(DTFRMTO,U,3)
+6 SET (BAMT,TAMT,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
Begin DoDot:1
+9 if $PIECE($GET(^PRCA(430,BILL,0)),U,9)'=DEBTOR
QUIT
+10 if '+$GET(^PRCA(430,BILL,15))
QUIT
+11 SET DATDATE=$PIECE($GET(^PRCA(430,BILL,15)),U)
if DATDATE<DTFRM!(DATDATE>DTTO)
QUIT
+12 SET B7=$GET(^PRCA(430,BILL,7))
+13 SET BAMT=0
FOR I=1:1:5
SET BAMT=BAMT+$PIECE(B7,U,I)
+14 SET TAMT=TAMT+BAMT
+15 SET ^TMP("RCTCSP1",$JOB,DEBTOR,BILL)=BAMT
End DoDot:1
+16 DO BILLREPH
+17 SET DEBTOR=""
FOR
SET DEBTOR=$ORDER(^TMP("RCTCSP1",$JOB,DEBTOR))
if 'DEBTOR!($DATA(DIRUT))
QUIT
Begin DoDot:1
+18 SET BILL=0
FOR
SET BILL=$ORDER(^TMP("RCTCSP1",$JOB,DEBTOR,BILL))
if 'BILL
QUIT
Begin DoDot:2
+19 if '+$GET(^PRCA(430,BILL,15))
QUIT
+20 SET FND=1
WRITE !,$PIECE(^PRCA(430,BILL,0),U)
SET CSTAT=$PIECE(^(0),U,8)
SET B7=$GET(^(7))
SET B15=$GET(^(15))
SET B16=$GET(^(16))
+21 IF 'EXCEL
WRITE ?12,$PIECE(^PRCA(430.3,CSTAT,0),U,2)
+22 IF EXCEL
WRITE U_$PIECE(^PRCA(430.3,CSTAT,0),U,2)
+23 IF 'EXCEL
WRITE ?15
+24 IF EXCEL
WRITE U
+25 ;AR CAT PRCA*4.5*433
WRITE $EXTRACT($PIECE(^PRCA(430.2,$PIECE(^PRCA(430,BILL,0),U,2),0),U),1,10)
+26 ;PRCA*4.5*433
IF 'EXCEL
WRITE ?27
+27 ;PRCA*4.5*433
IF EXCEL
WRITE U
+28 WRITE $JUSTIFY($PIECE(B16,U,9),8,2)
+29 SET BAMT=^TMP("RCTCSP1",$JOB,DEBTOR,BILL)
+30 ;PRCA*4.5*433
IF 'EXCEL
WRITE ?37
+31 IF EXCEL
WRITE U
+32 WRITE $JUSTIFY(BAMT,8,2)
+33 ;PRCA*4.5*433
IF 'EXCEL
WRITE ?47,$JUSTIFY($PIECE(B7,U,1),9,2),?57,$JUSTIFY($PIECE(B7,U,2),9,2),?67,$JUSTIFY($PIECE(B7,U,3),9,2),?77,$JUSTIFY($PIECE(B7,U,4),9,2)
+34 IF EXCEL
WRITE U,$JUSTIFY($PIECE(B7,U,1),8,2)_U_$JUSTIFY($PIECE(B7,U,2),7,2)_U_$JUSTIFY($PIECE(B7,U,3),7,2)_U_$JUSTIFY($PIECE(B7,U,4),8,2)
+35 ;Format date to n/n/nn (as per PRCA*4.5*315)
SET TMP=$$FMTE^XLFDT($PIECE(B15,U,1),"2Z")
+36 ;$P(TMP,", ",1)_","_$P(TMP,", ",2) ;
IF 'EXCEL
WRITE ?87,TMP
+37 IF EXCEL
WRITE U_TMP
+38 ;check for end of page here, if necessary form feed and print header
+39 IF ($Y+3)>IOSL
Begin DoDot:3
+40 IF $EXTRACT(IOST,1,2)="C-"
SET DIR(0)="E"
KILL DIRUT
DO ^DIR
if $DATA(DIRUT)
QUIT
+41 DO BILLREPH
End DoDot:3
End DoDot:2
End DoDot:1
+42 IF $EXTRACT(IOST,1,2)="C-"
READ !!,"END OF REPORT...PRESS RETURN TO CONTINUE",X:DTIME
WRITE @IOF
+43 DO ^%ZISC
+44 if $DATA(ZTQUEUED)
SET ZTREQ="@"
+45 KILL ^TMP("RCTCSP1",$JOB)
+46 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
WRITE "PAGE "_PAGE,?24,"CROSS-SERVICING BILL REPORT",?60,$$FMTE^XLFDT(DT,"2Z"),!,DASH
+4 IF EXCEL
WRITE "PAGE "_PAGE_U_"CROSS-SERVICING BILL REPORT"_U_U_$$FMTE^XLFDT(DT,"2Z")
+5 NEW RCHDR,RCSSN
+6 ;Pseudo SSN shouldn't be allowed but we allowed for it to print
SET RCHDR=$$ACCNTHDR^RCDPAPLM(DEBTOR)
SET RCSSN=$SELECT($PIECE(RCHDR,U,2)["P":$EXTRACT($PIECE(RCHDR,U,2),7,11),1:$EXTRACT($PIECE(RCHDR,U,2),6,9))
+7 IF 'EXCEL
Begin DoDot:1
+8 WRITE !!,"DEBTOR: ",$EXTRACT($PIECE(RCHDR,U,1),1,18),?26,"SSN: ",RCSSN,?45,"CURRENT CS DEBT: ",$JUSTIFY(TAMT,8,2),!,DASH
+9 ;PRCA*4.5*433
WRITE !,"BILL NO.",?12,"ST",?15,"AR CAT",?27,"ORIG AMT",?37,"CURR AMT",?47,"PRIN",?57,"INT",?67,"ADMIN",?77,"COURT",?87,"CS REF DT"
+10 ;PRCA*4.5*433
WRITE !,"-----------",?12,"--",?15,"----------",?27,"--------",?37,"--------",?47,"---------",?57,"---------",?67,"---------",?77,"---------",?87,"---------"
End DoDot:1
QUIT
+11 WRITE !,"DEBTOR: "_$EXTRACT($PIECE(RCHDR,U,1),1,18)_U_U_"SSN: "_RCSSN_U_U_U_"CURRENT CS DEBT: "_$JUSTIFY(TAMT,8,2)
+12 WRITE !,"BILL NO."_U_"ST"_U_"AR CAT"_U_"ORIG AMT"_U_"CURR AMT"_U_"PRIN"_U_"INT"_U_"ADMIN"_U_"COURT"_U_"CS REF DATE"
+13 QUIT
+14 ;
CSRPRT ;Print Cross-Servicing Report, prints sorted individual bills that make up a cross-servicing account
+1 ;
+2 KILL ^TMP("RCTCSP1",$JOB)
+3 NEW DIC,RCSORT,PAGE,DASH,DTOUT,DIRUT,DUOUT,DIROUT,RCIEN,RCDEBTOR,RCREFDT,RCSSN,RCORIG,RCCAMT,RCREFDT,RCBILL,ITEM,DBTR,SDT,SSN,NCIEN,TERMDIG
+4 SET PAGE=0
SET DASH=""
SET $PIECE(DASH,"-",89)=""
+5 WRITE !
+6 SET DIR(0)="S^1:Bill Number;2:Debtor Name;3:CS Referred Date"
SET DIR("A")="Sort by"
DO ^DIR
KILL DIR
+7 SET RCSORT=Y
if ($DATA(DTOUT)!$DATA(DUOUT)!$DATA(DIROUT))
QUIT
+8 ; The following sections were rewritten to eliminate using ^DIP - (as per PRCA*4.5*315 reformat dates and SSN)
+9 ;Get date range as per PRCA*4.5*315
SET DTFRMTO=$$DTFRMTO^RCTCSP2
if 'DTFRMTO
QUIT
+10 SET (DATE,DTFRM)=$$FMADD^XLFDT(+$PIECE(DTFRMTO,U,2))
SET DTTO=$PIECE(DTFRMTO,U,3)
+11 SET EXCEL=0
SET PROMPT="CAPTURE Report data to an Excel Document"
SET DIR(0)="Y"
SET DIR("?")="^D HEXC^RCTCSJR"
+12 SET EXCEL=$$SELECT^RCTCSJR(PROMPT,"NO")
IF "01"'[EXCEL
SET STOP=1
QUIT
+13 ; Display Excel display message
IF EXCEL=1
DO EXCMSG^RCTCSJR
+14 ;PRCA*4.5*433
IF 'EXCEL
WRITE !,"It is recommended that you Queue this report to a device that is 132 characters wide. "
+15 ;PRC*4.5*336
KILL IOP,IO("Q")
SET %ZIS="MQ"
SET %ZIS("B")=""
DO ^%ZIS
if POP
QUIT
+16 IF $DATA(IO("Q"))
Begin DoDot:1
+17 SET ZTSAVE("RCSORT")=""
SET ZTSAVE("DTFRMTO")=""
SET ZTSAVE("EXCEL")=""
SET ZTSAVE("PROMPT")=""
SET ZTSAVE("PAGE")=""
SET ZTSAVE("DASH")=""
+18 SET ZTRTN="CSRPRTR^RCTCSP1"
SET ZTDESC="PRINT CROSS-SERVICING REPORT"
+19 DO ^%ZTLOAD
DO HOME^%ZIS
+20 IF $GET(ZTSK)
WRITE !!,"Report compilation has started with task# ",ZTSK,".",!
SET DIR(0)="E"
DO ^DIR
KILL DIR
+21 QUIT
End DoDot:1
QUIT
CSRPRTR ; compile/print job - either foreground or background
+1 USE IO
+2 KILL ^TMP("RCTCSP1",$JOB)
+3 ;
+4 IF RCSORT=1
Begin DoDot:1
+5 DO CSRPRTH1^RCTCSP1A
+6 SET (DATE,DTFRM)=$$FMADD^XLFDT(+$PIECE(DTFRMTO,U,2))
SET DTTO=$PIECE(DTFRMTO,U,3)
+7 SET RCIEN=""
FOR
SET RCIEN=$ORDER(^PRCA(430,"TCSP",RCIEN))
if RCIEN=""
QUIT
Begin DoDot:2
+8 ;cross servicing data fields
if '$DATA(^PRCA(430,RCIEN,15))
QUIT
+9 if $PIECE($GET(^PRCA(430,RCIEN,15)),U)<DTFRM!($PIECE($GET(^PRCA(430,RCIEN,15)),U)>DTTO)
QUIT
+10 ;PRCA*4.5*433 added field 2
KILL LIST,MSG,RCLIST
DO GETS^DIQ(430,RCIEN_",",".01;2;9;121,141,161;169;151;11","IE","LIST","MSG")
SET RCLIST=$NAME(LIST(430,RCIEN_","))
+11 ;Q:$G(@RCLIST@(141,"E"))'="" ;Date sent to TOP
+12 ;PRCA*4.5*433
SET SSN=$EXTRACT($$SSN^RCFN01(@RCLIST@(9,"I")),6,9)
SET SSN=$SELECT(SSN'="":SSN,1:" ")
+13 ;PRCA*4.5*433
IF SSN
SET TERMDIG=$EXTRACT(@RCLIST@(9,"E"),1)_SSN
+14 ;PRCA*4.5*433
IF 'SSN
SET TERMDIG=SSN
+15 ; SSN=$E($$SSN^RCFN01(@RCLIST@(9,"I")),6,9) S SSN=$S(SSN'="":SSN,1:" "),TERMDIG=$E(@RCLIST@(9,"E"),1)_SSN
+16 IF EXCEL
Begin DoDot:3
+17 ;PRCA*4.5*433
SET ^TMP("RCTCSP1",$JOB,RCIEN,@RCLIST@(.01,"E"))=@RCLIST@(.01,"E")_U_$EXTRACT(@RCLIST@(2,"E"),1,10)_U_$EXTRACT(@RCLIST@(9,"E"),1,19)_U_TERMDIG_U_$JUSTIFY(@RCLIST@(169,"E"),8,2)_U_$$FMTE^XLFDT(@RCLIST@(151,"I"),"2Z")
+18 ;PRCA*4.5*433
SET ^TMP("RCTCSP1",$JOB,RCIEN,@RCLIST@(.01,"E"))=^TMP("RCTCSP1",$JOB,RCIEN,@RCLIST@(.01,"E"))_U_$JUSTIFY(@RCLIST@(11,"E"),8,2)
+19 QUIT
End DoDot:3
QUIT
+20 ;PRCA*4.5*433
SET ^TMP("RCTCSP1",$JOB,RCIEN,@RCLIST@(.01,"E"))=@RCLIST@(.01,"E")_U_$EXTRACT(@RCLIST@(2,"E"),1,10)_U_$EXTRACT(@RCLIST@(9,"E"),1,19)_U_TERMDIG_U_$JUSTIFY(@RCLIST@(169,"E"),8,2)_U_$$FMTE^XLFDT(@RCLIST@(151,"I"),"2Z")
+21 ;PRCA*4.5*433
SET ^TMP("RCTCSP1",$JOB,RCIEN,@RCLIST@(.01,"E"))=^TMP("RCTCSP1",$JOB,RCIEN,@RCLIST@(.01,"E"))_U_$JUSTIFY(@RCLIST@(11,"E"),8,2)
End DoDot:2
+22 ;
+23 ; print report for sort 1
+24 SET (NCIEN,ITEM)=""
FOR
SET NCIEN=$ORDER(^TMP("RCTCSP1",$JOB,NCIEN))
if NCIEN=""!$DATA(DIRUT)
QUIT
FOR
SET ITEM=$ORDER(^TMP("RCTCSP1",$JOB,NCIEN,ITEM))
if ITEM=""!$DATA(DIRUT)
QUIT
Begin DoDot:2
+25 IF EXCEL
WRITE !,$PIECE(^TMP("RCTCSP1",$JOB,NCIEN,ITEM),U)_U_$PIECE(^TMP("RCTCSP1",$JOB,NCIEN,ITEM),U,2)_U_$PIECE(^TMP("RCTCSP1",$JOB,NCIEN,ITEM),U,3)
+26 ;PRCA*4.5*433
IF EXCEL
WRITE U_$PIECE(^TMP("RCTCSP1",$JOB,NCIEN,ITEM),U,4)_U_$PIECE(^TMP("RCTCSP1",$JOB,NCIEN,ITEM),U,5)_U_$PIECE(^TMP("RCTCSP1",$JOB,NCIEN,ITEM),U,6)_U_$PIECE(^TMP("RCTCSP1",$JOB,NCIEN,ITEM),U,7)
+27 IF EXCEL
QUIT
+28 ; non-Excel output
+29 ;PRCA*4.5*433
WRITE !,$PIECE(^TMP("RCTCSP1",$JOB,NCIEN,ITEM),U),?14,$PIECE(^TMP("RCTCSP1",$JOB,NCIEN,ITEM),U,2),?25,$PIECE(^TMP("RCTCSP1",$JOB,NCIEN,ITEM),U,3)
+30 ;PRCA*4.5*433
WRITE ?46,$PIECE(^TMP("RCTCSP1",$JOB,NCIEN,ITEM),U,4),?54,$PIECE(^TMP("RCTCSP1",$JOB,NCIEN,ITEM),U,5),?69,$PIECE(^TMP("RCTCSP1",$JOB,NCIEN,ITEM),U,6),?79,$PIECE(^TMP("RCTCSP1",$JOB,NCIEN,ITEM),U,7)
+31 ; page break check
+32 IF ($Y+3)>IOSL
Begin DoDot:3
+33 IF $EXTRACT(IOST,1,2)="C-"
SET DIR(0)="E"
KILL DIRUT
DO ^DIR
KILL DIR
if $DATA(DIRUT)
QUIT
+34 DO CSRPRTH1^RCTCSP1A
+35 QUIT
End DoDot:3
+36 QUIT
End DoDot:2
if $DATA(DIRUT)
QUIT
+37 QUIT
End DoDot:1
+38 ;
+39 IF RCSORT=2
Begin DoDot:1
+40 DO CSRPRTH2^RCTCSP1A
+41 SET (DATE,DTFRM)=$$FMADD^XLFDT(+$PIECE(DTFRMTO,U,2),-1)
SET DTTO=$PIECE(DTFRMTO,U,3)
+42 SET RCIEN=""
FOR
SET RCIEN=$ORDER(^PRCA(430,"TCSP",RCIEN))
if RCIEN=""
QUIT
Begin DoDot:2
+43 ;cross servicing data fields
if '$DATA(^PRCA(430,RCIEN,15))
QUIT
+44 if $PIECE($GET(^PRCA(430,RCIEN,15)),U)<DTFRM!($PIECE($GET(^PRCA(430,RCIEN,15)),U)>DTTO)
QUIT
+45 ;PRCA*4.5*433 added field 2
KILL LIST,MSG,RCLIST
DO GETS^DIQ(430,RCIEN_",",".01;2;9;121,141,161;169;151;11","IE","LIST","MSG")
SET RCLIST=$NAME(LIST(430,RCIEN_","))
+46 ;Q:$G(@RCLIST@(121,"E"))'="" ;Date sent to DMC
+47 ;Q:$G(@RCLIST@(141,"E"))'="" ;Date sent to TOP
+48 ;PRCA*4.5*433
SET SSN=$EXTRACT($$SSN^RCFN01(@RCLIST@(9,"I")),6,9)
SET SSN=$SELECT(SSN'="":SSN,1:" ")
+49 ;PRCA*4.5*433
IF SSN
SET TERMDIG=$EXTRACT(@RCLIST@(9,"E"),1)_SSN
+50 ;PRCA*4.5*433
IF 'SSN
SET TERMDIG=SSN
+51 IF EXCEL
Begin DoDot:3
+52 ;PRCA*4.5*433
SET ^TMP("RCTCSP1",$JOB,@RCLIST@(9,"E"),RCIEN)=$EXTRACT(@RCLIST@(9,"E"),1,19)_U_$EXTRACT(@RCLIST@(2,"E"),1,10)_U_@RCLIST@(.01,"E")_U_TERMDIG_U_$JUSTIFY(@RCLIST@(169,"E"),8,2)_U_$$FMTE^XLFDT(@RCLIST@(151,"I"),"2Z")_U_$JUS
TIFY(@RCLIST@(11,"E"),8,2)
QUIT
End DoDot:3
QUIT
+53 ;PRCA*4.5*433
SET ^TMP("RCTCSP1",$JOB,@RCLIST@(9,"E"),RCIEN)=$EXTRACT(@RCLIST@(9,"E"),1,19)_U_$EXTRACT(@RCLIST@(2,"E"),1,10)_U_@RCLIST@(.01,"E")_U_SSN_U_$JUSTIFY(@RCLIST@(169,"E"),8,2)_U_$$FMTE^XLFDT(@RCLIST@(151,"I"),"2Z")_U_$JUSTIFY(@RCLIST
@(11,"E"),8,2)
End DoDot:2
+54 ;
+55 ; print report for sort 2
+56 SET (DBTR,NCIEN)=""
FOR
SET DBTR=$ORDER(^TMP("RCTCSP1",$JOB,DBTR))
if DBTR=""!$DATA(DIRUT)
QUIT
FOR
SET NCIEN=$ORDER(^TMP("RCTCSP1",$JOB,DBTR,NCIEN))
if NCIEN=""!$DATA(DIRUT)
QUIT
Begin DoDot:2
+57 ;PRCA*4.5*433
IF EXCEL
WRITE !,$PIECE(^TMP("RCTCSP1",$JOB,DBTR,NCIEN),U,1,4)_U_$PIECE(^TMP("RCTCSP1",$JOB,DBTR,NCIEN),U,5)_U_$PIECE(^TMP("RCTCSP1",$JOB,DBTR,NCIEN),U,6)_U_$PIECE(^TMP("RCTCSP1",$JOB,DBTR,NCIEN),U,7)
+58 IF EXCEL
QUIT
+59 ; non-Excel output
+60 ;PRCA*4.5*433
WRITE !,$PIECE(^TMP("RCTCSP1",$JOB,DBTR,NCIEN),U),?21,$PIECE(^TMP("RCTCSP1",$JOB,DBTR,NCIEN),U,2),?33,$PIECE(^TMP("RCTCSP1",$JOB,DBTR,NCIEN),U,3),?46,$PIECE(^TMP("RCTCSP1",$JOB,DBTR,NCIEN),U,4)
+61 ;PRCA*4.5*433
WRITE ?54,$PIECE(^TMP("RCTCSP1",$JOB,DBTR,NCIEN),U,5),?69,$PIECE(^TMP("RCTCSP1",$JOB,DBTR,NCIEN),U,6),?80,$PIECE(^TMP("RCTCSP1",$JOB,DBTR,NCIEN),U,7)
+62 ; page break check
+63 IF ($Y+3)>IOSL
Begin DoDot:3
+64 IF $EXTRACT(IOST,1,2)="C-"
SET DIR(0)="E"
KILL DIRUT
DO ^DIR
KILL DIR
if $DATA(DIRUT)
QUIT
+65 DO CSRPRTH2^RCTCSP1A
+66 QUIT
End DoDot:3
+67 QUIT
End DoDot:2
if $DATA(DIRUT)
QUIT
+68 QUIT
End DoDot:1
+69 ;
+70 IF RCSORT=3
Begin DoDot:1
+71 DO CSRPRTH3^RCTCSP1A
+72 SET (DATE,DTFRM)=$$FMADD^XLFDT(+$PIECE(DTFRMTO,U,2),-1)
SET DTTO=$PIECE(DTFRMTO,U,3)
+73 SET RCIEN=""
FOR
SET RCIEN=$ORDER(^PRCA(430,"TCSP",RCIEN))
if RCIEN=""
QUIT
Begin DoDot:2
+74 ;cross servicing data fields
if '$DATA(^PRCA(430,RCIEN,15))
QUIT
+75 if $PIECE(^PRCA(430,RCIEN,15),U)<DTFRM!($PIECE(^PRCA(430,RCIEN,15),U)>DTTO)
QUIT
+76 ;PRCA*4.5*433 Added field 2
KILL LIST,MSG,RCLIST
DO GETS^DIQ(430,RCIEN_",",".01;2;9;121,141,161;169;151;11","IE","LIST","MSG")
SET RCLIST=$NAME(LIST(430,RCIEN_","))
+77 ;Q:$G(@RCLIST@(121,"E"))'="" ;Date sent to DMC
+78 ;Q:$G(@RCLIST@(141,"E"))'="" ;Date sent to TOP
+79 ;S SSN=$E($$SSN^RCFN01(@RCLIST@(9,"I")),6,9) S SSN=$S(SSN'="":SSN,1:" "),TERMDIG=$E(@RCLIST@(9,"E"),1)_SSN
+80 ;PRCA*4.5*433
SET SSN=$EXTRACT($$SSN^RCFN01(@RCLIST@(9,"I")),6,9)
SET SSN=$SELECT(SSN'="":SSN,1:" ")
+81 ;PRCA*4.5*433
IF SSN
SET TERMDIG=$EXTRACT(@RCLIST@(9,"E"),1)_SSN
+82 ;PRCA*4.5*433
IF 'SSN
SET TERMDIG=SSN
+83 ;PRCA*4.5*433
IF EXCEL
SET ^TMP("RCTCSP1",$JOB,@RCLIST@(151,"I"),RCIEN)=$$FMTE^XLFDT(@RCLIST@(151,"I"),"2Z")_U_$EXTRACT(@RCLIST@(2,"E"),1,10)_U_$EXTRACT(@RCLIST@(9,"E"),1,19)_U_@RCLIST@(.01,"E")_U_TERMDIG_U_$JUSTIFY(@RCLIST@(169,"E"),8,2)_U_$JUSTI
FY(@RCLIST@(11,"E"),8,2)
+84 ;PRCA*4.5*433
IF 'EXCEL
Begin DoDot:3
+85 ;PRCA*4.5*433
SET ^TMP("RCTCSP1",$JOB,@RCLIST@(151,"I"),RCIEN)=$$FMTE^XLFDT(@RCLIST@(151,"I"),"2Z")_U_$EXTRACT(@RCLIST@(2,"E"),1,10)_U_$EXTRACT(@RCLIST@(9,"E"),1,19)_U_@RCLIST@(.01,"E")_U_TERMDIG_U_$JUSTIFY(@RCLIST@(169,"E"),8,2)_U_$J
USTIFY(@RCLIST@(11,"E"),8,2)
End DoDot:3
End DoDot:2
+86 ;
+87 ; print report for sort 3
+88 SET (SDT,NCIEN)=""
FOR
SET SDT=$ORDER(^TMP("RCTCSP1",$JOB,SDT))
if SDT=""!$DATA(DIRUT)
QUIT
FOR
SET NCIEN=$ORDER(^TMP("RCTCSP1",$JOB,SDT,NCIEN))
if NCIEN=""!$DATA(DIRUT)
QUIT
Begin DoDot:2
+89 ;PRCA*4.5*433
IF EXCEL
WRITE !,$PIECE(^TMP("RCTCSP1",$JOB,SDT,NCIEN),U)_U_$PIECE(^TMP("RCTCSP1",$JOB,SDT,NCIEN),U,2)_U_$PIECE(^TMP("RCTCSP1",$JOB,SDT,NCIEN),U,3)_U_$PIECE(^TMP("RCTCSP1",$JOB,SDT,NCIEN),U,4)
+90 ;PRCA*4.5*433
IF EXCEL
WRITE U_$PIECE(^TMP("RCTCSP1",$JOB,SDT,NCIEN),U,5)_U_$PIECE(^TMP("RCTCSP1",$JOB,SDT,NCIEN),U,6)_U_$PIECE(^TMP("RCTCSP1",$JOB,SDT,NCIEN),U,7)
+91 IF EXCEL
QUIT
+92 ; non-Excel output
+93 ;PRCA*4.5*433
WRITE !,$PIECE(^TMP("RCTCSP1",$JOB,SDT,NCIEN),U),?13,$PIECE(^TMP("RCTCSP1",$JOB,SDT,NCIEN),U,2),?25,$PIECE(^TMP("RCTCSP1",$JOB,SDT,NCIEN),U,3),?47
+94 ;PRCA*4.5*433
WRITE $PIECE(^TMP("RCTCSP1",$JOB,SDT,NCIEN),U,4),?60,$PIECE(^TMP("RCTCSP1",$JOB,SDT,NCIEN),U,5),?68,$PIECE(^TMP("RCTCSP1",$JOB,SDT,NCIEN),U,6),?80,$PIECE(^TMP("RCTCSP1",$JOB,SDT,NCIEN),U,7)
+95 ; page break check
+96 IF ($Y+3)>IOSL
Begin DoDot:3
+97 IF $EXTRACT(IOST,1,2)="C-"
SET DIR(0)="E"
KILL DIRUT
DO ^DIR
KILL DIR
if $DATA(DIRUT)
QUIT
+98 DO CSRPRTH3^RCTCSP1A
+99 QUIT
End DoDot:3
+100 QUIT
End DoDot:2
if $DATA(DIRUT)
QUIT
+101 QUIT
End DoDot:1
+102 ;
+103 ;end of report
+104 IF $EXTRACT(IOST,1,2)="C-"
IF '$DATA(DIRUT)
READ !!,"END OF REPORT...PRESS RETURN TO CONTINUE",X:DTIME
WRITE @IOF
+105 ;
+106 ; kill scratch
KILL ^TMP("RCTCSP1",$JOB)
+107 ; close device
DO ^%ZISC
+108 ; purge the task
IF $DATA(ZTQUEUED)
SET ZTREQ="@"
+109 QUIT
+110 ;
REC5B ;Create record 5B for Treasury
+1 ;
+2 ;PRCA*4.5*433 Functinality of tag REC5B moved routine RCTCSP1A for SACC size compliance
DO REC5B^RCTCSP1A
+3 ;
DATE8(X) ;changes fileman date into 8 digit date yyyymmdd
+1 IF +X
SET X=X+17000000
+2 SET X=$EXTRACT(X,1,8)
+3 QUIT X
+4 ;
AMOUNT(X,TT) ;changes amount to zero filled, right justified
+1 ;Zeroes are positive
+2 ;Increase adjustment are positive (TT=73,74)
+3 ;All other tranactions are negative (reduce bill balance)
+4 SET X=$TRANSLATE($JUSTIFY(X,0,2),".")
+5 SET X=$EXTRACT($SELECT(+X=0:0,TT=73!(TT=74):0,1:"-")_"00000000000",1,14-$LENGTH(X))_X
+6 QUIT X
+7 ;
BLANK(X) ;returns 'x' blank spaces
+1 NEW BLANK
+2 SET BLANK=""
SET $PIECE(BLANK," ",X+1)=""
+3 QUIT BLANK
+4 ;
RJZF(X,Y) ;right justify zero fill width Y
+1 SET X=$EXTRACT("000000000000",1,Y-$LENGTH(X))_X
+2 QUIT X
+3 ;
LJSF(X,Y) ;left justified space filled
+1 SET X=$EXTRACT(X,1,Y)
+2 SET X=X_$$BLANK(Y-$LENGTH(X))
+3 QUIT X
+4 ;
TAXID(DEBTOR) ;computes TAXID to place on documents
+1 NEW TAXID,DIC,DA,DR,DIQ
+2 SET TAXID=$$SSN^RCFN01(DEBTOR)
+3 SET TAXID=$$LJSF(TAXID,9)
+4 QUIT TAXID
+5 ;
ADDR(RCDFN,RCCSW) ; returns patient file address
+1 NEW DFN,ADDRCS,STATEIEN,STATEAB,VAPA,ADDR340,PRCAYY,PRCAPHON
+2 SET DFN=RCDFN
+3 DO ADD^VADPT
+4 SET STATEIEN=+VAPA(5)
SET STATEAB=$$GET1^DIQ(5,STATEIEN,1)
+5 SET ADDRCS=VAPA(1)_U_VAPA(2)_U_VAPA(4)_U_STATEAB_U_VAPA(6)_U_VAPA(8)_U_+VAPA(25)
+6 ;PRCA*4.5*336
SET ADDR340=$PIECE($$DADD^RCAMADD(DEBTOR,,RCCSW),U,1,8)
+7 ;PRCA*4.5*331/336
IF $PIECE(ADDRCS,U,7)>2
SET $PIECE(ADDR340,U,6)=" "
+8 ;PRCA*4.5*331
SET ADDR340=$PIECE(ADDR340,U,1,2)_"^"_$PIECE(ADDR340,U,4,7)_U_$SELECT($PIECE(ADDRCS,U,7)'="":$PIECE(ADDRCS,U,7),1:1)
+9 ;PRCA*4.5*331
IF $PIECE(ADDR340,U,7)=""
SET $PIECE(ADDR340,U,7)=$PIECE(ADDRCS,U,7)
+10 ;PRCA*4.5*331/336
IF $PIECE(ADDR340,U,7)>2
SET $PIECE(ADDR340,U,4)=" "
+11 SET PRCAYY=""
SET PRCAPHON=$PIECE(ADDR340,U,6)
FOR I=1:1:$LENGTH(PRCAPHON)
IF $EXTRACT(PRCAPHON,I)?1N
SET PRCAYY=PRCAYY_$EXTRACT($PIECE(ADDR340,U,6),I)
+12 ;PRCA*4.5*336/PRCA*4.5*343
SET PRCAPHON=PRCAYY
IF $LENGTH(PRCAPHON)'=10!(+PRCAPHON=0)
SET VAPA(8)=" "
SET $PIECE(ADDR340,U,6)=" "
+13 SET ADDRCS=ADDR340
+14 QUIT ADDRCS
+15 ;
DEM(RCDFN) ; returns patient file information
+1 NEW DFN,VADM
+2 SET DFN=RCDFN
+3 DO DEM^VADPT
+4 ; return string sex:m/f ^ dob: yyyymmdd ^ ssn ^ deceased ^ Debtor Name
+5 QUIT $PIECE(VADM(5),U,1)_U_$PIECE(VADM(3),U,1)_U_$PIECE(VADM(2),U,1)_U_VADM(6)
