BGP7D24A ; IHS/CMI/LAB - STI MEASURE 18 Oct 2009 8:37 AM 03 Jul 2010 7:56 AM ;
;;17.1;IHS CLINICAL REPORTING;;MAY 10, 2017;Build 29
;
KEYSTI(P,BDATE,EDATE) ;EP - return key sti's
NEW X,Y,Z,A,B,C,D,R,N,BD,ED,BGPD,BGPRES,BGPCNTI,BGPCNTN,BGPCNTH,BGPCNTR,BGPRESD,BGPRESN,BGPY
S BD=$$FMADD^XLFDT(BDATE,-60)
S ED=$$FMADD^XLFDT(BDATE,300)
;S ED=EDATE ;LORI
S (BGPRESD,BGPRESN,BGPCNTI,BGPCNTN,BGPCNTH,BGPCNTR,BGPHIV)="" ;RETURN VALUE
HIV ;get first HIV dx, if in time window count as an incident, if not don't
S BGPHIV=$$HIVDX(P,$$DOB^AUPNPAT(P),ED)
I BGPHIV,$P(BGPHIV,U,1)'<BD S BGPCNTI=BGPCNTI+1,BGPCNTI($P(BGPHIV,U,1),BGPCNTI)=BGPHIV,$P(BGPCNTI($P(BGPHIV,U),BGPCNTI),U,9)="HIV" ;,BGPRES=BGPRES_$S(BGPRES="":"",1:", ")_$$DATE^BGP7UTL($P($P(^AUPNVSIT($P(BGPG(1),U,5),0),U),"."))_" (HIV)"
CHL ;chlamydia
NEW BGPG
S BGPD=BD
S C=0,R=""
F D Q:'$D(BGPG(1))
.K BGPG
.S X=P_"^FIRST DX [BKM CHLAMYDIA DXS;DURING "_$$FMTE^XLFDT(BGPD)_"-"_$$FMTE^XLFDT(ED) S E=$$START1^APCLDF(X,"BGPG(")
.Q:'$D(BGPG(1))
.S BGPD=$$FMADD^XLFDT($P(BGPG(1),U,1),61)
.;S BGPRES=BGPRES_$S(BGPRES="":"",1:", ")_$$DATE^BGP7UTL($P($P(^AUPNVSIT($P(BGPG(1),U,5),0),U),"."))_" (CHL)"
.S BGPCNTI=BGPCNTI+1
.S BGPCNTI($P(BGPG(1),U,1),BGPCNTI)=BGPG(1),$P(BGPCNTI($P(BGPG(1),U),BGPCNTI),U,9)="CHL"
.D NEED
GON ;
K BGPG
S BGPD=BD
F D Q:'$D(BGPG(1))
.K BGPG
.S X=P_"^FIRST DX [BKM GONORRHEA DXS;DURING "_$$FMTE^XLFDT(BGPD)_"-"_$$FMTE^XLFDT(ED) S E=$$START1^APCLDF(X,"BGPG(")
.Q:'$D(BGPG(1))
.S BGPD=$$FMADD^XLFDT($P(BGPG(1),U,1),61)
.;S BGPRES=BGPRES_$S(BGPRES="":"",1:", ")_$$DATE^BGP7UTL($P($P(^AUPNVSIT($P(BGPG(1),U,5),0),U),"."))_" (GON)"
.S BGPCNTI=BGPCNTI+1
.S BGPCNTI($P(BGPG(1),U,1),BGPCNTI)=BGPG(1),$P(BGPCNTI($P(BGPG(1),U),BGPCNTI),U,9)="GON"
.D NEED
SYH ;
K BGPG
S BGPD=BD
F D Q:'$D(BGPG(1))
.K BGPG
.S X=P_"^FIRST DX [BKM SYPHILIS DXS;DURING "_$$FMTE^XLFDT(BGPD)_"-"_$$FMTE^XLFDT(ED) S E=$$START1^APCLDF(X,"BGPG(")
.Q:'$D(BGPG(1))
.S BGPD=$$FMADD^XLFDT($P(BGPG(1),U,1),61)
.;S BGPRES=BGPRES_$S(BGPRES="":"",1:", ")_$$DATE^BGP7UTL($P($P(^AUPNVSIT($P(BGPG(1),U,5),0),U),"."))_" (SYH)"
.S BGPCNTI=BGPCNTI+1
.S BGPCNTI($P(BGPG(1),U,1),BGPCNTI)=BGPG(1),$P(BGPCNTI($P(BGPG(1),U),BGPCNTI),U,9)="SYH"
.D NEED
;NOW COUNT ALL SCREENINGS DONE FOR ALL INCIDENCES
S BGPD=0 F S BGPD=$O(BGPCNTI(BGPD)) Q:BGPD'=+BGPD D
.S BGPY=0 F S BGPY=$O(BGPCNTI(BGPD,BGPY)) Q:BGPY'=+BGPY D
..Q:'$P(BGPCNTI(BGPD,BGPY),U,10) ;DOESN'T NEED A SCREEN
..S X=$$HIVTEST^BGP7D8(P,$$FMADD^XLFDT(BGPD,-30),$$FMADD^XLFDT(BGPD,60))
..I X S BGPCNTH=BGPCNTH+1,$P(BGPCNTI(BGPD,BGPY),U,11)=$P(X,U,2) Q
..S X=$$REFHIV(P,BDATE,EDATE)
..I X S BGPCNTR=BGPCNTR+1,$P(BGPCNTI(BGPD,BGPY),U,20)=$P(X,U,2)
S D=0
I 'BGPCNTI Q ""
F S D=$O(BGPCNTI(D)) Q:D'=+D D
.S Y=0 F S Y=$O(BGPCNTI(D,Y)) Q:Y'=+Y D
..S R=Y_") "_$$DATE^BGP7UTL($P(BGPCNTI(D,Y),U,1))_" "_$P(BGPCNTI(D,Y),U,9)_" "_$P(BGPCNTI(D,Y),U,2)
..S BGPRESD=BGPRESD_$S(BGPRESD]"":" ",1:"")_R
..I '$P(BGPCNTI(D,Y),U,10),$P(BGPCNTI(D,Y),U,9)'="HIV" S N=Y_") HIV-Contraind "_$$DATE^BGP7UTL($P(BGPHIV,U,1))_" Prior DX "_$P(BGPHIV,U,2) G R
..I '$P(BGPCNTI(D,Y),U,10),$P(BGPCNTI(D,Y),U,9)="HIV" S N=Y_") HIV-N/A" G R
..I $P(BGPCNTI(D,Y),U,10) S N=$P(BGPCNTI(D,Y),U,11) D
...I N]"" S N=Y_") HIV-Y "_N Q
...S N=$P(BGPCNTI(D,Y),U,20) I N]"" S N=Y_") HIV-"_N Q
...S N=Y_") HIV-N"
R ..S BGPRESN=BGPRESN_$S(BGPRESN]"":" ",1:"")_N
;ZW BGPCNTI
Q BGPCNTI_U_BGPCNTN_U_BGPCNTH_U_BGPCNTR_U_BGPRESD_U_BGPRESN
NEED ;
I BGPHIV,$P(BGPHIV,U,1)'>$P(BGPG(1),U,1) Q ;DOESN'T NEED HIV SCREEN AS ALREADY HAS HIV
S BGPCNTN=BGPCNTN+1 ;needs a screen
S $P(BGPCNTI($P(BGPG(1),U),BGPCNTI),U,10)=1 ;needs a screen
Q
REFHIV(P,BDATE,EDATE) ;
NEW T,BGPT,G,BGPT1
S T=""
S T=$$CPTREFT^BGP7UTL1(P,BDATE,EDATE,$O(^ATXAX("B","BGP CPT HIV TESTS",0)),"R")
I T S T=1_U_"Refused CPT "_$P(T,U,4)_U_$$DATE^BGP7UTL($P(T,U,2)) Q T
S BGPT=$O(^ATXLAB("B","BGP HIV TEST TAX",0))
I BGPT D I $P(G,U) Q 1_U_"Refused Lab "_U_$$DATE^BGP7UTL($P(G,U,2))
.S (G,BGPT1)=0 F S BGPT1=$O(^ATXLAB(BGPT,21,"B",BGPT1)) Q:BGPT1=""!($P(G,U)) D
..S G=$$REFUSAL^BGP7UTL1(P,60,BGPT1,BDATE,EDATE)
Q ""
HIVDX(P,BDATE,EDATE) ;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_"^FIRST 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_"POV "_$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,12)="I"
.Q:$P(^AUPNPROB(X,0),U,8)>EDATE
.I $P(^AUPNPROB(X,0),U,13)]"",$P(^AUPNPROB(X,0),U,13)>EDATE Q ;doo
.S Y=$P(^AUPNPROB(X,0),U)
.Q:'$$ICD^BGP7UTL2(Y,T,9)
.S G=$P(^AUPNPROB(X,0),U,8) Q
.S S=$$VAL^XBDIQ1(9000011,X,80001)
.I S]"",$D(^XTMP("BGPSNOMEDSUBSET",$J,"PXRM HIV",S)) S G=$P(^AUPNPROB(X,0),U,8) Q
.Q
Q G
BGP7D24A ; IHS/CMI/LAB - STI MEASURE 18 Oct 2009 8:37 AM 03 Jul 2010 7:56 AM ;
+1 ;;17.1;IHS CLINICAL REPORTING;;MAY 10, 2017;Build 29
+2 ;
KEYSTI(P,BDATE,EDATE) ;EP - return key sti's
+1 NEW X,Y,Z,A,B,C,D,R,N,BD,ED,BGPD,BGPRES,BGPCNTI,BGPCNTN,BGPCNTH,BGPCNTR,BGPRESD,BGPRESN,BGPY
+2 SET BD=$$FMADD^XLFDT(BDATE,-60)
+3 SET ED=$$FMADD^XLFDT(BDATE,300)
+4 ;S ED=EDATE ;LORI
+5 ;RETURN VALUE
SET (BGPRESD,BGPRESN,BGPCNTI,BGPCNTN,BGPCNTH,BGPCNTR,BGPHIV)=""
HIV ;get first HIV dx, if in time window count as an incident, if not don't
+1 SET BGPHIV=$$HIVDX(P,$$DOB^AUPNPAT(P),ED)
+2 ;,BGPRES=BGPRES_$S(BGPRES="":"",1:", ")_$$DATE^BGP7UTL($P($P(^AUPNVSIT($P(BGPG(1),U,5),0),U),"."))_" (HIV)"
IF BGPHIV
IF $PIECE(BGPHIV,U,1)'<BD
SET BGPCNTI=BGPCNTI+1
SET BGPCNTI($PIECE(BGPHIV,U,1),BGPCNTI)=BGPHIV
SET $PIECE(BGPCNTI($PIECE(BGPHIV,U),BGPCNTI),U,9)="HIV"
CHL ;chlamydia
+1 NEW BGPG
+2 SET BGPD=BD
+3 SET C=0
SET R=""
+4 FOR
Begin DoDot:1
+5 KILL BGPG
+6 SET X=P_"^FIRST DX [BKM CHLAMYDIA DXS;DURING "_$$FMTE^XLFDT(BGPD)_"-"_$$FMTE^XLFDT(ED)
SET E=$$START1^APCLDF(X,"BGPG(")
+7 IF '$DATA(BGPG(1))
QUIT
+8 SET BGPD=$$FMADD^XLFDT($PIECE(BGPG(1),U,1),61)
+9 ;S BGPRES=BGPRES_$S(BGPRES="":"",1:", ")_$$DATE^BGP7UTL($P($P(^AUPNVSIT($P(BGPG(1),U,5),0),U),"."))_" (CHL)"
+10 SET BGPCNTI=BGPCNTI+1
+11 SET BGPCNTI($PIECE(BGPG(1),U,1),BGPCNTI)=BGPG(1)
SET $PIECE(BGPCNTI($PIECE(BGPG(1),U),BGPCNTI),U,9)="CHL"
+12 DO NEED
End DoDot:1
IF '$DATA(BGPG(1))
QUIT
GON ;
+1 KILL BGPG
+2 SET BGPD=BD
+3 FOR
Begin DoDot:1
+4 KILL BGPG
+5 SET X=P_"^FIRST DX [BKM GONORRHEA DXS;DURING "_$$FMTE^XLFDT(BGPD)_"-"_$$FMTE^XLFDT(ED)
SET E=$$START1^APCLDF(X,"BGPG(")
+6 IF '$DATA(BGPG(1))
QUIT
+7 SET BGPD=$$FMADD^XLFDT($PIECE(BGPG(1),U,1),61)
+8 ;S BGPRES=BGPRES_$S(BGPRES="":"",1:", ")_$$DATE^BGP7UTL($P($P(^AUPNVSIT($P(BGPG(1),U,5),0),U),"."))_" (GON)"
+9 SET BGPCNTI=BGPCNTI+1
+10 SET BGPCNTI($PIECE(BGPG(1),U,1),BGPCNTI)=BGPG(1)
SET $PIECE(BGPCNTI($PIECE(BGPG(1),U),BGPCNTI),U,9)="GON"
+11 DO NEED
End DoDot:1
IF '$DATA(BGPG(1))
QUIT
SYH ;
+1 KILL BGPG
+2 SET BGPD=BD
+3 FOR
Begin DoDot:1
+4 KILL BGPG
+5 SET X=P_"^FIRST DX [BKM SYPHILIS DXS;DURING "_$$FMTE^XLFDT(BGPD)_"-"_$$FMTE^XLFDT(ED)
SET E=$$START1^APCLDF(X,"BGPG(")
+6 IF '$DATA(BGPG(1))
QUIT
+7 SET BGPD=$$FMADD^XLFDT($PIECE(BGPG(1),U,1),61)
+8 ;S BGPRES=BGPRES_$S(BGPRES="":"",1:", ")_$$DATE^BGP7UTL($P($P(^AUPNVSIT($P(BGPG(1),U,5),0),U),"."))_" (SYH)"
+9 SET BGPCNTI=BGPCNTI+1
+10 SET BGPCNTI($PIECE(BGPG(1),U,1),BGPCNTI)=BGPG(1)
SET $PIECE(BGPCNTI($PIECE(BGPG(1),U),BGPCNTI),U,9)="SYH"
+11 DO NEED
End DoDot:1
IF '$DATA(BGPG(1))
QUIT
+12 ;NOW COUNT ALL SCREENINGS DONE FOR ALL INCIDENCES
+13 SET BGPD=0
FOR
SET BGPD=$ORDER(BGPCNTI(BGPD))
IF BGPD'=+BGPD
QUIT
Begin DoDot:1
+14 SET BGPY=0
FOR
SET BGPY=$ORDER(BGPCNTI(BGPD,BGPY))
IF BGPY'=+BGPY
QUIT
Begin DoDot:2
+15 ;DOESN'T NEED A SCREEN
IF '$PIECE(BGPCNTI(BGPD,BGPY),U,10)
QUIT
+16 SET X=$$HIVTEST^BGP7D8(P,$$FMADD^XLFDT(BGPD,-30),$$FMADD^XLFDT(BGPD,60))
+17 IF X
SET BGPCNTH=BGPCNTH+1
SET $PIECE(BGPCNTI(BGPD,BGPY),U,11)=$PIECE(X,U,2)
QUIT
+18 SET X=$$REFHIV(P,BDATE,EDATE)
+19 IF X
SET BGPCNTR=BGPCNTR+1
SET $PIECE(BGPCNTI(BGPD,BGPY),U,20)=$PIECE(X,U,2)
End DoDot:2
End DoDot:1
+20 SET D=0
+21 IF 'BGPCNTI
QUIT ""
+22 FOR
SET D=$ORDER(BGPCNTI(D))
IF D'=+D
QUIT
Begin DoDot:1
+23 SET Y=0
FOR
SET Y=$ORDER(BGPCNTI(D,Y))
IF Y'=+Y
QUIT
Begin DoDot:2
+24 SET R=Y_") "_$$DATE^BGP7UTL($PIECE(BGPCNTI(D,Y),U,1))_" "_$PIECE(BGPCNTI(D,Y),U,9)_" "_$PIECE(BGPCNTI(D,Y),U,2)
+25 SET BGPRESD=BGPRESD_$SELECT(BGPRESD]"":" ",1:"")_R
+26 IF '$PIECE(BGPCNTI(D,Y),U,10)
IF $PIECE(BGPCNTI(D,Y),U,9)'="HIV"
SET N=Y_") HIV-Contraind "_$$DATE^BGP7UTL($PIECE(BGPHIV,U,1))_" Prior DX "_$PIECE(BGPHIV,U,2)
GOTO R
+27 IF '$PIECE(BGPCNTI(D,Y),U,10)
IF $PIECE(BGPCNTI(D,Y),U,9)="HIV"
SET N=Y_") HIV-N/A"
GOTO R
+28 IF $PIECE(BGPCNTI(D,Y),U,10)
SET N=$PIECE(BGPCNTI(D,Y),U,11)
Begin DoDot:3
+29 IF N]""
SET N=Y_") HIV-Y "_N
QUIT
+30 SET N=$PIECE(BGPCNTI(D,Y),U,20)
IF N]""
SET N=Y_") HIV-"_N
QUIT
+31 SET N=Y_") HIV-N"
End DoDot:3
R SET BGPRESN=BGPRESN_$SELECT(BGPRESN]"":" ",1:"")_N
End DoDot:2
End DoDot:1
+1 ;ZW BGPCNTI
+2 QUIT BGPCNTI_U_BGPCNTN_U_BGPCNTH_U_BGPCNTR_U_BGPRESD_U_BGPRESN
NEED ;
+1 ;DOESN'T NEED HIV SCREEN AS ALREADY HAS HIV
IF BGPHIV
IF $PIECE(BGPHIV,U,1)'>$PIECE(BGPG(1),U,1)
QUIT
+2 ;needs a screen
SET BGPCNTN=BGPCNTN+1
+3 ;needs a screen
SET $PIECE(BGPCNTI($PIECE(BGPG(1),U),BGPCNTI),U,10)=1
+4 QUIT
REFHIV(P,BDATE,EDATE) ;
+1 NEW T,BGPT,G,BGPT1
+2 SET T=""
+3 SET T=$$CPTREFT^BGP7UTL1(P,BDATE,EDATE,$ORDER(^ATXAX("B","BGP CPT HIV TESTS",0)),"R")
+4 IF T
SET T=1_U_"Refused CPT "_$PIECE(T,U,4)_U_$$DATE^BGP7UTL($PIECE(T,U,2))
QUIT T
+5 SET BGPT=$ORDER(^ATXLAB("B","BGP HIV TEST TAX",0))
+6 IF BGPT
Begin DoDot:1
+7 SET (G,BGPT1)=0
FOR
SET BGPT1=$ORDER(^ATXLAB(BGPT,21,"B",BGPT1))
IF BGPT1=""!($PIECE(G,U))
QUIT
Begin DoDot:2
+8 SET G=$$REFUSAL^BGP7UTL1(P,60,BGPT1,BDATE,EDATE)
End DoDot:2
End DoDot:1
IF $PIECE(G,U)
QUIT 1_U_"Refused Lab "_U_$$DATE^BGP7UTL($PIECE(G,U,2))
+9 QUIT ""
HIVDX(P,BDATE,EDATE) ;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_"^FIRST 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_"POV "_$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 ;Q:$P(^AUPNPROB(X,0),U,12)="I"
+12 IF $PIECE(^AUPNPROB(X,0),U,8)>EDATE
QUIT
+13 ;doo
IF $PIECE(^AUPNPROB(X,0),U,13)]""
IF $PIECE(^AUPNPROB(X,0),U,13)>EDATE
QUIT
+14 SET Y=$PIECE(^AUPNPROB(X,0),U)
+15 IF '$$ICD^BGP7UTL2(Y,T,9)
QUIT
+16 SET G=$PIECE(^AUPNPROB(X,0),U,8)
QUIT
+17 SET S=$$VAL^XBDIQ1(9000011,X,80001)
+18 IF S]""
IF $DATA(^XTMP("BGPSNOMEDSUBSET",$JOB,"PXRM HIV",S))
SET G=$PIECE(^AUPNPROB(X,0),U,8)
QUIT
+19 QUIT
End DoDot:1
+20 QUIT G
