BDMS9B2 ; IHS/CMI/LAB - DIABETIC CARE SUMMARY SUPPLEMENT ; 09 Nov 2017 3:25 PM
;;2.0;DIABETES MANAGEMENT SYSTEM;**3,4,5,6,7,8,9,10,11,12**;JUN 14, 2007;Build 51
;
;
MORE ;EP
S X="Immunizations:" D S(X,1)
S X=" Influenza vaccine (since August 1st): ",$E(X,41)=$$FLU^BDMS9B3(BDMSDFN) D S(X)
S X=" Pneumococcal vaccine (ever):",$E(X,41)=$$PNEU^BDMS9B4(BDMSDFN) D S(X)
S X=" Td/Tdap/DTAP/DT (in past 10 yrs):",$E(X,41)=$$TD^BDMS9B3(BDMSDFN,(DT-100000),DT) D S(X)
S X=" Tdap (ever):",$E(X,41)=$P($$TDAP^BDMDG1B(BDMSDFN,DT,"H")," ",2,99) D S(X)
S X=" Hepatitis B complete series (ever): ",$E(X,41)=$P($$HEP^BDMDG13(BDMSDFN,DT)," ",2,99) D S(X)
S Y=$$PPDS^BDMS9B4(BDMSDFN) S J=1 I Y]"" S X="TB - Status:",$E(X,30)=Y D S(X,1) S J=0
S Y=$$PPD^BDMS9B4(BDMSDFN) S X="TB - Last Documented Test:",$E(X,30)=$P(Y," ",4)_" "_$P(Y," ",1) D S(X,J)
S X="",$E(X,6)="TB Test Result:",$E(X,30)=$P(Y," ",2)_" "_$P(Y," ",3) D S(X)
S X=" TB Treatment Completed: ",$E(X,30)=$$TB(BDMSDFN) D S(X)
HEPC ;2018 AUDIT
D S("Hepatitis C (HCV)",1)
S X=$$HEPCDX^BDMDG1D(BDMSDFN,DT) D S(" Diagnosed with HCV ever: "_$P(X," ",2))
;SCREEN ALL P12
S B=$$DOB^AUPNPAT(BDMSDFN)
;I B<2450101!(B>2651231) G R ;patch 12 - add if screened ever
I $E(X)'=1 D S(" Screened for HCV ever: "_$P($$HEPSCR^BDMDG1D(BDMSDFN,DT)," ",2))
R ;retinopathy
S X=$$DMRETDX^BDMDG1D(BDMSDFN,DT) D S("Retinopathy Diagnosed: "_$S($E(X)=1:"Yes",1:"No"),1)
;ADDED LE AMPUTATIONS
LEAMP ;
S R=$$LEAMP^BDMDG1D(BDMSDFN,DT,2)
;
D S("Amputation",1)
S Y=" Lower extremity (ever), any type (e.g., toe, partial foot, above or" D S(Y)
S Y=" below knee): "_R D S(Y)
L ;
S X="Laboratory Results (most recent):",$E(X,55)="RPMS LAB TEST NAME" D S(X,1)
S X=" A1C:" S Y=$$HBA1C(BDMSDFN),$E(X,25)=$P(Y,"|||"),$E(X,44)=$$DATE^BDMS9B1($P(Y,"|||",2)),$E(X,55)=$P(Y,"|||",3) D S(X)
I $P(Y,"|||",4)]"" S X=" Note: "_$P(Y,"|||",4) D S(X)
S X=" Next most recent A1C:" S Y=$$NLHGB(BDMSDFN),$E(X,25)=$P(Y,"|||"),$E(X,44)=$$DATE^BDMS9B1($P(Y,"|||",2)),$E(X,55)=$P(Y,"|||",3) D S(X)
S X=" Serum Creatinine:" S Y=$$CREAT(BDMSDFN),$E(X,25)=$P(Y,"|||"),$E(X,44)=$$DATE^BDMS9B1($P(Y,"|||",2)),$E(X,55)=$P(Y,"|||",3) D S(X,1)
I $P(Y,"|||",4)]"" S X=" Note: "_$P(Y,"|||",4) D S(X)
S X=" eGFR:" S Y=$$GFR(BDMSDFN),$E(X,25)=$P(Y,"|||"),$E(X,44)=$$DATE^BDMS9B1($P(Y,"|||",2)),$E(X,55)=$P(Y,"|||",3) D S(X)
S Y=$$ACRATIO(BDMSDFN)
S X=" UACR (Quant A/C Ratio):",$E(X,25)=$P(Y,"|||"),$E(X,44)=$$DATE^BDMS9B1($P(Y,"|||",2)),$E(X,55)=$P(Y,"|||",3) D S(X)
S X=" Total Cholesterol:" S Y=$$TCHOL(BDMSDFN),$E(X,25)=$P(Y,"|||"),$E(X,44)=$$DATE^BDMS9B1($P(Y,"|||",2)),$E(X,55)=$P(Y,"|||",3) D S(X,1)
;S X=" Non-HDL Cholesterol:" S Y=$$NONHDL(BDMSDFN),$E(X,25)=$P(Y,"|||"),$E(X,44)=$$DATE^BDMS9B1($P(Y,"|||",2)),$E(X,55)=$P(Y,"|||",3) D S(X)
S X=" LDL Cholesterol:" S Y=$$CHOL(BDMSDFN),$E(X,25)=$P(Y,"|||"),$E(X,44)=$$DATE^BDMS9B1($P(Y,"|||",2)),$E(X,55)=$P(Y,"|||",3) D S(X)
S X=" HDL Cholesterol:" S Y=$$HDL(BDMSDFN),$E(X,25)=$P(Y,"|||"),$E(X,44)=$$DATE^BDMS9B1($P(Y,"|||",2)),$E(X,55)=$P(Y,"|||",3) D S(X)
S X=" Triglycerides:" S Y=$$TRIG(BDMSDFN),$E(X,25)=$P(Y,"|||"),$E(X,44)=$$DATE^BDMS9B1($P(Y,"|||",2)),$E(X,55)=$P(Y,"|||",3) D S(X)
S Z=0
EDUCD D S(" ")
S BDMSBEG=$$FMADD^XLFDT(DT,-365)
S X="Education Provided (in past yr): " D S(X)
S X=" Last Dietitian Visit (ever): "_$$DIETV^BDMS9B3(BDMSDFN) D S(X)
S X=""
K BDMX
D EDUC
I $D(BDMX) D
.S %="" F S %=$O(BDMX(%)) Q:%="" D S(" "_BDMX(%))
;I X]"" D S(X)
K BDMX,BDMY,%
D EDUCREF I $D(BDMX) S X="In the past year, the patient has refused the following Diabetes education:" D S(X) D
.S %="" F S %=$O(BDMX(%)) Q:%="" S X=" "_%_" "_BDMX(%) D S(X)
K BDMR,BDMY,%
Q
S(Y,F,C,T) ;set up array
I '$G(F) S F=0
I '$G(T) S T=0
NEW %,X
;blank lines
F F=1:1:F S X="" D S1
S X=Y
I $G(C) S L=$L(Y),T=(80-L)/2 D D S1 Q
.F %=1:1:(T-1) S X=" "_X
F %=1:1:T S X=" "_Y
D S1
Q
S1 ;
S %=$P(^TMP("APCHS",$J,"DCS",0),U)+1,$P(^TMP("APCHS",$J,"DCS",0),U)=%
S ^TMP("APCHS",$J,"DCS",%)=X
Q
EDUC ;EP - gather up all education provided in past year in BDMX
K BDMX,BDMY,BDMP S %=BDMSDFN_"^ALL EDUC;DURING "_$$DATE^BDMS9B1(BDMSBEG)_"-"_$$DATE^BDMS9B1(DT) S E=$$START1^APCLDF(%,"BDMY(") ;
I '$D(BDMY) S BDMX(1)=" <No Education Topics recorded in past year>" K BDMY Q
NEW X K BDMP S X=0,E="" F S X=$O(BDMY(X)) Q:X'=+X D
.S E=+$P(BDMY(X),U,4)
.Q:$P(^AUPNVPED(E,0),U,6)=5
.S E=$P(^AUPNVPED(E,0),U)
.Q:'$$EDT(E)
.S BDMP($$UP^XLFSTR($P(BDMY(X),U,2)))=$$DATE^BDMS9B1($P(BDMY(X),U))_U_$$EPRV(+$P(BDMY(X),U,4))
;S %=0,E="" F S E=$O(BDMP(E)) Q:E="" S %=%+1,BDMX(%)=$E(E,1,25),$E(BDMX(%),28)=$P(BDMP(E),U,1),$E(BDMX(%),39)=$P(BDMP(E),U,2)
S E="" F S E=$O(BDMP(E)) Q:E="" S BDMX(E)=$E(E,1,30),$E(BDMX(E),33)=$P(BDMP(E),U,1),$E(BDMX(E),45)=$P(BDMP(E),U,2)
K BDMY
Q
EPRV(I) ;
NEW P,D,%
S P=$$VALI^XBDIQ1(9000010.16,I,.05) I P S D=$$PROVCLS^XBFUNC1(P) S %="",%=$E($P(^VA(200,P,0),U,1),1,18),$E(%,24)=$E(D,1,15) Q %
S P=$$VALI^XBDIQ1(9000010.16,I,1204) I P S D=$$PROVCLS^XBFUNC1(P) S %="",%=$E($P(^VA(200,P,0),U,1),1,18),$E(%,24)=$E(D,1,15) Q %
S P=$$VALI^XBDIQ1(9000010.16,I,1202) I P S D=$$PROVCLS^XBFUNC1(P) S %="",%=$E($P(^VA(200,P,0),U,1),1,18),$E(%,24)=$E(D,1,15) Q %
S P=$$PRIMPROV^APCLV($P(^AUPNVPED(I,0),U,3),"I") I P S D=$$PROVCLS^XBFUNC1(P) S %="",%=$E($P(^VA(200,P,0),U,1),1,18),$E(%,20)=$E(D,1,15)
Q ""
EDUCREF ;EP - gather up all education provided in past year
K BDMX,BDMY
S BDMY=0 F S BDMY=$O(^AUPNPREF("AA",BDMSPAT,9999999.09,BDMY)) Q:BDMY'=+BDMY I $$EDT(BDMY) S BDMD=$O(^AUPNPREF("AA",BDMSPAT,9999999.09,BDMY,0)) I BDMD<(9999999-BDMSBEG) D
.Q:$D(BDMP($$UP^XLFSTR($P(^AUTTEDT(BDMY,0),U)))) ;already displayed
.S BDMX($P(^AUTTEDT(BDMY,0),U))=$$DATE^BDMS9B1(9999999-BDMD)
Q
EDT(E) ;
;is this ien in any taxonomy
NEW T,S
S T=$O(^ATXAX("B","DM AUDIT DIABETES EDUC TOPICS",0))
I T,$D(^ATXAX(T,21,"B",E)) Q 1
S T=$O(^ATXAX("B","DM AUDIT DIET EDUC TOPICS",0))
I T,$D(^ATXAX(T,21,"B",E)) Q 1
S T=$O(^ATXAX("B","DM AUDIT EXERCISE EDUC TOPICS",0))
I T,$D(^ATXAX(T,21,"B",E)) Q 1
S T=$O(^ATXAX("B","DM AUDIT OTHER EDUC TOPICS",0))
I T,$D(^ATXAX(T,21,"B",E)) Q 1
S T=$P(^AUTTEDT(E,0),U,2)
I $P(T,"-")="DM" Q 1
I $P(T,"-")="DMC" Q 1
I $P(T,"-")="MNT" Q 1
I $P(T,"-")="DMCN" Q 1
I $P(T,"-",2)="EX" Q 1
I $P(T,"-",2)="N" Q 1
I $P(T,"-",2)="DT" Q 1
I $P(T,"-",2)="MNT" Q 1
;SNOMED
I $P(T,"-",1)]"",$$SNOMED^BDMUTL($$LE(),"PXRM DIABETES",$P(T,"-",1)) Q 1
NEW CODE
S G=""
S CODE=$P($$CODEN^BDMUTL($P(T,"-",1),80),"~")
I CODE>0 D
.N TAX
.S TAX=$O(^ATXAX("B","SURVEILLANCE DIABETES",0))
.I $$ICD^BDMUTL(CODE,$P(^ATXAX(TAX,0),U),9) S G=1
Q G
LE() ;EP
NEW A,B
S B=""
S A=0 F S A=$O(^BDMSNME("B",A)) Q:A="" S B=A
Q B
TB(P) ;
I '$G(P) Q ""
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(1)) Q $P($G(BDMS(1)),U,3)
NEW %,Y
S %=$O(^ATXAX("B","DM AUDIT TB HEALTH FACTORS",0))
I '% Q ""
S (X,Y)=0 F S X=$O(^AUPNHF("AA",P,X)) Q:X'=+X!(Y) I $D(^ATXAX(%,21,"B",X)) S Y=X
I 'Y Q ""
Q $P(^AUTTHF(Y,0),U)
GFR(P) ;
I '$G(P) Q ""
S BDMC=""
NEW T,T1,T2
S T=$O(^LAB(60,"B","ESTIMATED GFR",0))
S T1=$O(^ATXLAB("B","BGP GPRA ESTIMATED GFR TAX",0))
S T2=$O(^ATXAX("B","BGP ESTIMATED GFR LOINC",0))
NEW D,V,G,X,J S (D,G)=0 F S D=$O(^AUPNVLAB("AE",P,D)) Q:D'=+D!(BDMC]"") D
.S X=0 F S X=$O(^AUPNVLAB("AE",P,D,X)) Q:X'=+X!(BDMC]"") D
..S Y=0 F S Y=$O(^AUPNVLAB("AE",P,D,X,Y)) Q:Y'=+Y D
...Q:'$D(^AUPNVLAB(Y,0))
...I $O(^LAB(60,$P(^AUPNVLAB(Y,0),U,1),2,0)) Q ;NO PANELS PER DOROTHY
...I T,$P(^AUPNVLAB(Y,0),U)=T D
....I BDMC]"",$P(^AUPNVLAB(Y,0),U,4)="" Q
....S BDMC=$$LBLK($P(^AUPNVLAB(Y,0),U,4),6)_" "_$P($G(^AUPNVLAB(Y,11)),U)_"|||"_$P($P(^AUPNVSIT($P(^AUPNVLAB(Y,0),U,3),0),U),".")_"|||"_$E($$VAL^XBDIQ1(9000010.09,Y,.01),1,25)_"|||"_Y Q
...I T1,$P(^AUPNVLAB(Y,0),U),$D(^ATXLAB(T1,21,"B",$P(^AUPNVLAB(Y,0),U))) D
....I BDMC]"",$P(^AUPNVLAB(Y,0),U,4)="" Q
....S BDMC=$$LBLK($P(^AUPNVLAB(Y,0),U,4),6)_" "_$P($G(^AUPNVLAB(Y,11)),U)_"|||"_$P($P(^AUPNVSIT($P(^AUPNVLAB(Y,0),U,3),0),U),".")_"|||"_$E($$VAL^XBDIQ1(9000010.09,Y,.01),1,25)_"|||"_Y Q
...S J=$P($G(^AUPNVLAB(Y,11)),U,13) Q:J=""
...Q:'$$LOINC(J,T2)
...I $O(^LAB(60,$P(^AUPNVLAB(Y,0),U,1),2,0)) Q ;NO PANELS PER DOROTHY
...S BDMC=$$LBLK($P(^AUPNVLAB(Y,0),U,4),6)_" "_$P($G(^AUPNVLAB(Y,11)),U)_"|||"_$P($P(^AUPNVSIT($P(^AUPNVLAB(Y,0),U,3),0),U),".")_"|||"_$E($$VAL^XBDIQ1(9000010.09,Y,.01),1,25)_"|||"_Y
...Q
I BDMC]"" Q BDMC
S T=$O(^ATXLAB("B","BGP GPRA ESTIMATED GFR TAX",0)) I 'T Q ""
Q $$LAB(P,T)
CHOL(P) ;EP
I '$G(P) Q ""
NEW T S T=$O(^ATXLAB("B","DM AUDIT LDL CHOLESTEROL TAX",0)),LT=$O(^ATXAX("B","BGP LDL LOINC CODES",0)) I 'T Q "<Taxonomy Missing>"
Q $$LAB(P,T,LT)
HDL(P) ;EP
I '$G(P) Q ""
NEW T S T=$O(^ATXLAB("B","DM AUDIT HDL TAX",0)),LT=$O(^ATXAX("B","BGP HDL LOINC CODES",0)) I 'T Q "<Taxonomy Missing>"
Q $$LAB(P,T,LT)
TCHOL(P) ;EP
I '$G(P) Q ""
NEW T S T=$O(^ATXLAB("B","DM AUDIT CHOLESTEROL TAX",0)),LT=$O(^ATXAX("B","BGP TOTAL CHOLESTEROL LOINC",0)) I 'T Q "<Taxonomy Missing>"
Q $$LAB(P,T,LT)
NONHDL(P) ;
NEW V,D,TC,HDL,TCD,HDLD,NT
I '$G(P) Q ""
S V=""
NEW T S T=$O(^ATXLAB("B","DM AUDIT CHOLESTEROL TAX",0)),LT=$O(^ATXAX("B","BGP TOTAL CHOLESTEROL LOINC",0)) I 'T Q "<Taxonomy Missing>"
S TC=$$LAB(P,T,LT),TCD=$P(TC,"|||",2),TC=$$STRIP^XLFSTR($P(TC,"|||")," ")
I TC="" Q V
I TCD<$P(V,"|||",2) Q V
S T=$O(^ATXLAB("B","DM AUDIT HDL TAX",0)),LT=$O(^ATXAX("B","BGP HDL LOINC CODES",0)) I 'T Q "<Taxonomy Missing>"
S HDL=$$LAB(P,T,LT),HDLD=$P(HDL,"|||",2),HDL=$$STRIP^XLFSTR($P(HDL,"|||")," ")
I HDL="" Q V
I HDLD<$P(V,"|||",2) Q V
S TC=+TC,HDL=+HDL
I 'TC Q ""
I 'HDL Q ""
Q $$LBLK(TC-HDL,6)_"|||"_TCD_"|||[Calculated Value]"
TRIG(P) ;EP
I '$G(P) Q ""
NEW T S T=$O(^ATXLAB("B","DM AUDIT TRIGLYCERIDE TAX",0)),LT=$O(^ATXAX("B","BGP TRIGLYCERIDE LOINC CODES",0)) I 'T Q "<Taxonomy Missing>"
Q $$LAB(P,T,LT)
CREAT(P) ;
I '$G(P) Q ""
NEW T S T=$O(^ATXLAB("B","DM AUDIT CREATININE TAX",0)),LT=$O(^ATXAX("B","BGP CREATININE LOINC CODES",0)) I 'T Q "<Taxonomy Missing>"
Q $$LAB(P,T,LT)
;
PCR(P) ;EP
I '$G(P) Q ""
NEW T S T=$O(^ATXLAB("B","DM AUDIT P/C RATIO TAX",0)),LT=$O(^ATXAX("B","DM AUDIT P/C RATIO LOINC",0)) I 'T Q "<Taxonomy Missing>"
Q $$LAB(P,T,LT,1)
LAB(P,T,LT,YEAR) ;EP
I '$G(LT) S LT=""
S YEAR=$G(YEAR)
NEW BDATE
S BDATE=$S(YEAR:$$FMADD^XLFDT(DT,-365),1:$$DOB^AUPNPAT(P))
NEW D,V,G,X,J S (D,G)=0 F S D=$O(^AUPNVLAB("AE",P,D)) Q:D'=+D!(G) D
.S X=0 F S X=$O(^AUPNVLAB("AE",P,D,X)) Q:X'=+X!(G) D
..Q:(9999999-D)<BDATE
..S Y=0 F S Y=$O(^AUPNVLAB("AE",P,D,X,Y)) Q:Y'=+Y!(G) D
...I $D(^ATXLAB(T,21,"B",X)),$P(^AUPNVLAB(Y,0),U,4)]"" S G=Y Q
...Q:'LT
...S J=$P($G(^AUPNVLAB(Y,11)),U,13) Q:J=""
...Q:'$$LOINC(J,LT)
...S G=Y
...Q
..Q
.Q
I 'G Q ""
S R=$$LBLK($P(^AUPNVLAB(G,0),U,4),6)_" "_$P($G(^AUPNVLAB(G,11)),U)_"|||"
S R=R_$P($P($G(^AUPNVSIT($P(^AUPNVLAB(G,0),U,3),0)),U),".")_"|||"_$E($$VAL^XBDIQ1(9000010.09,G,.01),1,25)_"|||"_$$REF(P,T,$P($P($G(^AUPNVSIT($P(^AUPNVLAB(G,0),U,3),0)),U),"."))_"|||"_G
Q R
LOINC(A,B) ;EP
NEW %
S %=$P($G(^LAB(95.3,A,9999999)),U,2)
I %]"",$D(^ATXAX(B,21,"B",%)) Q 1
S %=$P($G(^LAB(95.3,A,0)),U)_"-"_$P($G(^LAB(95.3,A,0)),U,15)
I $D(^ATXAX(B,21,"B",%)) Q 1
Q ""
DATE(D) ;EP - convert to slashed date
I $G(D)="" Q ""
Q $E(D,4,5)_"/"_$E(D,6,7)_"/"_$E(D,2,3)
REF(P,T,D) ;return refusal string after date D for test is tax T
I '$G(P) Q ""
I '$G(T) Q ""
I '$G(D) S D=""
N BDMREF,BDMT,V S BDMT=0 F S BDMT=$O(^ATXLAB(T,21,"B",BDMT)) Q:BDMT'=+BDMT D
.S V=$$REF1(P,60,BDMT,D) I V]"" S BDMREF(9999999-$P(V,U,3))=V
I $D(BDMREF) S %=0,%=$O(BDMREF(%)) I % S V=BDMREF(%) Q V
Q ""
REF1(P,F,I,D,T) ; ;
I '$G(P) Q ""
I '$G(F) Q ""
I '$G(I) Q ""
I $G(D)="" S D=""
I $G(T)="" S T="E"
NEW X,N S X=$O(^AUPNPREF("AA",P,F,I,0))
I 'X Q ""
S N=$O(^AUPNPREF("AA",P,F,I,X,0))
NEW Y S Y=9999999-X
I D]"",Y>D Q $S(T="I":Y,1:$$TYPEREF(N)_"-"_$$DATE(Y))
I T="I" Q Y ;quit on internal form of date
Q $$TYPEREF(N)_"-"_$$DATE(Y)
;
TYPEREF(N) ;
NEW % S %=$P(^AUPNPREF(N,0),U,7)
I %="R"!(%="") Q "Refused"
I %="N" Q "Not Med Ind"
I %="F" Q "No Resp to F/U"
Q ""
NLHGB(P) ;return next to last HGBA1C
I '$G(P) Q ""
NEW T S T=$O(^ATXLAB("B","DM AUDIT HGB A1C TAX",0)) I 'T Q "<Taxonomy Missing>"
NEW LT S LT=$O(^ATXAX("B","BGP HGBA1C LOINC CODES",0))
NEW D,V,G,X,E S (D,G)=0,E="" F S D=$O(^AUPNVLAB("AE",P,D)) Q:D'=+D!(G=2) D
.S X=0 F S X=$O(^AUPNVLAB("AE",P,D,X)) Q:X'=+X!(G=2) D
..S Y=0 F S Y=$O(^AUPNVLAB("AE",P,D,X,Y)) Q:Y'=+Y!(G=2) D
...I $D(^ATXLAB(T,21,"B",X)),$P(^AUPNVLAB(Y,0),U,4)]"" S G=G+1,E=Y Q
...Q:'LT
...S J=$P($G(^AUPNVLAB(Y,11)),U,13) Q:J=""
...Q:'$$LOINC(J,LT)
...S G=G+1,E=Y
...Q
..Q
.Q
I G'=2 Q ""
I 'E Q ""
Q $$LBLK($P(^AUPNVLAB(E,0),U,4),6)_" "_$P($G(^AUPNVLAB(E,11)),U)_"|||"_$P($P(^AUPNVSIT($P(^AUPNVLAB(E,0),U,3),0),U),".")_"|||"_$E($$VAL^XBDIQ1(9000010.09,E,.01),1,25)
HBA1C(P) ;
I '$G(P) Q ""
NEW T S T=$O(^ATXLAB("B","DM AUDIT HGB A1C TAX",0)),LT=$O(^ATXAX("B","BGP HGBA1C LOINC CODES",0)) I 'T Q "<Taxonomy Missing>"
Q $$LAB(P,T,LT)
URIN(P) ;
I '$G(P) Q ""
NEW T S T=$O(^ATXLAB("B","DM AUDIT URINE PROTEIN TAX",0)),LT=$O(^ATXAX("B","DM AUDIT URINE PROTEIN LOINC",0)) I 'T Q "<Taxonomy Missing>"
Q $$LAB(P,T,LT,1)
MICRO(P) ;
I '$G(P) Q ""
NEW T S T=$O(^ATXLAB("B","DM AUDIT MICROALBUMINURIA TAX",0)),LT=$O(^ATXAX("B","DM AUDIT MICROALBUMIN LOINC",0)) I 'T Q "<Taxonomy Missing>"
Q $$LAB(P,T,LT,1)
ACRATIO(P) ;
I '$G(P) Q ""
NEW T S T=$O(^ATXLAB("B","DM AUDIT QUANT UACR",0)),LT=$O(^ATXAX("B","DM AUDIT A/C RATIO LOINC",0)) I 'T Q "<Taxonomy Missing>"
Q $$LAB(P,T,LT)
HR24(P) ;
I '$G(P) Q ""
NEW T S T=$O(^ATXLAB("B","DM AUDIT 24HR URINE PROTEIN",0)),LT="" I 'T Q "<Taxonomy Missing>"
Q $$LAB(P,T,LT,1)
SEMI(P) ;
I '$G(P) Q ""
NEW T S T=$O(^ATXLAB("B","DM AUDIT SEMI QUANT UACR",0)),LT="" I 'T Q "<Taxonomy Missing>"
Q $$LAB(P,T,LT,1)
LBLK(V,L) ;EP LEFT blank fill
NEW %,I
S %=$L(V),Z=L-% F I=1:1:Z S V=" "_V
Q V
LDLLAB ;EP
K BDMX
NEW LT S LT=$O(^ATXAX("B","BGP LDL LOINC CODES",0))
NEW D,V,X,G S (D,G)=0 F S D=$O(^AUPNVLAB("AE",BDMSPAT,D)) Q:D'=+D!(G>2) D
.S X=0 F S X=$O(^AUPNVLAB("AE",BDMSPAT,D,X)) Q:X'=+X!(G>2) D
..S Y=0 F S Y=$O(^AUPNVLAB("AE",BDMSPAT,D,X,Y)) Q:Y'=+Y!(G>2) D
...Q:'$D(^AUPNVLAB(Y,0))
...I $P(^AUPNVLAB(Y,0),U,4)="" Q
...I Y=BDMIEN Q
...I $D(^ATXLAB(T,21,"B",X)) D Q
....S R=$P(^AUPNVLAB(Y,0),U,4) Q:R'=+R
....S BDMX(Y)=R_"^"_(9999999-D),G=G+1
...Q:'LT
...S J=$P($G(^AUPNVLAB(Y,11)),U,13) Q:J=""
...Q:'$$LOINC(J,LT)
...S R=$P(^AUPNVLAB(Y,0),U,4) Q:R'=+R
...S BDMX(Y)=R_"^"_(9999999-D),G=G+1
...Q
..Q
.Q
Q
BDMS9B2 ; IHS/CMI/LAB - DIABETIC CARE SUMMARY SUPPLEMENT ; 09 Nov 2017 3:25 PM
+1 ;;2.0;DIABETES MANAGEMENT SYSTEM;**3,4,5,6,7,8,9,10,11,12**;JUN 14, 2007;Build 51
+2 ;
+3 ;
MORE ;EP
+1 SET X="Immunizations:"
DO S(X,1)
+2 SET X=" Influenza vaccine (since August 1st): "
SET $EXTRACT(X,41)=$$FLU^BDMS9B3(BDMSDFN)
DO S(X)
+3 SET X=" Pneumococcal vaccine (ever):"
SET $EXTRACT(X,41)=$$PNEU^BDMS9B4(BDMSDFN)
DO S(X)
+4 SET X=" Td/Tdap/DTAP/DT (in past 10 yrs):"
SET $EXTRACT(X,41)=$$TD^BDMS9B3(BDMSDFN,(DT-100000),DT)
DO S(X)
+5 SET X=" Tdap (ever):"
SET $EXTRACT(X,41)=$PIECE($$TDAP^BDMDG1B(BDMSDFN,DT,"H")," ",2,99)
DO S(X)
+6 SET X=" Hepatitis B complete series (ever): "
SET $EXTRACT(X,41)=$PIECE($$HEP^BDMDG13(BDMSDFN,DT)," ",2,99)
DO S(X)
+7 SET Y=$$PPDS^BDMS9B4(BDMSDFN)
SET J=1
IF Y]""
SET X="TB - Status:"
SET $EXTRACT(X,30)=Y
DO S(X,1)
SET J=0
+8 SET Y=$$PPD^BDMS9B4(BDMSDFN)
SET X="TB - Last Documented Test:"
SET $EXTRACT(X,30)=$PIECE(Y," ",4)_" "_$PIECE(Y," ",1)
DO S(X,J)
+9 SET X=""
SET $EXTRACT(X,6)="TB Test Result:"
SET $EXTRACT(X,30)=$PIECE(Y," ",2)_" "_$PIECE(Y," ",3)
DO S(X)
+10 SET X=" TB Treatment Completed: "
SET $EXTRACT(X,30)=$$TB(BDMSDFN)
DO S(X)
HEPC ;2018 AUDIT
+1 DO S("Hepatitis C (HCV)",1)
+2 SET X=$$HEPCDX^BDMDG1D(BDMSDFN,DT)
DO S(" Diagnosed with HCV ever: "_$PIECE(X," ",2))
+3 ;SCREEN ALL P12
+4 SET B=$$DOB^AUPNPAT(BDMSDFN)
+5 ;I B<2450101!(B>2651231) G R ;patch 12 - add if screened ever
+6 IF $EXTRACT(X)'=1
DO S(" Screened for HCV ever: "_$PIECE($$HEPSCR^BDMDG1D(BDMSDFN,DT)," ",2))
R ;retinopathy
+1 SET X=$$DMRETDX^BDMDG1D(BDMSDFN,DT)
DO S("Retinopathy Diagnosed: "_$SELECT($EXTRACT(X)=1:"Yes",1:"No"),1)
+2 ;ADDED LE AMPUTATIONS
LEAMP ;
+1 SET R=$$LEAMP^BDMDG1D(BDMSDFN,DT,2)
+2 ;
+3 DO S("Amputation",1)
+4 SET Y=" Lower extremity (ever), any type (e.g., toe, partial foot, above or"
DO S(Y)
+5 SET Y=" below knee): "_R
DO S(Y)
L ;
+1 SET X="Laboratory Results (most recent):"
SET $EXTRACT(X,55)="RPMS LAB TEST NAME"
DO S(X,1)
+2 SET X=" A1C:"
SET Y=$$HBA1C(BDMSDFN)
SET $EXTRACT(X,25)=$PIECE(Y,"|||")
SET $EXTRACT(X,44)=$$DATE^BDMS9B1($PIECE(Y,"|||",2))
SET $EXTRACT(X,55)=$PIECE(Y,"|||",3)
DO S(X)
+3 IF $PIECE(Y,"|||",4)]""
SET X=" Note: "_$PIECE(Y,"|||",4)
DO S(X)
+4 SET X=" Next most recent A1C:"
SET Y=$$NLHGB(BDMSDFN)
SET $EXTRACT(X,25)=$PIECE(Y,"|||")
SET $EXTRACT(X,44)=$$DATE^BDMS9B1($PIECE(Y,"|||",2))
SET $EXTRACT(X,55)=$PIECE(Y,"|||",3)
DO S(X)
+5 SET X=" Serum Creatinine:"
SET Y=$$CREAT(BDMSDFN)
SET $EXTRACT(X,25)=$PIECE(Y,"|||")
SET $EXTRACT(X,44)=$$DATE^BDMS9B1($PIECE(Y,"|||",2))
SET $EXTRACT(X,55)=$PIECE(Y,"|||",3)
DO S(X,1)
+6 IF $PIECE(Y,"|||",4)]""
SET X=" Note: "_$PIECE(Y,"|||",4)
DO S(X)
+7 SET X=" eGFR:"
SET Y=$$GFR(BDMSDFN)
SET $EXTRACT(X,25)=$PIECE(Y,"|||")
SET $EXTRACT(X,44)=$$DATE^BDMS9B1($PIECE(Y,"|||",2))
SET $EXTRACT(X,55)=$PIECE(Y,"|||",3)
DO S(X)
+8 SET Y=$$ACRATIO(BDMSDFN)
+9 SET X=" UACR (Quant A/C Ratio):"
SET $EXTRACT(X,25)=$PIECE(Y,"|||")
SET $EXTRACT(X,44)=$$DATE^BDMS9B1($PIECE(Y,"|||",2))
SET $EXTRACT(X,55)=$PIECE(Y,"|||",3)
DO S(X)
+10 SET X=" Total Cholesterol:"
SET Y=$$TCHOL(BDMSDFN)
SET $EXTRACT(X,25)=$PIECE(Y,"|||")
SET $EXTRACT(X,44)=$$DATE^BDMS9B1($PIECE(Y,"|||",2))
SET $EXTRACT(X,55)=$PIECE(Y,"|||",3)
DO S(X,1)
+11 ;S X=" Non-HDL Cholesterol:" S Y=$$NONHDL(BDMSDFN),$E(X,25)=$P(Y,"|||"),$E(X,44)=$$DATE^BDMS9B1($P(Y,"|||",2)),$E(X,55)=$P(Y,"|||",3) D S(X)
+12 SET X=" LDL Cholesterol:"
SET Y=$$CHOL(BDMSDFN)
SET $EXTRACT(X,25)=$PIECE(Y,"|||")
SET $EXTRACT(X,44)=$$DATE^BDMS9B1($PIECE(Y,"|||",2))
SET $EXTRACT(X,55)=$PIECE(Y,"|||",3)
DO S(X)
+13 SET X=" HDL Cholesterol:"
SET Y=$$HDL(BDMSDFN)
SET $EXTRACT(X,25)=$PIECE(Y,"|||")
SET $EXTRACT(X,44)=$$DATE^BDMS9B1($PIECE(Y,"|||",2))
SET $EXTRACT(X,55)=$PIECE(Y,"|||",3)
DO S(X)
+14 SET X=" Triglycerides:"
SET Y=$$TRIG(BDMSDFN)
SET $EXTRACT(X,25)=$PIECE(Y,"|||")
SET $EXTRACT(X,44)=$$DATE^BDMS9B1($PIECE(Y,"|||",2))
SET $EXTRACT(X,55)=$PIECE(Y,"|||",3)
DO S(X)
+15 SET Z=0
EDUCD DO S(" ")
+1 SET BDMSBEG=$$FMADD^XLFDT(DT,-365)
+2 SET X="Education Provided (in past yr): "
DO S(X)
+3 SET X=" Last Dietitian Visit (ever): "_$$DIETV^BDMS9B3(BDMSDFN)
DO S(X)
+4 SET X=""
+5 KILL BDMX
+6 DO EDUC
+7 IF $DATA(BDMX)
Begin DoDot:1
+8 SET %=""
FOR
SET %=$ORDER(BDMX(%))
IF %=""
QUIT
DO S(" "_BDMX(%))
End DoDot:1
+9 ;I X]"" D S(X)
+10 KILL BDMX,BDMY,%
+11 DO EDUCREF
IF $DATA(BDMX)
SET X="In the past year, the patient has refused the following Diabetes education:"
DO S(X)
Begin DoDot:1
+12 SET %=""
FOR
SET %=$ORDER(BDMX(%))
IF %=""
QUIT
SET X=" "_%_" "_BDMX(%)
DO S(X)
End DoDot:1
+13 KILL BDMR,BDMY,%
+14 QUIT
S(Y,F,C,T) ;set up array
+1 IF '$GET(F)
SET F=0
+2 IF '$GET(T)
SET T=0
+3 NEW %,X
+4 ;blank lines
+5 FOR F=1:1:F
SET X=""
DO S1
+6 SET X=Y
+7 IF $GET(C)
SET L=$LENGTH(Y)
SET T=(80-L)/2
Begin DoDot:1
+8 FOR %=1:1:(T-1)
SET X=" "_X
End DoDot:1
DO S1
QUIT
+9 FOR %=1:1:T
SET X=" "_Y
+10 DO S1
+11 QUIT
S1 ;
+1 SET %=$PIECE(^TMP("APCHS",$JOB,"DCS",0),U)+1
SET $PIECE(^TMP("APCHS",$JOB,"DCS",0),U)=%
+2 SET ^TMP("APCHS",$JOB,"DCS",%)=X
+3 QUIT
EDUC ;EP - gather up all education provided in past year in BDMX
+1 ;
KILL BDMX,BDMY,BDMP
SET %=BDMSDFN_"^ALL EDUC;DURING "_$$DATE^BDMS9B1(BDMSBEG)_"-"_$$DATE^BDMS9B1(DT)
SET E=$$START1^APCLDF(%,"BDMY(")
+2 IF '$DATA(BDMY)
SET BDMX(1)=" <No Education Topics recorded in past year>"
KILL BDMY
QUIT
+3 NEW X
KILL BDMP
SET X=0
SET E=""
FOR
SET X=$ORDER(BDMY(X))
IF X'=+X
QUIT
Begin DoDot:1
+4 SET E=+$PIECE(BDMY(X),U,4)
+5 IF $PIECE(^AUPNVPED(E,0),U,6)=5
QUIT
+6 SET E=$PIECE(^AUPNVPED(E,0),U)
+7 IF '$$EDT(E)
QUIT
+8 SET BDMP($$UP^XLFSTR($PIECE(BDMY(X),U,2)))=$$DATE^BDMS9B1($PIECE(BDMY(X),U))_U_$$EPRV(+$PIECE(BDMY(X),U,4))
End DoDot:1
+9 ;S %=0,E="" F S E=$O(BDMP(E)) Q:E="" S %=%+1,BDMX(%)=$E(E,1,25),$E(BDMX(%),28)=$P(BDMP(E),U,1),$E(BDMX(%),39)=$P(BDMP(E),U,2)
+10 SET E=""
FOR
SET E=$ORDER(BDMP(E))
IF E=""
QUIT
SET BDMX(E)=$EXTRACT(E,1,30)
SET $EXTRACT(BDMX(E),33)=$PIECE(BDMP(E),U,1)
SET $EXTRACT(BDMX(E),45)=$PIECE(BDMP(E),U,2)
+11 KILL BDMY
+12 QUIT
EPRV(I) ;
+1 NEW P,D,%
+2 SET P=$$VALI^XBDIQ1(9000010.16,I,.05)
IF P
SET D=$$PROVCLS^XBFUNC1(P)
SET %=""
SET %=$EXTRACT($PIECE(^VA(200,P,0),U,1),1,18)
SET $EXTRACT(%,24)=$EXTRACT(D,1,15)
QUIT %
+3 SET P=$$VALI^XBDIQ1(9000010.16,I,1204)
IF P
SET D=$$PROVCLS^XBFUNC1(P)
SET %=""
SET %=$EXTRACT($PIECE(^VA(200,P,0),U,1),1,18)
SET $EXTRACT(%,24)=$EXTRACT(D,1,15)
QUIT %
+4 SET P=$$VALI^XBDIQ1(9000010.16,I,1202)
IF P
SET D=$$PROVCLS^XBFUNC1(P)
SET %=""
SET %=$EXTRACT($PIECE(^VA(200,P,0),U,1),1,18)
SET $EXTRACT(%,24)=$EXTRACT(D,1,15)
QUIT %
+5 SET P=$$PRIMPROV^APCLV($PIECE(^AUPNVPED(I,0),U,3),"I")
IF P
SET D=$$PROVCLS^XBFUNC1(P)
SET %=""
SET %=$EXTRACT($PIECE(^VA(200,P,0),U,1),1,18)
SET $EXTRACT(%,20)=$EXTRACT(D,1,15)
+6 QUIT ""
EDUCREF ;EP - gather up all education provided in past year
+1 KILL BDMX,BDMY
+2 SET BDMY=0
FOR
SET BDMY=$ORDER(^AUPNPREF("AA",BDMSPAT,9999999.09,BDMY))
IF BDMY'=+BDMY
QUIT
IF $$EDT(BDMY)
SET BDMD=$ORDER(^AUPNPREF("AA",BDMSPAT,9999999.09,BDMY,0))
IF BDMD<(9999999-BDMSBEG)
Begin DoDot:1
+3 ;already displayed
IF $DATA(BDMP($$UP^XLFSTR($PIECE(^AUTTEDT(BDMY,0),U))))
QUIT
+4 SET BDMX($PIECE(^AUTTEDT(BDMY,0),U))=$$DATE^BDMS9B1(9999999-BDMD)
End DoDot:1
+5 QUIT
EDT(E) ;
+1 ;is this ien in any taxonomy
+2 NEW T,S
+3 SET T=$ORDER(^ATXAX("B","DM AUDIT DIABETES EDUC TOPICS",0))
+4 IF T
IF $DATA(^ATXAX(T,21,"B",E))
QUIT 1
+5 SET T=$ORDER(^ATXAX("B","DM AUDIT DIET EDUC TOPICS",0))
+6 IF T
IF $DATA(^ATXAX(T,21,"B",E))
QUIT 1
+7 SET T=$ORDER(^ATXAX("B","DM AUDIT EXERCISE EDUC TOPICS",0))
+8 IF T
IF $DATA(^ATXAX(T,21,"B",E))
QUIT 1
+9 SET T=$ORDER(^ATXAX("B","DM AUDIT OTHER EDUC TOPICS",0))
+10 IF T
IF $DATA(^ATXAX(T,21,"B",E))
QUIT 1
+11 SET T=$PIECE(^AUTTEDT(E,0),U,2)
+12 IF $PIECE(T,"-")="DM"
QUIT 1
+13 IF $PIECE(T,"-")="DMC"
QUIT 1
+14 IF $PIECE(T,"-")="MNT"
QUIT 1
+15 IF $PIECE(T,"-")="DMCN"
QUIT 1
+16 IF $PIECE(T,"-",2)="EX"
QUIT 1
+17 IF $PIECE(T,"-",2)="N"
QUIT 1
+18 IF $PIECE(T,"-",2)="DT"
QUIT 1
+19 IF $PIECE(T,"-",2)="MNT"
QUIT 1
+20 ;SNOMED
+21 IF $PIECE(T,"-",1)]""
IF $$SNOMED^BDMUTL($$LE(),"PXRM DIABETES",$PIECE(T,"-",1))
QUIT 1
+22 NEW CODE
+23 SET G=""
+24 SET CODE=$PIECE($$CODEN^BDMUTL($PIECE(T,"-",1),80),"~")
+25 IF CODE>0
Begin DoDot:1
+26 NEW TAX
+27 SET TAX=$ORDER(^ATXAX("B","SURVEILLANCE DIABETES",0))
+28 IF $$ICD^BDMUTL(CODE,$PIECE(^ATXAX(TAX,0),U),9)
SET G=1
End DoDot:1
+29 QUIT G
LE() ;EP
+1 NEW A,B
+2 SET B=""
+3 SET A=0
FOR
SET A=$ORDER(^BDMSNME("B",A))
IF A=""
QUIT
SET B=A
+4 QUIT B
TB(P) ;
+1 IF '$GET(P)
QUIT ""
+2 NEW BDMS,E,X
+3 KILL BDMS
+4 SET X=P_"^LAST HEALTH [DM AUDIT TB HEALTH FACTORS"
SET E=$$START1^APCLDF(X,"BDMS(")
+5 IF $DATA(BDMS(1))
QUIT $PIECE($GET(BDMS(1)),U,3)
+6 NEW %,Y
+7 SET %=$ORDER(^ATXAX("B","DM AUDIT TB HEALTH FACTORS",0))
+8 IF '%
QUIT ""
+9 SET (X,Y)=0
FOR
SET X=$ORDER(^AUPNHF("AA",P,X))
IF X'=+X!(Y)
QUIT
IF $DATA(^ATXAX(%,21,"B",X))
SET Y=X
+10 IF 'Y
QUIT ""
+11 QUIT $PIECE(^AUTTHF(Y,0),U)
GFR(P) ;
+1 IF '$GET(P)
QUIT ""
+2 SET BDMC=""
+3 NEW T,T1,T2
+4 SET T=$ORDER(^LAB(60,"B","ESTIMATED GFR",0))
+5 SET T1=$ORDER(^ATXLAB("B","BGP GPRA ESTIMATED GFR TAX",0))
+6 SET T2=$ORDER(^ATXAX("B","BGP ESTIMATED GFR LOINC",0))
+7 NEW D,V,G,X,J
SET (D,G)=0
FOR
SET D=$ORDER(^AUPNVLAB("AE",P,D))
IF D'=+D!(BDMC]"")
QUIT
Begin DoDot:1
+8 SET X=0
FOR
SET X=$ORDER(^AUPNVLAB("AE",P,D,X))
IF X'=+X!(BDMC]"")
QUIT
Begin DoDot:2
+9 SET Y=0
FOR
SET Y=$ORDER(^AUPNVLAB("AE",P,D,X,Y))
IF Y'=+Y
QUIT
Begin DoDot:3
+10 IF '$DATA(^AUPNVLAB(Y,0))
QUIT
+11 ;NO PANELS PER DOROTHY
IF $ORDER(^LAB(60,$PIECE(^AUPNVLAB(Y,0),U,1),2,0))
QUIT
+12 IF T
IF $PIECE(^AUPNVLAB(Y,0),U)=T
Begin DoDot:4
+13 IF BDMC]""
IF $PIECE(^AUPNVLAB(Y,0),U,4)=""
QUIT
+14 SET BDMC=$$LBLK($PIECE(^AUPNVLAB(Y,0),U,4),6)_" "_$PIECE($GET(^AUPNVLAB(Y,11)),U)_"|||"_$PIECE($PIECE(^AUPNVSIT($PIECE(^AUPNVLAB(Y,0),U,3),0),U),".")_"|||"_$EXTRACT($$VAL^XBDIQ1(9000010.09,Y,.01),1,25)_"|||"_
Y
QUIT
End DoDot:4
+15 IF T1
IF $PIECE(^AUPNVLAB(Y,0),U)
IF $DATA(^ATXLAB(T1,21,"B",$PIECE(^AUPNVLAB(Y,0),U)))
Begin DoDot:4
+16 IF BDMC]""
IF $PIECE(^AUPNVLAB(Y,0),U,4)=""
QUIT
+17 SET BDMC=$$LBLK($PIECE(^AUPNVLAB(Y,0),U,4),6)_" "_$PIECE($GET(^AUPNVLAB(Y,11)),U)_"|||"_$PIECE($PIECE(^AUPNVSIT($PIECE(^AUPNVLAB(Y,0),U,3),0),U),".")_"|||"_$EXTRACT($$VAL^XBDIQ1(9000010.09,Y,.01),1,25)_"|
||"_Y
QUIT
End DoDot:4
+18 SET J=$PIECE($GET(^AUPNVLAB(Y,11)),U,13)
IF J=""
QUIT
+19 IF '$$LOINC(J,T2)
QUIT
+20 ;NO PANELS PER DOROTHY
IF $ORDER(^LAB(60,$PIECE(^AUPNVLAB(Y,0),U,1),2,0))
QUIT
+21 SET BDMC=$$LBLK($PIECE(^AUPNVLAB(Y,0),U,4),6)_" "_$PIECE($GET(^AUPNVLAB(Y,11)),U)_"|||"_$PIECE($PIECE(^AUPNVSIT($PIECE(^AUPNVLAB(Y,0),U,3),0),U),".")_"|||"_$EXTRACT($$VAL^XBDIQ1(9000010.09,Y,.01),1,25)_"|||"_Y
+22 QUIT
End DoDot:3
End DoDot:2
End DoDot:1
+23 IF BDMC]""
QUIT BDMC
+24 SET T=$ORDER(^ATXLAB("B","BGP GPRA ESTIMATED GFR TAX",0))
IF 'T
QUIT ""
+25 QUIT $$LAB(P,T)
CHOL(P) ;EP
+1 IF '$GET(P)
QUIT ""
+2 NEW T
SET T=$ORDER(^ATXLAB("B","DM AUDIT LDL CHOLESTEROL TAX",0))
SET LT=$ORDER(^ATXAX("B","BGP LDL LOINC CODES",0))
IF 'T
QUIT "<Taxonomy Missing>"
+3 QUIT $$LAB(P,T,LT)
HDL(P) ;EP
+1 IF '$GET(P)
QUIT ""
+2 NEW T
SET T=$ORDER(^ATXLAB("B","DM AUDIT HDL TAX",0))
SET LT=$ORDER(^ATXAX("B","BGP HDL LOINC CODES",0))
IF 'T
QUIT "<Taxonomy Missing>"
+3 QUIT $$LAB(P,T,LT)
TCHOL(P) ;EP
+1 IF '$GET(P)
QUIT ""
+2 NEW T
SET T=$ORDER(^ATXLAB("B","DM AUDIT CHOLESTEROL TAX",0))
SET LT=$ORDER(^ATXAX("B","BGP TOTAL CHOLESTEROL LOINC",0))
IF 'T
QUIT "<Taxonomy Missing>"
+3 QUIT $$LAB(P,T,LT)
NONHDL(P) ;
+1 NEW V,D,TC,HDL,TCD,HDLD,NT
+2 IF '$GET(P)
QUIT ""
+3 SET V=""
+4 NEW T
SET T=$ORDER(^ATXLAB("B","DM AUDIT CHOLESTEROL TAX",0))
SET LT=$ORDER(^ATXAX("B","BGP TOTAL CHOLESTEROL LOINC",0))
IF 'T
QUIT "<Taxonomy Missing>"
+5 SET TC=$$LAB(P,T,LT)
SET TCD=$PIECE(TC,"|||",2)
SET TC=$$STRIP^XLFSTR($PIECE(TC,"|||")," ")
+6 IF TC=""
QUIT V
+7 IF TCD<$PIECE(V,"|||",2)
QUIT V
+8 SET T=$ORDER(^ATXLAB("B","DM AUDIT HDL TAX",0))
SET LT=$ORDER(^ATXAX("B","BGP HDL LOINC CODES",0))
IF 'T
QUIT "<Taxonomy Missing>"
+9 SET HDL=$$LAB(P,T,LT)
SET HDLD=$PIECE(HDL,"|||",2)
SET HDL=$$STRIP^XLFSTR($PIECE(HDL,"|||")," ")
+10 IF HDL=""
QUIT V
+11 IF HDLD<$PIECE(V,"|||",2)
QUIT V
+12 SET TC=+TC
SET HDL=+HDL
+13 IF 'TC
QUIT ""
+14 IF 'HDL
QUIT ""
+15 QUIT $$LBLK(TC-HDL,6)_"|||"_TCD_"|||[Calculated Value]"
TRIG(P) ;EP
+1 IF '$GET(P)
QUIT ""
+2 NEW T
SET T=$ORDER(^ATXLAB("B","DM AUDIT TRIGLYCERIDE TAX",0))
SET LT=$ORDER(^ATXAX("B","BGP TRIGLYCERIDE LOINC CODES",0))
IF 'T
QUIT "<Taxonomy Missing>"
+3 QUIT $$LAB(P,T,LT)
CREAT(P) ;
+1 IF '$GET(P)
QUIT ""
+2 NEW T
SET T=$ORDER(^ATXLAB("B","DM AUDIT CREATININE TAX",0))
SET LT=$ORDER(^ATXAX("B","BGP CREATININE LOINC CODES",0))
IF 'T
QUIT "<Taxonomy Missing>"
+3 QUIT $$LAB(P,T,LT)
+4 ;
PCR(P) ;EP
+1 IF '$GET(P)
QUIT ""
+2 NEW T
SET T=$ORDER(^ATXLAB("B","DM AUDIT P/C RATIO TAX",0))
SET LT=$ORDER(^ATXAX("B","DM AUDIT P/C RATIO LOINC",0))
IF 'T
QUIT "<Taxonomy Missing>"
+3 QUIT $$LAB(P,T,LT,1)
LAB(P,T,LT,YEAR) ;EP
+1 IF '$GET(LT)
SET LT=""
+2 SET YEAR=$GET(YEAR)
+3 NEW BDATE
+4 SET BDATE=$SELECT(YEAR:$$FMADD^XLFDT(DT,-365),1:$$DOB^AUPNPAT(P))
+5 NEW D,V,G,X,J
SET (D,G)=0
FOR
SET D=$ORDER(^AUPNVLAB("AE",P,D))
IF D'=+D!(G)
QUIT
Begin DoDot:1
+6 SET X=0
FOR
SET X=$ORDER(^AUPNVLAB("AE",P,D,X))
IF X'=+X!(G)
QUIT
Begin DoDot:2
+7 IF (9999999-D)<BDATE
QUIT
+8 SET Y=0
FOR
SET Y=$ORDER(^AUPNVLAB("AE",P,D,X,Y))
IF Y'=+Y!(G)
QUIT
Begin DoDot:3
+9 IF $DATA(^ATXLAB(T,21,"B",X))
IF $PIECE(^AUPNVLAB(Y,0),U,4)]""
SET G=Y
QUIT
+10 IF 'LT
QUIT
+11 SET J=$PIECE($GET(^AUPNVLAB(Y,11)),U,13)
IF J=""
QUIT
+12 IF '$$LOINC(J,LT)
QUIT
+13 SET G=Y
+14 QUIT
End DoDot:3
+15 QUIT
End DoDot:2
+16 QUIT
End DoDot:1
+17 IF 'G
QUIT ""
+18 SET R=$$LBLK($PIECE(^AUPNVLAB(G,0),U,4),6)_" "_$PIECE($GET(^AUPNVLAB(G,11)),U)_"|||"
+19 SET R=R_$PIECE($PIECE($GET(^AUPNVSIT($PIECE(^AUPNVLAB(G,0),U,3),0)),U),".")_"|||"_$EXTRACT($$VAL^XBDIQ1(9000010.09,G,.01),1,25)_"|||"_$$REF(P,T,$PIECE($PIECE($GET(^AUPNVSIT($PIECE(^AUPNVLAB(G,0),U,3),0)),U),"."))_"|||"_G
+20 QUIT R
LOINC(A,B) ;EP
+1 NEW %
+2 SET %=$PIECE($GET(^LAB(95.3,A,9999999)),U,2)
+3 IF %]""
IF $DATA(^ATXAX(B,21,"B",%))
QUIT 1
+4 SET %=$PIECE($GET(^LAB(95.3,A,0)),U)_"-"_$PIECE($GET(^LAB(95.3,A,0)),U,15)
+5 IF $DATA(^ATXAX(B,21,"B",%))
QUIT 1
+6 QUIT ""
DATE(D) ;EP - convert to slashed date
+1 IF $GET(D)=""
QUIT ""
+2 QUIT $EXTRACT(D,4,5)_"/"_$EXTRACT(D,6,7)_"/"_$EXTRACT(D,2,3)
REF(P,T,D) ;return refusal string after date D for test is tax T
+1 IF '$GET(P)
QUIT ""
+2 IF '$GET(T)
QUIT ""
+3 IF '$GET(D)
SET D=""
+4 NEW BDMREF,BDMT,V
SET BDMT=0
FOR
SET BDMT=$ORDER(^ATXLAB(T,21,"B",BDMT))
IF BDMT'=+BDMT
QUIT
Begin DoDot:1
+5 SET V=$$REF1(P,60,BDMT,D)
IF V]""
SET BDMREF(9999999-$PIECE(V,U,3))=V
End DoDot:1
+6 IF $DATA(BDMREF)
SET %=0
SET %=$ORDER(BDMREF(%))
IF %
SET V=BDMREF(%)
QUIT V
+7 QUIT ""
REF1(P,F,I,D,T) ; ;
+1 IF '$GET(P)
QUIT ""
+2 IF '$GET(F)
QUIT ""
+3 IF '$GET(I)
QUIT ""
+4 IF $GET(D)=""
SET D=""
+5 IF $GET(T)=""
SET T="E"
+6 NEW X,N
SET X=$ORDER(^AUPNPREF("AA",P,F,I,0))
+7 IF 'X
QUIT ""
+8 SET N=$ORDER(^AUPNPREF("AA",P,F,I,X,0))
+9 NEW Y
SET Y=9999999-X
+10 IF D]""
IF Y>D
QUIT $SELECT(T="I":Y,1:$$TYPEREF(N)_"-"_$$DATE(Y))
+11 ;quit on internal form of date
IF T="I"
QUIT Y
+12 QUIT $$TYPEREF(N)_"-"_$$DATE(Y)
+13 ;
TYPEREF(N) ;
+1 NEW %
SET %=$PIECE(^AUPNPREF(N,0),U,7)
+2 IF %="R"!(%="")
QUIT "Refused"
+3 IF %="N"
QUIT "Not Med Ind"
+4 IF %="F"
QUIT "No Resp to F/U"
+5 QUIT ""
NLHGB(P) ;return next to last HGBA1C
+1 IF '$GET(P)
QUIT ""
+2 NEW T
SET T=$ORDER(^ATXLAB("B","DM AUDIT HGB A1C TAX",0))
IF 'T
QUIT "<Taxonomy Missing>"
+3 NEW LT
SET LT=$ORDER(^ATXAX("B","BGP HGBA1C LOINC CODES",0))
+4 NEW D,V,G,X,E
SET (D,G)=0
SET E=""
FOR
SET D=$ORDER(^AUPNVLAB("AE",P,D))
IF D'=+D!(G=2)
QUIT
Begin DoDot:1
+5 SET X=0
FOR
SET X=$ORDER(^AUPNVLAB("AE",P,D,X))
IF X'=+X!(G=2)
QUIT
Begin DoDot:2
+6 SET Y=0
FOR
SET Y=$ORDER(^AUPNVLAB("AE",P,D,X,Y))
IF Y'=+Y!(G=2)
QUIT
Begin DoDot:3
+7 IF $DATA(^ATXLAB(T,21,"B",X))
IF $PIECE(^AUPNVLAB(Y,0),U,4)]""
SET G=G+1
SET E=Y
QUIT
+8 IF 'LT
QUIT
+9 SET J=$PIECE($GET(^AUPNVLAB(Y,11)),U,13)
IF J=""
QUIT
+10 IF '$$LOINC(J,LT)
QUIT
+11 SET G=G+1
SET E=Y
+12 QUIT
End DoDot:3
+13 QUIT
End DoDot:2
+14 QUIT
End DoDot:1
+15 IF G'=2
QUIT ""
+16 IF 'E
QUIT ""
+17 QUIT $$LBLK($PIECE(^AUPNVLAB(E,0),U,4),6)_" "_$PIECE($GET(^AUPNVLAB(E,11)),U)_"|||"_$PIECE($PIECE(^AUPNVSIT($PIECE(^AUPNVLAB(E,0),U,3),0),U),".")_"|||"_$EXTRACT($$VAL^XBDIQ1(9000010.09,E,.01),1,25)
HBA1C(P) ;
+1 IF '$GET(P)
QUIT ""
+2 NEW T
SET T=$ORDER(^ATXLAB("B","DM AUDIT HGB A1C TAX",0))
SET LT=$ORDER(^ATXAX("B","BGP HGBA1C LOINC CODES",0))
IF 'T
QUIT "<Taxonomy Missing>"
+3 QUIT $$LAB(P,T,LT)
URIN(P) ;
+1 IF '$GET(P)
QUIT ""
+2 NEW T
SET T=$ORDER(^ATXLAB("B","DM AUDIT URINE PROTEIN TAX",0))
SET LT=$ORDER(^ATXAX("B","DM AUDIT URINE PROTEIN LOINC",0))
IF 'T
QUIT "<Taxonomy Missing>"
+3 QUIT $$LAB(P,T,LT,1)
MICRO(P) ;
+1 IF '$GET(P)
QUIT ""
+2 NEW T
SET T=$ORDER(^ATXLAB("B","DM AUDIT MICROALBUMINURIA TAX",0))
SET LT=$ORDER(^ATXAX("B","DM AUDIT MICROALBUMIN LOINC",0))
IF 'T
QUIT "<Taxonomy Missing>"
+3 QUIT $$LAB(P,T,LT,1)
ACRATIO(P) ;
+1 IF '$GET(P)
QUIT ""
+2 NEW T
SET T=$ORDER(^ATXLAB("B","DM AUDIT QUANT UACR",0))
SET LT=$ORDER(^ATXAX("B","DM AUDIT A/C RATIO LOINC",0))
IF 'T
QUIT "<Taxonomy Missing>"
+3 QUIT $$LAB(P,T,LT)
HR24(P) ;
+1 IF '$GET(P)
QUIT ""
+2 NEW T
SET T=$ORDER(^ATXLAB("B","DM AUDIT 24HR URINE PROTEIN",0))
SET LT=""
IF 'T
QUIT "<Taxonomy Missing>"
+3 QUIT $$LAB(P,T,LT,1)
SEMI(P) ;
+1 IF '$GET(P)
QUIT ""
+2 NEW T
SET T=$ORDER(^ATXLAB("B","DM AUDIT SEMI QUANT UACR",0))
SET LT=""
IF 'T
QUIT "<Taxonomy Missing>"
+3 QUIT $$LAB(P,T,LT,1)
LBLK(V,L) ;EP LEFT blank fill
+1 NEW %,I
+2 SET %=$LENGTH(V)
SET Z=L-%
FOR I=1:1:Z
SET V=" "_V
+3 QUIT V
LDLLAB ;EP
+1 KILL BDMX
+2 NEW LT
SET LT=$ORDER(^ATXAX("B","BGP LDL LOINC CODES",0))
+3 NEW D,V,X,G
SET (D,G)=0
FOR
SET D=$ORDER(^AUPNVLAB("AE",BDMSPAT,D))
IF D'=+D!(G>2)
QUIT
Begin DoDot:1
+4 SET X=0
FOR
SET X=$ORDER(^AUPNVLAB("AE",BDMSPAT,D,X))
IF X'=+X!(G>2)
QUIT
Begin DoDot:2
+5 SET Y=0
FOR
SET Y=$ORDER(^AUPNVLAB("AE",BDMSPAT,D,X,Y))
IF Y'=+Y!(G>2)
QUIT
Begin DoDot:3
+6 IF '$DATA(^AUPNVLAB(Y,0))
QUIT
+7 IF $PIECE(^AUPNVLAB(Y,0),U,4)=""
QUIT
+8 IF Y=BDMIEN
QUIT
+9 IF $DATA(^ATXLAB(T,21,"B",X))
Begin DoDot:4
+10 SET R=$PIECE(^AUPNVLAB(Y,0),U,4)
IF R'=+R
QUIT
+11 SET BDMX(Y)=R_"^"_(9999999-D)
SET G=G+1
End DoDot:4
QUIT
+12 IF 'LT
QUIT
+13 SET J=$PIECE($GET(^AUPNVLAB(Y,11)),U,13)
IF J=""
QUIT
+14 IF '$$LOINC(J,LT)
QUIT
+15 SET R=$PIECE(^AUPNVLAB(Y,0),U,4)
IF R'=+R
QUIT
+16 SET BDMX(Y)=R_"^"_(9999999-D)
SET G=G+1
+17 QUIT
End DoDot:3
+18 QUIT
End DoDot:2
+19 QUIT
End DoDot:1
+20 QUIT
