BAREDP04 ; IHS/SD/LSL - MATCH REASONS AND CLAIMS ; 01/09/2009
;;1.8;IHS ACCOUNTS RECEIVABLE;**5,6,10,20,21,22,23,24,28**;OCT 26, 2005;Build 92
;IHS/SD/POT APR 2012 HEAT62015 BUG FIX: DO NOT CALL ^%DT IF DOS=""
;IHS/SD/POT OCT 2012 HEAT87149 FIXING LINE +210 - BAR 1.8*23
;IHS/SD/POT NOV 2012 HEAT82698 LEADING ZEROES IN BILL # - BAR 1.8*23
;IHS/SD/POT DEC 2012 FIX INIT VALUE OF CLMDA (+27) - BAR 1.8*23
;IHS/SD/POT HEAT147572 ALLOW TRIBAL SITES ERA POSTING OF NEG BAL & CANCELLED BILLS - BAR 1.8*24
;IHS/SD/POT NOHEAT PROCESS ZERO (0) IN CLP(1) - BAR 1.8*24
;IHS/DIT/CPC CR9572 REMOVE OVER-RIDE REASON NOT TO POST WHEN MANUALLY MATCH - BAR*1.8*28
Q
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,! ;bar*1.8*20 REQ4
K ^XTMP("BAR-LIST_DETAIL",$J,DUZ(2)) ;BAR 1.8*24
K ^XTMP("BAR-LIST",$J,DUZ(2))
S BARDBG=1
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 D
.S ^XTMP("BAR-LIST",$J,DUZ(2),$P($G(^BAREDI("I",DUZ(2),IMPDA,30,CLMDA,0)),U),CLMDA)=""
S CLMCNT=0 S BARBL="" F S BARBL=$O(^XTMP("BAR-LIST",$J,DUZ(2),BARBL)) Q:BARBL="" D Q:QFLG=1
.S CLMDA=0 F S CLMDA=$O(^XTMP("BAR-LIST",$J,DUZ(2),BARBL,CLMDA)) Q:'CLMDA D Q:QFLG=1
..K ERRORS D CLMFLG(CLMDA,.ERRORS)
Q:QFLG=1
S BARFLG=$$EN^BAREDP0Z(IMPDA) ;PLB/Pymt Rev/Neg pymt amt chks
;;;old code D:$$IHS^BARUFUT(DUZ(2)) NEGBAL^BAREDEB(IMPDA,"ERA") ;CHK FOR NEG BAL IN RPMS BILLS BAR 1.8*24
D NEGBAL^BAR50EB(IMPDA,"ERA") ;note: IHS/TRIBAL CHK INSIDE BAR50EB CHK FOR NEG BAL IN RPMS BILLS HEAT147572 BAR 1.8*24
;NOTE: MATCHED PYMTS & CREDITS W/HAVE THE 'POST THIS CLM AS TYPE' FLD = TO 20=PYMT CREDIT
;BAR*1.8*6 TPF MOVE REV CHK TO BAREDEP AS A FULL LOOP CHK
;;;old code D:$$IHS^BARUFUT(DUZ(2)) NONPAYCH^BAREDEP1(IMPDA) ;CHK FOR PYMTS NOT MATCHED TO REV TO SEE IF BEING POSTED TO 'NONPYMT' BATCH
D:$$IHSNEGB^BARUFUT(DUZ(2)) NONPAYCH^BAREDEP1(IMPDA) ;CHK FOR PYMTS NOT MATCHED TO REV TO SEE IF BEING POSTED TO 'NONPYMT' BATCH BAR 1.8*24
K ERRORS
Q
;--------------
CLMFLG(CLMDA,ERRORS) ;
;NEXT LINE MOVED TO TOP OF THE 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 ; REQ4
.;;;I $G(BARDBG) W " 1ST CHK - SKIP"
NEW 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)
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 - SKIP",1)
I $$OVERIDE^BAREDEP1(CLMDA) D Q ;MRS:BAR*1.8*10 D159-1 & 2
.I $G(BARDBG) D INS^BAR50DET(" OVERRIDE - SKIP",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 MATCHING STATUS
;--------------------------
I TRNAME["HIPAA" D
.;;;I $G(BARDBG) W !,"PERFORMING TRADITIONAL HIPAA CHECKS FOR CLAIM ",$P($G(^BAREDI("I",DUZ(2),IMPDA,30,CLMDA,0)),U)
.S CLMCNT=+$G(CLMCNT)+1
.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)
;
;------------ upd status in ^BAREDI ----------
;
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) ; pull rsn
.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) ;BAR*1.8*5 SRS-80 TPF ERRORS CAN BE MULTIPLE
; 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")="" ;BAR*1.8*5 SRS-80 TPF
S READA=+Y
;No RPMS cat/type in table
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 not successful, chk other identifier "G" x-ref for Pharmacy POS
S BAREIENS=CLMDA_","_IMPDA_","
S BARTEST=$$GET1^DIQ(90056.0205,BAREIENS,.01) ;full string
;;;I (($A($E(BARTEST,$L($P(BARTEST,"-"))))>64)&($A($E(BARTEST,$L($P(BARTEST,"-"))))<91)) S BARBILL=BARBILL_$E(BARTEST,$L(BARBILL)+1)
S (BARBIEN,BARBILL)="" ;IHS/DIT/CPC BAR 1.8*28
S (BARBIEN,BARBILL)=$$GETBBILL(BARTEST) ;BAR 1.8*23
I BARTEST="" D
.S CLMTYP="CF"
.W !,"Bill number not sent on ERA"
.S ERRORS("CF")=""
K BARTMP ;INIT ARRAY
S BARX="",BARFND=0
D CLM^BAREDP4A(BAREIENS,BARBILL,.BARX,.BARMMFLG) ;bar*1.8*20 REQ4 split due to rtn size
I BARFND=0 D
.S BARMSG=$P($G(^BAREDI("I",DUZ(2),IMPDA,30,CLMDA,0)),U)_" ***CLAIM NOT FOUND IN RPMS***"
.W !,BARMSG ;IMPORTANT!
.D INS^BAR50DET(BARMSG,0) ;SAME MESSAGE INTO REPORT
.D NOMATCH^BAR50DET ;INDICATE NOT MATCH
I $$GET1^DIQ(90056.0205,BAREIENS,1.01,"I")'="" S BARCNT=1 ; IENS->BAREIENS BAR 1.8*23
I BARCNT=0 S CLMTYP="CT",ERRORS("CT")=""
I BARCNT=1 S BARBIEN=$O(BARTMP(0))
I BILMATCH=1 D ;
.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)
.;
.;
CLM2 ;
;
S NEWSTAT=$G(NEWSTAT) ;init value 12/12/2013
I BARCNT>1,($$GET1^DIQ(90056.0205,BAREIENS,1.01)=""),('$D(BARRVW)) D ;IHS/DIT/CPC - BAR*1.8*28
.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 ;bar*1.8*20
..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")=""
.I '+BARANS,BARSEL="N" Q ;bar*1.8*20
.I '+BARANS S CLMTYP="CT",ERRORS("CT")="" Q ;BAR*1.8*5 SRS-80 TPF
.S BARBIEN=BARTMP2(BARANS)
;Match DOS
S (BARRADT,X)=$$GET1^DIQ(90056.0205,BAREIENS,.08) ;BAR 1.8*23
I X]"" D ^%DT I Y'=-1 S BARRADT=Y ;DOS begin
S BARBDT=$$GET1^DIQ(90050.01,BARBIEN,102,"I")
I BARRADT'=BARBDT S CLMTYP="CD",ERRORS("CD")="" ;DOS DOESN'T MATCH RPMS ; BAR*1.8*5 SRS-80
;See if cancelled in 3P
S BAR3PIEN=$$FIND3PB^BARUTL(DUZ(2),BARBIEN)
I BAR3PIEN]"" D ;BAR*1.8*5 SRS-80 TPF
.;I $$IHSCANCB^BARUFUT(DUZ(2)) Q ;allow cancelled bills 2/4/2014 BAR 1.8*24
.I $$IHSCANCB^BARUFUT(DUZ(2)) D Q ;allow cancelled bills 2/4/14 ;Update reasons not to post IHS/DIT/CPC -20180423 1.8*28
..S ERRORS("CC")=""
..D ADDREAS(IMPDA,CLMDA,.ERRORS,SHOWMSG)
.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*5 SRS-80 TPF ;bar*1.8*28 IHS/DIT}
D TRANSCK^BAREDP4A ;bar*1.8*20 REQ6
I $G(NEWSTAT)="M"!($$GET1^DIQ(90056.0205,BAREIENS,.02,"I")="M") Q 1 ;bar*1.8*20 REQ5
Q:$D(ERRORS) 0 ;BAR*1.8*5 SRS-80 TPF
; 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 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
W !,$$EN^BARVDF("RVN") ;bar*1.8*20
W "ERA" ;bar*1.8*20
W ?4,$E($$GET1^DIQ(90056.0205,BAREIENS,.01),1,15) ;BILL/RX ;bar*1.8*20 REQ4
S X=$$GET1^DIQ(90056.0205,BAREIENS,.08)
D ^%DT
S BARRADT=Y ;DOS begin
I X]"" W ?20,$$SDT^BARDUTL(BARRADT) ;DOS begin
I X="" W ?20,"DOS <nil>" ;BAR 1.8*23
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") ;bar*1.8*20
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,15)
.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
;start new REQ4
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
I $D(DTOUT)!$D(DUOUT)!$D(DIRUT)!$D(DIROUT) S BARANS=0 Q
S BARSEL=Y
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
;
;DISPLAY ERRORS CODE MOVED TO BAREDP4B
;
ADDREAS(IMPDA,CLMDA,ERRORS) ;EP - ADD RSN NOT SENT TO 'RSN NOT TO POST MULTIPLE'
S SHOWMSG=$G(SHOWMSG)
D ADDREAS^BAREDP4B(IMPDA,CLMDA,.ERRORS)
Q
DELREAS(IMPDA,CLMDA) ;EP -CLR 'RSN NOT TO POST' MULTIPLES IN ERA FILE
D DELREAS^BAREDP4B(IMPDA,CLMDA) ;SAC REQ
Q
;
GETBBILL(BARTMP) ;----------------------------------------------
NEW 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() ;
NEW I,STR
S STR="" F I=1:1:78 S STR=STR_"-"
Q STR
FTYPE() ;
I $ZN["BAR50" Q "5010"
Q "4010"
BAREDP04 ; IHS/SD/LSL - MATCH REASONS AND CLAIMS ; 01/09/2009
+1 ;;1.8;IHS ACCOUNTS RECEIVABLE;**5,6,10,20,21,22,23,24,28**;OCT 26, 2005;Build 92
+2 ;IHS/SD/POT APR 2012 HEAT62015 BUG FIX: DO NOT CALL ^%DT IF DOS=""
+3 ;IHS/SD/POT OCT 2012 HEAT87149 FIXING LINE +210 - BAR 1.8*23
+4 ;IHS/SD/POT NOV 2012 HEAT82698 LEADING ZEROES IN BILL # - BAR 1.8*23
+5 ;IHS/SD/POT DEC 2012 FIX INIT VALUE OF CLMDA (+27) - BAR 1.8*23
+6 ;IHS/SD/POT HEAT147572 ALLOW TRIBAL SITES ERA POSTING OF NEG BAL & CANCELLED BILLS - BAR 1.8*24
+7 ;IHS/SD/POT NOHEAT PROCESS ZERO (0) IN CLP(1) - BAR 1.8*24
+8 ;IHS/DIT/CPC CR9572 REMOVE OVER-RIDE REASON NOT TO POST WHEN MANUALLY MATCH - BAR*1.8*28
+9 QUIT
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
+9 ;--------------
INDEX ;EP
+1 SET QFLG=0
+2 ;bar*1.8*20 REQ4
WRITE !,"Processing Claim Status using claim Index ",INDEX,!
+3 ;BAR 1.8*24
KILL ^XTMP("BAR-LIST_DETAIL",$JOB,DUZ(2))
+4 KILL ^XTMP("BAR-LIST",$JOB,DUZ(2))
+5 SET BARDBG=1
+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
Begin DoDot:1
+10 SET ^XTMP("BAR-LIST",$JOB,DUZ(2),$PIECE($GET(^BAREDI("I",DUZ(2),IMPDA,30,CLMDA,0)),U),CLMDA)=""
End DoDot:1
+11 SET CLMCNT=0
SET BARBL=""
FOR
SET BARBL=$ORDER(^XTMP("BAR-LIST",$JOB,DUZ(2),BARBL))
IF BARBL=""
QUIT
Begin DoDot:1
+12 SET CLMDA=0
FOR
SET CLMDA=$ORDER(^XTMP("BAR-LIST",$JOB,DUZ(2),BARBL,CLMDA))
IF 'CLMDA
QUIT
Begin DoDot:2
+13 KILL ERRORS
DO CLMFLG(CLMDA,.ERRORS)
End DoDot:2
IF QFLG=1
QUIT
End DoDot:1
IF QFLG=1
QUIT
+14 IF QFLG=1
QUIT
+15 ;PLB/Pymt Rev/Neg pymt amt chks
SET BARFLG=$$EN^BAREDP0Z(IMPDA)
+16 ;;;old code D:$$IHS^BARUFUT(DUZ(2)) NEGBAL^BAREDEB(IMPDA,"ERA") ;CHK FOR NEG BAL IN RPMS BILLS BAR 1.8*24
+17 ;note: IHS/TRIBAL CHK INSIDE BAR50EB CHK FOR NEG BAL IN RPMS BILLS HEAT147572 BAR 1.8*24
DO NEGBAL^BAR50EB(IMPDA,"ERA")
+18 ;NOTE: MATCHED PYMTS & CREDITS W/HAVE THE 'POST THIS CLM AS TYPE' FLD = TO 20=PYMT CREDIT
+19 ;BAR*1.8*6 TPF MOVE REV CHK TO BAREDEP AS A FULL LOOP CHK
+20 ;;;old code D:$$IHS^BARUFUT(DUZ(2)) NONPAYCH^BAREDEP1(IMPDA) ;CHK FOR PYMTS NOT MATCHED TO REV TO SEE IF BEING POSTED TO 'NONPYMT' BATCH
+21 ;CHK FOR PYMTS NOT MATCHED TO REV TO SEE IF BEING POSTED TO 'NONPYMT' BATCH BAR 1.8*24
IF $$IHSNEGB^BARUFUT(DUZ(2))
DO NONPAYCH^BAREDEP1(IMPDA)
+22 KILL ERRORS
+23 QUIT
+24 ;--------------
CLMFLG(CLMDA,ERRORS) ;
+1 ;NEXT LINE MOVED TO TOP OF THE SUBR
+2 ;only look at 1 chk's clms ; REQ4
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
+3 ;;;I $G(BARDBG) W " 1ST CHK - SKIP"
End DoDot:1
QUIT
+4 ;RETURN FLAG
NEW BARTMPM,BARTMPCL
+5 ;
SET BILMATCH=0
+6 SET BARTMPCL=$PIECE($GET(^BAREDI("I",DUZ(2),IMPDA,30,CLMDA,0)),U)
+7 IF $GET(BARDBG)
Begin DoDot:1
+8 DO INS^BAR50DET($$LINE(),0)
+9 SET BARMSG="PROCESSING ENTRY: "_$JUSTIFY(CLMDA,6)_" CLAIM "_BARTMPCL
WRITE !,BARMSG
+10 DO INS^BAR50DET(BARMSG,0)
End DoDot:1
+11 ;quit if posted
IF $PIECE($GET(^BAREDI("I",DUZ(2),IMPDA,30,CLMDA,0)),U,2)="P"
Begin DoDot:1
+12 IF $GET(BARDBG)
DO INS^BAR50DET(" POSTED - SKIP",1)
End DoDot:1
QUIT
+13 ;MRS:BAR*1.8*10 D159-1 & 2
IF $$OVERIDE^BAREDEP1(CLMDA)
Begin DoDot:1
+14 IF $GET(BARDBG)
DO INS^BAR50DET(" OVERRIDE - SKIP",1)
End DoDot:1
QUIT
+15 ;user marked as Exception-skip
IF $PIECE($GET(^BAREDI("I",DUZ(2),IMPDA,30,CLMDA,0)),U,2)="E"
Begin DoDot:1
+16 IF $GET(BARDBG)
DO INS^BAR50DET(" EXCEPTION - SKIP",1)
End DoDot:1
QUIT
+17 ;CLR ERRORS, SET STAT TO MATCHED, BEGIN BY ASSUMING ALL CLMS ARE MATCHED & ERROR FREE
DO DELREAS(IMPDA,CLMDA)
+18 ;CHK & SET CLM MATCHING STATUS
+19 ;--------------------------
+20 IF TRNAME["HIPAA"
Begin DoDot:1
+21 ;;;I $G(BARDBG) W !,"PERFORMING TRADITIONAL HIPAA CHECKS FOR CLAIM ",$P($G(^BAREDI("I",DUZ(2),IMPDA,30,CLMDA,0)),U)
+22 SET CLMCNT=+$GET(CLMCNT)+1
+23 SET CLMFLG=$$HIPAACLM(IMPDA,CLMDA,.ERRORS)
+24 IF $GET(QFLG)=1
QUIT
+25 SET REAFLG=$$HIPAAREA(IMPDA,CLMDA,.ERRORS)
End DoDot:1
+26 IF $GET(QFLG)=1
QUIT
+27 ;---------------------------
+28 IF TRNAME'["HIPAA"
Begin DoDot:1
+29 SET CLMFLG=$$CLM(CLMDA)
+30 SET REAFLG=$$REA(CLMDA)
End DoDot:1
+31 ;
+32 ;------------ upd status in ^BAREDI ----------
+33 ;
+34 SET STAT=""
+35 ;MATCHED
IF CLMFLG
IF REAFLG
SET STAT="M"
+36 ;CLM UNMATCHED
IF 'CLMFLG
IF REAFLG
SET STAT="C"
+37 IF CLMFLG
IF 'REAFLG
SET STAT="M"
+38 IF 'CLMFLG
IF 'REAFLG
SET STAT="C"
+39 KILL DR,DIE,DA
+40 SET DIE=$$DIC^XBDIQ1(90056.0205)
+41 SET DR=".02////^S X=STAT"
+42 SET DA(1)=IMPDA
+43 SET DA=CLMDA
+44 DO ^DIE
+45 ;-------------------------------------------
+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
+14 ;--------------
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 ; pull rsn
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
+30 ;-------------
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) ;BAR*1.8*5 SRS-80 TPF ERRORS CAN BE MULTIPLE
+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 ;BAR*1.8*5 SRS-80 TPF
SET ERRORS("RT")=""
End DoDot:1
QUIT
+19 SET READA=+Y
+20 ;No RPMS cat/type in table
+21 ;
IF $PIECE(Y(0),U,3)=""!($PIECE(Y(0),U,4)="")
Begin DoDot:1
+22 WRITE !,"Can't map standard adjustment reason ",X," to RPMS."
+23 SET REAFLG=0
+24 SET REATYP="RU"
+25 ;BAR*1.8*5 SRS-80 TPF
SET ERRORS("RU")=""
End DoDot:1
+26 KILL DIC,DA,DR,DIE
+27 SET DIE=$$DIC^XBDIQ1(90056.0208)
+28 SET DA(2)=IMPDA
+29 SET DA(1)=CLMDA
+30 SET DA=ADJDA
+31 SET DR=".04////^S X=$P(Y(0),U,3)"
+32 SET DR=DR_";.05////^S X=$P(Y(0),U,4)"
+33 DO ^DIE
+34 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
+4 ;If not successful, chk other identifier "G" x-ref for Pharmacy POS
+5 SET BAREIENS=CLMDA_","_IMPDA_","
+6 ;full string
SET BARTEST=$$GET1^DIQ(90056.0205,BAREIENS,.01)
+7 ;;;I (($A($E(BARTEST,$L($P(BARTEST,"-"))))>64)&($A($E(BARTEST,$L($P(BARTEST,"-"))))<91)) S BARBILL=BARBILL_$E(BARTEST,$L(BARBILL)+1)
+8 ;IHS/DIT/CPC BAR 1.8*28
SET (BARBIEN,BARBILL)=""
+9 ;BAR 1.8*23
SET (BARBIEN,BARBILL)=$$GETBBILL(BARTEST)
+10 IF BARTEST=""
Begin DoDot:1
+11 SET CLMTYP="CF"
+12 WRITE !,"Bill number not sent on ERA"
+13 SET ERRORS("CF")=""
End DoDot:1
+14 ;INIT ARRAY
KILL BARTMP
+15 SET BARX=""
SET BARFND=0
+16 ;bar*1.8*20 REQ4 split due to rtn size
DO CLM^BAREDP4A(BAREIENS,BARBILL,.BARX,.BARMMFLG)
+17 IF BARFND=0
Begin DoDot:1
+18 SET BARMSG=$PIECE($GET(^BAREDI("I",DUZ(2),IMPDA,30,CLMDA,0)),U)_" ***CLAIM NOT FOUND IN RPMS***"
+19 ;IMPORTANT!
WRITE !,BARMSG
+20 ;SAME MESSAGE INTO REPORT
DO INS^BAR50DET(BARMSG,0)
+21 ;INDICATE NOT MATCH
DO NOMATCH^BAR50DET
End DoDot:1
+22 ; IENS->BAREIENS BAR 1.8*23
IF $$GET1^DIQ(90056.0205,BAREIENS,1.01,"I")'=""
SET BARCNT=1
+23 IF BARCNT=0
SET CLMTYP="CT"
SET ERRORS("CT")=""
+24 IF BARCNT=1
SET BARBIEN=$ORDER(BARTMP(0))
+25 ;
IF BILMATCH=1
Begin DoDot:1
+26 SET BARBIEN=$ORDER(BILMATCH(""))
SET BARCNT=1
+27 SET BARMSG=$JUSTIFY("",5)_"ERA BILL "_$$GET1^DIQ(90056.0205,BAREIENS,.01)
WRITE !,BARMSG
+28 IF $GET(BARDBG)
DO INS^BAR50DET(BARMSG,0)
+29 SET BARMSG=" MATCHED TO "_$SELECT(BARX="G":"(POS)",1:"")_" A/R BILL "_$PIECE($GET(^BARBL(DUZ(2),BARBIEN,0)),U)
+30 WRITE BARMSG
+31 IF $GET(BARDBG)
DO INS^BAR50DET(BARMSG,1)
+32 ;
+33 ;
End DoDot:1
CLM2 ;
+1 ;
+2 ;init value 12/12/2013
SET NEWSTAT=$GET(NEWSTAT)
+3 ;IHS/DIT/CPC - BAR*1.8*28
IF BARCNT>1
IF ($$GET1^DIQ(90056.0205,BAREIENS,1.01)="")
IF ('$DATA(BARRVW))
Begin DoDot:1
+4 FOR
Begin DoDot:2
+5 DO HDR
+6 DO RABILL
+7 DO ARBILL
+8 DO CHOOSE
+9 ;bar*1.8*20
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 IF BARSEL="N"
SET NEWSTAT="M"
SET ERRORS("DUPB")=""
+21 ;bar*1.8*20
IF '+BARANS
IF BARSEL="N"
QUIT
+22 ;BAR*1.8*5 SRS-80 TPF
IF '+BARANS
SET CLMTYP="CT"
SET ERRORS("CT")=""
QUIT
+23 SET BARBIEN=BARTMP2(BARANS)
End DoDot:1
+24 ;Match DOS
+25 ;BAR 1.8*23
SET (BARRADT,X)=$$GET1^DIQ(90056.0205,BAREIENS,.08)
+26 ;DOS begin
IF X]""
DO ^%DT
IF Y'=-1
SET BARRADT=Y
+27 SET BARBDT=$$GET1^DIQ(90050.01,BARBIEN,102,"I")
+28 ;DOS DOESN'T MATCH RPMS ; BAR*1.8*5 SRS-80
IF BARRADT'=BARBDT
SET CLMTYP="CD"
SET ERRORS("CD")=""
+29 ;See if cancelled in 3P
+30 SET BAR3PIEN=$$FIND3PB^BARUTL(DUZ(2),BARBIEN)
+31 ;BAR*1.8*5 SRS-80 TPF
IF BAR3PIEN]""
Begin DoDot:1
+32 ;I $$IHSCANCB^BARUFUT(DUZ(2)) Q ;allow cancelled bills 2/4/2014 BAR 1.8*24
+33 ;allow cancelled bills 2/4/14 ;Update reasons not to post IHS/DIT/CPC -20180423 1.8*28
IF $$IHSCANCB^BARUFUT(DUZ(2))
Begin DoDot:2
+34 SET ERRORS("CC")=""
+35 DO ADDREAS(IMPDA,CLMDA,.ERRORS,SHOWMSG)
End DoDot:2
QUIT
+36 SET BARBSTAT=$PIECE($GET(^ABMDBILL($PIECE(BAR3PIEN,","),$PIECE(BAR3PIEN,",",2),0)),U,4)
+37 ;S:BARBSTAT="X" CLMTYP="CC" ;Cancelled in 3P ;bar*1.8*28 IHS/DIT}
+38 ;BAR*1.8*5 SRS-80 TPF ;bar*1.8*28 IHS/DIT}
IF BARBSTAT="X"
SET CLMTYP="CC"
SET ERRORS("CC")=""
End DoDot:1
+39 ;bar*1.8*20 REQ6
DO TRANSCK^BAREDP4A
+40 ;bar*1.8*20 REQ5
IF $GET(NEWSTAT)="M"!($$GET1^DIQ(90056.0205,BAREIENS,.02,"I")="M")
QUIT 1
+41 ;BAR*1.8*5 SRS-80 TPF
IF $DATA(ERRORS)
QUIT 0
+42 ; Bill matches RPMS-log AR Bill IEN in Image
+43 SET DIE=$$DIC^XBDIQ1(90056.0205)
+44 SET DA=CLMDA
+45 SET DA(1)=IMPDA
+46 SET DR="1.01////^S X=BARBIEN"
+47 SET MATCH="M"
+48 SET DR=DR_";.02////^S X=MATCH"
+49 DO ^DIE
+50 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 ;bar*1.8*20
WRITE !,$$EN^BARVDF("RVN")
+2 ;bar*1.8*20
WRITE "ERA"
+3 ;BILL/RX ;bar*1.8*20 REQ4
WRITE ?4,$EXTRACT($$GET1^DIQ(90056.0205,BAREIENS,.01),1,15)
+4 SET X=$$GET1^DIQ(90056.0205,BAREIENS,.08)
+5 DO ^%DT
+6 ;DOS begin
SET BARRADT=Y
+7 ;DOS begin
IF X]""
WRITE ?20,$$SDT^BARDUTL(BARRADT)
+8 ;BAR 1.8*23
IF X=""
WRITE ?20,"DOS <nil>"
+9 ;Pt name
WRITE ?31,$EXTRACT($$GET1^DIQ(90056.0205,BAREIENS,.06),1,25)
+10 ;Billed
WRITE ?57,$JUSTIFY($FNUMBER($$GET1^DIQ(90056.0205,BAREIENS,.05),",",2),10)
+11 ;bar*1.8*20
WRITE $$EN^BARVDF("RVF")
+12 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 WRITE ?4,$EXTRACT($$GET1^DIQ(90050.01,BARBIEN,.01),1,15)
+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 ;start new REQ4
+2 KILL DIR
+3 SET DIR(0)="SABO^B:Bill Inquire;H:History;M:Match to Item;N:Not Matched;Q:Quit"
+4 SET DIR("A")="Enter (B)ill Inquire,(H)istory,(M)atch to Item,(N)ot Matched,(Q)uit: "
+5 DO ^DIR
+6 IF $DATA(DTOUT)!$DATA(DUOUT)!$DATA(DIRUT)!$DATA(DIROUT)
SET BARANS=0
QUIT
+7 SET BARSEL=Y
+8 ;not matched
IF BARSEL="N"!(BARSEL="Q")
SET BARANS=0
QUIT
+9 KILL DIR
+10 SET DIR(0)="NAO^1:"_BARCNT2
+11 SET DIR("A")="Which Entry: "
+12 SET DIR("?")="Enter a number between 1 and "_BARCNT2
+13 DO ^DIR
+14 IF $DATA(DIROUT)!$DATA(DUOUT)!$DATA(DIRUT)!$DATA(DTOUT)
SET BARANS=0
QUIT
+15 SET BARANS1=$GET(BARTMP2(Y))
SET BARANS=Y
+16 IF BARSEL="H"
Begin DoDot:1
+17 DO EN^BARPST5(BARANS1)
End DoDot:1
+18 IF BARSEL="B"
Begin DoDot:1
+19 DO DIQ^XBLM(90050.01,BARANS1)
End DoDot:1
+20 QUIT
+21 ;
+22 ;DISPLAY ERRORS CODE MOVED TO BAREDP4B
+23 ;
ADDREAS(IMPDA,CLMDA,ERRORS) ;EP - ADD RSN NOT SENT TO 'RSN NOT TO POST MULTIPLE'
+1 SET SHOWMSG=$GET(SHOWMSG)
+2 DO ADDREAS^BAREDP4B(IMPDA,CLMDA,.ERRORS)
+3 QUIT
DELREAS(IMPDA,CLMDA) ;EP -CLR 'RSN NOT TO POST' MULTIPLES IN ERA FILE
+1 ;SAC REQ
DO DELREAS^BAREDP4B(IMPDA,CLMDA)
+2 QUIT
+3 ;
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
+6 ;
LINE() ;
+1 NEW I,STR
+2 SET STR=""
FOR I=1:1:78
SET STR=STR_"-"
+3 QUIT STR
FTYPE() ;
+1 IF $ZN["BAR50"
QUIT "5010"
+2 QUIT "4010"
