APCHS9B5 ; IHS/CMI/LAB - DIABETIC CARE SUMMARY SUPPLEMENT ; 20 Sep 2010 1:37 PM
;;2.0;IHS PCC SUITE;**5,11**;MAY 14, 2009;Build 58
;
;
MAM ;EP
K APCHSDAT,APCHSTEX
S APCHSDAT=""
;apchsdat=date of last, apchstex is display
Q:$P(^DPT(APCHSPAT,0),U,2)="M"
K APCHSEXD,APCHSDF1
S APCHSTXN=0
S APCHSDAT=$$LASTMAM^APCLAPI1(APCHSPAT)_"^"_$$MAMREF^APCHS9B4(APCHSPAT,APCHSDAT)
I $$VERSION^XPDUTL("BW")>2.9 G MAMA
S APCHSBWR=0 S:$D(X) APCHSAVX=X S X="BWUTL1" X ^%ZOSF("TEST") S:$D(APCHSAVX) X=APCHSAVX K APCHSAVX I $T S APCHSBWR=1
I APCHSBWR,$D(^BWP(APCHSPAT,0)) S APCHSTXN=APCHSTXN+1,APCHSTEX(APCHSTXN)=$$BNEED^BWUTL1(APCHSPAT) I APCHSTEX(1)="UNKNOWN" K APCHSTEX(1) S APCHSTXN=0
I $O(APCHSTEX("")) Q
MAMA ;
Q:$$AGE^AUPNPAT(APCHSPAT,DT,"Y")<50
Q:$$AGE^AUPNPAT(APCHSPAT,DT,"Y")>69
K APCHSTXN
S APCHSINT=365
I $P(APCHSDAT,U,2)]"" S APCHSTEX(1)=$P(APCHSDAT,U,2),APCHSDAT=$P(APCHSDAT,U) Q
I APCHSDAT="" S APCHSTEX(1)="MAY BE DUE NOW" Q
K APCHSBWR
S X1=APCHSDAT,X2=APCHSINT D C^%DTC S Y=X X APCHSCVD S APCHSTEX(1)="Next Due: "_Y,APCHSWD=Y
S X2=APCHSDAT,X1=DT D ^%DTC I X>APCHSINT S APCHSTEX(1)=$S('$D(APCHSDD):"MAY BE DUE NOW (WAS DUE "_APCHSWD_")",1:"MAY BE DUE NOW")
Q
;
;
PAP ;EP
K APCHSDAT,APCHSTEX,APCHSTP
S APCHSDAT=""
;apchsdat=date of last, apchstex is display
Q:$$AGE^AUPNPAT(APCHSPAT,DT,"Y")<18!($P(^DPT(APCHSPAT,0),U,2)="M")
K APCHSEXD,APCHSDF1
S APCHSTXN=0
I $$VERSION^XPDUTL("BW")>2.9 G PAPA
S APCHSBWR=0 S:$D(X) APCHSAVX=X S X="BWUTL1" X ^%ZOSF("TEST") S:$D(APCHSAVX) X=APCHSAVX K APCHSAVX I $T S APCHSBWR=1
I APCHSBWR,$D(^BWP(APCHSPAT,0)) S APCHSTXN=APCHSTXN+1,APCHSTEX(APCHSTXN)=$$CNEED^BWUTL1(APCHSPAT) I APCHSTEX(1)="UNKNOWN" K APCHSTEX(1) S APCHSTXN=0
PAPA ;
S APCHSTP=$$HYSTER^APCHS9B4(APCHSPAT,DT)
I APCHSTP]"" S APCHSTXN=APCHSTXN+1,APCHSTEX(APCHSTXN)="Pt had hysterectomy. Pap may be necessary",APCHSTXN=APCHSTXN+1,APCHSTEX(APCHSTXN)="based on individual followup."
I $O(APCHSTEX("")) S APCHSDAT="" 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^APCHSMU(IEN)_" on "_$$FMTE^XLFDT(DATE)
PNEU(P) ;EP
NEW APCHY,PNEU,X 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^APCHS9B3(APCHSPAT,9999999.14,$O(^AUTTIMM("C",$S($$BI:33,1:19),0)),$P($G(APCHY(1)),U))
I G]"" Q G
S G=$$REFDF^APCHS9B3(APCHSPAT,9999999.14,$O(^AUTTIMM("C",$S($$BI:109,1:19),0)),$P($G(APCHY(1)),U))
I G]"" Q G
S G=$$REFDF^APCHS9B3(APCHSPAT,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^APCHS9B3(APCHSPAT,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 APCHS,E,X
K APCHS
S X=P_"^LAST HEALTH [DM AUDIT TB HEALTH FACTORS" S E=$$START1^APCLDF(X,"APCHS(")
I $D(APCHS) 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 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) I $D(^AUPNPROB(X,0)),$P(^AUPNPROB(X,0),U,12)'="D" 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 APCHS S X=P_"^FIRST DX [SURVEILLANCE TUBERCULOSIS" S E=$$START1^APCLDF(X,"APCHS(")
I $D(APCHS(1)) Q "Known Positive PPD or Hx of TB (POV/DX "_$$FMTE^XLFDT($P(APCHS(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
APCHS9B5 ; IHS/CMI/LAB - DIABETIC CARE SUMMARY SUPPLEMENT ; 20 Sep 2010 1:37 PM
+1 ;;2.0;IHS PCC SUITE;**5,11**;MAY 14, 2009;Build 58
+2 ;
+3 ;
MAM ;EP
+1 KILL APCHSDAT,APCHSTEX
+2 SET APCHSDAT=""
+3 ;apchsdat=date of last, apchstex is display
+4 IF $PIECE(^DPT(APCHSPAT,0),U,2)="M"
QUIT
+5 KILL APCHSEXD,APCHSDF1
+6 SET APCHSTXN=0
+7 SET APCHSDAT=$$LASTMAM^APCLAPI1(APCHSPAT)_"^"_$$MAMREF^APCHS9B4(APCHSPAT,APCHSDAT)
+8 IF $$VERSION^XPDUTL("BW")>2.9
GOTO MAMA
+9 SET APCHSBWR=0
IF $DATA(X)
SET APCHSAVX=X
SET X="BWUTL1"
XECUTE ^%ZOSF("TEST")
IF $DATA(APCHSAVX)
SET X=APCHSAVX
KILL APCHSAVX
IF $TEST
SET APCHSBWR=1
+10 IF APCHSBWR
IF $DATA(^BWP(APCHSPAT,0))
SET APCHSTXN=APCHSTXN+1
SET APCHSTEX(APCHSTXN)=$$BNEED^BWUTL1(APCHSPAT)
IF APCHSTEX(1)="UNKNOWN"
KILL APCHSTEX(1)
SET APCHSTXN=0
+11 IF $ORDER(APCHSTEX(""))
QUIT
MAMA ;
+1 IF $$AGE^AUPNPAT(APCHSPAT,DT,"Y")<50
QUIT
+2 IF $$AGE^AUPNPAT(APCHSPAT,DT,"Y")>69
QUIT
+3 KILL APCHSTXN
+4 SET APCHSINT=365
+5 IF $PIECE(APCHSDAT,U,2)]""
SET APCHSTEX(1)=$PIECE(APCHSDAT,U,2)
SET APCHSDAT=$PIECE(APCHSDAT,U)
QUIT
+6 IF APCHSDAT=""
SET APCHSTEX(1)="MAY BE DUE NOW"
QUIT
+7 KILL APCHSBWR
+8 SET X1=APCHSDAT
SET X2=APCHSINT
DO C^%DTC
SET Y=X
XECUTE APCHSCVD
SET APCHSTEX(1)="Next Due: "_Y
SET APCHSWD=Y
+9 SET X2=APCHSDAT
SET X1=DT
DO ^%DTC
IF X>APCHSINT
SET APCHSTEX(1)=$SELECT('$DATA(APCHSDD):"MAY BE DUE NOW (WAS DUE "_APCHSWD_")",1:"MAY BE DUE NOW")
+10 QUIT
+11 ;
+12 ;
PAP ;EP
+1 KILL APCHSDAT,APCHSTEX,APCHSTP
+2 SET APCHSDAT=""
+3 ;apchsdat=date of last, apchstex is display
+4 IF $$AGE^AUPNPAT(APCHSPAT,DT,"Y")<18!($PIECE(^DPT(APCHSPAT,0),U,2)="M")
QUIT
+5 KILL APCHSEXD,APCHSDF1
+6 SET APCHSTXN=0
+7 IF $$VERSION^XPDUTL("BW")>2.9
GOTO PAPA
+8 SET APCHSBWR=0
IF $DATA(X)
SET APCHSAVX=X
SET X="BWUTL1"
XECUTE ^%ZOSF("TEST")
IF $DATA(APCHSAVX)
SET X=APCHSAVX
KILL APCHSAVX
IF $TEST
SET APCHSBWR=1
+9 IF APCHSBWR
IF $DATA(^BWP(APCHSPAT,0))
SET APCHSTXN=APCHSTXN+1
SET APCHSTEX(APCHSTXN)=$$CNEED^BWUTL1(APCHSPAT)
IF APCHSTEX(1)="UNKNOWN"
KILL APCHSTEX(1)
SET APCHSTXN=0
PAPA ;
+1 SET APCHSTP=$$HYSTER^APCHS9B4(APCHSPAT,DT)
+2 IF APCHSTP]""
SET APCHSTXN=APCHSTXN+1
SET APCHSTEX(APCHSTXN)="Pt had hysterectomy. Pap may be necessary"
SET APCHSTXN=APCHSTXN+1
SET APCHSTEX(APCHSTXN)="based on individual followup."
+3 IF $ORDER(APCHSTEX(""))
SET APCHSDAT=""
QUIT
+4 QUIT
+5 ;
+6 ;
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^APCHSMU(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
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^APCHS9B3(APCHSPAT,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^APCHS9B3(APCHSPAT,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^APCHS9B3(APCHSPAT,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^APCHS9B3(APCHSPAT,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 APCHS,E,X
+4 KILL APCHS
+5 SET X=P_"^LAST HEALTH [DM AUDIT TB HEALTH FACTORS"
SET E=$$START1^APCLDF(X,"APCHS(")
+6 IF $DATA(APCHS)
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
SET T=$ORDER(^ATXAX("B","SURVEILLANCE TUBERCULOSIS",0))
+2 IF 'T
QUIT ""
+3 NEW X,Y,I
SET (X,Y,I)=0
FOR
SET X=$ORDER(^AUPNPROB("AC",P,X))
IF X'=+X!(I)
QUIT
IF $DATA(^AUPNPROB(X,0))
IF $PIECE(^AUPNPROB(X,0),U,12)'="D"
SET Y=$PIECE(^AUPNPROB(X,0),U)
IF $$ICD^ATXAPI(Y,T,9)
SET I=1
+4 IF I
QUIT "Known Positive PPD or Hx of TB (Problem List DX)"
+5 ;check povs
+6 KILL APCHS
SET X=P_"^FIRST DX [SURVEILLANCE TUBERCULOSIS"
SET E=$$START1^APCLDF(X,"APCHS(")
+7 IF $DATA(APCHS(1))
QUIT "Known Positive PPD or Hx of TB (POV/DX "_$$FMTE^XLFDT($PIECE(APCHS(1),U))_")"
+8 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
