RCXVDC4 ;DAOU/ALA-AR Data Extraction Data Creation ;02-JUL-03
;;4.5;Accounts Receivable;**201,227,228,248,251,256,262,281**;Mar 20, 1995;Build 6
;;Per VHA Directive 2004-038, this routine should not be modified.
;
; Procedures
Q
D399PC ;
I RCXVD0="" Q
N RCXVD,RCXVDA,RCXVB,RCXVPC,RCXVP1,RCXVP2,RCXVP3,RCXVMULT
N RCXVDT3,RCXVCP,RCXVPCDT,RCXVPS1,RCXVPS2,RCXVPS,RCXVPSER,RCXVNPI,RCXVCNT,RCXVMH
;RCXVPC=PROC. CODE IEN, RCXVCP=CPT CODE IEN
; LOOP THRU PROC.
S (RCXVPC,RCXVCNT)=0
K ^TMP($J,"MTCH")
F S RCXVPC=$O(^DGCR(399,RCXVD0,"CP",RCXVPC)) Q:'RCXVPC D D399PCA
S RCXVPC=0
F S RCXVPC=$O(^DGCR(399,RCXVD0,"RC",RCXVPC)) Q:'RCXVPC D D39942
K ^TMP($J,"MTCH")
Q
D399PCA ;
S RCXVD=$G(^DGCR(399,RCXVD0,"CP",RCXVPC,0)) Q:RCXVD=""
S RCXVP1=$P(RCXVD,U,1),RCXVVP="",RCXVVP1=""
;
I RCXVP1'="",$P(RCXVP1,";",2)'="ICD0(" D
. S RCXVVP="^"_$P(RCXVP1,";",2)_$P(RCXVP1,";",1)_",0)"
. I RCXVVP'="" S RCXVVP1=$P($G(@RCXVVP),U,1)_RCXVU ; ICD10 in *281 - CPT code will not have a ICD code qualifier, so delimiter is added to account for qualifier field.
;
; ICD10 in *281 - procedure code by calling API #5747 (80.1,ien)
I RCXVP1'="",$P(RCXVP1,";",2)="ICD0(" D
. S RCXVVP1=$P($$CODEC^ICDEX(80.1,$P(RCXVP1,";")),U)
. S:RCXVVP1=-1 RCXVVP1=""
. ; ICD10 in *281 - determine procedure code qualifier by calling API #5747
. ; $$CODECS^ICDEX(CODE/IEN,FILE,CDT) coding system for code ien/file.
. ; Procedure code qualifiers ICD-9, ICD-10, etc.
. I RCXVVP1'="" S RCXVVP1=RCXVVP1_RCXVU_$P($$CODECS^ICDEX(RCXVP1,80.1,$P(RCXVD,U,2)),U,1) ; procedure code and qualifier.
;
I RCXVVP1="" D S RCXVVP1=RCXVU ; ICD10 in *281 - need to add delimiter for ICD proc code qualifier if no proc.
. NEW CT
. S CT=$G(^TMP("RCXVBREC",$J,0))+1,^TMP("RCXVBREC",$J,0)=CT
. S ^TMP("RCXVBREC",$J,CT,0)="Bill # "_$P($G(^DGCR(399,RCXVD0,0)),"^",1)_" has a bad CPT code at IEN # "_RCXVPC_" check ^DGCR(399,"_RCXVD0_",""CP"","_RCXVPC_",0)"
S RCXVDA=RCXVBLNA_RCXVU_RCXVVP1 ; PROC. ICD10 in *281 - RCXVVP1 contains the record for the PROC and ICD code qualifier (PROC_DELIMITER_QUALIFIER). Qualifier can be NULL.
S RCXVDT=$P(RCXVD,U,2)
S RCXVPCDT=$E($$HLDATE^HLFNC(RCXVDT),1,8)
S RCXVDA=RCXVDA_RCXVU_RCXVPCDT ; DT
S RCXVP1=$P(RCXVD,U,11),RCXVP2=""
;
; ICD10 in *281 - diagnosis code by calling API #5747 (80,ien)
I RCXVP1'="" D
. S RCXVP1=$P($G(^IBA(362.3,RCXVP1,0)),U,1)
. S RCXVP2=$P($$CODEC^ICDEX(80,RCXVP1),U)
. S:RCXVP2=-1 RCXVP2=""
. ; ICD10 in *281 - determine diagnosis code qualifier by calling API #5747
. ; $$CODECS^ICDEX(CODE/IEN,FILE,CDT) coding system for code ien/file.
. ; Diagnosis code qualifiers ICD-9, ICD-10, etc.
. I RCXVP2'="" S RCXVP2=RCXVP2_RCXVU_$P($$CODECS^ICDEX(RCXVP1,80,$P(RCXVD,U,2)),U,1) ; diagnosis code and qualifier.
;
S:RCXVP2="" RCXVP2=RCXVU ; ICD10 in *281 - need to add delimiter for ICD ASSOC DXN (1) code qualifier if no ASSOC DXN (1).
S RCXVDA=RCXVDA_RCXVU_RCXVP2 ; ASSOC DXN (1)
S RCXVP1=$P(RCXVD,U,7),RCXVP2=""
I RCXVP1'="" S RCXVP2=$P($G(^SC(RCXVP1,0)),U,1)
S RCXVDA=RCXVDA_RCXVU_RCXVP2 ; ASSC. CLNC (P)
S RCXVP1=$P(RCXVD,U,18),(RCXVP2,RCXVPS,RCXVPSER,RCXVNPI)=""
I RCXVP1'="" S RCXVP2=$$GET1^DIQ(200,RCXVP1_",",.01,"E"),RCXVNPI=$P($$NPI^XUSNPI("Individual_ID",RCXVP1),RCXVU,1) S:+RCXVNPI<1 RCXVNPI="" D
. S RCXVPS=$$GET^XUA4A72(RCXVP1,RCXVDT)
. S RCXVPS=$P(RCXVPS,U,3)
. S RCXVPSER=$$GET1^DIQ(200,RCXVP1_",",29,"E")
. Q
;provider^provider npi^specialty^service/section
S RCXVDA=RCXVDA_RCXVU_RCXVP2_RCXVU_RCXVNPI_RCXVU_RCXVPS_RCXVU_RCXVPSER
S RCXVCNT=RCXVCNT+1,^TMP($J,RCXVBLN,"4-399A",RCXVCNT)=RCXVDA
; LOOP THRU CPT
S RCXVCP=0,RCXVMULT=0
F S RCXVCP=$O(^DGCR(399,RCXVD0,"CP",RCXVPC,"MOD",RCXVCP)) Q:'RCXVCP D
. Q:'($D(^DGCR(399,RCXVD0,"CP",RCXVPC,"MOD",RCXVCP,0)))
. ; ^DGCR(399,D0,CP,D1,MOD,D2,0)= (#.01) CPT MODIFIER SEQUENCE [1N]
. ; (#.02) CPT ==>MODIFIER [2P:81.3]
. S RCXVP1=$P($G(^DGCR(399,RCXVD0,"CP",RCXVPC,"MOD",RCXVCP,0)),U,2)
. Q:RCXVP1=""
. S RCXVMULT=RCXVMULT+1
. S RCXVP2=$P($G(^DIC(81.3,RCXVP1,0)),U,1)
. S ^TMP($J,RCXVBLN,"4-399A",RCXVCNT,RCXVMULT)=RCXVP2
. Q
;
; *256 - loop through 399.042 to find CPT procedure
MATCH N RCXVCPT1,RCXVFND,X
S RCXVCPT1=$P(RCXVD,";",1) ;proc
S (RCXVFND,RCXVCP)=0
F S RCXVCP=$O(^DGCR(399,RCXVD0,"RC",RCXVCP)) Q:'RCXVCP!RCXVFND D
. Q:$D(^TMP($J,"MTCH",RCXVCP)) ;quit if CPT proc match
. S RCXVD1=$G(^DGCR(399,RCXVD0,"RC",RCXVCP,0))
. Q:RCXVD1=""
. S X=$P(RCXVD1,U,6) ;CPT proc
. I RCXVCPT1'="",X'="",RCXVCPT1=X D
.. S RCXVFND=1
.. S X=$P(RCXVD1,U)
.. S RCXVDB=RCXVBLNA_RCXVU_$$GET1^DIQ(399.2,X_",",.01,"E") ; Revenue Code
.. S X=$P(RCXVD1,U,6)
.. S RCXVDB=RCXVDB_RCXVU_$$GET1^DIQ(81,X_",",.01,"E") ; Procedures [P]
.. S RCXVDB=RCXVDB_RCXVU_RCXVPCDT ; PROC. DT
.. S RCXVDB=RCXVDB_RCXVU_$P(RCXVD1,U,2) ; Charges
.. S ^TMP($J,RCXVBLN,"4-399B",RCXVCNT)=RCXVDB
.. S ^TMP($J,"MTCH",RCXVCP)=""
I 'RCXVFND S ^TMP($J,RCXVBLN,"4-399B",RCXVCNT)=""
Q
;
D39942 ; charge
N X
Q:$D(^TMP($J,"MTCH",RCXVPC))
S RCXVD1=$G(^DGCR(399,RCXVD0,"RC",RCXVPC,0))
Q:RCXVD1=""
S X=$P(RCXVD1,U)
S RCXVDB=RCXVBLNA_RCXVU_$$GET1^DIQ(399.2,X_",",.01,"E") ; Revenue Code
S RCXVDB=RCXVDB_RCXVU_"" ;No CPT proc
S RCXVDB=RCXVDB_RCXVU_"" ; No proc dt
S RCXVDB=RCXVDB_RCXVU_$P(RCXVD1,U,2) ; Charges
S RCXVCNT=RCXVCNT+1
S ^TMP($J,RCXVBLN,"4-399A",RCXVCNT)=""
S ^TMP($J,RCXVBLN,"4-399B",RCXVCNT)=RCXVDB
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRCXVDC4 5449 printed Nov 22, 2024@16:59:45 Page 2
RCXVDC4 ;DAOU/ALA-AR Data Extraction Data Creation ;02-JUL-03
+1 ;;4.5;Accounts Receivable;**201,227,228,248,251,256,262,281**;Mar 20, 1995;Build 6
+2 ;;Per VHA Directive 2004-038, this routine should not be modified.
+3 ;
+4 ; Procedures
+5 QUIT
D399PC ;
+1 IF RCXVD0=""
QUIT
+2 NEW RCXVD,RCXVDA,RCXVB,RCXVPC,RCXVP1,RCXVP2,RCXVP3,RCXVMULT
+3 NEW RCXVDT3,RCXVCP,RCXVPCDT,RCXVPS1,RCXVPS2,RCXVPS,RCXVPSER,RCXVNPI,RCXVCNT,RCXVMH
+4 ;RCXVPC=PROC. CODE IEN, RCXVCP=CPT CODE IEN
+5 ; LOOP THRU PROC.
+6 SET (RCXVPC,RCXVCNT)=0
+7 KILL ^TMP($JOB,"MTCH")
+8 FOR
SET RCXVPC=$ORDER(^DGCR(399,RCXVD0,"CP",RCXVPC))
if 'RCXVPC
QUIT
DO D399PCA
+9 SET RCXVPC=0
+10 FOR
SET RCXVPC=$ORDER(^DGCR(399,RCXVD0,"RC",RCXVPC))
if 'RCXVPC
QUIT
DO D39942
+11 KILL ^TMP($JOB,"MTCH")
+12 QUIT
D399PCA ;
+1 SET RCXVD=$GET(^DGCR(399,RCXVD0,"CP",RCXVPC,0))
if RCXVD=""
QUIT
+2 SET RCXVP1=$PIECE(RCXVD,U,1)
SET RCXVVP=""
SET RCXVVP1=""
+3 ;
+4 IF RCXVP1'=""
IF $PIECE(RCXVP1,";",2)'="ICD0("
Begin DoDot:1
+5 SET RCXVVP="^"_$PIECE(RCXVP1,";",2)_$PIECE(RCXVP1,";",1)_",0)"
+6 ; ICD10 in *281 - CPT code will not have a ICD code qualifier, so delimiter is added to account for qualifier field.
IF RCXVVP'=""
SET RCXVVP1=$PIECE($GET(@RCXVVP),U,1)_RCXVU
End DoDot:1
+7 ;
+8 ; ICD10 in *281 - procedure code by calling API #5747 (80.1,ien)
+9 IF RCXVP1'=""
IF $PIECE(RCXVP1,";",2)="ICD0("
Begin DoDot:1
+10 SET RCXVVP1=$PIECE($$CODEC^ICDEX(80.1,$PIECE(RCXVP1,";")),U)
+11 if RCXVVP1=-1
SET RCXVVP1=""
+12 ; ICD10 in *281 - determine procedure code qualifier by calling API #5747
+13 ; $$CODECS^ICDEX(CODE/IEN,FILE,CDT) coding system for code ien/file.
+14 ; Procedure code qualifiers ICD-9, ICD-10, etc.
+15 ; procedure code and qualifier.
IF RCXVVP1'=""
SET RCXVVP1=RCXVVP1_RCXVU_$PIECE($$CODECS^ICDEX(RCXVP1,80.1,$PIECE(RCXVD,U,2)),U,1)
End DoDot:1
+16 ;
+17 ; ICD10 in *281 - need to add delimiter for ICD proc code qualifier if no proc.
IF RCXVVP1=""
Begin DoDot:1
+18 NEW CT
+19 SET CT=$GET(^TMP("RCXVBREC",$JOB,0))+1
SET ^TMP("RCXVBREC",$JOB,0)=CT
+20 SET ^TMP("RCXVBREC",$JOB,CT,0)="Bill # "_$PIECE($GET(^DGCR(399,RCXVD0,0)),"^",1)_" has a bad CPT code at IEN # "_RCXVPC_" check ^DGCR(399,"_RCXVD0_",""CP"","_RCXVPC_",0)"
End DoDot:1
SET RCXVVP1=RCXVU
+21 ; PROC. ICD10 in *281 - RCXVVP1 contains the record for the PROC and ICD code qualifier (PROC_DELIMITER_QUALIFIER). Qualifier can be NULL.
SET RCXVDA=RCXVBLNA_RCXVU_RCXVVP1
+22 SET RCXVDT=$PIECE(RCXVD,U,2)
+23 SET RCXVPCDT=$EXTRACT($$HLDATE^HLFNC(RCXVDT),1,8)
+24 ; DT
SET RCXVDA=RCXVDA_RCXVU_RCXVPCDT
+25 SET RCXVP1=$PIECE(RCXVD,U,11)
SET RCXVP2=""
+26 ;
+27 ; ICD10 in *281 - diagnosis code by calling API #5747 (80,ien)
+28 IF RCXVP1'=""
Begin DoDot:1
+29 SET RCXVP1=$PIECE($GET(^IBA(362.3,RCXVP1,0)),U,1)
+30 SET RCXVP2=$PIECE($$CODEC^ICDEX(80,RCXVP1),U)
+31 if RCXVP2=-1
SET RCXVP2=""
+32 ; ICD10 in *281 - determine diagnosis code qualifier by calling API #5747
+33 ; $$CODECS^ICDEX(CODE/IEN,FILE,CDT) coding system for code ien/file.
+34 ; Diagnosis code qualifiers ICD-9, ICD-10, etc.
+35 ; diagnosis code and qualifier.
IF RCXVP2'=""
SET RCXVP2=RCXVP2_RCXVU_$PIECE($$CODECS^ICDEX(RCXVP1,80,$PIECE(RCXVD,U,2)),U,1)
End DoDot:1
+36 ;
+37 ; ICD10 in *281 - need to add delimiter for ICD ASSOC DXN (1) code qualifier if no ASSOC DXN (1).
if RCXVP2=""
SET RCXVP2=RCXVU
+38 ; ASSOC DXN (1)
SET RCXVDA=RCXVDA_RCXVU_RCXVP2
+39 SET RCXVP1=$PIECE(RCXVD,U,7)
SET RCXVP2=""
+40 IF RCXVP1'=""
SET RCXVP2=$PIECE($GET(^SC(RCXVP1,0)),U,1)
+41 ; ASSC. CLNC (P)
SET RCXVDA=RCXVDA_RCXVU_RCXVP2
+42 SET RCXVP1=$PIECE(RCXVD,U,18)
SET (RCXVP2,RCXVPS,RCXVPSER,RCXVNPI)=""
+43 IF RCXVP1'=""
SET RCXVP2=$$GET1^DIQ(200,RCXVP1_",",.01,"E")
SET RCXVNPI=$PIECE($$NPI^XUSNPI("Individual_ID",RCXVP1),RCXVU,1)
if +RCXVNPI<1
SET RCXVNPI=""
Begin DoDot:1
+44 SET RCXVPS=$$GET^XUA4A72(RCXVP1,RCXVDT)
+45 SET RCXVPS=$PIECE(RCXVPS,U,3)
+46 SET RCXVPSER=$$GET1^DIQ(200,RCXVP1_",",29,"E")
+47 QUIT
End DoDot:1
+48 ;provider^provider npi^specialty^service/section
+49 SET RCXVDA=RCXVDA_RCXVU_RCXVP2_RCXVU_RCXVNPI_RCXVU_RCXVPS_RCXVU_RCXVPSER
+50 SET RCXVCNT=RCXVCNT+1
SET ^TMP($JOB,RCXVBLN,"4-399A",RCXVCNT)=RCXVDA
+51 ; LOOP THRU CPT
+52 SET RCXVCP=0
SET RCXVMULT=0
+53 FOR
SET RCXVCP=$ORDER(^DGCR(399,RCXVD0,"CP",RCXVPC,"MOD",RCXVCP))
if 'RCXVCP
QUIT
Begin DoDot:1
+54 if '($DATA(^DGCR(399,RCXVD0,"CP",RCXVPC,"MOD",RCXVCP,0)))
QUIT
+55 ; ^DGCR(399,D0,CP,D1,MOD,D2,0)= (#.01) CPT MODIFIER SEQUENCE [1N]
+56 ; (#.02) CPT ==>MODIFIER [2P:81.3]
+57 SET RCXVP1=$PIECE($GET(^DGCR(399,RCXVD0,"CP",RCXVPC,"MOD",RCXVCP,0)),U,2)
+58 if RCXVP1=""
QUIT
+59 SET RCXVMULT=RCXVMULT+1
+60 SET RCXVP2=$PIECE($GET(^DIC(81.3,RCXVP1,0)),U,1)
+61 SET ^TMP($JOB,RCXVBLN,"4-399A",RCXVCNT,RCXVMULT)=RCXVP2
+62 QUIT
End DoDot:1
+63 ;
+64 ; *256 - loop through 399.042 to find CPT procedure
MATCH NEW RCXVCPT1,RCXVFND,X
+1 ;proc
SET RCXVCPT1=$PIECE(RCXVD,";",1)
+2 SET (RCXVFND,RCXVCP)=0
+3 FOR
SET RCXVCP=$ORDER(^DGCR(399,RCXVD0,"RC",RCXVCP))
if 'RCXVCP!RCXVFND
QUIT
Begin DoDot:1
+4 ;quit if CPT proc match
if $DATA(^TMP($JOB,"MTCH",RCXVCP))
QUIT
+5 SET RCXVD1=$GET(^DGCR(399,RCXVD0,"RC",RCXVCP,0))
+6 if RCXVD1=""
QUIT
+7 ;CPT proc
SET X=$PIECE(RCXVD1,U,6)
+8 IF RCXVCPT1'=""
IF X'=""
IF RCXVCPT1=X
Begin DoDot:2
+9 SET RCXVFND=1
+10 SET X=$PIECE(RCXVD1,U)
+11 ; Revenue Code
SET RCXVDB=RCXVBLNA_RCXVU_$$GET1^DIQ(399.2,X_",",.01,"E")
+12 SET X=$PIECE(RCXVD1,U,6)
+13 ; Procedures [P]
SET RCXVDB=RCXVDB_RCXVU_$$GET1^DIQ(81,X_",",.01,"E")
+14 ; PROC. DT
SET RCXVDB=RCXVDB_RCXVU_RCXVPCDT
+15 ; Charges
SET RCXVDB=RCXVDB_RCXVU_$PIECE(RCXVD1,U,2)
+16 SET ^TMP($JOB,RCXVBLN,"4-399B",RCXVCNT)=RCXVDB
+17 SET ^TMP($JOB,"MTCH",RCXVCP)=""
End DoDot:2
End DoDot:1
+18 IF 'RCXVFND
SET ^TMP($JOB,RCXVBLN,"4-399B",RCXVCNT)=""
+19 QUIT
+20 ;
D39942 ; charge
+1 NEW X
+2 if $DATA(^TMP($JOB,"MTCH",RCXVPC))
QUIT
+3 SET RCXVD1=$GET(^DGCR(399,RCXVD0,"RC",RCXVPC,0))
+4 if RCXVD1=""
QUIT
+5 SET X=$PIECE(RCXVD1,U)
+6 ; Revenue Code
SET RCXVDB=RCXVBLNA_RCXVU_$$GET1^DIQ(399.2,X_",",.01,"E")
+7 ;No CPT proc
SET RCXVDB=RCXVDB_RCXVU_""
+8 ; No proc dt
SET RCXVDB=RCXVDB_RCXVU_""
+9 ; Charges
SET RCXVDB=RCXVDB_RCXVU_$PIECE(RCXVD1,U,2)
+10 SET RCXVCNT=RCXVCNT+1
+11 SET ^TMP($JOB,RCXVBLN,"4-399A",RCXVCNT)=""
+12 SET ^TMP($JOB,RCXVBLN,"4-399B",RCXVCNT)=RCXVDB
+13 QUIT
+14 ;
