BGP5D84 ; IHS/CMI/LAB - measure C ;
;;15.1;IHS CLINICAL REPORTING;;MAY 06, 2015;Build 143
;
HEDURI ;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=$$FMDIFF^XLFDT($$FMADD^XLFDT(BGPBDATE,-182),$P(^DPT(DFN,0),U,3))
I A<91 S BGPSTOP=1 Q ;less than 3 months old
;S A=$$AGE^AUPNPAT(DFN,$$FMADD^XLFDT(BGPBDATE,-180))
;I A<2 S BGPSTOP=1 ;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=$$URI(DFN,$$FMADD^XLFDT(BGPBDATE,-182),$$FMADD^XLFDT(BGPBDATE,182)) I 'BGPDN S BGPSTOP=1 Q ;no URI DX
I BGPACTCL S BGPD1=1
I BGPACTUP S BGPD2=1
S BGPN=$$CANTI(DFN,BGPDN,$$FMADD^XLFDT(BGPDN,3))
S BGPN1=$S('$P(BGPN,U):1,1:0)
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")
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")
Q
;
URI(P,BDATE,EDATE) ;
NEW BGPG,Y,X,G,V,E,C,H
S Y="BGPG("
S X=P_"^ALL DX [BGP URI 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=$$HOSPURI(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,-30),$$FMADD^XLFDT(BGPD,-1))
.;Q:'$$CANTI(P,BGPD,$$FMADD^XLFDT(BGPD,3))
.S G=BGPD
.Q
Q G
NDC(A,B) ;
;a is drug ien
;b is taxonomy ien
NEW BGPNDC
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^BGP5UTL2(P,BDATE,EDATE,,,,,.BGPMEDS1)
I '$D(BGPMEDS1) G NEWFRAP
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))
.S Z=$P($G(^AUPNVMED(Y,0)),U) ;get drug ien
.I $D(^ATXAX(T1,21,"B",Z))!($$NDC(Z,T4)),$P(^AUPNVMED(Y,0),U,8)="" S D=1
K ^TMP($J,"A")
I D Q D
NEWFRAP ;check V PROCEDURE
S D=$$LASTPRC^BGP5UTL1(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^BGP5UTL2(P,BDATE,EDATE,,,,,.BGPMEDS1)
I '$D(BGPMEDS1) G CANTIP
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))
.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_U_"antibiotic: "_$$DATE^BGP5UTL($P($P(^AUPNVSIT(V,0),U),"."))
K ^TMP($J,"A")
I D Q D
CANTIP ;check V PROCEDURE
S D=$$LASTPRC^BGP5UTL1(P,"BGP INJECTION ANTIBIOTIC PROCS",BDATE,EDATE)
Q $P(D,U)_$S(D:"^antibiotic injection: "_$$DATE^BGP5UTL($P(D,U,3)),1:"")
ACTA(P,BDATE,EDATE) ;
K ^TMP($J,"A")
NEW A,B,E,Z,X,D,V,Y,G,M,T,T1
K BGPMEDS1
D GETMEDS^BGP5UTL2(P,BDATE,EDATE,,,,,.BGPMEDS1)
I '$D(BGPMEDS1) G ACTAP
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))
.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)),$P(^AUPNVMED(Y,0),U,8)="" I $P(^AUPNVMED(Y,0),U,6)'<B S D=1
K ^TMP($J,"A")
I D Q D
ACTAP ;check V PROCEDURE
S D=$$LASTPRC^BGP5UTL1(P,"BGP INJECTION ANTIBIOTIC PROCS",$$FMADD^XLFDT(EDATE,-30),$$FMADD^XLFDT(EDATE,-1))
Q $P(D,U)_$S(D:"^antibiotic injection: "_$$DATE^BGP5UTL($P(D,U,3)),1:"")
HOSPURI(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^BGP5UTL2(T),U,2)
...Q:T=""
...Q:'$$ICD^BGP5UTL2(T,$O(^ATXAX("B","BGP URI 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^BGP5DU(P,BDATE,EDATE,$O(^ATXAX("B","BGP GROUP A STREP CPT",0)))
I %]"" Q 1_U_%
S %=$$TRAN^BGP5DU(P,BDATE,EDATE,$O(^ATXAX("B","BGP GROUP A STREP CPT",0)))
I %]"" 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_"LAB" Q
...Q:'T
...S J=$P($G(^AUPNVLAB(X,11)),U,13) Q:J=""
...Q:'$$LOINC^BGP5D21(J,T)
...S BGPC=1_U_(9999999-D)_U_"LOINC"
...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_"MICRO" Q
...Q:'T
...S J=$P($G(^AUPNVMIC(X,11)),U,13) Q:J=""
...Q:'$$LOINC^BGP5D21(J,T)
...S BGPC=1_U_(9999999-D)_U_"MICRO LOINC"
...Q
Q BGPC
HEPC ;
S (BGPN1,BGPN2,BGPN3,BGPN4,BGPN5,BGPD1,BGPD2)=0
;BGPD1 - PTS WITH NO HEP C
;BGPD2 - PTS WITH HEP C
;BGPN1 - PTS SCREENED IF IN BGPD1
;BGPN2 - PTS WITH CONF TEST IF IN BGPD2
;BGPN3 - PTS IN BGPN2 WITH POS RESULT
;BGPN4 - PTS IN BGPN2 WITH NEG RESULT
;BGPN5 - PTS IN BGPN2 WITH NO RESULT
NEW BGPHSCR
S BGPVALUE=""
I 'BGPACTUP S BGPSTOP=1 Q
Q:$$DOB^AUPNPAT(DFN)<2450101
Q:$$DOB^AUPNPAT(DFN)>2651231
I $$HEPCDX(DFN,BGPEDATE) S BGPD2=1
I 'BGPD2 S BGPD1=1
S BGPHSCR=""
I BGPD1 S BGPHSCR=$$HEPCSCR(DFN,BGPEDATE) I $P(BGPHSCR,U,1) S BGPN1=1
I BGPD2 S BGPHSCR=$$HEPCCON(DFN,BGPEDATE) D
.I $P(BGPHSCR,U,1) S BGPN2=1
.I $P(BGPHSCR,U,5)="POS" S BGPN3=1 Q
.I $P(BGPHSCR,U,5)="NEG" S BGPN4=1 Q
.S BGPN5=1
I BGPD1 S BGPVALUE="UP|||" I BGPN1 S BGPVALUE=BGPVALUE_"Screen: "_$P(BGPHSCR,U,2)_" "_$P(BGPHSCR,U,3)
I BGPD2 S BGPVALUE="UP,HEP|||" I BGPN2 S BGPVALUE=BGPVALUE_"Conf "_$P(BGPHSCR,U,2)_" "_$P(BGPHSCR,U,3)_" result="_$P(BGPHSCR,U,5)
Q
HEPCDX(P,EDATE) ;
NEW T,X,G
;now check problem list
S T=$O(^ATXAX("B","BGP HEPATITIS C DXS",0))
S (X,G)=0 F S X=$O(^AUPNPROB("AC",P,X)) Q:X'=+X!(G) D
.Q:$P(^AUPNPROB(X,0),U,8)>EDATE ;if added to pl after end of time period, no go
.S Y=$P(^AUPNPROB(X,0),U)
.Q:$P(^AUPNPROB(X,0),U,12)="D"
.Q:$P(^AUPNPROB(X,0),U,12)="I"
.Q:'$$ICD^BGP5UTL2(Y,T,9)
.S G=1
.Q
I G Q G
S X=$$LASTDX^BGP5UTL1(P,"BGP HEPATITIS C DXS")
I X Q 1
Q ""
HEPCSCR(P,EDATE) ;
NEW X,G,T,%,BGPC,BGPLT,L,D,J
S %="",E=+$$CODEN^ICPTCOD(86803),%=$$CPTI^BGP5DU(P,$$DOB^AUPNPAT(P),EDATE,E)
I % Q 1_U_$$DATE^BGP5UTL($P(%,U,2))_" CPT 86803"
;now get all loinc/taxonomy tests
S BGPC=""
S T=$O(^ATXAX("B","BGP HEP C TEST LOINC CODES",0))
S BGPLT=$O(^ATXLAB("B","BGP HEP C TESTS TAX",0))
S E=9999999-EDATE S D=E-1 F S D=$O(^AUPNVLAB("AE",P,D)) Q:D'=+D!(BGPC) D
.S L=0 F S L=$O(^AUPNVLAB("AE",P,D,L)) Q:L'=+L!(BGPC) D
..S X=0 F S X=$O(^AUPNVLAB("AE",P,D,L,X)) Q:X'=+X!(BGPC) 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_$$DATE^BGP5UTL((9999999-D))_" Lab Test" Q
...Q:'T
...S J=$P($G(^AUPNVLAB(X,11)),U,13) Q:J=""
...Q:'$$LOINC^BGP5D2(J,T)
...S BGPC=1_U_$$DATE^BGP5UTL((9999999-D))_" Lab Test (Loinc "_$$VAL^XBDIQ1(9000010.09,X,1113)_")"
...Q
Q BGPC
HEPCCON(P,EDATE) ;
;return first test with a valid result
;if none with a valid result, return 1st one
NEW BGPG,BGPT,BGPLT
;GET ALL LABS INTO ARRAY BGPG
S BGPLT=$O(^ATXAX("B","BGP HEP C CONF LOINC",0))
S BGPT=$O(^ATXLAB("B","BGP HEP C CONF TEST TAX",0))
NEW D,V,G,X,J,B,E,C,Y,R,I
S C=0,E=9999999-EDATE ;get inverse date and begin at edate-1 and end when greater than begin date
S D=E-1,D=D_".9999" F S D=$O(^AUPNVLAB("AE",P,D)) Q:D'=+D D
.S X=0 F S X=$O(^AUPNVLAB("AE",P,D,X)) Q:X'=+X D
..S Y=0 F S Y=$O(^AUPNVLAB("AE",P,D,X,Y)) Q:Y'=+Y D
...I BGPT,$D(^ATXLAB(BGPT,21,"B",X)) D SETLAB Q
...Q:'BGPLT
...S J=$P($G(^AUPNVLAB(Y,11)),U,13) Q:J=""
...Q:'$$LOINC^BGP5D21(J,BGPLT)
...D SETLAB Q
...Q
..Q
.Q
;NOW SET UP ARRAY AS DATE^ITEM^RESULT
;ADD IN CPT CODES
S X=$$FIRSTCPT^BGP5UTL1(P,"BGP HEP C CONF CPTS",$$DOB^AUPNPAT(P),EDATE)
I X D
.S C=C+1
.S BGPG($P(X,U,1),C)=$P(X,U,1)_U_$P(X,U,2)
;FIND FIRST WITH A VALID RESULT
I '$O(BGPG(0)) Q "" ;NO TESTS
S D=0,G="" F S D=$O(BGPG(D)) Q:D'=+D!(G) D
.S C=0
.F S C=$O(BGPG(D,C)) Q:C'=+C!(G) D
..;Q:$P(BGPG(D,C),U,3)="" ;NO RESULT
..S R=$P(BGPG(D,C),U,3)
..S I="" I $P(BGPG(D,C),U,2)["Lab" S I=$P(BGPG(D,C),U,4)
..S Y=$$GOODRES(R,I) I Y]"" S G=1_U_$$DATE^BGP5UTL($P(BGPG(D,C),U,1))_U_$P(BGPG(D,C),U,2)_U_$P(BGPG(D,C),U,3)_U_Y
; IF NO RESULT TAKE FIRST ONE
I G Q G
S D=$O(BGPG(0)),C=$O(BGPG(D,0))
Q 1_U_$$DATE^BGP5UTL($P(BGPG(D,C),U,1))_U_$P(BGPG(D,C),U,2)_U_U_"No Result"
SETLAB ;
S C=C+1
S BGPG($$VDTM^APCLV($P(^AUPNVLAB(Y,0),U,3)),C)=$$VD^APCLV($P(^AUPNVLAB(Y,0),U,3))_"^"_"Lab"_"^"_$$VAL^XBDIQ1(9000010.09,Y,.04)_"^"_Y_"^"_$P(^AUPNVLAB(Y,0),U,3)
Q
CD4RES(P,BDATE,EDATE,NORES) ;EP
NEW BGPG,BGPT,BGPC,BGPLT,T,B,E,D,L,X,R,G,C,%
K BGPG,BGPT,BGPC
S BGPC=0
S NORES=$G(NORES)
;now get all loinc/taxonomy tests
S T=$O(^ATXAX("B","BGP CD4 LOINC CODES",0))
S BGPLT=$O(^ATXLAB("B","BGP CD4 TAX",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) D
.S L=0 F S L=$O(^AUPNVLAB("AE",P,D,L)) Q:L'=+L D
..S X=0 F S X=$O(^AUPNVLAB("AE",P,D,L,X)) Q:X'=+X 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=BGPC+1,BGPT(D,BGPC)=$P(^AUPNVLAB(X,0),U,4) Q
...Q:'T
...S J=$P($G(^AUPNVLAB(X,11)),U,13) Q:J=""
...Q:'$$LOINC^BGP5D2(J,T)
...S R=$P(^AUPNVLAB(X,0),U,4)
...I 'R S R=""
...S BGPC=BGPC+1,BGPT(D,BGPC)=R
...Q
; now got though and set return value of done 1 or 0^VALUE^date
S D=0,G="" F S D=$O(BGPT(D)) Q:D'=+D!(G]"") D
.S C=0 F S C=$O(BGPT(D,C)) Q:C'=+C!(G]"") D
..S X=BGPT(D,C)
..I X="" Q
..S G=(9999999-D)_U_X
..Q
I G="" D ;now get one with no result
.S D=0,G="" F S D=$O(BGPT(D)) Q:D'=+D!(G]"") D
..S C=0 F S C=$O(BGPT(D,C)) Q:C'=+C!(G]"") D
...S X=BGPT(D,C)
...I X="" Q
...S G=(9999999-D)_U_X
..Q
;
I 'NORES,G]"" Q 1_U_G ;IF WANT A RESULT AND THERE IS ONE QUIT
S %=$$CPT^BGP5DU(P,BDATE,EDATE,$O(^ATXAX("B","BGP CD4 CPTS",0)),5)
I %]"" S BGPC=BGPC+1,BGPT(9999999-$P(%,U,1),BGPC)="CPT "_$P(%,U,2)
S %=$$TRAN^BGP5DU(P,BDATE,EDATE,$O(^ATXAX("B","BGP CD4 CPTS",0)),5)
I %]"" S BGPC=BGPC+1,BGPT(9999999-$P(%,U,1),BGPC)="CPT "_$P(%,U,2)
I '$O(BGPT(0)) Q ""
S %=$O(BGPT(0)) S C=$O(BGPT(%,0)) Q 1_"^"_(9999999-%)_"^"_BGPT(%,C)
Q ""
;
GOODRES(R,I) ;EP
;is this a good result
;Positive confirmation test result defined as any number greater than
;zero, "Pos", "Positive", "Detected", a result starting with ">", or a
;result starting with a number.
;Negative confirmation test result defined as a result starting with "<", "Neg", "Negative", "None detected", "None Detec", or "Not detected".
S R=$G(R)
I R="" Q ""
S R=$$UP^XLFSTR(R)
I $E(R)="<" Q "NEG"
I R["NEGATIVE" Q "NEG"
I R["NEG" Q "NEG"
I R["NONE DETECTED" Q "NEG"
I R["NONE DETEC" Q "NEG"
I R["NOT DETECTED" Q "NEG"
I R["NOTDETECTED" Q "NEG"
I R["NOT DETECT" Q "NEG"
I $E(R)=">" Q "POS"
I R["POSITIVE" Q "POS"
I R["DETECTED" Q "POS"
I R["POS" Q "POS"
I +R>0 Q "POS"
Q ""
GOODRES1 ;
I '$G(I) Q ""
;comments field
I $$UP^XLFSTR($G(^AUPNVLAB(I,13)))["NOT DETECTED" Q "NEG"
NEW J,K,T
S T=""
S J=0,K="" F S J=$O(^AUPNVLAB(I,21,J)) Q:J'=+J D
.S K=K_$G(^AUPNVLAB(I,21,J,0))
I $$UP^XLFSTR(K)["NOT DETECTED" Q "NEG"
I $$UP^XLFSTR(K)["NOTDETECTED" Q "NEG"
Q ""
BGP5D84 ; IHS/CMI/LAB - measure C ;
+1 ;;15.1;IHS CLINICAL REPORTING;;MAY 06, 2015;Build 143
+2 ;
HEDURI ;EP
+1 SET (BGPN1,BGPN2,BGPN3,BGPN4,BGPN5,BGPN6,BGPD1,BGPD2,BGPD3,BGPD4,BGPD5,BGPD6,BGPD7,BGPD8,BGPD9,BGPD10,BGPD11,BGPD12)=0
+2 IF 'BGPACTUP
SET BGPSTOP=1
QUIT
+3 SET A=$$FMDIFF^XLFDT($$FMADD^XLFDT(BGPBDATE,-182),$PIECE(^DPT(DFN,0),U,3))
+4 ;less than 3 months old
IF A<91
SET BGPSTOP=1
QUIT
+5 ;S A=$$AGE^AUPNPAT(DFN,$$FMADD^XLFDT(BGPBDATE,-180))
+6 ;I A<2 S BGPSTOP=1 ;must be at least 2
+7 SET A=$$AGE^AUPNPAT(DFN,$$FMADD^XLFDT(BGPBDATE,182))
+8 ;must not be older than 18 on this date
IF A>18
SET BGPSTOP=1
QUIT
+9 ;no URI DX
SET BGPDN=$$URI(DFN,$$FMADD^XLFDT(BGPBDATE,-182),$$FMADD^XLFDT(BGPBDATE,182))
IF 'BGPDN
SET BGPSTOP=1
QUIT
+10 IF BGPACTCL
SET BGPD1=1
+11 IF BGPACTUP
SET BGPD2=1
+12 SET BGPN=$$CANTI(DFN,BGPDN,$$FMADD^XLFDT(BGPDN,3))
+13 SET BGPN1=$SELECT('$PIECE(BGPN,U):1,1:0)
+14 SET BGPVALUE=$SELECT(BGPRTYPE'=3:"UP",1:"")_$SELECT(BGPD1:",AC",1:"")_"|||"_$PIECE(BGPN,U,2)_" "_$PIECE(BGPN,U,3)_$SELECT(BGPN1:" MEETS MEASURE",1:"DOES NOT MEET MEASURE")
+15 KILL 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
+16 KILL ^TMP($JOB,"A")
+17 QUIT
+18 ;
URI(P,BDATE,EDATE) ;
+1 NEW BGPG,Y,X,G,V,E,C,H
+2 SET Y="BGPG("
+3 SET X=P_"^ALL DX [BGP URI DXS;DURING "_BDATE_"-"_EDATE
SET E=$$START1^APCLDF(X,Y)
+4 IF '$DATA(BGPG(1))
QUIT 0
+5 SET X=0
SET G=0
FOR
SET X=$ORDER(BGPG(X))
IF X'=+X!(G)
QUIT
Begin DoDot:1
+6 SET V=$PIECE(BGPG(X),U,5)
+7 IF '$DATA(^AUPNVSIT(V,0))
QUIT
+8 ;not outpatient
IF "ASO"'[$PIECE(^AUPNVSIT(V,0),U,7)
QUIT
+9 SET (C,E)=0
FOR
SET E=$ORDER(^AUPNVPOV("AD",V,E))
IF E'=+E
QUIT
SET C=C+1
+10 ;can't have any other diagnoses
IF C>1
QUIT
+11 ;if H is 1 then there was a hosp stay so don't use this visit
IF $$CLINIC^APCLV(V,"C")=30
Begin DoDot:2
+12 SET H=0
+13 ;er visit with admission
SET E=$ORDER(^AUPNVER("AD",V,0))
IF E
IF "ATLM"[$PIECE($GET(^AUPNVER(E,0)),U,11)
SET H=1
QUIT
+14 SET H=$$HOSPURI(P,$PIECE($PIECE(^AUPNVSIT(V,0),U),"."))
End DoDot:2
IF H
QUIT
+15 ;NOW CHECK FOR ITEM #4 - NO NEW OR REFILL OF ANTIBIOTICS 30 DAYS PRIOR
+16 SET BGPD=$PIECE($PIECE(^AUPNVSIT(V,0),U),".")
+17 IF $$NEWRFA(P,$$FMADD^XLFDT(BGPD,-30),$$FMADD^XLFDT(BGPD,-1))
QUIT
+18 IF $$ACTA(P,$$FMADD^XLFDT(BGPD,-30),$$FMADD^XLFDT(BGPD,-1))
QUIT
+19 ;Q:'$$CANTI(P,BGPD,$$FMADD^XLFDT(BGPD,3))
+20 SET G=BGPD
+21 QUIT
End DoDot:1
+22 QUIT G
NDC(A,B) ;
+1 ;a is drug ien
+2 ;b is taxonomy ien
+3 NEW BGPNDC
+4 SET BGPNDC=$PIECE($GET(^PSDRUG(A,2)),U,4)
+5 IF BGPNDC]""
IF B
IF $DATA(^ATXAX(B,21,"B",BGPNDC))
QUIT 1
+6 QUIT 0
NEWRFA(P,BDATE,EDATE) ;
+1 KILL ^TMP($JOB,"A")
+2 NEW A,B,E,Z,X,D,V,Y,G,M,T,T1
+3 KILL BGPMEDS1
+4 DO GETMEDS^BGP5UTL2(P,BDATE,EDATE,,,,,.BGPMEDS1)
+5 IF '$DATA(BGPMEDS1)
GOTO NEWFRAP
+6 SET T1=$ORDER(^ATXAX("B","BGP HEDIS ANTIBIOTICS MEDS",0))
+7 SET T4=$ORDER(^ATXAX("B","BGP HEDIS ANTIBIOTICS NDC",0))
+8 SET (X,G,M,E)=0
SET D=""
FOR
SET X=$ORDER(BGPMEDS1(X))
IF X'=+X!(D)
QUIT
SET V=$PIECE(BGPMEDS1(X),U,5)
SET Y=+$PIECE(BGPMEDS1(X),U,4)
Begin DoDot:1
+9 IF '$DATA(^AUPNVSIT(V,0))
QUIT
+10 ;get drug ien
SET Z=$PIECE($GET(^AUPNVMED(Y,0)),U)
+11 IF $DATA(^ATXAX(T1,21,"B",Z))!($$NDC(Z,T4))
IF $PIECE(^AUPNVMED(Y,0),U,8)=""
SET D=1
End DoDot:1
+12 KILL ^TMP($JOB,"A")
+13 IF D
QUIT D
NEWFRAP ;check V PROCEDURE
+1 SET D=$$LASTPRC^BGP5UTL1(P,"BGP INJECTION ANTIBIOTIC PROCS",BDATE,EDATE)
+2 QUIT $PIECE(D,U)
CANTI(P,BDATE,EDATE) ;
+1 KILL ^TMP($JOB,"A")
+2 NEW A,B,E,Z,X,D,V,Y,G,M,T,T1
+3 KILL BGPMEDS1
+4 DO GETMEDS^BGP5UTL2(P,BDATE,EDATE,,,,,.BGPMEDS1)
+5 IF '$DATA(BGPMEDS1)
GOTO CANTIP
+6 SET T1=$ORDER(^ATXAX("B","BGP HEDIS ANTIBIOTICS MEDS",0))
+7 SET T4=$ORDER(^ATXAX("B","BGP HEDIS ANTIBIOTICS NDC",0))
+8 SET (X,G,M,E)=0
SET D=""
FOR
SET X=$ORDER(BGPMEDS1(X))
IF X'=+X!(D)
QUIT
SET V=$PIECE(BGPMEDS1(X),U,5)
SET Y=+$PIECE(BGPMEDS1(X),U,4)
Begin DoDot:1
+9 IF '$DATA(^AUPNVSIT(V,0))
QUIT
+10 ;get drug ien
SET Z=$PIECE($GET(^AUPNVMED(Y,0)),U)
+11 IF $$UP^XLFSTR($PIECE($GET(^AUPNVMED(Y,11)),U))["RETURNED TO STOCK"
QUIT
+12 IF $DATA(^ATXAX(T1,21,"B",Z))!($$NDC(Z,T4))
SET D=1_U_"antibiotic: "_$$DATE^BGP5UTL($PIECE($PIECE(^AUPNVSIT(V,0),U),"."))
End DoDot:1
+13 KILL ^TMP($JOB,"A")
+14 IF D
QUIT D
CANTIP ;check V PROCEDURE
+1 SET D=$$LASTPRC^BGP5UTL1(P,"BGP INJECTION ANTIBIOTIC PROCS",BDATE,EDATE)
+2 QUIT $PIECE(D,U)_$SELECT(D:"^antibiotic injection: "_$$DATE^BGP5UTL($PIECE(D,U,3)),1:"")
ACTA(P,BDATE,EDATE) ;
+1 KILL ^TMP($JOB,"A")
+2 NEW A,B,E,Z,X,D,V,Y,G,M,T,T1
+3 KILL BGPMEDS1
+4 DO GETMEDS^BGP5UTL2(P,BDATE,EDATE,,,,,.BGPMEDS1)
+5 IF '$DATA(BGPMEDS1)
GOTO ACTAP
+6 SET T1=$ORDER(^ATXAX("B","BGP HEDIS ANTIBIOTICS MEDS",0))
+7 SET T4=$ORDER(^ATXAX("B","BGP HEDIS ANTIBIOTICS NDC",0))
+8 SET (X,G,M,E)=0
SET D=""
FOR
SET X=$ORDER(BGPMEDS1(X))
IF X'=+X!(D)
QUIT
SET V=$PIECE(BGPMEDS1(X),U,5)
SET Y=+$PIECE(BGPMEDS1(X),U,4)
Begin DoDot:1
+9 IF '$DATA(^AUPNVSIT(V,0))
QUIT
+10 ;get drug ien
SET Z=$PIECE($GET(^AUPNVMED(Y,0)),U)
+11 SET B=$$FMDIFF^XLFDT(EDATE,$PIECE($PIECE(^AUPNVSIT(V,0),U),"."))
+12 IF $DATA(^ATXAX(T1,21,"B",Z))!($$NDC(Z,T4))
IF $PIECE(^AUPNVMED(Y,0),U,8)=""
IF $PIECE(^AUPNVMED(Y,0),U,6)'<B
SET D=1
End DoDot:1
+13 KILL ^TMP($JOB,"A")
+14 IF D
QUIT D
ACTAP ;check V PROCEDURE
+1 SET D=$$LASTPRC^BGP5UTL1(P,"BGP INJECTION ANTIBIOTIC PROCS",$$FMADD^XLFDT(EDATE,-30),$$FMADD^XLFDT(EDATE,-1))
+2 QUIT $PIECE(D,U)_$SELECT(D:"^antibiotic injection: "_$$DATE^BGP5UTL($PIECE(D,U,3)),1:"")
HOSPURI(P,D) ;is there a hosp with pharyngitis on date D or 1 day later
+1 SET (I,J,K,Q)=0
+2 FOR
SET I=$ORDER(^AUPNVSIT("AAH",P,I))
IF I'=+I
QUIT
Begin DoDot:1
+3 SET J=0
FOR
SET J=$ORDER(^AUPNVSIT("AAH",P,I,J))
IF J'=+J
QUIT
Begin DoDot:2
+4 IF '$DATA(^AUPNVSIT(J,0))
QUIT
+5 SET K=$PIECE($PIECE(^AUPNVSIT(J,0),U),".")
+6 ;before outpatient visit
IF K<D
QUIT
+7 ;more than 1 day after outpatient visit date
IF K>$$FMADD^XLFDT(D,1)
QUIT
+8 ;now must have a pharyngitis dx
+9 SET (R,S,T)=0
+10 FOR
SET R=$ORDER(^AUPNVPOV("AD",J,R))
IF R'=+R
QUIT
Begin DoDot:3
+11 SET T=$PIECE($GET(^AUPNVPOV(R,0)),U)
+12 IF T=""
QUIT
+13 SET T=$PIECE($$ICDDX^BGP5UTL2(T),U,2)
+14 IF T=""
QUIT
+15 IF '$$ICD^BGP5UTL2(T,$ORDER(^ATXAX("B","BGP URI DXS",0)),9)
QUIT
+16 SET S=1
End DoDot:3
+17 IF 'S
QUIT
+18 SET Q=1
End DoDot:2
+19 QUIT
End DoDot:1
+20 QUIT Q
STREP(P,BDATE,EDATE) ;EP
+1 KILL BGPC
+2 SET BGPC=0
+3 SET %=$$CPT^BGP5DU(P,BDATE,EDATE,$ORDER(^ATXAX("B","BGP GROUP A STREP CPT",0)))
+4 IF %]""
QUIT 1_U_%
+5 SET %=$$TRAN^BGP5DU(P,BDATE,EDATE,$ORDER(^ATXAX("B","BGP GROUP A STREP CPT",0)))
+6 IF %]""
QUIT 1_U_%
+7 ;now get all loinc/taxonomy tests
+8 SET T=$ORDER(^ATXAX("B","BGP GROUP A STREP LOINC",0))
+9 SET BGPLT=$ORDER(^ATXLAB("B","BGP GROUP A STREP TESTS",0))
+10 SET B=9999999-BDATE
SET E=9999999-EDATE
SET D=E-1
FOR
SET D=$ORDER(^AUPNVLAB("AE",P,D))
IF D'=+D!(D>B)!($PIECE(BGPC,U))
QUIT
Begin DoDot:1
+11 SET L=0
FOR
SET L=$ORDER(^AUPNVLAB("AE",P,D,L))
IF L'=+L!($PIECE(BGPC,U))
QUIT
Begin DoDot:2
+12 SET X=0
FOR
SET X=$ORDER(^AUPNVLAB("AE",P,D,L,X))
IF X'=+X!($PIECE(BGPC,U))
QUIT
Begin DoDot:3
+13 IF '$DATA(^AUPNVLAB(X,0))
QUIT
+14 IF BGPLT
IF $PIECE(^AUPNVLAB(X,0),U)
IF $DATA(^ATXLAB(BGPLT,21,"B",$PIECE(^AUPNVLAB(X,0),U)))
SET BGPC=1_U_(9999999-D)_U_"LAB"
QUIT
+15 IF 'T
QUIT
+16 SET J=$PIECE($GET(^AUPNVLAB(X,11)),U,13)
IF J=""
QUIT
+17 IF '$$LOINC^BGP5D21(J,T)
QUIT
+18 SET BGPC=1_U_(9999999-D)_U_"LOINC"
+19 QUIT
End DoDot:3
End DoDot:2
End DoDot:1
+20 IF BGPC
QUIT BGPC
+21 ;now check v microbiology
+22 SET B=9999999-BDATE
SET E=9999999-EDATE
SET D=E-1
FOR
SET D=$ORDER(^AUPNVMIC("AE",P,D))
IF D'=+D!(D>B)!($PIECE(BGPC,U))
QUIT
Begin DoDot:1
+23 SET L=0
FOR
SET L=$ORDER(^AUPNVMIC("AE",P,D,L))
IF L'=+L!($PIECE(BGPC,U))
QUIT
Begin DoDot:2
+24 SET X=0
FOR
SET X=$ORDER(^AUPNVMIC("AE",P,D,L,X))
IF X'=+X!($PIECE(BGPC,U))
QUIT
Begin DoDot:3
+25 IF '$DATA(^AUPNVMIC(X,0))
QUIT
+26 IF BGPLT
IF $PIECE(^AUPNVMIC(X,0),U)
IF $DATA(^ATXLAB(BGPLT,21,"B",$PIECE(^AUPNVMIC(X,0),U)))
SET BGPC=1_U_(9999999-D)_U_"MICRO"
QUIT
+27 IF 'T
QUIT
+28 SET J=$PIECE($GET(^AUPNVMIC(X,11)),U,13)
IF J=""
QUIT
+29 IF '$$LOINC^BGP5D21(J,T)
QUIT
+30 SET BGPC=1_U_(9999999-D)_U_"MICRO LOINC"
+31 QUIT
End DoDot:3
End DoDot:2
End DoDot:1
+32 QUIT BGPC
HEPC ;
+1 SET (BGPN1,BGPN2,BGPN3,BGPN4,BGPN5,BGPD1,BGPD2)=0
+2 ;BGPD1 - PTS WITH NO HEP C
+3 ;BGPD2 - PTS WITH HEP C
+4 ;BGPN1 - PTS SCREENED IF IN BGPD1
+5 ;BGPN2 - PTS WITH CONF TEST IF IN BGPD2
+6 ;BGPN3 - PTS IN BGPN2 WITH POS RESULT
+7 ;BGPN4 - PTS IN BGPN2 WITH NEG RESULT
+8 ;BGPN5 - PTS IN BGPN2 WITH NO RESULT
+9 NEW BGPHSCR
+10 SET BGPVALUE=""
+11 IF 'BGPACTUP
SET BGPSTOP=1
QUIT
+12 IF $$DOB^AUPNPAT(DFN)<2450101
QUIT
+13 IF $$DOB^AUPNPAT(DFN)>2651231
QUIT
+14 IF $$HEPCDX(DFN,BGPEDATE)
SET BGPD2=1
+15 IF 'BGPD2
SET BGPD1=1
+16 SET BGPHSCR=""
+17 IF BGPD1
SET BGPHSCR=$$HEPCSCR(DFN,BGPEDATE)
IF $PIECE(BGPHSCR,U,1)
SET BGPN1=1
+18 IF BGPD2
SET BGPHSCR=$$HEPCCON(DFN,BGPEDATE)
Begin DoDot:1
+19 IF $PIECE(BGPHSCR,U,1)
SET BGPN2=1
+20 IF $PIECE(BGPHSCR,U,5)="POS"
SET BGPN3=1
QUIT
+21 IF $PIECE(BGPHSCR,U,5)="NEG"
SET BGPN4=1
QUIT
+22 SET BGPN5=1
End DoDot:1
+23 IF BGPD1
SET BGPVALUE="UP|||"
IF BGPN1
SET BGPVALUE=BGPVALUE_"Screen: "_$PIECE(BGPHSCR,U,2)_" "_$PIECE(BGPHSCR,U,3)
+24 IF BGPD2
SET BGPVALUE="UP,HEP|||"
IF BGPN2
SET BGPVALUE=BGPVALUE_"Conf "_$PIECE(BGPHSCR,U,2)_" "_$PIECE(BGPHSCR,U,3)_" result="_$PIECE(BGPHSCR,U,5)
+25 QUIT
HEPCDX(P,EDATE) ;
+1 NEW T,X,G
+2 ;now check problem list
+3 SET T=$ORDER(^ATXAX("B","BGP HEPATITIS C DXS",0))
+4 SET (X,G)=0
FOR
SET X=$ORDER(^AUPNPROB("AC",P,X))
IF X'=+X!(G)
QUIT
Begin DoDot:1
+5 ;if added to pl after end of time period, no go
IF $PIECE(^AUPNPROB(X,0),U,8)>EDATE
QUIT
+6 SET Y=$PIECE(^AUPNPROB(X,0),U)
+7 IF $PIECE(^AUPNPROB(X,0),U,12)="D"
QUIT
+8 IF $PIECE(^AUPNPROB(X,0),U,12)="I"
QUIT
+9 IF '$$ICD^BGP5UTL2(Y,T,9)
QUIT
+10 SET G=1
+11 QUIT
End DoDot:1
+12 IF G
QUIT G
+13 SET X=$$LASTDX^BGP5UTL1(P,"BGP HEPATITIS C DXS")
+14 IF X
QUIT 1
+15 QUIT ""
HEPCSCR(P,EDATE) ;
+1 NEW X,G,T,%,BGPC,BGPLT,L,D,J
+2 SET %=""
SET E=+$$CODEN^ICPTCOD(86803)
SET %=$$CPTI^BGP5DU(P,$$DOB^AUPNPAT(P),EDATE,E)
+3 IF %
QUIT 1_U_$$DATE^BGP5UTL($PIECE(%,U,2))_" CPT 86803"
+4 ;now get all loinc/taxonomy tests
+5 SET BGPC=""
+6 SET T=$ORDER(^ATXAX("B","BGP HEP C TEST LOINC CODES",0))
+7 SET BGPLT=$ORDER(^ATXLAB("B","BGP HEP C TESTS TAX",0))
+8 SET E=9999999-EDATE
SET D=E-1
FOR
SET D=$ORDER(^AUPNVLAB("AE",P,D))
IF D'=+D!(BGPC)
QUIT
Begin DoDot:1
+9 SET L=0
FOR
SET L=$ORDER(^AUPNVLAB("AE",P,D,L))
IF L'=+L!(BGPC)
QUIT
Begin DoDot:2
+10 SET X=0
FOR
SET X=$ORDER(^AUPNVLAB("AE",P,D,L,X))
IF X'=+X!(BGPC)
QUIT
Begin DoDot:3
+11 IF '$DATA(^AUPNVLAB(X,0))
QUIT
+12 IF BGPLT
IF $PIECE(^AUPNVLAB(X,0),U)
IF $DATA(^ATXLAB(BGPLT,21,"B",$PIECE(^AUPNVLAB(X,0),U)))
SET BGPC=1_U_$$DATE^BGP5UTL((9999999-D))_" Lab Test"
QUIT
+13 IF 'T
QUIT
+14 SET J=$PIECE($GET(^AUPNVLAB(X,11)),U,13)
IF J=""
QUIT
+15 IF '$$LOINC^BGP5D2(J,T)
QUIT
+16 SET BGPC=1_U_$$DATE^BGP5UTL((9999999-D))_" Lab Test (Loinc "_$$VAL^XBDIQ1(9000010.09,X,1113)_")"
+17 QUIT
End DoDot:3
End DoDot:2
End DoDot:1
+18 QUIT BGPC
HEPCCON(P,EDATE) ;
+1 ;return first test with a valid result
+2 ;if none with a valid result, return 1st one
+3 NEW BGPG,BGPT,BGPLT
+4 ;GET ALL LABS INTO ARRAY BGPG
+5 SET BGPLT=$ORDER(^ATXAX("B","BGP HEP C CONF LOINC",0))
+6 SET BGPT=$ORDER(^ATXLAB("B","BGP HEP C CONF TEST TAX",0))
+7 NEW D,V,G,X,J,B,E,C,Y,R,I
+8 ;get inverse date and begin at edate-1 and end when greater than begin date
SET C=0
SET E=9999999-EDATE
+9 SET D=E-1
SET D=D_".9999"
FOR
SET D=$ORDER(^AUPNVLAB("AE",P,D))
IF D'=+D
QUIT
Begin DoDot:1
+10 SET X=0
FOR
SET X=$ORDER(^AUPNVLAB("AE",P,D,X))
IF X'=+X
QUIT
Begin DoDot:2
+11 SET Y=0
FOR
SET Y=$ORDER(^AUPNVLAB("AE",P,D,X,Y))
IF Y'=+Y
QUIT
Begin DoDot:3
+12 IF BGPT
IF $DATA(^ATXLAB(BGPT,21,"B",X))
DO SETLAB
QUIT
+13 IF 'BGPLT
QUIT
+14 SET J=$PIECE($GET(^AUPNVLAB(Y,11)),U,13)
IF J=""
QUIT
+15 IF '$$LOINC^BGP5D21(J,BGPLT)
QUIT
+16 DO SETLAB
QUIT
+17 QUIT
End DoDot:3
+18 QUIT
End DoDot:2
+19 QUIT
End DoDot:1
+20 ;NOW SET UP ARRAY AS DATE^ITEM^RESULT
+21 ;ADD IN CPT CODES
+22 SET X=$$FIRSTCPT^BGP5UTL1(P,"BGP HEP C CONF CPTS",$$DOB^AUPNPAT(P),EDATE)
+23 IF X
Begin DoDot:1
+24 SET C=C+1
+25 SET BGPG($PIECE(X,U,1),C)=$PIECE(X,U,1)_U_$PIECE(X,U,2)
End DoDot:1
+26 ;FIND FIRST WITH A VALID RESULT
+27 ;NO TESTS
IF '$ORDER(BGPG(0))
QUIT ""
+28 SET D=0
SET G=""
FOR
SET D=$ORDER(BGPG(D))
IF D'=+D!(G)
QUIT
Begin DoDot:1
+29 SET C=0
+30 FOR
SET C=$ORDER(BGPG(D,C))
IF C'=+C!(G)
QUIT
Begin DoDot:2
+31 ;Q:$P(BGPG(D,C),U,3)="" ;NO RESULT
+32 SET R=$PIECE(BGPG(D,C),U,3)
+33 SET I=""
IF $PIECE(BGPG(D,C),U,2)["Lab"
SET I=$PIECE(BGPG(D,C),U,4)
+34 SET Y=$$GOODRES(R,I)
IF Y]""
SET G=1_U_$$DATE^BGP5UTL($PIECE(BGPG(D,C),U,1))_U_$PIECE(BGPG(D,C),U,2)_U_$PIECE(BGPG(D,C),U,3)_U_Y
End DoDot:2
End DoDot:1
+35 ; IF NO RESULT TAKE FIRST ONE
+36 IF G
QUIT G
+37 SET D=$ORDER(BGPG(0))
SET C=$ORDER(BGPG(D,0))
+38 QUIT 1_U_$$DATE^BGP5UTL($PIECE(BGPG(D,C),U,1))_U_$PIECE(BGPG(D,C),U,2)_U_U_"No Result"
SETLAB ;
+1 SET C=C+1
+2 SET BGPG($$VDTM^APCLV($PIECE(^AUPNVLAB(Y,0),U,3)),C)=$$VD^APCLV($PIECE(^AUPNVLAB(Y,0),U,3))_"^"_"Lab"_"^"_$$VAL^XBDIQ1(9000010.09,Y,.04)_"^"_Y_"^"_$PIECE(^AUPNVLAB(Y,0),U,3)
+3 QUIT
CD4RES(P,BDATE,EDATE,NORES) ;EP
+1 NEW BGPG,BGPT,BGPC,BGPLT,T,B,E,D,L,X,R,G,C,%
+2 KILL BGPG,BGPT,BGPC
+3 SET BGPC=0
+4 SET NORES=$GET(NORES)
+5 ;now get all loinc/taxonomy tests
+6 SET T=$ORDER(^ATXAX("B","BGP CD4 LOINC CODES",0))
+7 SET BGPLT=$ORDER(^ATXLAB("B","BGP CD4 TAX",0))
+8 SET B=9999999-BDATE
SET E=9999999-EDATE
SET D=E-1
FOR
SET D=$ORDER(^AUPNVLAB("AE",P,D))
IF D'=+D!(D>B)
QUIT
Begin DoDot:1
+9 SET L=0
FOR
SET L=$ORDER(^AUPNVLAB("AE",P,D,L))
IF L'=+L
QUIT
Begin DoDot:2
+10 SET X=0
FOR
SET X=$ORDER(^AUPNVLAB("AE",P,D,L,X))
IF X'=+X
QUIT
Begin DoDot:3
+11 IF '$DATA(^AUPNVLAB(X,0))
QUIT
+12 IF BGPLT
IF $PIECE(^AUPNVLAB(X,0),U)
IF $DATA(^ATXLAB(BGPLT,21,"B",$PIECE(^AUPNVLAB(X,0),U)))
SET BGPC=BGPC+1
SET BGPT(D,BGPC)=$PIECE(^AUPNVLAB(X,0),U,4)
QUIT
+13 IF 'T
QUIT
+14 SET J=$PIECE($GET(^AUPNVLAB(X,11)),U,13)
IF J=""
QUIT
+15 IF '$$LOINC^BGP5D2(J,T)
QUIT
+16 SET R=$PIECE(^AUPNVLAB(X,0),U,4)
+17 IF 'R
SET R=""
+18 SET BGPC=BGPC+1
SET BGPT(D,BGPC)=R
+19 QUIT
End DoDot:3
End DoDot:2
End DoDot:1
+20 ; now got though and set return value of done 1 or 0^VALUE^date
+21 SET D=0
SET G=""
FOR
SET D=$ORDER(BGPT(D))
IF D'=+D!(G]"")
QUIT
Begin DoDot:1
+22 SET C=0
FOR
SET C=$ORDER(BGPT(D,C))
IF C'=+C!(G]"")
QUIT
Begin DoDot:2
+23 SET X=BGPT(D,C)
+24 IF X=""
QUIT
+25 SET G=(9999999-D)_U_X
+26 QUIT
End DoDot:2
End DoDot:1
+27 ;now get one with no result
IF G=""
Begin DoDot:1
+28 SET D=0
SET G=""
FOR
SET D=$ORDER(BGPT(D))
IF D'=+D!(G]"")
QUIT
Begin DoDot:2
+29 SET C=0
FOR
SET C=$ORDER(BGPT(D,C))
IF C'=+C!(G]"")
QUIT
Begin DoDot:3
+30 SET X=BGPT(D,C)
+31 IF X=""
QUIT
+32 SET G=(9999999-D)_U_X
End DoDot:3
+33 QUIT
End DoDot:2
End DoDot:1
+34 ;
+35 ;IF WANT A RESULT AND THERE IS ONE QUIT
IF 'NORES
IF G]""
QUIT 1_U_G
+36 SET %=$$CPT^BGP5DU(P,BDATE,EDATE,$ORDER(^ATXAX("B","BGP CD4 CPTS",0)),5)
+37 IF %]""
SET BGPC=BGPC+1
SET BGPT(9999999-$PIECE(%,U,1),BGPC)="CPT "_$PIECE(%,U,2)
+38 SET %=$$TRAN^BGP5DU(P,BDATE,EDATE,$ORDER(^ATXAX("B","BGP CD4 CPTS",0)),5)
+39 IF %]""
SET BGPC=BGPC+1
SET BGPT(9999999-$PIECE(%,U,1),BGPC)="CPT "_$PIECE(%,U,2)
+40 IF '$ORDER(BGPT(0))
QUIT ""
+41 SET %=$ORDER(BGPT(0))
SET C=$ORDER(BGPT(%,0))
QUIT 1_"^"_(9999999-%)_"^"_BGPT(%,C)
+42 QUIT ""
+43 ;
GOODRES(R,I) ;EP
+1 ;is this a good result
+2 ;Positive confirmation test result defined as any number greater than
+3 ;zero, "Pos", "Positive", "Detected", a result starting with ">", or a
+4 ;result starting with a number.
+5 ;Negative confirmation test result defined as a result starting with "<", "Neg", "Negative", "None detected", "None Detec", or "Not detected".
+6 SET R=$GET(R)
+7 IF R=""
QUIT ""
+8 SET R=$$UP^XLFSTR(R)
+9 IF $EXTRACT(R)="<"
QUIT "NEG"
+10 IF R["NEGATIVE"
QUIT "NEG"
+11 IF R["NEG"
QUIT "NEG"
+12 IF R["NONE DETECTED"
QUIT "NEG"
+13 IF R["NONE DETEC"
QUIT "NEG"
+14 IF R["NOT DETECTED"
QUIT "NEG"
+15 IF R["NOTDETECTED"
QUIT "NEG"
+16 IF R["NOT DETECT"
QUIT "NEG"
+17 IF $EXTRACT(R)=">"
QUIT "POS"
+18 IF R["POSITIVE"
QUIT "POS"
+19 IF R["DETECTED"
QUIT "POS"
+20 IF R["POS"
QUIT "POS"
+21 IF +R>0
QUIT "POS"
+22 QUIT ""
GOODRES1 ;
+1 IF '$GET(I)
QUIT ""
+2 ;comments field
+3 IF $$UP^XLFSTR($GET(^AUPNVLAB(I,13)))["NOT DETECTED"
QUIT "NEG"
+4 NEW J,K,T
+5 SET T=""
+6 SET J=0
SET K=""
FOR
SET J=$ORDER(^AUPNVLAB(I,21,J))
IF J'=+J
QUIT
Begin DoDot:1
+7 SET K=K_$GET(^AUPNVLAB(I,21,J,0))
End DoDot:1
+8 IF $$UP^XLFSTR(K)["NOT DETECTED"
QUIT "NEG"
+9 IF $$UP^XLFSTR(K)["NOTDETECTED"
QUIT "NEG"
+10 QUIT ""
