- 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 Feb 18, 2025@23:38:55 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 ;