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

BGP5D88.m

Go to the documentation of this file. 
  1. BGP5D88 ; IHS/CMI/LAB - measure C 03 Jul 2010 7:05 AM ;
  1.  ;;15.1;IHS CLINICAL REPORTING;;MAY 06, 2015;Build 143
  1.  ;
  1. HIV1 ;EP
  1.  S (BGPN1,BGPN2,BGPD1)=0
  1.  I 'BGPACTCL S BGPSTOP=1 Q  ;not active clinical pt
  1.  I BGPSEX'="F" S BGPSTOP=1 Q
  1.  Q:$$HIVDX^BGP5D8(DFN,BGPEDATE)  ;has HIV so quit
  1.  Q:'$$PREG^BGP5D7(DFN,$$FMADD^XLFDT(BGPEDATE,-609),BGPEDATE,1)  ;not pregnant
  1.  S BGPD1=1
  1.  S BGPHIV=$$HIVTEST(DFN,$$FMADD^XLFDT(BGPEDATE,-609),BGPEDATE)
  1.  I $P(BGPHIV,U) S BGPN1=1
  1.  S BGPVALUE="AC PREG"_"|||"_$P(BGPHIV,U,2)
  1.  S BGPVALUD="AC PREG"_"|||"_$P(BGPHIV,U,2)
  1.  K X,Y,Z,%,A,B,C,D,E,H,BDATE,EDATE,P,V,S,F,T
  1.  K BGPEDUC,BGPHIV
  1.  Q
  1. HIV2 ;EP
  1.  S (BGPN1,BGPN2,BGPD1)=0
  1.  I 'BGPACTCL S BGPSTOP=1 Q  ;not active clinical pt
  1.  I BGPSEX'="F" S BGPSTOP=1 Q
  1.  Q:$$HIVDX^BGP5D8(DFN,BGPEDATE)  ;has HIV so quit
  1.  Q:'$$PREG(DFN,$$FMADD^XLFDT(BGPEDATE,-600),BGPEDATE,1)  ;not pregnant
  1.  S BGPD1=1
  1.  S BGPHIV=$$HIVTEST(DFN,$$FMADD^XLFDT(BGPEDATE,-600),BGPEDATE)
  1.  I $P(BGPHIV,U) S BGPN1=1
  1.  S BGPVALUE="AC PREG"_"|||"_$P(BGPHIV,U,2)
  1.  S BGPVALUD="AC PREG"_"|||"_$P(BGPHIV,U,2)
  1.  K X,Y,Z,%,A,B,C,D,E,H,BDATE,EDATE,P,V,S,F,T
  1.  K BGPEDUC,BGPHIV
  1.  Q
  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.  ...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))) S BGPC=BGPC+1,BGPC(BGPC)=1_U_$$DATE^BGP5UTL((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^BGP5D21(J,T)
  1.  ...S BGPC=BGPC+1,BGPC(BGPC)=1_U_$$DATE^BGP5UTL((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.  S T=$O(^ATXAX("B","BGP CPT HIV TESTS",0))
  1.  I T D
  1.  .;go through visits in a date range for this patient, check cpts
  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^BGP5UTL2($P(^AUPNVCPT(X,0),U),T,1) I '$D(BGPA((9999999-$P(ED,".")))) S BGPC=BGPC+1,BGPC(BGPC)=1_U_$$DATE^BGP5UTL((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 Q ""
  1.  K BGPA
  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=1_U_$P(BGPA(T),U,2)
  1.  Q Y
  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. PREG(P,BDATE,EDATE,NORX) ;EP
  1.  NEW BGPDX,B,CNT,BGPD,BGPG
  1.  S B=0,CNT=0,BGPD=""  ;if there is one before time frame set this to 1
  1.  S NORX=$G(NORX)
  1.  K BGPG
  1.  S Y="BGPG("
  1.  S X=P_"^ALL DX [BGP PREGNANCY DIAGNOSES 2;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE) S E=$$START1^APCLDF(X,Y)
  1.  ;now reorder by date of diagnosis and eliminate all chr and rx if necessary
  1.  I '$D(BGPG) G PROB  ;no diagnoses
  1.  S B=0,X=0 F  S X=$O(BGPG(X)) Q:X'=+X  D
  1.  .;get date
  1.  .S D=$P(BGPG(X),U,1)
  1.  .S C=$$CLINIC^APCLV($P(BGPG(X),U,5),"C")
  1.  .I NORX,C=39 Q
  1.  .S BGPDX(D)="",CNT=CNT+1 I CNT=2 S BGPD=D
  1.  .I D>$$FMADD^XLFDT(EDATE,-365) S B=1
  1.  .Q
  1.  I CNT>1,B G MA
  1. PROB ;
  1.  I '$G(B) Q ""  ;no pregnancy visit during time period  ;-Lori fix in 09
  1.  S T=$O(^ATXAX("B","BGP PREGNANCY DIAGNOSES 2",0))
  1.  S (X,G)=0 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.  .Q:$P(^AUPNPROB(X,0),U,8)<BDATE
  1.  .S Y=$P(^AUPNPROB(X,0),U)
  1.  .Q:'$$ICD^BGP5UTL2(Y,T,9)
  1.  .S G=$P(^AUPNPROB(X,0),U,8)
  1.  .Q
  1.  I G=0,BGPD="" Q 0  ;no dxs and no problem list
  1.  S BGPD=G
  1. MA ;now check for abortion or miscarriage
  1.  ;abortion first
  1.  K BGPG S Y="BGPG(" S X=P_"^LAST DX [BGP MISCARRIAGE/ABORTION DXS;DURING "_$$FMTE^XLFDT(BGPD)_"-"_$$FMTE^XLFDT(EDATE) S E=$$START1^APCLDF(X,Y)
  1.  I $D(BGPG(1)) Q 0  ;HAD MIS/AB
  1.  S BGPG=$$LASTPRC^BGP5UTL1(P,"BGP ABORTION PROCEDURES",BDATE,EDATE)
  1.  I BGPG Q 0
  1.  S T=$O(^ATXAX("B","BGP MISCARRIAGE/ABORTION DXS",0))
  1.  S (X,G)=0 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)<BGPD
  1.  .Q:$P(^AUPNPROB(X,0),U,8)>EDATE
  1.  .S Y=$P(^AUPNPROB(X,0),U)
  1.  .Q:'$$ICD^BGP5UTL2(Y,T,9)
  1.  .S G=1
  1.  .Q
  1.  I G Q 0
  1.  ;now check CPTs for Abortion and Miscarriage
  1.  S T=$O(^ATXAX("B","BGP CPT ABORTION",0))
  1.  S %=$$CPT^BGP5DU(P,BGPD,EDATE,T,3)
  1.  I %]"" Q 0
  1.  S T=$O(^ATXAX("B","BGP CPT MISCARRIAGE",0))
  1.  S %=$$CPT^BGP5DU(P,BGPD,EDATE,T,3)
  1.  I %]"" Q 0
  1.  S T=$O(^ATXAX("B","BGP CPT ABORTION",0))
  1.  S %=$$TRAN^BGP5DU(P,BGPD,EDATE,T,3)
  1.  I %]"" Q 0
  1.  S T=$O(^ATXAX("B","BGP CPT MISCARRIAGE",0))
  1.  S %=$$TRAN^BGP5DU(P,BGPD,EDATE,T,3)
  1.  I %]"" Q 0
  1.  Q 1