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

BGP4D84.m

Go to the documentation of this file. 
  1. BGP4D84 ; IHS/CMI/LAB - measure C ;
  1.  ;;14.1;IHS CLINICAL REPORTING;;MAY 29, 2014;Build 114
  1.  ;
  1. HEDURI ;EP
  1.  S (BGPN1,BGPN2,BGPN3,BGPN4,BGPN5,BGPN6,BGPD1,BGPD2,BGPD3,BGPD4,BGPD5,BGPD6,BGPD7,BGPD8,BGPD9,BGPD10,BGPD11,BGPD12)=0
  1.  I 'BGPACTUP S BGPSTOP=1 Q
  1.  S A=$$FMDIFF^XLFDT($$FMADD^XLFDT(BGPBDATE,-182),$P(^DPT(DFN,0),U,3))
  1.  I A<91 S BGPSTOP=1 Q  ;less than 3 months old
  1.  ;S A=$$AGE^AUPNPAT(DFN,$$FMADD^XLFDT(BGPBDATE,-180))
  1.  ;I A<2 S BGPSTOP=1  ;must be at least 2
  1.  S A=$$AGE^AUPNPAT(DFN,$$FMADD^XLFDT(BGPBDATE,182))
  1.  I A>18 S BGPSTOP=1 Q   ;must not be older than 18 on this date
  1.  S BGPDN=$$URI(DFN,$$FMADD^XLFDT(BGPBDATE,-182),$$FMADD^XLFDT(BGPBDATE,182)) I 'BGPDN S BGPSTOP=1 Q  ;no URI DX
  1.  I BGPACTCL S BGPD1=1
  1.  I BGPACTUP S BGPD2=1
  1.  S BGPN=$$CANTI(DFN,BGPDN,$$FMADD^XLFDT(BGPDN,3))
  1.  S BGPN1=$S('$P(BGPN,U):1,1:0)
  1.  S BGPVALUE=$S(BGPRTYPE'=3:"UP",1:"")_$S(BGPD1:",AC",1:"")_"|||"_$P(BGPN,U,2)_" "_$P(BGPN,U,3)_$S(BGPN1:" MEETS MEASURE",1:"DOES NOT MEET MEASURE")
  1.  K A,B,C,D,E,F,G,H,I,J,K,M,N,O,P,Q,R,S,T,V,W,X,Y,Z,BDATE,EDATE,BGPDN,BGPN,BGPG,BGPC
  1.  K ^TMP($J,"A")
  1.  Q
  1.  ;
  1. URI(P,BDATE,EDATE) ;
  1.  NEW BGPG,Y,X,G,V,E,C,H
  1.  S Y="BGPG("
  1.  S X=P_"^ALL DX [BGP URI DXS;DURING "_BDATE_"-"_EDATE S E=$$START1^APCLDF(X,Y)
  1.  I '$D(BGPG(1)) Q 0
  1.  S X=0,G=0 F  S X=$O(BGPG(X)) Q:X'=+X!(G)  D
  1.  .S V=$P(BGPG(X),U,5)
  1.  .Q:'$D(^AUPNVSIT(V,0))
  1.  .I "ASO"'[$P(^AUPNVSIT(V,0),U,7) Q  ;not outpatient
  1.  .S (C,E)=0 F  S E=$O(^AUPNVPOV("AD",V,E)) Q:E'=+E  S C=C+1
  1.  .Q:C>1  ;can't have any other diagnoses
  1.  .I $$CLINIC^APCLV(V,"C")=30 D  Q:H  ;if H is 1 then there was a hosp stay so don't use this visit
  1.  ..S H=0
  1.  ..S E=$O(^AUPNVER("AD",V,0)) I E,"ATLM"[$P($G(^AUPNVER(E,0)),U,11) S H=1 Q  ;er visit with admission
  1.  ..S H=$$HOSPURI(P,$P($P(^AUPNVSIT(V,0),U),"."))
  1.  .;NOW CHECK FOR ITEM #4 - NO NEW OR REFILL OF ANTIBIOTICS 30 DAYS PRIOR
  1.  .S BGPD=$P($P(^AUPNVSIT(V,0),U),".")
  1.  .Q:$$NEWRFA(P,$$FMADD^XLFDT(BGPD,-30),$$FMADD^XLFDT(BGPD,-1))
  1.  .Q:$$ACTA(P,$$FMADD^XLFDT(BGPD,-30),$$FMADD^XLFDT(BGPD,-1))
  1.  .;Q:'$$CANTI(P,BGPD,$$FMADD^XLFDT(BGPD,3))
  1.  .S G=BGPD
  1.  .Q
  1.  Q G
  1. NDC(A,B) ;
  1.  ;a is drug ien
  1.  ;b is taxonomy ien
  1.  NEW BGPNDC
  1.  S BGPNDC=$P($G(^PSDRUG(A,2)),U,4)
  1.  I BGPNDC]"",B,$D(^ATXAX(B,21,"B",BGPNDC)) Q 1
  1.  Q 0
  1. NEWRFA(P,BDATE,EDATE) ;
  1.  K ^TMP($J,"A")
  1.  NEW A,B,E,Z,X,D,V,Y,G,M,T,T1
  1.  K BGPMEDS1
  1.  D GETMEDS^BGP4UTL2(P,BDATE,EDATE,,,,,.BGPMEDS1)
  1.  I '$D(BGPMEDS1) G NEWFRAP
  1.  S T1=$O(^ATXAX("B","BGP HEDIS ANTIBIOTICS MEDS",0))
  1.  S T4=$O(^ATXAX("B","BGP HEDIS ANTIBIOTICS NDC",0))
  1.  S (X,G,M,E)=0,D="" F  S X=$O(BGPMEDS1(X)) Q:X'=+X!(D)  S V=$P(BGPMEDS1(X),U,5),Y=+$P(BGPMEDS1(X),U,4) D
  1.  .Q:'$D(^AUPNVSIT(V,0))
  1.  .S Z=$P($G(^AUPNVMED(Y,0)),U) ;get drug ien
  1.  .I $D(^ATXAX(T1,21,"B",Z))!($$NDC(Z,T4)),$P(^AUPNVMED(Y,0),U,8)="" S D=1
  1.  K ^TMP($J,"A")
  1.  I D Q D
  1. NEWFRAP ;check V PROCEDURE
  1.  S D=$$LASTPRC^BGP4UTL1(P,"BGP INJECTION ANTIBIOTIC PROCS",BDATE,EDATE)
  1.  Q $P(D,U)
  1. CANTI(P,BDATE,EDATE) ;
  1.  K ^TMP($J,"A")
  1.  NEW A,B,E,Z,X,D,V,Y,G,M,T,T1
  1.  K BGPMEDS1
  1.  D GETMEDS^BGP4UTL2(P,BDATE,EDATE,,,,,.BGPMEDS1)
  1.  I '$D(BGPMEDS1) G CANTIP
  1.  S T1=$O(^ATXAX("B","BGP HEDIS ANTIBIOTICS MEDS",0))
  1.  S T4=$O(^ATXAX("B","BGP HEDIS ANTIBIOTICS NDC",0))
  1.  S (X,G,M,E)=0,D="" F  S X=$O(BGPMEDS1(X)) Q:X'=+X!(D)  S V=$P(BGPMEDS1(X),U,5),Y=+$P(BGPMEDS1(X),U,4) D
  1.  .Q:'$D(^AUPNVSIT(V,0))
  1.  .S Z=$P($G(^AUPNVMED(Y,0)),U) ;get drug ien
  1.  .Q:$$UP^XLFSTR($P($G(^AUPNVMED(Y,11)),U))["RETURNED TO STOCK"
  1.  .I $D(^ATXAX(T1,21,"B",Z))!($$NDC(Z,T4)) S D=1_U_"antibiotic: "_$$DATE^BGP4UTL($P($P(^AUPNVSIT(V,0),U),"."))
  1.  K ^TMP($J,"A")
  1.  I D Q D
  1. CANTIP ;check V PROCEDURE
  1.  S D=$$LASTPRC^BGP4UTL1(P,"BGP INJECTION ANTIBIOTIC PROCS",BDATE,EDATE)
  1.  Q $P(D,U)_$S(D:"^antibiotic injection: "_$$DATE^BGP4UTL($P(D,U,3)),1:"")
  1. ACTA(P,BDATE,EDATE) ;
  1.  K ^TMP($J,"A")
  1.  NEW A,B,E,Z,X,D,V,Y,G,M,T,T1
  1.  K BGPMEDS1
  1.  D GETMEDS^BGP4UTL2(P,BDATE,EDATE,,,,,.BGPMEDS1)
  1.  I '$D(BGPMEDS1) G ACTAP
  1.  S T1=$O(^ATXAX("B","BGP HEDIS ANTIBIOTICS MEDS",0))
  1.  S T4=$O(^ATXAX("B","BGP HEDIS ANTIBIOTICS NDC",0))
  1.  S (X,G,M,E)=0,D="" F  S X=$O(BGPMEDS1(X)) Q:X'=+X!(D)  S V=$P(BGPMEDS1(X),U,5),Y=+$P(BGPMEDS1(X),U,4) D
  1.  .Q:'$D(^AUPNVSIT(V,0))
  1.  .S Z=$P($G(^AUPNVMED(Y,0)),U) ;get drug ien
  1.  .S B=$$FMDIFF^XLFDT(EDATE,$P($P(^AUPNVSIT(V,0),U),"."))
  1.  .I $D(^ATXAX(T1,21,"B",Z))!($$NDC(Z,T4)),$P(^AUPNVMED(Y,0),U,8)="" I $P(^AUPNVMED(Y,0),U,6)'<B S D=1
  1.  K ^TMP($J,"A")
  1.  I D Q D
  1. ACTAP ;check V PROCEDURE
  1.  S D=$$LASTPRC^BGP4UTL1(P,"BGP INJECTION ANTIBIOTIC PROCS",$$FMADD^XLFDT(EDATE,-30),$$FMADD^XLFDT(EDATE,-1))
  1.  Q $P(D,U)_$S(D:"^antibiotic injection: "_$$DATE^BGP4UTL($P(D,U,3)),1:"")
  1. HOSPURI(P,D) ;is there a hosp with pharyngitis on date D or 1 day later
  1.  S (I,J,K,Q)=0
  1.  F  S I=$O(^AUPNVSIT("AAH",P,I)) Q:I'=+I  D
  1.  .S J=0 F  S J=$O(^AUPNVSIT("AAH",P,I,J)) Q:J'=+J  D
  1.  ..Q:'$D(^AUPNVSIT(J,0))
  1.  ..S K=$P($P(^AUPNVSIT(J,0),U),".")
  1.  ..I K<D Q  ;before outpatient visit
  1.  ..I K>$$FMADD^XLFDT(D,1) Q  ;more than 1 day after outpatient visit date
  1.  ..;now must have a pharyngitis dx
  1.  ..S (R,S,T)=0
  1.  ..F  S R=$O(^AUPNVPOV("AD",J,R)) Q:R'=+R  D
  1.  ...S T=$P($G(^AUPNVPOV(R,0)),U)
  1.  ...Q:T=""
  1.  ...S T=$P($$ICDDX^BGP4UTL2(T),U,2)
  1.  ...Q:T=""
  1.  ...Q:'$$ICD^BGP4UTL2(T,$O(^ATXAX("B","BGP URI DXS",0)),9)
  1.  ...S S=1
  1.  ..Q:'S
  1.  ..S Q=1
  1.  .Q
  1.  Q Q
  1. STREP(P,BDATE,EDATE) ;EP
  1.  K BGPC
  1.  S BGPC=0
  1.  S %=$$CPT^BGP4DU(P,BDATE,EDATE,$O(^ATXAX("B","BGP GROUP A STREP CPT",0)))
  1.  I %]"" Q 1_U_%
  1.  S %=$$TRAN^BGP4DU(P,BDATE,EDATE,$O(^ATXAX("B","BGP GROUP A STREP CPT",0)))
  1.  I %]"" Q 1_U_%
  1.  ;now get all loinc/taxonomy tests
  1.  S T=$O(^ATXAX("B","BGP GROUP A STREP LOINC",0))
  1.  S BGPLT=$O(^ATXLAB("B","BGP GROUP A STREP TESTS",0))
  1.  S B=9999999-BDATE,E=9999999-EDATE S D=E-1 F  S D=$O(^AUPNVLAB("AE",P,D)) Q:D'=+D!(D>B)!($P(BGPC,U))  D
  1.  .S L=0 F  S L=$O(^AUPNVLAB("AE",P,D,L)) Q:L'=+L!($P(BGPC,U))  D
  1.  ..S X=0 F  S X=$O(^AUPNVLAB("AE",P,D,L,X)) Q:X'=+X!($P(BGPC,U))  D
  1.  ...Q:'$D(^AUPNVLAB(X,0))
  1.  ...I BGPLT,$P(^AUPNVLAB(X,0),U),$D(^ATXLAB(BGPLT,21,"B",$P(^AUPNVLAB(X,0),U))) S BGPC=1_U_(9999999-D)_U_"LAB" Q
  1.  ...Q:'T
  1.  ...S J=$P($G(^AUPNVLAB(X,11)),U,13) Q:J=""
  1.  ...Q:'$$LOINC^BGP4D21(J,T)
  1.  ...S BGPC=1_U_(9999999-D)_U_"LOINC"
  1.  ...Q
  1.  I BGPC Q BGPC
  1.  ;now check v microbiology
  1.  S B=9999999-BDATE,E=9999999-EDATE S D=E-1 F  S D=$O(^AUPNVMIC("AE",P,D)) Q:D'=+D!(D>B)!($P(BGPC,U))  D
  1.  .S L=0 F  S L=$O(^AUPNVMIC("AE",P,D,L)) Q:L'=+L!($P(BGPC,U))  D
  1.  ..S X=0 F  S X=$O(^AUPNVMIC("AE",P,D,L,X)) Q:X'=+X!($P(BGPC,U))  D
  1.  ...Q:'$D(^AUPNVMIC(X,0))
  1.  ...I BGPLT,$P(^AUPNVMIC(X,0),U),$D(^ATXLAB(BGPLT,21,"B",$P(^AUPNVMIC(X,0),U))) S BGPC=1_U_(9999999-D)_U_"MICRO" Q
  1.  ...Q:'T
  1.  ...S J=$P($G(^AUPNVMIC(X,11)),U,13) Q:J=""
  1.  ...Q:'$$LOINC^BGP4D21(J,T)
  1.  ...S BGPC=1_U_(9999999-D)_U_"MICRO LOINC"
  1.  ...Q
  1.  Q BGPC
  1. HEPC ;
  1.  S (BGPN1,BGPD1)=0
  1.  NEW BGPHSCR
  1.  I 'BGPACTUP S BGPSTOP=1 Q
  1.  Q:$$DOB^AUPNPAT(DFN)<2450101
  1.  Q:$$DOB^AUPNPAT(DFN)>2651231
  1.  Q:$$HEPCDX(DFN,BGPEDATE)
  1.  S BGPD1=1
  1.  S BGPHSCR=$$HEPCSCR(DFN,BGPEDATE)
  1.  I $P(BGPHSCR,U,1) S BGPN1=1
  1.  S BGPVALUE=""
  1.  S BGPVALUE="UP|||"_$P(BGPHSCR,U,2)
  1.  Q
  1. HEPCDX(P,EDATE) ;
  1.  NEW T,X,G
  1.  ;now check problem list
  1.  S T=$O(^ATXAX("B","BGP HEPATITIS C DXS",0))
  1.  S (X,G)=0 F  S X=$O(^AUPNPROB("AC",P,X)) Q:X'=+X!(G)  D
  1.  .Q:$P(^AUPNPROB(X,0),U,8)>EDATE  ;if added to pl after end of time period, no go
  1.  .S Y=$P(^AUPNPROB(X,0),U)
  1.  .Q:$P(^AUPNPROB(X,0),U,12)="D"
  1.  .Q:$P(^AUPNPROB(X,0),U,12)="I"
  1.  .Q:'$$ICD^BGP4UTL2(Y,T,9)
  1.  .S G=1
  1.  .Q
  1.  I G Q G
  1.  S X=$$LASTDX^BGP4UTL1(P,"BGP HEPATITIS C DXS")
  1.  I X Q 1
  1.  Q ""
  1. HEPCSCR(P,EDATE) ;
  1.  NEW X,G,T,%,BGPC,BGPLT,L,D,J
  1.  S %="",E=+$$CODEN^ICPTCOD(86803),%=$$CPTI^BGP4DU(P,$$DOB^AUPNPAT(P),EDATE,E)
  1.  I % Q 1_U_$$DATE^BGP4UTL($P(%,U,2))_" CPT 86803"
  1.  ;now get all loinc/taxonomy tests
  1.  S BGPC=""
  1.  S T=$O(^ATXAX("B","BGP HEP C TEST LOINC CODES",0))
  1.  S BGPLT=$O(^ATXLAB("B","BGP HEP C TESTS TAX",0))
  1.  S E=9999999-EDATE S D=E-1 F  S D=$O(^AUPNVLAB("AE",P,D)) Q:D'=+D!(BGPC)  D
  1.  .S L=0 F  S L=$O(^AUPNVLAB("AE",P,D,L)) Q:L'=+L!(BGPC)  D
  1.  ..S X=0 F  S X=$O(^AUPNVLAB("AE",P,D,L,X)) Q:X'=+X!(BGPC)  D
  1.  ...Q:'$D(^AUPNVLAB(X,0))
  1.  ...I BGPLT,$P(^AUPNVLAB(X,0),U),$D(^ATXLAB(BGPLT,21,"B",$P(^AUPNVLAB(X,0),U))) S BGPC=1_U_$$DATE^BGP4UTL((9999999-D))_" Lab Test" Q
  1.  ...Q:'T
  1.  ...S J=$P($G(^AUPNVLAB(X,11)),U,13) Q:J=""
  1.  ...Q:'$$LOINC^BGP4D2(J,T)
  1.  ...S BGPC=1_U_$$DATE^BGP4UTL((9999999-D))_" Lab Test (Loinc "_$$VAL^XBDIQ1(9000010.09,X,1113)_")"
  1.  ...Q
  1.  Q BGPC
  1. CD4RES(P,BDATE,EDATE,NORES) ;EP
  1.  NEW BGPG,BGPT,BGPC,BGPLT,T,B,E,D,L,X,R,G,C,%
  1.  K BGPG,BGPT,BGPC
  1.  S BGPC=0
  1.  S NORES=$G(NORES)
  1.  ;now get all loinc/taxonomy tests
  1.  S T=$O(^ATXAX("B","BGP CD4 LOINC CODES",0))
  1.  S BGPLT=$O(^ATXLAB("B","BGP CD4 TAX",0))
  1.  S B=9999999-BDATE,E=9999999-EDATE S D=E-1 F  S D=$O(^AUPNVLAB("AE",P,D)) Q:D'=+D!(D>B)  D
  1.  .S L=0 F  S L=$O(^AUPNVLAB("AE",P,D,L)) Q:L'=+L  D
  1.  ..S X=0 F  S X=$O(^AUPNVLAB("AE",P,D,L,X)) Q:X'=+X  D
  1.  ...Q:'$D(^AUPNVLAB(X,0))
  1.  ...I BGPLT,$P(^AUPNVLAB(X,0),U),$D(^ATXLAB(BGPLT,21,"B",$P(^AUPNVLAB(X,0),U))) S BGPC=BGPC+1,BGPT(D,BGPC)=$P(^AUPNVLAB(X,0),U,4) Q
  1.  ...Q:'T
  1.  ...S J=$P($G(^AUPNVLAB(X,11)),U,13) Q:J=""
  1.  ...Q:'$$LOINC^BGP4D2(J,T)
  1.  ...S R=$P(^AUPNVLAB(X,0),U,4)
  1.  ...I 'R S R=""
  1.  ...S BGPC=BGPC+1,BGPT(D,BGPC)=R
  1.  ...Q
  1.  ; now got though and set return value of done 1 or 0^VALUE^date
  1.  S D=0,G="" F  S D=$O(BGPT(D)) Q:D'=+D!(G]"")  D
  1.  .S C=0 F  S C=$O(BGPT(D,C)) Q:C'=+C!(G]"")  D
  1.  ..S X=BGPT(D,C)
  1.  ..I X="" Q
  1.  ..S G=(9999999-D)_U_X
  1.  ..Q
  1.  I G="" D  ;now get one with no result
  1.  .S D=0,G="" F  S D=$O(BGPT(D)) Q:D'=+D!(G]"")  D
  1.  ..S C=0 F  S C=$O(BGPT(D,C)) Q:C'=+C!(G]"")  D
  1.  ...S X=BGPT(D,C)
  1.  ...I X="" Q
  1.  ...S G=(9999999-D)_U_X
  1.  ..Q
  1.  ;
  1.  I 'NORES,G]"" Q 1_U_G  ;IF WANT A RESULT AND THERE IS ONE QUIT
  1.  S %=$$CPT^BGP4DU(P,BDATE,EDATE,$O(^ATXAX("B","BGP CD4 CPTS",0)),5)
  1.  I %]"" S BGPC=BGPC+1,BGPT(9999999-$P(%,U,1),BGPC)="CPT "_$P(%,U,2)
  1.  S %=$$TRAN^BGP4DU(P,BDATE,EDATE,$O(^ATXAX("B","BGP CD4 CPTS",0)),5)
  1.  I %]"" S BGPC=BGPC+1,BGPT(9999999-$P(%,U,1),BGPC)="CPT "_$P(%,U,2)
  1.  I '$O(BGPT(0)) Q ""
  1.  S %=$O(BGPT(0)) S C=$O(BGPT(%,0)) Q 1_"^"_(9999999-%)_"^"_BGPT(%,C)
  1.  Q ""
  1.  ;