BDMDB18 ; IHS/CMI/LAB - 2014 DIABETES AUDIT ;
;;2.0;DIABETES MANAGEMENT SYSTEM;**7,8**;JUN 14, 2007;Build 53
;
;cmi/anch/maw 9/12/2007 code set versioning in WT
;
HT(P,BDATE,EDATE) ;EP
I 'P Q ""
NEW %,BDMARRY,H,E,D,W
S E=$O(^AUTTMSR("B","HT",0))
S H=""
S D=0 F S D=$O(^AUPNVMSR("AA",P,E,D)) Q:D'=+D!(H]"") D
.S W=0 F S W=$O(^AUPNVMSR("AA",P,E,D,W)) Q:W'=+W!(H]"") D
..Q:'$D(^AUPNVMSR(W,0))
..Q:$P($G(^AUPNVMSR(W,2)),U,1) ;entered in error
..S H=$P(^AUPNVMSR(W,0),U,4)
..S BDMARRAY(1)=$$VD^APCLV($P(^AUPNVMSR(W,0),U,3))
I H="" Q H
I H["?" Q ""
S H=$J(H,5,2)
Q H
WT(P,BDATE,EDATE) ;EP
I 'P Q ""
NEW %,E,BDMW,X,BDMN,BDM,BDMD,BDMZ,BDMX,ICD,BDMVF
K BDM S BDMW="" S BDMX=P_"^LAST 24 MEAS WT;DURING "_BDATE_"-"_EDATE S E=$$START1^APCLDF(BDMX,"BDM(")
S BDMN=0 F S BDMN=$O(BDM(BDMN)) Q:BDMN'=+BDMN!(BDMW]"") D
.S BDMVF=+$P(BDM(BDMN),U,4)
.Q:$P($G(^AUPNVMSR(BDMVF,2)),U,1) ;entered in error
.S BDMZ=$P(BDM(BDMN),U,5)
.I '$D(^AUPNVPOV("AD",BDMZ)) S BDMW=$P(BDM(BDMN),U,2) Q
.S BDMD=0,G=0 F S BDMD=$O(^AUPNVPOV("AD",BDMZ,BDMD)) Q:'BDMD!(G=1) D
..S ICD=$$VALI^XBDIQ1(9000010.07,BDMD,.01) D ;cmi/anch/maw 9/12/2007 csv
...I $$ICD^BDMUTL(ICD,"BGP PREGNANCY DIAGNOSES 2",9) S G=1 ;cmi/maw 05/15/2014 p8
.I 'G S BDMW=$P(BDM(BDMN),U,2)
Q BDMW
BMI(P,BDATE,EDATE) ;EP
I 'P Q ""
NEW %,W,H,B,D,%DT,X
S %=""
D Q %
.S W=$$WT(P,BDATE,EDATE) Q:W="" S W=W+.5,W=$P(W,".")
.S HDATE=$P(^DPT(P,0),U,3)
.S H=$$HT(P,HDATE,EDATE) I H="" Q
.S W=W*.45359,H=(H*.0254),H=(H*H),%=(W/H),%=$J(%,4,1)
.Q
Q
CREAT(P,BDATE,EDATE,F) ;EP
G CREAT^BDMDB1C
CHOL(P,BDATE,EDATE,F) ;EP
G CHOL^BDMDB1C
HDL(P,BDATE,EDATE,F) ;EP
G HDL^BDMDB1C
LDL(P,BDATE,EDATE,F) ;EP
G LDL^BDMDB1C
TRIG(P,BDATE,EDATE,F) ;EP
G TRIG^BDMDB1C
URIN(P,BDATE,EDATE) ;EP
G URIN^BDMDB1H
PROTEIN(P,BDATE,EDATE) ;EP
G PROTEIN^BDMDB1C
MICRO(P,BDATE,EDATE) ;EP
G MICRO^BDMDB1C
HGBA1C(P,BDATE,EDATE) ;EP
G HGBA1C^BDMDB1D
SEMI(P,BDATE,EDATE) ;EP
G SEMI^BDMDB1C
PPDS(P) ;
NEW BDMS,E,X
K BDMS
S X=P_"^LAST HEALTH [DM AUDIT TB HEALTH FACTORS" S E=$$START1^APCLDF(X,"BDMS(")
I $D(BDMS) Q 1_U_$$FMTE^XLFDT($P(BDMS(1),U))_" HF: "_$P(BDMS(1),U,3)
PPDSPL ;CHECK PL
N T S T=$O(^ATXAX("B","SURVEILLANCE TUBERCULOSIS",0))
I 'T Q ""
;N X,Y,I S (X,Y,I)=0 F S X=$O(^AUPNPROB("AC",P,X)) Q:X'=+X!(I) I $D(^AUPNPROB(X,0)) S Y=$P(^AUPNPROB(X,0),U) I $$ICD^ATXCHK(Y,T,9) S I=X
N X,Y,I S (X,Y,I)=0 F S X=$O(^AUPNPROB("AC",P,X)) Q:X'=+X!(I) I $D(^AUPNPROB(X,0)) S Y=$P(^AUPNPROB(X,0),U) I $$ICD^BDMUTL(Y,$P(^ATXAX(T,0),U),9) S I=X ;cmi/maw 05/15/2014 p8
I I Q 1_U_$$VAL^XBDIQ1(9000011,I,.03)_" Problem List: "_$$VAL^XBDIQ1(9000011,I,.01)
;check povs
K BDMS S X=P_"^FIRST DX [SURVEILLANCE TUBERCULOSIS" S E=$$START1^APCLDF(X,"BDMS(")
I $D(BDMS(1)) Q 1_U_$$FMTE^XLFDT($P(BDMS(1),U))_" POV: "_$P(BDMS(1),U,3)
Q ""
PPD(P,EDATE,F) ;EP
;f 1=tb test done
;f 2=tb result
S F=$G(F)
;RETURN 1^1 Skin Test||1 Positive
NEW BDM,X,E,G,BDATE,Y,%DT,D,R,R1,R2,ED,LD,LR
S LD="",LR=""
S X=EDATE,%DT="P" D ^%DT S ED=Y
S G=$$PPDS(P) I G Q "1 TB Positive "_$P(G,U,2)_"||1 Positive TB "_$P(G,U,2) ;IF HAD HF or dx or pl of TB use it as positive
K BDM
;get, in reverse order all skin tests and lab tests for TB testing (BDM(inverse date,#)=ST or LAB^ien^result^reading
S X=$O(^AUTTSK("B","PPD",0))
S D=9999999-ED-1,C=0 F S D=$O(^AUPNVSK("AA",P,X,D)) Q:D="" D
.S G=0 F S G=$O(^AUPNVSK("AA",P,X,D,G)) Q:G'=+G D
..Q:'$D(^AUPNVSK(G,0))
..S C=C+1 S BDM(D,C)="ST"_U_G_U_$P(^AUPNVSK(G,0),U,5)_U_$S($P(^AUPNVSK(G,0),U,4)="D":"",$P(^AUPNVSK(G,0),U,4)="O":"",1:$P(^AUPNVSK(G,0),U,4))
S BDMC=0
S BDMLT=$O(^ATXLAB("B","DM AUDIT TB LAB TESTS",0))
S BDMOT=$O(^ATXAX("B","DM AUDIT TB TEST LOINC",0))
S G="",E=9999999-ED S D=E-1 F S D=$O(^AUPNVLAB("AE",P,D)) Q:D'=+D!(G) D
.S L=0 F S L=$O(^AUPNVLAB("AE",P,D,L)) Q:L'=+L D
..S X=0 F S X=$O(^AUPNVLAB("AE",P,D,L,X)) Q:X'=+X D
...Q:'$D(^AUPNVLAB(X,0))
...Q:$P(^AUPNVLAB(X,0),U,4)=""
...Q:$$UP^XLFSTR($P(^AUPNVLAB(X,0),U,4))["CANC"
...I BDMLT,$P(^AUPNVLAB(X,0),U),$D(^ATXLAB(BDMLT,21,"B",$P(^AUPNVLAB(X,0),U))) D
....S C=C+1,BDM(D,C)="LAB^"_X_U_$P(^AUPNVLAB(X,0),U,4),G=1
...Q:'BDMOT
...S J=$P($G(^AUPNVLAB(X,11)),U,13) Q:J=""
...Q:'$$LOINC^BDMDB1C(J,BDMOT)
...S C=C+1,BDM(D,C)="LAB^"_X_U_$P(^AUPNVLAB(X,0),U,4),G=1
...Q
;now get latest with a result and use it, if none with a result take latest one
;if none, quit on value
S (D,C)=0,G=""
F S D=$O(BDM(D)) Q:D'=+D!(G]"") D
.S C=0 F S C=$O(BDM(D,C)) Q:C'=+C!(G]"") D
..I $P(BDM(D,C),U,3)]""!($P(BDM(D,C),U,4)]"") S G=BDM(D,C)
I F="I" Q $S($P(G,U,1)="LAB":$$VD^APCLV($P(^AUPNVLAB($P(G,U,2),0),U,3)),1:$$VD^APCLV($P(^AUPNVSK($P(G,U,2),0),U,3)))
I G]"" S C="" D Q C ;C=1 skin test||result value
.S C=$S($P(G,U,1)="ST":"1 Skin test (PPD)",1:"2 Blood Test (QFT-G, T SPOT-TB)")
.;GET RESULT VALUE
.I $P(G,U,1)="LAB" S R=$P(G,U,3) D Q
..I $E($$UP^XLFSTR(R))="P" S C=C_"||1 Positive "_$$VD^APCLV($P(^AUPNVLAB($P(G,U,2),0),U,3),"S")_" lab result: "_R Q
..I $E($$UP^XLFSTR(R))="N" S C=C_"||2 Negative "_$$VD^APCLV($P(^AUPNVLAB($P(G,U,2),0),U,3),"S")_" lab result: "_R Q
..S C=C_"||3 Unknown" Q
.I $P(G,U,1)="ST" D Q
..S R=$P(G,U,3),R1=$P(G,U,4)
..I R]"",R>9 S C=C_"||1 Positive "_$$VD^APCLV($P(^AUPNVSK($P(G,U,2),0),U,3),"S")_" Reading: "_R_" Result: "_R1 Q
..I R]"",R<10 S C=C_"||2 Negative "_$$VD^APCLV($P(^AUPNVSK($P(G,U,2),0),U,3),"S")_" Reading: "_R_" Result: "_R1 Q
..I R1]"",R1="P" S C=C_"||1 Positive "_$$VD^APCLV($P(^AUPNVSK($P(G,U,2),0),U,3),"S")_" Reading: "_R_" Result: "_R1 Q
..I R1]"",R1="N" S C=C_"||2 Negative "_$$VD^APCLV($P(^AUPNVSK($P(G,U,2),0),U,3),"S")_" Reading: "_R_" Result: "_R1 Q
Q "3 Unknown||"
;
LASTNP(P,EDATE) ;EP - last negative ppd
I $E($P($$PPD(P,EDATE),"||",2))'="2" Q ""
Q $$PPD(P,EDATE,"I")
;
FGLUCOSE(P,BDATE,EDATE,F) ;EP
G FGLUCOSE^BDMDB1D
G75(P,BDATE,EDATE,F) ;EP
G G75^BDMDB1D
;
STV(X,T,D) ;EP - strip hgba1c before epi export
I X="" Q X ;no value in X so don't bother
I X="?" Q ""
NEW A,B,L
S L=$L(X)
I $E(X)?1N S X=+X
F B=1:1:L S A=$E(X,B) Q:A="" I A'?1N,A'?1"." S X=$$STRIP^XLFSTR(X,A) S B=B-1
I X="" Q ""
I $G(D),X["." S X=$J(X,T,D)
S X=$$STRIP^XLFSTR(X," ")
Q $E(X,1,T)
STE(X,T,D) ;EP - strip hgba1c before epi export
I X="" Q X ;no value in X so don't bother
I X="?" Q ""
NEW A,B,L
S L=$L(X)
F B=1:1:L S A=$E(X,B) Q:A="" I A'?1N,A'?1".",X'?1"+",X'?1"-",X'?1">",X'?1"<" S X=$$STRIP^XLFSTR(X,A) S B=B-1
I X="" Q ""
I $G(D),X["." S X=$J(X,T,D)
S X=$$STRIP^XLFSTR(X," ")
Q $E(X,1,T)
AS(X) ;EP
I $E(X)="<" S X=$E(X,2,99),X=X-1 Q X
I $E(X)=">" S X=$E(X,2,99),X=X+1 Q X
Q X
;
CALCGFR(P,BDATE,EDATE) ;
NEW R,C,X,Y,Z,D
S R=$$CREAT^BDMDB18(P,BDATE,EDATE,"I"),D=$P(R,U,2),R=$P(R,U,1)
I R="" Q ""
;CALCULATE IT
S BDMSEX=$P(^DPT(P,0),U,2)
S BDMAGE=$$AGE^AUPNPAT(P,D)
S X=$$GFRSE1CU(P,R,BDMAGE,BDMSEX)
Q D_U_X_"^ESTIMATED GFR (CALC)"
GFRSE1CU(DFN,CRET,BDMAGE,BDMSEX) ; EP
;D:$G(SNAPSHOT) ENTRYAUD^BLRUTIL("GFRSE1CU^BLREXEC2")
;
S %X=$$CHKERRS ; Check for Errors
I %X'="OK" Q %X ; If NOT OK, quit with error
;
NEW CONSTA,CRETEXP,AGEEXP,SEXFACTR,RACEFACT
D SETVARS1 ; Setup constants & exponents
;
S %X=CONSTA*(CRET**CRETEXP)*(BDMAGE**AGEEXP)*$G(SEXFACTR)*$G(RACEFACT)
;
S %X=$TR($FN(%X,"",0)," ") ;ROUND RESULT
;
; See www.nkdep.nih.gov/resources/laboratory_reporting.htm
I %X>60 S %X=">60"
;
Q %X
;
CHKERRS() ; EP
N BDMERR
S BDMERR="N/A"
;
I $TR($G(CRET)," ")="" Q BDMERR ; If creatinine null, then quit
;
; If 1st character not numeric, then quit
; I $E($G(CRET))'?1N Q BDMERR
I $G(CRET)?1A.A S %X=BDMERR Q %X ; IHS/OIT/MKK - LR*5.2*1026
;
; Following lines added to handle errors sent by some instruments
; Quit if any are true
I $E($G(CRET))="" Q BDMERR ; If Null
I $E($G(CRET))="#" Q BDMERR ; Out of Range
I $E($G(CRET))="<" Q BDMERR ; Vitros results with "<"
I ($G(CRET))="-" Q BDMERR ; Negative results
;
I +$G(CRET)=0 Q BDMERR ; If zero results, then quit
;
;I AGE["DYS"!(AGE["MOS")!(AGE<17) Q BDMERR ; 16 & younger not done, quit
I BDMAGE<18 Q BDMERR
;
I BDMSEX="" Q BDMERR ; Cannot calculate without SEX
I BDMSEX="U" Q BDMERR
;
Q "OK"
;
SETVARS1 ; EP
;CONSTANTS, EXPONENTS
S SEXFACTR=$S(BDMSEX="M":1,1:.742) ; Sex Factor
;
S RACEFACT=$S($$RACE(DFN)="B":1.21,1:1)
;
S CONSTA=186 ; CONSTANT A
S CRETEXP=-1.154 ; CREATININE EXPONENT
S AGEEXP=-.203 ; AGE EXPONENT
;
;D:$G(SNAPSHOT) ENTRYAUD^BLRUTIL("SETVARS1^BLREXEC2")
Q
RACE(DFN) ; EP
NEW RACEPTR,RACEENT,V
;
I $T(RACE^AGUTL)]"" D Q V
.S V=""
.S RACEPTR=$$RACE^AGUTL(DFN)
.I $P(RACEPTR,U)=1,$P(RACEPTR,U,2)["BLACK" S V="B"
.S V="N"
S RACEPTR=$P($G(^DPT(+$G(DFN),0)),U,6)
Q:RACEPTR="" "N" ; If no entry, consider non-black
;
S RACEENT=$P($G(^DIC(10,RACEPTR,0)),U)
Q:RACEENT[("BLACK") "B" ; If RACEENT contains BLACK => race = Black
Q "N" ; otherwise, non-black
;
BDMDB18 ; IHS/CMI/LAB - 2014 DIABETES AUDIT ;
+1 ;;2.0;DIABETES MANAGEMENT SYSTEM;**7,8**;JUN 14, 2007;Build 53
+2 ;
+3 ;cmi/anch/maw 9/12/2007 code set versioning in WT
+4 ;
HT(P,BDATE,EDATE) ;EP
+1 IF 'P
QUIT ""
+2 NEW %,BDMARRY,H,E,D,W
+3 SET E=$ORDER(^AUTTMSR("B","HT",0))
+4 SET H=""
+5 SET D=0
FOR
SET D=$ORDER(^AUPNVMSR("AA",P,E,D))
IF D'=+D!(H]"")
QUIT
Begin DoDot:1
+6 SET W=0
FOR
SET W=$ORDER(^AUPNVMSR("AA",P,E,D,W))
IF W'=+W!(H]"")
QUIT
Begin DoDot:2
+7 IF '$DATA(^AUPNVMSR(W,0))
QUIT
+8 ;entered in error
IF $PIECE($GET(^AUPNVMSR(W,2)),U,1)
QUIT
+9 SET H=$PIECE(^AUPNVMSR(W,0),U,4)
+10 SET BDMARRAY(1)=$$VD^APCLV($PIECE(^AUPNVMSR(W,0),U,3))
End DoDot:2
End DoDot:1
+11 IF H=""
QUIT H
+12 IF H["?"
QUIT ""
+13 SET H=$JUSTIFY(H,5,2)
+14 QUIT H
WT(P,BDATE,EDATE) ;EP
+1 IF 'P
QUIT ""
+2 NEW %,E,BDMW,X,BDMN,BDM,BDMD,BDMZ,BDMX,ICD,BDMVF
+3 KILL BDM
SET BDMW=""
SET BDMX=P_"^LAST 24 MEAS WT;DURING "_BDATE_"-"_EDATE
SET E=$$START1^APCLDF(BDMX,"BDM(")
+4 SET BDMN=0
FOR
SET BDMN=$ORDER(BDM(BDMN))
IF BDMN'=+BDMN!(BDMW]"")
QUIT
Begin DoDot:1
+5 SET BDMVF=+$PIECE(BDM(BDMN),U,4)
+6 ;entered in error
IF $PIECE($GET(^AUPNVMSR(BDMVF,2)),U,1)
QUIT
+7 SET BDMZ=$PIECE(BDM(BDMN),U,5)
+8 IF '$DATA(^AUPNVPOV("AD",BDMZ))
SET BDMW=$PIECE(BDM(BDMN),U,2)
QUIT
+9 SET BDMD=0
SET G=0
FOR
SET BDMD=$ORDER(^AUPNVPOV("AD",BDMZ,BDMD))
IF 'BDMD!(G=1)
QUIT
Begin DoDot:2
+10 ;cmi/anch/maw 9/12/2007 csv
SET ICD=$$VALI^XBDIQ1(9000010.07,BDMD,.01)
Begin DoDot:3
+11 ;cmi/maw 05/15/2014 p8
IF $$ICD^BDMUTL(ICD,"BGP PREGNANCY DIAGNOSES 2",9)
SET G=1
End DoDot:3
End DoDot:2
+12 IF 'G
SET BDMW=$PIECE(BDM(BDMN),U,2)
End DoDot:1
+13 QUIT BDMW
BMI(P,BDATE,EDATE) ;EP
+1 IF 'P
QUIT ""
+2 NEW %,W,H,B,D,%DT,X
+3 SET %=""
+4 Begin DoDot:1
+5 SET W=$$WT(P,BDATE,EDATE)
IF W=""
QUIT
SET W=W+.5
SET W=$PIECE(W,".")
+6 SET HDATE=$PIECE(^DPT(P,0),U,3)
+7 SET H=$$HT(P,HDATE,EDATE)
IF H=""
QUIT
+8 SET W=W*.45359
SET H=(H*.0254)
SET H=(H*H)
SET %=(W/H)
SET %=$JUSTIFY(%,4,1)
+9 QUIT
End DoDot:1
QUIT %
+10 QUIT
CREAT(P,BDATE,EDATE,F) ;EP
+1 GOTO CREAT^BDMDB1C
CHOL(P,BDATE,EDATE,F) ;EP
+1 GOTO CHOL^BDMDB1C
HDL(P,BDATE,EDATE,F) ;EP
+1 GOTO HDL^BDMDB1C
LDL(P,BDATE,EDATE,F) ;EP
+1 GOTO LDL^BDMDB1C
TRIG(P,BDATE,EDATE,F) ;EP
+1 GOTO TRIG^BDMDB1C
URIN(P,BDATE,EDATE) ;EP
+1 GOTO URIN^BDMDB1H
PROTEIN(P,BDATE,EDATE) ;EP
+1 GOTO PROTEIN^BDMDB1C
MICRO(P,BDATE,EDATE) ;EP
+1 GOTO MICRO^BDMDB1C
HGBA1C(P,BDATE,EDATE) ;EP
+1 GOTO HGBA1C^BDMDB1D
SEMI(P,BDATE,EDATE) ;EP
+1 GOTO SEMI^BDMDB1C
PPDS(P) ;
+1 NEW BDMS,E,X
+2 KILL BDMS
+3 SET X=P_"^LAST HEALTH [DM AUDIT TB HEALTH FACTORS"
SET E=$$START1^APCLDF(X,"BDMS(")
+4 IF $DATA(BDMS)
QUIT 1_U_$$FMTE^XLFDT($PIECE(BDMS(1),U))_" HF: "_$PIECE(BDMS(1),U,3)
PPDSPL ;CHECK PL
+1 NEW T
SET T=$ORDER(^ATXAX("B","SURVEILLANCE TUBERCULOSIS",0))
+2 IF 'T
QUIT ""
+3 ;N X,Y,I S (X,Y,I)=0 F S X=$O(^AUPNPROB("AC",P,X)) Q:X'=+X!(I) I $D(^AUPNPROB(X,0)) S Y=$P(^AUPNPROB(X,0),U) I $$ICD^ATXCHK(Y,T,9) S I=X
+4 ;cmi/maw 05/15/2014 p8
NEW X,Y,I
SET (X,Y,I)=0
FOR
SET X=$ORDER(^AUPNPROB("AC",P,X))
IF X'=+X!(I)
QUIT
IF $DATA(^AUPNPROB(X,0))
SET Y=$PIECE(^AUPNPROB(X,0),U)
IF $$ICD^BDMUTL(Y,$PIECE(^ATXAX(T,0),U),9)
SET I=X
+5 IF I
QUIT 1_U_$$VAL^XBDIQ1(9000011,I,.03)_" Problem List: "_$$VAL^XBDIQ1(9000011,I,.01)
+6 ;check povs
+7 KILL BDMS
SET X=P_"^FIRST DX [SURVEILLANCE TUBERCULOSIS"
SET E=$$START1^APCLDF(X,"BDMS(")
+8 IF $DATA(BDMS(1))
QUIT 1_U_$$FMTE^XLFDT($PIECE(BDMS(1),U))_" POV: "_$PIECE(BDMS(1),U,3)
+9 QUIT ""
PPD(P,EDATE,F) ;EP
+1 ;f 1=tb test done
+2 ;f 2=tb result
+3 SET F=$GET(F)
+4 ;RETURN 1^1 Skin Test||1 Positive
+5 NEW BDM,X,E,G,BDATE,Y,%DT,D,R,R1,R2,ED,LD,LR
+6 SET LD=""
SET LR=""
+7 SET X=EDATE
SET %DT="P"
DO ^%DT
SET ED=Y
+8 ;IF HAD HF or dx or pl of TB use it as positive
SET G=$$PPDS(P)
IF G
QUIT "1 TB Positive "_$PIECE(G,U,2)_"||1 Positive TB "_$PIECE(G,U,2)
+9 KILL BDM
+10 ;get, in reverse order all skin tests and lab tests for TB testing (BDM(inverse date,#)=ST or LAB^ien^result^reading
+11 SET X=$ORDER(^AUTTSK("B","PPD",0))
+12 SET D=9999999-ED-1
SET C=0
FOR
SET D=$ORDER(^AUPNVSK("AA",P,X,D))
IF D=""
QUIT
Begin DoDot:1
+13 SET G=0
FOR
SET G=$ORDER(^AUPNVSK("AA",P,X,D,G))
IF G'=+G
QUIT
Begin DoDot:2
+14 IF '$DATA(^AUPNVSK(G,0))
QUIT
+15 SET C=C+1
SET BDM(D,C)="ST"_U_G_U_$PIECE(^AUPNVSK(G,0),U,5)_U_$SELECT($PIECE(^AUPNVSK(G,0),U,4)="D":"",$PIECE(^AUPNVSK(G,0),U,4)="O":"",1:$PIECE(^AUPNVSK(G,0),U,4))
End DoDot:2
End DoDot:1
+16 SET BDMC=0
+17 SET BDMLT=$ORDER(^ATXLAB("B","DM AUDIT TB LAB TESTS",0))
+18 SET BDMOT=$ORDER(^ATXAX("B","DM AUDIT TB TEST LOINC",0))
+19 SET G=""
SET E=9999999-ED
SET D=E-1
FOR
SET D=$ORDER(^AUPNVLAB("AE",P,D))
IF D'=+D!(G)
QUIT
Begin DoDot:1
+20 SET L=0
FOR
SET L=$ORDER(^AUPNVLAB("AE",P,D,L))
IF L'=+L
QUIT
Begin DoDot:2
+21 SET X=0
FOR
SET X=$ORDER(^AUPNVLAB("AE",P,D,L,X))
IF X'=+X
QUIT
Begin DoDot:3
+22 IF '$DATA(^AUPNVLAB(X,0))
QUIT
+23 IF $PIECE(^AUPNVLAB(X,0),U,4)=""
QUIT
+24 IF $$UP^XLFSTR($PIECE(^AUPNVLAB(X,0),U,4))["CANC"
QUIT
+25 IF BDMLT
IF $PIECE(^AUPNVLAB(X,0),U)
IF $DATA(^ATXLAB(BDMLT,21,"B",$PIECE(^AUPNVLAB(X,0),U)))
Begin DoDot:4
+26 SET C=C+1
SET BDM(D,C)="LAB^"_X_U_$PIECE(^AUPNVLAB(X,0),U,4)
SET G=1
End DoDot:4
+27 IF 'BDMOT
QUIT
+28 SET J=$PIECE($GET(^AUPNVLAB(X,11)),U,13)
IF J=""
QUIT
+29 IF '$$LOINC^BDMDB1C(J,BDMOT)
QUIT
+30 SET C=C+1
SET BDM(D,C)="LAB^"_X_U_$PIECE(^AUPNVLAB(X,0),U,4)
SET G=1
+31 QUIT
End DoDot:3
End DoDot:2
End DoDot:1
+32 ;now get latest with a result and use it, if none with a result take latest one
+33 ;if none, quit on value
+34 SET (D,C)=0
SET G=""
+35 FOR
SET D=$ORDER(BDM(D))
IF D'=+D!(G]"")
QUIT
Begin DoDot:1
+36 SET C=0
FOR
SET C=$ORDER(BDM(D,C))
IF C'=+C!(G]"")
QUIT
Begin DoDot:2
+37 IF $PIECE(BDM(D,C),U,3)]""!($PIECE(BDM(D,C),U,4)]"")
SET G=BDM(D,C)
End DoDot:2
End DoDot:1
+38 IF F="I"
QUIT $SELECT($PIECE(G,U,1)="LAB":$$VD^APCLV($PIECE(^AUPNVLAB($PIECE(G,U,2),0),U,3)),1:$$VD^APCLV($PIECE(^AUPNVSK($PIECE(G,U,2),0),U,3)))
+39 ;C=1 skin test||result value
IF G]""
SET C=""
Begin DoDot:1
+40 SET C=$SELECT($PIECE(G,U,1)="ST":"1 Skin test (PPD)",1:"2 Blood Test (QFT-G, T SPOT-TB)")
+41 ;GET RESULT VALUE
+42 IF $PIECE(G,U,1)="LAB"
SET R=$PIECE(G,U,3)
Begin DoDot:2
+43 IF $EXTRACT($$UP^XLFSTR(R))="P"
SET C=C_"||1 Positive "_$$VD^APCLV($PIECE(^AUPNVLAB($PIECE(G,U,2),0),U,3),"S")_" lab result: "_R
QUIT
+44 IF $EXTRACT($$UP^XLFSTR(R))="N"
SET C=C_"||2 Negative "_$$VD^APCLV($PIECE(^AUPNVLAB($PIECE(G,U,2),0),U,3),"S")_" lab result: "_R
QUIT
+45 SET C=C_"||3 Unknown"
QUIT
End DoDot:2
QUIT
+46 IF $PIECE(G,U,1)="ST"
Begin DoDot:2
+47 SET R=$PIECE(G,U,3)
SET R1=$PIECE(G,U,4)
+48 IF R]""
IF R>9
SET C=C_"||1 Positive "_$$VD^APCLV($PIECE(^AUPNVSK($PIECE(G,U,2),0),U,3),"S")_" Reading: "_R_" Result: "_R1
QUIT
+49 IF R]""
IF R<10
SET C=C_"||2 Negative "_$$VD^APCLV($PIECE(^AUPNVSK($PIECE(G,U,2),0),U,3),"S")_" Reading: "_R_" Result: "_R1
QUIT
+50 IF R1]""
IF R1="P"
SET C=C_"||1 Positive "_$$VD^APCLV($PIECE(^AUPNVSK($PIECE(G,U,2),0),U,3),"S")_" Reading: "_R_" Result: "_R1
QUIT
+51 IF R1]""
IF R1="N"
SET C=C_"||2 Negative "_$$VD^APCLV($PIECE(^AUPNVSK($PIECE(G,U,2),0),U,3),"S")_" Reading: "_R_" Result: "_R1
QUIT
End DoDot:2
QUIT
End DoDot:1
QUIT C
+52 QUIT "3 Unknown||"
+53 ;
LASTNP(P,EDATE) ;EP - last negative ppd
+1 IF $EXTRACT($PIECE($$PPD(P,EDATE),"||",2))'="2"
QUIT ""
+2 QUIT $$PPD(P,EDATE,"I")
+3 ;
FGLUCOSE(P,BDATE,EDATE,F) ;EP
+1 GOTO FGLUCOSE^BDMDB1D
G75(P,BDATE,EDATE,F) ;EP
+1 GOTO G75^BDMDB1D
+2 ;
STV(X,T,D) ;EP - strip hgba1c before epi export
+1 ;no value in X so don't bother
IF X=""
QUIT X
+2 IF X="?"
QUIT ""
+3 NEW A,B,L
+4 SET L=$LENGTH(X)
+5 IF $EXTRACT(X)?1N
SET X=+X
+6 FOR B=1:1:L
SET A=$EXTRACT(X,B)
IF A=""
QUIT
IF A'?1N
IF A'?1"."
SET X=$$STRIP^XLFSTR(X,A)
SET B=B-1
+7 IF X=""
QUIT ""
+8 IF $GET(D)
IF X["."
SET X=$JUSTIFY(X,T,D)
+9 SET X=$$STRIP^XLFSTR(X," ")
+10 QUIT $EXTRACT(X,1,T)
STE(X,T,D) ;EP - strip hgba1c before epi export
+1 ;no value in X so don't bother
IF X=""
QUIT X
+2 IF X="?"
QUIT ""
+3 NEW A,B,L
+4 SET L=$LENGTH(X)
+5 FOR B=1:1:L
SET A=$EXTRACT(X,B)
IF A=""
QUIT
IF A'?1N
IF A'?1"."
IF X'?1"+"
IF X'?1"-"
IF X'?1">"
IF X'?1"<"
SET X=$$STRIP^XLFSTR(X,A)
SET B=B-1
+6 IF X=""
QUIT ""
+7 IF $GET(D)
IF X["."
SET X=$JUSTIFY(X,T,D)
+8 SET X=$$STRIP^XLFSTR(X," ")
+9 QUIT $EXTRACT(X,1,T)
AS(X) ;EP
+1 IF $EXTRACT(X)="<"
SET X=$EXTRACT(X,2,99)
SET X=X-1
QUIT X
+2 IF $EXTRACT(X)=">"
SET X=$EXTRACT(X,2,99)
SET X=X+1
QUIT X
+3 QUIT X
+4 ;
CALCGFR(P,BDATE,EDATE) ;
+1 NEW R,C,X,Y,Z,D
+2 SET R=$$CREAT^BDMDB18(P,BDATE,EDATE,"I")
SET D=$PIECE(R,U,2)
SET R=$PIECE(R,U,1)
+3 IF R=""
QUIT ""
+4 ;CALCULATE IT
+5 SET BDMSEX=$PIECE(^DPT(P,0),U,2)
+6 SET BDMAGE=$$AGE^AUPNPAT(P,D)
+7 SET X=$$GFRSE1CU(P,R,BDMAGE,BDMSEX)
+8 QUIT D_U_X_"^ESTIMATED GFR (CALC)"
GFRSE1CU(DFN,CRET,BDMAGE,BDMSEX) ; EP
+1 ;D:$G(SNAPSHOT) ENTRYAUD^BLRUTIL("GFRSE1CU^BLREXEC2")
+2 ;
+3 ; Check for Errors
SET %X=$$CHKERRS
+4 ; If NOT OK, quit with error
IF %X'="OK"
QUIT %X
+5 ;
+6 NEW CONSTA,CRETEXP,AGEEXP,SEXFACTR,RACEFACT
+7 ; Setup constants & exponents
DO SETVARS1
+8 ;
+9 SET %X=CONSTA*(CRET**CRETEXP)*(BDMAGE**AGEEXP)*$GET(SEXFACTR)*$GET(RACEFACT)
+10 ;
+11 ;ROUND RESULT
SET %X=$TRANSLATE($FNUMBER(%X,"",0)," ")
+12 ;
+13 ; See www.nkdep.nih.gov/resources/laboratory_reporting.htm
+14 IF %X>60
SET %X=">60"
+15 ;
+16 QUIT %X
+17 ;
CHKERRS() ; EP
+1 NEW BDMERR
+2 SET BDMERR="N/A"
+3 ;
+4 ; If creatinine null, then quit
IF $TRANSLATE($GET(CRET)," ")=""
QUIT BDMERR
+5 ;
+6 ; If 1st character not numeric, then quit
+7 ; I $E($G(CRET))'?1N Q BDMERR
+8 ; IHS/OIT/MKK - LR*5.2*1026
IF $GET(CRET)?1A.A
SET %X=BDMERR
QUIT %X
+9 ;
+10 ; Following lines added to handle errors sent by some instruments
+11 ; Quit if any are true
+12 ; If Null
IF $EXTRACT($GET(CRET))=""
QUIT BDMERR
+13 ; Out of Range
IF $EXTRACT($GET(CRET))="#"
QUIT BDMERR
+14 ; Vitros results with "<"
IF $EXTRACT($GET(CRET))="<"
QUIT BDMERR
+15 ; Negative results
IF ($GET(CRET))="-"
QUIT BDMERR
+16 ;
+17 ; If zero results, then quit
IF +$GET(CRET)=0
QUIT BDMERR
+18 ;
+19 ;I AGE["DYS"!(AGE["MOS")!(AGE<17) Q BDMERR ; 16 & younger not done, quit
+20 IF BDMAGE<18
QUIT BDMERR
+21 ;
+22 ; Cannot calculate without SEX
IF BDMSEX=""
QUIT BDMERR
+23 IF BDMSEX="U"
QUIT BDMERR
+24 ;
+25 QUIT "OK"
+26 ;
SETVARS1 ; EP
+1 ;CONSTANTS, EXPONENTS
+2 ; Sex Factor
SET SEXFACTR=$SELECT(BDMSEX="M":1,1:.742)
+3 ;
+4 SET RACEFACT=$SELECT($$RACE(DFN)="B":1.21,1:1)
+5 ;
+6 ; CONSTANT A
SET CONSTA=186
+7 ; CREATININE EXPONENT
SET CRETEXP=-1.154
+8 ; AGE EXPONENT
SET AGEEXP=-.203
+9 ;
+10 ;D:$G(SNAPSHOT) ENTRYAUD^BLRUTIL("SETVARS1^BLREXEC2")
+11 QUIT
RACE(DFN) ; EP
+1 NEW RACEPTR,RACEENT,V
+2 ;
+3 IF $TEXT(RACE^AGUTL)]""
Begin DoDot:1
+4 SET V=""
+5 SET RACEPTR=$$RACE^AGUTL(DFN)
+6 IF $PIECE(RACEPTR,U)=1
IF $PIECE(RACEPTR,U,2)["BLACK"
SET V="B"
+7 SET V="N"
End DoDot:1
QUIT V
+8 SET RACEPTR=$PIECE($GET(^DPT(+$GET(DFN),0)),U,6)
+9 ; If no entry, consider non-black
IF RACEPTR=""
QUIT "N"
+10 ;
+11 SET RACEENT=$PIECE($GET(^DIC(10,RACEPTR,0)),U)
+12 ; If RACEENT contains BLACK => race = Black
IF RACEENT[("BLACK")
QUIT "B"
+13 ; otherwise, non-black
QUIT "N"
+14 ;
