IBCEST ;ALB/TMP - 837 EDI STATUS MESSAGE PROCESSING ;17-APR-96
;;2.0;INTEGRATED BILLING;**137,189,197,135,283,320,368,397,407,577,592,623**;21-MAR-94;Build 70
;;Per VA Directive 6402, this routine should not be modified.
; IA 4043 for call to AUDITX^PRCAUDT
Q
;
UPD361(IBTDA) ; Update IB BILL STATUS MESSAGES file
; IBTDA = ien of return message in file 364.2
;
N IB,IB0,IBSEQ,IB00,IBBILL,IBBTCH,IBMNUM,IBDATE,IBTYP
;
I '$$LOCK^IBCEM(IBTDA) G UPDQ ;Lock message in file 364.2
;
S IB0=$G(^IBA(364.2,IBTDA,0))
S IBMNUM=$P(IB0,U) ; Message number
S IB00=$G(^IBA(364,+$P(IB0,U,5),0)) ; Transmit bill entry
S IBBILL=+IB00 ; Actual bill ien in file 399
S IBBTCH=$P(IB0,U,4) ; Batch #
;
; Auto-audit bills based on status code on '10' record of status msg
; flat file
I IBBILL,$P($T(PRCAUDT+1^PRCAUDT),"**",2)[",173" D
. N Z,Z0,Z1,OK
. Q:+$$STA^PRCAFN(IBBILL)'=104
. S (Z,OK)=0
. F S Z=$O(^IBA(364.2,IBTDA,2,Z)) Q:'Z S Z0=$P($G(^(Z,0)),"##RAW DATA: ",2) I +Z0=10 S Z0=$P(Z0,U,5) D Q:OK
.. ; Strip leading spaces
.. S Z0=$$TRIM^XLFSTR(Z0)
.. Q:Z0=""
.. I $$SCODE^IBCEST1(Z0),$P($G(^DGCR(399.3,+$P($G(^DGCR(399,IBBILL,0)),U,7),0)),U,11) D AUDITX^PRCAUDT(IBBILL) S OK=1 ; IA 4043
;
I $S(IBMNUM="":1,1:'IBBILL&(IBBTCH="")) D DELMSG^IBCESRV2(IBTDA) G UPDQ
;
; Individual bill ; KDM US129 IB*2*577 rework Individual vs. Batch to Correct Storage of Payer ID
I IBBILL D UPDTBILL() G UPDQ
;
; Batch - update each bill separately
S IBBILL=""
F S IBBILL=$O(^IBA(364,"ABABI",+IBBTCH,IBBILL)) Q:'IBBILL D
. Q:$D(^TMP("IBCONF",$J,IBBILL)) ;Bill was rejected
. S IB=$O(^IBA(364,"ABABI",+IBBTCH,IBBILL,0))
. Q:'IB
. D UPDTBILL() ;KDM US129 IB*2*577 Correct Storage of PAYER ID
;
Q
;
UPDTBILL() ;KDM US129 IB*2*577 New section to Correct Storage of PAYER ID
N IBA1,IBMSG0,IBPID
S IBPID="",IBA1=0
;
F S IBA1=$O(^IBA(364.2,IBTDA,2,IBA1)) Q:'IBA1 D Q:IBPID]""
. S IBMSG0=$P($G(^(IBA1,0)),"##RAW DATA: ",2)
. I +IBMSG0=277,$P(IBMSG0,U,5)="N" S IBPID=$P(IBMSG0,U,11)
;
S IBSEQ=$P(IB00,U,8) S:IBSEQ="" IBSEQ="P"
D STORE(IB0,IBBTCH,IBMNUM,IBTDA,IBBILL,IBSEQ,IBPID,1)
Q
;
STORE(IB0,IBBTCH,IBMNUM,IBTDA,IBBILL,IBSEQ,IBPID,IB1) ;
;
; IB0 = 0-node of message in file 364.2
; IBBTCH = ien of batch in file 364.1
; IBMNUM = actual message number
; IBTDA = ien of message in file 364.2
; IBBILL = ien of bill in 399
; IBSEQ = P/S/T/ for COB sequence related to message
; IBPID = the payer id returned from clearinghouse for the claim
; IB1 = flag that says if the message was for a single bill or a batch.
; Batch statuses have an additional standard text entry.
; 1 = single bill 0 = batch
;
N DA,DIK,DIE,DIC,X,Y,DR,DO,DD,DLAYGO,Z,Z0,Z1,Z2,Z3,IBT,IBDUP,IBFLDS,IBY,IBAUTO,IBLN
;
S X=IBBILL,IBDUP=0
;
S IBFLDS=".02////"_$P(IB0,U,3)
S IBFLDS=IBFLDS_";.03////"_$S($$EXTERNAL^DILFD(364.2,.02,"U",$P(IB0,U,2))["REJ":"R",1:"I")_";.05////"_IBBTCH_";.06////"_IBMNUM_";.04////"_+$P(IB0,U,8)_";.07////"_IBSEQ_$S($P(IB0,U,5):";.11////"_$P(IB0,U,5),1:"")
S IBFLDS=IBFLDS_";.12////"_$P(IB0,U,10)_";.09////0"
S IBFLDS=IBFLDS_";.15////"_$$CHKSUM^IBCEST1("^IBA(364.2,"_IBTDA_",2)")
I IBPID'="" D
. ;JWS;IB*2.0*592;Dental Form 7
. S IBPID("TYPE")=$S($$FT^IBCEF(IBBILL)=2:"P",$$FT^IBCEF(IBBILL)=7:"D",1:"I")
. D UPDINS(.IBPID,$$POLICY^IBCEF(IBBILL,1,$TR(IBSEQ,"PST","123")),IBBILL,IBTDA) ;KDM US129 IB*2*577
;
I IBDUP D I $D(Y) G UPDQ
. ; Stuff fields into existing entry
. ; (may be needed for reprocessing of aborted updates)
. S DIE="^IBM(361,",DA=IBDUP,DR=IBFLDS_";1///@"
. D ^DIE
. I $D(Y) S IBY=-1 Q ;Update not successful
. S IBY=IBDUP
;
K IBT
I 'IBDUP D ; Create new entry and stuff fields
. S DIC(0)="L",DIC="^IBM(361,",DLAYGO=361
. S DIC("DR")=IBFLDS
. D FILE^DICN
. K DO,DD,DLAYGO,DIC
. S IBY=+Y
. Q:IBY'>0
. ;
. ; IB*2*320 - Check for duplicate status message
. NEW IBNEW,IBOLD,PCE,Z,DIK,DA
. S IBNEW=""
. F PCE=3,4,5,7,8,11,15 S IBNEW=IBNEW_$P($G(^IBM(361,IBY,0)),U,PCE)_U
. S Z=0
. F S Z=$O(^IBM(361,"B",IBBILL,Z)) Q:'Z I Z'=IBY D Q:IBY'>0
.. S IBOLD=""
.. F PCE=3,4,5,7,8,11,15 S IBOLD=IBOLD_$P($G(^IBM(361,Z,0)),U,PCE)_U
.. I IBNEW'=IBOLD Q ; no duplicate so get the next one
.. S DIK="^IBM(361,",DA=IBY,IBY=-1 D ^DIK D DELMSG^IBCESRV2(IBTDA)
.. Q
. Q
;
I IBY>0 D ;Move text over
. K IBT
. ;
. D BLDMSG(IB1,IBTDA,.IBT,.IBAUTO)
. ;
. ; IB*2*368 - ymg - 2Q,RE,RP messages will be filed as informational
. ; Z0 is the flag for 2Q code
. ; Z1 is the flag for RE code
. ; Z2 is the flag for RP code
. ; Z3 is the flag for autofiling the message
. I $P($G(^IBM(361,+IBY,0)),U,3)="R" D
.. S Z="",(Z0,Z1,Z2,Z3)=0 F S Z=$O(IBT(Z)) Q:Z=""!(Z3=1) D
... S IBLN=$$UP^XLFSTR($G(IBT(Z)))
... I (Z0!Z1!Z2)=0 D
.... S:IBLN?.E1"CODE:".P1"2Q".E Z0=1
.... S:IBLN?.E1"CODE:".P1"RE".E Z1=1
.... S:IBLN?.E1"CODE:".P1"RP".E Z2=1
... I Z0=1 S:IBLN?.P1"CLAIM".P1"REJECTED".P1"BY".P1"CLEARINGHOUSE".E Z3=1
... I Z1=1 S:IBLN?.P1"ELECTRONIC".P1"CLAIM".P1"REJECTED".P1"BY".P1"EMDEON".E Z3=1
... I Z2=1 S:IBLN?.P1"PAPER".P1"CLAIM".P1"REJECTED".P1"BY".P1"EMDEON".E Z3=1
.. I Z3=1 S IBAUTO=1,DIE=361,DA=+IBY,DR=".03////I" D ^DIE
.. Q
. ;
. ; if info msg, ck for no review needed based on first line of text
. I $G(IBAUTO),$P($G(^IBM(361,+IBY,0)),U,3)="I" D
.. S DIE="^IBM(361,",DR=".09////2;.14////1;.1////F",DA=+IBY D ^DIE
.. I IB1,$P($G(^IBM(361,+IBY,0)),U,11) S Z="",Z0=0 F S Z=$O(IBT(Z)) Q:Z=""!(Z0=1) D
... S Z0=$$PRINTUPD^IBCEU0($$UP^XLFSTR($G(IBT(Z))),$P($G(^IBM(361,+IBY,0)),U,11))
. ;
. D MSGLNSZ(.IBT) ; Convert Message Lines in IBT to be no longer than 70 chars
. D WP^DIE(361,+IBY_",",1,"A","IBT") ; file message text
. ;
. ; Delete message after it successfully updates the database.
. D DELMSG^IBCESRV2(IBTDA)
. Q
;
UPDQ L -^IBA(364.2,IBTDA,0)
Q
;
BLDMSG(IB1,IBTDA,IBT,IBAUTO) ; Builds message text
; IB1 = flag for batch message
; IBTDA = ien of entry in file 364.2
; IBT = array returned with message text
; IBAUTO = if passed by reference, returns 1 if text indicates review
; not needed
N IBDATA,IBCK,IBZ,IBZ0,IBZ1,Z
S (IBZ,IBZ0,IBDATA,IBAUTO,IBCK)=0
I 'IB1 S IBT(1)="Status message received for batch "_$P($G(^IBA(364.1,IBBTCH,0)),U)_" dated "_$$FMTE^XLFDT($P($G(^IBA(364.2,IBTDA,0)),U,10),2),IBZ0=1
; Don't move the raw data over, just move the text of the message
F S IBZ=$O(^IBA(364.2,IBTDA,2,IBZ)) Q:'IBZ S IBZ1=$G(^(IBZ,0)) S IBDATA=($E(IBZ1,1,2)="##") Q:IBDATA S IBZ0=IBZ0+1,IBT(IBZ0)=IBZ1 I 'IBCK S Z=$$CKREVU^IBCEM4(IBZ1,,,.IBCK),IBAUTO=$S(IBCK:0,Z:1,1:IBAUTO)
Q
;
UPDINS(IBPID,IBINS,IBIFN,IBTDA) ;KDM US129 IB*2*577
; Update the insurance id or the bill printed at
; the EDI contractor's print shop and mailed to the ins co.
; IBPID = the id returned from the EDI contractor for the ins co
; ("TYPE") = P if professional id or I if institutional id or D if Dental
; IBINS = the ien of the insurance co it was sent to (file 36)
; IBIFN = the ien of the claim (file 399)
; IBTDA = ien of entry in file 364.2 ;KDM US129 IB*2*577
;
;N IBID,IBIDFLD,IBPRT,IBLOOK,DA,DR,DIE,X,Y,Z,UPD ;KDM US129 IB*2*577
N DA,DIE,DONE,DR,HAVONE,IBHOLD,IBID,IBIDFLD,IBIDQ,IBPRT,IBLOOK,IBPID69,IBQUAL,IBSID,II,UPDATE,X,Y,Z ; vd US3994 - IB*2*623
;
Q:'$G(IBINS)!($G(IBPID)="")
;
; Strip spaces off the end of data
S IBLOOK=""
;I $L(IBPID) F Z=$L(IBPID):-1:1 I $E(IBPID,Z)'=" " S IBLOOK=$E(IBPID,1,Z) Q
;
;S IBPRT=($E(IBLOOK,2,5)="PRNT")
I $L(IBPID) F Z=$L(IBPID):-1:1 I $E(IBPID,Z)'=" " S IBHOLD=$E(IBPID,1,Z) Q ; vd US3994 - IB*2*623
;
S IBPRT=($E(IBHOLD,2,5)="PRNT") ; vd US3994 - IB*2*623
I IBPRT D ; Set printed via EDI field on bill
. S DA=IBIFN,DIE="^DGCR(399,",DR="26////1" D ^DIE
;
; KDM US129 IB*2*577 correct payer ID storage
;S IBLOOK=$E($S('IBPRT:$P(IBLOOK,"PAYID=",2),1:""),1,5)
;Q:IBLOOK=""!($E(IBLOOK,2,5)="PRNT")
I IBPRT Q
I IBHOLD'["PAYID=",IBHOLD'["COBID=" Q ; vd US3994 IB*2*623
S IBLOOK=$E($P(IBHOLD,"ID=",2),1,5) ; vd US3994 IB*2*623
Q:IBLOOK=""
;
;/vd IB*2*623 (US3994) - Beginning
S IBDATE=DT,IBTYP=$G(IBPID("TYPE")),IBPID69=$E(IBPID,6,9),UPDATE=1
S (IBID,IBIDQ)=""
I "^I^P^"[(U_IBTYP_U),IBHOLD["COBID=",IBPID69'="0000" D ; Update the CLM-OFC-IDs for I & P only with valid Secondary Payer IDs.
. S IBQUAL(1)=$S(IBTYP="I":6.01,1:6.05),IBQUAL(2)=$S(IBTYP="I":6.03,1:6.07) ; Get appropriate Qualifier field numbers.
. S IBSID(1)=$S(IBTYP="I":6.02,1:6.06),IBSID(2)=$S(IBTYP="I":6.04,1:6.08) ; Get appropriate Current Secondary Payer IDs.
. S (DONE,HAVONE)=0
. F II=1,2 D Q:((+DONE)!(+HAVONE)) ; PROCESS THRU BOTH SECONDARY PAYER IDS OR UNTIL WE PERFORMED AN UPDATE.
. . S IBIDQ=$$GET1^DIQ(36,+IBINS,IBQUAL(II),"I") ; Get the current qualifier value
. . S IBID=$$GET1^DIQ(36,+IBINS,IBSID(II),"I") ; Get the current id value
. . I IBIDQ="FY" S HAVONE=1 Q ; Already have a Claim Office ID.
. . I IBIDQ="" D Q ; Current value doesn't exists.okay to update.
. . . S DIE="^DIC(36,",DR=IBSID(II)_"////"_IBPID69_";"_IBQUAL(II)_"////FY",DA=IBINS D ^DIE ; Update the CLM-OFC-ID and Qualifier fields.
. . . D UPDLOG(1,IBDATE,IBINS,IBPID69,IBTYP_"2",IBID) ; Log the CLM-OFC-ID "UPDATE".
. . . S DONE=1 ; Success. Updated one so we can quit out.
. . . Q
. ; Should only get to the following line if no update was accomplished because there was no available room to add an "FY".
. I '+DONE D UPDLOG(0,IBDATE,IBINS,IBPID69,IBTYP_"2",$S(+HAVONE:IBID,1:"*N/A FULL")) ; Log the CLM-OFC-ID "ATTEMPT"
. Q
;/vd IB*2*623 (US3994) - End
;
S IBIDFLD="3.0"_$S($G(IBPID("TYPE"))="I":4,1:2)
;JWS;IB*2.0*592;Dental
I $G(IBPID("TYPE"))="D" S IBIDFLD=3.15
S IBID=$P($G(^DIC(36,+IBINS,3)),U,IBIDFLD*100#100)
Q:IBID=IBLOOK
;/vd IB*2*623 (US3994) Moved the following line up prior to some new lines of code.
; S IBDATE=DT,IBTYP=$G(IBPID("TYPE")) ;KDM US129 IB*2*577
I IBID="" D G UPDINSQ ; Update insurance co electronic id # if blank
. S DIE="^DIC(36,",DR=IBIDFLD_"////"_IBLOOK,DA=IBINS D ^DIE
. D UPDLOG(1,IBDATE,IBINS,IBLOOK,IBTYP,IBID) ;KDM US129 IB*2*577
I IBID'="",IBLOOK'="" D ; Bulletin that the id on file and id returned
. ; are different
. N XMTO,XMDUZ,XMBODY,IBXM,XMSUBJ,XMZ
. S XMTO("I:G.IB EDI")=""
. S XMDUZ="",XMBODY="IBXM",XMSUBJ="PAYER ID RETURNED IS DIFFERENT THAN PAYER ID ON FILE"
. S IBXM(1)="BILL # : "_$P($G(^DGCR(399,IBIFN,0)),U)
. S IBXM(2)="PAYER : "_$P($G(^DIC(36,+IBINS,0)),U)
. ;JWS;IB*2.0*592;Dental
. S IBXM(3)="BILL TYPE : "_$S($G(IBPID("TYPE"))="I":"INSTITUTIONAL",$G(IBPID("TYPE"))="D":"DENTAL",1:"PROFESSIONAL")
. S IBXM(4)="ID ON FILE : "_IBID
. S IBXM(5)="ID RETURNED: "_IBLOOK
. S IBXM(6)=" ",IBXM(7)=" Please determine which id number is correct and correct the id in the",IBXM(8)="insurance file for this payer, if needed"
. D SENDMSG^XMXAPI(XMDUZ,XMSUBJ,XMBODY,.XMTO,,.XMZ)
. D UPDLOG(0,IBDATE,IBINS,IBLOOK,IBTYP,IBID) ;KDM US129, US976 IB*2*577
;
UPDINSQ Q
;
UPDLOG(UPD,IBDATE,IBINS,IBLOOK,IBTYP,IBID) ;KDM US129, US976 IB*2*577 New section for New Payer Report
; store flds for reporting purposes when updating or attempting to update Payer information (US129)
; ^DIC(36 -17.0 277EDI ID Number
; 17.01 277EDI ID Number
; 17.02 277Date EDI ID Number
; 17.03 277EDI Type (P)ROF or (I)nst or (D)ental
; 17.04 277EDI ID NUMBER ON FILE ;if blank it was an update otherwise it was an attempted update.
;
Q:(($D(^DIC(36,"AEDIX",IBDATE,IBINS,IBLOOK,IBTYP)))&(UPD=0)) ;store only one attempt a day
N ERROR,IBFDA,LEV
S LEV="+2,"_IBINS_","
S IBFDA(36.017,LEV,.01)=IBLOOK ;New Value from 277STAT
S IBFDA(36.017,LEV,.02)=IBDATE ;Date transaction is processed
S IBFDA(36.017,LEV,.03)=IBTYP ;"P" or "I" for "EDI-PayerID, or "P2" or "I2" for CLM-OFC-ID
S IBFDA(36.017,LEV,.04)=$G(IBID) ;Value already on file- if blank it was an update, otherwise attempted update
D UPDATE^DIE("","IBFDA","","ERROR")
Q
;
MSGLNSZ(MSG) ; Change Input Message Lines to be no more than 70 characters long each
;
; Input/Output: MSG - array of Input Message Lines; this is also the Output Message
; which is an array of Converted Message Lines (with lines no more than 70 chars each)
;
N LN,XARY,XARYLN,CNT,OUTMSG,TMPMSG,LDNGSP,LDNGSPN
S LN="",CNT=0 F S LN=$O(MSG(LN)) Q:LN="" D ;
. ; Find any leading spaces in original message line,
. ; to be used if line got split below
. S TMPMSG=$$TRIM^XLFSTR(MSG(LN),"L"," ") ;Trim Leading Spaces
. S LDNGSP=$P(MSG(LN),TMPMSG,1) ;get leading spaces if any
. S LDNGSPN=$L(LDNGSP) S:LDNGSPN>30 LDNGSP=$E(LDNGSP,1,30) ;make sure there are no more than 30 leading spaces
. ; Converts a single line to multiple lines with a maximum width of 70 each
. ; If line is 70 chars or less, this call returns the exact line
. K XARY D FSTRNG^IBJU1(TMPMSG,70-LDNGSPN,.XARY)
. ; Scan lines and merge them into the final output array (OUTMSG)
. ; On lines 2 and higher, add Leading Spaces found above, if any.
. S XARYLN="" F S XARYLN=$O(XARY(XARYLN)) Q:XARYLN="" S CNT=CNT+1,OUTMSG(CNT)=LDNGSP_XARY(XARYLN)
;
; Move the final Message Lines (OUTMSG) into MSG array to be returned
K MSG M MSG=OUTMSG
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBCEST 13437 printed Dec 13, 2024@02:12:28 Page 2
IBCEST ;ALB/TMP - 837 EDI STATUS MESSAGE PROCESSING ;17-APR-96
+1 ;;2.0;INTEGRATED BILLING;**137,189,197,135,283,320,368,397,407,577,592,623**;21-MAR-94;Build 70
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ; IA 4043 for call to AUDITX^PRCAUDT
+4 QUIT
+5 ;
UPD361(IBTDA) ; Update IB BILL STATUS MESSAGES file
+1 ; IBTDA = ien of return message in file 364.2
+2 ;
+3 NEW IB,IB0,IBSEQ,IB00,IBBILL,IBBTCH,IBMNUM,IBDATE,IBTYP
+4 ;
+5 ;Lock message in file 364.2
IF '$$LOCK^IBCEM(IBTDA)
GOTO UPDQ
+6 ;
+7 SET IB0=$GET(^IBA(364.2,IBTDA,0))
+8 ; Message number
SET IBMNUM=$PIECE(IB0,U)
+9 ; Transmit bill entry
SET IB00=$GET(^IBA(364,+$PIECE(IB0,U,5),0))
+10 ; Actual bill ien in file 399
SET IBBILL=+IB00
+11 ; Batch #
SET IBBTCH=$PIECE(IB0,U,4)
+12 ;
+13 ; Auto-audit bills based on status code on '10' record of status msg
+14 ; flat file
+15 IF IBBILL
IF $PIECE($TEXT(PRCAUDT+1^PRCAUDT),"**",2)[",173"
Begin DoDot:1
+16 NEW Z,Z0,Z1,OK
+17 if +$$STA^PRCAFN(IBBILL)'=104
QUIT
+18 SET (Z,OK)=0
+19 FOR
SET Z=$ORDER(^IBA(364.2,IBTDA,2,Z))
if 'Z
QUIT
SET Z0=$PIECE($GET(^(Z,0)),"##RAW DATA: ",2)
IF +Z0=10
SET Z0=$PIECE(Z0,U,5)
Begin DoDot:2
+20 ; Strip leading spaces
+21 SET Z0=$$TRIM^XLFSTR(Z0)
+22 if Z0=""
QUIT
+23 ; IA 4043
IF $$SCODE^IBCEST1(Z0)
IF $PIECE($GET(^DGCR(399.3,+$PIECE($GET(^DGCR(399,IBBILL,0)),U,7),0)),U,11)
DO AUDITX^PRCAUDT(IBBILL)
SET OK=1
End DoDot:2
if OK
QUIT
End DoDot:1
+24 ;
+25 IF $SELECT(IBMNUM="":1,1:'IBBILL&(IBBTCH=""))
DO DELMSG^IBCESRV2(IBTDA)
GOTO UPDQ
+26 ;
+27 ; Individual bill ; KDM US129 IB*2*577 rework Individual vs. Batch to Correct Storage of Payer ID
+28 IF IBBILL
DO UPDTBILL()
GOTO UPDQ
+29 ;
+30 ; Batch - update each bill separately
+31 SET IBBILL=""
+32 FOR
SET IBBILL=$ORDER(^IBA(364,"ABABI",+IBBTCH,IBBILL))
if 'IBBILL
QUIT
Begin DoDot:1
+33 ;Bill was rejected
if $DATA(^TMP("IBCONF",$JOB,IBBILL))
QUIT
+34 SET IB=$ORDER(^IBA(364,"ABABI",+IBBTCH,IBBILL,0))
+35 if 'IB
QUIT
+36 ;KDM US129 IB*2*577 Correct Storage of PAYER ID
DO UPDTBILL()
End DoDot:1
+37 ;
+38 QUIT
+39 ;
UPDTBILL() ;KDM US129 IB*2*577 New section to Correct Storage of PAYER ID
+1 NEW IBA1,IBMSG0,IBPID
+2 SET IBPID=""
SET IBA1=0
+3 ;
+4 FOR
SET IBA1=$ORDER(^IBA(364.2,IBTDA,2,IBA1))
if 'IBA1
QUIT
Begin DoDot:1
+5 SET IBMSG0=$PIECE($GET(^(IBA1,0)),"##RAW DATA: ",2)
+6 IF +IBMSG0=277
IF $PIECE(IBMSG0,U,5)="N"
SET IBPID=$PIECE(IBMSG0,U,11)
End DoDot:1
if IBPID]""
QUIT
+7 ;
+8 SET IBSEQ=$PIECE(IB00,U,8)
if IBSEQ=""
SET IBSEQ="P"
+9 DO STORE(IB0,IBBTCH,IBMNUM,IBTDA,IBBILL,IBSEQ,IBPID,1)
+10 QUIT
+11 ;
STORE(IB0,IBBTCH,IBMNUM,IBTDA,IBBILL,IBSEQ,IBPID,IB1) ;
+1 ;
+2 ; IB0 = 0-node of message in file 364.2
+3 ; IBBTCH = ien of batch in file 364.1
+4 ; IBMNUM = actual message number
+5 ; IBTDA = ien of message in file 364.2
+6 ; IBBILL = ien of bill in 399
+7 ; IBSEQ = P/S/T/ for COB sequence related to message
+8 ; IBPID = the payer id returned from clearinghouse for the claim
+9 ; IB1 = flag that says if the message was for a single bill or a batch.
+10 ; Batch statuses have an additional standard text entry.
+11 ; 1 = single bill 0 = batch
+12 ;
+13 NEW DA,DIK,DIE,DIC,X,Y,DR,DO,DD,DLAYGO,Z,Z0,Z1,Z2,Z3,IBT,IBDUP,IBFLDS,IBY,IBAUTO,IBLN
+14 ;
+15 SET X=IBBILL
SET IBDUP=0
+16 ;
+17 SET IBFLDS=".02////"_$PIECE(IB0,U,3)
+18 SET IBFLDS=IBFLDS_";.03////"_$SELECT($$EXTERNAL^DILFD(364.2,.02,"U",$PIECE(IB0,U,2))["REJ":"R",1:"I")_";.05////"_IBBTCH_";.06////"_IBMNUM_";.04////"_+$PIECE(IB0,U,8)_";.07////"_IBSEQ_$SELECT($PIECE(IB0,U,5):";.11////"_$PIECE(IB0,U,5),1:"")
+19 SET IBFLDS=IBFLDS_";.12////"_$PIECE(IB0,U,10)_";.09////0"
+20 SET IBFLDS=IBFLDS_";.15////"_$$CHKSUM^IBCEST1("^IBA(364.2,"_IBTDA_",2)")
+21 IF IBPID'=""
Begin DoDot:1
+22 ;JWS;IB*2.0*592;Dental Form 7
+23 SET IBPID("TYPE")=$SELECT($$FT^IBCEF(IBBILL)=2:"P",$$FT^IBCEF(IBBILL)=7:"D",1:"I")
+24 ;KDM US129 IB*2*577
DO UPDINS(.IBPID,$$POLICY^IBCEF(IBBILL,1,$TRANSLATE(IBSEQ,"PST","123")),IBBILL,IBTDA)
End DoDot:1
+25 ;
+26 IF IBDUP
Begin DoDot:1
+27 ; Stuff fields into existing entry
+28 ; (may be needed for reprocessing of aborted updates)
+29 SET DIE="^IBM(361,"
SET DA=IBDUP
SET DR=IBFLDS_";1///@"
+30 DO ^DIE
+31 ;Update not successful
IF $DATA(Y)
SET IBY=-1
QUIT
+32 SET IBY=IBDUP
End DoDot:1
IF $DATA(Y)
GOTO UPDQ
+33 ;
+34 KILL IBT
+35 ; Create new entry and stuff fields
IF 'IBDUP
Begin DoDot:1
+36 SET DIC(0)="L"
SET DIC="^IBM(361,"
SET DLAYGO=361
+37 SET DIC("DR")=IBFLDS
+38 DO FILE^DICN
+39 KILL DO,DD,DLAYGO,DIC
+40 SET IBY=+Y
+41 if IBY'>0
QUIT
+42 ;
+43 ; IB*2*320 - Check for duplicate status message
+44 NEW IBNEW,IBOLD,PCE,Z,DIK,DA
+45 SET IBNEW=""
+46 FOR PCE=3,4,5,7,8,11,15
SET IBNEW=IBNEW_$PIECE($GET(^IBM(361,IBY,0)),U,PCE)_U
+47 SET Z=0
+48 FOR
SET Z=$ORDER(^IBM(361,"B",IBBILL,Z))
if 'Z
QUIT
IF Z'=IBY
Begin DoDot:2
+49 SET IBOLD=""
+50 FOR PCE=3,4,5,7,8,11,15
SET IBOLD=IBOLD_$PIECE($GET(^IBM(361,Z,0)),U,PCE)_U
+51 ; no duplicate so get the next one
IF IBNEW'=IBOLD
QUIT
+52 SET DIK="^IBM(361,"
SET DA=IBY
SET IBY=-1
DO ^DIK
DO DELMSG^IBCESRV2(IBTDA)
+53 QUIT
End DoDot:2
if IBY'>0
QUIT
+54 QUIT
End DoDot:1
+55 ;
+56 ;Move text over
IF IBY>0
Begin DoDot:1
+57 KILL IBT
+58 ;
+59 DO BLDMSG(IB1,IBTDA,.IBT,.IBAUTO)
+60 ;
+61 ; IB*2*368 - ymg - 2Q,RE,RP messages will be filed as informational
+62 ; Z0 is the flag for 2Q code
+63 ; Z1 is the flag for RE code
+64 ; Z2 is the flag for RP code
+65 ; Z3 is the flag for autofiling the message
+66 IF $PIECE($GET(^IBM(361,+IBY,0)),U,3)="R"
Begin DoDot:2
+67 SET Z=""
SET (Z0,Z1,Z2,Z3)=0
FOR
SET Z=$ORDER(IBT(Z))
if Z=""!(Z3=1)
QUIT
Begin DoDot:3
+68 SET IBLN=$$UP^XLFSTR($GET(IBT(Z)))
+69 IF (Z0!Z1!Z2)=0
Begin DoDot:4
+70 if IBLN?.E1"CODE
SET Z0=1
+71 if IBLN?.E1"CODE
SET Z1=1
+72 if IBLN?.E1"CODE
SET Z2=1
End DoDot:4
+73 IF Z0=1
if IBLN?.P1"CLAIM".P1"REJECTED".P1"BY".P1"CLEARINGHOUSE".E
SET Z3=1
+74 IF Z1=1
if IBLN?.P1"ELECTRONIC".P1"CLAIM".P1"REJECTED".P1"BY".P1"EMDEON".E
SET Z3=1
+75 IF Z2=1
if IBLN?.P1"PAPER".P1"CLAIM".P1"REJECTED".P1"BY".P1"EMDEON".E
SET Z3=1
End DoDot:3
+76 IF Z3=1
SET IBAUTO=1
SET DIE=361
SET DA=+IBY
SET DR=".03////I"
DO ^DIE
+77 QUIT
End DoDot:2
+78 ;
+79 ; if info msg, ck for no review needed based on first line of text
+80 IF $GET(IBAUTO)
IF $PIECE($GET(^IBM(361,+IBY,0)),U,3)="I"
Begin DoDot:2
+81 SET DIE="^IBM(361,"
SET DR=".09////2;.14////1;.1////F"
SET DA=+IBY
DO ^DIE
+82 IF IB1
IF $PIECE($GET(^IBM(361,+IBY,0)),U,11)
SET Z=""
SET Z0=0
FOR
SET Z=$ORDER(IBT(Z))
if Z=""!(Z0=1)
QUIT
Begin DoDot:3
+83 SET Z0=$$PRINTUPD^IBCEU0($$UP^XLFSTR($GET(IBT(Z))),$PIECE($GET(^IBM(361,+IBY,0)),U,11))
End DoDot:3
End DoDot:2
+84 ;
+85 ; Convert Message Lines in IBT to be no longer than 70 chars
DO MSGLNSZ(.IBT)
+86 ; file message text
DO WP^DIE(361,+IBY_",",1,"A","IBT")
+87 ;
+88 ; Delete message after it successfully updates the database.
+89 DO DELMSG^IBCESRV2(IBTDA)
+90 QUIT
End DoDot:1
+91 ;
UPDQ LOCK -^IBA(364.2,IBTDA,0)
+1 QUIT
+2 ;
BLDMSG(IB1,IBTDA,IBT,IBAUTO) ; Builds message text
+1 ; IB1 = flag for batch message
+2 ; IBTDA = ien of entry in file 364.2
+3 ; IBT = array returned with message text
+4 ; IBAUTO = if passed by reference, returns 1 if text indicates review
+5 ; not needed
+6 NEW IBDATA,IBCK,IBZ,IBZ0,IBZ1,Z
+7 SET (IBZ,IBZ0,IBDATA,IBAUTO,IBCK)=0
+8 IF 'IB1
SET IBT(1)="Status message received for batch "_$PIECE($GET(^IBA(364.1,IBBTCH,0)),U)_" dated "_$$FMTE^XLFDT($PIECE($GET(^IBA(364.2,IBTDA,0)),U,10),2)
SET IBZ0=1
+9 ; Don't move the raw data over, just move the text of the message
+10 FOR
SET IBZ=$ORDER(^IBA(364.2,IBTDA,2,IBZ))
if 'IBZ
QUIT
SET IBZ1=$GET(^(IBZ,0))
SET IBDATA=($EXTRACT(IBZ1,1,2)="##")
if IBDATA
QUIT
SET IBZ0=IBZ0+1
SET IBT(IBZ0)=IBZ1
IF 'IBCK
SET Z=$$CKREVU^IBCEM4(IBZ1,,,.IBCK)
SET IBAUTO=$SELECT(IBCK:0,Z:1,1:IBAUTO)
+11 QUIT
+12 ;
UPDINS(IBPID,IBINS,IBIFN,IBTDA) ;KDM US129 IB*2*577
+1 ; Update the insurance id or the bill printed at
+2 ; the EDI contractor's print shop and mailed to the ins co.
+3 ; IBPID = the id returned from the EDI contractor for the ins co
+4 ; ("TYPE") = P if professional id or I if institutional id or D if Dental
+5 ; IBINS = the ien of the insurance co it was sent to (file 36)
+6 ; IBIFN = the ien of the claim (file 399)
+7 ; IBTDA = ien of entry in file 364.2 ;KDM US129 IB*2*577
+8 ;
+9 ;N IBID,IBIDFLD,IBPRT,IBLOOK,DA,DR,DIE,X,Y,Z,UPD ;KDM US129 IB*2*577
+10 ; vd US3994 - IB*2*623
NEW DA,DIE,DONE,DR,HAVONE,IBHOLD,IBID,IBIDFLD,IBIDQ,IBPRT,IBLOOK,IBPID69,IBQUAL,IBSID,II,UPDATE,X,Y,Z
+11 ;
+12 if '$GET(IBINS)!($GET(IBPID)="")
QUIT
+13 ;
+14 ; Strip spaces off the end of data
+15 SET IBLOOK=""
+16 ;I $L(IBPID) F Z=$L(IBPID):-1:1 I $E(IBPID,Z)'=" " S IBLOOK=$E(IBPID,1,Z) Q
+17 ;
+18 ;S IBPRT=($E(IBLOOK,2,5)="PRNT")
+19 ; vd US3994 - IB*2*623
IF $LENGTH(IBPID)
FOR Z=$LENGTH(IBPID):-1:1
IF $EXTRACT(IBPID,Z)'=" "
SET IBHOLD=$EXTRACT(IBPID,1,Z)
QUIT
+20 ;
+21 ; vd US3994 - IB*2*623
SET IBPRT=($EXTRACT(IBHOLD,2,5)="PRNT")
+22 ; Set printed via EDI field on bill
IF IBPRT
Begin DoDot:1
+23 SET DA=IBIFN
SET DIE="^DGCR(399,"
SET DR="26////1"
DO ^DIE
End DoDot:1
+24 ;
+25 ; KDM US129 IB*2*577 correct payer ID storage
+26 ;S IBLOOK=$E($S('IBPRT:$P(IBLOOK,"PAYID=",2),1:""),1,5)
+27 ;Q:IBLOOK=""!($E(IBLOOK,2,5)="PRNT")
+28 IF IBPRT
QUIT
+29 ; vd US3994 IB*2*623
IF IBHOLD'["PAYID="
IF IBHOLD'["COBID="
QUIT
+30 ; vd US3994 IB*2*623
SET IBLOOK=$EXTRACT($PIECE(IBHOLD,"ID=",2),1,5)
+31 if IBLOOK=""
QUIT
+32 ;
+33 ;/vd IB*2*623 (US3994) - Beginning
+34 SET IBDATE=DT
SET IBTYP=$GET(IBPID("TYPE"))
SET IBPID69=$EXTRACT(IBPID,6,9)
SET UPDATE=1
+35 SET (IBID,IBIDQ)=""
+36 ; Update the CLM-OFC-IDs for I & P only with valid Secondary Payer IDs.
IF "^I^P^"[(U_IBTYP_U)
IF IBHOLD["COBID="
IF IBPID69'="0000"
Begin DoDot:1
+37 ; Get appropriate Qualifier field numbers.
SET IBQUAL(1)=$SELECT(IBTYP="I":6.01,1:6.05)
SET IBQUAL(2)=$SELECT(IBTYP="I":6.03,1:6.07)
+38 ; Get appropriate Current Secondary Payer IDs.
SET IBSID(1)=$SELECT(IBTYP="I":6.02,1:6.06)
SET IBSID(2)=$SELECT(IBTYP="I":6.04,1:6.08)
+39 SET (DONE,HAVONE)=0
+40 ; PROCESS THRU BOTH SECONDARY PAYER IDS OR UNTIL WE PERFORMED AN UPDATE.
FOR II=1,2
Begin DoDot:2
+41 ; Get the current qualifier value
SET IBIDQ=$$GET1^DIQ(36,+IBINS,IBQUAL(II),"I")
+42 ; Get the current id value
SET IBID=$$GET1^DIQ(36,+IBINS,IBSID(II),"I")
+43 ; Already have a Claim Office ID.
IF IBIDQ="FY"
SET HAVONE=1
QUIT
+44 ; Current value doesn't exists.okay to update.
IF IBIDQ=""
Begin DoDot:3
+45 ; Update the CLM-OFC-ID and Qualifier fields.
SET DIE="^DIC(36,"
SET DR=IBSID(II)_"////"_IBPID69_";"_IBQUAL(II)_"////FY"
SET DA=IBINS
DO ^DIE
+46 ; Log the CLM-OFC-ID "UPDATE".
DO UPDLOG(1,IBDATE,IBINS,IBPID69,IBTYP_"2",IBID)
+47 ; Success. Updated one so we can quit out.
SET DONE=1
+48 QUIT
End DoDot:3
QUIT
End DoDot:2
if ((+DONE)!(+HAVONE))
QUIT
+49 ; Should only get to the following line if no update was accomplished because there was no available room to add an "FY".
+50 ; Log the CLM-OFC-ID "ATTEMPT"
IF '+DONE
DO UPDLOG(0,IBDATE,IBINS,IBPID69,IBTYP_"2",$SELECT(+HAVONE:IBID,1:"*N/A FULL"))
+51 QUIT
End DoDot:1
+52 ;/vd IB*2*623 (US3994) - End
+53 ;
+54 SET IBIDFLD="3.0"_$SELECT($GET(IBPID("TYPE"))="I":4,1:2)
+55 ;JWS;IB*2.0*592;Dental
+56 IF $GET(IBPID("TYPE"))="D"
SET IBIDFLD=3.15
+57 SET IBID=$PIECE($GET(^DIC(36,+IBINS,3)),U,IBIDFLD*100#100)
+58 if IBID=IBLOOK
QUIT
+59 ;/vd IB*2*623 (US3994) Moved the following line up prior to some new lines of code.
+60 ; S IBDATE=DT,IBTYP=$G(IBPID("TYPE")) ;KDM US129 IB*2*577
+61 ; Update insurance co electronic id # if blank
IF IBID=""
Begin DoDot:1
+62 SET DIE="^DIC(36,"
SET DR=IBIDFLD_"////"_IBLOOK
SET DA=IBINS
DO ^DIE
+63 ;KDM US129 IB*2*577
DO UPDLOG(1,IBDATE,IBINS,IBLOOK,IBTYP,IBID)
End DoDot:1
GOTO UPDINSQ
+64 ; Bulletin that the id on file and id returned
IF IBID'=""
IF IBLOOK'=""
Begin DoDot:1
+65 ; are different
+66 NEW XMTO,XMDUZ,XMBODY,IBXM,XMSUBJ,XMZ
+67 SET XMTO("I:G.IB EDI")=""
+68 SET XMDUZ=""
SET XMBODY="IBXM"
SET XMSUBJ="PAYER ID RETURNED IS DIFFERENT THAN PAYER ID ON FILE"
+69 SET IBXM(1)="BILL # : "_$PIECE($GET(^DGCR(399,IBIFN,0)),U)
+70 SET IBXM(2)="PAYER : "_$PIECE($GET(^DIC(36,+IBINS,0)),U)
+71 ;JWS;IB*2.0*592;Dental
+72 SET IBXM(3)="BILL TYPE : "_$SELECT($GET(IBPID("TYPE"))="I":"INSTITUTIONAL",$GET(IBPID("TYPE"))="D":"DENTAL",1:"PROFESSIONAL")
+73 SET IBXM(4)="ID ON FILE : "_IBID
+74 SET IBXM(5)="ID RETURNED: "_IBLOOK
+75 SET IBXM(6)=" "
SET IBXM(7)=" Please determine which id number is correct and correct the id in the"
SET IBXM(8)="insurance file for this payer, if needed"
+76 DO SENDMSG^XMXAPI(XMDUZ,XMSUBJ,XMBODY,.XMTO,,.XMZ)
+77 ;KDM US129, US976 IB*2*577
DO UPDLOG(0,IBDATE,IBINS,IBLOOK,IBTYP,IBID)
End DoDot:1
+78 ;
UPDINSQ QUIT
+1 ;
UPDLOG(UPD,IBDATE,IBINS,IBLOOK,IBTYP,IBID) ;KDM US129, US976 IB*2*577 New section for New Payer Report
+1 ; store flds for reporting purposes when updating or attempting to update Payer information (US129)
+2 ; ^DIC(36 -17.0 277EDI ID Number
+3 ; 17.01 277EDI ID Number
+4 ; 17.02 277Date EDI ID Number
+5 ; 17.03 277EDI Type (P)ROF or (I)nst or (D)ental
+6 ; 17.04 277EDI ID NUMBER ON FILE ;if blank it was an update otherwise it was an attempted update.
+7 ;
+8 ;store only one attempt a day
if (($DATA(^DIC(36,"AEDIX",IBDATE,IBINS,IBLOOK,IBTYP)))&(UPD=0))
QUIT
+9 NEW ERROR,IBFDA,LEV
+10 SET LEV="+2,"_IBINS_","
+11 ;New Value from 277STAT
SET IBFDA(36.017,LEV,.01)=IBLOOK
+12 ;Date transaction is processed
SET IBFDA(36.017,LEV,.02)=IBDATE
+13 ;"P" or "I" for "EDI-PayerID, or "P2" or "I2" for CLM-OFC-ID
SET IBFDA(36.017,LEV,.03)=IBTYP
+14 ;Value already on file- if blank it was an update, otherwise attempted update
SET IBFDA(36.017,LEV,.04)=$GET(IBID)
+15 DO UPDATE^DIE("","IBFDA","","ERROR")
+16 QUIT
+17 ;
MSGLNSZ(MSG) ; Change Input Message Lines to be no more than 70 characters long each
+1 ;
+2 ; Input/Output: MSG - array of Input Message Lines; this is also the Output Message
+3 ; which is an array of Converted Message Lines (with lines no more than 70 chars each)
+4 ;
+5 NEW LN,XARY,XARYLN,CNT,OUTMSG,TMPMSG,LDNGSP,LDNGSPN
+6 ;
SET LN=""
SET CNT=0
FOR
SET LN=$ORDER(MSG(LN))
if LN=""
QUIT
Begin DoDot:1
+7 ; Find any leading spaces in original message line,
+8 ; to be used if line got split below
+9 ;Trim Leading Spaces
SET TMPMSG=$$TRIM^XLFSTR(MSG(LN),"L"," ")
+10 ;get leading spaces if any
SET LDNGSP=$PIECE(MSG(LN),TMPMSG,1)
+11 ;make sure there are no more than 30 leading spaces
SET LDNGSPN=$LENGTH(LDNGSP)
if LDNGSPN>30
SET LDNGSP=$EXTRACT(LDNGSP,1,30)
+12 ; Converts a single line to multiple lines with a maximum width of 70 each
+13 ; If line is 70 chars or less, this call returns the exact line
+14 KILL XARY
DO FSTRNG^IBJU1(TMPMSG,70-LDNGSPN,.XARY)
+15 ; Scan lines and merge them into the final output array (OUTMSG)
+16 ; On lines 2 and higher, add Leading Spaces found above, if any.
+17 SET XARYLN=""
FOR
SET XARYLN=$ORDER(XARY(XARYLN))
if XARYLN=""
QUIT
SET CNT=CNT+1
SET OUTMSG(CNT)=LDNGSP_XARY(XARYLN)
End DoDot:1
+18 ;
+19 ; Move the final Message Lines (OUTMSG) into MSG array to be returned
+20 KILL MSG
MERGE MSG=OUTMSG
+21 QUIT
+22 ;
