BGP1D53 ; IHS/CMI/LAB - measure calc ;
;;11.1;IHS CLINICAL REPORTING SYSTEM;;JUN 27, 2011;Build 33
;\
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^BGP1D53(DFN,BGP365,BGPEDATE)
S BGPN1=+BGPNV
S BGPVALUE=$S(BGPD2:"UP",1:"")_";"_$S(BGPD1:"AC",1:"")_"|||"_$P(BGPNV,U,2)_" "_$P(BGPNV,U,3)
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 V73.88;DURING "_BDATE_"-"_EDATE,E=$$START1^APCLDF(%,"BGPG(")
I $D(BGPG(1)) Q 1_U_$$DATE^BGP1UTL($P(BGPG(1),U))_U_"V73.88"
S %=P_"^LAST DX V73.98;DURING "_BDATE_"-"_EDATE,E=$$START1^APCLDF(%,"BGPG(")
I $D(BGPG(1)) Q 1_U_"POV V73.88"_U_$$DATE^BGP1UTL($P(BGPG(1),U))
;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^BGP1UTL($P(X,U,2))
.S X=$$CPT^BGP1DU(P,BDATE,EDATE,T,6) I X]"" Q
.S X=$$TRAN^BGP1DU(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^BGP1UTL((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 "_$$VAL^XBDIQ1(9000010.09,X,.01)_U_$$DATE^BGP1UTL((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_"v micro test"_U_$$DATE^BGP1UTL((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 "_$$VAL^XBDIQ1(9000010.25,X,.01)_U_$$DATE^BGP1UTL((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 ""
BGP1D53 ; IHS/CMI/LAB - measure calc ;
+1 ;;11.1;IHS CLINICAL REPORTING SYSTEM;;JUN 27, 2011;Build 33
+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^BGP1D53(DFN,BGP365,BGPEDATE)
+13 SET BGPN1=+BGPNV
+14 SET BGPVALUE=$SELECT(BGPD2:"UP",1:"")_";"_$SELECT(BGPD1:"AC",1:"")_"|||"_$PIECE(BGPNV,U,2)_" "_$PIECE(BGPNV,U,3)
+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 V73.88;DURING "_BDATE_"-"_EDATE
SET E=$$START1^APCLDF(%,"BGPG(")
+4 IF $DATA(BGPG(1))
QUIT 1_U_$$DATE^BGP1UTL($PIECE(BGPG(1),U))_U_"V73.88"
+5 SET %=P_"^LAST DX V73.98;DURING "_BDATE_"-"_EDATE
SET E=$$START1^APCLDF(%,"BGPG(")
+6 IF $DATA(BGPG(1))
QUIT 1_U_"POV V73.88"_U_$$DATE^BGP1UTL($PIECE(BGPG(1),U))
+7 ;check cpt taxonomy
+8 SET T=$ORDER(^ATXAX("B","BGP CHLAMYDIA CPTS",0))
+9 IF T
Begin DoDot:1
+10 SET X=$$CPT^BGP1DU(P,BDATE,EDATE,T,6)
IF X]""
QUIT
+11 SET X=$$TRAN^BGP1DU(P,BDATE,EDATE,T,6)
End DoDot:1
IF X
QUIT 1_U_"CPT "_$PIECE(X,U,3)_U_$$DATE^BGP1UTL($PIECE(X,U,2))
+12 ;now get all loinc/taxonomy tests
+13 SET BGPC=""
+14 SET T=$ORDER(^ATXAX("B","BGP CHLAMYDIA LOINC CODES",0))
+15 SET BGPLT=$ORDER(^ATXLAB("B","BGP CHLAMYDIA TESTS TAX",0))
+16 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
+17 SET L=0
FOR
SET L=$ORDER(^AUPNVLAB("AE",P,D,L))
IF L'=+L!(BGPC)
QUIT
Begin DoDot:2
+18 SET X=0
FOR
SET X=$ORDER(^AUPNVLAB("AE",P,D,L,X))
IF X'=+X!(BGPC)
QUIT
Begin DoDot:3
+19 IF '$DATA(^AUPNVLAB(X,0))
QUIT
+20 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^BGP1UTL((9999999-D))
QUIT
+21 IF 'T
QUIT
+22 SET J=$PIECE($GET(^AUPNVLAB(X,11)),U,13)
IF J=""
QUIT
+23 IF '$$LOINC(J,T)
QUIT
+24 SET R=$PIECE(^AUPNVLAB(X,0),U,4)
+25 SET BGPC=1_U_"Lab Test "_$$VAL^XBDIQ1(9000010.09,X,.01)_U_$$DATE^BGP1UTL((9999999-D))
+26 QUIT
End DoDot:3
End DoDot:2
End DoDot:1
+27 IF BGPC
QUIT BGPC
+28 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
+29 SET L=0
FOR
SET L=$ORDER(^AUPNVMIC("AE",P,D,L))
IF L'=+L!(BGPC)
QUIT
Begin DoDot:2
+30 SET X=0
FOR
SET X=$ORDER(^AUPNVMIC("AE",P,D,L,X))
IF X'=+X!(BGPC)
QUIT
Begin DoDot:3
+31 IF '$DATA(^AUPNVMIC(X,0))
QUIT
+32 IF BGPLT
IF $PIECE(^AUPNVMIC(X,0),U)
IF $DATA(^ATXLAB(BGPLT,21,"B",$PIECE(^AUPNVMIC(X,0),U)))
SET BGPC=1_U_"v micro test"_U_$$DATE^BGP1UTL((9999999-D))
QUIT
+33 IF 'T
QUIT
+34 SET J=$PIECE($GET(^AUPNVMIC(X,11)),U,13)
IF J=""
QUIT
+35 IF '$$LOINC(J,T)
QUIT
+36 SET R=$PIECE(^AUPNVMIC(X,0),U,4)
+37 SET BGPC=1_U_"Micro Test "_$$VAL^XBDIQ1(9000010.25,X,.01)_U_$$DATE^BGP1UTL((9999999-D))
+38 QUIT
End DoDot:3
End DoDot:2
End DoDot:1
+39 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 ""
