- BGP4D53 ; IHS/CMI/LAB - measure calc ;
- ;;14.1;IHS CLINICAL REPORTING;;MAY 29, 2014;Build 114
- ;\
- 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^BGP4UTL($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^BGP4UTL($P(X,U,2))
- .S X=$$CPT^BGP4DU(P,BDATE,EDATE,T,6) I X]"" Q
- .S X=$$TRAN^BGP4DU(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^BGP4UTL((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^BGP4UTL((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^BGP4UTL((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^BGP4UTL((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 ""
- BGP4D53 ; IHS/CMI/LAB - measure calc ;
- +1 ;;14.1;IHS CLINICAL REPORTING;;MAY 29, 2014;Build 114
- +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^BGP4UTL($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^BGP4DU(P,BDATE,EDATE,T,6)
- IF X]""
- QUIT
- +9 SET X=$$TRAN^BGP4DU(P,BDATE,EDATE,T,6)
- End DoDot:1
- IF X
- QUIT 1_U_"CPT "_$PIECE(X,U,3)_U_$$DATE^BGP4UTL($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^BGP4UTL((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^BGP4UTL((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^BGP4UTL((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^BGP4UTL((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 ""
