BLREXECU ;IHS/ITSC/TPF - IHS EXECUTE CODES ; 22-Oct-2013 09:22 ; MKK
;;5.2;LR;**1016,1017,1018,1022,1033**;NOV 01, 1997
;;
GETDNAM(NAME) ;
S DNAME=$O(^DD(63.04,"B",NAME,0))
Q:DNAME="" "NULL"
Q DNAME
;
; ----- BEGIN IHS/MSC/MKK - LR*5.2*1033
GETDNAMT(NAME) ; EP - Get DataName from File 60 Test
NEW F60IEN
S F60IEN=+$$FIND1^DIC(60,,,NAME)
Q:F60IEN<1 "NULL"
;
S DNAME=+$$GET1^DIQ(60,F60IEN_",",400,"I")
;
Q $S(DNAME:DNAME,1:"NULL")
; ----- END IHS/MSC/MKK - LR*5.2*1033
;
;GET RACE OF PATIENT; DEFINED AS BLACK OR NON-BLACK PER DR. NARVA'S
;APPLICATION OF THE GFR CALCULATION
RACE(DFN) ;
S RACEPTR=$P($G(^DPT(DFN,0)),U,6)
Q:RACEPTR="" "N" ;IF NO ENTRY CONSIDER NON-BLACK PER DR. NARVA
S RACEENT=$P($G(^DIC(10,RACEPTR,0)),U)
Q:RACEENT[("BLACK") "B" ;IF NAME FIELD CONTAINS BLACK RACE= BLACK
Q "N" ;OTHERWISE NON-BLACK
GFRDEL(CRET) ;
;NOW THAT WE HAVE A CREATININE RESULT CHECK VARIABLES NEEDED FOR GFR
;CALCULATION
Q:$G(CRET)="" ""
N BLRERR
S BLRERR="N/A"
;FOLLOWING LINE ADDED TO HANDLE CANCELS ETC IHS/ITSC/TPF 7/1/03 **1017*
I $G(CRET)?1A.A S %X=BLRERR Q %X
;FOLLOWING LINE ADDED TO HANDLE ERRORS SENT BY SOME INSTRUMENTS
;FOR INSTANCE "#########" AS OUT OF RANGE
I $E($G(CRET))="#" S %X=BLRERR Q %X
I $E($G(CRET))="<" S %X=BLRERR Q %X ;IHS/ITSC/TPF 02/23/2004 ADDED FOR VTROS RESULTS WITH "<" AND "<" INCLUDED
I $E($G(CRET))="-" S %X=BLRERR Q %X ;IHS/ITSC/MKK 11/18/2004 ADDED FOR NEGATIVE RESULTS
I +$G(CRET)=0 S %X=BLRERR Q %X ;IHS/ITSC/MKK 11/18/2004 ADDED FOR ZERO RESULTS
I AGE["DYS"!(AGE["MOS") S %X=BLRERR Q %X
I AGE<17 S %X=BLRERR Q %X ;16 AND YOUNGER NOT DONE
I SEX="" S %X=BLRERR Q %X ;CANNOT CALCULATE WITHOUT SEX
;
;CONSTANTS, EXPONENTS
S SEXFACTR=$S(SEX="M":1,1:.742) ;SEX FACTOR
;
; S RACEFACT=$S($$RACE(DFN)="B":1.21,1:1) ;RACE FACTOR
; ----- BEGIN IHS/OIT/MKK - Modifications -- 1022
; NOTE: the DFN is the Patient Pointer from the ^LR global
;
; If DFN is NOT null, then calculate Race Factor
I $G(DFN)'="" S RACEFACT=$S($$RACE(DFN)="B":1.21,1:1) ;RACE FACTOR
;
; If DFN IS null, try to set temporary variable to Patient Pointer
; using LRDFN. If it can be set, then use that to caculate the
; Race Factor.
NEW TMPVAR
I $G(DFN)="" D
. I $G(LRDFN)'="" S TMPVAR=$P($G(^LR(LRDFN,0)),"^",3)
. I $G(TMPVAR)'="" S RACEFACT=$S($$RACE(TMPVAR)="B":1.21,1:1) ;RACE FACTOR
;
; If RACEFACT still not set, default is Non-Black, per Dr. Narva
I $G(RACEFACT)="" S RACEFACT=1
; ----- END IHS/OIT/MKK - Modifications -- 1022
;
S CONSTA=186 ;CONSTANT A
S CRETEXP=-1.154 ;CREATININE EXPONENT
S AGEEXP=-.203 ;AGE EXPONENT
;
;
;FORMULA BELOW IS ON PAGE 10 OF WEB PAGE
;HTTP://WWW.KIDNEY.ORG/PROFESSIONALS/DOQI/KDOQI/P5_LAB_G4.HTM
;AND IS REFERENCED BY DR. NARVA IN HIS CORRSPONDENCE
S %X=CONSTA*(CRET**CRETEXP)*(AGE**AGEEXP)*$G(SEXFACTR)*$G(RACEFACT)
;
S %X=$TR($FN(%X,"",0)," ") ;ROUND RESULT
;
; ----- BEGIN IHS/OIT/MKK - Modifications -- 1022
; Change requested by Lab PSG
; See www.nkdep.nih.gov/resources/laboratory_reporting.htm
I %X>60 S %X=">60"
; ----- END IHS/OIT/MKK - Modifications -- 1022
;
Q %X
BLREXECU ;IHS/ITSC/TPF - IHS EXECUTE CODES ; 22-Oct-2013 09:22 ; MKK
+1 ;;5.2;LR;**1016,1017,1018,1022,1033**;NOV 01, 1997
+2 ;;
GETDNAM(NAME) ;
+1 SET DNAME=$ORDER(^DD(63.04,"B",NAME,0))
+2 IF DNAME=""
QUIT "NULL"
+3 QUIT DNAME
+4 ;
+5 ; ----- BEGIN IHS/MSC/MKK - LR*5.2*1033
GETDNAMT(NAME) ; EP - Get DataName from File 60 Test
+1 NEW F60IEN
+2 SET F60IEN=+$$FIND1^DIC(60,,,NAME)
+3 IF F60IEN<1
QUIT "NULL"
+4 ;
+5 SET DNAME=+$$GET1^DIQ(60,F60IEN_",",400,"I")
+6 ;
+7 QUIT $SELECT(DNAME:DNAME,1:"NULL")
+8 ; ----- END IHS/MSC/MKK - LR*5.2*1033
+9 ;
+10 ;GET RACE OF PATIENT; DEFINED AS BLACK OR NON-BLACK PER DR. NARVA'S
+11 ;APPLICATION OF THE GFR CALCULATION
RACE(DFN) ;
+1 SET RACEPTR=$PIECE($GET(^DPT(DFN,0)),U,6)
+2 ;IF NO ENTRY CONSIDER NON-BLACK PER DR. NARVA
IF RACEPTR=""
QUIT "N"
+3 SET RACEENT=$PIECE($GET(^DIC(10,RACEPTR,0)),U)
+4 ;IF NAME FIELD CONTAINS BLACK RACE= BLACK
IF RACEENT[("BLACK")
QUIT "B"
+5 ;OTHERWISE NON-BLACK
QUIT "N"
GFRDEL(CRET) ;
+1 ;NOW THAT WE HAVE A CREATININE RESULT CHECK VARIABLES NEEDED FOR GFR
+2 ;CALCULATION
+3 IF $GET(CRET)=""
QUIT ""
+4 NEW BLRERR
+5 SET BLRERR="N/A"
+6 ;FOLLOWING LINE ADDED TO HANDLE CANCELS ETC IHS/ITSC/TPF 7/1/03 **1017*
+7 IF $GET(CRET)?1A.A
SET %X=BLRERR
QUIT %X
+8 ;FOLLOWING LINE ADDED TO HANDLE ERRORS SENT BY SOME INSTRUMENTS
+9 ;FOR INSTANCE "#########" AS OUT OF RANGE
+10 IF $EXTRACT($GET(CRET))="#"
SET %X=BLRERR
QUIT %X
+11 ;IHS/ITSC/TPF 02/23/2004 ADDED FOR VTROS RESULTS WITH "<" AND "<" INCLUDED
IF $EXTRACT($GET(CRET))="<"
SET %X=BLRERR
QUIT %X
+12 ;IHS/ITSC/MKK 11/18/2004 ADDED FOR NEGATIVE RESULTS
IF $EXTRACT($GET(CRET))="-"
SET %X=BLRERR
QUIT %X
+13 ;IHS/ITSC/MKK 11/18/2004 ADDED FOR ZERO RESULTS
IF +$GET(CRET)=0
SET %X=BLRERR
QUIT %X
+14 IF AGE["DYS"!(AGE["MOS")
SET %X=BLRERR
QUIT %X
+15 ;16 AND YOUNGER NOT DONE
IF AGE<17
SET %X=BLRERR
QUIT %X
+16 ;CANNOT CALCULATE WITHOUT SEX
IF SEX=""
SET %X=BLRERR
QUIT %X
+17 ;
+18 ;CONSTANTS, EXPONENTS
+19 ;SEX FACTOR
SET SEXFACTR=$SELECT(SEX="M":1,1:.742)
+20 ;
+21 ; S RACEFACT=$S($$RACE(DFN)="B":1.21,1:1) ;RACE FACTOR
+22 ; ----- BEGIN IHS/OIT/MKK - Modifications -- 1022
+23 ; NOTE: the DFN is the Patient Pointer from the ^LR global
+24 ;
+25 ; If DFN is NOT null, then calculate Race Factor
+26 ;RACE FACTOR
IF $GET(DFN)'=""
SET RACEFACT=$SELECT($$RACE(DFN)="B":1.21,1:1)
+27 ;
+28 ; If DFN IS null, try to set temporary variable to Patient Pointer
+29 ; using LRDFN. If it can be set, then use that to caculate the
+30 ; Race Factor.
+31 NEW TMPVAR
+32 IF $GET(DFN)=""
Begin DoDot:1
+33 IF $GET(LRDFN)'=""
SET TMPVAR=$PIECE($GET(^LR(LRDFN,0)),"^",3)
+34 ;RACE FACTOR
IF $GET(TMPVAR)'=""
SET RACEFACT=$SELECT($$RACE(TMPVAR)="B":1.21,1:1)
End DoDot:1
+35 ;
+36 ; If RACEFACT still not set, default is Non-Black, per Dr. Narva
+37 IF $GET(RACEFACT)=""
SET RACEFACT=1
+38 ; ----- END IHS/OIT/MKK - Modifications -- 1022
+39 ;
+40 ;CONSTANT A
SET CONSTA=186
+41 ;CREATININE EXPONENT
SET CRETEXP=-1.154
+42 ;AGE EXPONENT
SET AGEEXP=-.203
+43 ;
+44 ;
+45 ;FORMULA BELOW IS ON PAGE 10 OF WEB PAGE
+46 ;HTTP://WWW.KIDNEY.ORG/PROFESSIONALS/DOQI/KDOQI/P5_LAB_G4.HTM
+47 ;AND IS REFERENCED BY DR. NARVA IN HIS CORRSPONDENCE
+48 SET %X=CONSTA*(CRET**CRETEXP)*(AGE**AGEEXP)*$GET(SEXFACTR)*$GET(RACEFACT)
+49 ;
+50 ;ROUND RESULT
SET %X=$TRANSLATE($FNUMBER(%X,"",0)," ")
+51 ;
+52 ; ----- BEGIN IHS/OIT/MKK - Modifications -- 1022
+53 ; Change requested by Lab PSG
+54 ; See www.nkdep.nih.gov/resources/laboratory_reporting.htm
+55 IF %X>60
SET %X=">60"
+56 ; ----- END IHS/OIT/MKK - Modifications -- 1022
+57 ;
+58 QUIT %X
