- 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 Jan 18, 2025@02:50:07 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 ;