IBCE837ACCU1 ;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
;
23 ;LOOP 23
I $E(SEG,1,4)="PAT*" Q ;patient - relationship to insured
I $E(SEG,1,4)="SBR*" Q ; LOOP=23
I $E(SEG,1,4)="NM1*" D Q
. I SEG2="PR" D NEXT Q ;other payer name
. I SEG2="IL" D D NEXT Q ;other subscriber name
.. I $G(IBPATIEN)'="" Q
.. ; 6/6/25;JWS;need to delete previous missing pat failure reason code
.. N IB36491 S IB36491=$O(^IBA(364.91,"B",1,0)) I 'IB36491 Q
.. S IBX=0 F S IBX=$O(^IBA(364.9,IBX12,5,IBX)) Q:IBX'=+IBX I $P($G(^(IBX,0)),"^")=IB36491 S DA(1)=IBX12,DIK="^IBA(364.9,"_DA(1)_",5,",DA=IBX D ^DIK
.. ;6/6/25;JWS;if previous icn lookup failed, attempt to find patient using other sub info (example had SSN here)
.. D PAT^IBCE837ACC4
.. Q
. I SEG2="QC" D Q ;patient name
.. D NEXT
.. I $G(IBPATLN)=$P(ARG(IBSEG),"*",4),$G(IBPATFN)=$P(ARG(IBSEG),"*",5),$G(IBPATMN)=$P(ARG(IBSEG),"*",6) Q ;patient is subscriber
.. ;patient is not veteran, so generate exception error
.. D UP^IBCE837ACC(IBX12,11,5,IBPATLN_","_IBPATFN_" "_$P(ARG(IBSEG),"*",4)_","_$P(ARG(IBSEG),"*",5)_" "_$P(ARG(IBSEG),"*",6))
.. Q
. I SEG2="PW" D Q ;amb pickup add
.. S IBSEGN="SEG"_(IBI+1) I $E($G(ARG(IBSEGN)),1,3)="N3*" D
... D SET^IBCE837ACC1($P(ARG(IBSEGN),"*",2),1,"AMB") S IBI=IBI+1
.. S IBSEGN="SEG"_(IBI+1) I $E($G(ARG(IBSEGN)),1,3)="N4*" D
... D SET^IBCE837ACC1($P(ARG(IBSEGN),"*",2,4),2,"AMB") S IBI=IBI+1
.. Q
. I SEG2=45 D Q ;amb drop-off loc
.. ;JWS;10/8/25;EBILL-6111;IB*2.0*770v49;adding amb drop-off loc name
.. ;JWS;2/2/26;EBILL-6482;IB*2.0*770v61;wrong variable was IBSEGN, should have been IBSEG (current seg data)
.. D SET^IBCE837ACC1($P(ARG(IBSEG),"*",4),5,"AMB")
.. S IBSEGN="SEG"_(IBI+1) I $E($G(ARG(IBSEGN)),1,3)="N3*" D
... D SET^IBCE837ACC1($P(ARG(IBSEGN),"*",2),3,"AMB") S IBI=IBI+1
.. S IBSEGN="SEG"_(IBI+1) I $E($G(ARG(IBSEGN)),1,3)="N4*" D
... D SET^IBCE837ACC1($P(ARG(IBSEGN),"*",2,4),4,"AMB") S IBI=IBI+1
.. Q
. I SEG2="DN" D Q ;DN - referring prov
.. N XIBPNAME,XIBPNPI
.. I $P(ARG(IBSEG),"*",4)="" Q ;other payer referring provider
.. S XIBPNAME=$P(ARG(IBSEG),"*",4)_","_$P(ARG(IBSEG),"*",5),XIBPNPI=$P(ARG(IBSEG),"*",10)
.. ;11/24/25;JWS;EBILL-6206;add error 27 for missing taxonomy
.. S OK=$$CHK35593^IBCE837ACCU(XIBPNPI,"DN") I OK<1 D UP^IBCE837ACC(IBX12,$S(OK=-1:27,1:4),5,XIBPNAME_":"_XIBPNPI)
.. ;JWS;IB*2.0*770v11;11/11/24;EBILL-3551;address NOT ON FILE name issue
.. I $F(XIBPNAME,"NOT ON FILE") S XIBPNAME=$G(IBPN2)
.. ;JWS;12/5/24;IB*2.0*770v15;remove storing referring provider into the encounter zero node
.. ;I $G(IBPN)="" S IBPN=XIBPNAME,IBPT="DN",IBPNPI=XIBPNPI
.. D SET^IBCE837ACC1(XIBPNPI,1.1,"DN"),SET^IBCE837ACC1(XIBPNAME,1.2,"DN"),SET^IBCE837ACC1($S(OK=1:355.93,1:200),1.3,"DN")
.. Q
. I SEG2=82 D Q ;NM101='82' - rendering prov
.. N XIBPNAME,XIBPNPI
.. I $P(ARG(IBSEG),"*",4)="" Q ;other payer rendering
.. S XIBPNAME=$P(ARG(IBSEG),"*",4)_","_$P(ARG(IBSEG),"*",5),XIBPNPI=$P(ARG(IBSEG),"*",10)
.. I $G(IBPN)="" S IBPN=XIBPNAME,IBPT=82,IBPNPI=XIBPNPI
.. ;11/24/25;JWS;EBILL-6206;add error 27 for missing taxonomy
.. S OK=$$CHK35593^IBCE837ACCU(XIBPNPI,82) I OK<1 D UP^IBCE837ACC(IBX12,$S(OK=-1:27,1:4),5,XIBPNAME_":"_XIBPNPI)
.. D SET^IBCE837ACC1(XIBPNPI,1.1,82),SET^IBCE837ACC1(XIBPNAME,1.2,82),SET^IBCE837ACC1($S(OK=1:355.93,1:200),1.3,82)
.. Q
. I SEG2=77 D Q ;NM101='77' - service facility
.. D NEXT
.. S IBPN1=$P(ARG(IBSEG),"*",4) I IBPN1="" Q ;other payer service facility
.. S OK=$$CHK35593^IBCE837ACCU($P(ARG(IBSEG),"*",10),77) I 'OK D UP^IBCE837ACC(IBX12,5,5,IBPN1_":"_$P(ARG(IBSEG),"*",10))
.. ;JWS;IB*2.0*770v10;11/11/24;EBILL-3551;address NOT ON FILE name issue
.. I $F(IBPN1,"NOT ON FILE") S IBPN1=$G(IBPN2)
.. D SET^IBCE837ACC1($P(ARG(IBSEG),"*",10),1.1,77),SET^IBCE837ACC1(IBPN1,1.2,77),SET^IBCE837ACC1($S(OK=1:355.93,1:200),1.3,77)
.. 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") I 'OK D UP^IBCE837ACC(IBX12,4,5,IBPN1_":"_$P(ARG(IBSEG),"*",10))
.. D SET^IBCE837ACC1($P(ARG(IBSEG),"*",10),1.1,"DQ"),SET^IBCE837ACC1($S(OK=1:355.93,1:200),1.3,"DQ")
.. Q
. I SEG2=71 D Q ;NM101='71' = attending provider
.. N XIBPNAME,XIBPNPI
.. I $P(ARG(IBSEG),"*",4)="" Q ;
.. S XIBPNAME=$P(ARG(IBSEG),"*",4)_","_$P(ARG(IBSEG),"*",5),XIBPNPI=$P(ARG(IBSEG),"*",10)
.. I $G(IBPN)="" S IBPN=XIBPNAME,IBPT=71,IBPNPI=XIBPNPI
.. ;11/24/25;JWS;EBILL-6206;add error 27 for missing taxonomy
.. S OK=$$CHK35593^IBCE837ACCU(XIBPNPI,71) I OK<1 D UP^IBCE837ACC(IBX12,$S(OK=-1:27,1:4),5,XIBPNAME_":"_XIBPNPI)
.. D SET^IBCE837ACC1(XIBPNPI,1.1,71),SET^IBCE837ACC1($S(OK=1:355.93,1:200),1.3,71)
.. Q
. I SEG2=72 D Q ;NM101='72' = operating physician
.. I $P(ARG(IBSEG),"*",4)="" Q ;
.. S IBPN1=$P(ARG(IBSEG),"*",4)_","_$P(ARG(IBSEG),"*",5)
.. S OK=$$CHK35593^IBCE837ACCU($P(ARG(IBSEG),"*",10),72) I 'OK D UP^IBCE837ACC(IBX12,4,5,IBPN1_":"_$P(ARG(IBSEG),"*",10))
.. D SET^IBCE837ACC1($P(ARG(IBSEG),"*",10),1.1,72),SET^IBCE837ACC1(IBPN1,1.2,72),SET^IBCE837ACC1($S(OK=1:355.93,1:200),1.3,72)
.. Q
. I SEG2="ZZ" D Q ;NM101='ZZ' = other operating physician
.. I $P(ARG(IBSEG),"*",4)="" Q ;
.. S IBPN1=$P(ARG(IBSEG),"*",4)_","_$P(ARG(IBSEG),"*",5)
.. S OK=$$CHK35593^IBCE837ACCU($P(ARG(IBSEG),"*",10),"ZZ") I 'OK D UP^IBCE837ACC(IBX12,4,5,IBPN1_":"_$P(ARG(IBSEG),"*",10))
.. D SET^IBCE837ACC1($P(ARG(IBSEG),"*",10),1.1,"ZZ"),SET^IBCE837ACC1($S(OK=1:355.93,1:200),1.3,"ZZ")
.. Q
. I SEG2=85 Q ;other billing provider name
. I SEG2="DD" D Q ;NM101='DD' = assistant surgeon
.. I $P(ARG(IBSEG),"*",4)="" Q
.. S IBPN1=$P(ARG(IBSEG),"*",4)_","_$P(ARG(IBSEG),"*",5)
.. S OK=$$CHK35593^IBCE837ACCU($P(ARG(IBSEG),"*",10),"DD") I 'OK D UP^IBCE837ACC(IBX12,4,5,IBPN1_":"_$P(ARG(IBSEG),"*",10))
.. D SET^IBCE837ACC1($P(ARG(IBSEG),"*",10),1.1,"DD"),SET^IBCE837ACC1($S(OK=1:355.93,1:200),1.3,"DD")
.. Q
. Q
I $E(SEG,1,4)="DMG*" D Q
. ;JWS;1/6/26;EBILL-6357;only set IBDOB if not already defined with VistA patient info
. S DOB=$P(ARG(IBSEG),"*",3) I DOB'="",$G(IBDOB)="" S IBDOB=$S($E(DOB,1,2)=19:2,1:3)_$E(DOB,3,8) Q
. Q
;get claim charge amt and place of service code from CLM loop 2300
I $E(SEG,1,4)="CLM*" D SET^IBCE837ACC1($P(ARG(IBSEG),"*",3),5),SET^IBCE837ACC1($P($P(ARG(IBSEG),"*",6),":"),6) Q
I $E(SEG,1,4)="DTP*" D Q
. I SEG2=431 D DT(9) Q ;399,.03 ;date of onset
. I SEG2=454 D DT(10) Q ;399,246 ;date of initial treatment
. I SEG2=304 D DT(11) Q ;399,237 ;date last seen
. I SEG2=453 D DT(12) Q ;399,247 ;date acute manifestation
. I SEG2=439 D DT(13) Q ;399,41,.02 - OCCURRENCE CODE = 01 ;accident date
. I SEG2=484 D DT(14) Q ;399,41,.02 - OCCURRENCE CODE = 10 ;last menstrual period
. I SEG2=455 D DT(15) Q ;399,245 ;date last x-ray
. I SEG2=471 Q ;hearing & vision prescription date
. I SEG2=314 D DT(16) Q ;399,263 and 264 ;disability start and end dates
. I SEG2=360 D DT(37) Q ;399,263 ;disability start date
. I SEG2=361 D DT(38) Q ;399,264 ;disability end date
. I SEG2=297 D DT(17) Q ;399,166 ;date last worked
. I SEG2=296 D DT(18) Q ;399,166 ;date authorized return to work
. ;check admission date - if DTP segment exists, then it's inpatient claim
. I SEG2=435 S IBIO="I" D DT(19) Q ;admission date - inpatient
. I SEG2="096" D DT(20) Q ;discharge date
. I SEG2="090" D DT(21) Q ;assumed care date
. I SEG2="091" D DT(22) Q ;relinquished care date
. I SEG2=444 D DT(23) Q ;first visit date
. I SEG2="050" Q ;repricer date
. I SEG2=573 Q ;claim check/ remittance date
. I SEG2=434 D Q
.. D DT(33) ;inst statement dates
.. N IBXDOS
.. I $P(ARG(IBSEG),"*",4)="" Q
.. S IBXDOS=3_$E($P(ARG(IBSEG),"*",4),3,8)
.. S IBDOS=IBXDOS D SET^IBCE837ACC1(IBDOS,8)
.. S IBLDOS=3_$E($P($P(ARG(IBSEG),"*",4),"-",2),3,8)
.. I IBLDOS=3 S IBLDOS=IBXDOS
.. D SET^IBCE837ACC1(IBLDOS,39)
.. Q
. I SEG2=452 D DT(35) Q ;dental appliance placement date
. I SEG2=472 D Q
.. D DT(36)
.. I $G(IBDOS)="" S (IBDOS,IBLDOS)=$P(^TMP("IB837ACC",$J),"^",36) D SET^IBCE837ACC1(IBDOS,8),SET^IBCE837ACC1(IBLDOS,39) Q ;dental date of service - claim level
.. Q
I $E(SEG,1,4)="CL1*" D SET^IBCE837ACC1(ARG(IBSEG),1,"CL1") Q
I $E(SEG,1,4)="PWK*" Q
I $E(SEG,1,4)="CN1*" Q ;NON-HIPPA USE
I $E(SEG,1,4)="REF*" D Q
. I SEG2="D9" S IBREFD9=$P(ARG(IBSEG),"*",3) Q ;claim identifier for transmission intermediaries
. I SEG2="EW" D SET^IBCE837ACC1($P(ARG(IBSEG),"*",3),24) Q
. I SEG2="X4" D SET^IBCE837ACC1($P(ARG(IBSEG),"*",3),25) Q
. ;JWS;10/23/25;EBILL-6172;add authorization and referral variables
. I SEG2="G1" S IBAUTH=$P(ARG(IBSEG),"*",3) Q
. I SEG2="9F" S IBREF=$P(ARG(IBSEG),"*",3) Q
. ;JWS;EBILL-4922;IB*2.0*770v18;add payer claim control number to encounter
. ;JWS;6/9/25;appears that cc encounters have the payer control number segment in loop 2330B (other payer claim control number)
. ;JWS;6/9/25;so adding conditional check in case future encounters have value in loop 2300
. I SEG2="F8",$P($G(^TMP("IB837ACC",$J)),"^",44)="" D SET^IBCE837ACC1($P(ARG(IBSEG),"*",3),44) Q
. Q
I $E(SEG,1,3)="K3*" Q ;file info
I $E(SEG,1,4)="NTE*" D SET^IBCE837ACC1($P(ARG(IBSEG),"*",3),1,"NTE"_"-"_$P(ARG(IBSEG),"*",2)) Q
I $E(SEG,1,4)="CR1*" D SET^IBCE837ACC1(ARG(IBSEG),1,"CR1") S $P(^TMP("IBCE837ACC",$J),"^",40)=1 Q ; ambulance transport info
I $E(SEG,1,4)="CR2*" Q
I $E(SEG,1,4)="CRC*" D Q
. I SEG2="07" D SET^IBCE837ACC1(ARG(IBSEG),1,"CRC07") Q ;amb certification
. I SEG2=75 D SET^IBCE837ACC1($P(ARG(IBSEG),"*",3,4),26) Q
. I SEG2="ZZ" D SET^IBCE837ACC1($P(ARG(IBSEG),"*",3,4),27) Q
. Q
;get principle diagnosis code
I $E(SEG,1,3)="HI*" D Q
. I $P(SEG2,":")="ABK" S IBPDX=$P($P(ARG(IBSEG),":",2),"*") D SET^IBCE837ACC1(ARG(IBSEG),1,"HI-D"),SET^IBCE837ACC1(IBPDX,7) Q ;diagnosis codes
. I $P(SEG2,":")="ABF" D SET^IBCE837ACC1(ARG(IBSEG),1,"HI-O") Q ;other-diagnosis
. I $P(SEG2,":")="ABJ" Q ;admitting diagnosis - need if/when doing inpatient
. I $P(SEG2,":")="APR" D SET^IBCE837ACC1($P(ARG(IBSEG),"*",2,4),28) Q ;reason for visit
. I $P(SEG2,":")="ABN" D SET^IBCE837ACC1(ARG(IBSEG),1,"HI-E") Q ;external cause of injury
. I $E(SEG2,1,3)="DR:" Q ;DRG group (inpatient inst)
. I $E(SEG2,1,3)="BP:" D SET^IBCE837ACC1($P($P(ARG(IBSEG),"*",2),":",2),34) Q ;anesthesia surgical code
. I $E(SEG2,1,4)="BBR:" D SET^IBCE837ACC1($P(ARG(IBSEG),"*",2),30) Q
. I $E(SEG2,1,4)="BBQ:" D SET^IBCE837ACC1($P(ARG(IBSEG),"*",2,13),1,"PROC") Q
. I $E(SEG2,1,3)="BI:" D SET^IBCE837ACC1($P(ARG(IBSEG),"*",2,13),1,"OSC") Q
. I $E(SEG2,1,3)="BH:" D SET^IBCE837ACC1($P(ARG(IBSEG),"*",2,13),1,"OC") Q ;"HI*BH:05:D8:20230501*BH:18:D8:20020301"
. I $E(SEG2,1,3)="BE:" D SET^IBCE837ACC1($P(ARG(IBSEG),"*",2,13),1,"CV") Q ;HI*BE:01:::2500*BE:80:::1
. I $E(SEG2,1,3)="BG:" D SET^IBCE837ACC1($P(ARG(IBSEG),"*",2,13),1,"CC") Q
. I $E(SEG2,1,3)="TC:" Q ;probably never get - Treatment Code Info
I $E(SEG,1,4)="DN1*" D SET^IBCE837ACC1($P(ARG(IBSEG),"*",2,5),1,"DN1") Q ;ortho total months
I $E(SEG,1,4)="DN2*" D SET^IBCE837ACC1($P(ARG(IBSEG),"*",2,7),1,"DN2") Q ;tooth status
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
;
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
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBCE837ACCU1 11928 printed May 25, 2026@12:14:11 Page 2
IBCE837ACCU1 ;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 ;
23 ;LOOP 23
+1 ;patient - relationship to insured
IF $EXTRACT(SEG,1,4)="PAT*"
QUIT
+2 ; LOOP=23
IF $EXTRACT(SEG,1,4)="SBR*"
QUIT
+3 IF $EXTRACT(SEG,1,4)="NM1*"
Begin DoDot:1
+4 ;other payer name
IF SEG2="PR"
DO NEXT
QUIT
+5 ;other subscriber name
IF SEG2="IL"
Begin DoDot:2
+6 IF $GET(IBPATIEN)'=""
QUIT
+7 ; 6/6/25;JWS;need to delete previous missing pat failure reason code
+8 NEW IB36491
SET IB36491=$ORDER(^IBA(364.91,"B",1,0))
IF 'IB36491
QUIT
+9 SET IBX=0
FOR
SET IBX=$ORDER(^IBA(364.9,IBX12,5,IBX))
if IBX'=+IBX
QUIT
IF $PIECE($GET(^(IBX,0)),"^")=IB36491
SET DA(1)=IBX12
SET DIK="^IBA(364.9,"_DA(1)_",5,"
SET DA=IBX
DO ^DIK
+10 ;6/6/25;JWS;if previous icn lookup failed, attempt to find patient using other sub info (example had SSN here)
+11 DO PAT^IBCE837ACC4
+12 QUIT
End DoDot:2
DO NEXT
QUIT
+13 ;patient name
IF SEG2="QC"
Begin DoDot:2
+14 DO NEXT
+15 ;patient is subscriber
IF $GET(IBPATLN)=$PIECE(ARG(IBSEG),"*",4)
IF $GET(IBPATFN)=$PIECE(ARG(IBSEG),"*",5)
IF $GET(IBPATMN)=$PIECE(ARG(IBSEG),"*",6)
QUIT
+16 ;patient is not veteran, so generate exception error
+17 DO UP^IBCE837ACC(IBX12,11,5,IBPATLN_","_IBPATFN_" "_$PIECE(ARG(IBSEG),"*",4)_","_$PIECE(ARG(IBSEG),"*",5)_" "_$PIECE(ARG(IBSEG),"*",6))
+18 QUIT
End DoDot:2
QUIT
+19 ;amb pickup add
IF SEG2="PW"
Begin DoDot:2
+20 SET IBSEGN="SEG"_(IBI+1)
IF $EXTRACT($GET(ARG(IBSEGN)),1,3)="N3*"
Begin DoDot:3
+21 DO SET^IBCE837ACC1($PIECE(ARG(IBSEGN),"*",2),1,"AMB")
SET IBI=IBI+1
End DoDot:3
+22 SET IBSEGN="SEG"_(IBI+1)
IF $EXTRACT($GET(ARG(IBSEGN)),1,3)="N4*"
Begin DoDot:3
+23 DO SET^IBCE837ACC1($PIECE(ARG(IBSEGN),"*",2,4),2,"AMB")
SET IBI=IBI+1
End DoDot:3
+24 QUIT
End DoDot:2
QUIT
+25 ;amb drop-off loc
IF SEG2=45
Begin DoDot:2
+26 ;JWS;10/8/25;EBILL-6111;IB*2.0*770v49;adding amb drop-off loc name
+27 ;JWS;2/2/26;EBILL-6482;IB*2.0*770v61;wrong variable was IBSEGN, should have been IBSEG (current seg data)
+28 DO SET^IBCE837ACC1($PIECE(ARG(IBSEG),"*",4),5,"AMB")
+29 SET IBSEGN="SEG"_(IBI+1)
IF $EXTRACT($GET(ARG(IBSEGN)),1,3)="N3*"
Begin DoDot:3
+30 DO SET^IBCE837ACC1($PIECE(ARG(IBSEGN),"*",2),3,"AMB")
SET IBI=IBI+1
End DoDot:3
+31 SET IBSEGN="SEG"_(IBI+1)
IF $EXTRACT($GET(ARG(IBSEGN)),1,3)="N4*"
Begin DoDot:3
+32 DO SET^IBCE837ACC1($PIECE(ARG(IBSEGN),"*",2,4),4,"AMB")
SET IBI=IBI+1
End DoDot:3
+33 QUIT
End DoDot:2
QUIT
+34 ;DN - referring prov
IF SEG2="DN"
Begin DoDot:2
+35 NEW XIBPNAME,XIBPNPI
+36 ;other payer referring provider
IF $PIECE(ARG(IBSEG),"*",4)=""
QUIT
+37 SET XIBPNAME=$PIECE(ARG(IBSEG),"*",4)_","_$PIECE(ARG(IBSEG),"*",5)
SET XIBPNPI=$PIECE(ARG(IBSEG),"*",10)
+38 ;11/24/25;JWS;EBILL-6206;add error 27 for missing taxonomy
+39 SET OK=$$CHK35593^IBCE837ACCU(XIBPNPI,"DN")
IF OK<1
DO UP^IBCE837ACC(IBX12,$SELECT(OK=-1:27,1:4),5,XIBPNAME_":"_XIBPNPI)
+40 ;JWS;IB*2.0*770v11;11/11/24;EBILL-3551;address NOT ON FILE name issue
+41 IF $FIND(XIBPNAME,"NOT ON FILE")
SET XIBPNAME=$GET(IBPN2)
+42 ;JWS;12/5/24;IB*2.0*770v15;remove storing referring provider into the encounter zero node
+43 ;I $G(IBPN)="" S IBPN=XIBPNAME,IBPT="DN",IBPNPI=XIBPNPI
+44 DO SET^IBCE837ACC1(XIBPNPI,1.1,"DN")
DO SET^IBCE837ACC1(XIBPNAME,1.2,"DN")
DO SET^IBCE837ACC1($SELECT(OK=1:355.93,1:200),1.3,"DN")
+45 QUIT
End DoDot:2
QUIT
+46 ;NM101='82' - rendering prov
IF SEG2=82
Begin DoDot:2
+47 NEW XIBPNAME,XIBPNPI
+48 ;other payer rendering
IF $PIECE(ARG(IBSEG),"*",4)=""
QUIT
+49 SET XIBPNAME=$PIECE(ARG(IBSEG),"*",4)_","_$PIECE(ARG(IBSEG),"*",5)
SET XIBPNPI=$PIECE(ARG(IBSEG),"*",10)
+50 IF $GET(IBPN)=""
SET IBPN=XIBPNAME
SET IBPT=82
SET IBPNPI=XIBPNPI
+51 ;11/24/25;JWS;EBILL-6206;add error 27 for missing taxonomy
+52 SET OK=$$CHK35593^IBCE837ACCU(XIBPNPI,82)
IF OK<1
DO UP^IBCE837ACC(IBX12,$SELECT(OK=-1:27,1:4),5,XIBPNAME_":"_XIBPNPI)
+53 DO SET^IBCE837ACC1(XIBPNPI,1.1,82)
DO SET^IBCE837ACC1(XIBPNAME,1.2,82)
DO SET^IBCE837ACC1($SELECT(OK=1:355.93,1:200),1.3,82)
+54 QUIT
End DoDot:2
QUIT
+55 ;NM101='77' - service facility
IF SEG2=77
Begin DoDot:2
+56 DO NEXT
+57 ;other payer service facility
SET IBPN1=$PIECE(ARG(IBSEG),"*",4)
IF IBPN1=""
QUIT
+58 SET OK=$$CHK35593^IBCE837ACCU($PIECE(ARG(IBSEG),"*",10),77)
IF 'OK
DO UP^IBCE837ACC(IBX12,5,5,IBPN1_":"_$PIECE(ARG(IBSEG),"*",10))
+59 ;JWS;IB*2.0*770v10;11/11/24;EBILL-3551;address NOT ON FILE name issue
+60 IF $FIND(IBPN1,"NOT ON FILE")
SET IBPN1=$GET(IBPN2)
+61 DO SET^IBCE837ACC1($PIECE(ARG(IBSEG),"*",10),1.1,77)
DO SET^IBCE837ACC1(IBPN1,1.2,77)
DO SET^IBCE837ACC1($SELECT(OK=1:355.93,1:200),1.3,77)
+62 QUIT
End DoDot:2
QUIT
+63 ;NM101='DQ' = supervising provider
IF SEG2="DQ"
Begin DoDot:2
+64 ;other payer supervising provider
IF $PIECE(ARG(IBSEG),"*",4)=""
QUIT
+65 SET IBPN1=$PIECE(ARG(IBSEG),"*",4)_","_$PIECE(ARG(IBSEG),"*",5)
+66 SET OK=$$CHK35593^IBCE837ACCU($PIECE(ARG(IBSEG),"*",10),"DQ")
IF 'OK
DO UP^IBCE837ACC(IBX12,4,5,IBPN1_":"_$PIECE(ARG(IBSEG),"*",10))
+67 DO SET^IBCE837ACC1($PIECE(ARG(IBSEG),"*",10),1.1,"DQ")
DO SET^IBCE837ACC1($SELECT(OK=1:355.93,1:200),1.3,"DQ")
+68 QUIT
End DoDot:2
QUIT
+69 ;NM101='71' = attending provider
IF SEG2=71
Begin DoDot:2
+70 NEW XIBPNAME,XIBPNPI
+71 ;
IF $PIECE(ARG(IBSEG),"*",4)=""
QUIT
+72 SET XIBPNAME=$PIECE(ARG(IBSEG),"*",4)_","_$PIECE(ARG(IBSEG),"*",5)
SET XIBPNPI=$PIECE(ARG(IBSEG),"*",10)
+73 IF $GET(IBPN)=""
SET IBPN=XIBPNAME
SET IBPT=71
SET IBPNPI=XIBPNPI
+74 ;11/24/25;JWS;EBILL-6206;add error 27 for missing taxonomy
+75 SET OK=$$CHK35593^IBCE837ACCU(XIBPNPI,71)
IF OK<1
DO UP^IBCE837ACC(IBX12,$SELECT(OK=-1:27,1:4),5,XIBPNAME_":"_XIBPNPI)
+76 DO SET^IBCE837ACC1(XIBPNPI,1.1,71)
DO SET^IBCE837ACC1($SELECT(OK=1:355.93,1:200),1.3,71)
+77 QUIT
End DoDot:2
QUIT
+78 ;NM101='72' = operating physician
IF SEG2=72
Begin DoDot:2
+79 ;
IF $PIECE(ARG(IBSEG),"*",4)=""
QUIT
+80 SET IBPN1=$PIECE(ARG(IBSEG),"*",4)_","_$PIECE(ARG(IBSEG),"*",5)
+81 SET OK=$$CHK35593^IBCE837ACCU($PIECE(ARG(IBSEG),"*",10),72)
IF 'OK
DO UP^IBCE837ACC(IBX12,4,5,IBPN1_":"_$PIECE(ARG(IBSEG),"*",10))
+82 DO SET^IBCE837ACC1($PIECE(ARG(IBSEG),"*",10),1.1,72)
DO SET^IBCE837ACC1(IBPN1,1.2,72)
DO SET^IBCE837ACC1($SELECT(OK=1:355.93,1:200),1.3,72)
+83 QUIT
End DoDot:2
QUIT
+84 ;NM101='ZZ' = other operating physician
IF SEG2="ZZ"
Begin DoDot:2
+85 ;
IF $PIECE(ARG(IBSEG),"*",4)=""
QUIT
+86 SET IBPN1=$PIECE(ARG(IBSEG),"*",4)_","_$PIECE(ARG(IBSEG),"*",5)
+87 SET OK=$$CHK35593^IBCE837ACCU($PIECE(ARG(IBSEG),"*",10),"ZZ")
IF 'OK
DO UP^IBCE837ACC(IBX12,4,5,IBPN1_":"_$PIECE(ARG(IBSEG),"*",10))
+88 DO SET^IBCE837ACC1($PIECE(ARG(IBSEG),"*",10),1.1,"ZZ")
DO SET^IBCE837ACC1($SELECT(OK=1:355.93,1:200),1.3,"ZZ")
+89 QUIT
End DoDot:2
QUIT
+90 ;other billing provider name
IF SEG2=85
QUIT
+91 ;NM101='DD' = assistant surgeon
IF SEG2="DD"
Begin DoDot:2
+92 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),"DD")
IF 'OK
DO UP^IBCE837ACC(IBX12,4,5,IBPN1_":"_$PIECE(ARG(IBSEG),"*",10))
+95 DO SET^IBCE837ACC1($PIECE(ARG(IBSEG),"*",10),1.1,"DD")
DO SET^IBCE837ACC1($SELECT(OK=1:355.93,1:200),1.3,"DD")
+96 QUIT
End DoDot:2
QUIT
+97 QUIT
End DoDot:1
QUIT
+98 IF $EXTRACT(SEG,1,4)="DMG*"
Begin DoDot:1
+99 ;JWS;1/6/26;EBILL-6357;only set IBDOB if not already defined with VistA patient info
+100 SET DOB=$PIECE(ARG(IBSEG),"*",3)
IF DOB'=""
IF $GET(IBDOB)=""
SET IBDOB=$SELECT($EXTRACT(DOB,1,2)=19:2,1:3)_$EXTRACT(DOB,3,8)
QUIT
+101 QUIT
End DoDot:1
QUIT
+102 ;get claim charge amt and place of service code from CLM loop 2300
+103 IF $EXTRACT(SEG,1,4)="CLM*"
DO SET^IBCE837ACC1($PIECE(ARG(IBSEG),"*",3),5)
DO SET^IBCE837ACC1($PIECE($PIECE(ARG(IBSEG),"*",6),":"),6)
QUIT
+104 IF $EXTRACT(SEG,1,4)="DTP*"
Begin DoDot:1
+105 ;399,.03 ;date of onset
IF SEG2=431
DO DT(9)
QUIT
+106 ;399,246 ;date of initial treatment
IF SEG2=454
DO DT(10)
QUIT
+107 ;399,237 ;date last seen
IF SEG2=304
DO DT(11)
QUIT
+108 ;399,247 ;date acute manifestation
IF SEG2=453
DO DT(12)
QUIT
+109 ;399,41,.02 - OCCURRENCE CODE = 01 ;accident date
IF SEG2=439
DO DT(13)
QUIT
+110 ;399,41,.02 - OCCURRENCE CODE = 10 ;last menstrual period
IF SEG2=484
DO DT(14)
QUIT
+111 ;399,245 ;date last x-ray
IF SEG2=455
DO DT(15)
QUIT
+112 ;hearing & vision prescription date
IF SEG2=471
QUIT
+113 ;399,263 and 264 ;disability start and end dates
IF SEG2=314
DO DT(16)
QUIT
+114 ;399,263 ;disability start date
IF SEG2=360
DO DT(37)
QUIT
+115 ;399,264 ;disability end date
IF SEG2=361
DO DT(38)
QUIT
+116 ;399,166 ;date last worked
IF SEG2=297
DO DT(17)
QUIT
+117 ;399,166 ;date authorized return to work
IF SEG2=296
DO DT(18)
QUIT
+118 ;check admission date - if DTP segment exists, then it's inpatient claim
+119 ;admission date - inpatient
IF SEG2=435
SET IBIO="I"
DO DT(19)
QUIT
+120 ;discharge date
IF SEG2="096"
DO DT(20)
QUIT
+121 ;assumed care date
IF SEG2="090"
DO DT(21)
QUIT
+122 ;relinquished care date
IF SEG2="091"
DO DT(22)
QUIT
+123 ;first visit date
IF SEG2=444
DO DT(23)
QUIT
+124 ;repricer date
IF SEG2="050"
QUIT
+125 ;claim check/ remittance date
IF SEG2=573
QUIT
+126 IF SEG2=434
Begin DoDot:2
+127 ;inst statement dates
DO DT(33)
+128 NEW IBXDOS
+129 IF $PIECE(ARG(IBSEG),"*",4)=""
QUIT
+130 SET IBXDOS=3_$EXTRACT($PIECE(ARG(IBSEG),"*",4),3,8)
+131 SET IBDOS=IBXDOS
DO SET^IBCE837ACC1(IBDOS,8)
+132 SET IBLDOS=3_$EXTRACT($PIECE($PIECE(ARG(IBSEG),"*",4),"-",2),3,8)
+133 IF IBLDOS=3
SET IBLDOS=IBXDOS
+134 DO SET^IBCE837ACC1(IBLDOS,39)
+135 QUIT
End DoDot:2
QUIT
+136 ;dental appliance placement date
IF SEG2=452
DO DT(35)
QUIT
+137 IF SEG2=472
Begin DoDot:2
+138 DO DT(36)
+139 ;dental date of service - claim level
IF $GET(IBDOS)=""
SET (IBDOS,IBLDOS)=$PIECE(^TMP("IB837ACC",$JOB),"^",36)
DO SET^IBCE837ACC1(IBDOS,8)
DO SET^IBCE837ACC1(IBLDOS,39)
QUIT
+140 QUIT
End DoDot:2
QUIT
End DoDot:1
QUIT
+141 IF $EXTRACT(SEG,1,4)="CL1*"
DO SET^IBCE837ACC1(ARG(IBSEG),1,"CL1")
QUIT
+142 IF $EXTRACT(SEG,1,4)="PWK*"
QUIT
+143 ;NON-HIPPA USE
IF $EXTRACT(SEG,1,4)="CN1*"
QUIT
+144 IF $EXTRACT(SEG,1,4)="REF*"
Begin DoDot:1
+145 ;claim identifier for transmission intermediaries
IF SEG2="D9"
SET IBREFD9=$PIECE(ARG(IBSEG),"*",3)
QUIT
+146 IF SEG2="EW"
DO SET^IBCE837ACC1($PIECE(ARG(IBSEG),"*",3),24)
QUIT
+147 IF SEG2="X4"
DO SET^IBCE837ACC1($PIECE(ARG(IBSEG),"*",3),25)
QUIT
+148 ;JWS;10/23/25;EBILL-6172;add authorization and referral variables
+149 IF SEG2="G1"
SET IBAUTH=$PIECE(ARG(IBSEG),"*",3)
QUIT
+150 IF SEG2="9F"
SET IBREF=$PIECE(ARG(IBSEG),"*",3)
QUIT
+151 ;JWS;EBILL-4922;IB*2.0*770v18;add payer claim control number to encounter
+152 ;JWS;6/9/25;appears that cc encounters have the payer control number segment in loop 2330B (other payer claim control number)
+153 ;JWS;6/9/25;so adding conditional check in case future encounters have value in loop 2300
+154 IF SEG2="F8"
IF $PIECE($GET(^TMP("IB837ACC",$JOB)),"^",44)=""
DO SET^IBCE837ACC1($PIECE(ARG(IBSEG),"*",3),44)
QUIT
+155 QUIT
End DoDot:1
QUIT
+156 ;file info
IF $EXTRACT(SEG,1,3)="K3*"
QUIT
+157 IF $EXTRACT(SEG,1,4)="NTE*"
DO SET^IBCE837ACC1($PIECE(ARG(IBSEG),"*",3),1,"NTE"_"-"_$PIECE(ARG(IBSEG),"*",2))
QUIT
+158 ; ambulance transport info
IF $EXTRACT(SEG,1,4)="CR1*"
DO SET^IBCE837ACC1(ARG(IBSEG),1,"CR1")
SET $PIECE(^TMP("IBCE837ACC",$JOB),"^",40)=1
QUIT
+159 IF $EXTRACT(SEG,1,4)="CR2*"
QUIT
+160 IF $EXTRACT(SEG,1,4)="CRC*"
Begin DoDot:1
+161 ;amb certification
IF SEG2="07"
DO SET^IBCE837ACC1(ARG(IBSEG),1,"CRC07")
QUIT
+162 IF SEG2=75
DO SET^IBCE837ACC1($PIECE(ARG(IBSEG),"*",3,4),26)
QUIT
+163 IF SEG2="ZZ"
DO SET^IBCE837ACC1($PIECE(ARG(IBSEG),"*",3,4),27)
QUIT
+164 QUIT
End DoDot:1
QUIT
+165 ;get principle diagnosis code
+166 IF $EXTRACT(SEG,1,3)="HI*"
Begin DoDot:1
+167 ;diagnosis codes
IF $PIECE(SEG2,":")="ABK"
SET IBPDX=$PIECE($PIECE(ARG(IBSEG),":",2),"*")
DO SET^IBCE837ACC1(ARG(IBSEG),1,"HI-D")
DO SET^IBCE837ACC1(IBPDX,7)
QUIT
+168 ;other-diagnosis
IF $PIECE(SEG2,":")="ABF"
DO SET^IBCE837ACC1(ARG(IBSEG),1,"HI-O")
QUIT
+169 ;admitting diagnosis - need if/when doing inpatient
IF $PIECE(SEG2,":")="ABJ"
QUIT
+170 ;reason for visit
IF $PIECE(SEG2,":")="APR"
DO SET^IBCE837ACC1($PIECE(ARG(IBSEG),"*",2,4),28)
QUIT
+171 ;external cause of injury
IF $PIECE(SEG2,":")="ABN"
DO SET^IBCE837ACC1(ARG(IBSEG),1,"HI-E")
QUIT
+172 ;DRG group (inpatient inst)
IF $EXTRACT(SEG2,1,3)="DR:"
QUIT
+173 ;anesthesia surgical code
IF $EXTRACT(SEG2,1,3)="BP:"
DO SET^IBCE837ACC1($PIECE($PIECE(ARG(IBSEG),"*",2),":",2),34)
QUIT
+174 IF $EXTRACT(SEG2,1,4)="BBR:"
DO SET^IBCE837ACC1($PIECE(ARG(IBSEG),"*",2),30)
QUIT
+175 IF $EXTRACT(SEG2,1,4)="BBQ:"
DO SET^IBCE837ACC1($PIECE(ARG(IBSEG),"*",2,13),1,"PROC")
QUIT
+176 IF $EXTRACT(SEG2,1,3)="BI:"
DO SET^IBCE837ACC1($PIECE(ARG(IBSEG),"*",2,13),1,"OSC")
QUIT
+177 ;"HI*BH:05:D8:20230501*BH:18:D8:20020301"
IF $EXTRACT(SEG2,1,3)="BH:"
DO SET^IBCE837ACC1($PIECE(ARG(IBSEG),"*",2,13),1,"OC")
QUIT
+178 ;HI*BE:01:::2500*BE:80:::1
IF $EXTRACT(SEG2,1,3)="BE:"
DO SET^IBCE837ACC1($PIECE(ARG(IBSEG),"*",2,13),1,"CV")
QUIT
+179 IF $EXTRACT(SEG2,1,3)="BG:"
DO SET^IBCE837ACC1($PIECE(ARG(IBSEG),"*",2,13),1,"CC")
QUIT
+180 ;probably never get - Treatment Code Info
IF $EXTRACT(SEG2,1,3)="TC:"
QUIT
End DoDot:1
QUIT
+181 ;ortho total months
IF $EXTRACT(SEG,1,4)="DN1*"
DO SET^IBCE837ACC1($PIECE(ARG(IBSEG),"*",2,5),1,"DN1")
QUIT
+182 ;tooth status
IF $EXTRACT(SEG,1,4)="DN2*"
DO SET^IBCE837ACC1($PIECE(ARG(IBSEG),"*",2,7),1,"DN2")
QUIT
+183 QUIT
+184 ;
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 ;
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 ;
