BGP3D53 ; IHS/CMI/LAB - measure calc ;
;;13.0;IHS CLINICAL REPORTING;;NOV 20, 2012;Build 81
;\
IK ;EP
S (BGPN1,BGPN2,BGPN3,BGPN4,BGPN5,BGPN6,BGPD1,BGPD2,BGPD3,BGPD4,BGPD5,BGPD6,BGPD7,BGPD8,BGPD9)=0
I 'BGPACTUP S BGPSTOP=1 Q
I BGPSEX'="F" S BGPSTOP=1 Q
I BGPAGEB<16 S BGPSTOP=1 Q
I BGPAGEB>25 S BGPSTOP=1 Q
I BGPACTUP S BGPD2=1
I BGPACTCL S BGPD1=1
I BGPACTCL,BGPAGEB>15,BGPAGEB<21 S BGPD3=1
I BGPACTCL,BGPAGEB>20,BGPAGEB<26 S BGPD4=1
I BGPACTUP,BGPAGEB>15,BGPAGEB<21 S BGPD5=1
I BGPACTUP,BGPAGEB>20,BGPAGEB<26 S BGPD6=1
S BGPNV=$$CHL(DFN,BGP365,BGPEDATE)
S BGPN1=+BGPNV
S BGPVALUE=$S(BGPD2:"UP",1:"")_$S(BGPD1:",AC",1:"")_"|||"_$P(BGPNV,U,3)_" "_$P(BGPNV,U,2)
K X,Y,Z,%,A,B,C,D,E,H,BDATE,EDATE,P,V,S,F,T
Q
CHL(P,BDATE,EDATE) ;EP
I '$G(P) Q ""
S BGPC=""
K BGPG S %=P_"^LAST DX [BGP CHLAMYDIA SCREEN DXS;DURING "_BDATE_"-"_EDATE,E=$$START1^APCLDF(%,"BGPG(")
I $D(BGPG(1)) Q 1_U_$$DATE^BGP3UTL($P(BGPG(1),U))_U_$P(BGPG(1),U,2)
;check cpt taxonomy
S T=$O(^ATXAX("B","BGP CHLAMYDIA CPTS",0))
I T D I X Q 1_U_"CPT "_$P(X,U,3)_U_$$DATE^BGP3UTL($P(X,U,2))
.S X=$$CPT^BGP3DU(P,BDATE,EDATE,T,6) I X]"" Q
.S X=$$TRAN^BGP3DU(P,BDATE,EDATE,T,6)
;now get all loinc/taxonomy tests
S BGPC=""
S T=$O(^ATXAX("B","BGP CHLAMYDIA LOINC CODES",0))
S BGPLT=$O(^ATXLAB("B","BGP CHLAMYDIA TESTS 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)!(BGPC) D
.S L=0 F S L=$O(^AUPNVLAB("AE",P,D,L)) Q:L'=+L!(BGPC) D
..S X=0 F S X=$O(^AUPNVLAB("AE",P,D,L,X)) Q:X'=+X!(BGPC) D
...Q:'$D(^AUPNVLAB(X,0))
...I BGPLT,$P(^AUPNVLAB(X,0),U),$D(^ATXLAB(BGPLT,21,"B",$P(^AUPNVLAB(X,0),U))) S BGPC=1_U_"Lab test"_U_$$DATE^BGP3UTL((9999999-D)) Q
...Q:'T
...S J=$P($G(^AUPNVLAB(X,11)),U,13) Q:J=""
...Q:'$$LOINC(J,T)
...S R=$P(^AUPNVLAB(X,0),U,4)
...S BGPC=1_U_"Lab Test "_U_$$DATE^BGP3UTL((9999999-D))
...Q
I BGPC Q BGPC
S B=9999999-BDATE,E=9999999-EDATE S D=E-1 F S D=$O(^AUPNVMIC("AE",P,D)) Q:D'=+D!(D>B)!(BGPC) D
.S L=0 F S L=$O(^AUPNVMIC("AE",P,D,L)) Q:L'=+L!(BGPC) D
..S X=0 F S X=$O(^AUPNVMIC("AE",P,D,L,X)) Q:X'=+X!(BGPC) D
...Q:'$D(^AUPNVMIC(X,0))
...I BGPLT,$P(^AUPNVMIC(X,0),U),$D(^ATXLAB(BGPLT,21,"B",$P(^AUPNVMIC(X,0),U))) S BGPC=1_U_"Micro test"_U_$$DATE^BGP3UTL((9999999-D)) Q
...Q:'T
...S J=$P($G(^AUPNVMIC(X,11)),U,13) Q:J=""
...Q:'$$LOINC(J,T)
...S R=$P(^AUPNVMIC(X,0),U,4)
...S BGPC=1_U_"Micro Test "_U_$$DATE^BGP3UTL((9999999-D))
...Q
Q BGPC
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 ""
BGP3D53 ; IHS/CMI/LAB - measure calc ;
+1 ;;13.0;IHS CLINICAL REPORTING;;NOV 20, 2012;Build 81
+2 ;\
IK ;EP
+1 SET (BGPN1,BGPN2,BGPN3,BGPN4,BGPN5,BGPN6,BGPD1,BGPD2,BGPD3,BGPD4,BGPD5,BGPD6,BGPD7,BGPD8,BGPD9)=0
+2 IF 'BGPACTUP
SET BGPSTOP=1
QUIT
+3 IF BGPSEX'="F"
SET BGPSTOP=1
QUIT
+4 IF BGPAGEB<16
SET BGPSTOP=1
QUIT
+5 IF BGPAGEB>25
SET BGPSTOP=1
QUIT
+6 IF BGPACTUP
SET BGPD2=1
+7 IF BGPACTCL
SET BGPD1=1
+8 IF BGPACTCL
IF BGPAGEB>15
IF BGPAGEB<21
SET BGPD3=1
+9 IF BGPACTCL
IF BGPAGEB>20
IF BGPAGEB<26
SET BGPD4=1
+10 IF BGPACTUP
IF BGPAGEB>15
IF BGPAGEB<21
SET BGPD5=1
+11 IF BGPACTUP
IF BGPAGEB>20
IF BGPAGEB<26
SET BGPD6=1
+12 SET BGPNV=$$CHL(DFN,BGP365,BGPEDATE)
+13 SET BGPN1=+BGPNV
+14 SET BGPVALUE=$SELECT(BGPD2:"UP",1:"")_$SELECT(BGPD1:",AC",1:"")_"|||"_$PIECE(BGPNV,U,3)_" "_$PIECE(BGPNV,U,2)
+15 KILL X,Y,Z,%,A,B,C,D,E,H,BDATE,EDATE,P,V,S,F,T
+16 QUIT
CHL(P,BDATE,EDATE) ;EP
+1 IF '$GET(P)
QUIT ""
+2 SET BGPC=""
+3 KILL BGPG
SET %=P_"^LAST DX [BGP CHLAMYDIA SCREEN DXS;DURING "_BDATE_"-"_EDATE
SET E=$$START1^APCLDF(%,"BGPG(")
+4 IF $DATA(BGPG(1))
QUIT 1_U_$$DATE^BGP3UTL($PIECE(BGPG(1),U))_U_$PIECE(BGPG(1),U,2)
+5 ;check cpt taxonomy
+6 SET T=$ORDER(^ATXAX("B","BGP CHLAMYDIA CPTS",0))
+7 IF T
Begin DoDot:1
+8 SET X=$$CPT^BGP3DU(P,BDATE,EDATE,T,6)
IF X]""
QUIT
+9 SET X=$$TRAN^BGP3DU(P,BDATE,EDATE,T,6)
End DoDot:1
IF X
QUIT 1_U_"CPT "_$PIECE(X,U,3)_U_$$DATE^BGP3UTL($PIECE(X,U,2))
+10 ;now get all loinc/taxonomy tests
+11 SET BGPC=""
+12 SET T=$ORDER(^ATXAX("B","BGP CHLAMYDIA LOINC CODES",0))
+13 SET BGPLT=$ORDER(^ATXLAB("B","BGP CHLAMYDIA TESTS TAX",0))
+14 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)!(BGPC)
QUIT
Begin DoDot:1
+15 SET L=0
FOR
SET L=$ORDER(^AUPNVLAB("AE",P,D,L))
IF L'=+L!(BGPC)
QUIT
Begin DoDot:2
+16 SET X=0
FOR
SET X=$ORDER(^AUPNVLAB("AE",P,D,L,X))
IF X'=+X!(BGPC)
QUIT
Begin DoDot:3
+17 IF '$DATA(^AUPNVLAB(X,0))
QUIT
+18 IF BGPLT
IF $PIECE(^AUPNVLAB(X,0),U)
IF $DATA(^ATXLAB(BGPLT,21,"B",$PIECE(^AUPNVLAB(X,0),U)))
SET BGPC=1_U_"Lab test"_U_$$DATE^BGP3UTL((9999999-D))
QUIT
+19 IF 'T
QUIT
+20 SET J=$PIECE($GET(^AUPNVLAB(X,11)),U,13)
IF J=""
QUIT
+21 IF '$$LOINC(J,T)
QUIT
+22 SET R=$PIECE(^AUPNVLAB(X,0),U,4)
+23 SET BGPC=1_U_"Lab Test "_U_$$DATE^BGP3UTL((9999999-D))
+24 QUIT
End DoDot:3
End DoDot:2
End DoDot:1
+25 IF BGPC
QUIT BGPC
+26 SET B=9999999-BDATE
SET E=9999999-EDATE
SET D=E-1
FOR
SET D=$ORDER(^AUPNVMIC("AE",P,D))
IF D'=+D!(D>B)!(BGPC)
QUIT
Begin DoDot:1
+27 SET L=0
FOR
SET L=$ORDER(^AUPNVMIC("AE",P,D,L))
IF L'=+L!(BGPC)
QUIT
Begin DoDot:2
+28 SET X=0
FOR
SET X=$ORDER(^AUPNVMIC("AE",P,D,L,X))
IF X'=+X!(BGPC)
QUIT
Begin DoDot:3
+29 IF '$DATA(^AUPNVMIC(X,0))
QUIT
+30 IF BGPLT
IF $PIECE(^AUPNVMIC(X,0),U)
IF $DATA(^ATXLAB(BGPLT,21,"B",$PIECE(^AUPNVMIC(X,0),U)))
SET BGPC=1_U_"Micro test"_U_$$DATE^BGP3UTL((9999999-D))
QUIT
+31 IF 'T
QUIT
+32 SET J=$PIECE($GET(^AUPNVMIC(X,11)),U,13)
IF J=""
QUIT
+33 IF '$$LOINC(J,T)
QUIT
+34 SET R=$PIECE(^AUPNVMIC(X,0),U,4)
+35 SET BGPC=1_U_"Micro Test "_U_$$DATE^BGP3UTL((9999999-D))
+36 QUIT
End DoDot:3
End DoDot:2
End DoDot:1
+37 QUIT BGPC
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 ""
