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

APCLD202.m

Go to the documentation of this file. 
  1. APCLD202 ; IHS/CMI/LAB - 2000 DIABETES AUDIT ;
  1.  ;;2.0;IHS PCC SUITE;;MAY 14, 2009
  1.  ;
  1. SETN ;set N = to v lab to use
  1.  S N="" NEW A,G S (A,G)=0 F  S A=$O(APCL(A)) Q:A'=+A!(G)  I $P(^AUPNVLAB(+$P(APCL(A),U,4),0),U,4)]"" S G=A
  1.  S N=$S(G:G,1:1)
  1.  Q
  1. TBTX(P) ;EP
  1.  I '$G(P) Q ""
  1.  NEW APCL,E,X
  1.  K APCL
  1.  S X=P_"^LAST HEALTH [DM AUDIT TB HEALTH FACTORS" S E=$$START1^APCLDF(X,"APCL(")
  1.  I E Q ""
  1.  I $D(APCL(1)) Q $P(APCL(1),U,3)_U_$S($P(APCL(1),U,3)["TX COMPLETE":"1 Yes",$P(APCL(1),U,3)["TX INCOMPLETE"!($P(APCL(1),U,3)["TX UNTREATED"):"2 No",1:"4 Unknown")
  1.  N T,Y S T=$O(^ATXAX("B","DM AUDIT TB HEALTH FACTORS",0))
  1.  I 'T Q ""
  1.  N G S G="",X=0 F  S X=$O(^AUPNHF("AA",P,X)) Q:X'=+X!(G]"")  I $D(^ATXAX(T,21,"B",X)) S G=$P(^AUTTHF(X,0),U)
  1.  I G]"" Q G_U_$S(G["TX COMPLETE":"1 Yes",G["TX INCOMPLETE"!(G["TX UNTREATED"):"2 No",1:"4 Unknown")
  1.  Q ""
  1. PAP(P,BDATE,EDATE) ; EP
  1.  NEW X,%DT,ED,%
  1.  S %DT="P",X=EDATE D ^%DT S ED=Y
  1.  I $$SEX^AUPNPAT(P)'="F" Q "N/A - male"
  1.  I $$AGE^AUPNPAT(P,ED)<18 Q "N/A - under 18"
  1.  NEW APCL S %=P_"^LAST LAB PAP SMEAR;DURING "_BDATE_"-"_EDATE,E=$$START1^APCLDF(%,"APCL(")
  1.  I $D(APCL(1)) Q "Yes  "_$$FMTE^XLFDT($P(APCL(1),U))
  1.  K APCL S %=P_"^LAST DX V76.2;DURING "_BDATE_"-"_EDATE,E=$$START1^APCLDF(%,"APCL(")
  1.  I $D(APCL(1)) Q "Yes  "_$$FMTE^XLFDT($P(APCL(1),U))
  1.  K APCL S %=P_"^LAST DX V72.3;DURING "_BDATE_"-"_EDATE,E=$$START1^APCLDF(%,"APCL(")
  1.  I $D(APCL(1)) Q "Yes  "_$$FMTE^XLFDT($P(APCL(1),U))
  1.  K APCL S %=P_"^LAST PROCEDURE 91.46;DURING "_BDATE_"-"_EDATE,E=$$START1^APCLDF(%,"APCL(")
  1.  I $D(APCL(1)) Q "Yes  "_$$FMTE^XLFDT($P(APCL(1),U))
  1.  ;check CPT codes in year prior to date range
  1.  S T=$O(^ATXAX("B","DM AUDIT PAP CPTS",0))
  1.  K APCL I T S APCL(1)=$$CPT^APCLD202(P,,ED,T,4) I $G(APCL(1))]"" Q "Yes  "_APCL(1)
  1.  NEW G S G=0
  1.  NEW T S T=$O(^LAB(60,"B","PAP SMEAR",0))
  1.  I 'T Q ""
  1.  S X=0 F  S X=$O(^ATXLAB(T,21,X)) Q:X'=+X!(G)  I $$REFUSAL^APCLD207(P,60,$P(^ATXLAB(T,21,X,0),U),BDATE,EDATE) S G=1
  1.  Q $S(G:"Refused",1:"No")
  1.  Q "No"
  1. CPT(P,BDATE,EDATE,T,F) ;EP return ien of CPT entry if patient had this CPT
  1.  I '$G(P) Q ""
  1.  I '$G(T) Q ""
  1.  I '$G(F) S F=1
  1.  I $G(EDATE)="" Q ""
  1.  I $G(BDATE)="" S BDATE=$$FMADD^XLFDT(EDATE,-365)
  1.  ;go through visits in a date range for this patient, check cpts
  1.  NEW D,BD,ED,X,Y,D,G,V
  1.  S ED=9999999-EDATE,BD=9999999-BDATE,G=0
  1.  F  S ED=$O(^AUPNVSIT("AA",P,ED)) Q:ED=""!($P(ED,".")>BD)!(G)  D
  1.  .S V=0 F  S V=$O(^AUPNVSIT("AA",P,ED,V)) Q:V'=+V!(G)  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!(G)  D
  1.  ...I $$ICD^ATXCHK($P(^AUPNVCPT(X,0),U),T,1) S G=X
  1.  ...Q
  1.  ..Q
  1.  .Q
  1.  I 'G Q ""
  1.  I F=1 Q $S(G:1,1:"")
  1.  I F=2 Q G
  1.  I F=3 S V=$P(^AUPNVCPT(G,0),U,3) I V Q $P($P($G(^AUPNVSIT(V,0)),U),".")
  1.  I F=4 S V=$P(^AUPNVCPT(G,0),U,3) I V Q $$FMTE^XLFDT($P($P($G(^AUPNVSIT(V,0)),U),"."))
  1.  Q ""
  1. EKG(P,EDATE,F) ;EP
  1.  I $G(F)="" S F="E"
  1.  NEW APCL,X,%,E,LEKG S LEKG="",%=P_"^LAST DIAGNOSTIC ECG SUMMARY;DURING "_$$DOB^AUPNPAT(P,"E")_"-"_EDATE,E=$$START1^APCLDF(%,"APCL(")
  1.  I $D(APCL) S LEKG=$P(APCL(1),U)
  1.  K APCL S %=P_"^LAST PROCEDURE 89.51",E=$$START1^APCLDF(%,"APCL(")
  1.  I $D(APCL(1)) D
  1.  .Q:LEKG>$P(APCL(1),U)
  1.  .S LEKG=$P(APCL(1),U)
  1.  K APCL S %=P_"^LAST PROCEDURE 89.52",E=$$START1^APCLDF(%,"APCL(")
  1.  I $D(APCL(1)) D
  1.  .Q:LEKG>$P(APCL(1),U)
  1.  .S LEKG=$P(APCL(1),U)
  1.  K APCL S %=P_"^LAST PROCEDURE 89.53",E=$$START1^APCLDF(%,"APCL(")
  1.  I $D(APCL(1)) D
  1.  .Q:LEKG>$P(APCL(1),U)
  1.  .S LEKG=$P(APCL(1),U)
  1.  Q $S(F="E":$$FMTE^XLFDT(LEKG),1:LEKG)
  1.  ;
  1. ALT(P,BDATE,EDATE) ;EP
  1.  NEW APCL,X,%,E,R,V
  1.  K APCL
  1.  S %=P_"^LAST LAB [DM AUDIT ALT TAX;DURING "_BDATE_"-"_EDATE,E=$$START1^APCLDF(%,"APCL(")
  1.  I '$D(APCL(1)) Q ""
  1.  S D=$P(APCL(1),U),D=$$FMTE^XLFDT(D) K APCL S %=P_"^ALL LAB [DM AUDIT ALT TAX;DURING "_D_"-"_D,E=$$START1^APCLDF(%,"APCL(")
  1.  NEW N D SETN
  1.  Q $P(^AUPNVLAB(+$P(APCL(N),U,4),0),U,4)_"  "_$$FMTE^XLFDT($P(APCL(N),U),5)
  1. AST(P,BDATE,EDATE) ;EP
  1.  NEW APCL,X,%,E,R,V
  1.  K APCL
  1.  S %=P_"^LAST LAB [DM AUDIT AST TAX;DURING "_BDATE_"-"_EDATE,E=$$START1^APCLDF(%,"APCL(")
  1.  I '$D(APCL(1)) Q ""
  1.  S D=$P(APCL(1),U),D=$$FMTE^XLFDT(D) K APCL S %=P_"^ALL LAB [DM AUDIT AST TAX;DURING "_D_"-"_D,E=$$START1^APCLDF(%,"APCL(")
  1.  NEW N D SETN
  1.  Q $P(^AUPNVLAB(+$P(APCL(N),U,4),0),U,4)_"  "_$$FMTE^XLFDT($P(APCL(N),U),5)
  1. INSULIN(P,BDATE,EDATE) ;EP
  1.  NEW X,APCL,E
  1.  S X=P_"^LAST MEDS [DM AUDIT INSULIN DRUGS"_";DURING "_BDATE_"-"_EDATE S E=$$START1^APCLDF(X,"APCL(")
  1.  I $D(APCL(1)) Q "X"
  1.  Q ""
  1.  ;
  1. SULF(P,BDATE,EDATE) ;EP
  1.  NEW X,APCL,E
  1.  S X=P_"^LAST MEDS [DM AUDIT SULFONYLUREA DRUGS"_";DURING "_BDATE_"-"_EDATE S E=$$START1^APCLDF(X,"APCL(")
  1.  I $D(APCL(1)) Q "X"
  1.  Q ""
  1. MET(P,BDATE,EDATE) ;EP
  1.  NEW X,APCL,E
  1.  S X=P_"^LAST MEDS [DM AUDIT METFORMIN DRUGS"_";DURING "_BDATE_"-"_EDATE S E=$$START1^APCLDF(X,"APCL(")
  1.  I $D(APCL(1)) Q "X"
  1.  Q ""
  1.  ;
  1. ACAR(P,BDATE,EDATE) ;EP
  1.  NEW X,APCL,E
  1.  S X=P_"^LAST MEDS [DM AUDIT ACARBOSE DRUGS"_";DURING "_BDATE_"-"_EDATE S E=$$START1^APCLDF(X,"APCL(")
  1.  I $D(APCL(1)) Q "X"
  1.  Q ""
  1.  ;
  1. TROG(P,BDATE,EDATE) ;EP
  1.  NEW X,APCL,E
  1.  S X=P_"^LAST MEDS [DM AUDIT GLITAZONE DRUGS"_";DURING "_BDATE_"-"_EDATE S E=$$START1^APCLDF(X,"APCL(")
  1.  I $D(APCL(1)) Q "X"
  1.  Q ""
  1.  ;
  1.  ;
  1. MAMMOG(P,BDATE,EDATE) ;  EP
  1.  NEW X,%DT,ED
  1.  S %DT="P",X=EDATE D ^%DT S ED=Y
  1.  I $$SEX^AUPNPAT(P)'="F" Q "N/A - male"
  1.  I $$AGE^AUPNPAT(P,ED)<40 Q "N/A - under 40"
  1.  I '$G(P) Q ""
  1.  NEW LMAM S LMAM=""
  1.  I $G(^AUTTSITE(1,0)),$P(^AUTTLOC($P(^AUTTSITE(1,0),U),0),U,10)="353101" S LMAM=$$MAMMOG1(P,BDATE,EDATE)
  1.  NEW APCL S %=P_"^LAST RAD 76091;DURING "_BDATE_"-"_EDATE,E=$$START1^APCLDF(%,"APCL(")
  1.  I $D(APCL(1)) D
  1.  .Q:LMAM>$P(APCL(1),U)
  1.  .S LMAM=$P(APCL(1),U)
  1.  K APCL S %=P_"^LAST RAD 76092;DURING "_BDATE_"-"_EDATE,E=$$START1^APCLDF(%,"APCL(")
  1.  I $D(APCL(1)) D
  1.  .Q:LMAM>$P(APCL(1),U)
  1.  .S LMAM=$P(APCL(1),U)
  1.  K APCL S %=P_"^LAST RAD 76090;DURING "_BDATE_"-"_EDATE,E=$$START1^APCLDF(%,"APCL(")
  1.  I $D(APCL(1)) D
  1.  .Q:LMAM>$P(APCL(1),U)
  1.  .S LMAM=$P(APCL(1),U)
  1.  K APCL S %=P_"^LAST DX V76.11;DURING "_BDATE_"-"_EDATE,E=$$START1^APCLDF(%,"APCL(")
  1.  I $D(APCL(1)) D
  1.  .Q:LMAM>$P(APCL(1),U)
  1.  .S LMAM=$P(APCL(1),U)
  1.  K APCL S %=P_"^LAST DX V76.12;DURING "_BDATE_"-"_EDATE,E=$$START1^APCLDF(%,"APCL(")
  1.  I $D(APCL(1)) D
  1.  .Q:LMAM>$P(APCL(1),U)
  1.  .S LMAM=$P(APCL(1),U)
  1.  K APCL S %=P_"^LAST PROCEDURE 87.37;DURING "_BDATE_"-"_EDATE,E=$$START1^APCLDF(%,"APCL(")
  1.  I $D(APCL(1)) D
  1.  .Q:LMAM>$P(APCL(1),U)
  1.  .S LMAM=$P(APCL(1),U)
  1.  K APCL S %=P_"^LAST PROCEDURE 87.36;DURING "_BDATE_"-"_EDATE,E=$$START1^APCLDF(%,"APCL(")
  1.  I $D(APCL(1)) D
  1.  .Q:LMAM>$P(APCL(1),U)
  1.  .S LMAM=$P(APCL(1),U)
  1.  ;check CPT codes in year prior to date range
  1.  S T=$O(^ATXAX("B","DM AUDIT MAMMOGRAM CPTS",0))
  1.  K APCL I T S APCL(1)=$$CPT^APCLD202(P,,ED,T,3) D
  1.  .I APCL(1)="" K APCL Q
  1.  .Q:LMAM>$P(APCL(1),U)
  1.  .S LMAM=$P(APCL(1),U)
  1.  Q $S(LMAM]"":"Yes  "_$$FMTE^XLFDT(LMAM),1:"No")
  1.  ;
  1. MAMMOG1(P,BDATE,EDATE) ;for radiology 4.5+ or until qman can handle taxonomies for radiology procedures
  1.  ;
  1.  ;IHS/ANMC/LJF 8/26/99 new code to look for all mammograms no matter
  1.  ;    how they are spelled in file 71 - for Rad version 4.5+
  1.  NEW APCLMAM,CODE,COUNT,IEN,X
  1.  S CODE=$O(^DIC(40.7,"C",72,0)) I 'CODE Q "No    <never recorded>"
  1.  S IEN=0 F  S IEN=$O(^RAMIS(71,IEN)) Q:'IEN  D
  1.  . Q:$G(^RAMIS(71,IEN,"I"))  ;inactive
  1.  . Q:'$D(^RAMIS(71,IEN,"STOP","B",CODE))  ;no mamm stop code
  1.  . S COUNT=$G(COUNT)+1,APCLMAM(COUNT)=$P(^RAMIS(71,IEN,0),U)
  1.  ;
  1.  ; -- use data fetcher to find mammogram dates
  1.  NEW APCLY,APCLSAV,APCLX,APCLNAM
  1.  S (APCLSAV,APCLX)=0 F  S APCLX=$O(APCLMAM(APCLX)) Q:'APCLX  D
  1.  . S %=P_"^LAST RAD "_APCLMAM(APCLX)_";DURING "_BDATE_"-"_EDATE,E=$$START1^APCLDF(%,"APCLY(")
  1.  . ; save latest date and procedure name
  1.  . I $G(APCLY(1)),$P(APCLY(1),U)>APCLSAV S APCLSAV=$P(APCLY(1),U),APCLNAM=APCLMAM(APCLX)
  1.  ;
  1.  ; -- return results
  1.  I APCLSAV'=0 Q APCLSAV
  1.  ;IHS/ANMC/LJF 8/26/99 end of new code
  1.  ;
  1.  Q ""
  1. TXNAME(V) ;EP
  1.  I $G(V)="" Q ""
  1.  S V=$$TXNAMES(V)
  1.  Q $E(V,1,16)
  1. TXNAMES(Y) ;
  1.  I Y=1 Q "DIET"
  1.  I Y=2 Q "INSULIN"
  1.  I Y=3 Q "SULFONYLUREA"
  1.  I Y=4 Q "METFORMIN (GLUCOPHAGE)"
  1.  I Y=5 Q "ACARBOSE OR MIGLITOL"
  1.  I Y=6 Q "GLITAZONE"
  1.  I Y=9 Q "UNKNOWN/REFUSED"
  1.  I Y=23 Q "INSULIN+S'UREA"
  1.  I Y=24 Q "INSULIN+MET"
  1.  I Y=25 Q "INSULIN+ACAR"
  1.  I Y=26 Q "INSULIN+GLITAZONE"
  1.  I Y=34 Q "S'UREA+MET"
  1.  I Y=35 Q "S'UREA+ACAR"
  1.  I Y=36 Q "S'UREA+GLITAZONE"
  1.  I Y=45 Q "MET+ACAR"
  1.  I Y=46 Q "MET+GLITAZONE"
  1.  I Y=56 Q "ACAR+GLITAZONE"
  1.  I Y=234 Q "INS+S'UREA+MET"
  1.  I Y=235 Q "INS+S'UREA+ACAR"
  1.  I Y=236 Q "INS+S'UREA+GLIT"
  1.  I Y=245 Q "INS+MET+ACAR"
  1.  I Y=246 Q "INS+MET+GLITAZONE"
  1.  I Y=256 Q "INS+ACAR+GLITAZONE"
  1.  I Y=345 Q "S'UREA+MET+ACAR"
  1.  I Y=346 Q "S'UREA+MET+GLIT"
  1.  I Y=356 Q "S'UREA+ACAR+GLIT"
  1.  I Y=456 Q "MET+ACAR+GLIT"
  1.  Q ""
  1.  ;