IBCE837ACC ;EDE/JWS - ACC consume X12 claim data ;
;;2.0;INTEGRATED BILLING;**770**;23-MAY-18;Build 119
;;Per VA Directive 6402, this routine should not be modified.
;
; Reference to D DUZ^XUP(IBREG) in ICR #4129
; Reference to $P($G(^DPT(IBPATIEN,"ENR")),"^") in ICR ***NEW*** (Pending)
; Reference to $P($G(^DGEN(27.11,IBPGIEN,0)),"^",7) in ICR #5158
; Reference to ENCODE^XLFJSON in ICR #6682
Q
;
POST(RESULT,ARG) ;Entry point to consume Community Care X12 Claim data
; Input: ARG
N DUZ,IBPAYERID,IBPATICN,IBAUTH,IBREF
N I,X,Y,IBND,ERROR,IBX12IEN,IBSITE,IBX12,IBSEG,IBIO,IBSLINE,LOOP,IBI,IBFT,IBREFD9,IBDUP,OK,IBNOTE,IBREG,IBACCRPC
N IBDA,IBDOB,IBPT,IBPN,DA,DIE,DR,DIC,DOB,IBACCRPC1
N IBPDX,IBDOS,IBLDOS,IBPATSSN,IBPNPI,IBCPT,IBPATFN,IBPATLN,IBPATMN
N IBSPID,IBPATIEN,IBPN1,IBSEGN,IBTNUM,VADM,IBPN2,IBX
N DA,DD,DIC,DO,DINUM,DLAYGO,DTOUT,DUOUT,RES,X,Y,DOB
K RESULT
D DTNOLF^DICRW
K ^TMP("IBCE837ACC",$J) ; used for return message to TAS API
K ^TMP("IB837ACC",$J) ; use this global to save claim info that will be used to create the K# in file 399
I $D(ARG)'>1 S ^TMP("IBCE837ACC",$J,"Status")="0^Invalid or no data passed to VistA." G FINISH
; get AUTHORIZER,IB ACC user to begin claim creation process
; Change the DUZ to be this user.
; *** Integration Agreement 4129 - Activated on 30-June-2003 ***
S IBACCRPC1=1
S IBREG=$$IBREG()
D DUZ^XUP(IBREG) ; IA#4129
D NOW^%DTC
S Y=% D DD^%DT S IBND=%
S IBDA(364.9,"+1,",.01)=IBND
K ERROR
D UPDATE^DIE(,"IBDA","IBX12IEN","ERROR")
I $D(ERROR) S ^TMP("IBCE837ACC",$J,"Status")="0^Problem interpreting X12 data" G FINISH
;JWS;IB*2.0*770v10;EBILL-3551;10/24/24;get site/division identifier from JSON data received
S IBSITE(1)=$G(ARG("stationDiv"))
S IBSITE=$$DIV(IBSITE(1))
S IBX12=IBX12IEN(1),IBSEG="",IBIO="O",LOOP=1
F IBI=1:1 S IBSEG="SEG"_IBI Q:'$D(ARG(IBSEG)) D
. ;JWS;EBILL-6035;IB*2.0*770v46;semi-colon issue in billing provider name, change to space ' '
. S ARG(IBSEG)=$TR(ARG(IBSEG),">",": ") ; colon (:) is a reserved character in JSON, so data is coming over with > delimiter for sub-fields
. N DA,DD,DIC,DO,DINUM,DLAYGO,DTOUT,DUOUT,RES,X,Y,DOB,SEG,SEG2,IBPN2
. S DA(1)=IBX12,DLAYGO=364.9001,DIC(0)="L",DIC="^IBA(364.9,"_DA(1)_",1,",X=ARG(IBSEG)
. D FILE^DICN S RES=+Y K DD,DO
. S SEG=$P(ARG(IBSEG),"*",1,3),SEG2=$P(SEG,"*",2)
. ; skip ST (transaction set header)
. I $E(SEG,1,3)="ST*" Q ;trans set header
. I $E(SEG,1,4)="BHT*" Q
. I $E(SEG,1,3)="SE*" Q ;trans set trailer
. I $E(SEG,1,3)="HL*" D Q
.. S LOOP=$P(ARG(IBSEG),"*",4) ;20=information source, 22=subscriber , 23=patient/dependent
.. I LOOP=20 S LOOP="20^IBCE837ACC1" Q
.. I LOOP=22 S LOOP="22^IBCE837ACC1" Q
.. I LOOP=23 S LOOP="23^IBCE837ACC1" Q
.. Q
. I $E(SEG,1,3)="LX*" D Q
.. S IBSLINE=$P(ARG(IBSEG),"*",2),LOOP="24^IBCE837ACC3"
.. ;JWS;12/4/24;IB*2.0*770v15;EBILL-4618;adding line payment amounts to encounter
.. N X,IBIEN
.. S X=$G(ARG(IBSLINE_"_SVC03")) I X="" Q
.. N FDA,ERROR,DA,D0,DR,DIE,DIC,DI,DQ,DD,DINUM,DLAYGO,DTOUT,DUOUT
.. S IBIEN="+1,"_IBX12_","
.. S FDA(364.96,IBIEN,.01)=IBSLINE
.. S FDA(364.96,IBIEN,.02)=$J(X,"",2)
.. D UPDATE^DIE(,"FDA","IBIEN","ERROR")
.. S $P(^TMP("IB837ACC",$J,"L",IBSLINE,0),"^",6)=X
.. Q
. I $E(SEG,1,4)="CAS*" Q ;skip all adjustment segments
. I $E(SEG,1,4)="AMT*" Q ;skip all payor paid amt segments
. I $E(SEG,1,3)="OI*" Q ;other insurance info
. I $E(SEG,1,4)="MOA*" Q ;adj info
. I $E(SEG,1,4)="MIA*" Q ;inpatient adjudication info
. I $E(SEG,1,7)="NM1*41*" Q ;submitter
. I $E(SEG,1,7)="PER*IC*" Q ;contact info - skip all,$G(LOOP)=1 Q
. I $E(SEG,1,7)="NM1*40*" Q ;skip receiver segments
. I +$G(LOOP)>1 S:$E(SEG,1,4)="CLM*" LOOP="23^IBCE837ACC1" D @LOOP Q
. Q
;
ALL ;entry point for auth/create function
I $G(IBPATIEN) D PCP^IBCE837ACCU(IBPATIEN,$G(IBFT))
N IBER,IBERRMSG,IBIFN
I $G(IBFT)="" D UP(IBX12,25,5,""),STAT(IBX12,2) D Q:'$G(IBACCRPC1) 0 G FINISH
. S ^TMP("IBCE837ACC",$J,"Status")="1^X12 claim data received, but appears incomplete."
. Q
;JWS;EBILL-3551;11/1/2024;IB*2.0*770v10;if patient is not found, then added, and encounter is re-processed, need to load patient link
I $G(IBPATIEN) D
. N DA,D0,DR,DIE,DIC,DI,DQ,DD,DINUM,DLAYGO,DTOUT,DUOUT
. S DA=IBX12
. S DR="2.01////"_IBPATIEN
. S DIE="^IBA(364.9,"
. D ^DIE
. Q
; below will create fields used for worklist landing page(s), routing info, etc...
D
. I $G(IBREFD9)'="",$D(^IBA(364.9,"D",IBREFD9)) S IBDUP=1
. N DA,D0,DR,DIE,DIC,DI,DQ,DD,DINUM,DLAYGO,DTOUT,DUOUT
. S DA=IBX12
. ;S DR=".02////"_IBPATLN_";.03////"_IBPATFN_";.04////"_IBPATMN_";.1////"_IBDOB_";.11////"_$G(IBPATSSN)_";.06////"_$G(IBFT)_";.05////"_IBIO
. ;JWS;12/29/25;EBILL-6340;remedy semi-colon failure potential
. S DR=".02////^S X=IBPATLN;.03////^S X=IBPATFN;.04////^S X=IBPATMN;.1////"_$G(IBDOB)_";.11////"_$G(IBPATSSN)_";.06////"_$G(IBFT)_";.05////"_IBIO
. S DR=DR_";.12////"_$G(IBDOS)_";.13////"_$G(IBCPT)_";.14////"_$G(IBPDX)_";.15////"_$G(IBREFD9)
. I $G(IBACCRPC1) D
.. N X,IBPAY
.. S DR=DR_";.16////0;.2////"_IBSITE_";.24////"_IBSITE(1)
.. ;JWS;8/14/25;EBILL-5876; don't extract dups;770v39
.. I '$G(IBDUP) S DR=DR_";.21////1"
.. ;JWS;12/4/24;IB*2.0*770v15;EBILL-4618;adding payment and charge amounts to encounter
.. S X=0 F S X=$O(^TMP("IB837ACC",$J,"L",X)) Q:X="" S IBPAY=$G(IBPAY)+$P($G(^(X,0)),"^",6)
.. ;JWS;EBILL-4922;IB*2.0*770v18;add payer claim control number to encounter
.. S DR=DR_";.27////"_$J($G(IBPAY),"",2)_";.28////"_$J($P($G(^TMP("IB837ACC",$J)),"^",5),"",2)_";.29////"_$P($G(^TMP("IB837ACC",$J)),"^",44)
. I $G(IBPT)'="" S DR=DR_";.08////"_IBPT_";.07////"_IBPN_";.09////"_$G(IBPNPI)
. ;JWS;11/13/24;EBILL-3551;IB*2.0*770v11;add Service Facility name [25] and NPI [26] to encounter 0 node
. I $D(^TMP("IB837ACC",$J,1,77)) S DR=DR_";.25////"_$P($G(^(77)),"^",2)_";.26////"_$P($G(^(77)),"^")
. S DIE="^IBA(364.9,"
. D ^DIE
. Q
;JWS;2/4/25;EBILL-3551;enter previous activity entry for all encounters
I $G(IBACCRPC1) D
. N DA,FDA,ERROR,IBIENA,DA,D0,DR,DIE,DIC,DI,DQ,DD,DINUM,DLAYGO,DTOUT,DUOUT
. S IBIENA="+1,"_IBX12_","
. S FDA(364.94,IBIENA,.01)=IBND
. S FDA(364.94,IBIENA,.02)=DUZ
. S FDA(364.94,IBIENA,.03)=$O(^IBA(364.92,"B",1000,0))
. D UPDATE^DIE(,"FDA","IBIENA","ERROR")
. Q
I $G(IBACCRPC1),$G(IBDUP) D G FINISH
. N IBIENA,FDA,ERROR,DA,D0,DR,DIE,DIC,DI,DQ,DD,DINUM,DLAYGO,DTOUT,DUOUT
. D UP(IBX12,17,5,""),STAT(IBX12,2)
. S ^TMP("IBCE837ACC",$J,"Status")="1^Duplicate claim (REF*D9) : "_$G(IBREFD9)
. K DA
. S IBIENA="+1,"_IBX12_","
. S FDA(364.94,IBIENA,.01)=IBND
. S FDA(364.94,IBIENA,.02)=DUZ
. S FDA(364.94,IBIENA,.03)=$O(^IBA(364.92,"B",1001,0))
. D UPDATE^DIE(,"FDA","IBIENA","ERROR")
. Q
I +$G(IBPATIEN) D
. S OK=$$CHKINS^IBCE837ACCU(IBPATIEN,$G(IBDOS),$G(IBFT),.IBNOTE)
. ;JWS;IB*2.0*770v4; if no OHI, then close encounter
. I OK=3 D UP(IBX12,3,5,""),STAT(IBX12,2) ; no OHI on file
. ;JWS;7/22/25;EBILL-5677;if Combat Vet, check combat vet end date and if expired, remove SC failure reason
. ;N IB36491 S IB36491=$O(^IBA(364.91,"B",21,0)) I 'IB36491 Q
. ;S IBX=$O(^IBA(364.9,IBX12,5,"B",IB36491,0)) I IBX D
. ;. S IBX1=$$CVEDT^IBACV(IBPATIEN,IBDOS)
. ;. I $P(IBX1,"^")=0 S DA(1)=IBX12,DIK="^IBA(364.9,"_DA(1)_",5,",DA=IBX D ^DIK
. Q
. ; check priority group;5/21/25;JWS;EBILL-5447;remove priority group check
. ;S OK=$$CHKPG^IBCE837ACC2A(IBPATIEN,.IBNOTE)
. ;I 'OK D UP(IBX12,6,5,IBNOTE)
. ;JWS;2/18/25;EBILL-4972;IB*2.0*770v20;allow to skip sc/sa (all RUR reasons) failure reasons
. ;I OK=2,'$P($G(^IBA(364.9,IBX12,0)),"^",31) D UP(IBX12,10,5,IBNOTE)
; if inpatient claim, set exception
; JWS;10/30/2025;EBILL-5763;process inpatient CMS-1550 professional claims without PTF
; I $G(IBIO)="I",'$$ACCFT^IBCE837ACC2A($P($G(^TMP("IB837ACC",$J)),"^",6),IBFT) D UP(IBX12,7,5,"")
I $G(IBIO)="I" D UP(IBX12,7,5,"")
; perform CPT check/changes for Medicare Primary claims, skip Dental
I $G(IBFT)'=7 D PS^IBCE837ACC4
S OK=$$EX^IBCE837ACC3()
I $P(OK,"^",2)>0 D I OK="END" Q:'$G(IBACCRPC1) 0 G FINISH
. I $G(IBACCRPC1) S ^TMP("IBCE837ACC",$J,"Status")="1^X12 claim data received, claim determined non-billable."
. N IBIENA,FDA,ERROR,DA,D0,DR,DIE,DIC,DI,DQ,DD,DINUM,DLAYGO,DTOUT,DUOUT
. ;JWS;7/2/25;EBILL-5531;procedures with Q1 modifier are non-billable or EBILL-5534 procedures determined non-billable
. I $P($P($G(^TMP("IB837ACC",$J)),"^",2),"*",3)="M" D UP(IBX12,24,5,"")
. I $P($P($G(^TMP("IB837ACC",$J)),"^",2),"*",3)="C" D UP(IBX12,26,5,"")
. I $P(OK,"^")'=$P(OK,"^",2) Q ;not all cpts are nonbillable
. S OK="END"
. D STAT(IBX12,2)
. ;JWS;2/4/25;EBILL-3551;remove unbillable activity code
. Q
;JWS;EBILL-4022;IB*2.0*770vxx;start;check for VistA claim / CC Encounter duplicates
;S OK=$$CHKDUP^IBCE837ACC4(IBX12,IBPATIEN,IBDOS,IBFT)
;I OK D Q:'$G(IBACCRPC1) 0 G FINISH
;. D UP(IBX12,108,5,""),STAT(IBX12,2)
;. I $G(IBACCRPC1) S ^TMP("IBCE837ACC",$J,"Status")="1^X12 claim data received, encounter already billed."
;. Q
;JWS;EBILL-4022;end
; add Medicare excluded services check here - if Medicare and one of the excluded services, set [41] of ^TMP("IB837ACC",$J) = payer sequence "S"
; if secondary payer is NOT in the COB switch table as enabled for COB EDI billing, create claim but set to force print
I $P(^TMP("IB837ACC",$J),"^",40) D
. N IBCOB
. I $P(^TMP("IB837ACC",$J),"^",3)'="" S IBCOB=$$SW^IBCE837ACCU2($P($P(^TMP("IB837ACC",$J),"^",3),"*"),IBFT) I 'IBCOB D
.. ;set the error status in X12 file, set force print
.. S $P(^TMP("IB837ACC",$J),"^",42)=1
.. D UP(IBX12,102,5,""),USERUP(IBX12)
.. I $G(IBACCRPC1) S ^TMP("IBCE837ACC",$J,"Status")="1^X12 claim data received, claim contains Medicare Excluded Services."
.. Q
. S $P(^TMP("IB837ACC",$J),"^",41)="S"
;JWS/12/13/24;EBILL-3551;IB*2.0*770v16;below should fall thru and allow claim to be created, but FORCE LOCAL PRINT should be set
;I 'OK D UP(IBX12,102,5,""),USERUP(IBX12) ;;Q:'$G(IBACCRPC1) 0 G FINISH
;JWS;EBILL-4398;IB*2.0*770v7;moved below from before check for excluded services and cpt exceptions to after
I $O(^IBA(364.9,IBX12,5,0)) S OK=1 D I 'OK Q:'$G(IBACCRPC1) 0 G FINISH
. N X,X1,X2,OK1 S OK1=1
. S X=0 F S X=$O(^IBA(364.9,IBX12,5,X)) Q:X'=+X S X1=$P(^(X,0),"^"),X2=$$GET1^DIQ(364.91,X1_",",.01,"E") I X2'=24,X2'=26,X2<100 S OK1=0 Q
. I OK1 Q
. S OK=0
. ;JWS;IB*2.0*770v4; if no OHI, do not assign to a wl, quit
. ;JWS;IB*2.0*770v16;12/16/24;code 3 might not be ien 3
. S X=$O(^IBA(364.91,"B",3,0)) I X,$D(^IBA(364.9,IBX12,5,"B",X)) D Q
.. S ^TMP("IBCE837ACC",$J,"Status")="1^X12 claim data received, no OHI to bill. No VistA claim # created."
. D USERUP(IBX12)
. ;JWS;EBILL-4386;IB*2.0*770v7;change HIMS to FRPTF
. ;JWS;11/25/24;IB*2.0*770v14;change FRPTF to PTF
. ;JWS;12/4/24;IB*2.0*770v15;remove inpatient check/assignment, allow $$USER to handle
. ;JWS;2/4/25;EBILL-3551;moved prev act entry
. I $G(IBACCRPC1) S ^TMP("IBCE837ACC",$J,"Status")="1^X12 claim data received but not autobilled. "_$S($G(IBFT)="":"Could not determine form type.",1:"No VistA claim # created.")
. Q
; attempt to create claim in VistA - file 399
;JWS;6/4/25;EBILL-5371;use Division sent with encounter
; change $$DIV("",1) to $$MCD^IBACCROWFT(IBSITE(1))
S IBIFN=$$CREATE^IBCE837ACC2(IBPATIEN,IBFT,IBIO,$$MCD^IBACCROWFT(IBSITE(1))) ;4th parameter will be division received from Payer EDI json
I '$G(IBIFN) Q:'$G(IBACCRPC1) 0 S ^TMP("IBCE837ACC",$J,"Status")="1^X12 claim data received but not autobilled. No VistA claim # created." G FINISH
D
. N DA,D0,DR,DIE,DIC,DI,DQ,DD,DINUM,DLAYGO,DTOUT,DUOUT,FDA,ERROR,IBIENA
. S DA=IBX12
. S DR="2.01////"_IBPATIEN_";2.02////"_$G(IBIFN)_";.21////1"
. S DIE="^IBA(364.9,"
. D ^DIE
;JWS;EBILL-5705;6/23/25;moved reasonable charges check to before enter/edit checks
S OK=$$FINAL^IBCE837ACC4(IBIFN,IBX12) I 'OK S ^TMP("IBCE837ACC",$J,"Status")="1^X12 claim data received, VistA claim created, eBilling edit errors found."
; perform ib edit checks
D
. N PRCASV,VACNTRY,VAPA,IBACCRPC
. S IBACCRPC=1
. D EN^IBCBB
I IBER'=""!$D(^TMP($J,"BILL-WARN")) D I IBER'="WARN" Q:'$G(IBACCRPC1) 0 G FINISH
. N X,I,J,NOTE,RET
. I IBER'="WARN" D UP(IBX12,100,5,"")
. ;get warnings from ^TMP($J,"BILL-WARN",#)
. I $D(^TMP($J,"BILL-WARN")) S X="" F I=1:1 S X=$O(^TMP($J,"BILL-WARN",X)) Q:X="" S NOTE(I)=$$STRIP^IBCE837ACC2A(^(X))
. ;get errors from IBER variable, comma delimited
. I IBER'="",IBER'="WARN" D
.. ;JWS;2/4/25;EBILL-3551;moved prev act entry, appending note to existing entry
.. N IBPAIEN,ERR
.. S I=$G(I)+1,NOTE(I)="**Errors**:"
.. F J=1:1 S X=$P(IBER,";",J) Q:X="" I $D(^IBE(350.8,+$O(^IBE(350.8,"AC",X,0)),0)) S Y=^(0),NOTE($G(I)+J)=$E($P(Y,"^",2),1,80)
.. ;D ADDPREVACT^IBACCWLUTIL(.RET,IBX12,DUZ,1000,"BILL","BILL",.NOTE)
.. S IBPAIEN=$O(^IBA(364.9,IBX12,4,"A"),-1) I IBPAIEN D
... S IBPAIEN=IBPAIEN_","_IBX12_","
... D WP^DIE(364.94,IBPAIEN,10,"A","NOTE","ERR")
.. D USERUP(IBX12)
.. I $G(IBACCRPC1) S ^TMP("IBCE837ACC",$J,"Status")="1^X12 claim data received, VistA claim created, eBilling edit errors found."
. Q
;JWS;EBILL-5705;6/23/25;moved reasonable charges check to before enter/edit checks
;S OK=$$FINAL^IBCE837ACC4(IBIFN,IBX12) I 'OK Q:'$G(IBACCRPC1) 0 S ^TMP("IBCE837ACC",$J,"Status")="1^X12 claim data received, VistA claim created, eBilling edit errors found." G FINISH
;JWS;EBILL-3551;1/13/25;IB*2.0*770v17;execute DSS scrubber call
S OK=$$SCRUB^IBCE837ACC4(IBIFN)
I '$G(OK) D Q:'$G(IBACCRPC1) 0 G FINISH
. D UP(IBX12,105,5,""),USERUP(IBX12)
. I $G(IBACCRPC1) S ^TMP("IBCE837ACC",$J,"Status")="1^X12 claim data received, VistA claim created. DSS Scrubber error."
. Q
;JWS;2/4/25;EBILL-3551;last check of failure codes before authorize
I $O(^IBA(364.9,IBX12,5,0)) D USERUP(IBX12) Q:'$G(IBACCRPC1) 0 G FINISH
;JWS;1/16/2025;EBILL-4866;IB*2.0*770v17;begin;flag to prevent auto-authorize and auto-transmit
S OK=0,X=$$FIND1^DIC(364.991,,"X","ACCAUTOTRANSMITOFF") I X D
. N XDIV
. S XDIV=$$GET1^DIQ(364.991,X_",",.1)
. I $F(XDIV,$E(IBSITE,1,3)_"|") S OK=1
. Q
I OK D Q:'$G(IBACCRPC1) 0 G FINISH
. D UP(IBX12,107,5,""),USERUP(IBX12)
. I $G(IBACCRPC1) S ^TMP("IBCE837ACC",$J,"Status")="1^X12 claim data received, VistA claim ready for authorization."
. Q
;JWS;1/16/2025;EBILL-4866;end
;
D AUTH^IBCE837ACCU2(IBIFN,.IBERRMSG,$$MCRWNR^IBEFUNC($$CURR^IBCEF2(IBIFN)))
I $G(IBERRMSG)="" D Q:'$G(IBACCRPC1) 1 G FINISH
. ; if successfully authorized and can transmit, then clear out 364.9 fields and change status to closed(2)
. N DA,D0,DR,DIE,DIC,DI,DQ,DD,DINUM,DLAYGO,DTOUT,DUOUT,FDA,ERROR,IBIENA,IBST,DUZ
. ;JWS;6/11/25;EBILL-5456;use AUTHORIZER,IB ACC as the user
. S IBREG=$$IBREG()
. D DUZ^XUP(IBREG) ; IA#4129
. S DA=IBX12
. S DR=".16////2;2.03////1;3.01////@"
. S DIE="^IBA(364.9,"
. D ^DIE
. S ^TMP("IBCE837ACC",$J,"Status")="1^X12 claim data received, VistA claim created and successfully transmitted."
. ; set claim (399) status after authorization
. K DA,D0,DR,DIE,DIC,DI,DQ,DD,DINUM,DLAYGO
. S DA=IBIFN
. ;JWS;4/29/25;need to set MRA date and user if Medicare
. S IBST=$S($$MCRWNR^IBEFUNC($$CURR^IBCEF2(IBIFN)):2,1:3)
. S DR=".13////"_IBST_$S(IBST=2:";7////"_DT_";8////"_DUZ,1:";9////1")
. S DIE="^DGCR(399,"
. D ^DIE
. Q
;JWS;2/4/25;moved prev act entry
Q:'$G(IBACCRPC1) 0
G FINISH
;
DT(FIELD) ;
N XDT,DATE
S DATE=$P(ARG(IBSEG),"*",4)
I $F(DATE,"-") S XDT=$S($E(DATE,1,2)=19:2,1:3)_$E(DATE,3,8)_"-"_$S($E(DATE,10,11)=19:2,1:3)_$E(DATE,12,17) D SET^IBCE837ACC1(XDT,FIELD) Q
I DATE'="" S XDT=$S($E(DATE,1,2)=19:2,1:3)_$E(DATE,3,8) I XDT'="" D SET^IBCE837ACC1(XDT,FIELD) Q
Q
;
USERUP(IBX12) ;
N DA,D0,DR,DIE,DIC,DI,DQ,DD,DINUM,DLAYGO,DTOUT,DUOUT,XD,XIAG
S DA=IBX12 ;;I DA="" Q - GEN ERROR MESSAGE
; field 3.01 - assigned to group (possible if only SC issue, assign to RUR)
;JWS;EBILL-4386;IB*2.0*770v7;change HIMS to FRPTF
;JWS;11/25/24;IB*2.0*770v14;change FRPTF to PTF
;JWS;12/4/24;IB*2.0*770v15;remove inpatient check/assignment, allow $$USER to handle
S XD=$$USER^IBCE837ACC4(IBX12),XIAG=$$GET1^DIQ(364.9,IBX12_",",3.02,"I")
;JWS;12/9/24;EBILL-3551;allow update and not change 3.02
S DR="3.01////"_XD_$S($G(XIAG)'="":"",1:";3.02////"_XD)_";3.03////"_IBND
S DIE="^IBA(364.9,"
D ^DIE
Q
;
FINISH ;
;JWS;10/31/25;moved FINISH to IBCE837ACC2A
G FINISH^IBCE837ACC2A
;
UP(IBIEN,IBVAL,IBFLD,NOTE) ;
Q:$G(IBVAL)=""
N IBVAL1,WL
;JWS;IB*2.0*770v19;EBILL-4921;1/29/25;added worklist to failure reason code multiple for filtering display
;JWS;2/4/25;EBILL-3551;make sure all failure reasons have a default wl
S WL=$S(IBVAL=1!(IBVAL>3&(IBVAL<7)):"FRT",IBVAL=2:"RUR",IBVAL=3!(IBVAL=16)!(IBVAL=18):"IV",IBVAL=7:"PTF",IBVAL>7&(IBVAL<11):"RUR",1:"NEXT")
;11/24/25;JWS;EBILL-6206;add error 27 for missing taxonomy to FRT
I WL="NEXT" S WL=$S(IBVAL=11:"FRT",IBVAL>11&(IBVAL<16):"RUR",IBVAL>18&(IBVAL<24):"RUR",IBVAL=27:"FRT",IBVAL=109:"FRT",IBVAL=110:"FRT",IBVAL>23:"BILL",1:"")
S IBVAL1=$O(^IBA(364.91,"B",IBVAL,0)) Q:IBVAL1=""
S DIC="^IBA(364.9,"_IBIEN_",5,",DIC(0)="L",DA(1)=IBIEN,X=IBVAL1,DLAYGO=364.95 K DD,DO D FILE^DICN K DO,DD,DLAYGO
S IBTNUM=+Y
I NOTE="" S NOTE=$$GET1^DIQ(364.91,IBVAL1,.02)
;JWS;IB*2.0*770v19;EBILL-4921;1/29/25;added worklist to failure reason code multiple for filtering display
;JWS;12/29/25;EBILL-6340;fix issue with semi-colon in proc name when modifier is expired or invalid
S DR=".02////^S X=NOTE;.03////"_WL_";.04////"_$S(IBVAL=4!(IBVAL=5):$P(NOTE,":",2),1:"")
S DIE=DIC,DA=IBTNUM D ^DIE K DIE,DIC,DA,DINUM,DO,DD,DR
I '$G(IBACCRPC1) Q
;JWS;10/23/25;EBILL-6172;add initial failure reasons to encounter file
S DIC="^IBA(364.9,"_IBIEN_",7,",DIC(0)="L",DA(1)=IBIEN,X=IBVAL1,DLAYGO=364.97 K DD,DO D FILE^DICN K DO,DD,DLAYGO
S IBTNUM=+Y
I NOTE="" S NOTE=$$GET1^DIQ(364.91,IBVAL1,.02)
;JWS;12/29/25;EBILL-6340;fix issue with semi-colon in proc name when modifier is expired or invalid
S DR=".02////^S X=NOTE;.03////"_WL_";.04////"_$S(IBVAL=4!(IBVAL=5):$P(NOTE,":",2),1:"")
S DIE=DIC,DA=IBTNUM D ^DIE K DIE,DIC,DA,DINUM,DO,DD,DR
Q
;
IBREG() ; Returns IEN (Internal Entry Number) from file #200 for
; the ACC Bill Authorizer ; AUTHORIZER,IB ACC
; Output: -1 if record not on file
; IEN if record is on file
N DIC,X,Y
S DIC(0)="MO",DIC="^VA(200,",X="AUTHORIZER,IB ACC" ;ICR #10060 (Supported)
D ^DIC
; if record is on file, return IEN else return -1
Q +Y
;
DIV(IBDIV,IBINT) ; obtain division
; use new Facility cross/walk table to obtain division to use
I $G(IBDIV)="" S:$G(IBINT)=1 IBDIV=$$GET1^DIQ(350.9,"1,",1.25,"I") Q:$G(IBINT)=1 IBDIV S IBDIV=$P($$SITE^VASITE,"^",3)
;JWS;10/24/24;IB*2.0*770V8;EBILL-3551;added user group map logic by site/div number
S IBDIV=$$RUST^IBACCROWFT(IBDIV)
Q IBDIV ;ptr to file 40.8
;
STAT(IBIEN,DATA) ; update status
N DA,D0,DR,DIE,DIC,DI,DQ,DD,DINUM,DLAYGO,DTOUT,DUOUT
S DA=IBIEN
S DR=".16////"_DATA
S DIE="^IBA(364.9,"
D ^DIE
;JWS;8/14/25;EBILL-5876; don't extract dups;770v39; need for status field trigger addition
I $G(IBDUP) S DR=".21////0" D ^DIE
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBCE837ACC 19326 printed May 25, 2026@12:14:04 Page 2
IBCE837ACC ;EDE/JWS - ACC consume X12 claim data ;
+1 ;;2.0;INTEGRATED BILLING;**770**;23-MAY-18;Build 119
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;
+4 ; Reference to D DUZ^XUP(IBREG) in ICR #4129
+5 ; Reference to $P($G(^DPT(IBPATIEN,"ENR")),"^") in ICR ***NEW*** (Pending)
+6 ; Reference to $P($G(^DGEN(27.11,IBPGIEN,0)),"^",7) in ICR #5158
+7 ; Reference to ENCODE^XLFJSON in ICR #6682
+8 QUIT
+9 ;
POST(RESULT,ARG) ;Entry point to consume Community Care X12 Claim data
+1 ; Input: ARG
+2 NEW DUZ,IBPAYERID,IBPATICN,IBAUTH,IBREF
+3 NEW I,X,Y,IBND,ERROR,IBX12IEN,IBSITE,IBX12,IBSEG,IBIO,IBSLINE,LOOP,IBI,IBFT,IBREFD9,IBDUP,OK,IBNOTE,IBREG,IBACCRPC
+4 NEW IBDA,IBDOB,IBPT,IBPN,DA,DIE,DR,DIC,DOB,IBACCRPC1
+5 NEW IBPDX,IBDOS,IBLDOS,IBPATSSN,IBPNPI,IBCPT,IBPATFN,IBPATLN,IBPATMN
+6 NEW IBSPID,IBPATIEN,IBPN1,IBSEGN,IBTNUM,VADM,IBPN2,IBX
+7 NEW DA,DD,DIC,DO,DINUM,DLAYGO,DTOUT,DUOUT,RES,X,Y,DOB
+8 KILL RESULT
+9 DO DTNOLF^DICRW
+10 ; used for return message to TAS API
KILL ^TMP("IBCE837ACC",$JOB)
+11 ; use this global to save claim info that will be used to create the K# in file 399
KILL ^TMP("IB837ACC",$JOB)
+12 IF $DATA(ARG)'>1
SET ^TMP("IBCE837ACC",$JOB,"Status")="0^Invalid or no data passed to VistA."
GOTO FINISH
+13 ; get AUTHORIZER,IB ACC user to begin claim creation process
+14 ; Change the DUZ to be this user.
+15 ; *** Integration Agreement 4129 - Activated on 30-June-2003 ***
+16 SET IBACCRPC1=1
+17 SET IBREG=$$IBREG()
+18 ; IA#4129
DO DUZ^XUP(IBREG)
+19 DO NOW^%DTC
+20 SET Y=%
DO DD^%DT
SET IBND=%
+21 SET IBDA(364.9,"+1,",.01)=IBND
+22 KILL ERROR
+23 DO UPDATE^DIE(,"IBDA","IBX12IEN","ERROR")
+24 IF $DATA(ERROR)
SET ^TMP("IBCE837ACC",$JOB,"Status")="0^Problem interpreting X12 data"
GOTO FINISH
+25 ;JWS;IB*2.0*770v10;EBILL-3551;10/24/24;get site/division identifier from JSON data received
+26 SET IBSITE(1)=$GET(ARG("stationDiv"))
+27 SET IBSITE=$$DIV(IBSITE(1))
+28 SET IBX12=IBX12IEN(1)
SET IBSEG=""
SET IBIO="O"
SET LOOP=1
+29 FOR IBI=1:1
SET IBSEG="SEG"_IBI
if '$DATA(ARG(IBSEG))
QUIT
Begin DoDot:1
+30 ;JWS;EBILL-6035;IB*2.0*770v46;semi-colon issue in billing provider name, change to space ' '
+31 ; colon (:) is a reserved character in JSON, so data is coming over with > delimiter for sub-fields
SET ARG(IBSEG)=$TRANSLATE(ARG(IBSEG),">",": ")
+32 NEW DA,DD,DIC,DO,DINUM,DLAYGO,DTOUT,DUOUT,RES,X,Y,DOB,SEG,SEG2,IBPN2
+33 SET DA(1)=IBX12
SET DLAYGO=364.9001
SET DIC(0)="L"
SET DIC="^IBA(364.9,"_DA(1)_",1,"
SET X=ARG(IBSEG)
+34 DO FILE^DICN
SET RES=+Y
KILL DD,DO
+35 SET SEG=$PIECE(ARG(IBSEG),"*",1,3)
SET SEG2=$PIECE(SEG,"*",2)
+36 ; skip ST (transaction set header)
+37 ;trans set header
IF $EXTRACT(SEG,1,3)="ST*"
QUIT
+38 IF $EXTRACT(SEG,1,4)="BHT*"
QUIT
+39 ;trans set trailer
IF $EXTRACT(SEG,1,3)="SE*"
QUIT
+40 IF $EXTRACT(SEG,1,3)="HL*"
Begin DoDot:2
+41 ;20=information source, 22=subscriber , 23=patient/dependent
SET LOOP=$PIECE(ARG(IBSEG),"*",4)
+42 IF LOOP=20
SET LOOP="20^IBCE837ACC1"
QUIT
+43 IF LOOP=22
SET LOOP="22^IBCE837ACC1"
QUIT
+44 IF LOOP=23
SET LOOP="23^IBCE837ACC1"
QUIT
+45 QUIT
End DoDot:2
QUIT
+46 IF $EXTRACT(SEG,1,3)="LX*"
Begin DoDot:2
+47 SET IBSLINE=$PIECE(ARG(IBSEG),"*",2)
SET LOOP="24^IBCE837ACC3"
+48 ;JWS;12/4/24;IB*2.0*770v15;EBILL-4618;adding line payment amounts to encounter
+49 NEW X,IBIEN
+50 SET X=$GET(ARG(IBSLINE_"_SVC03"))
IF X=""
QUIT
+51 NEW FDA,ERROR,DA,D0,DR,DIE,DIC,DI,DQ,DD,DINUM,DLAYGO,DTOUT,DUOUT
+52 SET IBIEN="+1,"_IBX12_","
+53 SET FDA(364.96,IBIEN,.01)=IBSLINE
+54 SET FDA(364.96,IBIEN,.02)=$JUSTIFY(X,"",2)
+55 DO UPDATE^DIE(,"FDA","IBIEN","ERROR")
+56 SET $PIECE(^TMP("IB837ACC",$JOB,"L",IBSLINE,0),"^",6)=X
+57 QUIT
End DoDot:2
QUIT
+58 ;skip all adjustment segments
IF $EXTRACT(SEG,1,4)="CAS*"
QUIT
+59 ;skip all payor paid amt segments
IF $EXTRACT(SEG,1,4)="AMT*"
QUIT
+60 ;other insurance info
IF $EXTRACT(SEG,1,3)="OI*"
QUIT
+61 ;adj info
IF $EXTRACT(SEG,1,4)="MOA*"
QUIT
+62 ;inpatient adjudication info
IF $EXTRACT(SEG,1,4)="MIA*"
QUIT
+63 ;submitter
IF $EXTRACT(SEG,1,7)="NM1*41*"
QUIT
+64 ;contact info - skip all,$G(LOOP)=1 Q
IF $EXTRACT(SEG,1,7)="PER*IC*"
QUIT
+65 ;skip receiver segments
IF $EXTRACT(SEG,1,7)="NM1*40*"
QUIT
+66 IF +$GET(LOOP)>1
if $EXTRACT(SEG,1,4)="CLM*"
SET LOOP="23^IBCE837ACC1"
DO @LOOP
QUIT
+67 QUIT
End DoDot:1
+68 ;
ALL ;entry point for auth/create function
+1 IF $GET(IBPATIEN)
DO PCP^IBCE837ACCU(IBPATIEN,$GET(IBFT))
+2 NEW IBER,IBERRMSG,IBIFN
+3 IF $GET(IBFT)=""
DO UP(IBX12,25,5,"")
DO STAT(IBX12,2)
Begin DoDot:1
+4 SET ^TMP("IBCE837ACC",$JOB,"Status")="1^X12 claim data received, but appears incomplete."
+5 QUIT
End DoDot:1
if '$GET(IBACCRPC1)
QUIT 0
GOTO FINISH
+6 ;JWS;EBILL-3551;11/1/2024;IB*2.0*770v10;if patient is not found, then added, and encounter is re-processed, need to load patient link
+7 IF $GET(IBPATIEN)
Begin DoDot:1
+8 NEW DA,D0,DR,DIE,DIC,DI,DQ,DD,DINUM,DLAYGO,DTOUT,DUOUT
+9 SET DA=IBX12
+10 SET DR="2.01////"_IBPATIEN
+11 SET DIE="^IBA(364.9,"
+12 DO ^DIE
+13 QUIT
End DoDot:1
+14 ; below will create fields used for worklist landing page(s), routing info, etc...
+15 Begin DoDot:1
+16 IF $GET(IBREFD9)'=""
IF $DATA(^IBA(364.9,"D",IBREFD9))
SET IBDUP=1
+17 NEW DA,D0,DR,DIE,DIC,DI,DQ,DD,DINUM,DLAYGO,DTOUT,DUOUT
+18 SET DA=IBX12
+19 ;S DR=".02////"_IBPATLN_";.03////"_IBPATFN_";.04////"_IBPATMN_";.1////"_IBDOB_";.11////"_$G(IBPATSSN)_";.06////"_$G(IBFT)_";.05////"_IBIO
+20 ;JWS;12/29/25;EBILL-6340;remedy semi-colon failure potential
+21 SET DR=".02////^S X=IBPATLN;.03////^S X=IBPATFN;.04////^S X=IBPATMN;.1////"_$GET(IBDOB)_";.11////"_$GET(IBPATSSN)_";.06////"_$GET(IBFT)_";.05////"_IBIO
+22 SET DR=DR_";.12////"_$GET(IBDOS)_";.13////"_$GET(IBCPT)_";.14////"_$GET(IBPDX)_";.15////"_$GET(IBREFD9)
+23 IF $GET(IBACCRPC1)
Begin DoDot:2
+24 NEW X,IBPAY
+25 SET DR=DR_";.16////0;.2////"_IBSITE_";.24////"_IBSITE(1)
+26 ;JWS;8/14/25;EBILL-5876; don't extract dups;770v39
+27 IF '$GET(IBDUP)
SET DR=DR_";.21////1"
+28 ;JWS;12/4/24;IB*2.0*770v15;EBILL-4618;adding payment and charge amounts to encounter
+29 SET X=0
FOR
SET X=$ORDER(^TMP("IB837ACC",$JOB,"L",X))
if X=""
QUIT
SET IBPAY=$GET(IBPAY)+$PIECE($GET(^(X,0)),"^",6)
+30 ;JWS;EBILL-4922;IB*2.0*770v18;add payer claim control number to encounter
+31 SET DR=DR_";.27////"_$JUSTIFY($GET(IBPAY),"",2)_";.28////"_$JUSTIFY($PIECE($GET(^TMP("IB837ACC",$JOB)),"^",5),"",2)_";.29////"_$PIECE($GET(^TMP("IB837ACC",$JOB)),"^",44)
End DoDot:2
+32 IF $GET(IBPT)'=""
SET DR=DR_";.08////"_IBPT_";.07////"_IBPN_";.09////"_$GET(IBPNPI)
+33 ;JWS;11/13/24;EBILL-3551;IB*2.0*770v11;add Service Facility name [25] and NPI [26] to encounter 0 node
+34 IF $DATA(^TMP("IB837ACC",$JOB,1,77))
SET DR=DR_";.25////"_$PIECE($GET(^(77)),"^",2)_";.26////"_$PIECE($GET(^(77)),"^")
+35 SET DIE="^IBA(364.9,"
+36 DO ^DIE
+37 QUIT
End DoDot:1
+38 ;JWS;2/4/25;EBILL-3551;enter previous activity entry for all encounters
+39 IF $GET(IBACCRPC1)
Begin DoDot:1
+40 NEW DA,FDA,ERROR,IBIENA,DA,D0,DR,DIE,DIC,DI,DQ,DD,DINUM,DLAYGO,DTOUT,DUOUT
+41 SET IBIENA="+1,"_IBX12_","
+42 SET FDA(364.94,IBIENA,.01)=IBND
+43 SET FDA(364.94,IBIENA,.02)=DUZ
+44 SET FDA(364.94,IBIENA,.03)=$ORDER(^IBA(364.92,"B",1000,0))
+45 DO UPDATE^DIE(,"FDA","IBIENA","ERROR")
+46 QUIT
End DoDot:1
+47 IF $GET(IBACCRPC1)
IF $GET(IBDUP)
Begin DoDot:1
+48 NEW IBIENA,FDA,ERROR,DA,D0,DR,DIE,DIC,DI,DQ,DD,DINUM,DLAYGO,DTOUT,DUOUT
+49 DO UP(IBX12,17,5,"")
DO STAT(IBX12,2)
+50 SET ^TMP("IBCE837ACC",$JOB,"Status")="1^Duplicate claim (REF*D9) : "_$GET(IBREFD9)
+51 KILL DA
+52 SET IBIENA="+1,"_IBX12_","
+53 SET FDA(364.94,IBIENA,.01)=IBND
+54 SET FDA(364.94,IBIENA,.02)=DUZ
+55 SET FDA(364.94,IBIENA,.03)=$ORDER(^IBA(364.92,"B",1001,0))
+56 DO UPDATE^DIE(,"FDA","IBIENA","ERROR")
+57 QUIT
End DoDot:1
GOTO FINISH
+58 IF +$GET(IBPATIEN)
Begin DoDot:1
+59 SET OK=$$CHKINS^IBCE837ACCU(IBPATIEN,$GET(IBDOS),$GET(IBFT),.IBNOTE)
+60 ;JWS;IB*2.0*770v4; if no OHI, then close encounter
+61 ; no OHI on file
IF OK=3
DO UP(IBX12,3,5,"")
DO STAT(IBX12,2)
+62 ;JWS;7/22/25;EBILL-5677;if Combat Vet, check combat vet end date and if expired, remove SC failure reason
+63 ;N IB36491 S IB36491=$O(^IBA(364.91,"B",21,0)) I 'IB36491 Q
+64 ;S IBX=$O(^IBA(364.9,IBX12,5,"B",IB36491,0)) I IBX D
+65 ;. S IBX1=$$CVEDT^IBACV(IBPATIEN,IBDOS)
+66 ;. I $P(IBX1,"^")=0 S DA(1)=IBX12,DIK="^IBA(364.9,"_DA(1)_",5,",DA=IBX D ^DIK
+67 QUIT
+68 ; check priority group;5/21/25;JWS;EBILL-5447;remove priority group check
+69 ;S OK=$$CHKPG^IBCE837ACC2A(IBPATIEN,.IBNOTE)
+70 ;I 'OK D UP(IBX12,6,5,IBNOTE)
+71 ;JWS;2/18/25;EBILL-4972;IB*2.0*770v20;allow to skip sc/sa (all RUR reasons) failure reasons
+72 ;I OK=2,'$P($G(^IBA(364.9,IBX12,0)),"^",31) D UP(IBX12,10,5,IBNOTE)
End DoDot:1
+73 ; if inpatient claim, set exception
+74 ; JWS;10/30/2025;EBILL-5763;process inpatient CMS-1550 professional claims without PTF
+75 ; I $G(IBIO)="I",'$$ACCFT^IBCE837ACC2A($P($G(^TMP("IB837ACC",$J)),"^",6),IBFT) D UP(IBX12,7,5,"")
+76 IF $GET(IBIO)="I"
DO UP(IBX12,7,5,"")
+77 ; perform CPT check/changes for Medicare Primary claims, skip Dental
+78 IF $GET(IBFT)'=7
DO PS^IBCE837ACC4
+79 SET OK=$$EX^IBCE837ACC3()
+80 IF $PIECE(OK,"^",2)>0
Begin DoDot:1
+81 IF $GET(IBACCRPC1)
SET ^TMP("IBCE837ACC",$JOB,"Status")="1^X12 claim data received, claim determined non-billable."
+82 NEW IBIENA,FDA,ERROR,DA,D0,DR,DIE,DIC,DI,DQ,DD,DINUM,DLAYGO,DTOUT,DUOUT
+83 ;JWS;7/2/25;EBILL-5531;procedures with Q1 modifier are non-billable or EBILL-5534 procedures determined non-billable
+84 IF $PIECE($PIECE($GET(^TMP("IB837ACC",$JOB)),"^",2),"*",3)="M"
DO UP(IBX12,24,5,"")
+85 IF $PIECE($PIECE($GET(^TMP("IB837ACC",$JOB)),"^",2),"*",3)="C"
DO UP(IBX12,26,5,"")
+86 ;not all cpts are nonbillable
IF $PIECE(OK,"^")'=$PIECE(OK,"^",2)
QUIT
+87 SET OK="END"
+88 DO STAT(IBX12,2)
+89 ;JWS;2/4/25;EBILL-3551;remove unbillable activity code
+90 QUIT
End DoDot:1
IF OK="END"
if '$GET(IBACCRPC1)
QUIT 0
GOTO FINISH
+91 ;JWS;EBILL-4022;IB*2.0*770vxx;start;check for VistA claim / CC Encounter duplicates
+92 ;S OK=$$CHKDUP^IBCE837ACC4(IBX12,IBPATIEN,IBDOS,IBFT)
+93 ;I OK D Q:'$G(IBACCRPC1) 0 G FINISH
+94 ;. D UP(IBX12,108,5,""),STAT(IBX12,2)
+95 ;. I $G(IBACCRPC1) S ^TMP("IBCE837ACC",$J,"Status")="1^X12 claim data received, encounter already billed."
+96 ;. Q
+97 ;JWS;EBILL-4022;end
+98 ; add Medicare excluded services check here - if Medicare and one of the excluded services, set [41] of ^TMP("IB837ACC",$J) = payer sequence "S"
+99 ; if secondary payer is NOT in the COB switch table as enabled for COB EDI billing, create claim but set to force print
+100 IF $PIECE(^TMP("IB837ACC",$JOB),"^",40)
Begin DoDot:1
+101 NEW IBCOB
+102 IF $PIECE(^TMP("IB837ACC",$JOB),"^",3)'=""
SET IBCOB=$$SW^IBCE837ACCU2($PIECE($PIECE(^TMP("IB837ACC",$JOB),"^",3),"*"),IBFT)
IF 'IBCOB
Begin DoDot:2
+103 ;set the error status in X12 file, set force print
+104 SET $PIECE(^TMP("IB837ACC",$JOB),"^",42)=1
+105 DO UP(IBX12,102,5,"")
DO USERUP(IBX12)
+106 IF $GET(IBACCRPC1)
SET ^TMP("IBCE837ACC",$JOB,"Status")="1^X12 claim data received, claim contains Medicare Excluded Services."
+107 QUIT
End DoDot:2
+108 SET $PIECE(^TMP("IB837ACC",$JOB),"^",41)="S"
End DoDot:1
+109 ;JWS/12/13/24;EBILL-3551;IB*2.0*770v16;below should fall thru and allow claim to be created, but FORCE LOCAL PRINT should be set
+110 ;I 'OK D UP(IBX12,102,5,""),USERUP(IBX12) ;;Q:'$G(IBACCRPC1) 0 G FINISH
+111 ;JWS;EBILL-4398;IB*2.0*770v7;moved below from before check for excluded services and cpt exceptions to after
+112 IF $ORDER(^IBA(364.9,IBX12,5,0))
SET OK=1
Begin DoDot:1
+113 NEW X,X1,X2,OK1
SET OK1=1
+114 SET X=0
FOR
SET X=$ORDER(^IBA(364.9,IBX12,5,X))
if X'=+X
QUIT
SET X1=$PIECE(^(X,0),"^")
SET X2=$$GET1^DIQ(364.91,X1_",",.01,"E")
IF X2'=24
IF X2'=26
IF X2<100
SET OK1=0
QUIT
+115 IF OK1
QUIT
+116 SET OK=0
+117 ;JWS;IB*2.0*770v4; if no OHI, do not assign to a wl, quit
+118 ;JWS;IB*2.0*770v16;12/16/24;code 3 might not be ien 3
+119 SET X=$ORDER(^IBA(364.91,"B",3,0))
IF X
IF $DATA(^IBA(364.9,IBX12,5,"B",X))
Begin DoDot:2
+120 SET ^TMP("IBCE837ACC",$JOB,"Status")="1^X12 claim data received, no OHI to bill. No VistA claim # created."
End DoDot:2
QUIT
+121 DO USERUP(IBX12)
+122 ;JWS;EBILL-4386;IB*2.0*770v7;change HIMS to FRPTF
+123 ;JWS;11/25/24;IB*2.0*770v14;change FRPTF to PTF
+124 ;JWS;12/4/24;IB*2.0*770v15;remove inpatient check/assignment, allow $$USER to handle
+125 ;JWS;2/4/25;EBILL-3551;moved prev act entry
+126 IF $GET(IBACCRPC1)
SET ^TMP("IBCE837ACC",$JOB,"Status")="1^X12 claim data received but not autobilled. "_$SELECT($GET(IBFT)="":"Could not determine form type.",1:"No VistA claim # created.")
+127 QUIT
End DoDot:1
IF 'OK
if '$GET(IBACCRPC1)
QUIT 0
GOTO FINISH
+128 ; attempt to create claim in VistA - file 399
+129 ;JWS;6/4/25;EBILL-5371;use Division sent with encounter
+130 ; change $$DIV("",1) to $$MCD^IBACCROWFT(IBSITE(1))
+131 ;4th parameter will be division received from Payer EDI json
SET IBIFN=$$CREATE^IBCE837ACC2(IBPATIEN,IBFT,IBIO,$$MCD^IBACCROWFT(IBSITE(1)))
+132 IF '$GET(IBIFN)
if '$GET(IBACCRPC1)
QUIT 0
SET ^TMP("IBCE837ACC",$JOB,"Status")="1^X12 claim data received but not autobilled. No VistA claim # created."
GOTO FINISH
+133 Begin DoDot:1
+134 NEW DA,D0,DR,DIE,DIC,DI,DQ,DD,DINUM,DLAYGO,DTOUT,DUOUT,FDA,ERROR,IBIENA
+135 SET DA=IBX12
+136 SET DR="2.01////"_IBPATIEN_";2.02////"_$GET(IBIFN)_";.21////1"
+137 SET DIE="^IBA(364.9,"
+138 DO ^DIE
End DoDot:1
+139 ;JWS;EBILL-5705;6/23/25;moved reasonable charges check to before enter/edit checks
+140 SET OK=$$FINAL^IBCE837ACC4(IBIFN,IBX12)
IF 'OK
SET ^TMP("IBCE837ACC",$JOB,"Status")="1^X12 claim data received, VistA claim created, eBilling edit errors found."
+141 ; perform ib edit checks
+142 Begin DoDot:1
+143 NEW PRCASV,VACNTRY,VAPA,IBACCRPC
+144 SET IBACCRPC=1
+145 DO EN^IBCBB
End DoDot:1
+146 IF IBER'=""!$DATA(^TMP($JOB,"BILL-WARN"))
Begin DoDot:1
+147 NEW X,I,J,NOTE,RET
+148 IF IBER'="WARN"
DO UP(IBX12,100,5,"")
+149 ;get warnings from ^TMP($J,"BILL-WARN",#)
+150 IF $DATA(^TMP($JOB,"BILL-WARN"))
SET X=""
FOR I=1:1
SET X=$ORDER(^TMP($JOB,"BILL-WARN",X))
if X=""
QUIT
SET NOTE(I)=$$STRIP^IBCE837ACC2A(^(X))
+151 ;get errors from IBER variable, comma delimited
+152 IF IBER'=""
IF IBER'="WARN"
Begin DoDot:2
+153 ;JWS;2/4/25;EBILL-3551;moved prev act entry, appending note to existing entry
+154 NEW IBPAIEN,ERR
+155 SET I=$GET(I)+1
SET NOTE(I)="**Errors**:"
+156 FOR J=1:1
SET X=$PIECE(IBER,";",J)
if X=""
QUIT
IF $DATA(^IBE(350.8,+$ORDER(^IBE(350.8,"AC",X,0)),0))
SET Y=^(0)
SET NOTE($GET(I)+J)=$EXTRACT($PIECE(Y,"^",2),1,80)
+157 ;D ADDPREVACT^IBACCWLUTIL(.RET,IBX12,DUZ,1000,"BILL","BILL",.NOTE)
+158 SET IBPAIEN=$ORDER(^IBA(364.9,IBX12,4,"A"),-1)
IF IBPAIEN
Begin DoDot:3
+159 SET IBPAIEN=IBPAIEN_","_IBX12_","
+160 DO WP^DIE(364.94,IBPAIEN,10,"A","NOTE","ERR")
End DoDot:3
+161 DO USERUP(IBX12)
+162 IF $GET(IBACCRPC1)
SET ^TMP("IBCE837ACC",$JOB,"Status")="1^X12 claim data received, VistA claim created, eBilling edit errors found."
End DoDot:2
+163 QUIT
End DoDot:1
IF IBER'="WARN"
if '$GET(IBACCRPC1)
QUIT 0
GOTO FINISH
+164 ;JWS;EBILL-5705;6/23/25;moved reasonable charges check to before enter/edit checks
+165 ;S OK=$$FINAL^IBCE837ACC4(IBIFN,IBX12) I 'OK Q:'$G(IBACCRPC1) 0 S ^TMP("IBCE837ACC",$J,"Status")="1^X12 claim data received, VistA claim created, eBilling edit errors found." G FINISH
+166 ;JWS;EBILL-3551;1/13/25;IB*2.0*770v17;execute DSS scrubber call
+167 SET OK=$$SCRUB^IBCE837ACC4(IBIFN)
+168 IF '$GET(OK)
Begin DoDot:1
+169 DO UP(IBX12,105,5,"")
DO USERUP(IBX12)
+170 IF $GET(IBACCRPC1)
SET ^TMP("IBCE837ACC",$JOB,"Status")="1^X12 claim data received, VistA claim created. DSS Scrubber error."
+171 QUIT
End DoDot:1
if '$GET(IBACCRPC1)
QUIT 0
GOTO FINISH
+172 ;JWS;2/4/25;EBILL-3551;last check of failure codes before authorize
+173 IF $ORDER(^IBA(364.9,IBX12,5,0))
DO USERUP(IBX12)
if '$GET(IBACCRPC1)
QUIT 0
GOTO FINISH
+174 ;JWS;1/16/2025;EBILL-4866;IB*2.0*770v17;begin;flag to prevent auto-authorize and auto-transmit
+175 SET OK=0
SET X=$$FIND1^DIC(364.991,,"X","ACCAUTOTRANSMITOFF")
IF X
Begin DoDot:1
+176 NEW XDIV
+177 SET XDIV=$$GET1^DIQ(364.991,X_",",.1)
+178 IF $FIND(XDIV,$EXTRACT(IBSITE,1,3)_"|")
SET OK=1
+179 QUIT
End DoDot:1
+180 IF OK
Begin DoDot:1
+181 DO UP(IBX12,107,5,"")
DO USERUP(IBX12)
+182 IF $GET(IBACCRPC1)
SET ^TMP("IBCE837ACC",$JOB,"Status")="1^X12 claim data received, VistA claim ready for authorization."
+183 QUIT
End DoDot:1
if '$GET(IBACCRPC1)
QUIT 0
GOTO FINISH
+184 ;JWS;1/16/2025;EBILL-4866;end
+185 ;
+186 DO AUTH^IBCE837ACCU2(IBIFN,.IBERRMSG,$$MCRWNR^IBEFUNC($$CURR^IBCEF2(IBIFN)))
+187 IF $GET(IBERRMSG)=""
Begin DoDot:1
+188 ; if successfully authorized and can transmit, then clear out 364.9 fields and change status to closed(2)
+189 NEW DA,D0,DR,DIE,DIC,DI,DQ,DD,DINUM,DLAYGO,DTOUT,DUOUT,FDA,ERROR,IBIENA,IBST,DUZ
+190 ;JWS;6/11/25;EBILL-5456;use AUTHORIZER,IB ACC as the user
+191 SET IBREG=$$IBREG()
+192 ; IA#4129
DO DUZ^XUP(IBREG)
+193 SET DA=IBX12
+194 SET DR=".16////2;2.03////1;3.01////@"
+195 SET DIE="^IBA(364.9,"
+196 DO ^DIE
+197 SET ^TMP("IBCE837ACC",$JOB,"Status")="1^X12 claim data received, VistA claim created and successfully transmitted."
+198 ; set claim (399) status after authorization
+199 KILL DA,D0,DR,DIE,DIC,DI,DQ,DD,DINUM,DLAYGO
+200 SET DA=IBIFN
+201 ;JWS;4/29/25;need to set MRA date and user if Medicare
+202 SET IBST=$SELECT($$MCRWNR^IBEFUNC($$CURR^IBCEF2(IBIFN)):2,1:3)
+203 SET DR=".13////"_IBST_$SELECT(IBST=2:";7////"_DT_";8////"_DUZ,1:";9////1")
+204 SET DIE="^DGCR(399,"
+205 DO ^DIE
+206 QUIT
End DoDot:1
if '$GET(IBACCRPC1)
QUIT 1
GOTO FINISH
+207 ;JWS;2/4/25;moved prev act entry
+208 if '$GET(IBACCRPC1)
QUIT 0
+209 GOTO FINISH
+210 ;
DT(FIELD) ;
+1 NEW XDT,DATE
+2 SET DATE=$PIECE(ARG(IBSEG),"*",4)
+3 IF $FIND(DATE,"-")
SET XDT=$SELECT($EXTRACT(DATE,1,2)=19:2,1:3)_$EXTRACT(DATE,3,8)_"-"_$SELECT($EXTRACT(DATE,10,11)=19:2,1:3)_$EXTRACT(DATE,12,17)
DO SET^IBCE837ACC1(XDT,FIELD)
QUIT
+4 IF DATE'=""
SET XDT=$SELECT($EXTRACT(DATE,1,2)=19:2,1:3)_$EXTRACT(DATE,3,8)
IF XDT'=""
DO SET^IBCE837ACC1(XDT,FIELD)
QUIT
+5 QUIT
+6 ;
USERUP(IBX12) ;
+1 NEW DA,D0,DR,DIE,DIC,DI,DQ,DD,DINUM,DLAYGO,DTOUT,DUOUT,XD,XIAG
+2 ;;I DA="" Q - GEN ERROR MESSAGE
SET DA=IBX12
+3 ; field 3.01 - assigned to group (possible if only SC issue, assign to RUR)
+4 ;JWS;EBILL-4386;IB*2.0*770v7;change HIMS to FRPTF
+5 ;JWS;11/25/24;IB*2.0*770v14;change FRPTF to PTF
+6 ;JWS;12/4/24;IB*2.0*770v15;remove inpatient check/assignment, allow $$USER to handle
+7 SET XD=$$USER^IBCE837ACC4(IBX12)
SET XIAG=$$GET1^DIQ(364.9,IBX12_",",3.02,"I")
+8 ;JWS;12/9/24;EBILL-3551;allow update and not change 3.02
+9 SET DR="3.01////"_XD_$SELECT($GET(XIAG)'="":"",1:";3.02////"_XD)_";3.03////"_IBND
+10 SET DIE="^IBA(364.9,"
+11 DO ^DIE
+12 QUIT
+13 ;
FINISH ;
+1 ;JWS;10/31/25;moved FINISH to IBCE837ACC2A
+2 GOTO FINISH^IBCE837ACC2A
+3 ;
UP(IBIEN,IBVAL,IBFLD,NOTE) ;
+1 if $GET(IBVAL)=""
QUIT
+2 NEW IBVAL1,WL
+3 ;JWS;IB*2.0*770v19;EBILL-4921;1/29/25;added worklist to failure reason code multiple for filtering display
+4 ;JWS;2/4/25;EBILL-3551;make sure all failure reasons have a default wl
+5 SET WL=$SELECT(IBVAL=1!(IBVAL>3&(IBVAL<7)):"FRT",IBVAL=2:"RUR",IBVAL=3!(IBVAL=16)!(IBVAL=18):"IV",IBVAL=7:"PTF",IBVAL>7&(IBVAL<11):"RUR",1:"NEXT")
+6 ;11/24/25;JWS;EBILL-6206;add error 27 for missing taxonomy to FRT
+7 IF WL="NEXT"
SET WL=$SELECT(IBVAL=11:"FRT",IBVAL>11&(IBVAL<16):"RUR",IBVAL>18&(IBVAL<24):"RUR",IBVAL=27:"FRT",IBVAL=109:"FRT",IBVAL=110:"FRT",IBVAL>23:"BILL",1:"")
+8 SET IBVAL1=$ORDER(^IBA(364.91,"B",IBVAL,0))
if IBVAL1=""
QUIT
+9 SET DIC="^IBA(364.9,"_IBIEN_",5,"
SET DIC(0)="L"
SET DA(1)=IBIEN
SET X=IBVAL1
SET DLAYGO=364.95
KILL DD,DO
DO FILE^DICN
KILL DO,DD,DLAYGO
+10 SET IBTNUM=+Y
+11 IF NOTE=""
SET NOTE=$$GET1^DIQ(364.91,IBVAL1,.02)
+12 ;JWS;IB*2.0*770v19;EBILL-4921;1/29/25;added worklist to failure reason code multiple for filtering display
+13 ;JWS;12/29/25;EBILL-6340;fix issue with semi-colon in proc name when modifier is expired or invalid
+14 SET DR=".02////^S X=NOTE;.03////"_WL_";.04////"_$SELECT(IBVAL=4!(IBVAL=5):$PIECE(NOTE,":",2),1:"")
+15 SET DIE=DIC
SET DA=IBTNUM
DO ^DIE
KILL DIE,DIC,DA,DINUM,DO,DD,DR
+16 IF '$GET(IBACCRPC1)
QUIT
+17 ;JWS;10/23/25;EBILL-6172;add initial failure reasons to encounter file
+18 SET DIC="^IBA(364.9,"_IBIEN_",7,"
SET DIC(0)="L"
SET DA(1)=IBIEN
SET X=IBVAL1
SET DLAYGO=364.97
KILL DD,DO
DO FILE^DICN
KILL DO,DD,DLAYGO
+19 SET IBTNUM=+Y
+20 IF NOTE=""
SET NOTE=$$GET1^DIQ(364.91,IBVAL1,.02)
+21 ;JWS;12/29/25;EBILL-6340;fix issue with semi-colon in proc name when modifier is expired or invalid
+22 SET DR=".02////^S X=NOTE;.03////"_WL_";.04////"_$SELECT(IBVAL=4!(IBVAL=5):$PIECE(NOTE,":",2),1:"")
+23 SET DIE=DIC
SET DA=IBTNUM
DO ^DIE
KILL DIE,DIC,DA,DINUM,DO,DD,DR
+24 QUIT
+25 ;
IBREG() ; Returns IEN (Internal Entry Number) from file #200 for
+1 ; the ACC Bill Authorizer ; AUTHORIZER,IB ACC
+2 ; Output: -1 if record not on file
+3 ; IEN if record is on file
+4 NEW DIC,X,Y
+5 ;ICR #10060 (Supported)
SET DIC(0)="MO"
SET DIC="^VA(200,"
SET X="AUTHORIZER,IB ACC"
+6 DO ^DIC
+7 ; if record is on file, return IEN else return -1
+8 QUIT +Y
+9 ;
DIV(IBDIV,IBINT) ; obtain division
+1 ; use new Facility cross/walk table to obtain division to use
+2 IF $GET(IBDIV)=""
if $GET(IBINT)=1
SET IBDIV=$$GET1^DIQ(350.9,"1,",1.25,"I")
if $GET(IBINT)=1
QUIT IBDIV
SET IBDIV=$PIECE($$SITE^VASITE,"^",3)
+3 ;JWS;10/24/24;IB*2.0*770V8;EBILL-3551;added user group map logic by site/div number
+4 SET IBDIV=$$RUST^IBACCROWFT(IBDIV)
+5 ;ptr to file 40.8
QUIT IBDIV
+6 ;
STAT(IBIEN,DATA) ; update status
+1 NEW DA,D0,DR,DIE,DIC,DI,DQ,DD,DINUM,DLAYGO,DTOUT,DUOUT
+2 SET DA=IBIEN
+3 SET DR=".16////"_DATA
+4 SET DIE="^IBA(364.9,"
+5 DO ^DIE
+6 ;JWS;8/14/25;EBILL-5876; don't extract dups;770v39; need for status field trigger addition
+7 IF $GET(IBDUP)
SET DR=".21////0"
DO ^DIE
+8 QUIT
+9 ;
