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

APCLD611.m

Go to the documentation of this file.
APCLD611 ; IHS/CMI/LAB -IHS -CUMULATIVE REPORT ;
 ;;2.0;IHS PCC SUITE;;MAY 14, 2009
 ;
 ;
IMM ;
 S:'$D(APCLCUML(140)) APCLCUML(140)="IMMUNIZATIONS"
 S $P(APCLCUML(140),U,2)=$P(APCLCUML(140),U,2)+1
 S V=$G(^XTMP("APCLDM61",APCLJOB,APCLBTH,"AUDIT",APCLPD,64))
 I $E(V)="Y" S $P(APCLCUML(140),U,3)=$P(APCLCUML(140),U,3)+1
 I $E(V)="R" S $P(APCLCUML(140),U,6)=$P(APCLCUML(140),U,6)+1
 S V=$G(^XTMP("APCLDM61",APCLJOB,APCLBTH,"AUDIT",APCLPD,66))
 I $E(V)="Y" S $P(APCLCUML(140),U,4)=$P(APCLCUML(140),U,4)+1
 I $E(V)="R" S $P(APCLCUML(140),U,7)=$P(APCLCUML(140),U,7)+1
 S V=$G(^XTMP("APCLDM61",APCLJOB,APCLBTH,"AUDIT",APCLPD,68))
 I $E(V)="Y" S $P(APCLCUML(140),U,5)=$P(APCLCUML(140),U,5)+1
 I $E(V)="R" S $P(APCLCUML(140),U,8)=$P(APCLCUML(140),U,8)+1
URIN ;
 ;title^total^total with urinalysis^protein present^protein absent^protein not done^micro present^micro absent^micro not done
 ;145
 S:'$D(APCLCUML(145)) APCLCUML(145)="URINALYSIS"
 S $P(APCLCUML(145),U,2)=$P(APCLCUML(145),U,2)+1
 S V=$G(^XTMP("APCLDM61",APCLJOB,APCLBTH,"AUDIT",APCLPD,92))
 S A=$G(^XTMP("APCLDM61",APCLJOB,APCLBTH,"AUDIT",APCLPD,94))
 I $E(V)="Y" S $P(APCLCUML(145),U,3)=$P(APCLCUML(145),U,3)+1
 I $E(A)="Y" S $P(APCLCUML(145),U,4)=$P(APCLCUML(145),U,4)+1
 I A["No result" S $P(APCLCUML(145),U,6)=$P(APCLCUML(145),U,6)+1 G EKG
 I $E(A)="N" S $P(APCLCUML(145),U,5)=$P(APCLCUML(145),U,5)+1 D
 .S V=$G(^XTMP("APCLDM61",APCLJOB,APCLBTH,"AUDIT",APCLPD,96))
 .I $E(V,1,3)="Pos" S $P(APCLCUML(145),U,7)=$P(APCLCUML(145),U,7)+1 Q
 .I $E(V,1,3)="Neg" S $P(APCLCUML(145),U,8)=$P(APCLCUML(145),U,8)+1 Q
 .S $P(APCLCUML(145),U,9)=$P(APCLCUML(145),U,9)+1
 .Q
EKG ;need date of last ekg
 S:'$D(APCLCUML(150)) APCLCUML(150)="EKG"
 G:$$AGE^AUPNPAT(APCLPD,APCLADAT)<30 CREAT
 S $P(APCLCUML(150),U,2)=$P(APCLCUML(150),U,2)+1
 S V=$$EKG^APCLD612(APCLPD,APCLRED,"I")
 I V]"" D
 .S E=$$FMDIFF^XLFDT(APCLADAT,V)
 .I E<(365.25*3) S $P(APCLCUML(150),U,3)=$P(APCLCUML(150),U,3)+1
 .I E<(365.25*5) S $P(APCLCUML(150),U,4)=$P(APCLCUML(150),U,4)+1
 .S $P(APCLCUML(150),U,5)=$P(APCLCUML(150),U,5)+1
CREAT ;
 S:'$D(APCLCUML(170)) APCLCUML(170)="Creatinine obtained in the past 12 months"
 S $P(APCLCUML(170),U,2)=$P(APCLCUML(170),U,2)+1
 S V=$$CREAT^APCLD618(APCLPD,APCLBDAT,APCLADAT,"I")
 I V="" S $P(APCLCUML(170),U,5)=$P(APCLCUML(170),U,5)+1 G TCHOL
 S V=$P(V,U)
 I $E(V)'=+$E(V),$E(V)'="." S $P(APCLCUML(170),U,6)=$P(APCLCUML(170),U,6)+1 G TCHOL ;unable to determine result, not a number
 I V>1.9 S $P(APCLCUML(170),U,3)=$P(APCLCUML(170),U,3)+1
 I V<2.0 S $P(APCLCUML(170),U,4)=$P(APCLCUML(170),U,4)+1
TCHOL ;
 S:'$D(APCLCUML(180)) APCLCUML(180)="Total Cholesterol obtained in past 12 months"
 S $P(APCLCUML(180),U,2)=$P(APCLCUML(180),U,2)+1
 S V=$$CHOL^APCLD618(APCLPD,APCLBDAT,APCLADAT,"I")
 I V="" S $P(APCLCUML(180),U,6)=$P(APCLCUML(180),U,6)+1 G LDL
 S V=$P(V,U)
 I $E(V)'=+$E(V) S $P(APCLCUML(180),U,7)=$P(APCLCUML(180),U,7)+1 G LDL ;unable to determine result, not a number or is blank
 I V<200 S $P(APCLCUML(180),U,3)=$P(APCLCUML(180),U,3)+1 G LDL
 I V<240 S $P(APCLCUML(180),U,4)=$P(APCLCUML(180),U,4)+1 G LDL
 S $P(APCLCUML(180),U,5)=$P(APCLCUML(180),U,5)+1
LDL ;
 S:'$D(APCLCUML(190)) APCLCUML(190)="LDL Cholesterol obtained in the past 12 months"
 S $P(APCLCUML(190),U,2)=$P(APCLCUML(190),U,2)+1
 S V=$$LDL^APCLD618(APCLPD,APCLBDAT,APCLADAT,"I")
 I V="" S $P(APCLCUML(190),U,7)=$P(APCLCUML(190),U,7)+1 G HDL
 S V=$P(V,U)
 I $E(V)'=+$E(V) S $P(APCLCUML(190),U,8)=$P(APCLCUML(190),U,8)+1 G HDL ;unable to determine result, not a number or blank
 I V<100 S $P(APCLCUML(190),U,3)=$P(APCLCUML(190),U,3)+1 G HDL
 I V<130 S $P(APCLCUML(190),U,4)=$P(APCLCUML(190),U,4)+1 G HDL
 I V<160.1 S $P(APCLCUML(190),U,5)=$P(APCLCUML(190),U,5)+1 G HDL
 S $P(APCLCUML(190),U,6)=$P(APCLCUML(190),U,6)+1
HDL ;
 S:'$D(APCLCUML(195)) APCLCUML(195)="HDL Cholesterol obtained in the past 12 months"
 S $P(APCLCUML(195),U,2)=$P(APCLCUML(195),U,2)+1
 S V=$$HDL^APCLD618(APCLPD,APCLBDAT,APCLADAT,"I")
 I V="" S $P(APCLCUML(195),U,7)=$P(APCLCUML(195),U,7)+1 G TRIG
 S V=$P(V,U)
 I $E(V)'=+$E(V) S $P(APCLCUML(195),U,8)=$P(APCLCUML(195),U,8)+1 G TRIG ;unable to determine result, not a number
 S V=$P(V,".")
 I V<35 S $P(APCLCUML(195),U,3)=$P(APCLCUML(195),U,3)+1 G TRIG
 I V<46 S $P(APCLCUML(195),U,4)=$P(APCLCUML(195),U,4)+1 G TRIG
 I V<55.1 S $P(APCLCUML(195),U,5)=$P(APCLCUML(195),U,5)+1 G TRIG
 S $P(APCLCUML(195),U,6)=$P(APCLCUML(195),U,6)+1
TRIG ;
 S:'$D(APCLCUML(200)) APCLCUML(200)="Triglycerides obtained in past 12 months"
 S $P(APCLCUML(200),U,2)=$P(APCLCUML(200),U,2)+1
 S V=$$TRIG^APCLD618(APCLPD,APCLBDAT,APCLADAT,"I")
 I V="" S $P(APCLCUML(200),U,7)=$P(APCLCUML(200),U,7)+1 G SELF
 S V=$P(V,U)
 I $E(V)'=+$E(V) S $P(APCLCUML(200),U,8)=$P(APCLCUML(200),U,8)+1 G SELF ;unable to determine result, not a number
 I V<150 S $P(APCLCUML(200),U,3)=$P(APCLCUML(200),U,3)+1 G SELF
 I V<200 S $P(APCLCUML(200),U,4)=$P(APCLCUML(200),U,4)+1 G SELF
 I V<401 S $P(APCLCUML(200),U,5)=$P(APCLCUML(200),U,5)+1 G SELF
 S $P(APCLCUML(200),U,6)=$P(APCLCUML(200),U,6)+1
SELF ;
 ;S:'$D(APCLCUML(210)) APCLCUML(210)="Self monitoring of blood glucose documented"
 ;S $P(APCLCUML(210),U,2)=$P(APCLCUML(210),U,2)+1
 ;S V=$G(^XTMP("APCLDM61",APCLJOB,APCLBTH,"AUDIT",APCLPD,98))
 ;S P=$S($E(V)="Y":3,$E(V)="N":4,$E(V)="R":5,1:6)
 ;S $P(APCLCUML(210),U,P)=$P(APCLCUML(210),U,P)+1
SDM  ;
 ;Q  ;NOT IN 2006
 ;S:'$D(APCLCUML(220)) APCLCUML(220)="Participating in SDM"
 ;S $P(APCLCUML(220),U,2)=$P(APCLCUML(220),U,2)+1
 ;S V=$G(^XTMP("APCLDM61",APCLJOB,APCLBTH,"AUDIT",APCLPD,100))
 ;S P=$S($E(V)="Y":3,1:4)
 ;S $P(APCLCUML(220),U,P)=$P(APCLCUML(220),U,P)+1
 Q
PED(P,BDATE,EDATE) ;EP
 K APCLALED
 NEW Y,B,D,T,A,G,Z,V,X
 S Y="APCLALED("
 S X=P_"^ALL EDUC;DURING "_BDATE_"-"_EDATE S E=$$START1^APCLDF(X,Y)
 I $D(APCLALED(1)) S %="" D  I %]"" Q %
 .S (X,D)=0,%="",T="" F  S X=$O(APCLALED(X)) Q:X'=+X!(%]"")  D
 ..S T=$P(^AUPNVPED(+$P(APCLALED(X),U,4),0),U)
 ..Q:'T
 ..Q:'$D(^AUTTEDT(T,0))
 ..S T=$P(^AUTTEDT(T,0),U,2)
 ..I $E(T,1,4)="TO-Q" S %="Yes-"_T_" "_$$FMTE^XLFDT($P(APCLALED(X),U),5) Q
 ..I T="TO-LA" S %="Yes-"_T_" "_$$FMTE^XLFDT($P(APCLALED(X),U),5) Q
 K ^TMP($J,"A")
 S A="^TMP($J,""A"",",B=P_"^ALL VISITS;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE),E=$$START1^APCLDF(B,A)
 I '$D(^TMP($J,"A",1)) Q ""
 S X=0,G="" F  S X=$O(^TMP($J,"A",X)) Q:X'=+X!(G]"")  S V=$P(^TMP($J,"A",X),U,5) D
 .Q:'$D(^AUPNVSIT(V,0))
 .Q:'$P(^AUPNVSIT(V,0),U,9)
 .Q:$P(^AUPNVSIT(V,0),U,11)
 .S B=$$CLINIC^APCLV(V,"C")
 .I B=94 S G="Yes-"_$$FMTE^XLFDT($P($P(^AUPNVSIT(V,0),U),"."),5)_" CL 94" Q
 .S Z=0 F  S Z=$O(^AUPNVDEN("AD",V,Z)) Q:Z'=+Z!(G)  S B=$P($G(^AUPNVDEN(Z,0)),U) I B S B=$P($G(^AUTTADA(B,0)),U) I B=1320 S G="Yes-"_$$FMTE^XLFDT($P($P(^AUPNVSIT(V,0),U),"."),5)_" ADA 1320" Q
 .Q
 Q G
CESS(P,B,D) ;EP - find any cessation hf in 12 months before E
 I '$G(P) Q ""
 NEW APCL,E,X,G,T
 K APCL
 S X=P_"^LAST HEALTH [DM AUDIT CESSATION HLTH FACTOR;DURING "_B_"-"_D S E=$$START1^APCLDF(X,"APCL(")
 I $D(APCL(1)) Q "Yes-"_$$FMTE^XLFDT($P(APCL(1),U),5)
 S X=P_"^EDUC [DM AUDIT SMOKING CESS EDUC;DURING "_B_"-"_D S E=$$START1^APCLDF(X,"APCL(")
 I $D(APCL(1)) Q "Yes-"_$$FMTE^XLFDT($P(APCL(1),U),5)
 S APCL=$$PED(P,B,D)
 I APCL]"" Q APCL
 NEW T S T=$O(^ATXAX("B","DM AUDIT SMOKING CESS EDUC",0))
 ;I 'T Q "No"
 S (X,G)=0
 I T F  S X=$O(^ATXAX(T,21,X)) Q:X'=+X!(G)  I $$REFUSAL^APCLD617(P,9999999.09,$P(^ATXAX(T,21,X,0),U),B,D) S G=1
 I G Q "Refused"
 S X=$O(^AUTTEDT("C","TO-Q",0))
 I X,$$REFUSAL^APCLD617(P,9999999.09,X,B,D) Q "Refused"
 S X=$O(^AUTTEDT("C","TO-LA",0))
 I X,$$REFUSAL^APCLD617(P,9999999.09,X,B,D) Q "Refused"
 S X=$O(^AUTTEDT("C","TO-QT",0))
 I X,$$REFUSAL^APCLD617(P,9999999.09,X,B,D) Q "Refused"
 S X=$O(^AUTTEDT("C","TO-QU",0))
 I X,$$REFUSAL^APCLD617(P,9999999.09,X,B,D) Q "Refused"
 Q "No"
 ;