- 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 ""