BAREDP08 ; IHS/SD/LSL - POST HIPAA CLAIMS ; 12/01/2008
;;1.8;IHS ACCOUNTS RECEIVABLE;**1,4,5,6,10,19,20,23,24**;OCT 26,2005;Build 69
;IHS/SD/POT HEAT147572 ALLOW TRIBAL SITES ERA POSTING OF NEG BAL & CANCELLED BILLS 2/11/2014 - BAR*1.8*.24
Q
POST(BARCKDA) ; EP bar*1.8*20 REQ6 changed BARCKIEN to BARCKDA
;Post this ERA Check (called from POST^BAREDP00)
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!"
.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.",!
I PSTQFLG=1 W !!,$$EN^BARVDF("HIN"),"** BILLS HAVE BEEN MARKED AS 'ITEM BALANCE EXCEEDED'. PLEASE REVIEW AND POST",!?4,"MANUALLY**",$$EN^BARVDF("HIF")
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
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
..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^BAREDP04(CLMDA,.ERRORS) ;bar*1.8*20 REQ6
..;;;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") ;HEAT147572 1/15/2014 $$ihs chk will be inside BAR50EB - BAR*1.8*.24
..;;;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 - BAR*1.8*.24
..Q:$P($G(^BAREDI("I",DUZ(2),IMPDA,30,CLMDA,0)),U,2)'="M"
..Q:(($P($G(^BAREDI("I",DUZ(2),IMPDA,30,CLMDA,0)),U,2)="M")&(+$O(^BAREDI("I",DUZ(2),IMPDA,30,CLMDA,4,0))'=0)) ;matched but reason not to post bar*1.8*20 REQ5
..S CLMCNT=+$G(CLMCNT)+1 ;bar*1.8*20 REQ6
..D BASIC
..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^BAREDP0Z(IMPDA,CLMDA,"EBAL") Q ;leave bill as matched but with NTP reason item balance exceeded
..D NEGBAL
..Q:'BARANS
..D ADJMULT
..D PAY
..;end new REQ6
..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
W !!,"<<Posting this bill will result in a negative balance on the bill>>"
;Mark bill not to post
D UP^BAREDP0Z(IMPDA,CLMDA,"NEGR")
S BARANS=0 ;bar*1.8*20
Q
; ****************
PAY ;EP ;PULL CLAIM INFO AND POST PYMT (IF ANY)
D PAY^BAREDP8A ;split due to rtn size
Q
; ******************
ADJMULT ;EP ;POST ADJUSTMENTS
D ADJMULT^BAREDP8A ;split due to rtn size
Q
; *******************
RMKCD ; POST REMARK CODES
D RMKCD^BAREDP8A ;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
;BAR*1.8*1 SRS ADDENDUM FOR BAR*1.8*1
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
;END
;BAR*1.8*5 TPF 6/17/2008
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
;END
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
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
BAREDP08 ; IHS/SD/LSL - POST HIPAA CLAIMS ; 12/01/2008
+1 ;;1.8;IHS ACCOUNTS RECEIVABLE;**1,4,5,6,10,19,20,23,24**;OCT 26,2005;Build 69
+2 ;IHS/SD/POT HEAT147572 ALLOW TRIBAL SITES ERA POSTING OF NEG BAL & CANCELLED BILLS 2/11/2014 - BAR*1.8*.24
+3 QUIT
POST(BARCKDA) ; EP bar*1.8*20 REQ6 changed BARCKIEN to BARCKDA
+1 ;Post this ERA Check (called from POST^BAREDP00)
+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 WRITE !,"CANNOT FIND A BPR02 VALUE IN IMPORT FILE!"
+15 KILL DIR
SET DIR(0)="E"
+16 DO ^DIR
End DoDot:1
QUIT
+17 KILL BARADD,BARERR
+18 ;GET PAYEE ADD IDENTIFICATION ;bar*1.8*20 REQ6
DO GETS^DIQ(90056.22,BARCKDA_",","2211*","E","BARADD","BARERR")
+19 ;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
+20 SET (BARBATCH,BAROLD)=""
+21 DO NOBATCH
End DoDot:1
QUIT
+22 ;TPF BAR*1.8*6 SCR119
IF (BARBATCH=""!(BARPITEM=""))
IF (BPR02>0)
DO NOBATCH
+23 IF +BARFND
QUIT
+24 ;MRS:BAR*1.8*6 DD 4.2.4
IF $DATA(BAROLD)
KILL BAROLD
QUIT
+25 ;if there are claims w/BUILT status
+26 IF $DATA(^BAREDI("I",DUZ(2),IMPDA,30,"AC","B"))
Begin DoDot:1
+27 SET CLMDA=0
+28 KILL BARSTOP
+29 FOR
SET CLMDA=$ORDER(^BAREDI("I",DUZ(2),IMPDA,30,"AC","B",CLMDA))
IF 'CLMDA
QUIT
Begin DoDot:2
+30 IF $PIECE($GET(^BAREDI("I",DUZ(2),IMPDA,30,CLMDA,2)),U)=BARCHECK
SET BARSTOP=1
End DoDot:2
+31 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
+32 IF ($GET(BARSTOP)=1)
QUIT
+33 DO ASKPOST
+34 ;MRS:BAR*1.8*10 H1228
IF 'BARANS
QUIT
+35 KILL DIR
+36 DO EOP^BARUTL(1)
+37 DO POSTEM
+38 IF '+BARPSTED
Begin DoDot:1
+39 WRITE !!,"No matched bills to post",!!
+40 ;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")
+41 KILL DIR
+42 DO EOP^BARUTL(1)
End DoDot:1
QUIT
+43 WRITE !!,BARPSTED," Bills posted to AR.",!
+44 IF PSTQFLG=1
WRITE !!,$$EN^BARVDF("HIN"),"** BILLS HAVE BEEN MARKED AS 'ITEM BALANCE EXCEEDED'. PLEASE REVIEW AND POST",!?4,"MANUALLY**",$$EN^BARVDF("HIF")
+45 ;Rollback now or later
DO ROLLBACK
+46 QUIT
+47 ;
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 SET CLMCNT=0
SET PSTQFLG=0
+4 KILL ^XTMP("BAR-MBAMT",$JOB,DUZ(2))
+5 FOR
SET CLMDA=$ORDER(^BAREDI("I",DUZ(2),"F",BARCHECK,IMPDA,CLMDA))
IF '+CLMDA
QUIT
Begin DoDot:1
+6 ;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
+7 SET CLMAMT=""
+8 FOR
SET CLMAMT=$ORDER(^XTMP("BAR-MBAMT",$JOB,DUZ(2),CLMAMT))
IF ($GET(CLMAMT)="")
QUIT
Begin DoDot:1
+9 SET CLMDA=0
+10 FOR
SET CLMDA=$ORDER(^XTMP("BAR-MBAMT",$JOB,DUZ(2),+CLMAMT,CLMDA))
IF '+CLMDA
QUIT
Begin DoDot:2
+11 ;bar*1.8*20 REQ6
SET BARCKIEN=$ORDER(^BAREDI("I",DUZ(2),IMPDA,5,"B",BARCHECK,0))
+12 ;bar*1.8*20 REQ6
SET BARBL=$PIECE($GET(^BAREDI("I",DUZ(2),IMPDA,30,CLMDA,0)),U)
+13 ;bar*1.8*20 REQ6
DO CLMFLG^BAREDP04(CLMDA,.ERRORS)
+14 ;;;old code I $$IHS^BARUFUT(DUZ(2)) S BARCHK=BARCHECK D NEGBAL^BAR50EB(IMPDA,"ERA") ;bar*1.8*20
+15 ;HEAT147572 1/15/2014 $$ihs chk will be inside BAR50EB - BAR*1.8*.24
SET BARCHK=BARCHECK
DO NEGBAL^BAR50EB(IMPDA,"ERA")
+16 ;;;old code D:$$IHS^BARUFUT(DUZ(2)) NONPAYCH^BAR50EP1(IMPDA) ;bar*1.8*20
+17 ;new code HEAT147572 - BAR*1.8*.24
IF $$IHSNEGB^BARUFUT(DUZ(2))
DO NONPAYCH^BAR50EP1(IMPDA)
+18 IF $PIECE($GET(^BAREDI("I",DUZ(2),IMPDA,30,CLMDA,0)),U,2)'="M"
QUIT
+19 ;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
+20 ;bar*1.8*20 REQ6
SET CLMCNT=+$GET(CLMCNT)+1
+21 DO BASIC
+22 ;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(")
+23 WRITE !?7,"Billed: ",CLM(.05),?25,"Payment: ",CLM(.04)
+24 SET IENS=BARITM_","_BARCOL_","
+25 ;item posting balance
SET ITEMAMT=$$GET1^DIQ(90051.1101,IENS,19)
+26 SET IENS=CLMDA_","_IMPDA_","
+27 SET BARCR=$$GET1^DIQ(90056.0205,IENS,".04")
+28 IF (ITEMAMT-BARCR)<0
Begin DoDot:3
+29 ;2/11/2014
IF '$$IHSNEGB^BARUFUT(DUZ(2))
QUIT
+30 WRITE !!?7,$$EN^BARVDF("HIN"),"<<PYMT EXCEEDS COLLECTION ITEM BALANCE. MARKED AS 'ITEM BALANCE EXCEEDED'",$$EN^BARVDF("HIF")
+31 SET PSTQFLG=1
End DoDot:3
+32 ;leave bill as matched but with NTP reason item balance exceeded
IF PSTQFLG=1
DO UP^BAREDP0Z(IMPDA,CLMDA,"EBAL")
QUIT
+33 DO NEGBAL
+34 IF 'BARANS
QUIT
+35 DO ADJMULT
+36 DO PAY
+37 ;end new REQ6
+38 ;Post remark codes
DO RMKCD
+39 ;Post NCPDP codes
DO NCPDP
+40 DO MRKCLMP
+41 WRITE !
End DoDot:2
IF +BARDONE
QUIT
End DoDot:1
+42 QUIT
+43 ; ********************
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
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 WRITE !!,"<<Posting this bill will result in a negative balance on the bill>>"
+14 ;Mark bill not to post
+15 DO UP^BAREDP0Z(IMPDA,CLMDA,"NEGR")
+16 ;bar*1.8*20
SET BARANS=0
+17 QUIT
+18 ; ****************
PAY ;EP ;PULL CLAIM INFO AND POST PYMT (IF ANY)
+1 ;split due to rtn size
DO PAY^BAREDP8A
+2 QUIT
+3 ; ******************
ADJMULT ;EP ;POST ADJUSTMENTS
+1 ;split due to rtn size
DO ADJMULT^BAREDP8A
+2 QUIT
+3 ; *******************
RMKCD ; POST REMARK CODES
+1 ;split due to rtn size
DO RMKCD^BAREDP8A
+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 ;BAR*1.8*1 SRS ADDENDUM FOR BAR*1.8*1
+13 ;INDENTIFICATION CODE QUALIFIER XX=NPI, FI=TAX ID
SET DR=DR_";401////^S X=BARICQ"
+14 ;IF BARICQ='XX' NPI
SET DR=DR_";402////^S X=BARNPI"
+15 ;IF BARICQ='FI' TAX ID
SET DR=DR_";403////^S X=BARTIN"
+16 ;END
+17 ;BAR*1.8*5 TPF 6/17/2008
+18 ;PYMT CREDIT APPLIED FROM BILL
SET DR=DR_";501////^S X=$G(BARTO)"
+19 ;PYMT CREDIT APPLIED TO BILL
SET DR=DR_";502////^S X=$G(BARFROM)"
+20 IF BARTRAN=138
Begin DoDot:1
+21 ;PYMT CREDIT POSTS AS ADJUSTMENT
SET BARTRAN=43
+22 SET BARCAT=20
+23 SET BARREAS=138
+24 ;PYMT CREDIT
SET DR=DR_";102////^S X=BARCAT"
+25 ;CREDIT TO OTHER BILL
SET DR=DR_";103////^S X=BARREAS"
End DoDot:1
+26 ;IF THIS IS TRUE THEN WE NEED TO POST THIS AS AN ADJ
IF BARTRAN=139
Begin DoDot:1
+27 SET BARTRAN=43
+28 SET BARCAT=20
+29 SET BARREAS=139
+30 SET DR=DR_";102////^S X=BARCAT"
+31 ;CREDIT FROM OTHER BILL
SET DR=DR_";103////^S X=BARREAS"
End DoDot:1
+32 ;END
+33 QUIT
+34 ; *************
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 ;USE RETURN ARRAY OF THE ADDITIONAL ID MULTIPLE FROM A/R EDI CHK
SET BARADD=0
+12 ;FILE AND PLACE INTO TRANSACTION FILE
+13 NEW BARIQ,BARREF
+14 SET DIC("P")=$PIECE(^DD(90050.03,1101,0),U,2)
+15 FOR
SET BARADD=$ORDER(BARADD(90056.2211,BARADD))
IF 'BARADD
QUIT
Begin DoDot:1
+16 SET BARIQ=BARADD(90056.2211,BARADD,.01,"E")
+17 SET BARREF=BARADD(90056.2211,BARADD,.02,"E")
+18 SET X=BARIQ
+19 SET DA(1)=BARTRIEN
+20 SET DIC="^BARTR("_DUZ(2)_","_DA(1)_",11,"
+21 SET DIC(0)="L"
+22 DO ^DIC
+23 IF Y<0
QUIT
+24 KILL DIE,DIC,DR,DA,DR,DIR
+25 SET DA(1)=BARTRIEN
+26 SET DA=+Y
+27 SET DIE="^BARTR("_DUZ(2)_","_DA(1)_",11,"
+28 SET DR=".02///^S X=BARREF"
+29 DO ^DIE
End DoDot:1
+30 ; Post from trans file to related files unless General/Pending
+31 IF BARTRAN=43
IF (",21,22,"[(","_BARCAT_","))
QUIT
+32 DO TR^BARTDO(BARTRIEN)
+33 QUIT
+34 ; ************
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
