source: FOIAVistA/trunk/r/LAB_SERVICE-LR-LS/LREGFR2.m@ 1336

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

initial load of FOIAVistA 6/30/08 version

File size: 4.1 KB
Line 
1LREGFR2 ;DALOI/SDV/AH/GDU Calculate Creatinine-eGFR ;Feb 2, 2004
2 ;;5.2;LAB SERVICES;**377**;Sep 27, 1994;Build 4
3 ;
4 ; Reference to EN^DDIOL supported by IA #10142
5 ; Reference to $$GET1^DIQ supported by IA #2056
6 ; Reference to DEM^VADPT supported by IA # 10061
7 ;
8 ; This routine is a delta check for the lab test eGFR called by delta
9 ; check CREATININE-EGFR. The eGFR test is calculated.
10 ;
11 ; Provided Data
12 ; DOB - Patient's date of birth
13 ; LRDFN - entry in LAB DATA file
14 ; LRIDT - inverse date/time of entry in LAB DATA file
15 ; LRNG - variable containing normals/units and delta check
16 ; LRSB - dataname for creatinine result
17 ;
18STRT(DFN,LRTR) ; Start Processing the Routine
19 ; Call with DFN = parent file ien
20 ; LRTR = serum creatinine value as mg/dl
21 ;
22 ; Do not calculate eGFR if called from group data review.
23 I $D(LRGVP) Q
24 ;
25 N AGE,LRTN,LRDC,LRRC,LRX,LRY,SEX,X,Y
26 ;
27 ; Determine test to store eFGR
28 S LRDC=$P(LRNG,"^",8),LRY=""
29 S LRX=$$GET1^DIQ(62.1,LRDC_",",61.1,"I")
30 I LRX S LRY=$$GET1^DIQ(60,LRX_",",5,"I")
31 S LRTN=$P(LRY,";",2)
32 I LRTN="" D Q
33 . D FILECOM^LRVR4(LRDFN,LRIDT,"For eGFR: **eGFR not Calculated - Delta check not configured**")
34 ;
35 ; Quit if creatinine unchanged and eGFR already calculated and not 'pending'.
36 I $P($G(LRSB(LRSB)),"^")=LRTR,$P($G(LRSB(LRTN)),"^")'="",$P(LRSB(LRTN),"^")'="pending" Q
37 ;
38 ; Check for eGFR dataname in test editing profile.
39 ; If creatinine changed and eGFR previously calculated then warn.
40 I '$D(^TMP("LR",$J,"TMP",LRTN)) D Q
41 . I $P($G(LRSB(LRSB)),"^")=LRTR Q
42 . I $P($G(^LR(LRDFN,"CH",LRIDT,LRTN)),"^")'="" D FILECOM^LRVR4(LRDFN,LRIDT,"For eGFR: **eGFR not in test editing profile - Creatinine Changed**")
43 ;
44 ; Calculate age based on specimen date/time
45 S AGE=""
46 I LRCDT,DOB S AGE=($$FMDIFF^XLFDT(LRCDT,DOB,1))\365.25
47 I 'AGE D Q
48 . S $P(LRSB(LRTN),"^")="canc"
49 . D FILECOM^LRVR4(LRDFN,LRIDT,"For eGFR: **eGFR not Calculated - No Age Recorded**")
50 ;
51 S SEX=""
52 I LRDPF=2 S SEX=$P(VADM(5),U)
53 I LRDPF=67 S SEX=$$GET1^DIQ(67,DFN_",",.02,"I")
54 I SEX=""!("MF"'[SEX) D Q
55 . S $P(LRSB(LRTN),"^")="canc"
56 . D FILECOM^LRVR4(LRDFN,LRIDT,"For eGFR: **eGFR not Calculated - No Sex Recorded**")
57 ;
58 ; Determine race
59 S LRRC=$$RACE(DFN)
60 ;
61 ; Compute eGFR return-value
62 ; Set user(DUZ) and site(DUZ(2) in case delta check calculated during
63 ; entry of reference lab results.
64 I LRTR D
65 . N LREGFR,LRX,PRMT
66 . S LREGFR=175*(LRTR**-1.154)*(AGE**-.203) ; Using a constant of 175. This is to support the updated creatinine methodology
67 . I SEX="F" S LREGFR=LREGFR*.742
68 . I LRRC=1 S LREGFR=LREGFR*1.21
69 . I 'LREGFR Q
70 . S LRX=+$$GET1^DID(63.04,LRTN,"","DECIMAL DEFAULT")
71 . S $P(LRSB(LRTN),"^")=$FN(LREGFR,"",LRX)
72 . S $P(LRSB(LRTN),"^",4)=$G(DUZ),$P(LRSB(LRTN),"^",9)=$G(DUZ(2))
73 . I LRRC="U" D FILECOM^LRVR4(LRDFN,LRIDT,"For eGFR: Race unknown, if African American multiply result by 1.210")
74 Q
75 ;
76 ;
77RACE(DFN) ; Get Race
78 ; Call with DFN = ien of PATIENT file (#2)
79 ; Returns XRC = 1 (African American)
80 ; 0 (non African American)
81 ; U (unknown)
82 ;
83 N XA,XB,XC,XD,XE,XRC
84 S XA="BLACK",XB="AFRICAN",XC="HISPANIC,",XD="UNKNOWN",XE="DECLINED"
85 S XRC=""
86 ;
87 ; If patient from PATIENT file (#2).
88 I LRDPF=2 D
89 . N VADM
90 . D DEM^VADPT
91 . S XRC=$P($G(VADM(12,1)),U,2)
92 . S:XRC="" XRC=$P($G(VADM(8)),U,2)
93 ;
94 ; If patient from REFERRAL file (#67).
95 I LRDPF=67 D
96 . S XRC=$$GET1^DIQ(67,DFN_",",.06)
97 ;
98 ; If race not defined then set to unknown.
99 I XRC="" S XRC="U"
100 ;
101 ; If race contains "BLACK" or "AFRICAN" but not HISPANIC then return "1"
102 I XRC[XA!(XRC[XB) I XRC'[XC S XRC=1
103 ;
104 ; If unknown or declined then return "U"
105 I XRC[XD!(XRC[XE) S XRC="U"
106 ; If not unknown or African-American then return "0"
107 I XRC'=1,XRC'="U" S XRC=0
108 Q XRC
109 ;
110 ;*************************************************************
111 ;LR(E)stimated(G)lomerular(F)iltration(R)ate: LREGFR
112 ;LR(T)est(N)ame: LRTN
113 ; (R)esults: LRTR
114 ;LR(R)ace: LRRC
115 ;
116 ;*************************************************************
117 ;* end of routine *
118 ;*************************************************************
Note: See TracBrowser for help on using the repository browser.