IBCE837ACCU2 ;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.
;
Q
;
; Reference to $$CPT^ICPTCOD in ICR #1995 (Supported)
;
AUTH(IBIFN,ERRMSG,IBMRANOT) ; Entry Point
; This procedure's job is to authorize this bill. The manual
; process to authorize a bill is found in routine IBCB1. This
; routine borrows heavily from that routine.
;
; *** Any changes here should be considered also in IBCB1 ***
;
;
; Input
; IBIFN - internal bill#
; IBMRANOT - 1 indicates process is NOT from MRA
;
; Output
; ERRMSG - optional output parameter, passed by reference
; - error message text
;
N IBTXSTAT,IB364,PRCASV,DFN,STSMSG,DIE,DA,DR,IBYY
;
; Check the bill, make sure the current status is valid
S IBIFN=+$G(IBIFN),ERRMSG=""
; Update the review status for all EOB's on file
D STAT^IBCEMU2(IBIFN,3) ; Accepted - Complete EOB
;
; Checks for need to add any codes to bill for EDI (call in quiet mode)
D AUTOCK^IBCEU2(IBIFN,1)
;
; Calculate transmittable status
; 0 = not transmittable
; 1 = yes, live transmittable
; 2 = yes, test transmittable
; P432 add MRANOT flag so it will create new entry in trans file for non-MRA's
S IBTXSTAT=+$$TXMT^IBCEF4(IBIFN,,$G(IBMRANOT))
;
; If transmittable, add this bill to the bill transmission file
I IBTXSTAT D I ERRMSG'="" G AUTHX
. S IB364=$$ADDTBILL^IBCB1(IBIFN,IBTXSTAT)
. Q
;
; Pass completed bill to Accounts Receivable (quietly)
I $G(IBMRANOT)'=1 D ARPASS^IBCB1(IBIFN,0) I '$G(PRCASV("OKAY")) S ERRMSG="Error while passing bill to A/R." G AUTHX
;
AUTHX ;
Q
;
SFRP ;check service facility and rendering provider
;if no service facility passed in X12, use original billing provider, per TR3 guides
;I '$D(^TMP("IB837ACC",$J,1,77)) D
;. N XNPI
;. S XNPI=$P($G(^TMP("IB837ACC",$J,1,85)),"^")
;. S OK=$$CHK35593^IBCE837ACCU(XNPI) I 'OK D UP^IBCE837ACC(IBX12,5,5,"NO SERVICE FACILITY IN X12 DATA") Q
;. M ^TMP("IB837ACC",$J,1,77)=^TMP("IB837ACC",$J,1,85)
;. Q
; if no rendering provider in X12, use original billing provider, per TR3 guides
;I '$D(^TMP("IB837ACC",$J,1,82)) D
;. N XNPI
;. S XNPI=$P($G(^TMP("IB837ACC",$J,1,85)),"^")
;. S OK=$$CHK35593^IBCE837ACCU(XNPI) I 'OK D UP^IBCE837ACC(IBX12,5,4,"NO RENDERING PROVIDER IN X12 DATA") Q
;. M ^TMP("IB837ACC",$J,1,82)=^TMP("IB837ACC",$J,1,85)
;. Q
Q
;
SW(IBINS,IBFT) ; check file 364.8
;Prevent claims going out via EDI with NOEXC Payer ID;need function to check file 364.8
N IBPID,OK,IB3648,IB3648FT,IB3648TF,IBTPAID,IBEXSV
; get payer id for claim COB value
S IBPID=$$PAYERID(IBINS,IBFT)
; if no payer id, quit not allowed for edi
I IBPID="" Q 0
; if Primary Payer ID, CI5-3 is not in the PayerIDSwitch file, send as is.
S (OK,IB3648)=0 F S IB3648=$O(^IBA(364.8,"B",IBPID,IB3648)) Q:IB3648="" D Q:OK
. ; has entry been deactivate or flagged as deleted
. I $P($G(^IBA(364.8,IB3648,0)),"^",9)=1 Q
. S IB3648FT=$P($G(^IBA(364.8,IB3648,0)),"^",4)
. I IB3648FT'=1,IBFT'=IB3648FT Q
. S IB3648TF=$P($G(^IBA(364.8,IB3648,0)),"^",8)
. ;jws;4/20/25;can't do this check, no claim created yet, so no IBIEN value
. ;I $$PROD^XUPROD(1),'+$$TEST^IBCEF4(IBIEN),IB3648TF Q ;ICR 4440 (Supported)
. S OK=1
. Q
; if no entry found in COB-SWITCH file, quit not allowed for edi
I 'IB3648 Q 0
S IBEXSV=$P($G(^IBA(364.8,IB3648,0)),"^",11)
; if entry in PAYER ID - COB SWITCH file is found for all form types or specific form, quit 1 (approved for EDI)
I IBEXSV=1!(IBEXSV=IBFT) Q 1
; otherwise, quit not allowed for EDI
Q 0
;
PAYERID(IBINS,IBFT) ;
N IBINST,IBEBI
S IBINST=$S(IBFT=3:4,IBFT=7:15,1:2)
S IBEBI=$P($G(^DIC(36,IBINS,3)),U,IBINST)
S IBEBI=$$UP^XLFSTR(IBEBI)
Q IBEBI
;
24 ;LOOP 24
;SVx segments are service lines, SV1 = prof, SV2 = inst, SV3 = dental and 1st cpt code, SV5 - durable medical equip
I $E(SEG,1,2)="SV" D Q
. ;JWS;9/24/25;EBILL-6055;check procedure codes if surgical range 10000 thru 69999
. I $E(SEG,1,3)="SVD" Q
. N XIBPC,XIBMOD,I,X1
. S ^TMP("IB837ACC",$J,"L",IBSLINE,$P(ARG(IBSEG),"*"))=ARG(IBSEG)
. S XIBPC=$P($P(ARG(IBSEG),":",2),"*")
. ;JWS;10/9/25;EBILL-6111;check modifiers
. I $E(SEG,1,3)="SV2" S XIBMOD=$P($P(ARG(IBSEG),"*",3),":",3,6)
. E S XIBMOD=$P($P(ARG(IBSEG),"*",2),":",3,6)
. I $G(IBFT)="" D FT^IBCE837ACC3($S($E(ARG(IBSEG),3)=1:2,$E(ARG(IBSEG),3)=2:3,$E(ARG(IBSEG),3)=3:7,1:""))
. I $G(IBCPT)="" S IBCPT=XIBPC
. I $G(IBFT)=3,$$OPPROV^IBCE837ACC3(XIBPC) S $P(^TMP("IB837ACC",$J),"^",45)=1
. ;JWS;10/9/25;EBILL-6111;check modifiers
. F I=1:1:$L(XIBMOD,":") S X1=$P(XIBMOD,":",I) I X1'="" D
.. N X2,XPN
.. S X2=$$GETMOD^IBCE837ACC4(X1)
.. I X2 Q
.. S XPN=$P($$CPT^ICPTCOD(XIBPC),"^",3) ;ICR #1995 (Supported)
.. S X2N=$$AMBMOD^IBCE837ACC3($E(X1))_" to "_$$AMBMOD^IBCE837ACC3($E(X1,2))
.. D UP^IBCE837ACC(IBX12,111,5,XIBPC_" "_XPN_": "_X1_" "_X2N)
.. Q
. Q
I $E(SEG,1,4)="CR1*" Q ;amb info - not done at line level for VA
I $E(SEG,1,4)="CR3*" S $P(^TMP("IB837ACC",$J,"L",IBSLINE,0),"^",8)=$P(ARG(IBSEG),"*",2,4) Q ;durable med equip cert
I $E(SEG,1,4)="CRC*" D Q
. I SEG2=70 S $P(^TMP("IB837ACC",$J,"L",IBSLINE,0),"^",7)=$P(ARG(IBSEG),"*",2,4) Q ;hospice
. I SEG2="09" S $P(^TMP("IB837ACC",$J,"L",IBSLINE,0),"^",9)=$P(ARG(IBSEG),"*",2,5) Q ;cond indicator/dme
; get date of service from 1st service line
I $E(SEG,1,4)="DTP*" D Q
. I SEG2=472 D Q
.. N IBXDOS
.. I $P(ARG(IBSEG),"*",4)="" Q
.. S IBXDOS=3_$E($P(ARG(IBSEG),"*",4),3,8),$P(^TMP("IB837ACC",$J,"L",IBSLINE,0),"^",14)=IBXDOS
.. I $G(IBDOS)="" S (IBDOS,IBLDOS)=IBXDOS D SET^IBCE837ACC1(IBDOS,8),SET^IBCE837ACC1(IBLDOS,39) Q
.. I $G(IBXDOS)>IBDOS S IBLDOS=IBXDOS D SET^IBCE837ACC1(IBLDOS,39)
.. Q
. I SEG2=441!(SEG2=139) S $P(^TMP("IB837ACC",$J,"L",IBSLINE,0),"^")=$P(ARG(IBSEG),"*",2),$P(^(0),"^",2)=$P(ARG(IBSEG),"*",4) Q
. I SEG2=452 D SETL^IBCE837ACC3(3) Q
. I SEG2=446 D SETL^IBCE837ACC3(4) Q
. I SEG2=196 D SETL^IBCE837ACC3(5) Q
. I SEG2=198 D SETL^IBCE837ACC3(15) Q
. I SEG2=607 S $P(^TMP("IB837ACC",$J,"L",IBSLINE,0),"^",10)=$P(ARG(IBSEG),"*",4) Q ;certification revision/recert date
. I SEG2=463 S $P(^TMP("IB837ACC",$J,"L",IBSLINE,0),"^",11)=$P(ARG(IBSEG),"*",4) Q ;DME begin therapy date
. I SEG2=461 S $P(^TMP("IB837ACC",$J,"L",IBSLINE,0),"^",12)=$P(ARG(IBSEG),"*",4) Q ;DME last cert date
. Q
I $E(SEG,1,4)="REF*" D Q
. I SEG2="VY" S $P(^TMP("IB837ACC",$J,"L",IBSLINE,0),"^",13)=$P(ARG(IBSEG),"*",3) Q ;link sequence number - pharmacy
. I SEG2="XZ" S $P(^TMP("IB837ACC",$J,"L",IBSLINE,0),"^",13)=$P(ARG(IBSEG),"*",3) Q ;pharmacy prescription#
. Q
I $E(SEG,1,4)="PWK*" Q
I $E(SEG,1,3)="K3*" Q
I $E(SEG,1,4)="NTE*" D Q
. I SEG2="TPO" Q
. N I
. F I=1:1 I '$D(^TMP("IB837ACC",$J,"L",IBSLINE,"NTE",SEG2,I)) S ^(I)=$P(ARG(IBSEG),"*",3) Q
. Q
I $E(SEG,1,4)="HCP*" D Q
. S $P(^TMP("IB837ACC",$J,"L",IBSLINE,0),"^",6)=$P(ARG(IBSEG),"*",3) ;line level paid amt
. I '$G(IBACCRPC1) Q
. N IBIEN
. 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)=$P(ARG(IBSEG),"*",3)
. D UPDATE^DIE(,"FDA","IBIEN","ERROR")
. Q
;
I $E(SEG,1,4)="LIN*" S ^TMP("IB837ACC",$J,"L",IBSLINE,"LIN")=$P(ARG(IBSEG),"*",3,4) Q ;pharmacy
I $E(SEG,1,4)="CTP*" S ^TMP("IB837ACC",$J,"L",IBSLINE,"CTP")=$P(ARG(IBSEG),"*",5,6) Q ;drug quantity
I $E(SEG,1,4)="NM1*" D Q
. I SEG2=82 D Q ;NM101='82' - rendering provider
.. I $P(ARG(IBSEG),"*",4)="" Q ;other payer rendering provider
.. S IBPN1=$P(ARG(IBSEG),"*",4)_","_$P(ARG(IBSEG),"*",5)
.. ;11/24/25;JWS;EBILL-6206;add error 27 for missing taxonomy
.. S OK=$$CHK35593^IBCE837ACCU($P(ARG(IBSEG),"*",10),82,IBSLINE) I OK<1 D UP^IBCE837ACC(IBX12,$S(OK=-1:27,1:4),5,IBPN1_":"_$P(ARG(IBSEG),"*",10)) Q
.. S ^TMP("IB837ACC",$J,"L",IBSLINE,1,82)=$P(ARG(IBSEG),"*",10)_"^"_IBPN1_"^"_$S(OK=1:355.93,1:200)
.. Q
. I SEG2=72 D Q ;NM101='72' - operating physician
.. I $P(ARG(IBSEG),"*",4)="" Q ;other provider
.. S IBPN1=$P(ARG(IBSEG),"*",4)_","_$P(ARG(IBSEG),"*",5)
.. S OK=$$CHK35593^IBCE837ACCU($P(ARG(IBSEG),"*",10),72,IBSLINE) I 'OK D UP^IBCE837ACC(IBX12,4,5,IBPN1_":"_$P(ARG(IBSEG),"*",10)) Q
.. S ^TMP("IB837ACC",$J,"L",IBSLINE,1,72)=$P(ARG(IBSEG),"*",10)_"^"_IBPN1_"^"_$S(OK=1:355.93,1:200)
.. Q
. I SEG2="DQ" D Q ;NM101='DQ' = supervising provider
.. I $P(ARG(IBSEG),"*",4)="" Q ;other payer supervising provider
.. S IBPN1=$P(ARG(IBSEG),"*",4)_","_$P(ARG(IBSEG),"*",5)
.. S OK=$$CHK35593^IBCE837ACCU($P(ARG(IBSEG),"*",10),"DQ",IBSLINE) I 'OK D UP^IBCE837ACC(IBX12,4,5,IBPN1_":"_$P(ARG(IBSEG),"*",10)) Q
.. S ^TMP("IB837ACC",$J,"L",IBSLINE,1,"DQ")=$P(ARG(IBSEG),"*",10)_"^"_IBPN1_"^"_$S(OK=1:355.93,1:200)
.. Q
. I SEG2="ZZ" D Q ;NM101='ZZ' - other operating physician
.. I $P(ARG(IBSEG),"*",4)="" Q ;other provider
.. S IBPN1=$P(ARG(IBSEG),"*",4)_","_$P(ARG(IBSEG),"*",5)
.. S OK=$$CHK35593^IBCE837ACCU($P(ARG(IBSEG),"*",10),"ZZ",IBSLINE) I 'OK D UP^IBCE837ACC(IBX12,4,5,IBPN1_":"_$P(ARG(IBSEG),"*",10)) Q
.. S ^TMP("IB837ACC",$J,"L",IBSLINE,1,"ZZ")=$P(ARG(IBSEG),"*",10)_"^"_IBPN1_"^"_$S(OK=1:355.93,1:200)
.. Q
. I SEG2="DD" D Q ;NM101='DD' - assistant surgeon
.. I $P(ARG(IBSEG),"*",4)="" Q ;other provider
.. S IBPN1=$P(ARG(IBSEG),"*",4)_","_$P(ARG(IBSEG),"*",5)
.. S OK=$$CHK35593^IBCE837ACCU($P(ARG(IBSEG),"*",10),"DD",IBSLINE) I 'OK D UP^IBCE837ACC(IBX12,4,5,IBPN1_":"_$P(ARG(IBSEG),"*",10)) Q
.. S ^TMP("IB837ACC",$J,"L",IBSLINE,1,"DD")=$P(ARG(IBSEG),"*",10)_"^"_IBPN1_"^"_$S(OK=1:355.93,1:200)
.. Q
. I SEG2="DN" D Q ;referring provider
.. I $P(ARG(IBSEG),"*",4)="" Q ;other payer referring provider
.. S IBPN1=$P(ARG(IBSEG),"*",4)_","_$P(ARG(IBSEG),"*",5)
.. ;11/24/25;JWS;EBILL-6206;add error 27 for missing taxonomy
.. S OK=$$CHK35593^IBCE837ACCU($P(ARG(IBSEG),"*",10),"DN",IBSLINE) I OK<1 D UP^IBCE837ACC(IBX12,$S(OK=-1:27,1:4),5,IBPN1_":"_$P(ARG(IBSEG),"*",10)) Q
.. ;JWS;IB*2.0*770v11;11/11/24;EBILL-3551;address NOT ON FILE name issue
.. I $F(IBPN1,"NOT ON FILE") S IBPN1=$G(IBPN2)
.. S ^TMP("IB837ACC",$J,"L",IBSLINE,1,"DN")=$P(ARG(IBSEG),"*",10)_"^"_IBPN1_"^"_$S(OK=1:355.93,1:200)
.. Q
. I SEG2="QB" Q
. I SEG2="PW" D NEXT Q ;VistA does not send Ambulance info at line level
. I SEG2=45 D NEXT Q ;VistA does not send Ambulance info at line level
. I SEG2=77 D NEXT Q ;service facility - not used at line level for VA
. I SEG2="DK" D NEXT Q
. Q
I $E(SEG,1,7)="PRV*PE*" Q ;rendering provider specialty info
I $E(SEG,1,7)="PRV*AS*" Q ;assistant surgeon specialty info
I $E(SEG,1,4)="SVD*" Q
I $E(SEG,1,3)="LQ*" Q
I $E(SEG,1,4)="FRM*" Q
I $E(SEG,1,4)="TOO*" D Q
. F I=1:1:32 I '$D(^TMP("IB837ACC",$J,"L",IBSLINE,"TOO",I)) S ^(I)=ARG(IBSEG) Q
. Q
I $E(SEG,1,7)="QTY*PT*" Q
I $E(SEG,1,7)="QTY*FL*" Q
I $E(SEG,1,4)="MEA*" Q
I $E(SEG,1,4)="CN1*" Q
I $E(SEG,1,4)="PS1*" Q
Q
;
NEXT ;
S IBSEGN="SEG"_(IBI+1) I $E($G(ARG(IBSEGN)),1,3)="N3*" S IBI=IBI+1
S IBSEGN="SEG"_(IBI+1) I $E($G(ARG(IBSEGN)),1,3)="N4*" S IBI=IBI+1
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBCE837ACCU2 11263 printed May 25, 2026@12:14:12 Page 2
IBCE837ACCU2 ;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 QUIT
+5 ;
+6 ; Reference to $$CPT^ICPTCOD in ICR #1995 (Supported)
+7 ;
AUTH(IBIFN,ERRMSG,IBMRANOT) ; Entry Point
+1 ; This procedure's job is to authorize this bill. The manual
+2 ; process to authorize a bill is found in routine IBCB1. This
+3 ; routine borrows heavily from that routine.
+4 ;
+5 ; *** Any changes here should be considered also in IBCB1 ***
+6 ;
+7 ;
+8 ; Input
+9 ; IBIFN - internal bill#
+10 ; IBMRANOT - 1 indicates process is NOT from MRA
+11 ;
+12 ; Output
+13 ; ERRMSG - optional output parameter, passed by reference
+14 ; - error message text
+15 ;
+16 NEW IBTXSTAT,IB364,PRCASV,DFN,STSMSG,DIE,DA,DR,IBYY
+17 ;
+18 ; Check the bill, make sure the current status is valid
+19 SET IBIFN=+$GET(IBIFN)
SET ERRMSG=""
+20 ; Update the review status for all EOB's on file
+21 ; Accepted - Complete EOB
DO STAT^IBCEMU2(IBIFN,3)
+22 ;
+23 ; Checks for need to add any codes to bill for EDI (call in quiet mode)
+24 DO AUTOCK^IBCEU2(IBIFN,1)
+25 ;
+26 ; Calculate transmittable status
+27 ; 0 = not transmittable
+28 ; 1 = yes, live transmittable
+29 ; 2 = yes, test transmittable
+30 ; P432 add MRANOT flag so it will create new entry in trans file for non-MRA's
+31 SET IBTXSTAT=+$$TXMT^IBCEF4(IBIFN,,$GET(IBMRANOT))
+32 ;
+33 ; If transmittable, add this bill to the bill transmission file
+34 IF IBTXSTAT
Begin DoDot:1
+35 SET IB364=$$ADDTBILL^IBCB1(IBIFN,IBTXSTAT)
+36 QUIT
End DoDot:1
IF ERRMSG'=""
GOTO AUTHX
+37 ;
+38 ; Pass completed bill to Accounts Receivable (quietly)
+39 IF $GET(IBMRANOT)'=1
DO ARPASS^IBCB1(IBIFN,0)
IF '$GET(PRCASV("OKAY"))
SET ERRMSG="Error while passing bill to A/R."
GOTO AUTHX
+40 ;
AUTHX ;
+1 QUIT
+2 ;
SFRP ;check service facility and rendering provider
+1 ;if no service facility passed in X12, use original billing provider, per TR3 guides
+2 ;I '$D(^TMP("IB837ACC",$J,1,77)) D
+3 ;. N XNPI
+4 ;. S XNPI=$P($G(^TMP("IB837ACC",$J,1,85)),"^")
+5 ;. S OK=$$CHK35593^IBCE837ACCU(XNPI) I 'OK D UP^IBCE837ACC(IBX12,5,5,"NO SERVICE FACILITY IN X12 DATA") Q
+6 ;. M ^TMP("IB837ACC",$J,1,77)=^TMP("IB837ACC",$J,1,85)
+7 ;. Q
+8 ; if no rendering provider in X12, use original billing provider, per TR3 guides
+9 ;I '$D(^TMP("IB837ACC",$J,1,82)) D
+10 ;. N XNPI
+11 ;. S XNPI=$P($G(^TMP("IB837ACC",$J,1,85)),"^")
+12 ;. S OK=$$CHK35593^IBCE837ACCU(XNPI) I 'OK D UP^IBCE837ACC(IBX12,5,4,"NO RENDERING PROVIDER IN X12 DATA") Q
+13 ;. M ^TMP("IB837ACC",$J,1,82)=^TMP("IB837ACC",$J,1,85)
+14 ;. Q
+15 QUIT
+16 ;
SW(IBINS,IBFT) ; check file 364.8
+1 ;Prevent claims going out via EDI with NOEXC Payer ID;need function to check file 364.8
+2 NEW IBPID,OK,IB3648,IB3648FT,IB3648TF,IBTPAID,IBEXSV
+3 ; get payer id for claim COB value
+4 SET IBPID=$$PAYERID(IBINS,IBFT)
+5 ; if no payer id, quit not allowed for edi
+6 IF IBPID=""
QUIT 0
+7 ; if Primary Payer ID, CI5-3 is not in the PayerIDSwitch file, send as is.
+8 SET (OK,IB3648)=0
FOR
SET IB3648=$ORDER(^IBA(364.8,"B",IBPID,IB3648))
if IB3648=""
QUIT
Begin DoDot:1
+9 ; has entry been deactivate or flagged as deleted
+10 IF $PIECE($GET(^IBA(364.8,IB3648,0)),"^",9)=1
QUIT
+11 SET IB3648FT=$PIECE($GET(^IBA(364.8,IB3648,0)),"^",4)
+12 IF IB3648FT'=1
IF IBFT'=IB3648FT
QUIT
+13 SET IB3648TF=$PIECE($GET(^IBA(364.8,IB3648,0)),"^",8)
+14 ;jws;4/20/25;can't do this check, no claim created yet, so no IBIEN value
+15 ;I $$PROD^XUPROD(1),'+$$TEST^IBCEF4(IBIEN),IB3648TF Q ;ICR 4440 (Supported)
+16 SET OK=1
+17 QUIT
End DoDot:1
if OK
QUIT
+18 ; if no entry found in COB-SWITCH file, quit not allowed for edi
+19 IF 'IB3648
QUIT 0
+20 SET IBEXSV=$PIECE($GET(^IBA(364.8,IB3648,0)),"^",11)
+21 ; if entry in PAYER ID - COB SWITCH file is found for all form types or specific form, quit 1 (approved for EDI)
+22 IF IBEXSV=1!(IBEXSV=IBFT)
QUIT 1
+23 ; otherwise, quit not allowed for EDI
+24 QUIT 0
+25 ;
PAYERID(IBINS,IBFT) ;
+1 NEW IBINST,IBEBI
+2 SET IBINST=$SELECT(IBFT=3:4,IBFT=7:15,1:2)
+3 SET IBEBI=$PIECE($GET(^DIC(36,IBINS,3)),U,IBINST)
+4 SET IBEBI=$$UP^XLFSTR(IBEBI)
+5 QUIT IBEBI
+6 ;
24 ;LOOP 24
+1 ;SVx segments are service lines, SV1 = prof, SV2 = inst, SV3 = dental and 1st cpt code, SV5 - durable medical equip
+2 IF $EXTRACT(SEG,1,2)="SV"
Begin DoDot:1
+3 ;JWS;9/24/25;EBILL-6055;check procedure codes if surgical range 10000 thru 69999
+4 IF $EXTRACT(SEG,1,3)="SVD"
QUIT
+5 NEW XIBPC,XIBMOD,I,X1
+6 SET ^TMP("IB837ACC",$JOB,"L",IBSLINE,$PIECE(ARG(IBSEG),"*"))=ARG(IBSEG)
+7 SET XIBPC=$PIECE($PIECE(ARG(IBSEG),":",2),"*")
+8 ;JWS;10/9/25;EBILL-6111;check modifiers
+9 IF $EXTRACT(SEG,1,3)="SV2"
SET XIBMOD=$PIECE($PIECE(ARG(IBSEG),"*",3),":",3,6)
+10 IF '$TEST
SET XIBMOD=$PIECE($PIECE(ARG(IBSEG),"*",2),":",3,6)
+11 IF $GET(IBFT)=""
DO FT^IBCE837ACC3($SELECT($EXTRACT(ARG(IBSEG),3)=1:2,$EXTRACT(ARG(IBSEG),3)=2:3,$EXTRACT(ARG(IBSEG),3)=3:7,1:""))
+12 IF $GET(IBCPT)=""
SET IBCPT=XIBPC
+13 IF $GET(IBFT)=3
IF $$OPPROV^IBCE837ACC3(XIBPC)
SET $PIECE(^TMP("IB837ACC",$JOB),"^",45)=1
+14 ;JWS;10/9/25;EBILL-6111;check modifiers
+15 FOR I=1:1:$LENGTH(XIBMOD,":")
SET X1=$PIECE(XIBMOD,":",I)
IF X1'=""
Begin DoDot:2
+16 NEW X2,XPN
+17 SET X2=$$GETMOD^IBCE837ACC4(X1)
+18 IF X2
QUIT
+19 ;ICR #1995 (Supported)
SET XPN=$PIECE($$CPT^ICPTCOD(XIBPC),"^",3)
+20 SET X2N=$$AMBMOD^IBCE837ACC3($EXTRACT(X1))_" to "_$$AMBMOD^IBCE837ACC3($EXTRACT(X1,2))
+21 DO UP^IBCE837ACC(IBX12,111,5,XIBPC_" "_XPN_": "_X1_" "_X2N)
+22 QUIT
End DoDot:2
+23 QUIT
End DoDot:1
QUIT
+24 ;amb info - not done at line level for VA
IF $EXTRACT(SEG,1,4)="CR1*"
QUIT
+25 ;durable med equip cert
IF $EXTRACT(SEG,1,4)="CR3*"
SET $PIECE(^TMP("IB837ACC",$JOB,"L",IBSLINE,0),"^",8)=$PIECE(ARG(IBSEG),"*",2,4)
QUIT
+26 IF $EXTRACT(SEG,1,4)="CRC*"
Begin DoDot:1
+27 ;hospice
IF SEG2=70
SET $PIECE(^TMP("IB837ACC",$JOB,"L",IBSLINE,0),"^",7)=$PIECE(ARG(IBSEG),"*",2,4)
QUIT
+28 ;cond indicator/dme
IF SEG2="09"
SET $PIECE(^TMP("IB837ACC",$JOB,"L",IBSLINE,0),"^",9)=$PIECE(ARG(IBSEG),"*",2,5)
QUIT
End DoDot:1
QUIT
+29 ; get date of service from 1st service line
+30 IF $EXTRACT(SEG,1,4)="DTP*"
Begin DoDot:1
+31 IF SEG2=472
Begin DoDot:2
+32 NEW IBXDOS
+33 IF $PIECE(ARG(IBSEG),"*",4)=""
QUIT
+34 SET IBXDOS=3_$EXTRACT($PIECE(ARG(IBSEG),"*",4),3,8)
SET $PIECE(^TMP("IB837ACC",$JOB,"L",IBSLINE,0),"^",14)=IBXDOS
+35 IF $GET(IBDOS)=""
SET (IBDOS,IBLDOS)=IBXDOS
DO SET^IBCE837ACC1(IBDOS,8)
DO SET^IBCE837ACC1(IBLDOS,39)
QUIT
+36 IF $GET(IBXDOS)>IBDOS
SET IBLDOS=IBXDOS
DO SET^IBCE837ACC1(IBLDOS,39)
+37 QUIT
End DoDot:2
QUIT
+38 IF SEG2=441!(SEG2=139)
SET $PIECE(^TMP("IB837ACC",$JOB,"L",IBSLINE,0),"^")=$PIECE(ARG(IBSEG),"*",2)
SET $PIECE(^(0),"^",2)=$PIECE(ARG(IBSEG),"*",4)
QUIT
+39 IF SEG2=452
DO SETL^IBCE837ACC3(3)
QUIT
+40 IF SEG2=446
DO SETL^IBCE837ACC3(4)
QUIT
+41 IF SEG2=196
DO SETL^IBCE837ACC3(5)
QUIT
+42 IF SEG2=198
DO SETL^IBCE837ACC3(15)
QUIT
+43 ;certification revision/recert date
IF SEG2=607
SET $PIECE(^TMP("IB837ACC",$JOB,"L",IBSLINE,0),"^",10)=$PIECE(ARG(IBSEG),"*",4)
QUIT
+44 ;DME begin therapy date
IF SEG2=463
SET $PIECE(^TMP("IB837ACC",$JOB,"L",IBSLINE,0),"^",11)=$PIECE(ARG(IBSEG),"*",4)
QUIT
+45 ;DME last cert date
IF SEG2=461
SET $PIECE(^TMP("IB837ACC",$JOB,"L",IBSLINE,0),"^",12)=$PIECE(ARG(IBSEG),"*",4)
QUIT
+46 QUIT
End DoDot:1
QUIT
+47 IF $EXTRACT(SEG,1,4)="REF*"
Begin DoDot:1
+48 ;link sequence number - pharmacy
IF SEG2="VY"
SET $PIECE(^TMP("IB837ACC",$JOB,"L",IBSLINE,0),"^",13)=$PIECE(ARG(IBSEG),"*",3)
QUIT
+49 ;pharmacy prescription#
IF SEG2="XZ"
SET $PIECE(^TMP("IB837ACC",$JOB,"L",IBSLINE,0),"^",13)=$PIECE(ARG(IBSEG),"*",3)
QUIT
+50 QUIT
End DoDot:1
QUIT
+51 IF $EXTRACT(SEG,1,4)="PWK*"
QUIT
+52 IF $EXTRACT(SEG,1,3)="K3*"
QUIT
+53 IF $EXTRACT(SEG,1,4)="NTE*"
Begin DoDot:1
+54 IF SEG2="TPO"
QUIT
+55 NEW I
+56 FOR I=1:1
IF '$DATA(^TMP("IB837ACC",$JOB,"L",IBSLINE,"NTE",SEG2,I))
SET ^(I)=$PIECE(ARG(IBSEG),"*",3)
QUIT
+57 QUIT
End DoDot:1
QUIT
+58 IF $EXTRACT(SEG,1,4)="HCP*"
Begin DoDot:1
+59 ;line level paid amt
SET $PIECE(^TMP("IB837ACC",$JOB,"L",IBSLINE,0),"^",6)=$PIECE(ARG(IBSEG),"*",3)
+60 IF '$GET(IBACCRPC1)
QUIT
+61 NEW IBIEN
+62 NEW FDA,ERROR,DA,D0,DR,DIE,DIC,DI,DQ,DD,DINUM,DLAYGO,DTOUT,DUOUT
+63 SET IBIEN="+1,"_IBX12_","
+64 SET FDA(364.96,IBIEN,.01)=IBSLINE
+65 SET FDA(364.96,IBIEN,.02)=$PIECE(ARG(IBSEG),"*",3)
+66 DO UPDATE^DIE(,"FDA","IBIEN","ERROR")
+67 QUIT
End DoDot:1
QUIT
+68 ;
+69 ;pharmacy
IF $EXTRACT(SEG,1,4)="LIN*"
SET ^TMP("IB837ACC",$JOB,"L",IBSLINE,"LIN")=$PIECE(ARG(IBSEG),"*",3,4)
QUIT
+70 ;drug quantity
IF $EXTRACT(SEG,1,4)="CTP*"
SET ^TMP("IB837ACC",$JOB,"L",IBSLINE,"CTP")=$PIECE(ARG(IBSEG),"*",5,6)
QUIT
+71 IF $EXTRACT(SEG,1,4)="NM1*"
Begin DoDot:1
+72 ;NM101='82' - rendering provider
IF SEG2=82
Begin DoDot:2
+73 ;other payer rendering provider
IF $PIECE(ARG(IBSEG),"*",4)=""
QUIT
+74 SET IBPN1=$PIECE(ARG(IBSEG),"*",4)_","_$PIECE(ARG(IBSEG),"*",5)
+75 ;11/24/25;JWS;EBILL-6206;add error 27 for missing taxonomy
+76 SET OK=$$CHK35593^IBCE837ACCU($PIECE(ARG(IBSEG),"*",10),82,IBSLINE)
IF OK<1
DO UP^IBCE837ACC(IBX12,$SELECT(OK=-1:27,1:4),5,IBPN1_":"_$PIECE(ARG(IBSEG),"*",10))
QUIT
+77 SET ^TMP("IB837ACC",$JOB,"L",IBSLINE,1,82)=$PIECE(ARG(IBSEG),"*",10)_"^"_IBPN1_"^"_$SELECT(OK=1:355.93,1:200)
+78 QUIT
End DoDot:2
QUIT
+79 ;NM101='72' - operating physician
IF SEG2=72
Begin DoDot:2
+80 ;other provider
IF $PIECE(ARG(IBSEG),"*",4)=""
QUIT
+81 SET IBPN1=$PIECE(ARG(IBSEG),"*",4)_","_$PIECE(ARG(IBSEG),"*",5)
+82 SET OK=$$CHK35593^IBCE837ACCU($PIECE(ARG(IBSEG),"*",10),72,IBSLINE)
IF 'OK
DO UP^IBCE837ACC(IBX12,4,5,IBPN1_":"_$PIECE(ARG(IBSEG),"*",10))
QUIT
+83 SET ^TMP("IB837ACC",$JOB,"L",IBSLINE,1,72)=$PIECE(ARG(IBSEG),"*",10)_"^"_IBPN1_"^"_$SELECT(OK=1:355.93,1:200)
+84 QUIT
End DoDot:2
QUIT
+85 ;NM101='DQ' = supervising provider
IF SEG2="DQ"
Begin DoDot:2
+86 ;other payer supervising provider
IF $PIECE(ARG(IBSEG),"*",4)=""
QUIT
+87 SET IBPN1=$PIECE(ARG(IBSEG),"*",4)_","_$PIECE(ARG(IBSEG),"*",5)
+88 SET OK=$$CHK35593^IBCE837ACCU($PIECE(ARG(IBSEG),"*",10),"DQ",IBSLINE)
IF 'OK
DO UP^IBCE837ACC(IBX12,4,5,IBPN1_":"_$PIECE(ARG(IBSEG),"*",10))
QUIT
+89 SET ^TMP("IB837ACC",$JOB,"L",IBSLINE,1,"DQ")=$PIECE(ARG(IBSEG),"*",10)_"^"_IBPN1_"^"_$SELECT(OK=1:355.93,1:200)
+90 QUIT
End DoDot:2
QUIT
+91 ;NM101='ZZ' - other operating physician
IF SEG2="ZZ"
Begin DoDot:2
+92 ;other provider
IF $PIECE(ARG(IBSEG),"*",4)=""
QUIT
+93 SET IBPN1=$PIECE(ARG(IBSEG),"*",4)_","_$PIECE(ARG(IBSEG),"*",5)
+94 SET OK=$$CHK35593^IBCE837ACCU($PIECE(ARG(IBSEG),"*",10),"ZZ",IBSLINE)
IF 'OK
DO UP^IBCE837ACC(IBX12,4,5,IBPN1_":"_$PIECE(ARG(IBSEG),"*",10))
QUIT
+95 SET ^TMP("IB837ACC",$JOB,"L",IBSLINE,1,"ZZ")=$PIECE(ARG(IBSEG),"*",10)_"^"_IBPN1_"^"_$SELECT(OK=1:355.93,1:200)
+96 QUIT
End DoDot:2
QUIT
+97 ;NM101='DD' - assistant surgeon
IF SEG2="DD"
Begin DoDot:2
+98 ;other provider
IF $PIECE(ARG(IBSEG),"*",4)=""
QUIT
+99 SET IBPN1=$PIECE(ARG(IBSEG),"*",4)_","_$PIECE(ARG(IBSEG),"*",5)
+100 SET OK=$$CHK35593^IBCE837ACCU($PIECE(ARG(IBSEG),"*",10),"DD",IBSLINE)
IF 'OK
DO UP^IBCE837ACC(IBX12,4,5,IBPN1_":"_$PIECE(ARG(IBSEG),"*",10))
QUIT
+101 SET ^TMP("IB837ACC",$JOB,"L",IBSLINE,1,"DD")=$PIECE(ARG(IBSEG),"*",10)_"^"_IBPN1_"^"_$SELECT(OK=1:355.93,1:200)
+102 QUIT
End DoDot:2
QUIT
+103 ;referring provider
IF SEG2="DN"
Begin DoDot:2
+104 ;other payer referring provider
IF $PIECE(ARG(IBSEG),"*",4)=""
QUIT
+105 SET IBPN1=$PIECE(ARG(IBSEG),"*",4)_","_$PIECE(ARG(IBSEG),"*",5)
+106 ;11/24/25;JWS;EBILL-6206;add error 27 for missing taxonomy
+107 SET OK=$$CHK35593^IBCE837ACCU($PIECE(ARG(IBSEG),"*",10),"DN",IBSLINE)
IF OK<1
DO UP^IBCE837ACC(IBX12,$SELECT(OK=-1:27,1:4),5,IBPN1_":"_$PIECE(ARG(IBSEG),"*",10))
QUIT
+108 ;JWS;IB*2.0*770v11;11/11/24;EBILL-3551;address NOT ON FILE name issue
+109 IF $FIND(IBPN1,"NOT ON FILE")
SET IBPN1=$GET(IBPN2)
+110 SET ^TMP("IB837ACC",$JOB,"L",IBSLINE,1,"DN")=$PIECE(ARG(IBSEG),"*",10)_"^"_IBPN1_"^"_$SELECT(OK=1:355.93,1:200)
+111 QUIT
End DoDot:2
QUIT
+112 IF SEG2="QB"
QUIT
+113 ;VistA does not send Ambulance info at line level
IF SEG2="PW"
DO NEXT
QUIT
+114 ;VistA does not send Ambulance info at line level
IF SEG2=45
DO NEXT
QUIT
+115 ;service facility - not used at line level for VA
IF SEG2=77
DO NEXT
QUIT
+116 IF SEG2="DK"
DO NEXT
QUIT
+117 QUIT
End DoDot:1
QUIT
+118 ;rendering provider specialty info
IF $EXTRACT(SEG,1,7)="PRV*PE*"
QUIT
+119 ;assistant surgeon specialty info
IF $EXTRACT(SEG,1,7)="PRV*AS*"
QUIT
+120 IF $EXTRACT(SEG,1,4)="SVD*"
QUIT
+121 IF $EXTRACT(SEG,1,3)="LQ*"
QUIT
+122 IF $EXTRACT(SEG,1,4)="FRM*"
QUIT
+123 IF $EXTRACT(SEG,1,4)="TOO*"
Begin DoDot:1
+124 FOR I=1:1:32
IF '$DATA(^TMP("IB837ACC",$JOB,"L",IBSLINE,"TOO",I))
SET ^(I)=ARG(IBSEG)
QUIT
+125 QUIT
End DoDot:1
QUIT
+126 IF $EXTRACT(SEG,1,7)="QTY*PT*"
QUIT
+127 IF $EXTRACT(SEG,1,7)="QTY*FL*"
QUIT
+128 IF $EXTRACT(SEG,1,4)="MEA*"
QUIT
+129 IF $EXTRACT(SEG,1,4)="CN1*"
QUIT
+130 IF $EXTRACT(SEG,1,4)="PS1*"
QUIT
+131 QUIT
+132 ;
NEXT ;
+1 SET IBSEGN="SEG"_(IBI+1)
IF $EXTRACT($GET(ARG(IBSEGN)),1,3)="N3*"
SET IBI=IBI+1
+2 SET IBSEGN="SEG"_(IBI+1)
IF $EXTRACT($GET(ARG(IBSEGN)),1,3)="N4*"
SET IBI=IBI+1
+3 QUIT
+4 ;
