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
IF BGPN10
IF BGPN17
IF BGPN37
SET BGPN38=1
+29 IF BGPTDAP
SET BGPVALUE=BGPVALUE_$SELECT($PIECE(BGPVALUE,"|||",2)]"":"; ",1:"")
SET BGPVALUE=BGPVALUE_"TDAP: "_$PIECE(BGPTDAP,U,2)_" (ever)"
+30 IF BGPTD
SET BGPVALUE=BGPVALUE_$SELECT($PIECE(BGPVALUE,"|||",2)]"":"; ",1:"")
SET BGPVALUE=BGPVALUE_"TDAP/TD: "_$PIECE(BGPTD,U,2)_" (past 10 yrs)"
+31 IF BGPFLU
SET BGPVALUE=BGPVALUE_$SELECT($PIECE(BGPVALUE,"|||",2)]"":"; ",1:"")
SET BGPVALUE=BGPVALUE_"FLU: "_$PIECE(BGPFLU,U,2)_" (past yr)"
+32 IF BGPZOST
SET BGPVALUE=BGPVALUE_$SELECT($PIECE(BGPVALUE,"|||",2)]"":"; ",1:"")
SET BGPVALUE=BGPVALUE_"ZOSTER: "_$PIECE(BGPZOST,U,2)_" (ever)"
+33 IF BGPTDAP
SET BGPVALUD=BGPVALUD_$SELECT($PIECE(BGPVALUD,"|||",2)]"":"; ",1:"")
SET BGPVALUD=BGPVALUD_"TDAP: "_$PIECE(BGPTDAP,U,2)_" (ever)"
+34 IF BGPTD
SET BGPVALUD=BGPVALUD_$SELECT($PIECE(BGPVALUD,"|||",2)]"":"; ",1:"")
SET BGPVALUD=BGPVALUD_"TDAP/TD: "_$PIECE(BGPTD,U,2)_" (past 10 yrs)"
+35 IF BGPFLU
SET BGPVALUD=BGPVALUD_$SELECT($PIECE(BGPVALUD,"|||",2)]"":"; ",1:"")
SET BGPVALUD=BGPVALUD_"FLU: "_$PIECE(BGPFLU,U,2)_" (past yr)"
+36 IF BGPZOST
SET BGPVALUD=BGPVALUD_$SELECT($PIECE(BGPVALUD,"|||",2)]"":"; ",1:"")
SET BGPVALUD=BGPVALUD_"ZOSTER: "_$PIECE(BGPZOST,U,2)_" (ever)"
TDE KILL BGPLPNU,BGPVAL,BGPA65,BGPVALH,BGPTD,BGPTDAP,BGPFLU
+1 QUIT
IZOSTER(P,BDATE,EDATE,FORE) ;EP
+1 NEW BGPLPNU,BGPG,X,E,R,BD,ED,G,%
+2 SET BGPLPNU=""
+3 SET BD=BDATE
+4 SET ED=EDATE
+5 SET EDATE=$$FMTE^XLFDT(EDATE)
+6 SET BDATE=$$FMTE^XLFDT(BDATE)
+7 SET X=P_"^LAST IMM 121;DURING "_BDATE_"-"_EDATE
SET E=$$START1^APCLDF(X,"BGPG(")
+8 IF $DATA(BGPG(1))
IF $PIECE(BGPLPNU,U,1)<$PIECE(BGPG(1),U)
SET BGPLPNU=$PIECE(BGPG(1),U,1)_U_"Imm 121"
+9 SET %=$$CPT^BGP5DU(P,BD,ED,$ORDER(^ATXAX("B","BGP ZOSTER IZ CPTS",0)),5)
+10 IF $PIECE(BGPLPNU,U,1)<$PIECE(%,U,1)
SET BGPLPNU=$PIECE(%,U,1)_U_"CPT "_$PIECE(%,U,2)
+11 SET %=$$TRAN^BGP5DU(P,BD,ED,$ORDER(^ATXAX("B","BGP ZOSTER IZ CPTS",0)),5)
+12 IF $PIECE(BGPLPNU,U,1)<$PIECE(%,U,1)
SET BGPLPNU=$PIECE(%,U,1)_U_"CPT "_$PIECE(%,U,2)
+13 IF BGPLPNU]""
QUIT BGPLPNU_U_1
+14 ;NOW CHECK FOR CONTRAINDICATION (NEW IN 8.0)
+15 FOR BGPZ=121
SET X=$$ANIMCONT^BGP5D31(P,BGPZ,ED)
+16 IF X]""
QUIT X_U_3
+17 ;NMI Refusal
+18 SET G=$$NMIREF^BGP5UTL1(P,9999999.14,$ORDER(^AUTTIMM("C",121,0)),$$DOB^AUPNPAT(P),ED)
+19 IF $PIECE(G,U)=1
QUIT $PIECE(G,U,2)_U_"NMI Refusal"_U_3
+20 SET R=$$CPTREFT^BGP5UTL1(P,$$DOB^AUPNPAT(P),ED,$ORDER(^ATXAX("B","BGP ZOSTER IZ CPTS",0)),"N")
+21 IF R
QUIT $PIECE(R,U,2)_U_"NMI Refusal "_$PIECE(R,U,4)_U_3
+22 QUIT ""
+23 ;
PNEUD(P,BDATE,EDATE,FORE) ;EP
+1 KILL BGPG
+2 SET BGPLPNU=""
+3 SET BD=BDATE
+4 SET ED=EDATE
+5 SET EDATE=$$FMTE^XLFDT(EDATE)
+6 SET BDATE=$$FMTE^XLFDT(BDATE)
+7 SET X=P_"^LAST IMM "_$SELECT($$BI^BGP5D31:33,1:19)_";DURING "_BDATE_"-"_EDATE
SET E=$$START1^APCLDF(X,"BGPG(")
+8 IF $DATA(BGPG(1))
SET BGPLPNU=$PIECE(BGPG(1),U)_U_"Imm 33"
+9 ;S X=P_"^LAST IMM 100;DURING "_BDATE_"-"_EDATE S E=$$START1^APCLDF(X,"BGPG(")
+10 ;I $D(BGPG(1)),$P(BGPLPNU,U,1)<$P(BGPG(1),U) S BGPLPNU=$P(BGPG(1),U,1)_U_"Imm 100"
+11 SET X=P_"^LAST IMM 109;DURING "_BDATE_"-"_EDATE
SET E=$$START1^APCLDF(X,"BGPG(")
+12 IF $DATA(BGPG(1))
IF $PIECE(BGPLPNU,U,1)<$PIECE(BGPG(1),U)
SET BGPLPNU=$PIECE(BGPG(1),U,1)_U_"Imm 109"
+13 ;S X=P_"^LAST IMM 133;DURING "_BDATE_"-"_EDATE S E=$$START1^APCLDF(X,"BGPG(")
+14 ;I $D(BGPG(1)),$P(BGPLPNU,U,1)<$P(BGPG(1),U) S BGPLPNU=$P(BGPG(1),U,1)_U_"Imm 133"
+15 ;S X=P_"^LAST IMM 152;DURING "_BDATE_"-"_EDATE S E=$$START1^APCLDF(X,"BGPG(")
+16 ;I $D(BGPG(1)),$P(BGPLPNU,U,1)<$P(BGPG(1),U) S BGPLPNU=$P(BGPG(1),U,1)_U_"Imm 152"
+17 KILL BGPG
SET %=P_"^LAST DX V03.82;DURING "_BDATE_"-"_EDATE
SET E=$$START1^APCLDF(%,"BGPG(")
+18 IF $DATA(BGPG(1))
IF $PIECE(BGPLPNU,U,1)<$PIECE(BGPG(1),U)
SET BGPLPNU=$PIECE(BGPG(1),U,1)_U_"POV "_$PIECE(BGPG(1),U,2)
+19 SET %=$$CPT^BGP5DU(P,BD,ED,$ORDER(^ATXAX("B","BGP PNEUMO IZ CPT DEV",0)),5)
+20 IF $PIECE(BGPLPNU,U,1)<$PIECE(%,U,1)
SET BGPLPNU=$PIECE(%,U,1)_U_"CPT "_$PIECE(%,U,2)
+21 SET %=$$TRAN^BGP5DU(P,BD,ED,$ORDER(^ATXAX("B","BGP PNEUMO IZ CPT DEV",0)),5)
+22 IF $PIECE(BGPLPNU,U,1)<$PIECE(%,U,1)
SET BGPLPNU=$PIECE(%,U,1)_U_"CPT "_$PIECE(%,U,2)
+23 IF BGPLPNU]""
QUIT BGPLPNU_U_1
+24 ;NOW CHECK FOR CONTRAINDICATION (NEW IN 8.0)
+25 FOR BGPZ=33,109
SET X=$$ANCONT^BGP5D31(P,BGPZ,ED)
IF X]""
QUIT
+26 IF X]""
QUIT X_U_3
+27 ;NMI Refusal
+28 SET G=$$NMIREF^BGP5UTL1(P,9999999.14,$ORDER(^AUTTIMM("C",33,0)),$$DOB^AUPNPAT(P),ED)
+29 IF $PIECE(G,U)=1
QUIT $PIECE(G,U,2)_U_"NMI Refusal"_U_3
+30 ;S G=$$NMIREF^BGP5UTL1(P,9999999.14,$O(^AUTTIMM("C",100,0)),$$DOB^AUPNPAT(P),ED)
+31 ;I $P(G,U)=1 Q $P(G,U,2)_U_"NMI Refusal"_U_3
+32 SET G=$$NMIREF^BGP5UTL1(P,9999999.14,$ORDER(^AUTTIMM("C",109,0)),$$DOB^AUPNPAT(P),ED)
+33 IF $PIECE(G,U)=1
QUIT $PIECE(G,U,2)_U_"NMI Refusal"_U_3
+34 ;S G=$$NMIREF^BGP5UTL1(P,9999999.14,$O(^AUTTIMM("C",133,0)),$$DOB^AUPNPAT(P),ED)
+35 ;I $P(G,U)=1 Q $P(G,U,2)_U_"NMI Refusal"_U_3
+36 SET R=$$CPTREFT^BGP5UTL1(P,$$DOB^AUPNPAT(P),ED,$ORDER(^ATXAX("B","BGP PNEUMO IZ CPT DEV",0)),"N")
+37 IF R
QUIT $PIECE(R,U,2)_U_"NMI Refusal "_$PIECE(R,U,4)_U_3
+38 QUIT ""
+39 ;
PNEUCONJ(P,BDATE,EDATE,FORE) ;EP
+1 KILL BGPG
+2 SET BGPLPNU=""
+3 SET BD=BDATE
+4 SET ED=EDATE
+5 SET EDATE=$$FMTE^XLFDT(EDATE)
+6 SET BDATE=$$FMTE^XLFDT(BDATE)
+7 SET X=P_"^LAST IMM 100;DURING "_BDATE_"-"_EDATE
SET E=$$START1^APCLDF(X,"BGPG(")
+8 IF $DATA(BGPG(1))
IF $PIECE(BGPLPNU,U,1)<$PIECE(BGPG(1),U)
SET BGPLPNU=$PIECE(BGPG(1),U,1)_U_"Imm 100 (conj)"
+9 SET X=P_"^LAST IMM 133;DURING "_BDATE_"-"_EDATE
SET E=$$START1^APCLDF(X,"BGPG(")
+10 IF $DATA(BGPG(1))
IF $PIECE(BGPLPNU,U,1)<$PIECE(BGPG(1),U)
SET BGPLPNU=$PIECE(BGPG(1),U,1)_U_"Imm 133 (conj)"
+11 SET X=P_"^LAST IMM 152;DURING "_BDATE_"-"_EDATE
SET E=$$START1^APCLDF(X,"BGPG(")
+12 IF $DATA(BGPG(1))
IF $PIECE(BGPLPNU,U,1)<$PIECE(BGPG(1),U)
SET BGPLPNU=$PIECE(BGPG(1),U,1)_U_"Imm 152 (conj)"
+13 SET %=$$CPT^BGP5DU(P,BD,ED,$ORDER(^ATXAX("B","BGP PNEUMO CONJUGATE CPTS",0)),5)
+14 IF $PIECE(BGPLPNU,U,1)<$PIECE(%,U,1)
SET BGPLPNU=$PIECE(%,U,1)_U_"CPT "_$PIECE(%,U,2)_" (conj)"
+15 SET %=$$TRAN^BGP5DU(P,BD,ED,$ORDER(^ATXAX("B","BGP PNEUMO CONJUGATE CPTS",0)),5)
+16 IF $PIECE(BGPLPNU,U,1)<$PIECE(%,U,1)
SET BGPLPNU=$PIECE(%,U,1)_U_"CPT "_$PIECE(%,U,2)_" (conj)"
+17 IF BGPLPNU]""
QUIT BGPLPNU_U_1
+18 ;NOW CHECK FOR CONTRAINDICATION (NEW IN 8.0)
+19 FOR BGPZ=100,133,152
SET X=$$ANCONT^BGP5D31(P,BGPZ,ED)
IF X]""
QUIT
+20 IF X]""
QUIT X_U_3
+21 ;NMI Refusal
+22 SET G=$$NMIREF^BGP5UTL1(P,9999999.14,$ORDER(^AUTTIMM("C",100,0)),$$DOB^AUPNPAT(P),ED)
+23 IF $PIECE(G,U)=1
QUIT $PIECE(G,U,2)_U_"NMI Refusal"_U_3
+24 SET G=$$NMIREF^BGP5UTL1(P,9999999.14,$ORDER(^AUTTIMM("C",133,0)),$$DOB^AUPNPAT(P),ED)
+25 IF $PIECE(G,U)=1
QUIT $PIECE(G,U,2)_U_"NMI Refusal"_U_3
+26 SET G=$$NMIREF^BGP5UTL1(P,9999999.14,$ORDER(^AUTTIMM("C",152,0)),$$DOB^AUPNPAT(P),ED)
+27 IF $PIECE(G,U)=1
QUIT $PIECE(G,U,2)_U_"NMI Refusal"_U_3
+28 SET R=$$CPTREFT^BGP5UTL1(P,$$DOB^AUPNPAT(P),ED,$ORDER(^ATXAX("B","BGP PNEUMO CONJUGATE CPTS",0)),"N")
+29 IF R
QUIT $PIECE(R,U,2)_U_"NMI Refusal "_$PIECE(R,U,4)_U_3
+30 QUIT ""
OPTOM ;
+1 SET (BGPD1,BGPN1)=0
+2 ;must be active clinical
IF 'BGPACTCL
SET BGPSTOP=1
QUIT
+3 ;18 and older only
IF BGPAGEB<18
SET BGPSTOP=1
QUIT
+4 ;MUST HAVE HAD GLAUCOMA DX EVER BEFORE END OF TIME PERIOD
IF '$$GLAUCOMA(DFN,BGPBDATE,BGPEDATE)
SET BGPSTOP=1
QUIT
+5 SET BGPD1=1
+6 SET %=$$CPT^BGP5DU(DFN,BGPBDATE,BGPEDATE,$ORDER(^ATXAX("B","BGP OPTIC NERVE HEAD EVAL CPT",0)),6)
+7 ;S %="",E=+$$CODEN^ICPTCOD("2027F"),%=$$CPTI^BGP5DU(DFN,BGPBDATE,BGPEDATE,E)
+8 IF %
SET BGPN1=1
+9 SET BGPVALUE="AC|||"_$$DATE^BGP5UTL($PIECE(%,U,2))_" "_$PIECE(%,U,3)
+10 QUIT
GLAUCOMA(P,BDATE,EDATE) ;EP
+1 QUIT $$LASTDX^BGP5UTL1(P,"BGP OPEN ANGLE GLAUCOMA DXS",BDATE,EDATE)
