IBACCWLRURREV1A ;EDE/TAZ - ACC (Automated Community Care) Claims - ADDITIONAL REVIEW SCREEN FOR RUR (cont'd); 12-SEP-2023 ; 12-SEP-2023
;;2.0;INTEGRATED BILLING;**770**;21-MAR-94;Build 119
;;Per VA Directive 6402, this routine should not be modified.
Q
;THIS ROUTINE ALLOWS THE USER TO VIEW THE X12 ENCOUNTER IN READABLE FORMAT.
;
HI(ABFCNT,DIAGCNT,GETX12TPE) ;Display Diagnosis Codes
;
I $G(GETX12TPE)="UBHI" D UBHI(.ABFCNT) Q ;SPECIAL CASE - CAN NOT DO THE SAME DISPLAY FOR UB AS FOR CMS
;
N AMT,CDE,CNT,CODE,DTP,DTQ,HI,POA,STR,TITLE,QC
S (HI,TITLE)=""
F CNT=2:1:13 D
. S CODE=$P(DATA,D,CNT) I CODE="" Q
. S TITLE="",QC=$P(CODE,D1,1),IC=$P(CODE,D1,2),DTQ=$P(CODE,D1,3),DTP=$P(CODE,D1,4),AMT=$P(CODE,D1,5),POA=$P(CODE,D1,9)
.;
. I QC'=HI D
.. S HI=QC
.. I QC="ABF" S ABFCNT=$G(ABFCNT)+1 S:ABFCNT=1 TITLE="Secondary Dx" Q
.. I QC="ABK" S TITLE="Primary Dx" Q
.. ;I QC="ABK",($G(IBINOUT)="INPATIENT") S TITLE="Primary Dx" Q
.. ;I QC="ABK",($G(IBINOUT)="OUTPATIENT") S TITLE="Billed Dx" Q
.. I QC="BBQ" S TITLE="(ICD-10-PCS) Other Procedure Code" S IC=$$ICDLKUP(IC) Q
.. I QC="BBR" S TITLE="Principal Procedure" S IC=$$ICDLKUP(IC) Q
.. I QC="BF" S TITLE="Additional Code" Q
.. I QC="BK" S TITLE="(ICD-9-CM) Primary Code" S IC=$$ICDLKUP(IC) Q
.. I QC="BQ" S TITLE="(ICD-9-CM) Other Procedure Code" S IC=$$ICDLKUP(IC) Q
.. I QC="BR" S TITLE="(ICD-9-CM) Principal Procedure Code" S IC=$$ICDLKUP(IC) Q
.;
. I HI=QC,(QC="ABK"!(QC="ABF")) S DIAGCNT=DIAGCNT+1 S IC=$$ICDLKUP(IC) S IC=((DIAGCNT)_". ")_IC S DIAGPTRARR(DIAGCNT)=IC ;TPF;IB*2*770v38;EBILL-5482,5483
. ;
. Q:U_"ABF"_U_"ABK"_U_"BBQ"_U_"BBR"_U_"BK"_U_"BQ"_U_"BR"_U'[(U_QC_U)
. ;
. D SET^IBACCWLRURREV(TITLE,IC,"","","1^15","16^80")
;
Q
;
;TAZ;IB*2*770v19;EBILL-4938
ICDLKUP(IC) ;Look up the ICD Code desciption v12
N ICDARY,DESC,RSLT
S IC=$E(IC,1,3)_"."_$E(IC,4,$L(IC))
S RSLT=$$DIAGSRCH^LEX10CS(IC,.ICDARY) ;ICR #5681 (Supported)
S DESC="" D
. I RSLT<0 S DESC="Unknown Code" Q
. I $G(ICDARY(1,"IDS"))]"" S DESC=ICDARY(1,"IDS") Q
. I $G(ICDARY(1,"LEX"))]"" S DESC=ICDARY(1,"LEX") Q
. I $G(ICDARY(1,"MENU"))]"" S DESC=ICDARY(1,"MENU") Q
. S DESC="Unknown Code"
ICDLKUPQ ;Exit lookup
Q IC_" - "_DESC
;
PCSLKUP(IC) ;ICD-PCS LOOKUP
N NEWIC ;LEXPCDAT KILLED BY API CALL
S NEWIC=$$PCSDIG^LEX10CS(IC) ;ICR #5681 (Supported)
Q:'$D(LEXPCDAT) IC_" - Not Found"
;
S NEWIC=IC_" - "_$G(LEXPCDAT("PCSDESC"))
Q NEWIC
;
UBHI(ABFCNT) ;Display Diagnosis Codes -UB HAS NO DIAGNOSISI POINTER CODES IN SV1-0. IT HAS SV2
N AMT,CDE,CNT,CODE,DTP,DTQ,HI,POA,STR,TITLE
S (HI,TITLE)=""
F CNT=2:1:13 D
. S CODE=$P(DATA,D,CNT) I CODE="" Q
. S TITLE="",QC=$P(CODE,D1,1),IC=$P(CODE,D1,2),DTQ=$P(CODE,D1,3),DTP=$P(CODE,D1,4),AMT=$P(CODE,D1,5),POA=$P(CODE,D1,9)
. ;
. I QC="BBQ"!(QC="BBR") S BBQLEVEL=BBQLEVEL+1
. I QC'=HI D
.. S HI=QC
.. I QC="ABF" S ABFCNT=$G(ABFCNT)+1 S:ABFCNT=1 TITLE="Secondary Dx" Q
.. I QC="ABK" S TITLE="Primary Dx" Q
.. ;I QC="ABK",($G(IBINOUT)="INPATIENT") S TITLE="Primary Dx" Q
.. ;I QC="ABK",($G(IBINOUT)="OUTPATIENT") S TITLE="Billed Dx" Q
.. I QC="BBQ" S TITLE="Other Procedure Code" Q ;(ICD-10-PCS)
.. I QC="BBR" S TITLE="Principal Procedure" Q ;(ICD-10-PCS)
.. I QC="BK" S TITLE="(ICD-9-CM) Primary Code" Q
.. I QC="BQ" S TITLE="(ICD-9-CM) Other Procedure Code" Q
.. I QC="BR" S TITLE="(ICD-9-CM) Principal Procedure Code" Q
.;
. Q:U_"ABF"_U_"ABK"_U_"BBQ"_U_"BBR"_U_"BK"_U_"BQ"_U_"BR"_U'[(U_QC_U)
.;
. I HI=QC,(QC="BBQ"!(QC="BBR")) D BBQ(IC,TITLE,.BBQLEVEL) Q
. S IC=$$ICDLKUP(IC) D SET^IBACCWLRURREV(TITLE,IC,"","","1^15","16^80")
;
Q
;
BBQ(IC,TITLE,BBQLEVEL) ;EP
;
I $G(BBQLEVEL)=1 D
.D SET^IBACCWLRURREV("","",1,"")
.D SET^IBACCWLRURREV(" "," ICD/PCS Description","")
S IC=$$PCSLKUP(IC)
D SET^IBACCWLRURREV(TITLE,IC,"","","1^20","25^80")
;
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBACCWLRURREV1A 3911 printed May 25, 2026@12:10:06 Page 2
IBACCWLRURREV1A ;EDE/TAZ - ACC (Automated Community Care) Claims - ADDITIONAL REVIEW SCREEN FOR RUR (cont'd); 12-SEP-2023 ; 12-SEP-2023
+1 ;;2.0;INTEGRATED BILLING;**770**;21-MAR-94;Build 119
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 QUIT
+4 ;THIS ROUTINE ALLOWS THE USER TO VIEW THE X12 ENCOUNTER IN READABLE FORMAT.
+5 ;
HI(ABFCNT,DIAGCNT,GETX12TPE) ;Display Diagnosis Codes
+1 ;
+2 ;SPECIAL CASE - CAN NOT DO THE SAME DISPLAY FOR UB AS FOR CMS
IF $GET(GETX12TPE)="UBHI"
DO UBHI(.ABFCNT)
QUIT
+3 ;
+4 NEW AMT,CDE,CNT,CODE,DTP,DTQ,HI,POA,STR,TITLE,QC
+5 SET (HI,TITLE)=""
+6 FOR CNT=2:1:13
Begin DoDot:1
+7 SET CODE=$PIECE(DATA,D,CNT)
IF CODE=""
QUIT
+8 SET TITLE=""
SET QC=$PIECE(CODE,D1,1)
SET IC=$PIECE(CODE,D1,2)
SET DTQ=$PIECE(CODE,D1,3)
SET DTP=$PIECE(CODE,D1,4)
SET AMT=$PIECE(CODE,D1,5)
SET POA=$PIECE(CODE,D1,9)
+9 ;
+10 IF QC'=HI
Begin DoDot:2
+11 SET HI=QC
+12 IF QC="ABF"
SET ABFCNT=$GET(ABFCNT)+1
if ABFCNT=1
SET TITLE="Secondary Dx"
QUIT
+13 IF QC="ABK"
SET TITLE="Primary Dx"
QUIT
+14 ;I QC="ABK",($G(IBINOUT)="INPATIENT") S TITLE="Primary Dx" Q
+15 ;I QC="ABK",($G(IBINOUT)="OUTPATIENT") S TITLE="Billed Dx" Q
+16 IF QC="BBQ"
SET TITLE="(ICD-10-PCS) Other Procedure Code"
SET IC=$$ICDLKUP(IC)
QUIT
+17 IF QC="BBR"
SET TITLE="Principal Procedure"
SET IC=$$ICDLKUP(IC)
QUIT
+18 IF QC="BF"
SET TITLE="Additional Code"
QUIT
+19 IF QC="BK"
SET TITLE="(ICD-9-CM) Primary Code"
SET IC=$$ICDLKUP(IC)
QUIT
+20 IF QC="BQ"
SET TITLE="(ICD-9-CM) Other Procedure Code"
SET IC=$$ICDLKUP(IC)
QUIT
+21 IF QC="BR"
SET TITLE="(ICD-9-CM) Principal Procedure Code"
SET IC=$$ICDLKUP(IC)
QUIT
End DoDot:2
+22 ;
+23 ;TPF;IB*2*770v38;EBILL-5482,5483
IF HI=QC
IF (QC="ABK"!(QC="ABF"))
SET DIAGCNT=DIAGCNT+1
SET IC=$$ICDLKUP(IC)
SET IC=((DIAGCNT)_". ")_IC
SET DIAGPTRARR(DIAGCNT)=IC
+24 ;
+25 if U_"ABF"_U_"ABK"_U_"BBQ"_U_"BBR"_U_"BK"_U_"BQ"_U_"BR"_U'[(U_QC_U)
QUIT
+26 ;
+27 DO SET^IBACCWLRURREV(TITLE,IC,"","","1^15","16^80")
End DoDot:1
+28 ;
+29 QUIT
+30 ;
+31 ;TAZ;IB*2*770v19;EBILL-4938
ICDLKUP(IC) ;Look up the ICD Code desciption v12
+1 NEW ICDARY,DESC,RSLT
+2 SET IC=$EXTRACT(IC,1,3)_"."_$EXTRACT(IC,4,$LENGTH(IC))
+3 ;ICR #5681 (Supported)
SET RSLT=$$DIAGSRCH^LEX10CS(IC,.ICDARY)
+4 SET DESC=""
Begin DoDot:1
+5 IF RSLT<0
SET DESC="Unknown Code"
QUIT
+6 IF $GET(ICDARY(1,"IDS"))]""
SET DESC=ICDARY(1,"IDS")
QUIT
+7 IF $GET(ICDARY(1,"LEX"))]""
SET DESC=ICDARY(1,"LEX")
QUIT
+8 IF $GET(ICDARY(1,"MENU"))]""
SET DESC=ICDARY(1,"MENU")
QUIT
+9 SET DESC="Unknown Code"
End DoDot:1
ICDLKUPQ ;Exit lookup
+1 QUIT IC_" - "_DESC
+2 ;
PCSLKUP(IC) ;ICD-PCS LOOKUP
+1 ;LEXPCDAT KILLED BY API CALL
NEW NEWIC
+2 ;ICR #5681 (Supported)
SET NEWIC=$$PCSDIG^LEX10CS(IC)
+3 if '$DATA(LEXPCDAT)
QUIT IC_" - Not Found"
+4 ;
+5 SET NEWIC=IC_" - "_$GET(LEXPCDAT("PCSDESC"))
+6 QUIT NEWIC
+7 ;
UBHI(ABFCNT) ;Display Diagnosis Codes -UB HAS NO DIAGNOSISI POINTER CODES IN SV1-0. IT HAS SV2
+1 NEW AMT,CDE,CNT,CODE,DTP,DTQ,HI,POA,STR,TITLE
+2 SET (HI,TITLE)=""
+3 FOR CNT=2:1:13
Begin DoDot:1
+4 SET CODE=$PIECE(DATA,D,CNT)
IF CODE=""
QUIT
+5 SET TITLE=""
SET QC=$PIECE(CODE,D1,1)
SET IC=$PIECE(CODE,D1,2)
SET DTQ=$PIECE(CODE,D1,3)
SET DTP=$PIECE(CODE,D1,4)
SET AMT=$PIECE(CODE,D1,5)
SET POA=$PIECE(CODE,D1,9)
+6 ;
+7 IF QC="BBQ"!(QC="BBR")
SET BBQLEVEL=BBQLEVEL+1
+8 IF QC'=HI
Begin DoDot:2
+9 SET HI=QC
+10 IF QC="ABF"
SET ABFCNT=$GET(ABFCNT)+1
if ABFCNT=1
SET TITLE="Secondary Dx"
QUIT
+11 IF QC="ABK"
SET TITLE="Primary Dx"
QUIT
+12 ;I QC="ABK",($G(IBINOUT)="INPATIENT") S TITLE="Primary Dx" Q
+13 ;I QC="ABK",($G(IBINOUT)="OUTPATIENT") S TITLE="Billed Dx" Q
+14 ;(ICD-10-PCS)
IF QC="BBQ"
SET TITLE="Other Procedure Code"
QUIT
+15 ;(ICD-10-PCS)
IF QC="BBR"
SET TITLE="Principal Procedure"
QUIT
+16 IF QC="BK"
SET TITLE="(ICD-9-CM) Primary Code"
QUIT
+17 IF QC="BQ"
SET TITLE="(ICD-9-CM) Other Procedure Code"
QUIT
+18 IF QC="BR"
SET TITLE="(ICD-9-CM) Principal Procedure Code"
QUIT
End DoDot:2
+19 ;
+20 if U_"ABF"_U_"ABK"_U_"BBQ"_U_"BBR"_U_"BK"_U_"BQ"_U_"BR"_U'[(U_QC_U)
QUIT
+21 ;
+22 IF HI=QC
IF (QC="BBQ"!(QC="BBR"))
DO BBQ(IC,TITLE,.BBQLEVEL)
QUIT
+23 SET IC=$$ICDLKUP(IC)
DO SET^IBACCWLRURREV(TITLE,IC,"","","1^15","16^80")
End DoDot:1
+24 ;
+25 QUIT
+26 ;
BBQ(IC,TITLE,BBQLEVEL) ;EP
+1 ;
+2 IF $GET(BBQLEVEL)=1
Begin DoDot:1
+3 DO SET^IBACCWLRURREV("","",1,"")
+4 DO SET^IBACCWLRURREV(" "," ICD/PCS Description","")
End DoDot:1
+5 SET IC=$$PCSLKUP(IC)
+6 DO SET^IBACCWLRURREV(TITLE,IC,"","","1^20","25^80")
+7 ;
+8 QUIT
