BGP8D841 ; IHS/CMI/LAB - measure C ;
;;18.1;IHS CLINICAL REPORTING;;MAY 25, 2018;Build 66
;
HEPC ;EP - called from BGP8D84
I 'BGPACTUP S BGPSTOP=1 Q
S (BGPN1,BGPN2,BGPN3,BGPN4,BGPN5,BGPN6,BGPN7,BGPN8,BGPN9,BGPN10,BGPN11,BGPD1,BGPD2,BGPD3,BGPD4,BGPD5,BGPD6,BGPD7)=0
;BGPD1 - PTS WITH NO HEP C 1945-1965
;BGPD2 - PTS WITH HEP C 1945-1965
;BGPD3 - UP WITH HEP C OR AB RESULT
;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
;BGPN6 - PTS W/HEP C DX
;BGPN7 - PTS W/AB POS EVER
;BGPN8 - POS SCREEN
;BGPN9 - NEG SCREEN
NEW BGPHSCR,BGPHHEP,BGPABPOS,BGPHCON,BGPHCON1,BGPVALX
S BGPHHEP="",BGPVALUE="",BGPABPOS="",BGPHCON="",BGPHCON1="",BGPVALX=""
S BGPHHEP=$$HEPCDX(DFN,BGPEDATE) I +BGPHHEP S BGPVALX="Hep C Dx: "_$$DATE^BGP8UTL($P(BGPHHEP,U,1))_" "_$P(BGPHHEP,U,2)
S BGPABPOS=$$ABPOSEV(DFN,BGPEDATE) I BGPABPOS S:BGPVALX]"" BGPVALX=BGPVALX_"; " S BGPVALX=BGPVALX_"Ab Test Pos: "_$P(BGPABPOS,U,2)
S D=$$DOB^AUPNPAT(DFN)
I D<2450101 G N
I D>2651231 G N
I BGPHHEP!(BGPABPOS) S BGPD2=1
I 'BGPHHEP S BGPD1=1
N ;
I BGPHHEP!(BGPABPOS) S BGPD3=1 ;all up
I BGPHHEP S BGPN11=1
I BGPABPOS S BGPN10=1
S BGPHSCR=""
I BGPD1 S BGPHSCR=$$HEPSCRR(DFN,BGPEDATE) I $P(BGPHSCR,U,1) S BGPN1=1 S:BGPVALX]"" BGPVALX=BGPVALX_"; " S BGPVALX=BGPVALX_"Screen: "_$P(BGPHSCR,U,2)
I BGPD1,'BGPN1 S BGPHSCR=$$HEPSCR(DFN,BGPEDATE) I $P(BGPHSCR,U,1) S BGPN1=1 S:BGPVALX]"" BGPVALX=BGPVALX_"; " S BGPVALX=BGPVALX_"Screen: "_$P(BGPHSCR,U,2)_" result=No Result"
I $P(BGPHSCR,U,3)="POS" S BGPN6=1
I $P(BGPHSCR,U,3)="NEG" S BGPN7=1
I BGPD2!BGPD3 S BGPHCON=$$HEPCCON(DFN,BGPEDATE) D
.I $P(BGPHCON,U,1) S BGPN2=1 S:BGPVALX]"" BGPVALX=BGPVALX_"; " S BGPVALX=BGPVALX_"Conf: "_$P(BGPHCON,U,2)_" "_$P(BGPHCON,U,3)_"="_$P(BGPHCON,U,5)
.I $P(BGPHCON,U,5)="POS" S BGPN3=1 Q
.I $P(BGPHCON,U,5)="NEG" S BGPN4=1 Q
.S BGPN5=1
;
;
;GET ALL CONFIRMATION TESTS
K BGPCONFT
I '(BGPD2+BGPD3) G SL1
I 'BGPN3 G SL1
D GETALLCF
I $D(BGPCONFT("POS")) S BGPD6=1
S D=$$DOB^AUPNPAT(DFN)
I D<2450101 G SL
I D>2651231 G SL
I $D(BGPCONFT("POS")) S BGPD7=1
SL I BGPD6!(BGPD7) D
.;BGPN8 - EVER HAD NEG WITHIN 12 WEEKS OF ANY POS
.;BGPN9 - EVER HAD NEG WITHIN 12 WEEKS OF last positive
.I '$D(BGPCONFT("NEG")) Q ;NEVER HAD A NEGATIVE
.S X="" F S X=$O(BGPCONFT("POS",X)) Q:X'=+X S L=X ;L IS DATE OF LAST POSITIVE
.S L=$P(L,".")
.;CHECK LAST ONE FIRST, IF A HIT MAKES BOTH NUMERATORS
.S X=L F S X=$O(BGPCONFT("NEG",X)) Q:X'=+X!(BGPN8) D I BGPN8 G SL1
..S Y=$$FMDIFF^XLFDT(X,L)
..I Y>83 S (BGPN8,BGPN9)=1,BGPVALX=BGPVALX_"; Currently Cured"
.;NOW CHECK ANY POS
.S X=0 F S X=$O(BGPCONFT("POS",X)) Q:X'=+X!(BGPN8) D
..S G=0 S Y=X F S Y=$O(BGPCONFT(Y)) Q:Y'=+Y!(G)!(BGPN8) D
...S G=0
...I $D(BGPCONFT("POS",Y)) S G=1 Q ;Q IF IT IS A POS AND GO TO THE NEXT POS
...I $D(BGPCONFT("UNK",Y)) S G=1 Q ;Q IF IT IS AN UNK
...S Z=$$FMDIFF^XLFDT(Y,X)
...I Z>83 S (BGPN8)=1,BGPVALX=BGPVALX_"; Ever Cured"
SL1 ;
I BGPD1 S BGPVALUE="UP|||"_BGPVALX
I BGPD2!(BGPD3) S BGPVALUE="UP,HEP|||"_BGPVALX
Q
HEPCDX(P,EDATE) ;
NEW T,X,G
S X=$$LASTDX^BGP8UTL1(P,"BGP HEPATITIS C DXS",,EDATE)
I X Q $P(X,U,3)_U_"POV "_$P(X,U,2)
;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
.I EDATE,$P(^AUPNPROB(X,0),U,13)>EDATE Q
.I $P(^AUPNPROB(X,0),U,13)="" 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^BGP8UTL2(Y,T,9)
.S G=$P(^AUPNPROB(X,0),U,8)_U_" Problem List "_$$VAL^XBDIQ1(9000011,X,.01)
.Q
I G Q G
S X=$$PLTAXID^BGP8DU(P,"BGP HEPATITIS C DXS",$$DOB^AUPNPAT(P),EDATE)
I X Q $P(X,U,3)_U_$P(X,U,2)
S X=$$IPLSNOID^BGP8DU(P,"PXRM HEPATITIS C",$$DOB^AUPNPAT(P),EDATE)
I X Q $P(X,U,3)_U_$P(X,U,2)
Q ""
HEPSCR(P,EDATE) ;
NEW X,G,T,%,BGPC,BGPLT,L,D,J
;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^BGP8UTL((9999999-D))_" Lab Test" Q
...Q:'T
...S J=$P($G(^AUPNVLAB(X,11)),U,13) Q:J=""
...Q:'$$LOINC^BGP8D2(J,T)
...S BGPC=1_U_$$DATE^BGP8UTL((9999999-D))_" Lab Test (Loinc "_$$VAL^XBDIQ1(9000010.09,X,1113)_")"
...Q
I BGPC Q BGPC
S %="",E=+$$CODEN^ICPTCOD(86803),%=$$CPTI^BGP8DU(P,$$DOB^AUPNPAT(P),EDATE,E)
I % Q 1_U_$$DATE^BGP8UTL($P(%,U,2))_" CPT 86803"
Q BGPC
ABPOSEV(P,EDATE) ;
NEW X,G,T,%,BGPC,BGPLT,L,D,J
;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))) D
....I $$POS($P(^AUPNVLAB(X,0),U,4)) S BGPC=1_U_$$DATE^BGP8UTL((9999999-D))_" "_$$VAL^XBDIQ1(9000010.09,X,.01)_" result: "_$P(^AUPNVLAB(X,0),U,4) Q
...Q:'T
...S J=$P($G(^AUPNVLAB(X,11)),U,13) Q:J=""
...Q:'$$LOINC^BGP8D2(J,T)
...Q:'$$POS($P(^AUPNVLAB(X,0),U,4))
...S BGPC=1_U_$$DATE^BGP8UTL((9999999-D))_" Lab Test (Loinc "_$$VAL^XBDIQ1(9000010.09,X,1113)_")"_" "_$$VAL^XBDIQ1(9000010.09,X,.01)_" result: "_$P(^AUPNVLAB(X,0),U,4) ; Result POS"
...Q
Q BGPC
HEPSCRR(P,EDATE) ;RETURN LAST WITH A RESULT
NEW X,G,T,%,BGPC,BGPLT,L,D,J,R
;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 R=$$RES($P(^AUPNVLAB(X,0),U,4)) I R]"" S BGPC=1_U_$$DATE^BGP8UTL((9999999-D))_" "_$$VAL^XBDIQ1(9000010.09,X,.01)_" result="_$P(^AUPNVLAB(X,0),U,4)_" "_R_U_R Q
...Q:'T
...S J=$P($G(^AUPNVLAB(X,11)),U,13) Q:J=""
...Q:'$$LOINC^BGP8D2(J,T)
...S R=$$RES($P(^AUPNVLAB(X,0),U,4))
...Q:R=""
...S BGPC=1_U_$$DATE^BGP8UTL((9999999-D))_" Lab Test (Loinc "_$$VAL^XBDIQ1(9000010.09,X,1113)_" "_$$VAL^XBDIQ1(9000010.09,X,.01)_") result="_$P(^AUPNVLAB(X,0),U,4)_" "_R_U_R
...Q
Q BGPC
HEPCCON(P,EDATE) ;
;return first test with a POSITIVE result
;if none return first with a negative result
;if none return first one found
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^BGP8D21(J,BGPLT)
...D SETLAB Q
...Q
..Q
.Q
;NOW SET UP ARRAY AS DATE^ITEM^RESULT
;ADD IN CPT CODES
S X=$$FIRSTCPT^BGP8UTL1(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="POS" S G=1_U_$$DATE^BGP8UTL($P(BGPG(D,C),U,1))_U_$P(BGPG(D,C),U,2)_U_$P(BGPG(D,C),U,3)_U_Y
I G Q G
;IF NO POS RESULT TAKE FIRST ONE WITH NEG RESULT
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="NEG" S G=1_U_$$DATE^BGP8UTL($P(BGPG(D,C),U,1))_U_$P(BGPG(D,C),U,2)_U_$P(BGPG(D,C),U,3)_U_Y
I G Q G
;IF NO NEG TAKE 1ST WITH NO RESULT
S D=$O(BGPG(0)),C=$O(BGPG(D,0))
Q 1_U_$$DATE^BGP8UTL($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))_"^"_$$VAL^XBDIQ1(9000010.09,Y,.01)_" Lab Result"_"^"_$$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))
...S R=$P(^AUPNVLAB(X,0),U,4) I 'R S R=""
...I BGPLT,$P(^AUPNVLAB(X,0),U),$D(^ATXLAB(BGPLT,21,"B",$P(^AUPNVLAB(X,0),U))) S BGPC=BGPC+1,BGPT(D,BGPC)=R Q
...Q:'T
...S J=$P($G(^AUPNVLAB(X,11)),U,13) Q:J=""
...Q:'$$LOINC^BGP8D2(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^BGP8DU(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^BGP8DU(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 "POS"
I $E(R)=">" Q "POS"
I R["NON" Q "NEG"
I R["NOT" Q "NEG"
I R["NEGATIVE" Q "NEG"
I R["NEG" Q "NEG"
I R["NONE" 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 R["POSITIVE" Q "POS"
I R["DETECTED" Q "POS"
I R["POS" Q "POS"
I R["DETEC" Q "POS"
I R["REACT" Q "POS"
I +R>0 Q "POS"
Q ""
GOODRES1 ;FOR HEP SCREENING TEST
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 ""
POS(R) ;IS THE RESULT A POSITIVE
I $G(R)="" Q ""
S R=$$UP^XLFSTR(R)
I $E(R)="<" Q ""
I R["NON" Q ""
I R["NOT" Q ""
I R["NEGATIVE" Q ""
I R["NEG" Q ""
I R["NONE DETECTED" Q ""
I R["NONE" Q ""
I R["NONE DETEC" Q ""
I R["NOT DETECTED" Q ""
I R["NOTDETECTED" Q ""
I $E(R)=">" Q 1
I R["POSITIVE" Q 1
I R["DETECTED" Q 1
I R["POS" Q 1
I R["DETEC" Q 1
I R["REACT" Q 1
;I +R>0 Q 1
Q ""
NEG(R) ;
I $G(R)="" Q ""
S R=$G(R)
I R="" Q ""
S R=$$UP^XLFSTR(R)
I $E(R)="<" Q 1
I R["NEGATIVE" Q 1
I R["NEG" Q 1
I R["NONE DETECTED" Q 1
I R["NONE DETEC" Q 1
I R["NOT DETECTED" Q 1
I R["NOTDETECTED" Q 1
I R["NOT DETECT" Q 1
I R["NON" Q 1
Q ""
GETALLCF ;
;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-BGPEDATE ;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",DFN,D)) Q:D'=+D D
.S X=0 F S X=$O(^AUPNVLAB("AE",DFN,D,X)) Q:X'=+X D
..S Y=0 F S Y=$O(^AUPNVLAB("AE",DFN,D,X,Y)) Q:Y'=+Y D
...I BGPT,$D(^ATXLAB(BGPT,21,"B",X)) D SETLABC Q
...Q:'BGPLT
...S J=$P($G(^AUPNVLAB(Y,11)),U,13) Q:J=""
...Q:'$$LOINC^BGP8D21(J,BGPLT)
...D SETLABC Q
...Q
..Q
.Q
Q
SETLABC ;
S C=C+1
S R=$$GOODRES($P(^AUPNVLAB(Y,0),U,4))
I R="" Q
S BGPCONFT($$VDTM^APCLV($P(^AUPNVLAB(Y,0),U,3)),R)=$$VD^APCLV($P(^AUPNVLAB(Y,0),U,3))_"^"_"Lab"_"^"_$$VAL^XBDIQ1(9000010.09,Y,.04)_"^"_Y_"^"_$P(^AUPNVLAB(Y,0),U,3)
S BGPCONFT(R,$$VDTM^APCLV($P(^AUPNVLAB(Y,0),U,3)))=$$VD^APCLV($P(^AUPNVLAB(Y,0),U,3))_"^"_"Lab"_"^"_$$VAL^XBDIQ1(9000010.09,Y,.04)_"^"_Y_"^"_$P(^AUPNVLAB(Y,0),U,3)
Q
RES(R) ;IS THE RESULT A POSITIVE
I $G(R)="" Q ""
S R=$$UP^XLFSTR(R)
I $E(R)="<" Q "NEG"
I R["NON" Q "NEG"
I R["NOT" Q "NEG"
I R["NEGATIVE" Q "NEG"
I R["NEG" Q "NEG"
I R["NONE DETECTED" Q "NEG"
I R["NONE" Q "NEG"
I R["NONE DETEC" Q "NEG"
I R["NOT DETECTED" Q "NEG"
I R["NOTDETECTED" Q "NEG"
I $E(R)=">" Q "POS"
I R["POSITIVE" Q "POS"
I R["DETECTED" Q "POS"
I R["POS" Q "POS"
I R["DETEC" Q "POS"
I R["REACT" Q "POS"
I +R>0 Q "NO RESULT"
Q ""
BGP8D841 ; IHS/CMI/LAB - measure C ;
+1 ;;18.1;IHS CLINICAL REPORTING;;MAY 25, 2018;Build 66
+2 ;
HEPC ;EP - called from BGP8D84
+1 IF 'BGPACTUP
SET BGPSTOP=1
QUIT
+2 SET (BGPN1,BGPN2,BGPN3,BGPN4,BGPN5,BGPN6,BGPN7,BGPN8,BGPN9,BGPN10,BGPN11,BGPD1,BGPD2,BGPD3,BGPD4,BGPD5,BGPD6,BGPD7)=0
+3 ;BGPD1 - PTS WITH NO HEP C 1945-1965
+4 ;BGPD2 - PTS WITH HEP C 1945-1965
+5 ;BGPD3 - UP WITH HEP C OR AB RESULT
+6 ;BGPN1 - PTS SCREENED IF IN BGPD1
+7 ;BGPN2 - PTS WITH CONF TEST IF IN BGPD2
+8 ;BGPN3 - PTS IN BGPN2 WITH POS RESULT
+9 ;BGPN4 - PTS IN BGPN2 WITH NEG RESULT
+10 ;BGPN5 - PTS IN BGPN2 WITH NO RESULT
+11 ;BGPN6 - PTS W/HEP C DX
+12 ;BGPN7 - PTS W/AB POS EVER
+13 ;BGPN8 - POS SCREEN
+14 ;BGPN9 - NEG SCREEN
+15 NEW BGPHSCR,BGPHHEP,BGPABPOS,BGPHCON,BGPHCON1,BGPVALX
+16 SET BGPHHEP=""
SET BGPVALUE=""
SET BGPABPOS=""
SET BGPHCON=""
SET BGPHCON1=""
SET BGPVALX=""
+17 SET BGPHHEP=$$HEPCDX(DFN,BGPEDATE)
IF +BGPHHEP
SET BGPVALX="Hep C Dx: "_$$DATE^BGP8UTL($PIECE(BGPHHEP,U,1))_" "_$PIECE(BGPHHEP,U,2)
+18 SET BGPABPOS=$$ABPOSEV(DFN,BGPEDATE)
IF BGPABPOS
IF BGPVALX]""
SET BGPVALX=BGPVALX_"; "
SET BGPVALX=BGPVALX_"Ab Test Pos: "_$PIECE(BGPABPOS,U,2)
+19 SET D=$$DOB^AUPNPAT(DFN)
+20 IF D<2450101
GOTO N
+21 IF D>2651231
GOTO N
+22 IF BGPHHEP!(BGPABPOS)
SET BGPD2=1
+23 IF 'BGPHHEP
SET BGPD1=1
N ;
+1 ;all up
IF BGPHHEP!(BGPABPOS)
SET BGPD3=1
+2 IF BGPHHEP
SET BGPN11=1
+3 IF BGPABPOS
SET BGPN10=1
+4 SET BGPHSCR=""
+5 IF BGPD1
SET BGPHSCR=$$HEPSCRR(DFN,BGPEDATE)
IF $PIECE(BGPHSCR,U,1)
SET BGPN1=1
IF BGPVALX]""
SET BGPVALX=BGPVALX_"; "
SET BGPVALX=BGPVALX_"Screen: "_$PIECE(BGPHSCR,U,2)
+6 IF BGPD1
IF 'BGPN1
SET BGPHSCR=$$HEPSCR(DFN,BGPEDATE)
IF $PIECE(BGPHSCR,U,1)
SET BGPN1=1
IF BGPVALX]""
SET BGPVALX=BGPVALX_"; "
SET BGPVALX=BGPVALX_"Screen: "_$PIECE(BGPHSCR,U,2)_" result=No Result"
+7 IF $PIECE(BGPHSCR,U,3)="POS"
SET BGPN6=1
+8 IF $PIECE(BGPHSCR,U,3)="NEG"
SET BGPN7=1
+9 IF BGPD2!BGPD3
SET BGPHCON=$$HEPCCON(DFN,BGPEDATE)
Begin DoDot:1
+10 IF $PIECE(BGPHCON,U,1)
SET BGPN2=1
IF BGPVALX]""
SET BGPVALX=BGPVALX_"; "
SET BGPVALX=BGPVALX_"Conf: "_$PIECE(BGPHCON,U,2)_" "_$PIECE(BGPHCON,U,3)_"="_$PIECE(BGPHCON,U,5)
+11 IF $PIECE(BGPHCON,U,5)="POS"
SET BGPN3=1
QUIT
+12 IF $PIECE(BGPHCON,U,5)="NEG"
SET BGPN4=1
QUIT
+13 SET BGPN5=1
End DoDot:1
+14 ;
+15 ;
+16 ;GET ALL CONFIRMATION TESTS
+17 KILL BGPCONFT
+18 IF '(BGPD2+BGPD3)
GOTO SL1
+19 IF 'BGPN3
GOTO SL1
+20 DO GETALLCF
+21 IF $DATA(BGPCONFT("POS"))
SET BGPD6=1
+22 SET D=$$DOB^AUPNPAT(DFN)
+23 IF D<2450101
GOTO SL
+24 IF D>2651231
GOTO SL
+25 IF $DATA(BGPCONFT("POS"))
SET BGPD7=1
SL IF BGPD6!(BGPD7)
Begin DoDot:1
+1 ;BGPN8 - EVER HAD NEG WITHIN 12 WEEKS OF ANY POS
+2 ;BGPN9 - EVER HAD NEG WITHIN 12 WEEKS OF last positive
+3 ;NEVER HAD A NEGATIVE
IF '$DATA(BGPCONFT("NEG"))
QUIT
+4 ;L IS DATE OF LAST POSITIVE
SET X=""
FOR
SET X=$ORDER(BGPCONFT("POS",X))
IF X'=+X
QUIT
SET L=X
+5 SET L=$PIECE(L,".")
+6 ;CHECK LAST ONE FIRST, IF A HIT MAKES BOTH NUMERATORS
+7 SET X=L
FOR
SET X=$ORDER(BGPCONFT("NEG",X))
IF X'=+X!(BGPN8)
QUIT
Begin DoDot:2
+8 SET Y=$$FMDIFF^XLFDT(X,L)
+9 IF Y>83
SET (BGPN8,BGPN9)=1
SET BGPVALX=BGPVALX_"; Currently Cured"
End DoDot:2
IF BGPN8
GOTO SL1
+10 ;NOW CHECK ANY POS
+11 SET X=0
FOR
SET X=$ORDER(BGPCONFT("POS",X))
IF X'=+X!(BGPN8)
QUIT
Begin DoDot:2
+12 SET G=0
SET Y=X
FOR
SET Y=$ORDER(BGPCONFT(Y))
IF Y'=+Y!(G)!(BGPN8)
QUIT
Begin DoDot:3
+13 SET G=0
+14 ;Q IF IT IS A POS AND GO TO THE NEXT POS
IF $DATA(BGPCONFT("POS",Y))
SET G=1
QUIT
+15 ;Q IF IT IS AN UNK
IF $DATA(BGPCONFT("UNK",Y))
SET G=1
QUIT
+16 SET Z=$$FMDIFF^XLFDT(Y,X)
+17 IF Z>83
SET (BGPN8)=1
SET BGPVALX=BGPVALX_"; Ever Cured"
End DoDot:3
End DoDot:2
End DoDot:1
SL1 ;
+1 IF BGPD1
SET BGPVALUE="UP|||"_BGPVALX
+2 IF BGPD2!(BGPD3)
SET BGPVALUE="UP,HEP|||"_BGPVALX
+3 QUIT
HEPCDX(P,EDATE) ;
+1 NEW T,X,G
+2 SET X=$$LASTDX^BGP8UTL1(P,"BGP HEPATITIS C DXS",,EDATE)
+3 IF X
QUIT $PIECE(X,U,3)_U_"POV "_$PIECE(X,U,2)
+4 ;now check problem list
+5 SET T=$ORDER(^ATXAX("B","BGP HEPATITIS C DXS",0))
+6 SET (X,G)=0
FOR
SET X=$ORDER(^AUPNPROB("AC",P,X))
IF X'=+X!(G)
QUIT
Begin DoDot:1
+7 IF EDATE
IF $PIECE(^AUPNPROB(X,0),U,13)>EDATE
QUIT
+8 ;if added to pl after end of time period, no go
IF $PIECE(^AUPNPROB(X,0),U,13)=""
IF $PIECE(^AUPNPROB(X,0),U,8)>EDATE
QUIT
+9 SET Y=$PIECE(^AUPNPROB(X,0),U)
+10 IF $PIECE(^AUPNPROB(X,0),U,12)="D"
QUIT
+11 IF $PIECE(^AUPNPROB(X,0),U,12)="I"
QUIT
+12 IF '$$ICD^BGP8UTL2(Y,T,9)
QUIT
+13 SET G=$PIECE(^AUPNPROB(X,0),U,8)_U_" Problem List "_$$VAL^XBDIQ1(9000011,X,.01)
+14 QUIT
End DoDot:1
+15 IF G
QUIT G
+16 SET X=$$PLTAXID^BGP8DU(P,"BGP HEPATITIS C DXS",$$DOB^AUPNPAT(P),EDATE)
+17 IF X
QUIT $PIECE(X,U,3)_U_$PIECE(X,U,2)
+18 SET X=$$IPLSNOID^BGP8DU(P,"PXRM HEPATITIS C",$$DOB^AUPNPAT(P),EDATE)
+19 IF X
QUIT $PIECE(X,U,3)_U_$PIECE(X,U,2)
+20 QUIT ""
HEPSCR(P,EDATE) ;
+1 NEW X,G,T,%,BGPC,BGPLT,L,D,J
+2 ;now get all loinc/taxonomy tests
+3 SET BGPC=""
+4 SET T=$ORDER(^ATXAX("B","BGP HEP C TEST LOINC CODES",0))
+5 SET BGPLT=$ORDER(^ATXLAB("B","BGP HEP C TESTS TAX",0))
+6 SET E=9999999-EDATE
SET D=E-1
FOR
SET D=$ORDER(^AUPNVLAB("AE",P,D))
IF D'=+D!(BGPC)
QUIT
Begin DoDot:1
+7 SET L=0
FOR
SET L=$ORDER(^AUPNVLAB("AE",P,D,L))
IF L'=+L!(BGPC)
QUIT
Begin DoDot:2
+8 SET X=0
FOR
SET X=$ORDER(^AUPNVLAB("AE",P,D,L,X))
IF X'=+X!(BGPC)
QUIT
Begin DoDot:3
+9 IF '$DATA(^AUPNVLAB(X,0))
QUIT
+10 IF BGPLT
IF $PIECE(^AUPNVLAB(X,0),U)
IF $DATA(^ATXLAB(BGPLT,21,"B",$PIECE(^AUPNVLAB(X,0),U)))
SET BGPC=1_U_$$DATE^BGP8UTL((9999999-D))_" Lab Test"
QUIT
+11 IF 'T
QUIT
+12 SET J=$PIECE($GET(^AUPNVLAB(X,11)),U,13)
IF J=""
QUIT
+13 IF '$$LOINC^BGP8D2(J,T)
QUIT
+14 SET BGPC=1_U_$$DATE^BGP8UTL((9999999-D))_" Lab Test (Loinc "_$$VAL^XBDIQ1(9000010.09,X,1113)_")"
+15 QUIT
End DoDot:3
End DoDot:2
End DoDot:1
+16 IF BGPC
QUIT BGPC
+17 SET %=""
SET E=+$$CODEN^ICPTCOD(86803)
SET %=$$CPTI^BGP8DU(P,$$DOB^AUPNPAT(P),EDATE,E)
+18 IF %
QUIT 1_U_$$DATE^BGP8UTL($PIECE(%,U,2))_" CPT 86803"
+19 QUIT BGPC
ABPOSEV(P,EDATE) ;
+1 NEW X,G,T,%,BGPC,BGPLT,L,D,J
+2 ;now get all loinc/taxonomy tests
+3 SET BGPC=""
+4 SET T=$ORDER(^ATXAX("B","BGP HEP C TEST LOINC CODES",0))
+5 SET BGPLT=$ORDER(^ATXLAB("B","BGP HEP C TESTS TAX",0))
+6 SET E=9999999-EDATE
SET D=E-1
FOR
SET D=$ORDER(^AUPNVLAB("AE",P,D))
IF D'=+D!(BGPC)
QUIT
Begin DoDot:1
+7 SET L=0
FOR
SET L=$ORDER(^AUPNVLAB("AE",P,D,L))
IF L'=+L!(BGPC)
QUIT
Begin DoDot:2
+8 SET X=0
FOR
SET X=$ORDER(^AUPNVLAB("AE",P,D,L,X))
IF X'=+X!(BGPC)
QUIT
Begin DoDot:3
+9 IF '$DATA(^AUPNVLAB(X,0))
QUIT
+10 IF BGPLT
IF $PIECE(^AUPNVLAB(X,0),U)
IF $DATA(^ATXLAB(BGPLT,21,"B",$PIECE(^AUPNVLAB(X,0),U)))
Begin DoDot:4
+11 IF $$POS($PIECE(^AUPNVLAB(X,0),U,4))
SET BGPC=1_U_$$DATE^BGP8UTL((9999999-D))_" "_$$VAL^XBDIQ1(9000010.09,X,.01)_" result: "_$PIECE(^AUPNVLAB(X,0),U,4)
QUIT
End DoDot:4
+12 IF 'T
QUIT
+13 SET J=$PIECE($GET(^AUPNVLAB(X,11)),U,13)
IF J=""
QUIT
+14 IF '$$LOINC^BGP8D2(J,T)
QUIT
+15 IF '$$POS($PIECE(^AUPNVLAB(X,0),U,4))
QUIT
+16 ; Result POS"
SET BGPC=1_U_$$DATE^BGP8UTL((9999999-D))_" Lab Test (Loinc "_$$VAL^XBDIQ1(9000010.09,X,1113)_")"_" "_$$VAL^XBDIQ1(9000010.09,X,.01)_" result: "_$PIECE(^AUPNVLAB(X,0),U,4)
+17 QUIT
End DoDot:3
End DoDot:2
End DoDot:1
+18 QUIT BGPC
HEPSCRR(P,EDATE) ;RETURN LAST WITH A RESULT
+1 NEW X,G,T,%,BGPC,BGPLT,L,D,J,R
+2 ;now get all loinc/taxonomy tests
+3 SET BGPC=""
+4 SET T=$ORDER(^ATXAX("B","BGP HEP C TEST LOINC CODES",0))
+5 SET BGPLT=$ORDER(^ATXLAB("B","BGP HEP C TESTS TAX",0))
+6 SET E=9999999-EDATE
SET D=E-1
FOR
SET D=$ORDER(^AUPNVLAB("AE",P,D))
IF D'=+D!(BGPC)
QUIT
Begin DoDot:1
+7 SET L=0
FOR
SET L=$ORDER(^AUPNVLAB("AE",P,D,L))
IF L'=+L!(BGPC)
QUIT
Begin DoDot:2
+8 SET X=0
FOR
SET X=$ORDER(^AUPNVLAB("AE",P,D,L,X))
IF X'=+X!(BGPC)
QUIT
Begin DoDot:3
+9 IF '$DATA(^AUPNVLAB(X,0))
QUIT
+10 IF BGPLT
IF $PIECE(^AUPNVLAB(X,0),U)
IF $DATA(^ATXLAB(BGPLT,21,"B",$PIECE(^AUPNVLAB(X,0),U)))
SET R=$$RES($PIECE(^AUPNVLAB(X,0),U,4))
IF R]""
SET BGPC=1_U_$$DATE^BGP8UTL((9999999-D))_" "_$$VAL^XBDIQ1(9000010.09,X,.01)_" result="_$PIECE(^AUPNVLAB(X,0),U,4)_" "_R_U_R
QUIT
+11 IF 'T
QUIT
+12 SET J=$PIECE($GET(^AUPNVLAB(X,11)),U,13)
IF J=""
QUIT
+13 IF '$$LOINC^BGP8D2(J,T)
QUIT
+14 SET R=$$RES($PIECE(^AUPNVLAB(X,0),U,4))
+15 IF R=""
QUIT
+16 SET BGPC=1_U_$$DATE^BGP8UTL((9999999-D))_" Lab Test (Loinc "_$$VAL^XBDIQ1(9000010.09,X,1113)_" "_$$VAL^XBDIQ1(9000010.09,X,.01)_") result="_$PIECE(^AUPNVLAB(X,0),U,4)_" "_R_U_R
+17 QUIT
End DoDot:3
End DoDot:2
End DoDot:1
+18 QUIT BGPC
HEPCCON(P,EDATE) ;
+1 ;return first test with a POSITIVE result
+2 ;if none return first with a negative result
+3 ;if none return first one found
+4 NEW BGPG,BGPT,BGPLT
+5 ;GET ALL LABS INTO ARRAY BGPG
+6 SET BGPLT=$ORDER(^ATXAX("B","BGP HEP C CONF LOINC",0))
+7 SET BGPT=$ORDER(^ATXLAB("B","BGP HEP C CONF TEST TAX",0))
+8 NEW D,V,G,X,J,B,E,C,Y,R,I
+9 ;get inverse date and begin at edate-1 and end when greater than begin date
SET C=0
SET E=9999999-EDATE
+10 SET D=E-1
SET D=D_".9999"
FOR
SET D=$ORDER(^AUPNVLAB("AE",P,D))
IF D'=+D
QUIT
Begin DoDot:1
+11 SET X=0
FOR
SET X=$ORDER(^AUPNVLAB("AE",P,D,X))
IF X'=+X
QUIT
Begin DoDot:2
+12 SET Y=0
FOR
SET Y=$ORDER(^AUPNVLAB("AE",P,D,X,Y))
IF Y'=+Y
QUIT
Begin DoDot:3
+13 IF BGPT
IF $DATA(^ATXLAB(BGPT,21,"B",X))
DO SETLAB
QUIT
+14 IF 'BGPLT
QUIT
+15 SET J=$PIECE($GET(^AUPNVLAB(Y,11)),U,13)
IF J=""
QUIT
+16 IF '$$LOINC^BGP8D21(J,BGPLT)
QUIT
+17 DO SETLAB
QUIT
+18 QUIT
End DoDot:3
+19 QUIT
End DoDot:2
+20 QUIT
End DoDot:1
+21 ;NOW SET UP ARRAY AS DATE^ITEM^RESULT
+22 ;ADD IN CPT CODES
+23 SET X=$$FIRSTCPT^BGP8UTL1(P,"BGP HEP C CONF CPTS",$$DOB^AUPNPAT(P),EDATE)
+24 IF X
Begin DoDot:1
+25 SET C=C+1
+26 SET BGPG($PIECE(X,U,1),C)=$PIECE(X,U,1)_U_$PIECE(X,U,2)
End DoDot:1
+27 ;FIND FIRST WITH A VALID RESULT
+28 ;NO TESTS
IF '$ORDER(BGPG(0))
QUIT ""
+29 SET D=0
SET G=""
FOR
SET D=$ORDER(BGPG(D))
IF D'=+D!(G)
QUIT
Begin DoDot:1
+30 SET C=0
+31 FOR
SET C=$ORDER(BGPG(D,C))
IF C'=+C!(G)
QUIT
Begin DoDot:2
+32 ;Q:$P(BGPG(D,C),U,3)="" ;NO RESULT
+33 SET R=$PIECE(BGPG(D,C),U,3)
+34 SET I=""
IF $PIECE(BGPG(D,C),U,2)["Lab"
SET I=$PIECE(BGPG(D,C),U,4)
+35 SET Y=$$GOODRES(R,I)
IF Y="POS"
SET G=1_U_$$DATE^BGP8UTL($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
+36 IF G
QUIT G
+37 ;IF NO POS RESULT TAKE FIRST ONE WITH NEG RESULT
+38 SET D=0
SET G=""
FOR
SET D=$ORDER(BGPG(D))
IF D'=+D!(G)
QUIT
Begin DoDot:1
+39 SET C=0
+40 FOR
SET C=$ORDER(BGPG(D,C))
IF C'=+C!(G)
QUIT
Begin DoDot:2
+41 ;Q:$P(BGPG(D,C),U,3)="" ;NO RESULT
+42 SET R=$PIECE(BGPG(D,C),U,3)
+43 SET I=""
IF $PIECE(BGPG(D,C),U,2)["Lab"
SET I=$PIECE(BGPG(D,C),U,4)
+44 SET Y=$$GOODRES(R,I)
IF Y="NEG"
SET G=1_U_$$DATE^BGP8UTL($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
+45 IF G
QUIT G
+46 ;IF NO NEG TAKE 1ST WITH NO RESULT
+47 SET D=$ORDER(BGPG(0))
SET C=$ORDER(BGPG(D,0))
+48 QUIT 1_U_$$DATE^BGP8UTL($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))_"^"_$$VAL^XBDIQ1(9000010.09,Y,.01)_" Lab Result"_"^"_$$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 SET R=$PIECE(^AUPNVLAB(X,0),U,4)
IF 'R
SET R=""
+13 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)=R
QUIT
+14 IF 'T
QUIT
+15 SET J=$PIECE($GET(^AUPNVLAB(X,11)),U,13)
IF J=""
QUIT
+16 IF '$$LOINC^BGP8D2(J,T)
QUIT
+17 SET R=$PIECE(^AUPNVLAB(X,0),U,4)
+18 IF 'R
SET R=""
+19 SET BGPC=BGPC+1
SET BGPT(D,BGPC)=R
+20 QUIT
End DoDot:3
End DoDot:2
End DoDot:1
+21 ; now got though and set return value of done 1 or 0^VALUE^date
+22 SET D=0
SET G=""
FOR
SET D=$ORDER(BGPT(D))
IF D'=+D!(G]"")
QUIT
Begin DoDot:1
+23 SET C=0
FOR
SET C=$ORDER(BGPT(D,C))
IF C'=+C!(G]"")
QUIT
Begin DoDot:2
+24 SET X=BGPT(D,C)
+25 IF X=""
QUIT
+26 SET G=(9999999-D)_U_X
+27 QUIT
End DoDot:2
End DoDot:1
+28 ;now get one with no result
IF G=""
Begin DoDot:1
+29 SET D=0
SET G=""
FOR
SET D=$ORDER(BGPT(D))
IF D'=+D!(G]"")
QUIT
Begin DoDot:2
+30 SET C=0
FOR
SET C=$ORDER(BGPT(D,C))
IF C'=+C!(G]"")
QUIT
Begin DoDot:3
+31 SET X=BGPT(D,C)
+32 IF X=""
QUIT
+33 SET G=(9999999-D)_U_X
End DoDot:3
+34 QUIT
End DoDot:2
End DoDot:1
+35 ;
+36 ;IF WANT A RESULT AND THERE IS ONE QUIT
IF 'NORES
IF G]""
QUIT 1_U_G
+37 SET %=$$CPT^BGP8DU(P,BDATE,EDATE,$ORDER(^ATXAX("B","BGP CD4 CPTS",0)),5)
+38 IF %]""
SET BGPC=BGPC+1
SET BGPT(9999999-$PIECE(%,U,1),BGPC)="CPT "_$PIECE(%,U,2)
+39 SET %=$$TRAN^BGP8DU(P,BDATE,EDATE,$ORDER(^ATXAX("B","BGP CD4 CPTS",0)),5)
+40 IF %]""
SET BGPC=BGPC+1
SET BGPT(9999999-$PIECE(%,U,1),BGPC)="CPT "_$PIECE(%,U,2)
+41 IF '$ORDER(BGPT(0))
QUIT ""
+42 SET %=$ORDER(BGPT(0))
SET C=$ORDER(BGPT(%,0))
QUIT 1_"^"_(9999999-%)_"^"_BGPT(%,C)
+43 QUIT ""
+44 ;
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 "POS"
+10 IF $EXTRACT(R)=">"
QUIT "POS"
+11 IF R["NON"
QUIT "NEG"
+12 IF R["NOT"
QUIT "NEG"
+13 IF R["NEGATIVE"
QUIT "NEG"
+14 IF R["NEG"
QUIT "NEG"
+15 IF R["NONE"
QUIT "NEG"
+16 IF R["NONE DETECTED"
QUIT "NEG"
+17 IF R["NONE DETEC"
QUIT "NEG"
+18 IF R["NOT DETECTED"
QUIT "NEG"
+19 IF R["NOTDETECTED"
QUIT "NEG"
+20 IF R["NOT DETECT"
QUIT "NEG"
+21 IF R["POSITIVE"
QUIT "POS"
+22 IF R["DETECTED"
QUIT "POS"
+23 IF R["POS"
QUIT "POS"
+24 IF R["DETEC"
QUIT "POS"
+25 IF R["REACT"
QUIT "POS"
+26 IF +R>0
QUIT "POS"
+27 QUIT ""
GOODRES1 ;FOR HEP SCREENING TEST
+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 ""
POS(R) ;IS THE RESULT A POSITIVE
+1 IF $GET(R)=""
QUIT ""
+2 SET R=$$UP^XLFSTR(R)
+3 IF $EXTRACT(R)="<"
QUIT ""
+4 IF R["NON"
QUIT ""
+5 IF R["NOT"
QUIT ""
+6 IF R["NEGATIVE"
QUIT ""
+7 IF R["NEG"
QUIT ""
+8 IF R["NONE DETECTED"
QUIT ""
+9 IF R["NONE"
QUIT ""
+10 IF R["NONE DETEC"
QUIT ""
+11 IF R["NOT DETECTED"
QUIT ""
+12 IF R["NOTDETECTED"
QUIT ""
+13 IF $EXTRACT(R)=">"
QUIT 1
+14 IF R["POSITIVE"
QUIT 1
+15 IF R["DETECTED"
QUIT 1
+16 IF R["POS"
QUIT 1
+17 IF R["DETEC"
QUIT 1
+18 IF R["REACT"
QUIT 1
+19 ;I +R>0 Q 1
+20 QUIT ""
NEG(R) ;
+1 IF $GET(R)=""
QUIT ""
+2 SET R=$GET(R)
+3 IF R=""
QUIT ""
+4 SET R=$$UP^XLFSTR(R)
+5 IF $EXTRACT(R)="<"
QUIT 1
+6 IF R["NEGATIVE"
QUIT 1
+7 IF R["NEG"
QUIT 1
+8 IF R["NONE DETECTED"
QUIT 1
+9 IF R["NONE DETEC"
QUIT 1
+10 IF R["NOT DETECTED"
QUIT 1
+11 IF R["NOTDETECTED"
QUIT 1
+12 IF R["NOT DETECT"
QUIT 1
+13 IF R["NON"
QUIT 1
+14 QUIT ""
GETALLCF ;
+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-BGPEDATE
+9 SET D=E-1
SET D=D_".9999"
FOR
SET D=$ORDER(^AUPNVLAB("AE",DFN,D))
IF D'=+D
QUIT
Begin DoDot:1
+10 SET X=0
FOR
SET X=$ORDER(^AUPNVLAB("AE",DFN,D,X))
IF X'=+X
QUIT
Begin DoDot:2
+11 SET Y=0
FOR
SET Y=$ORDER(^AUPNVLAB("AE",DFN,D,X,Y))
IF Y'=+Y
QUIT
Begin DoDot:3
+12 IF BGPT
IF $DATA(^ATXLAB(BGPT,21,"B",X))
DO SETLABC
QUIT
+13 IF 'BGPLT
QUIT
+14 SET J=$PIECE($GET(^AUPNVLAB(Y,11)),U,13)
IF J=""
QUIT
+15 IF '$$LOINC^BGP8D21(J,BGPLT)
QUIT
+16 DO SETLABC
QUIT
+17 QUIT
End DoDot:3
+18 QUIT
End DoDot:2
+19 QUIT
End DoDot:1
+20 QUIT
SETLABC ;
+1 SET C=C+1
+2 SET R=$$GOODRES($PIECE(^AUPNVLAB(Y,0),U,4))
+3 IF R=""
QUIT
+4 SET BGPCONFT($$VDTM^APCLV($PIECE(^AUPNVLAB(Y,0),U,3)),R)=$$VD^APCLV($PIECE(^AUPNVLAB(Y,0),U,3))_"^"_"Lab"_"^"_$$VAL^XBDIQ1(9000010.09,Y,.04)_"^"_Y_"^"_$PIECE(^AUPNVLAB(Y,0),U,3)
+5 SET BGPCONFT(R,$$VDTM^APCLV($PIECE(^AUPNVLAB(Y,0),U,3)))=$$VD^APCLV($PIECE(^AUPNVLAB(Y,0),U,3))_"^"_"Lab"_"^"_$$VAL^XBDIQ1(9000010.09,Y,.04)_"^"_Y_"^"_$PIECE(^AUPNVLAB(Y,0),U,3)
+6 QUIT
RES(R) ;IS THE RESULT A POSITIVE
+1 IF $GET(R)=""
QUIT ""
+2 SET R=$$UP^XLFSTR(R)
+3 IF $EXTRACT(R)="<"
QUIT "NEG"
+4 IF R["NON"
QUIT "NEG"
+5 IF R["NOT"
QUIT "NEG"
+6 IF R["NEGATIVE"
QUIT "NEG"
+7 IF R["NEG"
QUIT "NEG"
+8 IF R["NONE DETECTED"
QUIT "NEG"
+9 IF R["NONE"
QUIT "NEG"
+10 IF R["NONE DETEC"
QUIT "NEG"
+11 IF R["NOT DETECTED"
QUIT "NEG"
+12 IF R["NOTDETECTED"
QUIT "NEG"
+13 IF $EXTRACT(R)=">"
QUIT "POS"
+14 IF R["POSITIVE"
QUIT "POS"
+15 IF R["DETECTED"
QUIT "POS"
+16 IF R["POS"
QUIT "POS"
+17 IF R["DETEC"
QUIT "POS"
+18 IF R["REACT"
QUIT "POS"
+19 IF +R>0
QUIT "NO RESULT"
+20 QUIT ""
