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

BGP8D24A.m

Go to the documentation of this file. 
  1. BGP8D24A ;IHS/CMI/LAB - sti measure;
  1.  ;;18.1;IHS CLINICAL REPORTING;;MAY 25, 2018;Build 66
  1.  ;
  1. 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
  1.  S BD=$$FMADD^XLFDT(BDATE,-60)
  1.  S ED=$$FMADD^XLFDT(BDATE,300)
  1.  ;S ED=EDATE ;LORI
  1.  S (BGPRESD,BGPRESN,BGPCNTI,BGPCNTN,BGPCNTH,BGPCNTR,BGPHIV)=""  ;RETURN VALUE
  1. HIV ;get first HIV dx, if in time window count as an incident, if not don't
  1.  S BGPHIV=$$HIVDX(P,$$DOB^AUPNPAT(P),ED)
  1.  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^BGP8UTL($P($P(^AUPNVSIT($P(BGPG(1),U,5),0),U),"."))_" (HIV)"
  1. CHL ;chlamydia
  1.  NEW BGPG
  1.  S BGPD=BD
  1.  S C=0,R=""
  1.  F  D  Q:'$D(BGPG(1))
  1.  .K BGPG
  1.  .S X=P_"^FIRST DX [BKM CHLAMYDIA DXS;DURING "_$$FMTE^XLFDT(BGPD)_"-"_$$FMTE^XLFDT(ED) S E=$$START1^APCLDF(X,"BGPG(")
  1.  .Q:'$D(BGPG(1))
  1.  .S BGPD=$$FMADD^XLFDT($P(BGPG(1),U,1),61)
  1.  .;S BGPRES=BGPRES_$S(BGPRES="":"",1:", ")_$$DATE^BGP8UTL($P($P(^AUPNVSIT($P(BGPG(1),U,5),0),U),"."))_" (CHL)"
  1.  .S BGPCNTI=BGPCNTI+1
  1.  .S BGPCNTI($P(BGPG(1),U,1),BGPCNTI)=BGPG(1),$P(BGPCNTI($P(BGPG(1),U),BGPCNTI),U,9)="CHL"
  1.  .D NEED
  1. GON ;
  1.  K BGPG
  1.  S BGPD=BD
  1.  F  D  Q:'$D(BGPG(1))
  1.  .K BGPG
  1.  .S X=P_"^FIRST DX [BKM GONORRHEA DXS;DURING "_$$FMTE^XLFDT(BGPD)_"-"_$$FMTE^XLFDT(ED) S E=$$START1^APCLDF(X,"BGPG(")
  1.  .Q:'$D(BGPG(1))
  1.  .S BGPD=$$FMADD^XLFDT($P(BGPG(1),U,1),61)
  1.  .;S BGPRES=BGPRES_$S(BGPRES="":"",1:", ")_$$DATE^BGP8UTL($P($P(^AUPNVSIT($P(BGPG(1),U,5),0),U),"."))_" (GON)"
  1.  .S BGPCNTI=BGPCNTI+1
  1.  .S BGPCNTI($P(BGPG(1),U,1),BGPCNTI)=BGPG(1),$P(BGPCNTI($P(BGPG(1),U),BGPCNTI),U,9)="GON"
  1.  .D NEED
  1. SYH ;
  1.  K BGPG
  1.  S BGPD=BD
  1.  F  D  Q:'$D(BGPG(1))
  1.  .K BGPG
  1.  .S X=P_"^FIRST DX [BKM SYPHILIS DXS;DURING "_$$FMTE^XLFDT(BGPD)_"-"_$$FMTE^XLFDT(ED) S E=$$START1^APCLDF(X,"BGPG(")
  1.  .Q:'$D(BGPG(1))
  1.  .S BGPD=$$FMADD^XLFDT($P(BGPG(1),U,1),61)
  1.  .;S BGPRES=BGPRES_$S(BGPRES="":"",1:", ")_$$DATE^BGP8UTL($P($P(^AUPNVSIT($P(BGPG(1),U,5),0),U),"."))_" (SYH)"
  1.  .S BGPCNTI=BGPCNTI+1
  1.  .S BGPCNTI($P(BGPG(1),U,1),BGPCNTI)=BGPG(1),$P(BGPCNTI($P(BGPG(1),U),BGPCNTI),U,9)="SYH"
  1.  .D NEED
  1.  ;NOW COUNT ALL SCREENINGS DONE FOR ALL INCIDENCES
  1.  S BGPD=0 F  S BGPD=$O(BGPCNTI(BGPD)) Q:BGPD'=+BGPD  D
  1.  .S BGPY=0 F  S BGPY=$O(BGPCNTI(BGPD,BGPY)) Q:BGPY'=+BGPY  D
  1.  ..Q:'$P(BGPCNTI(BGPD,BGPY),U,10)  ;DOESN'T NEED A SCREEN
  1.  ..S X=$$HIVTEST^BGP8D8(P,$$FMADD^XLFDT(BGPD,-30),$$FMADD^XLFDT(BGPD,60))
  1.  ..I X S BGPCNTH=BGPCNTH+1,$P(BGPCNTI(BGPD,BGPY),U,11)=$P(X,U,2) Q
  1.  ..S X=$$REFHIV(P,BDATE,EDATE)
  1.  ..I X S BGPCNTR=BGPCNTR+1,$P(BGPCNTI(BGPD,BGPY),U,20)=$P(X,U,2)
  1.  S D=0
  1.  I 'BGPCNTI Q ""
  1.  F  S D=$O(BGPCNTI(D)) Q:D'=+D  D
  1.  .S Y=0 F  S Y=$O(BGPCNTI(D,Y)) Q:Y'=+Y  D
  1.  ..S R=Y_") "_$$DATE^BGP8UTL($P(BGPCNTI(D,Y),U,1))_" "_$P(BGPCNTI(D,Y),U,9)_" "_$P(BGPCNTI(D,Y),U,2)
  1.  ..S BGPRESD=BGPRESD_$S(BGPRESD]"":" ",1:"")_R
  1.  ..I '$P(BGPCNTI(D,Y),U,10),$P(BGPCNTI(D,Y),U,9)'="HIV" S N=Y_") HIV-Contraind "_$$DATE^BGP8UTL($P(BGPHIV,U,1))_" Prior DX "_$P(BGPHIV,U,2) G R
  1.  ..I '$P(BGPCNTI(D,Y),U,10),$P(BGPCNTI(D,Y),U,9)="HIV" S N=Y_") HIV-N/A" G R
  1.  ..I $P(BGPCNTI(D,Y),U,10) S N=$P(BGPCNTI(D,Y),U,11) D
  1.  ...I N]"" S N=Y_") HIV-Y "_N Q
  1.  ...S N=$P(BGPCNTI(D,Y),U,20) I N]"" S N=Y_") HIV-"_N Q
  1.  ...S N=Y_") HIV-N"
  1. R ..S BGPRESN=BGPRESN_$S(BGPRESN]"":" ",1:"")_N
  1.  ;ZW BGPCNTI
  1.  Q BGPCNTI_U_BGPCNTN_U_BGPCNTH_U_BGPCNTR_U_BGPRESD_U_BGPRESN
  1. NEED ;
  1.  I BGPHIV,$P(BGPHIV,U,1)'>$P(BGPG(1),U,1) Q  ;DOESN'T NEED HIV SCREEN AS ALREADY HAS HIV
  1.  S BGPCNTN=BGPCNTN+1  ;needs a screen
  1.  S $P(BGPCNTI($P(BGPG(1),U),BGPCNTI),U,10)=1  ;needs a screen
  1.  Q
  1. REFHIV(P,BDATE,EDATE) ;
  1.  NEW T,BGPT,G,BGPT1
  1.  S T=""
  1.  S T=$$CPTREFT^BGP8UTL1(P,BDATE,EDATE,$O(^ATXAX("B","BGP CPT HIV TESTS",0)),"R")
  1.  I T S T=1_U_"Refused CPT "_$P(T,U,4)_U_$$DATE^BGP8UTL($P(T,U,2)) Q T
  1.  S BGPT=$O(^ATXLAB("B","BGP HIV TEST TAX",0))
  1.  I BGPT D  I $P(G,U) Q 1_U_"Refused Lab "_U_$$DATE^BGP8UTL($P(G,U,2))
  1.  .S (G,BGPT1)=0 F  S BGPT1=$O(^ATXLAB(BGPT,21,"B",BGPT1)) Q:BGPT1=""!($P(G,U))  D
  1.  ..S G=$$REFUSAL^BGP8UTL1(P,60,BGPT1,BDATE,EDATE)
  1.  Q ""
  1. HIVDX(P,BDATE,EDATE) ;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_"^FIRST 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_"POV "_$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,12)="I"
  1.  .Q:$P(^AUPNPROB(X,0),U,8)>EDATE
  1.  .I $P(^AUPNPROB(X,0),U,13)]"",$P(^AUPNPROB(X,0),U,13)>EDATE Q  ;doo
  1.  .S Y=$P(^AUPNPROB(X,0),U)
  1.  .Q:'$$ICD^BGP8UTL2(Y,T,9)
  1.  .S G=$P(^AUPNPROB(X,0),U,8) Q
  1.  .S S=$$VAL^XBDIQ1(9000011,X,80001)
  1.  .I S]"",$D(^XTMP("BGPSNOMEDSUBSET",$J,"PXRM HIV",S)) S G=$P(^AUPNPROB(X,0),U,8) Q
  1.  .Q
  1.  Q G