BGP4D812 ; IHS/CMI/LAB - measure C 03 Jul 2010 7:05 AM ; 21 Mar 2014 5:25 PM
;;14.1;IHS CLINICAL REPORTING;;MAY 29, 2014;Build 114
;
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^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
..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^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
..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^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_$$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^BGP4D8(DFN,BGPED,D) I G S %=1_U_"Positive HIV DX "_$P(G,U,2)_" on "_$$DATE^BGP4UTL($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^BGP4UTL(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^BGP4UTL(9999999-D)
.;if neg result check for diagnosis after it
.I $E(%)=2 S G=$$HIVDX1^BGP4D8(DFN,BGPED,D) I G S %=1_U_"Positive HIV DX "_$P(G,U,2)_" on "_$$DATE^BGP4UTL($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^BGP4UTL(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 ""
CD4(P,BDATE,EDATE) ;EP
K BGPG
S %=P_"^LAST LAB [BGP CD4 TAX;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE),E=$$START1^APCLDF(%,"BGPG(")
I $D(BGPG(1)) Q 1_U_$P(BGPG(1),U,1)_U_$P(BGPG(1),U,2)
S E=+$$CODEN^ICPTCOD(86361),%=$$CPTI^BGP4DU(P,BDATE,EDATE,E) I %]"" Q 1_U_$P(%,U,2)_"^86361"
S E=+$$CODEN^ICPTCOD(86360),%=$$CPTI^BGP4DU(P,BDATE,EDATE,E) I %]"" Q 1_U_$P(%,U,2)_"^86360"
S E=+$$CODEN^ICPTCOD(86359),%=$$CPTI^BGP4DU(P,BDATE,EDATE,E) I %]"" Q 1_U_$P(%,U,2)_"^86359"
;
S E=+$$CODEN^ICPTCOD(86361),%=$$TRANI^BGP4DU(P,BDATE,EDATE,E) I %]"" Q 1_U_$P(%,U,2)_"^86361 TRAN"
S E=+$$CODEN^ICPTCOD(86360),%=$$TRANI^BGP4DU(P,BDATE,EDATE,E) I %]"" Q 1_U_$P(%,U,2)_"^86360 TRAN"
S E=+$$CODEN^ICPTCOD(86359),%=$$TRANI^BGP4DU(P,BDATE,EDATE,E) I %]"" Q 1_U_$P(%,U,2)_"^86359 TRAN"
;
K ^TMP($J,"A")
S A="^TMP($J,""A"",",%=P_"^ALL LAB;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE),E=$$START1^APCLDF(%,A)
I '$D(^TMP($J,"A",1)) Q ""
;
S T=$O(^ATXAX("B","BGP CD4 LOINC CODES",0))
I 'T Q ""
S (X,G)=0 F S X=$O(^TMP($J,"A",X)) Q:X'=+X!(G) S I=+$P(^TMP($J,"A",X),U,4) I $P($G(^AUPNVLAB(I,11)),U,13)]"" D
.S J=$P(^AUPNVLAB(I,11),U,13)
.I $$LOINC^BGP4D21(J,T) S G=1_U_$$VD^APCLV($P(^AUPNVLAB(I,0),U,3))_U_$$VAL^XBDIQ1(9000010.09,I,.01)
Q G
BGP4D812 ; IHS/CMI/LAB - measure C 03 Jul 2010 7:05 AM ; 21 Mar 2014 5:25 PM
+1 ;;14.1;IHS CLINICAL REPORTING;;MAY 29, 2014;Build 114
+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^BGP4UTL((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^BGP4D21(J,T)
QUIT
+19 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))=""
+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^BGP4UTL((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^BGP4D21(J,T)
QUIT
+35 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))=""
+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^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_$$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^BGP4D8(DFN,BGPED,D)
IF G
SET %=1_U_"Positive HIV DX "_$PIECE(G,U,2)_" on "_$$DATE^BGP4UTL($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^BGP4UTL(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^BGP4UTL(9999999-D)
+67 ;if neg result check for diagnosis after it
+68 IF $EXTRACT(%)=2
SET G=$$HIVDX1^BGP4D8(DFN,BGPED,D)
IF G
SET %=1_U_"Positive HIV DX "_$PIECE(G,U,2)_" on "_$$DATE^BGP4UTL($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^BGP4UTL(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 ""
CD4(P,BDATE,EDATE) ;EP
+1 KILL BGPG
+2 SET %=P_"^LAST LAB [BGP CD4 TAX;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(%,"BGPG(")
+3 IF $DATA(BGPG(1))
QUIT 1_U_$PIECE(BGPG(1),U,1)_U_$PIECE(BGPG(1),U,2)
+4 SET E=+$$CODEN^ICPTCOD(86361)
SET %=$$CPTI^BGP4DU(P,BDATE,EDATE,E)
IF %]""
QUIT 1_U_$PIECE(%,U,2)_"^86361"
+5 SET E=+$$CODEN^ICPTCOD(86360)
SET %=$$CPTI^BGP4DU(P,BDATE,EDATE,E)
IF %]""
QUIT 1_U_$PIECE(%,U,2)_"^86360"
+6 SET E=+$$CODEN^ICPTCOD(86359)
SET %=$$CPTI^BGP4DU(P,BDATE,EDATE,E)
IF %]""
QUIT 1_U_$PIECE(%,U,2)_"^86359"
+7 ;
+8 SET E=+$$CODEN^ICPTCOD(86361)
SET %=$$TRANI^BGP4DU(P,BDATE,EDATE,E)
IF %]""
QUIT 1_U_$PIECE(%,U,2)_"^86361 TRAN"
+9 SET E=+$$CODEN^ICPTCOD(86360)
SET %=$$TRANI^BGP4DU(P,BDATE,EDATE,E)
IF %]""
QUIT 1_U_$PIECE(%,U,2)_"^86360 TRAN"
+10 SET E=+$$CODEN^ICPTCOD(86359)
SET %=$$TRANI^BGP4DU(P,BDATE,EDATE,E)
IF %]""
QUIT 1_U_$PIECE(%,U,2)_"^86359 TRAN"
+11 ;
+12 KILL ^TMP($JOB,"A")
+13 SET A="^TMP($J,""A"","
SET %=P_"^ALL LAB;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(%,A)
+14 IF '$DATA(^TMP($JOB,"A",1))
QUIT ""
+15 ;
+16 SET T=$ORDER(^ATXAX("B","BGP CD4 LOINC CODES",0))
+17 IF 'T
QUIT ""
+18 SET (X,G)=0
FOR
SET X=$ORDER(^TMP($JOB,"A",X))
IF X'=+X!(G)
QUIT
SET I=+$PIECE(^TMP($JOB,"A",X),U,4)
IF $PIECE($GET(^AUPNVLAB(I,11)),U,13)]""
Begin DoDot:1
+19 SET J=$PIECE(^AUPNVLAB(I,11),U,13)
+20 IF $$LOINC^BGP4D21(J,T)
SET G=1_U_$$VD^APCLV($PIECE(^AUPNVLAB(I,0),U,3))_U_$$VAL^XBDIQ1(9000010.09,I,.01)
End DoDot:1
+21 QUIT G
