RCTCSP3 ;ALBANY/BDB-CROSS-SERVICING TRANSMISSION ;03/15/14 3:34 PM
;;4.5;Accounts Receivable;**301,315,350**;Mar 20, 1995;Build 66
;;Per VA Directive 6402, this routine should not be modified.
;
Q
;
ENTER ;Entry point from the post initialization
RCCSTUP I '$D(^XTMP("REJCDCONV")) D
. D NOW^%DTC S RCCSTART=%
. S ^XTMP("REJCDCONV","START COMPILE")=RCCSTART
. S ^XTMP("REJCDCONV","STATUS")="RUNNING"
. S ^XTMP("REJCDCONV",0)=$$FMADD^XLFDT(RCCSTART,730)_"^"_RCCSTART
S RCCCMPLT=0 I $G(^XTMP("REJCDCONV","STATUS"))="COMPLETE" S RCCCMPLT=1
AA N DEBTOR
S DEBTOR=0
F S DEBTOR=$O(^PRCA(430,"C",DEBTOR)) Q:DEBTOR'?1N.N D
.N X,RCDFN,DEMCS,DEBTOR0,DEBTOR1,DEBTOR7,BILL
.S DEBTOR0=^RCD(340,DEBTOR,0),DEBTOR1=$G(^(1)),DEBTOR7=$G(^(7))
.S RCDFN=+DEBTOR0
.S DEMCS=$$DEM^RCTCSP1(RCDFN) Q:$E($P(DEMCS,U,3),1,5)="00000"
.Q:+$P(DEMCS,U,4) ;deceased patient
.S BILL=0
.F S BILL=$O(^PRCA(430,"C",DEBTOR,BILL)) Q:BILL'?1N.N D
..N B0,B6,B7,B14,CAT,TOTAL
..S B0=$G(^PRCA(430,BILL,0)),B6=$G(^(6)),B7=$G(^(7)),B14=$G(^(14))
..I 'RCCCMPLT,$D(^PRCA(430,BILL,18)) D REJCODE
..I $D(^PRCA(430,"TCSP",BILL)) Q ;no dpn for cs bills
..Q:'$P(B0,U,2) ;no category
..S CAT=$P($G(^PRCA(430.2,$P(B0,U,2),0)),U,7)
..Q:'CAT
..I ",4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,19,20,21,22,23,25,26,27,28,33,34,35,36,37,38,39,"[(","_CAT_",") Q ;1st party check
..I +$P(B14,U,1) Q ;bill referred to TOP
..S TOTAL=$P(B7,U)+$P(B7,U,2)+$P(B7,U,3)+$P(B7,U,4)+$P(B7,U,5)
..I TOTAL'>0 Q ;total must be greater than zero
..I '$P(B0,U,8) Q ;if no current status
..I $P(B0,U,8)=23 Q ;quit if write-off
..I $P(B0,U,8)=26 Q ;quit if cancelled
..I $P(B0,U,8)=39 Q ;quit if cancellation
..I TOTAL<25 S $P(^PRCA(430,BILL,20),U,3,8)="1^^^^^" ;set dpn flag
..Q
.Q
I RCCCMPLT'=1 D
. D NOW^%DTC S RCCEND=%
. S ^XTMP("REJCDCONV","END REJ CODE CONV")=RCCEND
. S ^XTMP("REJCDCONV","STATUS")="COMPLETE"
Q
;
DUEPROC ; called from rctcspd
N TOTAL
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 ;no dpn record for bills less than $25
I $P($G(DEBTOR3),U,10) Q ;check site delete flag null
I +$P(B12,U,1) Q ;check date bill sent to dmc
I $P(B6,U,4),($P(B6,U,5)="DOJ") Q ;bill referred to doj
I $P(B0,U,8)'=16 Q ;status active
I '$P(B6,U,3) Q ;must have a 3rd letter
D RECDPN ;create a dpn record
Q
;
RECDPN ;
N KNUM,NAME
S REC="C"
S REC=REC_$$RJZF(BILL,10)
S REC=REC_$$TAXID(DEBTOR)
S NAME=$$NAMEFF(+DEBTOR0),NAME=$P(NAME,U)
S REC=REC_$$LJSF(NAME,30)
S RCDFN=+DEBTOR0
S ADDRCS=$$ADDR(RCDFN)
S REC=REC_$$LJSF($P(ADDRCS,U,1),35)_$$LJSF($P(ADDRCS,U,2),35)_$$LJSF($P(ADDRCS,U,3),15)
S REC=REC_$$LJSF($P(ADDRCS,U,8),20)
S REC=REC_$$BLANK(5)
S REC=REC_$$LJSF($P(ADDRCS,U,4),2)_$$LJSF($P(ADDRCS,U,5),9)
S REC=REC_$$COUNTRY^RCTCSP1A($P(ADDRCS,U,7)) ;Changed routine due to SACC size issue PRCA*4.5*315
S TOTAL=$P(B7,U)+$P(B7,U,2)+$P(B7,U,3)+$P(B7,U,4)+$P(B7,U,5)
S REC=REC_$$BLANK(9)
S REC=REC_$$DATE8(+$P(B6,U,21))
S KNUM=$P($P(B0,U,1),"-",2)
S REC=REC_$E(SITE,1,3)_$$LJSF(KNUM,7)
S REC=REC_$$AMOUNT9(TOTAL)
S REC=REC_$$LJSF($P(ADDRCS,U,9),10)
S REC=REC_$S($P(ADDRCS,U,9)="":" ",$P(ADDRCS,U,9)="US":" ",1:"F")
S REC=REC_$$BLANK(250-$L(REC))
S $P(^PRCA(430,BILL,20),U,4)=DT ;set the dpn request date
S $P(^PRCA(430,BILL,20),U,5,8)="^^^" ;clear the print date and error codes
S ^XTMP("RCTCSPDN",$J,BILL,"DPN",1)=REC
S ^XTMP("RCTCSPDN",$J,"BILL","DPN",BILL)=$$TAXID(DEBTOR)_"^"_+$E(REC,201,207)_"."_$E(REC,208,209) ;sends mailman message of documents sent to user
Q
;
COMPILED ;
N RCMSG,BCNTR,REC,RECC,AMOUNT,AMOUNT,RCNTR,ACTION,SEQ,EOF
S BCNTR=0,REC=0,RECC=0,AMOUNT=0,SEQ=0,EOF=0
F S BCNTR=$O(^XTMP("RCTCSPDN",$J,BCNTR)) S:+BCNTR'>0 EOF=1 Q:+BCNTR'>0 D
.I REC>120 D
..D TRAILERD
..D AITCMSGD
..S REC=0,RECC=0
..Q
.S ACTION="DPN"
.I REC=0 D HEADERD
.S RCNTR=1 I $D(^XTMP("RCTCSPDN",$J,BCNTR,ACTION,RCNTR)) D
..S REC=REC+1
..S RECC=RECC+1 ;record count for 'c' records on trailer record
..S ^XTMP("RCTCSPDN",$J,SEQ,"BUILD",REC)=^XTMP("RCTCSPDN",$J,BCNTR,ACTION,RCNTR)_$C(126)
..S AMOUNT=AMOUNT+$E(^XTMP("RCTCSPDN",$J,BCNTR,ACTION,RCNTR),201,209)
..Q
.Q
D TRAILERD
D AITCMSGD
D USRMSGD
Q
;
AITCMSGD ;
N XMY,XMDUZ,XMSUB,XMTEXT,SYSTYP
S SYSTYP=$$PROD^XUPROD(1) ; PRCA*4.5*350
Q:'$D(^XTMP("RCTCSPDN",$J))
S CNTLID=$$JD()_$$RJZF(SEQ,4)
S XMDUZ="AR PACKAGE"
I SYSTYP S XMY("XXX@Q-TPL.DOMAIN.EXT")=""
I 'SYSTYP S XMY("XXX@Q-TXL.DOMAIN.EXT")=""
S XMY("G.TCSP")=""
S XMSUB=SITE_"/DPN TRANSMISSION/BATCH#: "_CNTLID
S XMTEXT="^XTMP(""RCTCSPDN"","_$J_","""_SEQ_""",""BUILD"","
D ^XMD
Q
;
USRMSGD ;sends mailman message of documents sent to user
N XMY,XMDUZ,XMSUB,XMTEXT,X,RCNT,RCDAT1,RCDAT2
Q:'$D(^XTMP("RCTCSPDN",$J))
S ACTION="DPN"
K ^XTMP("RCTCSPDN",$J,"BILL","MSG")
S XMDUZ="AR PACKAGE"
S XMY("G.TCSP")=""
S XMSUB="CS DUE PROCESS"_" SENT ON "_$E(DT,4,5)_"/"_$E(DT,6,7)_"/"_$E(DT,2,3)_" BATCH ID: "_CNTLID
S ^XTMP("RCTCSPDN",$J,"BILL","MSG",1)="Bill# TIN TYPE AMOUNT"
S ^XTMP("RCTCSPDN",$J,"BILL","MSG",2)="----- --- ---- ------"
S X=0,RCNT=2 F S X=$O(^XTMP("RCTCSPDN",$J,"BILL",ACTION,X)) Q:X="" D
.S RCNT=RCNT+1
.S RCDAT1=$P(^XTMP("RCTCSPDN",$J,"BILL",ACTION,X),U,1)
.S RCDAT2=$P(^XTMP("RCTCSPDN",$J,"BILL",ACTION,X),U,2)
.S ^XTMP("RCTCSPDN",$J,"BILL","MSG",RCNT)=$$RJZF($P($G(^PRCA(430,X,0)),U,1),7)_$$BLANK(22)_RCDAT1_" "_ACTION_" "_$S(RCDAT2]"":RCDAT2,1:"")
.Q
S ^XTMP("RCTCSPDN",$J,"BILL","MSG",RCNT+1)="Total Bills: "_(RCNT-2)
S XMTEXT="^XTMP(""RCTCSPDN"","_$J_",""BILL"",""MSG"","
Q:$G(ONEBILL)
D ^XMD
K ^XTMP("RCTCSPDN",$J,"BILL","MSG")
Q
;
;increment batch sequence number, build new header
N RCMSG
S SEQ=SEQ+1
S CNTLID=$$JD()_$$RJZF(SEQ,4)
K ^XTMP("RCTCSPDN",$J,ACTION,"BUILD",SEQ)
S RCMSG="H"_CNTLID_$$BLANK(14)_"3636001200" ;header is record type H
S RCMSG=RCMSG_$$BLANK(250-$L(RCMSG))
S REC=REC+1
S ^XTMP("RCTCSPDN",$J,SEQ,"BUILD",REC)=RCMSG_$C(126)
Q
;
TRAILERD ;
;trailer is type Z record
I REC=0 K ^XTMP("RCTCSPDN",$J,SEQ,"BUILD") Q ;delete batch if no records processed
N RCMSG
S CNTLID=$$JD()_$$RJZF(SEQ,4)
S RCMSG="Z"_$$RJZF(RECC,8)_$$AMOUNT(AMOUNT/100)_CNTLID_$$BLANK(14)_"3636001200"
S RCMSG=RCMSG_$$BLANK(250-$L(RCMSG))
S:EOF $E(RCMSG,229,236)="0001"_$$RJZF(SEQ,4)
S REC=REC+1
S ^XTMP("RCTCSPDN",$J,SEQ,"BUILD",REC)=RCMSG_$C(126)
S REC=0,RECC=0,AMOUNT=0
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, 14 characters
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
;
LJZF(X,Y) ;x left justified, y zero filled
S X=X_"0000000000"
S X=$E(X,X,Y)
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
;
ADDR(RCDFN) ; returns patient file address
N DFN,ADDRCS,STATEIEN,STATEAB,VAPA
S DFN=RCDFN
D ADD^VADPT
S STATEIEN=+VAPA(5),STATEAB=$$GET1^DIQ(5,STATEIEN,1)
S ADDRCS=VAPA(1)_U_VAPA(2)_U_VAPA(4)_U_STATEAB_U_VAPA(6)_U_VAPA(8)_U_+VAPA(25)_U_VAPA(23)_U_VAPA(24) ;25-country,23-province,24-postal code
I $L(DEBTOR1)>0 I $P(DEBTOR1,U,1,5)'?1"^"."^" D
.N ADDR340
.S ADDR340=$P($$DADD^RCAMADD(DEBTOR),U,1,7)_"^"_1
.S ADDR340=$P(ADDR340,U,1,2)_"^"_$P(ADDR340,U,4,99)
.I $P(ADDR340,U,6)="" S $P(ADDR340,U,6)=$P(ADDRCS,U,6)
.S ADDRCS=ADDR340
Q ADDRCS
;
REJCODE ;Converts AITC reject codes in reject multiple to pointer to file 348.5
N RRI,REJI,REJCD,HREJREC,REJREC S RRI=0
REJA S RRI=$O(^PRCA(430,BILL,18,RRI)) Q:'RRI
S REJREC=$G(^PRCA(430,BILL,18,RRI,0)),HREJREC=REJREC,REJI=3 G REJA:REJREC=""
I $D(^XTMP("REJCDCONV","BB",BILL,18,RRI,0)) G REJA
F REJI=REJI:1:13 S REJCD=$P(REJREC,U,REJI) I REJCD'="" D
. I REJI=12,$D(^RC(348.7,"B",REJCD)) S $P(REJREC,U,REJI)=$O(^RC(348.7,"B",REJCD,0)) Q
. I REJI=13,$D(^RC(348.6,"B",REJCD)) S $P(REJREC,U,REJI)=$O(^RC(348.6,"B",REJCD,0)) Q
. I REJI>11 S ^XTMP("REJCDCONV","XX",BILL,18,RRI,0)=REJI_U_HREJREC Q
. I REJCD>9,REJCD<100 Q
. I REJCD?1.N,((REJCD>"00")&(REJCD<"10"))!((+REJCD>0)&(+REJCD<10)) S $P(REJREC,U,REJI)=+REJCD Q
. I $D(^RC(348.5,"B",REJCD)) S $P(REJREC,U,REJI)=$O(^RC(348.5,"B",REJCD,0)) Q
. S $P(REJREC,U,REJI)=298,^XTMP("REJCDCONV","ZZ",BILL,18,RRI,0)=$P(HREJREC,U,REJI)
. Q
I HREJREC'=REJREC S ^XTMP("REJCDCONV","BB",BILL,18,RRI,0)=HREJREC,^XTMP("REJCDCONV","BB",BILL,18,RRI,1)=REJREC,^PRCA(430,BILL,18,RRI,0)=REJREC
G REJA
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRCTCSP3 9674 printed Apr 09, 2024@20:47:22 Page 2
RCTCSP3 ;ALBANY/BDB-CROSS-SERVICING TRANSMISSION ;03/15/14 3:34 PM
+1 ;;4.5;Accounts Receivable;**301,315,350**;Mar 20, 1995;Build 66
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;
+4 QUIT
+5 ;
ENTER ;Entry point from the post initialization
RCCSTUP IF '$DATA(^XTMP("REJCDCONV"))
Begin DoDot:1
+1 DO NOW^%DTC
SET RCCSTART=%
+2 SET ^XTMP("REJCDCONV","START COMPILE")=RCCSTART
+3 SET ^XTMP("REJCDCONV","STATUS")="RUNNING"
+4 SET ^XTMP("REJCDCONV",0)=$$FMADD^XLFDT(RCCSTART,730)_"^"_RCCSTART
End DoDot:1
+5 SET RCCCMPLT=0
IF $GET(^XTMP("REJCDCONV","STATUS"))="COMPLETE"
SET RCCCMPLT=1
AA NEW DEBTOR
+1 SET DEBTOR=0
+2 FOR
SET DEBTOR=$ORDER(^PRCA(430,"C",DEBTOR))
if DEBTOR'?1N.N
QUIT
Begin DoDot:1
+3 NEW X,RCDFN,DEMCS,DEBTOR0,DEBTOR1,DEBTOR7,BILL
+4 SET DEBTOR0=^RCD(340,DEBTOR,0)
SET DEBTOR1=$GET(^(1))
SET DEBTOR7=$GET(^(7))
+5 SET RCDFN=+DEBTOR0
+6 SET DEMCS=$$DEM^RCTCSP1(RCDFN)
if $EXTRACT($PIECE(DEMCS,U,3),1,5)="00000"
QUIT
+7 ;deceased patient
if +$PIECE(DEMCS,U,4)
QUIT
+8 SET BILL=0
+9 FOR
SET BILL=$ORDER(^PRCA(430,"C",DEBTOR,BILL))
if BILL'?1N.N
QUIT
Begin DoDot:2
+10 NEW B0,B6,B7,B14,CAT,TOTAL
+11 SET B0=$GET(^PRCA(430,BILL,0))
SET B6=$GET(^(6))
SET B7=$GET(^(7))
SET B14=$GET(^(14))
+12 IF 'RCCCMPLT
IF $DATA(^PRCA(430,BILL,18))
DO REJCODE
+13 ;no dpn for cs bills
IF $DATA(^PRCA(430,"TCSP",BILL))
QUIT
+14 ;no category
if '$PIECE(B0,U,2)
QUIT
+15 SET CAT=$PIECE($GET(^PRCA(430.2,$PIECE(B0,U,2),0)),U,7)
+16 if 'CAT
QUIT
+17 ;1st party check
IF ",4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,19,20,21,22,23,25,26,27,28,33,34,35,36,37,38,39,"[(","_CAT_",")
QUIT
+18 ;bill referred to TOP
IF +$PIECE(B14,U,1)
QUIT
+19 SET TOTAL=$PIECE(B7,U)+$PIECE(B7,U,2)+$PIECE(B7,U,3)+$PIECE(B7,U,4)+$PIECE(B7,U,5)
+20 ;total must be greater than zero
IF TOTAL'>0
QUIT
+21 ;if no current status
IF '$PIECE(B0,U,8)
QUIT
+22 ;quit if write-off
IF $PIECE(B0,U,8)=23
QUIT
+23 ;quit if cancelled
IF $PIECE(B0,U,8)=26
QUIT
+24 ;quit if cancellation
IF $PIECE(B0,U,8)=39
QUIT
+25 ;set dpn flag
IF TOTAL<25
SET $PIECE(^PRCA(430,BILL,20),U,3,8)="1^^^^^"
+26 QUIT
End DoDot:2
+27 QUIT
End DoDot:1
+28 IF RCCCMPLT'=1
Begin DoDot:1
+29 DO NOW^%DTC
SET RCCEND=%
+30 SET ^XTMP("REJCDCONV","END REJ CODE CONV")=RCCEND
+31 SET ^XTMP("REJCDCONV","STATUS")="COMPLETE"
End DoDot:1
+32 QUIT
+33 ;
DUEPROC ; called from rctcspd
+1 NEW TOTAL
+2 SET TOTAL=$PIECE(B7,U)+$PIECE(B7,U,2)+$PIECE(B7,U,3)+$PIECE(B7,U,4)+$PIECE(B7,U,5)
+3 ;no dpn record for bills less than $25
IF TOTAL<25
QUIT
+4 ;check site delete flag null
IF $PIECE($GET(DEBTOR3),U,10)
QUIT
+5 ;check date bill sent to dmc
IF +$PIECE(B12,U,1)
QUIT
+6 ;bill referred to doj
IF $PIECE(B6,U,4)
IF ($PIECE(B6,U,5)="DOJ")
QUIT
+7 ;status active
IF $PIECE(B0,U,8)'=16
QUIT
+8 ;must have a 3rd letter
IF '$PIECE(B6,U,3)
QUIT
+9 ;create a dpn record
DO RECDPN
+10 QUIT
+11 ;
RECDPN ;
+1 NEW KNUM,NAME
+2 SET REC="C"
+3 SET REC=REC_$$RJZF(BILL,10)
+4 SET REC=REC_$$TAXID(DEBTOR)
+5 SET NAME=$$NAMEFF(+DEBTOR0)
SET NAME=$PIECE(NAME,U)
+6 SET REC=REC_$$LJSF(NAME,30)
+7 SET RCDFN=+DEBTOR0
+8 SET ADDRCS=$$ADDR(RCDFN)
+9 SET REC=REC_$$LJSF($PIECE(ADDRCS,U,1),35)_$$LJSF($PIECE(ADDRCS,U,2),35)_$$LJSF($PIECE(ADDRCS,U,3),15)
+10 SET REC=REC_$$LJSF($PIECE(ADDRCS,U,8),20)
+11 SET REC=REC_$$BLANK(5)
+12 SET REC=REC_$$LJSF($PIECE(ADDRCS,U,4),2)_$$LJSF($PIECE(ADDRCS,U,5),9)
+13 ;Changed routine due to SACC size issue PRCA*4.5*315
SET REC=REC_$$COUNTRY^RCTCSP1A($PIECE(ADDRCS,U,7))
+14 SET TOTAL=$PIECE(B7,U)+$PIECE(B7,U,2)+$PIECE(B7,U,3)+$PIECE(B7,U,4)+$PIECE(B7,U,5)
+15 SET REC=REC_$$BLANK(9)
+16 SET REC=REC_$$DATE8(+$PIECE(B6,U,21))
+17 SET KNUM=$PIECE($PIECE(B0,U,1),"-",2)
+18 SET REC=REC_$EXTRACT(SITE,1,3)_$$LJSF(KNUM,7)
+19 SET REC=REC_$$AMOUNT9(TOTAL)
+20 SET REC=REC_$$LJSF($PIECE(ADDRCS,U,9),10)
+21 SET REC=REC_$SELECT($PIECE(ADDRCS,U,9)="":" ",$PIECE(ADDRCS,U,9)="US":" ",1:"F")
+22 SET REC=REC_$$BLANK(250-$LENGTH(REC))
+23 ;set the dpn request date
SET $PIECE(^PRCA(430,BILL,20),U,4)=DT
+24 ;clear the print date and error codes
SET $PIECE(^PRCA(430,BILL,20),U,5,8)="^^^"
+25 SET ^XTMP("RCTCSPDN",$JOB,BILL,"DPN",1)=REC
+26 ;sends mailman message of documents sent to user
SET ^XTMP("RCTCSPDN",$JOB,"BILL","DPN",BILL)=$$TAXID(DEBTOR)_"^"_+$EXTRACT(REC,201,207)_"."_$EXTRACT(REC,208,209)
+27 QUIT
+28 ;
COMPILED ;
+1 NEW RCMSG,BCNTR,REC,RECC,AMOUNT,AMOUNT,RCNTR,ACTION,SEQ,EOF
+2 SET BCNTR=0
SET REC=0
SET RECC=0
SET AMOUNT=0
SET SEQ=0
SET EOF=0
+3 FOR
SET BCNTR=$ORDER(^XTMP("RCTCSPDN",$JOB,BCNTR))
if +BCNTR'>0
SET EOF=1
if +BCNTR'>0
QUIT
Begin DoDot:1
+4 IF REC>120
Begin DoDot:2
+5 DO TRAILERD
+6 DO AITCMSGD
+7 SET REC=0
SET RECC=0
+8 QUIT
End DoDot:2
+9 SET ACTION="DPN"
+10 IF REC=0
DO HEADERD
+11 SET RCNTR=1
IF $DATA(^XTMP("RCTCSPDN",$JOB,BCNTR,ACTION,RCNTR))
Begin DoDot:2
+12 SET REC=REC+1
+13 ;record count for 'c' records on trailer record
SET RECC=RECC+1
+14 SET ^XTMP("RCTCSPDN",$JOB,SEQ,"BUILD",REC)=^XTMP("RCTCSPDN",$JOB,BCNTR,ACTION,RCNTR)_$CHAR(126)
+15 SET AMOUNT=AMOUNT+$EXTRACT(^XTMP("RCTCSPDN",$JOB,BCNTR,ACTION,RCNTR),201,209)
+16 QUIT
End DoDot:2
+17 QUIT
End DoDot:1
+18 DO TRAILERD
+19 DO AITCMSGD
+20 DO USRMSGD
+21 QUIT
+22 ;
AITCMSGD ;
+1 NEW XMY,XMDUZ,XMSUB,XMTEXT,SYSTYP
+2 ; PRCA*4.5*350
SET SYSTYP=$$PROD^XUPROD(1)
+3 if '$DATA(^XTMP("RCTCSPDN",$JOB))
QUIT
+4 SET CNTLID=$$JD()_$$RJZF(SEQ,4)
+5 SET XMDUZ="AR PACKAGE"
+6 IF SYSTYP
SET XMY("XXX@Q-TPL.DOMAIN.EXT")=""
+7 IF 'SYSTYP
SET XMY("XXX@Q-TXL.DOMAIN.EXT")=""
+8 SET XMY("G.TCSP")=""
+9 SET XMSUB=SITE_"/DPN TRANSMISSION/BATCH#: "_CNTLID
+10 SET XMTEXT="^XTMP(""RCTCSPDN"","_$JOB_","""_SEQ_""",""BUILD"","
+11 DO ^XMD
+12 QUIT
+13 ;
USRMSGD ;sends mailman message of documents sent to user
+1 NEW XMY,XMDUZ,XMSUB,XMTEXT,X,RCNT,RCDAT1,RCDAT2
+2 if '$DATA(^XTMP("RCTCSPDN",$JOB))
QUIT
+3 SET ACTION="DPN"
+4 KILL ^XTMP("RCTCSPDN",$JOB,"BILL","MSG")
+5 SET XMDUZ="AR PACKAGE"
+6 SET XMY("G.TCSP")=""
+7 SET XMSUB="CS DUE PROCESS"_" SENT ON "_$EXTRACT(DT,4,5)_"/"_$EXTRACT(DT,6,7)_"/"_$EXTRACT(DT,2,3)_" BATCH ID: "_CNTLID
+8 SET ^XTMP("RCTCSPDN",$JOB,"BILL","MSG",1)="Bill# TIN TYPE AMOUNT"
+9 SET ^XTMP("RCTCSPDN",$JOB,"BILL","MSG",2)="----- --- ---- ------"
+10 SET X=0
SET RCNT=2
FOR
SET X=$ORDER(^XTMP("RCTCSPDN",$JOB,"BILL",ACTION,X))
if X=""
QUIT
Begin DoDot:1
+11 SET RCNT=RCNT+1
+12 SET RCDAT1=$PIECE(^XTMP("RCTCSPDN",$JOB,"BILL",ACTION,X),U,1)
+13 SET RCDAT2=$PIECE(^XTMP("RCTCSPDN",$JOB,"BILL",ACTION,X),U,2)
+14 SET ^XTMP("RCTCSPDN",$JOB,"BILL","MSG",RCNT)=$$RJZF($PIECE($GET(^PRCA(430,X,0)),U,1),7)_$$BLANK(22)_RCDAT1_" "_ACTION_" "_$SELECT(RCDAT2]"":RCDAT2,1:"")
+15 QUIT
End DoDot:1
+16 SET ^XTMP("RCTCSPDN",$JOB,"BILL","MSG",RCNT+1)="Total Bills: "_(RCNT-2)
+17 SET XMTEXT="^XTMP(""RCTCSPDN"","_$JOB_",""BILL"",""MSG"","
+18 if $GET(ONEBILL)
QUIT
+19 DO ^XMD
+20 KILL ^XTMP("RCTCSPDN",$JOB,"BILL","MSG")
+21 QUIT
+22 ;
+1 ;increment batch sequence number, build new header
+2 NEW RCMSG
+3 SET SEQ=SEQ+1
+4 SET CNTLID=$$JD()_$$RJZF(SEQ,4)
+5 KILL ^XTMP("RCTCSPDN",$JOB,ACTION,"BUILD",SEQ)
+6 ;header is record type H
SET RCMSG="H"_CNTLID_$$BLANK(14)_"3636001200"
+7 SET RCMSG=RCMSG_$$BLANK(250-$LENGTH(RCMSG))
+8 SET REC=REC+1
+9 SET ^XTMP("RCTCSPDN",$JOB,SEQ,"BUILD",REC)=RCMSG_$CHAR(126)
+10 QUIT
+11 ;
TRAILERD ;
+1 ;trailer is type Z record
+2 ;delete batch if no records processed
IF REC=0
KILL ^XTMP("RCTCSPDN",$JOB,SEQ,"BUILD")
QUIT
+3 NEW RCMSG
+4 SET CNTLID=$$JD()_$$RJZF(SEQ,4)
+5 SET RCMSG="Z"_$$RJZF(RECC,8)_$$AMOUNT(AMOUNT/100)_CNTLID_$$BLANK(14)_"3636001200"
+6 SET RCMSG=RCMSG_$$BLANK(250-$LENGTH(RCMSG))
+7 if EOF
SET $EXTRACT(RCMSG,229,236)="0001"_$$RJZF(SEQ,4)
+8 SET REC=REC+1
+9 SET ^XTMP("RCTCSPDN",$JOB,SEQ,"BUILD",REC)=RCMSG_$CHAR(126)
+10 SET REC=0
SET RECC=0
SET AMOUNT=0
+11 QUIT
+12 ;
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, 14 characters
+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 ;
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 ;
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 ;
ADDR(RCDFN) ; returns patient file address
+1 NEW DFN,ADDRCS,STATEIEN,STATEAB,VAPA
+2 SET DFN=RCDFN
+3 DO ADD^VADPT
+4 SET STATEIEN=+VAPA(5)
SET STATEAB=$$GET1^DIQ(5,STATEIEN,1)
+5 ;25-country,23-province,24-postal code
SET ADDRCS=VAPA(1)_U_VAPA(2)_U_VAPA(4)_U_STATEAB_U_VAPA(6)_U_VAPA(8)_U_+VAPA(25)_U_VAPA(23)_U_VAPA(24)
+6 IF $LENGTH(DEBTOR1)>0
IF $PIECE(DEBTOR1,U,1,5)'?1"^"."^"
Begin DoDot:1
+7 NEW ADDR340
+8 SET ADDR340=$PIECE($$DADD^RCAMADD(DEBTOR),U,1,7)_"^"_1
+9 SET ADDR340=$PIECE(ADDR340,U,1,2)_"^"_$PIECE(ADDR340,U,4,99)
+10 IF $PIECE(ADDR340,U,6)=""
SET $PIECE(ADDR340,U,6)=$PIECE(ADDRCS,U,6)
+11 SET ADDRCS=ADDR340
End DoDot:1
+12 QUIT ADDRCS
+13 ;
REJCODE ;Converts AITC reject codes in reject multiple to pointer to file 348.5
+1 NEW RRI,REJI,REJCD,HREJREC,REJREC
SET RRI=0
REJA SET RRI=$ORDER(^PRCA(430,BILL,18,RRI))
if 'RRI
QUIT
+1 SET REJREC=$GET(^PRCA(430,BILL,18,RRI,0))
SET HREJREC=REJREC
SET REJI=3
if REJREC=""
GOTO REJA
+2 IF $DATA(^XTMP("REJCDCONV","BB",BILL,18,RRI,0))
GOTO REJA
+3 FOR REJI=REJI:1:13
SET REJCD=$PIECE(REJREC,U,REJI)
IF REJCD'=""
Begin DoDot:1
+4 IF REJI=12
IF $DATA(^RC(348.7,"B",REJCD))
SET $PIECE(REJREC,U,REJI)=$ORDER(^RC(348.7,"B",REJCD,0))
QUIT
+5 IF REJI=13
IF $DATA(^RC(348.6,"B",REJCD))
SET $PIECE(REJREC,U,REJI)=$ORDER(^RC(348.6,"B",REJCD,0))
QUIT
+6 IF REJI>11
SET ^XTMP("REJCDCONV","XX",BILL,18,RRI,0)=REJI_U_HREJREC
QUIT
+7 IF REJCD>9
IF REJCD<100
QUIT
+8 IF REJCD?1.N
IF ((REJCD>"00")&(REJCD<"10"))!((+REJCD>0)&(+REJCD<10))
SET $PIECE(REJREC,U,REJI)=+REJCD
QUIT
+9 IF $DATA(^RC(348.5,"B",REJCD))
SET $PIECE(REJREC,U,REJI)=$ORDER(^RC(348.5,"B",REJCD,0))
QUIT
+10 SET $PIECE(REJREC,U,REJI)=298
SET ^XTMP("REJCDCONV","ZZ",BILL,18,RRI,0)=$PIECE(HREJREC,U,REJI)
+11 QUIT
End DoDot:1
+12 IF HREJREC'=REJREC
SET ^XTMP("REJCDCONV","BB",BILL,18,RRI,0)=HREJREC
SET ^XTMP("REJCDCONV","BB",BILL,18,RRI,1)=REJREC
SET ^PRCA(430,BILL,18,RRI,0)=REJREC
+13 GOTO REJA
