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