- BGP3D812 ; IHS/CMI/LAB - measure C 03 Jul 2010 7:05 AM ; 21 Mar 2013 5:25 PM
- ;;13.0;IHS CLINICAL REPORTING;**1**;NOV 20, 2012;Build 7
- ;
- HIVTEST1(P,BDATE,EDATE) ;EP
- 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
- ;FIRST TABLE ALL TESTS IN HIV-1 AND HIV-2
- S T=$O(^ATXAX("B","BGP HIV-1 TEST LOINC CODES",0))
- S BGPLT=$O(^ATXLAB("B","BGP HIV-1 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))
- ...;Q:$P(^AUPNVLAB(X,0),U,4)=""
- ...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))) D Q
- ....S BGPC=BGPC+1,BGPC(BGPC)=1_U_$$DATE^BGP3UTL((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^BGP3D21(J,T)
- ...S BGPC=BGPC+1,BGPC(BGPC)=1_U_$$DATE^BGP3UTL((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
- ..Q
- S T=$O(^ATXAX("B","BGP HIV-2 TEST LOINC CODES",0))
- S BGPLT=$O(^ATXLAB("B","BGP HIV-2 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))
- ...;Q:$P(^AUPNVLAB(X,0),U,4)=""
- ...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))) D Q
- ....S BGPC=BGPC+1,BGPC(BGPC)=1_U_$$DATE^BGP3UTL((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^BGP3D21(J,T)
- ...S BGPC=BGPC+1,BGPC(BGPC)=1_U_$$DATE^BGP3UTL((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
- ..Q
- I BGPC=0 D ;check for cpt code
- .S T=$O(^ATXAX("B","BGP CPT HIV TESTS",0))
- .I T D
- ..;
- ..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^ATXCHK($P(^AUPNVCPT(X,0),U),T,1) I '$D(BGPA((9999999-$P(ED,".")))) S BGPC=BGPC+1,BGPC(BGPC)=1_U_$$DATE^BGP3UTL((9999999-$P(ED,".")))_" CPT "_$$VAL^XBDIQ1(9000010.18,X,.01)_U_U_$$VD^APCLV(V),BGPA((9999999-$P(ED,".")))=""
- I BGPC=0 Q "" ;not tests done
- NEW POS,NEG,NR
- S POS="",NEG="",NR="",%=""
- S BGPC=0 F S BGPC=$O(BGPC(BGPC)) Q:BGPC'=+BGPC!(%]"") D
- .S X=$P(BGPC(BGPC),U,3) ;result
- .S D=$P(BGPC(BGPC),U,4) ;date
- .S X=$$UP^XLFSTR(X)
- .I X="",D S G=$$HIVDX1^BGP3D8(DFN,BGPED,D) I G S %=1_U_"Positive HIV DX "_$P(G,U,2)_" on "_$$DATE^BGP3UTL($P(G,U)) Q
- .I X="P"!(X="POSITIVE")!(X="POS")!(X="R")!(X="REACTIVE")!(X="REPEATEDLY REACTIVE")!(X="+")!(X[">") S %=1_U_"Positive Result: "_X_" on "_$$DATE^BGP3UTL(9999999-D) ;positive result
- .;I X="N"!(X="NEGATIVE")!(X="NEG")!(X="NR")!(X="NON REACTIVE")!(X="NON-REACTIVE")!(X="-") S BGPN6=1,BGPDAFT="Negative"
- I %]"" Q % ;has a positive result
- ;now look for negative
- S POS="",NEG="",NR="",%=""
- S BGPC=0 F S BGPC=$O(BGPC(BGPC)) Q:BGPC'=+BGPC!(%]"") D
- .S X=$P(BGPC(BGPC),U,3) ;result
- .S D=$P(BGPC(BGPC),U,4) ;date
- .S X=$$UP^XLFSTR(X)
- .I X="N"!(X="NEGATIVE")!(X="NEG")!(X="NR")!(X="NON REACTIVE")!(X="NON-REACTIVE")!(X="-") S %=2_U_"Negative Result: "_X_" on "_$$DATE^BGP3UTL(9999999-D)
- .;if neg result check for diagnosis after it
- .I $E(%)=2 S G=$$HIVDX1^BGP3D8(DFN,BGPED,D) I G S %=1_U_"Positive HIV DX "_$P(G,U,2)_" on "_$$DATE^BGP3UTL($P(G,U)) Q
- I %]"" Q %
- ;find last no result
- S POS="",NEG="",NR="",%=""
- S BGPC=0 F S BGPC=$O(BGPC(BGPC)) Q:BGPC'=+BGPC!(%]"") D
- .S X=$P(BGPC(BGPC),U,3) ;result
- .S D=$P(BGPC(BGPC),U,4) ;date
- .S %=3_U_"No Result: "_X_" on "_$$DATE^BGP3UTL(9999999-D)
- Q %
- ;
- 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 ""
- BGP3D812 ; IHS/CMI/LAB - measure C 03 Jul 2010 7:05 AM ; 21 Mar 2013 5:25 PM
- +1 ;;13.0;IHS CLINICAL REPORTING;**1**;NOV 20, 2012;Build 7
- +2 ;
- HIVTEST1(P,BDATE,EDATE) ;EP
- +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 ;FIRST TABLE ALL TESTS IN HIV-1 AND HIV-2
- +6 SET T=$ORDER(^ATXAX("B","BGP HIV-1 TEST LOINC CODES",0))
- +7 SET BGPLT=$ORDER(^ATXLAB("B","BGP HIV-1 TEST TAX",0))
- +8 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
- +9 SET L=0
- FOR
- SET L=$ORDER(^AUPNVLAB("AE",P,D,L))
- IF L'=+L
- QUIT
- Begin DoDot:2
- +10 SET X=0
- FOR
- SET X=$ORDER(^AUPNVLAB("AE",P,D,L,X))
- IF X'=+X
- QUIT
- Begin DoDot:3
- +11 IF '$DATA(^AUPNVLAB(X,0))
- QUIT
- +12 ;Q:$P(^AUPNVLAB(X,0),U,4)=""
- +13 SET V=$PIECE(^AUPNVLAB(X,0),U,3)
- +14 IF BGPLT
- IF $PIECE(^AUPNVLAB(X,0),U)
- IF $DATA(^ATXLAB(BGPLT,21,"B",$PIECE(^AUPNVLAB(X,0),U)))
- Begin DoDot:4
- +15 SET BGPC=BGPC+1
- SET BGPC(BGPC)=1_U_$$DATE^BGP3UTL((9999999-D))_" Lab"_U_$PIECE(^AUPNVLAB(X,0),U,4)_U_D
- SET BGPA((9999999-D))=""
- QUIT
- End DoDot:4
- QUIT
- +16 IF 'T
- QUIT
- +17 SET J=$PIECE($GET(^AUPNVLAB(X,11)),U,13)
- IF J=""
- QUIT
- +18 IF '$$LOINC^BGP3D21(J,T)
- QUIT
- +19 SET BGPC=BGPC+1
- SET BGPC(BGPC)=1_U_$$DATE^BGP3UTL((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))=""
- +20 QUIT
- End DoDot:3
- +21 QUIT
- End DoDot:2
- End DoDot:1
- +22 SET T=$ORDER(^ATXAX("B","BGP HIV-2 TEST LOINC CODES",0))
- +23 SET BGPLT=$ORDER(^ATXLAB("B","BGP HIV-2 TEST TAX",0))
- +24 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
- +25 SET L=0
- FOR
- SET L=$ORDER(^AUPNVLAB("AE",P,D,L))
- IF L'=+L
- QUIT
- Begin DoDot:2
- +26 SET X=0
- FOR
- SET X=$ORDER(^AUPNVLAB("AE",P,D,L,X))
- IF X'=+X
- QUIT
- Begin DoDot:3
- +27 IF '$DATA(^AUPNVLAB(X,0))
- QUIT
- +28 ;Q:$P(^AUPNVLAB(X,0),U,4)=""
- +29 SET V=$PIECE(^AUPNVLAB(X,0),U,3)
- +30 IF BGPLT
- IF $PIECE(^AUPNVLAB(X,0),U)
- IF $DATA(^ATXLAB(BGPLT,21,"B",$PIECE(^AUPNVLAB(X,0),U)))
- Begin DoDot:4
- +31 SET BGPC=BGPC+1
- SET BGPC(BGPC)=1_U_$$DATE^BGP3UTL((9999999-D))_" Lab"_U_$PIECE(^AUPNVLAB(X,0),U,4)_U_D
- SET BGPA((9999999-D))=""
- QUIT
- End DoDot:4
- QUIT
- +32 IF 'T
- QUIT
- +33 SET J=$PIECE($GET(^AUPNVLAB(X,11)),U,13)
- IF J=""
- QUIT
- +34 IF '$$LOINC^BGP3D21(J,T)
- QUIT
- +35 SET BGPC=BGPC+1
- SET BGPC(BGPC)=1_U_$$DATE^BGP3UTL((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))=""
- +36 QUIT
- End DoDot:3
- +37 QUIT
- End DoDot:2
- End DoDot:1
- +38 ;check for cpt code
- IF BGPC=0
- Begin DoDot:1
- +39 SET T=$ORDER(^ATXAX("B","BGP CPT HIV TESTS",0))
- +40 IF T
- Begin DoDot:2
- +41 ;
- +42 SET ED=(9999999-EDATE)
- SET BD=9999999-BDATE
- SET G=0
- +43 FOR
- SET ED=$ORDER(^AUPNVSIT("AA",P,ED))
- IF ED=""!($PIECE(ED,".")>BD)
- QUIT
- Begin DoDot:3
- +44 SET V=0
- FOR
- SET V=$ORDER(^AUPNVSIT("AA",P,ED,V))
- IF V'=+V
- QUIT
- Begin DoDot:4
- +45 IF '$DATA(^AUPNVSIT(V,0))
- QUIT
- +46 IF '$DATA(^AUPNVCPT("AD",V))
- QUIT
- +47 SET X=0
- FOR
- SET X=$ORDER(^AUPNVCPT("AD",V,X))
- IF X'=+X
- QUIT
- Begin DoDot:5
- +48 IF $$ICD^ATXCHK($PIECE(^AUPNVCPT(X,0),U),T,1)
- IF '$DATA(BGPA((9999999-$PIECE(ED,"."))))
- SET BGPC=BGPC+1
- SET BGPC(BGPC)=1_U_$$DATE^BGP3UTL((9999999-$PIECE(ED,".")))_" CPT "_$$VAL^XBDIQ1(9000010.18,X,.01)_U_U_$$VD^APCLV(V)
- SET BGPA((9999999-$PIECE(ED,".")))=""
- End DoDot:5
- End DoDot:4
- End DoDot:3
- End DoDot:2
- End DoDot:1
- +49 ;not tests done
- IF BGPC=0
- QUIT ""
- +50 NEW POS,NEG,NR
- +51 SET POS=""
- SET NEG=""
- SET NR=""
- SET %=""
- +52 SET BGPC=0
- FOR
- SET BGPC=$ORDER(BGPC(BGPC))
- IF BGPC'=+BGPC!(%]"")
- QUIT
- Begin DoDot:1
- +53 ;result
- SET X=$PIECE(BGPC(BGPC),U,3)
- +54 ;date
- SET D=$PIECE(BGPC(BGPC),U,4)
- +55 SET X=$$UP^XLFSTR(X)
- +56 IF X=""
- IF D
- SET G=$$HIVDX1^BGP3D8(DFN,BGPED,D)
- IF G
- SET %=1_U_"Positive HIV DX "_$PIECE(G,U,2)_" on "_$$DATE^BGP3UTL($PIECE(G,U))
- QUIT
- +57 ;positive result
- IF X="P"!(X="POSITIVE")!(X="POS")!(X="R")!(X="REACTIVE")!(X="REPEATEDLY REACTIVE")!(X="+")!(X[">")
- SET %=1_U_"Positive Result: "_X_" on "_$$DATE^BGP3UTL(9999999-D)
- +58 ;I X="N"!(X="NEGATIVE")!(X="NEG")!(X="NR")!(X="NON REACTIVE")!(X="NON-REACTIVE")!(X="-") S BGPN6=1,BGPDAFT="Negative"
- End DoDot:1
- +59 ;has a positive result
- IF %]""
- QUIT %
- +60 ;now look for negative
- +61 SET POS=""
- SET NEG=""
- SET NR=""
- SET %=""
- +62 SET BGPC=0
- FOR
- SET BGPC=$ORDER(BGPC(BGPC))
- IF BGPC'=+BGPC!(%]"")
- QUIT
- Begin DoDot:1
- +63 ;result
- SET X=$PIECE(BGPC(BGPC),U,3)
- +64 ;date
- SET D=$PIECE(BGPC(BGPC),U,4)
- +65 SET X=$$UP^XLFSTR(X)
- +66 IF X="N"!(X="NEGATIVE")!(X="NEG")!(X="NR")!(X="NON REACTIVE")!(X="NON-REACTIVE")!(X="-")
- SET %=2_U_"Negative Result: "_X_" on "_$$DATE^BGP3UTL(9999999-D)
- +67 ;if neg result check for diagnosis after it
- +68 IF $EXTRACT(%)=2
- SET G=$$HIVDX1^BGP3D8(DFN,BGPED,D)
- IF G
- SET %=1_U_"Positive HIV DX "_$PIECE(G,U,2)_" on "_$$DATE^BGP3UTL($PIECE(G,U))
- QUIT
- End DoDot:1
- +69 IF %]""
- QUIT %
- +70 ;find last no result
- +71 SET POS=""
- SET NEG=""
- SET NR=""
- SET %=""
- +72 SET BGPC=0
- FOR
- SET BGPC=$ORDER(BGPC(BGPC))
- IF BGPC'=+BGPC!(%]"")
- QUIT
- Begin DoDot:1
- +73 ;result
- SET X=$PIECE(BGPC(BGPC),U,3)
- +74 ;date
- SET D=$PIECE(BGPC(BGPC),U,4)
- +75 SET %=3_U_"No Result: "_X_" on "_$$DATE^BGP3UTL(9999999-D)
- End DoDot:1
- +76 QUIT %
- +77 ;
- 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 ""
