IBACCWLVE1A ;EDE/TAZ - ACC (Automated Community Care) Claims - VIEW ENCOUNTER (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 CALLED BY IBACCWLVE1 CODE MOVED FOR SAC RTN SIZE
;TPF;IB*2*770v38;EBILL-5482,5483
;
HI ;Display Diagnosis Codes
;
; Returns DIAGPTRARR (Diagnosis Pointer Array) if IBFORM'="UB-04"
;
N AMT,CDE,CNT,CODE,DTP,DTQ,HI,POA,QC,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'=HI D
.. S HI=QC
.. I QC="ABF" S:CNT=3 TITLE="(ICD-10-CM) Additional Code(s)" Q ;TPF;IB*2*770v38;EBILL-5482,5483
.. I QC="ABJ" S TITLE="(ICD-10-CM) Admitting Diagnosis" S IC=$$ICDLKUP(IC) Q
.. I QC="ABK" S TITLE="(ICD-10-CM) Primary Code" Q ;TPF;IB*2*770v38;EBILL-5482,5483
.. I QC="ABN" S TITLE="(ICD-10-CM) External Cause of Injury Code" S IC=$$ICDLKUP(IC) Q
.. I QC="APR" S TITLE="(ICD-10-CM) Patient's Reason for Visit" S IC=$$ICDLKUP(IC) Q
..; I QC="BBQ" S TITLE="(ICD-10-PCS) Other Procedure Code" S IC=$$ICDLKUP(IC) Q ;WCJ;V41;EBILL-5572
..; I QC="BBR" S TITLE="(ICD-10-PCS) Principal Procedure Code" S IC=$$ICDLKUP(IC) Q ;WCJ;V41;EBILL-5572
.. I QC="BBQ" S TITLE="(ICD-10-PCS) Other Procedure Code" S IC=$$PCSLKUP^IBACCWLRURREV1A(IC) Q ;WCJ;V41;EBILL-5572
.. I QC="BBR" S TITLE="(ICD-10-PCS) Principal Procedure Code" S IC=$$PCSLKUP^IBACCWLRURREV1A(IC) Q ;WCJ;V41;EBILL-5572
.. I QC="BE" S TITLE="Value Code" Q
.. I QC="BF" S TITLE="(ICD-9-CM) Additional Code" S IC=$$ICDLKUP(IC) Q
.. I QC="BG" S TITLE="Condition Code" Q
.. I QC="BH" S TITLE="Occurrence Code" Q
.. I QC="BI" S TITLE="Occurrence Span Code" Q
.. I QC="BJ" S TITLE="(ICD-9-CM) Admitting Diagnosis" S IC=$$ICDLKUP(IC) Q
.. I QC="BK" S TITLE="(ICD-9-CM) Primary Code" S IC=$$ICDLKUP(IC) Q
.. I QC="BN" S TITLE="(ICD-9-CM) External Cause of Injury Code" S IC=$$ICDLKUP(IC) Q
.. I QC="BO" S TITLE="Common Procedural Code" Q
.. I QC="BP" S TITLE="Anesthesia Related Surgical Procedure" 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 QC="CAH" S TITLE="Advanced Billing Concepts (ABC) Codes" Q
.. I QC="DR" S TITLE="Diagnosis Related Group (DRG)" Q
.. I QC="PR" S TITLE="(ICD-9-CM) Patient's Reason for Visit" S IC=$$ICDLKUP(IC) Q
.. I QC="TC" S TITLE="Treatment Code" Q
.. I QC="TQ" S TITLE="Systemized Nomenclature of Dentistry (SNODENT)" Q
.;
. I HI=QC D
.. I QC="ABK"!(QC="ABF") S IC=$$ICDLKUP(IC) S:$G(IBFORM)'="UB-04" IC=((CNT-1)_" ")_IC,DIAGPTRARR(CNT-1)=IC Q ;TPF;IB*2*770v38;EBILL-5482,5483
.. I QC="BBQ"!(QC="BBR") S IC=$$PCSLKUP^IBACCWLRURREV1A(IC) Q
.;
. D SET^IBACCWLVE1(TITLE,IC)
. I DTP'="" D D SET^IBACCWLVE1(TITLE,$$DATE^IBACCWLVE1(DTP,DTQ))
.. I QC="BH" S TITLE="Occurrence Code Date" Q
.. I QC="BI" S TITLE="Occurrence Span Code Dates" Q
.. S TITLE="Principal Procedure Date"
. I AMT'="" D SET^IBACCWLVE1("Value Code Amount",$$DOL^IBACCWLVE1(AMT))
. I POA'="" D SET^IBACCWLVE1("Present on Admission Indicator",$$YN^IBACCWLVE1(POA))
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
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBACCWLVE1A 3826 printed May 25, 2026@12:10:21 Page 2
IBACCWLVE1A ;EDE/TAZ - ACC (Automated Community Care) Claims - VIEW ENCOUNTER (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 CALLED BY IBACCWLVE1 CODE MOVED FOR SAC RTN SIZE
+5 ;TPF;IB*2*770v38;EBILL-5482,5483
+6 ;
HI ;Display Diagnosis Codes
+1 ;
+2 ; Returns DIAGPTRARR (Diagnosis Pointer Array) if IBFORM'="UB-04"
+3 ;
+4 NEW AMT,CDE,CNT,CODE,DTP,DTQ,HI,POA,QC,STR,TITLE
+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 IF QC'=HI
Begin DoDot:2
+10 SET HI=QC
+11 ;TPF;IB*2*770v38;EBILL-5482,5483
IF QC="ABF"
if CNT=3
SET TITLE="(ICD-10-CM) Additional Code(s)"
QUIT
+12 IF QC="ABJ"
SET TITLE="(ICD-10-CM) Admitting Diagnosis"
SET IC=$$ICDLKUP(IC)
QUIT
+13 ;TPF;IB*2*770v38;EBILL-5482,5483
IF QC="ABK"
SET TITLE="(ICD-10-CM) Primary Code"
QUIT
+14 IF QC="ABN"
SET TITLE="(ICD-10-CM) External Cause of Injury Code"
SET IC=$$ICDLKUP(IC)
QUIT
+15 IF QC="APR"
SET TITLE="(ICD-10-CM) Patient's Reason for Visit"
SET IC=$$ICDLKUP(IC)
QUIT
+16 ; I QC="BBQ" S TITLE="(ICD-10-PCS) Other Procedure Code" S IC=$$ICDLKUP(IC) Q ;WCJ;V41;EBILL-5572
+17 ; I QC="BBR" S TITLE="(ICD-10-PCS) Principal Procedure Code" S IC=$$ICDLKUP(IC) Q ;WCJ;V41;EBILL-5572
+18 ;WCJ;V41;EBILL-5572
IF QC="BBQ"
SET TITLE="(ICD-10-PCS) Other Procedure Code"
SET IC=$$PCSLKUP^IBACCWLRURREV1A(IC)
QUIT
+19 ;WCJ;V41;EBILL-5572
IF QC="BBR"
SET TITLE="(ICD-10-PCS) Principal Procedure Code"
SET IC=$$PCSLKUP^IBACCWLRURREV1A(IC)
QUIT
+20 IF QC="BE"
SET TITLE="Value Code"
QUIT
+21 IF QC="BF"
SET TITLE="(ICD-9-CM) Additional Code"
SET IC=$$ICDLKUP(IC)
QUIT
+22 IF QC="BG"
SET TITLE="Condition Code"
QUIT
+23 IF QC="BH"
SET TITLE="Occurrence Code"
QUIT
+24 IF QC="BI"
SET TITLE="Occurrence Span Code"
QUIT
+25 IF QC="BJ"
SET TITLE="(ICD-9-CM) Admitting Diagnosis"
SET IC=$$ICDLKUP(IC)
QUIT
+26 IF QC="BK"
SET TITLE="(ICD-9-CM) Primary Code"
SET IC=$$ICDLKUP(IC)
QUIT
+27 IF QC="BN"
SET TITLE="(ICD-9-CM) External Cause of Injury Code"
SET IC=$$ICDLKUP(IC)
QUIT
+28 IF QC="BO"
SET TITLE="Common Procedural Code"
QUIT
+29 IF QC="BP"
SET TITLE="Anesthesia Related Surgical Procedure"
QUIT
+30 IF QC="BQ"
SET TITLE="(ICD-9-CM) Other Procedure Code"
SET IC=$$ICDLKUP(IC)
QUIT
+31 IF QC="BR"
SET TITLE="(ICD-9-CM) Principal Procedure Code"
SET IC=$$ICDLKUP(IC)
QUIT
+32 IF QC="CAH"
SET TITLE="Advanced Billing Concepts (ABC) Codes"
QUIT
+33 IF QC="DR"
SET TITLE="Diagnosis Related Group (DRG)"
QUIT
+34 IF QC="PR"
SET TITLE="(ICD-9-CM) Patient's Reason for Visit"
SET IC=$$ICDLKUP(IC)
QUIT
+35 IF QC="TC"
SET TITLE="Treatment Code"
QUIT
+36 IF QC="TQ"
SET TITLE="Systemized Nomenclature of Dentistry (SNODENT)"
QUIT
End DoDot:2
+37 ;
+38 IF HI=QC
Begin DoDot:2
+39 ;TPF;IB*2*770v38;EBILL-5482,5483
IF QC="ABK"!(QC="ABF")
SET IC=$$ICDLKUP(IC)
if $GET(IBFORM)'="UB-04"
SET IC=((CNT-1)_" ")_IC
SET DIAGPTRARR(CNT-1)=IC
QUIT
+40 IF QC="BBQ"!(QC="BBR")
SET IC=$$PCSLKUP^IBACCWLRURREV1A(IC)
QUIT
End DoDot:2
+41 ;
+42 DO SET^IBACCWLVE1(TITLE,IC)
+43 IF DTP'=""
Begin DoDot:2
+44 IF QC="BH"
SET TITLE="Occurrence Code Date"
QUIT
+45 IF QC="BI"
SET TITLE="Occurrence Span Code Dates"
QUIT
+46 SET TITLE="Principal Procedure Date"
End DoDot:2
DO SET^IBACCWLVE1(TITLE,$$DATE^IBACCWLVE1(DTP,DTQ))
+47 IF AMT'=""
DO SET^IBACCWLVE1("Value Code Amount",$$DOL^IBACCWLVE1(AMT))
+48 IF POA'=""
DO SET^IBACCWLVE1("Present on Admission Indicator",$$YN^IBACCWLVE1(POA))
End DoDot:1
+49 QUIT
+50 ;
+51 ;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 ;
