source: WorldVistAEHR/trunk/r/ACCOUNTS_RECEIVABLE-PRCA-PRY-RC/RCXVDC4.m@ 789

Last change on this file since 789 was 623, checked in by George Lilly, 15 years ago

revised back to 6/30/08 version

File size: 2.8 KB
Line 
1RCXVDC4 ;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
7D399PC ;
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
16D399PCA ;
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
56D39942 ; 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 TracBrowser for help on using the repository browser.