BGP5D3B.m

BGP5D3B ; IHS/CMI/LAB - PNEUMO REMINDER ; 27 Feb 2015  7:52 AM

 ;;15.1;IHS CLINICAL REPORTING;;MAY 06, 2015;Build 143

 ;

I13 ;EP - PN

 NEW BGPTDAP,BGPTD,BGPFLU,BGPZOST,BGPPNEU,BGPPNEUD

 S (BGPN1,BGPN2,BGPN3,BGPN4,BGPN5,BGPN6,BGPN7,BGPN8,BGPN9,BGPN10,BGPN11,BGPN12,BGPD1,BGPD2,BGPD3,BGPD4,BGPD5,BGPD6,BGPD7,BGPD8,BGPD9,BGPD10,BGPD11,BGPD12,BGPD13)=0

 S (BGPN13,BGPN14,BGPN15,BGPN16,BGPN17,BGPN18,BGPN19,BGPN20,BGPN21,BGPN22,BGPN23,BGPN24,BGPN25,BGPN26,BGPN27,BGPN28,BGPN29,BGPN30,BGPN31,BGPN32,BGPN33,BGPN34,BGPN35,BGPN36,BGPN37,BGPN38)=0

 I BGPAGEB>64,BGPACTUP S BGPD3=1

 I BGPDMD2 S BGPD2=1

 I BGPAGEB>64,BGPACTCL S BGPD1=1

 I BGPAGEB>17,BGPAGEB<65,BGPACTCL,$$HIGHRP^BGP5D3A(DFN,BGPEDATE) S BGPD4=1

 I BGPAGEB>17,BGPAGEB<65,BGPACTUP,$$HIGHRP^BGP5D3A(DFN,BGPEDATE) S BGPD5=1

 I BGPAGEB>17,BGPAGEB<65,BGPACTCL S BGPD6=1

 I BGPAGEB>17,BGPAGEB<65,BGPACTUP S BGPD7=1

 I BGPAGEB>17,BGPACTCL S BGPD8=1

 I BGPAGEB>17,BGPACTUP S BGPD9=1

 I BGPAGEB>18,BGPAGEB<60,BGPACTCL S BGPD10=1

 I BGPAGEB>18,BGPAGEB<60,BGPACTUP S BGPD11=1

 I BGPAGEB>59,BGPAGEB<65,BGPACTCL S BGPD12=1

 I BGPAGEB>59,BGPAGEB<65,BGPACTUP S BGPD13=1

 I '(BGPD1+BGPD2+BGPD3+BGPD4+BGPD5+BGPD6+BGPD7+BGPD8+BGPD9+BGPD10+BGPD11+BGPD12+BGPD13) S BGPSTOP=1 Q

 S BGPVALUE="",BGPVALUD="",BGPPLPNU=""

PN ;EP - called from elder

 S BGPVALUE=$$PNEU^BGP5D31(DFN,$$DOB^AUPNPAT(DFN),BGPEDATE) ;set to date of PNEU shot

 I $P(BGPVALUE,U,3)=1!($P(BGPVALUE,U,3)=3) S BGPN1=1 ; ALL USERS HAD 1 EVER - 

 I $P(BGPVALUE,U,3)=3 S BGPN3=1  ;NMI EVER

 S BGPVAL=$$PNEU^BGP5D31(DFN,$$FMADD^XLFDT(BGPEDATE,-(5*365)),BGPEDATE)

 I $P(BGPVAL,U,3)=1!($P(BGPVAL,U,3)=3) S BGPN4=1  ;HAD IN PAST 5 YEARS SO "UP TO DATE"

 I $P(BGPVAL,U,3)=3 S BGPN6=1  ;NMI PAST 5 YRS

 ;65TH DOB DATE

 S B=$$DOB^AUPNPAT(DFN)

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

 S BGPN7=0,BGPA65="" I BGPAGEB>64 S BGPA65=$$PNEU^BGP5D31(DFN,BGPA65BD,BGPEDATE) I $P(BGPA65,U,3)=1!($P(BGPA65,U,3)=3) S BGPN4=1,BGPN7=1 ;65+ HAD AFTER 65TH DOB  BGPN4 IS UPTODATE

 I BGPAGEB<65,BGPN1 S BGPN4=1  ;anyone under and had 1 ever  ;BGPN4 IS UP TO DATE

 ;NATIONAL GPRA

 S BGPN8=0

 I BGPAGEB<65,BGPN1 S BGPN8=1  ;GPRA DEV UP TO DATE

 I BGPAGEB>64,BGPN1,(BGPN4+BGPN7) S BGPN8=1  ;IF 65+ HAD ONE IN PAST 5 YEARS OR AFTER AGE 65

 ;GPRA DEV V15.0

 D

 .S B=$$DOB^AUPNPAT(DFN)

 .S BGPA65BD=$E(B,1,3)+65_$E(B,4,7),BGPPNA65=""

 .I BGPAGEB>64 S BGPPNA65=$$PNEUD(DFN,BGPA65BD,BGPEDATE)

 .I BGPAGEB>64 I $P(BGPPNA65,U,3)=1!($P(BGPPNA65,U,3)=3) S BGPN37=1 ;HAD PNEUMO AFTER 65TH DOB UPTODATE

 .S (BGPPNEU,BGPPLPNU)=$$PNEUD(DFN,$$DOB^AUPNPAT(DFN),BGPEDATE) ;set to date of PNEU shot EVER

 .I $P(BGPPNEU,U,3)=1!($P(BGPPNEU,U,3)=3) S BGPN23=1 ; ALL USERS HAD 1 EVER - 

 .I $P(BGPPNEU,U,3)=3 S BGPN24=1  ;NMI

 .S BGPPNEUD=$$PNEUD(DFN,$$FMADD^XLFDT(BGPEDATE,-(5*365)),BGPEDATE)

 .I $P(BGPPNEUD,U,3)=1!($P(BGPPNEUD,U,3)=3) S BGPN25=1,BGPN37=1  ;HAD IN PAST 5 YEARS SO "UP TO DATE"

 .I $P(BGPPNEUD,U,3)=3 S BGPN26=1  ;NMI PAST 5 YRS

 .S BGPN27=0,BGPA65="" I BGPAGEB>64 S BGPA65=$$PNEUD(DFN,BGPA65BD,BGPEDATE) I $P(BGPA65,U,3)=1!($P(BGPA65,U,3)=3) S BGPN25=1,BGPN27=1 ;over 65 and had one after 65

 .I BGPAGEB<65,BGPN23 S BGPN25=1,BGPN37=1  ;anyone under and had 1 ever  ;BGPN4 IS UP TO DATE

 .I 'BGPN37 S (BGPPNCON,BGPPLPNU)=$$PNEUCONJ(DFN,BGPBDATE,BGPEDATE) I $P(BGPPNCON,U,3)=1!($P(BGPPNCON,U,3)=3) S BGPN36=1,BGPN37=1

 ;GPRA DEV

 S BGPN28=0

 I BGPAGEB<65,BGPN23 S BGPN28=1  ;GPRA DEV UP TO DATE

 I BGPAGEB>64,BGPN23,(BGPN25+BGPN27) S BGPN28=1  ;IF UNDER 66 HAD 1 EVER, IF OVER 65 HAD ONE IN PAST 5 YEARS OR AFTER AGE 65

 ;I BGPAGEB>65,BGPN23,(BGPN25+BGPN27+BGPN36) S BGPN37=1  ;IF UNDER 66 HAD 1 EVER, IF OVER 65 HAD ONE IN PAST 5 YEARS OR AFTER AGE 65

 S BGPDV=""

 I BGPRTYPE=1 S BGPDV="" D

 .I BGPD1 S BGPDV=BGPDV_$S(BGPDV]"":",AC",1:"AC")

 .I BGPD2 S BGPDV=BGPDV_$S(BGPDV]"":",AD",1:"AD")

 .I BGPN1 S BGPVALH=BGPVALUE,BGPVALUE=BGPDV_"|||" I BGPVALH]"" S BGPVALUE=BGPVALUE_"Pneumo: "_$$DATE^BGP5UTL($P(BGPVALH,U,1))_" "_$P(BGPVALH,U,2)_$S(BGPVALH]"":" (ever)",1:"")_" "_$S(BGPN8:" (up-to-date)",1:"") Q

 .S BGPVALUE=BGPDV_"|||"

 I BGPRTYPE=4 D

 .S BGPDV="UP"

 .I BGPD6!(BGPD1)!(BGPD8) S BGPDV=BGPDV_$S(BGPDV]"":",AC",1:"AC")

 .I BGPD4!(BGPD5) S BGPDV=BGPDV_$S(BGPDV]"":",HR",1:"HR")

 .I BGPD2 S BGPDV=BGPDV_$S(BGPDV]"":",AD",1:"AD")

 I BGPRTYPE=7 S BGPDV=$S(BGPD6:"AC",BGPD8:"AC",1:"") S:BGPD4 BGPDV=BGPDV_$S(BGPDV]"":",HR",1:"HR") S:BGPD2 BGPDV=BGPDV_$S(BGPDV]"":",AD",1:"AD")

 D

 .I BGPRTYPE'=1 S BGPVALH=BGPVALUE,BGPVALUE=BGPDV_"|||" I BGPVALH]"" S BGPVALUE=BGPVALUE_"Pneumo: "_$$DATE^BGP5UTL($P(BGPVALH,U,1))_" "_$P(BGPVALH,U,2)_$S(BGPVALH]"":" (ever)",1:"")_" "_$S(BGPN8:" (up-to-date)",1:"")

 .S BGPVALUD="AC"_"|||"

 .I BGPN23!(BGPN37) S BGPVALUD=BGPVALUD_"Pneumo: "_$$DATE^BGP5UTL($P(BGPPLPNU,U,1))_" "_$P(BGPPLPNU,U,2)_$S(BGPPLPNU]"":" (ever)",1:"")_" "

 .I BGPN28!(BGPN37&('BGPN36)) S BGPVALUD=BGPVALUD_"(up-to-date)" ;_$S((BGPN28!(BGPN37)),'BGPN36:"(up-to-date)",1:"")

TD ;new tdap and td stuff for v11.1

 S BGPTDAP=$$DTAP^BGP5D3A(DFN,$$DOB^AUPNPAT(DFN),BGPEDATE)

 I BGPTDAP S BGPN9=1

 I $P(BGPTDAP,U,1)=2 S BGPN12=1

 S BGPTD=$$DTAPTD^BGP5D3A(DFN,$$FMADD^XLFDT(BGPEDATE,-(10*365)),BGPEDATE)

 I BGPTD S BGPN10=1

 I $P(BGPTD,U,1)=2 S BGPN11=1

 I BGPRTYPE=5 G TDE

 ;FLU - 14.1

 S BGPFLU=$$FLU^BGP5D3(DFN,,BGPEDATE)

 I $P(BGPFLU,U,3)=1!($P(BGPFLU,U,3)=3) S BGPN13=1

 I $P(BGPFLU,U,3)=3 S BGPN14=1

 I BGPN9,BGPN10,BGPN13 S BGPN15=1

 I BGPN9,BGPN10 S BGPN30=1  ;TD 10 YRS/TDAP EVER

 I BGPN11!(BGPN12)!(BGPN14) S BGPN16=1

 I BGPN11!(BGPN12) S BGPN31=1 ;1:1 CONTRA

 S BGPZOST=$$IZOSTER(DFN,$$DOB^AUPNPAT(DFN),BGPEDATE)

 I $P(BGPZOST,U,3)=1!($P(BGPZOST,U,3)=3) S BGPN17=1

 I $P(BGPZOST,U,3)=3 S BGPN18=1

 I BGPN9,BGPN10,BGPN13,BGPN17 S BGPN19=1

 I BGPN9,BGPN10,BGPN17 S BGPN32=1  ;1:1:1: TD/TDAP/ZOSTER

 I BGPN11!(BGPN12)!(BGPN14)!(BGPN18) S BGPN20=1

 I BGPN11!(BGPN12)!(BGPN18) S BGPN33=1  ;1:1:1 TD/TDAP/ZOSTER CONTRA

 I BGPN9,BGPN10,BGPN13,BGPN17,BGPN8 S BGPN21=1

 I BGPN9,BGPN10,BGPN17,BGPN8 S BGPN34=1

 I BGPN11!(BGPN12)!(BGPN14)!(BGPN18)!(BGPN3) S BGPN22=1

 I BGPN11!(BGPN12)!(BGPN18)!(BGPN3) S BGPN35=1

 I BGPN9,BGPN10,BGPN13,BGPN17,BGPN28 S BGPN29=1

 I BGPN9,BGPN10,BGPN17,BGPN37 S BGPN38=1

 I BGPTDAP S BGPVALUE=BGPVALUE_$S($P(BGPVALUE,"|||",2)]"":"; ",1:""),BGPVALUE=BGPVALUE_"TDAP: "_$P(BGPTDAP,U,2)_" (ever)"

 I BGPTD S BGPVALUE=BGPVALUE_$S($P(BGPVALUE,"|||",2)]"":"; ",1:""),BGPVALUE=BGPVALUE_"TDAP/TD: "_$P(BGPTD,U,2)_" (past 10 yrs)"

 I BGPFLU S BGPVALUE=BGPVALUE_$S($P(BGPVALUE,"|||",2)]"":"; ",1:""),BGPVALUE=BGPVALUE_"FLU: "_$P(BGPFLU,U,2)_" (past yr)"

 I BGPZOST S BGPVALUE=BGPVALUE_$S($P(BGPVALUE,"|||",2)]"":"; ",1:""),BGPVALUE=BGPVALUE_"ZOSTER: "_$P(BGPZOST,U,2)_" (ever)"

 I BGPTDAP S BGPVALUD=BGPVALUD_$S($P(BGPVALUD,"|||",2)]"":"; ",1:""),BGPVALUD=BGPVALUD_"TDAP: "_$P(BGPTDAP,U,2)_" (ever)"

 I BGPTD S BGPVALUD=BGPVALUD_$S($P(BGPVALUD,"|||",2)]"":"; ",1:""),BGPVALUD=BGPVALUD_"TDAP/TD: "_$P(BGPTD,U,2)_" (past 10 yrs)"

 I BGPFLU S BGPVALUD=BGPVALUD_$S($P(BGPVALUD,"|||",2)]"":"; ",1:""),BGPVALUD=BGPVALUD_"FLU: "_$P(BGPFLU,U,2)_" (past yr)"

 I BGPZOST S BGPVALUD=BGPVALUD_$S($P(BGPVALUD,"|||",2)]"":"; ",1:""),BGPVALUD=BGPVALUD_"ZOSTER: "_$P(BGPZOST,U,2)_" (ever)"

TDE K BGPLPNU,BGPVAL,BGPA65,BGPVALH,BGPTD,BGPTDAP,BGPFLU

 Q

IZOSTER(P,BDATE,EDATE,FORE) ;EP

 NEW BGPLPNU,BGPG,X,E,R,BD,ED,G,%

 S BGPLPNU=""

 S BD=BDATE

 S ED=EDATE

 S EDATE=$$FMTE^XLFDT(EDATE)

 S BDATE=$$FMTE^XLFDT(BDATE)

 S X=P_"^LAST IMM 121;DURING "_BDATE_"-"_EDATE S E=$$START1^APCLDF(X,"BGPG(")

 I $D(BGPG(1)),$P(BGPLPNU,U,1)<$P(BGPG(1),U) S BGPLPNU=$P(BGPG(1),U,1)_U_"Imm 121"

 S %=$$CPT^BGP5DU(P,BD,ED,$O(^ATXAX("B","BGP ZOSTER IZ CPTS",0)),5)

 I $P(BGPLPNU,U,1)<$P(%,U,1) S BGPLPNU=$P(%,U,1)_U_"CPT "_$P(%,U,2)

 S %=$$TRAN^BGP5DU(P,BD,ED,$O(^ATXAX("B","BGP ZOSTER IZ CPTS",0)),5)

 I $P(BGPLPNU,U,1)<$P(%,U,1) S BGPLPNU=$P(%,U,1)_U_"CPT "_$P(%,U,2)

 I BGPLPNU]"" Q BGPLPNU_U_1

 ;NOW CHECK FOR CONTRAINDICATION (NEW IN 8.0)

 F BGPZ=121 S X=$$ANIMCONT^BGP5D31(P,BGPZ,ED)

 I X]"" Q X_U_3

 ;NMI Refusal

 S G=$$NMIREF^BGP5UTL1(P,9999999.14,$O(^AUTTIMM("C",121,0)),$$DOB^AUPNPAT(P),ED)

 I $P(G,U)=1 Q $P(G,U,2)_U_"NMI Refusal"_U_3

 S R=$$CPTREFT^BGP5UTL1(P,$$DOB^AUPNPAT(P),ED,$O(^ATXAX("B","BGP ZOSTER IZ CPTS",0)),"N")

 I R Q $P(R,U,2)_U_"NMI Refusal "_$P(R,U,4)_U_3

 Q ""

 ;

PNEUD(P,BDATE,EDATE,FORE) ;EP

 K BGPG

 S BGPLPNU=""

 S BD=BDATE

 S ED=EDATE

 S EDATE=$$FMTE^XLFDT(EDATE)

 S BDATE=$$FMTE^XLFDT(BDATE)

 S X=P_"^LAST IMM "_$S($$BI^BGP5D31:33,1:19)_";DURING "_BDATE_"-"_EDATE S E=$$START1^APCLDF(X,"BGPG(")

 I $D(BGPG(1)) S BGPLPNU=$P(BGPG(1),U)_U_"Imm 33"

 ;S X=P_"^LAST IMM 100;DURING "_BDATE_"-"_EDATE S E=$$START1^APCLDF(X,"BGPG(")

 ;I $D(BGPG(1)),$P(BGPLPNU,U,1)<$P(BGPG(1),U) S BGPLPNU=$P(BGPG(1),U,1)_U_"Imm 100"

 S X=P_"^LAST IMM 109;DURING "_BDATE_"-"_EDATE S E=$$START1^APCLDF(X,"BGPG(")

 I $D(BGPG(1)),$P(BGPLPNU,U,1)<$P(BGPG(1),U) S BGPLPNU=$P(BGPG(1),U,1)_U_"Imm 109"

 ;S X=P_"^LAST IMM 133;DURING "_BDATE_"-"_EDATE S E=$$START1^APCLDF(X,"BGPG(")

 ;I $D(BGPG(1)),$P(BGPLPNU,U,1)<$P(BGPG(1),U) S BGPLPNU=$P(BGPG(1),U,1)_U_"Imm 133"

 ;S X=P_"^LAST IMM 152;DURING "_BDATE_"-"_EDATE S E=$$START1^APCLDF(X,"BGPG(")

 ;I $D(BGPG(1)),$P(BGPLPNU,U,1)<$P(BGPG(1),U) S BGPLPNU=$P(BGPG(1),U,1)_U_"Imm 152"

 K BGPG S %=P_"^LAST DX V03.82;DURING "_BDATE_"-"_EDATE,E=$$START1^APCLDF(%,"BGPG(")

 I $D(BGPG(1)),$P(BGPLPNU,U,1)<$P(BGPG(1),U) S BGPLPNU=$P(BGPG(1),U,1)_U_"POV "_$P(BGPG(1),U,2)

 S %=$$CPT^BGP5DU(P,BD,ED,$O(^ATXAX("B","BGP PNEUMO IZ CPT DEV",0)),5)

 I $P(BGPLPNU,U,1)<$P(%,U,1) S BGPLPNU=$P(%,U,1)_U_"CPT "_$P(%,U,2)

 S %=$$TRAN^BGP5DU(P,BD,ED,$O(^ATXAX("B","BGP PNEUMO IZ CPT DEV",0)),5)

 I $P(BGPLPNU,U,1)<$P(%,U,1) S BGPLPNU=$P(%,U,1)_U_"CPT "_$P(%,U,2)

 I BGPLPNU]"" Q BGPLPNU_U_1

 ;NOW CHECK FOR CONTRAINDICATION (NEW IN 8.0)

 F BGPZ=33,109 S X=$$ANCONT^BGP5D31(P,BGPZ,ED) Q:X]""

 I X]"" Q X_U_3

 ;NMI Refusal

 S G=$$NMIREF^BGP5UTL1(P,9999999.14,$O(^AUTTIMM("C",33,0)),$$DOB^AUPNPAT(P),ED)

 I $P(G,U)=1 Q $P(G,U,2)_U_"NMI Refusal"_U_3

 ;S G=$$NMIREF^BGP5UTL1(P,9999999.14,$O(^AUTTIMM("C",100,0)),$$DOB^AUPNPAT(P),ED)

 ;I $P(G,U)=1 Q $P(G,U,2)_U_"NMI Refusal"_U_3

 S G=$$NMIREF^BGP5UTL1(P,9999999.14,$O(^AUTTIMM("C",109,0)),$$DOB^AUPNPAT(P),ED)

 I $P(G,U)=1 Q $P(G,U,2)_U_"NMI Refusal"_U_3

 ;S G=$$NMIREF^BGP5UTL1(P,9999999.14,$O(^AUTTIMM("C",133,0)),$$DOB^AUPNPAT(P),ED)

 ;I $P(G,U)=1 Q $P(G,U,2)_U_"NMI Refusal"_U_3

 S R=$$CPTREFT^BGP5UTL1(P,$$DOB^AUPNPAT(P),ED,$O(^ATXAX("B","BGP PNEUMO IZ CPT DEV",0)),"N")

 I R Q $P(R,U,2)_U_"NMI Refusal "_$P(R,U,4)_U_3

 Q ""

 ;

PNEUCONJ(P,BDATE,EDATE,FORE) ;EP

 K BGPG

 S BGPLPNU=""

 S BD=BDATE

 S ED=EDATE

 S EDATE=$$FMTE^XLFDT(EDATE)

 S BDATE=$$FMTE^XLFDT(BDATE)

 S X=P_"^LAST IMM 100;DURING "_BDATE_"-"_EDATE S E=$$START1^APCLDF(X,"BGPG(")

 I $D(BGPG(1)),$P(BGPLPNU,U,1)<$P(BGPG(1),U) S BGPLPNU=$P(BGPG(1),U,1)_U_"Imm 100 (conj)"

 S X=P_"^LAST IMM 133;DURING "_BDATE_"-"_EDATE S E=$$START1^APCLDF(X,"BGPG(")

 I $D(BGPG(1)),$P(BGPLPNU,U,1)<$P(BGPG(1),U) S BGPLPNU=$P(BGPG(1),U,1)_U_"Imm 133 (conj)"

 S X=P_"^LAST IMM 152;DURING "_BDATE_"-"_EDATE S E=$$START1^APCLDF(X,"BGPG(")

 I $D(BGPG(1)),$P(BGPLPNU,U,1)<$P(BGPG(1),U) S BGPLPNU=$P(BGPG(1),U,1)_U_"Imm 152 (conj)"

 S %=$$CPT^BGP5DU(P,BD,ED,$O(^ATXAX("B","BGP PNEUMO CONJUGATE CPTS",0)),5)

 I $P(BGPLPNU,U,1)<$P(%,U,1) S BGPLPNU=$P(%,U,1)_U_"CPT "_$P(%,U,2)_" (conj)"

 S %=$$TRAN^BGP5DU(P,BD,ED,$O(^ATXAX("B","BGP PNEUMO CONJUGATE CPTS",0)),5)

 I $P(BGPLPNU,U,1)<$P(%,U,1) S BGPLPNU=$P(%,U,1)_U_"CPT "_$P(%,U,2)_" (conj)"

 I BGPLPNU]"" Q BGPLPNU_U_1

 ;NOW CHECK FOR CONTRAINDICATION (NEW IN 8.0)

 F BGPZ=100,133,152 S X=$$ANCONT^BGP5D31(P,BGPZ,ED) Q:X]""

 I X]"" Q X_U_3

 ;NMI Refusal

 S G=$$NMIREF^BGP5UTL1(P,9999999.14,$O(^AUTTIMM("C",100,0)),$$DOB^AUPNPAT(P),ED)

 I $P(G,U)=1 Q $P(G,U,2)_U_"NMI Refusal"_U_3

 S G=$$NMIREF^BGP5UTL1(P,9999999.14,$O(^AUTTIMM("C",133,0)),$$DOB^AUPNPAT(P),ED)

 I $P(G,U)=1 Q $P(G,U,2)_U_"NMI Refusal"_U_3

 S G=$$NMIREF^BGP5UTL1(P,9999999.14,$O(^AUTTIMM("C",152,0)),$$DOB^AUPNPAT(P),ED)

 I $P(G,U)=1 Q $P(G,U,2)_U_"NMI Refusal"_U_3

 S R=$$CPTREFT^BGP5UTL1(P,$$DOB^AUPNPAT(P),ED,$O(^ATXAX("B","BGP PNEUMO CONJUGATE CPTS",0)),"N")

 I R Q $P(R,U,2)_U_"NMI Refusal "_$P(R,U,4)_U_3

 Q ""

OPTOM ;

 S (BGPD1,BGPN1)=0

 I 'BGPACTCL S BGPSTOP=1 Q  ;must be active clinical

 I BGPAGEB<18 S BGPSTOP=1 Q  ;18 and older only

 I '$$GLAUCOMA(DFN,BGPBDATE,BGPEDATE) S BGPSTOP=1 Q  ;MUST HAVE HAD GLAUCOMA DX EVER BEFORE END OF TIME PERIOD

 S BGPD1=1

 S %=$$CPT^BGP5DU(DFN,BGPBDATE,BGPEDATE,$O(^ATXAX("B","BGP OPTIC NERVE HEAD EVAL CPT",0)),6)

 ;S %="",E=+$$CODEN^ICPTCOD("2027F"),%=$$CPTI^BGP5DU(DFN,BGPBDATE,BGPEDATE,E)

 I % S BGPN1=1

 S BGPVALUE="AC|||"_$$DATE^BGP5UTL($P(%,U,2))_" "_$P(%,U,3)

 Q

GLAUCOMA(P,BDATE,EDATE) ;EP

 Q $$LASTDX^BGP5UTL1(P,"BGP OPEN ANGLE GLAUCOMA DXS",BDATE,EDATE)

BGP5D3B   ; IHS/CMI/LAB - PNEUMO REMINDER ; 27 Feb 2015  7:52 AM

 +1       ;;15.1;IHS CLINICAL REPORTING;;MAY 06, 2015;Build 143

 +2       ;

I13       ;EP - PN

 +1        NEW BGPTDAP,BGPTD,BGPFLU,BGPZOST,BGPPNEU,BGPPNEUD

 +2        SET (BGPN1,BGPN2,BGPN3,BGPN4,BGPN5,BGPN6,BGPN7,BGPN8,BGPN9,BGPN10,BGPN11,BGPN12,BGPD1,BGPD2,BGPD3,BGPD4,BGPD5,BGPD6,BGPD7,BGPD8,BGPD9,BGPD10,BGPD11,BGPD12,BGPD13)=0

 +3        SET (BGPN13,BGPN14,BGPN15,BGPN16,BGPN17,BGPN18,BGPN19,BGPN20,BGPN21,BGPN22,BGPN23,BGPN24,BGPN25,BGPN26,BGPN27,BGPN28,BGPN29,BGPN30,BGPN31,BGPN32,BGPN33,BGPN34,BGPN35,BGPN36,BGPN37,BGPN38)=0

 +4        IF BGPAGEB>64

               IF BGPACTUP

                   SET BGPD3=1

 +5        IF BGPDMD2

               SET BGPD2=1

 +6        IF BGPAGEB>64

               IF BGPACTCL

                   SET BGPD1=1

 +7        IF BGPAGEB>17

               IF BGPAGEB<65

                   IF BGPACTCL

                       IF $$HIGHRP^BGP5D3A(DFN,BGPEDATE)

                           SET BGPD4=1

 +8        IF BGPAGEB>17

               IF BGPAGEB<65

                   IF BGPACTUP

                       IF $$HIGHRP^BGP5D3A(DFN,BGPEDATE)

                           SET BGPD5=1

 +9        IF BGPAGEB>17

               IF BGPAGEB<65

                   IF BGPACTCL

                       SET BGPD6=1

 +10       IF BGPAGEB>17

               IF BGPAGEB<65

                   IF BGPACTUP

                       SET BGPD7=1

 +11       IF BGPAGEB>17

               IF BGPACTCL

                   SET BGPD8=1

 +12       IF BGPAGEB>17

               IF BGPACTUP

                   SET BGPD9=1

 +13       IF BGPAGEB>18

               IF BGPAGEB<60

                   IF BGPACTCL

                       SET BGPD10=1

 +14       IF BGPAGEB>18

               IF BGPAGEB<60

                   IF BGPACTUP

                       SET BGPD11=1

 +15       IF BGPAGEB>59

               IF BGPAGEB<65

                   IF BGPACTCL

                       SET BGPD12=1

 +16       IF BGPAGEB>59

               IF BGPAGEB<65

                   IF BGPACTUP

                       SET BGPD13=1

 +17       IF '(BGPD1+BGPD2+BGPD3+BGPD4+BGPD5+BGPD6+BGPD7+BGPD8+BGPD9+BGPD10+BGPD11+BGPD12+BGPD13)

               SET BGPSTOP=1

               QUIT 

 +18       SET BGPVALUE=""

           SET BGPVALUD=""

           SET BGPPLPNU=""

PN        ;EP - called from elder

 +1       ;set to date of PNEU shot

           SET BGPVALUE=$$PNEU^BGP5D31(DFN,$$DOB^AUPNPAT(DFN),BGPEDATE)

 +2       ; ALL USERS HAD 1 EVER - 

           IF $PIECE(BGPVALUE,U,3)=1!($PIECE(BGPVALUE,U,3)=3)

               SET BGPN1=1

 +3       ;NMI EVER

           IF $PIECE(BGPVALUE,U,3)=3

               SET BGPN3=1

 +4        SET BGPVAL=$$PNEU^BGP5D31(DFN,$$FMADD^XLFDT(BGPEDATE,-(5*365)),BGPEDATE)

 +5       ;HAD IN PAST 5 YEARS SO "UP TO DATE"

           IF $PIECE(BGPVAL,U,3)=1!($PIECE(BGPVAL,U,3)=3)

               SET BGPN4=1

 +6       ;NMI PAST 5 YRS

           IF $PIECE(BGPVAL,U,3)=3

               SET BGPN6=1

 +7       ;65TH DOB DATE

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

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

 +10      ;65+ HAD AFTER 65TH DOB  BGPN4 IS UPTODATE

           SET BGPN7=0

           SET BGPA65=""

           IF BGPAGEB>64

               SET BGPA65=$$PNEU^BGP5D31(DFN,BGPA65BD,BGPEDATE)

               IF $PIECE(BGPA65,U,3)=1!($PIECE(BGPA65,U,3)=3)

                   SET BGPN4=1

                   SET BGPN7=1

 +11      ;anyone under and had 1 ever  ;BGPN4 IS UP TO DATE

           IF BGPAGEB<65

               IF BGPN1

                   SET BGPN4=1

 +12      ;NATIONAL GPRA

 +13       SET BGPN8=0

 +14      ;GPRA DEV UP TO DATE

           IF BGPAGEB<65

               IF BGPN1

                   SET BGPN8=1

 +15      ;IF 65+ HAD ONE IN PAST 5 YEARS OR AFTER AGE 65

           IF BGPAGEB>64

               IF BGPN1

                   IF (BGPN4+BGPN7)

                       SET BGPN8=1

 +16      ;GPRA DEV V15.0

 +17       Begin DoDot:1

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

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

               SET BGPPNA65=""

 +20           IF BGPAGEB>64

                   SET BGPPNA65=$$PNEUD(DFN,BGPA65BD,BGPEDATE)

 +21      ;HAD PNEUMO AFTER 65TH DOB UPTODATE

               IF BGPAGEB>64

                   IF $PIECE(BGPPNA65,U,3)=1!($PIECE(BGPPNA65,U,3)=3)

                       SET BGPN37=1

 +22      ;set to date of PNEU shot EVER

               SET (BGPPNEU,BGPPLPNU)=$$PNEUD(DFN,$$DOB^AUPNPAT(DFN),BGPEDATE)

 +23      ; ALL USERS HAD 1 EVER - 

               IF $PIECE(BGPPNEU,U,3)=1!($PIECE(BGPPNEU,U,3)=3)

                   SET BGPN23=1

 +24      ;NMI

               IF $PIECE(BGPPNEU,U,3)=3

                   SET BGPN24=1

 +25           SET BGPPNEUD=$$PNEUD(DFN,$$FMADD^XLFDT(BGPEDATE,-(5*365)),BGPEDATE)

 +26      ;HAD IN PAST 5 YEARS SO "UP TO DATE"

               IF $PIECE(BGPPNEUD,U,3)=1!($PIECE(BGPPNEUD,U,3)=3)

                   SET BGPN25=1

                   SET BGPN37=1

 +27      ;NMI PAST 5 YRS

               IF $PIECE(BGPPNEUD,U,3)=3

                   SET BGPN26=1

 +28      ;over 65 and had one after 65

               SET BGPN27=0

               SET BGPA65=""

               IF BGPAGEB>64

                   SET BGPA65=$$PNEUD(DFN,BGPA65BD,BGPEDATE)

                   IF $PIECE(BGPA65,U,3)=1!($PIECE(BGPA65,U,3)=3)

                       SET BGPN25=1

                       SET BGPN27=1

 +29      ;anyone under and had 1 ever  ;BGPN4 IS UP TO DATE

               IF BGPAGEB<65

                   IF BGPN23

                       SET BGPN25=1

                       SET BGPN37=1

 +30           IF 'BGPN37

                   SET (BGPPNCON,BGPPLPNU)=$$PNEUCONJ(DFN,BGPBDATE,BGPEDATE)

                   IF $PIECE(BGPPNCON,U,3)=1!($PIECE(BGPPNCON,U,3)=3)

                       SET BGPN36=1

                       SET BGPN37=1

           End DoDot:1

 +31      ;GPRA DEV

 +32       SET BGPN28=0

 +33      ;GPRA DEV UP TO DATE

           IF BGPAGEB<65

               IF BGPN23

                   SET BGPN28=1

 +34      ;IF UNDER 66 HAD 1 EVER, IF OVER 65 HAD ONE IN PAST 5 YEARS OR AFTER AGE 65

           IF BGPAGEB>64

               IF BGPN23

                   IF (BGPN25+BGPN27)

                       SET BGPN28=1

 +35      ;I BGPAGEB>65,BGPN23,(BGPN25+BGPN27+BGPN36) S BGPN37=1  ;IF UNDER 66 HAD 1 EVER, IF OVER 65 HAD ONE IN PAST 5 YEARS OR AFTER AGE 65

 +36       SET BGPDV=""

 +37       IF BGPRTYPE=1

               SET BGPDV=""

               Begin DoDot:1

 +38               IF BGPD1

                       SET BGPDV=BGPDV_$SELECT(BGPDV]"":",AC",1:"AC")

 +39               IF BGPD2

                       SET BGPDV=BGPDV_$SELECT(BGPDV]"":",AD",1:"AD")

 +40               IF BGPN1

                       SET BGPVALH=BGPVALUE

                       SET BGPVALUE=BGPDV_"|||"

                       IF BGPVALH]""

                           SET BGPVALUE=BGPVALUE_"Pneumo: "_$$DATE^BGP5UTL($PIECE(BGPVALH,U,1))_" "_$PIECE(BGPVALH,U,2)_$SELECT(BGPVALH]"":" (ever)",1:"")_" "_$SELECT(BGPN8:" (up-to-date)",1:"")

                           QUIT 

 +41               SET BGPVALUE=BGPDV_"|||"

               End DoDot:1

 +42       IF BGPRTYPE=4

               Begin DoDot:1

 +43               SET BGPDV="UP"

 +44               IF BGPD6!(BGPD1)!(BGPD8)

                       SET BGPDV=BGPDV_$SELECT(BGPDV]"":",AC",1:"AC")

 +45               IF BGPD4!(BGPD5)

                       SET BGPDV=BGPDV_$SELECT(BGPDV]"":",HR",1:"HR")

 +46               IF BGPD2

                       SET BGPDV=BGPDV_$SELECT(BGPDV]"":",AD",1:"AD")

               End DoDot:1

 +47       IF BGPRTYPE=7

               SET BGPDV=$SELECT(BGPD6:"AC",BGPD8:"AC",1:"")

               IF BGPD4

                   SET BGPDV=BGPDV_$SELECT(BGPDV]"":",HR",1:"HR")

               IF BGPD2

                   SET BGPDV=BGPDV_$SELECT(BGPDV]"":",AD",1:"AD")

 +48       Begin DoDot:1

 +49           IF BGPRTYPE'=1

                   SET BGPVALH=BGPVALUE

                   SET BGPVALUE=BGPDV_"|||"

                   IF BGPVALH]""

                       SET BGPVALUE=BGPVALUE_"Pneumo: "_$$DATE^BGP5UTL($PIECE(BGPVALH,U,1))_" "_$PIECE(BGPVALH,U,2)_$SELECT(BGPVALH]"":" (ever)",1:"")_" "_$SELECT(BGPN8:" (up-to-date)",1:"")

 +50           SET BGPVALUD="AC"_"|||"

 +51           IF BGPN23!(BGPN37)

                   SET BGPVALUD=BGPVALUD_"Pneumo: "_$$DATE^BGP5UTL($PIECE(BGPPLPNU,U,1))_" "_$PIECE(BGPPLPNU,U,2)_$SELECT(BGPPLPNU]"":" (ever)",1:"")_" "

 +52      ;_$S((BGPN28!(BGPN37)),'BGPN36:"(up-to-date)",1:"")

               IF BGPN28!(BGPN37&('BGPN36))

                   SET BGPVALUD=BGPVALUD_"(up-to-date)"

           End DoDot:1

TD        ;new tdap and td stuff for v11.1

 +1        SET BGPTDAP=$$DTAP^BGP5D3A(DFN,$$DOB^AUPNPAT(DFN),BGPEDATE)

 +2        IF BGPTDAP

               SET BGPN9=1

 +3        IF $PIECE(BGPTDAP,U,1)=2

               SET BGPN12=1

 +4        SET BGPTD=$$DTAPTD^BGP5D3A(DFN,$$FMADD^XLFDT(BGPEDATE,-(10*365)),BGPEDATE)

 +5        IF BGPTD

               SET BGPN10=1

 +6        IF $PIECE(BGPTD,U,1)=2

               SET BGPN11=1

 +7        IF BGPRTYPE=5

               GOTO TDE

 +8       ;FLU - 14.1

 +9        SET BGPFLU=$$FLU^BGP5D3(DFN,,BGPEDATE)

 +10       IF $PIECE(BGPFLU,U,3)=1!($PIECE(BGPFLU,U,3)=3)

               SET BGPN13=1

 +11       IF $PIECE(BGPFLU,U,3)=3

               SET BGPN14=1

 +12       IF BGPN9

               IF BGPN10

                   IF BGPN13

                       SET BGPN15=1

 +13      ;TD 10 YRS/TDAP EVER

           IF BGPN9

               IF BGPN10

                   SET BGPN30=1

 +14       IF BGPN11!(BGPN12)!(BGPN14)

               SET BGPN16=1

 +15      ;1:1 CONTRA

           IF BGPN11!(BGPN12)

               SET BGPN31=1

 +16       SET BGPZOST=$$IZOSTER(DFN,$$DOB^AUPNPAT(DFN),BGPEDATE)

 +17       IF $PIECE(BGPZOST,U,3)=1!($PIECE(BGPZOST,U,3)=3)

               SET BGPN17=1

 +18       IF $PIECE(BGPZOST,U,3)=3

               SET BGPN18=1

 +19       IF BGPN9

               IF BGPN10

                   IF BGPN13

                       IF BGPN17

                           SET BGPN19=1

 +20      ;1:1:1: TD/TDAP/ZOSTER

           IF BGPN9

               IF BGPN10

                   IF BGPN17

                       SET BGPN32=1

 +21       IF BGPN11!(BGPN12)!(BGPN14)!(BGPN18)

               SET BGPN20=1

 +22      ;1:1:1 TD/TDAP/ZOSTER CONTRA

           IF BGPN11!(BGPN12)!(BGPN18)

               SET BGPN33=1

 +23       IF BGPN9

               IF BGPN10

                   IF BGPN13

                       IF BGPN17

                           IF BGPN8

                               SET BGPN21=1

 +24       IF BGPN9

               IF BGPN10

                   IF BGPN17

                       IF BGPN8

                           SET BGPN34=1

 +25       IF BGPN11!(BGPN12)!(BGPN14)!(BGPN18)!(BGPN3)

               SET BGPN22=1

 +26       IF BGPN11!(BGPN12)!(BGPN18)!(BGPN3)

               SET BGPN35=1

 +27       IF BGPN9

               IF BGPN10

                   IF BGPN13

                       IF BGPN17

                           IF BGPN28

                               SET BGPN29=1

 +28       IF BGPN9