BDMD018 ; IHS/CMI/LAB - 2010 DIABETES AUDIT ;
;;2.0;DIABETES MANAGEMENT SYSTEM;**3**;JUN 14, 2007
;
;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 %=P_"^LAST MEAS HT;DURING "_BDATE_"-"_EDATE NEW X S E=$$START1^APCLDF(%,"BDMARRY(") S H=$P($G(BDMARRY(1)),U,2)
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 F S BDMD=$O(^AUPNVPOV("AD",BDMZ,BDMD)) Q:'BDMD!(BDMW]"") D
.. S ICD=$P($$ICDDX^ICDCODE($P(^AUPNVPOV(BDMD,0),U)),U,2) D ;cmi/anch/maw 9/12/2007 csv
...I $E(ICD,1,3)="V22" Q
...I $E(ICD,1,3)="V23" Q
...I $E(ICD,1,3)="V27" Q
...I $E(ICD,1,3)="V28" Q
...I ICD>629.9999&(ICD<676.95) Q
...S BDMW=$P(BDM(BDMN),U,2)
..Q
Q BDMW
BMI(P,BDATE,EDATE) ;EP
I 'P Q -1
NEW %,W,H,B,D,%DT,X
S %DT="P",X=EDATE D ^%DT S D=Y
S %=""
D Q %
.S W=$$WT(P,$$FMADD^XLFDT(D,-365),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^BDMD01C
CHOL(P,BDATE,EDATE,F) ;EP
G CHOL^BDMD01C
HDL(P,BDATE,EDATE,F) ;EP
G HDL^BDMD01C
LDL(P,BDATE,EDATE,F) ;EP
G LDL^BDMD01C
TRIG(P,BDATE,EDATE,F) ;EP
G TRIG^BDMD01C
URIN(P,BDATE,EDATE) ;EP
G URIN^BDMD01H
PROTEIN(P,BDATE,EDATE) ;EP
G PROTEIN^BDMD01C
MICRO(P,BDATE,EDATE) ;EP
G MICRO^BDMD01C
HGBA1C(P,BDATE,EDATE) ;EP
G HGBA1C^BDMD01D
SEMI(P,BDATE,EDATE) ;EP
G SEMI^BDMD01C
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
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
..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))
;go through all ppds and find last reading or result
;S G="",D=0,X=0 F S D=$O(BDM(D)) Q:D'=+D!(G) S X=0 F S X=$O(BDM(D,X)) Q:X'=+X S R=$P(BDM(D,X),U,2),R1=$P(BDM(D,X),U,3) I R]""!(R1]"") S G=1,R2=9999999-D
;S LD=R2
;I R]"",R>9 S LR=1_U_1_U_"1 SKIN TEST"_U_"1 POSITIVE "_$$FMTE^XLFDT(R2)_" Reading: "_R_" Result: "_R1
;I R]"",R<10 S LR=1_U_2_U_"1 SKIN TEST"_U_"2 NEGATIVE "_$$FMTE^XLFDT(R2)_" Reading: "_R_" Result: "_R1
;I R1]"",R1="P" S LR=1_U_1_U_"1 SKIN TEST"_U_"1 POSITIVE "_$$FMTE^XLFDT(R2)_" Reading: "_R_" Result: "_R1
;I R1]"",R1="N" S LR=1_U_2_U_"1 SKIN TEST"_U_"2 NEGATIVE "_$$FMTE^XLFDT(R2)_" Reading: "_R_" Result: "_R1
;Now get last lab test, must have a result
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^BDMD01C(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_"||4 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
;now check refusal for PPD or lab test
S X=EDATE,%DT="P" D ^%DT S BDATE=$$FMADD^XLFDT(Y,-365),BDATE=$$FMTE^XLFDT(BDATE),G=0 S X=$$REFUSAL^BDMD017(P,9999999.28,$O(^AUTTSK("B","PPD",0)),BDATE,EDATE) I X S G=X
I G Q "3 Refused "_$P(G,U,3)_" "_$P(G,U,4)_" "_$P(G,U,5)_"||3 Refused"
;now check lab test refusal - lori
Q "4 Unknown||4 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^BDMD01D
G75(P,BDATE,EDATE,F) ;EP
G G75^BDMD01D
;
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)
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)
BDMD018 ; IHS/CMI/LAB - 2010 DIABETES AUDIT ;
+1 ;;2.0;DIABETES MANAGEMENT SYSTEM;**3**;JUN 14, 2007
+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 ;S %=P_"^LAST MEAS HT;DURING "_BDATE_"-"_EDATE NEW X S E=$$START1^APCLDF(%,"BDMARRY(") S H=$P($G(BDMARRY(1)),U,2)
+4 SET E=$ORDER(^AUTTMSR("B","HT",0))
+5 SET H=""
+6 SET D=0
FOR
SET D=$ORDER(^AUPNVMSR("AA",P,E,D))
IF D'=+D!(H]"")
QUIT
Begin DoDot:1
+7 SET W=0
FOR
SET W=$ORDER(^AUPNVMSR("AA",P,E,D,W))
IF W'=+W!(H]"")
QUIT
Begin DoDot:2
+8 IF '$DATA(^AUPNVMSR(W,0))
QUIT
+9 ;entered in error
IF $PIECE($GET(^AUPNVMSR(W,2)),U,1)
QUIT
+10 SET H=$PIECE(^AUPNVMSR(W,0),U,4)
+11 SET BDMARRAY(1)=$$VD^APCLV($PIECE(^AUPNVMSR(W,0),U,3))
End DoDot:2
End DoDot:1
+12 IF H=""
QUIT H
+13 IF H["?"
QUIT ""
+14 SET H=$JUSTIFY(H,5,2)
+15 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
FOR
SET BDMD=$ORDER(^AUPNVPOV("AD",BDMZ,BDMD))
IF 'BDMD!(BDMW]"")
QUIT
Begin DoDot:2
+10 ;cmi/anch/maw 9/12/2007 csv
SET ICD=$PIECE($$ICDDX^ICDCODE($PIECE(^AUPNVPOV(BDMD,0),U)),U,2)
Begin DoDot:3
+11 IF $EXTRACT(ICD,1,3)="V22"
QUIT
+12 IF $EXTRACT(ICD,1,3)="V23"
QUIT
+13 IF $EXTRACT(ICD,1,3)="V27"
QUIT
+14 IF $EXTRACT(ICD,1,3)="V28"
QUIT
+15 IF ICD>629.9999&(ICD<676.95)
QUIT
+16 SET BDMW=$PIECE(BDM(BDMN),U,2)
End DoDot:3
+17 QUIT
End DoDot:2
End DoDot:1
+18 QUIT BDMW
BMI(P,BDATE,EDATE) ;EP
+1 IF 'P
QUIT -1
+2 NEW %,W,H,B,D,%DT,X
+3 SET %DT="P"
SET X=EDATE
DO ^%DT
SET D=Y
+4 SET %=""
+5 Begin DoDot:1
+6 SET W=$$WT(P,$$FMADD^XLFDT(D,-365),EDATE)
IF W=""
QUIT
SET W=W+.5
SET W=$PIECE(W,".")
+7 SET HDATE=$PIECE(^DPT(P,0),U,3)
+8 SET H=$$HT(P,HDATE,EDATE)
IF H=""
QUIT
+9 SET W=W*.45359
SET H=(H*.0254)
SET H=(H*H)
SET %=(W/H)
SET %=$JUSTIFY(%,4,1)
+10 QUIT
End DoDot:1
QUIT %
+11 QUIT
CREAT(P,BDATE,EDATE,F) ;EP
+1 GOTO CREAT^BDMD01C
CHOL(P,BDATE,EDATE,F) ;EP
+1 GOTO CHOL^BDMD01C
HDL(P,BDATE,EDATE,F) ;EP
+1 GOTO HDL^BDMD01C
LDL(P,BDATE,EDATE,F) ;EP
+1 GOTO LDL^BDMD01C
TRIG(P,BDATE,EDATE,F) ;EP
+1 GOTO TRIG^BDMD01C
URIN(P,BDATE,EDATE) ;EP
+1 GOTO URIN^BDMD01H
PROTEIN(P,BDATE,EDATE) ;EP
+1 GOTO PROTEIN^BDMD01C
MICRO(P,BDATE,EDATE) ;EP
+1 GOTO MICRO^BDMD01C
HGBA1C(P,BDATE,EDATE) ;EP
+1 GOTO HGBA1C^BDMD01D
SEMI(P,BDATE,EDATE) ;EP
+1 GOTO SEMI^BDMD01C
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 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^ATXCHK(Y,T,9)
SET I=X
+4 IF I
QUIT 1_U_$$VAL^XBDIQ1(9000011,I,.03)_" Problem List: "_$$VAL^XBDIQ1(9000011,I,.01)
+5 ;check povs
+6 KILL BDMS
SET X=P_"^FIRST DX [SURVEILLANCE TUBERCULOSIS"
SET E=$$START1^APCLDF(X,"BDMS(")
+7 IF $DATA(BDMS(1))
QUIT 1_U_$$FMTE^XLFDT($PIECE(BDMS(1),U))_" POV: "_$PIECE(BDMS(1),U,3)
+8 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 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
+15 ;go through all ppds and find last reading or result
+16 ;S G="",D=0,X=0 F S D=$O(BDM(D)) Q:D'=+D!(G) S X=0 F S X=$O(BDM(D,X)) Q:X'=+X S R=$P(BDM(D,X),U,2),R1=$P(BDM(D,X),U,3) I R]""!(R1]"") S G=1,R2=9999999-D
+17 ;S LD=R2
+18 ;I R]"",R>9 S LR=1_U_1_U_"1 SKIN TEST"_U_"1 POSITIVE "_$$FMTE^XLFDT(R2)_" Reading: "_R_" Result: "_R1
+19 ;I R]"",R<10 S LR=1_U_2_U_"1 SKIN TEST"_U_"2 NEGATIVE "_$$FMTE^XLFDT(R2)_" Reading: "_R_" Result: "_R1
+20 ;I R1]"",R1="P" S LR=1_U_1_U_"1 SKIN TEST"_U_"1 POSITIVE "_$$FMTE^XLFDT(R2)_" Reading: "_R_" Result: "_R1
+21 ;I R1]"",R1="N" S LR=1_U_2_U_"1 SKIN TEST"_U_"2 NEGATIVE "_$$FMTE^XLFDT(R2)_" Reading: "_R_" Result: "_R1
+22 ;Now get last lab test, must have a result
+23 SET BDMC=0
+24 SET BDMLT=$ORDER(^ATXLAB("B","DM AUDIT TB LAB TESTS",0))
+25 SET BDMOT=$ORDER(^ATXAX("B","DM AUDIT TB TEST LOINC",0))
+26 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
+27 SET L=0
FOR
SET L=$ORDER(^AUPNVLAB("AE",P,D,L))
IF L'=+L
QUIT
Begin DoDot:2
+28 SET X=0
FOR
SET X=$ORDER(^AUPNVLAB("AE",P,D,L,X))
IF X'=+X
QUIT
Begin DoDot:3
+29 IF '$DATA(^AUPNVLAB(X,0))
QUIT
+30 IF $PIECE(^AUPNVLAB(X,0),U,4)=""
QUIT
+31 IF $$UP^XLFSTR($PIECE(^AUPNVLAB(X,0),U,4))["CANC"
QUIT
+32 IF BDMLT
IF $PIECE(^AUPNVLAB(X,0),U)
IF $DATA(^ATXLAB(BDMLT,21,"B",$PIECE(^AUPNVLAB(X,0),U)))
Begin DoDot:4
+33 SET C=C+1
SET BDM(D,C)="LAB^"_X_U_$PIECE(^AUPNVLAB(X,0),U,4)
SET G=1
End DoDot:4
+34 IF 'BDMOT
QUIT
+35 SET J=$PIECE($GET(^AUPNVLAB(X,11)),U,13)
IF J=""
QUIT
+36 IF '$$LOINC^BDMD01C(J,BDMOT)
QUIT
+37 SET C=C+1
SET BDM(D,C)="LAB^"_X_U_$PIECE(^AUPNVLAB(X,0),U,4)
SET G=1
+38 QUIT
End DoDot:3
End DoDot:2
End DoDot:1
+39 ;now get latest with a result and use it, if none with a result take latest one
+40 ;if none, quit on value
+41 SET (D,C)=0
SET G=""
+42 FOR
SET D=$ORDER(BDM(D))
IF D'=+D!(G]"")
QUIT
Begin DoDot:1
+43 SET C=0
FOR
SET C=$ORDER(BDM(D,C))
IF C'=+C!(G]"")
QUIT
Begin DoDot:2
+44 IF $PIECE(BDM(D,C),U,3)]""!($PIECE(BDM(D,C),U,4)]"")
SET G=BDM(D,C)
End DoDot:2
End DoDot:1
+45 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)))
+46 ;C=1 skin test||result value
IF G]""
SET C=""
Begin DoDot:1
+47 SET C=$SELECT($PIECE(G,U,1)="ST":"1 Skin test (PPD)",1:"2 Blood Test (QFT-G, T SPOT-TB)")
+48 ;GET RESULT VALUE
+49 IF $PIECE(G,U,1)="LAB"
SET R=$PIECE(G,U,3)
Begin DoDot:2
+50 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
+51 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
+52 SET C=C_"||4 Unknown"
QUIT
End DoDot:2
QUIT
+53 IF $PIECE(G,U,1)="ST"
Begin DoDot:2
+54 SET R=$PIECE(G,U,3)
SET R1=$PIECE(G,U,4)
+55 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
+56 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
+57 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
+58 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
+59 ;now check refusal for PPD or lab test
+60 SET X=EDATE
SET %DT="P"
DO ^%DT
SET BDATE=$$FMADD^XLFDT(Y,-365)
SET BDATE=$$FMTE^XLFDT(BDATE)
SET G=0
SET X=$$REFUSAL^BDMD017(P,9999999.28,$ORDER(^AUTTSK("B","PPD",0)),BDATE,EDATE)
IF X
SET G=X
+61 IF G
QUIT "3 Refused "_$PIECE(G,U,3)_" "_$PIECE(G,U,4)_" "_$PIECE(G,U,5)_"||3 Refused"
+62 ;now check lab test refusal - lori
+63 QUIT "4 Unknown||4 Unknown"
+64 ;
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^BDMD01D
G75(P,BDATE,EDATE,F) ;EP
+1 GOTO G75^BDMD01D
+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 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
+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)
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)
