- 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 ""
