IBCE837ACC2A ;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
;
TOS(XP) ;obtain Type of Service code for each professional claim service line
N X
;S DIC("DR")=DIC("DR")_";9////"_$S($P(XD,"*",4)="MJ":$$FIND1^DIC(353.2,,,7),1:$$FIND1^DIC(353.2,,,1))
;"SV1*HC:97012:GP*15*UN*1***3:1:2"
; ANESTHESIA : 00100-01999 = 7
; SURGERY : 10000-69999 = 2
; PATHOLOGY : 88305-88398 = 5
; RADIOLOGY : 70000-79999 = 4
; CONSULTATIONS : 99241-99245 = 3
;
I +XP>99,+XP<2000 S X=7 G TOS1
I +XP>9999,+XP<70000 S X=2 G TOS1
I +XP>69999,+XP<80000 S X=4 G TOS1
I +XP>88304,+XP<88399 S X=5 G TOS1
I +XP>99240,+XP<99246 S X=3 G TOS1
S X=1
TOS1 ;
Q $$FIND1^DIC(353.2,,"X",X)
;
TEETH ;10/15/25;from IBCE837ACC2
N XTS,I,XDATA,XD,XIEN,X
S XTS=0 F S XTS=$O(^TMP("IB837ACC",$J,"DN2",XTS)) Q:XTS="" S XDATA=^(XTS) D
. S X=$P(XDATA,"*") I X="" Q
. K DIC,DA,DINUM,DO,DD,DLAYGO
. I $P(XDATA,"*",2)'="E",$P(XDATA,"*",2)'="M" Q
. S DIC="^DGCR(399,"_IBIFN_",""DEN1"",",DIC(0)="L",DA(1)=IBIFN,DLAYGO=399.096,DIC("DR")=".02////"_$P(XDATA,"*",2)
. D FILE^DICN
. K DO,DD,DLAYGO,DA,DIC
Q
;
WRAP(STRING,ROOM,SUBS,IBARY) ; wrap long lines without breaking up words
;JWS;10/23/25;EBILL-6172;wrap note field
;
; STRING = data string to wrap
; ROOM = number of characters to break at for line 1
; SUBS = number of characters to break at for subsequent lines (may or may not be same as ROOM)
; IBARY = (required) subscripted array to return wrapped data in:
; array(1)=first line
; array(2)= 2nd line and so on
;
; Returns total # of lines in description
;
N START,END,I,C,STOP
; if there is enough room for 1 line, no wrapping needed
I $L(STRING)'>ROOM S IBARY(1)=STRING Q 1
I $F(STRING," ")=0 D Q 1
. N LEN S LEN=$L(STRING)
. F I=1:1 S IBARY(I)=$E(STRING,1,ROOM),STRING=$E(STRING,ROOM+1,LEN) Q:STRING=""
. Q
I $F(STRING," ")>ROOM S IBARY(1)=STRING Q 1
; add a space to the end of the string to avoid dropping last character
S START=1,END=ROOM,STRING=STRING_" "
F C=1:1 D Q:$L(STRING)<START Q:$G(STOP) ; stop if we have made it to the end of the data string
.; start at the end and work backwards until you find a blank space, cut the line there and move on to the next line
.F I=END:-1:1 I $E(STRING,I)=" " S IBARY(C)=$E(STRING,START,I),START=I+1,END=SUBS+START Q
.I I=1 S STOP=1 I '$D(IBARY(1)) S IBARY(1)=STRING Q
Q C
;
STRIP(DATA) ; strip leading spaces
N I,RTN
S RTN=DATA F I=1:1:$L(DATA) Q:$E(DATA,I)'=" " S RTN=$E(RTN,2,999)
Q RTN
;
FINISH ;
;JWS;10/23/25;EBILL-6172;add data comments to initial encounter load
N IBPAIEN,ERR,I,II,J,NOTE,NOTE1
S I=1,NOTE(1)="Encounter#: "_IBREFD9_"; ETD: "_IBPAYERID_"; Payer Claim Control #: "_$P($G(^TMP("IB837ACC",$J)),"^",44)
I $L(NOTE(1))>80 D
. S II=$$WRAP^IBCE837ACC2A(NOTE(1),80,80,.XX)
. F I=1:1:II S NOTE(I)=XX(I)
. S I=II
I $G(IBAUTH)'="" S NOTE1=$S($G(IBREF)="":"; Authorization #: ",1:"; Authorization/Referral #: ")
I $G(NOTE1)="",$G(IBREF)'="" S NOTE1="; Referral #: "
S I=I+1,NOTE(I)="ICN: "_$G(IBPATICN)_$G(NOTE1)_$S($G(IBAUTH)'="":IBAUTH,1:"")_$S(($G(IBAUTH)'=""&($G(IBREF)'="")):" / ",1:"")_$S($G(IBREF)'="":IBREF,1:"")
I $L(NOTE(I))>80 D
. S II=$$WRAP^IBCE837ACC2A(NOTE(I),80,80,.XX)
. I II>1 F J=1:1:II S NOTE(I)=XX(J),I=I+1
I $O(^IBA(364.9,IBX12,7,"B",0)) S I=I+1,NOTE(I)="Error codes:",II=0 F S II=$O(^IBA(364.9,IBX12,7,"B",II)) Q:II="" S NOTE(I)=NOTE(I)_" "_$$GET1^DIQ(364.91,II_",",.01,"E")
I $L(NOTE(I))>80 D
. S II=$$WRAP^IBCE837ACC2A(NOTE(I),80,80,.XX)
. I II>1 F J=1:1:II S NOTE(I)=XX(J),I=I+1
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")
. Q
;JWS;9/4/2025;IB*2.0*770v44;make sure we send back a response, if not dups will occur
I '$D(^TMP("IBCE837ACC",$J,"Status")) S ^TMP("IBCE837ACC",$J,"Status")="1^X12 claim data received and processed."
; Reference to ENCODE^XLFJSON in ICR #6682
D ENCODE^XLFJSON("^TMP(""IBCE837ACC"",$J)","RESULT")
I $G(RESULT(1))=""!($G(RESULT(1))="{}") S RESULT(1)="[{}]" Q
S RESULT(1)="["_RESULT(1)_"]"
Q
;
UPDATE(IBIEN,IBVAL,IBFLD) ;
N DA,D0,DR,DIE,DIC
S DA=IBIEN I DA="" Q
S DR=IBFLD_"////"_IBVAL
S DIE="^IBA(364.9,"
D ^DIE
Q
;
; JWS;10/30/2025;EBILL-5763;process inpatient CMS-1550 professional claims without PTF
ACCFT(IBFACT,IBFT) ;check facility type on a professional claim
; if facility type is in list, allow processing inpatient cms-1500 without PTF
N XIB,XIB1,OK,I
S OK=0
I IBFT=2 D Q OK
. S XIB=$$FIND1^DIC(364.991,,"X","ACC_PROF_FACILITY_TYPE_NOPTF")
. I 'XIB Q
. S XIB1=$$GET1^DIQ(364.991,XIB_",",.1)
. I XIB1="" Q
. F I=1:1:$L(XIB1,"|") I IBFACT=$P(XIB1,"|",I) S OK=1 Q
. Q
I IBFT=3 D
. S XIB=$$FIND1^DIC(364.991,,"X","ACC_INST_FACILITY_TYPE_PTF")
. I 'XIB Q
. S XIB1=$$GET1^DIQ(364.991,XIB_",",.1)
. I XIB1="" Q
. S OK=1
. F I=1:1:$L(XIB1,"|") I IBFACT=$P(XIB1,"|",I) S OK=0 Q
. Q
Q OK
;
CHKPG(IBPATIEN,IBNOTE) ;
N IBEGP,IBPGIEN,OK,IBEGPSG
; check priority group. must be 7 or 8, and if 8, sub group must be c - d needs a clinical decision
S IBPGIEN=$P($G(^DPT(IBPATIEN,"ENR")),"^") I IBPGIEN="" S IBNOTE="PRIORITY GROUP NOT FOUND" Q 0 ;no priority group ;ICR ***NEW (Pending)
;JWS;IB*2.0*770v4;EBILL-4223;allow priority group 4
S IBEGP=$P($G(^DGEN(27.11,IBPGIEN,0)),"^",7) I IBEGP'=4,IBEGP'=7,IBEGP'=8 S IBNOTE="PRIORITY GROUP MISMATCH ("_IBEGP_")" Q 0 ; wrong priority group ;ICR 5158 (Private)
;JWS;IB*2.0*770v4;EBILL-4221;add 8(d) exclusion due to clinical decision need
I IBEGP=8 N OK S IBEGPSG=$$GET1^DIQ(27.11,IBPGIEN_",",.12,"E") D Q OK ;ICR #5158 (Private) *** Need to modify
. I IBEGPSG'="c",IBEGPSG'="d" S IBNOTE="PRIORITY GROUP 8 SUBGRP MISMATCH ("_IBEGPSG_")",OK=0 Q ;wrong sub-group
. I IBEGPSG="d" S IBNOTE="PRIORITY GROUP 8 SUBGRP 'd' NEEDS CLINICAL DECISION",OK=2 Q
. ;JWS;IB*2.0*770;10/4/24 - set fall thru result
. S OK=1
Q 1
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBCE837ACC2A 6108 printed May 25, 2026@12:14:07 Page 2
IBCE837ACC2A ;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 ;
TOS(XP) ;obtain Type of Service code for each professional claim service line
+1 NEW X
+2 ;S DIC("DR")=DIC("DR")_";9////"_$S($P(XD,"*",4)="MJ":$$FIND1^DIC(353.2,,,7),1:$$FIND1^DIC(353.2,,,1))
+3 ;"SV1*HC:97012:GP*15*UN*1***3:1:2"
+4 ; ANESTHESIA : 00100-01999 = 7
+5 ; SURGERY : 10000-69999 = 2
+6 ; PATHOLOGY : 88305-88398 = 5
+7 ; RADIOLOGY : 70000-79999 = 4
+8 ; CONSULTATIONS : 99241-99245 = 3
+9 ;
+10 IF +XP>99
IF +XP<2000
SET X=7
GOTO TOS1
+11 IF +XP>9999
IF +XP<70000
SET X=2
GOTO TOS1
+12 IF +XP>69999
IF +XP<80000
SET X=4
GOTO TOS1
+13 IF +XP>88304
IF +XP<88399
SET X=5
GOTO TOS1
+14 IF +XP>99240
IF +XP<99246
SET X=3
GOTO TOS1
+15 SET X=1
TOS1 ;
+1 QUIT $$FIND1^DIC(353.2,,"X",X)
+2 ;
TEETH ;10/15/25;from IBCE837ACC2
+1 NEW XTS,I,XDATA,XD,XIEN,X
+2 SET XTS=0
FOR
SET XTS=$ORDER(^TMP("IB837ACC",$JOB,"DN2",XTS))
if XTS=""
QUIT
SET XDATA=^(XTS)
Begin DoDot:1
+3 SET X=$PIECE(XDATA,"*")
IF X=""
QUIT
+4 KILL DIC,DA,DINUM,DO,DD,DLAYGO
+5 IF $PIECE(XDATA,"*",2)'="E"
IF $PIECE(XDATA,"*",2)'="M"
QUIT
+6 SET DIC="^DGCR(399,"_IBIFN_",""DEN1"","
SET DIC(0)="L"
SET DA(1)=IBIFN
SET DLAYGO=399.096
SET DIC("DR")=".02////"_$PIECE(XDATA,"*",2)
+7 DO FILE^DICN
+8 KILL DO,DD,DLAYGO,DA,DIC
End DoDot:1
+9 QUIT
+10 ;
WRAP(STRING,ROOM,SUBS,IBARY) ; wrap long lines without breaking up words
+1 ;JWS;10/23/25;EBILL-6172;wrap note field
+2 ;
+3 ; STRING = data string to wrap
+4 ; ROOM = number of characters to break at for line 1
+5 ; SUBS = number of characters to break at for subsequent lines (may or may not be same as ROOM)
+6 ; IBARY = (required) subscripted array to return wrapped data in:
+7 ; array(1)=first line
+8 ; array(2)= 2nd line and so on
+9 ;
+10 ; Returns total # of lines in description
+11 ;
+12 NEW START,END,I,C,STOP
+13 ; if there is enough room for 1 line, no wrapping needed
+14 IF $LENGTH(STRING)'>ROOM
SET IBARY(1)=STRING
QUIT 1
+15 IF $FIND(STRING," ")=0
Begin DoDot:1
+16 NEW LEN
SET LEN=$LENGTH(STRING)
+17 FOR I=1:1
SET IBARY(I)=$EXTRACT(STRING,1,ROOM)
SET STRING=$EXTRACT(STRING,ROOM+1,LEN)
if STRING=""
QUIT
+18 QUIT
End DoDot:1
QUIT 1
+19 IF $FIND(STRING," ")>ROOM
SET IBARY(1)=STRING
QUIT 1
+20 ; add a space to the end of the string to avoid dropping last character
+21 SET START=1
SET END=ROOM
SET STRING=STRING_" "
+22 ; stop if we have made it to the end of the data string
FOR C=1:1
Begin DoDot:1
+23 ; start at the end and work backwards until you find a blank space, cut the line there and move on to the next line
+24 FOR I=END:-1:1
IF $EXTRACT(STRING,I)=" "
SET IBARY(C)=$EXTRACT(STRING,START,I)
SET START=I+1
SET END=SUBS+START
QUIT
+25 IF I=1
SET STOP=1
IF '$DATA(IBARY(1))
SET IBARY(1)=STRING
QUIT
End DoDot:1
if $LENGTH(STRING)<START
QUIT
if $GET(STOP)
QUIT
+26 QUIT C
+27 ;
STRIP(DATA) ; strip leading spaces
+1 NEW I,RTN
+2 SET RTN=DATA
FOR I=1:1:$LENGTH(DATA)
if $EXTRACT(DATA,I)'=" "
QUIT
SET RTN=$EXTRACT(RTN,2,999)
+3 QUIT RTN
+4 ;
FINISH ;
+1 ;JWS;10/23/25;EBILL-6172;add data comments to initial encounter load
+2 NEW IBPAIEN,ERR,I,II,J,NOTE,NOTE1
+3 SET I=1
SET NOTE(1)="Encounter#: "_IBREFD9_"; ETD: "_IBPAYERID_"; Payer Claim Control #: "_$PIECE($GET(^TMP("IB837ACC",$JOB)),"^",44)
+4 IF $LENGTH(NOTE(1))>80
Begin DoDot:1
+5 SET II=$$WRAP^IBCE837ACC2A(NOTE(1),80,80,.XX)
+6 FOR I=1:1:II
SET NOTE(I)=XX(I)
+7 SET I=II
End DoDot:1
+8 IF $GET(IBAUTH)'=""
SET NOTE1=$SELECT($GET(IBREF)="":"; Authorization #: ",1:"; Authorization/Referral #: ")
+9 IF $GET(NOTE1)=""
IF $GET(IBREF)'=""
SET NOTE1="; Referral #: "
+10 SET I=I+1
SET NOTE(I)="ICN: "_$GET(IBPATICN)_$GET(NOTE1)_$SELECT($GET(IBAUTH)'="":IBAUTH,1:"")_$SELECT(($GET(IBAUTH)'=""&($GET(IBREF)'="")):" / ",1:"")_$SELECT($GET(IBREF)'="":IBREF,1:"")
+11 IF $LENGTH(NOTE(I))>80
Begin DoDot:1
+12 SET II=$$WRAP^IBCE837ACC2A(NOTE(I),80,80,.XX)
+13 IF II>1
FOR J=1:1:II
SET NOTE(I)=XX(J)
SET I=I+1
End DoDot:1
+14 IF $ORDER(^IBA(364.9,IBX12,7,"B",0))
SET I=I+1
SET NOTE(I)="Error codes:"
SET II=0
FOR
SET II=$ORDER(^IBA(364.9,IBX12,7,"B",II))
if II=""
QUIT
SET NOTE(I)=NOTE(I)_" "_$$GET1^DIQ(364.91,II_",",.01,"E")
+15 IF $LENGTH(NOTE(I))>80
Begin DoDot:1
+16 SET II=$$WRAP^IBCE837ACC2A(NOTE(I),80,80,.XX)
+17 IF II>1
FOR J=1:1:II
SET NOTE(I)=XX(J)
SET I=I+1
End DoDot:1
+18 SET IBPAIEN=$ORDER(^IBA(364.9,IBX12,4,"A"),-1)
IF IBPAIEN
Begin DoDot:1
+19 SET IBPAIEN=IBPAIEN_","_IBX12_","
+20 DO WP^DIE(364.94,IBPAIEN,10,"A","NOTE","ERR")
+21 QUIT
End DoDot:1
+22 ;JWS;9/4/2025;IB*2.0*770v44;make sure we send back a response, if not dups will occur
+23 IF '$DATA(^TMP("IBCE837ACC",$JOB,"Status"))
SET ^TMP("IBCE837ACC",$JOB,"Status")="1^X12 claim data received and processed."
+24 ; Reference to ENCODE^XLFJSON in ICR #6682
+25 DO ENCODE^XLFJSON("^TMP(""IBCE837ACC"",$J)","RESULT")
+26 IF $GET(RESULT(1))=""!($GET(RESULT(1))="{}")
SET RESULT(1)="[{}]"
QUIT
+27 SET RESULT(1)="["_RESULT(1)_"]"
+28 QUIT
+29 ;
UPDATE(IBIEN,IBVAL,IBFLD) ;
+1 NEW DA,D0,DR,DIE,DIC
+2 SET DA=IBIEN
IF DA=""
QUIT
+3 SET DR=IBFLD_"////"_IBVAL
+4 SET DIE="^IBA(364.9,"
+5 DO ^DIE
+6 QUIT
+7 ;
+8 ; JWS;10/30/2025;EBILL-5763;process inpatient CMS-1550 professional claims without PTF
ACCFT(IBFACT,IBFT) ;check facility type on a professional claim
+1 ; if facility type is in list, allow processing inpatient cms-1500 without PTF
+2 NEW XIB,XIB1,OK,I
+3 SET OK=0
+4 IF IBFT=2
Begin DoDot:1
+5 SET XIB=$$FIND1^DIC(364.991,,"X","ACC_PROF_FACILITY_TYPE_NOPTF")
+6 IF 'XIB
QUIT
+7 SET XIB1=$$GET1^DIQ(364.991,XIB_",",.1)
+8 IF XIB1=""
QUIT
+9 FOR I=1:1:$LENGTH(XIB1,"|")
IF IBFACT=$PIECE(XIB1,"|",I)
SET OK=1
QUIT
+10 QUIT
End DoDot:1
QUIT OK
+11 IF IBFT=3
Begin DoDot:1
+12 SET XIB=$$FIND1^DIC(364.991,,"X","ACC_INST_FACILITY_TYPE_PTF")
+13 IF 'XIB
QUIT
+14 SET XIB1=$$GET1^DIQ(364.991,XIB_",",.1)
+15 IF XIB1=""
QUIT
+16 SET OK=1
+17 FOR I=1:1:$LENGTH(XIB1,"|")
IF IBFACT=$PIECE(XIB1,"|",I)
SET OK=0
QUIT
+18 QUIT
End DoDot:1
+19 QUIT OK
+20 ;
CHKPG(IBPATIEN,IBNOTE) ;
+1 NEW IBEGP,IBPGIEN,OK,IBEGPSG
+2 ; check priority group. must be 7 or 8, and if 8, sub group must be c - d needs a clinical decision
+3 ;no priority group ;ICR ***NEW (Pending)
SET IBPGIEN=$PIECE($GET(^DPT(IBPATIEN,"ENR")),"^")
IF IBPGIEN=""
SET IBNOTE="PRIORITY GROUP NOT FOUND"
QUIT 0
+4 ;JWS;IB*2.0*770v4;EBILL-4223;allow priority group 4
+5 ; wrong priority group ;ICR 5158 (Private)
SET IBEGP=$PIECE($GET(^DGEN(27.11,IBPGIEN,0)),"^",7)
IF IBEGP'=4
IF IBEGP'=7
IF IBEGP'=8
SET IBNOTE="PRIORITY GROUP MISMATCH ("_IBEGP_")"
QUIT 0
+6 ;JWS;IB*2.0*770v4;EBILL-4221;add 8(d) exclusion due to clinical decision need
+7 ;ICR #5158 (Private) *** Need to modify
IF IBEGP=8
NEW OK
SET IBEGPSG=$$GET1^DIQ(27.11,IBPGIEN_",",.12,"E")
Begin DoDot:1
+8 ;wrong sub-group
IF IBEGPSG'="c"
IF IBEGPSG'="d"
SET IBNOTE="PRIORITY GROUP 8 SUBGRP MISMATCH ("_IBEGPSG_")"
SET OK=0
QUIT
+9 IF IBEGPSG="d"
SET IBNOTE="PRIORITY GROUP 8 SUBGRP 'd' NEEDS CLINICAL DECISION"
SET OK=2
QUIT
+10 ;JWS;IB*2.0*770;10/4/24 - set fall thru result
+11 SET OK=1
End DoDot:1
QUIT OK
+12 QUIT 1
+13 ;
