BGP0D73 ; IHS/CMI/LAB - measure 31 ;
;;10.0;IHS CLINICAL REPORTING;;JUN 18, 2010
;
;
ID ;EP
S (BGPN1,BGPN2,BGPN3,BGPN4,BGPN5,BGPN6,BGPN7,BGPD1,BGPD2,BGPD3,BGPD4,BGPD5,BGPD6,BGPD7,BGPD8,BGPD9)=0
S BGPVALUE=""
;I BGPAGEB<23 S BGPSTOP=1 Q
I BGPACTUP,BGPAGEB>22 S BGPD1=1
I BGPACTCL,BGPACTUP,BGPAGEB>22 S BGPD2=1
I BGPACTCL,$$IHD^BGP0D721(DFN,BGP365,BGPEDATE) S BGPIHD=1,BGPD3=1
I '(BGPD1+BGPD2+BGPD3) S BGPSTOP=1 Q
CHEL ;EP - called from elder care
S BGPVALUE=$$CHOL(DFN,$$FMADD^XLFDT(BGPEDATE,-(5*365)),BGPEDATE)
I $P(BGPVALUE,U,1)]"" S BGPN1=1
S R=$P(BGPVALUE,U,3),R=+R I R,R>239 S BGPN2=1
S BGPLDL=$$LDL^BGP0D2(DFN,$$FMADD^XLFDT(BGPEDATE,-(5*365)),BGPEDATE) ;date^value
I $P(BGPLDL,U)=1 S BGPN3=1
I $P(BGPLDL,U,3)]"" D
.S V=$P(BGPLDL,U,3)
.I V["CPT" S:V["3048F" BGPN4=1 Q
.S V=+V
.I 'V Q
.I V]"",+V'>100 S BGPN4=1
.I +V>100,+V<131 S BGPN5=1
.I +V>130,+V<161 S BGPN6=1
.I +V>160 S BGPN7=1
S V=$S(BGPD1:"UP",1:"")_$S(BGPD2:";AC",1:"")_$S(BGPD3:";IHD",1:"")_"|||"
I BGPVALUE]"" S V=V_"CHOL "_$$DATE^BGP0UTL($P(BGPVALUE,U,2))_" "_$P(BGPVALUE,U,3)
I $P(BGPLDL,U) S V=V_";LDL "_$$DATE^BGP0UTL($P(BGPLDL,U,2))_" "_$P(BGPLDL,U,3)
S BGPVALUE=V
K X,Y,Z,%,A,B,C,D,E,H,BDATE,EDATE,P,V,S,F,T,BGPLDL
Q
CHOL(P,BDATE,EDATE,NORES) ;EP
K BGPG,BGPT,BGPC
S BGPC=0
S NORES=$G(NORES)
;now get all loinc/taxonomy tests
S T=$O(^ATXAX("B","BGP TOTAL CHOLESTEROL LOINC",0))
S BGPLT=$O(^ATXLAB("B","DM AUDIT CHOLESTEROL 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,BGPT(D,BGPC)=$P(^AUPNVLAB(X,0),U,4) Q
...Q:'T
...S J=$P($G(^AUPNVLAB(X,11)),U,13) Q:J=""
...Q:'$$LOINC(J,T)
...S R=$P(^AUPNVLAB(X,0),U,4)
...S BGPC=BGPC+1,BGPT(D,BGPC)=R
...Q
; now got though and set return value of done 1 or 0^VALUE^date
S D=0,G="" F S D=$O(BGPT(D)) Q:D'=+D!(G]"") D
.S C=0 F S C=$O(BGPT(D,C)) Q:C'=+C!(G]"") D
..S X=BGPT(D,C)
..I $E(X)'=+$E(X) Q
..S G=(9999999-D)_U_X
..Q
I 'NORES,G]"" Q 1_U_G ;IF WANT A RESULT AND THERE IS ONE QUIT
S E=+$$CODEN^ICPTCOD(82465),%=$$CPTI^BGP0DU(P,BDATE,EDATE,E) I %]"" Q $P(%,U,2)_"^CPT 82465"
S E=+$$CODEN^ICPTCOD(82465),%=$$TRANI^BGP0DU(P,BDATE,EDATE,E) I %]"" Q $P(%,U,2)_"^TRAN 82465"
Q ""
;
LOINC(A,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 ""
BGP0D73 ; IHS/CMI/LAB - measure 31 ;
+1 ;;10.0;IHS CLINICAL REPORTING;;JUN 18, 2010
+2 ;
+3 ;
ID ;EP
+1 SET (BGPN1,BGPN2,BGPN3,BGPN4,BGPN5,BGPN6,BGPN7,BGPD1,BGPD2,BGPD3,BGPD4,BGPD5,BGPD6,BGPD7,BGPD8,BGPD9)=0
+2 SET BGPVALUE=""
+3 ;I BGPAGEB<23 S BGPSTOP=1 Q
+4 IF BGPACTUP
IF BGPAGEB>22
SET BGPD1=1
+5 IF BGPACTCL
IF BGPACTUP
IF BGPAGEB>22
SET BGPD2=1
+6 IF BGPACTCL
IF $$IHD^BGP0D721(DFN,BGP365,BGPEDATE)
SET BGPIHD=1
SET BGPD3=1
+7 IF '(BGPD1+BGPD2+BGPD3)
SET BGPSTOP=1
QUIT
CHEL ;EP - called from elder care
+1 SET BGPVALUE=$$CHOL(DFN,$$FMADD^XLFDT(BGPEDATE,-(5*365)),BGPEDATE)
+2 IF $PIECE(BGPVALUE,U,1)]""
SET BGPN1=1
+3 SET R=$PIECE(BGPVALUE,U,3)
SET R=+R
IF R
IF R>239
SET BGPN2=1
+4 ;date^value
SET BGPLDL=$$LDL^BGP0D2(DFN,$$FMADD^XLFDT(BGPEDATE,-(5*365)),BGPEDATE)
+5 IF $PIECE(BGPLDL,U)=1
SET BGPN3=1
+6 IF $PIECE(BGPLDL,U,3)]""
Begin DoDot:1
+7 SET V=$PIECE(BGPLDL,U,3)
+8 IF V["CPT"
IF V["3048F"
SET BGPN4=1
QUIT
+9 SET V=+V
+10 IF 'V
QUIT
+11 IF V]""
IF +V'>100
SET BGPN4=1
+12 IF +V>100
IF +V<131
SET BGPN5=1
+13 IF +V>130
IF +V<161
SET BGPN6=1
+14 IF +V>160
SET BGPN7=1
End DoDot:1
+15 SET V=$SELECT(BGPD1:"UP",1:"")_$SELECT(BGPD2:";AC",1:"")_$SELECT(BGPD3:";IHD",1:"")_"|||"
+16 IF BGPVALUE]""
SET V=V_"CHOL "_$$DATE^BGP0UTL($PIECE(BGPVALUE,U,2))_" "_$PIECE(BGPVALUE,U,3)
+17 IF $PIECE(BGPLDL,U)
SET V=V_";LDL "_$$DATE^BGP0UTL($PIECE(BGPLDL,U,2))_" "_$PIECE(BGPLDL,U,3)
+18 SET BGPVALUE=V
+19 KILL X,Y,Z,%,A,B,C,D,E,H,BDATE,EDATE,P,V,S,F,T,BGPLDL
+20 QUIT
CHOL(P,BDATE,EDATE,NORES) ;EP
+1 KILL BGPG,BGPT,BGPC
+2 SET BGPC=0
+3 SET NORES=$GET(NORES)
+4 ;now get all loinc/taxonomy tests
+5 SET T=$ORDER(^ATXAX("B","BGP TOTAL CHOLESTEROL LOINC",0))
+6 SET BGPLT=$ORDER(^ATXLAB("B","DM AUDIT CHOLESTEROL TAX",0))
+7 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
+8 SET L=0
FOR
SET L=$ORDER(^AUPNVLAB("AE",P,D,L))
IF L'=+L
QUIT
Begin DoDot:2
+9 SET X=0
FOR
SET X=$ORDER(^AUPNVLAB("AE",P,D,L,X))
IF X'=+X
QUIT
Begin DoDot:3
+10 IF '$DATA(^AUPNVLAB(X,0))
QUIT
+11 IF BGPLT
IF $PIECE(^AUPNVLAB(X,0),U)
IF $DATA(^ATXLAB(BGPLT,21,"B",$PIECE(^AUPNVLAB(X,0),U)))
SET BGPC=BGPC+1
SET BGPT(D,BGPC)=$PIECE(^AUPNVLAB(X,0),U,4)
QUIT
+12 IF 'T
QUIT
+13 SET J=$PIECE($GET(^AUPNVLAB(X,11)),U,13)
IF J=""
QUIT
+14 IF '$$LOINC(J,T)
QUIT
+15 SET R=$PIECE(^AUPNVLAB(X,0),U,4)
+16 SET BGPC=BGPC+1
SET BGPT(D,BGPC)=R
+17 QUIT
End DoDot:3
End DoDot:2
End DoDot:1
+18 ; now got though and set return value of done 1 or 0^VALUE^date
+19 SET D=0
SET G=""
FOR
SET D=$ORDER(BGPT(D))
IF D'=+D!(G]"")
QUIT
Begin DoDot:1
+20 SET C=0
FOR
SET C=$ORDER(BGPT(D,C))
IF C'=+C!(G]"")
QUIT
Begin DoDot:2
+21 SET X=BGPT(D,C)
+22 IF $EXTRACT(X)'=+$EXTRACT(X)
QUIT
+23 SET G=(9999999-D)_U_X
+24 QUIT
End DoDot:2
End DoDot:1
+25 ;IF WANT A RESULT AND THERE IS ONE QUIT
IF 'NORES
IF G]""
QUIT 1_U_G
+26 SET E=+$$CODEN^ICPTCOD(82465)
SET %=$$CPTI^BGP0DU(P,BDATE,EDATE,E)
IF %]""
QUIT $PIECE(%,U,2)_"^CPT 82465"
+27 SET E=+$$CODEN^ICPTCOD(82465)
SET %=$$TRANI^BGP0DU(P,BDATE,EDATE,E)
IF %]""
QUIT $PIECE(%,U,2)_"^TRAN 82465"
+28 QUIT ""
+29 ;
LOINC(A,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 ""
