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

BGP0D8.m

Go to the documentation of this file.
  1. BGP0D8 ; IHS/CMI/LAB - measure C 03 Jul 2009 7:05 AM ;
  1. ;;10.0;IHS CLINICAL REPORTING;**1**;JUN 18, 2010
  1. ;
  1. IE2 ;EP
  1. S (BGPN1,BGPN2,BGPN3,BGPN4,BGPN5,BGPN6,BGPD1,BGPD2,BGPD3,BGPD4,BGPD5,BGPD6,BGPD7,BGPD8,BGPD9)=0
  1. ;I 'BGPACTCL S BGPSTOP=1 Q ;not active clinical pt
  1. ;I BGPSEX'="F" S BGPSTOP=1 Q
  1. S BGPNO2=0
  1. S BGPNO2=$$HIVDX(DFN,BGPEDATE) I BGPNO2]"" S BGPD3=1
  1. I BGPACTCL,BGPSEX="F",$$PREG^BGP0D7(DFN,$$FMADD^XLFDT(BGPEDATE,-600),BGPEDATE),BGPNO2="" S BGPD1=1 ;not pregnant
  1. ;I BGPACTCL,BGPSEX="F",$$PREG^BGP0D7(DFN,$$FMADD^XLFDT(BGPEDATE,-600),BGPEDATE,1),BGPNO2="" S BGPD4=1 ;not pregnant
  1. I BGPACTUP,BGPAGEB>12,BGPAGEB<65,BGPNO2="" S BGPD2=1
  1. I '(BGPD1+BGPD2+BGPD3) S BGPSTOP=1 Q ;not in either denominator
  1. S BGPHIV=$$HIVTEST(DFN,$$FMADD^XLFDT(BGPEDATE,$S(BGPD1:-600,1:-365)),$S(BGPNO2]"":BGPNO2,1:BGPEDATE))
  1. I $P(BGPHIV,U) S BGPN1=1
  1. I $P(BGPHIV,U)=2 S BGPN2=1
  1. S BGPN3=$P(BGPHIV,U,3)
  1. I BGPD3,'BGPN3 S BGPSTOP=1 Q ;screen count only but no screens
  1. I $P(BGPHIV,U)=1 S BGPN4=1
  1. ;S BGPEDUC=$$HIVEDUC(DFN,$$FMADD^XLFDT(BGPEDATE,-600),BGPEDATE)
  1. ;I $P(BGPEDUC,U)=1 S BGPN3=1
  1. ;I BGPRTYPE=1 S BGPVALUE="AC PREG|||"_$S(BGPD2&(BGPHIV):"HIV SCREEN MEASURE (NO HIV DX EVER): "_$P(BGPHIV,U,4),1:"") I 1
  1. S BGPVALUE=$S(BGPNO2="":"UP",1:"")_$S(BGPD1:";AC PREG",1:"")_" "_$S(BGPD4:"/AC PREG (NO RX/CHR)",1:"")_"|||"_$S(BGPD2&(BGPHIV):"HIV SCREEN MEASURE (NO HIV DX EVER): "_$P(BGPHIV,U,4)_" ; ",1:"")_$P(BGPHIV,U,2)
  1. ;I $P(BGPEDUC,U)=1 S BGPVALUE=BGPVALUE_" EDUC: "_$P(BGPEDUC,U,2)_" "_$P(BGPEDUC,U,3)
  1. S BGPVALUD="" I BGPD2 S BGPVALUD="UP13-64|||"_$S(BGPD2&(BGPHIV):"HIV SCREEN MEASURE (NO HIV DX EVER): "_$P(BGPHIV,U,4)_" ; ",1:"")_$P(BGPHIV,U,2)
  1. K X,Y,Z,%,A,B,C,D,E,H,BDATE,EDATE,P,V,S,F,T
  1. Q:$G(BGPIISO)
  1. K BGPEDUC,BGPHIV
  1. Q
  1. IE1 ;EP
  1. S (BGPN1,BGPN2,BGPN3,BGPN4,BGPN5,BGPN6,BGPD1,BGPD2,BGPD3,BGPD4,BGPD5,BGPD6,BGPD7,BGPD8,BGPD9,BGPCD4,BGPPCR)=0
  1. I BGPAGEB<13 S BGPSTOP=1 Q
  1. I 'BGPACTCL S BGPSTOP=1 Q ;not active clinical pt
  1. I '$$V2HIV(DFN,BGP365,BGPEDATE) S BGPSTOP=1 Q
  1. I BGPACTCL S BGPD1=1
  1. I 'BGPD1 S BGPSTOP=1 Q
  1. S BGPCD4=$$CD4(DFN,BGP365,BGPEDATE)
  1. S BGPPCR=$$PCR(DFN,BGP365,BGPEDATE)
  1. I BGPCD4,'BGPPCR S BGPN1=1
  1. I BGPPCR,'BGPCD4 S BGPN2=1
  1. I BGPPCR,BGPCD4 S BGPN3=1
  1. I (BGPN1+BGPN2+BGPN3) S BGPN4=1
  1. K X,Y,Z,%,A,B,C,D,E,H,BDATE,EDATE,P,V,S,F,T
  1. K ^TMP($J,"A")
  1. Q
  1. PHYACT ;EP
  1. S (BGPN1,BGPN2,BGPN3,BGPN4,BGPN5,BGPN6,BGPN7,BGPN8,BGPN9,BGPD1,BGPD2,BGPD3,BGPD4,BGPD5,BGPD6,BGPD7,BGPD8,BGPD9,BGPD10)=""
  1. I BGPAGEB<5 S BGPSTOP=1 Q ;no one under 5
  1. S BGPVALUE=""
  1. I BGPACTUP S BGPD1=1 ;user pop
  1. I BGPACTCL S BGPD2=1 ;active clinical
  1. I '(BGPACTUP+BGPACTCL) S BGPSTOP=1 Q ;not in measure
  1. I BGPACTCL,BGPAGEB>4,BGPAGEB<12 S BGPD3=1 ;5-11
  1. I BGPACTCL,BGPAGEB>11,BGPAGEB<20 S BGPD4=1 ;12-19
  1. I BGPACTCL,BGPAGEB>19,BGPAGEB<25 S BGPD5=1 ;20-24
  1. I BGPACTCL,BGPAGEB>24,BGPAGEB<35 S BGPD6=1 ;25-34
  1. I BGPACTCL,BGPAGEB>34,BGPAGEB<45 S BGPD7=1
  1. I BGPACTCL,BGPAGEB>44,BGPAGEB<55 S BGPD8=1
  1. I BGPACTCL,BGPAGEB>54,BGPAGEB<75 S BGPD9=1
  1. I BGPACTCL,BGPAGEB>74 S BGPD10=1
  1. S BGPPHYA=$$FIRSTHF(DFN,BGPBDATE,BGPEDATE,"ACTIVITY LEVEL") ;get the first health factor in this category recorded in this time period
  1. ;return 1^date internal^date external^factor found
  1. I BGPPHYA S BGPN1=1,BGPVALUE="PHYS ACT: "_$P(BGPPHYA,U,3)_" "_$P(BGPPHYA,U,4)_";" ;had assessment
  1. S BGPEXER="" I BGPPHYA S BGPEXER=$$EXER(DFN,$P(BGPPHYA,U,2),BGPEDATE)
  1. I BGPEXER S BGPN2=1,BGPVALUE=BGPVALUE_" EXER ED: "_$$DATE^BGP0UTL($P(BGPEXER,U,1))_" "_$P(BGPEXER,U,2)
  1. I BGPD1,'BGPD2 S BGPVALUE="UP|||"_BGPVALUE
  1. I BGPD2 S BGPVALUE="UP;AC|||"_BGPVALUE
  1. K BGPEXER,BGPPHYA
  1. Q
  1. EXER(P,BDATE,EDATE) ;
  1. NEW BGPG,X,E,BGPALLED
  1. K BGPG S X=P_"^LAST DX V65.41;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE) S E=$$START1^APCLDF(X,"BGPG(")
  1. I $D(BGPG(1)) Q $P(BGPG(1),U)_U_"V65.41"_U_$$DATE^BGP0UTL($P(BGPG(1),U,1))
  1. S Y="BGPALLED("
  1. S X=P_"^ALL EDUC;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE) S E=$$START1^APCLDF(X,Y)
  1. I '$D(BGPALLED(1)) Q ""
  1. S (X,D)=0,%="",T="" F S X=$O(BGPALLED(X)) Q:X'=+X!(%]"") D
  1. .S T=$P(^AUPNVPED(+$P(BGPALLED(X),U,4),0),U)
  1. .Q:'T
  1. .Q:'$D(^AUTTEDT(T,0))
  1. .S T=$P(^AUTTEDT(T,0),U,2)
  1. .I $P(T,"-",2)="EX"!($P(T,"-")="V65.41") S %=$P(BGPALLED(X),U)_U_T Q
  1. Q %
  1. FIRSTHF(P,BDATE,EDATE,CAT) ;EP
  1. NEW C,H,D,O
  1. S C=$O(^AUTTHF("B",CAT,0)) ;ien of category passed
  1. I '$G(C) Q ""
  1. S (H,D)=0 K O
  1. F S H=$O(^AUTTHF("AC",C,H)) Q:'+H D
  1. .Q:'$D(^AUPNVHF("AA",P,H))
  1. .S D="" F S D=$O(^AUPNVHF("AA",P,H,D)) Q:D'=+D D
  1. ..Q:(9999999-D)>EDATE ;after time frame
  1. ..Q:(9999999-D)<BDATE ;before time frame
  1. ..S O(9999999-D)=$O(^AUPNVHF("AA",P,H,D,""))
  1. .Q
  1. S D=$O(O(0))
  1. I D="" Q D
  1. Q 1_U_D_U_$$DATE^BGP0UTL(D)_U_$$VAL^XBDIQ1(9000010.23,O(D),.01)
  1. ;
  1. HIVDX(P,EDATE) ; any HIV dx ever or problem list HIV dx
  1. K BGPG
  1. S Y="BGPG("
  1. S BDATE=$P(^DPT(P,0),U,3) ;dob
  1. S X=P_"^LAST DX [BGP HIV/AIDS DXS;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE) S E=$$START1^APCLDF(X,Y)
  1. I $D(BGPG(1)) Q $P(BGPG(1),U)
  1. S T=$O(^ATXAX("B","BGP HIV/AIDS DXS",0))
  1. S X=0,G="" F S X=$O(^AUPNPROB("AC",P,X)) Q:X'=+X!(G]"") D
  1. .Q:$P(^AUPNPROB(X,0),U,8)>EDATE
  1. .S Y=$P(^AUPNPROB(X,0),U)
  1. .Q:'$$ICD^ATXCHK(Y,T,9)
  1. .S G=$P(^AUPNPROB(X,0),U,8)
  1. .Q
  1. Q G
  1. HIVTEST(P,BDATE,EDATE) ;
  1. NEW BGPC,BGPT,T,X,BGPLT,E,D,B,L,J,G,BGPT1,BGPA
  1. NEW BD,ED,Y,D,V
  1. K BGPA
  1. S BGPC=0
  1. S T=$O(^ATXAX("B","BGP CPT HIV TESTS",0))
  1. I T D
  1. .;go through visits in a date range for this patient, check cpts
  1. .S ED=(9999999-EDATE),BD=9999999-BDATE,G=0
  1. .F S ED=$O(^AUPNVSIT("AA",P,ED)) Q:ED=""!($P(ED,".")>BD) D
  1. ..S V=0 F S V=$O(^AUPNVSIT("AA",P,ED,V)) Q:V'=+V D
  1. ...Q:'$D(^AUPNVSIT(V,0))
  1. ...Q:'$D(^AUPNVCPT("AD",V))
  1. ...S X=0 F S X=$O(^AUPNVCPT("AD",V,X)) Q:X'=+X D
  1. ....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^BGP0UTL((9999999-$P(ED,".")))_" CPT "_$$VAL^XBDIQ1(9000010.18,X,.01),BGPA((9999999-$P(ED,".")))=""
  1. ....Q
  1. ...Q
  1. ..Q
  1. S T=$O(^ATXAX("B","BGP HIV TEST LOINC CODES",0))
  1. S BGPLT=$O(^ATXLAB("B","BGP HIV TEST 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 V=$P(^AUPNVLAB(X,0),U,3)
  1. ...I BGPLT,$P(^AUPNVLAB(X,0),U),$D(^ATXLAB(BGPLT,21,"B",$P(^AUPNVLAB(X,0),U))),'$D(BGPA((9999999-D))) S BGPC=BGPC+1,BGPC(BGPC)=1_U_$$DATE^BGP0UTL((9999999-D))_" LAB",BGPA((9999999-D))="" Q
  1. ...Q:'T
  1. ...S J=$P($G(^AUPNVLAB(X,11)),U,13) Q:J=""
  1. ...Q:'$$LOINC^BGP0D21(J,T)
  1. ...I '$D(BGPA((9999999-D))) S BGPC=BGPC+1,BGPC(BGPC)=1_U_$$DATE^BGP0UTL((9999999-D))_" LAB "_$P($G(^LAB(95.3,J,0)),U)_"-"_$P($G(^LAB(95.3,J,0)),U,15),BGPA((9999999-D))=""
  1. ...Q
  1. I BGPC>0 D S $P(X,U,2)=X,$P(X,U,1)=1,$P(X,U,3)=BGPC,$P(X,U,4)=$P(BGPC(1),U,2) Q X
  1. .S X=""
  1. .S T=0 F S T=$O(BGPC(T)) Q:T'=+T S:X]"" X=X_" " S X=X_T_") HIV SCREEN COUNT (NO PRIOR HIV DX): "_$P(BGPC(T),U,2)
  1. ;now check for refusal of an HIV test
  1. S BGPT=$O(^ATXLAB("B","BGP HIV TEST TAX",0))
  1. I 'BGPT Q ""
  1. S (G,BGPT1)=0,G="" F S BGPT1=$O(^ATXLAB(BGPT,21,"B",BGPT1)) Q:BGPT1=""!(G) D
  1. .S T=$$REFUSAL^BGP0UTL1(P,60,BGPT1,BDATE,EDATE) I $P(T,U)=1 S G=2_U_U_U_$$DATE^BGP0UTL($P(T,U,2))_" lab refusal"
  1. Q G
  1. HIVEDUC(P,BDATE,EDATE) ;
  1. K BGPG
  1. S Y="BGPG("
  1. S X=P_"^ALL EDUC;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE) S E=$$START1^APCLDF(X,Y)
  1. I '$D(BGPG(1)) Q ""
  1. S X=0,G="",%="",T="" F S X=$O(BGPG(X)) Q:X'=+X!($P(G,U)) D
  1. .S T=$P(^AUPNVPED(+$P(BGPG(X),U,4),0),U)
  1. .Q:'T
  1. .Q:'$D(^AUTTEDT(T,0))
  1. .S T=$P(^AUTTEDT(T,0),U,2)
  1. .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^BGP0UTL($P(BGPG(X),U))_U_T
  1. I $P(G,U)=1 Q G
  1. ;
  1. K BGPG
  1. S Y="BGPG("
  1. S X=P_"^LAST DX V65.44;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE) S E=$$START1^APCLDF(X,Y)
  1. I $D(BGPG(1)) Q 1_U_$$DATE^BGP0UTL($P(BGPG(1),U))_"V65.44" ;has a dx
  1. Q ""
  1. ;
  1. CD4(P,BDATE,EDATE) ;
  1. K BGPG
  1. S %=P_"^LAST LAB [BGP CD4 TAX;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE),E=$$START1^APCLDF(%,"BGPG(")
  1. I $D(BGPG(1)) Q 1
  1. S E=+$$CODEN^ICPTCOD(86361),%=$$CPTI^BGP0DU(P,BDATE,EDATE,E) I %]"" Q $P(%,U)_"^86361"
  1. S E=+$$CODEN^ICPTCOD(86360),%=$$CPTI^BGP0DU(P,BDATE,EDATE,E) I %]"" Q $P(%,U)_"^86360"
  1. S E=+$$CODEN^ICPTCOD(86359),%=$$CPTI^BGP0DU(P,BDATE,EDATE,E) I %]"" Q $P(%,U)_"^86359"
  1. ;tran codes
  1. S E=+$$CODEN^ICPTCOD(86361),%=$$TRANI^BGP0DU(P,BDATE,EDATE,E) I %]"" Q $P(%,U)_"^86361 TRAN"
  1. S E=+$$CODEN^ICPTCOD(86360),%=$$TRANI^BGP0DU(P,BDATE,EDATE,E) I %]"" Q $P(%,U)_"^86360 TRAN"
  1. S E=+$$CODEN^ICPTCOD(86359),%=$$TRANI^BGP0DU(P,BDATE,EDATE,E) I %]"" Q $P(%,U)_"^86359 TRAN"
  1. ;now go through all labs and check loinc codes
  1. K ^TMP($J,"A")
  1. S A="^TMP($J,""A"",",%=P_"^ALL LAB;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE),E=$$START1^APCLDF(%,A)
  1. I '$D(^TMP($J,"A",1)) Q ""
  1. ;now go through all lab tests and see if any are the loinc codes in the taxonomy
  1. S T=$O(^ATXAX("B","BGP CD4 LOINC CODES",0))
  1. I 'T Q ""
  1. 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
  1. .S J=$P(^AUPNVLAB(I,11),U,13)
  1. .I $$LOINC^BGP0D21(J,T) S G=1
  1. Q G
  1. PCR(P,BDATE,EDATE) ;
  1. K BGPG
  1. S %=P_"^LAST LAB [BGP HIV VIRAL LOAD TAX;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE),E=$$START1^APCLDF(%,"BGPG(")
  1. I $D(BGPG(1)) Q 1
  1. S E=+$$CODEN^ICPTCOD(87536),%=$$CPTI^BGP0DU(P,BDATE,EDATE,E) I %]"" Q $P(%,U)_"^87536"
  1. S E=+$$CODEN^ICPTCOD(87539),%=$$CPTI^BGP0DU(P,BDATE,EDATE,E) I %]"" Q $P(%,U)_"^87539"
  1. S E=+$$CODEN^ICPTCOD(87536),%=$$TRANI^BGP0DU(P,BDATE,EDATE,E) I %]"" Q $P(%,U)_"^87536 TRAN"
  1. S E=+$$CODEN^ICPTCOD(87539),%=$$TRANI^BGP0DU(P,BDATE,EDATE,E) I %]"" Q $P(%,U)_"^87539 TRAN"
  1. ;now go through all labs and check loinc codes
  1. K ^TMP($J,"A")
  1. S A="^TMP($J,""A"",",%=P_"^ALL LAB;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE),E=$$START1^APCLDF(%,A)
  1. I '$D(^TMP($J,"A",1)) Q ""
  1. ;now go through all lab tests and see if any are the loinc codes in the taxonomy
  1. S T=$O(^ATXAX("B","BGP VIRAL LOAD LOINC CODES",0))
  1. I 'T Q ""
  1. 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
  1. .S J=$P(^AUPNVLAB(I,11),U,13)
  1. .I $$LOINC^BGP0D21(J,T) S G=1
  1. Q G
  1. V2HIV(P,BDATE,EDATE) ;
  1. I '$G(P) Q ""
  1. I '$D(^AUPNVSIT("AC",P)) Q ""
  1. NEW BGP0M
  1. S BGP0M=$$FMADD^XLFDT(EDATE,-(6*30))
  1. K ^TMP($J,"A")
  1. S A="^TMP($J,""A"",",B=P_"^ALL VISITS;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE),E=$$START1^APCLDF(B,A)
  1. I '$D(^TMP($J,"A",1)) Q ""
  1. S T=$O(^ATXAX("B","BGP HIV/AIDS DXS",0))
  1. I 'T Q ""
  1. 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
  1. .Q:'$D(^AUPNVSIT(V,0))
  1. .Q:'$P(^AUPNVSIT(V,0),U,9)
  1. .Q:$P(^AUPNVSIT(V,0),U,11)
  1. .Q:"SAHO"'[$P(^AUPNVSIT(V,0),U,7)
  1. .Q:"CV"[$P(^AUPNVSIT(V,0),U,3) ;eliminate contract health
  1. .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
  1. .Q:'D
  1. .I $P($P(^AUPNVSIT(V,0),U),".")'<BGP0M S H=1
  1. .S G=G+1
  1. .Q
  1. I G>1,H=1 Q 1
  1. Q ""
  1. ;
  1. LOINC(A,B) ;
  1. NEW %
  1. S %=$P($G(^LAB(95.3,A,9999999)),U,2)
  1. I %]"",$D(^ATXAX(B,21,"B",%)) Q 1
  1. S %=$P($G(^LAB(95.3,A,0)),U)_"-"_$P($G(^LAB(95.3,A,0)),U,15)
  1. I $D(^ATXAX(B,21,"B",%)) Q 1
  1. Q ""