RCTCSP3S ;ALBANY/BDB-CROSS-SERVICING DPN SERVER ;03/15/14 3:34 PM
;;4.5;Accounts Receivable;**301,336**;Mar 20, 1995;Build 45
;;Per VA Directive 6402, this routine should not be modified.
;
;PRCA*4.5*336 Use a different work file ^XTMP('RCTCSP3SW') to avoid
; and contention with weekly CS batch run RCTCSPD.
;
READ ;READS MESSAGE INTO TEMPORARY GLOBAL
N FDT S FDT=0
K ^XTMP("RCTCSP3S",$J)
S ^XTMP("RCTCSP3S",0)=$$FMADD^XLFDT(DT,3)_"^"_DT
K ^XTMP("RCTCSP3SW",$J)
S ^XTMP("RCTCSP3SW",0)=$$FMADD^XLFDT(DT,3)_"^"_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("RCTCSP3S",$J,"READ",FDT,XMPOS)=XMRG
G READ1
;
READQ K XMA,XMER,XMREC,XMPOS,XMRG
N REC
S LN=0
F S LN=$O(^XTMP("RCTCSP3S",$J,"READ",FDT,LN)) Q:LN="" S REC=$G(^(LN)) D
.S TYPE=$E(REC,1)
.I TYPE="H" K TYPE Q
.I TYPE="C" D DPN K TYPE Q
.I TYPE="Z" K TYPE Q
.Q
;
D LTRPDT
D ERRCD
Q
;
LTRPDT ;sends mailman message to user for due process notification letter print date
Q:'$D(^XTMP("RCTCSP3SW",$J,"L"))
S XMDUZ="AR PACKAGE",XMY("G.TCSP")=""
N TCT,TDEB,TBIL,TBCNT
S XMSUB="CS DUE PROCESS NOTIFICATION LETTERS "_$E(DT,4,5)_"/"_$E(DT,6,7)_"/"_$E(DT,2,3)
S ^XTMP("RCTCSP3SW",$J,"LTR",1)="The following Debt Due Process Notification letters have been printed."
S ^XTMP("RCTCSP3SW",$J,"LTR",2)=""
S ^XTMP("RCTCSP3SW",$J,"LTR",3)="Name Bill # DPN File Date Letter Print Date"
S ^XTMP("RCTCSP3SW",$J,"LTR",4)="---- ------ ------------- -----------------"
S TDEB="",TBCNT=0,TCT=4
F S TDEB=$O(^XTMP("RCTCSP3SW",$J,"L",TDEB)) Q:TDEB="" D
.S TBIL=""
.F S TBIL=$O(^XTMP("RCTCSP3SW",$J,"L",TDEB,TBIL)) Q:TBIL="" S TBCNT=TBCNT+1 D
..S TCT=TCT+1
..S ^XTMP("RCTCSP3SW",$J,"LTR",TCT)=^XTMP("RCTCSP3SW",$J,"L",TDEB,TBIL)
S TCT=TCT+1
S ^XTMP("RCTCSP3SW",$J,"LTR",TCT)="Total records: "_TBCNT
S XMTEXT="^XTMP(""RCTCSP3SW"","_$J_",""LTR"","
D ^XMD K XMDUZ,XMSUB,XMTEXT,XMY
LTRQ Q
;
ERRCD ;sends mailman message to user for due process notification letter print date
Q:'$D(^XTMP("RCTCSP3SW",$J,"E"))
S XMDUZ="AR PACKAGE",XMY("G.TCSP")=""
N TCT,TDEB,TBIL,TBCNT
S XMSUB="CS DUE PROCESS NOTIFICATION REJECT RECORDS "_$E(DT,4,5)_"/"_$E(DT,6,7)_"/"_$E(DT,2,3)
S ^XTMP("RCTCSP3SW",$J,"ERRCD",1)="The following Debt Due Process Notification file records have been rejected."
S ^XTMP("RCTCSP3SW",$J,"ERRCD",2)=""
S ^XTMP("RCTCSP3SW",$J,"ERRCD",3)="Name Bill # DPN File Date Reject Error Codes"
S ^XTMP("RCTCSP3SW",$J,"ERRCD",4)="---- ------ ------------- ------------------"
S TDEB="",TBCNT=0,TCT=4
F S TDEB=$O(^XTMP("RCTCSP3SW",$J,"E",TDEB)) Q:TDEB="" D
.S TBIL=""
.F S TBIL=$O(^XTMP("RCTCSP3SW",$J,"E",TDEB,TBIL)) Q:TBIL="" S TBCNT=TBCNT+1 D
..S TCT=TCT+1
..S ^XTMP("RCTCSP3SW",$J,"ERRCD",TCT)=^XTMP("RCTCSP3SW",$J,"E",TDEB,TBIL)
S TCT=TCT+1
S ^XTMP("RCTCSP3SW",$J,"ERRCD",TCT)="Total records: "_TBCNT
S XMTEXT="^XTMP(""RCTCSP3SW"","_$J_",""ERRCD"","
D ^XMD
ERRQ Q
;
DPN ;due process notification record
N BILL,X,ERRCD,ERRCDD,Y,PRNTDT,DEBTOR,DEBTORN,REC1
S BILL=+$E(REC,2,11)
S X=$E(REC,221,228) I +X D Q ;check for a letter print date
.D ^%DT S PRNTDT=Y
.S $P(^PRCA(430,BILL,20),U,5)=PRNTDT ;set the aitc print date
.S DEBTOR=$P($G(^PRCA(430,BILL,0)),U,9)
.I DEBTOR D
..S DEBTORN=$$GET1^DIQ(430,BILL,9)
..S DEBTORN=$E(DEBTORN,1,31)
..S REC1=DEBTORN_$$BLANK(33-$L(DEBTORN))_$$LJSF($P($P(^PRCA(430,BILL,0),U,1),"-",2),7)_" "
..S REC1=REC1_$$LJSF($$FMTE^XLFDT($P($G(^PRCA(430,BILL,20)),U,4)),13)_" "_$$LJSF($$FMTE^XLFDT(PRNTDT),13)
..S ^XTMP("RCTCSP3SW",$J,"L",DEBTOR,BILL)=REC1
.S $P(^PRCA(430,BILL,20),U,6,8)="^^" ;clear the error codes
S ERRCD=$E(REC,231,248) I ERRCD'?1" "." " D Q ;check for error codes
.S DEBTOR=$P($G(^PRCA(430,BILL,0)),U,9)
.I DEBTOR D
..N ERRCDD,RCJ
..S DEBTORN=$$GET1^DIQ(430,BILL,9)
..S DEBTORN=$E(DEBTORN,1,23)
..S REC1=DEBTORN_$$BLANK(25-$L(DEBTORN))_$$LJSF($P($P(^PRCA(430,BILL,0),U,1),"-",2),7)_" "
..S REC1=REC1_$$LJSF($$FMTE^XLFDT($P($G(^PRCA(430,BILL,20)),U,4)),13)_" "
..S ERRCDD=$E(ERRCD,1,2)
..F RCJ=3:2:17 Q:$E(ERRCD,RCJ)'?1AN S ERRCDD=ERRCDD_","_$E(ERRCD,RCJ,RCJ+1)
..S REC1=REC1_$$LJSF(ERRCDD,27)
..S ^XTMP("RCTCSP3SW",$J,"E",DEBTOR,BILL)=REC1
.S $P(^PRCA(430,BILL,20),U,7)=DT ;set the aitc error date
.S $P(^PRCA(430,BILL,20),U,8)=ERRCD ;set the aitc error codes
.S $P(^PRCA(430,BILL,20),U,4,6)="^^" ;clear the request date, referral date, and the print date
Q
;
DATE8(X) ;changes fileman date into 8 digit date yyyymmdd
I +X S X=X+17000000
S X=$E(X,1,8)
Q X
;
AMOUNT(X) ;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
;
AMOUNT9(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,9-$L(X))_X
Q X
;
BLANK(X) ;returns 'x' blank spaces
N BLANK
S BLANK="",$P(BLANK," ",X+1)=""
Q BLANK
;
RJZF(X,Y) ;right justify zero fill width Y
S X=$E("000000000000",1,Y-$L(X))_X
Q X
;
LJSF(X,Y) ;left justified space filled
S X=$E(X,1,Y)
S X=X_$$BLANK(Y-$L(X))
Q X
;
TAXID(DEBTOR) ;computes TAXID to place on documents
N TAXID,DIC,DA,DR,DIQ
S TAXID=$$SSN^RCFN01(DEBTOR)
S TAXID=$$LJSF(TAXID,9)
Q TAXID
;
JD() ; returns today's Julian date YDOY
N XMDDD,XMNOW,XMDT
S XMNOW=$$NOW^XLFDT
S XMDT=$E(XMNOW,1,7)
S XMDDD=$$RJ^XLFSTR($$FMDIFF^XLFDT(XMDT,$E(XMDT,1,3)_"0101",1)+1,3,"0")
Q $E(DT,3)_XMDDD
;
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
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRCTCSP3S 5990 printed Nov 22, 2024@16:59:01 Page 2
RCTCSP3S ;ALBANY/BDB-CROSS-SERVICING DPN SERVER ;03/15/14 3:34 PM
+1 ;;4.5;Accounts Receivable;**301,336**;Mar 20, 1995;Build 45
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;
+4 ;PRCA*4.5*336 Use a different work file ^XTMP('RCTCSP3SW') to avoid
+5 ; and contention with weekly CS batch run RCTCSPD.
+6 ;
READ ;READS MESSAGE INTO TEMPORARY GLOBAL
+1 NEW FDT
SET FDT=0
+2 KILL ^XTMP("RCTCSP3S",$JOB)
+3 SET ^XTMP("RCTCSP3S",0)=$$FMADD^XLFDT(DT,3)_"^"_DT
+4 KILL ^XTMP("RCTCSP3SW",$JOB)
+5 SET ^XTMP("RCTCSP3SW",0)=$$FMADD^XLFDT(DT,3)_"^"_DT
+6 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("RCTCSP3S",$JOB,"READ",FDT,XMPOS)=XMRG
+3 GOTO READ1
+4 ;
READQ KILL XMA,XMER,XMREC,XMPOS,XMRG
+1 NEW REC
+2 SET LN=0
+3 FOR
SET LN=$ORDER(^XTMP("RCTCSP3S",$JOB,"READ",FDT,LN))
if LN=""
QUIT
SET REC=$GET(^(LN))
Begin DoDot:1
+4 SET TYPE=$EXTRACT(REC,1)
+5 IF TYPE="H"
KILL TYPE
QUIT
+6 IF TYPE="C"
DO DPN
KILL TYPE
QUIT
+7 IF TYPE="Z"
KILL TYPE
QUIT
+8 QUIT
End DoDot:1
+9 ;
+10 DO LTRPDT
+11 DO ERRCD
+12 QUIT
+13 ;
LTRPDT ;sends mailman message to user for due process notification letter print date
+1 if '$DATA(^XTMP("RCTCSP3SW",$JOB,"L"))
QUIT
+2 SET XMDUZ="AR PACKAGE"
SET XMY("G.TCSP")=""
+3 NEW TCT,TDEB,TBIL,TBCNT
+4 SET XMSUB="CS DUE PROCESS NOTIFICATION LETTERS "_$EXTRACT(DT,4,5)_"/"_$EXTRACT(DT,6,7)_"/"_$EXTRACT(DT,2,3)
+5 SET ^XTMP("RCTCSP3SW",$JOB,"LTR",1)="The following Debt Due Process Notification letters have been printed."
+6 SET ^XTMP("RCTCSP3SW",$JOB,"LTR",2)=""
+7 SET ^XTMP("RCTCSP3SW",$JOB,"LTR",3)="Name Bill # DPN File Date Letter Print Date"
+8 SET ^XTMP("RCTCSP3SW",$JOB,"LTR",4)="---- ------ ------------- -----------------"
+9 SET TDEB=""
SET TBCNT=0
SET TCT=4
+10 FOR
SET TDEB=$ORDER(^XTMP("RCTCSP3SW",$JOB,"L",TDEB))
if TDEB=""
QUIT
Begin DoDot:1
+11 SET TBIL=""
+12 FOR
SET TBIL=$ORDER(^XTMP("RCTCSP3SW",$JOB,"L",TDEB,TBIL))
if TBIL=""
QUIT
SET TBCNT=TBCNT+1
Begin DoDot:2
+13 SET TCT=TCT+1
+14 SET ^XTMP("RCTCSP3SW",$JOB,"LTR",TCT)=^XTMP("RCTCSP3SW",$JOB,"L",TDEB,TBIL)
End DoDot:2
End DoDot:1
+15 SET TCT=TCT+1
+16 SET ^XTMP("RCTCSP3SW",$JOB,"LTR",TCT)="Total records: "_TBCNT
+17 SET XMTEXT="^XTMP(""RCTCSP3SW"","_$JOB_",""LTR"","
+18 DO ^XMD
KILL XMDUZ,XMSUB,XMTEXT,XMY
LTRQ QUIT
+1 ;
ERRCD ;sends mailman message to user for due process notification letter print date
+1 if '$DATA(^XTMP("RCTCSP3SW",$JOB,"E"))
QUIT
+2 SET XMDUZ="AR PACKAGE"
SET XMY("G.TCSP")=""
+3 NEW TCT,TDEB,TBIL,TBCNT
+4 SET XMSUB="CS DUE PROCESS NOTIFICATION REJECT RECORDS "_$EXTRACT(DT,4,5)_"/"_$EXTRACT(DT,6,7)_"/"_$EXTRACT(DT,2,3)
+5 SET ^XTMP("RCTCSP3SW",$JOB,"ERRCD",1)="The following Debt Due Process Notification file records have been rejected."
+6 SET ^XTMP("RCTCSP3SW",$JOB,"ERRCD",2)=""
+7 SET ^XTMP("RCTCSP3SW",$JOB,"ERRCD",3)="Name Bill # DPN File Date Reject Error Codes"
+8 SET ^XTMP("RCTCSP3SW",$JOB,"ERRCD",4)="---- ------ ------------- ------------------"
+9 SET TDEB=""
SET TBCNT=0
SET TCT=4
+10 FOR
SET TDEB=$ORDER(^XTMP("RCTCSP3SW",$JOB,"E",TDEB))
if TDEB=""
QUIT
Begin DoDot:1
+11 SET TBIL=""
+12 FOR
SET TBIL=$ORDER(^XTMP("RCTCSP3SW",$JOB,"E",TDEB,TBIL))
if TBIL=""
QUIT
SET TBCNT=TBCNT+1
Begin DoDot:2
+13 SET TCT=TCT+1
+14 SET ^XTMP("RCTCSP3SW",$JOB,"ERRCD",TCT)=^XTMP("RCTCSP3SW",$JOB,"E",TDEB,TBIL)
End DoDot:2
End DoDot:1
+15 SET TCT=TCT+1
+16 SET ^XTMP("RCTCSP3SW",$JOB,"ERRCD",TCT)="Total records: "_TBCNT
+17 SET XMTEXT="^XTMP(""RCTCSP3SW"","_$JOB_",""ERRCD"","
+18 DO ^XMD
ERRQ QUIT
+1 ;
DPN ;due process notification record
+1 NEW BILL,X,ERRCD,ERRCDD,Y,PRNTDT,DEBTOR,DEBTORN,REC1
+2 SET BILL=+$EXTRACT(REC,2,11)
+3 ;check for a letter print date
SET X=$EXTRACT(REC,221,228)
IF +X
Begin DoDot:1
+4 DO ^%DT
SET PRNTDT=Y
+5 ;set the aitc print date
SET $PIECE(^PRCA(430,BILL,20),U,5)=PRNTDT
+6 SET DEBTOR=$PIECE($GET(^PRCA(430,BILL,0)),U,9)
+7 IF DEBTOR
Begin DoDot:2
+8 SET DEBTORN=$$GET1^DIQ(430,BILL,9)
+9 SET DEBTORN=$EXTRACT(DEBTORN,1,31)
+10 SET REC1=DEBTORN_$$BLANK(33-$LENGTH(DEBTORN))_$$LJSF($PIECE($PIECE(^PRCA(430,BILL,0),U,1),"-",2),7)_" "
+11 SET REC1=REC1_$$LJSF($$FMTE^XLFDT($PIECE($GET(^PRCA(430,BILL,20)),U,4)),13)_" "_$$LJSF($$FMTE^XLFDT(PRNTDT),13)
+12 SET ^XTMP("RCTCSP3SW",$JOB,"L",DEBTOR,BILL)=REC1
End DoDot:2
+13 ;clear the error codes
SET $PIECE(^PRCA(430,BILL,20),U,6,8)="^^"
End DoDot:1
QUIT
+14 ;check for error codes
SET ERRCD=$EXTRACT(REC,231,248)
IF ERRCD'?1" "." "
Begin DoDot:1
+15 SET DEBTOR=$PIECE($GET(^PRCA(430,BILL,0)),U,9)
+16 IF DEBTOR
Begin DoDot:2
+17 NEW ERRCDD,RCJ
+18 SET DEBTORN=$$GET1^DIQ(430,BILL,9)
+19 SET DEBTORN=$EXTRACT(DEBTORN,1,23)
+20 SET REC1=DEBTORN_$$BLANK(25-$LENGTH(DEBTORN))_$$LJSF($PIECE($PIECE(^PRCA(430,BILL,0),U,1),"-",2),7)_" "
+21 SET REC1=REC1_$$LJSF($$FMTE^XLFDT($PIECE($GET(^PRCA(430,BILL,20)),U,4)),13)_" "
+22 SET ERRCDD=$EXTRACT(ERRCD,1,2)
+23 FOR RCJ=3:2:17
if $EXTRACT(ERRCD,RCJ)'?1AN
QUIT
SET ERRCDD=ERRCDD_","_$EXTRACT(ERRCD,RCJ,RCJ+1)
+24 SET REC1=REC1_$$LJSF(ERRCDD,27)
+25 SET ^XTMP("RCTCSP3SW",$JOB,"E",DEBTOR,BILL)=REC1
End DoDot:2
+26 ;set the aitc error date
SET $PIECE(^PRCA(430,BILL,20),U,7)=DT
+27 ;set the aitc error codes
SET $PIECE(^PRCA(430,BILL,20),U,8)=ERRCD
+28 ;clear the request date, referral date, and the print date
SET $PIECE(^PRCA(430,BILL,20),U,4,6)="^^"
End DoDot:1
QUIT
+29 QUIT
+30 ;
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 ;
AMOUNT9(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,9-$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 ;
RJZF(X,Y) ;right justify zero fill width Y
+1 SET X=$EXTRACT("000000000000",1,Y-$LENGTH(X))_X
+2 QUIT X
+3 ;
LJSF(X,Y) ;left justified space filled
+1 SET X=$EXTRACT(X,1,Y)
+2 SET X=X_$$BLANK(Y-$LENGTH(X))
+3 QUIT X
+4 ;
TAXID(DEBTOR) ;computes TAXID to place on documents
+1 NEW TAXID,DIC,DA,DR,DIQ
+2 SET TAXID=$$SSN^RCFN01(DEBTOR)
+3 SET TAXID=$$LJSF(TAXID,9)
+4 QUIT TAXID
+5 ;
JD() ; returns today's Julian date YDOY
+1 NEW XMDDD,XMNOW,XMDT
+2 SET XMNOW=$$NOW^XLFDT
+3 SET XMDT=$EXTRACT(XMNOW,1,7)
+4 SET XMDDD=$$RJ^XLFSTR($$FMDIFF^XLFDT(XMDT,$EXTRACT(XMDT,1,3)_"0101",1)+1,3,"0")
+5 QUIT $EXTRACT(DT,3)_XMDDD
+6 ;
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 ;
