IBCEU0 ;ALB/TMP - EDI UTILITIES ;02-OCT-96
;;2.0;INTEGRATED BILLING;**137,197,155,296,349,417,432,592**;21-MAR-94;Build 58
;;Per VA Directive 6402, this routine should not be modified.
;
NOTECHG(IBDA,IBNTEXT) ; Enter who/when review stat change was entered
; IBDA = ien of entry in file 361.1
; IBNTEXT = array containing the lines of text to store if not using the
; default text IBNTEXT = # of lines IBNTEXT(#)=line text
N IBIEN,IBTEXT,DA,X,Y,DIC,DO,DLAYGO,DD
S DA(1)=IBDA,DIC="^IBM(361.1,"_DA(1)_",2,",DIC(0)="L",DLAYGO=361.121
S X=$$NOW^XLFDT
D FILE^DICN K DIC,DD,DO,DLAYGO
Q:Y'>0
S DA(2)=DA(1),DA(1)=+Y,IBIEN=DA(1)_","_DA(2)_","
I $G(IBNTEXT) D
. M IBTEXT=IBNTEXT
E D
. S IBTEXT(1)="REVIEW STATUS CHANGED TO '"_$$EXTERNAL^DILFD(361.1,.2,,$P(^IBM(361.1,DA(2),0),U,20))_"' BY: "_$$EXTERNAL^DILFD(361.121,.02,,+$G(DUZ))
D WP^DIE(361.121,IBIEN,.03,,"IBTEXT") K ^TMP("DIERR",$J)
Q
;
LOCK(IBFILE,IBREC) ; Lock record # IBREC in file #IBFILE (361 or 361.1)
N OK
S OK=0
L +^IBM(IBFILE,IBREC):3 I $T S OK=1
I 'OK D
. W !,"Another user has locked this record - try again later"
. D PAUSE^VALM1
Q OK
;
UNLOCK(IBFILE,IBREC) ; Unlock record # IBREC in file #IBFILE
I $G(IBREC) L -^IBM(IBFILE,IBREC)
Q
;
MSTAT ; Enter reviewed by selected range
N IBDAX,IBA,IBCLOSE,IBLOOK,IBOK,IBSTOP,IBREBLD,IBCLOK,DA,DIR,X,Y,DIE,DR
D FULL^VALM1
D SEL^IBCECSA4(.IBDAX)
S IBREBLD=0
I $O(IBDAX(""))="" G MSTATQ
S DIR("?,1")="ONLY SELECT TO CLOSE THE TRANSMIT RECORDS IF YOU KNOW THESE ARE THE FINAL",DIR("?",2)=" ELECTRONIC MESSAGES YOU WILL RECEIVE FOR ALL THE BILLS REFERENCED BY",DIR("?")=" THESE MESSAGES"
S DIR(0)="YA",DIR("A",1)="DO YOU WANT TO AUTOMATICALLY CLOSE THE TRANSMIT RECORDS FOR ANY MESSAGES",DIR("A")=" THAT AREN'T REJECTS?: ",DIR("B")="NO" W ! D ^DIR K DIR W !
G:$D(DIRUT) MSTATQ
S IBCLOSE=(Y=1)
S DIR(0)="YA",DIR("A")="DO YOU WANT TO SEE EACH MESSAGE BEFORE MARKING IT REVIEWED?: ",DIR("B")="NO"
S DIR("?",1)="IF YOU OPT TO SEE EACH MESSAGE, YOU CAN CONTROL WHETHER OR NOT THE MESSAGE",DIR("?",2)=" IS MARKED AS REVIEWED"
I 'IBCLOSE S DIR("?")=DIR("?",2) K DIR("?",2)
I IBCLOSE S DIR("?",2)=DIR("?",2)_" AND, FOR NON-REJECTS, WHETHER OR NOT TO CLOSE THE",DIR("?")=" TRANSMIT RECORD FOR THE BILL"
W ! D ^DIR K DIR W !
G:$D(DIRUT) MSTATQ
S IBLOOK=(Y=1)
S IBDAX=0,IBSTOP=0
F S IBDAX=+$O(IBDAX(IBDAX)) Q:'IBDAX D Q:IBSTOP
. S IBA=$G(IBDAX(IBDAX))
. S DIE="^IBM(361,",DA=$P(IBA,U,2),DR=""
. I DA D
.. S IBOK=1
.. S IBCLOK=$S(IBCLOSE:1,1:0)
.. I IBLOOK D Q:'IBOK
... S DIC="^IBM(361," D EN^DIQ
... I '$$LOCK(361,DA) W ! S IBOK=0 Q
... S DIR(0)="YA",DIR("A")="OK TO MARK REVIEWED?: ",DIR("B")="YES",DIR("?",1)="IF YOU ENTER YES, THIS MESSAGE WILL BE MARKED REVIEWED"
... S DIR("?",2)="IF YOU ENTER NO, THIS MESSAGE WILL NOT BE ALTERED",DIR("?",3)="IF YOU ENTER AN ^, THIS MESSAGE WILL NOT BE ALTERED & NONE OF THE",DIR("?")=" REMAINING MESSAGES WILL BE PROCESSED" D ^DIR K DIR
... I Y'>0 S IBOK=0 S:$D(DIRUT) IBSTOP=1 Q
... I 'IBCLOSE D
.... S DIR(0)="YA",DIR("A")="OK TO CLOSE THIS BILL'S TRANSMIT RECORD?: ",DIR("B")="NO"
.... S DIR("?",1)="If you respond YES to this prompt, the transmit status of this bill will",DIR("?",2)=" be set to CLOSED. No further electronic processing of this bill will be"
.... S DIR("?",3)=" allowed. If you respond NO to this prompt, this electronic message will",DIR("?",4)=" be filed as reviewed, but the bill's transmit status will not be changed."
.... S DIR("?",5)=" You may wish to periodically print a list of bills with a non-final",DIR("?",6)=" (closed/cancelled/etc) status to ensure the electronic processing of all"
.... S DIR("?",7)=" bills has been completed. Closing the transmit bill record here will",DIR("?")=" eliminate the bill from this list."
.... W ! D ^DIR K DIR W !
.... I Y'=1 S IBCLOK=0
.. I 'IBLOOK,$P($G(^IBM(361,DA,0)),U,3)="R" D Q:'IBOK
... S DR="1",DIC="^IBM(361," D EN^DIQ W !,"Bill Number: ",$$EXPAND^IBTRE(361,.01,+^IBM(361,DA,0))
... S DIR(0)="YA",DIR("A")="THIS IS A REJECTION ... ARE YOU SURE YOU WANT TO MARK IT REVIEWED?: ",DIR("B")="NO"
... S DIR("?",1)="IF YOU ENTER YES, THIS MESSAGE WILL BE MARKED REVIEWED"
... S DIR("?",2)="IF YOU ENTER NO, THIS MESSAGE WILL NOT BE ALTERED",DIR("?",3)="IF YOU ENTER AN ^, THIS MESSAGE WILL NOT BE ALTERED & NONE OF THE",DIR("?")=" MESSAGES FOLLOWING THIS ONE WILL BE PROCESSED" D ^DIR K DIR
... I Y'=1 S IBOK=0 S:$D(DIRUT) IBSTOP=1
.. S:'IBREBLD IBREBLD=1
.. S DR=".09////2;.1////F" D ^DIE
.. N IBUPD
.. S IBUPD=0
.. I $$PRINTUPD($G(^IBM(361,DA,1,1,0)),+$P(^IBM(361,DA,0),U,11)) S IBUPD=1
.. I $G(^IBM(361,DA,1,1,0))["CLAIM SENT TO PAYER" D UPDTX^IBCECSA2(+$P(^IBM(361,DA,0),U,11),$S(IBCLOK:"Z",1:"A2")) S IBUPD=1
.. I $G(^IBM(361,DA,1,1,0))["CLAIM REJECTED" D UPDTX^IBCECSA2(+$P(^IBM(361,DA,0),U,11),"E") S IBUPD=1
.. I IBCLOK,'IBUPD D UPDTX^IBCECSA2(+$P(^IBM(361,DA,0),U,11),"Z")
.. I 'IBLOOK D
... W !,"Seq #: ",IBDAX," Bill number: ",$$EXPAND^IBTRE(361,.01,+^IBM(361,DA,0)),?45,"REVIEWED"
.. D NOTECHG^IBCECSA2(DA,1)
.. D UNLOCK(361,DA)
W !!,"LAST SELECTION PROCESSED",!
D PAUSE^VALM1
MSTATQ S VALMBCK="R"
I IBREBLD D BLD^IBCECSA1
Q
;
PRPAY(IBIFN,IBMCR) ; Returns total amount of prior payments applied to
; bill ien IBIFN
; IBMCR = flag passed in as 1 if MRA total should be included
;
N IBTOT,IBZ,IBSEQ
S IBSEQ=$$COBN^IBCEF(IBIFN)
I IBSEQ'>1 S IBTOT=0 G PRPAYQ
D F^IBCEF("N-PRIOR PAYMENTS","IBZ",,IBIFN)
S IBTOT=IBZ
I $G(IBMCR),$$MCRONBIL^IBEFUNC(IBIFN)=1 D ; MCR on bill before curr ins
. N Z,Z0,Z2,Q
. F Z=1:1:IBSEQ-1 I $$WNRBILL^IBEFUNC(IBIFN,Z) D
.. S IBTOT=+$$MCRPAY(IBIFN)
PRPAYQ Q IBTOT
;
PRINTUPD(IBTEXT,IBDA) ; If the status message indicates claim was printed
; or the claim record in file 399 says it was, update the transmit
; message status to closed
; IBTEXT = the first line text of the status message (optional)
; IBDA = the ien of the transmission record in file 364
;
; FUNCTION returns 1 if message status changed
;
N IBP,IBP1
S IBP=0,IBP1=$P($G(^DGCR(399,+$G(^IBA(364,+$G(IBDA),0)),"TX")),U,7)
I $G(IBTEXT)["CLAIM RECEIVED, PRINTED AND MAILED BY PRINT CENTER"!IBP1 D
. N Z
. S Z=$E($P($G(^IBA(364,IBDA,0)),U,3),1)
. I "AP"'[Z Q ; Only change if status is pending or received/accepted
. D UPDTX^IBCECSA2(IBDA,"Z") S IBP=1
Q IBP
;
MCRPAY(IBIFN) ; Calculate MRA total for the bill IBIFN
N IBPAY,Q,Z0
S IBPAY=0
;include eligible bill for process
; 432 - added MRA flag to IBCEU1 to not always screen out non-MRA's
S Q=0 F S Q=$O(^IBM(361.1,"B",IBIFN,Q)) Q:'Q I $$EOBELIG^IBCEU1(Q,1) S IBPAY=IBPAY+$P($G(^IBM(361.1,Q,1)),U,1)
Q IBPAY
;
PREOBTOT(IBIFN,IBMRANOT) ; Function - Calculates Patient Responsibility Amount
; Input: IBIFN - ien of Bill Number (ien of file 399)
; IBMRANOT - flag to indicate that this is NOT and MRA
; Output Function returns: Patient Responsibility Amount for all EOB's for bill
;
N FRMTYP,IBPTRES
S IBPTRES=0
;JWS;IB*2.0*592: Dental form 7
; Form Type 2=CMS-1500; 3=UB-04; 7=J430D Dental
S FRMTYP=$$FT^IBCEF(IBIFN)
;
; For bills w/CMS-1500 Form Type, total up Pt Resp amount from top
; level of EOB (field 1.02) for All MRA type EOB's on file for that
; bill (IBIFN)
;
;JWS;IB*2.0*592: Dental form 7
I FRMTYP=2!(FRMTYP=7) D Q IBPTRES
. N IBEOB,EOBREC,EOBREC1,IBPRTOT
. S (IBEOB,IBPRTOT,IBPTRES)=0
. F S IBEOB=$O(^IBM(361.1,"B",IBIFN,IBEOB)) Q:'IBEOB D ;
. . S EOBREC=$G(^IBM(361.1,IBEOB,0)),EOBREC1=$G(^(1))
.. ; IB*2.0*432 allow for non-MRA's
. . I $G(IBMRANOT)'=1,$P(EOBREC,U,4)'=1 Q ;make sure it's an MRA
. . Q:$D(^IBM(361.1,IBEOB,"ERR")) ;no filing error
. . ; Total up Pt Resp Amounts on all valid MRA's
. . S IBPTRES=IBPTRES+$P(EOBREC1,U,2)
;
; For bills w/UB-04 Form Type, loop through all EOB's and sum up amounts
; on both Line level and on Claim level
N EOBADJ,IBEOB,LNLVL
S IBEOB=0
F S IBEOB=$O(^IBM(361.1,"B",IBIFN,IBEOB)) Q:'IBEOB D ;
. ; IB*2.0*432 allow for non-MRA's
. I $G(IBMRANOT)'=1,$P($G(^IBM(361.1,IBEOB,0)),U,4)'=1 Q ; must be an MRA
. Q:$D(^IBM(361.1,IBEOB,"ERR")) ; no filing error
. ; get claim level adjustments
. K EOBADJ M EOBADJ=^IBM(361.1,IBEOB,10)
. S IBPTRES=IBPTRES+$$CALCPR(.EOBADJ)
. ;
. ; get line level adjustments
. S LNLVL=0
. F S LNLVL=$O(^IBM(361.1,IBEOB,15,LNLVL)) Q:'LNLVL D ;
. . K EOBADJ M EOBADJ=^IBM(361.1,IBEOB,15,LNLVL,1)
. . S IBPTRES=IBPTRES+$$CALCPR(.EOBADJ)
Q IBPTRES
;
CALCPR(EOBADJ) ; Function - Calculate Patient Responsibilty Amount
; For Group Code PR; Ignore the PR-AAA kludge
; Input - EOBADJ = Array of Group Codes & Reason Codes from either the Claim
; Level (10) or Service Line Level (15) of EOB file (#361.1)
; Output - Function returns Patient Responsibility Amount
;
N GRPLVL,RSNCD,RSNAMT,PTRESP
S (GRPLVL,PTRESP)=0
F S GRPLVL=$O(EOBADJ(GRPLVL)) Q:'GRPLVL D
. I $P($G(EOBADJ(GRPLVL,0)),U)'="PR" Q ;grp code must be PR
. S RSNCD=0
. F S RSNCD=$O(EOBADJ(GRPLVL,1,RSNCD)) Q:'RSNCD D
. . I $P($G(EOBADJ(GRPLVL,1,RSNCD,0)),U,1)="AAA" Q ; ignore PR-AAA
. . S RSNAMT=$P($G(EOBADJ(GRPLVL,1,RSNCD,0)),U,2)
. . S PTRESP=PTRESP+RSNAMT
Q PTRESP
;
COBMOD(IBXSAVE,IBXDATA,SEQ) ; output the modifiers from the COB
; SEQ is which modifier we're extracting (1-4)
; Build IBXDATA(line#)=Modifier# SEQ
NEW LN,N,Z,MOD,LNSEQ
KILL IBXDATA
I '$G(SEQ) Q
S (LN,LNSEQ)=0
F S LN=$O(IBXSAVE("LCOB",LN)) Q:'LN D
. S LNSEQ=LNSEQ+1
. S (N,Z)=0
. F S Z=$O(IBXSAVE("LCOB",LN,"COBMOD",Z)) Q:'Z D
.. S N=N+1
.. S MOD(LNSEQ,N)=$P($G(IBXSAVE("LCOB",LN,"COBMOD",Z,0)),U,1)
.. Q
. S MOD=$G(MOD(LNSEQ,SEQ))
. I MOD'="" S IBXDATA(LNSEQ)=MOD
. Q
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBCEU0 9847 printed Dec 13, 2024@02:12:31 Page 2
IBCEU0 ;ALB/TMP - EDI UTILITIES ;02-OCT-96
+1 ;;2.0;INTEGRATED BILLING;**137,197,155,296,349,417,432,592**;21-MAR-94;Build 58
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;
NOTECHG(IBDA,IBNTEXT) ; Enter who/when review stat change was entered
+1 ; IBDA = ien of entry in file 361.1
+2 ; IBNTEXT = array containing the lines of text to store if not using the
+3 ; default text IBNTEXT = # of lines IBNTEXT(#)=line text
+4 NEW IBIEN,IBTEXT,DA,X,Y,DIC,DO,DLAYGO,DD
+5 SET DA(1)=IBDA
SET DIC="^IBM(361.1,"_DA(1)_",2,"
SET DIC(0)="L"
SET DLAYGO=361.121
+6 SET X=$$NOW^XLFDT
+7 DO FILE^DICN
KILL DIC,DD,DO,DLAYGO
+8 if Y'>0
QUIT
+9 SET DA(2)=DA(1)
SET DA(1)=+Y
SET IBIEN=DA(1)_","_DA(2)_","
+10 IF $GET(IBNTEXT)
Begin DoDot:1
+11 MERGE IBTEXT=IBNTEXT
End DoDot:1
+12 IF '$TEST
Begin DoDot:1
+13 SET IBTEXT(1)="REVIEW STATUS CHANGED TO '"_$$EXTERNAL^DILFD(361.1,.2,,$PIECE(^IBM(361.1,DA(2),0),U,20))_"' BY: "_$$EXTERNAL^DILFD(361.121,.02,,+$GET(DUZ))
End DoDot:1
+14 DO WP^DIE(361.121,IBIEN,.03,,"IBTEXT")
KILL ^TMP("DIERR",$JOB)
+15 QUIT
+16 ;
LOCK(IBFILE,IBREC) ; Lock record # IBREC in file #IBFILE (361 or 361.1)
+1 NEW OK
+2 SET OK=0
+3 LOCK +^IBM(IBFILE,IBREC):3
IF $TEST
SET OK=1
+4 IF 'OK
Begin DoDot:1
+5 WRITE !,"Another user has locked this record - try again later"
+6 DO PAUSE^VALM1
End DoDot:1
+7 QUIT OK
+8 ;
UNLOCK(IBFILE,IBREC) ; Unlock record # IBREC in file #IBFILE
+1 IF $GET(IBREC)
LOCK -^IBM(IBFILE,IBREC)
+2 QUIT
+3 ;
MSTAT ; Enter reviewed by selected range
+1 NEW IBDAX,IBA,IBCLOSE,IBLOOK,IBOK,IBSTOP,IBREBLD,IBCLOK,DA,DIR,X,Y,DIE,DR
+2 DO FULL^VALM1
+3 DO SEL^IBCECSA4(.IBDAX)
+4 SET IBREBLD=0
+5 IF $ORDER(IBDAX(""))=""
GOTO MSTATQ
+6 SET DIR("?,1")="ONLY SELECT TO CLOSE THE TRANSMIT RECORDS IF YOU KNOW THESE ARE THE FINAL"
SET DIR("?",2)=" ELECTRONIC MESSAGES YOU WILL RECEIVE FOR ALL THE BILLS REFERENCED BY"
SET DIR("?")=" THESE MESSAGES"
+7 SET DIR(0)="YA"
SET DIR("A",1)="DO YOU WANT TO AUTOMATICALLY CLOSE THE TRANSMIT RECORDS FOR ANY MESSAGES"
SET DIR("A")=" THAT AREN'T REJECTS?: "
SET DIR("B")="NO"
WRITE !
DO ^DIR
KILL DIR
WRITE !
+8 if $DATA(DIRUT)
GOTO MSTATQ
+9 SET IBCLOSE=(Y=1)
+10 SET DIR(0)="YA"
SET DIR("A")="DO YOU WANT TO SEE EACH MESSAGE BEFORE MARKING IT REVIEWED?: "
SET DIR("B")="NO"
+11 SET DIR("?",1)="IF YOU OPT TO SEE EACH MESSAGE, YOU CAN CONTROL WHETHER OR NOT THE MESSAGE"
SET DIR("?",2)=" IS MARKED AS REVIEWED"
+12 IF 'IBCLOSE
SET DIR("?")=DIR("?",2)
KILL DIR("?",2)
+13 IF IBCLOSE
SET DIR("?",2)=DIR("?",2)_" AND, FOR NON-REJECTS, WHETHER OR NOT TO CLOSE THE"
SET DIR("?")=" TRANSMIT RECORD FOR THE BILL"
+14 WRITE !
DO ^DIR
KILL DIR
WRITE !
+15 if $DATA(DIRUT)
GOTO MSTATQ
+16 SET IBLOOK=(Y=1)
+17 SET IBDAX=0
SET IBSTOP=0
+18 FOR
SET IBDAX=+$ORDER(IBDAX(IBDAX))
if 'IBDAX
QUIT
Begin DoDot:1
+19 SET IBA=$GET(IBDAX(IBDAX))
+20 SET DIE="^IBM(361,"
SET DA=$PIECE(IBA,U,2)
SET DR=""
+21 IF DA
Begin DoDot:2
+22 SET IBOK=1
+23 SET IBCLOK=$SELECT(IBCLOSE:1,1:0)
+24 IF IBLOOK
Begin DoDot:3
+25 SET DIC="^IBM(361,"
DO EN^DIQ
+26 IF '$$LOCK(361,DA)
WRITE !
SET IBOK=0
QUIT
+27 SET DIR(0)="YA"
SET DIR("A")="OK TO MARK REVIEWED?: "
SET DIR("B")="YES"
SET DIR("?",1)="IF YOU ENTER YES, THIS MESSAGE WILL BE MARKED REVIEWED"
+28 SET DIR("?",2)="IF YOU ENTER NO, THIS MESSAGE WILL NOT BE ALTERED"
SET DIR("?",3)="IF YOU ENTER AN ^, THIS MESSAGE WILL NOT BE ALTERED & NONE OF THE"
SET DIR("?")=" REMAINING MESSAGES WILL BE PROCESSED"
DO ^DIR
KILL DIR
+29 IF Y'>0
SET IBOK=0
if $DATA(DIRUT)
SET IBSTOP=1
QUIT
+30 IF 'IBCLOSE
Begin DoDot:4
+31 SET DIR(0)="YA"
SET DIR("A")="OK TO CLOSE THIS BILL'S TRANSMIT RECORD?: "
SET DIR("B")="NO"
+32 SET DIR("?",1)="If you respond YES to this prompt, the transmit status of this bill will"
SET DIR("?",2)=" be set to CLOSED. No further electronic processing of this bill will be"
+33 SET DIR("?",3)=" allowed. If you respond NO to this prompt, this electronic message will"
SET DIR("?",4)=" be filed as reviewed, but the bill's transmit status will not be changed."
+34 SET DIR("?",5)=" You may wish to periodically print a list of bills with a non-final"
SET DIR("?",6)=" (closed/cancelled/etc) status to ensure the electronic processing of all"
+35 SET DIR("?",7)=" bills has been completed. Closing the transmit bill record here will"
SET DIR("?")=" eliminate the bill from this list."
+36 WRITE !
DO ^DIR
KILL DIR
WRITE !
+37 IF Y'=1
SET IBCLOK=0
End DoDot:4
End DoDot:3
if 'IBOK
QUIT
+38 IF 'IBLOOK
IF $PIECE($GET(^IBM(361,DA,0)),U,3)="R"
Begin DoDot:3
+39 SET DR="1"
SET DIC="^IBM(361,"
DO EN^DIQ
WRITE !,"Bill Number: ",$$EXPAND^IBTRE(361,.01,+^IBM(361,DA,0))
+40 SET DIR(0)="YA"
SET DIR("A")="THIS IS A REJECTION ... ARE YOU SURE YOU WANT TO MARK IT REVIEWED?: "
SET DIR("B")="NO"
+41 SET DIR("?",1)="IF YOU ENTER YES, THIS MESSAGE WILL BE MARKED REVIEWED"
+42 SET DIR("?",2)="IF YOU ENTER NO, THIS MESSAGE WILL NOT BE ALTERED"
SET DIR("?",3)="IF YOU ENTER AN ^, THIS MESSAGE WILL NOT BE ALTERED & NONE OF THE"
SET DIR("?")=" MESSAGES FOLLOWING THIS ONE WILL BE PROCESSED"
DO ^DIR
KILL DIR
+43 IF Y'=1
SET IBOK=0
if $DATA(DIRUT)
SET IBSTOP=1
End DoDot:3
if 'IBOK
QUIT
+44 if 'IBREBLD
SET IBREBLD=1
+45 SET DR=".09////2;.1////F"
DO ^DIE
+46 NEW IBUPD
+47 SET IBUPD=0
+48 IF $$PRINTUPD($GET(^IBM(361,DA,1,1,0)),+$PIECE(^IBM(361,DA,0),U,11))
SET IBUPD=1
+49 IF $GET(^IBM(361,DA,1,1,0))["CLAIM SENT TO PAYER"
DO UPDTX^IBCECSA2(+$PIECE(^IBM(361,DA,0),U,11),$SELECT(IBCLOK:"Z",1:"A2"))
SET IBUPD=1
+50 IF $GET(^IBM(361,DA,1,1,0))["CLAIM REJECTED"
DO UPDTX^IBCECSA2(+$PIECE(^IBM(361,DA,0),U,11),"E")
SET IBUPD=1
+51 IF IBCLOK
IF 'IBUPD
DO UPDTX^IBCECSA2(+$PIECE(^IBM(361,DA,0),U,11),"Z")
+52 IF 'IBLOOK
Begin DoDot:3
+53 WRITE !,"Seq #: ",IBDAX," Bill number: ",$$EXPAND^IBTRE(361,.01,+^IBM(361,DA,0)),?45,"REVIEWED"
End DoDot:3
+54 DO NOTECHG^IBCECSA2(DA,1)
+55 DO UNLOCK(361,DA)
End DoDot:2
End DoDot:1
if IBSTOP
QUIT
+56 WRITE !!,"LAST SELECTION PROCESSED",!
+57 DO PAUSE^VALM1
MSTATQ SET VALMBCK="R"
+1 IF IBREBLD
DO BLD^IBCECSA1
+2 QUIT
+3 ;
PRPAY(IBIFN,IBMCR) ; Returns total amount of prior payments applied to
+1 ; bill ien IBIFN
+2 ; IBMCR = flag passed in as 1 if MRA total should be included
+3 ;
+4 NEW IBTOT,IBZ,IBSEQ
+5 SET IBSEQ=$$COBN^IBCEF(IBIFN)
+6 IF IBSEQ'>1
SET IBTOT=0
GOTO PRPAYQ
+7 DO F^IBCEF("N-PRIOR PAYMENTS","IBZ",,IBIFN)
+8 SET IBTOT=IBZ
+9 ; MCR on bill before curr ins
IF $GET(IBMCR)
IF $$MCRONBIL^IBEFUNC(IBIFN)=1
Begin DoDot:1
+10 NEW Z,Z0,Z2,Q
+11 FOR Z=1:1:IBSEQ-1
IF $$WNRBILL^IBEFUNC(IBIFN,Z)
Begin DoDot:2
+12 SET IBTOT=+$$MCRPAY(IBIFN)
End DoDot:2
End DoDot:1
PRPAYQ QUIT IBTOT
+1 ;
PRINTUPD(IBTEXT,IBDA) ; If the status message indicates claim was printed
+1 ; or the claim record in file 399 says it was, update the transmit
+2 ; message status to closed
+3 ; IBTEXT = the first line text of the status message (optional)
+4 ; IBDA = the ien of the transmission record in file 364
+5 ;
+6 ; FUNCTION returns 1 if message status changed
+7 ;
+8 NEW IBP,IBP1
+9 SET IBP=0
SET IBP1=$PIECE($GET(^DGCR(399,+$GET(^IBA(364,+$GET(IBDA),0)),"TX")),U,7)
+10 IF $GET(IBTEXT)["CLAIM RECEIVED, PRINTED AND MAILED BY PRINT CENTER"!IBP1
Begin DoDot:1
+11 NEW Z
+12 SET Z=$EXTRACT($PIECE($GET(^IBA(364,IBDA,0)),U,3),1)
+13 ; Only change if status is pending or received/accepted
IF "AP"'[Z
QUIT
+14 DO UPDTX^IBCECSA2(IBDA,"Z")
SET IBP=1
End DoDot:1
+15 QUIT IBP
+16 ;
MCRPAY(IBIFN) ; Calculate MRA total for the bill IBIFN
+1 NEW IBPAY,Q,Z0
+2 SET IBPAY=0
+3 ;include eligible bill for process
+4 ; 432 - added MRA flag to IBCEU1 to not always screen out non-MRA's
+5 SET Q=0
FOR
SET Q=$ORDER(^IBM(361.1,"B",IBIFN,Q))
if 'Q
QUIT
IF $$EOBELIG^IBCEU1(Q,1)
SET IBPAY=IBPAY+$PIECE($GET(^IBM(361.1,Q,1)),U,1)
+6 QUIT IBPAY
+7 ;
PREOBTOT(IBIFN,IBMRANOT) ; Function - Calculates Patient Responsibility Amount
+1 ; Input: IBIFN - ien of Bill Number (ien of file 399)
+2 ; IBMRANOT - flag to indicate that this is NOT and MRA
+3 ; Output Function returns: Patient Responsibility Amount for all EOB's for bill
+4 ;
+5 NEW FRMTYP,IBPTRES
+6 SET IBPTRES=0
+7 ;JWS;IB*2.0*592: Dental form 7
+8 ; Form Type 2=CMS-1500; 3=UB-04; 7=J430D Dental
+9 SET FRMTYP=$$FT^IBCEF(IBIFN)
+10 ;
+11 ; For bills w/CMS-1500 Form Type, total up Pt Resp amount from top
+12 ; level of EOB (field 1.02) for All MRA type EOB's on file for that
+13 ; bill (IBIFN)
+14 ;
+15 ;JWS;IB*2.0*592: Dental form 7
+16 IF FRMTYP=2!(FRMTYP=7)
Begin DoDot:1
+17 NEW IBEOB,EOBREC,EOBREC1,IBPRTOT
+18 SET (IBEOB,IBPRTOT,IBPTRES)=0
+19 ;
FOR
SET IBEOB=$ORDER(^IBM(361.1,"B",IBIFN,IBEOB))
if 'IBEOB
QUIT
Begin DoDot:2
+20 SET EOBREC=$GET(^IBM(361.1,IBEOB,0))
SET EOBREC1=$GET(^(1))
+21 ; IB*2.0*432 allow for non-MRA's
+22 ;make sure it's an MRA
IF $GET(IBMRANOT)'=1
IF $PIECE(EOBREC,U,4)'=1
QUIT
+23 ;no filing error
if $DATA(^IBM(361.1,IBEOB,"ERR"))
QUIT
+24 ; Total up Pt Resp Amounts on all valid MRA's
+25 SET IBPTRES=IBPTRES+$PIECE(EOBREC1,U,2)
End DoDot:2
End DoDot:1
QUIT IBPTRES
+26 ;
+27 ; For bills w/UB-04 Form Type, loop through all EOB's and sum up amounts
+28 ; on both Line level and on Claim level
+29 NEW EOBADJ,IBEOB,LNLVL
+30 SET IBEOB=0
+31 ;
FOR
SET IBEOB=$ORDER(^IBM(361.1,"B",IBIFN,IBEOB))
if 'IBEOB
QUIT
Begin DoDot:1
+32 ; IB*2.0*432 allow for non-MRA's
+33 ; must be an MRA
IF $GET(IBMRANOT)'=1
IF $PIECE($GET(^IBM(361.1,IBEOB,0)),U,4)'=1
QUIT
+34 ; no filing error
if $DATA(^IBM(361.1,IBEOB,"ERR"))
QUIT
+35 ; get claim level adjustments
+36 KILL EOBADJ
MERGE EOBADJ=^IBM(361.1,IBEOB,10)
+37 SET IBPTRES=IBPTRES+$$CALCPR(.EOBADJ)
+38 ;
+39 ; get line level adjustments
+40 SET LNLVL=0
+41 ;
FOR
SET LNLVL=$ORDER(^IBM(361.1,IBEOB,15,LNLVL))
if 'LNLVL
QUIT
Begin DoDot:2
+42 KILL EOBADJ
MERGE EOBADJ=^IBM(361.1,IBEOB,15,LNLVL,1)
+43 SET IBPTRES=IBPTRES+$$CALCPR(.EOBADJ)
End DoDot:2
End DoDot:1
+44 QUIT IBPTRES
+45 ;
CALCPR(EOBADJ) ; Function - Calculate Patient Responsibilty Amount
+1 ; For Group Code PR; Ignore the PR-AAA kludge
+2 ; Input - EOBADJ = Array of Group Codes & Reason Codes from either the Claim
+3 ; Level (10) or Service Line Level (15) of EOB file (#361.1)
+4 ; Output - Function returns Patient Responsibility Amount
+5 ;
+6 NEW GRPLVL,RSNCD,RSNAMT,PTRESP
+7 SET (GRPLVL,PTRESP)=0
+8 FOR
SET GRPLVL=$ORDER(EOBADJ(GRPLVL))
if 'GRPLVL
QUIT
Begin DoDot:1
+9 ;grp code must be PR
IF $PIECE($GET(EOBADJ(GRPLVL,0)),U)'="PR"
QUIT
+10 SET RSNCD=0
+11 FOR
SET RSNCD=$ORDER(EOBADJ(GRPLVL,1,RSNCD))
if 'RSNCD
QUIT
Begin DoDot:2
+12 ; ignore PR-AAA
IF $PIECE($GET(EOBADJ(GRPLVL,1,RSNCD,0)),U,1)="AAA"
QUIT
+13 SET RSNAMT=$PIECE($GET(EOBADJ(GRPLVL,1,RSNCD,0)),U,2)
+14 SET PTRESP=PTRESP+RSNAMT
End DoDot:2
End DoDot:1
+15 QUIT PTRESP
+16 ;
COBMOD(IBXSAVE,IBXDATA,SEQ) ; output the modifiers from the COB
+1 ; SEQ is which modifier we're extracting (1-4)
+2 ; Build IBXDATA(line#)=Modifier# SEQ
+3 NEW LN,N,Z,MOD,LNSEQ
+4 KILL IBXDATA
+5 IF '$GET(SEQ)
QUIT
+6 SET (LN,LNSEQ)=0
+7 FOR
SET LN=$ORDER(IBXSAVE("LCOB",LN))
if 'LN
QUIT
Begin DoDot:1
+8 SET LNSEQ=LNSEQ+1
+9 SET (N,Z)=0
+10 FOR
SET Z=$ORDER(IBXSAVE("LCOB",LN,"COBMOD",Z))
if 'Z
QUIT
Begin DoDot:2
+11 SET N=N+1
+12 SET MOD(LNSEQ,N)=$PIECE($GET(IBXSAVE("LCOB",LN,"COBMOD",Z,0)),U,1)
+13 QUIT
End DoDot:2
+14 SET MOD=$GET(MOD(LNSEQ,SEQ))
+15 IF MOD'=""
SET IBXDATA(LNSEQ)=MOD
+16 QUIT
End DoDot:1
+17 QUIT
+18 ;
