BHSDM5 ;IHS/CIA/MGH - Health Summary for Diabetic Supplement ;30-Nov-2015 10:24;DU
;;1.0;HEALTH SUMMARY COMPONENTS;**4,12**;Mar 17, 2006;Build 3
;===================================================================
;VA version of IHS components for supplemental summaries
;Taken from APCHS9B5
; IHS/TUCSON/LAB - DIABETIC CARE SUMMARY SUPPLEMENT ; [ 02/19/03 7:44 AM ]
;;2.0;IHS RPMS/PCC Health Summary;**3,5,6,8,10,12**;JUN 24, 1997
;====================================================================
;
MAM ;EP
K BHSDAT,BHSTEX
N X1,X2
S BHSDAT=""
;BHSdat=date of last, BHStex is display
Q:$P(^DPT(BHSPAT,0),U,2)="M"
K BHSEXD,BHSDF1
S BHSTXN=0
S BHSDAT=$$LASTMAM^APCLAPI1(BHSPAT)_"^"_$$MAMREF^APCHS9B4(BHSPAT,BHSDAT)
I $$VERSION^XPDUTL("BW")>2.9 G MAMA
S BHSBWR=0 S:$D(X) BHSAVX=X S X="BWUTL1" X ^%ZOSF("TEST") S:$D(BHSAVX) X=BHSAVX K BHSAVX I $T S BHSBWR=1
I BHSBWR,$D(^BWP(BHSPAT,0)) S BHSTXN=BHSTXN+1,BHSTEX(BHSTXN)=$$BNEED^BWUTL1(BHSPAT) I BHSTEX(1)="UNKNOWN" K BHSTEX(1) S BHSTXN=0
I $O(BHSTEX("")) Q
MAMA ;
Q:$$AGE^AUPNPAT(BHSPAT,DT,"Y")<50
Q:$$AGE^AUPNPAT(BHSPAT,DT,"Y")>69
K BHSTXN
S BHSINT=365
I $P(BHSDAT,U,2)]"" S BHSTEX(1)=$P(BHSDAT,U,2),BHSDAT=$P(BHSDAT,U) Q
I BHSDAT="" S BHSTEX(1)="MAY BE DUE NOW" Q
K BHSBWR
S X1=BHSDAT,X2=BHSINT D C^%DTC D REGDT4^GMTSU S BHSTEX(1)="Next Due: "_X,BHSWD=X
S X2=BHSDAT,X1=DT D ^%DTC I X>BHSINT S BHSTEX(1)=$S('$D(BHSDD):"MAY BE DUE NOW (WAS DUE "_BHSWD_")",1:"MAY BE DUE NOW")
Q
;
;
PAP ;EP
K BHSDAT,BHSTEX,BHSTP
S BHSDAT=""
;BHSdat=date of last, BHStex is display
Q:$$AGE^AUPNPAT(BHSPAT,DT,"Y")<18!($P(^DPT(BHSPAT,0),U,2)="M")
K BHSEXD,BHSDF1
S BHSTXN=0
I $$VERSION^XPDUTL("BW")>2.9 G PAPA
S BHSBWR=0 S:$D(X) BHSAVX=X S X="BWUTL1" X ^%ZOSF("TEST") S:$D(BHSAVX) X=BHSAVX K BHSAVX I $T S BHSBWR=1
I BHSBWR,$D(^BWP(BHSPAT,0)) S BHSTXN=BHSTXN+1,BHSTEX(BHSTXN)=$$CNEED^BWUTL1(BHSPAT) I BHSTEX(1)="UNKNOWN" K BHSTEX(1) S BHSTXN=0
;
PAPA S BHSTP=$$HYSTER^BHSDM4(BHSPAT,DT)
I BHSTP]"" S BHSTXN=BHSTXN+1,BHSTEX(BHSTXN)="Pt had hysterectomy. Pap may be necessary",BHSTXN=BHSTXN+1,BHSTEX(BHSTXN)="based on individual followup."
I $O(BHSTEX("")) S BHSDAT="" Q
Q
;
;
ACE(P,D) ;EP - return date of last ACE iNHIBITOR
;IHS/CMI/LAB patch 3 - added this subroutine
;go through all v meds until 9999999-D and find all drugs with class CV800 or CV805
;if none found check taxonomy
I '$G(P) Q ""
I '$G(D) S D=0 ;if don't pass date look at all time
NEW V,I,%
S %=""
S I=0 F S I=$O(^AUPNVMED("AA",P,I)) Q:I'=+I!(%)!(I>(9999999-D)) D
.S V=0 F S V=$O(^AUPNVMED("AA",P,I,V)) Q:V'=+V I $D(^AUPNVMED(V,0)) S G=$P(^AUPNVMED(V,0),U) I $P($G(^PSDRUG(G,0)),U,2)="CV800"!($P($G(^PSDRUG(G,0)),U,2)="CV805") S %=V
I %]"" D Q %
.I $P(^AUPNVMED(%,0),U,8)="" S %="Yes - "_$$FMTE^XLFDT($P($P(^AUPNVSIT($P(^AUPNVMED(%,0),U,3),0),U),".")) Q
.I $P(^AUPNVMED(%,0),U,8)]"" S %="Discontinued - "_$$FMTE^XLFDT($P($P(^AUPNVSIT($P(^AUPNVMED(%,0),U,3),0),U),".")) Q
NEW T S T=$O(^ATXAX("B","DM AUDIT ACE INHIBITORS",0))
I 'T Q ""
S I=0 F S I=$O(^AUPNVMED("AA",P,I)) Q:I'=+I!(%)!(I>(9999999-D)) D
.S V=0 F S V=$O(^AUPNVMED("AA",P,I,V)) Q:V'=+V I $D(^AUPNVMED(V,0)) S G=$P(^AUPNVMED(V,0),U) I $D(^ATXAX(T,21,"B",G)) S %=V
I %]"" D Q %
.I $P(^AUPNVMED(%,0),U,8)="" S %="Yes - "_$$FMTE^XLFDT($P($P(^AUPNVSIT($P(^AUPNVMED(%,0),U,3),0),U),".")) Q
.I $P(^AUPNVMED(%,0),U,8)]"" S %="Discontinued - "_$$FMTE^XLFDT($P($P(^AUPNVSIT($P(^AUPNVMED(%,0),U,3),0),U),".")) Q
Q "No"
;
ASPREF(P) ;EP - CHECK FOR ASPIRIN NMI OR REFUSAL
I '$G(P) Q ""
NEW X,N,Z,D,IEN,DATE,DRUG
K X
S T=$O(^ATXAX("B","DM AUDIT ASPIRIN DRUGS",0))
I 'T Q ""
S (D,G)=0 F S D=$O(^AUPNPREF("AA",P,50,D)) Q:D'=+D!(G) D
.Q:'$D(^ATXAX(T,21,"B",D))
.S X=$O(^AUPNPREF("AA",P,50,D,0))
.S N=$O(^AUPNPREF("AA",P,50,D,X,0))
.S G=1,DATE=9999999-X,DRUG=D,IEN=N
I 'G Q ""
Q $$VAL^XBDIQ1(50,DRUG,.01)_" "_$$TYPEREF^BHSMU(IEN)_" on "_$$FMTE^XLFDT(DATE)
PNEU(P) ;EP
NEW APCHY,PNEU,X,C S %=P_"^LAST 2 IMMUNIZATION "_$S($$BI:33,1:19),E=$$START1^APCLDF(%,"APCHY(") ;IHS/CMI/LAB patch 3 - changed line to support new imm package
I $D(APCHY(1)) S PNEU(9999999-$P(APCHY(1),U))=""
I $D(APCHY(2)) S PNEU(9999999-$P(APCHY(2),U))=""
K APCHY S %=P_"^LAST 2 IMMUNIZATION 100",E=$$START1^APCLDF(%,"APCHY(")
I $D(APCHY(1)) S PNEU(9999999-$P(APCHY(1),U))=""
I $D(APCHY(2)) S PNEU(9999999-$P(APCHY(2),U))=""
K APCHY S %=P_"^LAST 2 IMMUNIZATION 109",E=$$START1^APCLDF(%,"APCHY(")
I $D(APCHY(1)) S PNEU(9999999-$P(APCHY(1),U))=""
I $D(APCHY(2)) S PNEU(9999999-$P(APCHY(2),U))=""
K APCHY S X=0,C=0 F S X=$O(PNEU(X)) Q:X'=+X!(C>2) S C=C+1,APCHY(C)=9999999-X
I $D(APCHY(1)) Q "Yes "_$$FMTE^XLFDT($P(APCHY(1),U))_" "_$$FMTE^XLFDT($P($G(APCHY(2)),U))
S G=$$REFDF^BHSDM3(BHSPAT,9999999.14,$O(^AUTTIMM("C",$S($$BI:33,1:19),0)),$P($G(APCHY(1)),U))
I G]"" Q G
S G=$$REFDF^BHSDM3(BHSPAT,9999999.14,$O(^AUTTIMM("C",$S($$BI:109,1:19),0)),$P($G(APCHY(1)),U))
I G]"" Q G
S G=$$REFDF^BHSDM3(BHSPAT,9999999.14,$O(^AUTTIMM("C",$S($$BI:100,1:19),0)),$P($G(APCHY(1)),U))
I G]"" Q G
Q "No"
PPD(P) ;EP
NEW APCHY,Y,X,%,E S %=P_"^LAST SKIN PPD",E=$$START1^APCLDF(%,"APCHY(")
I $D(APCHY(1)) Q $P(^AUPNVSK(+$P(APCHY(1),U,4),0),U,5)_" "_$$FMTE^XLFDT($P(APCHY(1),U))
K APCHY S X=P_"^LAST DX V74.1" S E=$$START1^APCLDF(X,"APCHY(")
I $D(APCHY(1)) Q $$FMTE^XLFDT($P(APCHY(1),U))_" (by Diagnosis)"
S G=$$REFDF^BHSDM3(BHSPAT,9999999.28,$O(^AUTTSK("B","PPD",0)))
I G]"" Q G
Q ""
PPDS(P) ;EP
;check for tb health factor, problem list, povs if and
;indication of pos ppd then return "Known Positive PPD"
NEW BHS,E,X
K BHS
S X=P_"^LAST HEALTH [DM AUDIT TB HEALTH FACTORS" S E=$$START1^APCLDF(X,"BHS(")
I $D(BHS) Q "Known Positive PPD or Hx of TB (Health Factor recorded)"
N T S T=$O(^ATXAX("B","DM AUDIT TB HEALTH FACTORS",0))
I 'T G PPDSPL
N G S G=0,X=0 F S X=$O(^AUPNHF("AA",P,X)) Q:X'=+X!(G) I $D(^ATXAX(T,21,"B",X)) S G=1
I G Q "Known Positive PPD or Hx of TB (Health Factor recorded)"
PPDSPL ;CHECK PL
N T,TAXARR
;IHS/MSC/MGH Moved taxonomy lookup out of loop
S TAXARR=""
S T=$O(^ATXAX("B","SURVEILLANCE TUBERCULOSIS",0))
I 'T Q ""
N X,Y,I S (X,Y,I)=0
F S X=$O(^AUPNPROB("AC",P,X)) Q:X'=+X!(I) D
.I $D(^AUPNPROB(X,0)) S Y=$P(^AUPNPROB(X,0),U) I $$ICD^ATXAPI(Y,T,9) S I=1
I I Q "Known Positive PPD or Hx of TB (Problem List DX)"
;check povs
K BHS S X=P_"^FIRST DX [SURVEILLANCE TUBERCULOSIS" S E=$$START1^APCLDF(X,"BHS(")
I $D(BHS(1)) Q "Known Positive PPD or Hx of TB (POV/DX "_$$FMTE^XLFDT($P(BHS(1),U))_")"
Q ""
BI() ;EP- check to see if using new imm package or not 1/5/1999 IHS/CMI/LAB
Q $S($O(^AUTTIMM(0))<100:0,1:1)
;end new subrotuine CMI/TUCSON/LAB
BHSDM5 ;IHS/CIA/MGH - Health Summary for Diabetic Supplement ;30-Nov-2015 10:24;DU
+1 ;;1.0;HEALTH SUMMARY COMPONENTS;**4,12**;Mar 17, 2006;Build 3
+2 ;===================================================================
+3 ;VA version of IHS components for supplemental summaries
+4 ;Taken from APCHS9B5
+5 ; IHS/TUCSON/LAB - DIABETIC CARE SUMMARY SUPPLEMENT ; [ 02/19/03 7:44 AM ]
+6 ;;2.0;IHS RPMS/PCC Health Summary;**3,5,6,8,10,12**;JUN 24, 1997
+7 ;====================================================================
+8 ;
MAM ;EP
+1 KILL BHSDAT,BHSTEX
+2 NEW X1,X2
+3 SET BHSDAT=""
+4 ;BHSdat=date of last, BHStex is display
+5 IF $PIECE(^DPT(BHSPAT,0),U,2)="M"
QUIT
+6 KILL BHSEXD,BHSDF1
+7 SET BHSTXN=0
+8 SET BHSDAT=$$LASTMAM^APCLAPI1(BHSPAT)_"^"_$$MAMREF^APCHS9B4(BHSPAT,BHSDAT)
+9 IF $$VERSION^XPDUTL("BW")>2.9
GOTO MAMA
+10 SET BHSBWR=0
IF $DATA(X)
SET BHSAVX=X
SET X="BWUTL1"
XECUTE ^%ZOSF("TEST")
IF $DATA(BHSAVX)
SET X=BHSAVX
KILL BHSAVX
IF $TEST
SET BHSBWR=1
+11 IF BHSBWR
IF $DATA(^BWP(BHSPAT,0))
SET BHSTXN=BHSTXN+1
SET BHSTEX(BHSTXN)=$$BNEED^BWUTL1(BHSPAT)
IF BHSTEX(1)="UNKNOWN"
KILL BHSTEX(1)
SET BHSTXN=0
+12 IF $ORDER(BHSTEX(""))
QUIT
MAMA ;
+1 IF $$AGE^AUPNPAT(BHSPAT,DT,"Y")<50
QUIT
+2 IF $$AGE^AUPNPAT(BHSPAT,DT,"Y")>69
QUIT
+3 KILL BHSTXN
+4 SET BHSINT=365
+5 IF $PIECE(BHSDAT,U,2)]""
SET BHSTEX(1)=$PIECE(BHSDAT,U,2)
SET BHSDAT=$PIECE(BHSDAT,U)
QUIT
+6 IF BHSDAT=""
SET BHSTEX(1)="MAY BE DUE NOW"
QUIT
+7 KILL BHSBWR
+8 SET X1=BHSDAT
SET X2=BHSINT
DO C^%DTC
DO REGDT4^GMTSU
SET BHSTEX(1)="Next Due: "_X
SET BHSWD=X
+9 SET X2=BHSDAT
SET X1=DT
DO ^%DTC
IF X>BHSINT
SET BHSTEX(1)=$SELECT('$DATA(BHSDD):"MAY BE DUE NOW (WAS DUE "_BHSWD_")",1:"MAY BE DUE NOW")
+10 QUIT
+11 ;
+12 ;
PAP ;EP
+1 KILL BHSDAT,BHSTEX,BHSTP
+2 SET BHSDAT=""
+3 ;BHSdat=date of last, BHStex is display
+4 IF $$AGE^AUPNPAT(BHSPAT,DT,"Y")<18!($PIECE(^DPT(BHSPAT,0),U,2)="M")
QUIT
+5 KILL BHSEXD,BHSDF1
+6 SET BHSTXN=0
+7 IF $$VERSION^XPDUTL("BW")>2.9
GOTO PAPA
+8 SET BHSBWR=0
IF $DATA(X)
SET BHSAVX=X
SET X="BWUTL1"
XECUTE ^%ZOSF("TEST")
IF $DATA(BHSAVX)
SET X=BHSAVX
KILL BHSAVX
IF $TEST
SET BHSBWR=1
+9 IF BHSBWR
IF $DATA(^BWP(BHSPAT,0))
SET BHSTXN=BHSTXN+1
SET BHSTEX(BHSTXN)=$$CNEED^BWUTL1(BHSPAT)
IF BHSTEX(1)="UNKNOWN"
KILL BHSTEX(1)
SET BHSTXN=0
+10 ;
PAPA SET BHSTP=$$HYSTER^BHSDM4(BHSPAT,DT)
+1 IF BHSTP]""
SET BHSTXN=BHSTXN+1
SET BHSTEX(BHSTXN)="Pt had hysterectomy. Pap may be necessary"
SET BHSTXN=BHSTXN+1
SET BHSTEX(BHSTXN)="based on individual followup."
+2 IF $ORDER(BHSTEX(""))
SET BHSDAT=""
QUIT
+3 QUIT
+4 ;
+5 ;
ACE(P,D) ;EP - return date of last ACE iNHIBITOR
+1 ;IHS/CMI/LAB patch 3 - added this subroutine
+2 ;go through all v meds until 9999999-D and find all drugs with class CV800 or CV805
+3 ;if none found check taxonomy
+4 IF '$GET(P)
QUIT ""
+5 ;if don't pass date look at all time
IF '$GET(D)
SET D=0
+6 NEW V,I,%
+7 SET %=""
+8 SET I=0
FOR
SET I=$ORDER(^AUPNVMED("AA",P,I))
IF I'=+I!(%)!(I>(9999999-D))
QUIT
Begin DoDot:1
+9 SET V=0
FOR
SET V=$ORDER(^AUPNVMED("AA",P,I,V))
IF V'=+V
QUIT
IF $DATA(^AUPNVMED(V,0))
SET G=$PIECE(^AUPNVMED(V,0),U)
IF $PIECE($GET(^PSDRUG(G,0)),U,2)="CV800"!($PIECE($GET(^PSDRUG(G,0)),U,2)="CV805")
SET %=V
End DoDot:1
+10 IF %]""
Begin DoDot:1
+11 IF $PIECE(^AUPNVMED(%,0),U,8)=""
SET %="Yes - "_$$FMTE^XLFDT($PIECE($PIECE(^AUPNVSIT($PIECE(^AUPNVMED(%,0),U,3),0),U),"."))
QUIT
+12 IF $PIECE(^AUPNVMED(%,0),U,8)]""
SET %="Discontinued - "_$$FMTE^XLFDT($PIECE($PIECE(^AUPNVSIT($PIECE(^AUPNVMED(%,0),U,3),0),U),"."))
QUIT
End DoDot:1
QUIT %
+13 NEW T
SET T=$ORDER(^ATXAX("B","DM AUDIT ACE INHIBITORS",0))
+14 IF 'T
QUIT ""
+15 SET I=0
FOR
SET I=$ORDER(^AUPNVMED("AA",P,I))
IF I'=+I!(%)!(I>(9999999-D))
QUIT
Begin DoDot:1
+16 SET V=0
FOR
SET V=$ORDER(^AUPNVMED("AA",P,I,V))
IF V'=+V
QUIT
IF $DATA(^AUPNVMED(V,0))
SET G=$PIECE(^AUPNVMED(V,0),U)
IF $DATA(^ATXAX(T,21,"B",G))
SET %=V
End DoDot:1
+17 IF %]""
Begin DoDot:1
+18 IF $PIECE(^AUPNVMED(%,0),U,8)=""
SET %="Yes - "_$$FMTE^XLFDT($PIECE($PIECE(^AUPNVSIT($PIECE(^AUPNVMED(%,0),U,3),0),U),"."))
QUIT
+19 IF $PIECE(^AUPNVMED(%,0),U,8)]""
SET %="Discontinued - "_$$FMTE^XLFDT($PIECE($PIECE(^AUPNVSIT($PIECE(^AUPNVMED(%,0),U,3),0),U),"."))
QUIT
End DoDot:1
QUIT %
+20 QUIT "No"
+21 ;
ASPREF(P) ;EP - CHECK FOR ASPIRIN NMI OR REFUSAL
+1 IF '$GET(P)
QUIT ""
+2 NEW X,N,Z,D,IEN,DATE,DRUG
+3 KILL X
+4 SET T=$ORDER(^ATXAX("B","DM AUDIT ASPIRIN DRUGS",0))
+5 IF 'T
QUIT ""
+6 SET (D,G)=0
FOR
SET D=$ORDER(^AUPNPREF("AA",P,50,D))
IF D'=+D!(G)
QUIT
Begin DoDot:1
+7 IF '$DATA(^ATXAX(T,21,"B",D))
QUIT
+8 SET X=$ORDER(^AUPNPREF("AA",P,50,D,0))
+9 SET N=$ORDER(^AUPNPREF("AA",P,50,D,X,0))
+10 SET G=1
SET DATE=9999999-X
SET DRUG=D
SET IEN=N
End DoDot:1
+11 IF 'G
QUIT ""
+12 QUIT $$VAL^XBDIQ1(50,DRUG,.01)_" "_$$TYPEREF^BHSMU(IEN)_" on "_$$FMTE^XLFDT(DATE)
PNEU(P) ;EP
+1 ;IHS/CMI/LAB patch 3 - changed line to support new imm package
NEW APCHY,PNEU,X,C
SET %=P_"^LAST 2 IMMUNIZATION "_$SELECT($$BI:33,1:19)
SET E=$$START1^APCLDF(%,"APCHY(")
+2 IF $DATA(APCHY(1))
SET PNEU(9999999-$PIECE(APCHY(1),U))=""
+3 IF $DATA(APCHY(2))
SET PNEU(9999999-$PIECE(APCHY(2),U))=""
+4 KILL APCHY
SET %=P_"^LAST 2 IMMUNIZATION 100"
SET E=$$START1^APCLDF(%,"APCHY(")
+5 IF $DATA(APCHY(1))
SET PNEU(9999999-$PIECE(APCHY(1),U))=""
+6 IF $DATA(APCHY(2))
SET PNEU(9999999-$PIECE(APCHY(2),U))=""
+7 KILL APCHY
SET %=P_"^LAST 2 IMMUNIZATION 109"
SET E=$$START1^APCLDF(%,"APCHY(")
+8 IF $DATA(APCHY(1))
SET PNEU(9999999-$PIECE(APCHY(1),U))=""
+9 IF $DATA(APCHY(2))
SET PNEU(9999999-$PIECE(APCHY(2),U))=""
+10 KILL APCHY
SET X=0
SET C=0
FOR
SET X=$ORDER(PNEU(X))
IF X'=+X!(C>2)
QUIT
SET C=C+1
SET APCHY(C)=9999999-X
+11 IF $DATA(APCHY(1))
QUIT "Yes "_$$FMTE^XLFDT($PIECE(APCHY(1),U))_" "_$$FMTE^XLFDT($PIECE($GET(APCHY(2)),U))
+12 SET G=$$REFDF^BHSDM3(BHSPAT,9999999.14,$ORDER(^AUTTIMM("C",$SELECT($$BI:33,1:19),0)),$PIECE($GET(APCHY(1)),U))
+13 IF G]""
QUIT G
+14 SET G=$$REFDF^BHSDM3(BHSPAT,9999999.14,$ORDER(^AUTTIMM("C",$SELECT($$BI:109,1:19),0)),$PIECE($GET(APCHY(1)),U))
+15 IF G]""
QUIT G
+16 SET G=$$REFDF^BHSDM3(BHSPAT,9999999.14,$ORDER(^AUTTIMM("C",$SELECT($$BI:100,1:19),0)),$PIECE($GET(APCHY(1)),U))
+17 IF G]""
QUIT G
+18 QUIT "No"
PPD(P) ;EP
+1 NEW APCHY,Y,X,%,E
SET %=P_"^LAST SKIN PPD"
SET E=$$START1^APCLDF(%,"APCHY(")
+2 IF $DATA(APCHY(1))
QUIT $PIECE(^AUPNVSK(+$PIECE(APCHY(1),U,4),0),U,5)_" "_$$FMTE^XLFDT($PIECE(APCHY(1),U))
+3 KILL APCHY
SET X=P_"^LAST DX V74.1"
SET E=$$START1^APCLDF(X,"APCHY(")
+4 IF $DATA(APCHY(1))
QUIT $$FMTE^XLFDT($PIECE(APCHY(1),U))_" (by Diagnosis)"
+5 SET G=$$REFDF^BHSDM3(BHSPAT,9999999.28,$ORDER(^AUTTSK("B","PPD",0)))
+6 IF G]""
QUIT G
+7 QUIT ""
PPDS(P) ;EP
+1 ;check for tb health factor, problem list, povs if and
+2 ;indication of pos ppd then return "Known Positive PPD"
+3 NEW BHS,E,X
+4 KILL BHS
+5 SET X=P_"^LAST HEALTH [DM AUDIT TB HEALTH FACTORS"
SET E=$$START1^APCLDF(X,"BHS(")
+6 IF $DATA(BHS)
QUIT "Known Positive PPD or Hx of TB (Health Factor recorded)"
+7 NEW T
SET T=$ORDER(^ATXAX("B","DM AUDIT TB HEALTH FACTORS",0))
+8 IF 'T
GOTO PPDSPL
+9 NEW G
SET G=0
SET X=0
FOR
SET X=$ORDER(^AUPNHF("AA",P,X))
IF X'=+X!(G)
QUIT
IF $DATA(^ATXAX(T,21,"B",X))
SET G=1
+10 IF G
QUIT "Known Positive PPD or Hx of TB (Health Factor recorded)"
PPDSPL ;CHECK PL
+1 NEW T,TAXARR
+2 ;IHS/MSC/MGH Moved taxonomy lookup out of loop
+3 SET TAXARR=""
+4 SET T=$ORDER(^ATXAX("B","SURVEILLANCE TUBERCULOSIS",0))
+5 IF 'T
QUIT ""
+6 NEW X,Y,I
SET (X,Y,I)=0
+7 FOR
SET X=$ORDER(^AUPNPROB("AC",P,X))
IF X'=+X!(I)
QUIT
Begin DoDot:1
+8 IF $DATA(^AUPNPROB(X,0))
SET Y=$PIECE(^AUPNPROB(X,0),U)
IF $$ICD^ATXAPI(Y,T,9)
SET I=1
End DoDot:1
+9 IF I
QUIT "Known Positive PPD or Hx of TB (Problem List DX)"
+10 ;check povs
+11 KILL BHS
SET X=P_"^FIRST DX [SURVEILLANCE TUBERCULOSIS"
SET E=$$START1^APCLDF(X,"BHS(")
+12 IF $DATA(BHS(1))
QUIT "Known Positive PPD or Hx of TB (POV/DX "_$$FMTE^XLFDT($PIECE(BHS(1),U))_")"
+13 QUIT ""
BI() ;EP- check to see if using new imm package or not 1/5/1999 IHS/CMI/LAB
+1 QUIT $SELECT($ORDER(^AUTTIMM(0))<100:0,1:1)
+2 ;end new subrotuine CMI/TUCSON/LAB
