RCTCSPRS ;ALBANY/BDB - CROSS-SERVICING (RECONCILIATION SERVER);02/19/14 3:21 PM
;;4.5;Accounts Receivable;**301,315,336**;Mar 20, 1995;Build 45
;;Per VA Directive 6402, this routine should not be modified.
;
;Program to process reconciliation server messages from AITC
;
;PRCA*4.5*336 Use a different work file ^XTMP('RCTCSPRSW') to avoid
; any contention with weekly CS batch run RCTCSPD.
; Also, the clearing of the CS flag for debtor when
; no longer having any CS bills has been REMOVED.
;
READ ;READS MESSAGE INTO TEMPORARY GLOBAL
N FDT,RDNODE S FDT=0
K ^XTMP("RCTCSPDW",$J) ;PRCA*4.5*336
;New report for claims returned from treasury PRCA*4.5*315
S ^XTMP("RCTCSP5 - "_DT,0)=$$FMADD^XLFDT(DT,57)_"^"_DT_"^"_"Treasury Cross-Servicing IAI Report" ; Maintain this entry for 57 days
S RDNODE=$NA(^XTMP("RCTCSP5 - "_DT))
;
S XMA=0
READ1 X XMREC I $D(XMER) G:XMER<0 READQ
I $E(XMRG,1)="H" S FDT=$E(XMRG,2,9)
S ^XTMP("RCTCSPRS",$J,"READ",FDT,XMPOS)=XMRG
G READ1
;
READQ K XMA,XMER,XMREC,XMPOS,XMRG
N TYPE,VALC,VFASTCD,VSTTN,VSITE,LN,REC,REC1,REC2
S VALC="36001200"
S VFASTCD="36"
S VSTTN="DM1D "
S VSITE=$E($$SITE^RCMSITE(),1,3)
S LN=0
F S LN=$O(^XTMP("RCTCSPRS",$J,"READ",FDT,LN)) Q:LN="" S REC1=$G(^(LN)),LN=LN+1,REC2=$G(^(LN)),REC=$E(REC1,1,225)_$E(REC2,1,225) D
.S TYPE=$E(REC,1,2)
.I TYPE["H" D HDR Q
.I TYPE="A1" D A1 Q
.I TYPE="C1" Q
.I TYPE="R1" D R1 Q
.I TYPE="R2" D R2 Q
.I TYPE["Z" K TYPE Q
.Q
;
TRDT ;sends mailman message to user for returned debts
Q:'$D(^XTMP("RCTCSPDW",$J,"TRDTRDB"))
S XMDUZ="AR PACKAGE",XMY("G.TCSP")=""
N TCT1,TDEB1,TDEB10,TBIL1,TSP1,FST1,TBCNT,TTXT1
S XMSUB="CS QUALIFIED/RETURNED DEBTS "_$E(DT,4,5)_"/"_$E(DT,6,7)_"/"_$E(DT,2,3)
S ^XTMP("RCTCSPDW",$J,"TRDT",1)="The following Debtors and Debts were Returned by Reconciliation."
S ^XTMP("RCTCSPDW",$J,"TRDT",2)=""
S ^XTMP("RCTCSPDW",$J,"TRDT",3)="Name Bill # Returned Date Closed Date"
S ^XTMP("RCTCSPDW",$J,"TRDT",4)="---- ------ -------- ---- ------ ----"
S TCT1=5,TSP1=0,TDEB1="",TBCNT=0
F S TDEB1=$O(^XTMP("RCTCSPDW",$J,"TRDTRDB",TDEB1)) Q:TDEB1="" D
.S FST1=1,TBIL1=""
.I FST1,TCT1'=5 S ^XTMP("RCTCSPDW",$J,"TRDT",TCT1)="",TCT1=TCT1+1,TSP1=TSP1+1
.F S TBIL1=$O(^XTMP("RCTCSPDW",$J,"TRDTRDB",TDEB1,TBIL1)) Q:TBIL1="" S TBCNT=TBCNT+1 D
..S TDEB10=$S(FST1:TDEB1,1:""),TTXT1=""
..F S TTXT1=$O(^XTMP("RCTCSPDW",$J,"TRDTRDB",TDEB1,TBIL1,TTXT1)) Q:TTXT1="" S ^XTMP("RCTCSPDW",$J,"TRDT",TCT1)=^XTMP("RCTCSPDW",$J,"TRDTRDB",TDEB1,TBIL1,TTXT1) S TCT1=TCT1+1
..S TCT1=TCT1+1,FST1=0
S ^XTMP("RCTCSPDW",$J,"TRDT",TCT1)="Total records: "_TBCNT
S XMTEXT="^XTMP(""RCTCSPDW"","_$J_",""TRDT"","
D ^XMD K XMDUZ,XMSUB,XMTEXT,XMY
K ^XTMP("RCTCSPDW",$J,"TRDT")
TRDTQ Q
;
HDR ; header record
S TFASTCD=$E(REC,10,11),TALC=$E(REC,12,19) ;repeated on r1 AND r2
Q
;
A1 ;active debt record
N TFASTCD,TALC,TSTTN,TDBTID,TSITE,BILL,B0,DEBTOR
S TFASTCD=$E(REC,3,4),TALC=$E(REC,5,12),TSTTN=$E(REC,13,17),TDBTID=$E(REC,18,47),TRDT=$E(REC,58,65)
I TFASTCD'=VFASTCD D NPMSG("FASTCD",TFASTCD,VFASTCD) Q
I TALC'=VALC D NPMSG("ALC",TALC,VALC) Q
I TSTTN'=VSTTN D NPMSG("STATION",TSTTN,VSTTN)
S TSITE=$E(TDBTID,1,3) I TSITE'=VSITE D NPMSG("SITE",TSITE,VSITE) Q
S BILL=+$E(TDBTID,12,30) ;BILL = IEN
S B0=$G(^PRCA(430,BILL,0))
S DEBTOR=+$P(B0,U,9)
;PRCA*4.5*315 set data for IAI report (^RCTCSP5)
I DEBTOR,BILL S @RDNODE@(DEBTOR,BILL)="" ;set to debtor then bill IEN for sorting the IAI report
Q
;
R1 ;returned debt record
N TFASTCD,TALC,TSTTN,TDBTID,TRDT,TSITE,BILLNO,BILL,B0,B4,B6,B7,B9,B14,B15,B16,DEBTOR,RJND
S TFASTCD=$E(REC,3,4),TALC=$E(REC,5,12),TSTTN=$E(REC,13,17),TDBTID=$E(REC,18,47),TRDT=$E(REC,58,65)
I TFASTCD'=VFASTCD D NPMSG("FASTCD",TFASTCD,VFASTCD) Q
I TALC'=VALC D NPMSG("ALC",TALC,VALC) Q
I TSTTN'=VSTTN D NPMSG("STATION",TSTTN,VSTTN)
S TSITE=$E(TDBTID,1,3) I TSITE'=VSITE D NPMSG("SITE",TSITE,VSITE) Q
S BILLNO=$E(TDBTID,4,10),BILL=+$E(TDBTID,11,30) ;BILL = IEN
S B0=$G(^PRCA(430,BILL,0)),B4=$G(^(4)),B6=$G(^(6)),B7=$G(^(7)),B9=$G(^(9)),B14=$G(^(14)),B15=$G(^(15)),B16=$G(^(16))
S DEBTOR=$P(B0,U,9)
;set comment transaction in 433
D CSPRTR^RCTCSPD5 ;PRCA*4.5*315
;
S RJND=0 F S RJND=$O(^PRCA(430,BILL,18,RJND)) Q:'RJND D
.N DAT
.S DAT=+$G(^PRCA(430,BILL,18,RJND,0))
.I DAT K ^PRCA(430,"AB",DAT,BILL)
K ^PRCA(430,BILL,15),^(16),^(17),^(18),^(19),^(20)
I +TRDT D
.N DNM,DA,DIE,DR
.I $D(^XTMP("RCTCSPDW",$J,"TRDTRDB",DEBTOR,BILL,1)) S $E(^XTMP("RCTCSPDW",$J,"TRDTRDB",DEBTOR,BILL,1),52,63)=$$DTT2E(TRDT) Q
.S DNM=$E($$NAMEFF(+^RCD(340,DEBTOR,0)),1,30),DNM=$$LJSF(DNM,30)
.S ^XTMP("RCTCSPDW",$J,"TRDTRDB",DEBTOR,BILL,1)=$$LJSF(DNM,30)_" "_$$LJSF(BILLNO,7)_" "_$$DTT2E(TRDT)
.S EFFDT=$$HL7TFM^XLFDT(TRDT),REASON="O",COMMENT="BY RECONCILIATION"
.S $P(^PRCA(430,BILL,15),U,7,10)="1^"_EFFDT_U_REASON_U_$G(COMMENT)
.S DIE="^PRCA(430,",DA=BILL
.S DR="301////"_EFFDT ;Returned date
.S DR=DR_";310////"_$P(B16,U,9)
.S DR=DR_";311////"_$P(B16,U,10)
.S DR=DR_";312////"_$P(B15,U,3)
.D ^DIE
K ^PRCA(430,"TCSP",BILL) ;set the bill to not sent to cross-servicing
Q
;
R2 ;returned debtor record
N TFASTCD,TALC,TSTTN,TDBTID,TSITE,TFDA,TDBTORID,TRRSNCD,TCMPIND,TCMPAMT,TCLSDT,TBNKDT,TDTHDT,TDISDT,RJND
S TFASTCD=$E(REC,3,4),TALC=$E(REC,5,12),TSTTN=$E(REC,13,17),TDBTID=$E(REC,18,47),TDBTORID=$E(REC,48,62),TRRSNCD=$E(REC,261,262)
S TCMPIND=$E(REC,263,263),TCMPAMT=$E(REC,264,277),TCLSDT=$E(REC,278,285),TBNKDT=$E(REC,286,293),TDTHDT=$E(REC,294,301),TDISDT=$E(REC,302,309)
I TFASTCD'=VFASTCD D NPMSG("FASTCD",TFASTCD,VFASTCD) Q
I TALC'=VALC D NPMSG("ALC",TALC,VALC) Q
I TSTTN'=VSTTN D NPMSG("STATION",TSTTN,VSTTN)
S TSITE=$E(TDBTID,1,3) I TSITE'=VSITE D NPMSG("SITE",TSITE,VSITE) Q
S BILLNO=$E(TDBTID,4,10),BILL=+$E(TDBTID,11,30)
S B0=$G(^PRCA(430,BILL,0))
S TRRSNCD=$$CLRBLNK(TRRSNCD)
S DEBTOR=$P(B0,U,9)
S RJND=0 F S RJND=$O(^PRCA(430,BILL,18,RJND)) Q:'RJND D
.N DAT
.S DAT=+$G(^PRCA(430,BILL,18,RJND,0))
.I DAT K ^PRCA(430,"AB",DAT,BILL)
K ^PRCA(430,BILL,15),^(16),^(17),^(18),^(19),^(20)
I TRRSNCD]"" D
.N DNM,EFFDT,REASON,COMMENT
.I $D(^XTMP("RCTCSPDW",$J,"TRDTRDB",DEBTOR,BILL,1)) S $E(^XTMP("RCTCSPDW",$J,"TRDTRDB",DEBTOR,BILL,1),68,79)=$S($G(TCLSDT)]"":$$DTT2E(TCLSDT),1:"")
.I '$D(^XTMP("RCTCSPDW",$J,"TRDTRDB",DEBTOR,BILL,1)) D
..S DNM=$E($$NAMEFF(+^RCD(340,DEBTOR,0)),1,30),DNM=$$LJSF(DNM,30),^XTMP("RCTCSPDW",$J,"TRDTRDB",DEBTOR,BILL,1)=DNM_" "_$$LJSF(BILLNO,7)_" "_$S($G(TCLSDT)]"":$$DTT2E(TCLSDT),1:"")
.S DIC="^PRCA(430.5,",DIC(0)="Z",X=TRRSNCD D ^DIC K DIC I +Y>0 D
..S ^XTMP("RCTCSPDW",$J,"TRDTRDB",DEBTOR,BILL,2)=" "_$P(Y(0),U,2)
..S $P(^PRCA(430,BILL,30),U,2)=+Y
I TCMPIND="Y" D
.S ^XTMP("RCTCSPDW",$J,"TRDTRDB",DEBTOR,BILL,3)=" COMPROMISE, PLEASE WRITE THIS BILL OFF BY THE MANUAL PROCESS."
.S $P(^PRCA(430,BILL,30),U,3)=TCMPIND
.I +TCMPAMT D
..S ^XTMP("RCTCSPDW",$J,"TRDTRDB",DEBTOR,BILL,4)=" COMPROMISED AMOUNT (NOT COLLECTED):"_$J(TCMPAMT/100,9,2)
..S $P(^PRCA(430,BILL,30),U,4)=TCMPAMT/100
I +TBNKDT D
.S ^XTMP("RCTCSPDW",$J,"TRDTRDB",DEBTOR,BILL,5)=" BANKRUPTCY DATE: "_$$DTT2E(TBNKDT)
.S $P(^PRCA(430,BILL,30),U,6)=$$HL7TFM^XLFDT(TBNKDT)
I +TDTHDT D
.S ^XTMP("RCTCSPDW",$J,"TRDTRDB",DEBTOR,BILL,6)=" DATE OF DEATH: "_$$DTT2E(TDTHDT)
.S $P(^PRCA(430,BILL,30),U,7)=$$HL7TFM^XLFDT(TDTHDT)
I +TDISDT D
.S ^XTMP("RCTCSPDW",$J,"TRDTRDB",DEBTOR,BILL,7)=" DATE OF DISSOLUTION: "_$$DTT2E(TDISDT)
.S $P(^PRCA(430,BILL,30),U,8)=$$HL7TFM^XLFDT(TDISDT)
I +TCLSDT D
.S EFFDT=$$HL7TFM^XLFDT(TCLSDT),REASON="O",COMMENT="BY RECONCILIATION"
.S $P(^PRCA(430,BILL,15),U,7,10)="1^"_EFFDT_U_REASON_U_$G(COMMENT)
.S $P(^PRCA(430,BILL,30),U,5)=$$HL7TFM^XLFDT(TCLSDT)
K ^PRCA(430,"TCSP",BILL) ;set the bill to not sent to cross-servicing
S ^XTMP("RCTCSPDW",$J,"TRDTRDB",DEBTOR,BILL,8)=""
Q
;
NPMSG(FLD,TCD,VCD) ;error not processed
Q
;
LJSF(X,Y) ;left justified space filled
S X=$E(X,1,Y)
S X=X_$$BLANK(Y-$L(X))
Q X
;
BLANK(X) ;returns 'x' blank spaces
N BLANK
S BLANK="",$P(BLANK," ",X+1)=""
Q BLANK
;
CLRBLNK(X) ;clear blanks
S X=$TR(X," ","")
Q X
;
NAMEFF(DFN) ;returns name for document and name in file
N FN,LN,MN,NM,DOCNM,VA,VADM
S NM=""
D DEM^VADPT
I $D(VADM) S NM=VADM(1)
S LN=$TR($P(NM,",")," .'-"),MN=$P($P(NM,",",2)," ",2)
I ($E(MN,1,2)="SR")!($E(MN,1,2)="JR")!(MN?2.3"I")!(MN?0.1"I"1"V"1.3"I") S MN=""
S FN=$P($P(NM,",",2)," ")
S DOCNM=LN_" "_FN_" "_MN
Q DOCNM
;
DTT2E(TDT) ;date treasury to external format
Q $$UPPER^VALM1($$FMTE^XLFDT($$HL7TFM^XLFDT(TDT)))
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRCTCSPRS 8798 printed Dec 13, 2024@01:48:58 Page 2
RCTCSPRS ;ALBANY/BDB - CROSS-SERVICING (RECONCILIATION SERVER);02/19/14 3:21 PM
+1 ;;4.5;Accounts Receivable;**301,315,336**;Mar 20, 1995;Build 45
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;
+4 ;Program to process reconciliation server messages from AITC
+5 ;
+6 ;PRCA*4.5*336 Use a different work file ^XTMP('RCTCSPRSW') to avoid
+7 ; any contention with weekly CS batch run RCTCSPD.
+8 ; Also, the clearing of the CS flag for debtor when
+9 ; no longer having any CS bills has been REMOVED.
+10 ;
READ ;READS MESSAGE INTO TEMPORARY GLOBAL
+1 NEW FDT,RDNODE
SET FDT=0
+2 ;PRCA*4.5*336
KILL ^XTMP("RCTCSPDW",$JOB)
+3 ;New report for claims returned from treasury PRCA*4.5*315
+4 ; Maintain this entry for 57 days
SET ^XTMP("RCTCSP5 - "_DT,0)=$$FMADD^XLFDT(DT,57)_"^"_DT_"^"_"Treasury Cross-Servicing IAI Report"
+5 SET RDNODE=$NAME(^XTMP("RCTCSP5 - "_DT))
+6 ;
+7 SET XMA=0
READ1 XECUTE XMREC
IF $DATA(XMER)
if XMER<0
GOTO READQ
+1 IF $EXTRACT(XMRG,1)="H"
SET FDT=$EXTRACT(XMRG,2,9)
+2 SET ^XTMP("RCTCSPRS",$JOB,"READ",FDT,XMPOS)=XMRG
+3 GOTO READ1
+4 ;
READQ KILL XMA,XMER,XMREC,XMPOS,XMRG
+1 NEW TYPE,VALC,VFASTCD,VSTTN,VSITE,LN,REC,REC1,REC2
+2 SET VALC="36001200"
+3 SET VFASTCD="36"
+4 SET VSTTN="DM1D "
+5 SET VSITE=$EXTRACT($$SITE^RCMSITE(),1,3)
+6 SET LN=0
+7 FOR
SET LN=$ORDER(^XTMP("RCTCSPRS",$JOB,"READ",FDT,LN))
if LN=""
QUIT
SET REC1=$GET(^(LN))
SET LN=LN+1
SET REC2=$GET(^(LN))
SET REC=$EXTRACT(REC1,1,225)_$EXTRACT(REC2,1,225)
Begin DoDot:1
+8 SET TYPE=$EXTRACT(REC,1,2)
+9 IF TYPE["H"
DO HDR
QUIT
+10 IF TYPE="A1"
DO A1
QUIT
+11 IF TYPE="C1"
QUIT
+12 IF TYPE="R1"
DO R1
QUIT
+13 IF TYPE="R2"
DO R2
QUIT
+14 IF TYPE["Z"
KILL TYPE
QUIT
+15 QUIT
End DoDot:1
+16 ;
TRDT ;sends mailman message to user for returned debts
+1 if '$DATA(^XTMP("RCTCSPDW",$JOB,"TRDTRDB"))
QUIT
+2 SET XMDUZ="AR PACKAGE"
SET XMY("G.TCSP")=""
+3 NEW TCT1,TDEB1,TDEB10,TBIL1,TSP1,FST1,TBCNT,TTXT1
+4 SET XMSUB="CS QUALIFIED/RETURNED DEBTS "_$EXTRACT(DT,4,5)_"/"_$EXTRACT(DT,6,7)_"/"_$EXTRACT(DT,2,3)
+5 SET ^XTMP("RCTCSPDW",$JOB,"TRDT",1)="The following Debtors and Debts were Returned by Reconciliation."
+6 SET ^XTMP("RCTCSPDW",$JOB,"TRDT",2)=""
+7 SET ^XTMP("RCTCSPDW",$JOB,"TRDT",3)="Name Bill # Returned Date Closed Date"
+8 SET ^XTMP("RCTCSPDW",$JOB,"TRDT",4)="---- ------ -------- ---- ------ ----"
+9 SET TCT1=5
SET TSP1=0
SET TDEB1=""
SET TBCNT=0
+10 FOR
SET TDEB1=$ORDER(^XTMP("RCTCSPDW",$JOB,"TRDTRDB",TDEB1))
if TDEB1=""
QUIT
Begin DoDot:1
+11 SET FST1=1
SET TBIL1=""
+12 IF FST1
IF TCT1'=5
SET ^XTMP("RCTCSPDW",$JOB,"TRDT",TCT1)=""
SET TCT1=TCT1+1
SET TSP1=TSP1+1
+13 FOR
SET TBIL1=$ORDER(^XTMP("RCTCSPDW",$JOB,"TRDTRDB",TDEB1,TBIL1))
if TBIL1=""
QUIT
SET TBCNT=TBCNT+1
Begin DoDot:2
+14 SET TDEB10=$SELECT(FST1:TDEB1,1:"")
SET TTXT1=""
+15 FOR
SET TTXT1=$ORDER(^XTMP("RCTCSPDW",$JOB,"TRDTRDB",TDEB1,TBIL1,TTXT1))
if TTXT1=""
QUIT
SET ^XTMP("RCTCSPDW",$JOB,"TRDT",TCT1)=^XTMP("RCTCSPDW",$JOB,"TRDTRDB",TDEB1,TBIL1,TTXT1)
SET TCT1=TCT1+1
+16 SET TCT1=TCT1+1
SET FST1=0
End DoDot:2
End DoDot:1
+17 SET ^XTMP("RCTCSPDW",$JOB,"TRDT",TCT1)="Total records: "_TBCNT
+18 SET XMTEXT="^XTMP(""RCTCSPDW"","_$JOB_",""TRDT"","
+19 DO ^XMD
KILL XMDUZ,XMSUB,XMTEXT,XMY
+20 KILL ^XTMP("RCTCSPDW",$JOB,"TRDT")
TRDTQ QUIT
+1 ;
HDR ; header record
+1 ;repeated on r1 AND r2
SET TFASTCD=$EXTRACT(REC,10,11)
SET TALC=$EXTRACT(REC,12,19)
+2 QUIT
+3 ;
A1 ;active debt record
+1 NEW TFASTCD,TALC,TSTTN,TDBTID,TSITE,BILL,B0,DEBTOR
+2 SET TFASTCD=$EXTRACT(REC,3,4)
SET TALC=$EXTRACT(REC,5,12)
SET TSTTN=$EXTRACT(REC,13,17)
SET TDBTID=$EXTRACT(REC,18,47)
SET TRDT=$EXTRACT(REC,58,65)
+3 IF TFASTCD'=VFASTCD
DO NPMSG("FASTCD",TFASTCD,VFASTCD)
QUIT
+4 IF TALC'=VALC
DO NPMSG("ALC",TALC,VALC)
QUIT
+5 IF TSTTN'=VSTTN
DO NPMSG("STATION",TSTTN,VSTTN)
+6 SET TSITE=$EXTRACT(TDBTID,1,3)
IF TSITE'=VSITE
DO NPMSG("SITE",TSITE,VSITE)
QUIT
+7 ;BILL = IEN
SET BILL=+$EXTRACT(TDBTID,12,30)
+8 SET B0=$GET(^PRCA(430,BILL,0))
+9 SET DEBTOR=+$PIECE(B0,U,9)
+10 ;PRCA*4.5*315 set data for IAI report (^RCTCSP5)
+11 ;set to debtor then bill IEN for sorting the IAI report
IF DEBTOR
IF BILL
SET @RDNODE@(DEBTOR,BILL)=""
+12 QUIT
+13 ;
R1 ;returned debt record
+1 NEW TFASTCD,TALC,TSTTN,TDBTID,TRDT,TSITE,BILLNO,BILL,B0,B4,B6,B7,B9,B14,B15,B16,DEBTOR,RJND
+2 SET TFASTCD=$EXTRACT(REC,3,4)
SET TALC=$EXTRACT(REC,5,12)
SET TSTTN=$EXTRACT(REC,13,17)
SET TDBTID=$EXTRACT(REC,18,47)
SET TRDT=$EXTRACT(REC,58,65)
+3 IF TFASTCD'=VFASTCD
DO NPMSG("FASTCD",TFASTCD,VFASTCD)
QUIT
+4 IF TALC'=VALC
DO NPMSG("ALC",TALC,VALC)
QUIT
+5 IF TSTTN'=VSTTN
DO NPMSG("STATION",TSTTN,VSTTN)
+6 SET TSITE=$EXTRACT(TDBTID,1,3)
IF TSITE'=VSITE
DO NPMSG("SITE",TSITE,VSITE)
QUIT
+7 ;BILL = IEN
SET BILLNO=$EXTRACT(TDBTID,4,10)
SET BILL=+$EXTRACT(TDBTID,11,30)
+8 SET B0=$GET(^PRCA(430,BILL,0))
SET B4=$GET(^(4))
SET B6=$GET(^(6))
SET B7=$GET(^(7))
SET B9=$GET(^(9))
SET B14=$GET(^(14))
SET B15=$GET(^(15))
SET B16=$GET(^(16))
+9 SET DEBTOR=$PIECE(B0,U,9)
+10 ;set comment transaction in 433
+11 ;PRCA*4.5*315
DO CSPRTR^RCTCSPD5
+12 ;
+13 SET RJND=0
FOR
SET RJND=$ORDER(^PRCA(430,BILL,18,RJND))
if 'RJND
QUIT
Begin DoDot:1
+14 NEW DAT
+15 SET DAT=+$GET(^PRCA(430,BILL,18,RJND,0))
+16 IF DAT
KILL ^PRCA(430,"AB",DAT,BILL)
End DoDot:1
+17 KILL ^PRCA(430,BILL,15),^(16),^(17),^(18),^(19),^(20)
+18 IF +TRDT
Begin DoDot:1
+19 NEW DNM,DA,DIE,DR
+20 IF $DATA(^XTMP("RCTCSPDW",$JOB,"TRDTRDB",DEBTOR,BILL,1))
SET $EXTRACT(^XTMP("RCTCSPDW",$JOB,"TRDTRDB",DEBTOR,BILL,1),52,63)=$$DTT2E(TRDT)
QUIT
+21 SET DNM=$EXTRACT($$NAMEFF(+^RCD(340,DEBTOR,0)),1,30)
SET DNM=$$LJSF(DNM,30)
+22 SET ^XTMP("RCTCSPDW",$JOB,"TRDTRDB",DEBTOR,BILL,1)=$$LJSF(DNM,30)_" "_$$LJSF(BILLNO,7)_" "_$$DTT2E(TRDT)
+23 SET EFFDT=$$HL7TFM^XLFDT(TRDT)
SET REASON="O"
SET COMMENT="BY RECONCILIATION"
+24 SET $PIECE(^PRCA(430,BILL,15),U,7,10)="1^"_EFFDT_U_REASON_U_$GET(COMMENT)
+25 SET DIE="^PRCA(430,"
SET DA=BILL
+26 ;Returned date
SET DR="301////"_EFFDT
+27 SET DR=DR_";310////"_$PIECE(B16,U,9)
+28 SET DR=DR_";311////"_$PIECE(B16,U,10)
+29 SET DR=DR_";312////"_$PIECE(B15,U,3)
+30 DO ^DIE
End DoDot:1
+31 ;set the bill to not sent to cross-servicing
KILL ^PRCA(430,"TCSP",BILL)
+32 QUIT
+33 ;
R2 ;returned debtor record
+1 NEW TFASTCD,TALC,TSTTN,TDBTID,TSITE,TFDA,TDBTORID,TRRSNCD,TCMPIND,TCMPAMT,TCLSDT,TBNKDT,TDTHDT,TDISDT,RJND
+2 SET TFASTCD=$EXTRACT(REC,3,4)
SET TALC=$EXTRACT(REC,5,12)
SET TSTTN=$EXTRACT(REC,13,17)
SET TDBTID=$EXTRACT(REC,18,47)
SET TDBTORID=$EXTRACT(REC,48,62)
SET TRRSNCD=$EXTRACT(REC,261,262)
+3 SET TCMPIND=$EXTRACT(REC,263,263)
SET TCMPAMT=$EXTRACT(REC,264,277)
SET TCLSDT=$EXTRACT(REC,278,285)
SET TBNKDT=$EXTRACT(REC,286,293)
SET TDTHDT=$EXTRACT(REC,294,301)
SET TDISDT=$EXTRACT(REC,302,309)
+4 IF TFASTCD'=VFASTCD
DO NPMSG("FASTCD",TFASTCD,VFASTCD)
QUIT
+5 IF TALC'=VALC
DO NPMSG("ALC",TALC,VALC)
QUIT
+6 IF TSTTN'=VSTTN
DO NPMSG("STATION",TSTTN,VSTTN)
+7 SET TSITE=$EXTRACT(TDBTID,1,3)
IF TSITE'=VSITE
DO NPMSG("SITE",TSITE,VSITE)
QUIT
+8 SET BILLNO=$EXTRACT(TDBTID,4,10)
SET BILL=+$EXTRACT(TDBTID,11,30)
+9 SET B0=$GET(^PRCA(430,BILL,0))
+10 SET TRRSNCD=$$CLRBLNK(TRRSNCD)
+11 SET DEBTOR=$PIECE(B0,U,9)
+12 SET RJND=0
FOR
SET RJND=$ORDER(^PRCA(430,BILL,18,RJND))
if 'RJND
QUIT
Begin DoDot:1
+13 NEW DAT
+14 SET DAT=+$GET(^PRCA(430,BILL,18,RJND,0))
+15 IF DAT
KILL ^PRCA(430,"AB",DAT,BILL)
End DoDot:1
+16 KILL ^PRCA(430,BILL,15),^(16),^(17),^(18),^(19),^(20)
+17 IF TRRSNCD]""
Begin DoDot:1
+18 NEW DNM,EFFDT,REASON,COMMENT
+19 IF $DATA(^XTMP("RCTCSPDW",$JOB,"TRDTRDB",DEBTOR,BILL,1))
SET $EXTRACT(^XTMP("RCTCSPDW",$JOB,"TRDTRDB",DEBTOR,BILL,1),68,79)=$SELECT($GET(TCLSDT)]"":$$DTT2E(TCLSDT),1:"")
+20 IF '$DATA(^XTMP("RCTCSPDW",$JOB,"TRDTRDB",DEBTOR,BILL,1))
Begin DoDot:2
+21 SET DNM=$EXTRACT($$NAMEFF(+^RCD(340,DEBTOR,0)),1,30)
SET DNM=$$LJSF(DNM,30)
SET ^XTMP("RCTCSPDW",$JOB,"TRDTRDB",DEBTOR,BILL,1)=DNM_" "_$$LJSF(BILLNO,7)_" "_$SELECT($GET(TCLSDT)]"":$$DTT2E(TCLSDT),1:"")
End DoDot:2
+22 SET DIC="^PRCA(430.5,"
SET DIC(0)="Z"
SET X=TRRSNCD
DO ^DIC
KILL DIC
IF +Y>0
Begin DoDot:2
+23 SET ^XTMP("RCTCSPDW",$JOB,"TRDTRDB",DEBTOR,BILL,2)=" "_$PIECE(Y(0),U,2)
+24 SET $PIECE(^PRCA(430,BILL,30),U,2)=+Y
End DoDot:2
End DoDot:1
+25 IF TCMPIND="Y"
Begin DoDot:1
+26 SET ^XTMP("RCTCSPDW",$JOB,"TRDTRDB",DEBTOR,BILL,3)=" COMPROMISE, PLEASE WRITE THIS BILL OFF BY THE MANUAL PROCESS."
+27 SET $PIECE(^PRCA(430,BILL,30),U,3)=TCMPIND
+28 IF +TCMPAMT
Begin DoDot:2
+29 SET ^XTMP("RCTCSPDW",$JOB,"TRDTRDB",DEBTOR,BILL,4)=" COMPROMISED AMOUNT (NOT COLLECTED):"_$JUSTIFY(TCMPAMT/100,9,2)
+30 SET $PIECE(^PRCA(430,BILL,30),U,4)=TCMPAMT/100
End DoDot:2
End DoDot:1
+31 IF +TBNKDT
Begin DoDot:1
+32 SET ^XTMP("RCTCSPDW",$JOB,"TRDTRDB",DEBTOR,BILL,5)=" BANKRUPTCY DATE: "_$$DTT2E(TBNKDT)
+33 SET $PIECE(^PRCA(430,BILL,30),U,6)=$$HL7TFM^XLFDT(TBNKDT)
End DoDot:1
+34 IF +TDTHDT
Begin DoDot:1
+35 SET ^XTMP("RCTCSPDW",$JOB,"TRDTRDB",DEBTOR,BILL,6)=" DATE OF DEATH: "_$$DTT2E(TDTHDT)
+36 SET $PIECE(^PRCA(430,BILL,30),U,7)=$$HL7TFM^XLFDT(TDTHDT)
End DoDot:1
+37 IF +TDISDT
Begin DoDot:1
+38 SET ^XTMP("RCTCSPDW",$JOB,"TRDTRDB",DEBTOR,BILL,7)=" DATE OF DISSOLUTION: "_$$DTT2E(TDISDT)
+39 SET $PIECE(^PRCA(430,BILL,30),U,8)=$$HL7TFM^XLFDT(TDISDT)
End DoDot:1
+40 IF +TCLSDT
Begin DoDot:1
+41 SET EFFDT=$$HL7TFM^XLFDT(TCLSDT)
SET REASON="O"
SET COMMENT="BY RECONCILIATION"
+42 SET $PIECE(^PRCA(430,BILL,15),U,7,10)="1^"_EFFDT_U_REASON_U_$GET(COMMENT)
+43 SET $PIECE(^PRCA(430,BILL,30),U,5)=$$HL7TFM^XLFDT(TCLSDT)
End DoDot:1
+44 ;set the bill to not sent to cross-servicing
KILL ^PRCA(430,"TCSP",BILL)
+45 SET ^XTMP("RCTCSPDW",$JOB,"TRDTRDB",DEBTOR,BILL,8)=""
+46 QUIT
+47 ;
NPMSG(FLD,TCD,VCD) ;error not processed
+1 QUIT
+2 ;
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 ;
BLANK(X) ;returns 'x' blank spaces
+1 NEW BLANK
+2 SET BLANK=""
SET $PIECE(BLANK," ",X+1)=""
+3 QUIT BLANK
+4 ;
CLRBLNK(X) ;clear blanks
+1 SET X=$TRANSLATE(X," ","")
+2 QUIT X
+3 ;
NAMEFF(DFN) ;returns name for document and name in file
+1 NEW FN,LN,MN,NM,DOCNM,VA,VADM
+2 SET NM=""
+3 DO DEM^VADPT
+4 IF $DATA(VADM)
SET NM=VADM(1)
+5 SET LN=$TRANSLATE($PIECE(NM,",")," .'-")
SET MN=$PIECE($PIECE(NM,",",2)," ",2)
+6 IF ($EXTRACT(MN,1,2)="SR")!($EXTRACT(MN,1,2)="JR")!(MN?2.3"I")!(MN?0.1"I"1"V"1.3"I")
SET MN=""
+7 SET FN=$PIECE($PIECE(NM,",",2)," ")
+8 SET DOCNM=LN_" "_FN_" "_MN
+9 QUIT DOCNM
+10 ;
DTT2E(TDT) ;date treasury to external format
+1 QUIT $$UPPER^VALM1($$FMTE^XLFDT($$HL7TFM^XLFDT(TDT)))
