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

APCHS9B5.m

Go to the documentation of this file.
  1. 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
  1. ;
  1. ;
  1. MAM ;EP
  1. K APCHSDAT,APCHSTEX
  1. S APCHSDAT=""
  1. ;apchsdat=date of last, apchstex is display
  1. Q:$P(^DPT(APCHSPAT,0),U,2)="M"
  1. K APCHSEXD,APCHSDF1
  1. S APCHSTXN=0
  1. S APCHSDAT=$$LASTMAM^APCLAPI1(APCHSPAT)_"^"_$$MAMREF^APCHS9B4(APCHSPAT,APCHSDAT)
  1. I $$VERSION^XPDUTL("BW")>2.9 G MAMA
  1. 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
  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
  1. I $O(APCHSTEX("")) Q
  1. MAMA ;
  1. Q:$$AGE^AUPNPAT(APCHSPAT,DT,"Y")<50
  1. Q:$$AGE^AUPNPAT(APCHSPAT,DT,"Y")>69
  1. K APCHSTXN
  1. S APCHSINT=365
  1. I $P(APCHSDAT,U,2)]"" S APCHSTEX(1)=$P(APCHSDAT,U,2),APCHSDAT=$P(APCHSDAT,U) Q
  1. I APCHSDAT="" S APCHSTEX(1)="MAY BE DUE NOW" Q
  1. K APCHSBWR
  1. S X1=APCHSDAT,X2=APCHSINT D C^%DTC S Y=X X APCHSCVD S APCHSTEX(1)="Next Due: "_Y,APCHSWD=Y
  1. 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")
  1. Q
  1. ;
  1. ;
  1. PAP ;EP
  1. K APCHSDAT,APCHSTEX,APCHSTP
  1. S APCHSDAT=""
  1. ;apchsdat=date of last, apchstex is display
  1. Q:$$AGE^AUPNPAT(APCHSPAT,DT,"Y")<18!($P(^DPT(APCHSPAT,0),U,2)="M")
  1. K APCHSEXD,APCHSDF1
  1. S APCHSTXN=0
  1. I $$VERSION^XPDUTL("BW")>2.9 G PAPA
  1. 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
  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
  1. PAPA ;
  1. S APCHSTP=$$HYSTER^APCHS9B4(APCHSPAT,DT)
  1. I APCHSTP]"" S APCHSTXN=APCHSTXN+1,APCHSTEX(APCHSTXN)="Pt had hysterectomy. Pap may be necessary",APCHSTXN=APCHSTXN+1,APCHSTEX(APCHSTXN)="based on individual followup."
  1. I $O(APCHSTEX("")) S APCHSDAT="" Q
  1. Q
  1. ;
  1. ;
  1. ACE(P,D) ;EP - return date of last ACE iNHIBITOR
  1. ;IHS/CMI/LAB patch 3 - added this subroutine
  1. ;go through all v meds until 9999999-D and find all drugs with class CV800 or CV805
  1. ;if none found check taxonomy
  1. I '$G(P) Q ""
  1. I '$G(D) S D=0 ;if don't pass date look at all time
  1. NEW V,I,%
  1. S %=""
  1. S I=0 F S I=$O(^AUPNVMED("AA",P,I)) Q:I'=+I!(%)!(I>(9999999-D)) D
  1. .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
  1. I %]"" D Q %
  1. .I $P(^AUPNVMED(%,0),U,8)="" S %="Yes - "_$$FMTE^XLFDT($P($P(^AUPNVSIT($P(^AUPNVMED(%,0),U,3),0),U),".")) Q
  1. .I $P(^AUPNVMED(%,0),U,8)]"" S %="Discontinued - "_$$FMTE^XLFDT($P($P(^AUPNVSIT($P(^AUPNVMED(%,0),U,3),0),U),".")) Q
  1. NEW T S T=$O(^ATXAX("B","DM AUDIT ACE INHIBITORS",0))
  1. I 'T Q ""
  1. S I=0 F S I=$O(^AUPNVMED("AA",P,I)) Q:I'=+I!(%)!(I>(9999999-D)) D
  1. .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
  1. I %]"" D Q %
  1. .I $P(^AUPNVMED(%,0),U,8)="" S %="Yes - "_$$FMTE^XLFDT($P($P(^AUPNVSIT($P(^AUPNVMED(%,0),U,3),0),U),".")) Q
  1. .I $P(^AUPNVMED(%,0),U,8)]"" S %="Discontinued - "_$$FMTE^XLFDT($P($P(^AUPNVSIT($P(^AUPNVMED(%,0),U,3),0),U),".")) Q
  1. Q "No"
  1. ;
  1. ASPREF(P) ;EP - CHECK FOR ASPIRIN NMI OR REFUSAL
  1. I '$G(P) Q ""
  1. NEW X,N,Z,D,IEN,DATE,DRUG
  1. K X
  1. S T=$O(^ATXAX("B","DM AUDIT ASPIRIN DRUGS",0))
  1. I 'T Q ""
  1. S (D,G)=0 F S D=$O(^AUPNPREF("AA",P,50,D)) Q:D'=+D!(G) D
  1. .Q:'$D(^ATXAX(T,21,"B",D))
  1. .S X=$O(^AUPNPREF("AA",P,50,D,0))
  1. .S N=$O(^AUPNPREF("AA",P,50,D,X,0))
  1. .S G=1,DATE=9999999-X,DRUG=D,IEN=N
  1. I 'G Q ""
  1. Q $$VAL^XBDIQ1(50,DRUG,.01)_" "_$$TYPEREF^APCHSMU(IEN)_" on "_$$FMTE^XLFDT(DATE)
  1. PNEU(P) ;EP
  1. 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
  1. I $D(APCHY(1)) S PNEU(9999999-$P(APCHY(1),U))=""
  1. I $D(APCHY(2)) S PNEU(9999999-$P(APCHY(2),U))=""
  1. K APCHY S %=P_"^LAST 2 IMMUNIZATION 100",E=$$START1^APCLDF(%,"APCHY(")
  1. I $D(APCHY(1)) S PNEU(9999999-$P(APCHY(1),U))=""
  1. I $D(APCHY(2)) S PNEU(9999999-$P(APCHY(2),U))=""
  1. K APCHY S %=P_"^LAST 2 IMMUNIZATION 109",E=$$START1^APCLDF(%,"APCHY(")
  1. I $D(APCHY(1)) S PNEU(9999999-$P(APCHY(1),U))=""
  1. I $D(APCHY(2)) S PNEU(9999999-$P(APCHY(2),U))=""
  1. 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
  1. I $D(APCHY(1)) Q "Yes "_$$FMTE^XLFDT($P(APCHY(1),U))_" "_$$FMTE^XLFDT($P($G(APCHY(2)),U))
  1. S G=$$REFDF^APCHS9B3(APCHSPAT,9999999.14,$O(^AUTTIMM("C",$S($$BI:33,1:19),0)),$P($G(APCHY(1)),U))
  1. I G]"" Q G
  1. S G=$$REFDF^APCHS9B3(APCHSPAT,9999999.14,$O(^AUTTIMM("C",$S($$BI:109,1:19),0)),$P($G(APCHY(1)),U))
  1. I G]"" Q G
  1. S G=$$REFDF^APCHS9B3(APCHSPAT,9999999.14,$O(^AUTTIMM("C",$S($$BI:100,1:19),0)),$P($G(APCHY(1)),U))
  1. I G]"" Q G
  1. Q "No"
  1. PPD(P) ;EP
  1. NEW APCHY,Y,X,%,E S %=P_"^LAST SKIN PPD",E=$$START1^APCLDF(%,"APCHY(")
  1. I $D(APCHY(1)) Q $P(^AUPNVSK(+$P(APCHY(1),U,4),0),U,5)_" "_$$FMTE^XLFDT($P(APCHY(1),U))
  1. K APCHY S X=P_"^LAST DX V74.1" S E=$$START1^APCLDF(X,"APCHY(")
  1. I $D(APCHY(1)) Q $$FMTE^XLFDT($P(APCHY(1),U))_" (by Diagnosis)"
  1. S G=$$REFDF^APCHS9B3(APCHSPAT,9999999.28,$O(^AUTTSK("B","PPD",0)))
  1. I G]"" Q G
  1. Q ""
  1. PPDS(P) ;EP
  1. ;check for tb health factor, problem list, povs if and
  1. ;indication of pos ppd then return "Known Positive PPD"
  1. NEW APCHS,E,X
  1. K APCHS
  1. S X=P_"^LAST HEALTH [DM AUDIT TB HEALTH FACTORS" S E=$$START1^APCLDF(X,"APCHS(")
  1. I $D(APCHS) Q "Known Positive PPD or Hx of TB (Health Factor recorded)"
  1. N T S T=$O(^ATXAX("B","DM AUDIT TB HEALTH FACTORS",0))
  1. I 'T G PPDSPL
  1. 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
  1. I G Q "Known Positive PPD or Hx of TB (Health Factor recorded)"
  1. PPDSPL ;CHECK PL
  1. N T S T=$O(^ATXAX("B","SURVEILLANCE TUBERCULOSIS",0))
  1. I 'T Q ""
  1. 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
  1. I I Q "Known Positive PPD or Hx of TB (Problem List DX)"
  1. ;check povs
  1. K APCHS S X=P_"^FIRST DX [SURVEILLANCE TUBERCULOSIS" S E=$$START1^APCLDF(X,"APCHS(")
  1. I $D(APCHS(1)) Q "Known Positive PPD or Hx of TB (POV/DX "_$$FMTE^XLFDT($P(APCHS(1),U))_")"
  1. Q ""
  1. BI() ;EP- check to see if using new imm package or not 1/5/1999 IHS/CMI/LAB
  1. Q $S($O(^AUTTIMM(0))<100:0,1:1)
  1. ;end new subrotuine CMI/TUCSON/LAB