- Timestamp:
- Dec 4, 2009, 12:11:15 AM (14 years ago)
- File:
-
- 1 edited
Legend:
- Unmodified
- Added
- Removed
-
WorldVistAEHR/trunk/r/ACCOUNTS_RECEIVABLE-PRCA-PRY-RC/RCDMC90.m
r613 r623 1 RCDMC90 ;WASH IRMFO@ALTOONA,PA/TJK-DMC 90 DAY ;7/17/97 8:13 AM 2 V ;;4.5;Accounts Receivable;**45,108,133,121,163,190,192,236,237,229,253**;Mar 20, 1995;Build 9 3 ;;Per VHA Directive 2004-038, this routine should not be modified. 4 ENTER ;Entry point from nightly process 5 Q:'$D(RCDOC) 6 ;run the interest and admin for newly flagged Katrina Patients. 7 I DT'<$P($G(^RC(342,1,30)),"^",1)&(DT'>$P($G(^RC(342,1,30)),"^",2)) D ^RCEXINAD 8 N DEBTOR,BILL,DEBTOR0,B0,B6,B7,LTRDT3,P30DT,PRIN,INT,ADMIN,B4,B12 9 N TPRIN,TINT,TADMIN,ESTDT,CATYP,DFN,CNTR,SITE,LN,FN,MN,STNM,DOB,SITE 10 N PHONE,QUIT,TOTAL,ZIPCODE,FULLNM,XN,P91DT,OFFAMT,RCNT,TLINE,REPAY,X1,X2 11 N LKUP,ADDR,ADDRPHO,CHKPHONE,PSSN 12 K ^XTMP("RCDMC90",$J),^TMP($J,"RCDMC90") S ^XTMP("RCDMC90",0)=DT 13 S SITE=$$SITE^RCMSITE(),TLINE="0^0^0" 14 S X1=DT,X2=-91 D C^%DTC S P91DT=X 15 S X1=DT,X2=-30 D C^%DTC S P30DT=X 16 S (CNTR,DEBTOR)=0,RCNT=2 G UPDATE:$G(RCDOC)="W" 17 ;MASTER SHEET COMPILATION 18 F S DEBTOR=$O(^PRCA(430,"C",DEBTOR)) Q:DEBTOR'?1N.N D 19 .N X,RCDFN 20 .S RCDFN=$P($G(^RCD(340,DEBTOR,0)),"^",1) I $P(RCDFN,";",2)'["DPT" Q 21 .S X=$$EMERES^PRCAUTL(+RCDFN) I X]""&('$D(^RCD(340,"DMC",1,DEBTOR))) Q ;stop the master sheet compilation for hurricane Katrina sites 22 .K ^TMP($J,"RCDMC90","BILL") 23 .S QUIT=1,OFFAMT=+$P($G(^RCD(340,DEBTOR,3)),U,9) 24 .D PROC(DEBTOR,.QUIT) Q:QUIT 25 .;COMPILES FIELDS UNIQUE TO MASTER CODE SHEETS 26 .S FULLNM=$$NM(DFN),FN=$P(FULLNM,U,3),MN=$P(FULLNM,U,4) 27 .S LN=$P(FULLNM,U,1),XN=$P(FULLNM,U,2) 28 .S FULLNM=FN_" "_$S(MN'="":$P(MN,".")_" ",1:"")_LN_$S(XN'="":" "_$P(XN,"."),1:"") 29 .S STNM=$$LJ^XLFSTR($E(FN)_$S(MN'="":$E(MN),1:" ")_$E(LN,1,5),7," ") 30 .S DOB=$$DATE8(+VADM(3)) 31 .;SET HOLDING GLOBAL FOR MASTER SHEETS 32 .S CNTR=CNTR+1 33 .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) 34 .S CNTR=CNTR+1 35 .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) 36 .S CNTR=CNTR+1 37 .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) 38 .S CNTR=CNTR+1 39 .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) 40 .S CNTR=CNTR+1 41 .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_"$" 42 .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)="" 43 .S X=0 F S X=$O(^TMP($J,"RCDMC90","BILL",X)) Q:'X S ^PRCA(430,X,12)=^(X) 44 .D SETREC 45 .Q 46 D COMPILE^RCDMC90U(375,CNTR,5,TLINE),KVAR 47 Q 48 UPDATE ;WEEKLY UPDATE COMPILATION 49 F S DEBTOR=$O(^RCD(340,"DMC",1,DEBTOR)) Q:DEBTOR'?1N.N D 50 .I '$G(^RCD(340,DEBTOR,3)) K ^RCD(340,"DMC",1,DEBTOR) Q 51 .S QUIT=1,OFFAMT=+$P(^RCD(340,DEBTOR,3),U,9) 52 .D PROC(DEBTOR,.QUIT) Q:QUIT 53 .;SET HOLDING GLOBAL FOR WEEKLY UPDATES 54 .S CNTR=CNTR+1 55 .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) 56 .S CNTR=CNTR+1 57 .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) 58 .S CNTR=CNTR+1 59 .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) 60 .S CNTR=CNTR+1 61 .S ^XTMP("RCDMC90",$J,CNTR)=$E($$AMT(TPRIN),7,9)_$$AMT(TINT)_$$AMT(TADMIN)_$$DATE8(DT)_CATYP_$$AMT(OFFAMT)_$$AMT($$BAL(DEBTOR))_"$" 62 .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 63 .D SETREC 64 .Q 65 D COMPILE^RCDMC90U(300,CNTR,4,TLINE),KVAR 66 Q 67 KVAR D KVAR^VADPT 68 K RCDOC,^XTMP("RCDMC90",$J),VA("BID"),XMDUZ 69 Q 70 PROC(DEBTOR,QUIT) ;PROCESS BILLS FOR A SPECIFIC DEBTOR 71 ;SETS DATA COMMON TO BOTH WEEKLY & MASTER CODESHEETS 72 S DEBTOR0=$G(^RCD(340,DEBTOR,0)) 73 Q:$P(DEBTOR0,U)'["DPT" 74 S DFN=+DEBTOR0 D DEM^VADPT Q:$E(VADM(2),1,5)="00000" 75 F X=1:1:6 S CATYP(X)="" 76 S (BILL,TOTAL,TPRIN,TINT,TADMIN,REPAY)=0,ESTDT=P91DT 77 I RCDOC="W",$P(^RCD(340,DEBTOR,3),U,10) G TOTAL 78 F S BILL=$O(^PRCA(430,"C",DEBTOR,BILL)) Q:BILL'?1N.N D K:PRIN=0 ^PRCA(430,BILL,12) Q:REPAY 79 .S (PRIN,INT,ADMIN)=0 80 .I +VADM(6) Q 81 .S B0=$G(^PRCA(430,BILL,0)),B4=$G(^(4)),B6=$G(^(6)),B7=$G(^(7)),B12=$G(^(12)) 82 .Q:$P(B0,U,8)'=16 83 .I B4 D Q 84 ..S (TOTAL,TPRIN,TINT,TADMIN)=0 85 ..S X=0 F S X=$O(^PRCA(430,"C",DEBTOR,X)) Q:X'?1N.N K ^PRCA(430,X,12) 86 ..S REPAY=1 87 ..Q 88 .I RCDOC="W",'$P(B12,U) Q 89 .S PRIN=$P(B7,U),INT=$P(B7,U,2),ADMIN=$P(B7,U,3)+$P(B7,U,4)+$P(B7,U,5) 90 .I PRIN'>0,INT+ADMIN>0 D Q 91 ..N XMSUB,XMY,XMTEXT,MSG 92 ..S XMSUB="Notice Of Active Bill Without Principal Balance" 93 ..S XMY("G.DMR")="" 94 ..S XMDUZ="AR PACKAGE" 95 ..S XMTEXT="MSG(" 96 ..S MSG(1)="The following bill has a 0 principal balance," 97 ..S MSG(2)="but has interest/admin charges remaining." 98 ..S MSG(3)="These charges should be exempted" 99 ..S MSG(4)=" " 100 ..S MSG(5)="BILL #: "_$P(B0,U) 101 ..D ^XMD 102 ..Q 103 .Q:$P(B4,U) 104 .S LTRDT3=$P(B6,U,3) Q:'LTRDT3 Q:LTRDT3>P30DT 105 .;CHECK FOR DC REFERRAL HERE 106 .I $P(B6,U,4),($P(B6,U,5)="DC")!($P(B6,U,5)="RC") Q 107 .;Q:$$INSURED^IBCNS1(DFN,$P(B0,U,10)) ;Commented out w/patch *121 108 .S X=$P(B0,U,2),X=$S(X=22:1,X=23:1,(X>2)&(X<6):2,X=18:2,X=24:2,X=25:2,X=1:3,X=2:4,(X>26)&(X<30):5,X>29:6,1:"") 109 .Q:X="" K CATYP(X) 110 .;Check if bill should be deferred from being sent to DMC if Veteran is 111 .;SC 50% to 100% or Receiving VA Pension (Hold Debt to DMC project, sbw) 112 .Q:+$$HOLDCHK^RCDMCUT1(BILL,DFN)>0 113 .I $P(B6,U,21),$P(B6,U,21)<ESTDT S ESTDT=$P($P(B6,U,21),".") 114 .I $P(B12,U,2),PRIN>$P(B12,U,2) S PRIN=$P(B12,U,2) 115 .S ^TMP($J,"RCDMC90","BILL",BILL)=$S($P(B12,U):$P(B12,U),1:DT)_U_PRIN_U_INT_U_ADMIN 116 .S TPRIN=TPRIN+PRIN,TINT=TINT+INT,TADMIN=TADMIN+ADMIN 117 .Q 118 TOTAL S TOTAL=TPRIN+TINT+TADMIN 119 I RCDOC="M" Q:TPRIN'>0 ;PRCA*4.5*229 120 I RCDOC="M",'+$$SWSTAT^IBBAPI() Q:TOTAL<25 ;PRCA*4.5*229 121 ; 122 I RCDOC="M",$P(VADM(2),U)["P" S PSSN=$P(VADM(2),U) D PSEUDO^RCDMC90U(DFN,PSSN) Q 123 I RCDOC="W" Q:(TOTAL_U_TPRIN_U_TINT_U_TADMIN)=$P(^RCD(340,DEBTOR,3),U,5,8) 124 S DFN=+DEBTOR0 125 ;SETS CATEGORY CODE 1=MEANS TEST,2=PHARMACY,3=INEL.,4=EMER./HUM. 126 ;5=CHAMPVA,6=TRICARE OR ANY COMBINATION THEREOF 127 S CATYP="" F X=1:1:6 S:'$D(CATYP(X)) CATYP=CATYP_X 128 S CATYP=$$LJ^XLFSTR(CATYP,6) 129 ; 130 ;Send Master/Weekly error msg if Unknown or Invalid address 131 ;If Master update, quit and don't refer to DMC 132 ;If Weekly update, send a zero balance 133 S LKUP=$$CHKADD(DEBTOR) 134 I LKUP D ERROR^RCDMC90U(RCDOC,LKUP,DFN) Q:RCDOC="M" S (TOTAL,TPRIN,TINT,TADMIN)=0 135 ; 136 S ZIPCODE=$TR($P(ADDR,U,6),"-") 137 ; 138 ;Retrieve and format patient phone number 139 S ADDRPHO=$P(ADDR,U,7),PHONE="" 140 F I=1:1:$L(ADDRPHO) S CHKPHONE=$E(ADDRPHO,I) I CHKPHONE?1N S PHONE=PHONE_CHKPHONE 141 S PHONE=$S(PHONE?10N:PHONE,PHONE?7N:" "_PHONE,1:" ") 142 ; 143 I RCDOC="W",TOTAL=0 D 144 .K ^RCD(340,"DMC",1,DEBTOR),^RCD(340,DEBTOR,3) 145 .N NM,XMSUB,XMY,XMTEXT,MSG 146 .S XMSUB="Deletion of Debtor from DMC" 147 .S XMY("G.DMX")="" 148 .S XMDUZ="AR PACKAGE" 149 .S XMTEXT="MSG(" 150 .S MSG(1)="The following patient has a DMC balance of '0'" 151 .S MSG(2)="and will be deleted from the DMC system:" 152 .S MSG(3)=" " 153 .S MSG(4)=$P(^DPT(DFN,0),U)_" SSN: "_$P(^(0),U,9) 154 .D ^XMD 155 .Q 156 S QUIT=0 157 PROCQ Q 158 DATE8(X) ;CHANGES FILEMAN DATE INTO 8 DIGIT DATE IN FORMAT MMDDYYYY 159 S X=$E(X,4,7)_($E(X,1,3)+1700) 160 Q X 161 AMT(X) ;CHANGES AMOUNT TO ZERO FILLED, RIGHT JUSTIFIED 162 S X=$TR($J(X,0,2),".") 163 S X=$E("000000000",1,9-$L(X))_X 164 Q X 165 NM(DFN) ;Returns first, middle, and last name in 3 different variables 166 N FN,LN,MN,NM,XN 167 S NM=$P($G(^DPT(DFN,0)),"^") 168 S LN=$TR($P(NM,",")," .'-"),MN=$P($P(NM,",",2)," ",2) 169 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="" 170 I $G(XN)="" S XN=$P($P($G(NM),",",2)," ",3) 171 S FN=$P($P(NM,",",2)," ") 172 QNM Q LN_"^"_XN_"^"_FN_"^"_MN 173 BAL(DEBTOR) ;COMPUTES TOTAL OF ACTIVE BILLS THAT COULD BE SENT TO DMC 174 N BILL,BAL 175 S (BILL,BAL)=0 176 F S BILL=$O(^PRCA(430,"C",DEBTOR,BILL)) Q:BILL'?1N.N D 177 .S B0=$G(^PRCA(430,BILL,0)),B7=$G(^(7)) 178 .Q:$P(B0,U,8)'=16 179 .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:"") 180 .Q:X="" 181 .S BAL=BAL+$P(B7,U)+$P(B7,U,2)+$P(B7,U,3)+$P(B7,U,4)+$P(B7,U,5) 182 .Q 183 BALQ Q BAL 184 SETREC ;SETS TEMPORARY GLOBAL FOR MAIL MESSAGE TO USERS 185 S RCNT=RCNT+1 D PID^VADPT S:$L(VA("BID"))=4 VA("BID")=" "_VA("BID") 186 S TLINE=($P(TLINE,U)+TPRIN)_U_($P(TLINE,U,2)+TINT)_U_($P(TLINE,U,3)+TADMIN) 187 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) 188 Q 189 ; 190 CHKADD(DEBTOR) ; Checks for invalid and unknown addresses 191 N CHK S CHK=0,ADDR="" 192 I $P($G(^RCD(340,+DEBTOR,1)),"^",9)=1 S CHK=1 G CHKADDQ 193 S ADDR=$$DADD^RCAMADD(+DEBTOR,1) ;get address (confidential if possible) 194 I ADDR'?.ANP!(ADDR["$")!(ADDR["**")!(ADDR["///")!(ADDR["ZZZ") S CHK=2 195 CHKADDQ Q CHK 196 ; 1 RCDMC90 ;WASH IRMFO@ALTOONA,PA/TJK-DMC 90 DAY ;7/17/97 8:13 AM 2 V ;;4.5;Accounts Receivable;**45,108,133,121,163,190,192,236,237,229**;Mar 20, 1995 3 ;;Per VHA Directive 10-93-142, this routine should not be modified. 4 ENTER ;Entry point from nightly process 5 Q:'$D(RCDOC) 6 ;run the interest and admin for newly flagged Katrina Patients. 7 I DT'<$P($G(^RC(342,1,30)),"^",1)&(DT'>$P($G(^RC(342,1,30)),"^",2)) D ^RCEXINAD 8 N DEBTOR,BILL,DEBTOR0,B0,B6,B7,LTRDT3,P30DT,PRIN,INT,ADMIN,B4,B12 9 N TPRIN,TINT,TADMIN,ESTDT,CATYP,DFN,CNTR,SITE,LN,FN,MN,STNM,DOB,SITE 10 N PHONE,QUIT,TOTAL,ZIPCODE,FULLNM,XN,P91DT,OFFAMT,RCNT,TLINE,REPAY,X1,X2 11 N LKUP,ADDR,ADDRPHO,CHKPHONE,PSSN 12 K ^XTMP("RCDMC90",$J),^TMP($J,"RCDMC90") S ^XTMP("RCDMC90",0)=DT 13 S SITE=$$SITE^RCMSITE(),TLINE="0^0^0" 14 S X1=DT,X2=-91 D C^%DTC S P91DT=X 15 S X1=DT,X2=-30 D C^%DTC S P30DT=X 16 S (CNTR,DEBTOR)=0,RCNT=2 G UPDATE:$G(RCDOC)="W" 17 ;MASTER SHEET COMPILATION 18 F S DEBTOR=$O(^PRCA(430,"C",DEBTOR)) Q:DEBTOR'?1N.N D 19 .N X,RCDFN 20 .S RCDFN=$P($G(^RCD(340,DEBTOR,0)),"^",1) I $P(RCDFN,";",2)'["DPT" Q 21 .S X=$$EMERES^PRCAUTL(+RCDFN) I X]""&('$D(^RCD(340,"DMC",1,DEBTOR))) Q ;stop the master sheet compilation for hurricane Katrina sites 22 .K ^TMP($J,"RCDMC90","BILL") 23 .S QUIT=1,OFFAMT=+$P($G(^RCD(340,DEBTOR,3)),U,9) 24 .D PROC(DEBTOR,.QUIT) Q:QUIT 25 .;COMPILES FIELDS UNIQUE TO MASTER CODE SHEETS 26 .S FULLNM=$$NM(DFN),FN=$P(FULLNM,U,3),MN=$P(FULLNM,U,4) 27 .S LN=$P(FULLNM,U,1),XN=$P(FULLNM,U,2) 28 .S FULLNM=FN_" "_$S(MN'="":$P(MN,".")_" ",1:"")_LN_$S(XN'="":" "_$P(XN,"."),1:"") 29 .S STNM=$$LJ^XLFSTR($E(FN)_$S(MN'="":$E(MN),1:" ")_$E(LN,1,5),7," ") 30 .S DOB=$$DATE8(+VADM(3)) 31 .;SET HOLDING GLOBAL FOR MASTER SHEETS 32 .S CNTR=CNTR+1 33 .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) 34 .S CNTR=CNTR+1 35 .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) 36 .S CNTR=CNTR+1 37 .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) 38 .S CNTR=CNTR+1 39 .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) 40 .S CNTR=CNTR+1 41 .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_"$" 42 .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)="" 43 .S X=0 F S X=$O(^TMP($J,"RCDMC90","BILL",X)) Q:'X S ^PRCA(430,X,12)=^(X) 44 .D SETREC 45 .Q 46 D COMPILE^RCDMC90U(375,CNTR,5,TLINE),KVAR 47 Q 48 UPDATE ;WEEKLY UPDATE COMPILATION 49 F S DEBTOR=$O(^RCD(340,"DMC",1,DEBTOR)) Q:DEBTOR'?1N.N D 50 .I '$G(^RCD(340,DEBTOR,3)) K ^RCD(340,"DMC",1,DEBTOR) Q 51 .S QUIT=1,OFFAMT=+$P(^RCD(340,DEBTOR,3),U,9) 52 .D PROC(DEBTOR,.QUIT) Q:QUIT 53 .;SET HOLDING GLOBAL FOR WEEKLY UPDATES 54 .S CNTR=CNTR+1 55 .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) 56 .S CNTR=CNTR+1 57 .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) 58 .S CNTR=CNTR+1 59 .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) 60 .S CNTR=CNTR+1 61 .S ^XTMP("RCDMC90",$J,CNTR)=$E($$AMT(TPRIN),7,9)_$$AMT(TINT)_$$AMT(TADMIN)_$$DATE8(DT)_CATYP_$$AMT(OFFAMT)_$$AMT($$BAL(DEBTOR))_"$" 62 .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 63 .D SETREC 64 .Q 65 D COMPILE^RCDMC90U(300,CNTR,4,TLINE),KVAR 66 Q 67 KVAR D KVAR^VADPT 68 K RCDOC,^XTMP("RCDMC90",$J),VA("BID"),XMDUZ 69 Q 70 PROC(DEBTOR,QUIT) ;PROCESS BILLS FOR A SPECIFIC DEBTOR 71 ;SETS DATA COMMON TO BOTH WEEKLY & MASTER CODESHEETS 72 S DEBTOR0=$G(^RCD(340,DEBTOR,0)) 73 Q:$P(DEBTOR0,U)'["DPT" 74 S DFN=+DEBTOR0 D DEM^VADPT Q:$E(VADM(2),1,5)="00000" 75 F X=1:1:6 S CATYP(X)="" 76 S (BILL,TOTAL,TPRIN,TINT,TADMIN,REPAY)=0,ESTDT=P91DT 77 I RCDOC="W",$P(^RCD(340,DEBTOR,3),U,10) G TOTAL 78 F S BILL=$O(^PRCA(430,"C",DEBTOR,BILL)) Q:BILL'?1N.N D K:PRIN=0 ^PRCA(430,BILL,12) Q:REPAY 79 .S (PRIN,INT,ADMIN)=0 80 .I +VADM(6) Q 81 .S B0=$G(^PRCA(430,BILL,0)),B4=$G(^(4)),B6=$G(^(6)),B7=$G(^(7)),B12=$G(^(12)) 82 .Q:$P(B0,U,8)'=16 83 .I B4 D Q 84 ..S (TOTAL,TPRIN,TINT,TADMIN)=0 85 ..S X=0 F S X=$O(^PRCA(430,"C",DEBTOR,X)) Q:X'?1N.N K ^PRCA(430,X,12) 86 ..S REPAY=1 87 ..Q 88 .I RCDOC="W",'$P(B12,U) Q 89 .S PRIN=$P(B7,U),INT=$P(B7,U,2),ADMIN=$P(B7,U,3)+$P(B7,U,4)+$P(B7,U,5) 90 .I PRIN'>0,INT+ADMIN>0 D Q 91 ..N XMSUB,XMY,XMTEXT,MSG 92 ..S XMSUB="Notice Of Active Bill Without Principal Balance" 93 ..S XMY("G.DMR")="" 94 ..S XMDUZ="AR PACKAGE" 95 ..S XMTEXT="MSG(" 96 ..S MSG(1)="The following bill has a 0 principal balance," 97 ..S MSG(2)="but has interest/admin charges remaining." 98 ..S MSG(3)="These charges should be exempted" 99 ..S MSG(4)=" " 100 ..S MSG(5)="BILL #: "_$P(B0,U) 101 ..D ^XMD 102 ..Q 103 .Q:$P(B4,U) 104 .S LTRDT3=$P(B6,U,3) Q:'LTRDT3 Q:LTRDT3>P30DT 105 .;CHECK FOR DC REFERRAL HERE 106 .I $P(B6,U,4),($P(B6,U,5)="DC")!($P(B6,U,5)="RC") Q 107 .;Q:$$INSURED^IBCNS1(DFN,$P(B0,U,10)) ;Commented out w/patch *121 108 .S X=$P(B0,U,2),X=$S(X=22:1,X=23:1,(X>2)&(X<6):2,X=18:2,X=24:2,X=25:2,X=1:3,X=2:4,(X>26)&(X<30):5,X>29:6,1:"") 109 .Q:X="" K CATYP(X) 110 .I $P(B6,U,21),$P(B6,U,21)<ESTDT S ESTDT=$P($P(B6,U,21),".") 111 .I $P(B12,U,2),PRIN>$P(B12,U,2) S PRIN=$P(B12,U,2) 112 .S ^TMP($J,"RCDMC90","BILL",BILL)=$S($P(B12,U):$P(B12,U),1:DT)_U_PRIN_U_INT_U_ADMIN 113 .S TPRIN=TPRIN+PRIN,TINT=TINT+INT,TADMIN=TADMIN+ADMIN 114 .Q 115 TOTAL S TOTAL=TPRIN+TINT+TADMIN 116 I RCDOC="M" Q:TPRIN'>0 ;PRCA*4.5*229 117 I RCDOC="M",'+$$SWSTAT^IBBAPI() Q:TOTAL<25 ;PRCA*4.5*229 118 ; 119 I RCDOC="M",$P(VADM(2),U)["P" S PSSN=$P(VADM(2),U) D PSEUDO^RCDMC90U(DFN,PSSN) Q 120 I RCDOC="W" Q:(TOTAL_U_TPRIN_U_TINT_U_TADMIN)=$P(^RCD(340,DEBTOR,3),U,5,8) 121 S DFN=+DEBTOR0 122 ;SETS CATEGORY CODE 1=MEANS TEST,2=PHARMACY,3=INEL.,4=EMER./HUM. 123 ;5=CHAMPVA,6=TRICARE OR ANY COMBINATION THEREOF 124 S CATYP="" F X=1:1:6 S:'$D(CATYP(X)) CATYP=CATYP_X 125 S CATYP=$$LJ^XLFSTR(CATYP,6) 126 ; 127 ;Send Master/Weekly error msg if Unknown or Invalid address 128 ;If Master update, quit and don't refer to DMC 129 ;If Weekly update, send a zero balance 130 S LKUP=$$CHKADD(DEBTOR) 131 I LKUP D ERROR^RCDMC90U(RCDOC,LKUP,DFN) Q:RCDOC="M" S (TOTAL,TPRIN,TINT,TADMIN)=0 132 ; 133 S ZIPCODE=$TR($P(ADDR,U,6),"-") 134 ; 135 ;Retrieve and format patient phone number 136 S ADDRPHO=$P(ADDR,U,7),PHONE="" 137 F I=1:1:$L(ADDRPHO) S CHKPHONE=$E(ADDRPHO,I) I CHKPHONE?1N S PHONE=PHONE_CHKPHONE 138 S PHONE=$S(PHONE?10N:PHONE,PHONE?7N:" "_PHONE,1:" ") 139 ; 140 I RCDOC="W",TOTAL=0 D 141 .K ^RCD(340,"DMC",1,DEBTOR),^RCD(340,DEBTOR,3) 142 .N NM,XMSUB,XMY,XMTEXT,MSG 143 .S XMSUB="Deletion of Debtor from DMC" 144 .S XMY("G.DMX")="" 145 .S XMDUZ="AR PACKAGE" 146 .S XMTEXT="MSG(" 147 .S MSG(1)="The following patient has a DMC balance of '0'" 148 .S MSG(2)="and will be deleted from the DMC system:" 149 .S MSG(3)=" " 150 .S MSG(4)=$P(^DPT(DFN,0),U)_" SSN: "_$P(^(0),U,9) 151 .D ^XMD 152 .Q 153 S QUIT=0 154 PROCQ Q 155 DATE8(X) ;CHANGES FILEMAN DATE INTO 8 DIGIT DATE IN FORMAT MMDDYYYY 156 S X=$E(X,4,7)_($E(X,1,3)+1700) 157 Q X 158 AMT(X) ;CHANGES AMOUNT TO ZERO FILLED, RIGHT JUSTIFIED 159 S X=$TR($J(X,0,2),".") 160 S X=$E("000000000",1,9-$L(X))_X 161 Q X 162 NM(DFN) ;Returns first, middle, and last name in 3 different variables 163 N FN,LN,MN,NM,XN 164 S NM=$P($G(^DPT(DFN,0)),"^") 165 S LN=$TR($P(NM,",")," .'-"),MN=$P($P(NM,",",2)," ",2) 166 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="" 167 I $G(XN)="" S XN=$P($P($G(NM),",",2)," ",3) 168 S FN=$P($P(NM,",",2)," ") 169 QNM Q LN_"^"_XN_"^"_FN_"^"_MN 170 BAL(DEBTOR) ;COMPUTES TOTAL OF ACTIVE BILLS THAT COULD BE SENT TO DMC 171 N BILL,BAL 172 S (BILL,BAL)=0 173 F S BILL=$O(^PRCA(430,"C",DEBTOR,BILL)) Q:BILL'?1N.N D 174 .S B0=$G(^PRCA(430,BILL,0)),B7=$G(^(7)) 175 .Q:$P(B0,U,8)'=16 176 .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:"") 177 .Q:X="" 178 .S BAL=BAL+$P(B7,U)+$P(B7,U,2)+$P(B7,U,3)+$P(B7,U,4)+$P(B7,U,5) 179 .Q 180 BALQ Q BAL 181 SETREC ;SETS TEMPORARY GLOBAL FOR MAIL MESSAGE TO USERS 182 S RCNT=RCNT+1 D PID^VADPT S:$L(VA("BID"))=4 VA("BID")=" "_VA("BID") 183 S TLINE=($P(TLINE,U)+TPRIN)_U_($P(TLINE,U,2)+TINT)_U_($P(TLINE,U,3)+TADMIN) 184 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) 185 Q 186 ; 187 CHKADD(DEBTOR) ; Checks for invalid and unknown addresses 188 N CHK S CHK=0,ADDR="" 189 I $P($G(^RCD(340,+DEBTOR,1)),"^",9)=1 S CHK=1 G CHKADDQ 190 S ADDR=$$DADD^RCAMADD(+DEBTOR,1) ;get address (confidential if possible) 191 I ADDR'?.ANP!(ADDR["$")!(ADDR["**")!(ADDR["///")!(ADDR["ZZZ") S CHK=2 192 CHKADDQ Q CHK 193 ;
Note:
See TracChangeset
for help on using the changeset viewer.
