- BGP0D8 ; IHS/CMI/LAB - measure C 03 Jul 2009 7:05 AM ;
- ;;10.0;IHS CLINICAL REPORTING;**1**;JUN 18, 2010
- ;
- IE2 ;EP
- S (BGPN1,BGPN2,BGPN3,BGPN4,BGPN5,BGPN6,BGPD1,BGPD2,BGPD3,BGPD4,BGPD5,BGPD6,BGPD7,BGPD8,BGPD9)=0
- ;I 'BGPACTCL S BGPSTOP=1 Q ;not active clinical pt
- ;I BGPSEX'="F" S BGPSTOP=1 Q
- S BGPNO2=0
- S BGPNO2=$$HIVDX(DFN,BGPEDATE) I BGPNO2]"" S BGPD3=1
- I BGPACTCL,BGPSEX="F",$$PREG^BGP0D7(DFN,$$FMADD^XLFDT(BGPEDATE,-600),BGPEDATE),BGPNO2="" S BGPD1=1 ;not pregnant
- ;I BGPACTCL,BGPSEX="F",$$PREG^BGP0D7(DFN,$$FMADD^XLFDT(BGPEDATE,-600),BGPEDATE,1),BGPNO2="" S BGPD4=1 ;not pregnant
- I BGPACTUP,BGPAGEB>12,BGPAGEB<65,BGPNO2="" S BGPD2=1
- I '(BGPD1+BGPD2+BGPD3) S BGPSTOP=1 Q ;not in either denominator
- S BGPHIV=$$HIVTEST(DFN,$$FMADD^XLFDT(BGPEDATE,$S(BGPD1:-600,1:-365)),$S(BGPNO2]"":BGPNO2,1:BGPEDATE))
- I $P(BGPHIV,U) S BGPN1=1
- I $P(BGPHIV,U)=2 S BGPN2=1
- S BGPN3=$P(BGPHIV,U,3)
- I BGPD3,'BGPN3 S BGPSTOP=1 Q ;screen count only but no screens
- I $P(BGPHIV,U)=1 S BGPN4=1
- ;S BGPEDUC=$$HIVEDUC(DFN,$$FMADD^XLFDT(BGPEDATE,-600),BGPEDATE)
- ;I $P(BGPEDUC,U)=1 S BGPN3=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
- 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)
- ;I $P(BGPEDUC,U)=1 S BGPVALUE=BGPVALUE_" EDUC: "_$P(BGPEDUC,U,2)_" "_$P(BGPEDUC,U,3)
- 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)
- 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
- 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 ;no one under 5
- S BGPVALUE=""
- I BGPACTUP S BGPD1=1 ;user pop
- I BGPACTCL S BGPD2=1 ;active clinical
- 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^BGP0UTL($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^BGP0UTL($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)) ;ien of category passed
- 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 ;after time frame
- ..Q:(9999999-D)<BDATE ;before time frame
- ..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^BGP0UTL(D)_U_$$VAL^XBDIQ1(9000010.23,O(D),.01)
- ;
- HIVDX(P,EDATE) ; any HIV dx ever or problem list HIV dx
- K BGPG
- S Y="BGPG("
- 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 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^BGP0UTL((9999999-$P(ED,".")))_" CPT "_$$VAL^XBDIQ1(9000010.18,X,.01),BGPA((9999999-$P(ED,".")))=""
- ....Q
- ...Q
- ..Q
- 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))),'$D(BGPA((9999999-D))) S BGPC=BGPC+1,BGPC(BGPC)=1_U_$$DATE^BGP0UTL((9999999-D))_" LAB",BGPA((9999999-D))="" Q
- ...Q:'T
- ...S J=$P($G(^AUPNVLAB(X,11)),U,13) Q:J=""
- ...Q:'$$LOINC^BGP0D21(J,T)
- ...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))=""
- ...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)=$P(BGPC(1),U,2) Q X
- .S X=""
- .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)
- ;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^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"
- 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^BGP0UTL($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^BGP0UTL($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
- S E=+$$CODEN^ICPTCOD(86361),%=$$CPTI^BGP0DU(P,BDATE,EDATE,E) I %]"" Q $P(%,U)_"^86361"
- S E=+$$CODEN^ICPTCOD(86360),%=$$CPTI^BGP0DU(P,BDATE,EDATE,E) I %]"" Q $P(%,U)_"^86360"
- S E=+$$CODEN^ICPTCOD(86359),%=$$CPTI^BGP0DU(P,BDATE,EDATE,E) I %]"" Q $P(%,U)_"^86359"
- ;tran codes
- S E=+$$CODEN^ICPTCOD(86361),%=$$TRANI^BGP0DU(P,BDATE,EDATE,E) I %]"" Q $P(%,U)_"^86361 TRAN"
- S E=+$$CODEN^ICPTCOD(86360),%=$$TRANI^BGP0DU(P,BDATE,EDATE,E) I %]"" Q $P(%,U)_"^86360 TRAN"
- S E=+$$CODEN^ICPTCOD(86359),%=$$TRANI^BGP0DU(P,BDATE,EDATE,E) I %]"" Q $P(%,U)_"^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^BGP0D21(J,T) S G=1
- 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
- S E=+$$CODEN^ICPTCOD(87536),%=$$CPTI^BGP0DU(P,BDATE,EDATE,E) I %]"" Q $P(%,U)_"^87536"
- S E=+$$CODEN^ICPTCOD(87539),%=$$CPTI^BGP0DU(P,BDATE,EDATE,E) I %]"" Q $P(%,U)_"^87539"
- S E=+$$CODEN^ICPTCOD(87536),%=$$TRANI^BGP0DU(P,BDATE,EDATE,E) I %]"" Q $P(%,U)_"^87536 TRAN"
- S E=+$$CODEN^ICPTCOD(87539),%=$$TRANI^BGP0DU(P,BDATE,EDATE,E) I %]"" Q $P(%,U)_"^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^BGP0D21(J,T) S G=1
- Q G
- V2HIV(P,BDATE,EDATE) ;
- I '$G(P) Q ""
- I '$D(^AUPNVSIT("AC",P)) Q ""
- NEW BGP0M
- S BGP0M=$$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) ;eliminate contract health
- .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),".")'<BGP0M 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 ""
- BGP0D8 ; IHS/CMI/LAB - measure C 03 Jul 2009 7:05 AM ;
- +1 ;;10.0;IHS CLINICAL REPORTING;**1**;JUN 18, 2010
- +2 ;
- IE2 ;EP
- +1 SET (BGPN1,BGPN2,BGPN3,BGPN4,BGPN5,BGPN6,BGPD1,BGPD2,BGPD3,BGPD4,BGPD5,BGPD6,BGPD7,BGPD8,BGPD9)=0
- +2 ;I 'BGPACTCL S BGPSTOP=1 Q ;not active clinical pt
- +3 ;I BGPSEX'="F" S BGPSTOP=1 Q
- +4 SET BGPNO2=0
- +5 SET BGPNO2=$$HIVDX(DFN,BGPEDATE)
- IF BGPNO2]""
- SET BGPD3=1
- +6 ;not pregnant
- IF BGPACTCL
- IF BGPSEX="F"
- IF $$PREG^BGP0D7(DFN,$$FMADD^XLFDT(BGPEDATE,-600),BGPEDATE)
- IF BGPNO2=""
- SET BGPD1=1
- +7 ;I BGPACTCL,BGPSEX="F",$$PREG^BGP0D7(DFN,$$FMADD^XLFDT(BGPEDATE,-600),BGPEDATE,1),BGPNO2="" S BGPD4=1 ;not pregnant
- +8 IF BGPACTUP
- IF BGPAGEB>12
- IF BGPAGEB<65
- IF BGPNO2=""
- SET BGPD2=1
- +9 ;not in either denominator
- IF '(BGPD1+BGPD2+BGPD3)
- SET BGPSTOP=1
- QUIT
- +10 SET BGPHIV=$$HIVTEST(DFN,$$FMADD^XLFDT(BGPEDATE,$SELECT(BGPD1:-600,1:-365)),$SELECT(BGPNO2]"":BGPNO2,1:BGPEDATE))
- +11 IF $PIECE(BGPHIV,U)
- SET BGPN1=1
- +12 IF $PIECE(BGPHIV,U)=2
- SET BGPN2=1
- +13 SET BGPN3=$PIECE(BGPHIV,U,3)
- +14 ;screen count only but no screens
- IF BGPD3
- IF 'BGPN3
- SET BGPSTOP=1
- QUIT
- +15 IF $PIECE(BGPHIV,U)=1
- SET BGPN4=1
- +16 ;S BGPEDUC=$$HIVEDUC(DFN,$$FMADD^XLFDT(BGPEDATE,-600),BGPEDATE)
- +17 ;I $P(BGPEDUC,U)=1 S BGPN3=1
- +18 ;I BGPRTYPE=1 S BGPVALUE="AC PREG|||"_$S(BGPD2&(BGPHIV):"HIV SCREEN MEASURE (NO HIV DX EVER): "_$P(BGPHIV,U,4),1:"") I 1
- +19 SET BGPVALUE=$SELECT(BGPNO2="":"UP",1:"")_$SELECT(BGPD1:";AC PREG",1:"")_" "_$SELECT(BGPD4:"/AC PREG (NO RX/CHR)",1:"")_"|||"_$SELECT(BGPD2&(BGPHIV):"HIV SCREEN MEASURE (NO HIV DX EVER): "_$PIECE(BGPHIV,U,4)_" ; ",1:"")_$PIECE(BGPHIV,U,2)
- +20 ;I $P(BGPEDUC,U)=1 S BGPVALUE=BGPVALUE_" EDUC: "_$P(BGPEDUC,U,2)_" "_$P(BGPEDUC,U,3)
- +21 SET BGPVALUD=""
- IF BGPD2
- SET BGPVALUD="UP13-64|||"_$SELECT(BGPD2&(BGPHIV):"HIV SCREEN MEASURE (NO HIV DX EVER): "_$PIECE(BGPHIV,U,4)_" ; ",1:"")_$PIECE(BGPHIV,U,2)
- +22 KILL X,Y,Z,%,A,B,C,D,E,H,BDATE,EDATE,P,V,S,F,T
- +23 IF $GET(BGPIISO)
- QUIT
- +24 KILL BGPEDUC,BGPHIV
- +25 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 KILL X,Y,Z,%,A,B,C,D,E,H,BDATE,EDATE,P,V,S,F,T
- +14 KILL ^TMP($JOB,"A")
- +15 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 ;no one under 5
- IF BGPAGEB<5
- SET BGPSTOP=1
- QUIT
- +3 SET BGPVALUE=""
- +4 ;user pop
- IF BGPACTUP
- SET BGPD1=1
- +5 ;active clinical
- 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^BGP0UTL($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^BGP0UTL($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 ;ien of category passed
- 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 ;after time frame
- IF (9999999-D)>EDATE
- QUIT
- +9 ;before time frame
- 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^BGP0UTL(D)_U_$$VAL^XBDIQ1(9000010.23,O(D),.01)
- +15 ;
- HIVDX(P,EDATE) ; any HIV dx ever or problem list HIV dx
- +1 KILL BGPG
- +2 SET Y="BGPG("
- +3 ;dob
- SET BDATE=$PIECE(^DPT(P,0),U,3)
- +4 SET X=P_"^LAST DX [BGP HIV/AIDS DXS;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE)
- SET E=$$START1^APCLDF(X,Y)
- +5 IF $DATA(BGPG(1))
- QUIT $PIECE(BGPG(1),U)
- +6 SET T=$ORDER(^ATXAX("B","BGP HIV/AIDS DXS",0))
- +7 SET X=0
- SET G=""
- FOR
- SET X=$ORDER(^AUPNPROB("AC",P,X))
- IF X'=+X!(G]"")
- QUIT
- Begin DoDot:1
- +8 IF $PIECE(^AUPNPROB(X,0),U,8)>EDATE
- QUIT
- +9 SET Y=$PIECE(^AUPNPROB(X,0),U)
- +10 IF '$$ICD^ATXCHK(Y,T,9)
- QUIT
- +11 SET G=$PIECE(^AUPNPROB(X,0),U,8)
- +12 QUIT
- End DoDot:1
- +13 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 CPT HIV TESTS",0))
- +6 IF T
- Begin DoDot:1
- +7 ;go through visits in a date range for this patient, check cpts
- +8 SET ED=(9999999-EDATE)
- SET BD=9999999-BDATE
- SET G=0
- +9 FOR
- SET ED=$ORDER(^AUPNVSIT("AA",P,ED))
- IF ED=""!($PIECE(ED,".")>BD)
- QUIT
- Begin DoDot:2
- +10 SET V=0
- FOR
- SET V=$ORDER(^AUPNVSIT("AA",P,ED,V))
- IF V'=+V
- QUIT
- Begin DoDot:3
- +11 IF '$DATA(^AUPNVSIT(V,0))
- QUIT
- +12 IF '$DATA(^AUPNVCPT("AD",V))
- QUIT
- +13 SET X=0
- FOR
- SET X=$ORDER(^AUPNVCPT("AD",V,X))
- IF X'=+X
- QUIT
- Begin DoDot:4
- +14 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^BGP0UTL((9999999-$PIECE(ED,".")))_" CPT "_$$VAL^XBDIQ1(9000010.18,X,.01)
- SET BGPA((9999999-$PIECE(ED,".")))=""
- +15 QUIT
- End DoDot:4
- +16 QUIT
- End DoDot:3
- +17 QUIT
- End DoDot:2
- End DoDot:1
- +18 SET T=$ORDER(^ATXAX("B","BGP HIV TEST LOINC CODES",0))
- +19 SET BGPLT=$ORDER(^ATXLAB("B","BGP HIV TEST TAX",0))
- +20 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
- +21 SET L=0
- FOR
- SET L=$ORDER(^AUPNVLAB("AE",P,D,L))
- IF L'=+L
- QUIT
- Begin DoDot:2
- +22 SET X=0
- FOR
- SET X=$ORDER(^AUPNVLAB("AE",P,D,L,X))
- IF X'=+X
- QUIT
- Begin DoDot:3
- +23 IF '$DATA(^AUPNVLAB(X,0))
- QUIT
- +24 SET V=$PIECE(^AUPNVLAB(X,0),U,3)
- +25 IF BGPLT
- IF $PIECE(^AUPNVLAB(X,0),U)
- IF $DATA(^ATXLAB(BGPLT,21,"B",$PIECE(^AUPNVLAB(X,0),U)))
- IF '$DATA(BGPA((9999999-D)))
- SET BGPC=BGPC+1
- SET BGPC(BGPC)=1_U_$$DATE^BGP0UTL((9999999-D))_" LAB"
- SET BGPA((9999999-D))=""
- QUIT
- +26 IF 'T
- QUIT
- +27 SET J=$PIECE($GET(^AUPNVLAB(X,11)),U,13)
- IF J=""
- QUIT
- +28 IF '$$LOINC^BGP0D21(J,T)
- QUIT
- +29 IF '$DATA(BGPA((9999999-D)))
- SET BGPC=BGPC+1
- SET BGPC(BGPC)=1_U_$$DATE^BGP0UTL((9999999-D))_" LAB "_$PIECE($GET(^LAB(95.3,J,0)),U)_"-"_$PIECE($GET(^LAB(95.3,J,0)),U,15)
- SET BGPA((9999999-D))=""
- +30 QUIT
- End DoDot:3
- 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_T_") HIV SCREEN COUNT (NO PRIOR HIV DX): "_$PIECE(BGPC(T),U,2)
- 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)=$PIECE(BGPC(1),U,2)
- QUIT X
- +34 ;now check for refusal of an HIV test
- +35 SET BGPT=$ORDER(^ATXLAB("B","BGP HIV TEST TAX",0))
- +36 IF 'BGPT
- QUIT ""
- +37 SET (G,BGPT1)=0
- SET G=""
- FOR
- SET BGPT1=$ORDER(^ATXLAB(BGPT,21,"B",BGPT1))
- IF BGPT1=""!(G)
- QUIT
- Begin DoDot:1
- +38 SET T=$$REFUSAL^BGP0UTL1(P,60,BGPT1,BDATE,EDATE)
- IF $PIECE(T,U)=1
- SET G=2_U_U_U_$$DATE^BGP0UTL($PIECE(T,U,2))_" lab refusal"
- End DoDot:1
- +39 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^BGP0UTL($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^BGP0UTL($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
- +4 SET E=+$$CODEN^ICPTCOD(86361)
- SET %=$$CPTI^BGP0DU(P,BDATE,EDATE,E)
- IF %]""
- QUIT $PIECE(%,U)_"^86361"
- +5 SET E=+$$CODEN^ICPTCOD(86360)
- SET %=$$CPTI^BGP0DU(P,BDATE,EDATE,E)
- IF %]""
- QUIT $PIECE(%,U)_"^86360"
- +6 SET E=+$$CODEN^ICPTCOD(86359)
- SET %=$$CPTI^BGP0DU(P,BDATE,EDATE,E)
- IF %]""
- QUIT $PIECE(%,U)_"^86359"
- +7 ;tran codes
- +8 SET E=+$$CODEN^ICPTCOD(86361)
- SET %=$$TRANI^BGP0DU(P,BDATE,EDATE,E)
- IF %]""
- QUIT $PIECE(%,U)_"^86361 TRAN"
- +9 SET E=+$$CODEN^ICPTCOD(86360)
- SET %=$$TRANI^BGP0DU(P,BDATE,EDATE,E)
- IF %]""
- QUIT $PIECE(%,U)_"^86360 TRAN"
- +10 SET E=+$$CODEN^ICPTCOD(86359)
- SET %=$$TRANI^BGP0DU(P,BDATE,EDATE,E)
- IF %]""
- QUIT $PIECE(%,U)_"^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^BGP0D21(J,T)
- SET G=1
- 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
- +4 SET E=+$$CODEN^ICPTCOD(87536)
- SET %=$$CPTI^BGP0DU(P,BDATE,EDATE,E)
- IF %]""
- QUIT $PIECE(%,U)_"^87536"
- +5 SET E=+$$CODEN^ICPTCOD(87539)
- SET %=$$CPTI^BGP0DU(P,BDATE,EDATE,E)
- IF %]""
- QUIT $PIECE(%,U)_"^87539"
- +6 SET E=+$$CODEN^ICPTCOD(87536)
- SET %=$$TRANI^BGP0DU(P,BDATE,EDATE,E)
- IF %]""
- QUIT $PIECE(%,U)_"^87536 TRAN"
- +7 SET E=+$$CODEN^ICPTCOD(87539)
- SET %=$$TRANI^BGP0DU(P,BDATE,EDATE,E)
- IF %]""
- QUIT $PIECE(%,U)_"^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^BGP0D21(J,T)
- SET G=1
- End DoDot:1
- +18 QUIT G
- V2HIV(P,BDATE,EDATE) ;
- +1 IF '$GET(P)
- QUIT ""
- +2 IF '$DATA(^AUPNVSIT("AC",P))
- QUIT ""
- +3 NEW BGP0M
- +4 SET BGP0M=$$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 ;eliminate contract health
- 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),".")'<BGP0M
- 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 ""