Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: BGP2D42

BGP2D42.m

Go to the documentation of this file.
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 ""