APCHPWH6.m

APCHPWH6 ; IHS/CMI/LAB - PCC HEALTH SUMMARY - MAIN DRIVER PART 2 ;   

 ;;2.0;IHS PCC SUITE;**2,6,7,10,11**;MAY 14, 2009;Build 58

 ;

 ;EO MEASURES IN PWH

CANCER ;EP - cancer CCI measure

 NEW APCHVAL,Y,APCHHD

 D SUBHEAD^APCHPWHU

 S APCHHD=0  ;D S^APCHPWH1("CANCER SCREENING",1)

 D MAMMOGM

 D PAP

 D COLORECT

 Q

 ;

MAMMOGM ;

 Q:$P(^DPT(APCHSDFN,0),U,2)'="F"

 Q:$$AGE^AUPNPAT(APCHSDFN)<50

 Q:$$AGE^AUPNPAT(APCHSDFN)>69

 S APCHVAL=$$LASTMAM^APCLAPI1(APCHSDFN)

 ;I 'APCHHD D S^APCHPWH1("CANCER SCREENING",1) S APCHHD=1

 D S^APCHPWH1("MAMMOGRAM",1)

 I APCHVAL="" D  Q

 .D S^APCHPWH1("No mammogram on file.  It is recommended that you receive a mammogram")

 .D S^APCHPWH1("every year.  Ask your health care provider to order a mammogram for you.")

 I $$FMDIFF^XLFDT(DT,APCHVAL)<365 D  Q

 .D S^APCHPWH1("Your last mammogram was on "_$$FMTE^XLFDT(APCHVAL)_".  Your next mammogram will")

 .D S^APCHPWH1("be due on "_$$FMTE^XLFDT($$FMADD^XLFDT(APCHVAL,365))_".")

 D S^APCHPWH1("Your last mammogram was on "_$$FMTE^XLFDT(APCHVAL)_".  We recommend that you")

 D S^APCHPWH1("receive a mammogram every year.  Ask your health care provider to order a ")

 D S^APCHPWH1("mammogram for you.")

 Q

 ;

PAP ;

 Q:$P(^DPT(APCHSDFN,0),U,2)'="F"

 Q:$$AGE^AUPNPAT(APCHSDFN)<19

 I $$HYSTER^APCHSM04(APCHSDFN) Q

 D S^APCHPWH1("PAP SMEAR",1)

 S APCHVAL=$$LASTPAP^APCLAPI1(APCHSDFN)

 I APCHVAL="" D  Q

 .D S^APCHPWH1("No Pap Smear on file.  We recommend that you get a Pap Smear every 3 years.")

 .D S^APCHPWH1("Ask your health care provider to order a Pap Smear for you.")

 ;

 I $$FMDIFF^XLFDT(DT,APCHVAL)<(3*365) D  Q

 .D S^APCHPWH1("Your last Pap Smear was on "_$$FMTE^XLFDT(APCHVAL)_".  Your next Pap Smear will")

 .D S^APCHPWH1("be due on "_$$FMTE^XLFDT($$FMADD^XLFDT(APCHVAL,(3*365)))_".")

 D S^APCHPWH1("Your last Pap Smear was on "_$$FMTE^XLFDT(APCHVAL)_".  We recommend that you")

 D S^APCHPWH1("get a Pap smear every 3 years.  Ask your health care provider to order a ")

 D S^APCHPWH1("Pap Smear for you.")

 Q

 ;

COLORECT ;

 Q:$$AGE^AUPNPAT(APCHSDFN)<51

 Q:$$CRC(APCHSDFN)

 ;I 'APCHHD D S^APCHPWH1("CANCER SCREENING",1) S APCHHD=1

 D S^APCHPWH1("COLON HEALTH SCREENING",1)

 NEW D,Y

 S D="",Y=""

 S APCHVAL=$$LASTCOLO^APCLAPI(APCHSDFN,$$FMADD^XLFDT(DT,-(10*365)),DT,"D")

 I APCHVAL S D=$$FMADD^XLFDT(APCHVAL,(10*365))

 S APCHVAL=$$LASTFSIG^APCLAPI(APCHSDFN,$$FMADD^XLFDT(DT,-(5*365)),DT,"D")

 I APCHVAL S Y=$$FMADD^XLFDT(APCHVAL,(5*365)) I Y>D S D=Y

 S APCHVAL=$$LASTBE^APCLAPI4(APCHSDFN,$$FMADD^XLFDT(DT,-(10*365)),DT,"D")

 I APCHVAL S Y=$$FMADD^XLFDT(APCHVAL,(10*365)) I Y>D S D=Y

 S APCHVAL=$$LASTFOBT^APCLAPI3(APCHSDFN,$$FMADD^XLFDT(DT,-365),DT,"D")

 I APCHVAL S Y=$$FMADD^XLFDT(APCHVAL,365) I Y>D S D=Y

 I D D COLODISP Q

 D S^APCHPWH1("It is recommended that all people who are 51 years and older be screened")

 D S^APCHPWH1("for colon cancer.  Ask your health care provider to order a colon cancer")

 D S^APCHPWH1("screening for you.")

 Q

COLODISP ;

 D S^APCHPWH1("You are up to date for colon cancer screening.  Your next colon cancer")

 D S^APCHPWH1("screening will be due on "_$$FMTE^XLFDT(D)_".")

 Q

 ;

CRC(P) ;EP

 NEW APCHX,Y,X,T

 K APCHX

 S Y="APCHX("

 S X=P_"^LAST DX [BGP COLORECTAL CANCER DXS;DURING "_$$FMTE^XLFDT($$DOB^AUPNPAT(P))_"-"_$$FMTE^XLFDT(DT) S E=$$START1^APCLDF(X,Y)

 I $D(APCHX(1)) Q 1  ;has a dx

 S X=$$LASTCPTT^APCLAPIU(P,,DT,"BGP COLORECTAL CANCER CPTS","D")

 I X]"" Q 1

 S X=$$LASTPRCT^APCLAPIU(P,,DT,"BGP TOTAL CHOLECTOMY PROCS","D")

 I X Q 1

 S X=$$LASTCPTT^APCLAPIU(P,,DT,"BGP TOTAL CHOLECTOMY CPTS","D")

 I X Q 1

 I $$PLTAX^APCHSMU(P,"BGP COLORECTAL CANCER DXS") Q 1

 Q 0

 ;

CKD(P) ;EP - Does patient have chronic kidney disease (CKD)?

 NEW T,APCHLLAB,I,X

 ;get last serum creatinine value

 ;S APCHLLAB=$$LAB(P,$O(^ATXLAB("B","DM AUDIT CREATININE TAX",0)),$O(^ATXAX("B","BGP CREATININE LOINC")))

 ;I $$SEX^AUPNPAT(APCHSDFN)="F",APCHLLAB>1.3 Q 1

 ;I $$SEX^AUPNPAT(APCHSDFN)="M",APCHLLAB>1.5 Q 1

 ;get last urine protein value

 S T=$O(^ATXAX("B","APCH CKD DXS",0))

 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)'="I",$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 1

 S T=$$LASTDX^APCHSMU2(P,"APCH CKD DXS",$$FMADD^XLFDT(DT,-(365*1)),DT)

 I T Q 1

 S APCHLLAB=$$LAB(P,$O(^ATXLAB("B","DM AUDIT P/C RATIO TAX",0)),$O(^ATXAX("B","DM AUDIT P/C RATIO LOINC")))

 I +APCHLLAB>200 Q 1

 S APCHLLAB=$$LAB(P,$O(^ATXLAB("B","DM AUDIT 24HR URINE PROTEIN",0)))

 I +APCHLLAB>300 Q 1

 ;get last A/C ratio value

 S APCHLLAB=$$LAB(P,$O(^ATXLAB("B","DM AUDIT QUANT UACR",0)))

 I +APCHLLAB>30 Q 1

 ;get estimated GFR

 S APCHLLAB=$$LAB(P,$O(^ATXLAB("B","BGP GPRA ESTIMATED GFR TAX",0)),$O(^ATXAX("B","BGP ESTIMATED GFR LOINC")),"ESTIMATED GFR")

 I +APCHLLAB,APCHLLAB<60 Q 1

 Q ""

 ;

LAB(P,T,LT,LN) ;EP

 I '$G(LT) S LT=""

 S LN=$G(LN)

 NEW D,V,G,X,J S (D,G)=0 F  S D=$O(^AUPNVLAB("AE",P,D)) Q:D'=+D!(G)  D

 .S X=0 F  S X=$O(^AUPNVLAB("AE",P,D,X)) Q:X'=+X!(G)  D

 ..S Y=0 F  S Y=$O(^AUPNVLAB("AE",P,D,X,Y)) Q:Y'=+Y!(G)  D

 ...I $D(^ATXLAB(T,21,"B",X)),$P(^AUPNVLAB(Y,0),U,4)]"" S G=Y Q

 ...I LN]"",$$VAL^XBDIQ1(9000010.09,Y,.01)=LN S G=Y Q

 ...Q:'LT

 ...S J=$P($G(^AUPNVLAB(Y,11)),U,13) Q:J=""

 ...Q:'$$LOINC(J,LT)

 ...S G=Y

 ...Q

 ..Q

 .Q

 I 'G Q ""

 Q $P(^AUPNVLAB(G,0),U,4)

 ;

LOINC(A,B) ;

 NEW %

 S %=$P($G(^LAB(95.3,A,9999999)),U,2)

 I %]"",$D(^ATXAX(B,21,"B",%)) Q 1

 S %=$P($G(^LAB(95.3,A,0)),U)_"-"_$P($G(^LAB(95.3,A,0)),U,15)

 I $D(^ATXAX(B,21,"B",%)) Q 1

 Q ""

 ;

FOOTEX(P,BDATE,EDATE) ;EP

 NEW APCHY,APCHV,%,LDFE,PROV,D,V,G

 S LDFE="",%=P_"^LAST EXAM DIABETIC FOOT EXAM;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE),E=$$START1^APCLDF(%,"APCHY(")

 I $D(APCHY(1)) S LDFE=$P(APCHY(1),U)

 ;now check any clinic 65 or prov 33/25

 K APCHY,APCHV

 S %=P_"^ALL VISITS;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE),E=$$START1^APCLDF(%,"APCHY(")

 ;reorder by date

 S %=0 F  S %=$O(APCHY(%)) Q:%'=+%  S APCHV(9999999-$P(APCHY(%),U),$P(APCHY(%),U,5))=""

 S (D,V)=0,G="" F  S D=$O(APCHV(D)) Q:D'=+D!(G)  S V=0 F  S V=$O(APCHV(D,V)) Q:V'=+V!(G)  D

 .S PROV=$$PRIMPROV^APCLV(V,"D") I (PROV=33!(PROV=25)),'$$DNKA^APCHS9B4(V) S G=9999999-D Q

 .S PROV=$$CLINIC^APCLV(V,"C") I PROV=65!(PROV="B7"),'$$DNKA^APCHS9B4(V) S G=9999999-D

 I G,G>LDFE S LDFE=G

 Q LDFE

LAB30 ;EP - all labs in past 100 days

 NEW APCHLAB,APCHX,X,L,N,R,APCHL

 S APCHLAB="APCHLAB"

 D ALLLAB^APCLAPIU(DFN,$$FMADD^XLFDT(DT,-100),DT,,,,.APCHLAB)

 Q:'$D(APCHLAB)

 D SUBHEAD^APCHPWHU

 D S^APCHPWH1("RECENT LAB RESULTS")

 D WRITET^APCHPWHU("RECENT LAB RESULTS")

 S X="LABORATORY TEST",$E(X,32)="RESULT",$E(X,52)="REFERENCE RANGE",$E(X,68)="DATE" D S^APCHPWH1(X)

 S APCHX=0 F  S APCHX=$O(APCHLAB(APCHX)) Q:APCHX'=+APCHX  D

 .S APCHL=$P(APCHLAB(APCHX),U,4)

 .Q:$P(^AUPNVLAB(APCHL,0),U,4)=""  ;no result - this is pending

 .Q:$P(^AUPNVLAB(APCHL,0),U,4)="canc"  ;CANCELLED TEST

 .S N=$P($G(^AUPNVLAB(APCHL,11)),U,1)  ;UNITS

 .I $$UP^XLFSTR($P(^AUPNVLAB(APCHL,0),U,4))["REJECTED TEST" Q

 .S R=""

 .I $P($G(^AUPNVLAB(APCHL,11)),U,4)]"",$P($G(^AUPNVLAB(APCHL,11)),U,5)]"" S R=$P(^AUPNVLAB(APCHL,11),U,4)_"-"_$P(^AUPNVLAB(APCHL,11),U,5)

 .S X=$E($P(APCHLAB(APCHX),U,2),1,30),$E(X,32)=$P(APCHLAB(APCHX),U,3)_"  "_N,$E(X,52)=R,$E(X,68)=$$FMTE^XLFDT($P(APCHLAB(APCHX),U,1))

 .D S^APCHPWH1(X)

 .;DISPLAY COMMENTS?  YES/NO

 .Q:'$P(^APCHPWHT(APCHPWHT,1,APCHSORD,0),U,4)

 .;display comments (21 multiple using ^DIWP with a length of 65, indented to column 8

 .K ^UTILITY($J,"W")

 .S APCMZ=0

 .S DIWL=1,DIWR=65 F  S APCMZ=$O(^AUPNVLAB(APCHL,21,APCMZ)) Q:APCMZ'=+APCMZ  D

 ..S X=^AUPNVLAB(APCHL,21,APCMZ,0) I X]"" D ^DIWP

 ..Q

 .S Z=0 F  S Z=$O(^UTILITY($J,"W",DIWL,Z)) Q:Z'=+Z  S X="",$E(X,8)=^UTILITY($J,"W",DIWL,Z,0) D S^APCHPWH1(X)

 .K ^UTILITY($J,"W")

 Q

PENDLAB ;

 NEW APCHLRDF,APCHMIEN,APCHIEN,APCHLABS,APCHTIEN,APCHCNT

 S APCHLRDF=$G(^DPT(DFN,"LR"))

 Q:'APCHLRDF  ;NO LRDFN TO USE FOR LOOKUP

 Q:'$D(^LRO(69,"D",APCHLRDF))  ;no orders in LRO(69 for this LRDFN

 K APCHLABS

 S APCHCNT=0

 ;gather up order date (.01 field and test names in APCHLABS)

 S APCHIEN=$$FMADD^XLFDT(DT,-184) F  S APCHIEN=$O(^LRO(69,"D",APCHLRDF,APCHIEN)) Q:APCHIEN=""  D

 .S APCHMIEN=0 F  S APCHMIEN=$O(^LRO(69,"D",APCHLRDF,APCHIEN,APCHMIEN)) Q:APCHMIEN=""  D

 ..;now loop through tests to see if any not accessioned

 ..S APCHTIEN=0 F  S APCHTIEN=$O(^LRO(69,APCHIEN,1,APCHMIEN,2,APCHTIEN)) Q:APCHTIEN'=+APCHTIEN  D

 ...Q:$P($G(^LRO(69,APCHIEN,1,APCHMIEN,2,APCHTIEN,0)),U,3)  ;has accession date so not a pending order

 ...S APCHCNT=APCHCNT+1,APCHLABS(APCHCNT)=$P(^LRO(69,APCHIEN,0),U,1)_U_$P(^LRO(69,APCHIEN,1,APCHMIEN,2,APCHTIEN,0),U,1)

 Q:'$D(APCHLABS)  ;no pending labs so don't bother with displaying hte component.

 D SUBHEAD^APCHPWHU

 D S^APCHPWH1("PENDING LAB ORDERS")

 D WRITET^APCHPWHU("PENDING LABS")

 S X="",$E(X,5)="LABORATORY TEST",$E(X,40)="DATE ORDERED" D S^APCHPWH1(X)

 S APCHCNT=0 F  S APCHCNT=$O(APCHLABS(APCHCNT)) Q:APCHCNT=""  D

 .S X="",$E(X,5)=$P(^LAB(60,$P(APCHLABS(APCHCNT),U,2),0),U,1),$E(X,40)=$$FMTE^XLFDT($P(APCHLABS(APCHCNT),U,1)) D S^APCHPWH1(X)

 Q

 ;

PROCS ;EP - CALLED FROM PROCEDURES COMPONENT OF THE PWH

 ;

HOS ;  HISTORY OF SURGERY * 9000010.08 (V PROCEDURE) & V CPT *******

 NEW APCHHOSA,APCHHOSC,APCHSCNT,APCHSIVD,APCHSICD,APCHSN,APCHSDAT,APCHCODE,APCHDES,APCHSDAT,APCHSCVD,APCHSIEN

 NEW APCHCPTI,V,AJPCHT,Y

 K APCHHOSA,APCHHOSC

 I '$D(^AUPNVPRC("AC",APCHSDFN)),'$D(^AUPNVCPT("AC",APCHSDFN)),'$D(^AUPNVTC("AC",APCHSDFN)) G HOSX

 S APCHSCNT=0

 ;

 S APCHSIVD=0 F  S APCHSIVD=$O(^AUPNVPRC("AA",APCHSDFN,APCHSIVD)) Q:'APCHSIVD  D

 .S APCHSIEN=0 F  S APCHSIEN=$O(^AUPNVPRC("AA",APCHSDFN,APCHSIVD,APCHSIEN)) Q:'APCHSIEN  D

 ..S APCHSICD=$P(^AUPNVPRC(APCHSIEN,0),U)

 ..S APCHSN=^AUPNVPRC(APCHSIEN,0)

 ..D HOSCHK Q:APCHSICD=""

 ..S APCHSCNT=APCHSCNT+1

 ..;S APCHCSVD=+^AUPNVSIT($P(APCHSN,U,3),0)\1

 ..S X=$$ICDOP^ICDEX($P(APCHSN,U,1),+^AUPNVSIT($P(APCHSN,U,3),0)\1,,"I")

 ..S APCHCODE=$P(X,U,2),APCHDES=$P(X,U,5)

 ..S APCHSDAT=""

 ..S Y=$P(APCHSN,U,6) I Y]"" S APCHSDAT=$$FMTE^XLFDT(Y)

 ..I APCHSDAT="" S Y=$P(APCHSN,U,3),Y=+^AUPNVSIT(Y,0)\1 S APCHSDAT=$$FMTE^XLFDT(Y)

 ..S APCHHOSA(APCHSIVD,"PRC",APCHSIEN)=APCHSDAT_U_APCHDES_U_APCHCODE

 ;now go through v cpt

 S APCHT=$O(^ATXAX("B","APCH HS MAJOR PROCEDURE CPTS",0))

 S APCHCPTI=0 F  S APCHCPTI=$O(^AUPNVCPT("AA",APCHSDFN,APCHCPTI)) Q:APCHCPTI'=+APCHCPTI  D

 .I '$$ICD^ATXAPI(APCHCPTI,APCHT,1) Q  ;not a cpt wanted on this component

 .S APCHSIVD=0 F  S APCHSIVD=$O(^AUPNVCPT("AA",APCHSDFN,APCHCPTI,APCHSIVD)) Q:APCHSIVD=""  D

 ..S APCHSIEN=0 F  S APCHSIEN=$O(^AUPNVCPT("AA",APCHSDFN,APCHCPTI,APCHSIVD,APCHSIEN)) Q:APCHSIEN'=+APCHSIEN  D

 ...S Y=(9999999-APCHSIVD) S APCHSDAT=$$FMTE^XLFDT(Y)

 ...S APCHSN=^AUPNVCPT(APCHSIEN,0)

 ...S APCHSCNT=APCHSCNT+1

 ...S APCHDES=$P($$CPT^ICPTCOD($P(APCHSN,U,1),Y),U,3)  ;cmi/anch/maw 8/28/2007 code set versioning

 ...S APCHCODE=$P($$CPT^ICPTCOD($P(APCHSN,U,1),Y),U,2)

 ...S APCHHOSA(APCHSIVD,"CPT",APCHSIEN)=APCHSDAT_U_APCHDES_U_APCHCODE

 ...S APCHHOSC(APCHSIVD,"CPT",$P(^ICPT($P(APCHSN,U,1),0),U,1))=""

 ;now get all tran codes hcpcs

 S APCHSIEN=0 F  S APCHSIEN=$O(^AUPNVTC("AC",APCHSDFN,APCHSIEN)) Q:APCHSIEN=""  D

 .Q:'$D(^AUPNVTC(APCHSIEN))

 .S V=$P(^AUPNVTC(APCHSIEN,0),U,3)

 .Q:'V

 .Q:'$D(^AUPNVSIT(V,0))

 .S (APCHSDAT,V)=$P($P(^AUPNVSIT(V,0),U),".")

 .S APCHSIVD=9999999-V

 .S APCHCPTI=$P(^AUPNVTC(APCHSIEN,0),U,7)

 .Q:APCHCPTI=""

 .I '$$ICD^ATXAPI(APCHCPTI,APCHT,1) Q  ;not a cpt wanted on this component

 .Q:$D(APCHHOSC(APCHSIVD,"CPT",$P(^ICPT(APCHCPTI,0),U,1)))

 .S APCHDES=$P($$CPT^ICPTCOD(APCHCPTI,APCHSDAT),U,3)

 .S APCHCODE=$P($$CPT^ICPTCOD(APCHCPTI,APCHSDAT),U,2)

 .S APCHHOSA(APCHSIVD,"CPT",APCHSIEN)=$$FMTE^XLFDT(APCHSDAT)_U_APCHDES_U_APCHCODE

 .S APCHSCNT=APCHSCNT+1

 ;now display the procedures/cpt codes

 Q:'APCHSCNT

 D SUBHEAD^APCHPWHU

 D S^APCHPWH1("PROCEDURES")

 D WRITET^APCHPWHU("PROCEDURES")

 S APCHSIVD=0 F  S APCHSIVD=$O(APCHHOSA(APCHSIVD)) Q:APCHSIVD=""  D

 . S APCHIEN=0 F  S APCHIEN=$O(APCHHOSA(APCHSIVD,"PRC",APCHIEN)) Q:APCHIEN'=+APCHIEN  D

 .. S APCHDES=$P(APCHHOSA(APCHSIVD,"PRC",APCHIEN),U,2)

 .. S APCHSDAT=$P(APCHHOSA(APCHSIVD,"PRC",APCHIEN),U,1)

 .. S APCHCODE=$P(APCHHOSA(APCHSIVD,"PRC",APCHIEN),U,3)

 .. S X="",$E(X,1)=APCHDES,$E(X,60)=APCHSDAT

 .. D S^APCHPWH1(X)

 . S APCHIEN=0 F  S APCHIEN=$O(APCHHOSA(APCHSIVD,"CPT",APCHIEN)) Q:APCHIEN'=+APCHIEN!($D(APCHSQIT))  D

 .. S APCHDES=$P(APCHHOSA(APCHSIVD,"CPT",APCHIEN),U,2)

 .. S APCHSDAT=$P(APCHHOSA(APCHSIVD,"CPT",APCHIEN),U,1)

 .. S APCHCODE=$P(APCHHOSA(APCHSIVD,"CPT",APCHIEN),U,3)

 .. S X="",$E(X,1)=APCHDES,$E(X,60)=APCHSDAT

 .. D S^APCHPWH1(X)

HOSX ;

 K APCHHOSA,APCHHOSC

 Q

HOSCHK ;

 S APCHSCOD=$P($$ICDOP^ICDEX(APCHSICD,,,"I"),U,2)  ;cmi/anch/maw CSV

 I $$ICD^ATXAPI(APCHSICD,$O(^ATXAX("B","APCH MINOR SURGICAL PROCS",0)),0) S APCHSICD=""

 Q

APCHPWH6  ; IHS/CMI/LAB - PCC HEALTH SUMMARY - MAIN DRIVER PART 2 ;   

 +1       ;;2.0;IHS PCC SUITE;**2,6,7,10,11**;MAY 14, 2009;Build 58

 +2       ;

 +3       ;EO MEASURES IN PWH

CANCER    ;EP - cancer CCI measure

 +1        NEW APCHVAL,Y,APCHHD

 +2        DO SUBHEAD^APCHPWHU

 +3       ;D S^APCHPWH1("CANCER SCREENING",1)

           SET APCHHD=0

 +4        DO MAMMOGM

 +5        DO PAP

 +6        DO COLORECT

 +7        QUIT 

 +8       ;

MAMMOGM   ;

 +1        IF $PIECE(^DPT(APCHSDFN,0),U,2)'="F"

               QUIT 

 +2        IF $$AGE^AUPNPAT(APCHSDFN)<50

               QUIT 

 +3        IF $$AGE^AUPNPAT(APCHSDFN)>69

               QUIT 

 +4        SET APCHVAL=$$LASTMAM^APCLAPI1(APCHSDFN)

 +5       ;I 'APCHHD D S^APCHPWH1("CANCER SCREENING",1) S APCHHD=1

 +6        DO S^APCHPWH1("MAMMOGRAM",1)

 +7        IF APCHVAL=""

               Begin DoDot:1

 +8                DO S^APCHPWH1("No mammogram on file.  It is recommended that you receive a mammogram")

 +9                DO S^APCHPWH1("every year.  Ask your health care provider to order a mammogram for you.")

               End DoDot:1

               QUIT 

 +10       IF $$FMDIFF^XLFDT(DT,APCHVAL)<365

               Begin DoDot:1

 +11               DO S^APCHPWH1("Your last mammogram was on "_$$FMTE^XLFDT(APCHVAL)_".  Your next mammogram will")

 +12               DO S^APCHPWH1("be due on "_$$FMTE^XLFDT($$FMADD^XLFDT(APCHVAL,365))_".")

               End DoDot:1

               QUIT 

 +13       DO S^APCHPWH1("Your last mammogram was on "_$$FMTE^XLFDT(APCHVAL)_".  We recommend that you")

 +14       DO S^APCHPWH1("receive a mammogram every year.  Ask your health care provider to order a ")

 +15       DO S^APCHPWH1("mammogram for you.")

 +16       QUIT 

 +17      ;

PAP       ;

 +1        IF $PIECE(^DPT(APCHSDFN,0),U,2)'="F"

               QUIT 

 +2        IF $$AGE^AUPNPAT(APCHSDFN)<19

               QUIT 

 +3        IF $$HYSTER^APCHSM04(APCHSDFN)

               QUIT 

 +4        DO S^APCHPWH1("PAP SMEAR",1)

 +5        SET APCHVAL=$$LASTPAP^APCLAPI1(APCHSDFN)

 +6        IF APCHVAL=""

               Begin DoDot:1

 +7                DO S^APCHPWH1("No Pap Smear on file.  We recommend that you get a Pap Smear every 3 years.")

 +8                DO S^APCHPWH1("Ask your health care provider to order a Pap Smear for you.")

               End DoDot:1

               QUIT 

 +9       ;

 +10       IF $$FMDIFF^XLFDT(DT,APCHVAL)<(3*365)

               Begin DoDot:1

 +11               DO S^APCHPWH1("Your last Pap Smear was on "_$$FMTE^XLFDT(APCHVAL)_".  Your next Pap Smear will")

 +12               DO S^APCHPWH1("be due on "_$$FMTE^XLFDT($$FMADD^XLFDT(APCHVAL,(3*365)))_".")

               End DoDot:1

               QUIT 

 +13       DO S^APCHPWH1("Your last Pap Smear was on "_$$FMTE^XLFDT(APCHVAL)_".  We recommend that you")

 +14       DO S^APCHPWH1("get a Pap smear every 3 years.  Ask your health care provider to order a ")

 +15       DO S^APCHPWH1("Pap Smear for you.")

 +16       QUIT 

 +17      ;

COLORECT  ;

 +1        IF $$AGE^AUPNPAT(APCHSDFN)<51

               QUIT 

 +2        IF $$CRC(APCHSDFN)

               QUIT 

 +3       ;I 'APCHHD D S^APCHPWH1("CANCER SCREENING",1) S APCHHD=1

 +4        DO S^APCHPWH1("COLON HEALTH SCREENING",1)

 +5        NEW D,Y

 +6        SET D=""

           SET Y=""

 +7        SET APCHVAL=$$LASTCOLO^APCLAPI(APCHSDFN,$$FMADD^XLFDT(DT,-(10*365)),DT,"D")

 +8        IF APCHVAL

               SET D=$$FMADD^XLFDT(APCHVAL,(10*365))

 +9        SET APCHVAL=$$LASTFSIG^APCLAPI(APCHSDFN,$$FMADD^XLFDT(DT,-(5*365)),DT,"D")

 +10       IF APCHVAL

               SET Y=$$FMADD^XLFDT(APCHVAL,(5*365))

               IF Y>D

                   SET D=Y

 +11       SET APCHVAL=$$LASTBE^APCLAPI4(APCHSDFN,$$FMADD^XLFDT(DT,-(10*365)),DT,"D")

 +12       IF APCHVAL

               SET Y=$$FMADD^XLFDT(APCHVAL,(10*365))

               IF Y>D

                   SET D=Y

 +13       SET APCHVAL=$$LASTFOBT^APCLAPI3(APCHSDFN,$$FMADD^XLFDT(DT,-365),DT,"D")

 +14       IF APCHVAL

               SET Y=$$FMADD^XLFDT(APCHVAL,365)

               IF Y>D

                   SET D=Y

 +15       IF D

               DO COLODISP

               QUIT 

 +16       DO S^APCHPWH1("It is recommended that all people who are 51 years and older be screened")

 +17       DO S^APCHPWH1("for colon cancer.  Ask your health care provider to order a colon cancer")

 +18       DO S^APCHPWH1("screening for you.")

 +19       QUIT 

COLODISP  ;

 +1        DO S^APCHPWH1("You are up to date for colon cancer screening.  Your next colon cancer")

 +2        DO S^APCHPWH1("screening will be due on "_$$FMTE^XLFDT(D)_".")

 +3        QUIT 

 +4       ;

CRC(P)    ;EP

 +1        NEW APCHX,Y,X,T

 +2        KILL APCHX

 +3        SET Y="APCHX("

 +4        SET X=P_"^LAST DX [BGP COLORECTAL CANCER DXS;DURING "_$$FMTE^XLFDT($$DOB^AUPNPAT(P))_"-"_$$FMTE^XLFDT(DT)

           SET E=$$START1^APCLDF(X,Y)

 +5       ;has a dx

           IF $DATA(APCHX(1))

               QUIT 1

 +6        SET X=$$LASTCPTT^APCLAPIU(P,,DT,"BGP COLORECTAL CANCER CPTS","D")

 +7        IF X]""

               QUIT 1

 +8        SET X=$$LASTPRCT^APCLAPIU(P,,DT,"BGP TOTAL CHOLECTOMY PROCS","D")

 +9        IF X

               QUIT 1

 +10       SET X=$$LASTCPTT^APCLAPIU(P,,DT,"BGP TOTAL CHOLECTOMY CPTS","D")

 +11       IF X

               QUIT 1

 +12       IF $$PLTAX^APCHSMU(P,"BGP COLORECTAL CANCER DXS")

               QUIT 1

 +13       QUIT 0

 +14      ;

CKD(P)    ;EP - Does patient have chronic kidney disease (CKD)?

 +1        NEW T,APCHLLAB,I,X

 +2       ;get last serum creatinine value

 +3       ;S APCHLLAB=$$LAB(P,$O(^ATXLAB("B","DM AUDIT CREATININE TAX",0)),$O(^ATXAX("B","BGP CREATININE LOINC")))

 +4       ;I $$SEX^AUPNPAT(APCHSDFN)="F",APCHLLAB>1.3 Q 1

 +5       ;I $$SEX^AUPNPAT(APCHSDFN)="M",APCHLLAB>1.5 Q 1

 +6       ;get last urine protein value

 +7        SET T=$ORDER(^ATXAX("B","APCH CKD DXS",0))

 +8        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)'="I"

                       IF $PIECE(^AUPNPROB(X,0),U,12)'="D"

                           SET Y=$PIECE(^AUPNPROB(X,0),U)

                           IF $$ICD^ATXAPI(Y,T,9)

                               SET I=1

 +9        IF I

               QUIT 1

 +10       SET T=$$LASTDX^APCHSMU2(P,"APCH CKD DXS",$$FMADD^XLFDT(DT,-(365*1)),DT)

 +11       IF T

               QUIT 1

 +12       SET APCHLLAB=$$LAB(P,$ORDER(^ATXLAB("B","DM AUDIT P/C RATIO TAX",0)),$ORDER(^ATXAX("B","DM AUDIT P/C RATIO LOINC")))

 +13       IF +APCHLLAB>200

               QUIT 1

 +14       SET APCHLLAB=$$LAB(P,$ORDER(^ATXLAB("B","DM AUDIT 24HR URINE PROTEIN",0)))

 +15       IF +APCHLLAB>300

               QUIT 1

 +16      ;get last A/C ratio value

 +17       SET APCHLLAB=$$LAB(P,$ORDER(^ATXLAB("B","DM AUDIT QUANT UACR",0)))

 +18       IF +APCHLLAB>30

               QUIT 1

 +19      ;get estimated GFR

 +20       SET APCHLLAB=$$LAB(P,$ORDER(^ATXLAB("B","BGP GPRA ESTIMATED GFR TAX",0)),$ORDER(^ATXAX("B","BGP ESTIMATED GFR LOINC")),"ESTIMATED GFR")

 +21       IF +APCHLLAB

               IF APCHLLAB<60

                   QUIT 1

 +22       QUIT ""

 +23      ;

LAB(P,T,LT,LN) ;EP

 +1        IF '$GET(LT)

               SET LT=""

 +2        SET LN=$GET(LN)

 +3        NEW D,V,G,X,J

           SET (D,G)=0

           FOR 

               SET D=$ORDER(^AUPNVLAB("AE",P,D))

               IF D'=+D!(G)

                   QUIT 

               Begin DoDot:1

 +4                SET X=0

                   FOR 

                       SET X=$ORDER(^AUPNVLAB("AE",P,D,X))

                       IF X'=+X!(G)

                           QUIT 

                       Begin DoDot:2

 +5                        SET Y=0

                           FOR 

                               SET Y=$ORDER(^AUPNVLAB("AE",P,D,X,Y))

                               IF Y'=+Y!(G)

                                   QUIT 

                               Begin DoDot:3

 +6                                IF $DATA(^ATXLAB(T,21,"B",X))

                                       IF $PIECE(^AUPNVLAB(Y,0),U,4)]""

                                           SET G=Y

                                           QUIT 

 +7                                IF LN]""

                                       IF $$VAL^XBDIQ1(9000010.09,Y,.01)=LN

                                           SET G=Y

                                           QUIT 

 +8                                IF 'LT

                                       QUIT 

 +9                                SET J=$PIECE($GET(^AUPNVLAB(Y,11)),U,13)

                                   IF J=""

                                       QUIT 

 +10                               IF '$$LOINC(J,LT)

                                       QUIT 

 +11                               SET G=Y

 +12                               QUIT 

                               End DoDot:3

 +13                       QUIT 

                       End DoDot:2

 +14               QUIT 

               End DoDot:1

 +15       IF 'G

               QUIT ""

 +16       QUIT $PIECE(^AUPNVLAB(G,0),U,4)

 +17      ;

LOINC(A,B) ;

 +1        NEW %

 +2        SET %=$PIECE($GET(^LAB(95.3,A,9999999)),U,2)

 +3        IF %]""

               IF $DATA(^ATXAX(B,21,"B",%))

                   QUIT 1

 +4        SET %=$PIECE($GET(^LAB(95.3,A,0)),U)_"-"_$PIECE($GET(^LAB(95.3,A,0)),U,15)

 +5        IF $DATA(^ATXAX(B,21,"B",%))

               QUIT 1

 +6        QUIT ""

 +7       ;

FOOTEX(P,BDATE,EDATE) ;EP

 +1        NEW APCHY,APCHV,%,LDFE,PROV,D,V,G

 +2        SET LDFE=""

           SET %=P_"^LAST EXAM DIABETIC FOOT EXAM;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE)

           SET E=$$START1^APCLDF(%,"APCHY(")

 +3        IF $DATA(APCHY(1))

               SET LDFE=$PIECE(APCHY(1),U)

 +4       ;now check any clinic 65 or prov 33/25

 +5        KILL APCHY,APCHV

 +6        SET %=P_"^ALL VISITS;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE)

           SET E=$$START1^APCLDF(%,"APCHY(")

 +7       ;reorder by date

 +8        SET %=0

           FOR 

               SET %=$ORDER(APCHY(%))

               IF %'=+%

                   QUIT 

               SET APCHV(9999999-$PIECE(APCHY(%),U),$PIECE(APCHY(%),U,5))=""

 +9        SET (D,V)=0

           SET G=""