RCTCSPD ;ALBANY/BDB-CROSS-SERVICING TRANSMISSION ;03/15/14 3:34 PM
;;4.5;Accounts Receivable;**301,327,315,336,338,351,350,343,417**;Mar 20, 1995;Build 30
;;Per VA Directive 6402, this routine should not be modified.
;
;PRCA*4.5*327 a. Add check to insure debtor exists to prevent
; undefined error and set in XTMP work global to
; be reported via 'TCSP' mailgroup.
; b. Added process controls throughout entire batch
; run and message to mail group 'TCSP' batch run
; is complete
; c. Move SETUP/FINISH to new routine RCTCSPD0
; due to SACC size constraints
; d. Move REC2C tag/code to RCTCSP7 to create space
; for debtor undefined logic
;
;PRCA*4.5*336 a. Shift code to handle 5B transactions ahead
; of other processing that could cause a 5B
; record to not be sent in batch run at tag
; $$UPDCHK(BILL), EXCEPT FOR RECALL CHECK.
; b. Ensure address calls to RCTCSP1 include flag
; to handle missing debtor node 1 correctly when
; building address for CS transactions
;
;PRCA*4.5*343 Added check to ensure bill is cross-service status,
; 'active' and bal>25 to send pending tx per node 19.
; Also, add check to ensure a re-established bill is
; NOT ever sent to Treasury.
;
;PRCA*4.5*417 Correct gender update issue caused by patch
; and incidents INC22249334 & INC21601588
;
ENTER ;Entry point from nightly process PRCABJ
N DEBTOR,RC151DT,PRIN,INT,ADMIN,TDEB,TFIL,RCDFN,CNTR,SITE,LN,FN,MN,SITE,F60DT,VADM,PHONE,QUIT,TOTAL,ZIPCODE,FULLNM,RCNT,REPAY,X1,X2,ERROR,ADDR,CAT,BILLDT,CURRTOT,SITECD
N SEQ,CNTLID,PREPDT,X1,X2,X,DELDT,ACTDT,SITE40,PRCATX,PRCAREST,PRCAREFR
D SETUP^RCTCSPD0
S (DEBTOR,RCNT)=0,SEQ=0
RSDEBTOR ;
F S DEBTOR=$O(^PRCA(430,"C",DEBTOR)) Q:DEBTOR'?1N.N D
.D NOW^%DTC S ^XTMP("RCTCSPD",$J,"ZZBDEBTOR")=%_U_DEBTOR
.N X,RCDFN,DEMCS,DOB,GNDR,DEBTOR0,DEBTOR1,DEBTOR3,DEBTOR7,DEBTOR8,BILL,RCTCSCW
.I '$D(^RCD(340,DEBTOR,0)) S ^XTMP("RCTCSPD",$J,"ZZUNDEF",DEBTOR)="" Q
.S RCTCSCW=0,DEBTOR0=^RCD(340,DEBTOR,0),DEBTOR1=$G(^(1)),DEBTOR3=$G(^(3)),DEBTOR7=$G(^(7))
.S RCTCSCW=$$SSCHK^RCTCSP7(DEBTOR) Q:RCTCSCW=1 ;PRCA*4.5*417
.S DEBTOR8=$O(^RCD(340,DEBTOR,8,"A"),-1) I DEBTOR8?1.N S DEBTOR8=$P($G(^RCD(340,DEBTOR,8,DEBTOR8,0)),U)
.S RCDFN=+DEBTOR0
.S DEMCS=$$DEM^RCTCSP1(RCDFN)
.S DOB=$P(DEMCS,U,2)
.S GNDR=$P(DEMCS,U) S:"MF"'[GNDR GNDR="U"
.I $P(DEBTOR7,U,2) D:'+$P(DEBTOR7,U,3) ;send type 2 recall record
..N ACTION,B0,B15,BILL
..S ACTION="L"
..S B0="",B15="",BILL=0
..; The code below is designed to get ONLY one bill #. It is not a bug! As per VA SME contacts.
..F S BILL=$O(^PRCA(430,"C",DEBTOR,BILL)) Q:BILL'?1N.N I $D(^PRCA(430,"TCSP",BILL)) I $P(^PRCA(430,BILL,15),U,7)'=1 S B0=$G(^PRCA(430,BILL,0)),B15=$G(^(15)) Q ;get one bill
..I BILL="" S BILL=0,$P(^RCD(340,DEBTOR,7),U,2,4)="^^",$P(DEBTOR7,U,2,4)="^^" Q ;cs debtor with no cs bill, clear the debtor recall flag, quit
..D REC2
..S $P(^RCD(340,DEBTOR,7),U,3)=DT
..S DEBTOR7=^RCD(340,DEBTOR,7),TAXID=$$TAXID^RCTCSP1(DEBTOR)
..S BILL=0 ;set debtor cross-serviced bills as recalled
..F S BILL=$O(^PRCA(430,"C",DEBTOR,BILL)) Q:BILL'?1N.N D
...D NOW^%DTC S ^XTMP("RCTCSPD",$J,"ZZCRBILL")=%_U_BILL
...I $D(^PRCA(430,"TCSP",BILL)) D Q
....S ^PRCA(430,BILL,15)=U_1_U_DT_U_$P(^PRCA(430,BILL,15),U,4,99)
....S $P(^PRCA(430,BILL,15),U,4)=$P(DEBTOR7,U,4) ;set the recall reason
....S $P(^PRCA(430,BILL,15),U,5)=$$GET1^DIQ(430,BILL,11) ;set the recall amount to the current amount
....K ^PRCA(430,"TCSP",BILL)
....D RCRSD^RCTCSPD4 ; set debtor recall non-financial transaction PRCA*4.5*315
.S (BILL,TOTAL,REPAY)=0
RSBILL .F S BILL=$O(^PRCA(430,"C",DEBTOR,BILL)) Q:BILL'?1N.N D
..I $G(ONEBILL)'="",BILL'=ONEBILL Q ; Test single bill ; PRCA*4.5*350
..D NOW^%DTC S ^XTMP("RCTCSPD",$J,"ZZCTRACKER")=%_U_DEBTOR_U_BILL
..N B0,B4,B6,B7,B9,B12,B121,B14,B15,B16,B19,B20,ACTION,RR
..D TAXID^RCTCSP7(DEBTOR)
..S B0=$G(^PRCA(430,BILL,0)),B4=$G(^(4)),B6=$G(^(6)),B7=$G(^(7)),B9=$G(^(9)),B12=$G(^(12)),B121=$G(^(12.1)),B14=$G(^(14)),B15=$G(^(15)),B16=$G(^(16)),B19=$G(^(19)),B20=$G(^(20))
..S RR=$$RR^RCTCSPU(BILL) ;PRCA*4.5*350
..Q:($P(B6,U,21)\1)<ACTDT ;cs activation date cutoff
..I $D(^PRCA(430,"TCSP",BILL)),$$RCLLCHK^RCTCSP2(BILL) Q ;bill previously sent to TCSP
..I $$UPDCHK(BILL) Q
..Q:B4 ;repayment plan
..; Do we clear stop flag if RR TBD ; PRCA*4.5*350
..I +$P(B15,U,7),RR'=0 Q ;quit if bill is stopped
..Q:+$P(B14,U) ;bill referred to TOP
..Q:$P(DEBTOR1,"^",9)=1 ;quit if debtor address marked unknown
..Q:$E($P(DEMCS,U,3),1,5)="00000" ;quit if the ssn is not valid
..Q:DEBTOR8="S" ;quit if debtor is stopped PRCA*4.5*350
..Q:SITE40="S" ; quit if site is stopped PRCA*4.5*350
..I +$P(B12,U,1) Q ;check date bill sent to dmc
..Q:($P(B121,U,1)="N")!($P(B121,U,1)="P") ;dmc debt valid
..I $P(B6,U,4),($P(B6,U,5)="DOJ") Q
..Q:+$P(DEMCS,U,4) ;deceased patient
..Q:'$P(B0,U,2) ;no category
..S CAT=$P($G(^PRCA(430.2,$P(B0,U,2),0)),U,7)
..Q:'CAT
..;PRCA*4.5*338 - Use RFCHK^RCTOPD to determine if the Category can be referred
..; using the new date based algorithm.
..Q:'$$RFCHK^RCTOPD(CAT,"N",1.03,$P(B6,U,21))
..;end PRCA*4.5*338 ..;dpn checks
..I $P(B20,U,3)=1,(10000+$G(^RC(342,1,"CS")))>DT,'$P(B20,U,4) D DUEPROC^RCTCSP3 Q ;check to send dpn file to aitc
..I $P(B20,U,3)=1,(10000+$G(^RC(342,1,"CS")))>DT,$P(B20,U,4),'$P(B20,U,5) Q ;check for print letter date
..I $P(B20,U,3)=1,(10000+$G(^RC(342,1,"CS")))>DT,$P(B20,U,4),$P(B20,U,5) D I X<60 Q ;check for 60 day wait from print letter date
...N X1,X2
...S X1=DT,X2=$P(B20,U,5) D ^%DTC
...I X'<60 S $P(B20,U,6)=DT,^PRCA(430,BILL,20)=B20 ;set the bill referral date to the current date
..S BILLDT=$P(B6,U),PREPDT=$P(B0,U,10) ; PRCA*4.5*343 - change BILLDT from DATE ACCOUNT ACTIVATED (#60) to LETTER1(#61)
..I BILLDT>RC151DT Q ; PRCA*4.5*343 - Must be 151 days or more after LETTER1 date
..I ($P(B0,U,8)=16),('$P(B6,U,3)) D Q
...;no 3rd letter being sent
...N DNM
...S DNM=$$NAMEFF^RCTCSPRS(+DEBTOR0),^XTMP("RCTCSPD",$J,"THIRD",DNM,$P(B0,U))=""
..I $P(B0,U,8)=16 I $$ADDCHKND(BILL) Q
..I $P(B0,U,8)=16 I $$ADDCHKNB(BILL) Q
..Q
.Q
;
D NOW^%DTC S ^XTMP("RCTCSPD",$J,"ZZDEND")=%
D THIRD^RCTCSP2
D NOW^%DTC S ^XTMP("RCTCSPD",$J,"ZZETRANSMIT CS RECS")=%
D COMPILE^RCTCSP2 ;compile cross-serviced records
D NOW^%DTC S ^XTMP("RCTCSPD",$J,"ZZFTRANSMIT DPN")=%
D COMPILED^RCTCSP3 ;compile the aitc due process notification records
D NOW^%DTC S ^XTMP("RCTCSPD",$J,"ZZGTRANSMIT FINISHED")=%,^XTMP("RCTCSPD",$J,"ZZHCOMPLETE")=%
D FINISH^RCTCSPD0
Q
;
ADDCHKND(BILL) ;add a new bill referral, new debtor
N TOTAL,ACTION,X
S ACTION="A"
I $D(^RCD(340,"TCSP",DEBTOR)) Q 0 ;check debtor previously referred
I $P(DEBTOR7,U,2) Q 0 ;check debtor recall
I $D(^PRCA(430,"TCSP",BILL)) Q 0 ;bill previously sent to TCSP
S TOTAL=$P(B7,U)+$P(B7,U,2)+$P(B7,U,3)+$P(B7,U,4)+$P(B7,U,5)
I TOTAL<25 Q 1 ;no adds for bills less than $25
I RR=0 D RRMARK^RCTCSPD0 ; PRCA*4.5*350
I $P(B15,U,7) Q 0 ;check stop tcsp referral flag
I $P(B15,U,2) Q 0 ;check tcsp bill recall flag
D REC1,REC2,REC2A
S $P(^PRCA(430,BILL,16),U,13)=DOB,B16=^(16)
S $P(^PRCA(430,BILL,15),U,14)=GNDR,B15=^(15)
D REC2C^RCTCSP7 ;PRCA*4.5*327
S ADDRCS=$$ADDR^RCTCSP1(RCDFN,1) ;PRCA*4.5*336
S $P(^PRCA(430,BILL,16),U,4,8)=$P(ADDRCS,U,1,5),$P(^(16),U,11)=$P(ADDRCS,U,6),$P(^(16),U,12)=$P(ADDRCS,U,7)
S B16=^PRCA(430,BILL,16)
D REC3^RCTCSP2
S TAXID=$$TAXID^RCTCSP1(DEBTOR)
S NAME=$$NAME^RCTCSP7(+DEBTOR0),NAME=$P(NAME,U)
S $P(^PRCA(430,BILL,15),U,1)=DT,$P(^(16),U,1)=TAXID,$P(^(16),U,2)=NAME
S X1=BILLDT,X2=+30 D C^%DTC S DELDT=X
S $P(^PRCA(430,BILL,16),U,3)=DELDT,^PRCA(430,"TCSP",BILL)=""
I $P($G(^PRCA(430,BILL,21)),U)="" S $P(^PRCA(430,BILL,21),U)=DT ;PRCA*4.5*336
I '$D(^RCD(340,"TCSP",DEBTOR)) S $P(^RCD(340,DEBTOR,7),U,5)=DT,^RCD(340,"TCSP",DEBTOR)=""
D:RR'=0 NEWDEBTR^RCTCSPD4 D:RR=0 RRSEND^RCTCSPD4 ; set CS new debtor new bill non-financial transaction PRCA*4.5*315
Q 1
;
ADDCHKNB(BILL) ;add a new bill referral, existing debtor
N TOTAL,ACTION,TAXID,NAME,ADDRCS,X
I '$D(^RCD(340,"TCSP",DEBTOR)) Q 0 ;check debtor previously referred
I $D(^PRCA(430,"TCSP",BILL)) Q 0 ;bill previously sent to TCSP
S TOTAL=$P(B7,U)+$P(B7,U,2)+$P(B7,U,3)+$P(B7,U,4)+$P(B7,U,5)
I TOTAL<25 Q 0 ;no adds for bills less than $25
I RR=0 D RRMARK^RCTCSPD0 ; PRCA*4.5*350
I $P(B15,U,2) Q 0 ;check tcsp bill recall flag
I $P(B15,U,7) Q 0 ;check stop tcsp referral flag
S ACTION="A" D REC1
S ACTION="B" D REC2
S ACTION="A" D REC3^RCTCSP2
S TAXID=$$TAXID^RCTCSP1(DEBTOR)
S NAME=$$NAME^RCTCSP7(+DEBTOR0),NAME=$P(NAME,U)
S $P(^PRCA(430,BILL,15),U,1)=DT,$P(^(16),U,1)=TAXID,$P(^(16),U,2)=NAME,$P(^(16),U,3)=BILLDT,^PRCA(430,"TCSP",BILL)=""
I $P($G(^PRCA(430,BILL,21)),U)="" S $P(^PRCA(430,BILL,21),U)=DT ;PRCA*4.5*336
S ADDRCS=$$ADDR^RCTCSP1(RCDFN,1) ;PRCA*4.5*336
S $P(^PRCA(430,BILL,16),U,4,8)=$P(ADDRCS,U,1,5),$P(^(16),U,11)=$P(ADDRCS,U,6),$P(^(16),U,12)=$P(ADDRCS,U,7)
S $P(^PRCA(430,BILL,16),U,13)=DOB,B16=^(16)
S $P(^PRCA(430,BILL,15),U,14)=GNDR,B15=^(15)
I '$D(^RCD(340,"TCSP",DEBTOR)) S $P(^RCD(340,DEBTOR,7),U,5)=DT,^RCD(340,"TCSP",DEBTOR)=""
D:RR'=0 DEBTOR^RCTCSPD4 D:RR=0 RRSEND^RCTCSPD4 ; set CS debtor new bill non-financial transaction PRCA*4.5*315, PRCA*4.5*350
Q 1
;
UPDCHK(BILL) ;update 5b or existing bill
I $P(B15,U,2) Q 0 ;check tcsp bill recall flag
N TOTAL,TAXID,OTAXID,NAME,ONAME,ADDR,OADDR,ADDRCS,COUNTRY,OCOUNTRY,OPHONE,ODOB,OGNDR,TRNIDX,TRN1,TRN8,TRNAMT,TRNNUM,TRNFLG,FIVBFLG,PRCATTYP
;5b check
S FIVBFLG=0
S TRNIDX=0 F S TRNIDX=$O(^PRCA(430,BILL,17,TRNIDX)) Q:+TRNIDX=0 D
.S TRNNUM=$P($G(^PRCA(430,BILL,17,TRNIDX,0)),U,1),TRNFLG=$P($G(^PRCA(430,BILL,17,TRNIDX,0)),U,2)
.Q:+TRNFLG=0
.S TRN1=$G(^PRCA(433,TRNNUM,1)),TRNAMT=$P(TRN1,U,5) S:TRNAMT<0 TRNAMT=-TRNAMT
.S TRN8=$G(^PRCA(433,TRNNUM,8))
.S ACTION="U"
.D REC5B^RCTCSP1
.S $P(^PRCA(430,BILL,17,TRNIDX,0),U,2)=""
.S FIVBFLG=1
I $P(B15,U,7) Q 0 ;check stop tcsp referral flag ;PRCA*4.5*336
S TOTAL=$P(B7,U)+$P(B7,U,2)+$P(B7,U,3)+$P(B7,U,4)+$P(B7,U,5)
S (PRCAREST,PRCAREFR)=0
I FIVBFLG,(TOTAL=0) S DR="151///@",DIE="^PRCA(430,",DA=BILL D ^DIE K DR,DIE,DA
I $P($G(^PRCA(430,BILL,30)),U) D S:PRCAREFR PRCAREST=0 Q:PRCAREST 1 ;PRCA*4.5*343
. S PRCATX=0 F S PRCATX=$O(^PRCA(433,"C",BILL,PRCATX)) Q:'PRCATX D
. . S PRCATTYP=$P($G(^PRCA(433,PRCATX,1)),U,2)
. . I PRCATTYP=43 S PRCAREST=1,PRCAREFR=0
. . I PRCATTYP=86!(PRCATTYP=87) S PRCAREFR=1
. . I PRCATTYP=88 S PRCAREFR=0
I $D(^PRCA(430,"TCSP",BILL)),$P(B0,U,8)=16,TOTAL'<25 D ;PRCA*4.5*343
. I $P(B19,U,1)=1 S ACTION="U" D REC1 S $P(B19,U,1)="" S $P(^PRCA(430,BILL,19),U,1)=""
. I $P(B19,U,2)=1 S ACTION="U" D REC2 S $P(B19,U,2)="" S $P(^PRCA(430,BILL,19),U,2)=""
. I $P(B19,U,3)=1 S ACTION="U" D REC2A S $P(B19,U,3)="" S $P(^PRCA(430,BILL,19),U,3)=""
. I $P(B19,U,4)=1 S ACTION="A" D REC2C^RCTCSP7 S $P(B19,U,4)="" S $P(^PRCA(430,BILL,19),U,4)="" ;PRCA*4.5*327
I FIVBFLG=1 Q 1 ;if 5b sent, then do not continue to referral check
I '$D(^PRCA(430,"TCSP",BILL)) Q 0 ;if not cross-serviced, then continue referral check
I '$D(^PRCA(430,BILL,16)) Q 0 ;quit null node 16 old address ;PRCA*4.5*343
UP1 S NAME=$$NAME^RCTCSP7(+DEBTOR0),NAME=$P(NAME,U)
S ONAME=$P(B16,U,2)
I $P(B0,U,8)=16,$D(^PRCA(430,"TCSP",BILL)) I (NAME'=ONAME) D
.S ACTION="U"
.D REC2
.S $P(^PRCA(430,BILL,16),U,2)=NAME,$P(^PRCA(430,BILL,19),U,2)="",$P(B19,U,2)=""
S OADDR=$P(B16,U,4,8),OPHONE=$P(B16,U,11),OCOUNTRY=$P(B16,U,12)
S ADDRCS=$$ADDR^RCTCSP1(RCDFN,1),PHONE=$P(ADDRCS,U,6),COUNTRY=$P(ADDRCS,U,7) ;PRCA*4.5*336
I $P(DEBTOR1,"^",9)'=1 D ;if debtor address is not marked unknown, then check address
.I $P(B0,U,8)=16,$D(^PRCA(430,"TCSP",BILL)) I ($P(ADDRCS,U,1,5)'=$P(OADDR,U,1,5))!(PHONE'=OPHONE)!(COUNTRY'=OCOUNTRY) D
..S ACTION="A" ;2c records have action code 'a'
..D REC2C^RCTCSP7
..S $P(B19,U,4)=""
..S $P(^PRCA(430,BILL,16),U,4,8)=$P(ADDRCS,U,1,5),$P(^PRCA(430,BILL,16),U,11)=PHONE,$P(^PRCA(430,BILL,16),U,12)=$P(ADDRCS,U,7)
S B16=^PRCA(430,BILL,16)
S ODOB=$P(^PRCA(430,BILL,16),U,13)
S OGNDR=$P(^PRCA(430,BILL,15),U,14)
I $P(B0,U,8)=16,$D(^PRCA(430,"TCSP",BILL)) I (DOB'=ODOB)!(GNDR'=OGNDR) D
.S ACTION="U"
.D REC2A
.S $P(^PRCA(430,BILL,16),U,13)=DOB,B16=^PRCA(430,BILL,16)
.S $P(^PRCA(430,BILL,15),U,14)=GNDR,B15=^PRCA(430,BILL,15)
.Q
Q 1 ;bill is cross-serviced so do not continue referral check
;
REC1 ;record type 1
N REC,KNUM,DEBTNR,AMTORIG,AMTPBAL,AMTIBAL,AMTABAL,AMTFBAL,AMTCBAL,AMTRFRRD,AMOUNT,DELDT,X,X1,X2,BILLDT,PREPDT
S REC="C1 "_ACTION_"3636001200"_"DM1D "
S KNUM=$P($P(B0,U,1),"-",2)
S DEBTNR=$$AGDEBTID,REC=REC_DEBTNR_" " ; PRCA*4.5*350
S REC=REC_"I A MSCC"
S BILLDT=$P(B6,U,21),PREPDT=$P(B0,U,10)
S REC=REC_$$DATE8(PREPDT)
S X1=BILLDT,X2=+30 D C^%DTC S DELDT=X
S REC=REC_$$DATE8(DELDT)
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
S AMTORIG=$P(B0,U,3)
D ;
.I ACTION="A" S REC=REC_$$AMOUNT(AMTRFRRD)_$$AMOUNT(AMTRFRRD) Q
.I ACTION="L" S AMTRFRRD=0 S REC=REC_$$AMOUNT(AMTRFRRD)_$$AMOUNT(AMTRFRRD) Q
.S REC=REC_$$BLANK(28)
S REC=REC_" N "
S AMOUNT=$$AMOUNT(AMTPBAL)_$$AMOUNT(AMTIBAL)_$$AMOUNT(AMTABAL)_$$AMOUNT(AMTFBAL+AMTCBAL)
I ACTION="L" S AMOUNT=$$AMOUNT(0)_$$AMOUNT(0)_$$AMOUNT(0)_$$AMOUNT(0) ;by iai spec
I ACTION="U" S AMOUNT=$$BLANK(56) ;by iai spec
S REC=REC_AMOUNT
I ACTION="L" D
.S REC=REC_$$BLANK(252-$L(REC))
.S RCD=$P(B15,U,4)
.S REC=REC_$S(RCD="01":"01",RCD="07":"07",RCD="08":"08",RCD="15":"01",RCD="03":"01",RCD="05":"01",RCD="06":"01",1:"01")
S REC=REC_$$BLANK(450-$L(REC))
I ACTION="A" S $P(^PRCA(430,BILL,16),U,9)=AMTRFRRD,$P(^(16),U,10)=AMTRFRRD
I ACTION="L" S $P(^PRCA(430,BILL,16),U,9)="",$P(^(16),U,10)=""
S ^XTMP("RCTCSPD",$J,BILL,ACTION,1)=REC
S ^XTMP("RCTCSPD",$J,"BILL",ACTION,BILL)=$$TAXID^RCTCSP1(DEBTOR)_"^"_+$E(REC,91,102)_"."_$E(REC,103,104) ;sends mailman message of documents sent to user
D CLR19(BILL,1)
Q
;
REC2 ;
N REC,KNUM,DEBTNR,DEBTORNB,TAXID,NAME,RCD,HTAXID
S REC="C2 "_ACTION_"3636001200"_"DM1D "
S KNUM=$P($P(B0,U,1),"-",2),HTAXID=0
S DEBTNR=$$AGDEBTID,REC=REC_DEBTNR ; PRCA*4.5*350
S DEBTORNB=$E(SITE,1,3)_$TR($J(DEBTOR,12)," ",0)
S REC=REC_DEBTORNB
S TAXID=$$TAXID^RCTCSP1(DEBTOR) S:+$G(RCTCSSCH) HTAXID=TAXID,TAXID=$P(RCTCSSCH,U)
S REC=REC_TAXID_"SSN"
S NAME=$$NAME^RCTCSP7(+DEBTOR0),NAME=$P(NAME,U)
I $G(RCTCSCW) S NAME=$E(RCTCSSCH,11,115)
S REC=REC_NAME_$$BLANK(5)_"I"
I ACTION="U",HTAXID S REC=REC_$$BLANK(35)_HTAXID
I ACTION="L" D
.S REC=REC_$$BLANK(232-$L(REC))
.S RCD=$P(B15,U,4)
.S REC=REC_$S(RCD="01":"12",RCD="07":"12",RCD="08":"12",RCD="15":"12",RCD="03":"03",RCD="05":"05",RCD="06":"06",1:"12")
S REC=REC_$$BLANK(450-$L(REC))
S ^XTMP("RCTCSPD",$J,BILL,ACTION,2)=REC
S $P(^XTMP("RCTCSPD",$J,"BILL",ACTION,BILL),U,1)=$$TAXID^RCTCSP1(DEBTOR)
D CLR19(BILL,2)
Q
;
REC2A ;
N REC,KNUM,DEBTNR,DEBTORNB
S REC="C2A"_ACTION_"3636001200"_"DM1D "
S KNUM=$P($P(B0,U,1),"-",2)
S DEBTNR=$$AGDEBTID,REC=REC_DEBTNR ; PRCA*4.5*350
S DEBTORNB=$E(SITE,1,3)_$TR($J(DEBTOR,12)," ",0)
S REC=REC_DEBTORNB,REC=REC_$$BLANK(3),REC=REC_GNDR
S REC=REC_$$DATE8($P(DEMCS,U,2)),REC=REC_$$BLANK(450-$L(REC))
S ^XTMP("RCTCSPD",$J,BILL,ACTION,"2A")=REC
S $P(^XTMP("RCTCSPD",$J,"BILL",ACTION,BILL),U,1)=$$TAXID^RCTCSP1(DEBTOR)
D CLR19(BILL,3)
Q
AGDEBTID() ; Return Agency Debt ID accoring to new logic PRCA*4.5*350
; Input: SITE,KNUM,BILL,B15
N TRAIL S TRAIL=$P($G(^PRCA(430,BILL,21)),U,2)
I TRAIL="" Q $E(SITE,1,3)_$$LJZF(KNUM,7)_$TR($J(BILL,20)," ",0)
Q $E(SITE,1,3)_$$LJZF(KNUM,7)_$TR($J(BILL,18)," ",0)_TRAIL
;
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) ;changes amount to zero filled, right justified
S:X<0 X=-X
S X=$TR($J(X,0,2),".")
S X=$E("000000000000",1,14-$L(X))_X
Q X
;
BLANK(X) ;returns 'x' blank spaces
N BLANK
S BLANK="",$P(BLANK," ",X+1)=""
Q BLANK
;
NOW() ;compiles current date,time
N X,Y,%,%H
S %H=$H D YX^%DTC
Q Y
;
RJZF(X,Y) ;right justify zero fill width Y
S X=$E("000000000000",1,Y-$L(X))_X
Q X
;
LJSF(X,Y) ;x left justified, y space filled
S X=$E(X,1,Y)
S X=X_$$BLANK(Y-$L(X))
Q X
;
LJZF(X,Y) ;x left justified, y zero filled
S X=X_"0000000000"
S X=$E(X,1,Y)
Q X
;
RECALL(BILL) ; set the recall flag
S $P(^PRCA(430,BILL,15),U,2)=1
Q
;
CLR19(BILL,X) ; clear the send flag
S $P(^PRCA(430,BILL,19),U,X)=""
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRCTCSPD 17140 printed Dec 13, 2024@01:48:54 Page 2
RCTCSPD ;ALBANY/BDB-CROSS-SERVICING TRANSMISSION ;03/15/14 3:34 PM
+1 ;;4.5;Accounts Receivable;**301,327,315,336,338,351,350,343,417**;Mar 20, 1995;Build 30
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;
+4 ;PRCA*4.5*327 a. Add check to insure debtor exists to prevent
+5 ; undefined error and set in XTMP work global to
+6 ; be reported via 'TCSP' mailgroup.
+7 ; b. Added process controls throughout entire batch
+8 ; run and message to mail group 'TCSP' batch run
+9 ; is complete
+10 ; c. Move SETUP/FINISH to new routine RCTCSPD0
+11 ; due to SACC size constraints
+12 ; d. Move REC2C tag/code to RCTCSP7 to create space
+13 ; for debtor undefined logic
+14 ;
+15 ;PRCA*4.5*336 a. Shift code to handle 5B transactions ahead
+16 ; of other processing that could cause a 5B
+17 ; record to not be sent in batch run at tag
+18 ; $$UPDCHK(BILL), EXCEPT FOR RECALL CHECK.
+19 ; b. Ensure address calls to RCTCSP1 include flag
+20 ; to handle missing debtor node 1 correctly when
+21 ; building address for CS transactions
+22 ;
+23 ;PRCA*4.5*343 Added check to ensure bill is cross-service status,
+24 ; 'active' and bal>25 to send pending tx per node 19.
+25 ; Also, add check to ensure a re-established bill is
+26 ; NOT ever sent to Treasury.
+27 ;
+28 ;PRCA*4.5*417 Correct gender update issue caused by patch
+29 ; and incidents INC22249334 & INC21601588
+30 ;
ENTER ;Entry point from nightly process PRCABJ
+1 NEW DEBTOR,RC151DT,PRIN,INT,ADMIN,TDEB,TFIL,RCDFN,CNTR,SITE,LN,FN,MN,SITE,F60DT,VADM,PHONE,QUIT,TOTAL,ZIPCODE,FULLNM,RCNT,REPAY,X1,X2,ERROR,ADDR,CAT,BILLDT,CURRTOT,SITECD
+2 NEW SEQ,CNTLID,PREPDT,X1,X2,X,DELDT,ACTDT,SITE40,PRCATX,PRCAREST,PRCAREFR
+3 DO SETUP^RCTCSPD0
+4 SET (DEBTOR,RCNT)=0
SET SEQ=0
RSDEBTOR ;
+1 FOR
SET DEBTOR=$ORDER(^PRCA(430,"C",DEBTOR))
if DEBTOR'?1N.N
QUIT
Begin DoDot:1
+2 DO NOW^%DTC
SET ^XTMP("RCTCSPD",$JOB,"ZZBDEBTOR")=%_U_DEBTOR
+3 NEW X,RCDFN,DEMCS,DOB,GNDR,DEBTOR0,DEBTOR1,DEBTOR3,DEBTOR7,DEBTOR8,BILL,RCTCSCW
+4 IF '$DATA(^RCD(340,DEBTOR,0))
SET ^XTMP("RCTCSPD",$JOB,"ZZUNDEF",DEBTOR)=""
QUIT
+5 SET RCTCSCW=0
SET DEBTOR0=^RCD(340,DEBTOR,0)
SET DEBTOR1=$GET(^(1))
SET DEBTOR3=$GET(^(3))
SET DEBTOR7=$GET(^(7))
+6 ;PRCA*4.5*417
SET RCTCSCW=$$SSCHK^RCTCSP7(DEBTOR)
if RCTCSCW=1
QUIT
+7 SET DEBTOR8=$ORDER(^RCD(340,DEBTOR,8,"A"),-1)
IF DEBTOR8?1.N
SET DEBTOR8=$PIECE($GET(^RCD(340,DEBTOR,8,DEBTOR8,0)),U)
+8 SET RCDFN=+DEBTOR0
+9 SET DEMCS=$$DEM^RCTCSP1(RCDFN)
+10 SET DOB=$PIECE(DEMCS,U,2)
+11 SET GNDR=$PIECE(DEMCS,U)
if "MF"'[GNDR
SET GNDR="U"
+12 ;send type 2 recall record
IF $PIECE(DEBTOR7,U,2)
if '+$PIECE(DEBTOR7,U,3)
Begin DoDot:2
+13 NEW ACTION,B0,B15,BILL
+14 SET ACTION="L"
+15 SET B0=""
SET B15=""
SET BILL=0
+16 ; The code below is designed to get ONLY one bill #. It is not a bug! As per VA SME contacts.
+17 ;get one bill
FOR
SET BILL=$ORDER(^PRCA(430,"C",DEBTOR,BILL))
if BILL'?1N.N
QUIT
IF $DATA(^PRCA(430,"TCSP",BILL))
IF $PIECE(^PRCA(430,BILL,15),U,7)'=1
SET B0=$GET(^PRCA(430,BILL,0))
SET B15=$GET(^(15))
QUIT
+18 ;cs debtor with no cs bill, clear the debtor recall flag, quit
IF BILL=""
SET BILL=0
SET $PIECE(^RCD(340,DEBTOR,7),U,2,4)="^^"
SET $PIECE(DEBTOR7,U,2,4)="^^"
QUIT
+19 DO REC2
+20 SET $PIECE(^RCD(340,DEBTOR,7),U,3)=DT
+21 SET DEBTOR7=^RCD(340,DEBTOR,7)
SET TAXID=$$TAXID^RCTCSP1(DEBTOR)
+22 ;set debtor cross-serviced bills as recalled
SET BILL=0
+23 FOR
SET BILL=$ORDER(^PRCA(430,"C",DEBTOR,BILL))
if BILL'?1N.N
QUIT
Begin DoDot:3
+24 DO NOW^%DTC
SET ^XTMP("RCTCSPD",$JOB,"ZZCRBILL")=%_U_BILL
+25 IF $DATA(^PRCA(430,"TCSP",BILL))
Begin DoDot:4
+26 SET ^PRCA(430,BILL,15)=U_1_U_DT_U_$PIECE(^PRCA(430,BILL,15),U,4,99)
+27 ;set the recall reason
SET $PIECE(^PRCA(430,BILL,15),U,4)=$PIECE(DEBTOR7,U,4)
+28 ;set the recall amount to the current amount
SET $PIECE(^PRCA(430,BILL,15),U,5)=$$GET1^DIQ(430,BILL,11)
+29 KILL ^PRCA(430,"TCSP",BILL)
+30 ; set debtor recall non-financial transaction PRCA*4.5*315
DO RCRSD^RCTCSPD4
End DoDot:4
QUIT
End DoDot:3
End DoDot:2
+31 SET (BILL,TOTAL,REPAY)=0
RSBILL FOR
SET BILL=$ORDER(^PRCA(430,"C",DEBTOR,BILL))
if BILL'?1N.N
QUIT
Begin DoDot:2
+1 ; Test single bill ; PRCA*4.5*350
IF $GET(ONEBILL)'=""
IF BILL'=ONEBILL
QUIT
+2 DO NOW^%DTC
SET ^XTMP("RCTCSPD",$JOB,"ZZCTRACKER")=%_U_DEBTOR_U_BILL
+3 NEW B0,B4,B6,B7,B9,B12,B121,B14,B15,B16,B19,B20,ACTION,RR
+4 DO TAXID^RCTCSP7(DEBTOR)
+5 SET B0=$GET(^PRCA(430,BILL,0))
SET B4=$GET(^(4))
SET B6=$GET(^(6))
SET B7=$GET(^(7))
SET B9=$GET(^(9))
SET B12=$GET(^(12))
SET B121=$GET(^(12.1))
SET B14=$GET(^(14))
SET B15=$GET(^(15))
SET B16=$GET(^(16))
SET B19=$GET(^(19))
SET B20=$GET(^(20))
+6 ;PRCA*4.5*350
SET RR=$$RR^RCTCSPU(BILL)
+7 ;cs activation date cutoff
if ($PIECE(B6,U,21)\1)<ACTDT
QUIT
+8 ;bill previously sent to TCSP
IF $DATA(^PRCA(430,"TCSP",BILL))
IF $$RCLLCHK^RCTCSP2(BILL)
QUIT
+9 IF $$UPDCHK(BILL)
QUIT
+10 ;repayment plan
if B4
QUIT
+11 ; Do we clear stop flag if RR TBD ; PRCA*4.5*350
+12 ;quit if bill is stopped
IF +$PIECE(B15,U,7)
IF RR'=0
QUIT
+13 ;bill referred to TOP
if +$PIECE(B14,U)
QUIT
+14 ;quit if debtor address marked unknown
if $PIECE(DEBTOR1,"^",9)=1
QUIT
+15 ;quit if the ssn is not valid
if $EXTRACT($PIECE(DEMCS,U,3),1,5)="00000"
QUIT
+16 ;quit if debtor is stopped PRCA*4.5*350
if DEBTOR8="S"
QUIT
+17 ; quit if site is stopped PRCA*4.5*350
if SITE40="S"
QUIT
+18 ;check date bill sent to dmc
IF +$PIECE(B12,U,1)
QUIT
+19 ;dmc debt valid
if ($PIECE(B121,U,1)="N")!($PIECE(B121,U,1)="P")
QUIT
+20 IF $PIECE(B6,U,4)
IF ($PIECE(B6,U,5)="DOJ")
QUIT
+21 ;deceased patient
if +$PIECE(DEMCS,U,4)
QUIT
+22 ;no category
if '$PIECE(B0,U,2)
QUIT
+23 SET CAT=$PIECE($GET(^PRCA(430.2,$PIECE(B0,U,2),0)),U,7)
+24 if 'CAT
QUIT
+25 ;PRCA*4.5*338 - Use RFCHK^RCTOPD to determine if the Category can be referred
+26 ; using the new date based algorithm.
+27 if '$$RFCHK^RCTOPD(CAT,"N",1.03,$PIECE(B6,U,21))
QUIT
+28 ;end PRCA*4.5*338 ..;dpn checks
+29 ;check to send dpn file to aitc
IF $PIECE(B20,U,3)=1
IF (10000+$GET(^RC(342,1,"CS")))>DT
IF '$PIECE(B20,U,4)
DO DUEPROC^RCTCSP3
QUIT
+30 ;check for print letter date
IF $PIECE(B20,U,3)=1
IF (10000+$GET(^RC(342,1,"CS")))>DT
IF $PIECE(B20,U,4)
IF '$PIECE(B20,U,5)
QUIT
+31 ;check for 60 day wait from print letter date
IF $PIECE(B20,U,3)=1
IF (10000+$GET(^RC(342,1,"CS")))>DT
IF $PIECE(B20,U,4)
IF $PIECE(B20,U,5)
Begin DoDot:3
+32 NEW X1,X2
+33 SET X1=DT
SET X2=$PIECE(B20,U,5)
DO ^%DTC
+34 ;set the bill referral date to the current date
IF X'<60
SET $PIECE(B20,U,6)=DT
SET ^PRCA(430,BILL,20)=B20
End DoDot:3
IF X<60
QUIT
+35 ; PRCA*4.5*343 - change BILLDT from DATE ACCOUNT ACTIVATED (#60) to LETTER1(#61)
SET BILLDT=$PIECE(B6,U)
SET PREPDT=$PIECE(B0,U,10)
+36 ; PRCA*4.5*343 - Must be 151 days or more after LETTER1 date
IF BILLDT>RC151DT
QUIT
+37 IF ($PIECE(B0,U,8)=16)
IF ('$PIECE(B6,U,3))
Begin DoDot:3
+38 ;no 3rd letter being sent
+39 NEW DNM
+40 SET DNM=$$NAMEFF^RCTCSPRS(+DEBTOR0)
SET ^XTMP("RCTCSPD",$JOB,"THIRD",DNM,$PIECE(B0,U))=""
End DoDot:3
QUIT
+41 IF $PIECE(B0,U,8)=16
IF $$ADDCHKND(BILL)
QUIT
+42 IF $PIECE(B0,U,8)=16
IF $$ADDCHKNB(BILL)
QUIT
+43 QUIT
End DoDot:2
+44 QUIT
End DoDot:1
+45 ;
+46 DO NOW^%DTC
SET ^XTMP("RCTCSPD",$JOB,"ZZDEND")=%
+47 DO THIRD^RCTCSP2
+48 DO NOW^%DTC
SET ^XTMP("RCTCSPD",$JOB,"ZZETRANSMIT CS RECS")=%
+49 ;compile cross-serviced records
DO COMPILE^RCTCSP2
+50 DO NOW^%DTC
SET ^XTMP("RCTCSPD",$JOB,"ZZFTRANSMIT DPN")=%
+51 ;compile the aitc due process notification records
DO COMPILED^RCTCSP3
+52 DO NOW^%DTC
SET ^XTMP("RCTCSPD",$JOB,"ZZGTRANSMIT FINISHED")=%
SET ^XTMP("RCTCSPD",$JOB,"ZZHCOMPLETE")=%
+53 DO FINISH^RCTCSPD0
+54 QUIT
+55 ;
ADDCHKND(BILL) ;add a new bill referral, new debtor
+1 NEW TOTAL,ACTION,X
+2 SET ACTION="A"
+3 ;check debtor previously referred
IF $DATA(^RCD(340,"TCSP",DEBTOR))
QUIT 0
+4 ;check debtor recall
IF $PIECE(DEBTOR7,U,2)
QUIT 0
+5 ;bill previously sent to TCSP
IF $DATA(^PRCA(430,"TCSP",BILL))
QUIT 0
+6 SET TOTAL=$PIECE(B7,U)+$PIECE(B7,U,2)+$PIECE(B7,U,3)+$PIECE(B7,U,4)+$PIECE(B7,U,5)
+7 ;no adds for bills less than $25
IF TOTAL<25
QUIT 1
+8 ; PRCA*4.5*350
IF RR=0
DO RRMARK^RCTCSPD0
+9 ;check stop tcsp referral flag
IF $PIECE(B15,U,7)
QUIT 0
+10 ;check tcsp bill recall flag
IF $PIECE(B15,U,2)
QUIT 0
+11 DO REC1
DO REC2
DO REC2A
+12 SET $PIECE(^PRCA(430,BILL,16),U,13)=DOB
SET B16=^(16)
+13 SET $PIECE(^PRCA(430,BILL,15),U,14)=GNDR
SET B15=^(15)
+14 ;PRCA*4.5*327
DO REC2C^RCTCSP7
+15 ;PRCA*4.5*336
SET ADDRCS=$$ADDR^RCTCSP1(RCDFN,1)
+16 SET $PIECE(^PRCA(430,BILL,16),U,4,8)=$PIECE(ADDRCS,U,1,5)
SET $PIECE(^(16),U,11)=$PIECE(ADDRCS,U,6)
SET $PIECE(^(16),U,12)=$PIECE(ADDRCS,U,7)
+17 SET B16=^PRCA(430,BILL,16)
+18 DO REC3^RCTCSP2
+19 SET TAXID=$$TAXID^RCTCSP1(DEBTOR)
+20 SET NAME=$$NAME^RCTCSP7(+DEBTOR0)
SET NAME=$PIECE(NAME,U)
+21 SET $PIECE(^PRCA(430,BILL,15),U,1)=DT
SET $PIECE(^(16),U,1)=TAXID
SET $PIECE(^(16),U,2)=NAME
+22 SET X1=BILLDT
SET X2=+30
DO C^%DTC
SET DELDT=X
+23 SET $PIECE(^PRCA(430,BILL,16),U,3)=DELDT
SET ^PRCA(430,"TCSP",BILL)=""
+24 ;PRCA*4.5*336
IF $PIECE($GET(^PRCA(430,BILL,21)),U)=""
SET $PIECE(^PRCA(430,BILL,21),U)=DT
+25 IF '$DATA(^RCD(340,"TCSP",DEBTOR))
SET $PIECE(^RCD(340,DEBTOR,7),U,5)=DT
SET ^RCD(340,"TCSP",DEBTOR)=""
+26 ; set CS new debtor new bill non-financial transaction PRCA*4.5*315
if RR'=0
DO NEWDEBTR^RCTCSPD4
if RR=0
DO RRSEND^RCTCSPD4
+27 QUIT 1
+28 ;
ADDCHKNB(BILL) ;add a new bill referral, existing debtor
+1 NEW TOTAL,ACTION,TAXID,NAME,ADDRCS,X
+2 ;check debtor previously referred
IF '$DATA(^RCD(340,"TCSP",DEBTOR))
QUIT 0
+3 ;bill previously sent to TCSP
IF $DATA(^PRCA(430,"TCSP",BILL))
QUIT 0
+4 SET TOTAL=$PIECE(B7,U)+$PIECE(B7,U,2)+$PIECE(B7,U,3)+$PIECE(B7,U,4)+$PIECE(B7,U,5)
+5 ;no adds for bills less than $25
IF TOTAL<25
QUIT 0
+6 ; PRCA*4.5*350
IF RR=0
DO RRMARK^RCTCSPD0
+7 ;check tcsp bill recall flag
IF $PIECE(B15,U,2)
QUIT 0
+8 ;check stop tcsp referral flag
IF $PIECE(B15,U,7)
QUIT 0
+9 SET ACTION="A"
DO REC1
+10 SET ACTION="B"
DO REC2
+11 SET ACTION="A"
DO REC3^RCTCSP2
+12 SET TAXID=$$TAXID^RCTCSP1(DEBTOR)
+13 SET NAME=$$NAME^RCTCSP7(+DEBTOR0)
SET NAME=$PIECE(NAME,U)
+14 SET $PIECE(^PRCA(430,BILL,15),U,1)=DT
SET $PIECE(^(16),U,1)=TAXID
SET $PIECE(^(16),U,2)=NAME
SET $PIECE(^(16),U,3)=BILLDT
SET ^PRCA(430,"TCSP",BILL)=""
+15 ;PRCA*4.5*336
IF $PIECE($GET(^PRCA(430,BILL,21)),U)=""
SET $PIECE(^PRCA(430,BILL,21),U)=DT
+16 ;PRCA*4.5*336
SET ADDRCS=$$ADDR^RCTCSP1(RCDFN,1)
+17 SET $PIECE(^PRCA(430,BILL,16),U,4,8)=$PIECE(ADDRCS,U,1,5)
SET $PIECE(^(16),U,11)=$PIECE(ADDRCS,U,6)
SET $PIECE(^(16),U,12)=$PIECE(ADDRCS,U,7)
+18 SET $PIECE(^PRCA(430,BILL,16),U,13)=DOB
SET B16=^(16)
+19 SET $PIECE(^PRCA(430,BILL,15),U,14)=GNDR
SET B15=^(15)
+20 IF '$DATA(^RCD(340,"TCSP",DEBTOR))
SET $PIECE(^RCD(340,DEBTOR,7),U,5)=DT
SET ^RCD(340,"TCSP",DEBTOR)=""
+21 ; set CS debtor new bill non-financial transaction PRCA*4.5*315, PRCA*4.5*350
if RR'=0
DO DEBTOR^RCTCSPD4
if RR=0
DO RRSEND^RCTCSPD4
+22 QUIT 1
+23 ;
UPDCHK(BILL) ;update 5b or existing bill
+1 ;check tcsp bill recall flag
IF $PIECE(B15,U,2)
QUIT 0
+2 NEW TOTAL,TAXID,OTAXID,NAME,ONAME,ADDR,OADDR,ADDRCS,COUNTRY,OCOUNTRY,OPHONE,ODOB,OGNDR,TRNIDX,TRN1,TRN8,TRNAMT,TRNNUM,TRNFLG,FIVBFLG,PRCATTYP
+3 ;5b check
+4 SET FIVBFLG=0
+5 SET TRNIDX=0
FOR
SET TRNIDX=$ORDER(^PRCA(430,BILL,17,TRNIDX))
if +TRNIDX=0
QUIT
Begin DoDot:1
+6 SET TRNNUM=$PIECE($GET(^PRCA(430,BILL,17,TRNIDX,0)),U,1)
SET TRNFLG=$PIECE($GET(^PRCA(430,BILL,17,TRNIDX,0)),U,2)
+7 if +TRNFLG=0
QUIT
+8 SET TRN1=$GET(^PRCA(433,TRNNUM,1))
SET TRNAMT=$PIECE(TRN1,U,5)
if TRNAMT<0
SET TRNAMT=-TRNAMT
+9 SET TRN8=$GET(^PRCA(433,TRNNUM,8))
+10 SET ACTION="U"
+11 DO REC5B^RCTCSP1
+12 SET $PIECE(^PRCA(430,BILL,17,TRNIDX,0),U,2)=""
+13 SET FIVBFLG=1
End DoDot:1
+14 ;check stop tcsp referral flag ;PRCA*4.5*336
IF $PIECE(B15,U,7)
QUIT 0
+15 SET TOTAL=$PIECE(B7,U)+$PIECE(B7,U,2)+$PIECE(B7,U,3)+$PIECE(B7,U,4)+$PIECE(B7,U,5)
+16 SET (PRCAREST,PRCAREFR)=0
+17 IF FIVBFLG
IF (TOTAL=0)
SET DR="151///@"
SET DIE="^PRCA(430,"
SET DA=BILL
DO ^DIE
KILL DR,DIE,DA
+18 ;PRCA*4.5*343
IF $PIECE($GET(^PRCA(430,BILL,30)),U)
Begin DoDot:1
+19 SET PRCATX=0
FOR
SET PRCATX=$ORDER(^PRCA(433,"C",BILL,PRCATX))
if 'PRCATX
QUIT
Begin DoDot:2
+20 SET PRCATTYP=$PIECE($GET(^PRCA(433,PRCATX,1)),U,2)
+21 IF PRCATTYP=43
SET PRCAREST=1
SET PRCAREFR=0
+22 IF PRCATTYP=86!(PRCATTYP=87)
SET PRCAREFR=1
+23 IF PRCATTYP=88
SET PRCAREFR=0
End DoDot:2
End DoDot:1
if PRCAREFR
SET PRCAREST=0
if PRCAREST
QUIT 1
+24 ;PRCA*4.5*343
IF $DATA(^PRCA(430,"TCSP",BILL))
IF $PIECE(B0,U,8)=16
IF TOTAL'<25
Begin DoDot:1
+25 IF $PIECE(B19,U,1)=1
SET ACTION="U"
DO REC1
SET $PIECE(B19,U,1)=""
SET $PIECE(^PRCA(430,BILL,19),U,1)=""
+26 IF $PIECE(B19,U,2)=1
SET ACTION="U"
DO REC2
SET $PIECE(B19,U,2)=""
SET $PIECE(^PRCA(430,BILL,19),U,2)=""
+27 IF $PIECE(B19,U,3)=1
SET ACTION="U"
DO REC2A
SET $PIECE(B19,U,3)=""
SET $PIECE(^PRCA(430,BILL,19),U,3)=""
+28 ;PRCA*4.5*327
IF $PIECE(B19,U,4)=1
SET ACTION="A"
DO REC2C^RCTCSP7
SET $PIECE(B19,U,4)=""
SET $PIECE(^PRCA(430,BILL,19),U,4)=""
End DoDot:1
+29 ;if 5b sent, then do not continue to referral check
IF FIVBFLG=1
QUIT 1
+30 ;if not cross-serviced, then continue referral check
IF '$DATA(^PRCA(430,"TCSP",BILL))
QUIT 0
+31 ;quit null node 16 old address ;PRCA*4.5*343
IF '$DATA(^PRCA(430,BILL,16))
QUIT 0
UP1 SET NAME=$$NAME^RCTCSP7(+DEBTOR0)
SET NAME=$PIECE(NAME,U)
+1 SET ONAME=$PIECE(B16,U,2)
+2 IF $PIECE(B0,U,8)=16
IF $DATA(^PRCA(430,"TCSP",BILL))
IF (NAME'=ONAME)
Begin DoDot:1
+3 SET ACTION="U"
+4 DO REC2
+5 SET $PIECE(^PRCA(430,BILL,16),U,2)=NAME
SET $PIECE(^PRCA(430,BILL,19),U,2)=""
SET $PIECE(B19,U,2)=""
End DoDot:1
+6 SET OADDR=$PIECE(B16,U,4,8)
SET OPHONE=$PIECE(B16,U,11)
SET OCOUNTRY=$PIECE(B16,U,12)
+7 ;PRCA*4.5*336
SET ADDRCS=$$ADDR^RCTCSP1(RCDFN,1)
SET PHONE=$PIECE(ADDRCS,U,6)
SET COUNTRY=$PIECE(ADDRCS,U,7)
+8 ;if debtor address is not marked unknown, then check address
IF $PIECE(DEBTOR1,"^",9)'=1
Begin DoDot:1
+9 IF $PIECE(B0,U,8)=16
IF $DATA(^PRCA(430,"TCSP",BILL))
IF ($PIECE(ADDRCS,U,1,5)'=$PIECE(OADDR,U,1,5))!(PHONE'=OPHONE)!(COUNTRY'=OCOUNTRY)
Begin DoDot:2
+10 ;2c records have action code 'a'
SET ACTION="A"
+11 DO REC2C^RCTCSP7
+12 SET $PIECE(B19,U,4)=""
+13 SET $PIECE(^PRCA(430,BILL,16),U,4,8)=$PIECE(ADDRCS,U,1,5)
SET $PIECE(^PRCA(430,BILL,16),U,11)=PHONE
SET $PIECE(^PRCA(430,BILL,16),U,12)=$PIECE(ADDRCS,U,7)
End DoDot:2
End DoDot:1
+14 SET B16=^PRCA(430,BILL,16)
+15 SET ODOB=$PIECE(^PRCA(430,BILL,16),U,13)
+16 SET OGNDR=$PIECE(^PRCA(430,BILL,15),U,14)
+17 IF $PIECE(B0,U,8)=16
IF $DATA(^PRCA(430,"TCSP",BILL))
IF (DOB'=ODOB)!(GNDR'=OGNDR)
Begin DoDot:1
+18 SET ACTION="U"
+19 DO REC2A
+20 SET $PIECE(^PRCA(430,BILL,16),U,13)=DOB
SET B16=^PRCA(430,BILL,16)
+21 SET $PIECE(^PRCA(430,BILL,15),U,14)=GNDR
SET B15=^PRCA(430,BILL,15)
+22 QUIT
End DoDot:1
+23 ;bill is cross-serviced so do not continue referral check
QUIT 1
+24 ;
REC1 ;record type 1
+1 NEW REC,KNUM,DEBTNR,AMTORIG,AMTPBAL,AMTIBAL,AMTABAL,AMTFBAL,AMTCBAL,AMTRFRRD,AMOUNT,DELDT,X,X1,X2,BILLDT,PREPDT
+2 SET REC="C1 "_ACTION_"3636001200"_"DM1D "
+3 SET KNUM=$PIECE($PIECE(B0,U,1),"-",2)
+4 ; PRCA*4.5*350
SET DEBTNR=$$AGDEBTID
SET REC=REC_DEBTNR_" "
+5 SET REC=REC_"I A MSCC"
+6 SET BILLDT=$PIECE(B6,U,21)
SET PREPDT=$PIECE(B0,U,10)
+7 SET REC=REC_$$DATE8(PREPDT)
+8 SET X1=BILLDT
SET X2=+30
DO C^%DTC
SET DELDT=X
+9 SET REC=REC_$$DATE8(DELDT)
+10 ;principle balance
SET AMTPBAL=$PIECE(B7,U,1)
+11 ;interest balance
SET AMTIBAL=$PIECE(B7,U,2)
+12 ;administrative balance
SET AMTABAL=$PIECE(B7,U,3)
+13 ;marshal fee
SET AMTFBAL=$PIECE(B7,U,4)
+14 ;court cost
SET AMTCBAL=$PIECE(B7,U,5)
+15 SET AMTRFRRD=AMTPBAL+AMTIBAL+AMTABAL+AMTFBAL+AMTCBAL
+16 SET AMTORIG=$PIECE(B0,U,3)
+17 ;
Begin DoDot:1
+18 IF ACTION="A"
SET REC=REC_$$AMOUNT(AMTRFRRD)_$$AMOUNT(AMTRFRRD)
QUIT
+19 IF ACTION="L"
SET AMTRFRRD=0
SET REC=REC_$$AMOUNT(AMTRFRRD)_$$AMOUNT(AMTRFRRD)
QUIT
+20 SET REC=REC_$$BLANK(28)
End DoDot:1
+21 SET REC=REC_" N "
+22 SET AMOUNT=$$AMOUNT(AMTPBAL)_$$AMOUNT(AMTIBAL)_$$AMOUNT(AMTABAL)_$$AMOUNT(AMTFBAL+AMTCBAL)
+23 ;by iai spec
IF ACTION="L"
SET AMOUNT=$$AMOUNT(0)_$$AMOUNT(0)_$$AMOUNT(0)_$$AMOUNT(0)
+24 ;by iai spec
IF ACTION="U"
SET AMOUNT=$$BLANK(56)
+25 SET REC=REC_AMOUNT
+26 IF ACTION="L"
Begin DoDot:1
+27 SET REC=REC_$$BLANK(252-$LENGTH(REC))
+28 SET RCD=$PIECE(B15,U,4)
+29 SET REC=REC_$SELECT(RCD="01":"01",RCD="07":"07",RCD="08":"08",RCD="15":"01",RCD="03":"01",RCD="05":"01",RCD="06":"01",1:"01")
End DoDot:1
+30 SET REC=REC_$$BLANK(450-$LENGTH(REC))
+31 IF ACTION="A"
SET $PIECE(^PRCA(430,BILL,16),U,9)=AMTRFRRD
SET $PIECE(^(16),U,10)=AMTRFRRD
+32 IF ACTION="L"
SET $PIECE(^PRCA(430,BILL,16),U,9)=""
SET $PIECE(^(16),U,10)=""
+33 SET ^XTMP("RCTCSPD",$JOB,BILL,ACTION,1)=REC
+34 ;sends mailman message of documents sent to user
SET ^XTMP("RCTCSPD",$JOB,"BILL",ACTION,BILL)=$$TAXID^RCTCSP1(DEBTOR)_"^"_+$EXTRACT(REC,91,102)_"."_$EXTRACT(REC,103,104)
+35 DO CLR19(BILL,1)
+36 QUIT
+37 ;
REC2 ;
+1 NEW REC,KNUM,DEBTNR,DEBTORNB,TAXID,NAME,RCD,HTAXID
+2 SET REC="C2 "_ACTION_"3636001200"_"DM1D "
+3 SET KNUM=$PIECE($PIECE(B0,U,1),"-",2)
SET HTAXID=0
+4 ; PRCA*4.5*350
SET DEBTNR=$$AGDEBTID
SET REC=REC_DEBTNR
+5 SET DEBTORNB=$EXTRACT(SITE,1,3)_$TRANSLATE($JUSTIFY(DEBTOR,12)," ",0)
+6 SET REC=REC_DEBTORNB
+7 SET TAXID=$$TAXID^RCTCSP1(DEBTOR)
if +$GET(RCTCSSCH)
SET HTAXID=TAXID
SET TAXID=$PIECE(RCTCSSCH,U)
+8 SET REC=REC_TAXID_"SSN"
+9 SET NAME=$$NAME^RCTCSP7(+DEBTOR0)
SET NAME=$PIECE(NAME,U)
+10 IF $GET(RCTCSCW)
SET NAME=$EXTRACT(RCTCSSCH,11,115)
+11 SET REC=REC_NAME_$$BLANK(5)_"I"
+12 IF ACTION="U"
IF HTAXID
SET REC=REC_$$BLANK(35)_HTAXID
+13 IF ACTION="L"
Begin DoDot:1
+14 SET REC=REC_$$BLANK(232-$LENGTH(REC))
+15 SET RCD=$PIECE(B15,U,4)
+16 SET REC=REC_$SELECT(RCD="01":"12",RCD="07":"12",RCD="08":"12",RCD="15":"12",RCD="03":"03",RCD="05":"05",RCD="06":"06",1:"12")
End DoDot:1
+17 SET REC=REC_$$BLANK(450-$LENGTH(REC))
+18 SET ^XTMP("RCTCSPD",$JOB,BILL,ACTION,2)=REC
+19 SET $PIECE(^XTMP("RCTCSPD",$JOB,"BILL",ACTION,BILL),U,1)=$$TAXID^RCTCSP1(DEBTOR)
+20 DO CLR19(BILL,2)
+21 QUIT
+22 ;
REC2A ;
+1 NEW REC,KNUM,DEBTNR,DEBTORNB
+2 SET REC="C2A"_ACTION_"3636001200"_"DM1D "
+3 SET KNUM=$PIECE($PIECE(B0,U,1),"-",2)
+4 ; PRCA*4.5*350
SET DEBTNR=$$AGDEBTID
SET REC=REC_DEBTNR
+5 SET DEBTORNB=$EXTRACT(SITE,1,3)_$TRANSLATE($JUSTIFY(DEBTOR,12)," ",0)
+6 SET REC=REC_DEBTORNB
SET REC=REC_$$BLANK(3)
SET REC=REC_GNDR
+7 SET REC=REC_$$DATE8($PIECE(DEMCS,U,2))
SET REC=REC_$$BLANK(450-$LENGTH(REC))
+8 SET ^XTMP("RCTCSPD",$JOB,BILL,ACTION,"2A")=REC
+9 SET $PIECE(^XTMP("RCTCSPD",$JOB,"BILL",ACTION,BILL),U,1)=$$TAXID^RCTCSP1(DEBTOR)
+10 DO CLR19(BILL,3)
+11 QUIT
AGDEBTID() ; Return Agency Debt ID accoring to new logic PRCA*4.5*350
+1 ; Input: SITE,KNUM,BILL,B15
+2 NEW TRAIL
SET TRAIL=$PIECE($GET(^PRCA(430,BILL,21)),U,2)
+3 IF TRAIL=""
QUIT $EXTRACT(SITE,1,3)_$$LJZF(KNUM,7)_$TRANSLATE($JUSTIFY(BILL,20)," ",0)
+4 QUIT $EXTRACT(SITE,1,3)_$$LJZF(KNUM,7)_$TRANSLATE($JUSTIFY(BILL,18)," ",0)_TRAIL
+5 ;
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) ;changes amount to zero filled, right justified
+1 if X<0
SET X=-X
+2 SET X=$TRANSLATE($JUSTIFY(X,0,2),".")
+3 SET X=$EXTRACT("000000000000",1,14-$LENGTH(X))_X
+4 QUIT X
+5 ;
BLANK(X) ;returns 'x' blank spaces
+1 NEW BLANK
+2 SET BLANK=""
SET $PIECE(BLANK," ",X+1)=""
+3 QUIT BLANK
+4 ;
NOW() ;compiles current date,time
+1 NEW X,Y,%,%H
+2 SET %H=$HOROLOG
DO YX^%DTC
+3 QUIT Y
+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) ;x left justified, y space filled
+1 SET X=$EXTRACT(X,1,Y)
+2 SET X=X_$$BLANK(Y-$LENGTH(X))
+3 QUIT X
+4 ;
LJZF(X,Y) ;x left justified, y zero filled
+1 SET X=X_"0000000000"
+2 SET X=$EXTRACT(X,1,Y)
+3 QUIT X
+4 ;
RECALL(BILL) ; set the recall flag
+1 SET $PIECE(^PRCA(430,BILL,15),U,2)=1
+2 QUIT
+3 ;
CLR19(BILL,X) ; clear the send flag
+1 SET $PIECE(^PRCA(430,BILL,19),U,X)=""
+2 QUIT
+3 ;
