BAR50P08 ; IHS/SD/LSL - POST HIPAA CLAIMS ; 12/01/2008
;;1.8;IHS ACCOUNTS RECEIVABLE;**1,4,5,6,10,19,20,21,23,24,26**;OCT 26,2005;Build 17
;
;IHS/SD/POT 1.8*24 HEAT147572 ALLOW TRIBAL SITES ERA POSTING OF NEG BAL & CANCELLED BILLS 2/11/2014
;IHS/SD/SDR 1.8*26 HEAT170856 - Tribal sites couldn't post bill into negative balance. Also made change to not do matching checks again. Doing it
; again here was causing reasons to get deleted and not put back on so bills were posting that shouldn't. May need to revisit this but seems to
; work ok with the examples provided.
;
;
Q
POST(BARCKDA) ; EP bar*1.8*20 REQ6 changed BARCKIEN to BARCKDA
;Post this ERA Check (called from POST^BAR50P00)
N BPR02 ;TPF BAR*1.8*6 SCR119
K BAROLD ;MRS:BAR*1.8*6 DD 4.2.4
S BARFND=0
S BARSECT=BARUSR(29,"I")
S BARCHECK=$P($G(^BARECHK(BARCKDA,0)),U)
S BARBATCH=$P($G(^BARECHK(BARCKDA,0)),U,3)
S BARPITEM=$P($G(^BARECHK(BARCKDA,0)),U,4)
S BARICQ=$$GET1^DIQ(90056.22,BARCKDA_",",.08) ;ID CODE QUALIFIER FROM A/R EDI IMPORT XX=NPI, FI = TAX ID
S BARNPI=$$GET1^DIQ(90056.22,BARCKDA_",",.09) ;ID CODE (NPI) FROM A/R EDI IMPORT
S BARTIN=$$GET1^DIQ(90056.22,BARCKDA_",",.11) ;TAX ID FROM A/R EDI IMPORT
S BPR02=$$GETBPR02(BARCHECK)
I BPR02?.A D Q
.;W !,"CANNOT FIND A BPR02 VALUE IN IMPORT FILE!" OLD CODE
.W !,"CANNOT FIND A BPR02 VALUE IN IMPORT FILE! ("_BPR02_")" ;11/06/2013 MORE SPECIFIC MESSAGE
.K DIR S DIR(0)="E"
.D ^DIR
K BARADD,BARERR
D GETS^DIQ(90056.22,BARCKDA_",","2211*","E","BARADD","BARERR") ;GET PAYEE ADD IDENTIFICATION ;bar*1.8*20 REQ6
I BARBATCH'="",'$$CKDATE^BARPST(BARBATCH,1,"POSTING TO A/R COLLECTION BATCH") D Q ;MRS:BAR*1.8*6 DD 4.2.4 USER ALLOWED TO POST TO NO BATCH SCR119
.S (BARBATCH,BAROLD)=""
.D NOBATCH
I (BARBATCH=""!(BARPITEM="")),(BPR02>0) D NOBATCH ;TPF BAR*1.8*6 SCR119
Q:+BARFND
I $D(BAROLD) K BAROLD Q ;MRS:BAR*1.8*6 DD 4.2.4
;if there are claims w/BUILT status
I $D(^BAREDI("I",DUZ(2),IMPDA,30,"AC","B")) D
.S CLMDA=0
.K BARSTOP
.F S CLMDA=$O(^BAREDI("I",DUZ(2),IMPDA,30,"AC","B",CLMDA)) Q:'CLMDA D
..I $P($G(^BAREDI("I",DUZ(2),IMPDA,30,CLMDA,2)),U)=BARCHECK S BARSTOP=1
.I $G(BARSTOP)=1 W !!,"EDI Claims are still in a BUILT status for this check!",!,"Run BLMT or REV auto-review for matching."
Q:($G(BARSTOP)=1)
D ASKPOST
Q:'BARANS ;MRS:BAR*1.8*10 H1228
K DIR
D EOP^BARUTL(1)
D POSTEM
I '+BARPSTED D Q
. W !!,"No matched bills to post",!!
. I PSTQFLG=1 W !,$$EN^BARVDF("HIN"),"** BILLS HAVE BEEN MARKED AS 'ITEM BALANCE EXCEEDED'. PLEASE REVIEW AND POST",!?4,"MANUALLY**",$$EN^BARVDF("HIF") ;bar*1.8*20 REQ6
. K DIR
. D EOP^BARUTL(1)
W !!,BARPSTED," Bills posted to AR.",!
;start new bar*1.8*20 REQ6
I PSTQFLG=1 W !!,$$EN^BARVDF("HIN"),"** BILLS HAVE BEEN MARKED AS 'ITEM BALANCE EXCEEDED'. PLEASE REVIEW AND POST",!?4,"MANUALLY**",$$EN^BARVDF("HIF")
;end new REQ6
D ROLLBACK ;Rollback now or later
Q
;
GETBPR02(BARCHECK) ;EP -GET BPR02 MONETARY AMT FROM ERACHECK
N IMPDA,CLMDA,BPR02
S IMPDA="" S IMPDA=$O(^BAREDI("I",DUZ(2),"F",BARCHECK,IMPDA),-1) ;ALL BPR02 WILL BE SAME FOR ALL CHK ENTRIES. GET LAST LOAD
Q:IMPDA="" "NOIMPORT"
S CLMDA="" S CLMDA=$O(^BAREDI("I",DUZ(2),"F",BARCHECK,IMPDA,CLMDA))
Q:CLMDA="" "NOCLAIMFORIMPORT"
S BPR02=$P($G(^BAREDI("I",DUZ(2),IMPDA,30,CLMDA,2)),U,5)
Q:BPR02="" "NOBPR02"
Q BPR02
;
NOBATCH ;
;Chk for pymts on clms for this chk
S (BARCLM,BARFND)=0 ;"F" IS CHECK/EFT TRACE X-REF
F S BARCLM=$O(^BAREDI("I",DUZ(2),"F",BARCHECK,IMPDA,BARCLM)) Q:'+BARCLM D Q:+BARFND
. Q:'+$P($G(^BAREDI("I",DUZ(2),IMPDA,30,BARCLM,0)),U,4) ;E-PYMT
. S BARFND=1
I +BARFND D
. W !!,$$CJ^XLFSTR("Check "_BARCHECK_" does not match an RPMS Collection Batch and Item.",IOM)
. W !,$$CJ^XLFSTR("There is at least one bill for this check containing a payment amount.",IOM)
. W !,$$CJ^XLFSTR("The system will not allow posting bills to this check at this time.",IOM)
. W !,$$CJ^XLFSTR("Please go back and create an RPMS Collection Batch and Item",IOM),!
. K DIR
. D EOP^BARUTL(1)
Q
; ********************
ASKPOST ;Ask user if really want to post clms
W !
S BARANS=0
K DIR
S DIR(0)="Y"
S DIR("A")="Do you want to post ERA Claims for Chk/EFT "_BARCHECK_" now"
S DIR("B")="N"
D ^DIR
S:Y=1 BARANS=1
Q
; ********************
POSTEM ; LOOP Claims with this chk
; Quit if status is not matched
S (CLMDA,BARPSTED,BARDONE)=0
;start new bar*1.8*20 REQ6
S CLMCNT=0,PSTQFLG=0
K ^XTMP("BAR-MBAMT",$J,DUZ(2))
F S CLMDA=$O(^BAREDI("I",DUZ(2),"F",BARCHECK,IMPDA,CLMDA)) Q:'+CLMDA D Q:+BARDONE
.S ^XTMP("BAR-MBAMT",$J,DUZ(2),+$P($G(^BAREDI("I",DUZ(2),IMPDA,30,CLMDA,0)),U,4),CLMDA)="" ;E-payment
S CLMAMT=""
F S CLMAMT=$O(^XTMP("BAR-MBAMT",$J,DUZ(2),CLMAMT)) Q:($G(CLMAMT)="") D
.S CLMDA=0
.F S CLMDA=$O(^XTMP("BAR-MBAMT",$J,DUZ(2),+CLMAMT,CLMDA)) Q:'+CLMDA D Q:+BARDONE
..;below lines added 1 dot to line up w/new code
..S BARCKIEN=$O(^BAREDI("I",DUZ(2),IMPDA,5,"B",BARCHECK,0)) ;bar*1.8*20 REQ6
..S BARBL=$P($G(^BAREDI("I",DUZ(2),IMPDA,30,CLMDA,0)),U) ;bar*1.8*20 REQ6
..;D CLMFLG^BAR50P04(CLMDA,.ERRORS) ;bar*1.8*20 REQ6 ;bar*1.8*26 IHS/SD/SDR HEAT170856 - removed; it was deleting RNTP from claim, causing them to post when they shouldn't
..;;;old code I $$IHS^BARUFUT(DUZ(2)) S BARCHK=BARCHECK D NEGBAL^BAR50EB(IMPDA,"ERA") ;bar*1.8*20
..;S BARCHK=BARCHECK D NEGBAL^BAR50EB(IMPDA,"ERA") ;new code HEAT147572 2/5/2014 ;bar*1.8*26 IHS/SD/SDR HEAT170856
..I $$IHS^BARUFUT(DUZ(2)) S BARCHK=BARCHECK D NEGBAL^BAR50EB(IMPDA,"ERA") ;put this line back because it seems to work better with the check than without ;bar*1.8*26 IHS/SD/SDR HEAT170856
..;;;old code D:$$IHS^BARUFUT(DUZ(2)) NONPAYCH^BAR50EP1(IMPDA) ;bar*1.8*20
..D:$$IHSNEGB^BARUFUT(DUZ(2)) NONPAYCH^BAR50EP1(IMPDA) ;new code HEAT147572
..I $P($G(^BAREDI("I",DUZ(2),IMPDA,30,CLMDA,0)),U,2)'="M" Q ;NOT matched
..I (($P($G(^BAREDI("I",DUZ(2),IMPDA,30,CLMDA,0)),U,2)="M")&(+$O(^BAREDI("I",DUZ(2),IMPDA,30,CLMDA,4,0))'=0)) Q ;matched but reason not to post bar*1.8*20 REQ5
..S CLMCNT=+$G(CLMCNT)+1 ;bar*1.8*20 REQ6
..D BASIC
.. S PSTQFLG=0 ;INIT VALUE
..;check if posting this payment will create a negative balance on batch/item
..;------------------------------------------------------------------------
..D ENP^XBDIQ1(90056.0205,"IMPDA,CLMDA",".01;.05;1.01;.02;.04;.11;.12;301;501;601;602","CLM(") ;BAR*1.8*5 INCLUDE 'POST THIS CLAIM AS TYPE' FIELD
..W !?7,"Billed: ",CLM(.05),?25,"Payment: ",CLM(.04)
..S IENS=BARITM_","_BARCOL_","
..S ITEMAMT=$$GET1^DIQ(90051.1101,IENS,19) ;item posting balance
..S IENS=CLMDA_","_IMPDA_","
..S BARCR=$$GET1^DIQ(90056.0205,IENS,".04")
..;------------------------------------------------------------------------
..I (ITEMAMT-BARCR)<0 D
... I '$$IHSNEGB^BARUFUT(DUZ(2)) QUIT ;2/11/2014
...W !!?7,$$EN^BARVDF("HIN"),"<<PYMT EXCEEDS COLLECTION ITEM BALANCE. MARKED AS 'ITEM BALANCE EXCEEDED'",$$EN^BARVDF("HIF")
...S PSTQFLG=1
..;------------------------------------------------------------------------
..I PSTQFLG=1 D UP^BAR50P0Z(IMPDA,CLMDA,"EBAL") Q ;leave bill as matched but with NTP reason item balance exceeded
..D NEGBAL
..Q:'BARANS
.. ;CLMDA WILL BE POSTED OK
..D ADJMULT
..D PAY
..D RMKCD ;Post remark codes
..D NCPDP ;Post NCPDP codes
..D MRKCLMP
..W !
Q
; ********************
BASIC ;
S BAREIENS=CLMDA_","_IMPDA_","
S BARBLIEN=$$GET1^DIQ(90056.0205,BAREIENS,1.01,"I") ;A/R BILL
S BARBLPAT=$$GET1^DIQ(90050.01,BARBLIEN,101,"I") ;A/R Patient IEN
S BARBLAC=$$GET1^DIQ(90050.01,BARBLIEN,3,"I") ;A/R Account
S BARBAL=$$GET1^DIQ(90050.01,BARBLIEN,15) ;A/R Bill Balance
S BARCOL=BARBATCH
;S BARITM=BARITEM ;bar*1.8*20
S BARITM=BARPITEM ;bar*1.8*20
S BARVLOC=$$GET1^DIQ(90050.01,BARBLIEN,108,"I") ;A/R LOCATION
Q
;---------------------------------------------------------
NEGBAL ;
S BARANS=1
S BARTOT=0
S BARPAY=$P($G(^BAREDI("I",DUZ(2),IMPDA,30,CLMDA,0)),U,4)
S BARTOT=BARTOT+BARPAY
S (BARADJ,ADJDA)=0
F S ADJDA=$O(^BAREDI("I",DUZ(2),IMPDA,30,CLMDA,30,ADJDA)) Q:'+ADJDA D
.S BARAMT=$P($G(^BAREDI("I",DUZ(2),IMPDA,30,CLMDA,30,ADJDA,0)),U,2)
.S BARADJ=BARADJ+BARAMT
S BARTOT=BARTOT+BARADJ
I (BARBAL-BARTOT)=0 Q
I (BARBAL-BARTOT)>0 Q
I '$$IHSNEGB^BARUFUT(DUZ(2)) QUIT ;2/11/2014
I BARBAL>0 W !!,"<<Posting this bill will result in a negative balance on the bill>>" ;11/22/2013
I BARBAL=0 W !!,"<<<Posting this bill will result in a negative balance on the bill >>>" ;11/22/2013
;Mark bill not to post
D UP^BAR50P0Z(IMPDA,CLMDA,"NEGR")
S BARANS=0 ;bar*1.8*20
Q
; ****************
PAY ;EP ;PULL CLAIM INFO AND POST PYMT (IF ANY)
D PAY^BAR50P8A ;split due to rtn size
Q
; ******************
ADJMULT ;EP ;POST ADJUSTMENTS
D ADJMULT^BAR50P8A ;split due to rtn size
Q
; *******************
RMKCD ; POST REMARK CODES
D RMKCD^BAR50P8A ;split due to rtn size
Q
; ***************
NCPDP ; POST NCPDP CODES
K BARTO,BARFROM ;TPF BAR*1.8*6 SCR119
K NCPDP,DR,BARDR
D ENPM^XBDIQ1(90056.0212,"IMPDA,CLMDA,0",".03","NCPDP(","I")
Q:'$D(NCPDP)
S BARTRAN=506
S DR=""
D DR
S DR=$E(DR,2,9999) ;Strip leading ";"
I +$G(BARCOL)>0 S DR=DR_";14////^S X=$G(BARCOL)" ;Collct btch if know
I +$G(BARITM)>0 S DR=DR_";15////^S X=$G(BARITM)" ;Item if known
S DR=DR_";108////^S X=BARNCPDP" ;Remark Code pointer
S BARDR=DR
K DR
S NCPDPDA=0
F S NCPDPDA=$O(NCPDP(NCPDPDA)) Q:'+NCPDPDA D
.S BARNCPDP=NCPDP(NCPDPDA,.03,"I")
.Q:BARNCPDP=""
.D POSTRAN
.K NCPDPP
.D ENP^XBDIQ1(90056.0212,"IMPDA,CLMDA,NCPDPDA",".02;.03","NCPDPP(")
.W !?5,"NCPDP REJECT/PAYMENT CODE: ",NCPDPP(.03),?25,$E($P(NCPDPP(.02)," ",3,99),1,50)
K NCPDP,NCPDPP
Q
; ****************
DR ; Gather data needed for transaction
S DR=DR_";4////^S X=BARBLIEN" ;A/R Bill
S DR=DR_";5////^S X=BARBLPAT" ;A/R Patient
S DR=DR_";6////^S X=BARBLAC" ;A/R Account
S DR=DR_";8////^S X=DUZ(2)" ;Parent Location
S DR=DR_";9////^S X=DUZ(2)" ;Parent ASUFAC
S DR=DR_";10////^S X=BARSECT" ;A/R Section
S DR=DR_";11////^S X=BARVLOC" ;Visit Location
S DR=DR_";12////^S X=DT" ;Date
S DR=DR_";13////^S X=DUZ" ;Entry by
S DR=DR_";101////^S X=BARTRAN" ;Transaction Type
S DR=DR_";106////^S X=""e""" ;Data Source = e
S DR=DR_";401////^S X=BARICQ" ;INDENTIFICATION CODE QUALIFIER XX=NPI, FI=TAX ID
S DR=DR_";402////^S X=BARNPI" ;IF BARICQ='XX' NPI
S DR=DR_";403////^S X=BARTIN" ;IF BARICQ='FI' TAX ID
S DR=DR_";501////^S X=$G(BARTO)" ;PYMT CREDIT APPLIED FROM BILL
S DR=DR_";502////^S X=$G(BARFROM)" ;PYMT CREDIT APPLIED TO BILL
I BARTRAN=138 D
.S BARTRAN=43 ;PYMT CREDIT POSTS AS ADJUSTMENT
.S BARCAT=20
.S BARREAS=138
.S DR=DR_";102////^S X=BARCAT" ;PYMT CREDIT
.S DR=DR_";103////^S X=BARREAS" ;CREDIT TO OTHER BILL
I BARTRAN=139 D ;IF THIS IS TRUE THEN WE NEED TO POST THIS AS AN ADJ
.S BARTRAN=43
.S BARCAT=20
.S BARREAS=139
.S DR=DR_";102////^S X=BARCAT"
.S DR=DR_";103////^S X=BARREAS" ;CREDIT FROM OTHER BILL
Q
; *************
MRKCLMP ;EP ; MARK CLAIM AS POSTED
K DIC,DA,DR
S DIE=$$DIC^XBDIQ1(90056.0205)
S DA(1)=IMPDA
S DA=CLMDA
S DR=".02////P"
D ^DIE
K DIC,DA,DR
S BARPSTED=BARPSTED+1
Q
; ****************
POSTRAN ;EP ; SET TRANSACTION & POST FILES
S BARTRIEN=$$NEW^BARTR ;Create Trans
I BARTRIEN<1 D MSG^BARTR(BARBLIEN) Q
S BARROLL(BARBLIEN)=""
;Populate Trans file
S DR=BARDR
S DA=BARTRIEN ;IEN to A/R TRANSACTION
S DIE=90050.03
S DIDEL=90050
D ^DIE
K DIDEL,DIE,DA,DR
;BAR*1.8*1 SRS ADDENDUM FOR BAR*1.8*1
S BARADD=0 ;USE RETURN ARRAY OF THE ADDITIONAL ID MULTIPLE FROM A/R EDI CHK
;FILE AND PLACE INTO TRANSACTION FILE
N BARIQ,BARREF
S DIC("P")=$P(^DD(90050.03,1101,0),U,2)
F S BARADD=$O(BARADD(90056.2211,BARADD)) Q:'BARADD D
.S BARIQ=BARADD(90056.2211,BARADD,.01,"E")
.S BARREF=BARADD(90056.2211,BARADD,.02,"E")
.S X=BARIQ
.S DA(1)=BARTRIEN
.S DIC="^BARTR("_DUZ(2)_","_DA(1)_",11,"
.S DIC(0)="L"
.D ^DIC
.Q:Y<0
.K DIE,DIC,DR,DA,DR,DIR
.S DA(1)=BARTRIEN
.S DA=+Y
.S DIE="^BARTR("_DUZ(2)_","_DA(1)_",11,"
.S DR=".02///^S X=BARREF"
.D ^DIE
; Post from trans file to related files unless General/Pending
I BARTRAN=43,(",21,22,"[(","_BARCAT_",")) Q
D TR^BARTDO(BARTRIEN)
Q
; ************
ROLLBACK ; Rollback bills that just posted if Roll as you go set to yes
; Otherwise just mark for rollback later
S BARRAYGO=0 ;Default to not roll back
S BARPARAM=$P($G(^BAR(90052.06,DUZ(2),DUZ(2),0)),U,13)
I BARPARAM="A"!(BARPARAM="Y") D
.K DIR
.S DIR("A")="Do you want to rollback to 3P the bills that just posted"
.S DIR("B")="N"
.S DIR(0)="Y"
.S DIR("?")="Enter 'YES' to roll these A/R bills back to 3P NOW"
.D ^DIR
.I Y=1 S BARRAYGO=1
K DIR
I BARRAYGO=1 D Q ;Ok...rolling bills.
.W !!,"OK, now rolling back 3P the bills that just posted for chk/EFT ",BARCHECK
.D EN^BARROLL
.K BARROLL,DIR
.D EOP^BARUTL(1)
W !!,"OK, marking for rollback the bills that just posted for chk/EFT ",BARCHECK
W !,"Please use the ROL option when you're ready to roll them back to 3P"
D EN^BARROLL ;since BARRAYGO = 0, it will only mark for rollback
K DIR
D EOP^BARUTL(1)
Q
BAR50P08 ; IHS/SD/LSL - POST HIPAA CLAIMS ; 12/01/2008
+1 ;;1.8;IHS ACCOUNTS RECEIVABLE;**1,4,5,6,10,19,20,21,23,24,26**;OCT 26,2005;Build 17
+2 ;
+3 ;IHS/SD/POT 1.8*24 HEAT147572 ALLOW TRIBAL SITES ERA POSTING OF NEG BAL & CANCELLED BILLS 2/11/2014
+4 ;IHS/SD/SDR 1.8*26 HEAT170856 - Tribal sites couldn't post bill into negative balance. Also made change to not do matching checks again. Doing it
+5 ; again here was causing reasons to get deleted and not put back on so bills were posting that shouldn't. May need to revisit this but seems to
+6 ; work ok with the examples provided.
+7 ;
+8 ;
+9 QUIT
POST(BARCKDA) ; EP bar*1.8*20 REQ6 changed BARCKIEN to BARCKDA
+1 ;Post this ERA Check (called from POST^BAR50P00)
+2 ;TPF BAR*1.8*6 SCR119
NEW BPR02
+3 ;MRS:BAR*1.8*6 DD 4.2.4
KILL BAROLD
+4 SET BARFND=0
+5 SET BARSECT=BARUSR(29,"I")
+6 SET BARCHECK=$PIECE($GET(^BARECHK(BARCKDA,0)),U)
+7 SET BARBATCH=$PIECE($GET(^BARECHK(BARCKDA,0)),U,3)
+8 SET BARPITEM=$PIECE($GET(^BARECHK(BARCKDA,0)),U,4)
+9 ;ID CODE QUALIFIER FROM A/R EDI IMPORT XX=NPI, FI = TAX ID
SET BARICQ=$$GET1^DIQ(90056.22,BARCKDA_",",.08)
+10 ;ID CODE (NPI) FROM A/R EDI IMPORT
SET BARNPI=$$GET1^DIQ(90056.22,BARCKDA_",",.09)
+11 ;TAX ID FROM A/R EDI IMPORT
SET BARTIN=$$GET1^DIQ(90056.22,BARCKDA_",",.11)
+12 SET BPR02=$$GETBPR02(BARCHECK)
+13 IF BPR02?.A
Begin DoDot:1
+14 ;W !,"CANNOT FIND A BPR02 VALUE IN IMPORT FILE!" OLD CODE
+15 ;11/06/2013 MORE SPECIFIC MESSAGE
WRITE !,"CANNOT FIND A BPR02 VALUE IN IMPORT FILE! ("_BPR02_")"
+16 KILL DIR
SET DIR(0)="E"
+17 DO ^DIR
End DoDot:1
QUIT
+18 KILL BARADD,BARERR
+19 ;GET PAYEE ADD IDENTIFICATION ;bar*1.8*20 REQ6
DO GETS^DIQ(90056.22,BARCKDA_",","2211*","E","BARADD","BARERR")
+20 ;MRS:BAR*1.8*6 DD 4.2.4 USER ALLOWED TO POST TO NO BATCH SCR119
IF BARBATCH'=""
IF '$$CKDATE^BARPST(BARBATCH,1,"POSTING TO A/R COLLECTION BATCH")
Begin DoDot:1
+21 SET (BARBATCH,BAROLD)=""
+22 DO NOBATCH
End DoDot:1
QUIT
+23 ;TPF BAR*1.8*6 SCR119
IF (BARBATCH=""!(BARPITEM=""))
IF (BPR02>0)
DO NOBATCH
+24 IF +BARFND
QUIT
+25 ;MRS:BAR*1.8*6 DD 4.2.4
IF $DATA(BAROLD)
KILL BAROLD
QUIT
+26 ;if there are claims w/BUILT status
+27 IF $DATA(^BAREDI("I",DUZ(2),IMPDA,30,"AC","B"))
Begin DoDot:1
+28 SET CLMDA=0
+29 KILL BARSTOP
+30 FOR
SET CLMDA=$ORDER(^BAREDI("I",DUZ(2),IMPDA,30,"AC","B",CLMDA))
IF 'CLMDA
QUIT
Begin DoDot:2
+31 IF $PIECE($GET(^BAREDI("I",DUZ(2),IMPDA,30,CLMDA,2)),U)=BARCHECK
SET BARSTOP=1
End DoDot:2
+32 IF $GET(BARSTOP)=1
WRITE !!,"EDI Claims are still in a BUILT status for this check!",!,"Run BLMT or REV auto-review for matching."
End DoDot:1
+33 IF ($GET(BARSTOP)=1)
QUIT
+34 DO ASKPOST
+35 ;MRS:BAR*1.8*10 H1228
IF 'BARANS
QUIT
+36 KILL DIR
+37 DO EOP^BARUTL(1)
+38 DO POSTEM
+39 IF '+BARPSTED
Begin DoDot:1
+40 WRITE !!,"No matched bills to post",!!
+41 ;bar*1.8*20 REQ6
IF PSTQFLG=1
WRITE !,$$EN^BARVDF("HIN"),"** BILLS HAVE BEEN MARKED AS 'ITEM BALANCE EXCEEDED'. PLEASE REVIEW AND POST",!?4,"MANUALLY**",$$EN^BARVDF("HIF")
+42 KILL DIR
+43 DO EOP^BARUTL(1)
End DoDot:1
QUIT
+44 WRITE !!,BARPSTED," Bills posted to AR.",!
+45 ;start new bar*1.8*20 REQ6
+46 IF PSTQFLG=1
WRITE !!,$$EN^BARVDF("HIN"),"** BILLS HAVE BEEN MARKED AS 'ITEM BALANCE EXCEEDED'. PLEASE REVIEW AND POST",!?4,"MANUALLY**",$$EN^BARVDF("HIF")
+47 ;end new REQ6
+48 ;Rollback now or later
DO ROLLBACK
+49 QUIT
+50 ;
GETBPR02(BARCHECK) ;EP -GET BPR02 MONETARY AMT FROM ERACHECK
+1 NEW IMPDA,CLMDA,BPR02
+2 ;ALL BPR02 WILL BE SAME FOR ALL CHK ENTRIES. GET LAST LOAD
SET IMPDA=""
SET IMPDA=$ORDER(^BAREDI("I",DUZ(2),"F",BARCHECK,IMPDA),-1)
+3 IF IMPDA=""
QUIT "NOIMPORT"
+4 SET CLMDA=""
SET CLMDA=$ORDER(^BAREDI("I",DUZ(2),"F",BARCHECK,IMPDA,CLMDA))
+5 IF CLMDA=""
QUIT "NOCLAIMFORIMPORT"
+6 SET BPR02=$PIECE($GET(^BAREDI("I",DUZ(2),IMPDA,30,CLMDA,2)),U,5)
+7 IF BPR02=""
QUIT "NOBPR02"
+8 QUIT BPR02
+9 ;
NOBATCH ;
+1 ;Chk for pymts on clms for this chk
+2 ;"F" IS CHECK/EFT TRACE X-REF
SET (BARCLM,BARFND)=0
+3 FOR
SET BARCLM=$ORDER(^BAREDI("I",DUZ(2),"F",BARCHECK,IMPDA,BARCLM))
IF '+BARCLM
QUIT
Begin DoDot:1
+4 ;E-PYMT
IF '+$PIECE($GET(^BAREDI("I",DUZ(2),IMPDA,30,BARCLM,0)),U,4)
QUIT
+5 SET BARFND=1
End DoDot:1
IF +BARFND
QUIT
+6 IF +BARFND
Begin DoDot:1
+7 WRITE !!,$$CJ^XLFSTR("Check "_BARCHECK_" does not match an RPMS Collection Batch and Item.",IOM)
+8 WRITE !,$$CJ^XLFSTR("There is at least one bill for this check containing a payment amount.",IOM)
+9 WRITE !,$$CJ^XLFSTR("The system will not allow posting bills to this check at this time.",IOM)
+10 WRITE !,$$CJ^XLFSTR("Please go back and create an RPMS Collection Batch and Item",IOM),!
+11 KILL DIR
+12 DO EOP^BARUTL(1)
End DoDot:1
+13 QUIT
+14 ; ********************
ASKPOST ;Ask user if really want to post clms
+1 WRITE !
+2 SET BARANS=0
+3 KILL DIR
+4 SET DIR(0)="Y"
+5 SET DIR("A")="Do you want to post ERA Claims for Chk/EFT "_BARCHECK_" now"
+6 SET DIR("B")="N"
+7 DO ^DIR
+8 IF Y=1
SET BARANS=1
+9 QUIT
+10 ; ********************
POSTEM ; LOOP Claims with this chk
+1 ; Quit if status is not matched
+2 SET (CLMDA,BARPSTED,BARDONE)=0
+3 ;start new bar*1.8*20 REQ6
+4 SET CLMCNT=0
SET PSTQFLG=0
+5 KILL ^XTMP("BAR-MBAMT",$JOB,DUZ(2))
+6 FOR
SET CLMDA=$ORDER(^BAREDI("I",DUZ(2),"F",BARCHECK,IMPDA,CLMDA))
IF '+CLMDA
QUIT
Begin DoDot:1
+7 ;E-payment
SET ^XTMP("BAR-MBAMT",$JOB,DUZ(2),+$PIECE($GET(^BAREDI("I",DUZ(2),IMPDA,30,CLMDA,0)),U,4),CLMDA)=""
End DoDot:1
IF +BARDONE
QUIT
+8 SET CLMAMT=""
+9 FOR
SET CLMAMT=$ORDER(^XTMP("BAR-MBAMT",$JOB,DUZ(2),CLMAMT))
IF ($GET(CLMAMT)="")
QUIT
Begin DoDot:1
+10 SET CLMDA=0
+11 FOR
SET CLMDA=$ORDER(^XTMP("BAR-MBAMT",$JOB,DUZ(2),+CLMAMT,CLMDA))
IF '+CLMDA
QUIT
Begin DoDot:2
+12 ;below lines added 1 dot to line up w/new code
+13 ;bar*1.8*20 REQ6
SET BARCKIEN=$ORDER(^BAREDI("I",DUZ(2),IMPDA,5,"B",BARCHECK,0))
+14 ;bar*1.8*20 REQ6
SET BARBL=$PIECE($GET(^BAREDI("I",DUZ(2),IMPDA,30,CLMDA,0)),U)
+15 ;D CLMFLG^BAR50P04(CLMDA,.ERRORS) ;bar*1.8*20 REQ6 ;bar*1.8*26 IHS/SD/SDR HEAT170856 - removed; it was deleting RNTP from claim, causing them to post when they shouldn't
+16 ;;;old code I $$IHS^BARUFUT(DUZ(2)) S BARCHK=BARCHECK D NEGBAL^BAR50EB(IMPDA,"ERA") ;bar*1.8*20
+17 ;S BARCHK=BARCHECK D NEGBAL^BAR50EB(IMPDA,"ERA") ;new code HEAT147572 2/5/2014 ;bar*1.8*26 IHS/SD/SDR HEAT170856
+18 ;put this line back because it seems to work better with the check than without ;bar*1.8*26 IHS/SD/SDR HEAT170856
IF $$IHS^BARUFUT(DUZ(2))
SET BARCHK=BARCHECK
DO NEGBAL^BAR50EB(IMPDA,"ERA")
+19 ;;;old code D:$$IHS^BARUFUT(DUZ(2)) NONPAYCH^BAR50EP1(IMPDA) ;bar*1.8*20
+20 ;new code HEAT147572
IF $$IHSNEGB^BARUFUT(DUZ(2))
DO NONPAYCH^BAR50EP1(IMPDA)
+21 ;NOT matched
IF $PIECE($GET(^BAREDI("I",DUZ(2),IMPDA,30,CLMDA,0)),U,2)'="M"
QUIT
+22 ;matched but reason not to post bar*1.8*20 REQ5
IF (($PIECE($GET(^BAREDI("I",DUZ(2),IMPDA,30,CLMDA,0)),U,2)="M")&(+$ORDER(^BAREDI("I",DUZ(2),IMPDA,30,CLMDA,4,0))'=0))
QUIT
+23 ;bar*1.8*20 REQ6
SET CLMCNT=+$GET(CLMCNT)+1
+24 DO BASIC
+25 ;INIT VALUE
SET PSTQFLG=0
+26 ;check if posting this payment will create a negative balance on batch/item
+27 ;------------------------------------------------------------------------
+28 ;BAR*1.8*5 INCLUDE 'POST THIS CLAIM AS TYPE' FIELD
DO ENP^XBDIQ1(90056.0205,"IMPDA,CLMDA",".01;.05;1.01;.02;.04;.11;.12;301;501;601;602","CLM(")
+29 WRITE !?7,"Billed: ",CLM(.05),?25,"Payment: ",CLM(.04)
+30 SET IENS=BARITM_","_BARCOL_","
+31 ;item posting balance
SET ITEMAMT=$$GET1^DIQ(90051.1101,IENS,19)
+32 SET IENS=CLMDA_","_IMPDA_","
+33 SET BARCR=$$GET1^DIQ(90056.0205,IENS,".04")
+34 ;------------------------------------------------------------------------
+35 IF (ITEMAMT-BARCR)<0
Begin DoDot:3
+36 ;2/11/2014
IF '$$IHSNEGB^BARUFUT(DUZ(2))
QUIT
+37 WRITE !!?7,$$EN^BARVDF("HIN"),"<<PYMT EXCEEDS COLLECTION ITEM BALANCE. MARKED AS 'ITEM BALANCE EXCEEDED'",$$EN^BARVDF("HIF")
+38 SET PSTQFLG=1
End DoDot:3
+39 ;------------------------------------------------------------------------
+40 ;leave bill as matched but with NTP reason item balance exceeded
IF PSTQFLG=1
DO UP^BAR50P0Z(IMPDA,CLMDA,"EBAL")
QUIT
+41 DO NEGBAL
+42 IF 'BARANS
QUIT
+43 ;CLMDA WILL BE POSTED OK
+44 DO ADJMULT
+45 DO PAY
+46 ;Post remark codes
DO RMKCD
+47 ;Post NCPDP codes
DO NCPDP
+48 DO MRKCLMP
+49 WRITE !
End DoDot:2
IF +BARDONE
QUIT
End DoDot:1
+50 QUIT
+51 ; ********************
BASIC ;
+1 SET BAREIENS=CLMDA_","_IMPDA_","
+2 ;A/R BILL
SET BARBLIEN=$$GET1^DIQ(90056.0205,BAREIENS,1.01,"I")
+3 ;A/R Patient IEN
SET BARBLPAT=$$GET1^DIQ(90050.01,BARBLIEN,101,"I")
+4 ;A/R Account
SET BARBLAC=$$GET1^DIQ(90050.01,BARBLIEN,3,"I")
+5 ;A/R Bill Balance
SET BARBAL=$$GET1^DIQ(90050.01,BARBLIEN,15)
+6 SET BARCOL=BARBATCH
+7 ;S BARITM=BARITEM ;bar*1.8*20
+8 ;bar*1.8*20
SET BARITM=BARPITEM
+9 ;A/R LOCATION
SET BARVLOC=$$GET1^DIQ(90050.01,BARBLIEN,108,"I")
+10 QUIT
+11 ;---------------------------------------------------------
NEGBAL ;
+1 SET BARANS=1
+2 SET BARTOT=0
+3 SET BARPAY=$PIECE($GET(^BAREDI("I",DUZ(2),IMPDA,30,CLMDA,0)),U,4)
+4 SET BARTOT=BARTOT+BARPAY
+5 SET (BARADJ,ADJDA)=0
+6 FOR
SET ADJDA=$ORDER(^BAREDI("I",DUZ(2),IMPDA,30,CLMDA,30,ADJDA))
IF '+ADJDA
QUIT
Begin DoDot:1
+7 SET BARAMT=$PIECE($GET(^BAREDI("I",DUZ(2),IMPDA,30,CLMDA,30,ADJDA,0)),U,2)
+8 SET BARADJ=BARADJ+BARAMT
End DoDot:1
+9 SET BARTOT=BARTOT+BARADJ
+10 IF (BARBAL-BARTOT)=0
QUIT
+11 IF (BARBAL-BARTOT)>0
QUIT
+12 ;2/11/2014
IF '$$IHSNEGB^BARUFUT(DUZ(2))
QUIT
+13 ;11/22/2013
IF BARBAL>0
WRITE !!,"<<Posting this bill will result in a negative balance on the bill>>"
+14 ;11/22/2013
IF BARBAL=0
WRITE !!,"<<<Posting this bill will result in a negative balance on the bill >>>"
+15 ;Mark bill not to post
+16 DO UP^BAR50P0Z(IMPDA,CLMDA,"NEGR")
+17 ;bar*1.8*20
SET BARANS=0
+18 QUIT
+19 ; ****************
PAY ;EP ;PULL CLAIM INFO AND POST PYMT (IF ANY)
+1 ;split due to rtn size
DO PAY^BAR50P8A
+2 QUIT
+3 ; ******************
ADJMULT ;EP ;POST ADJUSTMENTS
+1 ;split due to rtn size
DO ADJMULT^BAR50P8A
+2 QUIT
+3 ; *******************
RMKCD ; POST REMARK CODES
+1 ;split due to rtn size
DO RMKCD^BAR50P8A
+2 QUIT
+3 ; ***************
NCPDP ; POST NCPDP CODES
+1 ;TPF BAR*1.8*6 SCR119
KILL BARTO,BARFROM
+2 KILL NCPDP,DR,BARDR
+3 DO ENPM^XBDIQ1(90056.0212,"IMPDA,CLMDA,0",".03","NCPDP(","I")
+4 IF '$DATA(NCPDP)
QUIT
+5 SET BARTRAN=506
+6 SET DR=""
+7 DO DR
+8 ;Strip leading ";"
SET DR=$EXTRACT(DR,2,9999)
+9 ;Collct btch if know
IF +$GET(BARCOL)>0
SET DR=DR_";14////^S X=$G(BARCOL)"
+10 ;Item if known
IF +$GET(BARITM)>0
SET DR=DR_";15////^S X=$G(BARITM)"
+11 ;Remark Code pointer
SET DR=DR_";108////^S X=BARNCPDP"
+12 SET BARDR=DR
+13 KILL DR
+14 SET NCPDPDA=0
+15 FOR
SET NCPDPDA=$ORDER(NCPDP(NCPDPDA))
IF '+NCPDPDA
QUIT
Begin DoDot:1
+16 SET BARNCPDP=NCPDP(NCPDPDA,.03,"I")
+17 IF BARNCPDP=""
QUIT
+18 DO POSTRAN
+19 KILL NCPDPP
+20 DO ENP^XBDIQ1(90056.0212,"IMPDA,CLMDA,NCPDPDA",".02;.03","NCPDPP(")
+21 WRITE !?5,"NCPDP REJECT/PAYMENT CODE: ",NCPDPP(.03),?25,$EXTRACT($PIECE(NCPDPP(.02)," ",3,99),1,50)
End DoDot:1
+22 KILL NCPDP,NCPDPP
+23 QUIT
+24 ; ****************
DR ; Gather data needed for transaction
+1 ;A/R Bill
SET DR=DR_";4////^S X=BARBLIEN"
+2 ;A/R Patient
SET DR=DR_";5////^S X=BARBLPAT"
+3 ;A/R Account
SET DR=DR_";6////^S X=BARBLAC"
+4 ;Parent Location
SET DR=DR_";8////^S X=DUZ(2)"
+5 ;Parent ASUFAC
SET DR=DR_";9////^S X=DUZ(2)"
+6 ;A/R Section
SET DR=DR_";10////^S X=BARSECT"
+7 ;Visit Location
SET DR=DR_";11////^S X=BARVLOC"
+8 ;Date
SET DR=DR_";12////^S X=DT"
+9 ;Entry by
SET DR=DR_";13////^S X=DUZ"
+10 ;Transaction Type
SET DR=DR_";101////^S X=BARTRAN"
+11 ;Data Source = e
SET DR=DR_";106////^S X=""e"""
+12 ;INDENTIFICATION CODE QUALIFIER XX=NPI, FI=TAX ID
SET DR=DR_";401////^S X=BARICQ"
+13 ;IF BARICQ='XX' NPI
SET DR=DR_";402////^S X=BARNPI"
+14 ;IF BARICQ='FI' TAX ID
SET DR=DR_";403////^S X=BARTIN"
+15 ;PYMT CREDIT APPLIED FROM BILL
SET DR=DR_";501////^S X=$G(BARTO)"
+16 ;PYMT CREDIT APPLIED TO BILL
SET DR=DR_";502////^S X=$G(BARFROM)"
+17 IF BARTRAN=138
Begin DoDot:1
+18 ;PYMT CREDIT POSTS AS ADJUSTMENT
SET BARTRAN=43
+19 SET BARCAT=20
+20 SET BARREAS=138
+21 ;PYMT CREDIT
SET DR=DR_";102////^S X=BARCAT"
+22 ;CREDIT TO OTHER BILL
SET DR=DR_";103////^S X=BARREAS"
End DoDot:1
+23 ;IF THIS IS TRUE THEN WE NEED TO POST THIS AS AN ADJ
IF BARTRAN=139
Begin DoDot:1
+24 SET BARTRAN=43
+25 SET BARCAT=20
+26 SET BARREAS=139
+27 SET DR=DR_";102////^S X=BARCAT"
+28 ;CREDIT FROM OTHER BILL
SET DR=DR_";103////^S X=BARREAS"
End DoDot:1
+29 QUIT
+30 ; *************
MRKCLMP ;EP ; MARK CLAIM AS POSTED
+1 KILL DIC,DA,DR
+2 SET DIE=$$DIC^XBDIQ1(90056.0205)
+3 SET DA(1)=IMPDA
+4 SET DA=CLMDA
+5 SET DR=".02////P"
+6 DO ^DIE
+7 KILL DIC,DA,DR
+8 SET BARPSTED=BARPSTED+1
+9 QUIT
+10 ; ****************
POSTRAN ;EP ; SET TRANSACTION & POST FILES
+1 ;Create Trans
SET BARTRIEN=$$NEW^BARTR
+2 IF BARTRIEN<1
DO MSG^BARTR(BARBLIEN)
QUIT
+3 SET BARROLL(BARBLIEN)=""
+4 ;Populate Trans file
+5 SET DR=BARDR
+6 ;IEN to A/R TRANSACTION
SET DA=BARTRIEN
+7 SET DIE=90050.03
+8 SET DIDEL=90050
+9 DO ^DIE
+10 KILL DIDEL,DIE,DA,DR
+11 ;BAR*1.8*1 SRS ADDENDUM FOR BAR*1.8*1
+12 ;USE RETURN ARRAY OF THE ADDITIONAL ID MULTIPLE FROM A/R EDI CHK
SET BARADD=0
+13 ;FILE AND PLACE INTO TRANSACTION FILE
+14 NEW BARIQ,BARREF
+15 SET DIC("P")=$PIECE(^DD(90050.03,1101,0),U,2)
+16 FOR
SET BARADD=$ORDER(BARADD(90056.2211,BARADD))
IF 'BARADD
QUIT
Begin DoDot:1
+17 SET BARIQ=BARADD(90056.2211,BARADD,.01,"E")
+18 SET BARREF=BARADD(90056.2211,BARADD,.02,"E")
+19 SET X=BARIQ
+20 SET DA(1)=BARTRIEN
+21 SET DIC="^BARTR("_DUZ(2)_","_DA(1)_",11,"
+22 SET DIC(0)="L"
+23 DO ^DIC
+24 IF Y<0
QUIT
+25 KILL DIE,DIC,DR,DA,DR,DIR
+26 SET DA(1)=BARTRIEN
+27 SET DA=+Y
+28 SET DIE="^BARTR("_DUZ(2)_","_DA(1)_",11,"
+29 SET DR=".02///^S X=BARREF"
+30 DO ^DIE
End DoDot:1
+31 ; Post from trans file to related files unless General/Pending
+32 IF BARTRAN=43
IF (",21,22,"[(","_BARCAT_","))
QUIT
+33 DO TR^BARTDO(BARTRIEN)
+34 QUIT
+35 ; ************
ROLLBACK ; Rollback bills that just posted if Roll as you go set to yes
+1 ; Otherwise just mark for rollback later
+2 ;Default to not roll back
SET BARRAYGO=0
+3 SET BARPARAM=$PIECE($GET(^BAR(90052.06,DUZ(2),DUZ(2),0)),U,13)
+4 IF BARPARAM="A"!(BARPARAM="Y")
Begin DoDot:1
+5 KILL DIR
+6 SET DIR("A")="Do you want to rollback to 3P the bills that just posted"
+7 SET DIR("B")="N"
+8 SET DIR(0)="Y"
+9 SET DIR("?")="Enter 'YES' to roll these A/R bills back to 3P NOW"
+10 DO ^DIR
+11 IF Y=1
SET BARRAYGO=1
End DoDot:1
+12 KILL DIR
+13 ;Ok...rolling bills.
IF BARRAYGO=1
Begin DoDot:1
+14 WRITE !!,"OK, now rolling back 3P the bills that just posted for chk/EFT ",BARCHECK
+15 DO EN^BARROLL
+16 KILL BARROLL,DIR
+17 DO EOP^BARUTL(1)
End DoDot:1
QUIT
+18 WRITE !!,"OK, marking for rollback the bills that just posted for chk/EFT ",BARCHECK
+19 WRITE !,"Please use the ROL option when you're ready to roll them back to 3P"
+20 ;since BARRAYGO = 0, it will only mark for rollback
DO EN^BARROLL
+21 KILL DIR
+22 DO EOP^BARUTL(1)
+23 QUIT
