BGP4D42.m

BGP4D42 ; IHS/CMI/LAB - measure 11 ;

 ;;14.1;IHS CLINICAL REPORTING;;MAY 29, 2014;Build 114

 ;

 ;

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^BGP4UTL1(DFN,"BGP OSTEOPOROSIS DXS",$P(^DPT(DFN,0),U,3),BGPEDATE) S BGPSTOP=1 Q  ;had osteoporosis dx

 ;GET 65TH BIRTHDAY

 S B=$$DOB^AUPNPAT(DFN)

 S B=$E(B,1,3)+65_$E(B,4,7)

 S BGPPAP=$$OSTEOSCR(DFN,B,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^BGP4UTL($P(BGPPAP,U,2))_" "_$P(BGPPAP,U,3)

 K BGPPAP,X

 Q

 ;

OSTEOSCR(P,BDATE,EDATE) ;EP

 NEW X,T

 S X=$$LASTPRC^BGP4UTL1(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^BGP4UTL1(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^BGP4DU(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^BGP4DU(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^BGP4DU(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^BGP4UTL1(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^BGP4UTL1(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^BGP4UTL1(P,BDATE,EDATE,T) I $P(G,U,1)=1 Q 1_"^"_$P(G,U,2)_"^Refused CPT "_$P(G,U,5)

 Q ""

BGP4D42   ; IHS/CMI/LAB - measure 11 ;

 +1       ;;14.1;IHS CLINICAL REPORTING;;MAY 29, 2014;Build 114

 +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^BGP4UTL1(DFN,"BGP OSTEOPOROSIS DXS",$PIECE(^DPT(DFN,0),U,3),BGPEDATE)

               SET BGPSTOP=1

               QUIT 

 +10      ;GET 65TH BIRTHDAY

 +11       SET B=$$DOB^AUPNPAT(DFN)

 +12       SET B=$EXTRACT(B,1,3)+65_$EXTRACT(B,4,7)

 +13       SET BGPPAP=$$OSTEOSCR(DFN,B,BGPEDATE)

 +14       IF BGPPAP

               SET BGPN1=1

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

 +16       SET BGPVALUE="UP"

 +17       IF BGPD1

               SET BGPVALUE=BGPVALUE_",AC"

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

 +19       KILL BGPPAP,X

 +20       QUIT 

 +21      ;

OSTEOSCR(P,BDATE,EDATE) ;EP

 +1        NEW X,T

 +2        SET X=$$LASTPRC^BGP4UTL1(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^BGP4UTL1(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^BGP4DU(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^BGP4DU(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^BGP4DU(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^BGP4UTL1(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^BGP4UTL1(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^BGP4UTL1(P,BDATE,EDATE,T)

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

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

 +9        QUIT ""