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

BGP3D8.m

Go to the documentation of this file.
  1. 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
  1. ;
  1. IE2 ;EP
  1. 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
  1. S (BGPN9,BGPN10,BGPN11,BGPN12,BGPN13,BGPN14,BGPN15,BGPN16)=0
  1. S BGPNO2=0
  1. S BGPNO2=$$HIVDX(DFN,BGPEDATE)
  1. S BGPHIVG=""
  1. S BGPHIV=""
  1. S BGPDXB=$$HIVDX(DFN,$$FMADD^XLFDT(BGPBDATE,-1))
  1. S BGPHIVD=$$HIVDX(DFN,BGPEDATE,BGPBDATE)
  1. I BGPACTCL,BGPSEX="F",$$PREG^BGP3D7(DFN,$$FMADD^XLFDT(BGPEDATE,-608),BGPEDATE,1,1),BGPNO2="" S BGPD1=1
  1. S BGPFIRST=$$FIRSTDX(DFN,BGPBDATE,BGPEDATE)
  1. S BGPN1=0
  1. S BGPN2=0
  1. I BGPD1 D
  1. .S BGPHIVG=$$HIVTEST(DFN,$$FMADD^XLFDT(BGPEDATE,-608),BGPEDATE)
  1. .I $P(BGPHIVG,U)=1 S BGPN1=1 ;had a test
  1. .I $P(BGPHIVG,U)=2 S BGPN2=1 ;had a Refusal
  1. ;---------------- done with GPRA num/den, now for developmental
  1. I BGPACTUP,BGPAGEB>12,BGPAGEB<65,BGPDXB="" S BGPD2=1 ;up 13-64 with no dx before report period
  1. I BGPACTUP,BGPAGEB>12,BGPAGEB<65,BGPFIRST S BGPD17=1
  1. I BGPACTUP,BGPDXB="" S BGPD3=1
  1. I BGPAGEB<13,BGPDXB="" S BGPD4=1
  1. I BGPAGEB>12,BGPAGEB<15,BGPDXB="" S BGPD5=1
  1. I BGPAGEB>14,BGPAGEB<20,BGPDXB="" S BGPD6=1
  1. I BGPAGEB>19,BGPAGEB<25,BGPDXB="" S BGPD7=1
  1. I BGPAGEB>24,BGPAGEB<30,BGPDXB="" S BGPD8=1
  1. I BGPAGEB>29,BGPAGEB<35,BGPDXB="" S BGPD9=1
  1. I BGPAGEB>34,BGPAGEB<40,BGPDXB="" S BGPD10=1
  1. I BGPAGEB>39,BGPAGEB<45,BGPDXB="" S BGPD11=1
  1. I BGPAGEB>44,BGPAGEB<50,BGPDXB="" S BGPD12=1
  1. I BGPAGEB>49,BGPAGEB<55,BGPDXB="" S BGPD13=1
  1. I BGPAGEB>54,BGPAGEB<60,BGPDXB="" S BGPD14=1
  1. I BGPAGEB>59,BGPAGEB<65,BGPDXB="" S BGPD15=1
  1. I BGPAGEB>64,BGPDXB="" S BGPD16=1
  1. ;get HIV test during the report period
  1. S BGPHIV=$$HIVTEST(DFN,BGPBDATE,$S(BGPHIVD:BGPHIVD,1:BGPEDATE))
  1. I BGPD2,$P(BGPHIV,U)=1 S BGPN4=1
  1. I BGPD2,$P(BGPHIV,U)=2 S BGPN8=1
  1. S BGPHIVE=$$HIVTEST(DFN,$$DOB^AUPNPAT(DFN),$S(BGPHIVD:BGPHIVD,1:BGPEDATE))
  1. I $P(BGPHIVE,U,1)=1 S BGPN16=1
  1. S BGPHIV5=$$HIVTEST(DFN,$$FMADD^XLFDT(BGPEDATE,-(5*365)),$S(BGPHIVD:BGPHIVD,1:BGPEDATE))
  1. I $P(BGPHIV5,U,1)=1 S BGPN15=1
  1. ;SET N3 TO TOTAL # OF SCREENS
  1. S BGPX=$$HIVTEST(DFN,BGPBDATE,$S(BGPHIVD:BGPHIVD,1:BGPEDATE))
  1. I BGPD3 S BGPN3=$P(BGPX,U,3)
  1. S BGPCD4=""
  1. I BGPFIRST D
  1. .S D=$P(BGPFIRST,U,3) S BGPCD4=$$CD4RES^BGP3D84(DFN,$$FMADD^XLFDT(D,-90),$$FMADD^XLFDT(D,90),1)
  1. .Q:'BGPCD4
  1. .S BGPN9=1
  1. .S R=$P(BGPCD4,U,3)
  1. .I R="" S BGPN14=1 Q
  1. .I $E(R,1,3)="CPT" S BGPN14=1 Q
  1. .I R>500 S BGPN13=1 Q
  1. .I R>350 S BGPN12=1 Q
  1. .I R<200 S BGPN10=1 Q
  1. .S BGPN11=1
  1. S BGPN5=0
  1. S BGPN6=0
  1. S BGPN7=0
  1. ;
  1. S BGPHIVR=$$HIVTEST1^BGP3D812(DFN,BGPBDATE,$S(BGPHIVD:BGPHIVD,1:BGPEDATE)) ;FOR GPRA DEV RESULT ONLY
  1. S BGPDAFT=""
  1. I BGPHIVR=""!($P(BGPHIVR,U,1)=3),BGPN4 S BGPN7=1,BGPDAFT="No Result"
  1. I $P(BGPHIVR,U,1)=1 S BGPN5=1,BGPDAFT=$P(BGPHIVR,U,2) ;"Positive" ;positive result
  1. I $P(BGPHIVR,U,1)=2 S BGPN6=1,BGPDAFT=$P(BGPHIVR,U,2) ;"Negative"
  1. V ;
  1. S BGPVALUE=""
  1. S BGPVAL=""
  1. I BGPD3 S BGPVALUE="UP"
  1. I BGPD2 S BGPVALUE="UP"
  1. I BGPD1 S BGPVALUE=BGPVALUE_",AC PREG"
  1. I BGPD1!(BGPD2) D
  1. .I BGPN1,'BGPN4 S BGPVAL=$P(BGPHIVG,U,2) Q
  1. .I BGPN1!(BGPN4) S BGPVAL=$P(BGPHIV,U,2)
  1. .I BGPN2!(BGPN8) S BGPVAL=$S(BGPHIVG]"":$P(BGPHIVG,U,4),1:$P(BGPHIV,U,4))
  1. I BGPD3,BGPN3 S BGPVAL=BGPVAL_$S(BGPVAL]"":"",1:$P(BGPX,U,2))_"; Screen Count: "_BGPN3
  1. S BGPVALUE=BGPVALUE_"|||"_BGPVAL
  1. S %="",D="",R=""
  1. I BGPHIV S %=" 1yr ",D=$P($P(BGPHIV,U,4)," ")_" ",E="" ;$P($P(BGPHIV,U,4)," ",2,99)
  1. I %="",BGPHIV5 S %=" 5yr ",D=$P($P(BGPHIV5,U,4)," ")_" ",E="" ;$P($P(BGPHIV5,U,4)," ",2,99)
  1. I %="",BGPHIVE S D=$P($P(BGPHIVE,U,4)," ")_" ",E="" ;$P($P(BGPHIVE,U,4)," ",2,99)
  1. S BGPVALUD="UP" I BGPD2,(BGPN1!(BGPN4)!(BGPN15)!(BGPN16))!(BGPN8) D
  1. .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:"")
  1. I BGPCD4 S:BGPVALUD'["|||" BGPVALUD=BGPVALUD_"|||" S:$P(BGPVALUD,"|||",2)]"" BGPVALUD=BGPVALUD_";" S BGPVALUD=BGPVALUD_"CD4="_$P(BGPCD4,U,3)
  1. I BGPD3,'BGPD2,BGPN3 S BGPVALUD="UP|||SCREEN COUNT MEASURE: "_BGPN3_" screens"
  1. I BGPDAFT]"" S BGPVALUD=BGPVALUD_"; RESULT (GPRA DEV): "_BGPDAFT
  1. I BGPVALUD=" ; " S BGPVALUD=""
  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,BGPHIVR,BGPHIVE,BGPHIV5
  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
  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^BGP3D811(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. S BGPVALUE="UP|||"_$S(BGPN3:"BOTH: ",1:"")_$S(BGPCD4:"CD4: "_$$DATE^BGP3UTL($P(BGPCD4,U,2))_" "_$P(BGPCD4,U,3),1:"")
  1. I $P(BGPVALUE,"|||",2)]"" S BGPVALUE=BGPVALUE_"; "
  1. S BGPVALUE=BGPVALUE_$S(BGPPCR:"Viral Load: "_$$DATE^BGP3UTL($P(BGPPCR,U,2))_" "_$P(BGPPCR,U,3),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
  1. S BGPVALUE=""
  1. I BGPACTUP S BGPD1=1
  1. I BGPACTCL S BGPD2=1
  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")
  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^BGP3UTL($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 [BGP EXERCISE COUNSELING DXS;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE) S E=$$START1^APCLDF(X,"BGPG(")
  1. I $D(BGPG(1)) Q $P(BGPG(1),U)_U_$P(BGPG(1),U,2)_U_$$DATE^BGP3UTL($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" S %=$P(BGPALLED(X),U)_U_T Q
  1. .S S=$P(T,"-",1)
  1. .S S=$$ICDDX^ICDCODE(S)
  1. .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
  1. Q %
  1. FIRSTHF(P,BDATE,EDATE,CAT) ;EP
  1. NEW C,H,D,O
  1. S C=$O(^AUTTHF("B",CAT,0))
  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
  1. ..Q:(9999999-D)<BDATE
  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^BGP3UTL(D)_U_$$VAL^XBDIQ1(9000010.23,O(D),.01)
  1. ;
  1. HIVDX1(P,EDATE,BDATE) ;EP - any HIV dx
  1. NEW BGPG,G,Y,X,T,E
  1. K BGPG
  1. S Y="BGPG("
  1. S BDATE=$G(BDATE)
  1. I BDATE="" 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)_U_$P(BGPG(1),U,2)
  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,12)="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)_U_$$VAL^XBDIQ1(9000011,X,.01)
  1. .Q
  1. Q G
  1. HIVDX(P,EDATE,BDATE) ;EP - any HIV dx ever or PL
  1. NEW BGPG,G,Y,X,T,E
  1. K BGPG
  1. S Y="BGPG("
  1. S BDATE=$G(BDATE)
  1. I BDATE="" S BDATE=$P(^DPT(P,0),U,3)
  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,12)="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 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. ...Q:$P(^AUPNVLAB(X,0),U,4)=""
  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 Q
  1. ....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
  1. ...Q:'T
  1. ...S J=$P($G(^AUPNVLAB(X,11)),U,13) Q:J=""
  1. ...Q:'$$LOINC^BGP3D21(J,T)
  1. ...Q:$D(BGPA((9999999-D)))
  1. ...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))=""
  1. ...Q
  1. ..Q
  1. .;
  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 Q
  1. ....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
  1. ...Q:'T
  1. ...S J=$P($G(^AUPNVLAB(X,11)),U,13) Q:J=""
  1. ...Q:'$$LOINC^BGP3D21(J,T)
  1. ...Q:$D(BGPA((9999999-D))) ;
  1. ...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))=""
  1. ...Q
  1. ..Q
  1. S T=$O(^ATXAX("B","BGP CPT HIV TESTS",0))
  1. I T D
  1. .;
  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^BGP3UTL((9999999-$P(ED,".")))_" CPT "_$$VAL^XBDIQ1(9000010.18,X,.01)_U_U_$P(ED,"."),BGPA((9999999-$P(ED,".")))=""
  1. ....Q
  1. ...Q
  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)=Y,$P(X,U,6)=(9999999-T) Q X
  1. .S X=""
  1. .S T=0 F S T=$O(BGPC(T)) Q:T'=+T S X=X_$S(X]"":", ",1:"")_$P(BGPC(T),U,2)
  1. .;
  1. .K BGPA
  1. .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)
  1. .S T=$O(BGPA(0))
  1. .I T S Y=$P(BGPA(T),U,2)_" result="_$P(BGPA(T),U,3)_U_$P(BGPA(T),U,3) Q
  1. .S T=0 F S T=$O(BGPC(T)) Q:T'=+T S BGPA($P(BGPC(T),U,4))=BGPC(T)
  1. .S T=$O(BGPA(0))
  1. .S Y=$P(BGPA(T),U,2)_" No Result"
  1. ;
  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^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"
  1. Q G
  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_U_$P(BGPG(1),U,1)_U_$P(BGPG(1),U,2)
  1. S E=+$$CODEN^ICPTCOD(86361),%=$$CPTI^BGP3DU(P,BDATE,EDATE,E) I %]"" Q 1_U_$P(%,U,2)_"^86361"
  1. S E=+$$CODEN^ICPTCOD(86360),%=$$CPTI^BGP3DU(P,BDATE,EDATE,E) I %]"" Q 1_U_$P(%,U,2)_"^86360"
  1. S E=+$$CODEN^ICPTCOD(86359),%=$$CPTI^BGP3DU(P,BDATE,EDATE,E) I %]"" Q 1_U_$P(%,U,2)_"^86359"
  1. ;
  1. S E=+$$CODEN^ICPTCOD(86361),%=$$TRANI^BGP3DU(P,BDATE,EDATE,E) I %]"" Q 1_U_$P(%,U,2)_"^86361 TRAN"
  1. S E=+$$CODEN^ICPTCOD(86360),%=$$TRANI^BGP3DU(P,BDATE,EDATE,E) I %]"" Q 1_U_$P(%,U,2)_"^86360 TRAN"
  1. S E=+$$CODEN^ICPTCOD(86359),%=$$TRANI^BGP3DU(P,BDATE,EDATE,E) I %]"" Q 1_U_$P(%,U,2)_"^86359 TRAN"
  1. ;
  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. ;
  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^BGP3D21(J,T) S G=1_U_$$VD^APCLV($P(^AUPNVLAB(I,0),U,3))_U_$$VAL^XBDIQ1(9000010.09,I,.01)
  1. Q G
  1. V2HIV(P,BDATE,EDATE) ;
  1. I '$G(P) Q ""
  1. I '$D(^AUPNVSIT("AC",P)) Q ""
  1. NEW BGPMM
  1. S BGPMM=$$FMADD^XLFDT(EDATE,-(182))
  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)
  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),".")'<BGPMM 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 ""
  1. FIRSTDX(P,BDATE,EDATE) ;EP - any HIV dx
  1. NEW BGPG,G,Y,X,T,E
  1. K BGPG
  1. S Y="BGPG("
  1. S BDATE=$G(BDATE)
  1. I BDATE="" S BDATE=$P(^DPT(P,0),U,3)
  1. S X=P_"^FIRST DX [BGP HIV/AIDS DXS" S E=$$START1^APCLDF(X,Y)
  1. I $D(BGPG(1)) D I G Q G
  1. .S G=""
  1. .I $P(BGPG(1),U,1)<BDATE Q
  1. .I $P(BGPG(1),U,1)>EDATE Q
  1. .S G=1_U_"First DX: "_$$DATE^BGP3UTL($P(BGPG(1),U,1))_U_$P(BGPG(1),U,1)
  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,12)="D"
  1. .Q:$P(^AUPNPROB(X,0),U,8)<BDATE
  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)_U_$$VAL^XBDIQ1(9000011,X,.01)
  1. .Q
  1. Q G