RCDMC90 ;WASH IRMFO/ALTOONA,PA/TJK - DMC 90 DAY ;7/17/97 8:13 AM
V ;;4.5;Accounts Receivable;**45,108,133,121,163,190,192,236,237,229,253,338,343**;Mar 20, 1995;Build 59
;Per VA Directive 6402,this routine should not be modified.
;
ENTER ;Entry point from nightly process
Q:'$D(RCDOC)
;run the interest and admin for newly flagged Katrina Patients.
I DT'<$P($G(^RC(342,1,30)),"^",1)&(DT'>$P($G(^RC(342,1,30)),"^",2)) D ^RCEXINAD
N DEBTOR,BILL,DEBTOR0,B0,B6,B7,LTRDT3,PRIN,INT,ADMIN,B4,B12
N TPRIN,TINT,TADMIN,ESTDT,CATYP,DFN,CNTR,SITE,LN,FN,MN,STNM,DOB,SITE
N PHONE,QUIT,TOTAL,ZIPCODE,FULLNM,XN,RC91DT,OFFAMT,RCNT,TLINE,REPAY,X1,X2
N LKUP,ADDR,ADDRPHO,CHKPHONE,PSSN
K ^XTMP("RCDMC90",$J),^TMP($J,"RCDMC90") S ^XTMP("RCDMC90",0)=DT
S SITE=$$SITE^RCMSITE(),TLINE="0^0^0"
S X1=DT,X2=-91 D C^%DTC S RC91DT=X ; PRCA*4.5*343 - namespace 91 day variable
;S X1=DT,X2=-30 D C^%DTC S P30DT=X ; PRCA*4.5*343 - comment out, will use 91 days instead of 30
S (CNTR,DEBTOR)=0,RCNT=2 G UPDATE:$G(RCDOC)="W"
;MASTER SHEET COMPILATION
F S DEBTOR=$O(^PRCA(430,"C",DEBTOR)) Q:DEBTOR'?1N.N D
.N X,RCDFN
.S RCDFN=$P($G(^RCD(340,DEBTOR,0)),"^",1) I $P(RCDFN,";",2)'["DPT" Q
.S X=$$EMERES^PRCAUTL(+RCDFN) I X]""&('$D(^RCD(340,"DMC",1,DEBTOR))) Q ;stop the master sheet compilation for hurricane Katrina sites
.K ^TMP($J,"RCDMC90","BILL")
.S QUIT=1,OFFAMT=+$P($G(^RCD(340,DEBTOR,3)),U,9)
.D PROC(DEBTOR,.QUIT) Q:QUIT
.;COMPILES FIELDS UNIQUE TO MASTER CODE SHEETS
.S FULLNM=$$NM(DFN),FN=$P(FULLNM,U,3),MN=$P(FULLNM,U,4)
.S LN=$P(FULLNM,U,1),XN=$P(FULLNM,U,2)
.S FULLNM=FN_" "_$S(MN'="":$P(MN,".")_" ",1:"")_LN_$S(XN'="":" "_$P(XN,"."),1:"")
.S STNM=$$LJ^XLFSTR($E(FN)_$S(MN'="":$E(MN),1:" ")_$E(LN,1,5),7," ")
.S DOB=$$DATE8(+VADM(3))
.;SET HOLDING GLOBAL FOR MASTER SHEETS
.S CNTR=CNTR+1
.S ^XTMP("RCDMC90",$J,CNTR)=$E($$LJ^XLFSTR($P(VADM(2),U),9),1,9)_STNM_SITE_DOB_PHONE_$$LJ^XLFSTR(FULLNM,40)_$$LJ^XLFSTR($E($P(ADDR,U,1),1,2),2)
.S CNTR=CNTR+1
.S ^XTMP("RCDMC90",$J,CNTR)=$$LJ^XLFSTR($E($P(ADDR,U,1),3,40),38)_$$LJ^XLFSTR($E($P(ADDR,U,2),1,40),40)_$$LJ^XLFSTR($E($P(ADDR,U,3)),1)
.S CNTR=CNTR+1
.S ^XTMP("RCDMC90",$J,CNTR)=$$LJ^XLFSTR($E($P(ADDR,U,3),2,40),39)_$$LJ^XLFSTR($E($P(ADDR,U,4),1,40),40)
.S CNTR=CNTR+1
.S ^XTMP("RCDMC90",$J,CNTR)=$$LJ^XLFSTR($E($P(ADDR,U,5),1,40),40)_$$LJ^XLFSTR(ZIPCODE,9)_$$DATE8(ESTDT)_$$AMT(TPRIN)_$$AMT(TINT)_$E($$AMT(TADMIN),1,4)
.S CNTR=CNTR+1
.S ^XTMP("RCDMC90",$J,CNTR)=$E($$AMT(TADMIN),5,9)_$$DATE8(DT)_CATYP_$$AMT(OFFAMT)_$$AMT($$BAL(DEBTOR))_$E("0000000000",1,10-$L(DEBTOR))_DEBTOR_"$"
.S $P(^RCD(340,DEBTOR,3),U)=1,$P(^(3),U,2)=DT,$P(^(3),U,3)=ESTDT,$P(^(3),U,5)=TOTAL,$P(^(3),U,6)=TPRIN,$P(^(3),U,7)=TINT,$P(^(3),U,8)=TADMIN,^RCD(340,"DMC",1,DEBTOR)=""
.S X=0 F S X=$O(^TMP($J,"RCDMC90","BILL",X)) Q:'X S ^PRCA(430,X,12)=^(X)
.D SETREC
.Q
D COMPILE^RCDMC90U(375,CNTR,5,TLINE),KVAR
Q
UPDATE ;WEEKLY UPDATE COMPILATION
F S DEBTOR=$O(^RCD(340,"DMC",1,DEBTOR)) Q:DEBTOR'?1N.N D
.I '$G(^RCD(340,DEBTOR,3)) K ^RCD(340,"DMC",1,DEBTOR) Q
.S QUIT=1,OFFAMT=+$P(^RCD(340,DEBTOR,3),U,9)
.D PROC(DEBTOR,.QUIT) Q:QUIT
.;SET HOLDING GLOBAL FOR WEEKLY UPDATES
.S CNTR=CNTR+1
.S ^XTMP("RCDMC90",$J,CNTR)=$E($$LJ^XLFSTR($P(VADM(2),U),9),1,9)_$$LJ^XLFSTR($E($P(ADDR,U,1),1,40),40)_$$LJ^XLFSTR($E($P(ADDR,U,2),1,30),30)
.S CNTR=CNTR+1
.S ^XTMP("RCDMC90",$J,CNTR)=$$LJ^XLFSTR($E($P(ADDR,U,2),31,40),10)_$$LJ^XLFSTR($E($P(ADDR,U,3),1,40),40)_$$LJ^XLFSTR($E($P(ADDR,U,4),1,29),29)
.S CNTR=CNTR+1
.S ^XTMP("RCDMC90",$J,CNTR)=$$LJ^XLFSTR($E($P(ADDR,U,4),30,40),11)_$$LJ^XLFSTR($E($P(ADDR,U,5),1,40),40)_$$LJ^XLFSTR(ZIPCODE,9)_SITE_PHONE_$E($$AMT(TPRIN),1,6)
.S CNTR=CNTR+1
.S ^XTMP("RCDMC90",$J,CNTR)=$E($$AMT(TPRIN),7,9)_$$AMT(TINT)_$$AMT(TADMIN)_$$DATE8(DT)_CATYP_$$AMT(OFFAMT)_$$AMT($$BAL(DEBTOR))_"$"
.S:TOTAL $P(^RCD(340,DEBTOR,3),U,5)=TOTAL,$P(^(3),U,6)=TPRIN,$P(^(3),U,7)=TINT,$P(^(3),U,8)=TADMIN
.D SETREC
.Q
D COMPILE^RCDMC90U(300,CNTR,4,TLINE),KVAR
Q
KVAR D KVAR^VADPT
K RCDOC,^XTMP("RCDMC90",$J),VA("BID"),XMDUZ
Q
PROC(DEBTOR,QUIT) ;PROCESS BILLS FOR A SPECIFIC DEBTOR
;SETS DATA COMMON TO BOTH WEEKLY & MASTER CODESHEETS
S DEBTOR0=$G(^RCD(340,DEBTOR,0))
Q:$P(DEBTOR0,U)'["DPT"
S DFN=+DEBTOR0 D DEM^VADPT Q:$E(VADM(2),1,5)="00000"
F X=1:1:6 S CATYP(X)=""
S (BILL,TOTAL,TPRIN,TINT,TADMIN,REPAY)=0,ESTDT=RC91DT
I RCDOC="W",$P(^RCD(340,DEBTOR,3),U,10) G TOTAL
F S BILL=$O(^PRCA(430,"C",DEBTOR,BILL)) Q:BILL'?1N.N D K:PRIN=0 ^PRCA(430,BILL,12) Q:REPAY
.S (PRIN,INT,ADMIN)=0
.I +VADM(6) Q
.S B0=$G(^PRCA(430,BILL,0)),B4=$G(^(4)),B6=$G(^(6)),B7=$G(^(7)),B12=$G(^(12))
.Q:$P(B0,U,8)'=16
.I B4 D Q
..S (TOTAL,TPRIN,TINT,TADMIN)=0
..S X=0 F S X=$O(^PRCA(430,"C",DEBTOR,X)) Q:X'?1N.N K ^PRCA(430,X,12)
..S REPAY=1
..Q
.I RCDOC="W",'$P(B12,U) Q
.S PRIN=$P(B7,U),INT=$P(B7,U,2),ADMIN=$P(B7,U,3)+$P(B7,U,4)+$P(B7,U,5)
.I PRIN'>0,INT+ADMIN>0 D Q
..N XMSUB,XMY,XMTEXT,MSG
..S XMSUB="Notice Of Active Bill Without Principal Balance"
..S XMY("G.DMR")=""
..S XMDUZ="AR PACKAGE"
..S XMTEXT="MSG("
..S MSG(1)="The following bill has a 0 principal balance,"
..S MSG(2)="but has interest/admin charges remaining."
..S MSG(3)="These charges should be exempted"
..S MSG(4)=" "
..S MSG(5)="BILL #: "_$P(B0,U)
..D ^XMD
..Q
.Q:$P(B4,U)
.;S LTRDT3=$P(B6,U,3) Q:'LTRDT3 Q:LTRDT3>P30DT ; comment out in *343
.S LTRDT3=$P(B6,U,3) Q:'LTRDT3 ; PRCA*4.5*343
.I +B6>RC91DT Q ; PRCA*4.5*343 - Must be 91 days or more after LETTER1 date
.;CHECK FOR DC REFERRAL HERE
.I $P(B6,U,4),($P(B6,U,5)="DC")!($P(B6,U,5)="RC") Q
.;Q:$$INSURED^IBCNS1(DFN,$P(B0,U,10)) ;Commented out w/patch *121
.;***PRCA*4.5*338 start
.S X=$P(B0,U,2)
.; Check to see if the AR category allows for a DMC referral
.Q:'$$RFCHK^RCTOPD(X,"I",1.01,$P(B6,U,21))
.;end PRCA*4.5*338
.;
.K CATYP(X)
.;Check if bill should be deferred from being sent to DMC if Veteran is
.;SC 50% to 100% or Receiving VA Pension (Hold Debt to DMC project, sbw)
.Q:+$$HOLDCHK^RCDMCUT1(BILL,DFN)>0
.I $P(B6,U,21),$P(B6,U,21)<ESTDT S ESTDT=$P($P(B6,U,21),".")
.I $P(B12,U,2),PRIN>$P(B12,U,2) S PRIN=$P(B12,U,2)
.S ^TMP($J,"RCDMC90","BILL",BILL)=$S($P(B12,U):$P(B12,U),1:DT)_U_PRIN_U_INT_U_ADMIN
.S TPRIN=TPRIN+PRIN,TINT=TINT+INT,TADMIN=TADMIN+ADMIN
.Q
TOTAL S TOTAL=TPRIN+TINT+TADMIN
I RCDOC="M" Q:TPRIN'>0 ;PRCA*4.5*229
I RCDOC="M",'+$$SWSTAT^IBBAPI() Q:TOTAL<25 ;PRCA*4.5*229
;
I RCDOC="M",$P(VADM(2),U)["P" S PSSN=$P(VADM(2),U) D PSEUDO^RCDMC90U(DFN,PSSN) Q
I RCDOC="W" Q:(TOTAL_U_TPRIN_U_TINT_U_TADMIN)=$P(^RCD(340,DEBTOR,3),U,5,8)
S DFN=+DEBTOR0
;SETS CATEGORY CODE 1=MEANS TEST,2=PHARMACY,3=INEL.,4=EMER./HUM.
;5=CHAMPVA,6=TRICARE OR ANY COMBINATION THEREOF
S CATYP="" F X=1:1:6 S:'$D(CATYP(X)) CATYP=CATYP_X
S CATYP=$$LJ^XLFSTR(CATYP,6)
;
;Send Master/Weekly error msg if Unknown or Invalid address
;If Master update, quit and don't refer to DMC
;If Weekly update, send a zero balance
S LKUP=$$CHKADD(DEBTOR)
I LKUP D ERROR^RCDMC90U(RCDOC,LKUP,DFN) Q:RCDOC="M" S (TOTAL,TPRIN,TINT,TADMIN)=0
;
S ZIPCODE=$TR($P(ADDR,U,6),"-")
;
;Retrieve and format patient phone number
S ADDRPHO=$P(ADDR,U,7),PHONE=""
F I=1:1:$L(ADDRPHO) S CHKPHONE=$E(ADDRPHO,I) I CHKPHONE?1N S PHONE=PHONE_CHKPHONE
S PHONE=$S(PHONE?10N:PHONE,PHONE?7N:" "_PHONE,1:" ")
;
I RCDOC="W",TOTAL=0 D
.K ^RCD(340,"DMC",1,DEBTOR),^RCD(340,DEBTOR,3)
.N NM,XMSUB,XMY,XMTEXT,MSG
.S XMSUB="Deletion of Debtor from DMC"
.S XMY("G.DMX")=""
.S XMDUZ="AR PACKAGE"
.S XMTEXT="MSG("
.S MSG(1)="The following patient has a DMC balance of '0'"
.S MSG(2)="and will be deleted from the DMC system:"
.S MSG(3)=" "
.S MSG(4)=$P(^DPT(DFN,0),U)_" SSN: "_$P(^(0),U,9)
.D ^XMD
.Q
S QUIT=0
PROCQ Q
DATE8(X) ;CHANGES FILEMAN DATE INTO 8 DIGIT DATE IN FORMAT MMDDYYYY
S X=$E(X,4,7)_($E(X,1,3)+1700)
Q X
AMT(X) ;CHANGES AMOUNT TO ZERO FILLED, RIGHT JUSTIFIED
S X=$TR($J(X,0,2),".")
S X=$E("000000000",1,9-$L(X))_X
Q X
NM(DFN) ;Returns first, middle, and last name in 3 different variables
N FN,LN,MN,NM,XN
S NM=$P($G(^DPT(DFN,0)),"^")
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 XN=MN,MN=""
I $G(XN)="" S XN=$P($P($G(NM),",",2)," ",3)
S FN=$P($P(NM,",",2)," ")
QNM Q LN_"^"_XN_"^"_FN_"^"_MN
BAL(DEBTOR) ;COMPUTES TOTAL OF ACTIVE BILLS THAT COULD BE SENT TO DMC
N BILL,BAL
S (BILL,BAL)=0
F S BILL=$O(^PRCA(430,"C",DEBTOR,BILL)) Q:BILL'?1N.N D
.S B0=$G(^PRCA(430,BILL,0)),B7=$G(^(7))
.Q:$P(B0,U,8)'=16
.S X=$P(B0,U,2),X=$S((X>0)&(X<6):1,X=18:1,(X>21)&(X<26):1,(X>26)&(X<33):1,1:"")
.Q:X=""
.S BAL=BAL+$P(B7,U)+$P(B7,U,2)+$P(B7,U,3)+$P(B7,U,4)+$P(B7,U,5)
.Q
BALQ Q BAL
SETREC ;SETS TEMPORARY GLOBAL FOR MAIL MESSAGE TO USERS
S RCNT=RCNT+1 D PID^VADPT S:$L(VA("BID"))=4 VA("BID")=" "_VA("BID")
S TLINE=($P(TLINE,U)+TPRIN)_U_($P(TLINE,U,2)+TINT)_U_($P(TLINE,U,3)+TADMIN)
S ^XTMP("RCDMC90",$J,"REC",$P(^DPT(DFN,0),U)_";"_DFN)=$$LJ^XLFSTR($E($P(^DPT(DFN,0),U),1,28),29)_" "_VA("BID")_" "_$J(TPRIN,10,2)_$J(TINT,10,2)_$J(TADMIN,10,2)_$J(TOTAL,10,2)
Q
;
CHKADD(DEBTOR) ; Checks for invalid and unknown addresses
N CHK S CHK=0,ADDR=""
I $P($G(^RCD(340,+DEBTOR,1)),"^",9)=1 S CHK=1 G CHKADDQ
S ADDR=$$DADD^RCAMADD(+DEBTOR,1) ;get address (confidential if possible)
I ADDR'?.ANP!(ADDR["$")!(ADDR["**")!(ADDR["///")!(ADDR["ZZZ") S CHK=2
CHKADDQ Q CHK
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRCDMC90 9554 printed Dec 13, 2024@01:43:25 Page 2
RCDMC90 ;WASH IRMFO/ALTOONA,PA/TJK - DMC 90 DAY ;7/17/97 8:13 AM
V ;;4.5;Accounts Receivable;**45,108,133,121,163,190,192,236,237,229,253,338,343**;Mar 20, 1995;Build 59
+1 ;Per VA Directive 6402,this routine should not be modified.
+2 ;
ENTER ;Entry point from nightly process
+1 if '$DATA(RCDOC)
QUIT
+2 ;run the interest and admin for newly flagged Katrina Patients.
+3 IF DT'<$PIECE($GET(^RC(342,1,30)),"^",1)&(DT'>$PIECE($GET(^RC(342,1,30)),"^",2))
DO ^RCEXINAD
+4 NEW DEBTOR,BILL,DEBTOR0,B0,B6,B7,LTRDT3,PRIN,INT,ADMIN,B4,B12
+5 NEW TPRIN,TINT,TADMIN,ESTDT,CATYP,DFN,CNTR,SITE,LN,FN,MN,STNM,DOB,SITE
+6 NEW PHONE,QUIT,TOTAL,ZIPCODE,FULLNM,XN,RC91DT,OFFAMT,RCNT,TLINE,REPAY,X1,X2
+7 NEW LKUP,ADDR,ADDRPHO,CHKPHONE,PSSN
+8 KILL ^XTMP("RCDMC90",$JOB),^TMP($JOB,"RCDMC90")
SET ^XTMP("RCDMC90",0)=DT
+9 SET SITE=$$SITE^RCMSITE()
SET TLINE="0^0^0"
+10 ; PRCA*4.5*343 - namespace 91 day variable
SET X1=DT
SET X2=-91
DO C^%DTC
SET RC91DT=X
+11 ;S X1=DT,X2=-30 D C^%DTC S P30DT=X ; PRCA*4.5*343 - comment out, will use 91 days instead of 30
+12 SET (CNTR,DEBTOR)=0
SET RCNT=2
if $GET(RCDOC)="W"
GOTO UPDATE
+13 ;MASTER SHEET COMPILATION
+14 FOR
SET DEBTOR=$ORDER(^PRCA(430,"C",DEBTOR))
if DEBTOR'?1N.N
QUIT
Begin DoDot:1
+15 NEW X,RCDFN
+16 SET RCDFN=$PIECE($GET(^RCD(340,DEBTOR,0)),"^",1)
IF $PIECE(RCDFN,";",2)'["DPT"
QUIT
+17 ;stop the master sheet compilation for hurricane Katrina sites
SET X=$$EMERES^PRCAUTL(+RCDFN)
IF X]""&('$DATA(^RCD(340,"DMC",1,DEBTOR)))
QUIT
+18 KILL ^TMP($JOB,"RCDMC90","BILL")
+19 SET QUIT=1
SET OFFAMT=+$PIECE($GET(^RCD(340,DEBTOR,3)),U,9)
+20 DO PROC(DEBTOR,.QUIT)
if QUIT
QUIT
+21 ;COMPILES FIELDS UNIQUE TO MASTER CODE SHEETS
+22 SET FULLNM=$$NM(DFN)
SET FN=$PIECE(FULLNM,U,3)
SET MN=$PIECE(FULLNM,U,4)
+23 SET LN=$PIECE(FULLNM,U,1)
SET XN=$PIECE(FULLNM,U,2)
+24 SET FULLNM=FN_" "_$SELECT(MN'="":$PIECE(MN,".")_" ",1:"")_LN_$SELECT(XN'="":" "_$PIECE(XN,"."),1:"")
+25 SET STNM=$$LJ^XLFSTR($EXTRACT(FN)_$SELECT(MN'="":$EXTRACT(MN),1:" ")_$EXTRACT(LN,1,5),7," ")
+26 SET DOB=$$DATE8(+VADM(3))
+27 ;SET HOLDING GLOBAL FOR MASTER SHEETS
+28 SET CNTR=CNTR+1
+29 SET ^XTMP("RCDMC90",$JOB,CNTR)=$EXTRACT($$LJ^XLFSTR($PIECE(VADM(2),U),9),1,9)_STNM_SITE_DOB_PHONE_$$LJ^XLFSTR(FULLNM,40)_$$LJ^XLFSTR($EXTRACT($PIECE(ADDR,U,1),1,2),2)
+30 SET CNTR=CNTR+1
+31 SET ^XTMP("RCDMC90",$JOB,CNTR)=$$LJ^XLFSTR($EXTRACT($PIECE(ADDR,U,1),3,40),38)_$$LJ^XLFSTR($EXTRACT($PIECE(ADDR,U,2),1,40),40)_$$LJ^XLFSTR($EXTRACT($PIECE(ADDR,U,3)),1)
+32 SET CNTR=CNTR+1
+33 SET ^XTMP("RCDMC90",$JOB,CNTR)=$$LJ^XLFSTR($EXTRACT($PIECE(ADDR,U,3),2,40),39)_$$LJ^XLFSTR($EXTRACT($PIECE(ADDR,U,4),1,40),40)
+34 SET CNTR=CNTR+1
+35 SET ^XTMP("RCDMC90",$JOB,CNTR)=$$LJ^XLFSTR($EXTRACT($PIECE(ADDR,U,5),1,40),40)_$$LJ^XLFSTR(ZIPCODE,9)_$$DATE8(ESTDT)_$$AMT(TPRIN)_$$AMT(TINT)_$EXTRACT($$AMT(TADMIN),1,4)
+36 SET CNTR=CNTR+1
+37 SET ^XTMP("RCDMC90",$JOB,CNTR)=$EXTRACT($$AMT(TADMIN),5,9)_$$DATE8(DT)_CATYP_$$AMT(OFFAMT)_$$AMT($$BAL(DEBTOR))_$EXTRACT("0000000000",1,10-$LENGTH(DEBTOR))_DEBTOR_"$"
+38 SET $PIECE(^RCD(340,DEBTOR,3),U)=1
SET $PIECE(^(3),U,2)=DT
SET $PIECE(^(3),U,3)=ESTDT
SET $PIECE(^(3),U,5)=TOTAL
SET $PIECE(^(3),U,6)=TPRIN
SET $PIECE(^(3),U,7)=TINT
SET $PIECE(^(3),U,8)=TADMIN
SET ^RCD(340,"DMC",1,DEBTOR)=""
+39 SET X=0
FOR
SET X=$ORDER(^TMP($JOB,"RCDMC90","BILL",X))
if 'X
QUIT
SET ^PRCA(430,X,12)=^(X)
+40 DO SETREC
+41 QUIT
End DoDot:1
+42 DO COMPILE^RCDMC90U(375,CNTR,5,TLINE)
DO KVAR
+43 QUIT
UPDATE ;WEEKLY UPDATE COMPILATION
+1 FOR
SET DEBTOR=$ORDER(^RCD(340,"DMC",1,DEBTOR))
if DEBTOR'?1N.N
QUIT
Begin DoDot:1
+2 IF '$GET(^RCD(340,DEBTOR,3))
KILL ^RCD(340,"DMC",1,DEBTOR)
QUIT
+3 SET QUIT=1
SET OFFAMT=+$PIECE(^RCD(340,DEBTOR,3),U,9)
+4 DO PROC(DEBTOR,.QUIT)
if QUIT
QUIT
+5 ;SET HOLDING GLOBAL FOR WEEKLY UPDATES
+6 SET CNTR=CNTR+1
+7 SET ^XTMP("RCDMC90",$JOB,CNTR)=$EXTRACT($$LJ^XLFSTR($PIECE(VADM(2),U),9),1,9)_$$LJ^XLFSTR($EXTRACT($PIECE(ADDR,U,1),1,40),40)_$$LJ^XLFSTR($EXTRACT($PIECE(ADDR,U,2),1,30),30)
+8 SET CNTR=CNTR+1
+9 SET ^XTMP("RCDMC90",$JOB,CNTR)=$$LJ^XLFSTR($EXTRACT($PIECE(ADDR,U,2),31,40),10)_$$LJ^XLFSTR($EXTRACT($PIECE(ADDR,U,3),1,40),40)_$$LJ^XLFSTR($EXTRACT($PIECE(ADDR,U,4),1,29),29)
+10 SET CNTR=CNTR+1
+11 SET ^XTMP("RCDMC90",$JOB,CNTR)=$$LJ^XLFSTR($EXTRACT($PIECE(ADDR,U,4),30,40),11)_$$LJ^XLFSTR($EXTRACT($PIECE(ADDR,U,5),1,40),40)_$$LJ^XLFSTR(ZIPCODE,9)_SITE_PHONE_$EXTRACT($$AMT(TPRIN),1,6)
+12 SET CNTR=CNTR+1
+13 SET ^XTMP("RCDMC90",$JOB,CNTR)=$EXTRACT($$AMT(TPRIN),7,9)_$$AMT(TINT)_$$AMT(TADMIN)_$$DATE8(DT)_CATYP_$$AMT(OFFAMT)_$$AMT($$BAL(DEBTOR))_"$"
+14 if TOTAL
SET $PIECE(^RCD(340,DEBTOR,3),U,5)=TOTAL
SET $PIECE(^(3),U,6)=TPRIN
SET $PIECE(^(3),U,7)=TINT
SET $PIECE(^(3),U,8)=TADMIN
+15 DO SETREC
+16 QUIT
End DoDot:1
+17 DO COMPILE^RCDMC90U(300,CNTR,4,TLINE)
DO KVAR
+18 QUIT
KVAR DO KVAR^VADPT
+1 KILL RCDOC,^XTMP("RCDMC90",$JOB),VA("BID"),XMDUZ
+2 QUIT
PROC(DEBTOR,QUIT) ;PROCESS BILLS FOR A SPECIFIC DEBTOR
+1 ;SETS DATA COMMON TO BOTH WEEKLY & MASTER CODESHEETS
+2 SET DEBTOR0=$GET(^RCD(340,DEBTOR,0))
+3 if $PIECE(DEBTOR0,U)'["DPT"
QUIT
+4 SET DFN=+DEBTOR0
DO DEM^VADPT
if $EXTRACT(VADM(2),1,5)="00000"
QUIT
+5 FOR X=1:1:6
SET CATYP(X)=""
+6 SET (BILL,TOTAL,TPRIN,TINT,TADMIN,REPAY)=0
SET ESTDT=RC91DT
+7 IF RCDOC="W"
IF $PIECE(^RCD(340,DEBTOR,3),U,10)
GOTO TOTAL
+8 FOR
SET BILL=$ORDER(^PRCA(430,"C",DEBTOR,BILL))
if BILL'?1N.N
QUIT
Begin DoDot:1
+9 SET (PRIN,INT,ADMIN)=0
+10 IF +VADM(6)
QUIT
+11 SET B0=$GET(^PRCA(430,BILL,0))
SET B4=$GET(^(4))
SET B6=$GET(^(6))
SET B7=$GET(^(7))
SET B12=$GET(^(12))
+12 if $PIECE(B0,U,8)'=16
QUIT
+13 IF B4
Begin DoDot:2
+14 SET (TOTAL,TPRIN,TINT,TADMIN)=0
+15 SET X=0
FOR
SET X=$ORDER(^PRCA(430,"C",DEBTOR,X))
if X'?1N.N
QUIT
KILL ^PRCA(430,X,12)
+16 SET REPAY=1
+17 QUIT
End DoDot:2
QUIT
+18 IF RCDOC="W"
IF '$PIECE(B12,U)
QUIT
+19 SET PRIN=$PIECE(B7,U)
SET INT=$PIECE(B7,U,2)
SET ADMIN=$PIECE(B7,U,3)+$PIECE(B7,U,4)+$PIECE(B7,U,5)
+20 IF PRIN'>0
IF INT+ADMIN>0
Begin DoDot:2
+21 NEW XMSUB,XMY,XMTEXT,MSG
+22 SET XMSUB="Notice Of Active Bill Without Principal Balance"
+23 SET XMY("G.DMR")=""
+24 SET XMDUZ="AR PACKAGE"
+25 SET XMTEXT="MSG("
+26 SET MSG(1)="The following bill has a 0 principal balance,"
+27 SET MSG(2)="but has interest/admin charges remaining."
+28 SET MSG(3)="These charges should be exempted"
+29 SET MSG(4)=" "
+30 SET MSG(5)="BILL #: "_$PIECE(B0,U)
+31 DO ^XMD
+32 QUIT
End DoDot:2
QUIT
+33 if $PIECE(B4,U)
QUIT
+34 ;S LTRDT3=$P(B6,U,3) Q:'LTRDT3 Q:LTRDT3>P30DT ; comment out in *343
+35 ; PRCA*4.5*343
SET LTRDT3=$PIECE(B6,U,3)
if 'LTRDT3
QUIT
+36 ; PRCA*4.5*343 - Must be 91 days or more after LETTER1 date
IF +B6>RC91DT
QUIT
+37 ;CHECK FOR DC REFERRAL HERE
+38 IF $PIECE(B6,U,4)
IF ($PIECE(B6,U,5)="DC")!($PIECE(B6,U,5)="RC")
QUIT
+39 ;Q:$$INSURED^IBCNS1(DFN,$P(B0,U,10)) ;Commented out w/patch *121
+40 ;***PRCA*4.5*338 start
+41 SET X=$PIECE(B0,U,2)
+42 ; Check to see if the AR category allows for a DMC referral
+43 if '$$RFCHK^RCTOPD(X,"I",1.01,$PIECE(B6,U,21))
QUIT
+44 ;end PRCA*4.5*338
+45 ;
+46 KILL CATYP(X)
+47 ;Check if bill should be deferred from being sent to DMC if Veteran is
+48 ;SC 50% to 100% or Receiving VA Pension (Hold Debt to DMC project, sbw)
+49 if +$$HOLDCHK^RCDMCUT1(BILL,DFN)>0
QUIT
+50 IF $PIECE(B6,U,21)
IF $PIECE(B6,U,21)<ESTDT
SET ESTDT=$PIECE($PIECE(B6,U,21),".")
+51 IF $PIECE(B12,U,2)
IF PRIN>$PIECE(B12,U,2)
SET PRIN=$PIECE(B12,U,2)
+52 SET ^TMP($JOB,"RCDMC90","BILL",BILL)=$SELECT($PIECE(B12,U):$PIECE(B12,U),1:DT)_U_PRIN_U_INT_U_ADMIN
+53 SET TPRIN=TPRIN+PRIN
SET TINT=TINT+INT
SET TADMIN=TADMIN+ADMIN
+54 QUIT
End DoDot:1
if PRIN=0
KILL ^PRCA(430,BILL,12)
if REPAY
QUIT
TOTAL SET TOTAL=TPRIN+TINT+TADMIN
+1 ;PRCA*4.5*229
IF RCDOC="M"
if TPRIN'>0
QUIT
+2 ;PRCA*4.5*229
IF RCDOC="M"
IF '+$$SWSTAT^IBBAPI()
if TOTAL<25
QUIT
+3 ;
+4 IF RCDOC="M"
IF $PIECE(VADM(2),U)["P"
SET PSSN=$PIECE(VADM(2),U)
DO PSEUDO^RCDMC90U(DFN,PSSN)
QUIT
+5 IF RCDOC="W"
if (TOTAL_U_TPRIN_U_TINT_U_TADMIN)=$PIECE(^RCD(340,DEBTOR,3),U,5,8)
QUIT
+6 SET DFN=+DEBTOR0
+7 ;SETS CATEGORY CODE 1=MEANS TEST,2=PHARMACY,3=INEL.,4=EMER./HUM.
+8 ;5=CHAMPVA,6=TRICARE OR ANY COMBINATION THEREOF
+9 SET CATYP=""
FOR X=1:1:6
if '$DATA(CATYP(X))
SET CATYP=CATYP_X
+10 SET CATYP=$$LJ^XLFSTR(CATYP,6)
+11 ;
+12 ;Send Master/Weekly error msg if Unknown or Invalid address
+13 ;If Master update, quit and don't refer to DMC
+14 ;If Weekly update, send a zero balance
+15 SET LKUP=$$CHKADD(DEBTOR)
+16 IF LKUP
DO ERROR^RCDMC90U(RCDOC,LKUP,DFN)
if RCDOC="M"
QUIT
SET (TOTAL,TPRIN,TINT,TADMIN)=0
+17 ;
+18 SET ZIPCODE=$TRANSLATE($PIECE(ADDR,U,6),"-")
+19 ;
+20 ;Retrieve and format patient phone number
+21 SET ADDRPHO=$PIECE(ADDR,U,7)
SET PHONE=""
+22 FOR I=1:1:$LENGTH(ADDRPHO)
SET CHKPHONE=$EXTRACT(ADDRPHO,I)
IF CHKPHONE?1N
SET PHONE=PHONE_CHKPHONE
+23 SET PHONE=$SELECT(PHONE?10N:PHONE,PHONE?7N:" "_PHONE,1:" ")
+24 ;
+25 IF RCDOC="W"
IF TOTAL=0
Begin DoDot:1
+26 KILL ^RCD(340,"DMC",1,DEBTOR),^RCD(340,DEBTOR,3)
+27 NEW NM,XMSUB,XMY,XMTEXT,MSG
+28 SET XMSUB="Deletion of Debtor from DMC"
+29 SET XMY("G.DMX")=""
+30 SET XMDUZ="AR PACKAGE"
+31 SET XMTEXT="MSG("
+32 SET MSG(1)="The following patient has a DMC balance of '0'"
+33 SET MSG(2)="and will be deleted from the DMC system:"
+34 SET MSG(3)=" "
+35 SET MSG(4)=$PIECE(^DPT(DFN,0),U)_" SSN: "_$PIECE(^(0),U,9)
+36 DO ^XMD
+37 QUIT
End DoDot:1
+38 SET QUIT=0
PROCQ QUIT
DATE8(X) ;CHANGES FILEMAN DATE INTO 8 DIGIT DATE IN FORMAT MMDDYYYY
+1 SET X=$EXTRACT(X,4,7)_($EXTRACT(X,1,3)+1700)
+2 QUIT X
AMT(X) ;CHANGES AMOUNT TO ZERO FILLED, RIGHT JUSTIFIED
+1 SET X=$TRANSLATE($JUSTIFY(X,0,2),".")
+2 SET X=$EXTRACT("000000000",1,9-$LENGTH(X))_X
+3 QUIT X
NM(DFN) ;Returns first, middle, and last name in 3 different variables
+1 NEW FN,LN,MN,NM,XN
+2 SET NM=$PIECE($GET(^DPT(DFN,0)),"^")
+3 SET LN=$TRANSLATE($PIECE(NM,",")," .'-")
SET MN=$PIECE($PIECE(NM,",",2)," ",2)
+4 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 XN=MN
SET MN=""
+5 IF $GET(XN)=""
SET XN=$PIECE($PIECE($GET(NM),",",2)," ",3)
+6 SET FN=$PIECE($PIECE(NM,",",2)," ")
QNM QUIT LN_"^"_XN_"^"_FN_"^"_MN
BAL(DEBTOR) ;COMPUTES TOTAL OF ACTIVE BILLS THAT COULD BE SENT TO DMC
+1 NEW BILL,BAL
+2 SET (BILL,BAL)=0
+3 FOR
SET BILL=$ORDER(^PRCA(430,"C",DEBTOR,BILL))
if BILL'?1N.N
QUIT
Begin DoDot:1
+4 SET B0=$GET(^PRCA(430,BILL,0))
SET B7=$GET(^(7))
+5 if $PIECE(B0,U,8)'=16
QUIT
+6 SET X=$PIECE(B0,U,2)
SET X=$SELECT((X>0)&(X<6):1,X=18:1,(X>21)&(X<26):1,(X>26)&(X<33):1,1:"")
+7 if X=""
QUIT
+8 SET BAL=BAL+$PIECE(B7,U)+$PIECE(B7,U,2)+$PIECE(B7,U,3)+$PIECE(B7,U,4)+$PIECE(B7,U,5)
+9 QUIT
End DoDot:1
BALQ QUIT BAL
SETREC ;SETS TEMPORARY GLOBAL FOR MAIL MESSAGE TO USERS
+1 SET RCNT=RCNT+1
DO PID^VADPT
if $LENGTH(VA("BID"))=4
SET VA("BID")=" "_VA("BID")
+2 SET TLINE=($PIECE(TLINE,U)+TPRIN)_U_($PIECE(TLINE,U,2)+TINT)_U_($PIECE(TLINE,U,3)+TADMIN)
+3 SET ^XTMP("RCDMC90",$JOB,"REC",$PIECE(^DPT(DFN,0),U)_";"_DFN)=$$LJ^XLFSTR($EXTRACT($PIECE(^DPT(DFN,0),U),1,28),29)_" "_VA("BID")_" "_$JUSTIFY(TPRIN,10,2)_$JUSTIFY(TINT,10,2)_$JUSTIFY(TADMIN,10,2)_$JUSTIFY(TOTAL,10,2)
+4 QUIT
+5 ;
CHKADD(DEBTOR) ; Checks for invalid and unknown addresses
+1 NEW CHK
SET CHK=0
SET ADDR=""
+2 IF $PIECE($GET(^RCD(340,+DEBTOR,1)),"^",9)=1
SET CHK=1
GOTO CHKADDQ
+3 ;get address (confidential if possible)
SET ADDR=$$DADD^RCAMADD(+DEBTOR,1)
+4 IF ADDR'?.ANP!(ADDR["$")!(ADDR["**")!(ADDR["///")!(ADDR["ZZZ")
SET CHK=2
CHKADDQ QUIT CHK
+1 ;
