- BGP3D8 ; IHS/CMI/LAB - measure C 03 Jul 2010 7:05 AM ; 21 Mar 2013 5:25 PM
- ;;13.0;IHS CLINICAL REPORTING;**1**;NOV 20, 2012;Build 7
- ;
- 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 (BGPN9,BGPN10,BGPN11,BGPN12,BGPN13,BGPN14,BGPN15,BGPN16)=0
- S BGPNO2=0
- S BGPNO2=$$HIVDX(DFN,BGPEDATE)
- S BGPHIVG=""
- S BGPHIV=""
- S BGPDXB=$$HIVDX(DFN,$$FMADD^XLFDT(BGPBDATE,-1))
- S BGPHIVD=$$HIVDX(DFN,BGPEDATE,BGPBDATE)
- I BGPACTCL,BGPSEX="F",$$PREG^BGP3D7(DFN,$$FMADD^XLFDT(BGPEDATE,-608),BGPEDATE,1,1),BGPNO2="" S BGPD1=1
- S BGPFIRST=$$FIRSTDX(DFN,BGPBDATE,BGPEDATE)
- S BGPN1=0
- S BGPN2=0
- I BGPD1 D
- .S BGPHIVG=$$HIVTEST(DFN,$$FMADD^XLFDT(BGPEDATE,-608),BGPEDATE)
- .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
- I BGPACTUP,BGPAGEB>12,BGPAGEB<65,BGPDXB="" S BGPD2=1 ;up 13-64 with no dx before report period
- I BGPACTUP,BGPAGEB>12,BGPAGEB<65,BGPFIRST S BGPD17=1
- I BGPACTUP,BGPDXB="" S BGPD3=1
- I BGPAGEB<13,BGPDXB="" S BGPD4=1
- I BGPAGEB>12,BGPAGEB<15,BGPDXB="" S BGPD5=1
- I BGPAGEB>14,BGPAGEB<20,BGPDXB="" S BGPD6=1
- I BGPAGEB>19,BGPAGEB<25,BGPDXB="" S BGPD7=1
- I BGPAGEB>24,BGPAGEB<30,BGPDXB="" S BGPD8=1
- I BGPAGEB>29,BGPAGEB<35,BGPDXB="" S BGPD9=1
- I BGPAGEB>34,BGPAGEB<40,BGPDXB="" S BGPD10=1
- I BGPAGEB>39,BGPAGEB<45,BGPDXB="" S BGPD11=1
- I BGPAGEB>44,BGPAGEB<50,BGPDXB="" S BGPD12=1
- I BGPAGEB>49,BGPAGEB<55,BGPDXB="" S BGPD13=1
- I BGPAGEB>54,BGPAGEB<60,BGPDXB="" S BGPD14=1
- I BGPAGEB>59,BGPAGEB<65,BGPDXB="" S BGPD15=1
- I BGPAGEB>64,BGPDXB="" S BGPD16=1
- ;get HIV test during the report period
- S BGPHIV=$$HIVTEST(DFN,BGPBDATE,$S(BGPHIVD:BGPHIVD,1:BGPEDATE))
- I BGPD2,$P(BGPHIV,U)=1 S BGPN4=1
- I BGPD2,$P(BGPHIV,U)=2 S BGPN8=1
- S BGPHIVE=$$HIVTEST(DFN,$$DOB^AUPNPAT(DFN),$S(BGPHIVD:BGPHIVD,1:BGPEDATE))
- I $P(BGPHIVE,U,1)=1 S BGPN16=1
- S BGPHIV5=$$HIVTEST(DFN,$$FMADD^XLFDT(BGPEDATE,-(5*365)),$S(BGPHIVD:BGPHIVD,1:BGPEDATE))
- I $P(BGPHIV5,U,1)=1 S BGPN15=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 BGPCD4=""
- I BGPFIRST D
- .S D=$P(BGPFIRST,U,3) S BGPCD4=$$CD4RES^BGP3D84(DFN,$$FMADD^XLFDT(D,-90),$$FMADD^XLFDT(D,90),1)
- .Q:'BGPCD4
- .S BGPN9=1
- .S R=$P(BGPCD4,U,3)
- .I R="" S BGPN14=1 Q
- .I $E(R,1,3)="CPT" S BGPN14=1 Q
- .I R>500 S BGPN13=1 Q
- .I R>350 S BGPN12=1 Q
- .I R<200 S BGPN10=1 Q
- .S BGPN11=1
- S BGPN5=0
- S BGPN6=0
- S BGPN7=0
- ;
- S BGPHIVR=$$HIVTEST1^BGP3D812(DFN,BGPBDATE,$S(BGPHIVD:BGPHIVD,1:BGPEDATE)) ;FOR GPRA DEV RESULT ONLY
- S BGPDAFT=""
- I BGPHIVR=""!($P(BGPHIVR,U,1)=3),BGPN4 S BGPN7=1,BGPDAFT="No Result"
- I $P(BGPHIVR,U,1)=1 S BGPN5=1,BGPDAFT=$P(BGPHIVR,U,2) ;"Positive" ;positive result
- I $P(BGPHIVR,U,1)=2 S BGPN6=1,BGPDAFT=$P(BGPHIVR,U,2) ;"Negative"
- V ;
- S BGPVALUE=""
- S BGPVAL=""
- I BGPD3 S BGPVALUE="UP"
- I BGPD2 S BGPVALUE="UP"
- I BGPD1 S BGPVALUE=BGPVALUE_",AC PREG"
- 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 %="",D="",R=""
- I BGPHIV S %=" 1yr ",D=$P($P(BGPHIV,U,4)," ")_" ",E="" ;$P($P(BGPHIV,U,4)," ",2,99)
- I %="",BGPHIV5 S %=" 5yr ",D=$P($P(BGPHIV5,U,4)," ")_" ",E="" ;$P($P(BGPHIV5,U,4)," ",2,99)
- I %="",BGPHIVE S D=$P($P(BGPHIVE,U,4)," ")_" ",E="" ;$P($P(BGPHIVE,U,4)," ",2,99)
- S BGPVALUD="UP" I BGPD2,(BGPN1!(BGPN4)!(BGPN15)!(BGPN16))!(BGPN8) D
- .S BGPVALUD="UP|||"_$S(BGPD2!(D]""):"SCREEN (NO HIV DX): "_D_$S(%]"":%,1:"")_E_"; ",1:"")_$S(BGPN3:"SCREEN COUNT (NO PRIOR DX): "_$P(BGPHIV,U,3)_" screens - "_$P(BGPHIV,U,2),1:"")_$S(BGPN8:" REF",1:"")
- I BGPCD4 S:BGPVALUD'["|||" BGPVALUD=BGPVALUD_"|||" S:$P(BGPVALUD,"|||",2)]"" BGPVALUD=BGPVALUD_";" S BGPVALUD=BGPVALUD_"CD4="_$P(BGPCD4,U,3)
- I BGPD3,'BGPD2,BGPN3 S BGPVALUD="UP|||SCREEN COUNT MEASURE: "_BGPN3_" screens"
- I BGPDAFT]"" S BGPVALUD=BGPVALUD_"; RESULT (GPRA DEV): "_BGPDAFT
- 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,BGPHIVR,BGPHIVE,BGPHIV5
- 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
- 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^BGP3D811(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(BGPN3:"BOTH: ",1:"")_$S(BGPCD4:"CD4: "_$$DATE^BGP3UTL($P(BGPCD4,U,2))_" "_$P(BGPCD4,U,3),1:"")
- I $P(BGPVALUE,"|||",2)]"" S BGPVALUE=BGPVALUE_"; "
- S BGPVALUE=BGPVALUE_$S(BGPPCR:"Viral Load: "_$$DATE^BGP3UTL($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")
- ;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^BGP3UTL($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 [BGP EXERCISE COUNSELING DXS;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE) S E=$$START1^APCLDF(X,"BGPG(")
- I $D(BGPG(1)) Q $P(BGPG(1),U)_U_$P(BGPG(1),U,2)_U_$$DATE^BGP3UTL($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" S %=$P(BGPALLED(X),U)_U_T Q
- .S S=$P(T,"-",1)
- .S S=$$ICDDX^ICDCODE(S)
- .I $P(S,U,1)'="-1",$$ICD^ATXCHK($P(S,U,1),$O(^ATXAX("B","BGP EXERCISE COUNSELING DXS",0)),9) 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^BGP3UTL(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,12)="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 PL
- 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)
- 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,12)="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))
- ...Q:$P(^AUPNVLAB(X,0),U,4)=""
- ...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 Q
- ....I '$D(BGPA((9999999-D))) S BGPC=BGPC+1,BGPC(BGPC)=1_U_$$DATE^BGP3UTL((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^BGP3D21(J,T)
- ...Q:$D(BGPA((9999999-D)))
- ...S BGPC=BGPC+1,BGPC(BGPC)=1_U_$$DATE^BGP3UTL((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
- ..Q
- .;
- .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 Q
- ....I '$D(BGPA((9999999-D))) S BGPC=BGPC+1,BGPC(BGPC)=1_U_$$DATE^BGP3UTL((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^BGP3D21(J,T)
- ...Q:$D(BGPA((9999999-D))) ;
- ...S BGPC=BGPC+1,BGPC(BGPC)=1_U_$$DATE^BGP3UTL((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
- ..Q
- S T=$O(^ATXAX("B","BGP CPT HIV TESTS",0))
- I T D
- .;
- .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^BGP3UTL((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_$S(X]"":", ",1:"")_$P(BGPC(T),U,2)
- .;
- .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"
- ;
- 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^BGP3UTL1(P,60,BGPT1,BDATE,EDATE) I $P(T,U)=1 S G=2_U_$$DATE^BGP3UTL($P(T,U,2))_" Refused Lab"_U_U_$$DATE^BGP3UTL($P(T,U,2))_" Refused Lab"
- Q G
- 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^BGP3DU(P,BDATE,EDATE,E) I %]"" Q 1_U_$P(%,U,2)_"^86361"
- S E=+$$CODEN^ICPTCOD(86360),%=$$CPTI^BGP3DU(P,BDATE,EDATE,E) I %]"" Q 1_U_$P(%,U,2)_"^86360"
- S E=+$$CODEN^ICPTCOD(86359),%=$$CPTI^BGP3DU(P,BDATE,EDATE,E) I %]"" Q 1_U_$P(%,U,2)_"^86359"
- ;
- S E=+$$CODEN^ICPTCOD(86361),%=$$TRANI^BGP3DU(P,BDATE,EDATE,E) I %]"" Q 1_U_$P(%,U,2)_"^86361 TRAN"
- S E=+$$CODEN^ICPTCOD(86360),%=$$TRANI^BGP3DU(P,BDATE,EDATE,E) I %]"" Q 1_U_$P(%,U,2)_"^86360 TRAN"
- S E=+$$CODEN^ICPTCOD(86359),%=$$TRANI^BGP3DU(P,BDATE,EDATE,E) I %]"" Q 1_U_$P(%,U,2)_"^86359 TRAN"
- ;
- 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 ""
- ;
- 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^BGP3D21(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 BGPMM
- S BGPMM=$$FMADD^XLFDT(EDATE,-(182))
- 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),".")'<BGPMM 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 ""
- FIRSTDX(P,BDATE,EDATE) ;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)
- S X=P_"^FIRST DX [BGP HIV/AIDS DXS" S E=$$START1^APCLDF(X,Y)
- I $D(BGPG(1)) D I G Q G
- .S G=""
- .I $P(BGPG(1),U,1)<BDATE Q
- .I $P(BGPG(1),U,1)>EDATE Q
- .S G=1_U_"First DX: "_$$DATE^BGP3UTL($P(BGPG(1),U,1))_U_$P(BGPG(1),U,1)
- 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,12)="D"
- .Q:$P(^AUPNPROB(X,0),U,8)<BDATE
- .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
- BGP3D8 ; IHS/CMI/LAB - measure C 03 Jul 2010 7:05 AM ; 21 Mar 2013 5:25 PM
- +1 ;;13.0;IHS CLINICAL REPORTING;**1**;NOV 20, 2012;Build 7
- +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 (BGPN9,BGPN10,BGPN11,BGPN12,BGPN13,BGPN14,BGPN15,BGPN16)=0
- +3 SET BGPNO2=0
- +4 SET BGPNO2=$$HIVDX(DFN,BGPEDATE)
- +5 SET BGPHIVG=""
- +6 SET BGPHIV=""
- +7 SET BGPDXB=$$HIVDX(DFN,$$FMADD^XLFDT(BGPBDATE,-1))
- +8 SET BGPHIVD=$$HIVDX(DFN,BGPEDATE,BGPBDATE)
- +9 IF BGPACTCL
- IF BGPSEX="F"
- IF $$PREG^BGP3D7(DFN,$$FMADD^XLFDT(BGPEDATE,-608),BGPEDATE,1,1)
- IF BGPNO2=""
- SET BGPD1=1
- +10 SET BGPFIRST=$$FIRSTDX(DFN,BGPBDATE,BGPEDATE)
- +11 SET BGPN1=0
- +12 SET BGPN2=0
- +13 IF BGPD1
- Begin DoDot:1
- +14 SET BGPHIVG=$$HIVTEST(DFN,$$FMADD^XLFDT(BGPEDATE,-608),BGPEDATE)
- +15 ;had a test
- IF $PIECE(BGPHIVG,U)=1
- SET BGPN1=1
- +16 ;had a Refusal
- IF $PIECE(BGPHIVG,U)=2
- SET BGPN2=1
- End DoDot:1
- +17 ;---------------- done with GPRA num/den, now for developmental
- +18 ;up 13-64 with no dx before report period
- IF BGPACTUP
- IF BGPAGEB>12
- IF BGPAGEB<65
- IF BGPDXB=""
- SET BGPD2=1
- +19 IF BGPACTUP
- IF BGPAGEB>12
- IF BGPAGEB<65
- IF BGPFIRST
- SET BGPD17=1
- +20 IF BGPACTUP
- IF BGPDXB=""
- SET BGPD3=1
- +21 IF BGPAGEB<13
- IF BGPDXB=""
- SET BGPD4=1
- +22 IF BGPAGEB>12
- IF BGPAGEB<15
- IF BGPDXB=""
- SET BGPD5=1
- +23 IF BGPAGEB>14
- IF BGPAGEB<20
- IF BGPDXB=""
- SET BGPD6=1
- +24 IF BGPAGEB>19
- IF BGPAGEB<25
- IF BGPDXB=""
- SET BGPD7=1
- +25 IF BGPAGEB>24
- IF BGPAGEB<30
- IF BGPDXB=""
- SET BGPD8=1
- +26 IF BGPAGEB>29
- IF BGPAGEB<35
- IF BGPDXB=""
- SET BGPD9=1
- +27 IF BGPAGEB>34
- IF BGPAGEB<40
- IF BGPDXB=""
- SET BGPD10=1
- +28 IF BGPAGEB>39
- IF BGPAGEB<45
- IF BGPDXB=""
- SET BGPD11=1
- +29 IF BGPAGEB>44
- IF BGPAGEB<50
- IF BGPDXB=""
- SET BGPD12=1
- +30 IF BGPAGEB>49
- IF BGPAGEB<55
- IF BGPDXB=""
- SET BGPD13=1
- +31 IF BGPAGEB>54
- IF BGPAGEB<60
- IF BGPDXB=""
- SET BGPD14=1
- +32 IF BGPAGEB>59
- IF BGPAGEB<65
- IF BGPDXB=""
- SET BGPD15=1
- +33 IF BGPAGEB>64
- IF BGPDXB=""
- SET BGPD16=1
- +34 ;get HIV test during the report period
- +35 SET BGPHIV=$$HIVTEST(DFN,BGPBDATE,$SELECT(BGPHIVD:BGPHIVD,1:BGPEDATE))
- +36 IF BGPD2
- IF $PIECE(BGPHIV,U)=1
- SET BGPN4=1
- +37 IF BGPD2
- IF $PIECE(BGPHIV,U)=2
- SET BGPN8=1
- +38 SET BGPHIVE=$$HIVTEST(DFN,$$DOB^AUPNPAT(DFN),$SELECT(BGPHIVD:BGPHIVD,1:BGPEDATE))
- +39 IF $PIECE(BGPHIVE,U,1)=1
- SET BGPN16=1
- +40 SET BGPHIV5=$$HIVTEST(DFN,$$FMADD^XLFDT(BGPEDATE,-(5*365)),$SELECT(BGPHIVD:BGPHIVD,1:BGPEDATE))
- +41 IF $PIECE(BGPHIV5,U,1)=1
- SET BGPN15=1
- +42 ;SET N3 TO TOTAL # OF SCREENS
- +43 SET BGPX=$$HIVTEST(DFN,BGPBDATE,$SELECT(BGPHIVD:BGPHIVD,1:BGPEDATE))
- +44 IF BGPD3
- SET BGPN3=$PIECE(BGPX,U,3)
- +45 SET BGPCD4=""
- +46 IF BGPFIRST
- Begin DoDot:1
- +47 SET D=$PIECE(BGPFIRST,U,3)
- SET BGPCD4=$$CD4RES^BGP3D84(DFN,$$FMADD^XLFDT(D,-90),$$FMADD^XLFDT(D,90),1)
- +48 IF 'BGPCD4
- QUIT
- +49 SET BGPN9=1
- +50 SET R=$PIECE(BGPCD4,U,3)
- +51 IF R=""
- SET BGPN14=1
- QUIT
- +52 IF $EXTRACT(R,1,3)="CPT"
- SET BGPN14=1
- QUIT
- +53 IF R>500
- SET BGPN13=1
- QUIT
- +54 IF R>350
- SET BGPN12=1
- QUIT
- +55 IF R<200
- SET BGPN10=1
- QUIT
- +56 SET BGPN11=1
- End DoDot:1
- +57 SET BGPN5=0
- +58 SET BGPN6=0
- +59 SET BGPN7=0
- +60 ;
- +61 ;FOR GPRA DEV RESULT ONLY
- SET BGPHIVR=$$HIVTEST1^BGP3D812(DFN,BGPBDATE,$SELECT(BGPHIVD:BGPHIVD,1:BGPEDATE))
- +62 SET BGPDAFT=""
- +63 IF BGPHIVR=""!($PIECE(BGPHIVR,U,1)=3)
- IF BGPN4
- SET BGPN7=1
- SET BGPDAFT="No Result"
- +64 ;"Positive" ;positive result
- IF $PIECE(BGPHIVR,U,1)=1
- SET BGPN5=1
- SET BGPDAFT=$PIECE(BGPHIVR,U,2)
- +65 ;"Negative"
- IF $PIECE(BGPHIVR,U,1)=2
- SET BGPN6=1
- SET BGPDAFT=$PIECE(BGPHIVR,U,2)
- V ;
- +1 SET BGPVALUE=""
- +2 SET BGPVAL=""
- +3 IF BGPD3
- SET BGPVALUE="UP"
- +4 IF BGPD2
- SET BGPVALUE="UP"
- +5 IF BGPD1
- SET BGPVALUE=BGPVALUE_",AC PREG"
- +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 %=""
- SET D=""
- SET R=""
- +13 ;$P($P(BGPHIV,U,4)," ",2,99)
- IF BGPHIV
- SET %=" 1yr "
- SET D=$PIECE($PIECE(BGPHIV,U,4)," ")_" "
- SET E=""
- +14 ;$P($P(BGPHIV5,U,4)," ",2,99)
- IF %=""
- IF BGPHIV5
- SET %=" 5yr "
- SET D=$PIECE($PIECE(BGPHIV5,U,4)," ")_" "
- SET E=""
- +15 ;$P($P(BGPHIVE,U,4)," ",2,99)
- IF %=""
- IF BGPHIVE
- SET D=$PIECE($PIECE(BGPHIVE,U,4)," ")_" "
- SET E=""
- +16 SET BGPVALUD="UP"
- IF BGPD2
- IF (BGPN1!(BGPN4)!(BGPN15)!(BGPN16))!(BGPN8)
- Begin DoDot:1
- +17 SET BGPVALUD="UP|||"_$SELECT(BGPD2!(D]""):"SCREEN (NO HIV DX): "_D_$SELECT(%]"":%,1:"")_E_"; ",1:"")_$SELECT(BGPN3:"SCREEN COUNT (NO PRIOR DX): "_$PIECE(BGPHIV,U,3)_" screens - "_$PIECE(BGPHIV,U,2),1:"")_$SELECT(BGPN8:" REF",1:"")
- End DoDot:1
- +18 IF BGPCD4
- IF BGPVALUD'["|||"
- SET BGPVALUD=BGPVALUD_"|||"
- IF $PIECE(BGPVALUD,"|||",2)]""
- SET BGPVALUD=BGPVALUD_";"
- SET BGPVALUD=BGPVALUD_"CD4="_$PIECE(BGPCD4,U,3)
- +19 IF BGPD3
- IF 'BGPD2
- IF BGPN3
- SET BGPVALUD="UP|||SCREEN COUNT MEASURE: "_BGPN3_" screens"
- +20 IF BGPDAFT]""
- SET BGPVALUD=BGPVALUD_"; RESULT (GPRA DEV): "_BGPDAFT
- +21 IF BGPVALUD=" ; "
- SET BGPVALUD=""
- +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,BGPHIVR,BGPHIVE,BGPHIV5
- +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 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^BGP3D811(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(BGPN3:"BOTH: ",1:"")_$SELECT(BGPCD4:"CD4: "_$$DATE^BGP3UTL($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^BGP3UTL($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 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^BGP3UTL($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 [BGP EXERCISE COUNSELING DXS;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE)
- SET E=$$START1^APCLDF(X,"BGPG(")
- +3 IF $DATA(BGPG(1))
- QUIT $PIECE(BGPG(1),U)_U_$PIECE(BGPG(1),U,2)_U_$$DATE^BGP3UTL($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"
- SET %=$PIECE(BGPALLED(X),U)_U_T
- QUIT
- +13 SET S=$PIECE(T,"-",1)
- +14 SET S=$$ICDDX^ICDCODE(S)
- +15 IF $PIECE(S,U,1)'="-1"
- IF $$ICD^ATXCHK($PIECE(S,U,1),$ORDER(^ATXAX("B","BGP EXERCISE COUNSELING DXS",0)),9)
- SET %=$PIECE(BGPALLED(X),U)_U_T
- QUIT
- End DoDot:1
- +16 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^BGP3UTL(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,12)="D"
- QUIT
- +11 IF $PIECE(^AUPNPROB(X,0),U,8)>EDATE
- QUIT
- +12 SET Y=$PIECE(^AUPNPROB(X,0),U)
- +13 IF '$$ICD^ATXCHK(Y,T,9)
- QUIT
- +14 SET G=$PIECE(^AUPNPROB(X,0),U,8)_U_$$VAL^XBDIQ1(9000011,X,.01)
- +15 QUIT
- End DoDot:1
- +16 QUIT G
- HIVDX(P,EDATE,BDATE) ;EP - any HIV dx ever or PL
- +1 NEW BGPG,G,Y,X,T,E
- +2 KILL BGPG
- +3 SET Y="BGPG("
- +4 SET BDATE=$GET(BDATE)
- +5 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,12)="D"
- QUIT
- +11 IF $PIECE(^AUPNPROB(X,0),U,8)>EDATE
- QUIT
- +12 SET Y=$PIECE(^AUPNPROB(X,0),U)
- +13 IF '$$ICD^ATXCHK(Y,T,9)
- QUIT
- +14 SET G=$PIECE(^AUPNPROB(X,0),U,8)
- +15 QUIT
- End DoDot:1
- +16 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 IF $PIECE(^AUPNVLAB(X,0),U,4)=""
- QUIT
- +12 SET V=$PIECE(^AUPNVLAB(X,0),U,3)
- +13 IF BGPLT
- IF $PIECE(^AUPNVLAB(X,0),U)
- IF $DATA(^ATXLAB(BGPLT,21,"B",$PIECE(^AUPNVLAB(X,0),U)))
- Begin DoDot:4
- +14 IF '$DATA(BGPA((9999999-D)))
- SET BGPC=BGPC+1
- SET BGPC(BGPC)=1_U_$$DATE^BGP3UTL((9999999-D))_" Lab"_U_$PIECE(^AUPNVLAB(X,0),U,4)_U_D
- SET BGPA((9999999-D))=""
- QUIT
- End DoDot:4
- QUIT
- +15 IF 'T
- QUIT
- +16 SET J=$PIECE($GET(^AUPNVLAB(X,11)),U,13)
- IF J=""
- QUIT
- +17 IF '$$LOINC^BGP3D21(J,T)
- QUIT
- +18 IF $DATA(BGPA((9999999-D)))
- QUIT
- +19 SET BGPC=BGPC+1
- SET BGPC(BGPC)=1_U_$$DATE^BGP3UTL((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))=""
- +20 QUIT
- End DoDot:3
- +21 QUIT
- End DoDot:2
- +22 ;
- +23 SET L=0
- FOR
- SET L=$ORDER(^AUPNVLAB("AE",P,D,L))
- IF L'=+L
- QUIT
- Begin DoDot:2
- +24 SET X=0
- FOR
- SET X=$ORDER(^AUPNVLAB("AE",P,D,L,X))
- IF X'=+X
- QUIT
- Begin DoDot:3
- +25 IF '$DATA(^AUPNVLAB(X,0))
- QUIT
- +26 SET V=$PIECE(^AUPNVLAB(X,0),U,3)
- +27 IF BGPLT
- IF $PIECE(^AUPNVLAB(X,0),U)
- IF $DATA(^ATXLAB(BGPLT,21,"B",$PIECE(^AUPNVLAB(X,0),U)))
- Begin DoDot:4
- +28 IF '$DATA(BGPA((9999999-D)))
- SET BGPC=BGPC+1
- SET BGPC(BGPC)=1_U_$$DATE^BGP3UTL((9999999-D))_" Lab"_U_$PIECE(^AUPNVLAB(X,0),U,4)_U_D
- SET BGPA((9999999-D))=""
- QUIT
- End DoDot:4
- QUIT
- +29 IF 'T
- QUIT
- +30 SET J=$PIECE($GET(^AUPNVLAB(X,11)),U,13)
- IF J=""
- QUIT
- +31 IF '$$LOINC^BGP3D21(J,T)
- QUIT
- +32 ;
- IF $DATA(BGPA((9999999-D)))
- QUIT
- +33 SET BGPC=BGPC+1
- SET BGPC(BGPC)=1_U_$$DATE^BGP3UTL((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))=""
- +34 QUIT
- End DoDot:3
- +35 QUIT
- End DoDot:2
- End DoDot:1
- +36 SET T=$ORDER(^ATXAX("B","BGP CPT HIV TESTS",0))
- +37 IF T
- Begin DoDot:1
- +38 ;
- +39 SET ED=(9999999-EDATE)
- SET BD=9999999-BDATE
- SET G=0
- +40 FOR
- SET ED=$ORDER(^AUPNVSIT("AA",P,ED))
- IF ED=""!($PIECE(ED,".")>BD)
- QUIT
- Begin DoDot:2
- +41 SET V=0
- FOR
- SET V=$ORDER(^AUPNVSIT("AA",P,ED,V))
- IF V'=+V
- QUIT
- Begin DoDot:3
- +42 IF '$DATA(^AUPNVSIT(V,0))
- QUIT
- +43 IF '$DATA(^AUPNVCPT("AD",V))
- QUIT
- +44 SET X=0
- FOR
- SET X=$ORDER(^AUPNVCPT("AD",V,X))
- IF X'=+X
- QUIT
- Begin DoDot:4
- +45 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^BGP3UTL((9999999-$PIECE(ED,".")))_" CPT "_$$VAL^XBDIQ1(9000010.18,X,.01)_U_U_$PIECE(ED,".")
- SET BGPA((9999999-$PIECE(ED,".")))=""
- +46 QUIT
- End DoDot:4
- +47 QUIT
- End DoDot:3
- +48 QUIT
- End DoDot:2
- End DoDot:1
- +49 IF BGPC>0
- Begin DoDot:1
- +50 SET X=""
- +51 SET T=0
- FOR
- SET T=$ORDER(BGPC(T))
- IF T'=+T
- QUIT
- SET X=X_$SELECT(X]"":", ",1:"")_$PIECE(BGPC(T),U,2)
- +52 ;
- +53 KILL BGPA
- +54 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)
- +55 SET T=$ORDER(BGPA(0))
- +56 IF T
- SET Y=$PIECE(BGPA(T),U,2)_" result="_$PIECE(BGPA(T),U,3)_U_$PIECE(BGPA(T),U,3)
- QUIT
- +57 SET T=0
- FOR
- SET T=$ORDER(BGPC(T))
- IF T'=+T
- QUIT
- SET BGPA($PIECE(BGPC(T),U,4))=BGPC(T)
- +58 SET T=$ORDER(BGPA(0))
- +59 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
- +60 ;
- +61 SET BGPT=$ORDER(^ATXLAB("B","BGP HIV TEST TAX",0))
- +62 IF 'BGPT
- QUIT ""
- +63 SET (G,BGPT1)=0
- SET G=""
- FOR
- SET BGPT1=$ORDER(^ATXLAB(BGPT,21,"B",BGPT1))
- IF BGPT1=""!(G)
- QUIT
- Begin DoDot:1
- +64 SET T=$$REFUSAL^BGP3UTL1(P,60,BGPT1,BDATE,EDATE)
- IF $PIECE(T,U)=1
- SET G=2_U_$$DATE^BGP3UTL($PIECE(T,U,2))_" Refused Lab"_U_U_$$DATE^BGP3UTL($PIECE(T,U,2))_" Refused Lab"
- End DoDot:1
- +65 QUIT G
- 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^BGP3DU(P,BDATE,EDATE,E)
- IF %]""
- QUIT 1_U_$PIECE(%,U,2)_"^86361"
- +5 SET E=+$$CODEN^ICPTCOD(86360)
- SET %=$$CPTI^BGP3DU(P,BDATE,EDATE,E)
- IF %]""
- QUIT 1_U_$PIECE(%,U,2)_"^86360"
- +6 SET E=+$$CODEN^ICPTCOD(86359)
- SET %=$$CPTI^BGP3DU(P,BDATE,EDATE,E)
- IF %]""
- QUIT 1_U_$PIECE(%,U,2)_"^86359"
- +7 ;
- +8 SET E=+$$CODEN^ICPTCOD(86361)
- SET %=$$TRANI^BGP3DU(P,BDATE,EDATE,E)
- IF %]""
- QUIT 1_U_$PIECE(%,U,2)_"^86361 TRAN"
- +9 SET E=+$$CODEN^ICPTCOD(86360)
- SET %=$$TRANI^BGP3DU(P,BDATE,EDATE,E)
- IF %]""
- QUIT 1_U_$PIECE(%,U,2)_"^86360 TRAN"
- +10 SET E=+$$CODEN^ICPTCOD(86359)
- SET %=$$TRANI^BGP3DU(P,BDATE,EDATE,E)
- IF %]""
- QUIT 1_U_$PIECE(%,U,2)_"^86359 TRAN"
- +11 ;
- +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 ;
- +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^BGP3D21(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
- V2HIV(P,BDATE,EDATE) ;
- +1 IF '$GET(P)
- QUIT ""
- +2 IF '$DATA(^AUPNVSIT("AC",P))
- QUIT ""
+3 NEW BGPMM
+4 SET BGPMM=$$FMADD^XLFDT(EDATE,-(182))
+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),".")'<BGPMM
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 ""
FIRSTDX(P,BDATE,EDATE) ;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 IF BDATE=""
SET BDATE=$PIECE(^DPT(P,0),U,3)
+6 SET X=P_"^FIRST DX [BGP HIV/AIDS DXS"
SET E=$$START1^APCLDF(X,Y)
+7 IF $DATA(BGPG(1))
Begin DoDot:1
+8 SET G=""
+9 IF $PIECE(BGPG(1),U,1)<BDATE
QUIT
+10 IF $PIECE(BGPG(1),U,1)>EDATE
QUIT
+11 SET G=1_U_"First DX: "_$$DATE^BGP3UTL($PIECE(BGPG(1),U,1))_U_$PIECE(BGPG(1),U,1)
End DoDot:1
IF G
QUIT G
+12 SET T=$ORDER(^ATXAX("B","BGP HIV/AIDS DXS",0))
+13 SET X=0
SET G=""
FOR
SET X=$ORDER(^AUPNPROB("AC",P,X))
IF X'=+X!(G]"")
QUIT
Begin DoDot:1
+14 IF $PIECE(^AUPNPROB(X,0),U,12)="D"
QUIT
+15 IF $PIECE(^AUPNPROB(X,0),U,8)<BDATE
QUIT
+16 IF $PIECE(^AUPNPROB(X,0),U,8)>EDATE
QUIT
+17 SET Y=$PIECE(^AUPNPROB(X,0),U)
+18 IF '$$ICD^ATXCHK(Y,T,9)
QUIT
+19 SET G=$PIECE(^AUPNPROB(X,0),U,8)_U_$$VAL^XBDIQ1(9000011,X,.01)
+20 QUIT
End DoDot:1
+21 QUIT G