Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: BAREDP08

BAREDP08.m

Go to the documentation of this file. 
  1. 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
  1.  ;IHS/SD/POT HEAT147572 ALLOW TRIBAL SITES ERA POSTING OF NEG BAL & CANCELLED BILLS 2/11/2014 - BAR*1.8*.24
  1.  Q
  1. POST(BARCKDA) ; EP  bar*1.8*20 REQ6 changed BARCKIEN to BARCKDA
  1.  ;Post this ERA Check (called from POST^BAREDP00)
  1.  N BPR02  ;TPF BAR*1.8*6 SCR119
  1.  K BAROLD  ;MRS:BAR*1.8*6 DD 4.2.4
  1.  S BARFND=0
  1.  S BARSECT=BARUSR(29,"I")
  1.  S BARCHECK=$P($G(^BARECHK(BARCKDA,0)),U)
  1.  S BARBATCH=$P($G(^BARECHK(BARCKDA,0)),U,3)
  1.  S BARPITEM=$P($G(^BARECHK(BARCKDA,0)),U,4)
  1.  S BARICQ=$$GET1^DIQ(90056.22,BARCKDA_",",.08)  ;ID CODE QUALIFIER FROM A/R EDI IMPORT XX=NPI, FI = TAX ID
  1.  S BARNPI=$$GET1^DIQ(90056.22,BARCKDA_",",.09)  ;ID CODE (NPI) FROM A/R EDI IMPORT
  1.  S BARTIN=$$GET1^DIQ(90056.22,BARCKDA_",",.11)  ;TAX ID FROM A/R EDI IMPORT
  1.  S BPR02=$$GETBPR02(BARCHECK)
  1.  I BPR02?.A D  Q
  1.  .W !,"CANNOT FIND A BPR02 VALUE IN IMPORT FILE!"
  1.  .K DIR S DIR(0)="E"
  1.  .D ^DIR
  1.  K BARADD,BARERR
  1.  D GETS^DIQ(90056.22,BARCKDA_",","2211*","E","BARADD","BARERR")  ;GET PAYEE ADD IDENTIFICATION  ;bar*1.8*20 REQ6
  1.  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
  1.  .S (BARBATCH,BAROLD)=""
  1.  .D NOBATCH
  1.  I (BARBATCH=""!(BARPITEM="")),(BPR02>0) D NOBATCH  ;TPF BAR*1.8*6 SCR119
  1.  Q:+BARFND
  1.  I $D(BAROLD) K BAROLD Q  ;MRS:BAR*1.8*6 DD 4.2.4
  1.  ;if there are claims w/BUILT status
  1.  I $D(^BAREDI("I",DUZ(2),IMPDA,30,"AC","B")) D
  1.  .S CLMDA=0
  1.  .K BARSTOP
  1.  .F  S CLMDA=$O(^BAREDI("I",DUZ(2),IMPDA,30,"AC","B",CLMDA)) Q:'CLMDA  D
  1.  ..I $P($G(^BAREDI("I",DUZ(2),IMPDA,30,CLMDA,2)),U)=BARCHECK S BARSTOP=1
  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."
  1.  Q:($G(BARSTOP)=1)
  1.  D ASKPOST
  1.  Q:'BARANS  ;MRS:BAR*1.8*10 H1228
  1.  K DIR
  1.  D EOP^BARUTL(1)
  1.  D POSTEM
  1.  I '+BARPSTED D  Q
  1.  . W !!,"No matched bills to post",!!
  1.  . 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
  1.  . K DIR
  1.  . D EOP^BARUTL(1)
  1.  W !!,BARPSTED," Bills posted to AR.",!
  1.  I PSTQFLG=1 W !!,$$EN^BARVDF("HIN"),"** BILLS HAVE BEEN MARKED AS 'ITEM BALANCE EXCEEDED'.  PLEASE REVIEW AND POST",!?4,"MANUALLY**",$$EN^BARVDF("HIF")
  1.  D ROLLBACK  ;Rollback now or later
  1.  Q
  1.  ;
  1. GETBPR02(BARCHECK) ;EP -GET BPR02 MONETARY AMT FROM ERACHECK
  1.  N IMPDA,CLMDA,BPR02
  1.  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
  1.  Q:IMPDA="" "NOIMPORT"
  1.  S CLMDA="" S CLMDA=$O(^BAREDI("I",DUZ(2),"F",BARCHECK,IMPDA,CLMDA))
  1.  Q:CLMDA="" "NOCLAIMFORIMPORT"
  1.  S BPR02=$P($G(^BAREDI("I",DUZ(2),IMPDA,30,CLMDA,2)),U,5)
  1.  Q:BPR02="" "NOBPR02"
  1.  Q BPR02
  1.  ;
  1. NOBATCH ;
  1.  ;Chk for pymts on clms for this chk
  1.  S (BARCLM,BARFND)=0  ;"F" IS CHECK/EFT TRACE X-REF
  1.  F  S BARCLM=$O(^BAREDI("I",DUZ(2),"F",BARCHECK,IMPDA,BARCLM)) Q:'+BARCLM  D  Q:+BARFND
  1.  . Q:'+$P($G(^BAREDI("I",DUZ(2),IMPDA,30,BARCLM,0)),U,4)  ;E-PYMT
  1.  . S BARFND=1
  1.  I +BARFND D
  1.  . W !!,$$CJ^XLFSTR("Check "_BARCHECK_" does not match an RPMS Collection Batch and Item.",IOM)
  1.  . W !,$$CJ^XLFSTR("There is at least one bill for this check containing a payment amount.",IOM)
  1.  . W !,$$CJ^XLFSTR("The system will not allow posting bills to this check at this time.",IOM)
  1.  . W !,$$CJ^XLFSTR("Please go back and create an RPMS Collection Batch and Item",IOM),!
  1.  . K DIR
  1.  . D EOP^BARUTL(1)
  1.  Q
  1.  ; ********************
  1. ASKPOST ;Ask user if really want to post clms
  1.  W !
  1.  S BARANS=0
  1.  K DIR
  1.  S DIR(0)="Y"
  1.  S DIR("A")="Do you want to post ERA Claims for Chk/EFT "_BARCHECK_" now"
  1.  S DIR("B")="N"
  1.  D ^DIR
  1.  S:Y=1 BARANS=1
  1.  Q
  1.  ; ********************
  1. POSTEM ; LOOP Claims with this chk
  1.  ; Quit if status is not matched
  1.  S (CLMDA,BARPSTED,BARDONE)=0
  1.  S CLMCNT=0,PSTQFLG=0
  1.  K ^XTMP("BAR-MBAMT",$J,DUZ(2))
  1.  F  S CLMDA=$O(^BAREDI("I",DUZ(2),"F",BARCHECK,IMPDA,CLMDA)) Q:'+CLMDA  D  Q:+BARDONE
  1.  .S ^XTMP("BAR-MBAMT",$J,DUZ(2),+$P($G(^BAREDI("I",DUZ(2),IMPDA,30,CLMDA,0)),U,4),CLMDA)=""  ;E-payment
  1.  S CLMAMT=""
  1.  F  S CLMAMT=$O(^XTMP("BAR-MBAMT",$J,DUZ(2),CLMAMT)) Q:($G(CLMAMT)="")  D
  1.  .S CLMDA=0
  1.  .F  S CLMDA=$O(^XTMP("BAR-MBAMT",$J,DUZ(2),+CLMAMT,CLMDA)) Q:'+CLMDA  D  Q:+BARDONE
  1.  ..S BARCKIEN=$O(^BAREDI("I",DUZ(2),IMPDA,5,"B",BARCHECK,0))  ;bar*1.8*20 REQ6
  1.  ..S BARBL=$P($G(^BAREDI("I",DUZ(2),IMPDA,30,CLMDA,0)),U)  ;bar*1.8*20 REQ6
  1.  ..D CLMFLG^BAREDP04(CLMDA,.ERRORS)  ;bar*1.8*20 REQ6
  1.  ..;;;old code I $$IHS^BARUFUT(DUZ(2)) S BARCHK=BARCHECK D NEGBAL^BAR50EB(IMPDA,"ERA")  ;bar*1.8*20
  1.  .. S BARCHK=BARCHECK D NEGBAL^BAR50EB(IMPDA,"ERA")  ;HEAT147572 1/15/2014 $$ihs chk will be inside BAR50EB - BAR*1.8*.24
  1.  ..;;;old code D:$$IHS^BARUFUT(DUZ(2)) NONPAYCH^BAR50EP1(IMPDA)  ;bar*1.8*20
  1.  ..D:$$IHSNEGB^BARUFUT(DUZ(2)) NONPAYCH^BAR50EP1(IMPDA) ;new code HEAT147572 - BAR*1.8*.24
  1.  ..Q:$P($G(^BAREDI("I",DUZ(2),IMPDA,30,CLMDA,0)),U,2)'="M"
  1.  ..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
  1.  ..S CLMCNT=+$G(CLMCNT)+1  ;bar*1.8*20 REQ6
  1.  ..D BASIC
  1.  ..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
  1.  ..W !?7,"Billed: ",CLM(.05),?25,"Payment: ",CLM(.04)
  1.  ..S IENS=BARITM_","_BARCOL_","
  1.  ..S ITEMAMT=$$GET1^DIQ(90051.1101,IENS,19)  ;item posting balance
  1.  ..S IENS=CLMDA_","_IMPDA_","
  1.  ..S BARCR=$$GET1^DIQ(90056.0205,IENS,".04")
  1.  ..I (ITEMAMT-BARCR)<0 D
  1.  ... I '$$IHSNEGB^BARUFUT(DUZ(2)) QUIT    ;2/11/2014
  1.  ...W !!?7,$$EN^BARVDF("HIN"),"<<PYMT EXCEEDS COLLECTION ITEM BALANCE. MARKED AS 'ITEM BALANCE EXCEEDED'",$$EN^BARVDF("HIF")
  1.  ...S PSTQFLG=1
  1.  ..I PSTQFLG=1 D UP^BAREDP0Z(IMPDA,CLMDA,"EBAL") Q  ;leave bill as matched but with NTP reason item balance exceeded
  1.  ..D NEGBAL
  1.  ..Q:'BARANS
  1.  ..D ADJMULT
  1.  ..D PAY
  1.  ..;end new REQ6
  1.  ..D RMKCD  ;Post remark codes
  1.  ..D NCPDP  ;Post NCPDP codes
  1.  ..D MRKCLMP
  1.  ..W !
  1.  Q
  1.  ; ********************
  1. BASIC ;
  1.  S BAREIENS=CLMDA_","_IMPDA_","
  1.  S BARBLIEN=$$GET1^DIQ(90056.0205,BAREIENS,1.01,"I")  ;A/R BILL
  1.  S BARBLPAT=$$GET1^DIQ(90050.01,BARBLIEN,101,"I")  ;A/R Patient IEN
  1.  S BARBLAC=$$GET1^DIQ(90050.01,BARBLIEN,3,"I")  ;A/R Account
  1.  S BARBAL=$$GET1^DIQ(90050.01,BARBLIEN,15)  ;A/R Bill Balance
  1.  S BARCOL=BARBATCH
  1.  ;S BARITM=BARITEM  ;bar*1.8*20
  1.  S BARITM=BARPITEM  ;bar*1.8*20
  1.  S BARVLOC=$$GET1^DIQ(90050.01,BARBLIEN,108,"I") ;A/R LOCATION
  1.  Q
  1. NEGBAL ;
  1.  S BARANS=1
  1.  S BARTOT=0
  1.  S BARPAY=$P($G(^BAREDI("I",DUZ(2),IMPDA,30,CLMDA,0)),U,4)
  1.  S BARTOT=BARTOT+BARPAY
  1.  S (BARADJ,ADJDA)=0
  1.  F  S ADJDA=$O(^BAREDI("I",DUZ(2),IMPDA,30,CLMDA,30,ADJDA)) Q:'+ADJDA  D
  1.  .S BARAMT=$P($G(^BAREDI("I",DUZ(2),IMPDA,30,CLMDA,30,ADJDA,0)),U,2)
  1.  .S BARADJ=BARADJ+BARAMT
  1.  S BARTOT=BARTOT+BARADJ
  1.  I (BARBAL-BARTOT)=0 Q
  1.  I (BARBAL-BARTOT)>0 Q
  1.  I '$$IHSNEGB^BARUFUT(DUZ(2)) QUIT  ;2/11/2014
  1.  W !!,"<<Posting this bill will result in a negative balance on the bill>>"
  1.  ;Mark bill not to post
  1.  D UP^BAREDP0Z(IMPDA,CLMDA,"NEGR")
  1.  S BARANS=0  ;bar*1.8*20
  1.  Q
  1.  ; ****************
  1. PAY ;EP  ;PULL CLAIM INFO AND POST PYMT (IF ANY)
  1.  D PAY^BAREDP8A  ;split due to rtn size
  1.  Q
  1.  ; ******************
  1. ADJMULT ;EP  ;POST ADJUSTMENTS
  1.  D ADJMULT^BAREDP8A  ;split due to rtn size
  1.  Q
  1.  ; *******************
  1. RMKCD ;  POST REMARK CODES
  1.  D RMKCD^BAREDP8A  ;split due to rtn size
  1.  Q
  1.  ; ***************
  1. NCPDP ;  POST NCPDP CODES
  1.  K BARTO,BARFROM  ;TPF BAR*1.8*6 SCR119
  1.  K NCPDP,DR,BARDR
  1.  D ENPM^XBDIQ1(90056.0212,"IMPDA,CLMDA,0",".03","NCPDP(","I")
  1.  Q:'$D(NCPDP)
  1.  S BARTRAN=506
  1.  S DR=""
  1.  D DR
  1.  S DR=$E(DR,2,9999)  ;Strip leading ";"
  1.  I +$G(BARCOL)>0 S DR=DR_";14////^S X=$G(BARCOL)"  ;Collct btch if know
  1.  I +$G(BARITM)>0 S DR=DR_";15////^S X=$G(BARITM)"  ;Item if known
  1.  S DR=DR_";108////^S X=BARNCPDP"  ;Remark Code pointer
  1.  S BARDR=DR
  1.  K DR
  1.  S NCPDPDA=0
  1.  F  S NCPDPDA=$O(NCPDP(NCPDPDA)) Q:'+NCPDPDA  D
  1.  .S BARNCPDP=NCPDP(NCPDPDA,.03,"I")
  1.  .Q:BARNCPDP=""
  1.  .D POSTRAN
  1.  .K NCPDPP
  1.  .D ENP^XBDIQ1(90056.0212,"IMPDA,CLMDA,NCPDPDA",".02;.03","NCPDPP(")
  1.  .W !?5,"NCPDP REJECT/PAYMENT CODE: ",NCPDPP(.03),?25,$E($P(NCPDPP(.02)," ",3,99),1,50)
  1.  K NCPDP,NCPDPP
  1.  Q
  1.  ; ****************
  1. DR ;  Gather data needed for transaction
  1.  S DR=DR_";4////^S X=BARBLIEN"  ;A/R Bill
  1.  S DR=DR_";5////^S X=BARBLPAT"  ;A/R Patient
  1.  S DR=DR_";6////^S X=BARBLAC"  ;A/R Account
  1.  S DR=DR_";8////^S X=DUZ(2)"  ;Parent Location
  1.  S DR=DR_";9////^S X=DUZ(2)"  ;Parent ASUFAC
  1.  S DR=DR_";10////^S X=BARSECT"  ;A/R Section
  1.  S DR=DR_";11////^S X=BARVLOC"  ;Visit Location
  1.  S DR=DR_";12////^S X=DT"  ;Date
  1.  S DR=DR_";13////^S X=DUZ"  ;Entry by
  1.  S DR=DR_";101////^S X=BARTRAN"  ;Transaction Type
  1.  S DR=DR_";106////^S X=""e"""  ;Data Source = e
  1.  ;BAR*1.8*1 SRS ADDENDUM FOR BAR*1.8*1
  1.  S DR=DR_";401////^S X=BARICQ"  ;INDENTIFICATION CODE QUALIFIER XX=NPI, FI=TAX ID
  1.  S DR=DR_";402////^S X=BARNPI"  ;IF BARICQ='XX' NPI
  1.  S DR=DR_";403////^S X=BARTIN"  ;IF BARICQ='FI' TAX ID
  1.  ;END
  1.  ;BAR*1.8*5 TPF 6/17/2008
  1.  S DR=DR_";501////^S X=$G(BARTO)"  ;PYMT CREDIT APPLIED FROM BILL
  1.  S DR=DR_";502////^S X=$G(BARFROM)"  ;PYMT CREDIT APPLIED TO BILL
  1.  I BARTRAN=138 D
  1.  .S BARTRAN=43  ;PYMT CREDIT POSTS AS ADJUSTMENT
  1.  .S BARCAT=20
  1.  .S BARREAS=138
  1.  .S DR=DR_";102////^S X=BARCAT"  ;PYMT CREDIT
  1.  .S DR=DR_";103////^S X=BARREAS"  ;CREDIT TO OTHER BILL
  1.  I BARTRAN=139 D  ;IF THIS IS TRUE THEN WE NEED TO POST THIS AS AN ADJ
  1.  .S BARTRAN=43
  1.  .S BARCAT=20
  1.  .S BARREAS=139
  1.  .S DR=DR_";102////^S X=BARCAT"
  1.  .S DR=DR_";103////^S X=BARREAS"  ;CREDIT FROM OTHER BILL
  1.  ;END
  1.  Q
  1.  ; *************
  1. MRKCLMP ;EP ;  MARK CLAIM AS POSTED
  1.  K DIC,DA,DR
  1.  S DIE=$$DIC^XBDIQ1(90056.0205)
  1.  S DA(1)=IMPDA
  1.  S DA=CLMDA
  1.  S DR=".02////P"
  1.  D ^DIE
  1.  K DIC,DA,DR
  1.  S BARPSTED=BARPSTED+1
  1.  Q
  1.  ; ****************
  1. POSTRAN ;EP  ; SET TRANSACTION & POST FILES
  1.  S BARTRIEN=$$NEW^BARTR  ;Create Trans
  1.  I BARTRIEN<1 D MSG^BARTR(BARBLIEN) Q
  1.  S BARROLL(BARBLIEN)=""
  1.  ;Populate Trans file
  1.  S DR=BARDR
  1.  S DA=BARTRIEN  ;IEN to A/R TRANSACTION
  1.  S DIE=90050.03
  1.  S DIDEL=90050
  1.  D ^DIE
  1.  K DIDEL,DIE,DA,DR
  1.  S BARADD=0  ;USE RETURN ARRAY OF THE ADDITIONAL ID MULTIPLE FROM A/R EDI CHK
  1.  ;FILE AND PLACE INTO TRANSACTION FILE
  1.  N BARIQ,BARREF
  1.  S DIC("P")=$P(^DD(90050.03,1101,0),U,2)
  1.  F  S BARADD=$O(BARADD(90056.2211,BARADD)) Q:'BARADD  D
  1.  .S BARIQ=BARADD(90056.2211,BARADD,.01,"E")
  1.  .S BARREF=BARADD(90056.2211,BARADD,.02,"E")
  1.  .S X=BARIQ
  1.  .S DA(1)=BARTRIEN
  1.  .S DIC="^BARTR("_DUZ(2)_","_DA(1)_",11,"
  1.  .S DIC(0)="L"
  1.  .D ^DIC
  1.  .Q:Y<0
  1.  .K DIE,DIC,DR,DA,DR,DIR
  1.  .S DA(1)=BARTRIEN
  1.  .S DA=+Y
  1.  .S DIE="^BARTR("_DUZ(2)_","_DA(1)_",11,"
  1.  .S DR=".02///^S X=BARREF"
  1.  .D ^DIE
  1.  ; Post from trans file to related files unless General/Pending
  1.  I BARTRAN=43,(",21,22,"[(","_BARCAT_",")) Q
  1.  D TR^BARTDO(BARTRIEN)
  1.  Q
  1.  ; ************
  1. ROLLBACK ; Rollback bills that just posted if Roll as you go set to yes
  1.  ; Otherwise just mark for rollback later
  1.  S BARRAYGO=0  ;Default to not roll back
  1.  S BARPARAM=$P($G(^BAR(90052.06,DUZ(2),DUZ(2),0)),U,13)
  1.  I BARPARAM="A"!(BARPARAM="Y") D
  1.  .K DIR
  1.  .S DIR("A")="Do you want to rollback to 3P the bills that just posted"
  1.  .S DIR("B")="N"
  1.  .S DIR(0)="Y"
  1.  .S DIR("?")="Enter 'YES' to roll these A/R bills back to 3P NOW"
  1.  .D ^DIR
  1.  .I Y=1 S BARRAYGO=1
  1.  K DIR
  1.  I BARRAYGO=1 D  Q  ;Ok...rolling bills.
  1.  .W !!,"OK, now rolling back 3P the bills that just posted for chk/EFT ",BARCHECK
  1.  .D EN^BARROLL
  1.  .K BARROLL,DIR
  1.  .D EOP^BARUTL(1)
  1.  W !!,"OK, marking for rollback the bills that just posted for chk/EFT ",BARCHECK
  1.  W !,"Please use the ROL option when you're ready to roll them back to 3P"
  1.  D EN^BARROLL  ;since BARRAYGO = 0, it will only mark for rollback
  1.  K DIR
  1.  D EOP^BARUTL(1)
  1.  Q