BDMDG1D ; IHS/CMI/LAB - BDM Continuation of BDMDG1C 1/11/2014 1:54:57 PM ;
;;2.0;DIABETES MANAGEMENT SYSTEM;**12**;JUN 14, 2007;Build 51
;
;
;
MICRO ;EP
NEW BDM,X,%,E,R,V,BDMLT,BDMOT,B,D,L,J,BDMC,BDMV,V
K BDM S BDMC=0
S BDMOT=$O(^ATXAX("B","DM AUDIT MICROALBUMIN LOINC",0))
S BDMLT=$O(^ATXLAB("B","DM AUDIT MICROALBUMINURIA TAX",0))
S B=9999999-BDATE,E=9999999-EDATE S D=E-1 F S D=$O(^AUPNVLAB("AE",P,D)) Q:D'=+D!(D>B) 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))
...I BDMLT,$P(^AUPNVLAB(X,0),U),$D(^ATXLAB(BDMLT,21,"B",$P(^AUPNVLAB(X,0),U))) D SETV Q
...Q:'BDMOT
...S J=$P($G(^AUPNVLAB(X,11)),U,13) Q:J=""
...Q:'$$LOINC(J,BDMOT)
...D SETV
...Q
I '$D(BDM(1)) S %1="" D ACRATIOM^BDMDG1C Q %1
D SETN
NEW % S %=$P(^AUPNVLAB(+$P(BDM(N),U,4),0),U,4)
S %1=$S(%="":"No result",%["+":"Pos ",%[">":"Pos ",$E(%)="P":"Pos ",$E(%)="p":"Pos ",$E(%)="c":"No result ",$E(%)="C":"No result ",+%>29:"Pos ",1:"Neg ")
Q %1_%_" "_$$FMTE^XLFDT($P(BDM(N),U),"5")_" "_$P(BDM(N),U,3)
HGBA1C ;EP
NEW BDM,X,%,E,R,V,BDMLT,BDMOT,B,D,L,J,BDMC,BDMV,V,G
K BDM
S BDMC=0
S BDMOT=$O(^ATXAX("B","BGP HGBA1C LOINC CODES",0))
S BDMLT=$O(^ATXLAB("B","DM AUDIT HGB A1C TAX",0))
S B=9999999-BDATE,E=9999999-EDATE S D=E-1 F S D=$O(^AUPNVLAB("AE",P,D)) Q:D'=+D!(D>B) 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)="" ;no result
...Q:$$UP^XLFSTR($P(^AUPNVLAB(X,0),U,4))["CANC"
...Q:$$UP^XLFSTR($P(^AUPNVLAB(X,0),U,4))["COMMENT"
...I BDMLT,$P(^AUPNVLAB(X,0),U),$D(^ATXLAB(BDMLT,21,"B",$P(^AUPNVLAB(X,0),U))) D SETV Q
...Q:'BDMOT
...S J=$P($G(^AUPNVLAB(X,11)),U,13) Q:J=""
...Q:'$$LOINC(J,BDMOT)
...D SETV
...Q
D SET3
;K X S (%,C,R)="" F S %=$O(BDM(%)) Q:%'=+%!(C>1) S C=C+1,X(9999999-$P(BDM(%),U),C)=$P(^AUPNVLAB(+$P(BDM(%),U,4),0),U,4)
;S %=0,R="" F S %=$O(X(%)) Q:%="" S V=0 F S V=$O(X(%,V)) Q:V="" S R=R_X(%,V)_"^"_$$FMTE^XLFDT(9999999-%)_"^"_(9999999-%)_"^"
;separate those with a result and those without a result
;first put in reverse date order
S (N,C,R)=""
K BDMR
F S N=$O(BDM(N)) Q:N'=+N D
.S D=$P(BDM(N),U)
.S R=$P(BDM(N),U,2) I R="?" S R=""
.I R]"" S BDMR("R",(9999999-D),N)=BDM(N)
.I R="" S BDMR("NR",(9999999-D),N)=BDM(N)
S R=""
S D=0 F S D=$O(BDMR("R",D)) Q:D'=+D!(R]"") D
.S N=0 F S N=$O(BDMR("R",D,N)) Q:N'=+N!(R]"") D
..S R=BDMR("R",D,N)
I R]"" Q R
S D=0 F S D=$O(BDMR("NR",D)) Q:D'=+D!(R]"") D
.S N=0 F S N=$O(BDMR("NR",D,N)) Q:N'=+N!(R]"") D
..S R=BDMR("NR",D,N)
Q R
BS ;EP
NEW BDM,X,%,E,R,V,C
K BDM
S %=P_"^LAST 200 LAB [DM AUDIT GLUCOSE TESTS TAX;DURING "_BDATE_"-"_EDATE,E=$$START1^APCLDF(%,"BDM(")
I '$D(BDM(1)) Q ""
D SET3
S (%,C,R)="" F S %=$O(BDM(%)) Q:%=""!(C>2) S R=R_$P(^AUPNVLAB(+$P(BDM(%),U,4),0),U,4)_$S($P(^AUPNVLAB(+$P(BDM(%),U,4),0),U,4)]"":" mg/dl ",1:"")_$$FMTE^XLFDT($P(BDM(%),U))_"^",C=C+1
Q R
;
FGLUCOSE ;EP
I $G(F)="" S F="E"
NEW BDM,X,%,E,R,V,BDMLT,BDMOT,B,D,L,J,BDMC,BDMV,V
K BDM
S BDMC=0
S BDMOT=$O(^ATXAX("B","DM AUDIT FASTING GLUC LOINC",0))
S BDMLT=$O(^ATXLAB("B","DM AUDIT FASTING GLUCOSE TESTS",0))
D GATHER
I '$D(BDM(1)) Q ""
D SETN
I F="I" Q $P(^AUPNVLAB(+$P(BDM(N),U,4),0),U,4)_"^"_$P(BDM(N),U)
Q $P(^AUPNVLAB(+$P(BDM(N),U,4),0),U,4)_$S($P(^AUPNVLAB(+$P(BDM(N),U,4),0),U,4)]"":" mg/dl ",1:"")_$$FMTE^XLFDT($P(BDM(N),U),5)
G75 ;EP
I $G(F)="" S F="E"
NEW BDM,X,%,E,R,V,BDMLT,BDMOT,B,D,L,J,BDMC,BDMV,V
K BDM
S BDMC=0
S BDMOT=$O(^ATXAX("B","DM AUDIT 75GM 2HR LOINC",0))
S BDMLT=$O(^ATXLAB("B","DM AUDIT 75GM 2HR GLUCOSE",0))
D GATHER
I '$D(BDM(1)) Q ""
D SETN
I F="I" Q $P(^AUPNVLAB(+$P(BDM(N),U,4),0),U,4)_"^"_$P(BDM(N),U)
Q $P(^AUPNVLAB(+$P(BDM(N),U,4),0),U,4)_$S($P(^AUPNVLAB(+$P(BDM(N),U,4),0),U,4)]"":" mg/dl ",1:"")_$$FMTE^XLFDT($P(BDM(N),U),5)
;
GATHER ;
S B=9999999-BDATE,E=9999999-EDATE S D=E-1 F S D=$O(^AUPNVLAB("AE",P,D)) Q:D'=+D!(D>B)!($D(BDM)) 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))
...I BDMLT,$P(^AUPNVLAB(X,0),U),$D(^ATXLAB(BDMLT,21,"B",$P(^AUPNVLAB(X,0),U))) D SETV Q
...Q:'BDMOT
...S J=$P($G(^AUPNVLAB(X,11)),U,13) Q:J=""
...Q:'$$LOINC(J,BDMOT)
...D SETV
...Q
I '$D(BDM(1)) Q
S D=$P(BDM(1),U),D=9999999-D
K BDM S BDMC=0
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))
..I BDMLT,$P(^AUPNVLAB(X,0),U),$D(^ATXLAB(BDMLT,21,"B",$P(^AUPNVLAB(X,0),U))) D SETV Q
..Q:'BDMOT
..S J=$P($G(^AUPNVLAB(X,11)),U,13) Q:J=""
..Q:'$$LOINC(J,BDMOT)
..D SETV
..Q
Q
LOINC(A,B) ;EP - is loinc code A in taxonomy B
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 ""
SETV ;
S BDMC=BDMC+1
S V=$P(^AUPNVLAB(X,0),U,3),BDMV=$P($P($G(^AUPNVSIT(V,0)),U),".") Q:'BDMV
S BDM(BDMC)=BDMV_"^"_$S($P(^AUPNVLAB(X,0),U,4)]"":$P(^AUPNVLAB(X,0),U,4),1:"")_"^"_$$VAL^XBDIQ1(9000010.09,X,.01)_"^"_X_";AUPNVLAB^"_V
Q
SETN ;
S N="" NEW A,G S (A,G)=0 F S A=$O(BDM(A)) Q:A'=+A!(G) S R=$P(^AUPNVLAB(+$P(BDM(A),U,4),0),U,4) I R]"",$$UP^XLFSTR(R)'="COMMENT" S G=A
S N=$S(G:G,1:1)
Q
SET3 ;
NEW X,N1,N2,N3,A,T,G,N
K A
S X=0 F S X=$O(BDM(X)) Q:X'=+X S A($P(BDM(X),U),X)=""
NEW D S D=0 F S D=$O(A(D)) Q:D'=+D D
.S G=0,N=0 F S N=$O(A(D,N)) Q:N'=+N D
..I $P(^AUPNVLAB(+$P(BDM(N),U,4),0),U,4)]"",$$UP^XLFSTR($P(^AUPNVLAB(+$P(BDM(N),U,4),0),U,4))'="COMMENT" S G=1 Q
.I G S N=0 F S N=$O(A(D,N)) Q:N'=+N I $P(^AUPNVLAB(+$P(BDM(N),U,4),0),U,4)="" K BDM(N)
.Q
Q
ASPIRIN ;EP
NEW X,BDM,E,A,N,G,T,T1,O,B,%
S (A,B,G,N,D)=""
S X=P_"^LAST MEDS [DM AUDIT ASPIRIN DRUGS"_";DURING "_BDATE_"-"_EDATE S E=$$START1^APCLDF(X,"BDM(")
I $D(BDM(1)) S A=1 S D=$$DATE^BDMS9B1($P(BDM(1),U))_" "_$P(BDM(1),U,3)
K BDM S X=P_"^LAST MEDS [DM AUDIT ANTIPLT/ANTICOAG RX"_";DURING "_BDATE_"-"_EDATE S E=$$START1^APCLDF(X,"BDM(")
I $D(BDM(1)) S N=1 S D=$$DATE^BDMS9B1($P(BDM(1),U))_" "_$P(BDM(1),U,3)
K BDM S X=P_"^LAST MEDS [DM AUDIT ANTI-PLATELET DRUGS"_";DURING "_BDATE_"-"_EDATE S E=$$START1^APCLDF(X,"BDM(")
I $D(BDM(1)) S N=1 S D=$$DATE^BDMS9B1($P(BDM(1),U))_" "_$P(BDM(1),U,3)
I A Q "1 Yes "_D
I N Q "1 Yes "_D
S T=$O(^ATXAX("B","DM AUDIT ASPIRIN DRUGS",0))
S T1=$O(^ATXAX("B","DM AUDIT ANTIPLT/ANTICOAG RX",0))
S X=0,%="" F S X=$O(^PS(55,P,"NVA",X)) Q:X'=+X!(%]"") D
.I $P($G(^PS(55,P,"NVA",X,999999911)),U,1),$D(^AUPNVMED($P(^PS(55,P,"NVA",X,999999911),U,1),0)) Q ;got this with V MED
.S L=$P($P($G(^PS(55,P,"NVA",X,0)),U,10),".")
.Q:$P(^PS(55,P,"NVA",X,0),U,6)=1 ;discontinued
.I $P(^PS(55,P,"NVA",X,0),U,7)]"",$P(^PS(55,P,"NVA",X,0),U,7)<EDATE Q ;discontinued date
.Q:$P(^PS(55,P,"NVA",X,0),U,9)>EDATE ;
.S D=$P(^PS(55,P,"NVA",X,0),U,2)
.I D S G=0 D
..I $D(^ATXAX(T,21,"B",D)) S G=1
..I $D(^ATXAX(T1,21,"B",D)) S G=1
.I D,G S %="1 Yes - NVA MED - "_$P(^PSDRUG(D,0),U,1) Q
.S O=$P(^PS(55,P,"NVA",X,0),U,1)
.Q:O=""
.S O=$P($G(^PS(50.7,O,0)),U,1)
.Q:O=""
.I $E(O,1,7)="ASPIRIN",$E(O,8)'="/" S %="1 Yes - NVA MED - "_O Q
I %]"" Q %
K %DT S %DT="P",X=EDATE D ^%DT S ED=Y
S BDM=$$PRESD^BDMDG18(P,$O(^ATXAX("B","DM AUDIT ASPIRIN DRUGS",0)),ED,186)
I BDM]"" Q BDM
S BDM=$$PRESD^BDMDG18(P,$O(^ATXAX("B","DM AUDIT ANTIPLT/ANTICOAG RX",0)),ED,186)
I BDM]"" Q BDM
S BDM=$$PRESD^BDMDG18(P,$O(^ATXAX("B","DM AUDIT ANTI-PLATELET DRUGS",0)),ED,186)
I BDM]"" Q BDM
Q "2 No"
;
;
HEPCDX(P,EDATE) ;EP - dx of HEP C ever?
NEW T,X,G
S X=$$LASTDXT^BDMAPIU(P,$$DOB^AUPNPAT(P),EDATE,"BGP HEPATITIS C DXS","E")
I X Q "1 Yes - "_$$DATE^BDMS9B1($P(X,U,1))_" "_$P(X,U,2)
;now check problem list
S T=$O(^ATXAX("B","BGP HEPATITIS C DXS",0))
S (X,G)=0 F S X=$O(^AUPNPROB("AC",P,X)) Q:X'=+X!(G) D
.Q:$P(^AUPNPROB(X,0),U,8)>EDATE ;if added to pl after end of time period, no go
.S Y=$P(^AUPNPROB(X,0),U)
.Q:$P(^AUPNPROB(X,0),U,12)="D"
.;Q:$P(^AUPNPROB(X,0),U,12)="I"
.I $$ICD^BGP8UTL2(Y,T,9) S G="1 Yes - "_"Problem List "_$$VAL^XBDIQ1(9000011,X,.01)_" "_$$DATE^BDMS9B1($P(^AUPNPROB(X,0),U,8)) Q
.I $P($G(^AUPNPROB(X,800)),U,1)]"",$$SNOMED^BDMUTL(2019,"PXRM HEPATITIS C",$P(^AUPNPROB(X,800),U,1)) S G=1
.Q
I G Q G
Q "2 No"
HEPSCR(P,EDATE) ;
I $E($$HEPCDX(P,EDATE))=1 Q "" ;HAS DX
NEW D
S D=$$DOB^AUPNPAT(P)
;I D<2450101 Q "3 Not born 1945-1965"
;I D>2651231 Q "3 Not born 1945-1965"
NEW X,G,T,%,BGPC,BGPLT,L,D,J,R,Y
;now get all loinc/taxonomy tests
S BGPC=""
S T=$O(^ATXAX("B","BGP HEP C TEST LOINC CODES",0))
S BGPLT=$O(^ATXLAB("B","BGP HEP C TESTS TAX",0))
S E=9999999-EDATE S D=E-1 F S D=$O(^AUPNVLAB("AE",P,D)) Q:D'=+D!(BGPC) D
.S L=0 F S L=$O(^AUPNVLAB("AE",P,D,L)) Q:L'=+L!(BGPC) D
..S X=0 F S X=$O(^AUPNVLAB("AE",P,D,L,X)) Q:X'=+X!(BGPC) D
...Q:'$D(^AUPNVLAB(X,0))
...I BGPLT,$P(^AUPNVLAB(X,0),U),$D(^ATXLAB(BGPLT,21,"B",$P(^AUPNVLAB(X,0),U))) D
....S BGPC="1 Yes "_$$DATE^BDMS9B1((9999999-D))_" "_$$VAL^XBDIQ1(9000010.09,X,.01) I $$VAL^XBDIQ1(9000010.09,X,.04)]"" S BGPC=BGPC_" ("_$$VAL^XBDIQ1(9000010.09,X,.04)_")" Q
...Q:'T
...S J=$P($G(^AUPNVLAB(X,11)),U,13) Q:J=""
...Q:'$$LOINC(J,T)
...S BGPC="1 Yes - "_$$DATE^BDMS9B1((9999999-D))_" "_$$VAL^XBDIQ1(9000010.09,X,.01) I $$VAL^XBDIQ1(9000010.09,X,.04)]"" S BGPC=BGPC_" ("_$$VAL^XBDIQ1(9000010.09,X,.04)_")"
...Q
I BGPC Q BGPC
S %="",E=+$$CODEN^ICPTCOD(86803),%=$$CPTI^BDMDGDU(P,$$DOB^AUPNPAT(P),EDATE,E)
I % Q "1 Yes - "_$$DATE^BDMS9B1($P(%,U,2))_" CPT 86803 "_$P($$CPT^ICPTCOD(E,$P(%,U,2)),U,3)
Q "2 No"
DMRETDX(P,EDATE) ;EP - is DM RETINOPATHY on problem list
I '$G(P) Q ""
I '$D(^DPT(P)) Q ""
NEW %,BDM,E,X,T,G,Y,D,I,S
S T=$O(^ATXAX("B","BGP DM RETINOPATHY DX",0))
S (X,G)=0 F S X=$O(^AUPNPROB("AC",P,X)) Q:X'=+X!(G) D
.Q:'$D(^AUPNPROB(X,0)) ;bad xref
.Q:$P(^AUPNPROB(X,0),U,8)>EDATE ;if added to pl after end of time period, no go
.S Y=$P(^AUPNPROB(X,0),U)
.Q:$P(^AUPNPROB(X,0),U,12)="I"
.Q:$P(^AUPNPROB(X,0),U,12)="D"
.I $$ICD^BDMUTL(Y,$P(^ATXAX(T,0),U),9) S G=X Q
.I $P($G(^AUPNPROB(X,800)),U,1)]"" D
..I $$SNOMED^BDMUTL(2019,"PXRM BGP DM RETINOPATHY",$P(^AUPNPROB(X,800),U,1)) S G=X
.Q
I G Q "1 Yes - Problem List "
K BDM
S X=P_"^LAST 1 DX ["_$P(^ATXAX(T,0),U,1)_";DURING "_$$DOB^AUPNPAT(P)_"-"_EDATE S E=$$START1^APCLDF(X,"BDM(")
I $D(BDM(1)) S Y=$$DATE^BDMS9B1($P(BDM(1),U,1)) Q "1 Yes - DX "_Y
;CHECK V POV SNOMED USING A
S G="",I=""
S S="" F S S=$O(^AUPNVPOV("ASNC",P,S)) Q:S=""!(G) D
.S I=0
.I $$SNOMED^BDMUTL(2019,"PXRM BGP DM RETINOPATHY",S) S I=1
.Q:'I
.S D=0 F S D=$O(^AUPNVPOV("ASNC",P,S,D)) Q:D=""!(G) D
..S Y=9999999-D
..Q:Y>EDATE
..S G=1
I G Q "1 Yes - "_$$DATE^BDMS9B1(Y)_" SNOMED: "_S
Q "2 No"
SNO(%) ;
NEW B,C
S B=$O(^BDMSNME("B",2019,0))
I 'B Q ""
S C=$O(^BDMSNME(B,11,"B",%,0))
I 'C Q ""
S C=$O(^BDMSNME(B,11,%,0))
I C Q 1
Q ""
LEAMP(P,EDATE,F) ;EP - dx of AMP ever?
I '$G(F) S F=1
;F=1 audit data format
;F=2 Yes or No only
NEW T,X,G,I,S,D,Y,T1
S X=""
I $O(^ATXAX("B","BGP DM BTK AMP DXS",0)) S X=$$LASTDXT^BDMAPIU(P,$$DOB^AUPNPAT(P),EDATE,"BGP DM BTK AMP DXS","E")
I X Q $S(F=1:"1 Yes - "_$$DATE^BDMS9B1($P(X,U,1))_" "_$P(X,U,2),1:"Yes")
I $O(^ATXAX("B","BGP DM ATK AMP DXS",0)) S X=$$LASTDXT^BDMAPIU(P,$$DOB^AUPNPAT(P),EDATE,"BGP DM ATK AMP DXS","E")
I X Q $S(F=1:"1 Yes - "_$$DATE^BDMS9B1($P(X,U,1))_" "_$P(X,U,2),1:"Yes")
;CHECK V POV SNOMED USING A
S G="",I=""
S S="" F S S=$O(^AUPNVPOV("ASNC",P,S)) Q:S=""!(G) D
.S I=0
.I $$SNOMED^BDMUTL(2019,"PXRM BGP DM BTK AMP",S) S I=1
.I $$SNOMED^BDMUTL(2019,"PXRM BGP DM ATK AMP",S) S I=1
.Q:'I
.S D=0 F S D=$O(^AUPNVPOV("ASNC",P,S,D)) Q:D=""!(G) D
..S Y=9999999-D
..Q:Y>EDATE
..S G=1
I G Q $S(F=1:"1 Yes - "_$$DATE^BDMS9B1(Y)_" SNOMED: "_S,1:"Yes")
S X=""
I $O(^ATXAX("B","BGP DM BTK AMP PROCS",0)) S X=$$LASTPRCT^BDMAPIU(P,$$DOB^AUPNPAT(P),EDATE,"BGP DM BTK AMP PROCS","E")
I X Q $S(F=1:"1 Yes - "_$$DATE^BDMS9B1($P(X,U,1))_" "_$P(X,U,2),1:"Yes")
I $O(^ATXAX("B","BGP DM ATK AMP PROCS",0)) S X=$$LASTPRCT^BDMAPIU(P,$$DOB^AUPNPAT(P),EDATE,"BGP DM ATK AMP PROCS","E")
I X Q $S(F=1:"1 Yes - "_$$DATE^BDMS9B1($P(X,U,1))_" "_$P(X,U,2),1:"Yes")
;now check problem list
S T=$O(^ATXAX("B","BGP DM BTK AMP DXS",0))
S T1=$O(^ATXAX("B","BGP DM ATK AMP DXS",0))
S (X,G)=0 F S X=$O(^AUPNPROB("AC",P,X)) Q:X'=+X!(G) D
.Q:$P(^AUPNPROB(X,0),U,8)>EDATE ;if added to pl after end of time period, no go
.S Y=$P(^AUPNPROB(X,0),U)
.Q:$P(^AUPNPROB(X,0),U,12)="D"
.;Q:$P(^AUPNPROB(X,0),U,12)="I"
.I T,$$ICD^BGP8UTL2(Y,T,9) S G=$S(F=1:"1 Yes - "_"Problem List "_$$VAL^XBDIQ1(9000011,X,.01)_" "_$$DATE^BDMS9B1($P(^AUPNPROB(X,0),U,8)),1:"Yes") Q
.I T1,$$ICD^BGP8UTL2(Y,T1,9) S G=$S(F=1:"1 Yes - "_"Problem List "_$$VAL^XBDIQ1(9000011,X,.01)_" "_$$DATE^BDMS9B1($P(^AUPNPROB(X,0),U,8)),1:"Yes") Q
.I $P($G(^AUPNPROB(X,800)),U,1)]"",$$SNOMED^BDMUTL(2019,"PXRM BGP DM BTK AMP",$P(^AUPNPROB(X,800),U,1)) S G=$S(F=1:"1 Yes - "_"Problem List "_$$VAL^XBDIQ1(9000011,X,80001)_" "_$$DATE^BDMS9B1($P(^AUPNPROB(X,0),U,8)),1:"Yes") Q
.I $P($G(^AUPNPROB(X,800)),U,1)]"",$$SNOMED^BDMUTL(2019,"PXRM BGP DM ATK AMP",$P(^AUPNPROB(X,800),U,1)) S G=$S(F=1:"1 Yes - "_"Problem List "_$$VAL^XBDIQ1(9000011,X,80001)_" "_$$DATE^BDMS9B1($P(^AUPNPROB(X,0),U,8)),1:"Yes") Q
.Q
I G Q G
S X=""
I $O(^ATXAX("B","BGP DM BTK AMP CPTS",0)) S X=$$LASTCPTT^BDMAPIU(P,$$DOB^AUPNPAT(P),EDATE,"BGP DM BTK AMP CPTS","E")
I X Q $S(F=1:"1 Yes - "_$$DATE^BDMS9B1($P(X,U,1))_" "_$P(X,U,2),1:"Yes")
I $O(^ATXAX("B","BGP DM ATK AMP CPTS",0)) S X=$$LASTCPTT^BDMAPIU(P,$$DOB^AUPNPAT(P),EDATE,"BGP DM ATK AMP CPTS","E")
I X Q $S(F=1:"1 Yes - "_$$DATE^BDMS9B1($P(X,U,1))_" "_$P(X,U,2),1:"Yes")
Q $S(F=1:"2 No",1:"No")
BDMDG1D ; IHS/CMI/LAB - BDM Continuation of BDMDG1C 1/11/2014 1:54:57 PM ;
+1 ;;2.0;DIABETES MANAGEMENT SYSTEM;**12**;JUN 14, 2007;Build 51
+2 ;
+3 ;
+4 ;
MICRO ;EP
+1 NEW BDM,X,%,E,R,V,BDMLT,BDMOT,B,D,L,J,BDMC,BDMV,V
+2 KILL BDM
SET BDMC=0
+3 SET BDMOT=$ORDER(^ATXAX("B","DM AUDIT MICROALBUMIN LOINC",0))
+4 SET BDMLT=$ORDER(^ATXLAB("B","DM AUDIT MICROALBUMINURIA TAX",0))
+5 SET B=9999999-BDATE
SET E=9999999-EDATE
SET D=E-1
FOR
SET D=$ORDER(^AUPNVLAB("AE",P,D))
IF D'=+D!(D>B)
QUIT
Begin DoDot:1
+6 SET L=0
FOR
SET L=$ORDER(^AUPNVLAB("AE",P,D,L))
IF L'=+L
QUIT
Begin DoDot:2
+7 SET X=0
FOR
SET X=$ORDER(^AUPNVLAB("AE",P,D,L,X))
IF X'=+X
QUIT
Begin DoDot:3
+8 IF '$DATA(^AUPNVLAB(X,0))
QUIT
+9 IF BDMLT
IF $PIECE(^AUPNVLAB(X,0),U)
IF $DATA(^ATXLAB(BDMLT,21,"B",$PIECE(^AUPNVLAB(X,0),U)))
DO SETV
QUIT
+10 IF 'BDMOT
QUIT
+11 SET J=$PIECE($GET(^AUPNVLAB(X,11)),U,13)
IF J=""
QUIT
+12 IF '$$LOINC(J,BDMOT)
QUIT
+13 DO SETV
+14 QUIT
End DoDot:3
End DoDot:2
End DoDot:1
+15 IF '$DATA(BDM(1))
SET %1=""
DO ACRATIOM^BDMDG1C
QUIT %1
+16 DO SETN
+17 NEW %
SET %=$PIECE(^AUPNVLAB(+$PIECE(BDM(N),U,4),0),U,4)
+18 SET %1=$SELECT(%="":"No result",%["+":"Pos ",%[">":"Pos ",$EXTRACT(%)="P":"Pos ",$EXTRACT(%)="p":"Pos ",$EXTRACT(%)="c":"No result ",$EXTRACT(%)="C":"No result ",+%>29:"Pos ",1:"Neg ")
+19 QUIT %1_%_" "_$$FMTE^XLFDT($PIECE(BDM(N),U),"5")_" "_$PIECE(BDM(N),U,3)
HGBA1C ;EP
+1 NEW BDM,X,%,E,R,V,BDMLT,BDMOT,B,D,L,J,BDMC,BDMV,V,G
+2 KILL BDM
+3 SET BDMC=0
+4 SET BDMOT=$ORDER(^ATXAX("B","BGP HGBA1C LOINC CODES",0))
+5 SET BDMLT=$ORDER(^ATXLAB("B","DM AUDIT HGB A1C TAX",0))
+6 SET B=9999999-BDATE
SET E=9999999-EDATE
SET D=E-1
FOR
SET D=$ORDER(^AUPNVLAB("AE",P,D))
IF D'=+D!(D>B)
QUIT
Begin DoDot:1
+7 SET L=0
FOR
SET L=$ORDER(^AUPNVLAB("AE",P,D,L))
IF L'=+L
QUIT
Begin DoDot:2
+8 SET X=0
FOR
SET X=$ORDER(^AUPNVLAB("AE",P,D,L,X))
IF X'=+X
QUIT
Begin DoDot:3
+9 IF '$DATA(^AUPNVLAB(X,0))
QUIT
+10 ;no result
IF $PIECE(^AUPNVLAB(X,0),U,4)=""
QUIT
+11 IF $$UP^XLFSTR($PIECE(^AUPNVLAB(X,0),U,4))["CANC"
QUIT
+12 IF $$UP^XLFSTR($PIECE(^AUPNVLAB(X,0),U,4))["COMMENT"
QUIT
+13 IF BDMLT
IF $PIECE(^AUPNVLAB(X,0),U)
IF $DATA(^ATXLAB(BDMLT,21,"B",$PIECE(^AUPNVLAB(X,0),U)))
DO SETV
QUIT
+14 IF 'BDMOT
QUIT
+15 SET J=$PIECE($GET(^AUPNVLAB(X,11)),U,13)
IF J=""
QUIT
+16 IF '$$LOINC(J,BDMOT)
QUIT
+17 DO SETV
+18 QUIT
End DoDot:3
End DoDot:2
End DoDot:1
+19 DO SET3
+20 ;K X S (%,C,R)="" F S %=$O(BDM(%)) Q:%'=+%!(C>1) S C=C+1,X(9999999-$P(BDM(%),U),C)=$P(^AUPNVLAB(+$P(BDM(%),U,4),0),U,4)
+21 ;S %=0,R="" F S %=$O(X(%)) Q:%="" S V=0 F S V=$O(X(%,V)) Q:V="" S R=R_X(%,V)_"^"_$$FMTE^XLFDT(9999999-%)_"^"_(9999999-%)_"^"
+22 ;separate those with a result and those without a result
+23 ;first put in reverse date order
+24 SET (N,C,R)=""
+25 KILL BDMR
+26 FOR
SET N=$ORDER(BDM(N))
IF N'=+N
QUIT
Begin DoDot:1
+27 SET D=$PIECE(BDM(N),U)
+28 SET R=$PIECE(BDM(N),U,2)
IF R="?"
SET R=""
+29 IF R]""
SET BDMR("R",(9999999-D),N)=BDM(N)
+30 IF R=""
SET BDMR("NR",(9999999-D),N)=BDM(N)
End DoDot:1
+31 SET R=""
+32 SET D=0
FOR
SET D=$ORDER(BDMR("R",D))
IF D'=+D!(R]"")
QUIT
Begin DoDot:1
+33 SET N=0
FOR
SET N=$ORDER(BDMR("R",D,N))
IF N'=+N!(R]"")
QUIT
Begin DoDot:2
+34 SET R=BDMR("R",D,N)
End DoDot:2
End DoDot:1
+35 IF R]""
QUIT R
+36 SET D=0
FOR
SET D=$ORDER(BDMR("NR",D))
IF D'=+D!(R]"")
QUIT
Begin DoDot:1
+37 SET N=0
FOR
SET N=$ORDER(BDMR("NR",D,N))
IF N'=+N!(R]"")
QUIT
Begin DoDot:2
+38 SET R=BDMR("NR",D,N)
End DoDot:2
End DoDot:1
+39 QUIT R
BS ;EP
+1 NEW BDM,X,%,E,R,V,C
+2 KILL BDM
+3 SET %=P_"^LAST 200 LAB [DM AUDIT GLUCOSE TESTS TAX;DURING "_BDATE_"-"_EDATE
SET E=$$START1^APCLDF(%,"BDM(")
+4 IF '$DATA(BDM(1))
QUIT ""
+5 DO SET3
+6 SET (%,C,R)=""
FOR
SET %=$ORDER(BDM(%))
IF %=""!(C>2)
QUIT
SET R=R_$PIECE(^AUPNVLAB(+$PIECE(BDM(%),U,4),0),U,4)_$SELECT($PIECE(^AUPNVLAB(+$PIECE(BDM(%),U,4),0),U,4)]"":" mg/dl ",1:"")_$$FMTE^XLFDT($PIECE(BDM(%),U))_"^"
SET C=C+1
+7 QUIT R
+8 ;
FGLUCOSE ;EP
+1 IF $GET(F)=""
SET F="E"
+2 NEW BDM,X,%,E,R,V,BDMLT,BDMOT,B,D,L,J,BDMC,BDMV,V
+3 KILL BDM
+4 SET BDMC=0
+5 SET BDMOT=$ORDER(^ATXAX("B","DM AUDIT FASTING GLUC LOINC",0))
+6 SET BDMLT=$ORDER(^ATXLAB("B","DM AUDIT FASTING GLUCOSE TESTS",0))
+7 DO GATHER
+8 IF '$DATA(BDM(1))
QUIT ""
+9 DO SETN
+10 IF F="I"
QUIT $PIECE(^AUPNVLAB(+$PIECE(BDM(N),U,4),0),U,4)_"^"_$PIECE(BDM(N),U)
+11 QUIT $PIECE(^AUPNVLAB(+$PIECE(BDM(N),U,4),0),U,4)_$SELECT($PIECE(^AUPNVLAB(+$PIECE(BDM(N),U,4),0),U,4)]"":" mg/dl ",1:"")_$$FMTE^XLFDT($PIECE(BDM(N),U),5)
G75 ;EP
+1 IF $GET(F)=""
SET F="E"
+2 NEW BDM,X,%,E,R,V,BDMLT,BDMOT,B,D,L,J,BDMC,BDMV,V
+3 KILL BDM
+4 SET BDMC=0
+5 SET BDMOT=$ORDER(^ATXAX("B","DM AUDIT 75GM 2HR LOINC",0))
+6 SET BDMLT=$ORDER(^ATXLAB("B","DM AUDIT 75GM 2HR GLUCOSE",0))
+7 DO GATHER
+8 IF '$DATA(BDM(1))
QUIT ""
+9 DO SETN
+10 IF F="I"
QUIT $PIECE(^AUPNVLAB(+$PIECE(BDM(N),U,4),0),U,4)_"^"_$PIECE(BDM(N),U)
+11 QUIT $PIECE(^AUPNVLAB(+$PIECE(BDM(N),U,4),0),U,4)_$SELECT($PIECE(^AUPNVLAB(+$PIECE(BDM(N),U,4),0),U,4)]"":" mg/dl ",1:"")_$$FMTE^XLFDT($PIECE(BDM(N),U),5)
+12 ;
GATHER ;
+1 SET B=9999999-BDATE
SET E=9999999-EDATE
SET D=E-1
FOR
SET D=$ORDER(^AUPNVLAB("AE",P,D))
IF D'=+D!(D>B)!($DATA(BDM))
QUIT
Begin DoDot:1
+2 SET L=0
FOR
SET L=$ORDER(^AUPNVLAB("AE",P,D,L))
IF L'=+L
QUIT
Begin DoDot:2
+3 SET X=0
FOR
SET X=$ORDER(^AUPNVLAB("AE",P,D,L,X))
IF X'=+X
QUIT
Begin DoDot:3
+4 IF '$DATA(^AUPNVLAB(X,0))
QUIT
+5 IF BDMLT
IF $PIECE(^AUPNVLAB(X,0),U)
IF $DATA(^ATXLAB(BDMLT,21,"B",$PIECE(^AUPNVLAB(X,0),U)))
DO SETV
QUIT
+6 IF 'BDMOT
QUIT
+7 SET J=$PIECE($GET(^AUPNVLAB(X,11)),U,13)
IF J=""
QUIT
+8 IF '$$LOINC(J,BDMOT)
QUIT
+9 DO SETV
+10 QUIT
End DoDot:3
End DoDot:2
End DoDot:1
+11 IF '$DATA(BDM(1))
QUIT
+12 SET D=$PIECE(BDM(1),U)
SET D=9999999-D
+13 KILL BDM
SET BDMC=0
+14 SET L=0
FOR
SET L=$ORDER(^AUPNVLAB("AE",P,D,L))
IF L'=+L
QUIT
Begin DoDot:1
+15 SET X=0
FOR
SET X=$ORDER(^AUPNVLAB("AE",P,D,L,X))
IF X'=+X
QUIT
Begin DoDot:2
+16 IF '$DATA(^AUPNVLAB(X,0))
QUIT
+17 IF BDMLT
IF $PIECE(^AUPNVLAB(X,0),U)
IF $DATA(^ATXLAB(BDMLT,21,"B",$PIECE(^AUPNVLAB(X,0),U)))
DO SETV
QUIT
+18 IF 'BDMOT
QUIT
+19 SET J=$PIECE($GET(^AUPNVLAB(X,11)),U,13)
IF J=""
QUIT
+20 IF '$$LOINC(J,BDMOT)
QUIT
+21 DO SETV
+22 QUIT
End DoDot:2
End DoDot:1
+23 QUIT
LOINC(A,B) ;EP - is loinc code A in taxonomy B
+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 ""
SETV ;
+1 SET BDMC=BDMC+1
+2 SET V=$PIECE(^AUPNVLAB(X,0),U,3)
SET BDMV=$PIECE($PIECE($GET(^AUPNVSIT(V,0)),U),".")
IF 'BDMV
QUIT
+3 SET BDM(BDMC)=BDMV_"^"_$SELECT($PIECE(^AUPNVLAB(X,0),U,4)]"":$PIECE(^AUPNVLAB(X,0),U,4),1:"")_"^"_$$VAL^XBDIQ1(9000010.09,X,.01)_"^"_X_";AUPNVLAB^"_V
+4 QUIT
SETN ;
+1 SET N=""
NEW A,G
SET (A,G)=0
FOR
SET A=$ORDER(BDM(A))
IF A'=+A!(G)
QUIT
SET R=$PIECE(^AUPNVLAB(+$PIECE(BDM(A),U,4),0),U,4)
IF R]""
IF $$UP^XLFSTR(R)'="COMMENT"
SET G=A
+2 SET N=$SELECT(G:G,1:1)
+3 QUIT
SET3 ;
+1 NEW X,N1,N2,N3,A,T,G,N
+2 KILL A
+3 SET X=0
FOR
SET X=$ORDER(BDM(X))
IF X'=+X
QUIT
SET A($PIECE(BDM(X),U),X)=""
+4 NEW D
SET D=0
FOR
SET D=$ORDER(A(D))
IF D'=+D
QUIT
Begin DoDot:1
+5 SET G=0
SET N=0
FOR
SET N=$ORDER(A(D,N))
IF N'=+N
QUIT
Begin DoDot:2
+6 IF $PIECE(^AUPNVLAB(+$PIECE(BDM(N),U,4),0),U,4)]""
IF $$UP^XLFSTR($PIECE(^AUPNVLAB(+$PIECE(BDM(N),U,4),0),U,4))'="COMMENT"
SET G=1
QUIT
End DoDot:2
+7 IF G
SET N=0
FOR
SET N=$ORDER(A(D,N))
IF N'=+N
QUIT
IF $PIECE(^AUPNVLAB(+$PIECE(BDM(N),U,4),0),U,4)=""
KILL BDM(N)
+8 QUIT
End DoDot:1
+9 QUIT
ASPIRIN ;EP
+1 NEW X,BDM,E,A,N,G,T,T1,O,B,%
+2 SET (A,B,G,N,D)=""
+3 SET X=P_"^LAST MEDS [DM AUDIT ASPIRIN DRUGS"_";DURING "_BDATE_"-"_EDATE
SET E=$$START1^APCLDF(X,"BDM(")
+4 IF $DATA(BDM(1))
SET A=1
SET D=$$DATE^BDMS9B1($PIECE(BDM(1),U))_" "_$PIECE(BDM(1),U,3)
+5 KILL BDM
SET X=P_"^LAST MEDS [DM AUDIT ANTIPLT/ANTICOAG RX"_";DURING "_BDATE_"-"_EDATE
SET E=$$START1^APCLDF(X,"BDM(")
+6 IF $DATA(BDM(1))
SET N=1
SET D=$$DATE^BDMS9B1($PIECE(BDM(1),U))_" "_$PIECE(BDM(1),U,3)
+7 KILL BDM
SET X=P_"^LAST MEDS [DM AUDIT ANTI-PLATELET DRUGS"_";DURING "_BDATE_"-"_EDATE
SET E=$$START1^APCLDF(X,"BDM(")
+8 IF $DATA(BDM(1))
SET N=1
SET D=$$DATE^BDMS9B1($PIECE(BDM(1),U))_" "_$PIECE(BDM(1),U,3)
+9 IF A
QUIT "1 Yes "_D
+10 IF N
QUIT "1 Yes "_D
+11 SET T=$ORDER(^ATXAX("B","DM AUDIT ASPIRIN DRUGS",0))
+12 SET T1=$ORDER(^ATXAX("B","DM AUDIT ANTIPLT/ANTICOAG RX",0))
+13 SET X=0
SET %=""
FOR
SET X=$ORDER(^PS(55,P,"NVA",X))
IF X'=+X!(%]"")
QUIT
Begin DoDot:1
+14 ;got this with V MED
IF $PIECE($GET(^PS(55,P,"NVA",X,999999911)),U,1)
IF $DATA(^AUPNVMED($PIECE(^PS(55,P,"NVA",X,999999911),U,1),0))
QUIT
+15 SET L=$PIECE($PIECE($GET(^PS(55,P,"NVA",X,0)),U,10),".")
+16 ;discontinued
IF $PIECE(^PS(55,P,"NVA",X,0),U,6)=1
QUIT
+17 ;discontinued date
IF $PIECE(^PS(55,P,"NVA",X,0),U,7)]""
IF $PIECE(^PS(55,P,"NVA",X,0),U,7)<EDATE
QUIT
+18 ;
IF $PIECE(^PS(55,P,"NVA",X,0),U,9)>EDATE
QUIT
+19 SET D=$PIECE(^PS(55,P,"NVA",X,0),U,2)
+20 IF D
SET G=0
Begin DoDot:2
+21 IF $DATA(^ATXAX(T,21,"B",D))
SET G=1
+22 IF $DATA(^ATXAX(T1,21,"B",D))
SET G=1
End DoDot:2
+23 IF D
IF G
SET %="1 Yes - NVA MED - "_$PIECE(^PSDRUG(D,0),U,1)
QUIT
+24 SET O=$PIECE(^PS(55,P,"NVA",X,0),U,1)
+25 IF O=""
QUIT
+26 SET O=$PIECE($GET(^PS(50.7,O,0)),U,1)
+27 IF O=""
QUIT
+28 IF $EXTRACT(O,1,7)="ASPIRIN"
IF $EXTRACT(O,8)'="/"
SET %="1 Yes - NVA MED - "_O
QUIT
End DoDot:1
+29 IF %]""
QUIT %
+30 KILL %DT
SET %DT="P"
SET X=EDATE
DO ^%DT
SET ED=Y
+31 SET BDM=$$PRESD^BDMDG18(P,$ORDER(^ATXAX("B","DM AUDIT ASPIRIN DRUGS",0)),ED,186)
+32 IF BDM]""
QUIT BDM
+33 SET BDM=$$PRESD^BDMDG18(P,$ORDER(^ATXAX("B","DM AUDIT ANTIPLT/ANTICOAG RX",0)),ED,186)
+34 IF BDM]""
QUIT BDM
+35 SET BDM=$$PRESD^BDMDG18(P,$ORDER(^ATXAX("B","DM AUDIT ANTI-PLATELET DRUGS",0)),ED,186)
+36 IF BDM]""
QUIT BDM
+37 QUIT "2 No"
+38 ;
+39 ;
HEPCDX(P,EDATE) ;EP - dx of HEP C ever?
+1 NEW T,X,G
+2 SET X=$$LASTDXT^BDMAPIU(P,$$DOB^AUPNPAT(P),EDATE,"BGP HEPATITIS C DXS","E")
+3 IF X
QUIT "1 Yes - "_$$DATE^BDMS9B1($PIECE(X,U,1))_" "_$PIECE(X,U,2)
+4 ;now check problem list
+5 SET T=$ORDER(^ATXAX("B","BGP HEPATITIS C DXS",0))
+6 SET (X,G)=0
FOR
SET X=$ORDER(^AUPNPROB("AC",P,X))
IF X'=+X!(G)
QUIT
Begin DoDot:1
+7 ;if added to pl after end of time period, no go
IF $PIECE(^AUPNPROB(X,0),U,8)>EDATE
QUIT
+8 SET Y=$PIECE(^AUPNPROB(X,0),U)
+9 IF $PIECE(^AUPNPROB(X,0),U,12)="D"
QUIT
+10 ;Q:$P(^AUPNPROB(X,0),U,12)="I"
+11 IF $$ICD^BGP8UTL2(Y,T,9)
SET G="1 Yes - "_"Problem List "_$$VAL^XBDIQ1(9000011,X,.01)_" "_$$DATE^BDMS9B1($PIECE(^AUPNPROB(X,0),U,8))
QUIT
+12 IF $PIECE($GET(^AUPNPROB(X,800)),U,1)]""
IF $$SNOMED^BDMUTL(2019,"PXRM HEPATITIS C",$PIECE(^AUPNPROB(X,800),U,1))
SET G=1
+13 QUIT
End DoDot:1
+14 IF G
QUIT G
+15 QUIT "2 No"
HEPSCR(P,EDATE) ;
+1 ;HAS DX
IF $EXTRACT($$HEPCDX(P,EDATE))=1
QUIT ""
+2 NEW D
+3 SET D=$$DOB^AUPNPAT(P)
+4 ;I D<2450101 Q "3 Not born 1945-1965"
+5 ;I D>2651231 Q "3 Not born 1945-1965"
+6 NEW X,G,T,%,BGPC,BGPLT,L,D,J,R,Y
+7 ;now get all loinc/taxonomy tests
+8 SET BGPC=""
+9 SET T=$ORDER(^ATXAX("B","BGP HEP C TEST LOINC CODES",0))
+10 SET BGPLT=$ORDER(^ATXLAB("B","BGP HEP C TESTS TAX",0))
+11 SET E=9999999-EDATE
SET D=E-1
FOR
SET D=$ORDER(^AUPNVLAB("AE",P,D))
IF D'=+D!(BGPC)
QUIT
Begin DoDot:1
+12 SET L=0
FOR
SET L=$ORDER(^AUPNVLAB("AE",P,D,L))
IF L'=+L!(BGPC)
QUIT
Begin DoDot:2
+13 SET X=0
FOR
SET X=$ORDER(^AUPNVLAB("AE",P,D,L,X))
IF X'=+X!(BGPC)
QUIT
Begin DoDot:3
+14 IF '$DATA(^AUPNVLAB(X,0))
QUIT
+15 IF BGPLT
IF $PIECE(^AUPNVLAB(X,0),U)
IF $DATA(^ATXLAB(BGPLT,21,"B",$PIECE(^AUPNVLAB(X,0),U)))
Begin DoDot:4
+16 SET BGPC="1 Yes "_$$DATE^BDMS9B1((9999999-D))_" "_$$VAL^XBDIQ1(9000010.09,X,.01)
IF $$VAL^XBDIQ1(9000010.09,X,.04)]""
SET BGPC=BGPC_" ("_$$VAL^XBDIQ1(9000010.09,X,.04)_")"
QUIT
End DoDot:4
+17 IF 'T
QUIT
+18 SET J=$PIECE($GET(^AUPNVLAB(X,11)),U,13)
IF J=""
QUIT
+19 IF '$$LOINC(J,T)
QUIT
+20 SET BGPC="1 Yes - "_$$DATE^BDMS9B1((9999999-D))_" "_$$VAL^XBDIQ1(9000010.09,X,.01)
IF $$VAL^XBDIQ1(9000010.09,X,.04)]""
SET BGPC=BGPC_" ("_$$VAL^XBDIQ1(9000010.09,X,.04)_")"
+21 QUIT
End DoDot:3
End DoDot:2
End DoDot:1
+22 IF BGPC
QUIT BGPC
+23 SET %=""
SET E=+$$CODEN^ICPTCOD(86803)
SET %=$$CPTI^BDMDGDU(P,$$DOB^AUPNPAT(P),EDATE,E)
+24 IF %
QUIT "1 Yes - "_$$DATE^BDMS9B1($PIECE(%,U,2))_" CPT 86803 "_$PIECE($$CPT^ICPTCOD(E,$PIECE(%,U,2)),U,3)
+25 QUIT "2 No"
DMRETDX(P,EDATE) ;EP - is DM RETINOPATHY on problem list
+1 IF '$GET(P)
QUIT ""
+2 IF '$DATA(^DPT(P))
QUIT ""
+3 NEW %,BDM,E,X,T,G,Y,D,I,S
+4 SET T=$ORDER(^ATXAX("B","BGP DM RETINOPATHY DX",0))
+5 SET (X,G)=0
FOR
SET X=$ORDER(^AUPNPROB("AC",P,X))
IF X'=+X!(G)
QUIT
Begin DoDot:1
+6 ;bad xref
IF '$DATA(^AUPNPROB(X,0))
QUIT
+7 ;if added to pl after end of time period, no go
IF $PIECE(^AUPNPROB(X,0),U,8)>EDATE
QUIT
+8 SET Y=$PIECE(^AUPNPROB(X,0),U)
+9 IF $PIECE(^AUPNPROB(X,0),U,12)="I"
QUIT
+10 IF $PIECE(^AUPNPROB(X,0),U,12)="D"
QUIT
+11 IF $$ICD^BDMUTL(Y,$PIECE(^ATXAX(T,0),U),9)
SET G=X
QUIT
+12 IF $PIECE($GET(^AUPNPROB(X,800)),U,1)]""
Begin DoDot:2
+13 IF $$SNOMED^BDMUTL(2019,"PXRM BGP DM RETINOPATHY",$PIECE(^AUPNPROB(X,800),U,1))
SET G=X
End DoDot:2
+14 QUIT
End DoDot:1
+15 IF G
QUIT "1 Yes - Problem List "
+16 KILL BDM
+17 SET X=P_"^LAST 1 DX ["_$PIECE(^ATXAX(T,0),U,1)_";DURING "_$$DOB^AUPNPAT(P)_"-"_EDATE
SET E=$$START1^APCLDF(X,"BDM(")
+18 IF $DATA(BDM(1))
SET Y=$$DATE^BDMS9B1($PIECE(BDM(1),U,1))
QUIT "1 Yes - DX "_Y
+19 ;CHECK V POV SNOMED USING A
+20 SET G=""
SET I=""
+21 SET S=""
FOR
SET S=$ORDER(^AUPNVPOV("ASNC",P,S))
IF S=""!(G)
QUIT
Begin DoDot:1
+22 SET I=0
+23 IF $$SNOMED^BDMUTL(2019,"PXRM BGP DM RETINOPATHY",S)
SET I=1
+24 IF 'I
QUIT
+25 SET D=0
FOR
SET D=$ORDER(^AUPNVPOV("ASNC",P,S,D))
IF D=""!(G)
QUIT
Begin DoDot:2
+26 SET Y=9999999-D
+27 IF Y>EDATE
QUIT
+28 SET G=1
End DoDot:2
End DoDot:1
+29 IF G
QUIT "1 Yes - "_$$DATE^BDMS9B1(Y)_" SNOMED: "_S
+30 QUIT "2 No"
SNO(%) ;
+1 NEW B,C
+2 SET B=$ORDER(^BDMSNME("B",2019,0))
+3 IF 'B
QUIT ""
+4 SET C=$ORDER(^BDMSNME(B,11,"B",%,0))
+5 IF 'C
QUIT ""
+6 SET C=$ORDER(^BDMSNME(B,11,%,0))
+7 IF C
QUIT 1
+8 QUIT ""
LEAMP(P,EDATE,F) ;EP - dx of AMP ever?
+1 IF '$GET(F)
SET F=1
+2 ;F=1 audit data format
+3 ;F=2 Yes or No only
+4 NEW T,X,G,I,S,D,Y,T1
+5 SET X=""
+6 IF $ORDER(^ATXAX("B","BGP DM BTK AMP DXS",0))
SET X=$$LASTDXT^BDMAPIU(P,$$DOB^AUPNPAT(P),EDATE,"BGP DM BTK AMP DXS","E")
+7 IF X
QUIT $SELECT(F=1:"1 Yes - "_$$DATE^BDMS9B1($PIECE(X,U,1))_" "_$PIECE(X,U,2),1:"Yes")
+8 IF $ORDER(^ATXAX("B","BGP DM ATK AMP DXS",0))
SET X=$$LASTDXT^BDMAPIU(P,$$DOB^AUPNPAT(P),EDATE,"BGP DM ATK AMP DXS","E")
+9 IF X
QUIT $SELECT(F=1:"1 Yes - "_$$DATE^BDMS9B1($PIECE(X,U,1))_" "_$PIECE(X,U,2),1:"Yes")
+10 ;CHECK V POV SNOMED USING A
+11 SET G=""
SET I=""
+12 SET S=""
FOR
SET S=$ORDER(^AUPNVPOV("ASNC",P,S))
IF S=""!(G)
QUIT
Begin DoDot:1
+13 SET I=0
+14 IF $$SNOMED^BDMUTL(2019,"PXRM BGP DM BTK AMP",S)
SET I=1
+15 IF $$SNOMED^BDMUTL(2019,"PXRM BGP DM ATK AMP",S)
SET I=1
+16 IF 'I
QUIT
+17 SET D=0
FOR
SET D=$ORDER(^AUPNVPOV("ASNC",P,S,D))
IF D=""!(G)
QUIT
Begin DoDot:2
+18 SET Y=9999999-D
+19 IF Y>EDATE
QUIT
+20 SET G=1
End DoDot:2
End DoDot:1
+21 IF G
QUIT $SELECT(F=1:"1 Yes - "_$$DATE^BDMS9B1(Y)_" SNOMED: "_S,1:"Yes")
+22 SET X=""
+23 IF $ORDER(^ATXAX("B","BGP DM BTK AMP PROCS",0))
SET X=$$LASTPRCT^BDMAPIU(P,$$DOB^AUPNPAT(P),EDATE,"BGP DM BTK AMP PROCS","E")
+24 IF X
QUIT $SELECT(F=1:"1 Yes - "_$$DATE^BDMS9B1($PIECE(X,U,1))_" "_$PIECE(X,U,2),1:"Yes")
+25 IF $ORDER(^ATXAX("B","BGP DM ATK AMP PROCS",0))
SET X=$$LASTPRCT^BDMAPIU(P,$$DOB^AUPNPAT(P),EDATE,"BGP DM ATK AMP PROCS","E")
+26 IF X
QUIT $SELECT(F=1:"1 Yes - "_$$DATE^BDMS9B1($PIECE(X,U,1))_" "_$PIECE(X,U,2),1:"Yes")
+27 ;now check problem list
+28 SET T=$ORDER(^ATXAX("B","BGP DM BTK AMP DXS",0))
+29 SET T1=$ORDER(^ATXAX("B","BGP DM ATK AMP DXS",0))
+30 SET (X,G)=0
FOR
SET X=$ORDER(^AUPNPROB("AC",P,X))
IF X'=+X!(G)
QUIT
Begin DoDot:1
+31 ;if added to pl after end of time period, no go
IF $PIECE(^AUPNPROB(X,0),U,8)>EDATE
QUIT
+32 SET Y=$PIECE(^AUPNPROB(X,0),U)
+33 IF $PIECE(^AUPNPROB(X,0),U,12)="D"
QUIT
+34 ;Q:$P(^AUPNPROB(X,0),U,12)="I"
+35 IF T
IF $$ICD^BGP8UTL2(Y,T,9)
SET G=$SELECT(F=1:"1 Yes - "_"Problem List "_$$VAL^XBDIQ1(9000011,X,.01)_" "_$$DATE^BDMS9B1($PIECE(^AUPNPROB(X,0),U,8)),1:"Yes")
QUIT
+36 IF T1
IF $$ICD^BGP8UTL2(Y,T1,9)
SET G=$SELECT(F=1:"1 Yes - "_"Problem List "_$$VAL^XBDIQ1(9000011,X,.01)_" "_$$DATE^BDMS9B1($PIECE(^AUPNPROB(X,0),U,8)),1:"Yes")
QUIT
+37 IF $PIECE($GET(^AUPNPROB(X,800)),U,1)]""
IF $$SNOMED^BDMUTL(2019,"PXRM BGP DM BTK AMP",$PIECE(^AUPNPROB(X,800),U,1))
SET G=$SELECT(F=1:"1 Yes - "_"Problem List "_$$VAL^XBDIQ1(9000011,X,80001)_" "_$$DATE^BDMS9B1($PIECE(^AUPNPROB(X,0),U,8)),1:"Yes")
QUIT
+38 IF $PIECE($GET(^AUPNPROB(X,800)),U,1)]""
IF $$SNOMED^BDMUTL(2019,"PXRM BGP DM ATK AMP",$PIECE(^AUPNPROB(X,800),U,1))
SET G=$SELECT(F=1:"1 Yes - "_"Problem List "_$$VAL^XBDIQ1(9000011,X,80001)_" "_$$DATE^BDMS9B1($PIECE(^AUPNPROB(X,0),U,8)),1:"Yes")
QUIT
+39 QUIT
End DoDot:1
+40 IF G
QUIT G
+41 SET X=""
+42 IF $ORDER(^ATXAX("B","BGP DM BTK AMP CPTS",0))
SET X=$$LASTCPTT^BDMAPIU(P,$$DOB^AUPNPAT(P),EDATE,"BGP DM BTK AMP CPTS","E")
+43 IF X
QUIT $SELECT(F=1:"1 Yes - "_$$DATE^BDMS9B1($PIECE(X,U,1))_" "_$PIECE(X,U,2),1:"Yes")
+44 IF $ORDER(^ATXAX("B","BGP DM ATK AMP CPTS",0))
SET X=$$LASTCPTT^BDMAPIU(P,$$DOB^AUPNPAT(P),EDATE,"BGP DM ATK AMP CPTS","E")
+45 IF X
QUIT $SELECT(F=1:"1 Yes - "_$$DATE^BDMS9B1($PIECE(X,U,1))_" "_$PIECE(X,U,2),1:"Yes")
+46 QUIT $SELECT(F=1:"2 No",1:"No")
