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

BGP9D21.m

Go to the documentation of this file. 
  1. BGP9D21 ; IHS/CMI/LAB - measure 6 ; 
  1.  ;;9.0;IHS CLINICAL REPORTING;;JUL 1, 2009
  1.  ;
  1. I6 ;EP
  1.  K BGPN1,BGPN2,BGPN3,BGPN4,BGPVALUE,BGPUP,BGPGFR
  1.  S (BGPN1,BGPN2,BGPN3,BGPN4)=0
  1.  I 'BGPDM1 S BGPSTOP=1 Q
  1. DMNA ;EP - called from elder care
  1.  S BGPBD1=BGP365
  1.  S BGPBD2=BGPBDATE
  1. I61 ;EP
  1.  S BGPGFR=$$GFR^BGP9D211(DFN,BGPBD1,BGPEDATE)
  1.  S BGPESRD=$$ESRD^BGP9D211(DFN,$P(^DPT(DFN,0),U,3),BGPEDATE)
  1.  S BGPQUP=$$QUANTUP^BGP9D211(DFN,BGPBD2,BGPEDATE)
  1.  S BGPHOLD=BGPGFR_"|"_BGPESRD_"|"_BGPQUP
  1.  I $P(BGPESRD,U) S BGPN1=1
  1.  I BGPGFR&(BGPQUP) S BGPN1=1
  1.  S BGPVALUE=$S(BGPDMD1:"UP",1:"")_$S(BGPDMD2:",AD",1:"")_$S(BGPDMD3:",AAD",1:"")_"|||"
  1.  I BGPN1 D
  1.  .I BGPESRD S BGPVALUE=BGPVALUE_$S(BGPESRD]"":"ESRD: "_$P(BGPESRD,U,2)_"-"_$$DATE^BGP9UTL($P(BGPESRD,U,3)),1:"") Q
  1.  .S BGPVALUE=BGPVALUE_";GFR: "_$$DATE^BGP9UTL($P(BGPGFR,U,2))
  1.  .S BGPVALUE=BGPVALUE_" & QUANT UP: "_$P(BGPQUP,U,2)_"-"_$$DATE^BGP9UTL($P(BGPQUP,U,3))
  1.  K BGPUP,BGPGFR,BGPX,BGPY,BGPC,BGPG,BGPBD1,BGPBD2,BGPQUP,BGPESRD
  1.  Q
  1.  ;
  1. I7 ;EP
  1.  K BGPN1,BGPN2,BGPN3,BGPN4,BGPN5,BGPVALUE,BGPEYE
  1.  I 'BGPDM1 S BGPSTOP=1 Q
  1. DMEYE ;EP - called from elder care
  1.  S BGPEYE=$$EYE(DFN,BGP365,BGPEDATE)
  1.  S BGPN2=0 I $P(BGPEYE,U)=1 S BGPN2=1
  1.  S BGPN3=0 I $P(BGPEYE,U)=2 S BGPN3=1
  1.  S BGPN4=0 I $P(BGPEYE,U)=3 S BGPN4=1
  1.  S BGPN1=0 I BGPN3!(BGPN2)!(BGPN4) S BGPN1=1
  1.  S BGPN5=0 I BGPN2!(BGPN4) S BGPN5=1
  1.  S BGPVALUE=$S(BGPDMD1:"UP",1:"")_$S(BGPDMD2:",AD",1:"")_$S(BGPDMD3:",AAD",1:"")_"|||"_$$DATE^BGP9UTL($P(BGPEYE,U,2))_" "_$P(BGPEYE,U,3)
  1.  K BGPG
  1.  K ^TMP($J,"A")
  1.  Q
  1.  ;
  1. I8 ;EP
  1.  K BGPN1,BGPVALUE,BGPN2,BGPN3,BGPN4,BGPN5
  1.  S BGPN1=0
  1.  I '$G(BGPDMD2) S BGPSTOP=1 Q
  1.  S BGPVALUE=$$DENTSRV(DFN,BGPBDATE,BGPEDATE)
  1.  S BGPN1=0 I $P(BGPVALUE,U) S BGPN1=1
  1.  S BGPN2=0 I $P(BGPVALUE,U)=2 S BGPN2=1
  1.  S BGPN3=0 I BGPN1,'BGPN2 S BGPN3=1
  1.  S BGPVALUE="AD|||"_$$DATE^BGP9UTL($P(BGPVALUE,U,2))_" "_$P(BGPVALUE,U,3)
  1.  Q
  1. I9 ;EP
  1.  K BGPN1,BGPVALUE,BGPN2,BGPN3,BGPN4,BGPN5
  1.  S (BGPD1,BGPD2,BGPD3,BGPD4,BGPD5,BGPD6,BGPD7,BGPD8,BGPD9)=0
  1.  I '$G(BGPACTUP) S BGPSTOP=1 Q
  1.  S BGPD1=1
  1.  S A=$$AGE^AUPNPAT(DFN,BGPBDATE)
  1.  I A<6 S BGPD2=1
  1.  I A>5,A<12 S BGPD3=1
  1.  I A>11,A<20 S BGPD4=1
  1.  I A>19,A<35 S BGPD5=1
  1.  I A>34,A<45 S BGPD6=1
  1.  I A>44,A<55 S BGPD7=1
  1.  I A>54,A<75 S BGPD8=1
  1.  I A>74 S BGPD9=1
  1.  S BGPVALUE=$$DENTSRV(DFN,BGPBDATE,BGPEDATE)
  1.  S BGPN1=0 I $P(BGPVALUE,U) S BGPN1=1
  1.  S BGPN2=0 I $P(BGPVALUE,U)=2 S BGPN2=1
  1.  S BGPN3=0 I BGPN1,'BGPN2 S BGPN3=1
  1.  S BGPVALUE="UP|||"_$$DATE^BGP9UTL($P(BGPVALUE,U,2))_" "_$P(BGPVALUE,U,3)
  1.  Q
  1. DENTSRV(P,BDATE,EDATE,FORECAST) ;EP
  1.  K BGPG
  1.  S FORECAST=$G(FORECAST)
  1.  S BGPC="",%=P_"^LAST ADA 0000;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE),E=$$START1^APCLDF(%,"BGPG(")
  1.  I $D(BGPG(1)) S BGPC=$P(BGPG(1),U)_"^"_"ADA "_$P(BGPG(1),U,2)
  1.  K BGPG
  1.  S %=P_"^LAST ADA 0190;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE),E=$$START1^APCLDF(%,"BGPG(")
  1.  I $D(BGPG(1)),$P(BGPG(1),U)>$P(BGPC,U) S BGPC=$P(BGPG(1),U)_"^"_"ADA "_$P(BGPG(1),U,2)
  1.  K BGPG S %=P_"^LAST EXAM DENTAL;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE),E=$$START1^APCLDF(%,"BGPG(")
  1.  I $D(BGPG(1)),$P(BGPG(1),U)>$P(BGPC,U) S BGPC=$P(BGPG(1),U)_"^"_$P(BGPG(1),U,3)
  1.  I BGPC]"",'FORECAST Q "1^"_BGPC
  1.  S BGPG=$$LASTDXI^BGP9UTL1(P,"V72.2",BDATE,EDATE)
  1.  I BGPG,'$G(FORECAST) Q "1^"_$P(BGPG,U,3)_"^V72.2"
  1.  I BGPG,$G(FORECAST),$P(BGPG,U,3)>$P(BGPC,U) S BGPC=$P(BGPG,U,3)_"^V72.2"
  1.  K BGPG S G="" S %=P_"^ALL ADA;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE),E=$$START1^APCLDF(%,"BGPG(")
  1.  I $D(BGPG) D  I G]"",'$G(FORECAST) Q G
  1.  .S X=0 F  S X=$O(BGPG(X)) Q:X'=+X  S V=$P(BGPG(X),U,5) D
  1.  ..I $P($G(^AUPNVSIT(V,0)),U,3)="C" D
  1.  ...I '$G(FORECAST) S G=1_"^"_$P(BGPG(X),U)_"^CHS VISIT ADA "_$P(BGPG(X),U,2) Q
  1.  ...I $G(FORECAST),$P(BGPG(X),U)>$P(BGPC,U) S BGPC=$P(BGPG(X),U)_"^CHS ADA VISIT"
  1.  I BGPC]"" S BGPC=1_"^"_BGPC
  1.  I $G(FORECAST) D  Q BGPC
  1.  .S G=$$REFUSAL^BGP9UTL1(P,9999999.15,$O(^AUTTEXAM("C",30,0)),$$FMADD^XLFDT(EDATE,-365),EDATE)
  1.  .I G,$P(G,U,2)>$P(BGPC,U,2) S BGPC="2^"_$P(G,U,2)_"^Refused EXAM 30"
  1.  .S G=$$REFUSAL^BGP9UTL1(P,9999999.31,$O(^AUTTADA("B","0000",0)),$$FMADD^XLFDT(EDATE,-365),EDATE)
  1.  .I G,$P(G,U,2)>$P(BGPC,U,2) S BGPC="2^"_$P(G,U,2)_"^Refused ADA 0000"
  1.  .S G=$$REFUSAL^BGP9UTL1(P,9999999.31,$O(^AUTTADA("B",0190,0)),$$FMADD^XLFDT(EDATE,-365),EDATE)
  1.  .I G,$P(G,U,2)>$P(BGPC,U,2) S BGPC="2^"_$P(G,U,2)_"^Refused ADA 0190"
  1.  S G=$$REFUSAL^BGP9UTL1(P,9999999.15,$O(^AUTTEXAM("C",30,0)),BDATE,EDATE)
  1.  I $P(G,U)=1 Q "2^"_$P(G,U,2)_"^Refused EXAM 30"
  1.  S G=$$REFUSAL^BGP9UTL1(P,9999999.31,$O(^AUTTADA("B","0000",0)),BDATE,EDATE)
  1.  I $P(G,U)=1 Q "2^"_$P(G,U,2)_"^Refused ADA 0000"
  1.  S G=$$REFUSAL^BGP9UTL1(P,9999999.31,$O(^AUTTADA("B","0190",0)),BDATE,EDATE)
  1.  I $P(G,U)=1 Q "2^"_$P(G,U,2)_"^Refused ADA 0190"
  1.  Q ""
  1.  ;
  1. EYE(P,BDATE,EDATE) ;EP
  1.  S BGPLEYE=""
  1.  K BGPG S %=P_"^LAST EXAM DIABETIC EYE EXAM;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE),E=$$START1^APCLDF(%,"BGPG(")
  1.  I $D(BGPG(1)) Q "1^"_$P(BGPG(1),U)_"^Diab Eye Ex"
  1.  ;now check cpt taxonomies
  1.  S T=$O(^ATXAX("B","BGP DM RETINAL EXAM CPTS",0))
  1.  I T D  I X]"",$P(BGPLEYE,U,2)<$P(X,U,1) Q 1_U_$P(X,U,1)_U_"CPT: "_$P(X,U,2)
  1.  .S X=$$CPT^BGP9DU(P,BDATE,EDATE,T,5) I X]"" Q
  1.  .S X=$$TRAN^BGP9DU(P,BDATE,EDATE,T,5)
  1.  K ^TMP($J,"A")
  1.  S A="^TMP($J,""A"","
  1.  S %=P_"^ALL VISITS;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE),E=$$START1^APCLDF(%,A)
  1.  S X=0,Y=0 F  S X=$O(^TMP($J,"A",X)) Q:X'=+X!(Y)  S R=$$CLINIC^APCLV($P(^TMP($J,"A",X),U,5),"C") I R="A2",'$$DNKA($P(^TMP($J,"A",X),U,5)) S Y=1,D=$P(^TMP($J,"A",X),U)
  1.  I Y Q 3_"^"_D_"^Cl: "_R
  1.  S X=0,Y=0 F  S X=$O(^TMP($J,"A",X)) Q:X'=+X!(Y)  S R=$$CLINIC^APCLV($P(^TMP($J,"A",X),U,5),"C") I (R=17!(R=18)!(R=64)),'$$DNKA($P(^TMP($J,"A",X),U,5)) S Y=1,D=$P(^TMP($J,"A",X),U)
  1.  I Y Q $S(R="A2":3,1:3)_"^"_D_"^Cl: "_R
  1.  S (X,Y)=0,D="" F  S X=$O(^TMP($J,"A",X)) Q:X'=+X!(Y)  S R=$$PRIMPROV^APCLV($P(^TMP($J,"A",X),U,5),"D") I (R=24!(R=79)!(R="08")),'$$DNKA($P(^TMP($J,"A",X),U,5)) S Y=1,D=$P(^TMP($J,"A",X),U)
  1.  I Y Q "3^"_D_"^Prv: "_R
  1.  ;
  1.  K BGPG S %=P_"^LAST DX V72.0;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE),E=$$START1^APCLDF(%,"BGPG(")
  1.  I $D(BGPG(1)) Q "3^"_$P(BGPG(1),U)_"^V72.0 POV"
  1.  ;
  1.  S T=$O(^ATXAX("B","BGP DM EYE EXAM CPTS",0))
  1.  I T D  I X]"" Q 3_U_$P(X,U,1)_U_"CPT: "_$P(X,U,2)
  1.  .S X=$$CPT^BGP9DU(P,BDATE,EDATE,T,5) I X]"" Q
  1.  .S X=$$TRAN^BGP9DU(P,BDATE,EDATE,T,5)
  1.  S X=$$LASTPRCI^BGP9UTL1(P,"95.02",BDATE,EDATE) I X]"" Q 3_U_$P(X,U,3)_U_"PROC: 95.02"
  1.  S G=$$REFUSAL^BGP9UTL1(P,9999999.15,$O(^AUTTEXAM("B","DIABETIC EYE EXAM",0)),BDATE,EDATE)
  1.  I $P(G,U)=1 Q "2^"_$P(G,U,2)_"^Refused"
  1.  Q BGPLEYE
  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 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_$$DATE^BGP9UTL((9999999-D)) Q
  1.  ...I T1,$D(^ATXLAB(T1,21,"B",$P(^AUPNVLAB(X,0),U))) S BGPC=1_U_(9999999-D) Q
  1.  ...S J=$P($G(^AUPNVLAB(X,11)),U,13) Q:J=""
  1.  ...S %=$P($G(^LAB(95.3,J,9999999)),U,2)
  1.  ...I %="33914-3" S BGPC=1_U_(9999999-D) Q
  1.  ...S J=$P($G(^LAB(95.3,J,0)),U)_"-"_$P($G(^LAB(95.3,J,0)),U,15)
  1.  ...I J="33914-3" S BGPC=1_U_(9999999-D) Q
  1.  ...Q
  1.  Q BGPC
  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.  K BGPG S %=P_"^LAST DX [BGP ESRD PMS DXS;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE),E=$$START1^APCLDF(%,"BGPG(")
  1.  I $D(BGPG(1)) Q "1^ESRD 585.6^^"_$P(BGPG(1),U)
  1.  S X=$$LASTPRC^BGP9UTL1(P,"BGP ESRD PROCS",BDATE,EDATE)
  1.  I X Q 1_"^ESRD PROC "_$P(X,U,2)_"^^"_$P(X,U,3)
  1.  S T=$O(^ATXAX("B","BGP ESRD CPTS",0))
  1.  I T D  I X]"" Q 1_U_"ESRD "_$P(X,U,2)_U_U_$P(X,U,1)
  1.  .S X=$$CPT^BGP9DU(P,$$DOB^AUPNPAT(P),EDATE,T,5) I X]"" Q
  1.  .S X=$$TRAN^BGP9DU(P,$$DOB^AUPNPAT(P),EDATE,T,5)
  1.  Q 0