Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: BGP6D812

BGP6D812.m

Go to the documentation of this file. 
  1. BGP6D812 ; IHS/CMI/LAB - measure C 03 Jul 2010 7:05 AM 21 Mar 2016 5:25 PM ; 
  1.  ;;16.1;IHS CLINICAL REPORTING;;MAR 22, 2016;Build 170
  1.  ;
  1. HIVTEST1(P,BDATE,EDATE) ;EP
  1.  NEW BGPC,BGPT,T,X,BGPLT,E,D,B,L,J,G,BGPT1,BGPA
  1.  NEW BD,ED,Y,D,V
  1.  K BGPA
  1.  S BGPC=0
  1.  ;FIRST TABLE ALL TESTS IN HIV-1 AND HIV-2
  1.  S T=$O(^ATXAX("B","BGP HIV-1 TEST LOINC CODES",0))
  1.  S BGPLT=$O(^ATXLAB("B","BGP HIV-1 TEST TAX",0))
  1.  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
  1.  .S L=0 F  S L=$O(^AUPNVLAB("AE",P,D,L)) Q:L'=+L  D
  1.  ..S X=0 F  S X=$O(^AUPNVLAB("AE",P,D,L,X)) Q:X'=+X  D
  1.  ...Q:'$D(^AUPNVLAB(X,0))
  1.  ...;Q:$P(^AUPNVLAB(X,0),U,4)=""
  1.  ...S V=$P(^AUPNVLAB(X,0),U,3)
  1.  ...I BGPLT,$P(^AUPNVLAB(X,0),U),$D(^ATXLAB(BGPLT,21,"B",$P(^AUPNVLAB(X,0),U))) D  Q
  1.  ....S BGPC=BGPC+1,BGPC(BGPC)=1_U_$$DATE^BGP6UTL((9999999-D))_" Lab"_U_$P(^AUPNVLAB(X,0),U,4)_U_D,BGPA((9999999-D))="" Q
  1.  ...Q:'T
  1.  ...S J=$P($G(^AUPNVLAB(X,11)),U,13) Q:J=""
  1.  ...Q:'$$LOINC^BGP6D21(J,T)
  1.  ...S BGPC=BGPC+1,BGPC(BGPC)=1_U_$$DATE^BGP6UTL((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))=""
  1.  ...Q
  1.  ..Q
  1.  S T=$O(^ATXAX("B","BGP HIV-2 TEST LOINC CODES",0))
  1.  S BGPLT=$O(^ATXLAB("B","BGP HIV-2 TEST TAX",0))
  1.  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
  1.  .S L=0 F  S L=$O(^AUPNVLAB("AE",P,D,L)) Q:L'=+L  D
  1.  ..S X=0 F  S X=$O(^AUPNVLAB("AE",P,D,L,X)) Q:X'=+X  D
  1.  ...Q:'$D(^AUPNVLAB(X,0))
  1.  ...;Q:$P(^AUPNVLAB(X,0),U,4)=""
  1.  ...S V=$P(^AUPNVLAB(X,0),U,3)
  1.  ...I BGPLT,$P(^AUPNVLAB(X,0),U),$D(^ATXLAB(BGPLT,21,"B",$P(^AUPNVLAB(X,0),U))) D  Q
  1.  ....S BGPC=BGPC+1,BGPC(BGPC)=1_U_$$DATE^BGP6UTL((9999999-D))_" Lab"_U_$P(^AUPNVLAB(X,0),U,4)_U_D,BGPA((9999999-D))="" Q
  1.  ...Q:'T
  1.  ...S J=$P($G(^AUPNVLAB(X,11)),U,13) Q:J=""
  1.  ...Q:'$$LOINC^BGP6D21(J,T)
  1.  ...S BGPC=BGPC+1,BGPC(BGPC)=1_U_$$DATE^BGP6UTL((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))=""
  1.  ...Q
  1.  ..Q
  1.  I BGPC=0 D  ;check for cpt code
  1.  .S T=$O(^ATXAX("B","BGP CPT HIV TESTS",0))
  1.  .I T D
  1.  ..;
  1.  ..S ED=(9999999-EDATE),BD=9999999-BDATE,G=0
  1.  ..F  S ED=$O(^AUPNVSIT("AA",P,ED)) Q:ED=""!($P(ED,".")>BD)  D
  1.  ...S V=0 F  S V=$O(^AUPNVSIT("AA",P,ED,V)) Q:V'=+V  D
  1.  ....Q:'$D(^AUPNVSIT(V,0))
  1.  ....Q:'$D(^AUPNVCPT("AD",V))
  1.  ....S X=0 F  S X=$O(^AUPNVCPT("AD",V,X)) Q:X'=+X  D
  1.  .....I $$ICD^BGP6UTL2($P(^AUPNVCPT(X,0),U),T,1) I '$D(BGPA((9999999-$P(ED,".")))) S BGPC=BGPC+1,BGPC(BGPC)=1_U_$$DATE^BGP6UTL((9999999-$P(ED,".")))_" CPT "_$$VAL^XBDIQ1(9000010.18,X,.01)_U_U_$$VD^APCLV(V),BGPA((9999999-$P(ED,".")))=""
  1.  I BGPC=0 Q ""  ;not tests done
  1.  NEW POS,NEG,NR
  1.  S POS="",NEG="",NR="",%=""
  1.  S BGPC=0 F  S BGPC=$O(BGPC(BGPC)) Q:BGPC'=+BGPC!(%]"")  D
  1.  .S X=$P(BGPC(BGPC),U,3)  ;result
  1.  .S D=$P(BGPC(BGPC),U,4)  ;date
  1.  .S X=$$UP^XLFSTR(X)
  1.  .I X="",D S G=$$HIVDX1^BGP6D8(DFN,BGPED,D) I G S %=1_U_"Positive HIV DX "_$P(G,U,2)_" on "_$$DATE^BGP6UTL($P(G,U)) Q
  1.  .I X="P"!(X="POSITIVE")!(X="POS")!(X="R")!(X="REACTIVE")!(X="REPEATEDLY REACTIVE")!(X="+")!(X[">") S %=1_U_"Positive Result: "_X_" on "_$$DATE^BGP6UTL(9999999-D)  ;positive result
  1.  .;I X="N"!(X="NEGATIVE")!(X="NEG")!(X="NR")!(X="NON REACTIVE")!(X="NON-REACTIVE")!(X="-") S BGPN6=1,BGPDAFT="Negative"
  1.  I %]"" Q %  ;has a positive result
  1.  ;now look for negative
  1.  S POS="",NEG="",NR="",%=""
  1.  S BGPC=0 F  S BGPC=$O(BGPC(BGPC)) Q:BGPC'=+BGPC!(%]"")  D
  1.  .S X=$P(BGPC(BGPC),U,3)  ;result
  1.  .S D=$P(BGPC(BGPC),U,4)  ;date
  1.  .S X=$$UP^XLFSTR(X)
  1.  .I X="N"!(X="NEGATIVE")!(X="NEG")!(X="NR")!(X="NON REACTIVE")!(X="NON-REACTIVE")!(X="-") S %=2_U_"Negative Result: "_X_" on "_$$DATE^BGP6UTL(9999999-D)
  1.  .;if neg result check for diagnosis after it
  1.  .I $E(%)=2 S G=$$HIVDX1^BGP6D8(DFN,BGPED,D) I G S %=1_U_"Positive HIV DX "_$P(G,U,2)_" on "_$$DATE^BGP6UTL($P(G,U)) Q
  1.  I %]"" Q %
  1.  ;find last no result
  1.  S POS="",NEG="",NR="",%=""
  1.  S BGPC=0 F  S BGPC=$O(BGPC(BGPC)) Q:BGPC'=+BGPC!(%]"")  D
  1.  .S X=$P(BGPC(BGPC),U,3)  ;result
  1.  .S D=$P(BGPC(BGPC),U,4)  ;date
  1.  .S %=3_U_"No Result: "_X_" on "_$$DATE^BGP6UTL(9999999-D)
  1.  Q %
  1.  ;
  1. LOINC(A,B) ;
  1.  NEW %
  1.  S %=$P($G(^LAB(95.3,A,9999999)),U,2)
  1.  I %]"",$D(^ATXAX(B,21,"B",%)) Q 1
  1.  S %=$P($G(^LAB(95.3,A,0)),U)_"-"_$P($G(^LAB(95.3,A,0)),U,15)
  1.  I $D(^ATXAX(B,21,"B",%)) Q 1
  1.  Q ""
  1. CD4(P,BDATE,EDATE) ;EP
  1.  K BGPG
  1.  S %=P_"^LAST LAB [BGP CD4 TAX;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE),E=$$START1^APCLDF(%,"BGPG(")
  1.  I $D(BGPG(1)) Q 1_U_$P(BGPG(1),U,1)_U_$P(BGPG(1),U,2)
  1.  S %=$$CPT^BGP6DU(P,BDATE,EDATE,$O(^ATXAX("B","BGP CD4 CPTS",0)),5) I %]"" Q 1_U_$P(%,U,1)_U_"CPT: "_$P(%,U,2)
  1.  S %=$$TRAN^BGP6DU(P,BDATE,EDATE,$O(^ATXAX("B","BGP CD4 CPTS",0)),5) I %]"" Q 1_U_$P(%,U,1)_U_"CPT: "_$P(%,U,2)
  1.  ;
  1.  ;S E=+$$CODEN^ICPTCOD(86361),%=$$CPTI^BGP6DU(P,BDATE,EDATE,E) I %]"" Q 1_U_$P(%,U,2)_"^86361"
  1.  ;S E=+$$CODEN^ICPTCOD(86360),%=$$CPTI^BGP6DU(P,BDATE,EDATE,E) I %]"" Q 1_U_$P(%,U,2)_"^86360"
  1.  ;S E=+$$CODEN^ICPTCOD(86359),%=$$CPTI^BGP6DU(P,BDATE,EDATE,E) I %]"" Q 1_U_$P(%,U,2)_"^86359"
  1.  ;
  1.  ;S E=+$$CODEN^ICPTCOD(86361),%=$$TRANI^BGP6DU(P,BDATE,EDATE,E) I %]"" Q 1_U_$P(%,U,2)_"^86361 TRAN"
  1.  ;S E=+$$CODEN^ICPTCOD(86360),%=$$TRANI^BGP6DU(P,BDATE,EDATE,E) I %]"" Q 1_U_$P(%,U,2)_"^86360 TRAN"
  1.  ;S E=+$$CODEN^ICPTCOD(86359),%=$$TRANI^BGP6DU(P,BDATE,EDATE,E) I %]"" Q 1_U_$P(%,U,2)_"^86359 TRAN"
  1.  ;
  1.  K ^TMP($J,"A")
  1.  S A="^TMP($J,""A"",",%=P_"^ALL LAB;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE),E=$$START1^APCLDF(%,A)
  1.  I '$D(^TMP($J,"A",1)) Q ""
  1.  ;
  1.  S T=$O(^ATXAX("B","BGP CD4 LOINC CODES",0))
  1.  I 'T Q ""
  1.  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
  1.  .S J=$P(^AUPNVLAB(I,11),U,13)
  1.  .I $$LOINC^BGP6D21(J,T) S G=1_U_$$VD^APCLV($P(^AUPNVLAB(I,0),U,3))_U_$$VAL^XBDIQ1(9000010.09,I,.01)
  1.  Q G