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

APCLD206.m

Go to the documentation of this file. 
  1. APCLD206 ; IHS/CMI/LAB - 2000 DIABETES AUDIT ;
  1.  ;;2.0;IHS PCC SUITE;;MAY 14, 2009
  1.  ;
  1.  ;cmi/anch/maw 9/10/2007 code set versioning in TOBACCO1
  1.  ;
  1. TBCODE(P,EDATE,R) ;EP
  1.  NEW APCLJ,APCLI
  1.  S APCLJ=""
  1.  ;return computed TB Status Code
  1.  S X=$$TBTX^APCLD202(P)
  1.  I X]"",X["TX COMPLETE" Q 1
  1.  I X]"" Q 2
  1.  I $$PPD^APCLD208(P,EDATE)["POS" D  Q APCLJ
  1.  .I $$TBTX^APCLD202(P)["TX COMPLETE" S APCLJ=1 Q
  1.  .S APCLJ=2
  1.  .Q
  1.  I $$PPD^APCLD208(P,EDATE)["NEG" S APCLJ=4 D  Q APCLJ
  1.  .I $$DODX(P,R,"I")="" S APCLJ=4 Q
  1.  .S D=$$DODX(P,R,"I"),E=$$PPD^APCLD208(P,EDATE,"I") S APCLJ=$S(D>E:4,1:3)
  1.  .Q
  1.  S APCLJ=5
  1.  Q APCLJ
  1.  ;;
  1. 1 ;;PPD +, treatment complete
  1. 2 ;;PPD +, not treated/treatment incomplete or unknown treatment
  1. 3 ;;PPD -, up-to-date (placed after dm dx)
  1. 4 ;;PPD -, before DM dx or date unknown
  1. 5 ;;PPD Status unknown
  1. BI() ;
  1.  Q $S($O(^AUTTIMM(0))>100:1,1:0)
  1. SYSMEAN(P,BDATE,EDATE) ;EP
  1.  NEW X S X=$$BPS^APCLD207(P,BDATE,EDATE,"I")
  1.  I X="" Q ""
  1.  NEW Y,C S C=0 F Y=1:1:3 I $P(X,";",Y)]"" S C=C+1
  1.  I C'=3 Q ""
  1.  S C=0 F Y=1:1:3 S C=$P($P(X,";",Y),"/")+C
  1.  Q C\3
  1.  Q ""
  1. DIAMEAN(P,BDATE,EDATE) ;EP
  1.  NEW X S X=$$BPS^APCLD207(P,BDATE,EDATE,"I")
  1.  I X="" Q ""
  1.  NEW Y,C S C=0 F Y=1:1:3 I $P(X,";",Y)]"" S C=C+1
  1.  I C'=3 Q ""
  1.  S C=0 F Y=1:1:3 S C=$P($P(X,";",Y),"/",2)+C
  1.  Q C\3
  1. PPDDATE(P,EDATE) ;EP
  1.  NEW X S X=$$LASTNP^APCLD208(P,EDATE)
  1.  Q X
  1. FLU(P,BDATE,EDATE) ;EP
  1.  NEW APCL,X,E,%,%DT
  1.  S X=EDATE,%DT="P" D ^%DT S BD=Y
  1.  S BD=$$FMADD^XLFDT(BD,-(15*30)),BD=$$FMTE^XLFDT(BD)
  1.  NEW LFLU S LFLU=""
  1.  S X=P_"^LAST IMM "_$S($$BI:88,1:12)_";DURING "_BD_"-"_EDATE S E=$$START1^APCLDF(X,"APCL(")
  1.  I $D(APCL(1)) S LFLU=$P(APCL(1),U)
  1.  K APCL S %=P_"^LAST DX V04.8;DURING "_BD_"-"_EDATE,E=$$START1^APCLDF(%,"APCL(")
  1.  I $D(APCL(1)) D
  1.  .Q:LFLU>$P(APCL(1),U)
  1.  .S LFLU=$P(APCL(1),U)
  1.  K APCL S %=P_"^LAST DX V06.6;DURING "_BD_"-"_EDATE,E=$$START1^APCLDF(%,"APCL(")
  1.  I $D(APCL(1)) D
  1.  .Q:LFLU>$P(APCL(1),U)
  1.  .S LFLU=$P(APCL(1),U)
  1.  K APCL S %=P_"^LAST PROCEDURE 99.52;DURING "_BD_"-"_EDATE,E=$$START1^APCLDF(%,"APCL(")
  1.  I $D(APCL(1)) D
  1.  .Q:LFLU>$P(APCL(1),U)
  1.  .S LFLU=$P(APCL(1),U)
  1.  ;check CPT codes in year prior to date range
  1.  S X=EDATE,%DT="P" D ^%DT S ED=Y
  1.  S X=BD,%DT="P" D ^%DT S BD=Y
  1.  S T=$O(^ATXAX("B","DM AUDIT FLU CPTS",0))
  1.  K APCL I T S APCL(1)=$$CPT^APCLD202(P,BD,ED,T,3) D
  1.  .I APCL(1)="" K APCL Q
  1.  .Q:LFLU>$P(APCL(1),U)
  1.  .S LFLU=$P(APCL(1),U)
  1.  I LFLU]"" Q "Yes  "_$$FMTE^XLFDT(LFLU)
  1.  ;
  1.  I $$REFUSAL^APCLD207(P,9999999.14,$O(^AUTTIMM("C",$S($$BI:88,1:12),0)),BD,EDATE) Q "Refused"
  1.  Q "No"
  1. PNEU(P,EDATE) ;EP
  1.  NEW APCL,X,E
  1.  S X=P_"^LAST IMM "_$S($$BI:33,1:19)_";DURING "_$$FMTE^XLFDT($$DOB^AUPNPAT(P))_"-"_EDATE S E=$$START1^APCLDF(X,"APCL(")
  1.  I $D(APCL(1)) Q "Yes - "_$$FMTE^XLFDT($P(APCL(1),U))
  1.  I $$REFUSAL^APCLD207(P,9999999.14,$O(^AUTTIMM("C",$S($$BI:33,1:19),0)),$$DOB^AUPNPAT(P,"E"),EDATE) Q "Refused"
  1.  Q "No"
  1. TD(P,EDATE) ;EP
  1.  NEW APCL,X,E,B,%DT,Y,TDD
  1.  S %DT="P",X=EDATE D ^%DT S B=Y
  1.  S X=P_"^LAST IMM "_$S($$BI:9,1:"02")_";DURING "_$$FMTE^XLFDT($$FMADD^XLFDT(B,-3653))_"-"_EDATE S E=$$START1^APCLDF(X,"APCL(")
  1.  I $D(APCL(1)) S TDD($P(APCL(1),U))=""
  1.  K APCL S X=P_"^LAST IMM "_$S($$BI:1,1:"03")_";DURING "_$$FMTE^XLFDT($$FMADD^XLFDT(B,-3653))_"-"_EDATE S E=$$START1^APCLDF(X,"APCL(")
  1.  I $D(APCL(1)) S TDD($P(APCL(1),U))=""
  1.  K APCL S X=P_"^LAST IMM "_$S($$BI:28,1:"34")_";DURING "_$$FMTE^XLFDT($$FMADD^XLFDT(B,-3653))_"-"_EDATE S E=$$START1^APCLDF(X,"APCL(")
  1.  I $D(APCL(1)) S TDD($P(APCL(1),U))=""
  1.  K APCL S X=P_"^LAST IMM "_$S($$BI:20,1:"42")_";DURING "_$$FMTE^XLFDT($$FMADD^XLFDT(B,-3653))_"-"_EDATE S E=$$START1^APCLDF(X,"APCL(")
  1.  I $D(APCL(1)) S TDD($P(APCL(1),U))=""
  1.  K APCL S APCL="",X=0 F  S X=$O(TDD(X)) Q:X'=+X  S APCL=X
  1.  I APCL]"" Q "Yes - "_$$FMTE^XLFDT(APCL)
  1.  S B=$$FMTE^XLFDT($$FMADD^XLFDT(B,-3653))
  1.  I $$REFUSAL^APCLD207(P,9999999.14,$O(^AUTTIMM("C",$S($$BI:9,1:"02"),0)),B,EDATE) Q "Refused"
  1.  I $$REFUSAL^APCLD207(P,9999999.14,$O(^AUTTIMM("C",$S($$BI:1,1:"03"),0)),B,EDATE) Q "Refused"
  1.  I $$REFUSAL^APCLD207(P,9999999.14,$O(^AUTTIMM("C",$S($$BI:28,1:34),0)),B,EDATE) Q "Refused"
  1.  I $$REFUSAL^APCLD207(P,9999999.14,$O(^AUTTIMM("C",$S($$BI:20,1:42),0)),B,EDATE) Q "Refused"
  1.  Q "No"
  1.  ;
  1. LIPID(P,BDATE,EDATE) ;EP
  1.  NEW X,APCL,E
  1.  S X=P_"^MEDS [DM AUDIT LIPID LOWERING DRUGS"_";DURING "_BDATE_"-"_EDATE S E=$$START1^APCLDF(X,"APCL(")
  1.  I $D(APCL(1)) Q "Yes"
  1.  Q "No"
  1.  ;
  1. ACE(P,BDATE,EDATE) ;EP
  1.  NEW X,APCL,E,X,Y,%DT,BD
  1.  S X=P_"^MEDS [DM AUDIT ACE INHIBITORS"_";DURING "_BDATE_"-"_EDATE S E=$$START1^APCLDF(X,"APCL(")
  1.  I $D(APCL(1)) Q "Yes"
  1.  ;go through all v meds until 9999999-D and find all drugs with class CV800 or CV805
  1.  NEW D,%DT K %DT S X=BDATE,%DT="P" D ^%DT S D=Y
  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  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 %=$P($P(^AUPNVSIT($P(^AUPNVMED(V,0),U,3),0),U),".")
  1.  Q $S(%]"":"Yes",1:"No")
  1.  ;
  1. SELF(P,BDATE,EDATE) ;EP
  1.  NEW X,APCL,E
  1.  S X=P_"^MEDS [DM AUDIT SELF MONITOR DRUGS"_";DURING "_BDATE_"-"_EDATE S E=$$START1^APCLDF(X,"APCL(")
  1.  I $D(APCL(1)) Q "Yes"
  1.  Q "No"
  1. SDM(P,BDATE,EDATE) ;EP
  1.  NEW T,APCL,E S T=$O(^ATXAX("B","DM AUDIT SDM PROVIDERS",0))
  1.  I 'T Q ""
  1.  S %=P_"^ALL DX [SURVEILLANCE DIABETES;DURING "_BDATE_"-"_EDATE,E=$$START1^APCLDF(%,"APCL(")
  1.  ;check to see if one of the providers was the primary prov
  1.  NEW X,V,G,P,P1 S (G,X)=0 F  S X=$O(APCL(X)) Q:X'=+X!(G)  S V=$P(APCL(X),U,5) D
  1.  .S P=0 F  S P=$O(^AUPNVPRV("AD",V,P)) Q:P'=+P!(G)  S P1=$P(^AUPNVPRV(P,0),U) I $D(^ATXAX(T,21,"B",P1)) S G=1
  1.  .Q
  1.  Q $S(G:"Yes",1:"No")
  1. PERI(P,BDATE,EDATE) ;EP
  1.  I '$G(P) Q ""
  1.  NEW APCL,% S %=P_"^LAST ADA [DM AUDIT PERIDONTAL ADA CODES;DURING "_BDATE_"-"_EDATE,E=$$START1^APCLDF(%,"APCL(")
  1.  I $D(APCL(1)) Q "Yes "_$$FMTE^XLFDT($P(APCL(1),U))
  1.  K APCL
  1.  S %=P_"^ALL VISITS;DURING "_BDATE_"-"_EDATE,E=$$START1^APCLDF(%,"APCL(")
  1.  NEW X,Y S X=0,Y=0 F  S X=$O(APCL(X)) Q:X'=+X!(Y)  I $$CLINIC^APCLV($P(APCL(X),U,5),"C")=56 S Y=1
  1.  I Y Q "Yes - clinic 56 visit"
  1.  Q "No"
  1.  ;
  1. ASPIRIN(P,BDATE,EDATE) ;EP
  1.  NEW X,APCL,E
  1.  S X=P_"^MEDS [DM AUDIT ASPIRIN DRUGS"_";DURING "_BDATE_"-"_EDATE S E=$$START1^APCLDF(X,"APCL(")
  1.  I $D(APCL(1)) Q "Yes"
  1.  Q "No"
  1.  ;
  1. TOBACCO(P,EDATE) ;EP
  1.  I '$G(P) Q ""
  1.  NEW APCLTOB,APCL,X,E
  1.  D TOBACCO3
  1.  I $D(APCLTOB) Q APCLTOB
  1.  D TOBACCO0
  1.  I $D(APCLTOB) Q APCLTOB
  1.  D TOBACCO1 ;check Problem file for tobacco use
  1.  I $D(APCLTOB) Q APCLTOB
  1.  D TOBACCO2 ;check POVs for tobacco use
  1.  I $D(APCLTOB) Q APCLTOB
  1.  Q "3  Not Documented "
  1. TOBACCO0 ;check for tobacco documented in health factors
  1.  K APCL S X=P_"^LAST HEALTH [DM AUDIT TOBACCO HLTH FACTORS" S E=$$START1^APCLDF(X,"APCL(") Q:E  I $D(APCL(1)) D  ;S APCLTOBN=$O(APCLTOB("")),APCLTOB=APCLTOB(APCLTOBN)
  1.  . I $P(APCL(1),U,3)["CURRENT" S APCLTOB="1  Current User" Q
  1.  . S APCLTOB="2  Not a Current User "
  1.  .Q
  1.  Q
  1. TOBACCO3 ;lookup in health status
  1.  S %=$O(^ATXAX("B","DM AUDIT TOBACCO HLTH FACTORS",0))
  1.  Q:'%
  1.  S (X,Y)=0 F  S X=$O(^AUPNHF("AA",P,X)) Q:X'=+X!(Y)  I $D(^ATXAX(%,21,"B",X)) S Y=X
  1.  Q:'Y
  1.  S Y=$P(^AUTTHF(Y,0),U)
  1.  S APCLTOB=Y
  1.  I Y["CURRENT" S APCLTOB="1  Current User" Q
  1.  S APCLTOB="2  Not a Current User"
  1.  Q
  1. TOBACCO1 ;check problem file for tobacco use
  1.  K APCL S X=P_"^PROBLEMS [DM AUDIT PROBLEM SMOKING DXS" S E=$$START1^APCLDF(X,"APCL(") Q:E  I $D(APCL(1)) D
  1.  . ;I $P(^ICD9($P(APCL(1),U,2),0),U,1)=305.13 S APCLTOB="2  Not a Current User"_" - "_$E($P(^AUTNPOV($P(^AUPNPROB(+$P(APCL(1),U,4),0),U,5),0),U),1,30) Q  ;cmi/anch/maw 9/10/2007 orig line
  1.  . I $P($$ICDDX^ICDCODE($P(APCL(1),U,2)),U,2)=305.13 S APCLTOB="2  Not a Current User"_" - "_$E($P(^AUTNPOV($P(^AUPNPROB(+$P(APCL(1),U,4),0),U,5),0),U),1,30) Q  ;cmi/anch/maw 9/10/2007 csv
  1.  . S APCLTOB="1  Current user - "_$E($P(^AUTNPOV($P(^AUPNPROB(+$P(APCL(1),U,4),0),U,5),0),U),1,30)
  1.  .Q
  1.  Q
  1. TOBACCO2 ;check pov file for TOBACCO USE DOC
  1.  NEW D,%DT
  1.  S %DT="P",X=EDATE D ^%DT S D=Y
  1.  NEW BDATE S BDATE=$$FMADD^XLFDT(D,-365),BDATE=$$FMTE^XLFDT(BDATE)
  1.  K APCL S X=P_"^LAST DX [DM AUDIT SMOKING RELATED DXS;DURING "_BDATE_"-"_EDATE S E=$$START1^APCLDF(X,"APCL(") Q:E  I $D(APCL(1)) D
  1.  . I $P(APCL(1),U,2)=305.13 S APCLTOB="2  Not a Current User"_" - "_$E($P(^AUTNPOV($P(^AUPNVPOV(+$P(APCL(1),U,4),0),U,4),0),U),1,30) Q
  1.  . S APCLTOB="1  Current user"_" - "_$E($P(^AUTNPOV($P(^AUPNVPOV(+$P(APCL(1),U,4),0),U,4),0),U),1,30)
  1.  .Q
  1.  Q
  1.  ;
  1. THERAPY(P,BD,EDATE) ;EP - therapy code for epi
  1.  I '$G(P) Q ""
  1.  NEW STR,TNAME,X,Y,%DT
  1.  S STR="",TNAME=""
  1.  S X=$$INSULIN^APCLD202(P,BD,EDATE)
  1.  I X]"" S STR=STR_"2"
  1.  S X=$$SULF^APCLD202(P,BD,EDATE)
  1.  I X]"" S STR=STR_3
  1.  S X=$$MET^APCLD202(P,BD,EDATE)
  1.  I X]"" S STR=STR_4
  1.  S X=$$ACAR^APCLD202(P,BD,EDATE)
  1.  I X]"" S STR=STR_5
  1.  S X=$$TROG^APCLD202(P,BD,EDATE)
  1.  I X]"" S STR=STR_"6"
  1.  I STR]"" Q STR
  1.  Q 1
  1.  ;
  1. TYPE(P,R,EDATE) ;EP return type 1 or 2 for epi file
  1.  I '$G(P) Q ""
  1.  NEW TYPE S TYPE=""
  1.  I $G(R) S TYPE=$$CMSFDX^APCLD207(P,R,"DX")
  1.  I TYPE="NIDDM" Q 2
  1.  I TYPE["TYPE II" Q 2
  1.  I TYPE="IDDM" Q 1
  1.  I TYPE["2" Q 2
  1.  I TYPE["1" Q 1
  1.  S TYPE="" NEW X,I,C S X=$$PLDMDXS^APCLD207(P)
  1.  F I=1:1 S C=$P(X,";",I) Q:C=""!(TYPE]"")  I $E(C,6)=0!($E(C,6)=2) S TYPE=2
  1.  I TYPE]"" Q TYPE
  1.  F I=1:1 S C=$P(X,";",I) Q:C=""!(TYPE]"")  I $E(C,6)=1!($E(C,6)=3) S TYPE=1
  1.  I TYPE]"" Q TYPE
  1.  S X=$$LASTDMDX^APCLD207(P,EDATE)
  1.  I X[2 Q 2
  1.  I X[1 Q 1
  1.  Q ""
  1.  ;
  1. DURDM(P,R,EDATE) ;EP
  1.  I '$G(P) Q ""
  1.  NEW Y S Y=$$DODX(P,R,"I")
  1.  I Y="" Q ""
  1.  I Y>EDATE Q ""
  1.  Q ($$FMDIFF^XLFDT(EDATE,Y,1)\365)
  1. DODX(P,R,F) ;EP - date of dx for epi file
  1.  I $G(F)="" S F="E"
  1.  NEW DATE,EARLY
  1.  S DATE="",EARLY=9999999
  1.  I $G(R) S DATE=$$CMSFDX^APCLD207(P,R,"ID")
  1.  I DATE]"" S EARLY=DATE
  1.  S DATE=$$PLDMDOO^APCLD207(P,"I")
  1.  I DATE]"",DATE<EARLY S EARLY=DATE
  1.  I EARLY=9999999 S EARLY=""
  1.  Q $S(F="I":EARLY,1:$$D(EARLY))
  1. D(D) ;
  1.  I D="" Q ""
  1.  Q $S($E(D,4,5)="00":"07",1:$E(D,4,5))_"/"_$S($E(D,6,7)="00":"15",1:$E(D,6,7))_"/"_(1700+$E(D,1,3))
  1.  ;