BGP4D88 ; IHS/CMI/LAB - measure C 03 Jul 2010 7:05 AM ;
;;14.1;IHS CLINICAL REPORTING;;MAY 29, 2014;Build 114
;
HIV1 ;EP
S (BGPN1,BGPN2,BGPD1)=0
I 'BGPACTCL S BGPSTOP=1 Q ;not active clinical pt
I BGPSEX'="F" S BGPSTOP=1 Q
Q:$$HIVDX^BGP4D8(DFN,BGPEDATE) ;has HIV so quit
Q:'$$PREG^BGP4D7(DFN,$$FMADD^XLFDT(BGPEDATE,-609),BGPEDATE,1) ;not pregnant
S BGPD1=1
S BGPHIV=$$HIVTEST(DFN,$$FMADD^XLFDT(BGPEDATE,-609),BGPEDATE)
I $P(BGPHIV,U) S BGPN1=1
S BGPVALUE="AC PREG"_"|||"_$P(BGPHIV,U,2)
S BGPVALUD="AC PREG"_"|||"_$P(BGPHIV,U,2)
K X,Y,Z,%,A,B,C,D,E,H,BDATE,EDATE,P,V,S,F,T
K BGPEDUC,BGPHIV
Q
HIV2 ;EP
S (BGPN1,BGPN2,BGPD1)=0
I 'BGPACTCL S BGPSTOP=1 Q ;not active clinical pt
I BGPSEX'="F" S BGPSTOP=1 Q
Q:$$HIVDX^BGP4D8(DFN,BGPEDATE) ;has HIV so quit
Q:'$$PREG(DFN,$$FMADD^XLFDT(BGPEDATE,-600),BGPEDATE,1) ;not pregnant
S BGPD1=1
S BGPHIV=$$HIVTEST(DFN,$$FMADD^XLFDT(BGPEDATE,-600),BGPEDATE)
I $P(BGPHIV,U) S BGPN1=1
S BGPVALUE="AC PREG"_"|||"_$P(BGPHIV,U,2)
S BGPVALUD="AC PREG"_"|||"_$P(BGPHIV,U,2)
K X,Y,Z,%,A,B,C,D,E,H,BDATE,EDATE,P,V,S,F,T
K BGPEDUC,BGPHIV
Q
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))
...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))) S BGPC=BGPC+1,BGPC(BGPC)=1_U_$$DATE^BGP4UTL((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^BGP4D21(J,T)
...S BGPC=BGPC+1,BGPC(BGPC)=1_U_$$DATE^BGP4UTL((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
S T=$O(^ATXAX("B","BGP CPT HIV TESTS",0))
I T D
.;go through visits in a date range for this patient, check cpts
.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^BGP4UTL2($P(^AUPNVCPT(X,0),U),T,1) I '$D(BGPA((9999999-$P(ED,".")))) S BGPC=BGPC+1,BGPC(BGPC)=1_U_$$DATE^BGP4UTL((9999999-$P(ED,".")))_" CPT "_$$VAL^XBDIQ1(9000010.18,X,.01)_U_U_$P(ED,"."),BGPA((9999999-$P(ED,".")))=""
....Q
...Q
..Q
I BGPC=0 Q ""
K BGPA
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=1_U_$P(BGPA(T),U,2)
Q Y
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 ""
PREG(P,BDATE,EDATE,NORX) ;EP
NEW BGPDX,B,CNT,BGPD,BGPG
S B=0,CNT=0,BGPD="" ;if there is one before time frame set this to 1
S NORX=$G(NORX)
K BGPG
S Y="BGPG("
S X=P_"^ALL DX [BGP PREGNANCY DIAGNOSES 2;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE) S E=$$START1^APCLDF(X,Y)
;now reorder by date of diagnosis and eliminate all chr and rx if necessary
I '$D(BGPG) G PROB ;no diagnoses
S B=0,X=0 F S X=$O(BGPG(X)) Q:X'=+X D
.;get date
.S D=$P(BGPG(X),U,1)
.S C=$$CLINIC^APCLV($P(BGPG(X),U,5),"C")
.I NORX,C=39 Q
.S BGPDX(D)="",CNT=CNT+1 I CNT=2 S BGPD=D
.I D>$$FMADD^XLFDT(EDATE,-365) S B=1
.Q
I CNT>1,B G MA
PROB ;
I '$G(B) Q "" ;no pregnancy visit during time period ;-Lori fix in 09
S T=$O(^ATXAX("B","BGP PREGNANCY DIAGNOSES 2",0))
S (X,G)=0 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
.Q:$P(^AUPNPROB(X,0),U,8)<BDATE
.S Y=$P(^AUPNPROB(X,0),U)
.Q:'$$ICD^BGP4UTL2(Y,T,9)
.S G=$P(^AUPNPROB(X,0),U,8)
.Q
I G=0,BGPD="" Q 0 ;no dxs and no problem list
S BGPD=G
MA ;now check for abortion or miscarriage
;abortion first
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)
I $D(BGPG(1)) Q 0 ;HAD MIS/AB
S BGPG=$$LASTPRC^BGP4UTL1(P,"BGP ABORTION PROCEDURES",BDATE,EDATE)
I BGPG Q 0
S T=$O(^ATXAX("B","BGP MISCARRIAGE/ABORTION DXS",0))
S (X,G)=0 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)<BGPD
.Q:$P(^AUPNPROB(X,0),U,8)>EDATE
.S Y=$P(^AUPNPROB(X,0),U)
.Q:'$$ICD^BGP4UTL2(Y,T,9)
.S G=1
.Q
I G Q 0
;now check CPTs for Abortion and Miscarriage
S T=$O(^ATXAX("B","BGP CPT ABORTION",0))
S %=$$CPT^BGP4DU(P,BGPD,EDATE,T,3)
I %]"" Q 0
S T=$O(^ATXAX("B","BGP CPT MISCARRIAGE",0))
S %=$$CPT^BGP4DU(P,BGPD,EDATE,T,3)
I %]"" Q 0
S T=$O(^ATXAX("B","BGP CPT ABORTION",0))
S %=$$TRAN^BGP4DU(P,BGPD,EDATE,T,3)
I %]"" Q 0
S T=$O(^ATXAX("B","BGP CPT MISCARRIAGE",0))
S %=$$TRAN^BGP4DU(P,BGPD,EDATE,T,3)
I %]"" Q 0
Q 1
BGP4D88 ; IHS/CMI/LAB - measure C 03 Jul 2010 7:05 AM ;
+1 ;;14.1;IHS CLINICAL REPORTING;;MAY 29, 2014;Build 114
+2 ;
HIV1 ;EP
+1 SET (BGPN1,BGPN2,BGPD1)=0
+2 ;not active clinical pt
IF 'BGPACTCL
SET BGPSTOP=1
QUIT
+3 IF BGPSEX'="F"
SET BGPSTOP=1
QUIT
+4 ;has HIV so quit
IF $$HIVDX^BGP4D8(DFN,BGPEDATE)
QUIT
+5 ;not pregnant
IF '$$PREG^BGP4D7(DFN,$$FMADD^XLFDT(BGPEDATE,-609),BGPEDATE,1)
QUIT
+6 SET BGPD1=1
+7 SET BGPHIV=$$HIVTEST(DFN,$$FMADD^XLFDT(BGPEDATE,-609),BGPEDATE)
+8 IF $PIECE(BGPHIV,U)
SET BGPN1=1
+9 SET BGPVALUE="AC PREG"_"|||"_$PIECE(BGPHIV,U,2)
+10 SET BGPVALUD="AC PREG"_"|||"_$PIECE(BGPHIV,U,2)
+11 KILL X,Y,Z,%,A,B,C,D,E,H,BDATE,EDATE,P,V,S,F,T
+12 KILL BGPEDUC,BGPHIV
+13 QUIT
HIV2 ;EP
+1 SET (BGPN1,BGPN2,BGPD1)=0
+2 ;not active clinical pt
IF 'BGPACTCL
SET BGPSTOP=1
QUIT
+3 IF BGPSEX'="F"
SET BGPSTOP=1
QUIT
+4 ;has HIV so quit
IF $$HIVDX^BGP4D8(DFN,BGPEDATE)
QUIT
+5 ;not pregnant
IF '$$PREG(DFN,$$FMADD^XLFDT(BGPEDATE,-600),BGPEDATE,1)
QUIT
+6 SET BGPD1=1
+7 SET BGPHIV=$$HIVTEST(DFN,$$FMADD^XLFDT(BGPEDATE,-600),BGPEDATE)
+8 IF $PIECE(BGPHIV,U)
SET BGPN1=1
+9 SET BGPVALUE="AC PREG"_"|||"_$PIECE(BGPHIV,U,2)
+10 SET BGPVALUD="AC PREG"_"|||"_$PIECE(BGPHIV,U,2)
+11 KILL X,Y,Z,%,A,B,C,D,E,H,BDATE,EDATE,P,V,S,F,T
+12 KILL BGPEDUC,BGPHIV
+13 QUIT
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 SET V=$PIECE(^AUPNVLAB(X,0),U,3)
+12 IF BGPLT
IF $PIECE(^AUPNVLAB(X,0),U)
IF $DATA(^ATXLAB(BGPLT,21,"B",$PIECE(^AUPNVLAB(X,0),U)))
SET BGPC=BGPC+1
SET BGPC(BGPC)=1_U_$$DATE^BGP4UTL((9999999-D))_" Lab"_U_$PIECE(^AUPNVLAB(X,0),U,4)_U_D
SET BGPA((9999999-D))=""
QUIT
+13 IF 'T
QUIT
+14 SET J=$PIECE($GET(^AUPNVLAB(X,11)),U,13)
IF J=""
QUIT
+15 IF '$$LOINC^BGP4D21(J,T)
QUIT
+16 SET BGPC=BGPC+1
SET BGPC(BGPC)=1_U_$$DATE^BGP4UTL((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))=""
+17 QUIT
End DoDot:3
End DoDot:2
End DoDot:1
+18 SET T=$ORDER(^ATXAX("B","BGP CPT HIV TESTS",0))
+19 IF T
Begin DoDot:1
+20 ;go through visits in a date range for this patient, check cpts
+21 SET ED=(9999999-EDATE)
SET BD=9999999-BDATE
SET G=0
+22 FOR
SET ED=$ORDER(^AUPNVSIT("AA",P,ED))
IF ED=""!($PIECE(ED,".")>BD)
QUIT
Begin DoDot:2
+23 SET V=0
FOR
SET V=$ORDER(^AUPNVSIT("AA",P,ED,V))
IF V'=+V
QUIT
Begin DoDot:3
+24 IF '$DATA(^AUPNVSIT(V,0))
QUIT
+25 IF '$DATA(^AUPNVCPT("AD",V))
QUIT
+26 SET X=0
FOR
SET X=$ORDER(^AUPNVCPT("AD",V,X))
IF X'=+X
QUIT
Begin DoDot:4
+27 IF $$ICD^BGP4UTL2($PIECE(^AUPNVCPT(X,0),U),T,1)
IF '$DATA(BGPA((9999999-$PIECE(ED,"."))))
SET BGPC=BGPC+1
SET BGPC(BGPC)=1_U_$$DATE^BGP4UTL((9999999-$PIECE(ED,".")))_" CPT "_$$VAL^XBDIQ1(9000010.18,X,.01)_U_U_$PIECE(ED,".")
SET BGPA((9999999-$PIECE(ED,".")))=""
+28 QUIT
End DoDot:4
+29 QUIT
End DoDot:3
+30 QUIT
End DoDot:2
End DoDot:1
+31 IF BGPC=0
QUIT ""
+32 KILL BGPA
+33 SET T=0
FOR
SET T=$ORDER(BGPC(T))
IF T'=+T
QUIT
SET BGPA($PIECE(BGPC(T),U,4))=BGPC(T)
+34 SET T=$ORDER(BGPA(0))
+35 SET Y=1_U_$PIECE(BGPA(T),U,2)
+36 QUIT Y
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 ""
PREG(P,BDATE,EDATE,NORX) ;EP
+1 NEW BGPDX,B,CNT,BGPD,BGPG
+2 ;if there is one before time frame set this to 1
SET B=0
SET CNT=0
SET BGPD=""
+3 SET NORX=$GET(NORX)
+4 KILL BGPG
+5 SET Y="BGPG("
+6 SET X=P_"^ALL DX [BGP PREGNANCY DIAGNOSES 2;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(X,Y)
+7 ;now reorder by date of diagnosis and eliminate all chr and rx if necessary
+8 ;no diagnoses
IF '$DATA(BGPG)
GOTO PROB
+9 SET B=0
SET X=0
FOR
SET X=$ORDER(BGPG(X))
IF X'=+X
QUIT
Begin DoDot:1
+10 ;get date
+11 SET D=$PIECE(BGPG(X),U,1)
+12 SET C=$$CLINIC^APCLV($PIECE(BGPG(X),U,5),"C")
+13 IF NORX
IF C=39
QUIT
+14 SET BGPDX(D)=""
SET CNT=CNT+1
IF CNT=2
SET BGPD=D
+15 IF D>$$FMADD^XLFDT(EDATE,-365)
SET B=1
+16 QUIT
End DoDot:1
+17 IF CNT>1
IF B
GOTO MA
PROB ;
+1 ;no pregnancy visit during time period ;-Lori fix in 09
IF '$GET(B)
QUIT ""
+2 SET T=$ORDER(^ATXAX("B","BGP PREGNANCY DIAGNOSES 2",0))
+3 SET (X,G)=0
FOR
SET X=$ORDER(^AUPNPROB("AC",P,X))
IF X'=+X!(G)
QUIT
Begin DoDot:1
+4 IF $PIECE(^AUPNPROB(X,0),U,12)="D"
QUIT
+5 IF $PIECE(^AUPNPROB(X,0),U,12)="I"
QUIT
+6 IF $PIECE(^AUPNPROB(X,0),U,8)>EDATE
QUIT
+7 IF $PIECE(^AUPNPROB(X,0),U,8)<BDATE
QUIT
+8 SET Y=$PIECE(^AUPNPROB(X,0),U)
+9 IF '$$ICD^BGP4UTL2(Y,T,9)
QUIT
+10 SET G=$PIECE(^AUPNPROB(X,0),U,8)
+11 QUIT
End DoDot:1
+12 ;no dxs and no problem list
IF G=0
IF BGPD=""
QUIT 0
+13 SET BGPD=G
MA ;now check for abortion or miscarriage
+1 ;abortion first
+2 KILL BGPG
SET Y="BGPG("
SET X=P_"^LAST DX [BGP MISCARRIAGE/ABORTION DXS;DURING "_$$FMTE^XLFDT(BGPD)_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(X,Y)
+3 ;HAD MIS/AB
IF $DATA(BGPG(1))
QUIT 0
+4 SET BGPG=$$LASTPRC^BGP4UTL1(P,"BGP ABORTION PROCEDURES",BDATE,EDATE)
+5 IF BGPG
QUIT 0
+6 SET T=$ORDER(^ATXAX("B","BGP MISCARRIAGE/ABORTION DXS",0))
+7 SET (X,G)=0
FOR
SET X=$ORDER(^AUPNPROB("AC",P,X))
IF X'=+X!(G)
QUIT
Begin DoDot:1
+8 IF $PIECE(^AUPNPROB(X,0),U,12)="D"
QUIT
+9 IF $PIECE(^AUPNPROB(X,0),U,12)="I"
QUIT
+10 IF $PIECE(^AUPNPROB(X,0),U,8)<BGPD
QUIT
+11 IF $PIECE(^AUPNPROB(X,0),U,8)>EDATE
QUIT
+12 SET Y=$PIECE(^AUPNPROB(X,0),U)
+13 IF '$$ICD^BGP4UTL2(Y,T,9)
QUIT
+14 SET G=1
+15 QUIT
End DoDot:1
+16 IF G
QUIT 0
+17 ;now check CPTs for Abortion and Miscarriage
+18 SET T=$ORDER(^ATXAX("B","BGP CPT ABORTION",0))
+19 SET %=$$CPT^BGP4DU(P,BGPD,EDATE,T,3)
+20 IF %]""
QUIT 0
+21 SET T=$ORDER(^ATXAX("B","BGP CPT MISCARRIAGE",0))
+22 SET %=$$CPT^BGP4DU(P,BGPD,EDATE,T,3)
+23 IF %]""
QUIT 0
+24 SET T=$ORDER(^ATXAX("B","BGP CPT ABORTION",0))
+25 SET %=$$TRAN^BGP4DU(P,BGPD,EDATE,T,3)
+26 IF %]""
QUIT 0
+27 SET T=$ORDER(^ATXAX("B","BGP CPT MISCARRIAGE",0))
+28 SET %=$$TRAN^BGP4DU(P,BGPD,EDATE,T,3)
+29 IF %]""
QUIT 0
+30 QUIT 1
