BGP0D42.m

BGP0D42 ; IHS/CMI/LAB - measure 11 ;

 ;;10.0;IHS CLINICAL REPORTING;;JUN 18, 2010

 ;

 ;

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^BGP0UTL1(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 $P(BGPPAP,U)=3 S BGPN2=1

 S BGPVALUE="UP"

 I BGPD1 S BGPVALUE=BGPVALUE_";AC"

 S BGPVALUE=BGPVALUE_"|||"_$P(BGPPAP,U,2)_" "_$$DATE^BGP0UTL($P(BGPPAP,U,3))_$S($P(BGPPAP,U,1)=3:" (refused)",1:"")

 K BGPPAP,X

 Q

 ;

OSTEOSCR(P,BDATE,EDATE) ;EP

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

 I X Q X

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

 I X Q X

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

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

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

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

 ;now check for refusal

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

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

 ;

 S X=$$RADREF^BGP0UTL1(P,$$FMADD^XLFDT(EDATE,-365),EDATE,$O(^ATXAX("B","BGP OSTEO SCREEN CPTS",0)))

 I X Q 3_U_$P(X,U,3)_U_$P(X,U,2)

 Q ""

BGP0D42   ; IHS/CMI/LAB - measure 11 ;

 +1       ;;10.0;IHS CLINICAL REPORTING;;JUN 18, 2010

 +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^BGP0UTL1(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       IF $PIECE(BGPPAP,U)=3

               SET BGPN2=1

 +13       SET BGPVALUE="UP"

 +14       IF BGPD1

               SET BGPVALUE=BGPVALUE_";AC"

 +15       SET BGPVALUE=BGPVALUE_"|||"_$PIECE(BGPPAP,U,2)_" "_$$DATE^BGP0UTL($PIECE(BGPPAP,U,3))_$SELECT($PIECE(BGPPAP,U,1)=3:" (refused)",1:"")

 +16       KILL BGPPAP,X

 +17       QUIT 

 +18      ;

OSTEOSCR(P,BDATE,EDATE) ;EP

 +1        SET X=$$LASTPRCI^BGP0UTL1(P,"88.98",BDATE,EDATE)

 +2        IF X

               QUIT X

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

 +4        IF X

               QUIT X

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

 +6        IF X

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

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

 +8        IF X

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

 +9       ;now check for refusal

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

 +11       IF X

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

 +12      ;

 +13       SET X=$$RADREF^BGP0UTL1(P,$$FMADD^XLFDT(EDATE,-365),EDATE,$ORDER(^ATXAX("B","BGP OSTEO SCREEN CPTS",0)))

 +14       IF X

               QUIT 3_U_$PIECE(X,U,3)_U_$PIECE(X,U,2)

 +15       QUIT ""