IBCE837ACC3 ;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)
;
; tag : 24 - loop 2400 process loop 2400 for incoming encounter from TAS API business.js service
; NB - check for Medicare Non-Billable
24 ;LOOP 24
;SVx segments are service lines, SV1 = prof, SV2 = inst, SV3 = dental and 1st cpt code, SV5 - durable medical equip
; SV1*HC:99222*420*UN*1***1:2
; SV2*0301*HC:83880*509*UN*1**285.04
; SV3*AD:D4341:::::PERIODONTAL SCALING AND ROOT P*270**10
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),"*")
. 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($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(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($E(X1))_" to "_$$AMBMOD($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="07" Q ;amb cert - not done at line level for VA
. 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=573 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(3) Q
. I SEG2=446 D SETL(4) Q
. I SEG2=196 D SETL(5) Q
. I SEG2=198 D SETL(15) Q
. I SEG2=471 Q ;prescription date
. I SEG2=607 D SETL(10) Q ;certification revision/recert date
. I SEG2=463 D SETL(11) Q ;DME begin therapy date
. I SEG2=461 D SETL(12) Q ;DME last cert date
. I SEG2=304 Q ;date last seen - not reported at line level for VA
. I SEG2=738 Q ;hemoglobin or hematocrit test date
. I SEG2=739 Q ;serum creatine test date
. I SEG2="011" Q ;shipped date
. I SEG2=455 Q ;x-ray date - not reported at line level for VA
. I SEG2=454 Q ;initial treatment date - not reported at line level for VA
. Q
I $E(SEG,1,4)="REF*" D Q
. ;JWS;9/29/25;EBILL-6085;issue with linking payment metadata to service line for non-network CC claims
. I SEG2="6R",$P($G(^TMP("IB837ACC",$J,"L",IBSLINE,0)),"^",6)="" D
.. N XLCN
.. S XLCN=$P(ARG(IBSEG),"*",3) I XLCN="" Q
.. N X,IBIEN
.. S X=$G(ARG(XLCN_"_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 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
. N X
. S $P(^TMP("IB837ACC",$J,"L",IBSLINE,0),"^",6)=$P(ARG(IBSEG),"*",3) ;line level paid amt
. S X=$P($G(^TMP("IB837ACC",$J)),"^",43),X=X+$P(ARG(IBSEG),"*",3),$P(^($J),"^",43)=X
. 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^IBCE837ACC1 Q ;VistA does not send Ambulance info at line level
. I SEG2=45 D NEXT^IBCE837ACC1 Q ;VistA does not send Ambulance info at line level
. I SEG2=77 D NEXT^IBCE837ACC1 Q ;service facility - not used at line level for VA
. I SEG2="DK" D NEXT^IBCE837ACC1 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,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
;
;JWS;7/3/25;EBILL-5534;suppress claims containing vaccine codes as non-billable
NB(IBPROD) ; check proc codes for billable status to all insurances
N X,OK
I IBPROD="" Q 0
S OK=0
S X=$$FIND1^DIC(364.991,,"X","ACCPROCNONBILL") I X D
. N XTASP
. S XTASP=$$GET1^DIQ(364.991,X_",",.1)
. I $F(XTASP,IBPROD_"|") S OK=1
. Q
Q OK
;JWS;7/3/25;EBILL-5534;suppress claims containing vaccine codes as non-billable;changed tag name
MNB(IBPROD) ;check for Medicare Non-Billable
N XED,XL,XLD,PROC,PROCD,OK
S XED=$G(^TMP("IB837ACC",$J)) I XED="" Q 0
I $P($P(XED,"^",2),"*",3)'="M" Q 0 ; must be medicare
S OK=0
; home healthcare/hospice
I IBPROD?1"G"4N D Q OK
. N X S X=$E(IBPROD,2,5)
. I +X<151 Q
. I +X>164,+X'=299,+X'=300,+X'=493,+X'=494,+X'=495,+X'=496 Q
. S OK=1
. Q
I IBPROD?1"Q"4N D Q OK
. N X S X=$E(IBPROD,2,5)
. I +X'=5001,+X'=5002,+X'=5009 Q
. S OK=1
. Q
; routine labs / IB edit already checks for 80000-89999
I IBPROD?1"8"4N D Q OK
. N X S X=$E(IBPROD,2,5)
. I +X<47 Q
. I +X>7999 Q
. S OK=1
. Q
;JWS;12/2/24;EBILL-4554;IB*2.0*770v15;added procedure codes 36415 and 36416 to Lab codes 100% covered by Medicare
I $F(",36415,36416,",","_IBPROD_",") Q 1
; mammograms
I IBPROD?1"77"3N D Q OK
. N X S X=$E(IBPROD,3,5)
. I X<63 Q
. I X>67 Q
. S OK=1
. Q
; acupuncture
I IBPROD?1"978"2N D Q OK
. N X S X=$E(IBPROD,4,5)
. I +X<10 Q
. I +X>14 Q
. S OK=1
. Q
; hearing aid exams/services
I IBPROD?1"925"2N D Q OK
. N X S X=$E(IBPROD,4,5)
. I +X<90 Q
. I +X>95 Q
. S OK=1
. Q
; self mgmt / education & training
I IBPROD?1"989"2N D Q OK
. N X S X=$E(IBPROD,4,5)
. I +X<60 Q
. I +X>62 Q
. S OK=1
. Q
; refractions
I IBPROD=92015 Q 1
I $E(IBPROD)="H" Q 1
I $E(IBPROD)="T" Q 1
;JWS;11/4/25;EBILL-6197;IB*2.0*770v51;add S codes
I $E(IBPROD)="S" Q 1
I IBPROD?1"978"2N D Q OK
. N X S X=$E(IBPROD,4,5)
. I +X<2 Q
. I +X>4 Q
. S OK=1
. Q
I IBPROD?1"G"4N D Q OK
. N X S X=$E(IBPROD,2,5)
. I +X=270!(+X=271) S OK=1
. Q
Q 0
;
EX() ;CPT code exception checking
N XL,XCT,XCT1,XR
S XL="" F XCT=0:1 S XL=$O(^TMP("IB837ACC",$J,"L",XL)) Q:XL="" I $P($G(^(XL,0)),"^",16)=1!($P($G(^(0)),"^",19)=1) S XCT1=$G(XCT1)+1
S XR=XCT_"^"_$G(XCT1)
Q XR
;
EX1(IBPROD) ;Medicare Excluded Services - dialysis proc codes
N XED,XL,XLD,PROC,PROCD,OK
S XED=$G(^TMP("IB837ACC",$J)) I XED="" Q 0
I $P($P(XED,"^",2),"*",3)'="M" Q 0
S OK=1
I $E(IBPROD,1,2)=90 D Q OK
. N X S X=$E(IBPROD,3,5)
. I +X=999 Q
. I +X>934,+X<937 Q
. I +X>944,+X<948 Q
. I +X>950,+X<963 Q
. S OK=0
. Q
Q 0
;
FT(FT) ;
I FT="" Q
S IBFT=FT,IBCPT=$P($P(ARG(IBSEG),":",2),"*")
Q
;
SETL(PIECE) ;
S $P(^TMP("IB837ACC",$J,"L",IBSLINE,0),"^",PIECE)=$P(ARG(IBSEG),"*",4) Q
Q
;
OPPROV(XIBPC) ;check procedure code to determine if operating provider is required on UB-04 institutional claim
;I +$E(XIBPC,1,2)>9,+$E(XIBPC,1,2)<70
N XIB,XIB1,XIBPC1,I,OK
S XIB=$$FIND1^DIC(364.991,,"X","ACCPROCOPPROV")
I 'XIB Q 0
S XIB1=$$GET1^DIQ(364.991,XIB_",",.1)
I '+XIB1 Q 0
S OK=0 F I=1:1:$L(XIB1,"|") S XIBPC1=$P(XIB1,"|",I) I XIBPC1'="" D I OK Q
. I XIBPC=$P(XIBPC1,":") S OK=1 Q
. I $F(XIBPC1,":") D Q
.. I +XIBPC>$P(XIBPC1,":"),+XIBPC<$P(XIBPC1,":",2) S OK=1 Q
.. I +XIBPC=$P(XIBPC1,":",2) S OK=1 Q
Q OK
;
AMBMOD(X2) ;
N X,NM,I
S NM="",X=$$FIND1^DIC(364.991,,"X","ACCAMBMOD1") I X D
. N X1
. S X1=$$GET1^DIQ(364.991,X_",",.1)
. S X=$$FIND1^DIC(364.991,,"X","ACCAMBMOD2") I X S X1=$G(X1)_$$GET1^DIQ(364.991,X_",",.1)
. F I=1:1:$L(X1,"|") I $P($P(X1,"|",I),":")=X2 S NM=$P($P(X1,"|",I),":",2) Q
. Q
Q NM
;
NOTE(IBIEN,TEXT) ; create history entry
N IBDATA
S IBDATA(1)=TEXT
D WP^DIE(364.94,"1,"_IBX12_",",10,"A","IBDATA","ERROR")
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBCE837ACC3 12145 printed May 25, 2026@12:14:08 Page 2
IBCE837ACC3 ;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 QUIT
+4 ;
+5 ; Reference to $$CPT^ICPTCOD in ICR #1995 (Supported)
+6 ;
+7 ; tag : 24 - loop 2400 process loop 2400 for incoming encounter from TAS API business.js service
+8 ; NB - check for Medicare Non-Billable
24 ;LOOP 24
+1 ;SVx segments are service lines, SV1 = prof, SV2 = inst, SV3 = dental and 1st cpt code, SV5 - durable medical equip
+2 ; SV1*HC:99222*420*UN*1***1:2
+3 ; SV2*0301*HC:83880*509*UN*1**285.04
+4 ; SV3*AD:D4341:::::PERIODONTAL SCALING AND ROOT P*270**10
+5 IF $EXTRACT(SEG,1,2)="SV"
Begin DoDot:1
+6 ;JWS;9/24/25;EBILL-6055;check procedure codes if surgical range 10000 thru 69999
+7 IF $EXTRACT(SEG,1,3)="SVD"
QUIT
+8 NEW XIBPC,XIBMOD,I,X1
+9 SET ^TMP("IB837ACC",$JOB,"L",IBSLINE,$PIECE(ARG(IBSEG),"*"))=ARG(IBSEG)
+10 SET XIBPC=$PIECE($PIECE(ARG(IBSEG),":",2),"*")
+11 IF $EXTRACT(SEG,1,3)="SV2"
SET XIBMOD=$PIECE($PIECE(ARG(IBSEG),"*",3),":",3,6)
+12 IF '$TEST
SET XIBMOD=$PIECE($PIECE(ARG(IBSEG),"*",2),":",3,6)
+13 IF $GET(IBFT)=""
DO FT($SELECT($EXTRACT(ARG(IBSEG),3)=1:2,$EXTRACT(ARG(IBSEG),3)=2:3,$EXTRACT(ARG(IBSEG),3)=3:7,1:""))
+14 IF $GET(IBCPT)=""
SET IBCPT=XIBPC
+15 IF $GET(IBFT)=3
IF $$OPPROV(XIBPC)
SET $PIECE(^TMP("IB837ACC",$JOB),"^",45)=1
+16 ;JWS;10/9/25;EBILL-6111;check modifiers
+17 FOR I=1:1:$LENGTH(XIBMOD,":")
SET X1=$PIECE(XIBMOD,":",I)
IF X1'=""
Begin DoDot:2
+18 NEW X2,XPN
+19 SET X2=$$GETMOD^IBCE837ACC4(X1)
+20 IF X2
QUIT
+21 ;ICR #1995 (Supported)
SET XPN=$PIECE($$CPT^ICPTCOD(XIBPC),"^",3)
+22 SET X2N=$$AMBMOD($EXTRACT(X1))_" to "_$$AMBMOD($EXTRACT(X1,2))
+23 DO UP^IBCE837ACC(IBX12,111,5,XIBPC_" "_XPN_": "_X1_" "_X2N)
+24 QUIT
End DoDot:2
+25 QUIT
End DoDot:1
QUIT
+26 ;amb info - not done at line level for VA
IF $EXTRACT(SEG,1,4)="CR1*"
QUIT
+27 ;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
+28 IF $EXTRACT(SEG,1,4)="CRC*"
Begin DoDot:1
+29 ;amb cert - not done at line level for VA
IF SEG2="07"
QUIT
+30 ;hospice
IF SEG2=70
SET $PIECE(^TMP("IB837ACC",$JOB,"L",IBSLINE,0),"^",7)=$PIECE(ARG(IBSEG),"*",2,4)
QUIT
+31 ;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
+32 ; get date of service from 1st service line
+33 IF $EXTRACT(SEG,1,4)="DTP*"
Begin DoDot:1
+34 IF SEG2=472
Begin DoDot:2
+35 NEW IBXDOS
+36 IF $PIECE(ARG(IBSEG),"*",4)=""
QUIT
+37 SET IBXDOS=3_$EXTRACT($PIECE(ARG(IBSEG),"*",4),3,8)
SET $PIECE(^TMP("IB837ACC",$JOB,"L",IBSLINE,0),"^",14)=IBXDOS
+38 IF $GET(IBDOS)=""
SET (IBDOS,IBLDOS)=IBXDOS
DO SET^IBCE837ACC1(IBDOS,8)
DO SET^IBCE837ACC1(IBLDOS,39)
QUIT
+39 IF $GET(IBXDOS)>IBDOS
SET IBLDOS=IBXDOS
DO SET^IBCE837ACC1(IBLDOS,39)
+40 QUIT
End DoDot:2
QUIT
+41 IF SEG2=573
QUIT
+42 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
+43 IF SEG2=452
DO SETL(3)
QUIT
+44 IF SEG2=446
DO SETL(4)
QUIT
+45 IF SEG2=196
DO SETL(5)
QUIT
+46 IF SEG2=198
DO SETL(15)
QUIT
+47 ;prescription date
IF SEG2=471
QUIT
+48 ;certification revision/recert date
IF SEG2=607
DO SETL(10)
QUIT
+49 ;DME begin therapy date
IF SEG2=463
DO SETL(11)
QUIT
+50 ;DME last cert date
IF SEG2=461
DO SETL(12)
QUIT
+51 ;date last seen - not reported at line level for VA
IF SEG2=304
QUIT
+52 ;hemoglobin or hematocrit test date
IF SEG2=738
QUIT
+53 ;serum creatine test date
IF SEG2=739
QUIT
+54 ;shipped date
IF SEG2="011"
QUIT
+55 ;x-ray date - not reported at line level for VA
IF SEG2=455
QUIT
+56 ;initial treatment date - not reported at line level for VA
IF SEG2=454
QUIT
+57 QUIT
End DoDot:1
QUIT
+58 IF $EXTRACT(SEG,1,4)="REF*"
Begin DoDot:1
+59 ;JWS;9/29/25;EBILL-6085;issue with linking payment metadata to service line for non-network CC claims
+60 IF SEG2="6R"
IF $PIECE($GET(^TMP("IB837ACC",$JOB,"L",IBSLINE,0)),"^",6)=""
Begin DoDot:2
+61 NEW XLCN
+62 SET XLCN=$PIECE(ARG(IBSEG),"*",3)
IF XLCN=""
QUIT
+63 NEW X,IBIEN
+64 SET X=$GET(ARG(XLCN_"_SVC03"))
IF X=""
QUIT
+65 NEW FDA,ERROR,DA,D0,DR,DIE,DIC,DI,DQ,DD,DINUM,DLAYGO,DTOUT,DUOUT
+66 SET IBIEN="+1,"_IBX12_","
+67 SET FDA(364.96,IBIEN,.01)=IBSLINE
+68 SET FDA(364.96,IBIEN,.02)=$JUSTIFY(X,"",2)
+69 DO UPDATE^DIE(,"FDA","IBIEN","ERROR")
+70 SET $PIECE(^TMP("IB837ACC",$JOB,"L",IBSLINE,0),"^",6)=X
+71 QUIT
End DoDot:2
+72 ;link sequence number - pharmacy
IF SEG2="VY"
SET $PIECE(^TMP("IB837ACC",$JOB,"L",IBSLINE,0),"^",13)=$PIECE(ARG(IBSEG),"*",3)
QUIT
+73 ;pharmacy prescription#
IF SEG2="XZ"
SET $PIECE(^TMP("IB837ACC",$JOB,"L",IBSLINE,0),"^",13)=$PIECE(ARG(IBSEG),"*",3)
QUIT
+74 QUIT
End DoDot:1
QUIT
+75 IF $EXTRACT(SEG,1,4)="PWK*"
QUIT
+76 IF $EXTRACT(SEG,1,3)="K3*"
QUIT
+77 IF $EXTRACT(SEG,1,4)="NTE*"
Begin DoDot:1
+78 IF SEG2="TPO"
QUIT
+79 NEW I
+80 FOR I=1:1
IF '$DATA(^TMP("IB837ACC",$JOB,"L",IBSLINE,"NTE",SEG2,I))
SET ^(I)=$PIECE(ARG(IBSEG),"*",3)
QUIT
+81 QUIT
End DoDot:1
QUIT
+82 IF $EXTRACT(SEG,1,4)="HCP*"
Begin DoDot:1
+83 NEW X
+84 ;line level paid amt
SET $PIECE(^TMP("IB837ACC",$JOB,"L",IBSLINE,0),"^",6)=$PIECE(ARG(IBSEG),"*",3)
+85 SET X=$PIECE($GET(^TMP("IB837ACC",$JOB)),"^",43)
SET X=X+$PIECE(ARG(IBSEG),"*",3)
SET $PIECE(^($JOB),"^",43)=X
+86 QUIT
End DoDot:1
QUIT
+87 ;pharmacy
IF $EXTRACT(SEG,1,4)="LIN*"
SET ^TMP("IB837ACC",$JOB,"L",IBSLINE,"LIN")=$PIECE(ARG(IBSEG),"*",3,4)
QUIT
+88 ;drug quantity
IF $EXTRACT(SEG,1,4)="CTP*"
SET ^TMP("IB837ACC",$JOB,"L",IBSLINE,"CTP")=$PIECE(ARG(IBSEG),"*",5,6)
QUIT
+89 IF $EXTRACT(SEG,1,4)="NM1*"
Begin DoDot:1
+90 ;NM101='82' - rendering provider
IF SEG2=82
Begin DoDot:2
+91 ;other payer rendering provider
IF $PIECE(ARG(IBSEG),"*",4)=""
QUIT
+92 SET IBPN1=$PIECE(ARG(IBSEG),"*",4)_","_$PIECE(ARG(IBSEG),"*",5)
+93 ;11/24/25;JWS;EBILL-6206;add error 27 for missing taxonomy
+94 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
+95 SET ^TMP("IB837ACC",$JOB,"L",IBSLINE,1,82)=$PIECE(ARG(IBSEG),"*",10)_"^"_IBPN1_"^"_$SELECT(OK=1:355.93,1:200)
+96 QUIT
End DoDot:2
QUIT
+97 ;NM101='72' - operating physician
IF SEG2=72
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),72,IBSLINE)
IF 'OK
DO UP^IBCE837ACC(IBX12,4,5,IBPN1_":"_$PIECE(ARG(IBSEG),"*",10))
QUIT
+101 SET ^TMP("IB837ACC",$JOB,"L",IBSLINE,1,72)=$PIECE(ARG(IBSEG),"*",10)_"^"_IBPN1_"^"_$SELECT(OK=1:355.93,1:200)
+102 QUIT
End DoDot:2
QUIT
+103 ;NM101='DQ' = supervising provider
IF SEG2="DQ"
Begin DoDot:2
+104 ;other payer supervising provider
IF $PIECE(ARG(IBSEG),"*",4)=""
QUIT
+105 SET IBPN1=$PIECE(ARG(IBSEG),"*",4)_","_$PIECE(ARG(IBSEG),"*",5)
+106 SET OK=$$CHK35593^IBCE837ACCU($PIECE(ARG(IBSEG),"*",10),"DQ",IBSLINE)
IF 'OK
DO UP^IBCE837ACC(IBX12,4,5,IBPN1_":"_$PIECE(ARG(IBSEG),"*",10))
QUIT
+107 SET ^TMP("IB837ACC",$JOB,"L",IBSLINE,1,"DQ")=$PIECE(ARG(IBSEG),"*",10)_"^"_IBPN1_"^"_$SELECT(OK=1:355.93,1:200)
+108 QUIT
End DoDot:2
QUIT
+109 ;NM101='ZZ' - other operating physician
IF SEG2="ZZ"
Begin DoDot:2
+110 ;other provider
IF $PIECE(ARG(IBSEG),"*",4)=""
QUIT
+111 SET IBPN1=$PIECE(ARG(IBSEG),"*",4)_","_$PIECE(ARG(IBSEG),"*",5)
+112 SET OK=$$CHK35593^IBCE837ACCU($PIECE(ARG(IBSEG),"*",10),"ZZ",IBSLINE)
IF 'OK
DO UP^IBCE837ACC(IBX12,4,5,IBPN1_":"_$PIECE(ARG(IBSEG),"*",10))
QUIT
+113 SET ^TMP("IB837ACC",$JOB,"L",IBSLINE,1,"ZZ")=$PIECE(ARG(IBSEG),"*",10)_"^"_IBPN1_"^"_$SELECT(OK=1:355.93,1:200)
+114 QUIT
End DoDot:2
QUIT
+115 ;NM101='DD' - assistant surgeon
IF SEG2="DD"
Begin DoDot:2
+116 ;other provider
IF $PIECE(ARG(IBSEG),"*",4)=""
QUIT
+117 SET IBPN1=$PIECE(ARG(IBSEG),"*",4)_","_$PIECE(ARG(IBSEG),"*",5)
+118 SET OK=$$CHK35593^IBCE837ACCU($PIECE(ARG(IBSEG),"*",10),"DD",IBSLINE)
IF 'OK
DO UP^IBCE837ACC(IBX12,4,5,IBPN1_":"_$PIECE(ARG(IBSEG),"*",10))
QUIT
+119 SET ^TMP("IB837ACC",$JOB,"L",IBSLINE,1,"DD")=$PIECE(ARG(IBSEG),"*",10)_"^"_IBPN1_"^"_$SELECT(OK=1:355.93,1:200)
+120 QUIT
End DoDot:2
QUIT
+121 ;referring provider
IF SEG2="DN"
Begin DoDot:2
+122 ;other payer referring provider
IF $PIECE(ARG(IBSEG),"*",4)=""
QUIT
+123 SET IBPN1=$PIECE(ARG(IBSEG),"*",4)_","_$PIECE(ARG(IBSEG),"*",5)
+124 ;11/24/25;JWS;EBILL-6206;add error 27 for missing taxonomy
+125 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
+126 ;JWS;IB*2.0*770v11;11/11/24;EBILL-3551;address NOT ON FILE name issue
+127 IF $FIND(IBPN1,"NOT ON FILE")
SET IBPN1=$GET(IBPN2)
+128 SET ^TMP("IB837ACC",$JOB,"L",IBSLINE,1,"DN")=$PIECE(ARG(IBSEG),"*",10)_"^"_IBPN1_"^"_$SELECT(OK=1:355.93,1:200)
+129 QUIT
End DoDot:2
QUIT
+130 IF SEG2="QB"
QUIT
+131 ;VistA does not send Ambulance info at line level
IF SEG2="PW"
DO NEXT^IBCE837ACC1
QUIT
+132 ;VistA does not send Ambulance info at line level
IF SEG2=45
DO NEXT^IBCE837ACC1
QUIT
+133 ;service facility - not used at line level for VA
IF SEG2=77
DO NEXT^IBCE837ACC1
QUIT
+134 IF SEG2="DK"
DO NEXT^IBCE837ACC1
QUIT
+135 QUIT
End DoDot:1
QUIT
+136 ;rendering provider specialty info
IF $EXTRACT(SEG,1,7)="PRV*PE*"
QUIT
+137 ;assistant surgeon specialty info
IF $EXTRACT(SEG,1,7)="PRV*AS*"
QUIT
+138 IF $EXTRACT(SEG,1,3)="LQ*"
QUIT
+139 IF $EXTRACT(SEG,1,4)="FRM*"
QUIT
+140 IF $EXTRACT(SEG,1,4)="TOO*"
Begin DoDot:1
+141 FOR I=1:1:32
IF '$DATA(^TMP("IB837ACC",$JOB,"L",IBSLINE,"TOO",I))
SET ^(I)=ARG(IBSEG)
QUIT
+142 QUIT
End DoDot:1
QUIT
+143 IF $EXTRACT(SEG,1,7)="QTY*PT*"
QUIT
+144 IF $EXTRACT(SEG,1,7)="QTY*FL*"
QUIT
+145 IF $EXTRACT(SEG,1,4)="MEA*"
QUIT
+146 IF $EXTRACT(SEG,1,4)="CN1*"
QUIT
+147 IF $EXTRACT(SEG,1,4)="PS1*"
QUIT
+148 QUIT
+149 ;
+150 ;JWS;7/3/25;EBILL-5534;suppress claims containing vaccine codes as non-billable
NB(IBPROD) ; check proc codes for billable status to all insurances
+1 NEW X,OK
+2 IF IBPROD=""
QUIT 0
+3 SET OK=0
+4 SET X=$$FIND1^DIC(364.991,,"X","ACCPROCNONBILL")
IF X
Begin DoDot:1
+5 NEW XTASP
+6 SET XTASP=$$GET1^DIQ(364.991,X_",",.1)
+7 IF $FIND(XTASP,IBPROD_"|")
SET OK=1
+8 QUIT
End DoDot:1
+9 QUIT OK
+10 ;JWS;7/3/25;EBILL-5534;suppress claims containing vaccine codes as non-billable;changed tag name
MNB(IBPROD) ;check for Medicare Non-Billable
+1 NEW XED,XL,XLD,PROC,PROCD,OK
+2 SET XED=$GET(^TMP("IB837ACC",$JOB))
IF XED=""
QUIT 0
+3 ; must be medicare
IF $PIECE($PIECE(XED,"^",2),"*",3)'="M"
QUIT 0
+4 SET OK=0
+5 ; home healthcare/hospice
+6 IF IBPROD?1"G"4N
Begin DoDot:1
+7 NEW X
SET X=$EXTRACT(IBPROD,2,5)
+8 IF +X<151
QUIT
+9 IF +X>164
IF +X'=299
IF +X'=300
IF +X'=493
IF +X'=494
IF +X'=495
IF +X'=496
QUIT
+10 SET OK=1
+11 QUIT
End DoDot:1
QUIT OK
+12 IF IBPROD?1"Q"4N
Begin DoDot:1
+13 NEW X
SET X=$EXTRACT(IBPROD,2,5)
+14 IF +X'=5001
IF +X'=5002
IF +X'=5009
QUIT
+15 SET OK=1
+16 QUIT
End DoDot:1
QUIT OK
+17 ; routine labs / IB edit already checks for 80000-89999
+18 IF IBPROD?1"8"4N
Begin DoDot:1
+19 NEW X
SET X=$EXTRACT(IBPROD,2,5)
+20 IF +X<47
QUIT
+21 IF +X>7999
QUIT
+22 SET OK=1
+23 QUIT
End DoDot:1
QUIT OK
+24 ;JWS;12/2/24;EBILL-4554;IB*2.0*770v15;added procedure codes 36415 and 36416 to Lab codes 100% covered by Medicare
+25 IF $FIND(",36415,36416,",","_IBPROD_",")
QUIT 1
+26 ; mammograms
+27 IF IBPROD?1"77"3N
Begin DoDot:1
+28 NEW X
SET X=$EXTRACT(IBPROD,3,5)
+29 IF X<63
QUIT
+30 IF X>67
QUIT
+31 SET OK=1
+32 QUIT
End DoDot:1
QUIT OK
+33 ; acupuncture
+34 IF IBPROD?1"978"2N
Begin DoDot:1
+35 NEW X
SET X=$EXTRACT(IBPROD,4,5)
+36 IF +X<10
QUIT
+37 IF +X>14
QUIT
+38 SET OK=1
+39 QUIT
End DoDot:1
QUIT OK
+40 ; hearing aid exams/services
+41 IF IBPROD?1"925"2N
Begin DoDot:1
+42 NEW X
SET X=$EXTRACT(IBPROD,4,5)
+43 IF +X<90
QUIT
+44 IF +X>95
QUIT
+45 SET OK=1
+46 QUIT
End DoDot:1
QUIT OK
+47 ; self mgmt / education & training
+48 IF IBPROD?1"989"2N
Begin DoDot:1
+49 NEW X
SET X=$EXTRACT(IBPROD,4,5)
+50 IF +X<60
QUIT
+51 IF +X>62
QUIT
+52 SET OK=1
+53 QUIT
End DoDot:1
QUIT OK
+54 ; refractions
+55 IF IBPROD=92015
QUIT 1
+56 IF $EXTRACT(IBPROD)="H"
QUIT 1
+57 IF $EXTRACT(IBPROD)="T"
QUIT 1
+58 ;JWS;11/4/25;EBILL-6197;IB*2.0*770v51;add S codes
+59 IF $EXTRACT(IBPROD)="S"
QUIT 1
+60 IF IBPROD?1"978"2N
Begin DoDot:1
+61 NEW X
SET X=$EXTRACT(IBPROD,4,5)
+62 IF +X<2
QUIT
+63 IF +X>4
QUIT
+64 SET OK=1
+65 QUIT
End DoDot:1
QUIT OK
+66 IF IBPROD?1"G"4N
Begin DoDot:1
+67 NEW X
SET X=$EXTRACT(IBPROD,2,5)
+68 IF +X=270!(+X=271)
SET OK=1
+69 QUIT
End DoDot:1
QUIT OK
+70 QUIT 0
+71 ;
EX() ;CPT code exception checking
+1 NEW XL,XCT,XCT1,XR
+2 SET XL=""
FOR XCT=0:1
SET XL=$ORDER(^TMP("IB837ACC",$JOB,"L",XL))
if XL=""
QUIT
IF $PIECE($GET(^(XL,0)),"^",16)=1!($PIECE($GET(^(0)),"^",19)=1)
SET XCT1=$GET(XCT1)+1
+3 SET XR=XCT_"^"_$GET(XCT1)
+4 QUIT XR
+5 ;
EX1(IBPROD) ;Medicare Excluded Services - dialysis proc codes
+1 NEW XED,XL,XLD,PROC,PROCD,OK
+2 SET XED=$GET(^TMP("IB837ACC",$JOB))
IF XED=""
QUIT 0
+3 IF $PIECE($PIECE(XED,"^",2),"*",3)'="M"
QUIT 0
+4 SET OK=1
+5 IF $EXTRACT(IBPROD,1,2)=90
Begin DoDot:1
+6 NEW X
SET X=$EXTRACT(IBPROD,3,5)
+7 IF +X=999
QUIT
+8 IF +X>934
IF +X<937
QUIT
+9 IF +X>944
IF +X<948
QUIT
+10 IF +X>950
IF +X<963
QUIT
+11 SET OK=0
+12 QUIT
End DoDot:1
QUIT OK
+13 QUIT 0
+14 ;
FT(FT) ;
+1 IF FT=""
QUIT
+2 SET IBFT=FT
SET IBCPT=$PIECE($PIECE(ARG(IBSEG),":",2),"*")
+3 QUIT
+4 ;
SETL(PIECE) ;
+1 SET $PIECE(^TMP("IB837ACC",$JOB,"L",IBSLINE,0),"^",PIECE)=$PIECE(ARG(IBSEG),"*",4)
QUIT
+2 QUIT
+3 ;
OPPROV(XIBPC) ;check procedure code to determine if operating provider is required on UB-04 institutional claim
+1 ;I +$E(XIBPC,1,2)>9,+$E(XIBPC,1,2)<70
+2 NEW XIB,XIB1,XIBPC1,I,OK
+3 SET XIB=$$FIND1^DIC(364.991,,"X","ACCPROCOPPROV")
+4 IF 'XIB
QUIT 0
+5 SET XIB1=$$GET1^DIQ(364.991,XIB_",",.1)
+6 IF '+XIB1
QUIT 0
+7 SET OK=0
FOR I=1:1:$LENGTH(XIB1,"|")
SET XIBPC1=$PIECE(XIB1,"|",I)
IF XIBPC1'=""
Begin DoDot:1
+8 IF XIBPC=$PIECE(XIBPC1,":")
SET OK=1
QUIT
+9 IF $FIND(XIBPC1,":")
Begin DoDot:2
+10 IF +XIBPC>$PIECE(XIBPC1,":")
IF +XIBPC<$PIECE(XIBPC1,":",2)
SET OK=1
QUIT
+11 IF +XIBPC=$PIECE(XIBPC1,":",2)
SET OK=1
QUIT
End DoDot:2
QUIT
End DoDot:1
IF OK
QUIT
+12 QUIT OK
+13 ;
AMBMOD(X2) ;
+1 NEW X,NM,I
+2 SET NM=""
SET X=$$FIND1^DIC(364.991,,"X","ACCAMBMOD1")
IF X
Begin DoDot:1
+3 NEW X1
+4 SET X1=$$GET1^DIQ(364.991,X_",",.1)
+5 SET X=$$FIND1^DIC(364.991,,"X","ACCAMBMOD2")
IF X
SET X1=$GET(X1)_$$GET1^DIQ(364.991,X_",",.1)
+6 FOR I=1:1:$LENGTH(X1,"|")
IF $PIECE($PIECE(X1,"|",I),":")=X2
SET NM=$PIECE($PIECE(X1,"|",I),":",2)
QUIT
+7 QUIT
End DoDot:1
+8 QUIT NM
+9 ;
NOTE(IBIEN,TEXT) ; create history entry
+1 NEW IBDATA
+2 SET IBDATA(1)=TEXT
+3 DO WP^DIE(364.94,"1,"_IBX12_",",10,"A","IBDATA","ERROR")
+4 QUIT
+5 ;
