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

IBCEU0.m

Go to the documentation of this file.
  1. 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
  1. ;;Per VA Directive 6402, this routine should not be modified.
  1. ;
  1. NOTECHG(IBDA,IBNTEXT) ; Enter who/when review stat change was entered
  1. ; IBDA = ien of entry in file 361.1
  1. ; IBNTEXT = array containing the lines of text to store if not using the
  1. ; default text IBNTEXT = # of lines IBNTEXT(#)=line text
  1. N IBIEN,IBTEXT,DA,X,Y,DIC,DO,DLAYGO,DD
  1. S DA(1)=IBDA,DIC="^IBM(361.1,"_DA(1)_",2,",DIC(0)="L",DLAYGO=361.121
  1. S X=$$NOW^XLFDT
  1. D FILE^DICN K DIC,DD,DO,DLAYGO
  1. Q:Y'>0
  1. S DA(2)=DA(1),DA(1)=+Y,IBIEN=DA(1)_","_DA(2)_","
  1. I $G(IBNTEXT) D
  1. . M IBTEXT=IBNTEXT
  1. E D
  1. . 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))
  1. D WP^DIE(361.121,IBIEN,.03,,"IBTEXT") K ^TMP("DIERR",$J)
  1. Q
  1. ;
  1. LOCK(IBFILE,IBREC) ; Lock record # IBREC in file #IBFILE (361 or 361.1)
  1. N OK
  1. S OK=0
  1. L +^IBM(IBFILE,IBREC):3 I $T S OK=1
  1. I 'OK D
  1. . W !,"Another user has locked this record - try again later"
  1. . D PAUSE^VALM1
  1. Q OK
  1. ;
  1. UNLOCK(IBFILE,IBREC) ; Unlock record # IBREC in file #IBFILE
  1. I $G(IBREC) L -^IBM(IBFILE,IBREC)
  1. Q
  1. ;
  1. MSTAT ; Enter reviewed by selected range
  1. N IBDAX,IBA,IBCLOSE,IBLOOK,IBOK,IBSTOP,IBREBLD,IBCLOK,DA,DIR,X,Y,DIE,DR
  1. D FULL^VALM1
  1. D SEL^IBCECSA4(.IBDAX)
  1. S IBREBLD=0
  1. I $O(IBDAX(""))="" G MSTATQ
  1. 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"
  1. 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 !
  1. G:$D(DIRUT) MSTATQ
  1. S IBCLOSE=(Y=1)
  1. S DIR(0)="YA",DIR("A")="DO YOU WANT TO SEE EACH MESSAGE BEFORE MARKING IT REVIEWED?: ",DIR("B")="NO"
  1. S DIR("?",1)="IF YOU OPT TO SEE EACH MESSAGE, YOU CAN CONTROL WHETHER OR NOT THE MESSAGE",DIR("?",2)=" IS MARKED AS REVIEWED"
  1. I 'IBCLOSE S DIR("?")=DIR("?",2) K DIR("?",2)
  1. I IBCLOSE S DIR("?",2)=DIR("?",2)_" AND, FOR NON-REJECTS, WHETHER OR NOT TO CLOSE THE",DIR("?")=" TRANSMIT RECORD FOR THE BILL"
  1. W ! D ^DIR K DIR W !
  1. G:$D(DIRUT) MSTATQ
  1. S IBLOOK=(Y=1)
  1. S IBDAX=0,IBSTOP=0
  1. F S IBDAX=+$O(IBDAX(IBDAX)) Q:'IBDAX D Q:IBSTOP
  1. . S IBA=$G(IBDAX(IBDAX))
  1. . S DIE="^IBM(361,",DA=$P(IBA,U,2),DR=""
  1. . I DA D
  1. .. S IBOK=1
  1. .. S IBCLOK=$S(IBCLOSE:1,1:0)
  1. .. I IBLOOK D Q:'IBOK
  1. ... S DIC="^IBM(361," D EN^DIQ
  1. ... I '$$LOCK(361,DA) W ! S IBOK=0 Q
  1. ... 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"
  1. ... 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
  1. ... I Y'>0 S IBOK=0 S:$D(DIRUT) IBSTOP=1 Q
  1. ... I 'IBCLOSE D
  1. .... S DIR(0)="YA",DIR("A")="OK TO CLOSE THIS BILL'S TRANSMIT RECORD?: ",DIR("B")="NO"
  1. .... 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"
  1. .... 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."
  1. .... 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"
  1. .... S DIR("?",7)=" bills has been completed. Closing the transmit bill record here will",DIR("?")=" eliminate the bill from this list."
  1. .... W ! D ^DIR K DIR W !
  1. .... I Y'=1 S IBCLOK=0
  1. .. I 'IBLOOK,$P($G(^IBM(361,DA,0)),U,3)="R" D Q:'IBOK
  1. ... S DR="1",DIC="^IBM(361," D EN^DIQ W !,"Bill Number: ",$$EXPAND^IBTRE(361,.01,+^IBM(361,DA,0))
  1. ... S DIR(0)="YA",DIR("A")="THIS IS A REJECTION ... ARE YOU SURE YOU WANT TO MARK IT REVIEWED?: ",DIR("B")="NO"
  1. ... S DIR("?",1)="IF YOU ENTER YES, THIS MESSAGE WILL BE MARKED REVIEWED"
  1. ... 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
  1. ... I Y'=1 S IBOK=0 S:$D(DIRUT) IBSTOP=1
  1. .. S:'IBREBLD IBREBLD=1
  1. .. S DR=".09////2;.1////F" D ^DIE
  1. .. N IBUPD
  1. .. S IBUPD=0
  1. .. I $$PRINTUPD($G(^IBM(361,DA,1,1,0)),+$P(^IBM(361,DA,0),U,11)) S IBUPD=1
  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
  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
  1. .. I IBCLOK,'IBUPD D UPDTX^IBCECSA2(+$P(^IBM(361,DA,0),U,11),"Z")
  1. .. I 'IBLOOK D
  1. ... W !,"Seq #: ",IBDAX," Bill number: ",$$EXPAND^IBTRE(361,.01,+^IBM(361,DA,0)),?45,"REVIEWED"
  1. .. D NOTECHG^IBCECSA2(DA,1)
  1. .. D UNLOCK(361,DA)
  1. W !!,"LAST SELECTION PROCESSED",!
  1. D PAUSE^VALM1
  1. MSTATQ S VALMBCK="R"
  1. I IBREBLD D BLD^IBCECSA1
  1. Q
  1. ;
  1. PRPAY(IBIFN,IBMCR) ; Returns total amount of prior payments applied to
  1. ; bill ien IBIFN
  1. ; IBMCR = flag passed in as 1 if MRA total should be included
  1. ;
  1. N IBTOT,IBZ,IBSEQ
  1. S IBSEQ=$$COBN^IBCEF(IBIFN)
  1. I IBSEQ'>1 S IBTOT=0 G PRPAYQ
  1. D F^IBCEF("N-PRIOR PAYMENTS","IBZ",,IBIFN)
  1. S IBTOT=IBZ
  1. I $G(IBMCR),$$MCRONBIL^IBEFUNC(IBIFN)=1 D ; MCR on bill before curr ins
  1. . N Z,Z0,Z2,Q
  1. . F Z=1:1:IBSEQ-1 I $$WNRBILL^IBEFUNC(IBIFN,Z) D
  1. .. S IBTOT=+$$MCRPAY(IBIFN)
  1. PRPAYQ Q IBTOT
  1. ;
  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
  1. ; message status to closed
  1. ; IBTEXT = the first line text of the status message (optional)
  1. ; IBDA = the ien of the transmission record in file 364
  1. ;
  1. ; FUNCTION returns 1 if message status changed
  1. ;
  1. N IBP,IBP1
  1. S IBP=0,IBP1=$P($G(^DGCR(399,+$G(^IBA(364,+$G(IBDA),0)),"TX")),U,7)
  1. I $G(IBTEXT)["CLAIM RECEIVED, PRINTED AND MAILED BY PRINT CENTER"!IBP1 D
  1. . N Z
  1. . S Z=$E($P($G(^IBA(364,IBDA,0)),U,3),1)
  1. . I "AP"'[Z Q ; Only change if status is pending or received/accepted
  1. . D UPDTX^IBCECSA2(IBDA,"Z") S IBP=1
  1. Q IBP
  1. ;
  1. MCRPAY(IBIFN) ; Calculate MRA total for the bill IBIFN
  1. N IBPAY,Q,Z0
  1. S IBPAY=0
  1. ;include eligible bill for process
  1. ; 432 - added MRA flag to IBCEU1 to not always screen out non-MRA's
  1. 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)
  1. Q IBPAY
  1. ;
  1. PREOBTOT(IBIFN,IBMRANOT) ; Function - Calculates Patient Responsibility Amount
  1. ; Input: IBIFN - ien of Bill Number (ien of file 399)
  1. ; IBMRANOT - flag to indicate that this is NOT and MRA
  1. ; Output Function returns: Patient Responsibility Amount for all EOB's for bill
  1. ;
  1. N FRMTYP,IBPTRES
  1. S IBPTRES=0
  1. ;JWS;IB*2.0*592: Dental form 7
  1. ; Form Type 2=CMS-1500; 3=UB-04; 7=J430D Dental
  1. S FRMTYP=$$FT^IBCEF(IBIFN)
  1. ;
  1. ; For bills w/CMS-1500 Form Type, total up Pt Resp amount from top
  1. ; level of EOB (field 1.02) for All MRA type EOB's on file for that
  1. ; bill (IBIFN)
  1. ;
  1. ;JWS;IB*2.0*592: Dental form 7
  1. I FRMTYP=2!(FRMTYP=7) D Q IBPTRES
  1. . N IBEOB,EOBREC,EOBREC1,IBPRTOT
  1. . S (IBEOB,IBPRTOT,IBPTRES)=0
  1. . F S IBEOB=$O(^IBM(361.1,"B",IBIFN,IBEOB)) Q:'IBEOB D ;
  1. . . S EOBREC=$G(^IBM(361.1,IBEOB,0)),EOBREC1=$G(^(1))
  1. .. ; IB*2.0*432 allow for non-MRA's
  1. . . I $G(IBMRANOT)'=1,$P(EOBREC,U,4)'=1 Q ;make sure it's an MRA
  1. . . Q:$D(^IBM(361.1,IBEOB,"ERR")) ;no filing error
  1. . . ; Total up Pt Resp Amounts on all valid MRA's
  1. . . S IBPTRES=IBPTRES+$P(EOBREC1,U,2)
  1. ;
  1. ; For bills w/UB-04 Form Type, loop through all EOB's and sum up amounts
  1. ; on both Line level and on Claim level
  1. N EOBADJ,IBEOB,LNLVL
  1. S IBEOB=0
  1. F S IBEOB=$O(^IBM(361.1,"B",IBIFN,IBEOB)) Q:'IBEOB D ;
  1. . ; IB*2.0*432 allow for non-MRA's
  1. . I $G(IBMRANOT)'=1,$P($G(^IBM(361.1,IBEOB,0)),U,4)'=1 Q ; must be an MRA
  1. . Q:$D(^IBM(361.1,IBEOB,"ERR")) ; no filing error
  1. . ; get claim level adjustments
  1. . K EOBADJ M EOBADJ=^IBM(361.1,IBEOB,10)
  1. . S IBPTRES=IBPTRES+$$CALCPR(.EOBADJ)
  1. . ;
  1. . ; get line level adjustments
  1. . S LNLVL=0
  1. . F S LNLVL=$O(^IBM(361.1,IBEOB,15,LNLVL)) Q:'LNLVL D ;
  1. . . K EOBADJ M EOBADJ=^IBM(361.1,IBEOB,15,LNLVL,1)
  1. . . S IBPTRES=IBPTRES+$$CALCPR(.EOBADJ)
  1. Q IBPTRES
  1. ;
  1. CALCPR(EOBADJ) ; Function - Calculate Patient Responsibilty Amount
  1. ; For Group Code PR; Ignore the PR-AAA kludge
  1. ; Input - EOBADJ = Array of Group Codes & Reason Codes from either the Claim
  1. ; Level (10) or Service Line Level (15) of EOB file (#361.1)
  1. ; Output - Function returns Patient Responsibility Amount
  1. ;
  1. N GRPLVL,RSNCD,RSNAMT,PTRESP
  1. S (GRPLVL,PTRESP)=0
  1. F S GRPLVL=$O(EOBADJ(GRPLVL)) Q:'GRPLVL D
  1. . I $P($G(EOBADJ(GRPLVL,0)),U)'="PR" Q ;grp code must be PR
  1. . S RSNCD=0
  1. . F S RSNCD=$O(EOBADJ(GRPLVL,1,RSNCD)) Q:'RSNCD D
  1. . . I $P($G(EOBADJ(GRPLVL,1,RSNCD,0)),U,1)="AAA" Q ; ignore PR-AAA
  1. . . S RSNAMT=$P($G(EOBADJ(GRPLVL,1,RSNCD,0)),U,2)
  1. . . S PTRESP=PTRESP+RSNAMT
  1. Q PTRESP
  1. ;
  1. COBMOD(IBXSAVE,IBXDATA,SEQ) ; output the modifiers from the COB
  1. ; SEQ is which modifier we're extracting (1-4)
  1. ; Build IBXDATA(line#)=Modifier# SEQ
  1. NEW LN,N,Z,MOD,LNSEQ
  1. KILL IBXDATA
  1. I '$G(SEQ) Q
  1. S (LN,LNSEQ)=0
  1. F S LN=$O(IBXSAVE("LCOB",LN)) Q:'LN D
  1. . S LNSEQ=LNSEQ+1
  1. . S (N,Z)=0
  1. . F S Z=$O(IBXSAVE("LCOB",LN,"COBMOD",Z)) Q:'Z D
  1. .. S N=N+1
  1. .. S MOD(LNSEQ,N)=$P($G(IBXSAVE("LCOB",LN,"COBMOD",Z,0)),U,1)
  1. .. Q
  1. . S MOD=$G(MOD(LNSEQ,SEQ))
  1. . I MOD'="" S IBXDATA(LNSEQ)=MOD
  1. . Q
  1. Q
  1. ;