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

BGP8PC68.m

Go to the documentation of this file. 
  1. BGP8PC68 ; 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. ROTA(P) ;
  1.  NEW A42,A730,X,Y,Z,TCVX,TCPT,C,BGPIMMS,D,V,BGPZ
  1.  S TCVX=$O(^ATXAX("B","BGP IPC ROTA 2 DOSE CVX CODES",0))
  1.  S TCPT=$O(^ATXAX("B","BGP IPC ROTA 2 DOSE CPT CODES",0))
  1.  S A42=$$FMADD^XLFDT($$DOB^AUPNPAT(P),42)
  1.  S A730=$$FMADD^XLFDT($$DOB^AUPNPAT(P),730)
  1.  ;FIRST GET 2 DOSE
  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<A42
  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 4 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>1 Q 1_U_"2 2-DOSE ROTA"
  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<A42
  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<A42
  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 2 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>1 Q 1_U_"2 2-DOSE ROTA"
  1. D3 ;now add in 3 dose and make sure there are 3
  1.  S TCVX=$O(^ATXAX("B","BGP IPC ROTA 3 DOSE CVX CODES",0))
  1.  S TCPT=$O(^ATXAX("B","BGP IPC ROTA 3 DOSE CPT CODES",0))
  1.  S A42=$$FMADD^XLFDT($$DOB^AUPNPAT(P),42)
  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<A42
  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 4 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>3 Q 1_U_"3 DOSE ROTA"
  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<A42
  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<A42
  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 2 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>2 Q 1_U_"3 DOSE ROTA"
  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_"ROTA CONTRA ANAPHYLACTIC/IMMUNE DEF"
  1.  S X=$$ANSNROTA(P,A730) I X Q 1_U_"ROTA CONTRA ANAPHYLACTIC REACTION"
  1.  S X=$$SCID(P,A730) I X Q 1_U_"ROTA CONTRA SCID"
  1.  S X=$$INTUSS(P,A730) I X Q 1_U_"ROTA CONTRA INTUSSUSCEPTION"
  1.  Q ""
  1. ANSNROTA(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=428331000124103 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=428331000124103 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'=428331000124103 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
  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)="Immune Deficiency" S G=D_U_"Contra: Immune Deficiency"
  1.  Q G
  1. SCID(P,EDATE) ;EP
  1.  NEW X,Y,Z,G,T,S,D,E,R,L,J,ME
  1.  I $$PLTAXND^BGP8DU(P,"BGP IPC SCID DXS",EDATE,0) Q 1
  1.  I $$IPLSNOND^BGP8DU(P,"PXRM BGP IPC SCID",EDATE,0) Q 1
  1.  I $$LASTDX^BGP8UTL1(P,"BGP IPC SCID DXS",$$DOB^AUPNPAT(P),EDATE) Q 1
  1.  ;NOW V POV SNOMED
  1.  ;NOW SNOMED USING ASNC
  1.  S T="PXRM BGP IPC SCID"
  1.  S G=""
  1.  S S=0 F  S S=$O(^XTMP("BGPSNOMEDSUBSET",$J,T,S)) Q:S=""!(G)  D
  1.  .Q:'$D(^AUPNVPOV("ASNC",P,S))
  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.  Q G
  1. INTUSS(P,EDATE) ;EP
  1.  NEW X,Y,Z,G,T,S,D,E,R,L,J,ME
  1.  I $$PLTAXND^BGP8DU(P,"BGP IPC INTUSSUSCEPTION DXS",EDATE,0) Q 1
  1.  I $$IPLSNOND^BGP8DU(P,"PXRM BGP IPC INTUSSUS",EDATE,0) Q 1
  1.  I $$LASTDX^BGP8UTL1(P,"BGP IPC INTUSSUSCEPTION DXS",$$DOB^AUPNPAT(P),EDATE) Q 1
  1.  ;NOW V POV SNOMED
  1.  ;NOW SNOMED USING ASNC
  1.  S T="PXRM BGP IPC INTUSSUS"
  1.  S G=""
  1.  S S=0 F  S S=$O(^XTMP("BGPSNOMEDSUBSET",$J,T,S)) Q:S=""!(G)  D
  1.  .Q:'$D(^AUPNVPOV("ASNC",P,S))
  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.  Q G