IBACCWLRURREV3 ;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.
;
SV1 ;837p
;
N CNT,COMBCPTANDDIAG,CPTCODE,CPTDESC,INFO,MODIFIER
;
S INFO=$P(DATA,D,2)
F CNT=3:1:6 S MODIFIER=$P(INFO,D1,CNT) Q:MODIFIER="" S MODIFIER(CNT-2)=MODIFIER
S CPTCODE=$P(INFO,D1,2)
I CPTCODE="" Q
S SV1LEVEL=SV1LEVEL+1 ;MUST INCREASE LEVEL NLY IF CODE EXISTS
S CPTDESC=$P($$HCPCS^IBACCWLUTIL1(CPTCODE),"- ",2)
S INFO=$P(DATA,D,8)
;
I $G(SV1LEVEL)=1 D
.D SET^IBACCWLRURREV("")
.D SET^IBACCWLRURREV("CPT Mod","Description","","","1^9","11^30","45^25^Diagnosis Code Pointer")
;
Q:$G(SV1LEVEL)>2&($G(IBPROC)="")
I $G(SV1LEVEL)=2,($G(IBPROC)="") D Q
. D SET^IBACCWLRURREV("No CPTs Found")
;
;FOR DETAIL MULT LINE DISPLAY
;F CNT=1:1:4 S CODE=$P(INFO,D1,CNT) I $L(CODE) I $D(DIAGPTRARR(CODE)) S:CNT'=1 TITLE="" D SET(TITLE,COMBCPTANDDIAG_DIAGPTRARR(CODE))
;FOR ONE LINE DISPLAY
S COMBCPTANDDIAG=""
F CNT=1:1:4 S CODE=$P(INFO,D1,CNT) I $L(CODE) S:$D(DIAGPTRARR(CODE)) COMBCPTANDDIAG=COMBCPTANDDIAG_$P(DIAGPTRARR(CODE)," -")_$S(CNT<$L(INFO,":"):", ",1:"")
;
S CNT=0
I $O(MODIFIER(CNT)) D Q
.F S CNT=$O(MODIFIER(CNT)) Q:CNT="" D
..D SET^IBACCWLRURREV(CPTCODE_" "_MODIFIER(CNT),CPTDESC,"","","1^9","11^30","45^80^"_COMBCPTANDDIAG) ;TPF;IB*2*770v42;EBILL-5942,EBILL-5909
;
D SET^IBACCWLRURREV(CPTCODE_" ",CPTDESC,"","","1^9","11^30","45^80^"_COMBCPTANDDIAG)
;
Q
;
SV2 ;837i
;
N CODE,CNT,INFO
;
S INFO=$P(DATA,D,3)
S CODE=$P(INFO,D1,2)
I CODE="" Q
;
S SV2LEVEL=SV2LEVEL+1
;
I $G(SV2LEVEL)=1 D
.D SET^IBACCWLRURREV("","",1,"")
.D SET^IBACCWLRURREV(" "," ICD/PCS Description","")
;
Q:$G(SV2LEVEL)>2&($G(IBPROC)="")
I $G(SV2LEVEL)=2,($G(IBPROC)="") D Q
. D SET^IBACCWLRURREV("Principle Procedure","No Procedures Found","","","1^25","26^80")
;
I $G(SV2LEVEL)=1 D SET^IBACCWLRURREV("Principle Procedure",$$HCPCS(CODE),"","","1^25","26^80") Q
E I $G(SV2LEVEL)=2 D SET^IBACCWLRURREV("Other Procedure",$$HCPCS(CODE),"","","1^25","26^80") Q
D SET^IBACCWLRURREV("",$$HCPCS(CODE),"","","1^25","26^80")
;
Q
;
SV3 ;837J DENTAL
;
N CNT,CODE,CPTCODE,COMBCPTANDDIAG,INFO
;
S INFO=$P(DATA,D,2)
S CODE=$P(INFO,D1,1)
I CODE="" Q
S SV3LEVEL=SV3LEVEL+1
;
S CPTCODE=$P(INFO,D1,2)
S COMBCPTANDDIAG=""
;
I $G(SV3LEVEL)=1,($G(IBPROC)="") D Q
. D SET^IBACCWLRURREV("Principle Procedure","No Procedure Codes Found")
;
I $G(SV3LEVEL)=1 D
.D SET^IBACCWLRURREV("")
.D SET^IBACCWLRURREV("CPT","Description","","","1^8","10^100","45^80^Diagnosis Code Pointer") ;TPF;IB*2*770v42;EBILL-5942,EBILL-5909
;
Q:$G(SV3LEVEL)>1&$G(IBPROC)=""
I $G(SV3LEVEL)=2,($G(IBPROC)="") D Q
. D SET^IBACCWLRURREV("No CPTs Found")
;
S INFO=$P(DATA,D,12) I INFO'="" F CNT=1:1:4 S CODE=$P(INFO,D1,CNT) I CODE S:$D(DIAGPTRARR(CODE)) COMBCPTANDDIAG=COMBCPTANDDIAG_$P(DIAGPTRARR(CODE)," -")_$S(CNT<$L(INFO,":"):", ",1:"")
;
D SET^IBACCWLRURREV(CPTCODE,$P($$HCPCS(CPTCODE),"-",2),"","","1^8","10^30","45^80^"_COMBCPTANDDIAG)
;
Q
;
CPTMOD(MOD) ;CPT Code Modifier lookup v12
N CPTARY,RSLT
S RSLT=$$MOD^ICPTMOD(MOD,.CPTARY) ;ICR #1996 (Supported)
I RSLT'["" Q MOD_" - Unknown Code"
S MOD=MOD_" - "_$P(RSLT,U,3)
Q MOD
;
DATE(DATE,TYPE) ;Format Date/Time
N D1
S TYPE=$G(TYPE,"D8")
I TYPE="TM" S D1=DATE G DATEQ
I TYPE="D8"!(TYPE="DT") D G DATEQ
. S D1=$$FMTE^XLFDT($$HL7TFM^XLFDT($E(DATE,1,8)),1)
. I TYPE="DT" S D1=D1_" "_$E(DATE,9,12)
S D1=$$FMTE^XLFDT($$HL7TFM^XLFDT($P(DATE,"-",1),1))_"-"_$$FMTE^XLFDT($$HL7TFM^XLFDT($P(DATE,"-",2),1))
DATEQ ;
Q D1
;
DOL(DATA) ;Format Dollars
S DATA="$"_$FN(DATA,",",2)
Q DATA
;
HCPCS(CODE) ;CPT Code lookup v12
N CPTARY,RSLT
S RSLT=$$CPT^ICPTCOD(CODE,.CPTARY) ;ICR #1995 (Supported)
I RSLT'["" S CODE=CODE_" - Unknown Code" G HCPCSQ
S CODE=CODE_" - "_$P(RSLT,U,3)
HCPCSQ Q CODE
;
SET(TITLE,VALUE,BLANK,HEADER) ;
D SET^IBACCWLRURREV($G(TITLE),$G(VALUE),$G(BLANK),$G(HEADER))
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBACCWLRURREV3 4254 printed May 25, 2026@12:10:08 Page 2
IBACCWLRURREV3 ;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 ;
SV1 ;837p
+1 ;
+2 NEW CNT,COMBCPTANDDIAG,CPTCODE,CPTDESC,INFO,MODIFIER
+3 ;
+4 SET INFO=$PIECE(DATA,D,2)
+5 FOR CNT=3:1:6
SET MODIFIER=$PIECE(INFO,D1,CNT)
if MODIFIER=""
QUIT
SET MODIFIER(CNT-2)=MODIFIER
+6 SET CPTCODE=$PIECE(INFO,D1,2)
+7 IF CPTCODE=""
QUIT
+8 ;MUST INCREASE LEVEL NLY IF CODE EXISTS
SET SV1LEVEL=SV1LEVEL+1
+9 SET CPTDESC=$PIECE($$HCPCS^IBACCWLUTIL1(CPTCODE),"- ",2)
+10 SET INFO=$PIECE(DATA,D,8)
+11 ;
+12 IF $GET(SV1LEVEL)=1
Begin DoDot:1
+13 DO SET^IBACCWLRURREV("")
+14 DO SET^IBACCWLRURREV("CPT Mod","Description","","","1^9","11^30","45^25^Diagnosis Code Pointer")
End DoDot:1
+15 ;
+16 if $GET(SV1LEVEL)>2&($GET(IBPROC)="")
QUIT
+17 IF $GET(SV1LEVEL)=2
IF ($GET(IBPROC)="")
Begin DoDot:1
+18 DO SET^IBACCWLRURREV("No CPTs Found")
End DoDot:1
QUIT
+19 ;
+20 ;FOR DETAIL MULT LINE DISPLAY
+21 ;F CNT=1:1:4 S CODE=$P(INFO,D1,CNT) I $L(CODE) I $D(DIAGPTRARR(CODE)) S:CNT'=1 TITLE="" D SET(TITLE,COMBCPTANDDIAG_DIAGPTRARR(CODE))
+22 ;FOR ONE LINE DISPLAY
+23 SET COMBCPTANDDIAG=""
+24 FOR CNT=1:1:4
SET CODE=$PIECE(INFO,D1,CNT)
IF $LENGTH(CODE)
if $DATA(DIAGPTRARR(CODE))
SET COMBCPTANDDIAG=COMBCPTANDDIAG_$PIECE(DIAGPTRARR(CODE)," -")_$SELECT(CNT<$LENGTH(INFO,":"):", ",1:"")
+25 ;
+26 SET CNT=0
+27 IF $ORDER(MODIFIER(CNT))
Begin DoDot:1
+28 FOR
SET CNT=$ORDER(MODIFIER(CNT))
if CNT=""
QUIT
Begin DoDot:2
+29 ;TPF;IB*2*770v42;EBILL-5942,EBILL-5909
DO SET^IBACCWLRURREV(CPTCODE_" "_MODIFIER(CNT),CPTDESC,"","","1^9","11^30","45^80^"_COMBCPTANDDIAG)
End DoDot:2
End DoDot:1
QUIT
+30 ;
+31 DO SET^IBACCWLRURREV(CPTCODE_" ",CPTDESC,"","","1^9","11^30","45^80^"_COMBCPTANDDIAG)
+32 ;
+33 QUIT
+34 ;
SV2 ;837i
+1 ;
+2 NEW CODE,CNT,INFO
+3 ;
+4 SET INFO=$PIECE(DATA,D,3)
+5 SET CODE=$PIECE(INFO,D1,2)
+6 IF CODE=""
QUIT
+7 ;
+8 SET SV2LEVEL=SV2LEVEL+1
+9 ;
+10 IF $GET(SV2LEVEL)=1
Begin DoDot:1
+11 DO SET^IBACCWLRURREV("","",1,"")
+12 DO SET^IBACCWLRURREV(" "," ICD/PCS Description","")
End DoDot:1
+13 ;
+14 if $GET(SV2LEVEL)>2&($GET(IBPROC)="")
QUIT
+15 IF $GET(SV2LEVEL)=2
IF ($GET(IBPROC)="")
Begin DoDot:1
+16 DO SET^IBACCWLRURREV("Principle Procedure","No Procedures Found","","","1^25","26^80")
End DoDot:1
QUIT
+17 ;
+18 IF $GET(SV2LEVEL)=1
DO SET^IBACCWLRURREV("Principle Procedure",$$HCPCS(CODE),"","","1^25","26^80")
QUIT
+19 IF '$TEST
IF $GET(SV2LEVEL)=2
DO SET^IBACCWLRURREV("Other Procedure",$$HCPCS(CODE),"","","1^25","26^80")
QUIT
+20 DO SET^IBACCWLRURREV("",$$HCPCS(CODE),"","","1^25","26^80")
+21 ;
+22 QUIT
+23 ;
SV3 ;837J DENTAL
+1 ;
+2 NEW CNT,CODE,CPTCODE,COMBCPTANDDIAG,INFO
+3 ;
+4 SET INFO=$PIECE(DATA,D,2)
+5 SET CODE=$PIECE(INFO,D1,1)
+6 IF CODE=""
QUIT
+7 SET SV3LEVEL=SV3LEVEL+1
+8 ;
+9 SET CPTCODE=$PIECE(INFO,D1,2)
+10 SET COMBCPTANDDIAG=""
+11 ;
+12 IF $GET(SV3LEVEL)=1
IF ($GET(IBPROC)="")
Begin DoDot:1
+13 DO SET^IBACCWLRURREV("Principle Procedure","No Procedure Codes Found")
End DoDot:1
QUIT
+14 ;
+15 IF $GET(SV3LEVEL)=1
Begin DoDot:1
+16 DO SET^IBACCWLRURREV("")
+17 ;TPF;IB*2*770v42;EBILL-5942,EBILL-5909
DO SET^IBACCWLRURREV("CPT","Description","","","1^8","10^100","45^80^Diagnosis Code Pointer")
End DoDot:1
+18 ;
+19 if $GET(SV3LEVEL)>1&$GET(IBPROC)=""
QUIT
+20 IF $GET(SV3LEVEL)=2
IF ($GET(IBPROC)="")
Begin DoDot:1
+21 DO SET^IBACCWLRURREV("No CPTs Found")
End DoDot:1
QUIT
+22 ;
+23 SET INFO=$PIECE(DATA,D,12)
IF INFO'=""
FOR CNT=1:1:4
SET CODE=$PIECE(INFO,D1,CNT)
IF CODE
if $DATA(DIAGPTRARR(CODE))
SET COMBCPTANDDIAG=COMBCPTANDDIAG_$PIECE(DIAGPTRARR(CODE)," -")_$SELECT(CNT<$LENGTH(INFO,":"):", ",1:"")
+24 ;
+25 DO SET^IBACCWLRURREV(CPTCODE,$PIECE($$HCPCS(CPTCODE),"-",2),"","","1^8","10^30","45^80^"_COMBCPTANDDIAG)
+26 ;
+27 QUIT
+28 ;
CPTMOD(MOD) ;CPT Code Modifier lookup v12
+1 NEW CPTARY,RSLT
+2 ;ICR #1996 (Supported)
SET RSLT=$$MOD^ICPTMOD(MOD,.CPTARY)
+3 IF RSLT'[""
QUIT MOD_" - Unknown Code"
+4 SET MOD=MOD_" - "_$PIECE(RSLT,U,3)
+5 QUIT MOD
+6 ;
DATE(DATE,TYPE) ;Format Date/Time
+1 NEW D1
+2 SET TYPE=$GET(TYPE,"D8")
+3 IF TYPE="TM"
SET D1=DATE
GOTO DATEQ
+4 IF TYPE="D8"!(TYPE="DT")
Begin DoDot:1
+5 SET D1=$$FMTE^XLFDT($$HL7TFM^XLFDT($EXTRACT(DATE,1,8)),1)
+6 IF TYPE="DT"
SET D1=D1_" "_$EXTRACT(DATE,9,12)
End DoDot:1
GOTO DATEQ
+7 SET D1=$$FMTE^XLFDT($$HL7TFM^XLFDT($PIECE(DATE,"-",1),1))_"-"_$$FMTE^XLFDT($$HL7TFM^XLFDT($PIECE(DATE,"-",2),1))
DATEQ ;
+1 QUIT D1
+2 ;
DOL(DATA) ;Format Dollars
+1 SET DATA="$"_$FNUMBER(DATA,",",2)
+2 QUIT DATA
+3 ;
HCPCS(CODE) ;CPT Code lookup v12
+1 NEW CPTARY,RSLT
+2 ;ICR #1995 (Supported)
SET RSLT=$$CPT^ICPTCOD(CODE,.CPTARY)
+3 IF RSLT'[""
SET CODE=CODE_" - Unknown Code"
GOTO HCPCSQ
+4 SET CODE=CODE_" - "_$PIECE(RSLT,U,3)
HCPCSQ QUIT CODE
+1 ;
SET(TITLE,VALUE,BLANK,HEADER) ;
+1 DO SET^IBACCWLRURREV($GET(TITLE),$GET(VALUE),$GET(BLANK),$GET(HEADER))
+2 QUIT
