BGP8D861 ; IHS/CMI/LAB - measure C ;
;;18.1;IHS CLINICAL REPORTING;;MAY 25, 2018;Build 66
;
NDC(A,B) ;
S BGPNDC=$P($G(^PSDRUG(A,2)),U,4)
I BGPNDC]"",B,$D(^ATXAX(B,21,"B",BGPNDC)) Q 1
Q 0
CBC4(P,BDATE,EDATE) ;EP
K BGPC,BGPLAB
S BGPC=0
S %="",E=+$$CODEN^ICPTCOD(85025),%=$$CPTI^BGP8DU(P,BDATE,EDATE,E)
I %]"" S BGPC=BGPC+1,BGPC($P(%,U,2))=""
S %="",E=+$$CODEN^ICPTCOD(85027),%=$$CPTI^BGP8DU(P,BDATE,EDATE,E)
I %]"" S BGPC=BGPC+1,BGPC($P(%,U,2))=""
S %="",E=+$$CODEN^ICPTCOD(85025),%=$$TRANI^BGP8DU(P,BDATE,EDATE,E)
I %]"" S BGPC=BGPC+1,BGPC($P(%,U,2))=""
S %="",E=+$$CODEN^ICPTCOD(85027),%=$$TRANI^BGP8DU(P,BDATE,EDATE,E)
I %]"" S BGPC=BGPC+1,BGPC($P(%,U,2))=""
;now get all loinc/taxonomy tests
S T=$O(^ATXAX("B","BGP CBC LOINC",0))
S BGPLT=$O(^ATXLAB("B","BGP CBC TESTS",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 BGPLT,$P(^AUPNVLAB(X,0),U),$D(^ATXLAB(BGPLT,21,"B",$P(^AUPNVLAB(X,0),U))) S BGPC=BGPC+1,BGPC(9999999-D)="" Q
...Q:'T
...S J=$P($G(^AUPNVLAB(X,11)),U,13) Q:J=""
...Q:'$$LOINC^BGP8D21(J,T)
...S BGPC=BGPC+1,BGPC(9999999-D)=""
...Q
;now check to see if they are all spaced 10 days apart, if not, kill off the odd ones
S (X,Y)="",C=0 F S X=$O(BGPC(X)) Q:X'=+X S C=C+1 D
.I C=1 S Y=X Q
.I $$FMDIFF^XLFDT(X,Y)<11 K BGPC(X) Q
.S Y=X
S C=0,X=0 F S X=$O(BGPC(X)) Q:X'=+X S C=C+1
Q $S(C>3:1,1:"")
CBC6(P,BDATE,EDATE) ;EP
K BGPC,BGPLAB
S BGPC=0
S %="",E=+$$CODEN^ICPTCOD(85025),%=$$CPTI^BGP8DU(P,BDATE,EDATE,E)
I %]"" S BGPC=BGPC+1,BGPC($P(%,U,2))=""
S %="",E=+$$CODEN^ICPTCOD(85027),%=$$CPTI^BGP8DU(P,BDATE,EDATE,E)
I %]"" S BGPC=BGPC+1,BGPC($P(%,U,2))=""
S %="",E=+$$CODEN^ICPTCOD(85025),%=$$TRANI^BGP8DU(P,BDATE,EDATE,E)
I %]"" S BGPC=BGPC+1,BGPC($P(%,U,2))=""
S %="",E=+$$CODEN^ICPTCOD(85027),%=$$TRANI^BGP8DU(P,BDATE,EDATE,E)
I %]"" S BGPC=BGPC+1,BGPC($P(%,U,2))=""
;now get all loinc/taxonomy tests
S T=$O(^ATXAX("B","BGP CBC LOINC",0))
S BGPLT=$O(^ATXLAB("B","BGP CBC TESTS",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 BGPLT,$P(^AUPNVLAB(X,0),U),$D(^ATXLAB(BGPLT,21,"B",$P(^AUPNVLAB(X,0),U))) S BGPC=BGPC+1,BGPC(9999999-D)="" Q
...Q:'T
...S J=$P($G(^AUPNVLAB(X,11)),U,13) Q:J=""
...Q:'$$LOINC^BGP8D21(J,T)
...S BGPC=BGPC+1,BGPC(9999999-D)=""
...Q
;now check to see if they are all spaced 10 days apart, if not, kill off the odd ones
S (X,Y)="",C=0 F S X=$O(BGPC(X)) Q:X'=+X S C=C+1 D
.I C=1 S Y=X Q
.I $$FMDIFF^XLFDT(X,Y)<11 K BGPC(X) Q
.S Y=X
S C=0,X=0 F S X=$O(BGPC(X)) Q:X'=+X S C=C+1
Q $S(C>5:1,1:"")
SERUM6(P,BDATE,EDATE) ;EP
K BGPC,BGPLAB
S BGPC=0
S T=$O(^ATXAX("B","BGP CREATININE CPTS",0))
S %=$$CPT^BGP8DU(P,BDATE,EDATE,T,3)
I %]"" S BGPC=BGPC+1,BGPC($P(%,U,1))=""
S T=$O(^ATXAX("B","BGP CREATININE CPTS",0))
S %=$$TRAN^BGP8DU(P,BDATE,EDATE,T,3)
I %]"" S BGPC=BGPC+1,BGPC($P(%,U,1))=""
;now get all loinc/taxonomy tests
S T=$O(^ATXAX("B","BGP CREATININE LOINC CODES",0))
S BGPLT=$O(^ATXLAB("B","DM AUDIT CREATININE 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 BGPLT,$P(^AUPNVLAB(X,0),U),$D(^ATXLAB(BGPLT,21,"B",$P(^AUPNVLAB(X,0),U))) S BGPC=BGPC+1,BGPC(9999999-D)="" Q
...Q:'T
...S J=$P($G(^AUPNVLAB(X,11)),U,13) Q:J=""
...Q:'$$LOINC^BGP8D21(J,T)
...S BGPC=BGPC+1,BGPC(9999999-D)=""
...Q
;now check to see if they are all spaced 10 days apart, if not, kill off the odd ones
S (X,Y)="",C=0 F S X=$O(BGPC(X)) Q:X'=+X S C=C+1 D
.I C=1 S Y=X Q
.I $$FMDIFF^XLFDT(X,Y)<11 K BGPC(X) Q
.S Y=X
S C=0,X=0 F S X=$O(BGPC(X)) Q:X'=+X S C=C+1
Q $S(C>5:1,1:"")
LFT6(P,BDATE,EDATE) ;EP
K BGPC
S BGPC=0
S %="",E=+$$CODEN^ICPTCOD(84460),%=$$CPTI^BGP8DU(P,BDATE,EDATE,E)
I %]"" S BGPC=BGPC+1,BGPC($P(%,U,2))=""
S %="",E=+$$CODEN^ICPTCOD(84450),%=$$CPTI^BGP8DU(P,BDATE,EDATE,E)
I %]"" S BGPC=BGPC+1,BGPC($P(%,U,2))=""
S %="",E=+$$CODEN^ICPTCOD(80076),%=$$CPTI^BGP8DU(P,BDATE,EDATE,E)
I %]"" S BGPC=BGPC+1,BGPC($P(%,U,2))=""
;TRAN
S %="",E=+$$CODEN^ICPTCOD(84460),%=$$TRANI^BGP8DU(P,BDATE,EDATE,E)
I %]"" S BGPC=BGPC+1,BGPC($P(%,U,2))=""
S %="",E=+$$CODEN^ICPTCOD(84450),%=$$TRANI^BGP8DU(P,BDATE,EDATE,E)
I %]"" S BGPC=BGPC+1,BGPC($P(%,U,2))=""
S %="",E=+$$CODEN^ICPTCOD(80076),%=$$TRANI^BGP8DU(P,BDATE,EDATE,E)
I %]"" S BGPC=BGPC+1,BGPC($P(%,U,2))=""
;now get all loinc/taxonomy tests
S T=$O(^ATXAX("B","BGP ALT LOINC",0))
S BGPLT=$O(^ATXLAB("B","DM AUDIT ALT 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 BGPLT,$P(^AUPNVLAB(X,0),U),$D(^ATXLAB(BGPLT,21,"B",$P(^AUPNVLAB(X,0),U))) S BGPC=BGPC+1,BGPC(9999999-D)="" Q
...Q:'T
...S J=$P($G(^AUPNVLAB(X,11)),U,13) Q:J=""
...Q:'$$LOINC^BGP8D21(J,T)
...S BGPC=BGPC+1,BGPC(9999999-D)=""
...Q
;now get all AST
S T=$O(^ATXAX("B","BGP AST LOINC",0))
S BGPLT=$O(^ATXLAB("B","DM AUDIT AST 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 BGPLT,$P(^AUPNVLAB(X,0),U),$D(^ATXLAB(BGPLT,21,"B",$P(^AUPNVLAB(X,0),U))) S BGPC=BGPC+1,BGPC(9999999-D)="" Q
...Q:'T
...S J=$P($G(^AUPNVLAB(X,11)),U,13) Q:J=""
...Q:'$$LOINC^BGP8D21(J,T)
...S BGPC=BGPC+1,BGPC(9999999-D)=""
...Q
;now get all loinc/taxonomy tests
S T=$O(^ATXAX("B","BGP LIVER FUNCTION LOINC",0))
S BGPLT=$O(^ATXLAB("B","BGP LIVER FUNCTION TESTS",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 BGPLT,$P(^AUPNVLAB(X,0),U),$D(^ATXLAB(BGPLT,21,"B",$P(^AUPNVLAB(X,0),U))) S BGPC=BGPC+1,BGPC(9999999-D)="" Q
...Q:'T
...S J=$P($G(^AUPNVLAB(X,11)),U,13) Q:J=""
...Q:'$$LOINC^BGP8D21(J,T)
...S BGPC=BGPC+1,BGPC(9999999-D)=""
...Q
;now check to see if they are all spaced 10 days apart, if not, kill off the odd ones
S (X,Y)="",C=0 F S X=$O(BGPC(X)) Q:X'=+X S C=C+1 D
.I C=1 S Y=X Q
.I $$FMDIFF^XLFDT(X,Y)<11 K BGPC(X) Q
.S Y=X
S C=0,X=0 F S X=$O(BGPC(X)) Q:X'=+X S C=C+1
Q $S(C>5:1,1:"")
CBC(P,BDATE,EDATE) ;EP
K BGPC
S BGPC=0
S %="",E=+$$CODEN^ICPTCOD(85025),%=$$CPTI^BGP8DU(P,BDATE,EDATE,E)
I %]"" S BGPC=1_U_$P(%,U,2)_U_"85025"
S %="",E=+$$CODEN^ICPTCOD(85027),%=$$CPTI^BGP8DU(P,BDATE,EDATE,E)
I %]"" S BGPC=1_U_$P(%,U,2)_U_"85027"
S %="",E=+$$CODEN^ICPTCOD(85025),%=$$TRANI^BGP8DU(P,BDATE,EDATE,E)
I %]"" S BGPC=1_U_$P(%,U,2)_U_"85025 TRAN"
S %="",E=+$$CODEN^ICPTCOD(85027),%=$$TRANI^BGP8DU(P,BDATE,EDATE,E)
I %]"" S BGPC=1_U_$P(%,U,2)_U_"85027 TRAN"
;now get all loinc/taxonomy tests
S T=$O(^ATXAX("B","BGP CBC LOINC",0))
S BGPLT=$O(^ATXLAB("B","BGP CBC TESTS",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)!($P(BGPC,U)) D
.S L=0 F S L=$O(^AUPNVLAB("AE",P,D,L)) Q:L'=+L!($P(BGPC,U)) D
..S X=0 F S X=$O(^AUPNVLAB("AE",P,D,L,X)) Q:X'=+X!($P(BGPC,U)) D
...Q:'$D(^AUPNVLAB(X,0))
...I BGPLT,$P(^AUPNVLAB(X,0),U),$D(^ATXLAB(BGPLT,21,"B",$P(^AUPNVLAB(X,0),U))) S BGPC=1_U_(9999999-D)_U_"LAB" Q
...Q:'T
...S J=$P($G(^AUPNVLAB(X,11)),U,13) Q:J=""
...Q:'$$LOINC^BGP8D21(J,T)
...S BGPC=1_U_(9999999-D)_U_"LOINC"
...Q
Q BGPC
POT(P,BDATE,EDATE) ;EP
K BGPC
S BGPC=0
S %="",E=+$$CODEN^ICPTCOD(84132),%=$$CPTI^BGP8DU(P,BDATE,EDATE,E)
I %]"" S BGPC=1_U_$P(%,U,2)_U_"84132"
S %="",E=+$$CODEN^ICPTCOD(84132),%=$$TRANI^BGP8DU(P,BDATE,EDATE,E)
I %]"" S BGPC=1_U_$P(%,U,2)_U_"84132 TRAN"
;now get all loinc/taxonomy tests
S T=$O(^ATXAX("B","BGP POTASSIUM LOINC",0))
S BGPLT=$O(^ATXLAB("B","BGP POTASSIUM TESTS",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)!($P(BGPC,U)) D
.S L=0 F S L=$O(^AUPNVLAB("AE",P,D,L)) Q:L'=+L!($P(BGPC,U)) D
..S X=0 F S X=$O(^AUPNVLAB("AE",P,D,L,X)) Q:X'=+X!($P(BGPC,U)) D
...Q:'$D(^AUPNVLAB(X,0))
...I BGPLT,$P(^AUPNVLAB(X,0),U),$D(^ATXLAB(BGPLT,21,"B",$P(^AUPNVLAB(X,0),U))) S BGPC=1_U_(9999999-D)_U_"LAB" Q
...Q:'T
...S J=$P($G(^AUPNVLAB(X,11)),U,13) Q:J=""
...Q:'$$LOINC^BGP8D21(J,T)
...S BGPC=1_U_(9999999-D)_U_"LOINC"
...Q
Q BGPC
LFT(P,BDATE,EDATE) ;EP
K BGPC
S BGPC=0
S %="",E=+$$CODEN^ICPTCOD(84460),%=$$CPTI^BGP8DU(P,BDATE,EDATE,E)
I %]"" S BGPC=1_U_$P(%,U,2)_U_"84460"
S %="",E=+$$CODEN^ICPTCOD(84450),%=$$CPTI^BGP8DU(P,BDATE,EDATE,E)
I %]"" S BGPC=1_U_$P(%,U,2)_U_"84450"
S %="",E=+$$CODEN^ICPTCOD(80076),%=$$CPTI^BGP8DU(P,BDATE,EDATE,E)
I %]"" S BGPC=1_U_$P(%,U,2)_U_"80076"
;TRAN
S %="",E=+$$CODEN^ICPTCOD(84460),%=$$TRANI^BGP8DU(P,BDATE,EDATE,E)
I %]"" S BGPC=1_U_$P(%,U,2)_U_"84460 TRAN"
S %="",E=+$$CODEN^ICPTCOD(84450),%=$$TRANI^BGP8DU(P,BDATE,EDATE,E)
I %]"" S BGPC=1_U_$P(%,U,2)_U_"84450 TRAN"
S %="",E=+$$CODEN^ICPTCOD(80076),%=$$TRANI^BGP8DU(P,BDATE,EDATE,E)
I %]"" S BGPC=1_U_$P(%,U,2)_U_"80076 TRAN"
;now get all loinc/taxonomy tests
S T=$O(^ATXAX("B","BGP ALT LOINC",0))
S BGPLT=$O(^ATXLAB("B","DM AUDIT ALT 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)!($P(BGPC,U)) D
.S L=0 F S L=$O(^AUPNVLAB("AE",P,D,L)) Q:L'=+L!($P(BGPC,U)) D
..S X=0 F S X=$O(^AUPNVLAB("AE",P,D,L,X)) Q:X'=+X!($P(BGPC,U)) D
...Q:'$D(^AUPNVLAB(X,0))
...I BGPLT,$P(^AUPNVLAB(X,0),U),$D(^ATXLAB(BGPLT,21,"B",$P(^AUPNVLAB(X,0),U))) S BGPC=1_U_(9999999-D)_U_"LAB" Q
...Q:'T
...S J=$P($G(^AUPNVLAB(X,11)),U,13) Q:J=""
...Q:'$$LOINC^BGP8D21(J,T)
...S BGPC=1_U_(9999999-D)_U_"LOINC"
...Q
I BGPC Q BGPC
;now get all AST
S T=$O(^ATXAX("B","BGP AST LOINC",0))
S BGPLT=$O(^ATXLAB("B","DM AUDIT AST 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)!($P(BGPC,U)) D
.S L=0 F S L=$O(^AUPNVLAB("AE",P,D,L)) Q:L'=+L!($P(BGPC,U)) D
..S X=0 F S X=$O(^AUPNVLAB("AE",P,D,L,X)) Q:X'=+X!($P(BGPC,U)) D
...Q:'$D(^AUPNVLAB(X,0))
...I BGPLT,$P(^AUPNVLAB(X,0),U),$D(^ATXLAB(BGPLT,21,"B",$P(^AUPNVLAB(X,0),U))) S BGPC=1_U_(9999999-D)_U_"LAB" Q
...Q:'T
...S J=$P($G(^AUPNVLAB(X,11)),U,13) Q:J=""
...Q:'$$LOINC^BGP8D21(J,T)
...S BGPC=1_U_(9999999-D)_U_"LOINC"
...Q
I BGPC Q BGPC
;now get all loinc/taxonomy tests
S T=$O(^ATXAX("B","BGP LIVER FUNCTION LOINC",0))
S BGPLT=$O(^ATXLAB("B","BGP LIVER FUNCTION TESTS",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)!($P(BGPC,U)) D
.S L=0 F S L=$O(^AUPNVLAB("AE",P,D,L)) Q:L'=+L!($P(BGPC,U)) D
..S X=0 F S X=$O(^AUPNVLAB("AE",P,D,L,X)) Q:X'=+X!($P(BGPC,U)) D
...Q:'$D(^AUPNVLAB(X,0))
...I BGPLT,$P(^AUPNVLAB(X,0),U),$D(^ATXLAB(BGPLT,21,"B",$P(^AUPNVLAB(X,0),U))) S BGPC=1_U_(9999999-D)_U_"LAB" Q
...Q:'T
...S J=$P($G(^AUPNVLAB(X,11)),U,13) Q:J=""
...Q:'$$LOINC^BGP8D21(J,T)
...S BGPC=1_U_(9999999-D)_U_"LOINC"
...Q
Q BGPC
SERUM12(P,BDATE,EDATE) ;EP
K BGPC,BGPLAB
S BGPC=0
S T=$O(^ATXAX("B","BGP CREATININE CPTS",0))
S %="",E=+$$CODEN^ICPTCOD(85025),%=$$CPT^BGP8DU(P,BDATE,EDATE,T,3)
I %]"" S BGPC=BGPC+1,BGPC($P(%,U,1))=""
S T=$O(^ATXAX("B","BGP CREATININE CPTS",0))
S %="",E=+$$CODEN^ICPTCOD(85025),%=$$TRAN^BGP8DU(P,BDATE,EDATE,T,3)
I %]"" S BGPC=BGPC+1,BGPC($P(%,U,1))=""
;now get all loinc/taxonomy tests
S T=$O(^ATXAX("B","BGP CREATININE LOINC CODES",0))
S BGPLT=$O(^ATXLAB("B","DM AUDIT CREATININE 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 BGPLT,$P(^AUPNVLAB(X,0),U),$D(^ATXLAB(BGPLT,21,"B",$P(^AUPNVLAB(X,0),U))) S BGPC=BGPC+1,BGPC(9999999-D)="" Q
...Q:'T
...S J=$P($G(^AUPNVLAB(X,11)),U,13) Q:J=""
...Q:'$$LOINC^BGP8D21(J,T)
...S BGPC=BGPC+1,BGPC(9999999-D)=""
...Q
;now check to see if they are all spaced 10 days apart, if not, kill off the odd ones
S (X,Y)="",C=0 F S X=$O(BGPC(X)) Q:X'=+X S C=C+1 D
.I C=1 S Y=X Q
.I $$FMDIFF^XLFDT(X,Y)<11 K BGPC(X) Q
.S Y=X
S C=0,X=0 F S X=$O(BGPC(X)) Q:X'=+X S C=C+1
Q $S(C>11:1,1:"")
UP4(P,BDATE,EDATE) ;EP
K BGPC,BGPLAB
S BGPC=0
;now get all loinc/taxonomy tests
S T=$O(^ATXAX("B","DM AUDIT URINE PROTEIN TAX",0))
S BGPLT=$O(^ATXLAB("B","BGP URINE PROTEIN LOINC CODES",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 BGPLT,$P(^AUPNVLAB(X,0),U),$D(^ATXLAB(BGPLT,21,"B",$P(^AUPNVLAB(X,0),U))) S BGPC=BGPC+1,BGPC(9999999-D)="" Q
...Q:'T
...S J=$P($G(^AUPNVLAB(X,11)),U,13) Q:J=""
...Q:'$$LOINC^BGP8D21(J,T)
...S BGPC=BGPC+1,BGPC(9999999-D)=""
...Q
;now check to see if they are all spaced 10 days apart, if not, kill off the odd ones
S (X,Y)="",C=0 F S X=$O(BGPC(X)) Q:X'=+X S C=C+1 D
.I C=1 S Y=X Q
.I $$FMDIFF^XLFDT(X,Y)<11 K BGPC(X) Q
.S Y=X
S C=0,X=0 F S X=$O(BGPC(X)) Q:X'=+X S C=C+1
Q $S(C>3:1,1:"")
BGP8D861 ; IHS/CMI/LAB - measure C ;
+1 ;;18.1;IHS CLINICAL REPORTING;;MAY 25, 2018;Build 66
+2 ;
NDC(A,B) ;
+1 SET BGPNDC=$PIECE($GET(^PSDRUG(A,2)),U,4)
+2 IF BGPNDC]""
IF B
IF $DATA(^ATXAX(B,21,"B",BGPNDC))
QUIT 1
+3 QUIT 0
CBC4(P,BDATE,EDATE) ;EP
+1 KILL BGPC,BGPLAB
+2 SET BGPC=0
+3 SET %=""
SET E=+$$CODEN^ICPTCOD(85025)
SET %=$$CPTI^BGP8DU(P,BDATE,EDATE,E)
+4 IF %]""
SET BGPC=BGPC+1
SET BGPC($PIECE(%,U,2))=""
+5 SET %=""
SET E=+$$CODEN^ICPTCOD(85027)
SET %=$$CPTI^BGP8DU(P,BDATE,EDATE,E)
+6 IF %]""
SET BGPC=BGPC+1
SET BGPC($PIECE(%,U,2))=""
+7 SET %=""
SET E=+$$CODEN^ICPTCOD(85025)
SET %=$$TRANI^BGP8DU(P,BDATE,EDATE,E)
+8 IF %]""
SET BGPC=BGPC+1
SET BGPC($PIECE(%,U,2))=""
+9 SET %=""
SET E=+$$CODEN^ICPTCOD(85027)
SET %=$$TRANI^BGP8DU(P,BDATE,EDATE,E)
+10 IF %]""
SET BGPC=BGPC+1
SET BGPC($PIECE(%,U,2))=""
+11 ;now get all loinc/taxonomy tests
+12 SET T=$ORDER(^ATXAX("B","BGP CBC LOINC",0))
+13 SET BGPLT=$ORDER(^ATXLAB("B","BGP CBC TESTS",0))
+14 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
+15 SET L=0
FOR
SET L=$ORDER(^AUPNVLAB("AE",P,D,L))
IF L'=+L
QUIT
Begin DoDot:2
+16 SET X=0
FOR
SET X=$ORDER(^AUPNVLAB("AE",P,D,L,X))
IF X'=+X
QUIT
Begin DoDot:3
+17 IF '$DATA(^AUPNVLAB(X,0))
QUIT
+18 IF BGPLT
IF $PIECE(^AUPNVLAB(X,0),U)
IF $DATA(^ATXLAB(BGPLT,21,"B",$PIECE(^AUPNVLAB(X,0),U)))
SET BGPC=BGPC+1
SET BGPC(9999999-D)=""
QUIT
+19 IF 'T
QUIT
+20 SET J=$PIECE($GET(^AUPNVLAB(X,11)),U,13)
IF J=""
QUIT
+21 IF '$$LOINC^BGP8D21(J,T)
QUIT
+22 SET BGPC=BGPC+1
SET BGPC(9999999-D)=""
+23 QUIT
End DoDot:3
End DoDot:2
End DoDot:1
+24 ;now check to see if they are all spaced 10 days apart, if not, kill off the odd ones
+25 SET (X,Y)=""
SET C=0
FOR
SET X=$ORDER(BGPC(X))
IF X'=+X
QUIT
SET C=C+1
Begin DoDot:1
+26 IF C=1
SET Y=X
QUIT
+27 IF $$FMDIFF^XLFDT(X,Y)<11
KILL BGPC(X)
QUIT
+28 SET Y=X
End DoDot:1
+29 SET C=0
SET X=0
FOR
SET X=$ORDER(BGPC(X))
IF X'=+X
QUIT
SET C=C+1
+30 QUIT $SELECT(C>3:1,1:"")
CBC6(P,BDATE,EDATE) ;EP
+1 KILL BGPC,BGPLAB
+2 SET BGPC=0
+3 SET %=""
SET E=+$$CODEN^ICPTCOD(85025)
SET %=$$CPTI^BGP8DU(P,BDATE,EDATE,E)
+4 IF %]""
SET BGPC=BGPC+1
SET BGPC($PIECE(%,U,2))=""
+5 SET %=""
SET E=+$$CODEN^ICPTCOD(85027)
SET %=$$CPTI^BGP8DU(P,BDATE,EDATE,E)
+6 IF %]""
SET BGPC=BGPC+1
SET BGPC($PIECE(%,U,2))=""
+7 SET %=""
SET E=+$$CODEN^ICPTCOD(85025)
SET %=$$TRANI^BGP8DU(P,BDATE,EDATE,E)
+8 IF %]""
SET BGPC=BGPC+1
SET BGPC($PIECE(%,U,2))=""
+9 SET %=""
SET E=+$$CODEN^ICPTCOD(85027)
SET %=$$TRANI^BGP8DU(P,BDATE,EDATE,E)
+10 IF %]""
SET BGPC=BGPC+1
SET BGPC($PIECE(%,U,2))=""
+11 ;now get all loinc/taxonomy tests
+12 SET T=$ORDER(^ATXAX("B","BGP CBC LOINC",0))
+13 SET BGPLT=$ORDER(^ATXLAB("B","BGP CBC TESTS",0))
+14 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
+15 SET L=0
FOR
SET L=$ORDER(^AUPNVLAB("AE",P,D,L))
IF L'=+L
QUIT
Begin DoDot:2
+16 SET X=0
FOR
SET X=$ORDER(^AUPNVLAB("AE",P,D,L,X))
IF X'=+X
QUIT
Begin DoDot:3
+17 IF '$DATA(^AUPNVLAB(X,0))
QUIT
+18 IF BGPLT
IF $PIECE(^AUPNVLAB(X,0),U)
IF $DATA(^ATXLAB(BGPLT,21,"B",$PIECE(^AUPNVLAB(X,0),U)))
SET BGPC=BGPC+1
SET BGPC(9999999-D)=""
QUIT
+19 IF 'T
QUIT
+20 SET J=$PIECE($GET(^AUPNVLAB(X,11)),U,13)
IF J=""
QUIT
+21 IF '$$LOINC^BGP8D21(J,T)
QUIT
+22 SET BGPC=BGPC+1
SET BGPC(9999999-D)=""
+23 QUIT
End DoDot:3
End DoDot:2
End DoDot:1
+24 ;now check to see if they are all spaced 10 days apart, if not, kill off the odd ones
+25 SET (X,Y)=""
SET C=0
FOR
SET X=$ORDER(BGPC(X))
IF X'=+X
QUIT
SET C=C+1
Begin DoDot:1
+26 IF C=1
SET Y=X
QUIT
+27 IF $$FMDIFF^XLFDT(X,Y)<11
KILL BGPC(X)
QUIT
+28 SET Y=X
End DoDot:1
+29 SET C=0
SET X=0
FOR
SET X=$ORDER(BGPC(X))
IF X'=+X
QUIT
SET C=C+1
+30 QUIT $SELECT(C>5:1,1:"")
SERUM6(P,BDATE,EDATE) ;EP
+1 KILL BGPC,BGPLAB
+2 SET BGPC=0
+3 SET T=$ORDER(^ATXAX("B","BGP CREATININE CPTS",0))
+4 SET %=$$CPT^BGP8DU(P,BDATE,EDATE,T,3)
+5 IF %]""
SET BGPC=BGPC+1
SET BGPC($PIECE(%,U,1))=""
+6 SET T=$ORDER(^ATXAX("B","BGP CREATININE CPTS",0))
+7 SET %=$$TRAN^BGP8DU(P,BDATE,EDATE,T,3)
+8 IF %]""
SET BGPC=BGPC+1
SET BGPC($PIECE(%,U,1))=""
+9 ;now get all loinc/taxonomy tests
+10 SET T=$ORDER(^ATXAX("B","BGP CREATININE LOINC CODES",0))
+11 SET BGPLT=$ORDER(^ATXLAB("B","DM AUDIT CREATININE TAX",0))
+12 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
+13 SET L=0
FOR
SET L=$ORDER(^AUPNVLAB("AE",P,D,L))
IF L'=+L
QUIT
Begin DoDot:2
+14 SET X=0
FOR
SET X=$ORDER(^AUPNVLAB("AE",P,D,L,X))
IF X'=+X
QUIT
Begin DoDot:3
+15 IF '$DATA(^AUPNVLAB(X,0))
QUIT
+16 IF BGPLT
IF $PIECE(^AUPNVLAB(X,0),U)
IF $DATA(^ATXLAB(BGPLT,21,"B",$PIECE(^AUPNVLAB(X,0),U)))
SET BGPC=BGPC+1
SET BGPC(9999999-D)=""
QUIT
+17 IF 'T
QUIT
+18 SET J=$PIECE($GET(^AUPNVLAB(X,11)),U,13)
IF J=""
QUIT
+19 IF '$$LOINC^BGP8D21(J,T)
QUIT
+20 SET BGPC=BGPC+1
SET BGPC(9999999-D)=""
+21 QUIT
End DoDot:3
End DoDot:2
End DoDot:1
+22 ;now check to see if they are all spaced 10 days apart, if not, kill off the odd ones
+23 SET (X,Y)=""
SET C=0
FOR
SET X=$ORDER(BGPC(X))
IF X'=+X
QUIT
SET C=C+1
Begin DoDot:1
+24 IF C=1
SET Y=X
QUIT
+25 IF $$FMDIFF^XLFDT(X,Y)<11
KILL BGPC(X)
QUIT
+26 SET Y=X
End DoDot:1
+27 SET C=0
SET X=0
FOR
SET X=$ORDER(BGPC(X))
IF X'=+X
QUIT
SET C=C+1
+28 QUIT $SELECT(C>5:1,1:"")
LFT6(P,BDATE,EDATE) ;EP
+1 KILL BGPC
+2 SET BGPC=0
+3 SET %=""
SET E=+$$CODEN^ICPTCOD(84460)
SET %=$$CPTI^BGP8DU(P,BDATE,EDATE,E)
+4 IF %]""
SET BGPC=BGPC+1
SET BGPC($PIECE(%,U,2))=""
+5 SET %=""
SET E=+$$CODEN^ICPTCOD(84450)
SET %=$$CPTI^BGP8DU(P,BDATE,EDATE,E)
+6 IF %]""
SET BGPC=BGPC+1
SET BGPC($PIECE(%,U,2))=""
+7 SET %=""
SET E=+$$CODEN^ICPTCOD(80076)
SET %=$$CPTI^BGP8DU(P,BDATE,EDATE,E)
+8 IF %]""
SET BGPC=BGPC+1
SET BGPC($PIECE(%,U,2))=""
+9 ;TRAN
+10 SET %=""
SET E=+$$CODEN^ICPTCOD(84460)
SET %=$$TRANI^BGP8DU(P,BDATE,EDATE,E)
+11 IF %]""
SET BGPC=BGPC+1
SET BGPC($PIECE(%,U,2))=""
+12 SET %=""
SET E=+$$CODEN^ICPTCOD(84450)
SET %=$$TRANI^BGP8DU(P,BDATE,EDATE,E)
+13 IF %]""
SET BGPC=BGPC+1
SET BGPC($PIECE(%,U,2))=""
+14 SET %=""
SET E=+$$CODEN^ICPTCOD(80076)
SET %=$$TRANI^BGP8DU(P,BDATE,EDATE,E)
+15 IF %]""
SET BGPC=BGPC+1
SET BGPC($PIECE(%,U,2))=""
+16 ;now get all loinc/taxonomy tests
+17 SET T=$ORDER(^ATXAX("B","BGP ALT LOINC",0))
+18 SET BGPLT=$ORDER(^ATXLAB("B","DM AUDIT ALT TAX",0))
+19 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
+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 BGPLT
IF $PIECE(^AUPNVLAB(X,0),U)
IF $DATA(^ATXLAB(BGPLT,21,"B",$PIECE(^AUPNVLAB(X,0),U)))
SET BGPC=BGPC+1
SET BGPC(9999999-D)=""
QUIT
+24 IF 'T
QUIT
+25 SET J=$PIECE($GET(^AUPNVLAB(X,11)),U,13)
IF J=""
QUIT
+26 IF '$$LOINC^BGP8D21(J,T)
QUIT
+27 SET BGPC=BGPC+1
SET BGPC(9999999-D)=""
+28 QUIT
End DoDot:3
End DoDot:2
End DoDot:1
+29 ;now get all AST
+30 SET T=$ORDER(^ATXAX("B","BGP AST LOINC",0))
+31 SET BGPLT=$ORDER(^ATXLAB("B","DM AUDIT AST TAX",0))
+32 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
+33 SET L=0
FOR
SET L=$ORDER(^AUPNVLAB("AE",P,D,L))
IF L'=+L
QUIT
Begin DoDot:2
+34 SET X=0
FOR
SET X=$ORDER(^AUPNVLAB("AE",P,D,L,X))
IF X'=+X
QUIT
Begin DoDot:3
+35 IF '$DATA(^AUPNVLAB(X,0))
QUIT
+36 IF BGPLT
IF $PIECE(^AUPNVLAB(X,0),U)
IF $DATA(^ATXLAB(BGPLT,21,"B",$PIECE(^AUPNVLAB(X,0),U)))
SET BGPC=BGPC+1
SET BGPC(9999999-D)=""
QUIT
+37 IF 'T
QUIT
+38 SET J=$PIECE($GET(^AUPNVLAB(X,11)),U,13)
IF J=""
QUIT
+39 IF '$$LOINC^BGP8D21(J,T)
QUIT
+40 SET BGPC=BGPC+1
SET BGPC(9999999-D)=""
+41 QUIT
End DoDot:3
End DoDot:2
End DoDot:1
+42 ;now get all loinc/taxonomy tests
+43 SET T=$ORDER(^ATXAX("B","BGP LIVER FUNCTION LOINC",0))
+44 SET BGPLT=$ORDER(^ATXLAB("B","BGP LIVER FUNCTION TESTS",0))
+45 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
+46 SET L=0
FOR
SET L=$ORDER(^AUPNVLAB("AE",P,D,L))
IF L'=+L
QUIT
Begin DoDot:2
+47 SET X=0
FOR
SET X=$ORDER(^AUPNVLAB("AE",P,D,L,X))
IF X'=+X
QUIT
Begin DoDot:3
+48 IF '$DATA(^AUPNVLAB(X,0))
QUIT
+49 IF BGPLT
IF $PIECE(^AUPNVLAB(X,0),U)
IF $DATA(^ATXLAB(BGPLT,21,"B",$PIECE(^AUPNVLAB(X,0),U)))
SET BGPC=BGPC+1
SET BGPC(9999999-D)=""
QUIT
+50 IF 'T
QUIT
+51 SET J=$PIECE($GET(^AUPNVLAB(X,11)),U,13)
IF J=""
QUIT
+52 IF '$$LOINC^BGP8D21(J,T)
QUIT
+53 SET BGPC=BGPC+1
SET BGPC(9999999-D)=""
+54 QUIT
End DoDot:3
End DoDot:2
End DoDot:1
+55 ;now check to see if they are all spaced 10 days apart, if not, kill off the odd ones
+56 SET (X,Y)=""
SET C=0
FOR
SET X=$ORDER(BGPC(X))
IF X'=+X
QUIT
SET C=C+1
Begin DoDot:1
+57 IF C=1
SET Y=X
QUIT
+58 IF $$FMDIFF^XLFDT(X,Y)<11
KILL BGPC(X)
QUIT
+59 SET Y=X
End DoDot:1
+60 SET C=0
SET X=0
FOR
SET X=$ORDER(BGPC(X))
IF X'=+X
QUIT
SET C=C+1
+61 QUIT $SELECT(C>5:1,1:"")
CBC(P,BDATE,EDATE) ;EP
+1 KILL BGPC
+2 SET BGPC=0
+3 SET %=""
SET E=+$$CODEN^ICPTCOD(85025)
SET %=$$CPTI^BGP8DU(P,BDATE,EDATE,E)
+4 IF %]""
SET BGPC=1_U_$PIECE(%,U,2)_U_"85025"
+5 SET %=""
SET E=+$$CODEN^ICPTCOD(85027)
SET %=$$CPTI^BGP8DU(P,BDATE,EDATE,E)
+6 IF %]""
SET BGPC=1_U_$PIECE(%,U,2)_U_"85027"
+7 SET %=""
SET E=+$$CODEN^ICPTCOD(85025)
SET %=$$TRANI^BGP8DU(P,BDATE,EDATE,E)
+8 IF %]""
SET BGPC=1_U_$PIECE(%,U,2)_U_"85025 TRAN"
+9 SET %=""
SET E=+$$CODEN^ICPTCOD(85027)
SET %=$$TRANI^BGP8DU(P,BDATE,EDATE,E)
+10 IF %]""
SET BGPC=1_U_$PIECE(%,U,2)_U_"85027 TRAN"
+11 ;now get all loinc/taxonomy tests
+12 SET T=$ORDER(^ATXAX("B","BGP CBC LOINC",0))
+13 SET BGPLT=$ORDER(^ATXLAB("B","BGP CBC TESTS",0))
+14 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)!($PIECE(BGPC,U))
QUIT
Begin DoDot:1
+15 SET L=0
FOR
SET L=$ORDER(^AUPNVLAB("AE",P,D,L))
IF L'=+L!($PIECE(BGPC,U))
QUIT
Begin DoDot:2
+16 SET X=0
FOR
SET X=$ORDER(^AUPNVLAB("AE",P,D,L,X))
IF X'=+X!($PIECE(BGPC,U))
QUIT
Begin DoDot:3
+17 IF '$DATA(^AUPNVLAB(X,0))
QUIT
+18 IF BGPLT
IF $PIECE(^AUPNVLAB(X,0),U)
IF $DATA(^ATXLAB(BGPLT,21,"B",$PIECE(^AUPNVLAB(X,0),U)))
SET BGPC=1_U_(9999999-D)_U_"LAB"
QUIT
+19 IF 'T
QUIT
+20 SET J=$PIECE($GET(^AUPNVLAB(X,11)),U,13)
IF J=""
QUIT
+21 IF '$$LOINC^BGP8D21(J,T)
QUIT
+22 SET BGPC=1_U_(9999999-D)_U_"LOINC"
+23 QUIT
End DoDot:3
End DoDot:2
End DoDot:1
+24 QUIT BGPC
POT(P,BDATE,EDATE) ;EP
+1 KILL BGPC
+2 SET BGPC=0
+3 SET %=""
SET E=+$$CODEN^ICPTCOD(84132)
SET %=$$CPTI^BGP8DU(P,BDATE,EDATE,E)
+4 IF %]""
SET BGPC=1_U_$PIECE(%,U,2)_U_"84132"
+5 SET %=""
SET E=+$$CODEN^ICPTCOD(84132)
SET %=$$TRANI^BGP8DU(P,BDATE,EDATE,E)
+6 IF %]""
SET BGPC=1_U_$PIECE(%,U,2)_U_"84132 TRAN"
+7 ;now get all loinc/taxonomy tests
+8 SET T=$ORDER(^ATXAX("B","BGP POTASSIUM LOINC",0))
+9 SET BGPLT=$ORDER(^ATXLAB("B","BGP POTASSIUM TESTS",0))
+10 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)!($PIECE(BGPC,U))
QUIT
Begin DoDot:1
+11 SET L=0
FOR
SET L=$ORDER(^AUPNVLAB("AE",P,D,L))
IF L'=+L!($PIECE(BGPC,U))
QUIT
Begin DoDot:2
+12 SET X=0
FOR
SET X=$ORDER(^AUPNVLAB("AE",P,D,L,X))
IF X'=+X!($PIECE(BGPC,U))
QUIT
Begin DoDot:3
+13 IF '$DATA(^AUPNVLAB(X,0))
QUIT
+14 IF BGPLT
IF $PIECE(^AUPNVLAB(X,0),U)
IF $DATA(^ATXLAB(BGPLT,21,"B",$PIECE(^AUPNVLAB(X,0),U)))
SET BGPC=1_U_(9999999-D)_U_"LAB"
QUIT
+15 IF 'T
QUIT
+16 SET J=$PIECE($GET(^AUPNVLAB(X,11)),U,13)
IF J=""
QUIT
+17 IF '$$LOINC^BGP8D21(J,T)
QUIT
+18 SET BGPC=1_U_(9999999-D)_U_"LOINC"
+19 QUIT
End DoDot:3
End DoDot:2
End DoDot:1
+20 QUIT BGPC
LFT(P,BDATE,EDATE) ;EP
+1 KILL BGPC
+2 SET BGPC=0
+3 SET %=""
SET E=+$$CODEN^ICPTCOD(84460)
SET %=$$CPTI^BGP8DU(P,BDATE,EDATE,E)
+4 IF %]""
SET BGPC=1_U_$PIECE(%,U,2)_U_"84460"
+5 SET %=""
SET E=+$$CODEN^ICPTCOD(84450)
SET %=$$CPTI^BGP8DU(P,BDATE,EDATE,E)
+6 IF %]""
SET BGPC=1_U_$PIECE(%,U,2)_U_"84450"
+7 SET %=""
SET E=+$$CODEN^ICPTCOD(80076)
SET %=$$CPTI^BGP8DU(P,BDATE,EDATE,E)
+8 IF %]""
SET BGPC=1_U_$PIECE(%,U,2)_U_"80076"
+9 ;TRAN
+10 SET %=""
SET E=+$$CODEN^ICPTCOD(84460)
SET %=$$TRANI^BGP8DU(P,BDATE,EDATE,E)
+11 IF %]""
SET BGPC=1_U_$PIECE(%,U,2)_U_"84460 TRAN"
+12 SET %=""
SET E=+$$CODEN^ICPTCOD(84450)
SET %=$$TRANI^BGP8DU(P,BDATE,EDATE,E)
+13 IF %]""
SET BGPC=1_U_$PIECE(%,U,2)_U_"84450 TRAN"
+14 SET %=""
SET E=+$$CODEN^ICPTCOD(80076)
SET %=$$TRANI^BGP8DU(P,BDATE,EDATE,E)
+15 IF %]""
SET BGPC=1_U_$PIECE(%,U,2)_U_"80076 TRAN"
+16 ;now get all loinc/taxonomy tests
+17 SET T=$ORDER(^ATXAX("B","BGP ALT LOINC",0))
+18 SET BGPLT=$ORDER(^ATXLAB("B","DM AUDIT ALT TAX",0))
+19 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)!($PIECE(BGPC,U))
QUIT
Begin DoDot:1
+20 SET L=0
FOR
SET L=$ORDER(^AUPNVLAB("AE",P,D,L))
IF L'=+L!($PIECE(BGPC,U))
QUIT
Begin DoDot:2
+21 SET X=0
FOR
SET X=$ORDER(^AUPNVLAB("AE",P,D,L,X))
IF X'=+X!($PIECE(BGPC,U))
QUIT
Begin DoDot:3
+22 IF '$DATA(^AUPNVLAB(X,0))
QUIT
+23 IF BGPLT
IF $PIECE(^AUPNVLAB(X,0),U)
IF $DATA(^ATXLAB(BGPLT,21,"B",$PIECE(^AUPNVLAB(X,0),U)))
SET BGPC=1_U_(9999999-D)_U_"LAB"
QUIT
+24 IF 'T
QUIT
+25 SET J=$PIECE($GET(^AUPNVLAB(X,11)),U,13)
IF J=""
QUIT
+26 IF '$$LOINC^BGP8D21(J,T)
QUIT
+27 SET BGPC=1_U_(9999999-D)_U_"LOINC"
+28 QUIT
End DoDot:3
End DoDot:2
End DoDot:1
+29 IF BGPC
QUIT BGPC
+30 ;now get all AST
+31 SET T=$ORDER(^ATXAX("B","BGP AST LOINC",0))
+32 SET BGPLT=$ORDER(^ATXLAB("B","DM AUDIT AST TAX",0))
+33 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)!($PIECE(BGPC,U))
QUIT
Begin DoDot:1
+34 SET L=0
FOR
SET L=$ORDER(^AUPNVLAB("AE",P,D,L))
IF L'=+L!($PIECE(BGPC,U))
QUIT
Begin DoDot:2
+35 SET X=0
FOR
SET X=$ORDER(^AUPNVLAB("AE",P,D,L,X))
IF X'=+X!($PIECE(BGPC,U))
QUIT
Begin DoDot:3
+36 IF '$DATA(^AUPNVLAB(X,0))
QUIT
+37 IF BGPLT
IF $PIECE(^AUPNVLAB(X,0),U)
IF $DATA(^ATXLAB(BGPLT,21,"B",$PIECE(^AUPNVLAB(X,0),U)))
SET BGPC=1_U_(9999999-D)_U_"LAB"
QUIT
+38 IF 'T
QUIT
+39 SET J=$PIECE($GET(^AUPNVLAB(X,11)),U,13)
IF J=""
QUIT
+40 IF '$$LOINC^BGP8D21(J,T)
QUIT
+41 SET BGPC=1_U_(9999999-D)_U_"LOINC"
+42 QUIT
End DoDot:3
End DoDot:2
End DoDot:1
+43 IF BGPC
QUIT BGPC
+44 ;now get all loinc/taxonomy tests
+45 SET T=$ORDER(^ATXAX("B","BGP LIVER FUNCTION LOINC",0))
+46 SET BGPLT=$ORDER(^ATXLAB("B","BGP LIVER FUNCTION TESTS",0))
+47 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)!($PIECE(BGPC,U))
QUIT
Begin DoDot:1
+48 SET L=0
FOR
SET L=$ORDER(^AUPNVLAB("AE",P,D,L))
IF L'=+L!($PIECE(BGPC,U))
QUIT
Begin DoDot:2
+49 SET X=0
FOR
SET X=$ORDER(^AUPNVLAB("AE",P,D,L,X))
IF X'=+X!($PIECE(BGPC,U))
QUIT
Begin DoDot:3
+50 IF '$DATA(^AUPNVLAB(X,0))
QUIT
+51 IF BGPLT
IF $PIECE(^AUPNVLAB(X,0),U)
IF $DATA(^ATXLAB(BGPLT,21,"B",$PIECE(^AUPNVLAB(X,0),U)))
SET BGPC=1_U_(9999999-D)_U_"LAB"
QUIT
+52 IF 'T
QUIT
+53 SET J=$PIECE($GET(^AUPNVLAB(X,11)),U,13)
IF J=""
QUIT
+54 IF '$$LOINC^BGP8D21(J,T)
QUIT
+55 SET BGPC=1_U_(9999999-D)_U_"LOINC"
+56 QUIT
End DoDot:3
End DoDot:2
End DoDot:1
+57 QUIT BGPC
SERUM12(P,BDATE,EDATE) ;EP
+1 KILL BGPC,BGPLAB
+2 SET BGPC=0
+3 SET T=$ORDER(^ATXAX("B","BGP CREATININE CPTS",0))
+4 SET %=""
SET E=+$$CODEN^ICPTCOD(85025)
SET %=$$CPT^BGP8DU(P,BDATE,EDATE,T,3)
+5 IF %]""
SET BGPC=BGPC+1
SET BGPC($PIECE(%,U,1))=""
+6 SET T=$ORDER(^ATXAX("B","BGP CREATININE CPTS",0))
+7 SET %=""
SET E=+$$CODEN^ICPTCOD(85025)
SET %=$$TRAN^BGP8DU(P,BDATE,EDATE,T,3)
+8 IF %]""
SET BGPC=BGPC+1
SET BGPC($PIECE(%,U,1))=""
+9 ;now get all loinc/taxonomy tests
+10 SET T=$ORDER(^ATXAX("B","BGP CREATININE LOINC CODES",0))
+11 SET BGPLT=$ORDER(^ATXLAB("B","DM AUDIT CREATININE TAX",0))
+12 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
+13 SET L=0
FOR
SET L=$ORDER(^AUPNVLAB("AE",P,D,L))
IF L'=+L
QUIT
Begin DoDot:2
+14 SET X=0
FOR
SET X=$ORDER(^AUPNVLAB("AE",P,D,L,X))
IF X'=+X
QUIT
Begin DoDot:3
+15 IF '$DATA(^AUPNVLAB(X,0))
QUIT
+16 IF BGPLT
IF $PIECE(^AUPNVLAB(X,0),U)
IF $DATA(^ATXLAB(BGPLT,21,"B",$PIECE(^AUPNVLAB(X,0),U)))
SET BGPC=BGPC+1
SET BGPC(9999999-D)=""
QUIT
+17 IF 'T
QUIT
+18 SET J=$PIECE($GET(^AUPNVLAB(X,11)),U,13)
IF J=""
QUIT
+19 IF '$$LOINC^BGP8D21(J,T)
QUIT
+20 SET BGPC=BGPC+1
SET BGPC(9999999-D)=""
+21 QUIT
End DoDot:3
End DoDot:2
End DoDot:1
+22 ;now check to see if they are all spaced 10 days apart, if not, kill off the odd ones
+23 SET (X,Y)=""
SET C=0
FOR
SET X=$ORDER(BGPC(X))
IF X'=+X
QUIT
SET C=C+1
Begin DoDot:1
+24 IF C=1
SET Y=X
QUIT
+25 IF $$FMDIFF^XLFDT(X,Y)<11
KILL BGPC(X)
QUIT
+26 SET Y=X
End DoDot:1
+27 SET C=0
SET X=0
FOR
SET X=$ORDER(BGPC(X))
IF X'=+X
QUIT
SET C=C+1
+28 QUIT $SELECT(C>11:1,1:"")
UP4(P,BDATE,EDATE) ;EP
+1 KILL BGPC,BGPLAB
+2 SET BGPC=0
+3 ;now get all loinc/taxonomy tests
+4 SET T=$ORDER(^ATXAX("B","DM AUDIT URINE PROTEIN TAX",0))
+5 SET BGPLT=$ORDER(^ATXLAB("B","BGP URINE PROTEIN LOINC CODES",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 IF BGPLT
IF $PIECE(^AUPNVLAB(X,0),U)
IF $DATA(^ATXLAB(BGPLT,21,"B",$PIECE(^AUPNVLAB(X,0),U)))
SET BGPC=BGPC+1
SET BGPC(9999999-D)=""
QUIT
+11 IF 'T
QUIT
+12 SET J=$PIECE($GET(^AUPNVLAB(X,11)),U,13)
IF J=""
QUIT
+13 IF '$$LOINC^BGP8D21(J,T)
QUIT
+14 SET BGPC=BGPC+1
SET BGPC(9999999-D)=""
+15 QUIT
End DoDot:3
End DoDot:2
End DoDot:1
+16 ;now check to see if they are all spaced 10 days apart, if not, kill off the odd ones
+17 SET (X,Y)=""
SET C=0
FOR
SET X=$ORDER(BGPC(X))
IF X'=+X
QUIT
SET C=C+1
Begin DoDot:1
+18 IF C=1
SET Y=X
QUIT
+19 IF $$FMDIFF^XLFDT(X,Y)<11
KILL BGPC(X)
QUIT
+20 SET Y=X
End DoDot:1
+21 SET C=0
SET X=0
FOR
SET X=$ORDER(BGPC(X))
IF X'=+X
QUIT
SET C=C+1
+22 QUIT $SELECT(C>3:1,1:"")
