- 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