- BGP3D73 ; IHS/CMI/LAB - measure 31 ;
- ;;13.0;IHS CLINICAL REPORTING;;NOV 20, 2012;Build 81
- ;
- ;
- ID ;EP
- S (BGPN1,BGPN2,BGPN3,BGPN4,BGPN5,BGPN6,BGPN7,BGPD1,BGPD2,BGPD3,BGPD4,BGPD5,BGPD6,BGPD7,BGPD8,BGPD9)=0
- S BGPVALUE=""
- I BGPACTUP,BGPAGEB>22 S BGPD1=1
- I BGPACTCL,BGPACTUP,BGPAGEB>22 S BGPD2=1
- I BGPACTCL,$$CHD^BGP3D729(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^BGP3D2(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:",CHD",1:"")_"|||"
- I BGPVALUE]"" S V=V_"CHOL: "_$$DATE^BGP3UTL($P(BGPVALUE,U,2))_" "_$P(BGPVALUE,U,3)
- I $P(BGPLDL,U) S V=V_$S(BGPVALUE]"":"; ",1:"") S V=V_"LDL: "_$$DATE^BGP3UTL($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^BGP3DU(P,BDATE,EDATE,E) I %]"" Q $P(%,U,2)_"^CPT 82465"
- S E=+$$CODEN^ICPTCOD(82465),%=$$TRANI^BGP3DU(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 ""
- BGP3D73 ; IHS/CMI/LAB - measure 31 ;
- +1 ;;13.0;IHS CLINICAL REPORTING;;NOV 20, 2012;Build 81
- +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 IF BGPACTUP
- IF BGPAGEB>22
- SET BGPD1=1
- +4 IF BGPACTCL
- IF BGPACTUP
- IF BGPAGEB>22
- SET BGPD2=1
- +5 IF BGPACTCL
- IF $$CHD^BGP3D729(DFN,BGP365,BGPEDATE)
- SET BGPIHD=1
- SET BGPD3=1
- +6 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^BGP3D2(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:",CHD",1:"")_"|||"
- +16 IF BGPVALUE]""
- SET V=V_"CHOL: "_$$DATE^BGP3UTL($PIECE(BGPVALUE,U,2))_" "_$PIECE(BGPVALUE,U,3)
- +17 IF $PIECE(BGPLDL,U)
- SET V=V_$SELECT(BGPVALUE]"":"; ",1:"")
- SET V=V_"LDL: "_$$DATE^BGP3UTL($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^BGP3DU(P,BDATE,EDATE,E)
- IF %]""
- QUIT $PIECE(%,U,2)_"^CPT 82465"
- +27 SET E=+$$CODEN^ICPTCOD(82465)
- SET %=$$TRANI^BGP3DU(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 ""
