BGP2D42.m

BGP2D42 ; IHS/CMI/LAB - measure 11 ;

 ;;12.1;IHS CLINICAL REPORTING;;MAY 17, 2012;Build 66

 ;

 ;

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^BGP2UTL1(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^BGP2UTL($P(BGPPAP,U,2))_" "_$P(BGPPAP,U,3)

 K BGPPAP,X

 Q

 ;

OSTEOSCR(P,BDATE,EDATE) ;EP

 NEW X,T

 S X=$$LASTPRC^BGP2UTL1(P,"BGP OSTEOPOROSIS SCREEN PROCS",BDATE,EDATE)

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

 S X=$$LASTDX^BGP2UTL1(P,"BGP OSTEOPOROSIS SCRN DXS",BDATE,EDATE)

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

 S X=$$CPT^BGP2DU(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^BGP2DU(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 T=$O(^ATXAX("B","BGP OSTEO SCREEN CPTS",0))

 I T S X=$$RAD^BGP2DU(P,BDATE,EDATE,T,6)

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

 Q ""

OSTEOREF(P,BDATE,EDATE) ;EP

 NEW X,T,BGPT,C,G

 ;now check for Refusal

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

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

 S X=$$PRCREFT^BGP2UTL1(P,BDATE,EDATE,$O(^ATXAX("B","BGP OSTEOPOROSIS SCREEN PROCS",0)))

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

 S T=$O(^ATXAX("B","BGP OSTEO SCREEN CPTS",0))

 I T S G=$$RADREF^BGP2UTL1(P,BDATE,EDATE,T) I $P(G,U,1)=1 Q 1_"^"_$P(G,U,2)_"^Refused CPT "_$P(G,U,5)

 Q ""

BGP2D42   ; IHS/CMI/LAB - measure 11 ;

 +1       ;;12.1;IHS CLINICAL REPORTING;;MAY 17, 2012;Build 66

 +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^BGP2UTL1(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^BGP2UTL($PIECE(BGPPAP,U,2))_" "_$PIECE(BGPPAP,U,3)

 +16       KILL BGPPAP,X

 +17       QUIT 

 +18      ;

OSTEOSCR(P,BDATE,EDATE) ;EP

 +1        NEW X,T

 +2        SET X=$$LASTPRC^BGP2UTL1(P,"BGP OSTEOPOROSIS SCREEN PROCS",BDATE,EDATE)

 +3        IF X

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

 +4        SET X=$$LASTDX^BGP2UTL1(P,"BGP OSTEOPOROSIS SCRN DXS",BDATE,EDATE)

 +5        IF X

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

 +6        SET X=$$CPT^BGP2DU(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^BGP2DU(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       SET T=$ORDER(^ATXAX("B","BGP OSTEO SCREEN CPTS",0))

 +11       IF T

               SET X=$$RAD^BGP2DU(P,BDATE,EDATE,T,6)

 +12       IF X

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

 +13       QUIT ""

OSTEOREF(P,BDATE,EDATE) ;EP

 +1        NEW X,T,BGPT,C,G

 +2       ;now check for Refusal

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

 +4        IF X

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

 +5        SET X=$$PRCREFT^BGP2UTL1(P,BDATE,EDATE,$ORDER(^ATXAX("B","BGP OSTEOPOROSIS SCREEN PROCS",0)))

 +6        IF X

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

 +7        SET T=$ORDER(^ATXAX("B","BGP OSTEO SCREEN CPTS",0))

 +8        IF T

               SET G=$$RADREF^BGP2UTL1(P,BDATE,EDATE,T)

               IF $PIECE(G,U,1)=1

                   QUIT 1_"^"_$PIECE(G,U,2)_"^Refused CPT "_$PIECE(G,U,5)

 +9        QUIT ""