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

BGP8PC62.m

Go to the documentation of this file. 
  1. BGP8PC62 ; IHS/CMI/LAB - measure I2 ; 02 Feb 2018  11:25 AM
  1.  ;;18.1;IHS CLINICAL REPORTING;**1**;MAY 25, 2018;Build 65
  1.  ;
  1. MMR(P) ;
  1.  NEW A730,X,Y,Z,TCVX,TCPT,C,BGPIMMS,D,V,BGPZ
  1.  S TCVX=$O(^ATXAX("B","BGP IPC MMR CVX CODES",0))
  1.  S TCPT=$O(^ATXAX("B","BGP IPC MMR CPT CODES",0))
  1.  S A730=$$FMADD^XLFDT($$DOB^AUPNPAT(P),730)
  1.  S X=0 F  S X=$O(^AUPNVIMM("AC",P,X)) Q:X'=+X  D
  1.  .Q:'$D(^AUPNVIMM(X,0))  ;happens
  1.  .S Y=$P(^AUPNVIMM(X,0),U)
  1.  .Q:'Y  ;happens too
  1.  .S I=$P($G(^AUTTIMM(Y,0)),U,3)  ;get HL7/CVX code
  1.  .Q:'$D(^ATXAX(TCVX,21,"B",I))
  1.  .S D=$P($P($G(^AUPNVIMM(X,12)),U,1),".")
  1.  .I D="" S V=$P(^AUPNVIMM(X,0),U,3) I V S D=$P($P($G(^AUPNVSIT(V,0)),U),".")
  1.  .Q:D>A730
  1.  .S BGPIMMS(D)=Y
  1.  .Q
  1.  ;go through and set into array if 1 days apart
  1.  S X="",Y="",C=0 F  S X=$O(BGPIMMS(X)) Q:X'=+X  S C=C+1 D
  1.  .I C=1 S Y=X Q
  1.  .I $$FMDIFF^XLFDT(X,Y)<1 K BGPIMMS(X) Q
  1.  .S Y=X
  1.  ;see if there are 1 of them, if there are quit
  1.  S BGPIMMS=0,X=0 F  S X=$O(BGPIMMS(X)) Q:X'=+X  S BGPIMMS=BGPIMMS+1
  1.  I BGPIMMS>0 Q 1_U_"1 MMR"
  1.  ;now get cpts
  1.  S G="",X=0
  1.  F  S X=$O(^AUPNVCPT("AC",P,X)) Q:X=""  D
  1.  .Q:'$D(^AUPNVCPT(X,0))
  1.  .S Y=$P(^AUPNVCPT(X,0),U)
  1.  .Q:'$$ICD^BGP8UTL2(Y,TCPT,1)
  1.  .S V=$P(^AUPNVCPT(X,0),U,3) Q:'V
  1.  .S D=$$VD^APCLV(V)
  1.  .Q:D>A730
  1.  .S BGPIMMS(D)=""
  1.  ;get tran codes
  1.  S X=0 F  S X=$O(^AUPNVTC("AC",P,X)) Q:X'=+X  D
  1.  .Q:'$D(^AUPNVTC(X,0))
  1.  .S Y=$P(^AUPNVTC(X,0),U,7) Q:'Y
  1.  .Q:'$$ICD^BGP8UTL2(Y,TCPT,1)
  1.  .S V=$P(^AUPNVTC(X,0),U,3) Q:'V
  1.  .S D=$$VD^APCLV(V)
  1.  .Q:D>A730
  1.  .S BGPIMMS(D)=""
  1.  ;
  1.  ;go through and set into array if 1 days apart
  1.  S X="",Y="",C=0 F  S X=$O(BGPIMMS(X)) Q:X'=+X  S C=C+1 D
  1.  .I C=1 S Y=X Q
  1.  .I $$FMDIFF^XLFDT(X,Y)<1 K BGPIMMS(X) Q
  1.  .S Y=X
  1.  ;see if there are 3 of them, if there are quit
  1.  S BGPIMMS=0,X=0 F  S X=$O(BGPIMMS(X)) Q:X'=+X  S BGPIMMS=BGPIMMS+1
  1.  I BGPIMMS>0 Q 1_U_"1 MMR"
  1.  ;NOW CHECK FOR CONTRAINDICATION
  1.  ;IMM PKG ANAPHYLACTIS
  1.  S BGPZ=0
  1.  F  S BGPZ=$O(^ATXAX(TCVX,21,"B",BGPZ)) Q:BGPZ=""!(X]"")  D
  1.  .S X=$$ANNECONT(P,BGPZ,A730)
  1.  I X]"" Q 1_U_"MMR CONTRA ANAPHYLACTIC/NEOMYCIN"
  1.  S X=$$ANSNMMR(P,A730) I X Q 1_U_"MMR CONTRA ANAPHYLACTIC REACTION"
  1.  S X=$$DIS^BGP8PC65(P,A730) I X Q 1_U_"MMR CONTRA DIS IMMUNE SYS"
  1.  S X=$$HIV^BGP8PC65(P,A730) I X Q 1_U_"MMR CONTRA HIV"
  1.  S X=$$MNLHT^BGP8PC65(P,A730) I X Q 1_U_"MMR CONTRA NEOPLASM"
  1.  S X=$$EVIDMMR(P,A730) I X Q 1_U_"EVIDENCE OF M/M/R"
  1.  Q ""
  1. ANSNMMR(P,EDATE) ;
  1.  ;V POV OR PROBLEM LIST
  1.  NEW X,Y,Z,G,T,S,D,I
  1.  S (X,Y,I)=0
  1.  F  S X=$O(^AUPNPROB("AC",P,X)) Q:X'=+X!(I)  D
  1.  .Q:'$D(^AUPNPROB(X,0))
  1.  .Q:$P(^AUPNPROB(X,0),U,12)="D"
  1.  .I $P(^AUPNPROB(X,0),U,13),$P(^AUPNPROB(X,0),U,13)>EDATE Q  ;if there is a doo and it is after report period skip
  1.  .I $P(^AUPNPROB(X,0),U,13)="",$P(^AUPNPROB(X,0),U,8)>EDATE Q  ;entered after report period, skip
  1.  .S S=$$VAL^XBDIQ1(9000011,X,80001)
  1.  .I S=292927007 S I=1 Q
  1.  .Q
  1.  I I Q I
  1.  ;NOW V POV SNOMED
  1.  ;NOW SNOMED USING ASNC
  1.  S G="",I=""
  1.  S S="" F  S S=$O(^AUPNVPOV("ASNC",P,S)) Q:S=""!(G)  D
  1.  .S I=0
  1.  .I S=292927007 S I=1
  1.  .Q:'I
  1.  .S D=0 F  S D=$O(^AUPNVPOV("ASNC",P,S,D)) Q:D=""!(G)  D
  1.  ..S Y=9999999-D
  1.  ..Q:Y>EDATE
  1.  ..S G=1
  1.  I G Q G
  1.  ;REFUSAL FILE
  1.  S I="" F  S I=$O(^AUPNPREF("AA",P,9002318.4,I)) Q:I=""!(G)  D
  1.  .I I'=292927007 Q   ;IF IT'S SNOMED, MUST BE THAT ONE
  1.  .S ID=0 F  S ID=$O(^AUPNPREF("AA",P,9002318.4,I,ID)) Q:ID=""!(G)  D
  1.  ..S D=9999999-ID
  1.  ..Q:D>EDATE
  1.  ..S G=1
  1.  Q G
  1. ANNECONT(P,C,ED) ;EP - ANALPHYLAXIS/NEOMYCIN CONTRAINDICATION
  1.  NEW X,G,Y,R,D
  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)="Anaphylaxis" S G=D_U_"Contra Anaphylaxis"
  1.  .I $P(^BICONT(R,0),U,1)="Neomycin Allergy" S G=D_U_"Contra: Neomycin Allergy"
  1.  .I $P(^BICONT(R,0),U,1)="Immune Deficiency" S G=D_U_"Contra: Immune Deficiency"
  1.  Q G
  1. EVIDMMR(P,EDATE) ;
  1.  ;is there measles evidence
  1.  ;V POV OR PROBLEM LIST
  1.  NEW X,Y,Z,G,T,S,D,E,R,L,J,ME,MU,RU
  1.  S (ME,MU,RU)=""
  1.  I $$PLTAXND^BGP8DU(P,"BGP IPC MEASLES DXS",EDATE,0) S ME=1
  1.  I $$IPLSNOND^BGP8DU(P,"PXRM BGP IPC MEASLES EVID",EDATE,0) S ME=1
  1.  I $$LASTDX^BGP8UTL1(P,"BGP IPC MEASLES DXS",$$DOB^AUPNPAT(P),EDATE) S ME=1
  1.  ;NOW V POV SNOMED
  1.  ;NOW SNOMED USING ASNC
  1.  S T="PXRM BGP IPC MEASLES EVID"
  1.  S G=""
  1.  S S=0 F  S S=$O(^XTMP("BGPSNOMEDSUBSET",$J,T,S)) Q:S=""!(ME)  D
  1.  .Q:'$D(^AUPNVPOV("ASNC",P,S))
  1.  .S D=0 F  S D=$O(^AUPNVPOV("ASNC",P,S,D)) Q:D=""!(ME)  D
  1.  ..S Y=9999999-D
  1.  ..Q:Y>EDATE
  1.  ..S ME=1
  1.  I ME G MU
  1.  ;lab tests?
  1. MLT ;
  1.  S E=9999999-EDATE S D=E-1 F  S D=$O(^AUPNVLAB("AE",P,D)) Q:D'=+D!(ME)  D
  1.  .S L=0 F  S L=$O(^AUPNVLAB("AE",P,D,L)) Q:L'=+L!(ME)  D
  1.  ..S X=0 F  S X=$O(^AUPNVLAB("AE",P,D,L,X)) Q:X'=+X!(ME)  D
  1.  ...Q:'$D(^AUPNVLAB(X,0))
  1.  ...S J=$P($G(^AUPNVLAB(X,11)),U,13) Q:J=""
  1.  ...Q:'$$LOINCME(J)
  1.  ...S R=$P(^AUPNVLAB(X,0),U,4)
  1.  ...S R=+R
  1.  ...I R'<1.10 S ME=1
  1.  ...Q
  1.  I 'ME Q ""  ;since no measles and have to have all 3 might as well quit now
  1. MU ;is there evidence of mumps?
  1.  I $$PLTAXND^BGP8DU(P,"BGP IPC MUMPS DXS",EDATE,0) S MU=1
  1.  I $$IPLSNOND^BGP8DU(P,"PXRM BGP IPC MUMPS EVID",EDATE,0) S MU=1
  1.  I $$LASTDX^BGP8UTL1(P,"BGP IPC MUMPS DXS",$$DOB^AUPNPAT(P),EDATE) S MU=1
  1.  ;NOW V POV SNOMED
  1.  ;NOW SNOMED USING ASNC
  1.  S T="PXRM BGP IPC MUMPS EVID"
  1.  S G=""
  1.  S S=0 F  S S=$O(^XTMP("BGPSNOMEDSUBSET",$J,T,S)) Q:S=""!(MU)  D
  1.  .Q:'$D(^AUPNVPOV("ASNC",P,S))
  1.  .S D=0 F  S D=$O(^AUPNVPOV("ASNC",P,S,D)) Q:D=""!(MU)  D
  1.  ..S Y=9999999-D
  1.  ..Q:Y>EDATE
  1.  ..S MU=1
  1.  I MU G RU
  1.  ;lab tests?
  1. MULT ;
  1.  S E=9999999-EDATE S D=E-1 F  S D=$O(^AUPNVLAB("AE",P,D)) Q:D'=+D!(MU)  D
  1.  .S L=0 F  S L=$O(^AUPNVLAB("AE",P,D,L)) Q:L'=+L!(MU)  D
  1.  ..S X=0 F  S X=$O(^AUPNVLAB("AE",P,D,L,X)) Q:X'=+X!(MU)  D
  1.  ...Q:'$D(^AUPNVLAB(X,0))
  1.  ...S J=$P($G(^AUPNVLAB(X,11)),U,13) Q:J=""
  1.  ...Q:'$$LOINCMU(J)
  1.  ...S R=$P(^AUPNVLAB(X,0),U,4)
  1.  ...S R=+R
  1.  ...I R'<1.10 S MU=1
  1.  ...Q
  1.  I 'MU Q ""  ;since no MUMPS and have to have all 3 might as well quit now
  1. RU ;
  1.  ;is there evidence of RUBELLA?
  1.  I $$PLTAXND^BGP8DU(P,"BGP IPC RUBELLA DXS",EDATE,0) S RU=1
  1.  I $$IPLSNOND^BGP8DU(P,"PXRM BGP IPC RUBELLA EVID",EDATE,0) S RU=1
  1.  I $$LASTDX^BGP8UTL1(P,"BGP IPC RUBELLA DXS",$$DOB^AUPNPAT(P),EDATE) S RU=1
  1.  ;NOW V POV SNOMED
  1.  ;NOW SNOMED USING ASNC
  1.  S T="PXRM BGP IPC RUBELLA EVID"
  1.  S G=""
  1.  S S=0 F  S S=$O(^XTMP("BGPSNOMEDSUBSET",$J,T,S)) Q:S=""!(MU)  D
  1.  .Q:'$D(^AUPNVPOV("ASNC",P,S))
  1.  .S D=0 F  S D=$O(^AUPNVPOV("ASNC",P,S,D)) Q:D=""!(MU)  D
  1.  ..S Y=9999999-D
  1.  ..Q:Y>EDATE
  1.  ..S RU=1
  1.  I RU Q 1
  1.  ;lab tests?
  1. RULT ;
  1.  S E=9999999-EDATE S D=E-1 F  S D=$O(^AUPNVLAB("AE",P,D)) Q:D'=+D!(RU)  D
  1.  .S L=0 F  S L=$O(^AUPNVLAB("AE",P,D,L)) Q:L'=+L!(RU)  D
  1.  ..S X=0 F  S X=$O(^AUPNVLAB("AE",P,D,L,X)) Q:X'=+X!(RU)  D
  1.  ...Q:'$D(^AUPNVLAB(X,0))
  1.  ...S J=$P($G(^AUPNVLAB(X,11)),U,13) Q:J=""
  1.  ...Q:'$$LOINCRU(J)
  1.  ...S R=$P(^AUPNVLAB(X,0),U,4)
  1.  ...S R=+R
  1.  ...I R'<1.10 S RU=1
  1.  ...Q
  1.  I 'RU Q ""  ;since no RUBELLA and have to have all 3 might as well quit now
  1.  Q 1
  1. LOINCME(A) ;is this a measles loinc code
  1.  NEW %
  1.  S %=$P($G(^LAB(95.3,A,0)),U)_"-"_$P($G(^LAB(95.3,A,0)),U,15)
  1.  I %="21500-4" Q 1
  1.  I %="21501-2" Q 1
  1.  I %="22501-1" Q 1
  1.  I %="22502-9" Q 1
  1.  Q ""
  1. LOINCMU(A) ;is this a MUMPS loinc code
  1.  NEW %
  1.  S %=$P($G(^LAB(95.3,A,0)),U)_"-"_$P($G(^LAB(95.3,A,0)),U,15)
  1.  I %="21401-5" Q 1
  1.  I %="22416-2" Q 1
  1.  I %="22417-0" Q 1
  1.  I %="6477-4" Q 1
  1.  Q ""
  1. LOINCRU(A) ;is this a RUBELLA loinc code
  1.  NEW %
  1.  S %=$P($G(^LAB(95.3,A,0)),U)_"-"_$P($G(^LAB(95.3,A,0)),U,15)
  1.  I %="41763-4" Q 1
  1.  I %="46110-3" Q 1
  1.  Q ""