BAR50P04 ; IHS/SD/LSL - MATCH REASONS AND CLAIMS ; 01/09/2009
;;1.8;IHS ACCOUNTS RECEIVABLE;**5,6,10,20,21,22,23,24,26,28**;OCT 26, 2005;Build 92
;IHS/SD/POT 1.8*23 HEAT87149 FIXING LINE +210
;IHS/SD/POT 1.8*23 HEAT82698 LEADING ZEROES IN BILL #
;IHS/SD/POT 1.8*23 FIX INIT VALUE OF CLMDA (+27)
;IHS/SD/POT 1.8*24 HEAT147572 ALLOW TRIBAL SITES ERA POSTING OF NEG BAL & CANCELLED BILLS 1/15/2014; 2/5/2014
;IHS/SD/POT 1.8*26 HEAT170856 correct non-ihs functionality when parm "ALLOW ERA POSTING NEG BALANCES" set
;IHS/SD/SDR 1.8*26 HEAT170856 Made changes so BLMT and REV work same. One would add reasons that other would take away. Also corrected check for Allow ERA cancelled clm parm.
;IHS/SD/SDR 1.8*26 HEAT233443 - Stopped MAXNUMBER error. Occurred when 'E' is in CLP01 element. Changed it to 'A'. We look for bill number (excluding alpha) so most matches are made so it doesn't matter
; that it is 'A' instead of 'E'.
;IHS/SD/SDR 1.8*28 CR8347 HEAT281465 If CLP01=0 make it still go through process so it will change status from BUILT to CLAIM UNMATCHED w/reason NTP of no RPMS bill.
;IHS/SD/SDR 1.8*28 CR9572 HEAT258378 Fixed if they don't pick anything when mult. potential matches; also made it so mult. potential matches and none picked is Claim Unmatched w/RNTP of UOR.
EN(TRDA,IMPDA) ;EP ;SCAN CLMS BUILT "B" STATUS
N REVERSAL,ERACHECK
D INIT^BARUTL
W !,"Matching E-Claims to A/R Bills and Reason Codes",!
I TRNAME["HIPAA" D Q
.S INDEX="B"
.D INDEX,PRT^BAR50DET
F INDEX="B","X","C","R" D INDEX,PRT^BAR50DET
Q
INDEX ;EP
S QFLG=0
W !,"Processing Claim Status using claim Index ",INDEX,!
S BARDBG=1 ;1=build detail matching report ;IHS/DIT/CPC - BAR*1.8*28
K ^XTMP("BAR-LIST_DETAIL",$J,DUZ(2))
K ^XTMP("BAR-LIST",$J,DUZ(2))
S BARMSG="PERFORMING TRADITIONAL HIPAA CHECKS...("_$$FTYPE()_")" W !,BARMSG
I $G(BARDBG) D INS^BAR50DET(BARMSG,0)
K BARFLG
S CLMDA=0 F S CLMDA=$O(^BAREDI("I",DUZ(2),IMPDA,30,CLMDA)) Q:'CLMDA S ^XTMP("BAR-LIST",$J,DUZ(2),$P($G(^BAREDI("I",DUZ(2),IMPDA,30,CLMDA,0)),U),CLMDA)=""
S CLMCNT=0,BARBL=""
;F S BARBL=$O(^XTMP("BAR-LIST",$J,DUZ(2),BARBL)) Q:BARBL="" D Q:QFLG=1 ;bar*1.8*26 IHS/SD/SDR HEAT170856
F S BARBL=$O(^XTMP("BAR-LIST",$J,DUZ(2),BARBL)) Q:BARBL="" D ;bar*1.8*26 IHS/SD/SDR HEAT170856
.S CLMDA=0
.;F S CLMDA=$O(^XTMP("BAR-LIST",$J,DUZ(2),BARBL,CLMDA)) Q:'CLMDA K ERRS D CLMFLG(CLMDA,.ERRORS) Q:$G(QFLG)=1 ;bar*1.8*26 IHS/SD/SDR HEAT170856
.F S CLMDA=$O(^XTMP("BAR-LIST",$J,DUZ(2),BARBL,CLMDA)) Q:'CLMDA K ERRS D CLMFLG(CLMDA,.ERRORS) ;bar*1.8*26 IHS/SD/SDR HEAT170856
;Q:QFLG=1 ;bar*1.8*29 IHS/SD/SDR HEAT170856
S BARFLG=$$EN^BAR50P0Z(IMPDA) ;PLB/Pymt Rev/Neg pymt amt chks
;old D:$$IHS^BARUFUT(DUZ(2)) NEGBAL^BAR50EB(IMPDA,"ERA") ;CHK FOR NEG BAL IN RPMS BILLS
D NEGBAL^BAR50EB(IMPDA,"ERA") ;note:IHS/TRIBAL CHK INSIDE BAR50EB CHK FOR NEG BAL IN RPMS BILLS HEAT147572 MOD: 2/5/2014
;NOTE: MATCHED PYMTS & CREDITS W/HAVE THE 'POST THIS CLM AS TYPE' FLD = TO 20=PYMT CREDIT
;D:$$IHS^BARUFUT(DUZ(2)) NONPAYCH^BAR50EP1(IMPDA) ;CHK PYMTS NOT MATCHED TO REV TO SEE IF BEING POSTED TO 'NONPYMT' BATCH ;bar*1.8*26 IHS/SD/POT HEAT170856
D:$$IHSNEGB^BARUFUT(DUZ(2)) NONPAYCH^BAR50EP1(IMPDA) ;bar*1.8*26 IHS/SD/POT HEAT170856
;K ERRORS
Q
CLMFLG(CLMDA,ERRORS) ;EP
;NEXT LINE MOVED TO TOP OF SUBR
I (($P($G(^BAREDI("I",DUZ(2),IMPDA,30,CLMDA,2)),U))'=($P($G(^BAREDI("I",DUZ(2),IMPDA,5,BARCKIEN,0)),U))) D Q ;only look at 1 chk's clms
N BARTMPM,BARTMPCL ;RETURN FLAG
S BILMATCH=0
S BARTMPCL=$P($G(^BAREDI("I",DUZ(2),IMPDA,30,CLMDA,0)),U)
I $G(BARDBG) D
.D INS^BAR50DET($$LINE(),0)
.S BARMSG="PROCESSING ENTRY: "_$J(CLMDA,6)_" CLAIM "_BARTMPCL W !,BARMSG
.D INS^BAR50DET(BARMSG,0)
;start old bar*1.8*28 IHS/SD/SDR CR8347 HEAT281465
;I BARTMPCL=0 D Q
;.S BARMSG=" INVALID CLAIM NUMBER" W BARMSG
;.D INS^BAR50DET(BARMSG,1)
;end old bar*1.8*28 IHS/SD/SDR CR8347 HEAT281465
I $P($G(^BAREDI("I",DUZ(2),IMPDA,30,CLMDA,0)),U,2)="P" D Q ;quit if posted
.I $G(BARDBG) D INS^BAR50DET(" POSTED - SKIPP",1)
;S BARTMPM=$$OVERIDE^BAR50EP1(CLMDA) I BARTMPM D Q ;P.OTT ;bar*1.8*26 IHS/SD/SDR HEAT170856
.I $G(BARDBG) D INS^BAR50DET(" OVERRIDE: "_$P(BARTMPM,"^",2),1)
I $P($G(^BAREDI("I",DUZ(2),IMPDA,30,CLMDA,0)),U,2)="E" D Q ;user marked as Exception-skip
.I $G(BARDBG) D INS^BAR50DET(" EXCEPTION - SKIP",1)
D DELREAS(IMPDA,CLMDA) ;CLR ERRORS, SET STAT TO MATCHED, BEGIN BY ASSUMING ALL CLMS ARE MATCHED & ERROR FREE
;CHK & SET CLM MATCH STATUS
I TRNAME["HIPAA" D
.S CLMCNT=+$G(CLMCNT)+1
.I $G(BARDBG) W !?2,CLMCNT,?10,BARBL," ",$P($G(^BAREDI("I",DUZ(2),IMPDA,30,CLMDA,0)),U)
.S CLMFLG=$$HIPAACLM(IMPDA,CLMDA,.ERRORS)
.Q:$G(QFLG)=1
.S REAFLG=$$HIPAAREA(IMPDA,CLMDA,.ERRORS)
Q:$G(QFLG)=1
;
I TRNAME'["HIPAA" D
.S CLMFLG=$$CLM(CLMDA)
.S REAFLG=$$REA(CLMDA)
;
S STAT=""
I CLMFLG,REAFLG S STAT="M" ;MATCHED
I 'CLMFLG,REAFLG S STAT="C" ;CLM UNMATCHED
I CLMFLG,'REAFLG S STAT="M"
I 'CLMFLG,'REAFLG S STAT="C"
K DR,DIE,DA
S DIE=$$DIC^XBDIQ1(90056.0205)
S DR=".02////^S X=STAT"
S DA(1)=IMPDA
S DA=CLMDA
D ^DIE
I TRNAME["HIPAA" D
.I '$G(REAFLG),$G(REATYP)="RT" S STAT="RT" ;RSN CD NOT DEFINED IN STD TBL ;ADDED $G ;IHS/DIT/CPC - BAR*1.8*28
.I '$G(REAFLG),$G(REATYP)="RF" S STAT="RF" ;RSN CD NOT ON RA ;ADDED $G ;IHS/DIT/CPC - BAR*1.8*28
.I '$G(REAFLG),$G(REATYP)="RU" S STAT="RU" ;STD ADJ CD NOT MAPPED TO RPMS ;ADDED $G ;IHS/DIT/CPC - BAR*1.8*28
.I '$G(CLMFLG),$G(CLMTYP)="CF" S STAT="CF" ;CLM# (CLP01) NOT SENT ON RA ;ADDED $G ;IHS/DIT/CPC - BAR*1.8*28
.I '$G(CLMFLG),$G(CLMTYP)="CT" S STAT="CT" ;RA CLM NOT FOUND IN RPMS ;ADDED $G ;IHS/DIT/CPC - BAR*1.8*28
.I '$G(CLMFLG),$G(CLMTYP)="CC" S STAT="CC" ;RA CLM IN RPMS AR BUT CANCELLED IN 3P ;ADDED $G ;IHS/DIT/CPC - BAR*1.8*28
.I '$G(CLMFLG),$G(CLMTYP)="CD" S STAT="CD" ;DOS DOESN'T MATCH RPMS ;ADDED $G ;IHS/DIT/CPC - BAR*1.8*28
;RSNS FOUND FOR 'NOT TO POST' (OLD)
I $D(ERRORS("CT")) K ERRORS S ERRORS("CT")=""
I $D(ERRORS("DUPB")) K ERRORS S ERRORS("DUPB")=""
I $D(ERRORS) D ADDREAS(IMPDA,CLMDA,.ERRORS)
;CHKS FOR RSNS 'NOT TO POST'
K ERRORS,STAT,REA,READA,REASDA,REAFLG,BARMSG,CLMTYP,REATYP ;IHS/DIT/CPC - BAR*1.8*28
Q
CLM(CLMDA) ;EP ;MATCH/SET/FLAG E-CLM TO A/R BILL
S X=$$VAL^XBDIQ1(90056.0205,"IMPDA,CLMDA",.01)
K DIC,DA,DR
S DIC=90050.01
S DIC(0)="M"
D ^DIC
I Y'>0 Q 0
S BARBLDA=+Y
S DIE=$$DIC^XBDIQ1(90056.0205)
S DA=CLMDA
S DA(1)=IMPDA
S DR="1.01////^S X=BARBLDA"
D ^DIE
Q 1
REA(CLMDA) ;EP ;LOOP MATCH/SET/FLAG RSN CODES OF E-CLM
K ADJ
S REAFLG=1
S ADJDA=0
F S ADJDA=$O(^BAREDI("I",DUZ(2),IMPDA,30,CLMDA,30,ADJDA)) Q:ADJDA'>0 D
.S ACAT=$$VALI^XBDIQ1(90056.0208,"IMPDA,CLMDA,ADJDA",.04)
.S AREA=$$VALI^XBDIQ1(90056.0208,"IMPDA,CLMDA,ADJDA",.05)
.S REA=$$VAL^XBDIQ1(90056.0208,"IMPDA,CLMDA,ADJDA",.03)
.I '$L(REA) S REAFLG=0 Q
.;lookup rsn in rsn table
.K DIC,DA,DR
.S DIC=$$DIC^XBDIQ1(90056.0107)
.S DA(1)=TRDA
.S X=$P(REA," ")
.S DIC(0)="X"
.D ^DIC
.I Y'>0 D Q
..S BARMSG=" NO REASON "_X W !,BARMSG
..I $G(BARDBG) D INS^BAR50DET(BARMSG,0)
..S REAFLG=0
.S READA=+Y
.;line below to ignore inpt w/non-cov'd days
.I +CLMFLG>0,$P($G(^BARBL(DUZ(2),BARBLDA,1)),U,14)=111,$P(Y,U,2)=96 Q
.Q:$P(Y,U,2)=93 ;Q if rsn is 93 w/o attempting to match
.;pull A/R cat & rsn
.S ACAT=$$VALI^XBDIQ1(90056.0107,"TRDA,READA",2.01)
.S AREA=$$VALI^XBDIQ1(90056.0107,"TRDA,READA",2.02)
.I ACAT,AREA D SETREA I 1
.E S REAFLG=0
Q REAFLG
SETREA ;EP SET CAT & REA INTO E-CLM
K DIC,DIE,DR,DA
S DIE=$$DIC^XBDIQ1(90056.0208)
S DA(2)=IMPDA
S DA(1)=CLMDA,DA=ADJDA
S DR=".04////^S X=ACAT;.05////^S X=AREA"
D ^DIE
Q
HIPAAREA(IMPDA,CLMDA,ERRORS) ;mult errors
;Match HIPAA std codes to RPMS
K ADJ
S REAFLG=1
S ADJDA=0
F S ADJDA=$O(^BAREDI("I",DUZ(2),IMPDA,30,CLMDA,30,ADJDA)) Q:'+ADJDA D HIPAAR2
Q REAFLG
HIPAAR2 ;Match HIPAA std codes to RPMS
S REA=$P($G(^BAREDI("I",DUZ(2),IMPDA,30,CLMDA,30,ADJDA,0)),U,3)
I REA="" D ;
.W !,"Standard adjustment reason not sent on RA."
.S REAFLG=0
.S REATYP="RF"
.S ERRORS("RF")="" ;
S ACAT=$P($G(^BAREDI("I",DUZ(2),IMPDA,30,CLMDA,30,ADJDA,0)),U,4)
S AREA=$P($G(^BAREDI("I",DUZ(2),IMPDA,30,CLMDA,30,ADJDA,0)),U,5)
K DIC,DR,DA
S DIC="^BARADJ("
S X=$P(REA," ")
S DIC(0)="XZ"
D ^DIC
I +Y<1 D Q
.W !,"Standard adjustment reason ",X," not in standard table."
.S REAFLG=0
.S REATYP="RT"
.S ERRORS("RT")="" ;
S READA=+Y
I $P(Y(0),U,3)=""!($P(Y(0),U,4)="") D ;
.W !,"Can't map standard adjustment reason ",X," to RPMS."
.S REAFLG=0
.S REATYP="RU"
.S ERRORS("RU")="" ;BAR*1.8*5 SRS-80 TPF
K DIC,DA,DR,DIE
S DIE=$$DIC^XBDIQ1(90056.0208)
S DA(2)=IMPDA
S DA(1)=CLMDA
S DA=ADJDA
S DR=".04////^S X=$P(Y(0),U,3)"
S DR=DR_";.05////^S X=$P(Y(0),U,4)"
D ^DIE
Q
HIPAACLM(IMPDA,CLMDA,ERRORS) ;BAR*1.8*5 SRS-80 TPF ERRORS CAN BE MULTIPLE
N BARTMP,BARAMT,BARDOS,ERAAMT,ERADOS,ERATYPE,BARFND
;Match RA clms to RPMS
;1st chk bill# "B" x-ref; if no, chk other identifier "G" x-ref (Pharmacy POS)
S BAREIENS=CLMDA_","_IMPDA_","
;S BARTEST=$$GET1^DIQ(90056.0205,BAREIENS,.01) ;bar*1.8*26 IHS/SD/SDR HEAT233443
S BARTEST=$TR($P($G(^BAREDI("I",DUZ(2),IMPDA,30,CLMDA,0)),U),"E","A") ;bar*1.8*26 IHS/SD/SDR HEAT233443
S (BARBIEN,BARBILL)="" ;IHS/DIT/CPC BAR*1.8*28
S (BARBIEN,BARBILL)=$$GETBBILL(BARTEST) ;P.OTT ENDS WITH FIRST NON ALPHANUMERIC CHAR
I BARBILL="" D Q ;
.S CLMTYP="CF"
.W !,"Bill number not sent on ERA"
.S ERRORS("CF")=""
S BARCNT=0
D CLM^BAR50P4A(BAREIENS,BARBILL,.BARX,.BARMMFLG) ;bar*1.8*20
I BARFND=0 D
.S BARMSG=$P($G(^BAREDI("I",DUZ(2),IMPDA,30,CLMDA,0)),U)_" ***CLAIM NOT FOUND IN RPMS***"
.W !,BARMSG
.D INS^BAR50DET(BARMSG,0) ;SAME MSG INTO REPORT
.D NOMATCH^BAR50DET ;NOT MATCH
I $$GET1^DIQ(90056.0205,BAREIENS,1.01,"I")'="" S BARCNT=1 ;IENS->BAREIENS
;FROM p.ott
I BARCNT=1 S BARBIEN=$O(BARTMP(0))
I BILMATCH=1 D ;
.S NEWSTAT="M"
.S BARBIEN=$O(BILMATCH("")) S BARCNT=1
.S BARMSG=$J("",5)_"ERA BILL "_$$GET1^DIQ(90056.0205,BAREIENS,.01) W !,BARMSG
.I $G(BARDBG) D INS^BAR50DET(BARMSG,0)
.S BARMSG=" MATCHED TO "_$S(BARX="G":"(POS)",1:"")_" A/R BILL "_$P($G(^BARBL(DUZ(2),BARBIEN,0)),U)
.W BARMSG
.I $G(BARDBG) D INS^BAR50DET(BARMSG,1)
;TO p.ott
I BARCNT=0 S CLMTYP="CT",ERRORS("CT")=""
CLM2 ;
S NEWSTAT=$G(NEWSTAT) ;init value 12/12/13
I BARCNT>1,($$GET1^DIQ(90056.0205,BAREIENS,1.01)="") D
.S NEWSTAT="",BARANS=""
.F D Q:($G(BARSEL)'="B"&($G(BARSEL)'="H"))
..D HDR
..D RABILL
..D ARBILL
..D CHOOSE
..I ($G(BARSEL)="Q") S QFLG=1 Q ;
..I (+$G(BARANS)'=0)&(($G(BARSEL)'="B")&($G(BARSEL)'="H")) D
...K DIR
...S DIR(0)="Y"
...S DIR("A")="Are you sure?"
...S DIR("B")="N"
...D ^DIR
...I +Y<1 S BARANS=0 S BARSEL="B"
.I $G(BARSEL)="" D
..W !!,"BILL WILL NOT BE MATCHED AND WILL BE SET TO 'NOT MATCHED'. CONTINUING.."
..S BARSEL="N"
.;I BARSEL="N" S NEWSTAT="M",ERRORS("DUPB")="" ;bar*1.8*28 IHS/SD/SDR CR9572 HEAT258378
.I BARSEL="N" S NEWSTAT="C",ERRORS("UOR")="" ;bar*1.8*28 IHS/SD/SDR CR9572 HEAT258378
.I BARSEL="M" S NEWSTAT="M" ;BAR*1.8*28 IHS/DIT/CPC CR9572
.I '+BARANS,BARSEL="N" Q ;
.I '+BARANS S CLMTYP="CT",ERRORS("CT")="" Q
.S BARBIEN=BARTMP2(BARANS)
;Match DOS
;See if 3P cancelled
S BAR3PIEN=$$FIND3PB^BARUTL(DUZ(2),BARBIEN)
I BAR3PIEN]"" D ;
.S BARBSTAT=$P($G(^ABMDBILL($P(BAR3PIEN,","),$P(BAR3PIEN,",",2),0)),U,4)
.;S:BARBSTAT="X" CLMTYP="CC" ;Cancelled in 3P ;bar*1.8*28 IHS/DIT}
.S:BARBSTAT="X" CLMTYP="CC",ERRORS("CC")="" ;bar*1.8*28 IHS/DIT}
I $$GET1^DIQ(90056.0205,BAREIENS,.02,"I")="M" Q 1 ;IHS/DIT/CPC - BAR*1.8*28
Q:$D(ERRORS("CT"))!($D(ERRORS("CF")))!($D(ERRORS("UOR"))) 0 ;IHS/DIT/CPC - BAR*1.8*28
;Bill matches RPMS-log AR Bill IEN in Image
S DIE=$$DIC^XBDIQ1(90056.0205)
S DA=CLMDA
S DA(1)=IMPDA
S DR="1.01////^S X=BARBIEN"
S MATCH="M"
S DR=DR_";.02////^S X=MATCH"
D ^DIE
;Q:$D(ERRORS) 0 ;IHS/DIT/CPC - BAR*1.8*28
Q 1
HDR ;hdr
W !!,$$EN^BARVDF("ULN"),?4,"BILL #",?23,"DOS",?31,"PATIENT NAME"
W ?57,"BILLED AMT",?71,"BALANCE",$$EN^BARVDF("ULF")
Q
RABILL ;Write RA data
S X=$$GET1^DIQ(90056.0205,BAREIENS,.08)
D ^%DT
S BARRADT=Y ;DOS begin
W !,$$EN^BARVDF("RVN")
W "ERA" ;
W ?4,$E($$GET1^DIQ(90056.0205,BAREIENS,.01),1,15) ;BILL/RX
W ?20,$$SDT^BARDUTL(BARRADT) ;DOS begin
W ?31,$E($$GET1^DIQ(90056.0205,BAREIENS,.06),1,25) ;Pt name
W ?57,$J($FN($$GET1^DIQ(90056.0205,BAREIENS,.05),",",2),10) ;Billed
W $$EN^BARVDF("RVF")
Q
ARBILL ;Loop & write AR data
S (BARBIEN,BARCNT2)=0
F S BARBIEN=$O(BARTMP(BARBIEN)) Q:'+BARBIEN D
.S BARCNT2=BARCNT2+1
.S BARBDT=$$GET1^DIQ(90050.01,BARBIEN,102,"I")
.W !,$J(BARCNT2,2),")"
.W ?4,$E($$GET1^DIQ(90050.01,BARBIEN,.01),1,20) ;expanded ck# to 20 chars bar*1.8*22 SDR
.W ?20,$$SDT^BARDUTL(BARBDT)
.W ?31,$E($$GET1^DIQ(90050.01,BARBIEN,101),1,25)
.W ?52,$J($FN($$GET1^DIQ(90050.01,BARBIEN,13),",",2),10)
.W ?68,$J($FN($$GET1^DIQ(90050.01,BARBIEN,15),",",2),10)
.S BARTMP2(BARCNT2)=BARBIEN
Q
CHOOSE ;Choose bill from AR
K DIR
S DIR(0)="SABO^B:Bill Inquire;H:History;M:Match to Item;N:Not Matched;Q:Quit"
S DIR("A")="Enter (B)ill Inquire,(H)istory,(M)atch to Item,(N)ot Matched,(Q)uit: "
D ^DIR
S BARSEL=Y ;bar*1.8*28 IHS/SD/SDR CR9572 HEAT258378
I $D(DTOUT)!$D(DUOUT)!$D(DIRUT)!$D(DIROUT) S BARANS=0 Q
I BARSEL="N"!(BARSEL="Q") S BARANS=0 Q ;not matched
K DIR
S DIR(0)="NAO^1:"_BARCNT2
S DIR("A")="Which Entry: "
S DIR("?")="Enter a number between 1 and "_BARCNT2
D ^DIR
I $D(DIROUT)!$D(DUOUT)!$D(DIRUT)!$D(DTOUT) S BARANS=0 Q
S BARANS1=$G(BARTMP2(Y)),BARANS=Y
I BARSEL="H" D
.D EN^BARPST5(BARANS1)
I BARSEL="B" D
.D DIQ^XBLM(90050.01,BARANS1)
Q
;BAR*1.8*5 SRS-80 TPF
ADDREAS(IMPDA,CLMDA,ERRORS,SHOWMSG) ;EP - ADD RSN NOT SENT TO 'RSN NOT TO POST MULTIPLE'
S SHOWMSG=$G(SHOWMSG)
N REASON,STAT,ERRDA,CURSTAT
S REASON=""
F S REASON=$O(ERRORS(REASON)) Q:REASON="" D
.I REASON="CT" D STAT(IMPDA,CLMDA)
.I SHOWMSG D
..S ERRDA=$O(^BARERR("B",REASON,""))
..W !,$$GET1^DIQ(90056.21,ERRDA_",",.02,"E")
.K DIC,DIE,DR,DA,DIR
.S DIC("P")=$P(^DD(90056.0205,401,0),U,2)
.S DA(2)=IMPDA
.S DA(1)=CLMDA
.S DIC(0)="L"
.S DIC="^BAREDI(""I"",DUZ(2),"_DA(2)_",30,"_DA(1)_",4,"
.S X=REASON
.D ^DIC
Q
STAT(IMPDA,CLMDA) ;EP
K DR,DIE,DA
S DIE=$$DIC^XBDIQ1(90056.0205)
S STAT="C"
S DR=".02///^S X=STAT"
S DA(1)=IMPDA
S DA=CLMDA
D ^DIE
Q
DELREAS(IMPDA,CLMDA) ;EP -CLR 'RSN NOT TO POST' MULTIPLES IN ERA FILE
N REASDA
K DA,DIR,DIC,DIE,DR
S REASDA=0
F S REASDA=$O(^BAREDI("I",DUZ(2),IMPDA,30,CLMDA,4,REASDA)) Q:'REASDA D
.S DA(2)=IMPDA
.S DA(1)=CLMDA
.S DIE="^BAREDI(""I"","_DUZ(2)_","_DA(2)_",30,"_DA(1)_",4,"
.S DA=REASDA
.S DR=".01///@"
.D ^DIE
K DA,DR,DIE,DIC,DIR
S DIE=$$DIC^XBDIQ1(90056.0205)
S DR="" ;REQ4
S IENS=CLMDA_","_IMPDA_"," ;REQ4
;I $$GET1^DIQ(90056.0205,IENS,71)="" S DR=".02///C" ;'STATUS' FLD CLM UNMATCHED ;REQ4
I $$GET1^DIQ(90056.0205,IENS,.02)=""!($$GET1^DIQ(90056.0205,IENS,.02,"I")="B") S DR=".02///C" ;'STATUS' FLD CLM UNMATCHED IHS/DIT/CPC - BAR*1.8*28
S DR=DR_";501///@" ;'POST CLM AS TYPE'
S DR=DR_";601///@" ;'PYMT CRDT APPLIED TO'
S DR=DR_";602///@" ;'PYMT CRDT APPLIED FROM'
S DA(1)=IMPDA
S DA=CLMDA
D ^DIE
K DA,DR,DIE,DIC,DIR
Q
;
GETBBILL(BARTMP) ;
N BARBLNUM,I,CH
S BARBLNUM="" F I=1:1:$L(BARTMP) S CH=$E(BARTMP,I) Q:CH'?1N S BARBLNUM=BARBLNUM_CH
I CH?1A S BARBLNUM=BARBLNUM_CH ;TAKE THE FIRST ALPHA AFTER NNNN
I BARBLNUM="" Q ""
Q BARBLNUM
LINE() ;
N I,STR
S STR="" F I=1:1:78 S STR=STR_"-"
Q STR
FTYPE() ;
Q "5010"
;EOR - IHS/DIT/CPC 1.8*28
BAR50P04 ; IHS/SD/LSL - MATCH REASONS AND CLAIMS ; 01/09/2009
+1 ;;1.8;IHS ACCOUNTS RECEIVABLE;**5,6,10,20,21,22,23,24,26,28**;OCT 26, 2005;Build 92
+2 ;IHS/SD/POT 1.8*23 HEAT87149 FIXING LINE +210
+3 ;IHS/SD/POT 1.8*23 HEAT82698 LEADING ZEROES IN BILL #
+4 ;IHS/SD/POT 1.8*23 FIX INIT VALUE OF CLMDA (+27)
+5 ;IHS/SD/POT 1.8*24 HEAT147572 ALLOW TRIBAL SITES ERA POSTING OF NEG BAL & CANCELLED BILLS 1/15/2014; 2/5/2014
+6 ;IHS/SD/POT 1.8*26 HEAT170856 correct non-ihs functionality when parm "ALLOW ERA POSTING NEG BALANCES" set
+7 ;IHS/SD/SDR 1.8*26 HEAT170856 Made changes so BLMT and REV work same. One would add reasons that other would take away. Also corrected check for Allow ERA cancelled clm parm.
+8 ;IHS/SD/SDR 1.8*26 HEAT233443 - Stopped MAXNUMBER error. Occurred when 'E' is in CLP01 element. Changed it to 'A'. We look for bill number (excluding alpha) so most matches are made so it doesn't matter
+9 ; that it is 'A' instead of 'E'.
+10 ;IHS/SD/SDR 1.8*28 CR8347 HEAT281465 If CLP01=0 make it still go through process so it will change status from BUILT to CLAIM UNMATCHED w/reason NTP of no RPMS bill.
+11 ;IHS/SD/SDR 1.8*28 CR9572 HEAT258378 Fixed if they don't pick anything when mult. potential matches; also made it so mult. potential matches and none picked is Claim Unmatched w/RNTP of UOR.
EN(TRDA,IMPDA) ;EP ;SCAN CLMS BUILT "B" STATUS
+1 NEW REVERSAL,ERACHECK
+2 DO INIT^BARUTL
+3 WRITE !,"Matching E-Claims to A/R Bills and Reason Codes",!
+4 IF TRNAME["HIPAA"
Begin DoDot:1
+5 SET INDEX="B"
+6 DO INDEX
DO PRT^BAR50DET
End DoDot:1
QUIT
+7 FOR INDEX="B","X","C","R"
DO INDEX
DO PRT^BAR50DET
+8 QUIT
INDEX ;EP
+1 SET QFLG=0
+2 WRITE !,"Processing Claim Status using claim Index ",INDEX,!
+3 ;1=build detail matching report ;IHS/DIT/CPC - BAR*1.8*28
SET BARDBG=1
+4 KILL ^XTMP("BAR-LIST_DETAIL",$JOB,DUZ(2))
+5 KILL ^XTMP("BAR-LIST",$JOB,DUZ(2))
+6 SET BARMSG="PERFORMING TRADITIONAL HIPAA CHECKS...("_$$FTYPE()_")"
WRITE !,BARMSG
+7 IF $GET(BARDBG)
DO INS^BAR50DET(BARMSG,0)
+8 KILL BARFLG
+9 SET CLMDA=0
FOR
SET CLMDA=$ORDER(^BAREDI("I",DUZ(2),IMPDA,30,CLMDA))
IF 'CLMDA
QUIT
SET ^XTMP("BAR-LIST",$JOB,DUZ(2),$PIECE($GET(^BAREDI("I",DUZ(2),IMPDA,30,CLMDA,0)),U),CLMDA)=""
+10 SET CLMCNT=0
SET BARBL=""
+11 ;F S BARBL=$O(^XTMP("BAR-LIST",$J,DUZ(2),BARBL)) Q:BARBL="" D Q:QFLG=1 ;bar*1.8*26 IHS/SD/SDR HEAT170856
+12 ;bar*1.8*26 IHS/SD/SDR HEAT170856
FOR
SET BARBL=$ORDER(^XTMP("BAR-LIST",$JOB,DUZ(2),BARBL))
IF BARBL=""
QUIT
Begin DoDot:1
+13 SET CLMDA=0
+14 ;F S CLMDA=$O(^XTMP("BAR-LIST",$J,DUZ(2),BARBL,CLMDA)) Q:'CLMDA K ERRS D CLMFLG(CLMDA,.ERRORS) Q:$G(QFLG)=1 ;bar*1.8*26 IHS/SD/SDR HEAT170856
+15 ;bar*1.8*26 IHS/SD/SDR HEAT170856
FOR
SET CLMDA=$ORDER(^XTMP("BAR-LIST",$JOB,DUZ(2),BARBL,CLMDA))
IF 'CLMDA
QUIT
KILL ERRS
DO CLMFLG(CLMDA,.ERRORS)
End DoDot:1
+16 ;Q:QFLG=1 ;bar*1.8*29 IHS/SD/SDR HEAT170856
+17 ;PLB/Pymt Rev/Neg pymt amt chks
SET BARFLG=$$EN^BAR50P0Z(IMPDA)
+18 ;old D:$$IHS^BARUFUT(DUZ(2)) NEGBAL^BAR50EB(IMPDA,"ERA") ;CHK FOR NEG BAL IN RPMS BILLS
+19 ;note:IHS/TRIBAL CHK INSIDE BAR50EB CHK FOR NEG BAL IN RPMS BILLS HEAT147572 MOD: 2/5/2014
DO NEGBAL^BAR50EB(IMPDA,"ERA")
+20 ;NOTE: MATCHED PYMTS & CREDITS W/HAVE THE 'POST THIS CLM AS TYPE' FLD = TO 20=PYMT CREDIT
+21 ;D:$$IHS^BARUFUT(DUZ(2)) NONPAYCH^BAR50EP1(IMPDA) ;CHK PYMTS NOT MATCHED TO REV TO SEE IF BEING POSTED TO 'NONPYMT' BATCH ;bar*1.8*26 IHS/SD/POT HEAT170856
+22 ;bar*1.8*26 IHS/SD/POT HEAT170856
IF $$IHSNEGB^BARUFUT(DUZ(2))
DO NONPAYCH^BAR50EP1(IMPDA)
+23 ;K ERRORS
+24 QUIT
CLMFLG(CLMDA,ERRORS) ;EP
+1 ;NEXT LINE MOVED TO TOP OF SUBR
+2 ;only look at 1 chk's clms
IF (($PIECE($GET(^BAREDI("I",DUZ(2),IMPDA,30,CLMDA,2)),U))'=($PIECE($GET(^BAREDI("I",DUZ(2),IMPDA,5,BARCKIEN,0)),U)))
Begin DoDot:1
End DoDot:1
QUIT
+3 ;RETURN FLAG
NEW BARTMPM,BARTMPCL
+4 SET BILMATCH=0
+5 SET BARTMPCL=$PIECE($GET(^BAREDI("I",DUZ(2),IMPDA,30,CLMDA,0)),U)
+6 IF $GET(BARDBG)
Begin DoDot:1
+7 DO INS^BAR50DET($$LINE(),0)
+8 SET BARMSG="PROCESSING ENTRY: "_$JUSTIFY(CLMDA,6)_" CLAIM "_BARTMPCL
WRITE !,BARMSG
+9 DO INS^BAR50DET(BARMSG,0)
End DoDot:1
+10 ;start old bar*1.8*28 IHS/SD/SDR CR8347 HEAT281465
+11 ;I BARTMPCL=0 D Q
+12 ;.S BARMSG=" INVALID CLAIM NUMBER" W BARMSG
+13 ;.D INS^BAR50DET(BARMSG,1)
+14 ;end old bar*1.8*28 IHS/SD/SDR CR8347 HEAT281465
+15 ;quit if posted
IF $PIECE($GET(^BAREDI("I",DUZ(2),IMPDA,30,CLMDA,0)),U,2)="P"
Begin DoDot:1
+16 IF $GET(BARDBG)
DO INS^BAR50DET(" POSTED - SKIPP",1)
End DoDot:1
QUIT
+17 ;S BARTMPM=$$OVERIDE^BAR50EP1(CLMDA) I BARTMPM D Q ;P.OTT ;bar*1.8*26 IHS/SD/SDR HEAT170856
+18
*** ERROR ***
+19 ;user marked as Exception-skip
IF $PIECE($GET(^BAREDI("I",DUZ(2),IMPDA,30,CLMDA,0)),U,2)="E"
Begin DoDot:1
+20 IF $GET(BARDBG)
DO INS^BAR50DET(" EXCEPTION - SKIP",1)
End DoDot:1
QUIT
+21 ;CLR ERRORS, SET STAT TO MATCHED, BEGIN BY ASSUMING ALL CLMS ARE MATCHED & ERROR FREE
DO DELREAS(IMPDA,CLMDA)
+22 ;CHK & SET CLM MATCH STATUS
+23 IF TRNAME["HIPAA"
Begin DoDot:1
+24 SET CLMCNT=+$GET(CLMCNT)+1
+25 IF $GET(BARDBG)
WRITE !?2,CLMCNT,?10,BARBL," ",$PIECE($GET(^BAREDI("I",DUZ(2),IMPDA,30,CLMDA,0)),U)
+26 SET CLMFLG=$$HIPAACLM(IMPDA,CLMDA,.ERRORS)
+27 IF $GET(QFLG)=1
QUIT
+28 SET REAFLG=$$HIPAAREA(IMPDA,CLMDA,.ERRORS)
End DoDot:1
+29 IF $GET(QFLG)=1
QUIT
+30 ;
+31 IF TRNAME'["HIPAA"
Begin DoDot:1
+32 SET CLMFLG=$$CLM(CLMDA)
+33 SET REAFLG=$$REA(CLMDA)
End DoDot:1
+34 ;
+35 SET STAT=""
+36 ;MATCHED
IF CLMFLG
IF REAFLG
SET STAT="M"
+37 ;CLM UNMATCHED
IF 'CLMFLG
IF REAFLG
SET STAT="C"
+38 IF CLMFLG
IF 'REAFLG
SET STAT="M"
+39 IF 'CLMFLG
IF 'REAFLG
SET STAT="C"
+40 KILL DR,DIE,DA
+41 SET DIE=$$DIC^XBDIQ1(90056.0205)
+42 SET DR=".02////^S X=STAT"
+43 SET DA(1)=IMPDA
+44 SET DA=CLMDA
+45 DO ^DIE
+46 IF TRNAME["HIPAA"
Begin DoDot:1
+47 ;RSN CD NOT DEFINED IN STD TBL ;ADDED $G ;IHS/DIT/CPC - BAR*1.8*28
IF '$GET(REAFLG)
IF $GET(REATYP)="RT"
SET STAT="RT"
+48 ;RSN CD NOT ON RA ;ADDED $G ;IHS/DIT/CPC - BAR*1.8*28
IF '$GET(REAFLG)
IF $GET(REATYP)="RF"
SET STAT="RF"
+49 ;STD ADJ CD NOT MAPPED TO RPMS ;ADDED $G ;IHS/DIT/CPC - BAR*1.8*28
IF '$GET(REAFLG)
IF $GET(REATYP)="RU"
SET STAT="RU"
+50 ;CLM# (CLP01) NOT SENT ON RA ;ADDED $G ;IHS/DIT/CPC - BAR*1.8*28
IF '$GET(CLMFLG)
IF $GET(CLMTYP)="CF"
SET STAT="CF"
+51 ;RA CLM NOT FOUND IN RPMS ;ADDED $G ;IHS/DIT/CPC - BAR*1.8*28
IF '$GET(CLMFLG)
IF $GET(CLMTYP)="CT"
SET STAT="CT"
+52 ;RA CLM IN RPMS AR BUT CANCELLED IN 3P ;ADDED $G ;IHS/DIT/CPC - BAR*1.8*28
IF '$GET(CLMFLG)
IF $GET(CLMTYP)="CC"
SET STAT="CC"
+53 ;DOS DOESN'T MATCH RPMS ;ADDED $G ;IHS/DIT/CPC - BAR*1.8*28
IF '$GET(CLMFLG)
IF $GET(CLMTYP)="CD"
SET STAT="CD"
End DoDot:1
+54 ;RSNS FOUND FOR 'NOT TO POST' (OLD)
+55 IF $DATA(ERRORS("CT"))
KILL ERRORS
SET ERRORS("CT")=""
+56 IF $DATA(ERRORS("DUPB"))
KILL ERRORS
SET ERRORS("DUPB")=""
+57 IF $DATA(ERRORS)
DO ADDREAS(IMPDA,CLMDA,.ERRORS)
+58 ;CHKS FOR RSNS 'NOT TO POST'
+59 ;IHS/DIT/CPC - BAR*1.8*28
KILL ERRORS,STAT,REA,READA,REASDA,REAFLG,BARMSG,CLMTYP,REATYP
+60 QUIT
CLM(CLMDA) ;EP ;MATCH/SET/FLAG E-CLM TO A/R BILL
+1 SET X=$$VAL^XBDIQ1(90056.0205,"IMPDA,CLMDA",.01)
+2 KILL DIC,DA,DR
+3 SET DIC=90050.01
+4 SET DIC(0)="M"
+5 DO ^DIC
+6 IF Y'>0
QUIT 0
+7 SET BARBLDA=+Y
+8 SET DIE=$$DIC^XBDIQ1(90056.0205)
+9 SET DA=CLMDA
+10 SET DA(1)=IMPDA
+11 SET DR="1.01////^S X=BARBLDA"
+12 DO ^DIE
+13 QUIT 1
REA(CLMDA) ;EP ;LOOP MATCH/SET/FLAG RSN CODES OF E-CLM
+1 KILL ADJ
+2 SET REAFLG=1
+3 SET ADJDA=0
+4 FOR
SET ADJDA=$ORDER(^BAREDI("I",DUZ(2),IMPDA,30,CLMDA,30,ADJDA))
IF ADJDA'>0
QUIT
Begin DoDot:1
+5 SET ACAT=$$VALI^XBDIQ1(90056.0208,"IMPDA,CLMDA,ADJDA",.04)
+6 SET AREA=$$VALI^XBDIQ1(90056.0208,"IMPDA,CLMDA,ADJDA",.05)
+7 SET REA=$$VAL^XBDIQ1(90056.0208,"IMPDA,CLMDA,ADJDA",.03)
+8 IF '$LENGTH(REA)
SET REAFLG=0
QUIT
+9 ;lookup rsn in rsn table
+10 KILL DIC,DA,DR
+11 SET DIC=$$DIC^XBDIQ1(90056.0107)
+12 SET DA(1)=TRDA
+13 SET X=$PIECE(REA," ")
+14 SET DIC(0)="X"
+15 DO ^DIC
+16 IF Y'>0
Begin DoDot:2
+17 SET BARMSG=" NO REASON "_X
WRITE !,BARMSG
+18 IF $GET(BARDBG)
DO INS^BAR50DET(BARMSG,0)
+19 SET REAFLG=0
End DoDot:2
QUIT
+20 SET READA=+Y
+21 ;line below to ignore inpt w/non-cov'd days
+22 IF +CLMFLG>0
IF $PIECE($GET(^BARBL(DUZ(2),BARBLDA,1)),U,14)=111
IF $PIECE(Y,U,2)=96
QUIT
+23 ;Q if rsn is 93 w/o attempting to match
IF $PIECE(Y,U,2)=93
QUIT
+24 ;pull A/R cat & rsn
+25 SET ACAT=$$VALI^XBDIQ1(90056.0107,"TRDA,READA",2.01)
+26 SET AREA=$$VALI^XBDIQ1(90056.0107,"TRDA,READA",2.02)
+27 IF ACAT
IF AREA
DO SETREA
IF 1
+28 IF '$TEST
SET REAFLG=0
End DoDot:1
+29 QUIT REAFLG
SETREA ;EP SET CAT & REA INTO E-CLM
+1 KILL DIC,DIE,DR,DA
+2 SET DIE=$$DIC^XBDIQ1(90056.0208)
+3 SET DA(2)=IMPDA
+4 SET DA(1)=CLMDA
SET DA=ADJDA
+5 SET DR=".04////^S X=ACAT;.05////^S X=AREA"
+6 DO ^DIE
+7 QUIT
HIPAAREA(IMPDA,CLMDA,ERRORS) ;mult errors
+1 ;Match HIPAA std codes to RPMS
+2 KILL ADJ
+3 SET REAFLG=1
+4 SET ADJDA=0
+5 FOR
SET ADJDA=$ORDER(^BAREDI("I",DUZ(2),IMPDA,30,CLMDA,30,ADJDA))
IF '+ADJDA
QUIT
DO HIPAAR2
+6 QUIT REAFLG
HIPAAR2 ;Match HIPAA std codes to RPMS
+1 SET REA=$PIECE($GET(^BAREDI("I",DUZ(2),IMPDA,30,CLMDA,30,ADJDA,0)),U,3)
+2 ;
IF REA=""
Begin DoDot:1
+3 WRITE !,"Standard adjustment reason not sent on RA."
+4 SET REAFLG=0
+5 SET REATYP="RF"
+6 ;
SET ERRORS("RF")=""
End DoDot:1
+7 SET ACAT=$PIECE($GET(^BAREDI("I",DUZ(2),IMPDA,30,CLMDA,30,ADJDA,0)),U,4)
+8 SET AREA=$PIECE($GET(^BAREDI("I",DUZ(2),IMPDA,30,CLMDA,30,ADJDA,0)),U,5)
+9 KILL DIC,DR,DA
+10 SET DIC="^BARADJ("
+11 SET X=$PIECE(REA," ")
+12 SET DIC(0)="XZ"
+13 DO ^DIC
+14 IF +Y<1
Begin DoDot:1
+15 WRITE !,"Standard adjustment reason ",X," not in standard table."
+16 SET REAFLG=0
+17 SET REATYP="RT"
+18 ;
SET ERRORS("RT")=""
End DoDot:1
QUIT
+19 SET READA=+Y
+20 ;
IF $PIECE(Y(0),U,3)=""!($PIECE(Y(0),U,4)="")
Begin DoDot:1
+21 WRITE !,"Can't map standard adjustment reason ",X," to RPMS."
+22 SET REAFLG=0
+23 SET REATYP="RU"
+24 ;BAR*1.8*5 SRS-80 TPF
SET ERRORS("RU")=""
End DoDot:1
+25 KILL DIC,DA,DR,DIE
+26 SET DIE=$$DIC^XBDIQ1(90056.0208)
+27 SET DA(2)=IMPDA
+28 SET DA(1)=CLMDA
+29 SET DA=ADJDA
+30 SET DR=".04////^S X=$P(Y(0),U,3)"
+31 SET DR=DR_";.05////^S X=$P(Y(0),U,4)"
+32 DO ^DIE
+33 QUIT
HIPAACLM(IMPDA,CLMDA,ERRORS) ;BAR*1.8*5 SRS-80 TPF ERRORS CAN BE MULTIPLE
+1 NEW BARTMP,BARAMT,BARDOS,ERAAMT,ERADOS,ERATYPE,BARFND
+2 ;Match RA clms to RPMS
+3 ;1st chk bill# "B" x-ref; if no, chk other identifier "G" x-ref (Pharmacy POS)
+4 SET BAREIENS=CLMDA_","_IMPDA_","
+5 ;S BARTEST=$$GET1^DIQ(90056.0205,BAREIENS,.01) ;bar*1.8*26 IHS/SD/SDR HEAT233443
+6 ;bar*1.8*26 IHS/SD/SDR HEAT233443
SET BARTEST=$TRANSLATE($PIECE($GET(^BAREDI("I",DUZ(2),IMPDA,30,CLMDA,0)),U),"E","A")
+7 ;IHS/DIT/CPC BAR*1.8*28
SET (BARBIEN,BARBILL)=""
+8 ;P.OTT ENDS WITH FIRST NON ALPHANUMERIC CHAR
SET (BARBIEN,BARBILL)=$$GETBBILL(BARTEST)
+9 ;
IF BARBILL=""
Begin DoDot:1
+10 SET CLMTYP="CF"
+11 WRITE !,"Bill number not sent on ERA"
+12 SET ERRORS("CF")=""
End DoDot:1
QUIT
+13 SET BARCNT=0
+14 ;bar*1.8*20
DO CLM^BAR50P4A(BAREIENS,BARBILL,.BARX,.BARMMFLG)
+15 IF BARFND=0
Begin DoDot:1
+16 SET BARMSG=$PIECE($GET(^BAREDI("I",DUZ(2),IMPDA,30,CLMDA,0)),U)_" ***CLAIM NOT FOUND IN RPMS***"
+17 WRITE !,BARMSG
+18 ;SAME MSG INTO REPORT
DO INS^BAR50DET(BARMSG,0)
+19 ;NOT MATCH
DO NOMATCH^BAR50DET
End DoDot:1
+20 ;IENS->BAREIENS
IF $$GET1^DIQ(90056.0205,BAREIENS,1.01,"I")'=""
SET BARCNT=1
+21 ;FROM p.ott
+22 IF BARCNT=1
SET BARBIEN=$ORDER(BARTMP(0))
+23 ;
IF BILMATCH=1
Begin DoDot:1
+24 SET NEWSTAT="M"
+25 SET BARBIEN=$ORDER(BILMATCH(""))
SET BARCNT=1
+26 SET BARMSG=$JUSTIFY("",5)_"ERA BILL "_$$GET1^DIQ(90056.0205,BAREIENS,.01)
WRITE !,BARMSG
+27 IF $GET(BARDBG)
DO INS^BAR50DET(BARMSG,0)
+28 SET BARMSG=" MATCHED TO "_$SELECT(BARX="G":"(POS)",1:"")_" A/R BILL "_$PIECE($GET(^BARBL(DUZ(2),BARBIEN,0)),U)
+29 WRITE BARMSG
+30 IF $GET(BARDBG)
DO INS^BAR50DET(BARMSG,1)
End DoDot:1
+31 ;TO p.ott
+32 IF BARCNT=0
SET CLMTYP="CT"
SET ERRORS("CT")=""
CLM2 ;
+1 ;init value 12/12/13
SET NEWSTAT=$GET(NEWSTAT)
+2 IF BARCNT>1
IF ($$GET1^DIQ(90056.0205,BAREIENS,1.01)="")
Begin DoDot:1
+3 SET NEWSTAT=""
SET BARANS=""
+4 FOR
Begin DoDot:2
+5 DO HDR
+6 DO RABILL
+7 DO ARBILL
+8 DO CHOOSE
+9 ;
IF ($GET(BARSEL)="Q")
SET QFLG=1
QUIT
+10 IF (+$GET(BARANS)'=0)&(($GET(BARSEL)'="B")&($GET(BARSEL)'="H"))
Begin DoDot:3
+11 KILL DIR
+12 SET DIR(0)="Y"
+13 SET DIR("A")="Are you sure?"
+14 SET DIR("B")="N"
+15 DO ^DIR
+16 IF +Y<1
SET BARANS=0
SET BARSEL="B"
End DoDot:3
End DoDot:2
IF ($GET(BARSEL)'="B"&($GET(BARSEL)'="H"))
QUIT
+17 IF $GET(BARSEL)=""
Begin DoDot:2
+18 WRITE !!,"BILL WILL NOT BE MATCHED AND WILL BE SET TO 'NOT MATCHED'. CONTINUING.."
+19 SET BARSEL="N"
End DoDot:2
+20 ;I BARSEL="N" S NEWSTAT="M",ERRORS("DUPB")="" ;bar*1.8*28 IHS/SD/SDR CR9572 HEAT258378
+21 ;bar*1.8*28 IHS/SD/SDR CR9572 HEAT258378
IF BARSEL="N"
SET NEWSTAT="C"
SET ERRORS("UOR")=""
+22 ;BAR*1.8*28 IHS/DIT/CPC CR9572
IF BARSEL="M"
SET NEWSTAT="M"
+23 ;
IF '+BARANS
IF BARSEL="N"
QUIT
+24 IF '+BARANS
SET CLMTYP="CT"
SET ERRORS("CT")=""
QUIT
+25 SET BARBIEN=BARTMP2(BARANS)
End DoDot:1
+26 ;Match DOS
+27 ;See if 3P cancelled
+28 SET BAR3PIEN=$$FIND3PB^BARUTL(DUZ(2),BARBIEN)
+29 ;
IF BAR3PIEN]""
Begin DoDot:1
+30 SET BARBSTAT=$PIECE($GET(^ABMDBILL($PIECE(BAR3PIEN,","),$PIECE(BAR3PIEN,",",2),0)),U,4)
+31 ;S:BARBSTAT="X" CLMTYP="CC" ;Cancelled in 3P ;bar*1.8*28 IHS/DIT}
+32 ;bar*1.8*28 IHS/DIT}
IF BARBSTAT="X"
SET CLMTYP="CC"
SET ERRORS("CC")=""
End DoDot:1
+33 ;IHS/DIT/CPC - BAR*1.8*28
IF $$GET1^DIQ(90056.0205,BAREIENS,.02,"I")="M"
QUIT 1
+34 ;IHS/DIT/CPC - BAR*1.8*28
IF $DATA(ERRORS("CT"))!($DATA(ERRORS("CF")))!($DATA(ERRORS("UOR")))
QUIT 0
+35 ;Bill matches RPMS-log AR Bill IEN in Image
+36 SET DIE=$$DIC^XBDIQ1(90056.0205)
+37 SET DA=CLMDA
+38 SET DA(1)=IMPDA
+39 SET DR="1.01////^S X=BARBIEN"
+40 SET MATCH="M"
+41 SET DR=DR_";.02////^S X=MATCH"
+42 DO ^DIE
+43 ;Q:$D(ERRORS) 0 ;IHS/DIT/CPC - BAR*1.8*28
+44 QUIT 1
HDR ;hdr
+1 WRITE !!,$$EN^BARVDF("ULN"),?4,"BILL #",?23,"DOS",?31,"PATIENT NAME"
+2 WRITE ?57,"BILLED AMT",?71,"BALANCE",$$EN^BARVDF("ULF")
+3 QUIT
RABILL ;Write RA data
+1 SET X=$$GET1^DIQ(90056.0205,BAREIENS,.08)
+2 DO ^%DT
+3 ;DOS begin
SET BARRADT=Y
+4 WRITE !,$$EN^BARVDF("RVN")
+5 ;
WRITE "ERA"
+6 ;BILL/RX
WRITE ?4,$EXTRACT($$GET1^DIQ(90056.0205,BAREIENS,.01),1,15)
+7 ;DOS begin
WRITE ?20,$$SDT^BARDUTL(BARRADT)
+8 ;Pt name
WRITE ?31,$EXTRACT($$GET1^DIQ(90056.0205,BAREIENS,.06),1,25)
+9 ;Billed
WRITE ?57,$JUSTIFY($FNUMBER($$GET1^DIQ(90056.0205,BAREIENS,.05),",",2),10)
+10 WRITE $$EN^BARVDF("RVF")
+11 QUIT
ARBILL ;Loop & write AR data
+1 SET (BARBIEN,BARCNT2)=0
+2 FOR
SET BARBIEN=$ORDER(BARTMP(BARBIEN))
IF '+BARBIEN
QUIT
Begin DoDot:1
+3 SET BARCNT2=BARCNT2+1
+4 SET BARBDT=$$GET1^DIQ(90050.01,BARBIEN,102,"I")
+5 WRITE !,$JUSTIFY(BARCNT2,2),")"
+6 ;expanded ck# to 20 chars bar*1.8*22 SDR
WRITE ?4,$EXTRACT($$GET1^DIQ(90050.01,BARBIEN,.01),1,20)
+7 WRITE ?20,$$SDT^BARDUTL(BARBDT)
+8 WRITE ?31,$EXTRACT($$GET1^DIQ(90050.01,BARBIEN,101),1,25)
+9 WRITE ?52,$JUSTIFY($FNUMBER($$GET1^DIQ(90050.01,BARBIEN,13),",",2),10)
+10 WRITE ?68,$JUSTIFY($FNUMBER($$GET1^DIQ(90050.01,BARBIEN,15),",",2),10)
+11 SET BARTMP2(BARCNT2)=BARBIEN
End DoDot:1
+12 QUIT
CHOOSE ;Choose bill from AR
+1 KILL DIR
+2 SET DIR(0)="SABO^B:Bill Inquire;H:History;M:Match to Item;N:Not Matched;Q:Quit"
+3 SET DIR("A")="Enter (B)ill Inquire,(H)istory,(M)atch to Item,(N)ot Matched,(Q)uit: "
+4 DO ^DIR
+5 ;bar*1.8*28 IHS/SD/SDR CR9572 HEAT258378
SET BARSEL=Y
+6 IF $DATA(DTOUT)!$DATA(DUOUT)!$DATA(DIRUT)!$DATA(DIROUT)
SET BARANS=0
QUIT
+7 ;not matched
IF BARSEL="N"!(BARSEL="Q")
SET BARANS=0
QUIT
+8 KILL DIR
+9 SET DIR(0)="NAO^1:"_BARCNT2
+10 SET DIR("A")="Which Entry: "
+11 SET DIR("?")="Enter a number between 1 and "_BARCNT2
+12 DO ^DIR
+13 IF $DATA(DIROUT)!$DATA(DUOUT)!$DATA(DIRUT)!$DATA(DTOUT)
SET BARANS=0
QUIT
+14 SET BARANS1=$GET(BARTMP2(Y))
SET BARANS=Y
+15 IF BARSEL="H"
Begin DoDot:1
+16 DO EN^BARPST5(BARANS1)
End DoDot:1
+17 IF BARSEL="B"
Begin DoDot:1
+18 DO DIQ^XBLM(90050.01,BARANS1)
End DoDot:1
+19 QUIT
+20 ;BAR*1.8*5 SRS-80 TPF
ADDREAS(IMPDA,CLMDA,ERRORS,SHOWMSG) ;EP - ADD RSN NOT SENT TO 'RSN NOT TO POST MULTIPLE'
+1 SET SHOWMSG=$GET(SHOWMSG)
+2 NEW REASON,STAT,ERRDA,CURSTAT
+3 SET REASON=""
+4 FOR
SET REASON=$ORDER(ERRORS(REASON))
IF REASON=""
QUIT
Begin DoDot:1
+5 IF REASON="CT"
DO STAT(IMPDA,CLMDA)
+6 IF SHOWMSG
Begin DoDot:2
+7 SET ERRDA=$ORDER(^BARERR("B",REASON,""))
+8 WRITE !,$$GET1^DIQ(90056.21,ERRDA_",",.02,"E")
End DoDot:2
+9 KILL DIC,DIE,DR,DA,DIR
+10 SET DIC("P")=$PIECE(^DD(90056.0205,401,0),U,2)
+11 SET DA(2)=IMPDA
+12 SET DA(1)=CLMDA
+13 SET DIC(0)="L"
+14 SET DIC="^BAREDI(""I"",DUZ(2),"_DA(2)_",30,"_DA(1)_",4,"
+15 SET X=REASON
+16 DO ^DIC
End DoDot:1
+17 QUIT
STAT(IMPDA,CLMDA) ;EP
+1 KILL DR,DIE,DA
+2 SET DIE=$$DIC^XBDIQ1(90056.0205)
+3 SET STAT="C"
+4 SET DR=".02///^S X=STAT"
+5 SET DA(1)=IMPDA
+6 SET DA=CLMDA
+7 DO ^DIE
+8 QUIT
DELREAS(IMPDA,CLMDA) ;EP -CLR 'RSN NOT TO POST' MULTIPLES IN ERA FILE
+1 NEW REASDA
+2 KILL DA,DIR,DIC,DIE,DR
+3 SET REASDA=0
+4 FOR
SET REASDA=$ORDER(^BAREDI("I",DUZ(2),IMPDA,30,CLMDA,4,REASDA))
IF 'REASDA
QUIT
Begin DoDot:1
+5 SET DA(2)=IMPDA
+6 SET DA(1)=CLMDA
+7 SET DIE="^BAREDI(""I"","_DUZ(2)_","_DA(2)_",30,"_DA(1)_",4,"
+8 SET DA=REASDA
+9 SET DR=".01///@"
+10 DO ^DIE
End DoDot:1
+11 KILL DA,DR,DIE,DIC,DIR
+12 SET DIE=$$DIC^XBDIQ1(90056.0205)
+13 ;REQ4
SET DR=""
+14 ;REQ4
SET IENS=CLMDA_","_IMPDA_","
+15 ;I $$GET1^DIQ(90056.0205,IENS,71)="" S DR=".02///C" ;'STATUS' FLD CLM UNMATCHED ;REQ4
+16 ;'STATUS' FLD CLM UNMATCHED IHS/DIT/CPC - BAR*1.8*28
IF $$GET1^DIQ(90056.0205,IENS,.02)=""!($$GET1^DIQ(90056.0205,IENS,.02,"I")="B")
SET DR=".02///C"
+17 ;'POST CLM AS TYPE'
SET DR=DR_";501///@"
+18 ;'PYMT CRDT APPLIED TO'
SET DR=DR_";601///@"
+19 ;'PYMT CRDT APPLIED FROM'
SET DR=DR_";602///@"
+20 SET DA(1)=IMPDA
+21 SET DA=CLMDA
+22 DO ^DIE
+23 KILL DA,DR,DIE,DIC,DIR
+24 QUIT
+25 ;
GETBBILL(BARTMP) ;
+1 NEW BARBLNUM,I,CH
+2 SET BARBLNUM=""
FOR I=1:1:$LENGTH(BARTMP)
SET CH=$EXTRACT(BARTMP,I)
IF CH'?1N
QUIT
SET BARBLNUM=BARBLNUM_CH
+3 ;TAKE THE FIRST ALPHA AFTER NNNN
IF CH?1A
SET BARBLNUM=BARBLNUM_CH
+4 IF BARBLNUM=""
QUIT ""
+5 QUIT BARBLNUM
LINE() ;
+1 NEW I,STR
+2 SET STR=""
FOR I=1:1:78
SET STR=STR_"-"
+3 QUIT STR
FTYPE() ;
+1 QUIT "5010"
+2 ;EOR - IHS/DIT/CPC 1.8*28
