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

BGP8D35.m

Go to the documentation of this file. 
  1. BGP8D35 ;IHS/CMI/LAB - MEASURE LOGIC;
  1.  ;;18.1;IHS CLINICAL REPORTING;;MAY 25, 2018;Build 66
  1.  ;
  1. VAR(P,EDATE) ;EP
  1.  NEW BGPC,BGPG,BGPX,BGPVARI,C,ED,BD,G,V,X,Y,BGPZ,B,BGPIMM,R,BGPNMI
  1.  ;gather up all immunizations, cpts, povs and check for 3 each ten days apart
  1.  K BGPVARI
  1.  ;get all immunizations
  1.  S C="21^94"
  1.  D GETIMMS^BGP8D32(P,EDATE,C,.BGPX)
  1.  ;go through and set into array if 10 days apart
  1.  I $O(BGPX(0)) Q 1_U_"Vari"
  1.  ;now get cpts
  1.  S ED=9999999-EDATE-1,BD=9999999-$$DOB^AUPNPAT(P),G=0
  1.  F  S ED=$O(^AUPNVSIT("AA",P,ED)) Q:ED=""!($P(ED,".")>BD)  D
  1.  .S V=0 F  S V=$O(^AUPNVSIT("AA",P,ED,V)) Q:V'=+V  D
  1.  ..Q:'$D(^AUPNVSIT(V,0))
  1.  ..S X=0 F  S X=$O(^AUPNVCPT("AD",V,X)) Q:X'=+X  D
  1.  ...S Y=$P(^AUPNVCPT(X,0),U),Y=$P($$CPT^ICPTCOD(Y),U,2) I Y=90710!(Y=90716) S BGPVARI(9999999-$P(ED,"."))=""
  1.  ..S X=0 F  S X=$O(^AUPNVTC("AD",V,X)) Q:X'=+X  D
  1.  ...S Y=$P(^AUPNVTC(X,0),U,7) Q:'Y  S Y=$P($$CPT^ICPTCOD(Y),U,2) I Y=90710!(Y=90716) S BGPVARI(9999999-$P(ED,"."))=""
  1.  I $D(BGPVARI) Q 1_U_"Vari"
  1.  K BGPG S %=P_"^ALL DX [BGP VARICELLA IZ DXS;DURING "_$$DOB^AUPNPAT(P)_"-"_EDATE,E=$$START1^APCLDF(%,"BGPG(")
  1.  I $D(BGPG(1)) Q 2_U_"Vari"
  1.  ;check for Evidence of desease and Contraindications and if yes, then quit
  1.  K BGPG S %=P_"^LAST DX [BGP VARICELLA EVIDENCE;DURING "_$$DOB^AUPNPAT(P)_"-"_EDATE,E=$$START1^APCLDF(%,"BGPG(")
  1.  I $D(BGPG(1)) Q 4_U_"Evid Vari"
  1.  I $$PLTAXND^BGP8DU(P,"BGP VARICELLA EVIDENCE",EDATE) Q 4_U_"Evid Vari"
  1.  I $$IPLSNOND^BGP8DU(P,"PXRM BGP VARICELLA",EDATE) Q 4_U_"Evid Vari"
  1.  F BGPZ=21,94 S X=$$EVIDVAR(P,BGPZ,EDATE) Q:X]""
  1.  I X]"" Q 4_U_"Evid Vari"
  1.  S BGPZ=$$IMMUNO^BGP8D36(P,EDATE) I BGPZ Q 4_U_"Contra Vari"
  1.  S BGPZ=$$HIVDX^BGP8D24A(P,$$DOB^AUPNPAT(P),EDATE) I BGPZ Q 4_U_"Contra Vari"
  1.  S BGPZ=$$LYMPHO^BGP8D36(P,EDATE) I BGPZ Q 4_U_"Contra Vari"
  1.  F BGPZ=21,94 S X=$$MMRCONT^BGP8D31(P,BGPZ,EDATE) Q:X]""
  1.  I X]"" Q 4_U_"Contra Vari"
  1.  ;now go to Refusals
  1.  S B=$$DOB^AUPNPAT(P),E=EDATE,BGPNMI="",R=""
  1.  F BGPIMM=21,94  D
  1.  .S I=$O(^AUTTIMM("C",BGPIMM,0)) Q:'I
  1.  .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) I $P(^AUPNPREF(Y,0),U,7)="N" S BGPNMI=1 S R=1
  1.  I R Q $S(BGPNMI:4,1:3)_U_$S(BGPNMI:"NMI Vari",1:"Ref Vari")
  1.  F BGPIMM=90710,90716  D
  1.  .S I=+$$CODEN^ICPTCOD(BGPIMM) Q:'I
  1.  .S X=0 F  S X=$O(^AUPNPREF("AA",P,81,I,X)) Q:X'=+X  S Y=0 F  S Y=$O(^AUPNPREF("AA",P,81,I,X,Y)) Q:Y'=+Y  S D=$P(^AUPNPREF(Y,0),U,3) I D'<B&(D'>E) I $P(^AUPNPREF(Y,0),U,7)="N" S BGPNMI=1 S R=1
  1.  I R Q $S(BGPNMI:4,1:3)_U_$S(BGPNMI:"NMI Vari",1:"Ref Vari")
  1.  ;now check Refusals in imm pkg
  1.  ;F BGPIMM=21,94 S R=$$IMMREF^BGP8D32(P,BGPIMM,$$DOB^AUPNPAT(P),EDATE)+R
  1.  ;I R Q 3_U_"Ref imm pkg Vari"
  1.  Q ""
  1. HEP(P,EDATE) ;EP
  1.  NEW BGPC,BGPG,BGPX,BGPHEP,X,ED,BD,G,T,BGP10743,V,Z,Y,C
  1.  S BGP10743=""
  1.  ;get all immunizations
  1.  S C="8^42^43^44^45^51^102^104^110^132^146^189"
  1.  D GETIMMS^BGP8D32(P,EDATE,C,.BGPX)
  1.  ;go through and set into array if 10 days apart
  1.  S X=0 F  S X=$O(BGPX(X)) Q:X'=+X  S BGPHEP(X)=""
  1.  ;now get cpts
  1.  S ED=9999999-EDATE,BD=9999999-$$DOB^AUPNPAT(P),G=0
  1.  S T=$O(^ATXAX("B","BGP HEPATITIS CPTS",0))
  1.  S BGP10743=0 F  S ED=$O(^AUPNVSIT("AA",P,ED)) Q:ED=""!($P(ED,".")>BD)  D
  1.  .S V=0 F  S V=$O(^AUPNVSIT("AA",P,ED,V)) Q:V'=+V  D
  1.  ..Q:'$D(^AUPNVSIT(V,0))
  1.  ..S X=0 F  S X=$O(^AUPNVCPT("AD",V,X)) Q:X'=+X  D
  1.  ...S Y=$P(^AUPNVCPT(X,0),U) S Z=$P($$CPT^ICPTCOD(Y),U,2) S:Z=90743 BGP10743=1 I $$ICD^BGP8UTL2(Y,T,1) S BGPHEP(9999999-$P(ED,"."))=""
  1.  ..S X=0 F  S X=$O(^AUPNVTC("AD",V,X)) Q:X'=+X  D
  1.  ...S Y=$P(^AUPNVTC(X,0),U,7) Q:'Y  S Z=$P($$CPT^ICPTCOD(Y),U,2) S:Z=90743 BGP10743=1 I $$ICD^BGP8UTL2(Y,T,1) S BGPHEP(9999999-$P(ED,"."))=""
  1.  ;now check to see if they are all spaced 10 days apart, if not, kill off the odd ones
  1.  S X="",Y="",C=0 F  S X=$O(BGPHEP(X)) Q:X'=+X  S C=C+1 D
  1.  .I C=1 S Y=X Q
  1.  .I $$FMDIFF^XLFDT(X,Y)<11 K BGPHEP(X) Q
  1.  .S Y=X
  1.  ;now count them and see if there are 4 of them
  1.  S BGPHEP=0,X=0 F  S X=$O(BGPHEP(X)) Q:X'=+X  S BGPHEP=BGPHEP+1
  1.  ;I '$G(BGPADOL),BGPHEP=3,BGP10743 G I
  1.  I BGPHEP>2 Q 1_U_"3 Hep B"
  1. I I BGPHEP=2,BGP10743,$G(BGPADOL) Q 1_U_" 3 Hep B"
  1.  ;check for Evidence of desease and Contraindications and if yes, then quit
  1.  K BGPG S %=P_"^LAST DX [BGP HEP EVIDENCE;DURING "_$$DOB^AUPNPAT(P)_"-"_EDATE,E=$$START1^APCLDF(%,"BGPG(")
  1.  I $D(BGPG(1)) Q 4_U_"Evid Hep B"
  1.  I $$PLTAXND^BGP8DU(P,"BGP HEP EVIDENCE",EDATE) Q 4_U_"Evid Hep B"
  1.  I $$IPLSNOND^BGP8DU(P,"PXRM BGP HEPATITIS B",EDATE) Q 4_U_"Evid Hep B"
  1.  ;now go to Refusals
  1.  S B=$$DOB^AUPNPAT(P),E=EDATE,BGPNMI="",R=""
  1.  F BGPIMM="8",42,43,44,45,51,102,104,110,132,146,189  D
  1.  .S I=$O(^AUTTIMM("C",BGPIMM,0)) Q:'I
  1.  .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) I $P(^AUPNPREF(Y,0),U,7)="N" S BGPNMI=1 S R=1
  1.  I R Q $S(BGPNMI:4,1:3)_U_$S(BGPNMI:"NMI",1:"Ref")_" Hep B"
  1.  S R=$$CPTREFT^BGP8UTL1(P,$$DOB^AUPNPAT(P),EDATE,$O(^ATXAX("B","BGP HEPATITIS CPTS",0)))
  1.  I R,$P(R,U,3)="N" S BGPNMI=1 Q $S(BGPNMI:4,1:3)_U_$S(BGPNMI:"NMI",1:"Ref")_" Hep B"
  1.  ;now check Refusals in imm pkg
  1.  ;F BGPIMM=8,42,43,44,45,51,102,104,110,132,146 S R=$$IMMREF^BGP8D32(P,BGPIMM,$$DOB^AUPNPAT(P),EDATE)+R
  1.  ;I R Q $S(BGPNMI:4,1:3)_U_$S(BGPNMI:"NMI",1:"Ref")_" Hep B"
  1.  F BGPZ=8,42,43,44,45,51,102,104,110,132,146,189 S X=$$ANCONT^BGP8D31(P,BGPZ,EDATE) Q:X]""  ;cmi/maw 12/17/07 missing edate
  1.  I X]"" Q 4_U_"Contra Hep B"
  1.  Q ""
  1. HIB(P,EDATE) ;EP
  1.  K BGPC,BGPG,BGPX
  1.  K BGPHIB,BGPAHIB
  1.  ;get all immunizations
  1.  S C="17^22^46^47^48^49^50^51^102^120^132^146"
  1.  D GETIMMS^BGP8D32(P,EDATE,C,.BGPX)
  1.  S X=0 F  S X=$O(BGPX(X)) Q:X'=+X  S BGPHIB(X)="",BGPAHIB(X)=""
  1.  ;now get cpts
  1.  S ED=9999999-EDATE,BD=9999999-$$DOB^AUPNPAT(P),G=0
  1.  F  S ED=$O(^AUPNVSIT("AA",P,ED)) Q:ED=""!($P(ED,".")>BD)  D
  1.  .S V=0 F  S V=$O(^AUPNVSIT("AA",P,ED,V)) Q:V'=+V  D
  1.  ..Q:'$D(^AUPNVSIT(V,0))
  1.  ..S X=0 F  S X=$O(^AUPNVCPT("AD",V,X)) Q:X'=+X  D
  1.  ...S Y=$P(^AUPNVCPT(X,0),U),Y=$P($$CPT^ICPTCOD(Y),U,2) I Y=90645!(Y=90646)!(Y=90647)!(Y=90648)!(Y=90698)!(Y=90720)!(Y=90721)!(Y=90748)!(Y=90737) S BGPHIB(9999999-$P(ED,"."))="",BGPAHIB(9999999-$P(ED,"."))=""
  1.  ..S X=0 F  S X=$O(^AUPNVTC("AD",V,X)) Q:X'=+X  D
  1.  ...S Y=$P(^AUPNVTC(X,0),U,7) Q:'Y  S Y=$P($$CPT^ICPTCOD(Y),U,2) I Y=90645!(Y=90646)!(Y=90647)!(Y=90648)!(Y=90698)!(Y=90720)!(Y=90721)!(Y=90748)!(Y=90737) S BGPHIB(9999999-$P(ED,"."))="",BGPAHIB(9999999-$P(ED,"."))=""
  1.  ;now check to see if they are all spaced 10 days apart, if not, kill off the odd ones
  1.  S X="",Y="",C=0 F  S X=$O(BGPHIB(X)) Q:X'=+X  S C=C+1 D
  1.  .I C=1 S Y=X Q
  1.  .I $$FMDIFF^XLFDT(X,Y)<11 K BGPHIB(X) Q
  1.  .S Y=X
  1.  ;now count them and see if there are 4 of them
  1.  S BGPHIB=0,X=0 F  S X=$O(BGPHIB(X)) Q:X'=+X  S BGPHIB=BGPHIB+1
  1.  I BGPHIB>2 Q 1_U_"3 Hib"
  1.  ;now get povs
  1.  K BGPHIB M BGPHIB=BGPAHIB
  1.  K BGPG S %=P_"^ALL DX [BGP HIB IZ DXS;DURING "_$$DOB^AUPNPAT(P)_"-"_EDATE,E=$$START1^APCLDF(%,"BGPG(")
  1.  I $D(BGPG(1)) S X=0 F  S X=$O(BGPG(X)) Q:X'=+X  S BGPHIB($P(BGPG(X),U))="",BGPAHIB($P(BGPG(X),U))=""
  1.  ;now check to see if they are all spaced 10 days apart, if not, kill off the odd ones
  1.  S X="",Y="",C=0 F  S X=$O(BGPHIB(X)) Q:X'=+X  S C=C+1 D
  1.  .I C=1 S Y=X Q
  1.  .I $$FMDIFF^XLFDT(X,Y)<11 K BGPHIB(X) Q
  1.  .S Y=X
  1.  ;now count them and see if there are 4 of them
  1.  S BGPHIB=0,X=0 F  S X=$O(BGPHIB(X)) Q:X'=+X  S BGPHIB=BGPHIB+1
  1.  I BGPHIB>2 Q 2_U_"3 Hib"
  1.  ;check for Evidence of desease and Contraindications and if yes, then quit
  1.  ;
  1.  ;now go to Refusals
  1.  S B=$$DOB^AUPNPAT(P),E=EDATE,BGPNMI="",R=""
  1.  F BGPIMM=22,46,47,48,49,50,51,102,120,132,146 D
  1.  .S I=$O(^AUTTIMM("C",BGPIMM,0)) Q:'I
  1.  .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) S:$P(^AUPNPREF(Y,0),U,7)="N" BGPNMI=1 S R=1
  1.  I R Q $S(BGPNMI:4,1:3)_U_$S(BGPNMI:"NMI",1:"Ref")_" Hib"
  1.  S R=$$CPTREFT^BGP8UTL1(P,$$DOB^AUPNPAT(P),EDATE,$O(^ATXAX("B","BGP HIB CPT",0)))
  1.  I R S:$P(R,U,3)="N" BGPNMI=1 Q $S(BGPNMI:4,1:3)_U_$S(BGPNMI:"NMI",1:"Ref")_" Hib"
  1.  ;now check Refusals in imm pkg
  1.  F BGPIMM=17,22,46,47,48,49,50,51,102,120,132,146 S R=$$IMMREF^BGP8D32(P,BGPIMM,$$DOB^AUPNPAT(P),EDATE)+R
  1.  I R Q $S(BGPNMI:4,1:3)_U_$S(BGPNMI:"NMI",1:"Ref")_" Hib"
  1.  F BGPZ=17,22,46,47,48,49,50,51,102,120,132,146 S X=$$ANCONT^BGP8D31(P,BGPZ,EDATE) Q:X]""  ;cmi/maw 12/17/07 missing edate
  1.  I X]"" Q 4_U_"Contra Hib"
  1.  Q ""
  1. PNEUMO(P,EDATE,MINN) ;EP
  1.  K BGPC,BGPG,BGPX
  1.  ;gather up all immunizations, cpts, povs and check for 3 each ten days apart
  1.  K BGPPNU,BGPAPNU
  1.  ;get all immunizations
  1.  S C="33^100^109^133^152"
  1.  D GETIMMS^BGP8D32(P,EDATE,C,.BGPX)
  1.  S X=0 F  S X=$O(BGPX(X)) Q:X'=+X  S BGPPNU(X)="",BGPAPNU(X)=""
  1.  ;now get cpts
  1.  S ED=9999999-EDATE,BD=9999999-$$DOB^AUPNPAT(P),G=0
  1.  F  S ED=$O(^AUPNVSIT("AA",P,ED)) Q:ED=""!($P(ED,".")>BD)  D
  1.  .S V=0 F  S V=$O(^AUPNVSIT("AA",P,ED,V)) Q:V'=+V  D
  1.  ..Q:'$D(^AUPNVSIT(V,0))
  1.  ..S X=0 F  S X=$O(^AUPNVCPT("AD",V,X)) Q:X'=+X  D
  1.  ...S Y=$P(^AUPNVCPT(X,0),U),Y=$P($$CPT^ICPTCOD(Y),U,2) I $$ICD^BGP8UTL2($P(^AUPNVCPT(X,0),U),$O(^ATXAX("B","BGP PNEUMO IZ CPTS",0)),1) S BGPPNU(9999999-$P(ED,"."))="",BGPAPNU(9999999-$P(ED,"."))=""
  1.  ..S X=0 F  S X=$O(^AUPNVTC("AD",V,X)) Q:X'=+X  D
  1.  ...S Y=$P(^AUPNVTC(X,0),U,7) Q:'Y  S Y=$P($$CPT^ICPTCOD(Y),U,2) I $$ICD^BGP8UTL2($P(^AUPNVTC(X,0),U),$O(^ATXAX("B","BGP PNEUMO IZ CPTS",0)),1) S BGPPNU(9999999-$P(ED,"."))="",BGPAPNU(9999999-$P(ED,"."))=""
  1.  ;now check to see if they are all spaced 10 days apart, if not, kill off the odd ones
  1.  S X="",Y="",C=0 F  S X=$O(BGPPNU(X)) Q:X'=+X  S C=C+1 D
  1.  .I C=1 S Y=X Q
  1.  .I $$FMDIFF^XLFDT(X,Y)<11 K BGPPNU(X) Q
  1.  .S Y=X
  1.  ;now count them and see if there are 4 of them
  1.  S BGPPNU=0,X=0 F  S X=$O(BGPPNU(X)) Q:X'=+X  S BGPPNU=BGPPNU+1
  1.  I BGPPNU>(MINN-1) Q 1_U_MINN_" Pneumo"
  1.  ;now get povs
  1.  K BGPPNU M BGPPNU=BGPAPNU
  1.  K BGPG S %=P_"^ALL DX [BGP PNEUMO IZ DXS;DURING "_$$DOB^AUPNPAT(P)_"-"_EDATE,E=$$START1^APCLDF(%,"BGPG(")
  1.  I $D(BGPG(1)) S X=0 F  S X=$O(BGPG(X)) Q:X'=+X  S BGPPNU($P(BGPG(X),U))="",BGPAPNU($P(BGPG(X),U))=""
  1.  ;now check to see if they are all spaced 10 days apart, if not, kill off the odd ones
  1.  S X="",Y="",C=0 F  S X=$O(BGPPNU(X)) Q:X'=+X  S C=C+1 D
  1.  .I C=1 S Y=X Q
  1.  .I $$FMDIFF^XLFDT(X,Y)<11 K BGPPNU(X) Q
  1.  .S Y=X
  1.  ;now count them and see if there are 4 of them
  1.  S BGPPNU=0,X=0 F  S X=$O(BGPPNU(X)) Q:X'=+X  S BGPPNU=BGPPNU+1
  1.  I BGPPNU>(MINN-1) Q 2_U_MINN_" Pneumo/DX"
  1.  ;now go to Refusals
  1.  S B=$$DOB^AUPNPAT(P),E=EDATE,BGPNMI="",R=""
  1.  F BGPIMM=33,100,109,133,152 D
  1.  .S I=$O(^AUTTIMM("C",BGPIMM,0)) Q:'I
  1.  .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) I $P(^AUPNPREF(Y,0),U,7)="N" S BGPNMI=1 S R=1
  1.  I R Q $S(BGPNMI:4,1:3)_U_$S(BGPNMI:"NMI",1:"Ref")_" Pneumo"
  1.  S R=$$CPTREFT^BGP8UTL1(P,$$DOB^AUPNPAT(P),EDATE,$O(^ATXAX("B","BGP PNEUMO IZ CPTS",0)),"N")
  1.  I R,$P(R,U,3)="N" S BGPNMI=1 Q $S(BGPNMI:4,1:3)_U_$S(BGPNMI:"NMI",1:"Ref")_" Pneumo"
  1.  ;now check Refusals in imm pkg
  1.  ;F BGPIMM=33,100,109,133 S R=$$IMMREF^BGP8D32(P,BGPIMM,$$DOB^AUPNPAT(P),EDATE)+R
  1.  ;I R Q $S(BGPNMI:4,1:3)_U_$S(BGPNMI:"NMI",1:"Ref")_" Pneumo"
  1.  F BGPZ=33,100,109,133,152 S X=$$ANCONT^BGP8D31(P,BGPZ,EDATE) Q:X]""  ;cmi/maw 12/17/07 missing edate
  1.  I X]"" Q 4_U_"Contra Pneumo"
  1.  Q ""
  1. EVIDVAR(P,C,ED) ;EP - HX CHICKEN POX, IMMUNE
  1.  NEW X
  1.  S X=0,G="",Y=$O(^AUTTIMM("C",C,0)) I Y F  S X=$O(^BIPC("AC",P,Y,X)) Q:X'=+X!(G)  D
  1.  .S R=$P(^BIPC(X,0),U,3)
  1.  .Q:R=""
  1.  .Q:'$D(^BICONT(R,0))
  1.  .S D=$P(^BIPC(X,0),U,4)
  1.  .Q:D=""
  1.  .;Q:$P(^BIPC(X,0),U,4)<BD
  1.  .Q:$P(^BIPC(X,0),U,4)>ED
  1.  .I $P(^BICONT(R,0),U,1)="Hx of Chicken Pox" S G=D_U_"Contra: Hx of Chicken Pox"
  1.  .I $P(^BICONT(R,0),U,1)="Immune" S G=D_U_"Contra: Immune"
  1.  Q G