BGP6D3B ; IHS/CMI/LAB - PNEUMO REMINDER 27 Feb 2015 7:52 AM ;
;;16.1;IHS CLINICAL REPORTING;;MAR 22, 2016;Build 170
;
I13 ;EP - PN
NEW BGPTDAP,BGPTD,BGPFLU,BGPZOST,BGPPNEU,BGPPNEUD,BGPDTAPP
F X=1:1:15 S Y="BGPD"_X S @Y=""
F X=1:1:45 S Y="BGPN"_X S @Y=""
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^BGP6D3A(DFN,BGPEDATE) S BGPD4=1
I BGPAGEB>17,BGPAGEB<65,BGPACTUP,$$HIGHRP^BGP6D3A(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 BGPSEX="F" S X=$$PREG(DFN,BGPBDATE,BGPEDATE) I X S BGPD14=1 ;v16 pregnant women
I '(BGPD1+BGPD2+BGPD3+BGPD4+BGPD5+BGPD6+BGPD7+BGPD8+BGPD9+BGPD10+BGPD11+BGPD12+BGPD13+BGPD14) S BGPSTOP=1 Q
S BGPVALUE="",BGPVALUD="",BGPPLPNU="",BGPDTAPP="",BGPTDAP=""
PN ;EP - called from elder
S BGPVALUE=$$PNEU^BGP6D31(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^BGP6D31(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^BGP6D31(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,BGPN28=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,BGPN37=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
;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 BGPN28 S BGPN37=1
I 'BGPN37 S BGPPLPNU=$$PNEUCONJ(DFN,BGPBDATE,BGPEDATE) I $P(BGPPLPNU,U,3)=1!($P(BGPPLPNU,U,3)=3) S BGPN36=1,BGPN37=1
I BGPPLPNU="" S BGPPLPNU=BGPPNEU
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^BGP6UTL($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^BGP6UTL($P(BGPVALH,U,1))_" "_$P(BGPVALH,U,2)_$S(BGPVALH]"":" (ever)",1:"")_" "_$S(BGPN8:" (up-to-date)",1:"")
.S BGPVALUD="AC"_"|||"
.I BGPN28!(BGPN37) S BGPVALUD=BGPVALUD_"Pneumo: "_$$DATE^BGP6UTL($P(BGPPLPNU,U,1))_" "_$P(BGPPLPNU,U,2)_$S(BGPPLPNU]"":" (ever)",1:"")_" "
.I BGPN28 S BGPVALUD=BGPVALUD_"(up-to-date)" ;_$S((BGPN28!(BGPN37)),'BGPN36:"(up-to-date)",1:"")
.I BGPN36 S BGPVALUD=BGPVALUD_" (conj)"
TD ;new tdap and td stuff for v11.1
S BGPTDAP=$$DTAP^BGP6D3A(DFN,$$DOB^AUPNPAT(DFN),BGPEDATE)
I BGPTDAP S BGPN9=1
I $P(BGPTDAP,U,1)=2 S BGPN12=1
S BGPTD=$$DTAPTD^BGP6D3A(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^BGP6D3(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,BGPN37 S BGPN29=1
I BGPN9,BGPN10,BGPN17,BGPN37 S BGPN38=1
;NEW FOR V16.0
S BGPTRIM=""
I BGPD14 D
.S BGPVALUD="AC;PREG|||"_$P(BGPVALUD,"|||",2)
.S BGPFPRDX=$$FIRSTPDX^BGP6D3C(DFN,$$FMADD^XLFDT(BGPEDATE,-608),BGPEDATE)
.;GET EDD
.S BGPEDD=$$EDD^BGP6UTL2(DFN,BGPBDATE,BGPEDATE)
.K BGPTDAPP
.S D=BGPEDATE
.I BGPEDD]"",BGPEDD<BGPEDATE S D=BGPEDD
.S BGPTDAPP=$$LASTTDAP(DFN,BGPFPRDX,D)
.I $E(BGPTDAPP) S BGPN39=1 ;A SHOT OR AN NMI
.I $E(BGPTDAPP)=2 S BGPN40=1 ;NMI
.I 'BGPN39 Q
.;FIGURE OUT TRIMESTER
.I BGPEDD D Q
..;FIGURE OUT TRIMESTER FOR ALL TDAPS, IF ANY ARE 3RD USE IT, THEN DO 2ND, THEN DO 1ST
..;FIRST DAY OF PREG IS 280 DAYS BEFORE EDD
..NEW FB,FE,SB,SE,TB,TE
..S G=""
..S TB=$$FMADD^XLFDT(BGPEDD,-91)
..S TE=BGPEDD
..S SB=$$FMADD^XLFDT(BGPEDD,-182)
..S SE=$$FMADD^XLFDT(TB,-1)
..S FB=$$FMADD^XLFDT(BGPEDD,-280)
..S FE=$$FMADD^XLFDT(SB,-1)
..S X=$P(BGPTDAPP,U,2)
..I X'<TB,X'>TE S G=G_3
..I X'>SE,X'<SB S G=G_2
..I X>FB S G=G_1
..I G[3 S BGPN43=1,BGPTRIM="3rd Trimester" Q
..I G[2 S BGPN42=1,BGPTRIM="2nd Trimester" Q
..I G[1 S BGPN41=1,BGPTRIM="1st Trimester" Q
..I G="" S BGPN44=1,BGPTRIM="unk Trimester"
.I BGPEDD="" D ;try to find icd codes
..S X=$P(BGPTDAPP,U,2) D
...;get all dxs tri, sec, 1st
...S G=""
...S Y=$$LASTDX^BGP6UTL1(DFN,"BGP PREGNANCY TRI 3 DXS",$$FMADD^XLFDT(X,-7),$$FMADD^XLFDT(X,7))
...I Y S G=G_3
...S Y=$$LASTDX^BGP6UTL1(DFN,"BGP PREGNANCY TRI 2 DXS",$$FMADD^XLFDT(X,-7),$$FMADD^XLFDT(X,7))
...I Y S G=G_2
...S Y=$$LASTDX^BGP6UTL1(DFN,"BGP PREGNANCY TRI 1 DXS",$$FMADD^XLFDT(X,-7),$$FMADD^XLFDT(X,7))
...I Y S G=G_1
..I G[3 S BGPN43=1,BGPTRIM="3rd Trimester" Q
..I G[2 S BGPN42=1,BGPTRIM="2nd Trimester" Q
..I G[1 S BGPN41=1,BGPTRIM="1st Trimester" Q
..I G="" S BGPN44=1,BGPTRIM="unk Trimester"
N ;
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: "_$S($P(BGPDTAPP,U,3)]"":$P(BGPDTAPP,U,3),1:$P(BGPTDAP,U,2))_" (ever) "_$S(BGPTRIM]"":"("_BGPTRIM_")",1:"")
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,BGPTDAPP,BGPPNCON
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^BGP6DU(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^BGP6DU(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^BGP6D31(P,BGPZ,ED)
I X]"" Q X_U_3
;NMI Refusal
S G=$$NMIREF^BGP6UTL1(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^BGP6UTL1(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^BGP6D31: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 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"
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^BGP6DU(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^BGP6DU(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^BGP6D31(P,BGPZ,ED) Q:X]""
I X]"" Q X_U_3
;NMI Refusal
S G=$$NMIREF^BGP6UTL1(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^BGP6UTL1(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 R=$$CPTREFT^BGP6UTL1(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"
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"
S %=$$CPT^BGP6DU(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)_""
S %=$$TRAN^BGP6DU(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)_""
I BGPLPNU]"" Q BGPLPNU_U_1
;NOW CHECK FOR CONTRAINDICATION (NEW IN 8.0)
F BGPZ=100,133,152 S X=$$ANCONT^BGP6D31(P,BGPZ,ED) Q:X]""
I X]"" Q X_U_3
;NMI Refusal
S G=$$NMIREF^BGP6UTL1(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^BGP6UTL1(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^BGP6UTL1(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^BGP6UTL1(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
I BGPAGEB<18 S BGPSTOP=1 Q
I '$$GLAUCOMA(DFN,BGPBDATE,BGPEDATE) S BGPSTOP=1 Q
S BGPD1=1
S %=$$CPT^BGP6DU(DFN,BGPBDATE,BGPEDATE,$O(^ATXAX("B","BGP OPTIC NERVE HEAD EVAL CPT",0)),6)
I % S BGPN1=1
S BGPVALUE="AC|||"_$$DATE^BGP6UTL($P(%,U,2))_" "_$P(%,U,3)
Q
GLAUCOMA(P,BDATE,EDATE) ;EP
Q $$LASTDX^BGP6UTL1(P,"BGP OPEN ANGLE GLAUCOMA DXS",BDATE,EDATE)
LASTTDAP(P,BDATE,EDATE) ;EP
NEW C,D,BGPX,X,Y,G,B,R,ID,BGPZ
S BGPX=""
S C=$O(^AUTTIMM("C",115,0))
S D=0 F S D=$O(^AUPNVIMM("AA",P,C,D)) Q:D'=+D!(BGPX) D
.S X=0 F S X=$O(^AUPNVIMM("AA",P,C,D,X)) Q:X'=+X D
..S ID=$P($P($G(^AUPNVIMM(X,12)),U),".")
..I ID="" Q:$P(^AUPNVIMM(X,0),U,3)=""
..I ID="" S ID=$$VD^APCLV($P(^AUPNVIMM(X,0),U,3))
..Q:ID<BDATE
..Q:ID>EDATE
..S BGPX=ID_U_$$DATE^BGP6UTL(ID)_" Imm 115"
.Q
;now add in cpt codes if on different dates
S C=+$$CODEN^ICPTCOD(90715)
S D=$$CPTI^BGP6DU(P,BDATE,EDATE,C)
I $P(D,U,2)>$P(BGPX,U,1) S BGPX=$P(D,U,2)_U_$$DATE^BGP6UTL(D)_" CPT 90715"
I BGPX Q 1_U_BGPX
;now check contra/nmi
F BGPZ=115 S X=$$ANCONT^BGP6D31(P,BGPZ,EDATE)
I X]"" S BGPX=2_U_$P(X,U,1)_U_$$DATE^BGP6UTL($P(X,U,1))_" "_$P(X,U,2) Q BGPX
;now go to Refusals
S B=$$DOB^AUPNPAT(P),E=EDATE,BGPNMI="",R=""
F BGPIMM=115 D
.S I=$O(^AUTTIMM("C",BGPIMM,0)) Q:'I
.S X=0 F S X=$O(^AUPNPREF("AA",P,9999999.14,I,X)) Q:X'=+X S Y=0 F S Y=$O(^AUPNPREF("AA",P,9999999.14,I,X,Y)) Q:Y'=+Y S D=$P(^AUPNPREF(Y,0),U,3) I D'<B&(D'>E) D
..Q:$P(^AUPNPREF(Y,0),U,7)'="N"
..S R=D
I R S BGPX=2_U_R_U_$$DATE^BGP6UTL(R)_" "_"NMI Dtap" Q BGPX
S R="",B=+$$CODEN^ICPTCOD(90715)
S G=$$NMIREF^BGP6UTL1(P,81,B,$$DOB^AUPNPAT(P),EDATE)
I G S BGPX=2_U_$P(G,U,2)_U_$$DATE^BGP6UTL($P(G,U,2))_" "_"NMI Dtap 90715" Q G
Q ""
PREG(P,BDATE,EDATE) ;
I '$$PREG^BGP6D7(DFN,$$FMADD^XLFDT(EDATE,-608),EDATE,1,1) Q ""
Q 1
BGP6D3B ; IHS/CMI/LAB - PNEUMO REMINDER 27 Feb 2015 7:52 AM ;
+1 ;;16.1;IHS CLINICAL REPORTING;;MAR 22, 2016;Build 170
+2 ;
I13 ;EP - PN
+1 NEW BGPTDAP,BGPTD,BGPFLU,BGPZOST,BGPPNEU,BGPPNEUD,BGPDTAPP
+2 FOR X=1:1:15
SET Y="BGPD"_X
SET @Y=""
+3 FOR X=1:1:45
SET Y="BGPN"_X
SET @Y=""
+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^BGP6D3A(DFN,BGPEDATE)
SET BGPD4=1
+8 IF BGPAGEB>17
IF BGPAGEB<65
IF BGPACTUP
IF $$HIGHRP^BGP6D3A(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 ;v16 pregnant women
IF BGPSEX="F"
SET X=$$PREG(DFN,BGPBDATE,BGPEDATE)
IF X
SET BGPD14=1
+18 IF '(BGPD1+BGPD2+BGPD3+BGPD4+BGPD5+BGPD6+BGPD7+BGPD8+BGPD9+BGPD10+BGPD11+BGPD12+BGPD13+BGPD14)
SET BGPSTOP=1
QUIT
+19 SET BGPVALUE=""
SET BGPVALUD=""
SET BGPPLPNU=""
SET BGPDTAPP=""
SET BGPTDAP=""
PN ;EP - called from elder
+1 ;set to date of PNEU shot
SET BGPVALUE=$$PNEU^BGP6D31(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^BGP6D31(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^BGP6D31(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 ;I BGPAGEB>64 S BGPPNA65=$$PNEUD(DFN,BGPA65BD,BGPEDATE)
+21 ;I BGPAGEB>64 I $P(BGPPNA65,U,3)=1!($P(BGPPNA65,U,3)=3) S BGPN37=1,BGPN28=1 ;HAD PNEUMO AFTER 65TH DOB UPTODATE
+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
SET BGPN37=1
+29 ;anyone under and had 1 ever ;BGPN4 IS UP TO DATE
IF BGPAGEB<65
IF BGPN23
SET BGPN25=1
SET BGPN37=1
End DoDot:1
+30 ;GPRA DEV
+31 SET BGPN28=0
+32 ;GPRA DEV UP TO DATE
IF BGPAGEB<65
IF BGPN23
SET BGPN28=1
+33 ;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
+34 IF BGPN28
SET BGPN37=1
+35 IF 'BGPN37
SET BGPPLPNU=$$PNEUCONJ(DFN,BGPBDATE,BGPEDATE)
IF $PIECE(BGPPLPNU,U,3)=1!($PIECE(BGPPLPNU,U,3)=3)
SET BGPN36=1
SET BGPN37=1
+36 IF BGPPLPNU=""
SET BGPPLPNU=BGPPNEU
+37 SET BGPDV=""
+38 IF BGPRTYPE=1
SET BGPDV=""
Begin DoDot:1
+39 IF BGPD1
SET BGPDV=BGPDV_$SELECT(BGPDV]"":",AC",1:"AC")
+40 IF BGPD2
SET BGPDV=BGPDV_$SELECT(BGPDV]"":",AD",1:"AD")
+41 IF BGPN1
SET BGPVALH=BGPVALUE
SET BGPVALUE=BGPDV_"|||"
IF BGPVALH]""
SET BGPVALUE=BGPVALUE_"Pneumo: "_$$DATE^BGP6UTL($PIECE(BGPVALH,U,1))_" "_$PIECE(BGPVALH,U,2)_$SELECT(BGPVALH]"":" (ever)",1:"")_" "_$SELECT(BGPN8:" (up-to-date)",1:"")
QUIT
+42 SET BGPVALUE=BGPDV_"|||"
End DoDot:1
+43 IF BGPRTYPE=4
Begin DoDot:1
+44 SET BGPDV="UP"
+45 IF BGPD6!(BGPD1)!(BGPD8)
SET BGPDV=BGPDV_$SELECT(BGPDV]"":",AC",1:"AC")
+46 IF BGPD4!(BGPD5)
SET BGPDV=BGPDV_$SELECT(BGPDV]"":",HR",1:"HR")
+47 IF BGPD2
SET BGPDV=BGPDV_$SELECT(BGPDV]"":",AD",1:"AD")
End DoDot:1
+48 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")
+49 Begin DoDot:1
+50 IF BGPRTYPE'=1
SET BGPVALH=BGPVALUE
SET BGPVALUE=BGPDV_"|||"
IF BGPVALH]""
SET BGPVALUE=BGPVALUE_"Pneumo: "_$$DATE^BGP6UTL($PIECE(BGPVALH,U,1))_" "_$PIECE(BGPVALH,U,2)_$SELECT(BGPVALH]"":" (ever)",1:"")_" "_$SELECT(BGPN8:" (up-to-date)",1:"")
+51 SET BGPVALUD="AC"_"|||"
+52 IF BGPN28!(BGPN37)
SET BGPVALUD=BGPVALUD_"Pneumo: "_$$DATE^BGP6UTL($PIECE(BGPPLPNU,U,1))_" "_$PIECE(BGPPLPNU,U,2)_$SELECT(BGPPLPNU]"":" (ever)",1:"")_" "
+53 ;_$S((BGPN28!(BGPN37)),'BGPN36:"(up-to-date)",1:"")
IF BGPN28
SET BGPVALUD=BGPVALUD_"(up-to-date)"
+54 IF BGPN36
SET BGPVALUD=BGPVALUD_" (conj)"
End DoDot:1
TD ;new tdap and td stuff for v11.1
+1 SET BGPTDAP=$$DTAP^BGP6D3A(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^BGP6D3A(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^BGP6D3(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 BGPN37
SET BGPN29=1
+28 IF BGPN9
IF BGPN10
IF BGPN17
IF BGPN37
SET BGPN38=1
+29 ;NEW FOR V16.0
+30 SET BGPTRIM=""
+31 IF BGPD14
Begin DoDot:1
+32 SET BGPVALUD="AC;PREG|||"_$PIECE(BGPVALUD,"|||",2)
+33 SET BGPFPRDX=$$FIRSTPDX^BGP6D3C(DFN,$$FMADD^XLFDT(BGPEDATE,-608),BGPEDATE)
+34 ;GET EDD
+35 SET BGPEDD=$$EDD^BGP6UTL2(DFN,BGPBDATE,BGPEDATE)
+36 KILL BGPTDAPP
+37 SET D=BGPEDATE
+38 IF BGPEDD]""
IF BGPEDD<BGPEDATE
SET D=BGPEDD
+39 SET BGPTDAPP=$$LASTTDAP(DFN,BGPFPRDX,D)
+40 ;A SHOT OR AN NMI
IF $EXTRACT(BGPTDAPP)
SET BGPN39=1
+41 ;NMI
IF $EXTRACT(BGPTDAPP)=2
SET BGPN40=1
+42 IF 'BGPN39
QUIT
+43 ;FIGURE OUT TRIMESTER
+44 IF BGPEDD
Begin DoDot:2
+45 ;FIGURE OUT TRIMESTER FOR ALL TDAPS, IF ANY ARE 3RD USE IT, THEN DO 2ND, THEN DO 1ST
+46 ;FIRST DAY OF PREG IS 280 DAYS BEFORE EDD
+47 NEW FB,FE,SB,SE,TB,TE
+48 SET G=""
+49 SET TB=$$FMADD^XLFDT(BGPEDD,-91)
+50 SET TE=BGPEDD
+51 SET SB=$$FMADD^XLFDT(BGPEDD,-182)
+52 SET SE=$$FMADD^XLFDT(TB,-1)
+53 SET FB=$$FMADD^XLFDT(BGPEDD,-280)
+54 SET FE=$$FMADD^XLFDT(SB,-1)
+55 SET X=$PIECE(BGPTDAPP,U,2)
+56 IF X'<TB
IF X'>TE
SET G=G_3
+57 IF X'>SE
IF X'<SB
SET G=G_2
+58 IF X>FB
SET G=G_1
+59 IF G[3
SET BGPN43=1
SET BGPTRIM="3rd Trimester"
QUIT
+60 IF G[2
SET BGPN42=1
SET BGPTRIM="2nd Trimester"
QUIT
+61 IF G[1
SET BGPN41=1
SET BGPTRIM="1st Trimester"
QUIT
+62 IF G=""
SET BGPN44=1
SET BGPTRIM="unk Trimester"
End DoDot:2
QUIT
+63 ;try to find icd codes
IF BGPEDD=""
Begin DoDot:2
+64 SET X=$PIECE(BGPTDAPP,U,2)
Begin DoDot:3
+65 ;get all dxs tri, sec, 1st
+66 SET G=""
+67 SET Y=$$LASTDX^BGP6UTL1(DFN,"BGP PREGNANCY TRI 3 DXS",$$FMADD^XLFDT(X,-7),$$FMADD^XLFDT(X,7))
+68 IF Y
SET G=G_3
+69 SET Y=$$LASTDX^BGP6UTL1(DFN,"BGP PREGNANCY TRI 2 DXS",$$FMADD^XLFDT(X,-7),$$FMADD^XLFDT(X,7))
+70 IF Y
SET G=G_2
+71 SET Y=$$LASTDX^BGP6UTL1(DFN,"BGP PREGNANCY TRI 1 DXS",$$FMADD^XLFDT(X,-7),$$FMADD^XLFDT(X,7))
+72 IF Y
SET G=G_1
End DoDot:3
+73 IF G[3
SET BGPN43=1
SET BGPTRIM="3rd Trimester"
QUIT
+74 IF G[2
SET BGPN42=1
SET BGPTRIM="2nd Trimester"
QUIT
+75 IF G[1
SET BGPN41=1
SET BGPTRIM="1st Trimester"
QUIT
+76 IF G=""
SET BGPN44=1
SET BGPTRIM="unk Trimester"
End DoDot:2
End DoDot:1
N ;
+1 IF BGPTDAP
SET BGPVALUE=BGPVALUE_$SELECT($PIECE(BGPVALUE,"|||",2)]"":"; ",1:"")
SET BGPVALUE=BGPVALUE_"TDAP: "_$PIECE(BGPTDAP,U,2)_" (ever)"
+2 IF BGPTD
SET BGPVALUE=BGPVALUE_$SELECT($PIECE(BGPVALUE,"|||",2)]"":"; ",1:"")
SET BGPVALUE=BGPVALUE_"TDAP/TD: "_$PIECE(BGPTD,U,2)_" (past 10 yrs)"
+3 IF BGPFLU
SET BGPVALUE=BGPVALUE_$SELECT($PIECE(BGPVALUE,"|||",2)]"":"; ",1:"")
SET BGPVALUE=BGPVALUE_"FLU: "_$PIECE(BGPFLU,U,2)_" (past yr)"
+4 IF BGPZOST
SET BGPVALUE=BGPVALUE_$SELECT($PIECE(BGPVALUE,"|||",2)]"":"; ",1:"")
SET BGPVALUE=BGPVALUE_"ZOSTER: "_$PIECE(BGPZOST,U,2)_" (ever)"
+5 IF BGPTDAP
SET BGPVALUD=BGPVALUD_$SELECT($PIECE(BGPVALUD,"|||",2)]"":"; ",1:"")
SET BGPVALUD=BGPVALUD_"TDAP: "_$SELECT($PIECE(BGPDTAPP,U,3)]"":$PIECE(BGPDTAPP,U,3),1:$PIECE(BGPTDAP,U,2))_" (ever) "_$SELECT(BGPTRIM]"":"("_BGPTRIM_")",1:"")
+6 IF BGPTD
SET BGPVALUD=BGPVALUD_$SELECT($PIECE(BGPVALUD,"|||",2)]"":"; ",1:"")
SET BGPVALUD=BGPVALUD_"TDAP/TD: "_$PIECE(BGPTD,U,2)_" (past 10 yrs)"
+7 IF BGPFLU
SET BGPVALUD=BGPVALUD_$SELECT($PIECE(BGPVALUD,"|||",2)]"":"; ",1:"")
SET BGPVALUD=BGPVALUD_"FLU: "_$PIECE(BGPFLU,U,2)_" (past yr)"
+8 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,BGPTDAPP,BGPPNCON
+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^BGP6DU(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^BGP6DU(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^BGP6D31(P,BGPZ,ED)
+16 IF X]""
QUIT X_U_3
+17 ;NMI Refusal
+18 SET G=$$NMIREF^BGP6UTL1(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^BGP6UTL1(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^BGP6D31: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 SET X=P_"^LAST IMM 109;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 109"
+11 KILL BGPG
SET %=P_"^LAST DX V03.82;DURING "_BDATE_"-"_EDATE
SET E=$$START1^APCLDF(%,"BGPG(")
+12 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)
+13 SET %=$$CPT^BGP6DU(P,BD,ED,$ORDER(^ATXAX("B","BGP PNEUMO IZ CPT DEV",0)),5)
+14 IF $PIECE(BGPLPNU,U,1)<$PIECE(%,U,1)
SET BGPLPNU=$PIECE(%,U,1)_U_"CPT "_$PIECE(%,U,2)
+15 SET %=$$TRAN^BGP6DU(P,BD,ED,$ORDER(^ATXAX("B","BGP PNEUMO IZ CPT DEV",0)),5)
+16 IF $PIECE(BGPLPNU,U,1)<$PIECE(%,U,1)
SET BGPLPNU=$PIECE(%,U,1)_U_"CPT "_$PIECE(%,U,2)
+17 IF BGPLPNU]""
QUIT BGPLPNU_U_1
+18 ;NOW CHECK FOR CONTRAINDICATION (NEW IN 8.0)
+19 FOR BGPZ=33,109
SET X=$$ANCONT^BGP6D31(P,BGPZ,ED)
IF X]""
QUIT
+20 IF X]""
QUIT X_U_3
+21 ;NMI Refusal
+22 SET G=$$NMIREF^BGP6UTL1(P,9999999.14,$ORDER(^AUTTIMM("C",33,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^BGP6UTL1(P,9999999.14,$ORDER(^AUTTIMM("C",109,0)),$$DOB^AUPNPAT(P),ED)
+25 IF $PIECE(G,U)=1
QUIT $PIECE(G,U,2)_U_"NMI Refusal"_U_3
+26 SET R=$$CPTREFT^BGP6UTL1(P,$$DOB^AUPNPAT(P),ED,$ORDER(^ATXAX("B","BGP PNEUMO IZ CPT DEV",0)),"N")
+27 IF R
QUIT $PIECE(R,U,2)_U_"NMI Refusal "_$PIECE(R,U,4)_U_3
+28 QUIT ""
+29 ;
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"
+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"
+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"
+13 SET %=$$CPT^BGP6DU(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)_""
+15 SET %=$$TRAN^BGP6DU(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)_""
+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^BGP6D31(P,BGPZ,ED)
IF X]""
QUIT
+20 IF X]""
QUIT X_U_3
+21 ;NMI Refusal
+22 SET G=$$NMIREF^BGP6UTL1(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^BGP6UTL1(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^BGP6UTL1(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^BGP6UTL1(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 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^BGP6DU(DFN,BGPBDATE,BGPEDATE,$ORDER(^ATXAX("B","BGP OPTIC NERVE HEAD EVAL CPT",0)),6)
+7 IF %
SET BGPN1=1
+8 SET BGPVALUE="AC|||"_$$DATE^BGP6UTL($PIECE(%,U,2))_" "_$PIECE(%,U,3)
+9 QUIT
GLAUCOMA(P,BDATE,EDATE) ;EP
+1 QUIT $$LASTDX^BGP6UTL1(P,"BGP OPEN ANGLE GLAUCOMA DXS",BDATE,EDATE)
LASTTDAP(P,BDATE,EDATE) ;EP
+1 NEW C,D,BGPX,X,Y,G,B,R,ID,BGPZ
+2 SET BGPX=""
+3 SET C=$ORDER(^AUTTIMM("C",115,0))
+4 SET D=0
FOR
SET D=$ORDER(^AUPNVIMM("AA",P,C,D))
IF D'=+D!(BGPX)
QUIT
Begin DoDot:1
+5 SET X=0
FOR
SET X=$ORDER(^AUPNVIMM("AA",P,C,D,X))
IF X'=+X
QUIT
Begin DoDot:2
+6 SET ID=$PIECE($PIECE($GET(^AUPNVIMM(X,12)),U),".")
+7 IF ID=""
IF $PIECE(^AUPNVIMM(X,0),U,3)=""
QUIT
+8 IF ID=""
SET ID=$$VD^APCLV($PIECE(^AUPNVIMM(X,0),U,3))
+9 IF ID<BDATE
QUIT
+10 IF ID>EDATE
QUIT
+11 SET BGPX=ID_U_$$DATE^BGP6UTL(ID)_" Imm 115"
End DoDot:2
+12 QUIT
End DoDot:1
+13 ;now add in cpt codes if on different dates
+14 SET C=+$$CODEN^ICPTCOD(90715)
+15 SET D=$$CPTI^BGP6DU(P,BDATE,EDATE,C)
+16 IF $PIECE(D,U,2)>$PIECE(BGPX,U,1)
SET BGPX=$PIECE(D,U,2)_U_$$DATE^BGP6UTL(D)_" CPT 90715"
+17 IF BGPX
QUIT 1_U_BGPX
+18 ;now check contra/nmi
+19 FOR BGPZ=115
SET X=$$ANCONT^BGP6D31(P,BGPZ,EDATE)
+20 IF X]""
SET BGPX=2_U_$PIECE(X,U,1)_U_$$DATE^BGP6UTL($PIECE(X,U,1))_" "_$PIECE(X,U,2)
QUIT BGPX
+21 ;now go to Refusals
+22 SET B=$$DOB^AUPNPAT(P)
SET E=EDATE
SET BGPNMI=""
SET R=""
+23 FOR BGPIMM=115
Begin DoDot:1
+24 SET I=$ORDER(^AUTTIMM("C",BGPIMM,0))
IF 'I
QUIT
+25 SET X=0
FOR
SET X=$ORDER(^AUPNPREF("AA",P,9999999.14,I,X))
IF X'=+X
QUIT
SET Y=0
FOR
SET Y=$ORDER(^AUPNPREF("AA",P,9999999.14,I,X,Y))
IF Y'=+Y
QUIT
SET D=$PIECE(^AUPNPREF(Y,0),U,3)
IF D'<B&(D'>E)
Begin DoDot:2
+26 IF $PIECE(^AUPNPREF(Y,0),U,7)'="N"
QUIT
+27 SET R=D
End DoDot:2
End DoDot:1
+28 IF R
SET BGPX=2_U_R_U_$$DATE^BGP6UTL(R)_" "_"NMI Dtap"
QUIT BGPX
+29 SET R=""
SET B=+$$CODEN^ICPTCOD(90715)
+30 SET G=$$NMIREF^BGP6UTL1(P,81,B,$$DOB^AUPNPAT(P),EDATE)
+31 IF G
SET BGPX=2_U_$PIECE(G,U,2)_U_$$DATE^BGP6UTL($PIECE(G,U,2))_" "_"NMI Dtap 90715"
QUIT G
+32 QUIT ""
PREG(P,BDATE,EDATE) ;
+1 IF '$$PREG^BGP6D7(DFN,$$FMADD^XLFDT(EDATE,-608),EDATE,1,1)
QUIT ""
+2 QUIT 1
