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

BGP8PC65.m

Go to the documentation of this file. 
  1. BGP8PC65 ; 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. VZV(P) ;
  1.  NEW A730,X,Y,Z,TCVX,TCPT,C,BGPIMMS,D,V,BGPZ
  1.  S TCVX=$O(^ATXAX("B","BGP IPC VZV CVX CODES",0))
  1.  S TCPT=$O(^ATXAX("B","BGP IPC VZV 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 VZV"
  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 VZV"
  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=$$ANVZV(P,BGPZ,A730)
  1.  I X]"" Q 1_U_"VZV CONTRA ANAPHYLACTIC/NEOMYCIN"
  1.  S X=$$ANSNVZV(P,A730) I X Q 1_U_"VZV CONTRA ANAPHYLACTIC REACTION"
  1.  S X=$$DIS(P,A730) I X Q 1_U_"VZV CONTRA DIS IMMUNE SYS"
  1.  S X=$$HIV(P,A730) I X Q 1_U_"VZV CONTRA HIV"
  1.  S X=$$MNLHT(P,A730) I X Q 1_U_"VZV CONTRA NEOPLASM"
  1.  S X=$$EVIDVZV(P,A730) I X Q 1_U_"EVIDENCE OF VZV"
  1.  Q ""
  1. ANSNVZV(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. ANVZV(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. EVIDVZV(P,EDATE) ;
  1.  ;is there HEP B evidence
  1.  ;V POV OR PROBLEM LIST
  1.  NEW X,Y,Z,G,T,S,D,E,R,L,J,ME
  1.  I $$PLTAXND^BGP8DU(P,"BGP IPC VARICELLA DXS",EDATE,0) Q 1
  1.  I $$IPLSNOND^BGP8DU(P,"PXRM BGP IPC VZV EVID",EDATE,0) Q 1
  1.  I $$LASTDX^BGP8UTL1(P,"BGP IPC VARICELLA DXS",$$DOB^AUPNPAT(P),EDATE) Q 1
  1.  ;NOW V POV SNOMED
  1.  ;NOW SNOMED USING ASNC
  1.  S T="PXRM BGP IPC VZV EVID"
  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.  I G Q 1
  1. MLT ;
  1.  S E=9999999-EDATE,G="" S D=E-1 F  S D=$O(^AUPNVLAB("AE",P,D)) Q:D'=+D!(G)  D
  1.  .S L=0 F  S L=$O(^AUPNVLAB("AE",P,D,L)) Q:L'=+L!(G)  D
  1.  ..S X=0 F  S X=$O(^AUPNVLAB("AE",P,D,L,X)) Q:X'=+X!(G)  D
  1.  ...Q:'$D(^AUPNVLAB(X,0))
  1.  ...S J=$P($G(^AUPNVLAB(X,11)),U,13) Q:J=""
  1.  ...Q:'$$LOINCVZV(J)
  1.  ...S R=$P(^AUPNVLAB(X,0),U,4)
  1.  ...S R=+R
  1.  ...I R'<1.10 S G=1
  1.  ...Q
  1.  I G Q 1
  1.  Q ""
  1. LOINCVZV(A) ;is this a HEP B 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 %="21595-4" Q 1
  1.  I %="22601-9" Q 1
  1.  I %="22602-7" Q 1
  1.  I %="6569-8" Q 1
  1.  Q ""
  1. DIS(P,EDATE) ;EP
  1.  NEW X,Y,Z,G,T,S,D,E,R,L,J,ME
  1.  I $$PLTAXND^BGP8DU(P,"BGP IPC IMMUNE DISORDERS DXS",EDATE,0) Q 1
  1.  I $$IPLSNOND^BGP8DU(P,"PXRM BGP IPC IMMUNE DIS",EDATE,0) Q 1
  1.  I $$LASTDX^BGP8UTL1(P,"BGP IPC IMMUNE DISORDERS DXS",$$DOB^AUPNPAT(P),EDATE) Q 1
  1.  ;NOW V POV SNOMED
  1.  ;NOW SNOMED USING ASNC
  1.  S T="PXRM BGP IPC IMMUNE DIS"
  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. HIV(P,EDATE) ;EP
  1.  NEW X,Y,Z,G,T,S,D,E,R,L,J,ME
  1.  I $$PLTAXND^BGP8DU(P,"BGP IPC HIV DXS",EDATE,0) Q 1
  1.  I $$IPLSNOND^BGP8DU(P,"PXRM BGP IPC HIV",EDATE,0) Q 1
  1.  I $$LASTDX^BGP8UTL1(P,"BGP IPC HIV DXS",$$DOB^AUPNPAT(P),EDATE) Q 1
  1.  ;NOW V POV SNOMED
  1.  ;NOW SNOMED USING ASNC
  1.  S T="PXRM BGP IPC HIV"
  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. MNLHT(P,EDATE) ;EP
  1.  NEW X,Y,Z,G,T,S,D,E,R,L,J,ME
  1.  I $$PLTAXND^BGP8DU(P,"BGP IPC LYMPHATIC CANCER DXS",EDATE,0) Q 1
  1.  I $$IPLSNOND^BGP8DU(P,"PXRM BGP IPC LYMPH CANCER",EDATE,0) Q 1
  1.  I $$LASTDX^BGP8UTL1(P,"BGP IPC LYMPHATIC CANCER DXS",$$DOB^AUPNPAT(P),EDATE) Q 1
  1.  ;NOW V POV SNOMED
  1.  ;NOW SNOMED USING ASNC
  1.  S T="PXRM BGP IPC LYMPH CANCER"
  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