Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: BGP4D3B

BGP4D3B.m

Go to the documentation of this file.
  1. BGP4D3B ; IHS/CMI/LAB - PNEUMO REMINDER ;
  1. ;;14.1;IHS CLINICAL REPORTING;;MAY 29, 2014;Build 114
  1. ;
  1. I13 ;EP - PN
  1. NEW BGPTDAP,BGPTD,BGPFLU,BGPZOST
  1. 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
  1. S (BGPN13,BGPN14,BGPN15,BGPN16,BGPN17,BGPN18,BGPN19,BGPN20,BGPN21,BGPN22)=0
  1. I BGPAGEB>64,BGPACTUP S BGPD3=1
  1. I BGPDMD2 S BGPD2=1
  1. I BGPAGEB>64,BGPACTCL S BGPD1=1
  1. I BGPAGEB>17,BGPAGEB<65,BGPACTCL,$$HIGHRP^BGP4D3A(DFN,BGPEDATE) S BGPD4=1
  1. I BGPAGEB>17,BGPAGEB<65,BGPACTUP,$$HIGHRP^BGP4D3A(DFN,BGPEDATE) S BGPD5=1
  1. I BGPAGEB>17,BGPAGEB<65,BGPACTCL S BGPD6=1
  1. I BGPAGEB>17,BGPAGEB<65,BGPACTUP S BGPD7=1
  1. I BGPAGEB>17,BGPACTCL S BGPD8=1
  1. I BGPAGEB>17,BGPACTUP S BGPD9=1
  1. I BGPAGEB>18,BGPAGEB<60,BGPACTCL S BGPD10=1
  1. I BGPAGEB>18,BGPAGEB<60,BGPACTUP S BGPD11=1
  1. I BGPAGEB>59,BGPAGEB<65,BGPACTCL S BGPD12=1
  1. I BGPAGEB>59,BGPAGEB<65,BGPACTUP S BGPD13=1
  1. I '(BGPD1+BGPD2+BGPD3+BGPD4+BGPD5+BGPD6+BGPD7+BGPD8+BGPD9+BGPD10+BGPD11+BGPD12+BGPD13) S BGPSTOP=1 Q
  1. I BGPRTYPE=3,'BGPD1 S BGPSTOP=1 Q
  1. PN ;EP - called from elder
  1. S BGPVALUE=$$PNEU^BGP4D31(DFN,$$DOB^AUPNPAT(DFN),BGPEDATE) ;set to date of PNEU shot
  1. ;I BGPVALUE]"" S BGPN1=1
  1. I $P(BGPVALUE,U,3)=1!($P(BGPVALUE,U,3)=3) S BGPN1=1
  1. ;I $P(BGPVALUE,U,3)=2 S BGPN2=1 ;REF
  1. I $P(BGPVALUE,U,3)=3 S BGPN3=1 ;NMI
  1. S BGPVAL=$$PNEU^BGP4D31(DFN,$$FMADD^XLFDT(BGPEDATE,-(5*365)),BGPEDATE)
  1. I $P(BGPVAL,U,3)=1!($P(BGPVAL,U,3)=3) S BGPN4=1 ;HAD IN PAST 5 YEARS SO "UP TO DATE"
  1. ;I $P(BGPVAL,U,3)=2 S BGPN5=1
  1. I $P(BGPVAL,U,3)=3 S BGPN6=1
  1. S BGPN7=0,BGPA65="" I BGPAGEB>65 S BGPA65=$$PNEU^BGP4D31(DFN,$$FMADD^XLFDT($$DOB^AUPNPAT(DFN),+(65*365)),BGPEDATE) I $P(BGPA65,U,3)=1!($P(BGPA65,U,3)=3) S BGPN4=1,BGPN7=1 ;over 65 and had one after 65
  1. I BGPAGEB<65,BGPN1 S BGPN4=1 ;anyone under and had 1 ever
  1. ;GPRA DEVELOPMENTAL
  1. S BGPN8=0
  1. I BGPAGEB<66,BGPN1 S BGPN8=1
  1. I BGPAGEB>65,BGPN1,(BGPN4+BGPN7) S BGPN8=1 ;IF UNDER 66 HAD 1 EVER, IF OVER 65 HAD ONE IN PAST 5 YEARS OR AFTER AGE 65
  1. S BGPDV=""
  1. I BGPRTYPE=1 S BGPDV="" D
  1. .I BGPD1 S BGPDV=BGPDV_$S(BGPDV]"":",AC",1:"AC")
  1. .I BGPD2 S BGPDV=BGPDV_$S(BGPDV]"":",AD",1:"AD")
  1. .I BGPN1 S BGPVALH=BGPVALUE,BGPVALUE=BGPDV_"|||" I BGPVALH]"" S BGPVALUE=BGPVALUE_"Pneumo: "_$$DATE^BGP4UTL($P(BGPVALH,U,1))_" "_$P(BGPVALH,U,2)_$S(BGPVALH]"":" (ever)",1:"")_" "_$S(BGPN8:" (up-to-date)",1:"") Q
  1. .S BGPVALUE=BGPDV_"|||"
  1. I BGPRTYPE=4 D
  1. .S BGPDV="UP"
  1. .I BGPD6!(BGPD1)!(BGPD8) S BGPDV=BGPDV_$S(BGPDV]"":",AC",1:"AC")
  1. .I BGPD4!(BGPD5) S BGPDV=BGPDV_$S(BGPDV]"":",HR",1:"HR")
  1. .;I BGPD3 S BGPDV=BGPDV_$S(BGPDV]"":",UP >64",1:"UP >64")
  1. .;I BGPD7 S BGPDV=BGPDV_$S(BGPDV]"":",UP 18-64",1:"UP 18-64")
  1. .;I BGPD5 S BGPDV=BGPDV_$S(BGPDV]"":",UP 18-64HR",1:"UP 18-64HR")
  1. .I BGPD2 S BGPDV=BGPDV_$S(BGPDV]"":",AD",1:"AD")
  1. 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")
  1. ;I BGPRTYPE=5 S BGPVALUE="" I (BGPN8!BGPN3) S BGPVALUE="AC"_"|||"_$$DATE^BGP4UTL($P(BGPVALUE,U,1))_" "_$P(BGPVALUE,U,2) I 1
  1. D
  1. .I BGPRTYPE'=1 S BGPVALH=BGPVALUE,BGPVALUE=BGPDV_"|||" I BGPVALH]"" S BGPVALUE=BGPVALUE_"Pneumo: "_$$DATE^BGP4UTL($P(BGPVALH,U,1))_" "_$P(BGPVALH,U,2)_$S(BGPVALH]"":" (ever)",1:"")_" "_$S(BGPN8:" (up-to-date)",1:"")
  1. .S BGPVALUD="AC"_"|||"
  1. .I BGPN4 S BGPVALUD=BGPVALUD_"Pneumo: "_$$DATE^BGP4UTL($P(BGPVALH,U,1))_" "_$P(BGPVALH,U,2)_$S(BGPVALH]"":" (ever)",1:"")_" "
  1. .S BGPVALUD=BGPVALUD_$S(BGPN8:"(up-to-date)",1:"")
  1. TD ;new tdap and td stuff for v11.1
  1. S BGPTDAP=$$DTAP^BGP4D3A(DFN,$$DOB^AUPNPAT(DFN),BGPEDATE)
  1. I BGPTDAP S BGPN9=1
  1. I $P(BGPTDAP,U,1)=2 S BGPN12=1
  1. S BGPTD=$$DTAPTD^BGP4D3A(DFN,$$FMADD^XLFDT(BGPEDATE,-(10*365)),BGPEDATE)
  1. I BGPTD S BGPN10=1
  1. I $P(BGPTD,U,1)=2 S BGPN11=1
  1. I BGPRTYPE=5 G TDE
  1. ;FLU - 14.1
  1. S BGPFLU=$$FLU^BGP4D3(DFN,,BGPEDATE)
  1. I $P(BGPFLU,U,3)=1!($P(BGPFLU,U,3)=3) S BGPN13=1
  1. I $P(BGPFLU,U,3)=3 S BGPN14=1
  1. I BGPN9,BGPN10,BGPN13 S BGPN15=1
  1. I BGPN11!(BGPN12)!(BGPN14) S BGPN16=1
  1. S BGPZOST=$$IZOSTER(DFN,$$DOB^AUPNPAT(DFN),BGPEDATE)
  1. I $P(BGPZOST,U,3)=1!($P(BGPZOST,U,3)=3) S BGPN17=1
  1. I $P(BGPZOST,U,3)=3 S BGPN18=1
  1. I BGPN9,BGPN10,BGPN13,BGPN17 S BGPN19=1
  1. I BGPN11!(BGPN12)!(BGPN14)!(BGPN18) S BGPN20=1
  1. I BGPN9,BGPN10,BGPN13,BGPN17,BGPN8 S BGPN21=1
  1. I BGPN11!(BGPN12)!(BGPN14)!(BGPN18)!(BGPN3) S BGPN22=1
  1. I BGPTDAP S BGPVALUE=BGPVALUE_$S($P(BGPVALUE,"|||",2)]"":"; ",1:""),BGPVALUE=BGPVALUE_"TDAP: "_$P(BGPTDAP,U,2)_" (ever)"
  1. I BGPTD S BGPVALUE=BGPVALUE_$S($P(BGPVALUE,"|||",2)]"":"; ",1:""),BGPVALUE=BGPVALUE_"TDAP/TD: "_$P(BGPTD,U,2)_" (past 10 yrs)"
  1. I BGPFLU S BGPVALUE=BGPVALUE_$S($P(BGPVALUE,"|||",2)]"":"; ",1:""),BGPVALUE=BGPVALUE_"FLU: "_$P(BGPFLU,U,2)_" (past yr)"
  1. I BGPZOST S BGPVALUE=BGPVALUE_$S($P(BGPVALUE,"|||",2)]"":"; ",1:""),BGPVALUE=BGPVALUE_"ZOSTER: "_$P(BGPZOST,U,2)_" (ever)"
  1. I BGPTDAP S BGPVALUD=BGPVALUD_$S($P(BGPVALUD,"|||",2)]"":"; ",1:""),BGPVALUD=BGPVALUD_"TDAP: "_$P(BGPTDAP,U,2)_" (ever)"
  1. I BGPTD S BGPVALUD=BGPVALUD_$S($P(BGPVALUD,"|||",2)]"":"; ",1:""),BGPVALUD=BGPVALUD_"TDAP/TD: "_$P(BGPTD,U,2)_" (past 10 yrs)"
  1. I BGPFLU S BGPVALUD=BGPVALUD_$S($P(BGPVALUD,"|||",2)]"":"; ",1:""),BGPVALUD=BGPVALUD_"FLU: "_$P(BGPFLU,U,2)_" (past yr)"
  1. I BGPZOST S BGPVALUD=BGPVALUD_$S($P(BGPVALUD,"|||",2)]"":"; ",1:""),BGPVALUD=BGPVALUD_"ZOSTER: "_$P(BGPZOST,U,2)_" (ever)"
  1. TDE K BGPLPNU,BGPVAL,BGPA65,BGPVALH,BGPTD,BGPTDAP,BGPFLU
  1. Q
  1. IZOSTER(P,BDATE,EDATE,FORE) ;EP
  1. NEW BGPLPNU,BGPG,X,E
  1. S BGPLPNU=""
  1. S BD=BDATE
  1. S ED=EDATE
  1. S EDATE=$$FMTE^XLFDT(EDATE)
  1. S BDATE=$$FMTE^XLFDT(BDATE)
  1. S X=P_"^LAST IMM 121;DURING "_BDATE_"-"_EDATE S E=$$START1^APCLDF(X,"BGPG(")
  1. I $D(BGPG(1)),$P(BGPLPNU,U,1)<$P(BGPG(1),U) S BGPLPNU=$P(BGPG(1),U,1)_U_"Imm 121"
  1. S %=$$CPT^BGP4DU(P,BD,ED,$O(^ATXAX("B","BGP ZOSTER IZ CPTS",0)),5)
  1. I $P(BGPLPNU,U,1)<$P(%,U,1) S BGPLPNU=$P(%,U,1)_U_"CPT "_$P(%,U,2)
  1. S %=$$TRAN^BGP4DU(P,BD,ED,$O(^ATXAX("B","BGP ZOSTER IZ CPTS",0)),5)
  1. I $P(BGPLPNU,U,1)<$P(%,U,1) S BGPLPNU=$P(%,U,1)_U_"CPT "_$P(%,U,2)
  1. I BGPLPNU]"" Q BGPLPNU_U_1
  1. ;NOW CHECK FOR CONTRAINDICATION (NEW IN 8.0)
  1. F BGPZ=121 S X=$$ANIMCONT^BGP4D31(P,BGPZ,ED)
  1. I X]"" Q X_U_3
  1. ;NMI Refusal
  1. S G=$$NMIREF^BGP4UTL1(P,9999999.14,$O(^AUTTIMM("C",121,0)),$$DOB^AUPNPAT(P),ED)
  1. I $P(G,U)=1 Q $P(G,U,2)_U_"NMI Refusal"_U_3
  1. Q ""
  1. ;