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

BGP4D83.m

Go to the documentation of this file.
BGP4D83 ; IHS/CMI/LAB - measure C ;
 ;;14.1;IHS CLINICAL REPORTING;;MAY 29, 2014;Build 114
 ;
IHEDCWP ;EP
 S (BGPN1,BGPN2,BGPN3,BGPN4,BGPN5,BGPN6,BGPD1,BGPD2,BGPD3,BGPD4,BGPD5,BGPD6,BGPD7,BGPD8,BGPD9,BGPD10,BGPD11,BGPD12)=0
 I 'BGPACTUP S BGPSTOP=1 Q
 S A=$$AGE^AUPNPAT(DFN,$$FMADD^XLFDT(BGPBDATE,-182))
 I A<2 S BGPSTOP=1 Q  ;must be at least 2
 S A=$$AGE^AUPNPAT(DFN,$$FMADD^XLFDT(BGPBDATE,182))
 I A>18 S BGPSTOP=1 Q  ;must not be older than 18 on this date
 S BGPDN=$$PHAR(DFN,$$FMADD^XLFDT(BGPBDATE,-182),$$FMADD^XLFDT(BGPBDATE,182)) I 'BGPDN S BGPSTOP=1 Q  ;no PHARYNGITIS DX
 I BGPACTCL S BGPD1=1
 I BGPACTUP S BGPD2=1
 S BGPN=$$STREP(DFN,$$FMADD^XLFDT(BGPDN,-3),$$FMADD^XLFDT(BGPDN,3))
 S BGPN1=+BGPN
 S BGPVALUE=$S(BGPRTYPE=3:"",1:"UP")_$S(BGPD1:",AC",1:"")_"|||"_$$DATE^BGP4UTL($P(BGPN,U,2))_" "_$P(BGPN,U,3)
 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
 K ^TMP($J,"A"),BGPMEDS1
 Q
 ;
PHAR(P,BDATE,EDATE) ;
 NEW BGPG,Y,E,X,Y,G,V,C,H,BGPD
 S Y="BGPG("
 S X=P_"^ALL DX [BGP PHARYNGITIS DXS;DURING "_BDATE_"-"_EDATE S E=$$START1^APCLDF(X,Y)
 I '$D(BGPG(1)) Q 0
 S X=0,G=0 F  S X=$O(BGPG(X)) Q:X'=+X!(G)  D
 .S V=$P(BGPG(X),U,5)
 .Q:'$D(^AUPNVSIT(V,0))
 .I "ASO"'[$P(^AUPNVSIT(V,0),U,7) Q  ;not outpatient
 .S (C,E)=0 F  S E=$O(^AUPNVPOV("AD",V,E)) Q:E'=+E  S C=C+1
 .Q:C>1  ;can't have any other diagnoses
 .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
 ..S H=0
 ..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
 ..S H=$$HOSPPHAR(P,$P($P(^AUPNVSIT(V,0),U),"."))
 .;NOW CHECK FOR ITEM #4 - NO NEW OR REFILL OF ANTIBIOTICS 30 DAYS PRIOR
 .S BGPD=$P($P(^AUPNVSIT(V,0),U),".")
 .Q:$$NEWRFA(P,$$FMADD^XLFDT(BGPD,-30),$$FMADD^XLFDT(BGPD,-1))
 .Q:$$ACTA(P,$$FMADD^XLFDT(BGPD,-1))
 .Q:'$$CANTI(P,BGPD,$$FMADD^XLFDT(BGPD,3))
 .S G=BGPD
 .Q
 K BGPMEDS1
 Q G
NDC(A,B) ;
 ;a is drug ien
 ;b is taxonomy ien
 S BGPNDC=$P($G(^PSDRUG(A,2)),U,4)
 I BGPNDC]"",B,$D(^ATXAX(B,21,"B",BGPNDC)) Q 1
 Q 0
NEWRFA(P,BDATE,EDATE) ;
 K ^TMP($J,"A")
 NEW A,B,E,Z,X,D,V,Y,G,M,T,T1
 K BGPMEDS1
 D GETMEDS^BGP4UTL2(P,BDATE,EDATE,,,,,.BGPMEDS1)
 I '$D(BGPMEDS1) G NEWP
 S T1=$O(^ATXAX("B","BGP HEDIS ANTIBIOTICS MEDS",0))
 S T4=$O(^ATXAX("B","BGP HEDIS ANTIBIOTICS NDC",0))
 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
 .Q:'$D(^AUPNVSIT(V,0))
 .Q:$$UP^XLFSTR($P($G(^AUPNVMED(Y,11)),U))["RETURNED TO STOCK"
 .S Z=$P($G(^AUPNVMED(Y,0)),U) ;get drug ien
 .I $D(^ATXAX(T1,21,"B",Z))!($$NDC(Z,T4)) S D=1
 K ^TMP($J,"A"),BGPMEDS1
 I D Q D
NEWP ;check V PROCEDURE
 S D=$$LASTPRC^BGP4UTL1(P,"BGP INJECTION ANTIBIOTIC PROCS",BDATE,EDATE)
 Q $P(D,U)
 ;
CANTI(P,BDATE,EDATE) ;
 K ^TMP($J,"A")
 NEW A,B,E,Z,X,D,V,Y,G,M,T,T1
 K BGPMEDS1
 D GETMEDS^BGP4UTL2(P,BDATE,EDATE,,,,,.BGPMEDS1)
 I '$D(BGPMEDS1) G CANP
 S T1=$O(^ATXAX("B","BGP HEDIS ANTIBIOTICS MEDS",0))
 S T4=$O(^ATXAX("B","BGP HEDIS ANTIBIOTICS NDC",0))
 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
 .Q:'$D(^AUPNVSIT(V,0))
 .Q:'$D(^AUPNVMED(Y))
 .S Z=$P($G(^AUPNVMED(Y,0)),U) ;get drug ien
 .Q:$$UP^XLFSTR($P($G(^AUPNVMED(Y,11)),U))["RETURNED TO STOCK"
 .I $D(^ATXAX(T1,21,"B",Z))!($$NDC(Z,T4)) S D=1
 K ^TMP($J,"A"),BGPMEDS1
 I D Q D
CANP ;check V PROCEDURE
 S D=$$LASTPRC^BGP4UTL1(P,"BGP INJECTION ANTIBIOTIC PROCS",BDATE,EDATE)
 Q $P(D,U)
ACTA(P,EDATE) ;
 K ^TMP($J,"A")
 NEW A,B,E,Z,X,D,V,Y,G,M,T,T1
 K BGPMEDS1
 D GETMEDS^BGP4UTL2(P,$$FMADD^XLFDT(EDATE,-365),EDATE,,,,,.BGPMEDS1)
 I '$D(BGPMEDS1) Q 0
 S T1=$O(^ATXAX("B","BGP HEDIS ANTIBIOTICS MEDS",0))
 S T4=$O(^ATXAX("B","BGP HEDIS ANTIBIOTICS NDC",0))
 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
 .Q:'$D(^AUPNVSIT(V,0))
 .Q:'$D(^AUPNVMED(Y))
 .Q:$$UP^XLFSTR($P($G(^AUPNVMED(Y,11)),U))["RETURNED TO STOCK"
 .S Z=$P($G(^AUPNVMED(Y,0)),U) ;get drug ien
 .S B=$$FMDIFF^XLFDT(EDATE,$P($P(^AUPNVSIT(V,0),U),"."))
 .I $D(^ATXAX(T1,21,"B",Z))!($$NDC(Z,T4)) I $P(^AUPNVMED(Y,0),U,6)'<B S D=1
 K ^TMP($J,"A"),BGPMEDS1
 Q D
HOSPPHAR(P,D) ;is there a hosp with pharyngitis on date D or 1 day later
 S (I,J,K,Q)=0
 F  S I=$O(^AUPNVSIT("AAH",P,I)) Q:I'=+I  D
 .S J=0 F  S J=$O(^AUPNVSIT("AAH",P,I,J)) Q:J'=+J  D
 ..Q:'$D(^AUPNVSIT(J,0))
 ..S K=$P($P(^AUPNVSIT(J,0),U),".")
 ..I K<D Q  ;before outpatient visit
 ..I K>$$FMADD^XLFDT(D,1) Q  ;more than 1 day after outpatient visit date
 ..;now must have a pharyngitis dx
 ..S (R,S,T)=0
 ..F  S R=$O(^AUPNVPOV("AD",J,R)) Q:R'=+R  D
 ...S T=$P($G(^AUPNVPOV(R,0)),U)
 ...Q:T=""
 ...S T=$P($$ICDDX^BGP4UTL2(T),U,2)
 ...Q:T=""
 ...Q:'$$ICD^BGP4UTL2(T,$O(^ATXAX("B","BGP PHARYNGITIS DXS",0)),9)
 ...S S=1
 ..Q:'S
 ..S Q=1
 .Q
 Q Q
STREP(P,BDATE,EDATE) ;EP
 K BGPC
 S BGPC=0
 S %=$$CPT^BGP4DU(P,BDATE,EDATE,$O(^ATXAX("B","BGP GROUP A STREP CPT",0)),5)
 I %]"" S $P(%,U,2)="CPT "_$P(%,U,2) Q 1_U_%
 S %=$$TRAN^BGP4DU(P,BDATE,EDATE,$O(^ATXAX("B","BGP GROUP A STREP CPT",0)),5)
 I %]"" S $P(%,U,2)="CPT "_$P(%,U,2) Q 1_U_%
 ;now get all loinc/taxonomy tests
 S T=$O(^ATXAX("B","BGP GROUP A STREP LOINC",0))
 S BGPLT=$O(^ATXLAB("B","BGP GROUP A STREP TESTS",0))
 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
 .S L=0 F  S L=$O(^AUPNVLAB("AE",P,D,L)) Q:L'=+L!($P(BGPC,U))  D
 ..S X=0 F  S X=$O(^AUPNVLAB("AE",P,D,L,X)) Q:X'=+X!($P(BGPC,U))  D
 ...Q:'$D(^AUPNVLAB(X,0))
 ...I BGPLT,$P(^AUPNVLAB(X,0),U),$D(^ATXLAB(BGPLT,21,"B",$P(^AUPNVLAB(X,0),U))) S BGPC=1_U_(9999999-D)_U_$P(^LAB(60,$P(^AUPNVLAB(X,0),U),0),U) Q
 ...Q:'T
 ...S J=$P($G(^AUPNVLAB(X,11)),U,13) Q:J=""
 ...Q:'$$LOINC^BGP4D21(J,T)
 ...S BGPC=1_U_(9999999-D)_U_$P(^LAB(60,$P(^AUPNVLAB(X,0),U),0),U)
 ...Q
 I BGPC Q BGPC
 ;now check v microbiology
 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
 .S L=0 F  S L=$O(^AUPNVMIC("AE",P,D,L)) Q:L'=+L!($P(BGPC,U))  D
 ..S X=0 F  S X=$O(^AUPNVMIC("AE",P,D,L,X)) Q:X'=+X!($P(BGPC,U))  D
 ...Q:'$D(^AUPNVMIC(X,0))
 ...I BGPLT,$P(^AUPNVMIC(X,0),U),$D(^ATXLAB(BGPLT,21,"B",$P(^AUPNVMIC(X,0),U))) S BGPC=1_U_(9999999-D)_U_$P(^LAB(60,$P(^AUPNVMIC(X,0),U),0),U) Q
 ...Q:'T
 ...S J=$P($G(^AUPNVMIC(X,11)),U,13) Q:J=""
 ...Q:'$$LOINC^BGP4D21(J,T)
 ...S BGPC=1_U_(9999999-D)_U_$P(^LAB(60,$P(^AUPNVMIC(X,0),U),0),U)
 ...Q
 Q BGPC