Routine: RCXVDC4

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

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")

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)=""

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

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRCXVDC4   5449     printed  Mar 13, 2025@20:54:14                                                                                                                                                                                                     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      ;

RCXVDC4.m