BGP1D8 ; IHS/CMI/LAB - measure C 03 Jul 2010 7:05 AM ;
;;11.1;IHS CLINICAL REPORTING SYSTEM;;JUN 27, 2011;Build 33
;
IE2 ;EP
S (BGPN1,BGPN2,BGPN3,BGPN4,BGPN5,BGPN6,BGPN7,BGPN8,BGPD1,BGPD2,BGPD3,BGPD4,BGPD5,BGPD6,BGPD7,BGPD8,BGPD9,BGPD10,BGPD11,BGPD12,BGPD13,BGPD14,BGPD15,BGPD16,BGPD17,BGPD18)=0
S BGPNO2=0
S BGPNO2=$$HIVDX(DFN,BGPEDATE) ;has HIV dx ever (gpra)
S BGPHIVG=""
S BGPHIV=""
S BGPDXB=$$HIVDX(DFN,$$FMADD^XLFDT(BGPBDATE,-1)) ;has dx before report period
S BGPHIVD=$$HIVDX(DFN,BGPEDATE,BGPBDATE) ;date of dx during report period
I BGPACTCL,BGPSEX="F",$$PREG^BGP1D7(DFN,$$FMADD^XLFDT(BGPEDATE,-600),BGPEDATE,0,1),BGPNO2="" S BGPD1=1 ;active clinical, no hiv, pregnant
S BGPN1=0
S BGPN2=0
I BGPD1 D
.S BGPHIVG=$$HIVTEST(DFN,$$FMADD^XLFDT(BGPEDATE,-600),BGPEDATE) ;get tests in past 20 months for gpra numerator
.I $P(BGPHIVG,U)=1 S BGPN1=1 ;had a test
.I $P(BGPHIVG,U)=2 S BGPN2=1 ;had a refusal
;---------------- done with GPRA num/den, now for developmental
;S BGPN3=$P(BGPHIV,U,3)
;I BGPD3,'BGPN3 S BGPSTOP=1 Q ;screen count only but no screens
I BGPACTUP,BGPAGEB>12,BGPAGEB<65,BGPDXB="" S BGPD2=1 ;up 13-64 with no dx before report period
I BGPACTUP,BGPDXB="" S BGPD3=1 ;this is for screen count only, all ages and no dx before report period
I BGPAGEB<13 S BGPD4=1
I BGPAGEB>12,BGPAGEB<15 S BGPD5=1
I BGPAGEB>14,BGPAGEB<20 S BGPD6=1
I BGPAGEB>19,BGPAGEB<25 S BGPD7=1
I BGPAGEB>24,BGPAGEB<30 S BGPD8=1
I BGPAGEB>29,BGPAGEB<35 S BGPD9=1
I BGPAGEB>34,BGPAGEB<40 S BGPD10=1
I BGPAGEB>39,BGPAGEB<45 S BGPD11=1
I BGPAGEB>44,BGPAGEB<50 S BGPD12=1
I BGPAGEB>49,BGPAGEB<55 S BGPD13=1
I BGPAGEB>54,BGPAGEB<60 S BGPD14=1
I BGPAGEB>59,BGPAGEB<65 S BGPD15=1
I BGPAGEB>64 S BGPD16=1
;get HIV test during the report period
S BGPHIV=$$HIVTEST(DFN,BGPBDATE,BGPEDATE) ;get tests in past 20 months for gpra numerator
I BGPD2,$P(BGPHIV,U)=1 S BGPN4=1
I BGPD2,$P(BGPHIV,U)=2 S BGPN8=1
;SET N3 TO TOTAL # OF SCREENS
S BGPX=$$HIVTEST(DFN,BGPBDATE,$S(BGPHIVD:BGPHIVD,1:BGPEDATE))
I BGPD3 S BGPN3=$P(BGPX,U,3)
S BGPN5=0
S BGPN6=0
S BGPN7=0
;determine result pos or neg
S X=$P(BGPHIV,U,5)
S X=$$UP^XLFSTR(X)
S D=$P(BGPHIV,U,6)
S BGPDAFT=""
I X="",D S G=$$HIVDX1(DFN,BGPED,D) I G S BGPN5=1,BGPDAFT="Positive HIV DX "_$P(G,U,2)_" on "_$$DATE^BGP1UTL($P(G,U)) G V
I X="",BGPN4 S BGPN7=1,BGPDAFT="No Result"
I X="P"!(X="POSITIVE")!(X="POS")!(X="R")!(X="REACTIVE")!(X="REPEATEDLY REACTIVE")!(X="+")!(X[">") S BGPN5=1,BGPDAFT="Positive" ;positive result
I X="N"!(X="NEGATIVE")!(X="NEG")!(X="NR")!(X="NON REACTIVE")!(X="NON-REACTIVE")!(X="-") S BGPN6=1,BGPDAFT="Negative"
V ;set denominator value for selected
S BGPVALUE=""
S BGPVAL=""
I BGPD3 S BGPVALUE="UP"
I BGPD2 S BGPVALUE="UP,UP13-64"
I BGPD1 S BGPVALUE=BGPVALUE_",AC PREG (NO DX)"
I BGPD1!(BGPD2) D
.I BGPN1,'BGPN4 S BGPVAL=$P(BGPHIVG,U,2) Q
.I BGPN1!(BGPN4) S BGPVAL=$P(BGPHIV,U,2)
.I BGPN2!(BGPN8) S BGPVAL=$S(BGPHIVG]"":$P(BGPHIVG,U,4),1:$P(BGPHIV,U,4))
I BGPD3,BGPN3 S BGPVAL=BGPVAL_$S(BGPVAL]"":"",1:$P(BGPX,U,2))_" ;Screen Count: "_BGPN3
S BGPVALUE=BGPVALUE_"|||"_BGPVAL
S BGPVALUD="" I BGPD2 S BGPVALUD="UP,UP13-64|||"_$S(BGPD2&(BGPHIV):"SCREEN (NO HIV DX): "_$P(BGPHIV,U,4)_" ; ",1:"")_$P(BGPHIV,U,2)_" ; "_BGPDAFT_$S(BGPN3:" ;SCREEN COUNT (NO PRIOR DX): "_$P(BGPHIV,U,3)_" screens",1:"")
I BGPD3,'BGPD2,BGPN3 S BGPVALUD="UP|||SCREEN COUNT MEASURE: "_BGPN3_" screens"
I BGPVALUD=" ; " S BGPVALUD=""
K X,Y,Z,%,A,B,C,D,E,H,BDATE,EDATE,P,V,S,F,T
Q:$G(BGPIISO)
K BGPEDUC,BGPHIV
Q
IE1 ;EP
S (BGPN1,BGPN2,BGPN3,BGPN4,BGPN5,BGPN6,BGPD1,BGPD2,BGPD3,BGPD4,BGPD5,BGPD6,BGPD7,BGPD8,BGPD9,BGPCD4,BGPPCR)=0
I BGPAGEB<13 S BGPSTOP=1 Q
I 'BGPACTCL S BGPSTOP=1 Q ;not active clinical pt
I '$$V2HIV(DFN,BGP365,BGPEDATE) S BGPSTOP=1 Q
I BGPACTCL S BGPD1=1
I 'BGPD1 S BGPSTOP=1 Q
S BGPCD4=$$CD4(DFN,BGP365,BGPEDATE)
S BGPPCR=$$PCR(DFN,BGP365,BGPEDATE)
I BGPCD4,'BGPPCR S BGPN1=1
I BGPPCR,'BGPCD4 S BGPN2=1
I BGPPCR,BGPCD4 S BGPN3=1
I (BGPN1+BGPN2+BGPN3) S BGPN4=1
S BGPVALUE="UP|||"_$S(BGPCD4:"CD4: "_$$DATE^BGP1UTL($P(BGPCD4,U,2))_" "_$P(BGPCD4,U,3),1:"")
I $P(BGPVALUE,"|||",2)]"" S BGPVALUE=BGPVALUE_"; "
S BGPVALUE=BGPVALUE_$S(BGPPCR:"Viral Load: "_$$DATE^BGP1UTL($P(BGPPCR,U,2))_" "_$P(BGPPCR,U,3),1:"")
K X,Y,Z,%,A,B,C,D,E,H,BDATE,EDATE,P,V,S,F,T
K ^TMP($J,"A")
Q
PHYACT ;EP
S (BGPN1,BGPN2,BGPN3,BGPN4,BGPN5,BGPN6,BGPN7,BGPN8,BGPN9,BGPD1,BGPD2,BGPD3,BGPD4,BGPD5,BGPD6,BGPD7,BGPD8,BGPD9,BGPD10)=""
I BGPAGEB<5 S BGPSTOP=1 Q
S BGPVALUE=""
I BGPACTUP S BGPD1=1
I BGPACTCL S BGPD2=1
I '(BGPACTUP+BGPACTCL) S BGPSTOP=1 Q ;not in measure
I BGPACTCL,BGPAGEB>4,BGPAGEB<12 S BGPD3=1 ;5-11
I BGPACTCL,BGPAGEB>11,BGPAGEB<20 S BGPD4=1 ;12-19
I BGPACTCL,BGPAGEB>19,BGPAGEB<25 S BGPD5=1 ;20-24
I BGPACTCL,BGPAGEB>24,BGPAGEB<35 S BGPD6=1 ;25-34
I BGPACTCL,BGPAGEB>34,BGPAGEB<45 S BGPD7=1
I BGPACTCL,BGPAGEB>44,BGPAGEB<55 S BGPD8=1
I BGPACTCL,BGPAGEB>54,BGPAGEB<75 S BGPD9=1
I BGPACTCL,BGPAGEB>74 S BGPD10=1
S BGPPHYA=$$FIRSTHF(DFN,BGPBDATE,BGPEDATE,"ACTIVITY LEVEL") ;get the first health factor in this category recorded in this time period
;return 1^date internal^date external^factor found
I BGPPHYA S BGPN1=1,BGPVALUE="PHYS ACT: "_$P(BGPPHYA,U,3)_" "_$P(BGPPHYA,U,4) ;had assessment
S BGPEXER="" I BGPPHYA S BGPEXER=$$EXER(DFN,$P(BGPPHYA,U,2),BGPEDATE)
I BGPEXER S BGPN2=1,BGPVALUE=BGPVALUE_"; EXER ED: "_$$DATE^BGP1UTL($P(BGPEXER,U,1))_" "_$P(BGPEXER,U,2)
I BGPD1,'BGPD2 S BGPVALUE="UP|||"_BGPVALUE
I BGPD2 S BGPVALUE="UP,AC|||"_BGPVALUE
K BGPEXER,BGPPHYA
Q
EXER(P,BDATE,EDATE) ;
NEW BGPG,X,E,BGPALLED
K BGPG S X=P_"^LAST DX V65.41;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE) S E=$$START1^APCLDF(X,"BGPG(")
I $D(BGPG(1)) Q $P(BGPG(1),U)_U_"V65.41"_U_$$DATE^BGP1UTL($P(BGPG(1),U,1))
S Y="BGPALLED("
S X=P_"^ALL EDUC;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE) S E=$$START1^APCLDF(X,Y)
I '$D(BGPALLED(1)) Q ""
S (X,D)=0,%="",T="" F S X=$O(BGPALLED(X)) Q:X'=+X!(%]"") D
.S T=$P(^AUPNVPED(+$P(BGPALLED(X),U,4),0),U)
.Q:'T
.Q:'$D(^AUTTEDT(T,0))
.S T=$P(^AUTTEDT(T,0),U,2)
.I $P(T,"-",2)="EX"!($P(T,"-")="V65.41") S %=$P(BGPALLED(X),U)_U_T Q
Q %
FIRSTHF(P,BDATE,EDATE,CAT) ;EP
NEW C,H,D,O
S C=$O(^AUTTHF("B",CAT,0))
I '$G(C) Q ""
S (H,D)=0 K O
F S H=$O(^AUTTHF("AC",C,H)) Q:'+H D
.Q:'$D(^AUPNVHF("AA",P,H))
.S D="" F S D=$O(^AUPNVHF("AA",P,H,D)) Q:D'=+D D
..Q:(9999999-D)>EDATE
..Q:(9999999-D)<BDATE
..S O(9999999-D)=$O(^AUPNVHF("AA",P,H,D,""))
.Q
S D=$O(O(0))
I D="" Q D
Q 1_U_D_U_$$DATE^BGP1UTL(D)_U_$$VAL^XBDIQ1(9000010.23,O(D),.01)
;
HIVDX1(P,EDATE,BDATE) ;EP - any HIV dx
NEW BGPG,G,Y,X,T,E
K BGPG
S Y="BGPG("
S BDATE=$G(BDATE)
I BDATE="" S BDATE=$P(^DPT(P,0),U,3) ;dob
S X=P_"^LAST DX [BGP HIV/AIDS DXS;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE) S E=$$START1^APCLDF(X,Y)
I $D(BGPG(1)) Q $P(BGPG(1),U)_U_$P(BGPG(1),U,2)
S T=$O(^ATXAX("B","BGP HIV/AIDS DXS",0))
S X=0,G="" F S X=$O(^AUPNPROB("AC",P,X)) Q:X'=+X!(G]"") D
.Q:$P(^AUPNPROB(X,0),U,8)>EDATE
.S Y=$P(^AUPNPROB(X,0),U)
.Q:'$$ICD^ATXCHK(Y,T,9)
.S G=$P(^AUPNPROB(X,0),U,8)_U_$$VAL^XBDIQ1(9000011,X,.01)
.Q
Q G
HIVDX(P,EDATE,BDATE) ;EP - any HIV dx ever or problem list HIV dx
NEW BGPG,G,Y,X,T,E
K BGPG
S Y="BGPG("
S BDATE=$G(BDATE)
I BDATE="" S BDATE=$P(^DPT(P,0),U,3) ;dob
S X=P_"^LAST DX [BGP HIV/AIDS DXS;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE) S E=$$START1^APCLDF(X,Y)
I $D(BGPG(1)) Q $P(BGPG(1),U)
S T=$O(^ATXAX("B","BGP HIV/AIDS DXS",0))
S X=0,G="" F S X=$O(^AUPNPROB("AC",P,X)) Q:X'=+X!(G]"") D
.Q:$P(^AUPNPROB(X,0),U,8)>EDATE
.S Y=$P(^AUPNPROB(X,0),U)
.Q:'$$ICD^ATXCHK(Y,T,9)
.S G=$P(^AUPNPROB(X,0),U,8)
.Q
Q G
HIVTEST(P,BDATE,EDATE) ;
NEW BGPC,BGPT,T,X,BGPLT,E,D,B,L,J,G,BGPT1,BGPA
NEW BD,ED,Y,D,V
K BGPA
S BGPC=0
S T=$O(^ATXAX("B","BGP HIV TEST LOINC CODES",0))
S BGPLT=$O(^ATXLAB("B","BGP HIV TEST 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 V=$P(^AUPNVLAB(X,0),U,3)
...I BGPLT,$P(^AUPNVLAB(X,0),U),$D(^ATXLAB(BGPLT,21,"B",$P(^AUPNVLAB(X,0),U))) S BGPC=BGPC+1,BGPC(BGPC)=1_U_$$DATE^BGP1UTL((9999999-D))_" LAB"_U_$P(^AUPNVLAB(X,0),U,4)_U_D,BGPA((9999999-D))="" Q
...Q:'T
...S J=$P($G(^AUPNVLAB(X,11)),U,13) Q:J=""
...Q:'$$LOINC^BGP1D21(J,T)
...S BGPC=BGPC+1,BGPC(BGPC)=1_U_$$DATE^BGP1UTL((9999999-D))_" LAB "_$P($G(^LAB(95.3,J,0)),U)_"-"_$P($G(^LAB(95.3,J,0)),U,15)_U_$P(^AUPNVLAB(X,0),U,4)_U_D,BGPA((9999999-D))=""
...Q
S T=$O(^ATXAX("B","BGP CPT HIV TESTS",0))
I T D
.;go through visits in a date range for this patient, check cpts
.S ED=(9999999-EDATE),BD=9999999-BDATE,G=0
.F S ED=$O(^AUPNVSIT("AA",P,ED)) Q:ED=""!($P(ED,".")>BD) D
..S V=0 F S V=$O(^AUPNVSIT("AA",P,ED,V)) Q:V'=+V D
...Q:'$D(^AUPNVSIT(V,0))
...Q:'$D(^AUPNVCPT("AD",V))
...S X=0 F S X=$O(^AUPNVCPT("AD",V,X)) Q:X'=+X D
....I $$ICD^ATXCHK($P(^AUPNVCPT(X,0),U),T,1) I '$D(BGPA((9999999-$P(ED,".")))) S BGPC=BGPC+1,BGPC(BGPC)=1_U_$$DATE^BGP1UTL((9999999-$P(ED,".")))_" CPT "_$$VAL^XBDIQ1(9000010.18,X,.01)_U_U_$P(ED,"."),BGPA((9999999-$P(ED,".")))=""
....Q
...Q
..Q
I BGPC>0 D S $P(X,U,2)=X,$P(X,U,1)=1,$P(X,U,3)=BGPC,$P(X,U,4)=Y,$P(X,U,6)=(9999999-T) Q X
.S X=""
.S T=0 F S T=$O(BGPC(T)) Q:T'=+T S:X]"" X=X_" " S X=X_$S(X]"":"; ",1:"")_$P(BGPC(T),U,2)_" result: "_$P(BGPC(T),U,3)
.;GET LAST ONE WITH A RESULT AND SET INTO Y
.K BGPA
.S T=0 F S T=$O(BGPC(T)) Q:T'=+T I $P(BGPC(T),U,3)]"" S BGPA($P(BGPC(T),U,4))=BGPC(T)
.S T=$O(BGPA(0))
.I T S Y=$P(BGPA(T),U,2)_" result: "_$P(BGPA(T),U,3)_U_$P(BGPA(T),U,3) Q
.S T=0 F S T=$O(BGPC(T)) Q:T'=+T S BGPA($P(BGPC(T),U,4))=BGPC(T)
.S T=$O(BGPA(0))
.S Y=$P(BGPA(T),U,2)_" No Result"
;now check for refusal of an HIV test
S BGPT=$O(^ATXLAB("B","BGP HIV TEST TAX",0))
I 'BGPT Q ""
S (G,BGPT1)=0,G="" F S BGPT1=$O(^ATXLAB(BGPT,21,"B",BGPT1)) Q:BGPT1=""!(G) D
.S T=$$REFUSAL^BGP1UTL1(P,60,BGPT1,BDATE,EDATE) I $P(T,U)=1 S G=2_U_$$DATE^BGP1UTL($P(T,U,2))_" lab refusal"_U_U_$$DATE^BGP1UTL($P(T,U,2))_" lab refusal"
Q G
HIVEDUC(P,BDATE,EDATE) ;
K BGPG
S Y="BGPG("
S X=P_"^ALL EDUC;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE) S E=$$START1^APCLDF(X,Y)
I '$D(BGPG(1)) Q ""
S X=0,G="",%="",T="" F S X=$O(BGPG(X)) Q:X'=+X!($P(G,U)) D
.S T=$P(^AUPNVPED(+$P(BGPG(X),U,4),0),U)
.Q:'T
.Q:'$D(^AUTTEDT(T,0))
.S T=$P(^AUTTEDT(T,0),U,2)
.I $P(T,"-",1)="HIV"!($P(T,"-",1)["042")!($P(T,"-",1)["043")!($P(T,"-",1)["044")!($P(T,"-",1)="V08.")!($P(T,"-",1)["795.71")!($P(T,"-",2)="HIV") S G=1_U_$$DATE^BGP1UTL($P(BGPG(X),U))_U_T
I $P(G,U)=1 Q G
;
K BGPG
S Y="BGPG("
S X=P_"^LAST DX V65.44;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE) S E=$$START1^APCLDF(X,Y)
I $D(BGPG(1)) Q 1_U_$$DATE^BGP1UTL($P(BGPG(1),U))_"V65.44" ;has a dx
Q ""
;
CD4(P,BDATE,EDATE) ;
K BGPG
S %=P_"^LAST LAB [BGP CD4 TAX;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE),E=$$START1^APCLDF(%,"BGPG(")
I $D(BGPG(1)) Q 1_U_$P(BGPG(1),U,1)_U_$P(BGPG(1),U,2)
S E=+$$CODEN^ICPTCOD(86361),%=$$CPTI^BGP1DU(P,BDATE,EDATE,E) I %]"" Q 1_U_$P(%,U,2)_"^86361"
S E=+$$CODEN^ICPTCOD(86360),%=$$CPTI^BGP1DU(P,BDATE,EDATE,E) I %]"" Q 1_U_$P(%,U,2)_"^86360"
S E=+$$CODEN^ICPTCOD(86359),%=$$CPTI^BGP1DU(P,BDATE,EDATE,E) I %]"" Q 1_U_$P(%,U,2)_"^86359"
;tran codes
S E=+$$CODEN^ICPTCOD(86361),%=$$TRANI^BGP1DU(P,BDATE,EDATE,E) I %]"" Q 1_U_$P(%,U,2)_"^86361 TRAN"
S E=+$$CODEN^ICPTCOD(86360),%=$$TRANI^BGP1DU(P,BDATE,EDATE,E) I %]"" Q 1_U_$P(%,U,2)_"^86360 TRAN"
S E=+$$CODEN^ICPTCOD(86359),%=$$TRANI^BGP1DU(P,BDATE,EDATE,E) I %]"" Q 1_U_$P(%,U,2)_"^86359 TRAN"
;now go through all labs and check loinc codes
K ^TMP($J,"A")
S A="^TMP($J,""A"",",%=P_"^ALL LAB;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE),E=$$START1^APCLDF(%,A)
I '$D(^TMP($J,"A",1)) Q ""
;now go through all lab tests and see if any are the loinc codes in the taxonomy
S T=$O(^ATXAX("B","BGP CD4 LOINC CODES",0))
I 'T Q ""
S (X,G)=0 F S X=$O(^TMP($J,"A",X)) Q:X'=+X!(G) S I=+$P(^TMP($J,"A",X),U,4) I $P($G(^AUPNVLAB(I,11)),U,13)]"" D
.S J=$P(^AUPNVLAB(I,11),U,13)
.I $$LOINC^BGP1D21(J,T) S G=1_U_$$VD^APCLV($P(^AUPNVLAB(I,0),U,3))_U_$$VAL^XBDIQ1(9000010.09,I,.01)
Q G
PCR(P,BDATE,EDATE) ;
K BGPG
S %=P_"^LAST LAB [BGP HIV VIRAL LOAD TAX;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE),E=$$START1^APCLDF(%,"BGPG(")
I $D(BGPG(1)) Q 1_U_$P(BGPG(1),U,1)_U_$P(BGPG(1),U,2)
S E=+$$CODEN^ICPTCOD(87536),%=$$CPTI^BGP1DU(P,BDATE,EDATE,E) I %]"" Q 1_U_$P(%,U,2)_"^87536"
S E=+$$CODEN^ICPTCOD(87539),%=$$CPTI^BGP1DU(P,BDATE,EDATE,E) I %]"" Q 1_U_$P(%,U,2)_"^87539"
S E=+$$CODEN^ICPTCOD(87536),%=$$TRANI^BGP1DU(P,BDATE,EDATE,E) I %]"" Q 1_U_$P(%,U,2)_"^87536 TRAN"
S E=+$$CODEN^ICPTCOD(87539),%=$$TRANI^BGP1DU(P,BDATE,EDATE,E) I %]"" Q 1_U_$P(%,U,2)_"^87539 TRAN"
;now go through all labs and check loinc codes
K ^TMP($J,"A")
S A="^TMP($J,""A"",",%=P_"^ALL LAB;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE),E=$$START1^APCLDF(%,A)
I '$D(^TMP($J,"A",1)) Q ""
;now go through all lab tests and see if any are the loinc codes in the taxonomy
S T=$O(^ATXAX("B","BGP VIRAL LOAD LOINC CODES",0))
I 'T Q ""
S (X,G)=0 F S X=$O(^TMP($J,"A",X)) Q:X'=+X!(G) S I=+$P(^TMP($J,"A",X),U,4) I $P($G(^AUPNVLAB(I,11)),U,13)]"" D
.S J=$P(^AUPNVLAB(I,11),U,13)
.I $$LOINC^BGP1D21(J,T) S G=1_U_$$VD^APCLV($P(^AUPNVLAB(I,0),U,3))_U_$$VAL^XBDIQ1(9000010.09,I,.01)
Q G
V2HIV(P,BDATE,EDATE) ;
I '$G(P) Q ""
I '$D(^AUPNVSIT("AC",P)) Q ""
NEW BGP1M
S BGP1M=$$FMADD^XLFDT(EDATE,-(6*30))
K ^TMP($J,"A")
S A="^TMP($J,""A"",",B=P_"^ALL VISITS;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE),E=$$START1^APCLDF(B,A)
I '$D(^TMP($J,"A",1)) Q ""
S T=$O(^ATXAX("B","BGP HIV/AIDS DXS",0))
I 'T Q ""
S (X,G,H)=0 F S X=$O(^TMP($J,"A",X)) Q:X'=+X S V=$P(^TMP($J,"A",X),U,5) D
.Q:'$D(^AUPNVSIT(V,0))
.Q:'$P(^AUPNVSIT(V,0),U,9)
.Q:$P(^AUPNVSIT(V,0),U,11)
.Q:"SAHO"'[$P(^AUPNVSIT(V,0),U,7)
.Q:"CV"[$P(^AUPNVSIT(V,0),U,3)
.S (D,Y)=0 F S Y=$O(^AUPNVPOV("AD",V,Y)) Q:Y'=+Y!(D) I $D(^AUPNVPOV(Y,0)) S %=$P(^AUPNVPOV(Y,0),U) I $$ICD^ATXCHK(%,T,9) S D=1
.Q:'D
.I $P($P(^AUPNVSIT(V,0),U),".")'<BGP1M S H=1
.S G=G+1
.Q
I G>1,H=1 Q 1
Q ""
;
LOINC(A,B) ;
NEW %
S %=$P($G(^LAB(95.3,A,9999999)),U,2)
I %]"",$D(^ATXAX(B,21,"B",%)) Q 1
S %=$P($G(^LAB(95.3,A,0)),U)_"-"_$P($G(^LAB(95.3,A,0)),U,15)
I $D(^ATXAX(B,21,"B",%)) Q 1
Q ""
BGP1D8 ; IHS/CMI/LAB - measure C 03 Jul 2010 7:05 AM ;
+1 ;;11.1;IHS CLINICAL REPORTING SYSTEM;;JUN 27, 2011;Build 33
+2 ;
IE2 ;EP
+1 SET (BGPN1,BGPN2,BGPN3,BGPN4,BGPN5,BGPN6,BGPN7,BGPN8,BGPD1,BGPD2,BGPD3,BGPD4,BGPD5,BGPD6,BGPD7,BGPD8,BGPD9,BGPD10,BGPD11,BGPD12,BGPD13,BGPD14,BGPD15,BGPD16,BGPD17,BGPD18)=0
+2 SET BGPNO2=0
+3 ;has HIV dx ever (gpra)
SET BGPNO2=$$HIVDX(DFN,BGPEDATE)
+4 SET BGPHIVG=""
+5 SET BGPHIV=""
+6 ;has dx before report period
SET BGPDXB=$$HIVDX(DFN,$$FMADD^XLFDT(BGPBDATE,-1))
+7 ;date of dx during report period
SET BGPHIVD=$$HIVDX(DFN,BGPEDATE,BGPBDATE)
+8 ;active clinical, no hiv, pregnant
IF BGPACTCL
IF BGPSEX="F"
IF $$PREG^BGP1D7(DFN,$$FMADD^XLFDT(BGPEDATE,-600),BGPEDATE,0,1)
IF BGPNO2=""
SET BGPD1=1
+9 SET BGPN1=0
+10 SET BGPN2=0
+11 IF BGPD1
Begin DoDot:1
+12 ;get tests in past 20 months for gpra numerator
SET BGPHIVG=$$HIVTEST(DFN,$$FMADD^XLFDT(BGPEDATE,-600),BGPEDATE)
+13 ;had a test
IF $PIECE(BGPHIVG,U)=1
SET BGPN1=1
+14 ;had a refusal
IF $PIECE(BGPHIVG,U)=2
SET BGPN2=1
End DoDot:1
+15 ;---------------- done with GPRA num/den, now for developmental
+16 ;S BGPN3=$P(BGPHIV,U,3)
+17 ;I BGPD3,'BGPN3 S BGPSTOP=1 Q ;screen count only but no screens
+18 ;up 13-64 with no dx before report period
IF BGPACTUP
IF BGPAGEB>12
IF BGPAGEB<65
IF BGPDXB=""
SET BGPD2=1
+19 ;this is for screen count only, all ages and no dx before report period
IF BGPACTUP
IF BGPDXB=""
SET BGPD3=1
+20 IF BGPAGEB<13
SET BGPD4=1
+21 IF BGPAGEB>12
IF BGPAGEB<15
SET BGPD5=1
+22 IF BGPAGEB>14
IF BGPAGEB<20
SET BGPD6=1
+23 IF BGPAGEB>19
IF BGPAGEB<25
SET BGPD7=1
+24 IF BGPAGEB>24
IF BGPAGEB<30
SET BGPD8=1
+25 IF BGPAGEB>29
IF BGPAGEB<35
SET BGPD9=1
+26 IF BGPAGEB>34
IF BGPAGEB<40
SET BGPD10=1
+27 IF BGPAGEB>39
IF BGPAGEB<45
SET BGPD11=1
+28 IF BGPAGEB>44
IF BGPAGEB<50
SET BGPD12=1
+29 IF BGPAGEB>49
IF BGPAGEB<55
SET BGPD13=1
+30 IF BGPAGEB>54
IF BGPAGEB<60
SET BGPD14=1
+31 IF BGPAGEB>59
IF BGPAGEB<65
SET BGPD15=1
+32 IF BGPAGEB>64
SET BGPD16=1
+33 ;get HIV test during the report period
+34 ;get tests in past 20 months for gpra numerator
SET BGPHIV=$$HIVTEST(DFN,BGPBDATE,BGPEDATE)
+35 IF BGPD2
IF $PIECE(BGPHIV,U)=1
SET BGPN4=1
+36 IF BGPD2
IF $PIECE(BGPHIV,U)=2
SET BGPN8=1
+37 ;SET N3 TO TOTAL # OF SCREENS
+38 SET BGPX=$$HIVTEST(DFN,BGPBDATE,$SELECT(BGPHIVD:BGPHIVD,1:BGPEDATE))
+39 IF BGPD3
SET BGPN3=$PIECE(BGPX,U,3)
+40 SET BGPN5=0
+41 SET BGPN6=0
+42 SET BGPN7=0
+43 ;determine result pos or neg
+44 SET X=$PIECE(BGPHIV,U,5)
+45 SET X=$$UP^XLFSTR(X)
+46 SET D=$PIECE(BGPHIV,U,6)
+47 SET BGPDAFT=""
+48 IF X=""
IF D
SET G=$$HIVDX1(DFN,BGPED,D)
IF G
SET BGPN5=1
SET BGPDAFT="Positive HIV DX "_$PIECE(G,U,2)_" on "_$$DATE^BGP1UTL($PIECE(G,U))
GOTO V
+49 IF X=""
IF BGPN4
SET BGPN7=1
SET BGPDAFT="No Result"
+50 ;positive result
IF X="P"!(X="POSITIVE")!(X="POS")!(X="R")!(X="REACTIVE")!(X="REPEATEDLY REACTIVE")!(X="+")!(X[">")
SET BGPN5=1
SET BGPDAFT="Positive"
+51 IF X="N"!(X="NEGATIVE")!(X="NEG")!(X="NR")!(X="NON REACTIVE")!(X="NON-REACTIVE")!(X="-")
SET BGPN6=1
SET BGPDAFT="Negative"
V ;set denominator value for selected
+1 SET BGPVALUE=""
+2 SET BGPVAL=""
+3 IF BGPD3
SET BGPVALUE="UP"
+4 IF BGPD2
SET BGPVALUE="UP,UP13-64"
+5 IF BGPD1
SET BGPVALUE=BGPVALUE_",AC PREG (NO DX)"
+6 IF BGPD1!(BGPD2)
Begin DoDot:1
+7 IF BGPN1
IF 'BGPN4
SET BGPVAL=$PIECE(BGPHIVG,U,2)
QUIT
+8 IF BGPN1!(BGPN4)
SET BGPVAL=$PIECE(BGPHIV,U,2)
+9 IF BGPN2!(BGPN8)
SET BGPVAL=$SELECT(BGPHIVG]"":$PIECE(BGPHIVG,U,4),1:$PIECE(BGPHIV,U,4))
End DoDot:1
+10 IF BGPD3
IF BGPN3
SET BGPVAL=BGPVAL_$SELECT(BGPVAL]"":"",1:$PIECE(BGPX,U,2))_" ;Screen Count: "_BGPN3
+11 SET BGPVALUE=BGPVALUE_"|||"_BGPVAL
+12 SET BGPVALUD=""
IF BGPD2
SET BGPVALUD="UP,UP13-64|||"_$SELECT(BGPD2&(BGPHIV):"SCREEN (NO HIV DX): "_$PIECE(BGPHIV,U,4)_" ; ",1:"")_$PIECE(BGPHIV,U,2)_" ; "_BGPDAFT_$SELECT(BGPN3:" ;SCREEN COUNT (NO PRIOR DX): "_$PIECE(BGPHIV,U,3)_" screens",1:"")
+13 IF BGPD3
IF 'BGPD2
IF BGPN3
SET BGPVALUD="UP|||SCREEN COUNT MEASURE: "_BGPN3_" screens"
+14 IF BGPVALUD=" ; "
SET BGPVALUD=""
+15 KILL X,Y,Z,%,A,B,C,D,E,H,BDATE,EDATE,P,V,S,F,T
+16 IF $GET(BGPIISO)
QUIT
+17 KILL BGPEDUC,BGPHIV
+18 QUIT
IE1 ;EP
+1 SET (BGPN1,BGPN2,BGPN3,BGPN4,BGPN5,BGPN6,BGPD1,BGPD2,BGPD3,BGPD4,BGPD5,BGPD6,BGPD7,BGPD8,BGPD9,BGPCD4,BGPPCR)=0
+2 IF BGPAGEB<13
SET BGPSTOP=1
QUIT
+3 ;not active clinical pt
IF 'BGPACTCL
SET BGPSTOP=1
QUIT
+4 IF '$$V2HIV(DFN,BGP365,BGPEDATE)
SET BGPSTOP=1
QUIT
+5 IF BGPACTCL
SET BGPD1=1
+6 IF 'BGPD1
SET BGPSTOP=1
QUIT
+7 SET BGPCD4=$$CD4(DFN,BGP365,BGPEDATE)
+8 SET BGPPCR=$$PCR(DFN,BGP365,BGPEDATE)
+9 IF BGPCD4
IF 'BGPPCR
SET BGPN1=1
+10 IF BGPPCR
IF 'BGPCD4
SET BGPN2=1
+11 IF BGPPCR
IF BGPCD4
SET BGPN3=1
+12 IF (BGPN1+BGPN2+BGPN3)
SET BGPN4=1
+13 SET BGPVALUE="UP|||"_$SELECT(BGPCD4:"CD4: "_$$DATE^BGP1UTL($PIECE(BGPCD4,U,2))_" "_$PIECE(BGPCD4,U,3),1:"")
+14 IF $PIECE(BGPVALUE,"|||",2)]""
SET BGPVALUE=BGPVALUE_"; "
+15 SET BGPVALUE=BGPVALUE_$SELECT(BGPPCR:"Viral Load: "_$$DATE^BGP1UTL($PIECE(BGPPCR,U,2))_" "_$PIECE(BGPPCR,U,3),1:"")
+16 KILL X,Y,Z,%,A,B,C,D,E,H,BDATE,EDATE,P,V,S,F,T
+17 KILL ^TMP($JOB,"A")
+18 QUIT
PHYACT ;EP
+1 SET (BGPN1,BGPN2,BGPN3,BGPN4,BGPN5,BGPN6,BGPN7,BGPN8,BGPN9,BGPD1,BGPD2,BGPD3,BGPD4,BGPD5,BGPD6,BGPD7,BGPD8,BGPD9,BGPD10)=""
+2 IF BGPAGEB<5
SET BGPSTOP=1
QUIT
+3 SET BGPVALUE=""
+4 IF BGPACTUP
SET BGPD1=1
+5 IF BGPACTCL
SET BGPD2=1
+6 ;not in measure
IF '(BGPACTUP+BGPACTCL)
SET BGPSTOP=1
QUIT
+7 ;5-11
IF BGPACTCL
IF BGPAGEB>4
IF BGPAGEB<12
SET BGPD3=1
+8 ;12-19
IF BGPACTCL
IF BGPAGEB>11
IF BGPAGEB<20
SET BGPD4=1
+9 ;20-24
IF BGPACTCL
IF BGPAGEB>19
IF BGPAGEB<25
SET BGPD5=1
+10 ;25-34
IF BGPACTCL
IF BGPAGEB>24
IF BGPAGEB<35
SET BGPD6=1
+11 IF BGPACTCL
IF BGPAGEB>34
IF BGPAGEB<45
SET BGPD7=1
+12 IF BGPACTCL
IF BGPAGEB>44
IF BGPAGEB<55
SET BGPD8=1
+13 IF BGPACTCL
IF BGPAGEB>54
IF BGPAGEB<75
SET BGPD9=1
+14 IF BGPACTCL
IF BGPAGEB>74
SET BGPD10=1
+15 ;get the first health factor in this category recorded in this time period
SET BGPPHYA=$$FIRSTHF(DFN,BGPBDATE,BGPEDATE,"ACTIVITY LEVEL")
+16 ;return 1^date internal^date external^factor found
+17 ;had assessment
IF BGPPHYA
SET BGPN1=1
SET BGPVALUE="PHYS ACT: "_$PIECE(BGPPHYA,U,3)_" "_$PIECE(BGPPHYA,U,4)
+18 SET BGPEXER=""
IF BGPPHYA
SET BGPEXER=$$EXER(DFN,$PIECE(BGPPHYA,U,2),BGPEDATE)
+19 IF BGPEXER
SET BGPN2=1
SET BGPVALUE=BGPVALUE_"; EXER ED: "_$$DATE^BGP1UTL($PIECE(BGPEXER,U,1))_" "_$PIECE(BGPEXER,U,2)
+20 IF BGPD1
IF 'BGPD2
SET BGPVALUE="UP|||"_BGPVALUE
+21 IF BGPD2
SET BGPVALUE="UP,AC|||"_BGPVALUE
+22 KILL BGPEXER,BGPPHYA
+23 QUIT
EXER(P,BDATE,EDATE) ;
+1 NEW BGPG,X,E,BGPALLED
+2 KILL BGPG
SET X=P_"^LAST DX V65.41;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(X,"BGPG(")
+3 IF $DATA(BGPG(1))
QUIT $PIECE(BGPG(1),U)_U_"V65.41"_U_$$DATE^BGP1UTL($PIECE(BGPG(1),U,1))
+4 SET Y="BGPALLED("
+5 SET X=P_"^ALL EDUC;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(X,Y)
+6 IF '$DATA(BGPALLED(1))
QUIT ""
+7 SET (X,D)=0
SET %=""
SET T=""
FOR
SET X=$ORDER(BGPALLED(X))
IF X'=+X!(%]"")
QUIT
Begin DoDot:1
+8 SET T=$PIECE(^AUPNVPED(+$PIECE(BGPALLED(X),U,4),0),U)
+9 IF 'T
QUIT
+10 IF '$DATA(^AUTTEDT(T,0))
QUIT
+11 SET T=$PIECE(^AUTTEDT(T,0),U,2)
+12 IF $PIECE(T,"-",2)="EX"!($PIECE(T,"-")="V65.41")
SET %=$PIECE(BGPALLED(X),U)_U_T
QUIT
End DoDot:1
+13 QUIT %
FIRSTHF(P,BDATE,EDATE,CAT) ;EP
+1 NEW C,H,D,O
+2 SET C=$ORDER(^AUTTHF("B",CAT,0))
+3 IF '$GET(C)
QUIT ""
+4 SET (H,D)=0
KILL O
+5 FOR
SET H=$ORDER(^AUTTHF("AC",C,H))
IF '+H
QUIT
Begin DoDot:1
+6 IF '$DATA(^AUPNVHF("AA",P,H))
QUIT
+7 SET D=""
FOR
SET D=$ORDER(^AUPNVHF("AA",P,H,D))
IF D'=+D
QUIT
Begin DoDot:2
+8 IF (9999999-D)>EDATE
QUIT
+9 IF (9999999-D)<BDATE
QUIT
+10 SET O(9999999-D)=$ORDER(^AUPNVHF("AA",P,H,D,""))
End DoDot:2
+11 QUIT
End DoDot:1
+12 SET D=$ORDER(O(0))
+13 IF D=""
QUIT D
+14 QUIT 1_U_D_U_$$DATE^BGP1UTL(D)_U_$$VAL^XBDIQ1(9000010.23,O(D),.01)
+15 ;
HIVDX1(P,EDATE,BDATE) ;EP - any HIV dx
+1 NEW BGPG,G,Y,X,T,E
+2 KILL BGPG
+3 SET Y="BGPG("
+4 SET BDATE=$GET(BDATE)
+5 ;dob
IF BDATE=""
SET BDATE=$PIECE(^DPT(P,0),U,3)
+6 SET X=P_"^LAST DX [BGP HIV/AIDS DXS;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(X,Y)
+7 IF $DATA(BGPG(1))
QUIT $PIECE(BGPG(1),U)_U_$PIECE(BGPG(1),U,2)
+8 SET T=$ORDER(^ATXAX("B","BGP HIV/AIDS DXS",0))
+9 SET X=0
SET G=""
FOR
SET X=$ORDER(^AUPNPROB("AC",P,X))
IF X'=+X!(G]"")
QUIT
Begin DoDot:1
+10 IF $PIECE(^AUPNPROB(X,0),U,8)>EDATE
QUIT
+11 SET Y=$PIECE(^AUPNPROB(X,0),U)
+12 IF '$$ICD^ATXCHK(Y,T,9)
QUIT
+13 SET G=$PIECE(^AUPNPROB(X,0),U,8)_U_$$VAL^XBDIQ1(9000011,X,.01)
+14 QUIT
End DoDot:1
+15 QUIT G
HIVDX(P,EDATE,BDATE) ;EP - any HIV dx ever or problem list HIV dx
+1 NEW BGPG,G,Y,X,T,E
+2 KILL BGPG
+3 SET Y="BGPG("
+4 SET BDATE=$GET(BDATE)
+5 ;dob
IF BDATE=""
SET BDATE=$PIECE(^DPT(P,0),U,3)
+6 SET X=P_"^LAST DX [BGP HIV/AIDS DXS;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(X,Y)
+7 IF $DATA(BGPG(1))
QUIT $PIECE(BGPG(1),U)
+8 SET T=$ORDER(^ATXAX("B","BGP HIV/AIDS DXS",0))
+9 SET X=0
SET G=""
FOR
SET X=$ORDER(^AUPNPROB("AC",P,X))
IF X'=+X!(G]"")
QUIT
Begin DoDot:1
+10 IF $PIECE(^AUPNPROB(X,0),U,8)>EDATE
QUIT
+11 SET Y=$PIECE(^AUPNPROB(X,0),U)
+12 IF '$$ICD^ATXCHK(Y,T,9)
QUIT
+13 SET G=$PIECE(^AUPNPROB(X,0),U,8)
+14 QUIT
End DoDot:1
+15 QUIT G
HIVTEST(P,BDATE,EDATE) ;
+1 NEW BGPC,BGPT,T,X,BGPLT,E,D,B,L,J,G,BGPT1,BGPA
+2 NEW BD,ED,Y,D,V
+3 KILL BGPA
+4 SET BGPC=0
+5 SET T=$ORDER(^ATXAX("B","BGP HIV TEST LOINC CODES",0))
+6 SET BGPLT=$ORDER(^ATXLAB("B","BGP HIV TEST TAX",0))
+7 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
+8 SET L=0
FOR
SET L=$ORDER(^AUPNVLAB("AE",P,D,L))
IF L'=+L
QUIT
Begin DoDot:2
+9 SET X=0
FOR
SET X=$ORDER(^AUPNVLAB("AE",P,D,L,X))
IF X'=+X
QUIT
Begin DoDot:3
+10 IF '$DATA(^AUPNVLAB(X,0))
QUIT
+11 SET V=$PIECE(^AUPNVLAB(X,0),U,3)
+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 BGPC(BGPC)=1_U_$$DATE^BGP1UTL((9999999-D))_" LAB"_U_$PIECE(^AUPNVLAB(X,0),U,4)_U_D
SET BGPA((9999999-D))=""
QUIT
+13 IF 'T
QUIT
+14 SET J=$PIECE($GET(^AUPNVLAB(X,11)),U,13)
IF J=""
QUIT
+15 IF '$$LOINC^BGP1D21(J,T)
QUIT
+16 SET BGPC=BGPC+1
SET BGPC(BGPC)=1_U_$$DATE^BGP1UTL((9999999-D))_" LAB "_$PIECE($GET(^LAB(95.3,J,0)),U)_"-"_$PIECE($GET(^LAB(95.3,J,0)),U,15)_U_$PIECE(^AUPNVLAB(X,0),U,4)_U_D
SET BGPA((9999999-D))=""
+17 QUIT
End DoDot:3
End DoDot:2
End DoDot:1
+18 SET T=$ORDER(^ATXAX("B","BGP CPT HIV TESTS",0))
+19 IF T
Begin DoDot:1
+20 ;go through visits in a date range for this patient, check cpts
+21 SET ED=(9999999-EDATE)
SET BD=9999999-BDATE
SET G=0
+22 FOR
SET ED=$ORDER(^AUPNVSIT("AA",P,ED))
IF ED=""!($PIECE(ED,".")>BD)
QUIT
Begin DoDot:2
+23 SET V=0
FOR
SET V=$ORDER(^AUPNVSIT("AA",P,ED,V))
IF V'=+V
QUIT
Begin DoDot:3
+24 IF '$DATA(^AUPNVSIT(V,0))
QUIT
+25 IF '$DATA(^AUPNVCPT("AD",V))
QUIT
+26 SET X=0
FOR
SET X=$ORDER(^AUPNVCPT("AD",V,X))
IF X'=+X
QUIT
Begin DoDot:4
+27 IF $$ICD^ATXCHK($PIECE(^AUPNVCPT(X,0),U),T,1)
IF '$DATA(BGPA((9999999-$PIECE(ED,"."))))
SET BGPC=BGPC+1
SET BGPC(BGPC)=1_U_$$DATE^BGP1UTL((9999999-$PIECE(ED,".")))_" CPT "_$$VAL^XBDIQ1(9000010.18,X,.01)_U_U_$PIECE(ED,".")
SET BGPA((9999999-$PIECE(ED,".")))=""
+28 QUIT
End DoDot:4
+29 QUIT
End DoDot:3
+30 QUIT
End DoDot:2
End DoDot:1
+31 IF BGPC>0
Begin DoDot:1
+32 SET X=""
+33 SET T=0
FOR
SET T=$ORDER(BGPC(T))
IF T'=+T
QUIT
IF X]""
SET X=X_" "
SET X=X_$SELECT(X]"":"; ",1:"")_$PIECE(BGPC(T),U,2)_" result: "_$PIECE(BGPC(T),U,3)
+34 ;GET LAST ONE WITH A RESULT AND SET INTO Y
+35 KILL BGPA
+36 SET T=0
FOR
SET T=$ORDER(BGPC(T))
IF T'=+T
QUIT
IF $PIECE(BGPC(T),U,3)]""
SET BGPA($PIECE(BGPC(T),U,4))=BGPC(T)
+37 SET T=$ORDER(BGPA(0))
+38 IF T
SET Y=$PIECE(BGPA(T),U,2)_" result: "_$PIECE(BGPA(T),U,3)_U_$PIECE(BGPA(T),U,3)
QUIT
+39 SET T=0
FOR
SET T=$ORDER(BGPC(T))
IF T'=+T
QUIT
SET BGPA($PIECE(BGPC(T),U,4))=BGPC(T)
+40 SET T=$ORDER(BGPA(0))
+41 SET Y=$PIECE(BGPA(T),U,2)_" No Result"
End DoDot:1
SET $PIECE(X,U,2)=X
SET $PIECE(X,U,1)=1
SET $PIECE(X,U,3)=BGPC
SET $PIECE(X,U,4)=Y
SET $PIECE(X,U,6)=(9999999-T)
QUIT X
+42 ;now check for refusal of an HIV test
+43 SET BGPT=$ORDER(^ATXLAB("B","BGP HIV TEST TAX",0))
+44 IF 'BGPT
QUIT ""
+45 SET (G,BGPT1)=0
SET G=""
FOR
SET BGPT1=$ORDER(^ATXLAB(BGPT,21,"B",BGPT1))
IF BGPT1=""!(G)
QUIT
Begin DoDot:1
+46 SET T=$$REFUSAL^BGP1UTL1(P,60,BGPT1,BDATE,EDATE)
IF $PIECE(T,U)=1
SET G=2_U_$$DATE^BGP1UTL($PIECE(T,U,2))_" lab refusal"_U_U_$$DATE^BGP1UTL($PIECE(T,U,2))_" lab refusal"
End DoDot:1
+47 QUIT G
HIVEDUC(P,BDATE,EDATE) ;
+1 KILL BGPG
+2 SET Y="BGPG("
+3 SET X=P_"^ALL EDUC;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(X,Y)
+4 IF '$DATA(BGPG(1))
QUIT ""
+5 SET X=0
SET G=""
SET %=""
SET T=""
FOR
SET X=$ORDER(BGPG(X))
IF X'=+X!($PIECE(G,U))
QUIT
Begin DoDot:1
+6 SET T=$PIECE(^AUPNVPED(+$PIECE(BGPG(X),U,4),0),U)
+7 IF 'T
QUIT
+8 IF '$DATA(^AUTTEDT(T,0))
QUIT
+9 SET T=$PIECE(^AUTTEDT(T,0),U,2)
+10 IF $PIECE(T,"-",1)="HIV"!($PIECE(T,"-",1)["042")!($PIECE(T,"-",1)["043")!($PIECE(T,"-",1)["044")!($PIECE(T,"-",1)="V08.")!($PIECE(T,"-",1)["795.71")!($PIECE(T,"-",2)="HIV")
SET G=1_U_$$DATE^BGP1UTL($PIECE(BGPG(X),U))_U_T
End DoDot:1
+11 IF $PIECE(G,U)=1
QUIT G
+12 ;
+13 KILL BGPG
+14 SET Y="BGPG("
+15 SET X=P_"^LAST DX V65.44;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(X,Y)
+16 ;has a dx
IF $DATA(BGPG(1))
QUIT 1_U_$$DATE^BGP1UTL($PIECE(BGPG(1),U))_"V65.44"
+17 QUIT ""
+18 ;
CD4(P,BDATE,EDATE) ;
+1 KILL BGPG
+2 SET %=P_"^LAST LAB [BGP CD4 TAX;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(%,"BGPG(")
+3 IF $DATA(BGPG(1))
QUIT 1_U_$PIECE(BGPG(1),U,1)_U_$PIECE(BGPG(1),U,2)
+4 SET E=+$$CODEN^ICPTCOD(86361)
SET %=$$CPTI^BGP1DU(P,BDATE,EDATE,E)
IF %]""
QUIT 1_U_$PIECE(%,U,2)_"^86361"
+5 SET E=+$$CODEN^ICPTCOD(86360)
SET %=$$CPTI^BGP1DU(P,BDATE,EDATE,E)
IF %]""
QUIT 1_U_$PIECE(%,U,2)_"^86360"
+6 SET E=+$$CODEN^ICPTCOD(86359)
SET %=$$CPTI^BGP1DU(P,BDATE,EDATE,E)
IF %]""
QUIT 1_U_$PIECE(%,U,2)_"^86359"
+7 ;tran codes
+8 SET E=+$$CODEN^ICPTCOD(86361)
SET %=$$TRANI^BGP1DU(P,BDATE,EDATE,E)
IF %]""
QUIT 1_U_$PIECE(%,U,2)_"^86361 TRAN"
+9 SET E=+$$CODEN^ICPTCOD(86360)
SET %=$$TRANI^BGP1DU(P,BDATE,EDATE,E)
IF %]""
QUIT 1_U_$PIECE(%,U,2)_"^86360 TRAN"
+10 SET E=+$$CODEN^ICPTCOD(86359)
SET %=$$TRANI^BGP1DU(P,BDATE,EDATE,E)
IF %]""
QUIT 1_U_$PIECE(%,U,2)_"^86359 TRAN"
+11 ;now go through all labs and check loinc codes
+12 KILL ^TMP($JOB,"A")
+13 SET A="^TMP($J,""A"","
SET %=P_"^ALL LAB;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(%,A)
+14 IF '$DATA(^TMP($JOB,"A",1))
QUIT ""
+15 ;now go through all lab tests and see if any are the loinc codes in the taxonomy
+16 SET T=$ORDER(^ATXAX("B","BGP CD4 LOINC CODES",0))
+17 IF 'T
QUIT ""
+18 SET (X,G)=0
FOR
SET X=$ORDER(^TMP($JOB,"A",X))
IF X'=+X!(G)
QUIT
SET I=+$PIECE(^TMP($JOB,"A",X),U,4)
IF $PIECE($GET(^AUPNVLAB(I,11)),U,13)]""
Begin DoDot:1
+19 SET J=$PIECE(^AUPNVLAB(I,11),U,13)
+20 IF $$LOINC^BGP1D21(J,T)
SET G=1_U_$$VD^APCLV($PIECE(^AUPNVLAB(I,0),U,3))_U_$$VAL^XBDIQ1(9000010.09,I,.01)
End DoDot:1
+21 QUIT G
PCR(P,BDATE,EDATE) ;
+1 KILL BGPG
+2 SET %=P_"^LAST LAB [BGP HIV VIRAL LOAD TAX;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(%,"BGPG(")
+3 IF $DATA(BGPG(1))
QUIT 1_U_$PIECE(BGPG(1),U,1)_U_$PIECE(BGPG(1),U,2)
+4 SET E=+$$CODEN^ICPTCOD(87536)
SET %=$$CPTI^BGP1DU(P,BDATE,EDATE,E)
IF %]""
QUIT 1_U_$PIECE(%,U,2)_"^87536"
+5 SET E=+$$CODEN^ICPTCOD(87539)
SET %=$$CPTI^BGP1DU(P,BDATE,EDATE,E)
IF %]""
QUIT 1_U_$PIECE(%,U,2)_"^87539"
+6 SET E=+$$CODEN^ICPTCOD(87536)
SET %=$$TRANI^BGP1DU(P,BDATE,EDATE,E)
IF %]""
QUIT 1_U_$PIECE(%,U,2)_"^87536 TRAN"
+7 SET E=+$$CODEN^ICPTCOD(87539)
SET %=$$TRANI^BGP1DU(P,BDATE,EDATE,E)
IF %]""
QUIT 1_U_$PIECE(%,U,2)_"^87539 TRAN"
+8 ;now go through all labs and check loinc codes
+9 KILL ^TMP($JOB,"A")
+10 SET A="^TMP($J,""A"","
SET %=P_"^ALL LAB;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(%,A)
+11 IF '$DATA(^TMP($JOB,"A",1))
QUIT ""
+12 ;now go through all lab tests and see if any are the loinc codes in the taxonomy
+13 SET T=$ORDER(^ATXAX("B","BGP VIRAL LOAD LOINC CODES",0))
+14 IF 'T
QUIT ""
+15 SET (X,G)=0
FOR
SET X=$ORDER(^TMP($JOB,"A",X))
IF X'=+X!(G)
QUIT
SET I=+$PIECE(^TMP($JOB,"A",X),U,4)
IF $PIECE($GET(^AUPNVLAB(I,11)),U,13)]""
Begin DoDot:1
+16 SET J=$PIECE(^AUPNVLAB(I,11),U,13)
+17 IF $$LOINC^BGP1D21(J,T)
SET G=1_U_$$VD^APCLV($PIECE(^AUPNVLAB(I,0),U,3))_U_$$VAL^XBDIQ1(9000010.09,I,.01)
End DoDot:1
+18 QUIT G
V2HIV(P,BDATE,EDATE) ;
+1 IF '$GET(P)
QUIT ""
+2 IF '$DATA(^AUPNVSIT("AC",P))
QUIT ""
+3 NEW BGP1M
+4 SET BGP1M=$$FMADD^XLFDT(EDATE,-(6*30))
+5 KILL ^TMP($JOB,"A")
+6 SET A="^TMP($J,""A"","
SET B=P_"^ALL VISITS;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(B,A)
+7 IF '$DATA(^TMP($JOB,"A",1))
QUIT ""
+8 SET T=$ORDER(^ATXAX("B","BGP HIV/AIDS DXS",0))
+9 IF 'T
QUIT ""
+10 SET (X,G,H)=0
FOR
SET X=$ORDER(^TMP($JOB,"A",X))
IF X'=+X
QUIT
SET V=$PIECE(^TMP($JOB,"A",X),U,5)
Begin DoDot:1
+11 IF '$DATA(^AUPNVSIT(V,0))
QUIT
+12 IF '$PIECE(^AUPNVSIT(V,0),U,9)
QUIT
+13 IF $PIECE(^AUPNVSIT(V,0),U,11)
QUIT
+14 IF "SAHO"'[$PIECE(^AUPNVSIT(V,0),U,7)
QUIT
+15 IF "CV"[$PIECE(^AUPNVSIT(V,0),U,3)
QUIT
+16 SET (D,Y)=0
FOR
SET Y=$ORDER(^AUPNVPOV("AD",V,Y))
IF Y'=+Y!(D)
QUIT
IF $DATA(^AUPNVPOV(Y,0))
SET %=$PIECE(^AUPNVPOV(Y,0),U)
IF $$ICD^ATXCHK(%,T,9)
SET D=1
+17 IF 'D
QUIT
+18 IF $PIECE($PIECE(^AUPNVSIT(V,0),U),".")'<BGP1M
SET H=1
+19 SET G=G+1
+20 QUIT
End DoDot:1
+21 IF G>1
IF H=1
QUIT 1
+22 QUIT ""
+23 ;
LOINC(A,B) ;
+1 NEW %
+2 SET %=$PIECE($GET(^LAB(95.3,A,9999999)),U,2)
+3 IF %]""
IF $DATA(^ATXAX(B,21,"B",%))
QUIT 1
+4 SET %=$PIECE($GET(^LAB(95.3,A,0)),U)_"-"_$PIECE($GET(^LAB(95.3,A,0)),U,15)
+5 IF $DATA(^ATXAX(B,21,"B",%))
QUIT 1
+6 QUIT ""
