BGP1D42.m

BGP1D42 ; IHS/CMI/LAB - measure 11 ;

 ;;11.1;IHS CLINICAL REPORTING SYSTEM;;JUN 27, 2011;Build 33

 ;

 ;

IRAO ;EP

 S (BGPN1,BGPN2,BGPN3,BGPN4,BGPN5,BGPN6,BGPN7,BGPN8,BGPD1,BGPD2,BGPD3,BGPD4)=0

 I BGPAGEB<65 S BGPSTOP="" Q  ;65 and older

 I $P(^DPT(DFN,0),U,2)'="F" S BGPSTOP="" Q  ;only females

 I BGPACTUP S BGPD2=1

 I BGPACTCL S BGPD1=1

 I 'BGPD2,'BGPD1 S BGPSTOP=1 Q  ;not in either denom so quit

 S T=$O(^ATXAX("B","BGP OSTEOPOROSIS DXS",0))

 I 'T W BGPBOMB Q

 I $$LASTDX^BGP1UTL1(DFN,"BGP OSTEOPOROSIS DXS",$P(^DPT(DFN,0),U,3),BGPEDATE) S BGPSTOP=1 Q  ;had osteoporosis dx

 S BGPPAP=$$OSTEOSCR(DFN,$$FMADD^XLFDT(BGPBDATE,-(365*2)),BGPEDATE)

 I BGPPAP S BGPN1=1

 I 'BGPN1 S BGPPAP=$$OSTEOREF(DFN,BGPBDATE,BGPEDATE) I BGPPAP S BGPN2=1  ;refusal

 S BGPVALUE="UP"

 I BGPD1 S BGPVALUE=BGPVALUE_";AC"

 S BGPVALUE=BGPVALUE_"|||"_$$DATE^BGP1UTL($P(BGPPAP,U,2))_" "_$P(BGPPAP,U,3)

 K BGPPAP,X

 Q

 ;

OSTEOSCR(P,BDATE,EDATE) ;EP

 NEW X

 S X=$$LASTPRCI^BGP1UTL1(P,"88.98",BDATE,EDATE)

 I X Q 1_U_$P(X,U,3)_U_"Procedure "_$P(X,U,2)

 S X=$$LASTDXI^BGP1UTL1(P,"V82.81",BDATE,EDATE)

 I X Q 1_U_$P(X,U,3)_U_"POV "_$P(X,U,2)

 S X=$$CPT^BGP1DU(P,BDATE,EDATE,$O(^ATXAX("B","BGP OSTEO SCREEN CPTS",0)),6)

 I X Q 1_U_$P(X,U,2)_U_"CPT "_$P(X,U,3)

 S X=$$TRAN^BGP1DU(P,BDATE,EDATE,$O(^ATXAX("B","BGP OSTEO SCREEN CPTS",0)),6)

 I X Q 1_U_$P(X,U,2)_U_"CPT "_$P(X,U,3)

 Q ""

OSTEOREF(P,BDATE,EDATE) ;EP

 NEW X

 ;now check for refusal

 S X=$$CPTREFT^BGP1UTL1(P,BDATE,EDATE,$O(^ATXAX("B","BGP OSTEO SCREEN CPTS",0)))

 I X Q 1_U_$P(X,U,2)_U_"Refusal "_$P(X,U,4)

 F BGPT=88.98 D  Q:$P(T,U)=1

 .S C=+$$CODEN^ICDCODE(BGPT,80.1) Q:C'>0

 .S T=""

 .S T=$$REFUSAL^BGP1UTL1(P,80.1,C,$$FMADD^XLFDT(EDATE,-365),EDATE)

 .I T S T="1^"_$P(T,U,2)_"^Refusal "_BGPT

 I $P(T,U)=1 Q T

 Q ""

BGP1D42   ; IHS/CMI/LAB - measure 11 ;

 +1       ;;11.1;IHS CLINICAL REPORTING SYSTEM;;JUN 27, 2011;Build 33

 +2       ;

 +3       ;

IRAO      ;EP

 +1        SET (BGPN1,BGPN2,BGPN3,BGPN4,BGPN5,BGPN6,BGPN7,BGPN8,BGPD1,BGPD2,BGPD3,BGPD4)=0

 +2       ;65 and older

           IF BGPAGEB<65

               SET BGPSTOP=""

               QUIT 

 +3       ;only females

           IF $PIECE(^DPT(DFN,0),U,2)'="F"

               SET BGPSTOP=""

               QUIT 

 +4        IF BGPACTUP

               SET BGPD2=1

 +5        IF BGPACTCL

               SET BGPD1=1

 +6       ;not in either denom so quit

           IF 'BGPD2

               IF 'BGPD1

                   SET BGPSTOP=1

                   QUIT 

 +7        SET T=$ORDER(^ATXAX("B","BGP OSTEOPOROSIS DXS",0))

 +8        IF 'T

               WRITE BGPBOMB

               QUIT 

 +9       ;had osteoporosis dx

           IF $$LASTDX^BGP1UTL1(DFN,"BGP OSTEOPOROSIS DXS",$PIECE(^DPT(DFN,0),U,3),BGPEDATE)

               SET BGPSTOP=1

               QUIT 

 +10       SET BGPPAP=$$OSTEOSCR(DFN,$$FMADD^XLFDT(BGPBDATE,-(365*2)),BGPEDATE)

 +11       IF BGPPAP

               SET BGPN1=1

 +12      ;refusal

           IF 'BGPN1

               SET BGPPAP=$$OSTEOREF(DFN,BGPBDATE,BGPEDATE)

               IF BGPPAP

                   SET BGPN2=1

 +13       SET BGPVALUE="UP"

 +14       IF BGPD1

               SET BGPVALUE=BGPVALUE_";AC"

 +15       SET BGPVALUE=BGPVALUE_"|||"_$$DATE^BGP1UTL($PIECE(BGPPAP,U,2))_" "_$PIECE(BGPPAP,U,3)

 +16       KILL BGPPAP,X

 +17       QUIT 

 +18      ;

OSTEOSCR(P,BDATE,EDATE) ;EP

 +1        NEW X

 +2        SET X=$$LASTPRCI^BGP1UTL1(P,"88.98",BDATE,EDATE)

 +3        IF X

               QUIT 1_U_$PIECE(X,U,3)_U_"Procedure "_$PIECE(X,U,2)

 +4        SET X=$$LASTDXI^BGP1UTL1(P,"V82.81",BDATE,EDATE)

 +5        IF X

               QUIT 1_U_$PIECE(X,U,3)_U_"POV "_$PIECE(X,U,2)

 +6        SET X=$$CPT^BGP1DU(P,BDATE,EDATE,$ORDER(^ATXAX("B","BGP OSTEO SCREEN CPTS",0)),6)

 +7        IF X

               QUIT 1_U_$PIECE(X,U,2)_U_"CPT "_$PIECE(X,U,3)

 +8        SET X=$$TRAN^BGP1DU(P,BDATE,EDATE,$ORDER(^ATXAX("B","BGP OSTEO SCREEN CPTS",0)),6)

 +9        IF X

               QUIT 1_U_$PIECE(X,U,2)_U_"CPT "_$PIECE(X,U,3)

 +10       QUIT ""

OSTEOREF(P,BDATE,EDATE) ;EP

 +1        NEW X

 +2       ;now check for refusal

 +3        SET X=$$CPTREFT^BGP1UTL1(P,BDATE,EDATE,$ORDER(^ATXAX("B","BGP OSTEO SCREEN CPTS",0)))

 +4        IF X

               QUIT 1_U_$PIECE(X,U,2)_U_"Refusal "_$PIECE(X,U,4)

 +5        FOR BGPT=88.98

               Begin DoDot:1

 +6                SET C=+$$CODEN^ICDCODE(BGPT,80.1)

                   IF C'>0

                       QUIT 

 +7                SET T=""

 +8                SET T=$$REFUSAL^BGP1UTL1(P,80.1,C,$$FMADD^XLFDT(EDATE,-365),EDATE)

 +9                IF T

                       SET T="1^"_$PIECE(T,U,2)_"^Refusal "_BGPT

               End DoDot:1

               IF $PIECE(T,U)=1

                   QUIT 

 +10       IF $PIECE(T,U)=1

               QUIT T

 +11       QUIT ""