RCTCSP7 ;ALBANY/RGB-CROSS - SERVICING TRANSMISSION CONT'D ;08/03/17 3:34 PM
;;4.5;Accounts Receivable;**327,315,336,350,343,417**;Mar 20, 1995;Build 30
;;Per VA Directive 6402, this routine should not be modified.
;
;PRCA*4.5*327 Moved rec code from RCTCSPD to create room
; for batch mods.
;
;PRCA*4.5*336 Set CS call switch for address setup
; Also, ensure that pos 260 & 275 are set
; to 10 spaces for non-numeric phone number
;
;PRCA*4.5*343 Moved NAME subroutine from RCTCSPD to get
; under SACC routine size max
;
;PRCA*4.5*417 Added check for SSN change to send only C2U
; tx and no there transaction for debtor in that
; batch. If there was other activity to send it
; will have go in the next week's batch run.
;
REC2C ;
N REC,KNUM,DEBTNR,DEBTORNB,TAXID,RCDFN,PHONE,ADDRCS
S REC="C2C"_ACTION_"3636001200"_"DM1D "
S KNUM=$P($P(B0,U,1),"-",2)
;S DEBTNR=$E(SITE,1,3)_$$LJZF(KNUM,7)_$TR($J(BILL,20)," ",0),REC=REC_DEBTNR
S DEBTNR=$$AGDEBTID^RCTCSPD,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(DEBTOR)
S REC=REC_TAXID
S REC=REC_"SLFIND"
S REC=REC_$$BLANK(20)
S RCDFN=+DEBTOR0
S REC=REC_$$LJSF($$NAMEFF(RCDFN),60)_"Y"
S ADDRCS=$$ADDR^RCTCSP1(RCDFN,1),PHONE=$P(ADDRCS,U,6) ;PRCA*4.5*336
S REC=REC_$$LJSF($P(ADDRCS,U,1),35)_$$LJSF($P(ADDRCS,U,2),35)_$$LJSF($P(ADDRCS,U,3),15)_$$LJSF($P(ADDRCS,U,4),2)_$$LJSF($P(ADDRCS,U,5),9)
S REC=REC_$$COUNTRY^RCTCSP1A($P(ADDRCS,U,7)) ;COUNTRY label moved due to routine size PRCA*4.5*315/DRF
S REC=REC_"Y"
S REC=REC_$S(+PHONE:"P",1:" ") ;PRCA*4.5*336
S REC=REC_$$LJSF($TR(PHONE,"() -"),10)_$$BLANK(4)
S REC=REC_$S(+PHONE:"Y",1:" ") ;PRCA*4.5*336
S REC=REC_$$BLANK(450-$L(REC))
S ^XTMP("RCTCSPD",$J,BILL,ACTION,"2C")=REC
S $P(^XTMP("RCTCSPD",$J,"BILL",ACTION,BILL),U,1)=$$TAXID(DEBTOR)
D CLR19(BILL,4)
Q
;
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
;
BLANK(X) ;returns 'x' blank spaces
N BLANK
S BLANK="",$P(BLANK," ",X+1)=""
Q BLANK
;
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
;
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,X,Y)
Q X
;
CLR19(BILL,X) ; clear the send flag
S $P(^PRCA(430,BILL,19),U,X)=""
;
NAME(DFN) ;returns name for document and name in file - called by RCTCSPD
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=$$LJ^XLFSTR($E(LN,1,35),35)_$$LJ^XLFSTR($E(FN,1,35),35)_$$LJ^XLFSTR($E(MN,1,35),35)
Q DOCNM
;
SSCHK(DEBTOR) ;check for TCSP debtor SS# change PRCA*4.5*417
N PRCABILL,TAXID,B0,ACTION,RCTCSSCH
S PRCABILL=0,RCTCSCW=0,XX=0,RCTCSSCH=""
S TAXID=$$TAXID^RCTCSP1(DEBTOR) I $L(TAXID)'=9 G SQ
F S PRCABILL=$O(^PRCA(430,"C",DEBTOR,PRCABILL)) Q:'PRCABILL D
.I '$G(^PRCA(430,PRCABILL,16)) Q
.I TAXID=$P(^PRCA(430,PRCABILL,16),U) Q
.S RCTCSSCH=^PRCA(430,PRCABILL,16)
.S DA=PRCABILL,DR="161///"_TAXID,DIE="^PRCA(430," D ^DIE
.Q:RCTCSCW=1
CHK .S ACTION="U",B0=^PRCA(430,PRCABILL,0),BILL=PRCABILL,RCTCSCW=1
.D REC2^RCTCSPD
SQ Q RCTCSCW
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRCTCSP7 3833 printed Apr 09, 2024@20:44:17 Page 2
RCTCSP7 ;ALBANY/RGB-CROSS - SERVICING TRANSMISSION CONT'D ;08/03/17 3:34 PM
+1 ;;4.5;Accounts Receivable;**327,315,336,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 Moved rec code from RCTCSPD to create room
+5 ; for batch mods.
+6 ;
+7 ;PRCA*4.5*336 Set CS call switch for address setup
+8 ; Also, ensure that pos 260 & 275 are set
+9 ; to 10 spaces for non-numeric phone number
+10 ;
+11 ;PRCA*4.5*343 Moved NAME subroutine from RCTCSPD to get
+12 ; under SACC routine size max
+13 ;
+14 ;PRCA*4.5*417 Added check for SSN change to send only C2U
+15 ; tx and no there transaction for debtor in that
+16 ; batch. If there was other activity to send it
+17 ; will have go in the next week's batch run.
+18 ;
REC2C ;
+1 NEW REC,KNUM,DEBTNR,DEBTORNB,TAXID,RCDFN,PHONE,ADDRCS
+2 SET REC="C2C"_ACTION_"3636001200"_"DM1D "
+3 SET KNUM=$PIECE($PIECE(B0,U,1),"-",2)
+4 ;S DEBTNR=$E(SITE,1,3)_$$LJZF(KNUM,7)_$TR($J(BILL,20)," ",0),REC=REC_DEBTNR
+5 ; PRCA*4.5*350
SET DEBTNR=$$AGDEBTID^RCTCSPD
SET REC=REC_DEBTNR
+6 SET DEBTORNB=$EXTRACT(SITE,1,3)_$TRANSLATE($JUSTIFY(DEBTOR,12)," ",0)
+7 SET REC=REC_DEBTORNB
+8 SET TAXID=$$TAXID(DEBTOR)
+9 SET REC=REC_TAXID
+10 SET REC=REC_"SLFIND"
+11 SET REC=REC_$$BLANK(20)
+12 SET RCDFN=+DEBTOR0
+13 SET REC=REC_$$LJSF($$NAMEFF(RCDFN),60)_"Y"
+14 ;PRCA*4.5*336
SET ADDRCS=$$ADDR^RCTCSP1(RCDFN,1)
SET PHONE=$PIECE(ADDRCS,U,6)
+15 SET REC=REC_$$LJSF($PIECE(ADDRCS,U,1),35)_$$LJSF($PIECE(ADDRCS,U,2),35)_$$LJSF($PIECE(ADDRCS,U,3),15)_$$LJSF($PIECE(ADDRCS,U,4),2)_$$LJSF($PIECE(ADDRCS,U,5),9)
+16 ;COUNTRY label moved due to routine size PRCA*4.5*315/DRF
SET REC=REC_$$COUNTRY^RCTCSP1A($PIECE(ADDRCS,U,7))
+17 SET REC=REC_"Y"
+18 ;PRCA*4.5*336
SET REC=REC_$SELECT(+PHONE:"P",1:" ")
+19 SET REC=REC_$$LJSF($TRANSLATE(PHONE,"() -"),10)_$$BLANK(4)
+20 ;PRCA*4.5*336
SET REC=REC_$SELECT(+PHONE:"Y",1:" ")
+21 SET REC=REC_$$BLANK(450-$LENGTH(REC))
+22 SET ^XTMP("RCTCSPD",$JOB,BILL,ACTION,"2C")=REC
+23 SET $PIECE(^XTMP("RCTCSPD",$JOB,"BILL",ACTION,BILL),U,1)=$$TAXID(DEBTOR)
+24 DO CLR19(BILL,4)
+25 QUIT
+26 ;
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 ;
BLANK(X) ;returns 'x' blank spaces
+1 NEW BLANK
+2 SET BLANK=""
SET $PIECE(BLANK," ",X+1)=""
+3 QUIT BLANK
+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 ;
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,X,Y)
+3 QUIT X
+4 ;
CLR19(BILL,X) ; clear the send flag
+1 SET $PIECE(^PRCA(430,BILL,19),U,X)=""
+2 ;
NAME(DFN) ;returns name for document and name in file - called by RCTCSPD
+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=$$LJ^XLFSTR($EXTRACT(LN,1,35),35)_$$LJ^XLFSTR($EXTRACT(FN,1,35),35)_$$LJ^XLFSTR($EXTRACT(MN,1,35),35)
+9 QUIT DOCNM
+10 ;
SSCHK(DEBTOR) ;check for TCSP debtor SS# change PRCA*4.5*417
+1 NEW PRCABILL,TAXID,B0,ACTION,RCTCSSCH
+2 SET PRCABILL=0
SET RCTCSCW=0
SET XX=0
SET RCTCSSCH=""
+3 SET TAXID=$$TAXID^RCTCSP1(DEBTOR)
IF $LENGTH(TAXID)'=9
GOTO SQ
+4 FOR
SET PRCABILL=$ORDER(^PRCA(430,"C",DEBTOR,PRCABILL))
if 'PRCABILL
QUIT
Begin DoDot:1
+5 IF '$GET(^PRCA(430,PRCABILL,16))
QUIT
+6 IF TAXID=$PIECE(^PRCA(430,PRCABILL,16),U)
QUIT
+7 SET RCTCSSCH=^PRCA(430,PRCABILL,16)
+8 SET DA=PRCABILL
SET DR="161///"_TAXID
SET DIE="^PRCA(430,"
DO ^DIE
+9 if RCTCSCW=1
QUIT
CHK SET ACTION="U"
SET B0=^PRCA(430,PRCABILL,0)
SET BILL=PRCABILL
SET RCTCSCW=1
+1 DO REC2^RCTCSPD
End DoDot:1
SQ QUIT RCTCSCW
