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

BGP8D841.m

Go to the documentation of this file.
  1. BGP8D841 ; IHS/CMI/LAB - measure C ;
  1. ;;18.1;IHS CLINICAL REPORTING;;MAY 25, 2018;Build 66
  1. ;
  1. HEPC ;EP - called from BGP8D84
  1. I 'BGPACTUP S BGPSTOP=1 Q
  1. S (BGPN1,BGPN2,BGPN3,BGPN4,BGPN5,BGPN6,BGPN7,BGPN8,BGPN9,BGPN10,BGPN11,BGPD1,BGPD2,BGPD3,BGPD4,BGPD5,BGPD6,BGPD7)=0
  1. ;BGPD1 - PTS WITH NO HEP C 1945-1965
  1. ;BGPD2 - PTS WITH HEP C 1945-1965
  1. ;BGPD3 - UP WITH HEP C OR AB RESULT
  1. ;BGPN1 - PTS SCREENED IF IN BGPD1
  1. ;BGPN2 - PTS WITH CONF TEST IF IN BGPD2
  1. ;BGPN3 - PTS IN BGPN2 WITH POS RESULT
  1. ;BGPN4 - PTS IN BGPN2 WITH NEG RESULT
  1. ;BGPN5 - PTS IN BGPN2 WITH NO RESULT
  1. ;BGPN6 - PTS W/HEP C DX
  1. ;BGPN7 - PTS W/AB POS EVER
  1. ;BGPN8 - POS SCREEN
  1. ;BGPN9 - NEG SCREEN
  1. NEW BGPHSCR,BGPHHEP,BGPABPOS,BGPHCON,BGPHCON1,BGPVALX
  1. S BGPHHEP="",BGPVALUE="",BGPABPOS="",BGPHCON="",BGPHCON1="",BGPVALX=""
  1. S BGPHHEP=$$HEPCDX(DFN,BGPEDATE) I +BGPHHEP S BGPVALX="Hep C Dx: "_$$DATE^BGP8UTL($P(BGPHHEP,U,1))_" "_$P(BGPHHEP,U,2)
  1. S BGPABPOS=$$ABPOSEV(DFN,BGPEDATE) I BGPABPOS S:BGPVALX]"" BGPVALX=BGPVALX_"; " S BGPVALX=BGPVALX_"Ab Test Pos: "_$P(BGPABPOS,U,2)
  1. S D=$$DOB^AUPNPAT(DFN)
  1. I D<2450101 G N
  1. I D>2651231 G N
  1. I BGPHHEP!(BGPABPOS) S BGPD2=1
  1. I 'BGPHHEP S BGPD1=1
  1. N ;
  1. I BGPHHEP!(BGPABPOS) S BGPD3=1 ;all up
  1. I BGPHHEP S BGPN11=1
  1. I BGPABPOS S BGPN10=1
  1. S BGPHSCR=""
  1. 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)
  1. 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"
  1. I $P(BGPHSCR,U,3)="POS" S BGPN6=1
  1. I $P(BGPHSCR,U,3)="NEG" S BGPN7=1
  1. I BGPD2!BGPD3 S BGPHCON=$$HEPCCON(DFN,BGPEDATE) D
  1. .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)
  1. .I $P(BGPHCON,U,5)="POS" S BGPN3=1 Q
  1. .I $P(BGPHCON,U,5)="NEG" S BGPN4=1 Q
  1. .S BGPN5=1
  1. ;
  1. ;
  1. ;GET ALL CONFIRMATION TESTS
  1. K BGPCONFT
  1. I '(BGPD2+BGPD3) G SL1
  1. I 'BGPN3 G SL1
  1. D GETALLCF
  1. I $D(BGPCONFT("POS")) S BGPD6=1
  1. S D=$$DOB^AUPNPAT(DFN)
  1. I D<2450101 G SL
  1. I D>2651231 G SL
  1. I $D(BGPCONFT("POS")) S BGPD7=1
  1. SL I BGPD6!(BGPD7) D
  1. .;BGPN8 - EVER HAD NEG WITHIN 12 WEEKS OF ANY POS
  1. .;BGPN9 - EVER HAD NEG WITHIN 12 WEEKS OF last positive
  1. .I '$D(BGPCONFT("NEG")) Q ;NEVER HAD A NEGATIVE
  1. .S X="" F S X=$O(BGPCONFT("POS",X)) Q:X'=+X S L=X ;L IS DATE OF LAST POSITIVE
  1. .S L=$P(L,".")
  1. .;CHECK LAST ONE FIRST, IF A HIT MAKES BOTH NUMERATORS
  1. .S X=L F S X=$O(BGPCONFT("NEG",X)) Q:X'=+X!(BGPN8) D I BGPN8 G SL1
  1. ..S Y=$$FMDIFF^XLFDT(X,L)
  1. ..I Y>83 S (BGPN8,BGPN9)=1,BGPVALX=BGPVALX_"; Currently Cured"
  1. .;NOW CHECK ANY POS
  1. .S X=0 F S X=$O(BGPCONFT("POS",X)) Q:X'=+X!(BGPN8) D
  1. ..S G=0 S Y=X F S Y=$O(BGPCONFT(Y)) Q:Y'=+Y!(G)!(BGPN8) D
  1. ...S G=0
  1. ...I $D(BGPCONFT("POS",Y)) S G=1 Q ;Q IF IT IS A POS AND GO TO THE NEXT POS
  1. ...I $D(BGPCONFT("UNK",Y)) S G=1 Q ;Q IF IT IS AN UNK
  1. ...S Z=$$FMDIFF^XLFDT(Y,X)
  1. ...I Z>83 S (BGPN8)=1,BGPVALX=BGPVALX_"; Ever Cured"
  1. SL1 ;
  1. I BGPD1 S BGPVALUE="UP|||"_BGPVALX
  1. I BGPD2!(BGPD3) S BGPVALUE="UP,HEP|||"_BGPVALX
  1. Q
  1. HEPCDX(P,EDATE) ;
  1. NEW T,X,G
  1. S X=$$LASTDX^BGP8UTL1(P,"BGP HEPATITIS C DXS",,EDATE)
  1. I X Q $P(X,U,3)_U_"POV "_$P(X,U,2)
  1. ;now check problem list
  1. S T=$O(^ATXAX("B","BGP HEPATITIS C DXS",0))
  1. S (X,G)=0 F S X=$O(^AUPNPROB("AC",P,X)) Q:X'=+X!(G) D
  1. .I EDATE,$P(^AUPNPROB(X,0),U,13)>EDATE Q
  1. .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
  1. .S Y=$P(^AUPNPROB(X,0),U)
  1. .Q:$P(^AUPNPROB(X,0),U,12)="D"
  1. .Q:$P(^AUPNPROB(X,0),U,12)="I"
  1. .Q:'$$ICD^BGP8UTL2(Y,T,9)
  1. .S G=$P(^AUPNPROB(X,0),U,8)_U_" Problem List "_$$VAL^XBDIQ1(9000011,X,.01)
  1. .Q
  1. I G Q G
  1. S X=$$PLTAXID^BGP8DU(P,"BGP HEPATITIS C DXS",$$DOB^AUPNPAT(P),EDATE)
  1. I X Q $P(X,U,3)_U_$P(X,U,2)
  1. S X=$$IPLSNOID^BGP8DU(P,"PXRM HEPATITIS C",$$DOB^AUPNPAT(P),EDATE)
  1. I X Q $P(X,U,3)_U_$P(X,U,2)
  1. Q ""
  1. HEPSCR(P,EDATE) ;
  1. NEW X,G,T,%,BGPC,BGPLT,L,D,J
  1. ;now get all loinc/taxonomy tests
  1. S BGPC=""
  1. S T=$O(^ATXAX("B","BGP HEP C TEST LOINC CODES",0))
  1. S BGPLT=$O(^ATXLAB("B","BGP HEP C TESTS TAX",0))
  1. S E=9999999-EDATE S D=E-1 F S D=$O(^AUPNVLAB("AE",P,D)) Q:D'=+D!(BGPC) D
  1. .S L=0 F S L=$O(^AUPNVLAB("AE",P,D,L)) Q:L'=+L!(BGPC) D
  1. ..S X=0 F S X=$O(^AUPNVLAB("AE",P,D,L,X)) Q:X'=+X!(BGPC) D
  1. ...Q:'$D(^AUPNVLAB(X,0))
  1. ...I BGPLT,$P(^AUPNVLAB(X,0),U),$D(^ATXLAB(BGPLT,21,"B",$P(^AUPNVLAB(X,0),U))) S BGPC=1_U_$$DATE^BGP8UTL((9999999-D))_" Lab Test" Q
  1. ...Q:'T
  1. ...S J=$P($G(^AUPNVLAB(X,11)),U,13) Q:J=""
  1. ...Q:'$$LOINC^BGP8D2(J,T)
  1. ...S BGPC=1_U_$$DATE^BGP8UTL((9999999-D))_" Lab Test (Loinc "_$$VAL^XBDIQ1(9000010.09,X,1113)_")"
  1. ...Q
  1. I BGPC Q BGPC
  1. S %="",E=+$$CODEN^ICPTCOD(86803),%=$$CPTI^BGP8DU(P,$$DOB^AUPNPAT(P),EDATE,E)
  1. I % Q 1_U_$$DATE^BGP8UTL($P(%,U,2))_" CPT 86803"
  1. Q BGPC
  1. ABPOSEV(P,EDATE) ;
  1. NEW X,G,T,%,BGPC,BGPLT,L,D,J
  1. ;now get all loinc/taxonomy tests
  1. S BGPC=""
  1. S T=$O(^ATXAX("B","BGP HEP C TEST LOINC CODES",0))
  1. S BGPLT=$O(^ATXLAB("B","BGP HEP C TESTS TAX",0))
  1. S E=9999999-EDATE S D=E-1 F S D=$O(^AUPNVLAB("AE",P,D)) Q:D'=+D!(BGPC) D
  1. .S L=0 F S L=$O(^AUPNVLAB("AE",P,D,L)) Q:L'=+L!(BGPC) D
  1. ..S X=0 F S X=$O(^AUPNVLAB("AE",P,D,L,X)) Q:X'=+X!(BGPC) D
  1. ...Q:'$D(^AUPNVLAB(X,0))
  1. ...I BGPLT,$P(^AUPNVLAB(X,0),U),$D(^ATXLAB(BGPLT,21,"B",$P(^AUPNVLAB(X,0),U))) D
  1. ....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
  1. ...Q:'T
  1. ...S J=$P($G(^AUPNVLAB(X,11)),U,13) Q:J=""
  1. ...Q:'$$LOINC^BGP8D2(J,T)
  1. ...Q:'$$POS($P(^AUPNVLAB(X,0),U,4))
  1. ...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"
  1. ...Q
  1. Q BGPC
  1. HEPSCRR(P,EDATE) ;RETURN LAST WITH A RESULT
  1. NEW X,G,T,%,BGPC,BGPLT,L,D,J,R
  1. ;now get all loinc/taxonomy tests
  1. S BGPC=""
  1. S T=$O(^ATXAX("B","BGP HEP C TEST LOINC CODES",0))
  1. S BGPLT=$O(^ATXLAB("B","BGP HEP C TESTS TAX",0))
  1. S E=9999999-EDATE S D=E-1 F S D=$O(^AUPNVLAB("AE",P,D)) Q:D'=+D!(BGPC) D
  1. .S L=0 F S L=$O(^AUPNVLAB("AE",P,D,L)) Q:L'=+L!(BGPC) D
  1. ..S X=0 F S X=$O(^AUPNVLAB("AE",P,D,L,X)) Q:X'=+X!(BGPC) D
  1. ...Q:'$D(^AUPNVLAB(X,0))
  1. ...I BGPLT,$P(^AUPNVLAB(X,0),U),$D(^ATXLAB(BGPLT,21,"B",$P(^AUPNVLAB(X,0),U))) S 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
  1. ...Q:'T
  1. ...S J=$P($G(^AUPNVLAB(X,11)),U,13) Q:J=""
  1. ...Q:'$$LOINC^BGP8D2(J,T)
  1. ...S R=$$RES($P(^AUPNVLAB(X,0),U,4))
  1. ...Q:R=""
  1. ...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
  1. ...Q
  1. Q BGPC
  1. HEPCCON(P,EDATE) ;
  1. ;return first test with a POSITIVE result
  1. ;if none return first with a negative result
  1. ;if none return first one found
  1. NEW BGPG,BGPT,BGPLT
  1. ;GET ALL LABS INTO ARRAY BGPG
  1. S BGPLT=$O(^ATXAX("B","BGP HEP C CONF LOINC",0))
  1. S BGPT=$O(^ATXLAB("B","BGP HEP C CONF TEST TAX",0))
  1. NEW D,V,G,X,J,B,E,C,Y,R,I
  1. S C=0,E=9999999-EDATE ;get inverse date and begin at edate-1 and end when greater than begin date
  1. S D=E-1,D=D_".9999" F S D=$O(^AUPNVLAB("AE",P,D)) Q:D'=+D D
  1. .S X=0 F S X=$O(^AUPNVLAB("AE",P,D,X)) Q:X'=+X D
  1. ..S Y=0 F S Y=$O(^AUPNVLAB("AE",P,D,X,Y)) Q:Y'=+Y D
  1. ...I BGPT,$D(^ATXLAB(BGPT,21,"B",X)) D SETLAB Q
  1. ...Q:'BGPLT
  1. ...S J=$P($G(^AUPNVLAB(Y,11)),U,13) Q:J=""
  1. ...Q:'$$LOINC^BGP8D21(J,BGPLT)
  1. ...D SETLAB Q
  1. ...Q
  1. ..Q
  1. .Q
  1. ;NOW SET UP ARRAY AS DATE^ITEM^RESULT
  1. ;ADD IN CPT CODES
  1. S X=$$FIRSTCPT^BGP8UTL1(P,"BGP HEP C CONF CPTS",$$DOB^AUPNPAT(P),EDATE)
  1. I X D
  1. .S C=C+1
  1. .S BGPG($P(X,U,1),C)=$P(X,U,1)_U_$P(X,U,2)
  1. ;FIND FIRST WITH A VALID RESULT
  1. I '$O(BGPG(0)) Q "" ;NO TESTS
  1. S D=0,G="" F S D=$O(BGPG(D)) Q:D'=+D!(G) D
  1. .S C=0
  1. .F S C=$O(BGPG(D,C)) Q:C'=+C!(G) D
  1. ..;Q:$P(BGPG(D,C),U,3)="" ;NO RESULT
  1. ..S R=$P(BGPG(D,C),U,3)
  1. ..S I="" I $P(BGPG(D,C),U,2)["Lab" S I=$P(BGPG(D,C),U,4)
  1. ..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
  1. I G Q G
  1. ;IF NO POS RESULT TAKE FIRST ONE WITH NEG RESULT
  1. S D=0,G="" F S D=$O(BGPG(D)) Q:D'=+D!(G) D
  1. .S C=0
  1. .F S C=$O(BGPG(D,C)) Q:C'=+C!(G) D
  1. ..;Q:$P(BGPG(D,C),U,3)="" ;NO RESULT
  1. ..S R=$P(BGPG(D,C),U,3)
  1. ..S I="" I $P(BGPG(D,C),U,2)["Lab" S I=$P(BGPG(D,C),U,4)
  1. ..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
  1. I G Q G
  1. ;IF NO NEG TAKE 1ST WITH NO RESULT
  1. S D=$O(BGPG(0)),C=$O(BGPG(D,0))
  1. Q 1_U_$$DATE^BGP8UTL($P(BGPG(D,C),U,1))_U_$P(BGPG(D,C),U,2)_U_U_"No Result"
  1. SETLAB ;
  1. S C=C+1
  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)
  1. Q
  1. CD4RES(P,BDATE,EDATE,NORES) ;EP
  1. NEW BGPG,BGPT,BGPC,BGPLT,T,B,E,D,L,X,R,G,C,%
  1. K BGPG,BGPT,BGPC
  1. S BGPC=0
  1. S NORES=$G(NORES)
  1. ;now get all loinc/taxonomy tests
  1. S T=$O(^ATXAX("B","BGP CD4 LOINC CODES",0))
  1. S BGPLT=$O(^ATXLAB("B","BGP CD4 TAX",0))
  1. S B=9999999-BDATE,E=9999999-EDATE S D=E-1 F S D=$O(^AUPNVLAB("AE",P,D)) Q:D'=+D!(D>B) D
  1. .S L=0 F S L=$O(^AUPNVLAB("AE",P,D,L)) Q:L'=+L D
  1. ..S X=0 F S X=$O(^AUPNVLAB("AE",P,D,L,X)) Q:X'=+X D
  1. ...Q:'$D(^AUPNVLAB(X,0))
  1. ...S R=$P(^AUPNVLAB(X,0),U,4) I 'R S R=""
  1. ...I BGPLT,$P(^AUPNVLAB(X,0),U),$D(^ATXLAB(BGPLT,21,"B",$P(^AUPNVLAB(X,0),U))) S BGPC=BGPC+1,BGPT(D,BGPC)=R Q
  1. ...Q:'T
  1. ...S J=$P($G(^AUPNVLAB(X,11)),U,13) Q:J=""
  1. ...Q:'$$LOINC^BGP8D2(J,T)
  1. ...S R=$P(^AUPNVLAB(X,0),U,4)
  1. ...I 'R S R=""
  1. ...S BGPC=BGPC+1,BGPT(D,BGPC)=R
  1. ...Q
  1. ; now got though and set return value of done 1 or 0^VALUE^date
  1. S D=0,G="" F S D=$O(BGPT(D)) Q:D'=+D!(G]"") D
  1. .S C=0 F S C=$O(BGPT(D,C)) Q:C'=+C!(G]"") D
  1. ..S X=BGPT(D,C)
  1. ..I X="" Q
  1. ..S G=(9999999-D)_U_X
  1. ..Q
  1. I G="" D ;now get one with no result
  1. .S D=0,G="" F S D=$O(BGPT(D)) Q:D'=+D!(G]"") D
  1. ..S C=0 F S C=$O(BGPT(D,C)) Q:C'=+C!(G]"") D
  1. ...S X=BGPT(D,C)
  1. ...I X="" Q
  1. ...S G=(9999999-D)_U_X
  1. ..Q
  1. ;
  1. I 'NORES,G]"" Q 1_U_G ;IF WANT A RESULT AND THERE IS ONE QUIT
  1. S %=$$CPT^BGP8DU(P,BDATE,EDATE,$O(^ATXAX("B","BGP CD4 CPTS",0)),5)
  1. I %]"" S BGPC=BGPC+1,BGPT(9999999-$P(%,U,1),BGPC)="CPT "_$P(%,U,2)
  1. S %=$$TRAN^BGP8DU(P,BDATE,EDATE,$O(^ATXAX("B","BGP CD4 CPTS",0)),5)
  1. I %]"" S BGPC=BGPC+1,BGPT(9999999-$P(%,U,1),BGPC)="CPT "_$P(%,U,2)
  1. I '$O(BGPT(0)) Q ""
  1. S %=$O(BGPT(0)) S C=$O(BGPT(%,0)) Q 1_"^"_(9999999-%)_"^"_BGPT(%,C)
  1. Q ""
  1. ;
  1. GOODRES(R,I) ;EP
  1. ;is this a good result
  1. ;Positive confirmation test result defined as any number greater than
  1. ;zero, "Pos", "Positive", "Detected", a result starting with ">", or a
  1. ;result starting with a number.
  1. ;Negative confirmation test result defined as a result starting with "<", "Neg", "Negative", "None detected", "None Detec", or "Not detected".
  1. S R=$G(R)
  1. I R="" Q ""
  1. S R=$$UP^XLFSTR(R)
  1. I $E(R)="<" Q "POS"
  1. I $E(R)=">" Q "POS"
  1. I R["NON" Q "NEG"
  1. I R["NOT" Q "NEG"
  1. I R["NEGATIVE" Q "NEG"
  1. I R["NEG" Q "NEG"
  1. I R["NONE" Q "NEG"
  1. I R["NONE DETECTED" Q "NEG"
  1. I R["NONE DETEC" Q "NEG"
  1. I R["NOT DETECTED" Q "NEG"
  1. I R["NOTDETECTED" Q "NEG"
  1. I R["NOT DETECT" Q "NEG"
  1. I R["POSITIVE" Q "POS"
  1. I R["DETECTED" Q "POS"
  1. I R["POS" Q "POS"
  1. I R["DETEC" Q "POS"
  1. I R["REACT" Q "POS"
  1. I +R>0 Q "POS"
  1. Q ""
  1. GOODRES1 ;FOR HEP SCREENING TEST
  1. I '$G(I) Q ""
  1. ;comments field
  1. I $$UP^XLFSTR($G(^AUPNVLAB(I,13)))["NOT DETECTED" Q "NEG"
  1. NEW J,K,T
  1. S T=""
  1. S J=0,K="" F S J=$O(^AUPNVLAB(I,21,J)) Q:J'=+J D
  1. .S K=K_$G(^AUPNVLAB(I,21,J,0))
  1. I $$UP^XLFSTR(K)["NOT DETECTED" Q "NEG"
  1. I $$UP^XLFSTR(K)["NOTDETECTED" Q "NEG"
  1. Q ""
  1. POS(R) ;IS THE RESULT A POSITIVE
  1. I $G(R)="" Q ""
  1. S R=$$UP^XLFSTR(R)
  1. I $E(R)="<" Q ""
  1. I R["NON" Q ""
  1. I R["NOT" Q ""
  1. I R["NEGATIVE" Q ""
  1. I R["NEG" Q ""
  1. I R["NONE DETECTED" Q ""
  1. I R["NONE" Q ""
  1. I R["NONE DETEC" Q ""
  1. I R["NOT DETECTED" Q ""
  1. I R["NOTDETECTED" Q ""
  1. I $E(R)=">" Q 1
  1. I R["POSITIVE" Q 1
  1. I R["DETECTED" Q 1
  1. I R["POS" Q 1
  1. I R["DETEC" Q 1
  1. I R["REACT" Q 1
  1. ;I +R>0 Q 1
  1. Q ""
  1. NEG(R) ;
  1. I $G(R)="" Q ""
  1. S R=$G(R)
  1. I R="" Q ""
  1. S R=$$UP^XLFSTR(R)
  1. I $E(R)="<" Q 1
  1. I R["NEGATIVE" Q 1
  1. I R["NEG" Q 1
  1. I R["NONE DETECTED" Q 1
  1. I R["NONE DETEC" Q 1
  1. I R["NOT DETECTED" Q 1
  1. I R["NOTDETECTED" Q 1
  1. I R["NOT DETECT" Q 1
  1. I R["NON" Q 1
  1. Q ""
  1. GETALLCF ;
  1. ;return first test with a valid result
  1. ;if none with a valid result, return 1st one
  1. NEW BGPG,BGPT,BGPLT
  1. ;GET ALL LABS INTO ARRAY BGPG
  1. S BGPLT=$O(^ATXAX("B","BGP HEP C CONF LOINC",0))
  1. S BGPT=$O(^ATXLAB("B","BGP HEP C CONF TEST TAX",0))
  1. NEW D,V,G,X,J,B,E,C,Y,R,I
  1. S C=0,E=9999999-BGPEDATE ;get inverse date and begin at edate-1 and end when greater than begin date
  1. S D=E-1,D=D_".9999" F S D=$O(^AUPNVLAB("AE",DFN,D)) Q:D'=+D D
  1. .S X=0 F S X=$O(^AUPNVLAB("AE",DFN,D,X)) Q:X'=+X D
  1. ..S Y=0 F S Y=$O(^AUPNVLAB("AE",DFN,D,X,Y)) Q:Y'=+Y D
  1. ...I BGPT,$D(^ATXLAB(BGPT,21,"B",X)) D SETLABC Q
  1. ...Q:'BGPLT
  1. ...S J=$P($G(^AUPNVLAB(Y,11)),U,13) Q:J=""
  1. ...Q:'$$LOINC^BGP8D21(J,BGPLT)
  1. ...D SETLABC Q
  1. ...Q
  1. ..Q
  1. .Q
  1. Q
  1. SETLABC ;
  1. S C=C+1
  1. S R=$$GOODRES($P(^AUPNVLAB(Y,0),U,4))
  1. I R="" Q
  1. 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)
  1. 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)
  1. Q
  1. RES(R) ;IS THE RESULT A POSITIVE
  1. I $G(R)="" Q ""
  1. S R=$$UP^XLFSTR(R)
  1. I $E(R)="<" Q "NEG"
  1. I R["NON" Q "NEG"
  1. I R["NOT" Q "NEG"
  1. I R["NEGATIVE" Q "NEG"
  1. I R["NEG" Q "NEG"
  1. I R["NONE DETECTED" Q "NEG"
  1. I R["NONE" Q "NEG"
  1. I R["NONE DETEC" Q "NEG"
  1. I R["NOT DETECTED" Q "NEG"
  1. I R["NOTDETECTED" Q "NEG"
  1. I $E(R)=">" Q "POS"
  1. I R["POSITIVE" Q "POS"
  1. I R["DETECTED" Q "POS"
  1. I R["POS" Q "POS"
  1. I R["DETEC" Q "POS"
  1. I R["REACT" Q "POS"
  1. I +R>0 Q "NO RESULT"
  1. Q ""