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

BGP2D211.m

Go to the documentation of this file. 
  1. BGP2D211 ; IHS/CMI/LAB - measure 6 ;
  1.  ;;12.1;IHS CLINICAL REPORTING;;MAY 17, 2012;Build 66
  1.  ;
  1. DNKA(V) ;EP
  1.  NEW D,N
  1.  S D=$$PRIMPOV^APCLV(V,"C")
  1.  I D=".0860" Q 1
  1.  S N=$$PRIMPOV^APCLV(V,"N")
  1.  I $E(D)="V",N["DNKA" Q 1
  1.  I $E(D)="V",N["DID NOT KEEP APPOINTMENT" Q 1
  1.  I $E(D)="V",N["DID NOT KEEP APPT" Q 1
  1.  Q 0
  1. GFR(P,BDATE,EDATE) ;EP
  1.  S BGPC=""
  1.  S T=$O(^LAB(60,"B","ESTIMATED GFR",0))
  1.  S T1=$O(^ATXLAB("B","BGP GPRA ESTIMATED GFR TAX",0))
  1.  S T2=$O(^ATXAX("B","BGP ESTIMATED GFR LOINC",0))
  1.  S B=9999999-BDATE,E=9999999-EDATE S D=E-1 F  S D=$O(^AUPNVLAB("AE",P,D)) Q:D'=+D!(D>B)!(BGPC]"")  D
  1.  .S L=0 F  S L=$O(^AUPNVLAB("AE",P,D,L)) Q:L'=+L!(BGPC]"")  D
  1.  ..S X=0 F  S X=$O(^AUPNVLAB("AE",P,D,L,X)) Q:X'=+X!(BGPC]"")  D
  1.  ...Q:'$D(^AUPNVLAB(X,0))
  1.  ...Q:$P(^AUPNVLAB(X,0),U,4)=""
  1.  ...I T,$P(^AUPNVLAB(X,0),U)=T S BGPC=1_U_(9999999-D) Q
  1.  ...I T1,$D(^ATXLAB(T1,21,"B",$P(^AUPNVLAB(X,0),U))) S BGPC=1_U_(9999999-D) Q
  1.  ...Q:'T2
  1.  ...S J=$P($G(^AUPNVLAB(X,11)),U,13) Q:J=""
  1.  ...Q:'$$LOINC(J,T2)
  1.  ...S BGPC=1_U_(9999999-D)
  1.  ...Q
  1.  Q BGPC
  1. QUANTUP(P,BDATE,EDATE) ;EP
  1.  K BGPC,BGPX
  1.  S BGPC="",BGPLC=""
  1.  K BGPG S %=P_"^LAST LAB [BGP QUANT URINE PROTEIN;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE),E=$$START1^APCLDF(%,"BGPG(")
  1.  I $D(BGPG(1)) S BGPLC=1_"^"_$P(BGPG(1),U,3)_"^"_$P(BGPG(1),U)
  1.  S T=$O(^ATXAX("B","BGP QUANT URINE PROT LOINC",0))
  1.  S B=9999999-BDATE,E=9999999-EDATE S D=E-1 F  S D=$O(^AUPNVLAB("AE",P,D)) Q:D'=+D!(D>B)!(BGPC]"")  D
  1.  .S L=0 F  S L=$O(^AUPNVLAB("AE",P,D,L)) Q:L'=+L!(BGPC]"")  D
  1.  ..S X=0 F  S X=$O(^AUPNVLAB("AE",P,D,L,X)) Q:X'=+X!(BGPC]"")  D
  1.  ...Q:'T
  1.  ...S J=$P($G(^AUPNVLAB(X,11)),U,13) Q:J=""
  1.  ...Q:'$$LOINC(J,T)
  1.  ...S %=$$VAL^XBDIQ1(9000010.09,X,.01)  ;$P(^AUPNVLAB(X,0),U,4)
  1.  ...I $P(BGPLC,U,3)<(9999999-D) S BGPLC=1_U_%_U_(9999999-D)
  1.  S %="",E=+$$CODEN^ICPTCOD(82043),%=$$CPTI^BGP2DU(P,BDATE,EDATE,E)
  1.  I %]"",$P(BGPLC,U,3)<$P(%,U,2) S BGPLC="1^CPT 82043^"_$P(%,U,2)
  1.  S %="",E=+$$CODEN^ICPTCOD(82042),%=$$CPTI^BGP2DU(P,BDATE,EDATE,E)
  1.  I %]"",$P(BGPLC,U,3)<$P(%,U,2) S BGPLC="1^CPT 82042^"_$P(%,U,2)
  1.  S %="",E=+$$CODEN^ICPTCOD(84156),%=$$CPTI^BGP2DU(P,BDATE,EDATE,E)
  1.  I %]"",$P(BGPLC,U,3)<$P(%,U,2) S BGPLC="1^CPT 84156^"_$P(%,U,2)
  1.  S %="",E=+$$CODEN^ICPTCOD(82043),%=$$TRANI^BGP2DU(P,BDATE,EDATE,E)
  1.  I %]"",$P(BGPLC,U,3)<$P(%,U,2) S BGPLC="1^CPT 84023^"_$P(%,U,2)
  1.  S %="",E=+$$CODEN^ICPTCOD(82042),%=$$TRANI^BGP2DU(P,BDATE,EDATE,E)
  1.  I %]"",$P(BGPLC,U,3)<$P(%,U,2) S BGPLC="1^CPT 82042^"_$P(%,U,2)
  1.  S %="",E=+$$CODEN^ICPTCOD(84156),%=$$TRANI^BGP2DU(P,BDATE,EDATE,E)
  1.  I %]"",$P(BGPLC,U,3)<$P(%,U,2) S BGPLC="1^CPT 84156^"_$P(%,U,2)
  1.  Q BGPLC
  1. LOINC(A,B) ;EP
  1.  NEW %
  1.  S %=$P($G(^LAB(95.3,A,9999999)),U,2)
  1.  I %]"",$D(^ATXAX(B,21,"B",%)) Q 1
  1.  S %=$P($G(^LAB(95.3,A,0)),U)_"-"_$P($G(^LAB(95.3,A,0)),U,15)
  1.  I $D(^ATXAX(B,21,"B",%)) Q 1
  1.  Q ""
  1. ESRD(P,BDATE,EDATE) ;EP
  1.  S X=$$LASTDX^BGP2UTL1(P,"BGP ESRD PMS DXS",BDATE,EDATE)
  1.  I X Q 1_U_"POV "_$P(X,U,2)_U_$P(X,U,3)
  1.  S T=$O(^ATXAX("B","BGP ESRD CPTS",0))
  1.  I T D  I X]"" Q 1_U_"CPT "_$P(X,U,2)_U_$P(X,U,1)
  1.  .S X=$$CPT^BGP2DU(P,$$DOB^AUPNPAT(P),EDATE,T,5) I X]"" Q
  1.  .S X=$$TRAN^BGP2DU(P,$$DOB^AUPNPAT(P),EDATE,T,5)
  1.  S X=$$LASTPRC^BGP2UTL1(P,"BGP ESRD PROCS",BDATE,EDATE)
  1.  I X Q 1_U_"PRC "_$P(X,U,2)_U_$P(X,U,3)
  1.  Q 0
  1. IGOAL ;EP
  1.  I '$D(^AUPNVPED("AC",DFN)) S BGPSTOP=1  ;no education so don't bother
  1.  I 'BGPACTUP S BGPSTOP=1 Q  ;no user pop
  1.  S (BGPD1,BGPN1,BGPN2)=0
  1.  NEW BGPALLED,BGPEDPRV S BGPVALUE=""
  1.  NEW BGPPROVS,BGPFYCT,Y,X,D,G,T,BGPLEVEL,R,BGPEDD
  1.  S BGPFYCT=$O(^BGPCTRL("B",2012,0))
  1.  S Y="BGPALLED("
  1.  S X=DFN_"^ALL EDUC;DURING "_$$FMTE^XLFDT(BGPBDATE)_"-"_$$FMTE^XLFDT(BGPEDATE) S E=$$START1^APCLDF(X,Y)
  1.  I '$D(BGPALLED(1)) Q
  1.  S (X,D,G)=0,%="",T="" F  S X=$O(BGPALLED(X)) Q:X'=+X  D
  1.  .S Y=+$P(BGPALLED(X),U,4)
  1.  .S T=$P(^AUPNVPED(+$P(BGPALLED(X),U,4),0),U)
  1.  .Q:'T
  1.  .Q:'$D(^AUTTEDT(T,0))
  1.  .S T=$P(^AUTTEDT(T,0),U,2)
  1.  .I T="" Q
  1.  .Q:'$$EDUALLOW^BGP2DPE1(BGPFYCT,T)
  1.  .S G=1
  1.  .S BGPLEVEL=$P(^AUPNVPED(Y,0),U,13)
  1.  .Q:BGPLEVEL=""
  1.  .S BGPPROVS(BGPLEVEL)=$G(BGPPROVS(BGPLEVEL))+1,$P(BGPEDD(BGPLEVEL),U,BGPPROVS(BGPLEVEL))=$P(BGPALLED(X),U,1)  ;count up 
  1.  .;get provider
  1.  .S R="",R=$P(^AUPNVPED(Y,0),U,5) D
  1.  ..Q:R]""
  1.  ..S R=$P($G(^AUPNVPED(Y,12)),U,4)
  1.  ..Q:R]""
  1.  ..S R=$P($G(^AUPNVPED(Y,12)),U,2)
  1.  ..Q:R]""
  1.  ..S R=$$PRIMPROV^APCLV($P(^AUPNVPED(Y,0),U,3),"I")
  1.  .I R D
  1.  ..S D=$$VALI^XBDIQ1(200,R,53.5)
  1.  ..S D=$S(D:$$VAL^XBDIQ1(7,D,9999999.01),1:"")
  1.  ..I D="" S D="??"
  1.  ..S BGPPROVS(BGPLEVEL,"PROVS")=$G(BGPPROVS(BGPLEVEL,"PROVS"))_U_D
  1.  S BGPVALUE=""
  1.  I 'G S BGPD1=0,BGPN1=0,BGPN2=0 Q   ;no allowable topics so not in denominator
  1.  S BGPD1=1  ;in denominator
  1.  I '$D(BGPPROVS) S BGPN1=0
  1.  I $G(BGPPROVS("GS")) S BGPVALUE="GS: ",BGPN1=1 F X=1:1 S Y=$P(BGPEDD("GS"),U,X) Q:Y=""  S BGPVALUE=BGPVALUE_$S(X=1:"",1:", ") S BGPVALUE=BGPVALUE_$$DATE^BGP2UTL(Y)
  1.  ;I $G(BGPPROVS("GNS")),'$G(BGPPROVS("GS")) S BGPVALUE=BGPVALUE_$S(BGPVALUE]"":", ",1:"")_"GNS"_$G(BGPPROVS("GNS","PROVS"))
  1.  I $G(BGPPROVS("GM")) S BGPVALUE=BGPVALUE_$S(BGPVALUE]"":", GM: ",1:"GM: "),BGPN2=1 F X=1:1 S Y=$P(BGPEDD("GM"),U,X) Q:Y=""  S BGPVALUE=BGPVALUE_$S(X=1:"",1:", ") S BGPVALUE=BGPVALUE_$$DATE^BGP2UTL(Y)
  1.  ;I $G(BGPPROVS("GNM")),'$G(BGPPROVS("GM")) S BGPVALUE=BGPVALUE_$S(BGPVALUE]"":", ",1:"")_"GNM"_$G(BGPPROVS("GNM","PROVS"))
  1.  S BGPVALUE="UP|||"_BGPVALUE
  1.  Q
  1.  ;
  1. AWV ;EP
  1.  S (BGPD1,BGPD2,BGPD3,BGPD4,BGPD5,BGPD6,BGPN1)=0
  1.  S BGPVALUE=""
  1.  I 'BGPACTCL S BGPSTOP=1 Q  ;not active clinical
  1.  I BGPAGEB<65 S BGPSTOP=1 Q  ;not over 65
  1.  S BGPD1=1
  1.  I $P(^DPT(DFN,0),U,2)="M" S BGPD2=1
  1.  I $P(^DPT(DFN,0),U,2)="F" S BGPD3=1
  1.  I BGPAGEB>64,BGPAGEB<75 S BGPD4=1
  1.  I BGPAGEB>74,BGPAGEB<85 S BGPD5=1
  1.  I BGPAGEB>84 S BGPD6=1
  1.  S BGPVAL=$$AWV1(DFN,$$FMADD^XLFDT(BGPEDATE,-456),BGPEDATE)
  1.  S BGPN1=$P(BGPVAL,U)
  1.  S BGPVALUE="AC|||" I BGPN1 S BGPVALUE=BGPVALUE_$$DATE^BGP2UTL($P(BGPVAL,U,2))_" CPT "_$P(BGPVAL,U,3)
  1.  K BGPVAL
  1.  Q
  1.  ;
  1. AWV1(P,BDATE,EDATE) ;EP
  1.  NEW T,X
  1.  S T=$O(^ATXAX("B","BGP ANNUAL WELLNESS CPTS",0))
  1.  I 'T Q ""
  1.  S X=$$CPT^BGP2DU(P,BDATE,EDATE,T,6)
  1.  I 'X S X=$$TRAN^BGP2DU(P,BDATE,EDATE,T,6)
  1.  Q X