- Timestamp:
- Dec 4, 2009, 12:11:15 AM (14 years ago)
- File:
-
- 1 edited
Legend:
- Unmodified
- Added
- Removed
-
WorldVistAEHR/trunk/r/ACCOUNTS_RECEIVABLE-PRCA-PRY-RC/RCXVDC4.m
r613 r623 1 RCXVDC4 ;DAOU/ALA-AR Data Extraction Data Creation ;02-JUL-03 2 ;;4.5;Accounts Receivable;**201,227,228,248,251,256**;Mar 20, 1995;Build 6 3 ;;Per VHA Directive 2004-038, this routine should not be modified. 4 ; 5 ; Procedures 6 Q 7 D399PC ; 8 I RCXVD0="" Q 9 N RCXVD,RCXVDA,RCXVB,RCXVPC,RCXVP1,RCXVP2,RCXVP3,RCXVMULT 10 N RCXVDT3,RCXVCP,RCXVPCDT,RCXVPS1,RCXVPS2,RCXVPS,RCXVPSER,RCXVNPI,RCXVCNT,RCXVMH 11 ;RCXVPC=PROC. CODE IEN, RCXVCP=CPT CODE IEN 12 ; LOOP THRU PROC. 13 S RCXVMH="",(RCXVPC,RCXVCNT)=0 14 F S RCXVPC=$O(^DGCR(399,RCXVD0,"CP",RCXVPC)) Q:'RCXVPC D D399PCA 15 S RCXVPC=0 16 F S RCXVPC=$O(^DGCR(399,RCXVD0,"RC",RCXVPC)) Q:'RCXVPC D D39942 17 Q 18 D399PCA ; 19 S RCXVD=$G(^DGCR(399,RCXVD0,"CP",RCXVPC,0)) Q:RCXVD="" 20 S RCXVP1=$P(RCXVD,U,1),RCXVVP="",RCXVVP1="" 21 I RCXVP1'="" S RCXVVP="^"_$P(RCXVP1,";",2)_$P(RCXVP1,";",1)_",0)" 22 I RCXVVP'="" S RCXVVP1=$P($G(@RCXVVP),U,1) I RCXVVP1="" D 23 . NEW CT 24 . S CT=$G(^TMP("RCXVBREC",$J,0))+1,^TMP("RCXVBREC",$J,0)=CT 25 . 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)" 26 S RCXVDA=RCXVBLNA_RCXVU_RCXVVP1 ; PROC. 27 S RCXVDT=$P(RCXVD,U,2) 28 S RCXVPCDT=$E($$HLDATE^HLFNC(RCXVDT),1,8) 29 S RCXVDA=RCXVDA_RCXVU_RCXVPCDT ; DT 30 S RCXVP1=$P(RCXVD,U,11),RCXVP2="" 31 I RCXVP1'="" S RCXVP1=$P($G(^IBA(362.3,RCXVP1,0)),U,1) 32 I RCXVP1'="" S RCXVP2=$P($G(^ICD9(RCXVP1,0)),U,1) 33 S RCXVDA=RCXVDA_RCXVU_RCXVP2 ; ASSOC DXN (1) 34 S RCXVP1=$P(RCXVD,U,7),RCXVP2="" 35 I RCXVP1'="" S RCXVP2=$P($G(^SC(RCXVP1,0)),U,1) 36 S RCXVDA=RCXVDA_RCXVU_RCXVP2 ; ASSC. CLNC (P) 37 S RCXVP1=$P(RCXVD,U,18),(RCXVP2,RCXVPS,RCXVPSER,RCXVNPI)="" 38 I RCXVP1'="" S RCXVP2=$$GET1^DIQ(200,RCXVP1_",",.01,"E"),RCXVNPI=$P($$NPI^XUSNPI("Individual_ID",RCXVP1),RCXVU,1) S:+RCXVNPI<1 RCXVNPI="" D 39 . S RCXVPS=$$GET^XUA4A72(RCXVP1,RCXVDT) 40 . S RCXVPS=$P(RCXVPS,U,3) 41 . S RCXVPSER=$$GET1^DIQ(200,RCXVP1_",",29,"E") 42 . Q 43 ;provider^provider npi^specialty^service/section 44 S RCXVDA=RCXVDA_RCXVU_RCXVP2_RCXVU_RCXVNPI_RCXVU_RCXVPS_RCXVU_RCXVPSER 45 S RCXVCNT=RCXVCNT+1,^TMP($J,RCXVBLN,"4-399A",RCXVCNT)=RCXVDA 46 ; LOOP THRU CPT 47 S RCXVCP=0,RCXVMULT=0 48 F S RCXVCP=$O(^DGCR(399,RCXVD0,"CP",RCXVPC,"MOD",RCXVCP)) Q:'RCXVCP D 49 . Q:'($D(^DGCR(399,RCXVD0,"CP",RCXVPC,"MOD",RCXVCP,0))) 50 . ; ^DGCR(399,D0,CP,D1,MOD,D2,0)= (#.01) CPT MODIFIER SEQUENCE [1N] 51 . ; (#.02) CPT ==>MODIFIER [2P:81.3] 52 . S RCXVP1=$P($G(^DGCR(399,RCXVD0,"CP",RCXVPC,"MOD",RCXVCP,0)),U,2) 53 . Q:RCXVP1="" 54 . S RCXVMULT=RCXVMULT+1 55 . S RCXVP2=$P($G(^DIC(81.3,RCXVP1,0)),U,1) 56 . S ^TMP($J,RCXVBLN,"4-399A",RCXVCNT,RCXVMULT)=RCXVP2 57 . Q 58 ; 59 ; *256 - loop through 399.042 to find CPT procedure 60 MATCH N RCXVCPT1,RCXVFND,X 61 S RCXVCPT1=$P(RCXVD,";",1) ;proc 62 S (RCXVFND,RCXVCP)=0 63 F S RCXVCP=$O(^DGCR(399,RCXVD0,"RC",RCXVCP)) Q:'RCXVCP!RCXVFND D 64 . Q:$F(RCXVMH,";"_RCXVCP) ;quit if CPT proc match 65 . S RCXVD1=$G(^DGCR(399,RCXVD0,"RC",RCXVCP,0)) 66 . Q:RCXVD1="" 67 . S X=$P(RCXVD1,U,6) ;CPT proc 68 . I RCXVCPT1'="",X'="",RCXVCPT1=X D 69 .. S RCXVFND=1 70 .. S X=$P(RCXVD1,U) 71 .. S RCXVDB=RCXVBLNA_RCXVU_$$GET1^DIQ(399.2,X_",",.01,"E") ; Revenue Code 72 .. S X=$P(RCXVD1,U,6) 73 .. S RCXVDB=RCXVDB_RCXVU_$$GET1^DIQ(81,X_",",.01,"E") ; Procedures [P] 74 .. S RCXVDB=RCXVDB_RCXVU_RCXVPCDT ; PROC. DT 75 .. S RCXVDB=RCXVDB_RCXVU_$P(RCXVD1,U,2) ; Charges 76 .. S ^TMP($J,RCXVBLN,"4-399B",RCXVCNT)=RCXVDB 77 .. S RCXVMH=RCXVMH_";"_RCXVCP 78 I 'RCXVFND S ^TMP($J,RCXVBLN,"4-399B",RCXVCNT)="" 79 Q 80 ; 81 D39942 ; charge 82 N X 83 Q:$F(RCXVMH,";"_RCXVPC) 84 S RCXVD1=$G(^DGCR(399,RCXVD0,"RC",RCXVPC,0)) 85 Q:RCXVD1="" 86 S X=$P(RCXVD1,U) 87 S RCXVDB=RCXVBLNA_RCXVU_$$GET1^DIQ(399.2,X_",",.01,"E") ; Revenue Code 88 S RCXVDB=RCXVDB_RCXVU_"" ;No CPT proc 89 S RCXVDB=RCXVDB_RCXVU_"" ; No proc dt 90 S RCXVDB=RCXVDB_RCXVU_$P(RCXVD1,U,2) ; Charges 91 S RCXVCNT=RCXVCNT+1 92 S ^TMP($J,RCXVBLN,"4-399A",RCXVCNT)="" 93 S ^TMP($J,RCXVBLN,"4-399B",RCXVCNT)=RCXVDB 94 Q 95 ; 1 RCXVDC4 ;DAOU/ALA-AR Data Extraction Data Creation ;02-JUL-03 2 ;;4.5;Accounts Receivable;**201,227,228,248,251**;Mar 20, 1995;Build 21 3 ;;Per VHA Directive 2004-038, this routine should not be modified. 4 ; 5 ; Procedures 6 Q 7 D399PC ; 8 I RCXVD0="" Q 9 N RCXVD,RCXVDA,RCXVB,RCXVPC,RCXVP1,RCXVP2,RCXVP3,RCXVMULT 10 N RCXVDT3,RCXVCP,RCXVPCDT,RCXVPS1,RCXVPS2,RCXVPS,RCXVPSER,RCXVNPI 11 ;RCXVPC=PROC. CODE IEN, RCXVCP=CPT CODE IEN 12 ; LOOP THRU PROC. 13 S RCXVPC=0 14 F S RCXVPC=$O(^DGCR(399,RCXVD0,"CP",RCXVPC)) Q:'RCXVPC D D399PCA 15 Q 16 D399PCA ; 17 S RCXVD=$G(^DGCR(399,RCXVD0,"CP",RCXVPC,0)) Q:RCXVD="" 18 S RCXVP1=$P(RCXVD,U,1),RCXVVP="",RCXVVP1="" 19 I RCXVP1'="" S RCXVVP="^"_$P(RCXVP1,";",2)_$P(RCXVP1,";",1)_",0)" 20 I RCXVVP'="" S RCXVVP1=$P($G(@RCXVVP),U,1) I RCXVVP1="" D 21 . NEW CT 22 . S CT=$G(^TMP("RCXVBREC",$J,0))+1,^TMP("RCXVBREC",$J,0)=CT 23 . 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)" 24 S RCXVDA=RCXVBLNA_RCXVU_RCXVVP1 ; PROC. 25 S RCXVDT=$P(RCXVD,U,2) 26 S RCXVPCDT=$E($$HLDATE^HLFNC(RCXVDT),1,8) 27 S RCXVDA=RCXVDA_RCXVU_RCXVPCDT ; DT 28 S RCXVP1=$P(RCXVD,U,11),RCXVP2="" 29 I RCXVP1'="" S RCXVP1=$P($G(^IBA(362.3,RCXVP1,0)),U,1) 30 I RCXVP1'="" S RCXVP2=$P($G(^ICD9(RCXVP1,0)),U,1) 31 S RCXVDA=RCXVDA_RCXVU_RCXVP2 ; ASSOC DXN (1) 32 S RCXVP1=$P(RCXVD,U,7),RCXVP2="" 33 I RCXVP1'="" S RCXVP2=$P($G(^SC(RCXVP1,0)),U,1) 34 S RCXVDA=RCXVDA_RCXVU_RCXVP2 ; ASSC. CLNC (P) 35 S RCXVP1=$P(RCXVD,U,18),(RCXVP2,RCXVPS,RCXVPSER,RCXVNPI)="" 36 I RCXVP1'="" S RCXVP2=$$GET1^DIQ(200,RCXVP1_",",.01,"E"),RCXVNPI=$P($$NPI^XUSNPI("Individual_ID",RCXVP1),RCXVU,1) S:+RCXVNPI<1 RCXVNPI="" D 37 . S RCXVPS=$$GET^XUA4A72(RCXVP1,RCXVDT) 38 . S RCXVPS=$P(RCXVPS,U,3) 39 . S RCXVPSER=$$GET1^DIQ(200,RCXVP1_",",29,"E") 40 . Q 41 ;provider^provider npi^specialty^service/section 42 S RCXVDA=RCXVDA_RCXVU_RCXVP2_RCXVU_RCXVNPI_RCXVU_RCXVPS_RCXVU_RCXVPSER 43 S ^TMP($J,RCXVBLN,"4-399A",RCXVPC)=RCXVDA 44 ; LOOP THRU CPT 45 S RCXVCP=0,RCXVMULT=0 46 F S RCXVCP=$O(^DGCR(399,RCXVD0,"CP",RCXVPC,"MOD",RCXVCP)) Q:'RCXVCP D 47 . Q:'($D(^DGCR(399,RCXVD0,"CP",RCXVPC,"MOD",RCXVCP,0))) 48 . ; ^DGCR(399,D0,CP,D1,MOD,D2,0)= (#.01) CPT MODIFIER SEQUENCE [1N] 49 . ; (#.02) CPT ==>MODIFIER [2P:81.3] 50 . S RCXVP1=$P($G(^DGCR(399,RCXVD0,"CP",RCXVPC,"MOD",RCXVCP,0)),U,2) 51 . Q:RCXVP1="" 52 . S RCXVMULT=RCXVMULT+1 53 . S RCXVP2=$P($G(^DIC(81.3,RCXVP1,0)),U,1) 54 . S ^TMP($J,RCXVBLN,"4-399A",RCXVPC,RCXVMULT)=RCXVP2 55 . Q 56 D39942 ; CHARGES FROM 399.042 57 ; LOOP THRU 399.042 58 N X 59 S RCXVD1=$G(^DGCR(399,RCXVD0,"RC",RCXVPC,0)) 60 I RCXVD1="" Q 61 S X=$P(RCXVD1,U) 62 S RCXVDB=RCXVBLNA_RCXVU_$$GET1^DIQ(399.2,X_",",.01,"E") ; Revenue Code 63 S X=$P(RCXVD1,U,6) 64 S RCXVDB=RCXVDB_RCXVU_$$GET1^DIQ(81,X_",",.01,"E") ; Procedures [P] 65 S RCXVDB=RCXVDB_RCXVU_RCXVPCDT ; PROC. DT 66 S RCXVDB=RCXVDB_RCXVU_$P(RCXVD1,U,2) ; Charges 67 S ^TMP($J,RCXVBLN,"4-399B",RCXVPC)=RCXVDB 68 Q 69 ;
Note:
See TracChangeset
for help on using the changeset viewer.
