RCTCSP1 ;ALBANY/BDB-CROSS-SERVICING TRANSMISSION ;03/15/14 3:34 PM
;;4.5;Accounts Receivable;**301,331,315,339,341,336,350,343**;Mar 20, 1995;Build 59
;;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.
;
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
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,DASH,TMP,I,DATE,DTFRM,DTTO,DATDATE
K ^TMP("RCTCSP1",$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,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 $J($P(B16,U,9),8,2)
..S BAMT=^TMP("RCTCSP1",$J,DEBTOR,BILL)
..I 'EXCEL W ?25
..I EXCEL W U
..W $J(BAMT,8,2)
..I 'EXCEL W $J($P(B7,U,1),9,2),$J($P(B7,U,2),7,2),$J($P(B7,U,3),8,2),$J($P(B7,U,4),8,2) ;(as per PRCA*4.5*315)
..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 ?67,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),?22,"SSN: ",RCSSN,?45,"CURRENT CS DEBT: ",$J(TAMT,8,2),!,DASH
. W !,"BILL NO.",?12,"ST",?15,"ORIG AMT",?25,"CURR AMT",?38,"PRIN",?46,"INT",?52,"ADMIN",?60,"COURT",?67,"CS REF DT" ;(as per PRCA*4.5*315)
. W !,"---- ---",?12,"--",?15,"---- ---",?25,"---- ---",?38,"----",?46,"---",?52,"-----",?60,"-----",?67,"-- -------"
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_"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,"-",81)=""
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
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;9;121,141,161;169;151;11","IE","LIST","MSG") S RCLIST=$NA(LIST(430,RCIEN_","))
..;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
..I EXCEL D Q
...S ^TMP("RCTCSP1",$J,RCIEN,@RCLIST@(.01,"E"))=@RCLIST@(.01,"E")_U_$E(@RCLIST@(9,"E"),1,19)_U_TERMDIG_U_$J(@RCLIST@(169,"E"),8,2)_U_$$FMTE^XLFDT(@RCLIST@(151,"I"),"2Z")
...S ^TMP("RCTCSP1",$J,RCIEN,@RCLIST@(.01,"E"))=^TMP("RCTCSP1",$J,RCIEN,@RCLIST@(.01,"E"))_U_$J(@RCLIST@(11,"E"),8,2)
...Q
..S ^TMP("RCTCSP1",$J,RCIEN,@RCLIST@(.01,"E"))=@RCLIST@(.01,"E")_U_$E(@RCLIST@(9,"E"),1,19)_U_SSN_U_$J(@RCLIST@(169,"E"),8,2)_U_$$FMTE^XLFDT(@RCLIST@(151,"I"),"2Z")
..S ^TMP("RCTCSP1",$J,RCIEN,@RCLIST@(.01,"E"))=^TMP("RCTCSP1",$J,RCIEN,@RCLIST@(.01,"E"))_U_$J(@RCLIST@(11,"E"),8,2)
.;
.; 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)
..I EXCEL Q
..; non-Excel output
..W !,$P(^TMP("RCTCSP1",$J,NCIEN,ITEM),U),?14,$P(^TMP("RCTCSP1",$J,NCIEN,ITEM),U,2),?35,$P(^TMP("RCTCSP1",$J,NCIEN,ITEM),U,3),?43
..W $P(^TMP("RCTCSP1",$J,NCIEN,ITEM),U,4),?58,$P(^TMP("RCTCSP1",$J,NCIEN,ITEM),U,5),?68,$P(^TMP("RCTCSP1",$J,NCIEN,ITEM),U,6)
..; 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;9;121,141,161;169;151;11","IE","LIST","MSG") S RCLIST=$NA(LIST(430,RCIEN_","))
..;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
..I EXCEL D Q
...S ^TMP("RCTCSP1",$J,@RCLIST@(9,"E"),RCIEN)=$E(@RCLIST@(9,"E"),1,19)_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
..S ^TMP("RCTCSP1",$J,@RCLIST@(9,"E"),RCIEN)=$E(@RCLIST@(9,"E"),1,19)_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)
.;
.; 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)
..I EXCEL Q
..; non-Excel output
..W !,$P(^TMP("RCTCSP1",$J,DBTR,NCIEN),U),?21,$P(^TMP("RCTCSP1",$J,DBTR,NCIEN),U,2),?35,$P(^TMP("RCTCSP1",$J,DBTR,NCIEN),U,3),?43,$P(^TMP("RCTCSP1",$J,DBTR,NCIEN),U,4)
..W ?58,$P(^TMP("RCTCSP1",$J,DBTR,NCIEN),U,5),?68,$P(^TMP("RCTCSP1",$J,DBTR,NCIEN),U,6)
..; 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;9;121,141,161;169;151;11","IE","LIST","MSG") S RCLIST=$NA(LIST(430,RCIEN_","))
..;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
..I EXCEL S ^TMP("RCTCSP1",$J,@RCLIST@(151,"I"),RCIEN)=$$FMTE^XLFDT(@RCLIST@(151,"I"),"2Z")_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)
..I 'EXCEL S ^TMP("RCTCSP1",$J,@RCLIST@(151,"I"),RCIEN)=$$FMTE^XLFDT(@RCLIST@(151,"I"),"2Z")_U_$E(@RCLIST@(9,"E"),1,19)_U_@RCLIST@(.01,"E")_U_SSN_U_$J(@RCLIST@(169,"E"),8,2)_U_$J(@RCLIST@(11,"E"),8,2)
.;
.; 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)
..I EXCEL W U_$P(^TMP("RCTCSP1",$J,SDT,NCIEN),U,5)_U_$P(^TMP("RCTCSP1",$J,SDT,NCIEN),U,6)
..I EXCEL Q
..; non-Excel output
..W !,$P(^TMP("RCTCSP1",$J,SDT,NCIEN),U),?12,$P(^TMP("RCTCSP1",$J,SDT,NCIEN),U,2),?34,$P(^TMP("RCTCSP1",$J,SDT,NCIEN),U,3),?49
..W $P(^TMP("RCTCSP1",$J,SDT,NCIEN),U,4),?58,$P(^TMP("RCTCSP1",$J,SDT,NCIEN),U,5),?68,$P(^TMP("RCTCSP1",$J,SDT,NCIEN),U,6)
..; 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
; trnnum transaction number file #433 pass in
; trntyp transaction type pointer to 430.3
; trntypa aia transaction type (aio: dmc agency internal offset, abal: decrease adjustment)
N REC,KNUM,DEBTNR,DEBTORNB,TAMOUNT,TAMTPBAL,TAMTIBAL,TAMTABAL,TAMTFBAL,TAMTCBAL,AMTRFRRD,TRNTYP,TRNTYPA,TRANSNB
N AMTPBAL,AMTIBAL,AMTABAL,AMTFBAL,AMTCBAL,TRN3,TRNNUME
S TRNTYPA="AIO"
S REC="C5B"_ACTION_"3636001200"_"DM1D "_"L"
S KNUM=$P($P(B0,U,1),"-",2)
;S DEBTNR=$E(SITE,1,3)_$$RJZF(KNUM,7)_$TR($J(BILL,20)," ",0),REC=REC_DEBTNR
S DEBTNR=$$AGDEBTID^RCTCSPD,REC=REC_DEBTNR ; PRCA*4.5*350
S DEBTORNB=$E(SITE,1,3)_$TR($J(DEBTOR,12)," ",0)
S REC=REC_DEBTORNB
S TRNTYP=$P($G(^PRCA(433,TRNNUM,1)),U,2) I ",35,73,74,"[TRNTYP S TRNTYPA="ABAL"
S REC=REC_$$LJSF(TRNTYPA,9)
S TRNNUME=$$RJZF(TRNNUM,10)
S TRNNUME=$E(TRNNUME,5,10) ;max is 999999
I TRNNUME="000000" S TRNNUME="000001" ;min is 1
S REC=REC_$$RJZF(TRNNUME,10)
S REC=REC_$$DATE8(DT)
S TRANSNB=$E(SITE,1,3)_$TR($J(TRNNUM,12)," ",0)
S REC=REC_TRANSNB
S REC=REC_$$BLANK(9)
S TRN3=$G(^PRCA(433,TRNNUM,3))
S TAMTPBAL=$P(TRN3,U,1) ;transaction principle balance
S TAMTIBAL=$P(TRN3,U,2) ;transaction interest balance
S TAMTABAL=$P(TRN3,U,3) ;transaction administrative balance
S TAMTFBAL=$P(TRN3,U,4) ;transaction marshal fee
S TAMTCBAL=$P(TRN3,U,5) ;transaction court cost
I (TAMTPBAL+TAMTIBAL+TAMTABAL+TAMTFBAL+TAMTCBAL)=0 S TAMTPBAL=TRNAMT
S TAMOUNT=$$AMOUNT(TAMTPBAL,TRNTYP)
S TAMOUNT=TAMOUNT_$$AMOUNT(TAMTIBAL,TRNTYP)
S TAMOUNT=TAMOUNT_$$AMOUNT(TAMTABAL,TRNTYP)
S TAMOUNT=TAMOUNT_$$AMOUNT(TAMTFBAL+TAMTCBAL,TRNTYP)
S REC=REC_TAMOUNT
S REC=REC_$$AMOUNT(TRNAMT,TRNTYP)
S REC=REC_$$BLANK(450-$L(REC))
S AMTPBAL=$P(B7,U,1) ;principle balance
S AMTIBAL=$P(B7,U,2) ;interest balance
S AMTABAL=$P(B7,U,3) ;administrative balance
S AMTFBAL=$P(B7,U,4) ;marshal fee
S AMTCBAL=$P(B7,U,5) ;court cost
S AMTRFRRD=AMTPBAL+AMTIBAL+AMTABAL+AMTFBAL+AMTCBAL
I ACTION="U" S $P(^PRCA(430,BILL,16),U,10)=AMTRFRRD
S ^XTMP("RCTCSPD",$J,BILL,ACTION,"5B",TRNNUM)=REC
S ^XTMP("RCTCSPD",$J,"BILL",ACTION,BILL)=$$TAXID(DEBTOR)_"^"_$S(TRNTYP=73!(TRNTYP=74):"",1:"-")_+$E(REC,174,184)_"."_$E(REC,185,186)
Q
;
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 gender and dob
N DFN,VADM
S DFN=RCDFN
D DEM^VADPT
; return string sex:m/f ^ dob: yyyymmdd ^ ssn ^ deceased
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 16987 printed Apr 09, 2024@20:46:35 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**;Mar 20, 1995;Build 59
+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 QUIT
+21 ;
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 ;PRC*4.5*336
KILL IOP,IO("Q")
SET %ZIS="MQ"
SET %ZIS("B")=""
DO ^%ZIS
if POP
GOTO BILLREPQ
+10 IF $DATA(IO("Q"))
Begin DoDot:1
+11 SET ZTSAVE("DEBTOR")=""
SET ZTSAVE("DTFRMTO")=""
SET ZTSAVE("EXCEL")=""
+12 SET ZTRTN="BILLREPP^RCTCSP1"
SET ZTDESC="CROSS-SERVICING BILL REPORT"
+13 DO ^%ZTLOAD
DO HOME^%ZIS
+14 IF $GET(ZTSK)
WRITE !!,"Report compilation has started with task# ",ZTSK,".",!
SET DIR(0)="E"
DO ^DIR
KILL DIR
+15 QUIT
End DoDot:1
GOTO BILLREPQ
+16 ;
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,DASH,TMP,I,DATE,DTFRM,DTTO,DATDATE
+3 KILL ^TMP("RCTCSP1",$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,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 WRITE $JUSTIFY($PIECE(B16,U,9),8,2)
+26 SET BAMT=^TMP("RCTCSP1",$JOB,DEBTOR,BILL)
+27 IF 'EXCEL
WRITE ?25
+28 IF EXCEL
WRITE U
+29 WRITE $JUSTIFY(BAMT,8,2)
+30 ;(as per PRCA*4.5*315)
IF 'EXCEL
WRITE $JUSTIFY($PIECE(B7,U,1),9,2),$JUSTIFY($PIECE(B7,U,2),7,2),$JUSTIFY($PIECE(B7,U,3),8,2),$JUSTIFY($PIECE(B7,U,4),8,2)
+31 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)
+32 ;Format date to n/n/nn (as per PRCA*4.5*315)
SET TMP=$$FMTE^XLFDT($PIECE(B15,U,1),"2Z")
+33 ;$P(TMP,", ",1)_","_$P(TMP,", ",2) ;
IF 'EXCEL
WRITE ?67,TMP
+34 IF EXCEL
WRITE U_TMP
+35 ;check for end of page here, if necessary form feed and print header
+36 IF ($Y+3)>IOSL
Begin DoDot:3
+37 IF $EXTRACT(IOST,1,2)="C-"
SET DIR(0)="E"
KILL DIRUT
DO ^DIR
if $DATA(DIRUT)
QUIT
+38 DO BILLREPH
End DoDot:3
End DoDot:2
End DoDot:1
+39 IF $EXTRACT(IOST,1,2)="C-"
READ !!,"END OF REPORT...PRESS RETURN TO CONTINUE",X:DTIME
WRITE @IOF
+40 DO ^%ZISC
+41 if $DATA(ZTQUEUED)
SET ZTREQ="@"
+42 KILL ^TMP("RCTCSP1",$JOB)
+43 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),?22,"SSN: ",RCSSN,?45,"CURRENT CS DEBT: ",$JUSTIFY(TAMT,8,2),!,DASH
+9 ;(as per PRCA*4.5*315)
WRITE !,"BILL NO.",?12,"ST",?15,"ORIG AMT",?25,"CURR AMT",?38,"PRIN",?46,"INT",?52,"ADMIN",?60,"COURT",?67,"CS REF DT"
+10 WRITE !,"---- ---",?12,"--",?15,"---- ---",?25,"---- ---",?38,"----",?46,"---",?52,"-----",?60,"-----",?67,"-- -------"
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_"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,"-",81)=""
+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 ;PRC*4.5*336
KILL IOP,IO("Q")
SET %ZIS="MQ"
SET %ZIS("B")=""
DO ^%ZIS
if POP
QUIT
+15 IF $DATA(IO("Q"))
Begin DoDot:1
+16 SET ZTSAVE("RCSORT")=""
SET ZTSAVE("DTFRMTO")=""
SET ZTSAVE("EXCEL")=""
SET ZTSAVE("PROMPT")=""
SET ZTSAVE("PAGE")=""
SET ZTSAVE("DASH")=""
+17 SET ZTRTN="CSRPRTR^RCTCSP1"
SET ZTDESC="PRINT CROSS-SERVICING REPORT"
+18 DO ^%ZTLOAD
DO HOME^%ZIS
+19 IF $GET(ZTSK)
WRITE !!,"Report compilation has started with task# ",ZTSK,".",!
SET DIR(0)="E"
DO ^DIR
KILL DIR
+20 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 KILL LIST,MSG,RCLIST
DO GETS^DIQ(430,RCIEN_",",".01;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 SET SSN=$EXTRACT($$SSN^RCFN01(@RCLIST@(9,"I")),6,9)
SET SSN=$SELECT(SSN'="":SSN,1:" ")
SET TERMDIG=$EXTRACT(@RCLIST@(9,"E"),1)_SSN
+13 IF EXCEL
Begin DoDot:3
+14 SET ^TMP("RCTCSP1",$JOB,RCIEN,@RCLIST@(.01,"E"))=@RCLIST@(.01,"E")_U_$EXTRACT(@RCLIST@(9,"E"),1,19)_U_TERMDIG_U_$JUSTIFY(@RCLIST@(169,"E"),8,2)_U_$$FMTE^XLFDT(@RCLIST@(151,"I"),"2Z")
+15 SET ^TMP("RCTCSP1",$JOB,RCIEN,@RCLIST@(.01,"E"))=^TMP("RCTCSP1",$JOB,RCIEN,@RCLIST@(.01,"E"))_U_$JUSTIFY(@RCLIST@(11,"E"),8,2)
+16 QUIT
End DoDot:3
QUIT
+17 SET ^TMP("RCTCSP1",$JOB,RCIEN,@RCLIST@(.01,"E"))=@RCLIST@(.01,"E")_U_$EXTRACT(@RCLIST@(9,"E"),1,19)_U_SSN_U_$JUSTIFY(@RCLIST@(169,"E"),8,2)_U_$$FMTE^XLFDT(@RCLIST@(151,"I"),"2Z")
+18 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
+19 ;
+20 ; print report for sort 1
+21 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
+22 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)
+23 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)
+24 IF EXCEL
QUIT
+25 ; non-Excel output
+26 WRITE !,$PIECE(^TMP("RCTCSP1",$JOB,NCIEN,ITEM),U),?14,$PIECE(^TMP("RCTCSP1",$JOB,NCIEN,ITEM),U,2),?35,$PIECE(^TMP("RCTCSP1",$JOB,NCIEN,ITEM),U,3),?43
+27 WRITE $PIECE(^TMP("RCTCSP1",$JOB,NCIEN,ITEM),U,4),?58,$PIECE(^TMP("RCTCSP1",$JOB,NCIEN,ITEM),U,5),?68,$PIECE(^TMP("RCTCSP1",$JOB,NCIEN,ITEM),U,6)
+28 ; page break check
+29 IF ($Y+3)>IOSL
Begin DoDot:3
+30 IF $EXTRACT(IOST,1,2)="C-"
SET DIR(0)="E"
KILL DIRUT
DO ^DIR
KILL DIR
if $DATA(DIRUT)
QUIT
+31 DO CSRPRTH1^RCTCSP1A
+32 QUIT
End DoDot:3
+33 QUIT
End DoDot:2
if $DATA(DIRUT)
QUIT
+34 QUIT
End DoDot:1
+35 ;
+36 IF RCSORT=2
Begin DoDot:1
+37 DO CSRPRTH2^RCTCSP1A
+38 SET (DATE,DTFRM)=$$FMADD^XLFDT(+$PIECE(DTFRMTO,U,2),-1)
SET DTTO=$PIECE(DTFRMTO,U,3)
+39 SET RCIEN=""
FOR
SET RCIEN=$ORDER(^PRCA(430,"TCSP",RCIEN))
if RCIEN=""
QUIT
Begin DoDot:2
+40 ;cross servicing data fields
if '$DATA(^PRCA(430,RCIEN,15))
QUIT
+41 if $PIECE($GET(^PRCA(430,RCIEN,15)),U)<DTFRM!($PIECE($GET(^PRCA(430,RCIEN,15)),U)>DTTO)
QUIT
+42 KILL LIST,MSG,RCLIST
DO GETS^DIQ(430,RCIEN_",",".01;9;121,141,161;169;151;11","IE","LIST","MSG")
SET RCLIST=$NAME(LIST(430,RCIEN_","))
+43 ;Q:$G(@RCLIST@(121,"E"))'="" ;Date sent to DMC
+44 ;Q:$G(@RCLIST@(141,"E"))'="" ;Date sent to TOP
+45 SET SSN=$EXTRACT($$SSN^RCFN01(@RCLIST@(9,"I")),6,9)
SET SSN=$SELECT(SSN'="":SSN,1:" ")
SET TERMDIG=$EXTRACT(@RCLIST@(9,"E"),1)_SSN
+46 IF EXCEL
Begin DoDot:3
+47 SET ^TMP("RCTCSP1",$JOB,@RCLIST@(9,"E"),RCIEN)=$EXTRACT(@RCLIST@(9,"E"),1,19)_U_@RCLIST@(.01,"E")_U_TERMDIG_U_$JUSTIFY(@RCLIST@(169,"E"),8,2)_U_$$FMTE^XLFDT(@RCLIST@(151,"I"),"2Z")_U_$JUSTIFY(@RCLIST@(11,"E"),8,2)
QUIT
End DoDot:3
QUIT
+48 SET ^TMP("RCTCSP1",$JOB,@RCLIST@(9,"E"),RCIEN)=$EXTRACT(@RCLIST@(9,"E"),1,19)_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
+49 ;
+50 ; print report for sort 2
+51 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
+52 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)
+53 IF EXCEL
QUIT
+54 ; non-Excel output
+55 WRITE !,$PIECE(^TMP("RCTCSP1",$JOB,DBTR,NCIEN),U),?21,$PIECE(^TMP("RCTCSP1",$JOB,DBTR,NCIEN),U,2),?35,$PIECE(^TMP("RCTCSP1",$JOB,DBTR,NCIEN),U,3),?43,$PIECE(^TMP("RCTCSP1",$JOB,DBTR,NCIEN),U,4)
+56 WRITE ?58,$PIECE(^TMP("RCTCSP1",$JOB,DBTR,NCIEN),U,5),?68,$PIECE(^TMP("RCTCSP1",$JOB,DBTR,NCIEN),U,6)
+57 ; page break check
+58 IF ($Y+3)>IOSL
Begin DoDot:3
+59 IF $EXTRACT(IOST,1,2)="C-"
SET DIR(0)="E"
KILL DIRUT
DO ^DIR
KILL DIR
if $DATA(DIRUT)
QUIT
+60 DO CSRPRTH2^RCTCSP1A
+61 QUIT
End DoDot:3
+62 QUIT
End DoDot:2
if $DATA(DIRUT)
QUIT
+63 QUIT
End DoDot:1
+64 ;
+65 IF RCSORT=3
Begin DoDot:1
+66 DO CSRPRTH3^RCTCSP1A
+67 SET (DATE,DTFRM)=$$FMADD^XLFDT(+$PIECE(DTFRMTO,U,2),-1)
SET DTTO=$PIECE(DTFRMTO,U,3)
+68 SET RCIEN=""
FOR
SET RCIEN=$ORDER(^PRCA(430,"TCSP",RCIEN))
if RCIEN=""
QUIT
Begin DoDot:2
+69 ;cross servicing data fields
if '$DATA(^PRCA(430,RCIEN,15))
QUIT
+70 if $PIECE(^PRCA(430,RCIEN,15),U)<DTFRM!($PIECE(^PRCA(430,RCIEN,15),U)>DTTO)
QUIT
+71 KILL LIST,MSG,RCLIST
DO GETS^DIQ(430,RCIEN_",",".01;9;121,141,161;169;151;11","IE","LIST","MSG")
SET RCLIST=$NAME(LIST(430,RCIEN_","))
+72 ;Q:$G(@RCLIST@(121,"E"))'="" ;Date sent to DMC
+73 ;Q:$G(@RCLIST@(141,"E"))'="" ;Date sent to TOP
+74 SET SSN=$EXTRACT($$SSN^RCFN01(@RCLIST@(9,"I")),6,9)
SET SSN=$SELECT(SSN'="":SSN,1:" ")
SET TERMDIG=$EXTRACT(@RCLIST@(9,"E"),1)_SSN
+75 IF EXCEL
SET ^TMP("RCTCSP1",$JOB,@RCLIST@(151,"I"),RCIEN)=$$FMTE^XLFDT(@RCLIST@(151,"I"),"2Z")_U_$EXTRACT(@RCLIST@(9,"E"),1,19)_U_@RCLIST@(.01,"E")_U_TERMDIG_U_$JUSTIFY(@RCLIST@(169,"E"),8,2)_U_$JUSTIFY(@RCLIST@(11,"E"),8,2)
+76 IF 'EXCEL
SET ^TMP("RCTCSP1",$JOB,@RCLIST@(151,"I"),RCIEN)=$$FMTE^XLFDT(@RCLIST@(151,"I"),"2Z")_U_$EXTRACT(@RCLIST@(9,"E"),1,19)_U_@RCLIST@(.01,"E")_U_SSN_U_$JUSTIFY(@RCLIST@(169,"E"),8,2)_U_$JUSTIFY(@RCLIST@(11,"E"),8,2)
End DoDot:2
+77 ;
+78 ; print report for sort 3
+79 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
+80 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)
+81 IF EXCEL
WRITE U_$PIECE(^TMP("RCTCSP1",$JOB,SDT,NCIEN),U,5)_U_$PIECE(^TMP("RCTCSP1",$JOB,SDT,NCIEN),U,6)
+82 IF EXCEL
QUIT
+83 ; non-Excel output
+84 WRITE !,$PIECE(^TMP("RCTCSP1",$JOB,SDT,NCIEN),U),?12,$PIECE(^TMP("RCTCSP1",$JOB,SDT,NCIEN),U,2),?34,$PIECE(^TMP("RCTCSP1",$JOB,SDT,NCIEN),U,3),?49
+85 WRITE $PIECE(^TMP("RCTCSP1",$JOB,SDT,NCIEN),U,4),?58,$PIECE(^TMP("RCTCSP1",$JOB,SDT,NCIEN),U,5),?68,$PIECE(^TMP("RCTCSP1",$JOB,SDT,NCIEN),U,6)
+86 ; page break check
+87 IF ($Y+3)>IOSL
Begin DoDot:3
+88 IF $EXTRACT(IOST,1,2)="C-"
SET DIR(0)="E"
KILL DIRUT
DO ^DIR
KILL DIR
if $DATA(DIRUT)
QUIT
+89 DO CSRPRTH3^RCTCSP1A
+90 QUIT
End DoDot:3
+91 QUIT
End DoDot:2
if $DATA(DIRUT)
QUIT
+92 QUIT
End DoDot:1
+93 ;
+94 ;end of report
+95 IF $EXTRACT(IOST,1,2)="C-"
IF '$DATA(DIRUT)
READ !!,"END OF REPORT...PRESS RETURN TO CONTINUE",X:DTIME
WRITE @IOF
+96 ;
+97 ; kill scratch
KILL ^TMP("RCTCSP1",$JOB)
+98 ; close device
DO ^%ZISC
+99 ; purge the task
IF $DATA(ZTQUEUED)
SET ZTREQ="@"
+100 QUIT
+101 ;
REC5B ;Create record 5B for Treasury
+1 ; trnnum transaction number file #433 pass in
+2 ; trntyp transaction type pointer to 430.3
+3 ; trntypa aia transaction type (aio: dmc agency internal offset, abal: decrease adjustment)
+4 NEW REC,KNUM,DEBTNR,DEBTORNB,TAMOUNT,TAMTPBAL,TAMTIBAL,TAMTABAL,TAMTFBAL,TAMTCBAL,AMTRFRRD,TRNTYP,TRNTYPA,TRANSNB
+5 NEW AMTPBAL,AMTIBAL,AMTABAL,AMTFBAL,AMTCBAL,TRN3,TRNNUME
+6 SET TRNTYPA="AIO"
+7 SET REC="C5B"_ACTION_"3636001200"_"DM1D "_"L"
+8 SET KNUM=$PIECE($PIECE(B0,U,1),"-",2)
+9 ;S DEBTNR=$E(SITE,1,3)_$$RJZF(KNUM,7)_$TR($J(BILL,20)," ",0),REC=REC_DEBTNR
+10 ; PRCA*4.5*350
SET DEBTNR=$$AGDEBTID^RCTCSPD
SET REC=REC_DEBTNR
+11 SET DEBTORNB=$EXTRACT(SITE,1,3)_$TRANSLATE($JUSTIFY(DEBTOR,12)," ",0)
+12 SET REC=REC_DEBTORNB
+13 SET TRNTYP=$PIECE($GET(^PRCA(433,TRNNUM,1)),U,2)
IF ",35,73,74,"[TRNTYP
SET TRNTYPA="ABAL"
+14 SET REC=REC_$$LJSF(TRNTYPA,9)
+15 SET TRNNUME=$$RJZF(TRNNUM,10)
+16 ;max is 999999
SET TRNNUME=$EXTRACT(TRNNUME,5,10)
+17 ;min is 1
IF TRNNUME="000000"
SET TRNNUME="000001"
+18 SET REC=REC_$$RJZF(TRNNUME,10)
+19 SET REC=REC_$$DATE8(DT)
+20 SET TRANSNB=$EXTRACT(SITE,1,3)_$TRANSLATE($JUSTIFY(TRNNUM,12)," ",0)
+21 SET REC=REC_TRANSNB
+22 SET REC=REC_$$BLANK(9)
+23 SET TRN3=$GET(^PRCA(433,TRNNUM,3))
+24 ;transaction principle balance
SET TAMTPBAL=$PIECE(TRN3,U,1)
+25 ;transaction interest balance
SET TAMTIBAL=$PIECE(TRN3,U,2)
+26 ;transaction administrative balance
SET TAMTABAL=$PIECE(TRN3,U,3)
+27 ;transaction marshal fee
SET TAMTFBAL=$PIECE(TRN3,U,4)
+28 ;transaction court cost
SET TAMTCBAL=$PIECE(TRN3,U,5)
+29 IF (TAMTPBAL+TAMTIBAL+TAMTABAL+TAMTFBAL+TAMTCBAL)=0
SET TAMTPBAL=TRNAMT
+30 SET TAMOUNT=$$AMOUNT(TAMTPBAL,TRNTYP)
+31 SET TAMOUNT=TAMOUNT_$$AMOUNT(TAMTIBAL,TRNTYP)
+32 SET TAMOUNT=TAMOUNT_$$AMOUNT(TAMTABAL,TRNTYP)
+33 SET TAMOUNT=TAMOUNT_$$AMOUNT(TAMTFBAL+TAMTCBAL,TRNTYP)
+34 SET REC=REC_TAMOUNT
+35 SET REC=REC_$$AMOUNT(TRNAMT,TRNTYP)
+36 SET REC=REC_$$BLANK(450-$LENGTH(REC))
+37 ;principle balance
SET AMTPBAL=$PIECE(B7,U,1)
+38 ;interest balance
SET AMTIBAL=$PIECE(B7,U,2)
+39 ;administrative balance
SET AMTABAL=$PIECE(B7,U,3)
+40 ;marshal fee
SET AMTFBAL=$PIECE(B7,U,4)
+41 ;court cost
SET AMTCBAL=$PIECE(B7,U,5)
+42 SET AMTRFRRD=AMTPBAL+AMTIBAL+AMTABAL+AMTFBAL+AMTCBAL
+43 IF ACTION="U"
SET $PIECE(^PRCA(430,BILL,16),U,10)=AMTRFRRD
+44 SET ^XTMP("RCTCSPD",$JOB,BILL,ACTION,"5B",TRNNUM)=REC
+45 SET ^XTMP("RCTCSPD",$JOB,"BILL",ACTION,BILL)=$$TAXID(DEBTOR)_"^"_$SELECT(TRNTYP=73!(TRNTYP=74):"",1:"-")_+$EXTRACT(REC,174,184)_"."_$EXTRACT(REC,185,186)
+46 QUIT
+47 ;
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 gender and dob
+1 NEW DFN,VADM
+2 SET DFN=RCDFN
+3 DO DEM^VADPT
+4 ; return string sex:m/f ^ dob: yyyymmdd ^ ssn ^ deceased
+5 QUIT $PIECE(VADM(5),U,1)_U_$PIECE(VADM(3),U,1)_U_$PIECE(VADM(2),U,1)_U_VADM(6)
