BGP8D3B ; IHS/CMI/LAB - PNEUMO REMINDER 27 Feb 2015 7:52 AM ;
;;18.1;IHS CLINICAL REPORTING;;MAY 25, 2018;Build 66
;
I13 ;EP - PN
NEW BGPTDAP,BGPTD,BGPFLU,BGPZOST,BGPPNEU,BGPPNEUD,BGPDTAPP,BGPPPSEV,BGPPCVEV,BGPPP65,BGPPC65,BGPPP5Y,BGPPC5Y,BGPPC1Y,BGPPC19,BGPPP1Y
S (BGPPNCON,BGPPPSEV,BGPPCVEV,BGPPP65,BGPPC65,BGPPP5Y,BGPPC5Y,BGPPC1Y,BGPPC19,BGPPP1Y,BGPPPCON,BGPPCCON)=""
F X=1:1:17 S Y="BGPD"_X S @Y=""
F X=1:1:55 S Y="BGPN"_X S @Y=""
I BGPAGEB>64,BGPACTUP S BGPD3=1 ;UP 65+
I BGPDMD2 S BGPD2=1 ;ACT DM
I BGPAGEB>64,BGPACTCL S BGPD1=1 ;AC 65+
I BGPAGEB>17,BGPAGEB<65,BGPACTCL,$$HIGHRP^BGP8D3A(DFN,BGPEDATE) S BGPD4=1 ;18-64 AC HIGH RISK
I BGPAGEB>17,BGPAGEB<65,BGPACTUP,$$HIGHRP^BGP8D3A(DFN,BGPEDATE) S BGPD5=1 ;18-64 UP HIGH RISK
I BGPAGEB>17,BGPAGEB<65,BGPACTCL S BGPD6=1 ;18-64 AC
I BGPAGEB>17,BGPAGEB<65,BGPACTUP S BGPD7=1 ;18-64 UP
I BGPAGEB>17,BGPACTCL S BGPD8=1
I BGPAGEB>17,BGPACTUP S BGPD9=1
I BGPAGEB>18,BGPAGEB<60,BGPACTCL S BGPD10=1 ;AC 19-59 026.N.1
I BGPAGEB>18,BGPAGEB<60,BGPACTUP S BGPD11=1
I BGPAGEB>59,BGPAGEB<65,BGPACTCL S BGPD12=1 ;AC 60-64 026.QO
I BGPAGEB>59,BGPAGEB<65,BGPACTUP S BGPD13=1
I BGPSEX="F" S X=$$PREG(DFN,BGPBDATE,BGPEDATE) I X S BGPD14=1 ;pregnant
I BGPACTCL,BGPAGEB>18 S BGPD15=1 ;GPRA DEV V17 AC 19+
I BGPACTUP,BGPAGEB>18 S BGPD17=1 ;V18 USER OP 19+
I '(BGPD1+BGPD2+BGPD3+BGPD4+BGPD5+BGPD6+BGPD7+BGPD8+BGPD9+BGPD10+BGPD11+BGPD12+BGPD13+BGPD14+BGPD15+BGPD16+BGPD17) S BGPSTOP=1 Q
S BGPVALUE="",BGPVALUD="",BGPPLPNU="",BGPDTAPP="",BGPTDAP=""
PN ;EP - called from elder
;NEW PNEUMO AGE 65+ ONLY
;I BGPAGEB<65 G N1
S BGPPPCON=$$PPCONT(DFN,BGPEDATE) ;I BGPPPCON S (BGPPPSEV,BGPPP5Y,BGPPP1Y,BGPPP65)=BGPPPCON ;did they have a contraindication
S BGPPCCON=$$PCCONT(DFN,BGPEDATE) ;I BGPPCCON S (BGPPCVEV,BGPPC5Y,BGPPC1Y,BGPPC19)=BGPPCCON ;did they have a contraindication
;I BGPPCON S (BGPN1,BGPN8,BGPN37,BGPN46,BGPN47,BGPN48,BGPN49,BGPN50,BGPN51,BGPN52)=1 G N1
S BGPPPSEV=$$PPSV23^BGP8D3C(DFN,$$DOB^AUPNPAT(DFN),BGPEDATE) ;PPSV23 EVER
S BGPPCVEV=$$PCV13^BGP8D3C(DFN,$$DOB^AUPNPAT(DFN),BGPEDATE) ;PCV13 EVER
S BGPPP5Y=$$PPSV23^BGP8D3C(DFN,$$FMADD^XLFDT(BGPEDATE,-(5*365)),BGPEDATE) ;PPSV23 LAST 5 YEARS
S BGPPC5Y=$$PCV13^BGP8D3C(DFN,$$FMADD^XLFDT(BGPEDATE,-(5*365)),BGPEDATE) ;PCV13 LAST 5 YEARS
S BGPPC1Y=$$PCV13^BGP8D3C(DFN,BGPBDATE,BGPEDATE) ;PCV13 PAST YEAR
S BGPPP1Y=$$PPSV23^BGP8D3C(DFN,BGPBDATE,BGPEDATE) ;PPSV23 PAST YEAR
S B=$$DOB^AUPNPAT(DFN)
S BGPA65BD=$E(B,1,3)+65_$E(B,4,7)
I BGPAGEB>64 S BGPPP65=$$PPSV23^BGP8D3C(DFN,BGPA65BD,BGPEDATE),BGPPC65=$$PCV13^BGP8D3C(DFN,BGPA65BD,BGPEDATE)
S BGPA19BD=$E(B,1,3)+19_$E(B,4,7)
S BGPPC19=$$PCV13^BGP8D3C(DFN,BGPA19BD,BGPEDATE)
I BGPPPSEV!(BGPPCVEV)!(BGPPCCON)!(BGPPPCON) S BGPN1=1
;BGPN8 - V18 026.C.5
S BGPN8=0
;I BGPAGEB<65,(BGPPPSEV!(BGPPCVEV)) S BGPN8=1 ;UNDER 65 HAD PPSV23 OR PCV13 EVER PNEUMO ONLY 65+
I (BGPPPSEV!(BGPPCVEV)),(BGPPP65!(BGPPC65)!(BGPPP5Y)!(BGPPC5Y)) S BGPN8=1 ;026.C.5 BGPN8
I BGPPPCON!(BGPPCCON) S BGPN8=1
S BGPN47=0 ;026.C.26
I BGPPC19!(BGPPP1Y) S BGPN47=1
I BGPPCCON S BGPN47=1
S BGPN48=0 ;026.C.27
I BGPPPCON!(BGPPC1Y) S BGPN48=1
I BGPPP5Y!(BGPPP65) S BGPN48=1
S BGPN46=0 ;026.C.25 UP TO DATE
I BGPN47,BGPN48 S BGPN46=1 ;UP TO DATE
S BGPN49=0 ;026.C.28
I BGPPP65!(BGPPPCON),BGPPC65!(BGPPCCON) S BGPN49=1
S BGPN50=0 ;026.C.29
I BGPPP65!(BGPPPCON) S BGPN50=1
S BGPN51=0 ;026.C.30
I BGPPC65!(BGPPCCON) S BGPN51=1
;BGPN52 026.D.1
S BGPN52=0
I BGPAGEB>64,BGPPPSEV,(BGPPP65!(BGPPP5Y)) S BGPN52=1
I BGPAGEB<65,BGPPPSEV S BGPN52=1
I BGPPPCON S BGPN52=1
N1 S BGPDV=""
;
TD ;new tdap and td stuff for v11.1
I BGPRTYPE=5 G P1
S BGPTDAP=$$DTAP^BGP8D3A(DFN,$$DOB^AUPNPAT(DFN),BGPEDATE)
I BGPTDAP S BGPN9=1 ;026.N.3 TDAP/TD EVER BGPN9
S BGPTD=$$DTAPTD^BGP8D3A(DFN,$$FMADD^XLFDT(BGPEDATE,-(10*365)),BGPEDATE)
I BGPTD S BGPN10=1 ;026.N.1 1 Tdap/Td in past 10 years BGPN10
I BGPN9,BGPN10 S BGPN30=1 ;026.N.9 TD 10 YRS/TDAP EVER 1:1 19-59 BGPN30
;FLU
S BGPFLU=$$FLU^BGP8D3(DFN,BGPBDATE,BGPEDATE)
I $P(BGPFLU,U,3)=1!($P(BGPFLU,U,3)=3) S BGPN13=1 ;026.O.5 FLU DURING RP BGPN13
I BGPN9,BGPN10,BGPN13 S BGPN15=1 ;022=6.N.7 1:1:1 19-59 BGPN15
;I BGPN11!(BGPN12)!(BGPN14) S BGPN16=1
S BGPZOST=$$IZOSTER^BGP8D3C(DFN,$$DOB^AUPNPAT(DFN),BGPEDATE)
I $P(BGPZOST,U,3)=1!($P(BGPZOST,U,3)=3) S BGPN17=1 ;026.O.7
I BGPN9,BGPN10,BGPN13,BGPN17 S BGPN19=1 ;026.O.9 60-64 1:1:1:1
I BGPN9,BGPN10,BGPN17 S BGPN32=1 ;1:1:1: TD/TDAP/ZOSTER O26.O.11
I BGPN9,BGPN10,BGPN13,BGPN17,BGPN46 S BGPN21=1 ;026.C.14
I BGPN9,BGPN10,BGPN17,BGPN46 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,BGPN48 S BGPN29=1 ;026.C.17
I BGPN9,BGPN10,BGPN17,BGPN48 S BGPN38=1
;
S BGPTRIM=""
I BGPD14 D
.S BGPVALUD="AC PREG|||"
.S BGPFPRDX=$$FIRSTPDX^BGP8D3C(DFN,$$FMADD^XLFDT(BGPEDATE,-608),BGPEDATE) I BGPFPRDX="" S BGPFPRDX=$P($G(^AUPNREP(DFN,11)),U,2)
.;GET EDD
.S BGPEDD=$$EDD^BGP8UTL2(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
.;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=""
..;I $E(BGPTDAPP)=2 G UNK
..S TB=$$FMADD^XLFDT(BGPEDD,-91)
..S TE=BGPEDD
..S BGPD16=$$LASTVD^BGP8D3C(DFN,TB,TE)
..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) ;DATE OF DTAP
..I X="" Q
..I $E(BGPTDAPP)=2 G UNK
..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
UNK ..I G="" S BGPN44=1,BGPTRIM="unk Trimester"
.I BGPEDD="" D ;try to find icd codes
..;get all dxs tri, sec, 1st
..S G=""
..S BGPD16=$$LASTDX^BGP8UTL1(DFN,"BGP PREGNANCY TRI 3 DXS",BGPBDATE,BGPEDATE)
..S X=$P(BGPTDAPP,U,2) ;DATE OF TDAP
..I X="" Q
..I $E(BGPTDAPP)=2 G UNK1
..S Y=$$LASTDX^BGP8UTL1(DFN,"BGP PREGNANCY TRI 3 DXS",$$FMADD^XLFDT(X,-7),$$FMADD^XLFDT(X,7))
..I Y S G=G_3,BGPD16=1
..S Y=$$LASTDX^BGP8UTL1(DFN,"BGP PREGNANCY TRI 2 DXS",$$FMADD^XLFDT(X,-7),$$FMADD^XLFDT(X,7))
..I Y S G=G_2
..S Y=$$LASTDX^BGP8UTL1(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
UNK1 ..I G="" S BGPN44=1,BGPTRIM="unk Trimester"
N ;
;GPRA DEV PREG BGPVALUD
I BGPD16 S BGPVALUD=$P(BGPVALUD,"|||")_",PREGVTTM|||"_$P(BGPVALUD,"|||",2)
I BGPD14!(BGPD16) D
.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)"
;ONM DENOMINATOR LIST VALUE
S BGPDV=""
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")
;SELECTED DENOMINATOR LIST VALUE
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")
;NATL GPRA DENOMINATOR LIST VALUE
I BGPRTYPE=1 D
.S BGPDV="UP"
.I BGPD6!(BGPD1)!(BGPD8) S BGPDV=BGPDV_$S(BGPDV]"":",AC",1:"AC")
I BGPD10!(BGPD11),BGPN30 S BGPN45=1 ;19-59
I BGPD12!(BGPD13),BGPN32 S BGPN45=1 ;60-64
I BGPD1!(BGPD3),BGPN34 S BGPN45=1 ;65+
S BGPVALUE=""
I BGPTDAP S BGPVALUE=BGPVALUE_$S(BGPVALUE]"":"; ",1:""),BGPVALUE=BGPVALUE_"TDAP: "_$P(BGPTDAP,U,2)_" (ever)"
I BGPTD S BGPVALUE=BGPVALUE_$S(BGPVALUE]"":"; ",1:""),BGPVALUE=BGPVALUE_"TDAP/TD: "_$P(BGPTD,U,2)_" (past 10 yrs)"
I BGPFLU S BGPVALUE=BGPVALUE_$S(BGPVALUE]"":"; ",1:""),BGPVALUE=BGPVALUE_"FLU: "_$P(BGPFLU,U,2)_" (past yr)"
I BGPZOST]"" S BGPVALUE=BGPVALUE_$S(BGPVALUE]"":"; ",1:""),BGPVALUE=BGPVALUE_"ZOSTER: "_$P(BGPZOST,U,2)_" (ever)"
P1 I BGPPPCON S BGPVALUE=BGPVALUE_$S(BGPVALUE]"":"; ",1:"")_"PPSV23: "_$$DATE^BGP8UTL($P(BGPPPCON,U,1))_" "_$P(BGPPPCON,U,2)
I BGPPCCON S BGPVALUE=BGPVALUE_$S(BGPVALUE]"":"; ",1:"")_"PCV13: "_$$DATE^BGP8UTL($P(BGPPCCON,U,1))_" "_$P(BGPPCCON,U,2)
;PPSV23
I BGPPPSEV D
.S BGPVALUE=BGPVALUE_$S(BGPVALUE]"":"; ",1:"")_"PPSV23: "_$$DATE^BGP8UTL($P(BGPPPSEV,U,1))_" "_$P(BGPPPSEV,U,2)_" (ever)"
.S:BGPPP5Y BGPVALUE=BGPVALUE_" (past 5 yrs)" S:BGPPP1Y BGPVALUE=BGPVALUE_" (past 1 yr)" S:BGPPP65 BGPVALUE=BGPVALUE_" (after 65)" I BGPN46 S BGPVALUE=BGPVALUE_" (up-to-date)"
I BGPPCVEV D
.S BGPVALUE=BGPVALUE_$S(BGPVALUE]"":"; ",1:"")_"PCV13: "_$$DATE^BGP8UTL($P(BGPPCVEV,U,1))_" "_$P(BGPPCVEV,U,2)_" (ever)"
.S:BGPPC5Y BGPVALUE=BGPVALUE_" (past 5 yrs)" S:BGPPC1Y BGPVALUE=BGPVALUE_" (past 1 yr)" S:BGPPC65 BGPVALUE=BGPVALUE_" (after 65)" S:BGPPC19 BGPVALUE=BGPVALUE_" (after 19)" I BGPN46 S BGPVALUE=BGPVALUE_" (up-to-date)"
S BGPVALUE=BGPDV_"|||"_BGPVALUE
;S BGPVALUE=BGPVALUE_" MET: "_BGPLORI
TDE K BGPLPNU,BGPVAL,BGPA65,BGPVALH,BGPTD,BGPTDAP,BGPFLU,BGPTDAPP,BGPPNCON,BGPA65BD,BGPA19BD,BGPPNCON
Q
OPTOM ;EP
G OPTOM^BGP8D213
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^BGP8UTL(ID)_" Imm 115"
.Q
;now add in cpt
S C=+$$CODEN^ICPTCOD(90715)
S D=$$CPTI^BGP8DU(P,BDATE,EDATE,C)
I $P(D,U,2)>$P(BGPX,U,1) S BGPX=$P(D,U,2)_U_$$DATE^BGP8UTL(D)_" CPT 90715"
I BGPX Q 1_U_BGPX
;contra/nmi
F BGPZ=115 S X=$$ANCONT^BGP8D31(P,BGPZ,EDATE)
I X]"" S BGPX=2_U_$P(X,U,1)_U_$$DATE^BGP8UTL($P(X,U,1))_" "_$P(X,U,2) Q BGPX
;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^BGP8UTL(R)_" "_"NMI Dtap" Q BGPX
S R="",B=+$$CODEN^ICPTCOD(90715)
S G=$$NMIREF^BGP8UTL1(P,81,B,$$DOB^AUPNPAT(P),EDATE)
I G S BGPX=2_U_$P(G,U,2)_U_$$DATE^BGP8UTL($P(G,U,2))_" "_"NMI Dtap 90715" Q G
Q ""
PREG(P,BDATE,EDATE) ;
I '$$PREG^BGP8D7(DFN,$$FMADD^XLFDT(EDATE,-608),EDATE,1,1,,BDATE,EDATE) Q "" ;V17.1 CMI/LAB ADDED DATES FOR CURRENTLY PREGNANT
Q 1
PPCONT(P,EDATE) ;contraindicated
;NOW CHECK FOR CONTRAINDICATION pps23
NEW X,TA,BGPZ,G,R
S X=""
S T1=$O(^ATXAX("B","BGP PPSV23 CVX CODES",0))
S BGPZ=0 F S BGPZ=$O(^ATXAX(T1,21,"B",BGPZ)) Q:BGPZ'=+BGPZ!(X]"") S X=$$ANCONT^BGP8D31(P,BGPZ,EDATE)
I X]"" Q X_U_3
;NMI Refusal
S BGPZ=0,G="" F S BGPZ=$O(^ATXAX(T1,21,"B",BGPZ)) Q:BGPZ'=+BGPZ!(G) D
.S G=$$NMIREF^BGP8UTL1(P,9999999.14,$O(^AUTTIMM("C",BGPZ,0)),$$DOB^AUPNPAT(P),EDATE)
.I $P(G,U)=1 S G=$P(G,U,2)_U_"NMI Refusal"_U_3
I G]"" Q G
S R=$$CPTREFT^BGP8UTL1(P,$$DOB^AUPNPAT(P),EDATE,$O(^ATXAX("B","BGP PPSV23 CPT CODES",0)),"N")
I R Q $P(R,U,2)_U_"NMI Refusal "_$P(R,U,4)_U_3
Q ""
PCCONT(P,EDATE) ;
;NOW CHECK FOR CONTRAINDICATION (NEW IN 8.0)
S X=""
S T1=$O(^ATXAX("B","BGP PCV13 CVX CODES",0))
S BGPZ=0 F S BGPZ=$O(^ATXAX(T1,21,"B",BGPZ)) Q:BGPZ'=+BGPZ!(X]"") S X=$$ANCONT^BGP8D31(P,BGPZ,EDATE)
I X]"" Q X_U_3
;NMI Refusal pcv13
S BGPZ=0,G="" F S BGPZ=$O(^ATXAX(T1,21,"B",BGPZ)) Q:BGPZ'=+BGPZ!(G) D
.S G=$$NMIREF^BGP8UTL1(P,9999999.14,$O(^AUTTIMM("C",BGPZ,0)),$$DOB^AUPNPAT(P),EDATE)
.I $P(G,U)=1 S G=$P(G,U,2)_U_"NMI Refusal"_U_3
I G]"" Q G
S R=$$CPTREFT^BGP8UTL1(P,$$DOB^AUPNPAT(P),EDATE,$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 ""
BGP8D3B ; IHS/CMI/LAB - PNEUMO REMINDER 27 Feb 2015 7:52 AM ;
+1 ;;18.1;IHS CLINICAL REPORTING;;MAY 25, 2018;Build 66
+2 ;
I13 ;EP - PN
+1 NEW BGPTDAP,BGPTD,BGPFLU,BGPZOST,BGPPNEU,BGPPNEUD,BGPDTAPP,BGPPPSEV,BGPPCVEV,BGPPP65,BGPPC65,BGPPP5Y,BGPPC5Y,BGPPC1Y,BGPPC19,BGPPP1Y
+2 SET (BGPPNCON,BGPPPSEV,BGPPCVEV,BGPPP65,BGPPC65,BGPPP5Y,BGPPC5Y,BGPPC1Y,BGPPC19,BGPPP1Y,BGPPPCON,BGPPCCON)=""
+3 FOR X=1:1:17
SET Y="BGPD"_X
SET @Y=""
+4 FOR X=1:1:55
SET Y="BGPN"_X
SET @Y=""
+5 ;UP 65+
IF BGPAGEB>64
IF BGPACTUP
SET BGPD3=1
+6 ;ACT DM
IF BGPDMD2
SET BGPD2=1
+7 ;AC 65+
IF BGPAGEB>64
IF BGPACTCL
SET BGPD1=1
+8 ;18-64 AC HIGH RISK
IF BGPAGEB>17
IF BGPAGEB<65
IF BGPACTCL
IF $$HIGHRP^BGP8D3A(DFN,BGPEDATE)
SET BGPD4=1
+9 ;18-64 UP HIGH RISK
IF BGPAGEB>17
IF BGPAGEB<65
IF BGPACTUP
IF $$HIGHRP^BGP8D3A(DFN,BGPEDATE)
SET BGPD5=1
+10 ;18-64 AC
IF BGPAGEB>17
IF BGPAGEB<65
IF BGPACTCL
SET BGPD6=1
+11 ;18-64 UP
IF BGPAGEB>17
IF BGPAGEB<65
IF BGPACTUP
SET BGPD7=1
+12 IF BGPAGEB>17
IF BGPACTCL
SET BGPD8=1
+13 IF BGPAGEB>17
IF BGPACTUP
SET BGPD9=1
+14 ;AC 19-59 026.N.1
IF BGPAGEB>18
IF BGPAGEB<60
IF BGPACTCL
SET BGPD10=1
+15 IF BGPAGEB>18
IF BGPAGEB<60
IF BGPACTUP
SET BGPD11=1
+16 ;AC 60-64 026.QO
IF BGPAGEB>59
IF BGPAGEB<65
IF BGPACTCL
SET BGPD12=1
+17 IF BGPAGEB>59
IF BGPAGEB<65
IF BGPACTUP
SET BGPD13=1
+18 ;pregnant
IF BGPSEX="F"
SET X=$$PREG(DFN,BGPBDATE,BGPEDATE)
IF X
SET BGPD14=1
+19 ;GPRA DEV V17 AC 19+
IF BGPACTCL
IF BGPAGEB>18
SET BGPD15=1
+20 ;V18 USER OP 19+
IF BGPACTUP
IF BGPAGEB>18
SET BGPD17=1
+21 IF '(BGPD1+BGPD2+BGPD3+BGPD4+BGPD5+BGPD6+BGPD7+BGPD8+BGPD9+BGPD10+BGPD11+BGPD12+BGPD13+BGPD14+BGPD15+BGPD16+BGPD17)
SET BGPSTOP=1
QUIT
+22 SET BGPVALUE=""
SET BGPVALUD=""
SET BGPPLPNU=""
SET BGPDTAPP=""
SET BGPTDAP=""
PN ;EP - called from elder
+1 ;NEW PNEUMO AGE 65+ ONLY
+2 ;I BGPAGEB<65 G N1
+3 ;I BGPPPCON S (BGPPPSEV,BGPPP5Y,BGPPP1Y,BGPPP65)=BGPPPCON ;did they have a contraindication
SET BGPPPCON=$$PPCONT(DFN,BGPEDATE)
+4 ;I BGPPCCON S (BGPPCVEV,BGPPC5Y,BGPPC1Y,BGPPC19)=BGPPCCON ;did they have a contraindication
SET BGPPCCON=$$PCCONT(DFN,BGPEDATE)
+5 ;I BGPPCON S (BGPN1,BGPN8,BGPN37,BGPN46,BGPN47,BGPN48,BGPN49,BGPN50,BGPN51,BGPN52)=1 G N1
+6 ;PPSV23 EVER
SET BGPPPSEV=$$PPSV23^BGP8D3C(DFN,$$DOB^AUPNPAT(DFN),BGPEDATE)
+7 ;PCV13 EVER
SET BGPPCVEV=$$PCV13^BGP8D3C(DFN,$$DOB^AUPNPAT(DFN),BGPEDATE)
+8 ;PPSV23 LAST 5 YEARS
SET BGPPP5Y=$$PPSV23^BGP8D3C(DFN,$$FMADD^XLFDT(BGPEDATE,-(5*365)),BGPEDATE)
+9 ;PCV13 LAST 5 YEARS
SET BGPPC5Y=$$PCV13^BGP8D3C(DFN,$$FMADD^XLFDT(BGPEDATE,-(5*365)),BGPEDATE)
+10 ;PCV13 PAST YEAR
SET BGPPC1Y=$$PCV13^BGP8D3C(DFN,BGPBDATE,BGPEDATE)
+11 ;PPSV23 PAST YEAR
SET BGPPP1Y=$$PPSV23^BGP8D3C(DFN,BGPBDATE,BGPEDATE)
+12 SET B=$$DOB^AUPNPAT(DFN)
+13 SET BGPA65BD=$EXTRACT(B,1,3)+65_$EXTRACT(B,4,7)
+14 IF BGPAGEB>64
SET BGPPP65=$$PPSV23^BGP8D3C(DFN,BGPA65BD,BGPEDATE)
SET BGPPC65=$$PCV13^BGP8D3C(DFN,BGPA65BD,BGPEDATE)
+15 SET BGPA19BD=$EXTRACT(B,1,3)+19_$EXTRACT(B,4,7)
+16 SET BGPPC19=$$PCV13^BGP8D3C(DFN,BGPA19BD,BGPEDATE)
+17 IF BGPPPSEV!(BGPPCVEV)!(BGPPCCON)!(BGPPPCON)
SET BGPN1=1
+18 ;BGPN8 - V18 026.C.5
+19 SET BGPN8=0
+20 ;I BGPAGEB<65,(BGPPPSEV!(BGPPCVEV)) S BGPN8=1 ;UNDER 65 HAD PPSV23 OR PCV13 EVER PNEUMO ONLY 65+
+21 ;026.C.5 BGPN8
IF (BGPPPSEV!(BGPPCVEV))
IF (BGPPP65!(BGPPC65)!(BGPPP5Y)!(BGPPC5Y))
SET BGPN8=1
+22 IF BGPPPCON!(BGPPCCON)
SET BGPN8=1
+23 ;026.C.26
SET BGPN47=0
+24 IF BGPPC19!(BGPPP1Y)
SET BGPN47=1
+25 IF BGPPCCON
SET BGPN47=1
+26 ;026.C.27
SET BGPN48=0
+27 IF BGPPPCON!(BGPPC1Y)
SET BGPN48=1
+28 IF BGPPP5Y!(BGPPP65)
SET BGPN48=1
+29 ;026.C.25 UP TO DATE
SET BGPN46=0
+30 ;UP TO DATE
IF BGPN47
IF BGPN48
SET BGPN46=1
+31 ;026.C.28
SET BGPN49=0
+32 IF BGPPP65!(BGPPPCON)
IF BGPPC65!(BGPPCCON)
SET BGPN49=1
+33 ;026.C.29
SET BGPN50=0
+34 IF BGPPP65!(BGPPPCON)
SET BGPN50=1
+35 ;026.C.30
SET BGPN51=0
+36 IF BGPPC65!(BGPPCCON)
SET BGPN51=1
+37 ;BGPN52 026.D.1
+38 SET BGPN52=0
+39 IF BGPAGEB>64
IF BGPPPSEV
IF (BGPPP65!(BGPPP5Y))
SET BGPN52=1
+40 IF BGPAGEB<65
IF BGPPPSEV
SET BGPN52=1
+41 IF BGPPPCON
SET BGPN52=1
N1 SET BGPDV=""
+1 ;
TD ;new tdap and td stuff for v11.1
+1 IF BGPRTYPE=5
GOTO P1
+2 SET BGPTDAP=$$DTAP^BGP8D3A(DFN,$$DOB^AUPNPAT(DFN),BGPEDATE)
+3 ;026.N.3 TDAP/TD EVER BGPN9
IF BGPTDAP
SET BGPN9=1
+4 SET BGPTD=$$DTAPTD^BGP8D3A(DFN,$$FMADD^XLFDT(BGPEDATE,-(10*365)),BGPEDATE)
+5 ;026.N.1 1 Tdap/Td in past 10 years BGPN10
IF BGPTD
SET BGPN10=1
+6 ;026.N.9 TD 10 YRS/TDAP EVER 1:1 19-59 BGPN30
IF BGPN9
IF BGPN10
SET BGPN30=1
+7 ;FLU
+8 SET BGPFLU=$$FLU^BGP8D3(DFN,BGPBDATE,BGPEDATE)
+9 ;026.O.5 FLU DURING RP BGPN13
IF $PIECE(BGPFLU,U,3)=1!($PIECE(BGPFLU,U,3)=3)
SET BGPN13=1
+10 ;022=6.N.7 1:1:1 19-59 BGPN15
IF BGPN9
IF BGPN10
IF BGPN13
SET BGPN15=1
+11 ;I BGPN11!(BGPN12)!(BGPN14) S BGPN16=1
+12 SET BGPZOST=$$IZOSTER^BGP8D3C(DFN,$$DOB^AUPNPAT(DFN),BGPEDATE)
+13 ;026.O.7
IF $PIECE(BGPZOST,U,3)=1!($PIECE(BGPZOST,U,3)=3)
SET BGPN17=1
+14 ;026.O.9 60-64 1:1:1:1
IF BGPN9
IF BGPN10
IF BGPN13
IF BGPN17
SET BGPN19=1
+15 ;1:1:1: TD/TDAP/ZOSTER O26.O.11
IF BGPN9
IF BGPN10
IF BGPN17
SET BGPN32=1
+16 ;026.C.14
IF BGPN9
IF BGPN10
IF BGPN13
IF BGPN17
IF BGPN46
SET BGPN21=1
+17 IF BGPN9
IF BGPN10
IF BGPN17
IF BGPN46
SET BGPN34=1
+18 IF BGPN11!(BGPN12)!(BGPN14)!(BGPN18)!(BGPN3)
SET BGPN22=1
+19 IF BGPN11!(BGPN12)!(BGPN18)!(BGPN3)
SET BGPN35=1
+20 ;026.C.17
IF BGPN9
IF BGPN10
IF BGPN13
IF BGPN17
IF BGPN48
SET BGPN29=1
+21 IF BGPN9
IF BGPN10
IF BGPN17
IF BGPN48
SET BGPN38=1
+22 ;
+23 SET BGPTRIM=""
+24 IF BGPD14
Begin DoDot:1
+25 SET BGPVALUD="AC PREG|||"
+26 SET BGPFPRDX=$$FIRSTPDX^BGP8D3C(DFN,$$FMADD^XLFDT(BGPEDATE,-608),BGPEDATE)
IF BGPFPRDX=""
SET BGPFPRDX=$PIECE($GET(^AUPNREP(DFN,11)),U,2)
+27 ;GET EDD
+28 SET BGPEDD=$$EDD^BGP8UTL2(DFN,BGPBDATE,BGPEDATE)
+29 KILL BGPTDAPP
+30 SET D=BGPEDATE
+31 IF BGPEDD]""
IF BGPEDD<BGPEDATE
SET D=BGPEDD
+32 SET BGPTDAPP=$$LASTTDAP(DFN,BGPFPRDX,D)
+33 ;A SHOT OR AN NMI
IF $EXTRACT(BGPTDAPP)
SET BGPN39=1
+34 ;NMI
IF $EXTRACT(BGPTDAPP)=2
SET BGPN40=1
+35 ;I 'BGPN39 Q
+36 ;TRIMESTER
+37 IF BGPEDD
Begin DoDot:2
+38 ;FIGURE OUT TRIMESTER FOR ALL TDAPS, IF ANY ARE 3RD USE IT, THEN DO 2ND, THEN DO 1ST
+39 ;FIRST DAY OF PREG IS 280 DAYS BEFORE EDD
+40 NEW FB,FE,SB,SE,TB,TE
+41 ;
+42 SET G=""
+43 ;I $E(BGPTDAPP)=2 G UNK
+44 SET TB=$$FMADD^XLFDT(BGPEDD,-91)
+45 SET TE=BGPEDD
+46 SET BGPD16=$$LASTVD^BGP8D3C(DFN,TB,TE)
+47 SET SB=$$FMADD^XLFDT(BGPEDD,-182)
+48 SET SE=$$FMADD^XLFDT(TB,-1)
+49 SET FB=$$FMADD^XLFDT(BGPEDD,-280)
+50 SET FE=$$FMADD^XLFDT(SB,-1)
+51 ;DATE OF DTAP
SET X=$PIECE(BGPTDAPP,U,2)
+52 IF X=""
QUIT
+53 IF $EXTRACT(BGPTDAPP)=2
GOTO UNK
+54 IF X'<TB
IF X'>TE
SET G=G_3
+55 IF X'>SE
IF X'<SB
SET G=G_2
+56 IF X>FB
SET G=G_1
+57 IF G[3
SET BGPN43=1
SET BGPTRIM="3rd Trimester"
QUIT
+58 IF G[2
SET BGPN42=1
SET BGPTRIM="2nd Trimester"
QUIT
+59 IF G[1
SET BGPN41=1
SET BGPTRIM="1st Trimester"
QUIT
UNK IF G=""
SET BGPN44=1
SET BGPTRIM="unk Trimester"
End DoDot:2
QUIT
+1 ;try to find icd codes
IF BGPEDD=""
Begin DoDot:2
+2 ;get all dxs tri, sec, 1st
+3 SET G=""
+4 SET BGPD16=$$LASTDX^BGP8UTL1(DFN,"BGP PREGNANCY TRI 3 DXS",BGPBDATE,BGPEDATE)
+5 ;DATE OF TDAP
SET X=$PIECE(BGPTDAPP,U,2)
+6 IF X=""
QUIT
+7 IF $EXTRACT(BGPTDAPP)=2
GOTO UNK1
+8 SET Y=$$LASTDX^BGP8UTL1(DFN,"BGP PREGNANCY TRI 3 DXS",$$FMADD^XLFDT(X,-7),$$FMADD^XLFDT(X,7))
+9 IF Y
SET G=G_3
SET BGPD16=1
+10 SET Y=$$LASTDX^BGP8UTL1(DFN,"BGP PREGNANCY TRI 2 DXS",$$FMADD^XLFDT(X,-7),$$FMADD^XLFDT(X,7))
+11 IF Y
SET G=G_2
+12 SET Y=$$LASTDX^BGP8UTL1(DFN,"BGP PREGNANCY TRI 1 DXS",$$FMADD^XLFDT(X,-7),$$FMADD^XLFDT(X,7))
+13 IF Y
SET G=G_1
+14 IF G[3
SET BGPN43=1
SET BGPTRIM="3rd Trimester"
QUIT
+15 IF G[2
SET BGPN42=1
SET BGPTRIM="2nd Trimester"
QUIT
+16 IF G[1
SET BGPN41=1
SET BGPTRIM="1st Trimester"
QUIT
UNK1 IF G=""
SET BGPN44=1
SET BGPTRIM="unk Trimester"
End DoDot:2
End DoDot:1
N ;
+1 ;GPRA DEV PREG BGPVALUD
+2 IF BGPD16
SET BGPVALUD=$PIECE(BGPVALUD,"|||")_",PREGVTTM|||"_$PIECE(BGPVALUD,"|||",2)
+3 IF BGPD14!(BGPD16)
Begin DoDot:1
+4 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:"")
+5 IF BGPTD
SET BGPVALUD=BGPVALUD_$SELECT($PIECE(BGPVALUD,"|||",2)]"":"; ",1:"")
SET BGPVALUD=BGPVALUD_"TDAP/TD: "_$PIECE(BGPTD,U,2)_" (past 10 yrs)"
+6 IF BGPFLU
SET BGPVALUD=BGPVALUD_$SELECT($PIECE(BGPVALUD,"|||",2)]"":"; ",1:"")
SET BGPVALUD=BGPVALUD_"FLU: "_$PIECE(BGPFLU,U,2)_" (past yr)"
End DoDot:1
+7 ;ONM DENOMINATOR LIST VALUE
+8 SET BGPDV=""
+9 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")
+10 ;SELECTED DENOMINATOR LIST VALUE
+11 IF BGPRTYPE=4
Begin DoDot:1
+12 SET BGPDV="UP"
+13 IF BGPD6!(BGPD1)!(BGPD8)
SET BGPDV=BGPDV_$SELECT(BGPDV]"":",AC",1:"AC")
+14 IF BGPD4!(BGPD5)
SET BGPDV=BGPDV_$SELECT(BGPDV]"":",HR",1:"HR")
+15 IF BGPD2
SET BGPDV=BGPDV_$SELECT(BGPDV]"":",AD",1:"AD")
End DoDot:1
+16 ;NATL GPRA DENOMINATOR LIST VALUE
+17 IF BGPRTYPE=1
Begin DoDot:1
+18 SET BGPDV="UP"
+19 IF BGPD6!(BGPD1)!(BGPD8)
SET BGPDV=BGPDV_$SELECT(BGPDV]"":",AC",1:"AC")
End DoDot:1
+20 ;19-59
IF BGPD10!(BGPD11)
IF BGPN30
SET BGPN45=1
+21 ;60-64
IF BGPD12!(BGPD13)
IF BGPN32
SET BGPN45=1
+22 ;65+
IF BGPD1!(BGPD3)
IF BGPN34
SET BGPN45=1
+23 SET BGPVALUE=""
+24 IF BGPTDAP
SET BGPVALUE=BGPVALUE_$SELECT(BGPVALUE]"":"; ",1:"")
SET BGPVALUE=BGPVALUE_"TDAP: "_$PIECE(BGPTDAP,U,2)_" (ever)"
+25 IF BGPTD
SET BGPVALUE=BGPVALUE_$SELECT(BGPVALUE]"":"; ",1:"")
SET BGPVALUE=BGPVALUE_"TDAP/TD: "_$PIECE(BGPTD,U,2)_" (past 10 yrs)"
+26 IF BGPFLU
SET BGPVALUE=BGPVALUE_$SELECT(BGPVALUE]"":"; ",1:"")
SET BGPVALUE=BGPVALUE_"FLU: "_$PIECE(BGPFLU,U,2)_" (past yr)"
+27 IF BGPZOST]""
SET BGPVALUE=BGPVALUE_$SELECT(BGPVALUE]"":"; ",1:"")
SET BGPVALUE=BGPVALUE_"ZOSTER: "_$PIECE(BGPZOST,U,2)_" (ever)"
P1 IF BGPPPCON
SET BGPVALUE=BGPVALUE_$SELECT(BGPVALUE]"":"; ",1:"")_"PPSV23: "_$$DATE^BGP8UTL($PIECE(BGPPPCON,U,1))_" "_$PIECE(BGPPPCON,U,2)
+1 IF BGPPCCON
SET BGPVALUE=BGPVALUE_$SELECT(BGPVALUE]"":"; ",1:"")_"PCV13: "_$$DATE^BGP8UTL($PIECE(BGPPCCON,U,1))_" "_$PIECE(BGPPCCON,U,2)
+2 ;PPSV23
+3 IF BGPPPSEV
Begin DoDot:1
+4 SET BGPVALUE=BGPVALUE_$SELECT(BGPVALUE]"":"; ",1:"")_"PPSV23: "_$$DATE^BGP8UTL($PIECE(BGPPPSEV,U,1))_" "_$PIECE(BGPPPSEV,U,2)_" (ever)"
+5 IF BGPPP5Y
SET BGPVALUE=BGPVALUE_" (past 5 yrs)"
IF BGPPP1Y
SET BGPVALUE=BGPVALUE_" (past 1 yr)"
IF BGPPP65
SET BGPVALUE=BGPVALUE_" (after 65)"
IF BGPN46
SET BGPVALUE=BGPVALUE_" (up-to-date)"
End DoDot:1
+6 IF BGPPCVEV
Begin DoDot:1
+7 SET BGPVALUE=BGPVALUE_$SELECT(BGPVALUE]"":"; ",1:"")_"PCV13: "_$$DATE^BGP8UTL($PIECE(BGPPCVEV,U,1))_" "_$PIECE(BGPPCVEV,U,2)_" (ever)"
+8 IF BGPPC5Y
SET BGPVALUE=BGPVALUE_" (past 5 yrs)"
IF BGPPC1Y
SET BGPVALUE=BGPVALUE_" (past 1 yr)"
IF BGPPC65
SET BGPVALUE=BGPVALUE_" (after 65)"
IF BGPPC19
SET BGPVALUE=BGPVALUE_" (after 19)"
IF BGPN46
SET BGPVALUE=BGPVALUE_" (up-to-date)"
End DoDot:1
+9 SET BGPVALUE=BGPDV_"|||"_BGPVALUE
+10 ;S BGPVALUE=BGPVALUE_" MET: "_BGPLORI
TDE KILL BGPLPNU,BGPVAL,BGPA65,BGPVALH,BGPTD,BGPTDAP,BGPFLU,BGPTDAPP,BGPPNCON,BGPA65BD,BGPA19BD,BGPPNCON
+1 QUIT
OPTOM ;EP
+1 GOTO OPTOM^BGP8D213
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^BGP8UTL(ID)_" Imm 115"
End DoDot:2
+12 QUIT
End DoDot:1
+13 ;now add in cpt
+14 SET C=+$$CODEN^ICPTCOD(90715)
+15 SET D=$$CPTI^BGP8DU(P,BDATE,EDATE,C)
+16 IF $PIECE(D,U,2)>$PIECE(BGPX,U,1)
SET BGPX=$PIECE(D,U,2)_U_$$DATE^BGP8UTL(D)_" CPT 90715"
+17 IF BGPX
QUIT 1_U_BGPX
+18 ;contra/nmi
+19 FOR BGPZ=115
SET X=$$ANCONT^BGP8D31(P,BGPZ,EDATE)
+20 IF X]""
SET BGPX=2_U_$PIECE(X,U,1)_U_$$DATE^BGP8UTL($PIECE(X,U,1))_" "_$PIECE(X,U,2)
QUIT BGPX
+21 ;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^BGP8UTL(R)_" "_"NMI Dtap"
QUIT BGPX
+29 SET R=""
SET B=+$$CODEN^ICPTCOD(90715)
+30 SET G=$$NMIREF^BGP8UTL1(P,81,B,$$DOB^AUPNPAT(P),EDATE)
+31 IF G
SET BGPX=2_U_$PIECE(G,U,2)_U_$$DATE^BGP8UTL($PIECE(G,U,2))_" "_"NMI Dtap 90715"
QUIT G
+32 QUIT ""
PREG(P,BDATE,EDATE) ;
+1 ;V17.1 CMI/LAB ADDED DATES FOR CURRENTLY PREGNANT
IF '$$PREG^BGP8D7(DFN,$$FMADD^XLFDT(EDATE,-608),EDATE,1,1,,BDATE,EDATE)
QUIT ""
+2 QUIT 1
PPCONT(P,EDATE) ;contraindicated
+1 ;NOW CHECK FOR CONTRAINDICATION pps23
+2 NEW X,TA,BGPZ,G,R
+3 SET X=""
+4 SET T1=$ORDER(^ATXAX("B","BGP PPSV23 CVX CODES",0))
+5 SET BGPZ=0
FOR
SET BGPZ=$ORDER(^ATXAX(T1,21,"B",BGPZ))
IF BGPZ'=+BGPZ!(X]"")
QUIT
SET X=$$ANCONT^BGP8D31(P,BGPZ,EDATE)
+6 IF X]""
QUIT X_U_3
+7 ;NMI Refusal
+8 SET BGPZ=0
SET G=""
FOR
SET BGPZ=$ORDER(^ATXAX(T1,21,"B",BGPZ))
IF BGPZ'=+BGPZ!(G)
QUIT
Begin DoDot:1
+9 SET G=$$NMIREF^BGP8UTL1(P,9999999.14,$ORDER(^AUTTIMM("C",BGPZ,0)),$$DOB^AUPNPAT(P),EDATE)
+10 IF $PIECE(G,U)=1
SET G=$PIECE(G,U,2)_U_"NMI Refusal"_U_3
End DoDot:1
+11 IF G]""
QUIT G
+12 SET R=$$CPTREFT^BGP8UTL1(P,$$DOB^AUPNPAT(P),EDATE,$ORDER(^ATXAX("B","BGP PPSV23 CPT CODES",0)),"N")
+13 IF R
QUIT $PIECE(R,U,2)_U_"NMI Refusal "_$PIECE(R,U,4)_U_3
+14 QUIT ""
PCCONT(P,EDATE) ;
+1 ;NOW CHECK FOR CONTRAINDICATION (NEW IN 8.0)
+2 SET X=""
+3 SET T1=$ORDER(^ATXAX("B","BGP PCV13 CVX CODES",0))
+4 SET BGPZ=0
FOR
SET BGPZ=$ORDER(^ATXAX(T1,21,"B",BGPZ))
IF BGPZ'=+BGPZ!(X]"")
QUIT
SET X=$$ANCONT^BGP8D31(P,BGPZ,EDATE)
+5 IF X]""
QUIT X_U_3
+6 ;NMI Refusal pcv13
+7 SET BGPZ=0
SET G=""
FOR
SET BGPZ=$ORDER(^ATXAX(T1,21,"B",BGPZ))
IF BGPZ'=+BGPZ!(G)
QUIT
Begin DoDot:1
+8 SET G=$$NMIREF^BGP8UTL1(P,9999999.14,$ORDER(^AUTTIMM("C",BGPZ,0)),$$DOB^AUPNPAT(P),EDATE)
+9 IF $PIECE(G,U)=1
SET G=$PIECE(G,U,2)_U_"NMI Refusal"_U_3
End DoDot:1
+10 IF G]""
QUIT G
+11 SET R=$$CPTREFT^BGP8UTL1(P,$$DOB^AUPNPAT(P),EDATE,$ORDER(^ATXAX("B","BGP PNEUMO CONJUGATE CPTS",0)),"N")
+12 IF R
QUIT $PIECE(R,U,2)_U_"NMI Refusal "_$PIECE(R,U,4)_U_3
+13 QUIT ""
