BGP8D213 ; IHS/CMI/LAB - measure 6 13 Aug 2015 6:58 AM ;
;;18.1;IHS CLINICAL REPORTING;;MAY 25, 2018;Build 66
;
CVD ;EP - called from report execution
I BGPAGEB<21 S BGPSTOP=1 Q ;ONLY 21+
NEW BGPCVDL
;F X=1:1:6 S Y="BGPD"_X S @Y="" ;6 denominators
F X=1:1:7 S Y="BGPD"_X S @Y="" ;6 denominators maw 06/22/2016 modified, I think there is supposed to be 7 here
S (BGPN1,BGPN2,BGPN3)="" ;2 numerators
S BGPCVDL=$$CHDLDL^BGP8D212(DFN,$$DOB^AUPNPAT(DFN),BGPEDATE) ;CHD OR LDL^CHD^LDL
I BGPAGEB>20,BGPAGEB<40,'BGPCVDL S BGPSTOP=1 Q ;21-39 and no cvd/ldl
I BGPAGEB>75,'BGPCVDL S BGPSTOP=1 Q ;>75 and no cvd/ldl
;DENOM 1
I BGPDMD1,BGPAGEB>39,BGPAGEB<76 S BGPD1=1 ;up diabetic ages 40-75
I BGPAGEB>20,BGPCVDL S BGPD1=1 ;or UP 21+ w/CVD or LDL =>190
;DENOM 2 21-39, UP with CVD or LDL >=190
I BGPAGEB>20,BGPAGEB<40,BGPCVDL S BGPD2=1
;DENOM 3 40-75, UP with CVD or LDL =>190
I BGPAGEB>39,BGPAGEB<76,BGPCVDL S BGPD3=1
;DENOM 4 76+ with cvd or ldl >=190
I BGPAGEB>75,BGPCVDL S BGPD4=1
;DENOM 5 UP diabetic 40-75
I BGPDMD1,BGPAGEB>39,BGPAGEB<76 S BGPD5=1
;DENOM 6 up 21+
I BGPD1 S BGPD6=1
;I 'BGPD6 S BGPSTOP=1 Q ;not in at least UP denominator
;now exclude people
S (BGPEXL1,BGPEXL2,BGPEXL3,BGPEXL4,BGPEXL5,BGPEXL6,BGPEXL7)=""
S BGPEXL1=$$STATALG(DFN,$$DOB^AUPNPAT(DFN),BGPEDATE,BGPBDATE,BGPEDATE) I BGPEXL1 S (BGPN2,BGPN3)=1 G SETL ;excl 1
;ALCOHOL HEP
S BGPEXL1=$$ALCHEP^BGP8D212(DFN,BGPBDATE,BGPEDATE) I BGPEXL1 S BGPN2=1 G SETL
;NMI
S BGPEXL1=$$STATNMI^BGP8D212(DFN,BGPBDATE,BGPEDATE) I BGPEXL1 S BGPN2=1 G SETL
;PREGNANCY
S BGPEXL2=$$PREG^BGP8D715(DFN,BGPBDATE,BGPEDATE,1,1,,BGPBDATE,BGPEDATE) I BGPEXL2 S BGPN2=1 G SETL ;V17.1 CMI/LAB ADDED DATES FOR CURRENTLY PREGNANT
;BREASTFEEDING
S BGPEXL2=$$BF^BGP8D21(DFN,BGPBDATE,BGPEDATE) I BGPEXL2 S BGPN2=1 G SETL
;cirrhosis of liver
S BGPEXL6=$$CLIVER(DFN,BGPPBD,BGPEDATE) I BGPEXL6 S BGPN2=1 G SETL
;PALLIATIVE
S BGPEXL3=$$LASTDX^BGP8UTL1(DFN,"BGP PALLIATIVE CARE DXS",BGPBDATE,BGPEDATE) I BGPEXL3 S BGPN2=1,BGPEXL3=1_U_$$DATE^BGP8UTL($P(BGPEXL3,U,3))_" Palliative Care" G SETL ;excl 3
;ESRD
S BGPEXL4=$$ESRD^BGP8D211(DFN,$$DOB^AUPNPAT(DFN),BGPEDATE) I BGPEXL4 S BGPEXL4=1_U_$$DATE^BGP8UTL($P(BGPEXL4,U,3))_" ESRD" S BGPN2=1 G SETL ;excl 4 ESRD
;EXCL 5
S BGPEXL7=$$HEPA^BGP8D21A(DFN,$$DOB^AUPNPAT(DFN),BGPEDATE) I BGPEXL7 S BGPEXL7=1_U_$$DATE^BGP8UTL($P(BGPEXL7,U,3))_" HEP A" S BGPN2=1 G SETL
S BGPEXL7=$$HEPB^BGP8D21A(DFN,$$DOB^AUPNPAT(DFN),BGPEDATE) I BGPEXL7 S BGPEXL7=1_U_$$DATE^BGP8UTL($P(BGPEXL7,U,3))_" HEP B" S BGPN2=1 G SETL
NEW BGPSTAT
S BGPSTAT=$$STATIN^BGP8D214(DFN,BGPBDATE,BGPEDATE,0)
S BGPEXL5=$$LASTLDLV^BGP8D212(DFN,$$DOB^AUPNPAT(DFN),BGPEDATE) I BGPEXL5,'$P(BGPCVDL,U,3),'BGPSTAT S BGPN2=1 G SETL ;excl 5
;numerator
S BGPN1=BGPSTAT
SETL ;
I BGPN2 S (BGPD1,BGPD2,BGPD3,BGPD4,BGPD5)="" ;if exclusion don't count in those denoms per Megan
I BGPN2,BGPD1 S BGPD6=1
S BGPVALUE=$S(BGPDMD2:"UP,AD",1:"UP") I BGPDMD1!(BGPCVDL) D
.;S BGPVALUE=BGPVALUE_" ("
.I BGPDMD1,'BGPCVDL S BGPVALUE=BGPVALUE_" (DM)"_"|||" Q
.I BGPDMD1,BGPCVDL S BGPVALUE=BGPVALUE_$S($P(BGPCVDL,U,2):" (DM,CHD)",$P(BGPCVDL,U,3):" (DM,LDL)",$P(BGPCVDL,U,4):" (DM,HYPER CHOL)",1:"")_"|||" Q
.S BGPVALUE=BGPVALUE_$S($P(BGPCVDL,U,2):" (CHD)",$P(BGPCVDL,U,3):" (LDL)",$P(BGPCVDL,U,4):" (HYPER CHOL)",1:"")_"|||"
I BGPN1 S BGPVALUE=BGPVALUE_$P(BGPN1,U,2)
I BGPEXL1 S BGPVALUE=BGPVALUE_"Exclusion: "_$P(BGPEXL1,U,2)
I BGPEXL2 S BGPVALUE=BGPVALUE_"Exclusion: "_$P(BGPEXL2,U,2)_" Pregnant/Breastfeeding"
I BGPEXL3 S BGPVALUE=BGPVALUE_"Exclusion: "_$P(BGPEXL3,U,2)
I BGPEXL4 S BGPVALUE=BGPVALUE_"Exclusion: "_$P(BGPEXL4,U,2)
I BGPEXL6 S BGPVALUE=BGPVALUE_"Exclusion: "_$P(BGPEXL6,U,2)_" Cirrhosis/Liver Dis"
I BGPEXL5,BGPN2 S BGPVALUE=BGPVALUE_"Exclusion: "_$P(BGPEXL5,U,2)
I BGPEXL7 S BGPVALUE=BGPVALUE_"Exclusion: "_$P(BGPEXL7,U,2)
K BGPEXL1,BGPEXL2,BGPEXL3,BGPEXL4,BGPEXL5,BGPCVDL,BGPEXL6,BGPEXL7
Q
CLIVER(P,BD,ED) ;EP - cirrhosis of liver? OR LIVER DISEASE
NEW %,X
S X=$$LASTDX^BGP8UTL1(P,"BGP CIRRHOSIS OF LIVER DXS",BD,ED)
I X Q 1_U_$$DATE^BGP8UTL($P(X,U,3))
;PROBLEM LIST
NEW X
S X=$$PLTAXND^BGP8DU(P,"BGP CIRRHOSIS OF LIVER DXS",ED)
I X Q 1
S X=$$IPLSNOND^BGP8DU(P,"PXRM BGP CIRRHOSIS",ED)
I X Q 1
;LIVER DISEASE
S X=$$LASTDX^BGP8UTL1(P,"BGP LIVER DISEASE DXS",BD,ED)
I X Q 1_U_$$DATE^BGP8UTL($P(X,U,3))
;PROBLEM LIST
NEW X
S X=$$PLTAXND^BGP8DU(P,"BGP LIVER DISEASE DXS",ED)
I X Q 1
S X=$$IPLSNOND^BGP8DU(P,"PXRM BGP LIVER DISEASE",ED)
I X Q 1
Q ""
STATALG(P,BDATE,EDATE,RPB,RPE) ;EP
;get all visits and check for ALT/AST tests on 2 consecutive visits
NEW BGPG,BGPY,Y,X,N,Z,BGPC,T
S BGPC=""
K BGPG,BGPY S Y="BGPG(",X=P_"^ALL DX [BGP ASA ALLERGY 995.0-995.3;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE) S E=$$START1^APCLDF(X,Y)
S X=0 F S X=$O(BGPG(X)) Q:X'=+X S Y=+$P(BGPG(X),U,4) D
.S N=$$VAL^XBDIQ1(9000010.07,Y,.04) S N=$$UP^XLFSTR(N)
.I N["STATIN"!(N["STATINS"),N'["NYSTATIN" S BGPC=1_U_$$DATE^BGP8UTL($P(BGPG(X),U))_" ADR/Allergy POV "_$P(BGPG(X),U,2)
.S T=$O(^ATXAX("B","BGP ADV EFF CARDIOVASC NEC",0))
.S Z=$P(^AUPNVPOV(Y,0),U,9) I Z]"",$$ICD^BGP8UTL2(Z,T,9) S BGPC=1_U_$$DATE^BGP8UTL($P(BGPG(X),U))_" ADR/Allergy POV ["_$P(BGPG(X),U,2)_" + "_$P($$ICDDX^BGP8UTL2(Z),U,2)_"] "_N Q
.S Z=$P(^AUPNVPOV(Y,0),U,18) I Z]"",$$ICD^BGP8UTL2(Z,T,9) S BGPC=1_U_$$DATE^BGP8UTL($P(BGPG(X),U))_" ADR/Allergy POV ["_$P(BGPG(X),U,2)_" + "_$P($$ICDDX^BGP8UTL2(Z),U,2)_"] "_N Q
.S Z=$P(^AUPNVPOV(Y,0),U,19) I Z]"",$$ICD^BGP8UTL2(Z,T,9) S BGPC=1_U_$$DATE^BGP8UTL($P(BGPG(X),U))_" ADR/Allergy POV ["_$P(BGPG(X),U,2)_" + "_$P($$ICDDX^BGP8UTL2(Z),U,2)_"] "_N Q
.Q
I BGPC Q BGPC
K BGPG S BGPC=0 S Y="BGPG(",X=P_"^ALL DX [BGP HX DRUG ALLERGY NEC;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE) S E=$$START1^APCLDF(X,Y)
S X=0 F S X=$O(BGPG(X)) Q:X'=+X S Y=+$P(BGPG(X),U,4) D
.S N=$$VAL^XBDIQ1(9000010.07,Y,.04),N=$$UP^XLFSTR(N)
.I N["STATIN"!(N["STATINS"),N'["NYSTATIN" S BGPC=1_U_$$DATE^BGP8UTL($P(BGPG(X),U))_" ADR/Allergy POV "_$P(BGPG(X),U,2) ;_"]"
I BGPC Q BGPC
;PL
NEW SNT
S SNT="PXRM BGP ADR STATIN" ;CODE WITH LATERALITY=BILATERAL
S BGPC=0
S T="",T=$O(^ATXAX("B","BGP ASA ALLERGY 995.0-995.3",0))
S X=0 F S X=$O(^AUPNPROB("AC",P,X)) Q:X'=+X D
.S I=$P($G(^AUPNPROB(X,0)),U),Y=$P($$ICDDX^BGP8UTL2(I),U,2)
.S N=$$VAL^XBDIQ1(9000011,X,.05),N=$$UP^XLFSTR(N)
.I $P(^AUPNPROB(X,0),U,13)="" Q:$P(^AUPNPROB(X,0),U,8)>EDATE
.I $P(^AUPNPROB(X,0),U,13)]"",$P(^AUPNPROB(X,0),U,13)>EDATE Q ;doo
.Q:$P(^AUPNPROB(X,0),U,12)="D"
.;Q:$P(^AUPNPROB(X,0),U,12)="I" crs 17.0
.S S=$$VAL^XBDIQ1(9000011,X,80001) I S]"",$D(^XTMP("BGPSNOMEDSUBSET",$J,SNT,S)) S BGPC=1_U_"ADR/Allergy Problem List "_S Q
.I $$ICD^BGP8UTL2(I,$O(^ATXAX("B","BGP HX DRUG ALLERGY NEC",0)),9)!($$ICD^BGP8UTL2(I,T,9)),N["STATIN"!(N["STATINS"),N'["NYSTATIN" S BGPC=1_U_$$DATE^BGP8UTL($P(^AUPNPROB(X,0),U,8))_" ADR/Allergy Problem List "_Y ;_"]"
.Q
I BGPC Q BGPC
;ART
S BGPC=0
S X=0 F S X=$O(^GMR(120.8,"B",P,X)) Q:X'=+X D
.Q:$P($P($G(^GMR(120.8,X,0)),U,4),".")>EDATE
.S N=$P($G(^GMR(120.8,X,0)),U,2),N=$$UP^XLFSTR(N)
.I N["STATIN",N'["NYSTATIN" S BGPC=1_U_$$DATE^BGP8UTL($P(^GMR(120.8,X,0),U,4))_" ADR/Allergy Allergy Tracking "_N
I BGPC Q BGPC
;now go into the report period items
K BGPG S Y="BGPG(",X=P_"^LAST DX [BGP MYOPATHY/MYALGIA;DURING "_$$FMTE^XLFDT(RPB)_"-"_$$FMTE^XLFDT(RPE) S E=$$START1^APCLDF(X,Y)
I $D(BGPG(1)) Q 1_U_$$DATE^BGP8UTL($P(BGPG(1),U))_" ADR/Allergy POV "_"Myalgia" ;$P(BGPG(1),U,2) ;_"]"
;PROBLEM LIST
NEW X
S X=$$PLTAXID^BGP8DU(P,"BGP MYOPATHY/MYALGIA",RPB,RPE)
I X Q 1_U_"ADR/Allergy Problem List: Myalgia"
S X=$$IPLSNOID^BGP8DU(P,"PXRM BGP MYOPATHY MYALGIA",RPB,RPE)
I X Q 1_U_"ADR/Allergy Problem List: Myalgia"
;RHABDOMYOLYSIS
K BGPG S Y="BGPG(",X=P_"^LAST DX [BGP RHABDOMYOLYSIS DX;DURING "_$$FMTE^XLFDT(RPB)_"-"_$$FMTE^XLFDT(RPE) S E=$$START1^APCLDF(X,Y)
I $D(BGPG(1)) Q 1_U_$$DATE^BGP8UTL($P(BGPG(1),U))_" ADR/Allergy POV Rhabdomyolysis" ;$P(BGPG(1),U,2) ;_"]"
;PROBLEM LIST
NEW X
S X=$$PLTAXID^BGP8DU(P,"BGP RHABDOMYOLYSIS DX",RPB,RPE)
I X Q 1_U_"ADR/Allergy Problem List: Rhabdomyolysis"
S X=$$IPLSNOID^BGP8DU(P,"PXRM BGP RHABDOMYOLYSIS",RPB,RPE)
I X Q 1_U_"ADR/Allergy Problem List: Rhabdomyolysis"
;creatine lab value > 10,000 or 10x uln
S BGPG=""
S T=$O(^ATXAX("B","BGP CREATINE KINASE LOINC",0))
S BGPLT=$O(^ATXLAB("B","BGP CREATINE KINASE TAX",0))
S B=9999999-RPB,E=9999999-RPE S D=E-1 F S D=$O(^AUPNVLAB("AE",P,D)) Q:D'=+D!(D>B)!(BGPG) D
.S L=0 F S L=$O(^AUPNVLAB("AE",P,D,L)) Q:L'=+L D
..S X=0 F S X=$O(^AUPNVLAB("AE",P,D,L,X)) Q:X'=+X D
...Q:'$D(^AUPNVLAB(X,0))
...I BGPLT,$P(^AUPNVLAB(X,0),U),$D(^ATXLAB(BGPLT,21,"B",$P(^AUPNVLAB(X,0),U))) I $$RESCK^BGP8D722(X) S BGPG=1_U_$$DATE^BGP8UTL((9999999-D))_" ADR/Allergy creat kinase of "_$P(^AUPNVLAB(X,0),U,4) Q
...Q:'T
...S J=$P($G(^AUPNVLAB(X,11)),U,13) Q:J=""
...Q:'$$LOINC^BGP8D2(J,T)
...I $$RESCK^BGP8D722(X) S BGPG=1_U_$$DATE^BGP8UTL((9999999-D))_" ADR/Allergy creat kinase of "_$P(^AUPNVLAB(X,0),U,4) Q
...Q
I BGPG Q BGPG
S T=$O(^ATXAX("B","BGP ALT LOINC",0))
S BGPLT=$O(^ATXLAB("B","DM AUDIT ALT TAX",0))
S T2=$O(^ATXAX("B","BGP AST LOINC",0))
S BGPLT2=$O(^ATXLAB("B","DM AUDIT AST TAX",0))
S B=9999999-$$FMADD^XLFDT(EDATE,-365),E=9999999-EDATE S D=E-1 F S D=$O(^AUPNVLAB("AE",P,D)) Q:D'=+D!(D>B)!(BGPG) D
.S L=0 F S L=$O(^AUPNVLAB("AE",P,D,L)) Q:L'=+L D
..S X=0 F S X=$O(^AUPNVLAB("AE",P,D,L,X)) Q:X'=+X D
...Q:'$D(^AUPNVLAB(X,0))
...I BGPLT,$P(^AUPNVLAB(X,0),U),$D(^ATXLAB(BGPLT,21,"B",$P(^AUPNVLAB(X,0),U))) S BGPC=BGPC+1,BGPC((9999999-D))=X_U_$P(^AUPNVLAB(X,0),U,4)_U_$P($G(^AUPNVLAB(X,11)),U,5) Q
...I BGPLT2,$P(^AUPNVLAB(X,0),U),$D(^ATXLAB(BGPLT2,21,"B",$P(^AUPNVLAB(X,0),U))) S BGPC=BGPC+1,BGPC((9999999-D))=X_U_$P(^AUPNVLAB(X,0),U,4)_U_$P($G(^AUPNVLAB(X,11)),U,5) Q
...S J=$P($G(^AUPNVLAB(X,11)),U,13) Q:J=""
...I '$$LOINC^BGP8D2(J,T),'$$LOINC^BGP8D2(J,T2)
...S BGPC=BGPC+1,BGPC((9999999-D))=X_U_$P(^AUPNVLAB(X,0),U,4)_U_$P($G(^AUPNVLAB(X,11)),U,5) Q
...Q
;are they 2 consecutive
S BGPG=""
S X=0 F S X=$O(BGPC(X)) Q:X'=+X!(BGPG) D
.Q:'$$RESAL^BGP8D722(BGPC(X))
.;is next one also bad?
.S Y=$O(BGPC(X))
.Q:Y=""
.I $$RESAL^BGP8D722(BGPC(Y)) S BGPG=1_U_" ADR/Allergy AST/ALT" Q
.Q
I BGPG Q BGPG
Q 0
NEW BGPG,%,E,A,Y,X,R,G
S REFUSAL=$G(REFUSAL)
K BGPG S %=P_"^LAST EXAM DIABETIC FOOT EXAM;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE),E=$$START1^APCLDF(%,"BGPG(")
I $D(BGPG(1)) Q "1^"_$P(BGPG(1),U)_"^Diab Foot Ex"
K ^TMP($J,"A")
S A="^TMP($J,""A"","
S %=P_"^ALL VISITS;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE),E=$$START1^APCLDF(%,A)
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=65!(R="B7"),'$$DNKA^BGP8D21($P(^TMP($J,"A",X),U,5)) S Y=1,D=$P(^TMP($J,"A",X),U)
I Y Q 1_"^"_D_"^Cl "_R
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=33!(R=84)!(R=25)),'$$DNKA^BGP8D21($P(^TMP($J,"A",X),U,5)) S Y=1,D=$P(^TMP($J,"A",X),U)
I Y Q "1^"_D_"^Prv "_R
;
S G=$$CPT^BGP8DU(P,BDATE,EDATE,$O(^ATXAX("B","BGP CPT FOOT EXAM",0)),5)
I G Q 1_U_$P(G,U,1)_"^CPT: "_$P(G,U,2)
I $G(REFUSAL) Q ""
S G=$$REFUSAL^BGP8UTL1(P,9999999.15,$O(^AUTTEXAM("B","DIABETIC FOOT EXAM, COMPLETE",0)),BDATE,EDATE)
I $P(G,U)=1 Q "1^"_$P(G,U,2)_"^Refused"
Q ""
OPTOM ;EP
S (BGPD1,BGPN1)=0
I 'BGPACTCL S BGPSTOP=1 Q
I BGPAGEB<18 S BGPSTOP=1 Q
I '$$GLAUCOMA(DFN,BGPBDATE,BGPEDATE) S BGPSTOP=1 Q
S BGPD1=1
S %=$$CPT^BGP8DU(DFN,BGPBDATE,BGPEDATE,$O(^ATXAX("B","BGP OPTIC NERVE HEAD EVAL CPT",0)),6)
I % S BGPN1=1
S BGPVALUE="AC|||"_$$DATE^BGP8UTL($P(%,U,2))_" "_$P(%,U,3)
Q
GLAUCOMA(P,BDATE,EDATE) ;EP
I $$LASTDX^BGP8UTL1(P,"BGP OPEN ANGLE GLAUCOMA DXS",BDATE,EDATE) Q 1
I $$PLTAXID^BGP8DU(P,"BGP OPEN ANGLE GLAUCOMA DXS",BDATE,EDATE) Q 1
I $$IPLSNOID^BGP8DU(P,"PXRM OPEN ANGLE GLAUCOMA",BDATE,EDATE) Q 1
Q 0
EMP(P,BDATE,EDATE) ;EP
K BGPG
S Y="BGPG("
S X=P_"^LAST DX [BGP EMPHYSEMA DXS;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE) S E=$$START1^APCLDF(X,Y)
I $D(BGPG(1)) Q 1
I $$PLTAXND^BGP8DU(P,"BGP EMPHYSEMA DXS",EDATE) Q 1
I $$IPLSNOND^BGP8DU(P,"PXRM BGP EMPHYSEMA",EDATE) Q 1
Q 0
BGP8D213 ; IHS/CMI/LAB - measure 6 13 Aug 2015 6:58 AM ;
+1 ;;18.1;IHS CLINICAL REPORTING;;MAY 25, 2018;Build 66
+2 ;
CVD ;EP - called from report execution
+1 ;ONLY 21+
IF BGPAGEB<21
SET BGPSTOP=1
QUIT
+2 NEW BGPCVDL
+3 ;F X=1:1:6 S Y="BGPD"_X S @Y="" ;6 denominators
+4 ;6 denominators maw 06/22/2016 modified, I think there is supposed to be 7 here
FOR X=1:1:7
SET Y="BGPD"_X
SET @Y=""
+5 ;2 numerators
SET (BGPN1,BGPN2,BGPN3)=""
+6 ;CHD OR LDL^CHD^LDL
SET BGPCVDL=$$CHDLDL^BGP8D212(DFN,$$DOB^AUPNPAT(DFN),BGPEDATE)
+7 ;21-39 and no cvd/ldl
IF BGPAGEB>20
IF BGPAGEB<40
IF 'BGPCVDL
SET BGPSTOP=1
QUIT
+8 ;>75 and no cvd/ldl
IF BGPAGEB>75
IF 'BGPCVDL
SET BGPSTOP=1
QUIT
+9 ;DENOM 1
+10 ;up diabetic ages 40-75
IF BGPDMD1
IF BGPAGEB>39
IF BGPAGEB<76
SET BGPD1=1
+11 ;or UP 21+ w/CVD or LDL =>190
IF BGPAGEB>20
IF BGPCVDL
SET BGPD1=1
+12 ;DENOM 2 21-39, UP with CVD or LDL >=190
+13 IF BGPAGEB>20
IF BGPAGEB<40
IF BGPCVDL
SET BGPD2=1
+14 ;DENOM 3 40-75, UP with CVD or LDL =>190
+15 IF BGPAGEB>39
IF BGPAGEB<76
IF BGPCVDL
SET BGPD3=1
+16 ;DENOM 4 76+ with cvd or ldl >=190
+17 IF BGPAGEB>75
IF BGPCVDL
SET BGPD4=1
+18 ;DENOM 5 UP diabetic 40-75
+19 IF BGPDMD1
IF BGPAGEB>39
IF BGPAGEB<76
SET BGPD5=1
+20 ;DENOM 6 up 21+
+21 IF BGPD1
SET BGPD6=1
+22 ;I 'BGPD6 S BGPSTOP=1 Q ;not in at least UP denominator
+23 ;now exclude people
+24 SET (BGPEXL1,BGPEXL2,BGPEXL3,BGPEXL4,BGPEXL5,BGPEXL6,BGPEXL7)=""
+25 ;excl 1
SET BGPEXL1=$$STATALG(DFN,$$DOB^AUPNPAT(DFN),BGPEDATE,BGPBDATE,BGPEDATE)
IF BGPEXL1
SET (BGPN2,BGPN3)=1
GOTO SETL
+26 ;ALCOHOL HEP
+27 SET BGPEXL1=$$ALCHEP^BGP8D212(DFN,BGPBDATE,BGPEDATE)
IF BGPEXL1
SET BGPN2=1
GOTO SETL
+28 ;NMI
+29 SET BGPEXL1=$$STATNMI^BGP8D212(DFN,BGPBDATE,BGPEDATE)
IF BGPEXL1
SET BGPN2=1
GOTO SETL
+30 ;PREGNANCY
+31 ;V17.1 CMI/LAB ADDED DATES FOR CURRENTLY PREGNANT
SET BGPEXL2=$$PREG^BGP8D715(DFN,BGPBDATE,BGPEDATE,1,1,,BGPBDATE,BGPEDATE)
IF BGPEXL2
SET BGPN2=1
GOTO SETL
+32 ;BREASTFEEDING
+33 SET BGPEXL2=$$BF^BGP8D21(DFN,BGPBDATE,BGPEDATE)
IF BGPEXL2
SET BGPN2=1
GOTO SETL
+34 ;cirrhosis of liver
+35 SET BGPEXL6=$$CLIVER(DFN,BGPPBD,BGPEDATE)
IF BGPEXL6
SET BGPN2=1
GOTO SETL
+36 ;PALLIATIVE
+37 ;excl 3
SET BGPEXL3=$$LASTDX^BGP8UTL1(DFN,"BGP PALLIATIVE CARE DXS",BGPBDATE,BGPEDATE)
IF BGPEXL3
SET BGPN2=1
SET BGPEXL3=1_U_$$DATE^BGP8UTL($PIECE(BGPEXL3,U,3))_" Palliative Care"
GOTO SETL
+38 ;ESRD
+39 ;excl 4 ESRD
SET BGPEXL4=$$ESRD^BGP8D211(DFN,$$DOB^AUPNPAT(DFN),BGPEDATE)
IF BGPEXL4
SET BGPEXL4=1_U_$$DATE^BGP8UTL($PIECE(BGPEXL4,U,3))_" ESRD"
SET BGPN2=1
GOTO SETL
+40 ;EXCL 5
+41 SET BGPEXL7=$$HEPA^BGP8D21A(DFN,$$DOB^AUPNPAT(DFN),BGPEDATE)
IF BGPEXL7
SET BGPEXL7=1_U_$$DATE^BGP8UTL($PIECE(BGPEXL7,U,3))_" HEP A"
SET BGPN2=1
GOTO SETL
+42 SET BGPEXL7=$$HEPB^BGP8D21A(DFN,$$DOB^AUPNPAT(DFN),BGPEDATE)
IF BGPEXL7
SET BGPEXL7=1_U_$$DATE^BGP8UTL($PIECE(BGPEXL7,U,3))_" HEP B"
SET BGPN2=1
GOTO SETL
+43 NEW BGPSTAT
+44 SET BGPSTAT=$$STATIN^BGP8D214(DFN,BGPBDATE,BGPEDATE,0)
+45 ;excl 5
SET BGPEXL5=$$LASTLDLV^BGP8D212(DFN,$$DOB^AUPNPAT(DFN),BGPEDATE)
IF BGPEXL5
IF '$PIECE(BGPCVDL,U,3)
IF 'BGPSTAT
SET BGPN2=1
GOTO SETL
+46 ;numerator
+47 SET BGPN1=BGPSTAT
SETL ;
+1 ;if exclusion don't count in those denoms per Megan
IF BGPN2
SET (BGPD1,BGPD2,BGPD3,BGPD4,BGPD5)=""
+2 IF BGPN2
IF BGPD1
SET BGPD6=1
+3 SET BGPVALUE=$SELECT(BGPDMD2:"UP,AD",1:"UP")
IF BGPDMD1!(BGPCVDL)
Begin DoDot:1
+4 ;S BGPVALUE=BGPVALUE_" ("
+5 IF BGPDMD1
IF 'BGPCVDL
SET BGPVALUE=BGPVALUE_" (DM)"_"|||"
QUIT
+6 IF BGPDMD1
IF BGPCVDL
SET BGPVALUE=BGPVALUE_$SELECT($PIECE(BGPCVDL,U,2):" (DM,CHD)",$PIECE(BGPCVDL,U,3):" (DM,LDL)",$PIECE(BGPCVDL,U,4):" (DM,HYPER CHOL)",1:"")_"|||"
QUIT
+7 SET BGPVALUE=BGPVALUE_$SELECT($PIECE(BGPCVDL,U,2):" (CHD)",$PIECE(BGPCVDL,U,3):" (LDL)",$PIECE(BGPCVDL,U,4):" (HYPER CHOL)",1:"")_"|||"
End DoDot:1
+8 IF BGPN1
SET BGPVALUE=BGPVALUE_$PIECE(BGPN1,U,2)
+9 IF BGPEXL1
SET BGPVALUE=BGPVALUE_"Exclusion: "_$PIECE(BGPEXL1,U,2)
+10 IF BGPEXL2
SET BGPVALUE=BGPVALUE_"Exclusion: "_$PIECE(BGPEXL2,U,2)_" Pregnant/Breastfeeding"
+11 IF BGPEXL3
SET BGPVALUE=BGPVALUE_"Exclusion: "_$PIECE(BGPEXL3,U,2)
+12 IF BGPEXL4
SET BGPVALUE=BGPVALUE_"Exclusion: "_$PIECE(BGPEXL4,U,2)
+13 IF BGPEXL6
SET BGPVALUE=BGPVALUE_"Exclusion: "_$PIECE(BGPEXL6,U,2)_" Cirrhosis/Liver Dis"
+14 IF BGPEXL5
IF BGPN2
SET BGPVALUE=BGPVALUE_"Exclusion: "_$PIECE(BGPEXL5,U,2)
+15 IF BGPEXL7
SET BGPVALUE=BGPVALUE_"Exclusion: "_$PIECE(BGPEXL7,U,2)
+16 KILL BGPEXL1,BGPEXL2,BGPEXL3,BGPEXL4,BGPEXL5,BGPCVDL,BGPEXL6,BGPEXL7
+17 QUIT
CLIVER(P,BD,ED) ;EP - cirrhosis of liver? OR LIVER DISEASE
+1 NEW %,X
+2 SET X=$$LASTDX^BGP8UTL1(P,"BGP CIRRHOSIS OF LIVER DXS",BD,ED)
+3 IF X
QUIT 1_U_$$DATE^BGP8UTL($PIECE(X,U,3))
+4 ;PROBLEM LIST
+5 NEW X
+6 SET X=$$PLTAXND^BGP8DU(P,"BGP CIRRHOSIS OF LIVER DXS",ED)
+7 IF X
QUIT 1
+8 SET X=$$IPLSNOND^BGP8DU(P,"PXRM BGP CIRRHOSIS",ED)
+9 IF X
QUIT 1
+10 ;LIVER DISEASE
+11 SET X=$$LASTDX^BGP8UTL1(P,"BGP LIVER DISEASE DXS",BD,ED)
+12 IF X
QUIT 1_U_$$DATE^BGP8UTL($PIECE(X,U,3))
+13 ;PROBLEM LIST
+14 NEW X
+15 SET X=$$PLTAXND^BGP8DU(P,"BGP LIVER DISEASE DXS",ED)
+16 IF X
QUIT 1
+17 SET X=$$IPLSNOND^BGP8DU(P,"PXRM BGP LIVER DISEASE",ED)
+18 IF X
QUIT 1
+19 QUIT ""
STATALG(P,BDATE,EDATE,RPB,RPE) ;EP
+1 ;get all visits and check for ALT/AST tests on 2 consecutive visits
+2 NEW BGPG,BGPY,Y,X,N,Z,BGPC,T
+3 SET BGPC=""
+4 KILL BGPG,BGPY
SET Y="BGPG("
SET X=P_"^ALL DX [BGP ASA ALLERGY 995.0-995.3;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(X,Y)
+5 SET X=0
FOR
SET X=$ORDER(BGPG(X))
IF X'=+X
QUIT
SET Y=+$PIECE(BGPG(X),U,4)
Begin DoDot:1
+6 SET N=$$VAL^XBDIQ1(9000010.07,Y,.04)
SET N=$$UP^XLFSTR(N)
+7 IF N["STATIN"!(N["STATINS")
IF N'["NYSTATIN"
SET BGPC=1_U_$$DATE^BGP8UTL($PIECE(BGPG(X),U))_" ADR/Allergy POV "_$PIECE(BGPG(X),U,2)
+8 SET T=$ORDER(^ATXAX("B","BGP ADV EFF CARDIOVASC NEC",0))
+9 SET Z=$PIECE(^AUPNVPOV(Y,0),U,9)
IF Z]""
IF $$ICD^BGP8UTL2(Z,T,9)
SET BGPC=1_U_$$DATE^BGP8UTL($PIECE(BGPG(X),U))_" ADR/Allergy POV ["_$PIECE(BGPG(X),U,2)_" + "_$PIECE($$ICDDX^BGP8UTL2(Z),U,2)_"] "_N
QUIT
+10 SET Z=$PIECE(^AUPNVPOV(Y,0),U,18)
IF Z]""
IF $$ICD^BGP8UTL2(Z,T,9)
SET BGPC=1_U_$$DATE^BGP8UTL($PIECE(BGPG(X),U))_" ADR/Allergy POV ["_$PIECE(BGPG(X),U,2)_" + "_$PIECE($$ICDDX^BGP8UTL2(Z),U,2)_"] "_N
QUIT
+11 SET Z=$PIECE(^AUPNVPOV(Y,0),U,19)
IF Z]""
IF $$ICD^BGP8UTL2(Z,T,9)
SET BGPC=1_U_$$DATE^BGP8UTL($PIECE(BGPG(X),U))_" ADR/Allergy POV ["_$PIECE(BGPG(X),U,2)_" + "_$PIECE($$ICDDX^BGP8UTL2(Z),U,2)_"] "_N
QUIT
+12 QUIT
End DoDot:1
+13 IF BGPC
QUIT BGPC
+14 KILL BGPG
SET BGPC=0
SET Y="BGPG("
SET X=P_"^ALL DX [BGP HX DRUG ALLERGY NEC;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(X,Y)
+15 SET X=0
FOR
SET X=$ORDER(BGPG(X))
IF X'=+X
QUIT
SET Y=+$PIECE(BGPG(X),U,4)
Begin DoDot:1
+16 SET N=$$VAL^XBDIQ1(9000010.07,Y,.04)
SET N=$$UP^XLFSTR(N)
+17 ;_"]"
IF N["STATIN"!(N["STATINS")
IF N'["NYSTATIN"
SET BGPC=1_U_$$DATE^BGP8UTL($PIECE(BGPG(X),U))_" ADR/Allergy POV "_$PIECE(BGPG(X),U,2)
End DoDot:1
+18 IF BGPC
QUIT BGPC
+19 ;PL
+20 NEW SNT
+21 ;CODE WITH LATERALITY=BILATERAL
SET SNT="PXRM BGP ADR STATIN"
+22 SET BGPC=0
+23 SET T=""
SET T=$ORDER(^ATXAX("B","BGP ASA ALLERGY 995.0-995.3",0))
+24 SET X=0
FOR
SET X=$ORDER(^AUPNPROB("AC",P,X))
IF X'=+X
QUIT
Begin DoDot:1
+25 SET I=$PIECE($GET(^AUPNPROB(X,0)),U)
SET Y=$PIECE($$ICDDX^BGP8UTL2(I),U,2)
+26 SET N=$$VAL^XBDIQ1(9000011,X,.05)
SET N=$$UP^XLFSTR(N)
+27 IF $PIECE(^AUPNPROB(X,0),U,13)=""
IF $PIECE(^AUPNPROB(X,0),U,8)>EDATE
QUIT
+28 ;doo
IF $PIECE(^AUPNPROB(X,0),U,13)]""
IF $PIECE(^AUPNPROB(X,0),U,13)>EDATE
QUIT
+29 IF $PIECE(^AUPNPROB(X,0),U,12)="D"
QUIT
+30 ;Q:$P(^AUPNPROB(X,0),U,12)="I" crs 17.0
+31 SET S=$$VAL^XBDIQ1(9000011,X,80001)
IF S]""
IF $DATA(^XTMP("BGPSNOMEDSUBSET",$JOB,SNT,S))
SET BGPC=1_U_"ADR/Allergy Problem List "_S
QUIT
+32 ;_"]"
IF $$ICD^BGP8UTL2(I,$ORDER(^ATXAX("B","BGP HX DRUG ALLERGY NEC",0)),9)!($$ICD^BGP8UTL2(I,T,9))
IF N["STATIN"!(N["STATINS")
IF N'["NYSTATIN"
SET BGPC=1_U_$$DATE^BGP8UTL($PIECE(^AUPNPROB(X,0),U,8))_" ADR/Allergy Problem List "_Y
+33 QUIT
End DoDot:1
+34 IF BGPC
QUIT BGPC
+35 ;ART
+36 SET BGPC=0
+37 SET X=0
FOR
SET X=$ORDER(^GMR(120.8,"B",P,X))
IF X'=+X
QUIT
Begin DoDot:1
+38 IF $PIECE($PIECE($GET(^GMR(120.8,X,0)),U,4),".")>EDATE
QUIT
+39 SET N=$PIECE($GET(^GMR(120.8,X,0)),U,2)
SET N=$$UP^XLFSTR(N)
+40 IF N["STATIN"
IF N'["NYSTATIN"
SET BGPC=1_U_$$DATE^BGP8UTL($PIECE(^GMR(120.8,X,0),U,4))_" ADR/Allergy Allergy Tracking "_N
End DoDot:1
+41 IF BGPC
QUIT BGPC
+42 ;now go into the report period items
+43 KILL BGPG
SET Y="BGPG("
SET X=P_"^LAST DX [BGP MYOPATHY/MYALGIA;DURING "_$$FMTE^XLFDT(RPB)_"-"_$$FMTE^XLFDT(RPE)
SET E=$$START1^APCLDF(X,Y)
+44 ;$P(BGPG(1),U,2) ;_"]"
IF $DATA(BGPG(1))
QUIT 1_U_$$DATE^BGP8UTL($PIECE(BGPG(1),U))_" ADR/Allergy POV "_"Myalgia"
+45 ;PROBLEM LIST
+46 NEW X
+47 SET X=$$PLTAXID^BGP8DU(P,"BGP MYOPATHY/MYALGIA",RPB,RPE)
+48 IF X
QUIT 1_U_"ADR/Allergy Problem List: Myalgia"
+49 SET X=$$IPLSNOID^BGP8DU(P,"PXRM BGP MYOPATHY MYALGIA",RPB,RPE)
+50 IF X
QUIT 1_U_"ADR/Allergy Problem List: Myalgia"
+51 ;RHABDOMYOLYSIS
+52 KILL BGPG
SET Y="BGPG("
SET X=P_"^LAST DX [BGP RHABDOMYOLYSIS DX;DURING "_$$FMTE^XLFDT(RPB)_"-"_$$FMTE^XLFDT(RPE)
SET E=$$START1^APCLDF(X,Y)
+53 ;$P(BGPG(1),U,2) ;_"]"
IF $DATA(BGPG(1))
QUIT 1_U_$$DATE^BGP8UTL($PIECE(BGPG(1),U))_" ADR/Allergy POV Rhabdomyolysis"
+54 ;PROBLEM LIST
+55 NEW X
+56 SET X=$$PLTAXID^BGP8DU(P,"BGP RHABDOMYOLYSIS DX",RPB,RPE)
+57 IF X
QUIT 1_U_"ADR/Allergy Problem List: Rhabdomyolysis"
+58 SET X=$$IPLSNOID^BGP8DU(P,"PXRM BGP RHABDOMYOLYSIS",RPB,RPE)
+59 IF X
QUIT 1_U_"ADR/Allergy Problem List: Rhabdomyolysis"
+60 ;creatine lab value > 10,000 or 10x uln
+61 SET BGPG=""
+62 SET T=$ORDER(^ATXAX("B","BGP CREATINE KINASE LOINC",0))
+63 SET BGPLT=$ORDER(^ATXLAB("B","BGP CREATINE KINASE TAX",0))
+64 SET B=9999999-RPB
SET E=9999999-RPE
SET D=E-1
FOR
SET D=$ORDER(^AUPNVLAB("AE",P,D))
IF D'=+D!(D>B)!(BGPG)
QUIT
Begin DoDot:1
+65 SET L=0
FOR
SET L=$ORDER(^AUPNVLAB("AE",P,D,L))
IF L'=+L
QUIT
Begin DoDot:2
+66 SET X=0
FOR
SET X=$ORDER(^AUPNVLAB("AE",P,D,L,X))
IF X'=+X
QUIT
Begin DoDot:3
+67 IF '$DATA(^AUPNVLAB(X,0))
QUIT
+68 IF BGPLT
IF $PIECE(^AUPNVLAB(X,0),U)
IF $DATA(^ATXLAB(BGPLT,21,"B",$PIECE(^AUPNVLAB(X,0),U)))
IF $$RESCK^BGP8D722(X)
SET BGPG=1_U_$$DATE^BGP8UTL((9999999-D))_" ADR/Allergy creat kinase of "_$PIECE(^AUPNVLAB(X,0),U,4)
QUIT
+69 IF 'T
QUIT
+70 SET J=$PIECE($GET(^AUPNVLAB(X,11)),U,13)
IF J=""
QUIT
+71 IF '$$LOINC^BGP8D2(J,T)
QUIT
+72 IF $$RESCK^BGP8D722(X)
SET BGPG=1_U_$$DATE^BGP8UTL((9999999-D))_" ADR/Allergy creat kinase of "_$PIECE(^AUPNVLAB(X,0),U,4)
QUIT
+73 QUIT
End DoDot:3
End DoDot:2
End DoDot:1
+74 IF BGPG
QUIT BGPG
+75 SET T=$ORDER(^ATXAX("B","BGP ALT LOINC",0))
+76 SET BGPLT=$ORDER(^ATXLAB("B","DM AUDIT ALT TAX",0))
+77 SET T2=$ORDER(^ATXAX("B","BGP AST LOINC",0))
+78 SET BGPLT2=$ORDER(^ATXLAB("B","DM AUDIT AST TAX",0))
+79 SET B=9999999-$$FMADD^XLFDT(EDATE,-365)
SET E=9999999-EDATE
SET D=E-1
FOR
SET D=$ORDER(^AUPNVLAB("AE",P,D))
IF D'=+D!(D>B)!(BGPG)
QUIT
Begin DoDot:1
+80 SET L=0
FOR
SET L=$ORDER(^AUPNVLAB("AE",P,D,L))
IF L'=+L
QUIT
Begin DoDot:2
+81 SET X=0
FOR
SET X=$ORDER(^AUPNVLAB("AE",P,D,L,X))
IF X'=+X
QUIT
Begin DoDot:3
+82 IF '$DATA(^AUPNVLAB(X,0))
QUIT
+83 IF BGPLT
IF $PIECE(^AUPNVLAB(X,0),U)
IF $DATA(^ATXLAB(BGPLT,21,"B",$PIECE(^AUPNVLAB(X,0),U)))
SET BGPC=BGPC+1
SET BGPC((9999999-D))=X_U_$PIECE(^AUPNVLAB(X,0),U,4)_U_$PIECE($GET(^AUPNVLAB(X,11)),U,5)
QUIT
+84 IF BGPLT2
IF $PIECE(^AUPNVLAB(X,0),U)
IF $DATA(^ATXLAB(BGPLT2,21,"B",$PIECE(^AUPNVLAB(X,0),U)))
SET BGPC=BGPC+1
SET BGPC((9999999-D))=X_U_$PIECE(^AUPNVLAB(X,0),U,4)_U_$PIECE($GET(^AUPNVLAB(X,11)),U,5)
QUIT
+85 SET J=$PIECE($GET(^AUPNVLAB(X,11)),U,13)
IF J=""
QUIT
+86 IF '$$LOINC^BGP8D2(J,T)
IF '$$LOINC^BGP8D2(J,T2)
+87 SET BGPC=BGPC+1
SET BGPC((9999999-D))=X_U_$PIECE(^AUPNVLAB(X,0),U,4)_U_$PIECE($GET(^AUPNVLAB(X,11)),U,5)
QUIT
+88 QUIT
End DoDot:3
End DoDot:2
End DoDot:1
+89 ;are they 2 consecutive
+90 SET BGPG=""
+91 SET X=0
FOR
SET X=$ORDER(BGPC(X))
IF X'=+X!(BGPG)
QUIT
Begin DoDot:1
+92 IF '$$RESAL^BGP8D722(BGPC(X))
QUIT
+93 ;is next one also bad?
+94 SET Y=$ORDER(BGPC(X))
+95 IF Y=""
QUIT
+96 IF $$RESAL^BGP8D722(BGPC(Y))
SET BGPG=1_U_" ADR/Allergy AST/ALT"
QUIT
+97 QUIT
End DoDot:1
+98 IF BGPG
QUIT BGPG
+99 QUIT 0
+1 NEW BGPG,%,E,A,Y,X,R,G
+2 SET REFUSAL=$GET(REFUSAL)
+3 KILL BGPG
SET %=P_"^LAST EXAM DIABETIC FOOT EXAM;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(%,"BGPG(")
+4 IF $DATA(BGPG(1))
QUIT "1^"_$PIECE(BGPG(1),U)_"^Diab Foot Ex"
+5 KILL ^TMP($JOB,"A")
+6 SET A="^TMP($J,""A"","
+7 SET %=P_"^ALL VISITS;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(%,A)
+8 SET X=0
SET Y=0
FOR
SET X=$ORDER(^TMP($JOB,"A",X))
IF X'=+X!(Y)
QUIT
SET R=$$CLINIC^APCLV($PIECE(^TMP($JOB,"A",X),U,5),"C")
IF R=65!(R="B7")
IF '$$DNKA^BGP8D21($PIECE(^TMP($JOB,"A",X),U,5))
SET Y=1
SET D=$PIECE(^TMP($JOB,"A",X),U)
+9 IF Y
QUIT 1_"^"_D_"^Cl "_R
+10 SET (X,Y)=0
SET D=""
FOR
SET X=$ORDER(^TMP($JOB,"A",X))
IF X'=+X!(Y)
QUIT
SET R=$$PRIMPROV^APCLV($PIECE(^TMP($JOB,"A",X),U,5),"D")
IF (R=33!(R=84)!(R=25))
IF '$$DNKA^BGP8D21($PIECE(^TMP($JOB,"A",X),U,5))
SET Y=1
SET D=$PIECE(^TMP($JOB,"A",X),U)
+11 IF Y
QUIT "1^"_D_"^Prv "_R
+12 ;
+13 SET G=$$CPT^BGP8DU(P,BDATE,EDATE,$ORDER(^ATXAX("B","BGP CPT FOOT EXAM",0)),5)
+14 IF G
QUIT 1_U_$PIECE(G,U,1)_"^CPT: "_$PIECE(G,U,2)
+15 IF $GET(REFUSAL)
QUIT ""
+16 SET G=$$REFUSAL^BGP8UTL1(P,9999999.15,$ORDER(^AUTTEXAM("B","DIABETIC FOOT EXAM, COMPLETE",0)),BDATE,EDATE)
+17 IF $PIECE(G,U)=1
QUIT "1^"_$PIECE(G,U,2)_"^Refused"
+18 QUIT ""
OPTOM ;EP
+1 SET (BGPD1,BGPN1)=0
+2 IF 'BGPACTCL
SET BGPSTOP=1
QUIT
+3 IF BGPAGEB<18
SET BGPSTOP=1
QUIT
+4 IF '$$GLAUCOMA(DFN,BGPBDATE,BGPEDATE)
SET BGPSTOP=1
QUIT
+5 SET BGPD1=1
+6 SET %=$$CPT^BGP8DU(DFN,BGPBDATE,BGPEDATE,$ORDER(^ATXAX("B","BGP OPTIC NERVE HEAD EVAL CPT",0)),6)
+7 IF %
SET BGPN1=1
+8 SET BGPVALUE="AC|||"_$$DATE^BGP8UTL($PIECE(%,U,2))_" "_$PIECE(%,U,3)
+9 QUIT
GLAUCOMA(P,BDATE,EDATE) ;EP
+1 IF $$LASTDX^BGP8UTL1(P,"BGP OPEN ANGLE GLAUCOMA DXS",BDATE,EDATE)
QUIT 1
+2 IF $$PLTAXID^BGP8DU(P,"BGP OPEN ANGLE GLAUCOMA DXS",BDATE,EDATE)
QUIT 1
+3 IF $$IPLSNOID^BGP8DU(P,"PXRM OPEN ANGLE GLAUCOMA",BDATE,EDATE)
QUIT 1
+4 QUIT 0
EMP(P,BDATE,EDATE) ;EP
+1 KILL BGPG
+2 SET Y="BGPG("
+3 SET X=P_"^LAST DX [BGP EMPHYSEMA DXS;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(X,Y)
+4 IF $DATA(BGPG(1))
QUIT 1
+5 IF $$PLTAXND^BGP8DU(P,"BGP EMPHYSEMA DXS",EDATE)
QUIT 1
+6 IF $$IPLSNOND^BGP8DU(P,"PXRM BGP EMPHYSEMA",EDATE)
QUIT 1
+7 QUIT 0
