APCHSM06.m

APCHSM06 ; IHS/CMI/LAB -- CONTINUATION OF ROUTINES ;

 ;;2.0;IHS PCC SUITE;**2,11,14,16**;MAY 14, 2009;Build 9

 ;IHS/CMI/LAB - uncommented age limit on pap smear

 ;

 ; ******************** SURVEILLANCE - HARD CODE ********************

S(X) ;

 NEW %,C S (C,%)=0 F  S %=$O(APCHSTEX(%)) Q:%'=+%  S C=C+1

 S APCHSTEX(C+1)=X

 Q

PPDWT ;

 S V=$$REF^APCHSMU(APCHSPAT,9999999.28,APCHSFLX,APCHLAST) I V]"" S X=$P(V,U) D S(X) S X=$P(V,U,2) I X]"" D S(X)

 D WRITE^APCHSMU

 X APCHSURX

 Q

PPD ;EP - PPD

 X APCHSURX

 Q:'$$INAC^APCHSMU(APCHSITI)  ;is item turned on or off

 S APCHLAST="",APCHNEXT="" K APCHSTEX

 S APCHSINT="",APCHSCRI=$$SITECRIT^APCHSMU(APCHSITI)

 S APCHSFLX=$O(^AUTTSK("B","PPD",0)),APCHIMMC="PPD"

 S APCHICAR=$$LASTITEM^APCLAPIU(APCHSPAT,"PPD","SKIN",,,"A")

 S APCHLAST=$P(APCHICAR,U,1)

 S APCHOVR=$$OVR^APCHSMU(APCHSPAT,APCHSITI)

 I $P(APCHOVR,U)>APCHLAST D  Q

 .S X=$$DATE^APCHSMU($P(APCHOVR,U))_" (per "_$P(APCHOVR,U,2)_")" D S(X) S X=$P(APCHOVR,U,3) D S(X)

 .D PPDWT

 .Q

PPDREG ;

 I APCHSCRI S APCHSINT=$$AGESEX^APCHSMU(APCHSITI,APCHSPAT),APCHMIN=$$MINAGE^APCHSMU(APCHSITI,APCHSPAT)

 I 'APCHSCRI D PPDIHS Q

 I APCHSINT="" X APCHSURX Q  ;no frequency so skip it

 I $$PPDS^APCHS9B5(APCHSPAT)]"" X APCHSURX Q  ;known tb

 I APCHLAST="" S APCHSTEX(1)=$$DATE^APCHSMU($$DATEAGE^APCHSMU(APCHSPAT,APCHMIN)) D PPDWT Q

 S APCHNEXT=$$FMADD^XLFDT(APCHLAST,APCHSINT)

 I APCHNEXT>DT S APCHSTEX(1)=$$DATE^APCHSMU(APCHNEXT)

 I APCHNEXT'>DT S APCHSTEX(1)=$$DATE^APCHSMU(APCHNEXT)

 D PPDWT

 Q

 ;

PPDIHS ;

 Q:APCHSAGE>18

 Q:APCHSAGE<4

 S APCHMIN=4

 I $$PPDS^APCHS9B5(APCHSPAT)]"" X APCHSURX Q  ;known tb

 I APCHLAST="" S APCHSTEX(1)=$$DATE^APCHSMU($$DATEAGE^APCHSMU(APCHSPAT,APCHMIN)) D PPDWT Q

 S APCHSOLD=$$FMDIFF^XLFDT(APCHLAST,APCHSDOB)

 I APCHSAGE>3,APCHSAGE<11 D  Q

 .I APCHSOLD<(3*365) S APCHSTEX(1)=$$DATE^APCHSMU($$FMADD^XLFDT(APCHSDOB,(4*365))) D PPDWT Q

 .S APCHNEXT=$$FMADD^XLFDT(APCHSDOB,(11*365)),APCHSTEX(1)=$$DATE^APCHSMU(APCHNEXT) D PPDWT Q

 I APCHSAGE>10,APCHSOLD<(9*365) S APCHSTEX(1)=$$DATE^APCHSMU($$FMADD^XLFDT(APCHSDOB,(11*365))) D PPDWT Q

 Q

 ;

LDL1 ;

 X APCHSURX

 Q:'$$INAC^APCHSMU(APCHSITI)  ;is item turned on or off

 S X=$$PLTAX^APCHSMU(APCHSPAT,"BGP IHD DXS")  ;is ihd on problem list

 S Y=$$LASTITEM^APCLAPIU(APCHSPAT,"[BGP IHD DXS]","DX")

 I Y]"",Y<$$FMADD^XLFDT(DT,-365) S Y=""

 I 'X,'Y Q  ;no pl dx and no pov in past year

 S APCHSINT="",APCHSCRI=$$SITECRIT^APCHSMU(APCHSITI)

 I APCHSCRI S APCHSINT=$$AGESEX^APCHSMU(APCHSITI,APCHSPAT),APCHMIN=$$MINAGE^APCHSMU(APCHSITI,APCHSPAT)

 I 'APCHSCRI D

 .Q:APCHSAGE<18

 .S APCHSINT=365

 .S APCHMIN=18

 S APCHLAST="",APCHNEXT="" K APCHSTEX

 S APCHTAXN=$O(^ATXLAB("B","DM AUDIT LDL CHOLESTEROL TAX",0))

 I APCHSINT,APCHTAXN="" S APCHSTEX(1)="DM AUDIT LDL CHOLESTEROL TAX Taxonomy Missing" D WRITE^APCHSMU X APCHSURX Q

 S APCHICAR=$$LASTLAB^APCLAPIU(APCHSPAT,,,,$O(^ATXLAB("B","DM AUDIT LDL CHOLESTEROL TAX",0)),,$O(^ATXAX("B","BGP LDL LOINC CODES",0)),"A")

 S APCHLAST=$P(APCHICAR,U,1)

 S APCHOVR=$$OVR^APCHSMU(APCHSPAT,APCHSITI)

 I $P(APCHOVR,U)>APCHLAST D  Q

 .S X=$$DATE^APCHSMU($P(APCHOVR,U))_" (per "_$P(APCHOVR,U,2)_")" D S(X) S X=$P(APCHOVR,U,3) D S(X)

 .D REF^APCHSM02

 .D WRITE^APCHSMU

 .X APCHSURX

 .Q

LDL1REG ;regular stuff

 I APCHSINT="" X APCHSURX Q  ;no frequency so skip it

 I APCHLAST="" S APCHSTEX(1)=$$DATE^APCHSMU($$DATEAGE^APCHSMU(APCHSPAT,APCHMIN)) D  Q

 .D REF^APCHSM02

 .D WRITE^APCHSMU

 .X APCHSURX

 .Q

 S APCHNEXT=$$FMADD^XLFDT(APCHLAST,APCHSINT)

 I APCHNEXT>DT S APCHSTEX(1)=$$DATE^APCHSMU(APCHNEXT)

 I APCHNEXT'>DT S APCHSTEX(1)=$$DATE^APCHSMU(APCHNEXT)

 D REF^APCHSM02

 D WRITE^APCHSMU

 X APCHSURX

 Q

 ;

LDL2 ;

 X APCHSURX

 Q:'$$INAC^APCHSMU(APCHSITI)  ;is item turned on or off

 S X=$$PLTAX^APCHSMU(APCHSPAT,"BGP IHD DXS")  ;is ihd on problem list

 S Y=$$LASTITEM^APCHSMU(APCHSPAT,"[BGP IHD DXS]","DX")

 I Y]"",Y<$$FMADD^XLFDT(DT,-365) S Y=""

 I 'X,'Y Q  ;no pl dx and no pov in past year

 ;S APCHICAR=$$LASTLDL(APCHSPAT)  ;IF Last one in 5 years NOT >=100 THEN QUIT

 ;S APCHLAST=$P(APCHICAR,U,1)

 S APCHICAR=$$LASTLAB^APCLAPIU(APCHSPAT,$$FMADD^XLFDT(DT,-(5*365)),DT,,$O(^ATXLAB("B","DM AUDIT LDL CHOLESTEROL TAX",0)),,$O(^ATXAX("B","BGP LDL LOINC CODES",0)),"A")

 S APCHLAST=$P(APCHICAR,U,1)

 I 'APCHLAST Q  ;last ldl in past 5 years not >=100

 S APCHRES=$P(APCHICAR,U,3)

 I APCHRES'=+APCHRES Q  ;not a valid ldl value

 I APCHRES'>100 Q  ;not greater than 100

 S APCHSINT="",APCHSCRI=$$SITECRIT^APCHSMU(APCHSITI)

 I APCHSCRI S APCHSINT=$$AGESEX^APCHSMU(APCHSITI,APCHSPAT),APCHMIN=$$MINAGE^APCHSMU(APCHSITI,APCHSPAT)

 I 'APCHSCRI D

 .Q:APCHSAGE<18

 .S APCHSINT=365

 .S APCHMIN=18

 S APCHNEXT="" K APCHSTEX

 S APCHTAXN=$O(^ATXLAB("B","DM AUDIT LDL CHOLESTEROL TAX",0))

 I APCHSINT,APCHTAXN="" S APCHSTEX(1)="DM AUDIT LDL CHOLESTEROL TAX Taxonomy Missing" D WRITE^APCHSMU X APCHSURX Q

 S APCHOVR=$$OVR^APCHSMU(APCHSPAT,APCHSITI)

 I $P(APCHOVR,U)>APCHLAST D  Q

 .S X=$$DATE^APCHSMU($P(APCHOVR,U))_" (per "_$P(APCHOVR,U,2)_")" D S(X) S X=$P(APCHOVR,U,3) D S(X)

 .D REF^APCHSM02

 .D WRITE^APCHSMU

 .X APCHSURX

 .Q

LDL2REG ;regular stuff

 S APCHSTEX(1)="Last LDL above goal "_$$FMTE^XLFDT($P(APCHLAST,U))_"  "_APCHRES D  Q

 .D REF^APCHSM02

 .D WRITE^APCHSMU

 .X APCHSURX

 .Q

 Q

 ;

SETR ;

 Q:$P(V,U,3)<APCHLAST

 Q:APCHLSTR>$P(V,U,3)

 S APCHLSTR=$P(V,U,3)

 S APCHLSTR(1)=$P(V,U,1)

 S APCHLSTR(2)=$P(V,U,2)

 Q

OSTEOREF ;

 S X="" K APCHLSTR S APCHLSTR=""

 I X="" S V=$$REF^APCHSMU(APCHSPAT,81,$O(^ICD0("BA",88.98,0)),APCHLAST) I V]"" D SETR

 S APCHT=$O(^ATXAX("B","BGP OSTEO SCREEN CPTS",0))

 I APCHT S V=$$RADREF^APCHSMU2(APCHSPAT,APCHLAST,DT,APCHT) I V]"" D SETR

 S APCHT=$O(^ATXAX("B","BGP OSTEO SCREEN CPTS",0))

 I APCHT S V=$$CPTREFT^APCHSMU2(APCHSPAT,APCHLAST,DT,APCHT) I V]"" D SETR

 I APCHLSTR]"" S X=$G(APCHLSTR(1)) D S(X) S X=$G(APCHLSTR(2)) I X]"" D S(X)

 Q

 ;

OSTOWT ;

 K APCHV

 D OSTEOREF

 D WRITE^APCHSMU

 X APCHSURX

 Q

OSTEO ;EP - OSTEOPOROSIS screening

 Q:'$$INAC^APCHSMU(APCHSITI)  ;is item turned on or off

 S APCHHOST=""

 I $$LASTDX^APCHSMU2(APCHSPAT,"BGP OSTEOPOROSIS DXS",$P(^DPT(DFN,0),U,3),DT) S APCHHOST=1  ;had osteoporosis dx

 I 'APCHHOST,$$PLTAX^APCHSMU(APCHSPAT,"BGP OSTEOPOROSIS DXS",,1) S APCHHOST=1  ;OSTEO is on Problem List

 I 'APCHHOST,$$IPLSNO^APCHSMU1(APCHSPAT,"PXRM OSTEOPOROSIS-OSTEOPENIA",1) S APCHHOST=1

 S APCHLAST="",APCHNEXT="" K APCHSTEX

 S APCHICAR=$$LASTOST^APCLAPI4(APCHSPAT,,,"A")

 S APCHLAST=$P(APCHICAR,U,1)

 S APCHOVR=$$OVR^APCHSMU(APCHSPAT,APCHSITI)

 I $P(APCHOVR,U)>APCHLAST D  Q

 .S X=$$DATE^APCHSMU($P(APCHOVR,U))_" (per "_$P(APCHOVR,U,2)_")" D S(X) S X=$P(APCHOVR,U,3) D S(X)

 .D OSTEOREF

 .D WRITE^APCHSMU

 .X APCHSURX

 .Q

OSTOREG ;regular stuff

 S APCHSINT="",APCHSCRI=$$SITECRIT^APCHSMU(APCHSITI)

 I 'APCHSCRI,APCHSAGE>64,$P(^DPT(APCHSPAT,0),U,2)="F" S APCHSINT=(365*2),APCHMIN=65

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

 I 'APCHSCRI Q:APCHSAGE<65

 I APCHSCRI S APCHSINT=$$AGESEX^APCHSMU(APCHSITI,APCHSPAT) ;return in APCHSINT the frequency in days for this age/sex

 I APCHSINT="" X APCHSURX Q  ;no frequency so skip it

 I APCHLAST="" S APCHSTEX(1)=$$DATE^APCHSMU($$DATEAGE^APCHSMU(APCHSPAT,APCHMIN)) D OSTOWT Q

 S A=$$DATEAGE^APCHSMU(APCHSPAT,APCHMIN)

 I 'APCHHOST D  Q

 .I APCHLAST'<A Q  ;HAD ONE AFTER AGE 65

 .S APCHNEXT=A

 .I APCHNEXT>DT S APCHSTEX(1)=$$DATE^APCHSMU(APCHNEXT)

 .I APCHNEXT'>DT S APCHSTEX(1)=$$DATE^APCHSMU(APCHNEXT)

 .D OSTOWT

 I APCHHOST D  Q

 .;every 2 years

 .S APCHNEXT=$$FMADD^XLFDT(APCHLAST,APCHSINT)

 .I APCHNEXT>DT S APCHSTEX(1)=$$DATE^APCHSMU(APCHNEXT)

 .I APCHNEXT'>DT S APCHSTEX(1)=$$DATE^APCHSMU(APCHNEXT)

 .D OSTOWT

 Q

 ;

AOFOWT ;

 K APCHV

 D WRITE^APCHSMU

 X APCHSURX

 Q

AOF ;EP - AOF

 Q:'$$INAC^APCHSMU(APCHSITI)  ;is item turned on or off

 S APCHLAST="",APCHNEXT="" K APCHSTEX

 S APCHICAR=$$LASTAOF^APCLAPI4(APCHSPAT,,,"A")

 S APCHLAST=$P(APCHICAR,U,1)

 S APCHOVR=$$OVR^APCHSMU(APCHSPAT,APCHSITI)

 I $P(APCHOVR,U)>APCHLAST D  Q

 .S X=$$DATE^APCHSMU($P(APCHOVR,U))_" (per "_$P(APCHOVR,U,2)_")" D S(X) S X=$P(APCHOVR,U,3) D S(X)

 .D WRITE^APCHSMU

 .X APCHSURX

 .Q

AOFOREG ;regular stuff

 S APCHSINT="",APCHSCRI=$$SITECRIT^APCHSMU(APCHSITI)

 I 'APCHSCRI,APCHSAGE>64 S APCHSINT=365,APCHMIN=65

 I 'APCHSCRI Q:APCHSAGE<65

 I APCHSCRI S APCHSINT=$$AGESEX^APCHSMU(APCHSITI,APCHSPAT),APCHMIN=$$MINAGE^APCHSMU(APCHSITI,APCHSPAT) ;return in APCHSINT the frequency in days for this age/sex

 I APCHSINT="" X APCHSURX Q  ;no frequency so skip it

 I APCHLAST="" S APCHSTEX(1)=$$DATE^APCHSMU($$DATEAGE^APCHSMU(APCHSPAT,APCHMIN)) D AOFOWT Q

 S APCHNEXT=$$FMADD^XLFDT(APCHLAST,APCHSINT)

 I APCHNEXT>DT S APCHSTEX(1)=$$DATE^APCHSMU(APCHNEXT)

 I APCHNEXT'>DT S APCHSTEX(1)=$$DATE^APCHSMU(APCHNEXT)

 D AOFOWT

 Q

CHLEOREF ;

 S X="" K APCHLSTR S APCHLSTR=""

 S APCHT=$O(^ATXAX("B","BGP CHLAMYDIA CPTS",0))

 I APCHT S V=$$CPTREFT^APCHSMU2(APCHSPAT,APCHLAST,DT,APCHT) I V]"" D SETR

 I APCHLSTR]"" S X=$G(APCHLSTR(1)) D S(X) S X=$G(APCHLSTR(2)) I X]"" D S(X)

 S APCHTAXN=$O(^ATXLAB("B","BGP CHLAMYDIA TESTS TAX",0)) D REF^APCHSM02

 Q

 ;

CHLOWT ;

 K APCHV

 D CHLEOREF

 D WRITE^APCHSMU

 X APCHSURX

 Q

CHLEO ;EP - CHLAMYDIA screening

 Q:$P(^DPT(APCHSPAT,0),U,2)'="F"  ;females only

 Q:'$$INAC^APCHSMU(APCHSITI)  ;is item turned on or off

 NEW D,APCH16BD,APCH25BD,APCH26BD

 S D=$P(^DPT(DFN,0),U,3)

 S APCH16BD=$E(D,1,3)+16_$E(D,4,7)

 S APCH26BD=$E(D,1,3)+26_$E(D,4,7),APCH25BD=$$FMADD^XLFDT(APCH26BD,-1)

 I $$LASTDX^APCHSMU2(APCHSPAT,"BKM CHLAMYDIA DXS",$$FMADD^XLFDT(DT,-365),DT) Q  ;had CHLAMYDIA dx in past year so don't prompt

 ;I $$PLTAX^APCHSMU(APCHSPAT,"BKM CHLAMYDIA DXS") Q  ;chlamydia on problem list -NO per Susan

 S APCHLAST="",APCHNEXT="" K APCHSTEX

 S APCHICAR=$$LASTCHLA^APCLAPI5(APCHSPAT,,DT,"A")

 S APCHLAST=$P(APCHICAR,U,1)

 S APCHOVR=$$OVR^APCHSMU(APCHSPAT,APCHSITI)

 I $P(APCHOVR,U)>APCHLAST D  Q

 .S X=$$DATE^APCHSMU($P(APCHOVR,U))_" (per "_$P(APCHOVR,U,2)_")" D S(X) S X=$P(APCHOVR,U,3) D S(X)

 .D CHLEOREF

 .D WRITE^APCHSMU

 .X APCHSURX

 .Q

CHLOREG ;regular stuff

 ;S APCHSINT="",APCHSCRI=$$SITECRIT^APCHSMU(APCHSITI)

 Q:APCHSAGE>25

 Q:APCHSAGE<16

 ;I $$LASTCHLA^APCLAPI5(APCHSPAT,,DT)]"" Q

 S APCHSINT=365

 ;I APCHSCRI S APCHSINT=$$AGESEX^APCHSMU(APCHSITI,APCHSPAT) ;return in APCHSINT the frequency in days for this age/sex

 I APCHSINT="" X APCHSURX Q  ;no frequency so skip it

 I APCHLAST="" S APCHSTEX(1)=$$DATE^APCHSMU(APCH16BD) D CHLOWT Q

 S APCHNEXT=$$FMADD^XLFDT(APCHLAST,APCHSINT)

 I APCHNEXT>DT S APCHSTEX(1)=$$DATE^APCHSMU(APCHNEXT)

 I APCHNEXT'>DT S APCHSTEX(1)=$$DATE^APCHSMU(APCHNEXT)

 D CHLOWT

 Q

 ;

HIVEOREF ;

 S X="" K APCHLSTR S APCHLSTR=""

 S APCHT=$O(^ATXAX("B","BGP CPT HIV TESTS",0))

 I APCHT S V=$$CPTREFT^APCHSMU2(APCHSPAT,APCHLAST,DT,APCHT) I V]"" D SETR

 I APCHLSTR]"" S X=$G(APCHLSTR(1)) D S(X) S X=$G(APCHLSTR(2)) I X]"" D S(X)

 S APCHTAXN=$O(^ATXLAB("B","BGP HIV TEST TAX",0)) D REF^APCHSM02

 Q

 ;

HIVOWT ;

 K APCHV

 D HIVEOREF

 D WRITE^APCHSMU

 X APCHSURX

 Q

HIVSCR ;EP - HIV screening

 Q:'$$INAC^APCHSMU(APCHSITI)  ;is item turned on or off

 I $$LASTDX^APCHSMU2(APCHSPAT,"BGP HIV/AIDS DXS",$P(^DPT(DFN,0),U,3),DT) Q  ;had HIV dx

 I $$PLTAX^APCHSMU(APCHSPAT,"BGP HIV/AIDS DXS",,1) X APCHSURX Q  ;HIV on problem list

 I $$IPLSNO^APCHSMU1(APCHSPAT,"PXRM HIV",1) X APCHSURX Q

 NEW D,APCH13BD,APCH65BD,APCH64BD

 S D=$P(^DPT(DFN,0),U,3)

 S APCH13BD=$E(D,1,3)+13_$E(D,4,7)

 S APCH65BD=$E(D,1,3)+65_$E(D,4,7),APCH64BD=$$FMADD^XLFDT(APCH65BD,-1)

 S APCHLAST="",APCHNEXT="" K APCHSTEX

 S APCHICAR=$$LASTHIVS^APCLAPI5(APCHSPAT,APCH13BD,APCH64BD,"A")

 S APCHLAST=$P(APCHICAR,U,1)

 S APCHOVR=$$OVR^APCHSMU(APCHSPAT,APCHSITI)

 I $P(APCHOVR,U)>APCHLAST D  Q

 .S X=$$DATE^APCHSMU($P(APCHOVR,U))_" (per "_$P(APCHOVR,U,2)_")" D S(X) S X=$P(APCHOVR,U,3) D S(X)

 .D HIVEOREF

 .D WRITE^APCHSMU

 .X APCHSURX

 .Q

HIVOREG ;regular stuff

 S APCHSINT=1  ;,APCHSCRI=$$SITECRIT^APCHSMU(APCHSITI)

 Q:APCHSAGE>64

 Q:APCHSAGE<13

 I APCHLAST]"" Q

 S APCHSINT=1

 ;I APCHSCRI S APCHSINT=$$AGESEX^APCHSMU(APCHSITI,APCHSPAT) ;return in APCHSINT the frequency in days for this age/sex

 I APCHSINT="" X APCHSURX Q  ;no frequency so skip it

 I APCHLAST="" S APCHSTEX(1)=$$DATE^APCHSMU(APCH13BD) D HIVOWT Q

 S APCHNEXT=$$FMADD^XLFDT(APCHLAST,APCHSINT)

 I APCHNEXT>DT S APCHSTEX(1)=$$DATE^APCHSMU(APCHNEXT)

 I APCHNEXT'>DT S APCHSTEX(1)=$$DATE^APCHSMU(APCHNEXT)

 D HIVOWT

 Q

 ;

APCHSM06  ; IHS/CMI/LAB -- CONTINUATION OF ROUTINES ;

 +1       ;;2.0;IHS PCC SUITE;**2,11,14,16**;MAY 14, 2009;Build 9

 +2       ;IHS/CMI/LAB - uncommented age limit on pap smear

 +3       ;

 +4       ; ******************** SURVEILLANCE - HARD CODE ********************

S(X)      ;

 +1        NEW %,C

           SET (C,%)=0

           FOR 

               SET %=$ORDER(APCHSTEX(%))

               IF %'=+%

                   QUIT 

               SET C=C+1

 +2        SET APCHSTEX(C+1)=X

 +3        QUIT 

PPDWT     ;

 +1        SET V=$$REF^APCHSMU(APCHSPAT,9999999.28,APCHSFLX,APCHLAST)

           IF V]""

               SET X=$PIECE(V,U)

               DO S(X)

               SET X=$PIECE(V,U,2)

               IF X]""

                   DO S(X)

 +2        DO WRITE^APCHSMU

 +3        XECUTE APCHSURX

 +4        QUIT 

PPD       ;EP - PPD

 +1        XECUTE APCHSURX

 +2       ;is item turned on or off

           IF '$$INAC^APCHSMU(APCHSITI)

               QUIT 

 +3        SET APCHLAST=""

           SET APCHNEXT=""

           KILL APCHSTEX

 +4        SET APCHSINT=""

           SET APCHSCRI=$$SITECRIT^APCHSMU(APCHSITI)

 +5        SET APCHSFLX=$ORDER(^AUTTSK("B","PPD",0))

           SET APCHIMMC="PPD"

 +6        SET APCHICAR=$$LASTITEM^APCLAPIU(APCHSPAT,"PPD","SKIN",,,"A")

 +7        SET APCHLAST=$PIECE(APCHICAR,U,1)

 +8        SET APCHOVR=$$OVR^APCHSMU(APCHSPAT,APCHSITI)

 +9        IF $PIECE(APCHOVR,U)>APCHLAST

               Begin DoDot:1

 +10               SET X=$$DATE^APCHSMU($PIECE(APCHOVR,U))_" (per "_$PIECE(APCHOVR,U,2)_")"

                   DO S(X)

                   SET X=$PIECE(APCHOVR,U,3)

                   DO S(X)

 +11               DO PPDWT

 +12               QUIT 

               End DoDot:1

               QUIT 

PPDREG    ;

 +1        IF APCHSCRI

               SET APCHSINT=$$AGESEX^APCHSMU(APCHSITI,APCHSPAT)

               SET APCHMIN=$$MINAGE^APCHSMU(APCHSITI,APCHSPAT)

 +2        IF 'APCHSCRI

               DO PPDIHS

               QUIT 

 +3       ;no frequency so skip it

           IF APCHSINT=""

               XECUTE APCHSURX

               QUIT 

 +4       ;known tb

           IF $$PPDS^APCHS9B5(APCHSPAT)]""

               XECUTE APCHSURX

               QUIT 

 +5        IF APCHLAST=""

               SET APCHSTEX(1)=$$DATE^APCHSMU($$DATEAGE^APCHSMU(APCHSPAT,APCHMIN))

               DO PPDWT

               QUIT 

 +6        SET APCHNEXT=$$FMADD^XLFDT(APCHLAST,APCHSINT)

 +7        IF APCHNEXT>DT

               SET APCHSTEX(1)=$$DATE^APCHSMU(APCHNEXT)

 +8        IF APCHNEXT'>DT

               SET APCHSTEX(1)=$$DATE^APCHSMU(APCHNEXT)

 +9        DO PPDWT

 +10       QUIT 

 +11      ;

PPDIHS    ;

 +1        IF APCHSAGE>18

               QUIT 

 +2        IF APCHSAGE<4

               QUIT 

 +3        SET APCHMIN=4

 +4       ;known tb

           IF $$PPDS^APCHS9B5(APCHSPAT)]""

               XECUTE APCHSURX

               QUIT 

 +5        IF APCHLAST=""

               SET APCHSTEX(1)=$$DATE^APCHSMU($$DATEAGE^APCHSMU(APCHSPAT,APCHMIN))

               DO PPDWT

               QUIT 

 +6        SET APCHSOLD=$$FMDIFF^XLFDT(APCHLAST,APCHSDOB)

 +7        IF APCHSAGE>3

               IF APCHSAGE<11

                   Begin DoDot:1

 +8                    IF APCHSOLD<(3*365)

                           SET APCHSTEX(1)=$$DATE^APCHSMU($$FMADD^XLFDT(APCHSDOB,(4*365)))

                           DO PPDWT

                           QUIT 

 +9                    SET APCHNEXT=$$FMADD^XLFDT(APCHSDOB,(11*365))

                       SET APCHSTEX(1)=$$DATE^APCHSMU(APCHNEXT)

                       DO PPDWT

                       QUIT 

                   End DoDot:1

                   QUIT 

 +10       IF APCHSAGE>10

               IF APCHSOLD<(9*365)

                   SET APCHSTEX(1)=$$DATE^APCHSMU($$FMADD^XLFDT(APCHSDOB,(11*365)))

                   DO PPDWT

                   QUIT 

 +11       QUIT 

 +12      ;

LDL1      ;

 +1        XECUTE APCHSURX

 +2       ;is item turned on or off

           IF '$$INAC^APCHSMU(APCHSITI)

               QUIT 

 +3       ;is ihd on problem list

           SET X=$$PLTAX^APCHSMU(APCHSPAT,"BGP IHD DXS")

 +4        SET Y=$$LASTITEM^APCLAPIU(APCHSPAT,"[BGP IHD DXS]","DX")

 +5        IF Y]""

               IF Y<$$FMADD^XLFDT(DT,-365)

                   SET Y=""

 +6       ;no pl dx and no pov in past year

           IF 'X

               IF 'Y

                   QUIT 

 +7        SET APCHSINT=""

           SET APCHSCRI=$$SITECRIT^APCHSMU(APCHSITI)

 +8        IF APCHSCRI

               SET APCHSINT=$$AGESEX^APCHSMU(APCHSITI,APCHSPAT)

               SET APCHMIN=$$MINAGE^APCHSMU(APCHSITI,APCHSPAT)

 +9        IF 'APCHSCRI

               Begin DoDot:1

 +10               IF APCHSAGE<18

                       QUIT 

 +11               SET APCHSINT=365

 +12               SET APCHMIN=18

               End DoDot:1

 +13       SET APCHLAST=""

           SET APCHNEXT=""

           KILL APCHSTEX

 +14       SET APCHTAXN=$ORDER(^ATXLAB("B","DM AUDIT LDL CHOLESTEROL TAX",0))

 +15       IF APCHSINT

               IF APCHTAXN=""

                   SET APCHSTEX(1)="DM AUDIT LDL CHOLESTEROL TAX Taxonomy Missing"

                   DO WRITE^APCHSMU

                   XECUTE APCHSURX

                   QUIT 

 +16       SET APCHICAR=$$LASTLAB^APCLAPIU(APCHSPAT,,,,$ORDER(^ATXLAB("B","DM AUDIT LDL CHOLESTEROL TAX",0)),,$ORDER(^ATXAX("B","BGP LDL LOINC CODES",0)),"A")

 +17       SET APCHLAST=$PIECE(APCHICAR,U,1)

 +18       SET APCHOVR=$$OVR^APCHSMU(APCHSPAT,APCHSITI)

 +19       IF $PIECE(APCHOVR,U)>APCHLAST

               Begin DoDot:1

 +20               SET X=$$DATE^APCHSMU($PIECE(APCHOVR,U))_" (per "_$PIECE(APCHOVR,U,2)_")"

                   DO S(X)

                   SET X=$PIECE(APCHOVR,U,3)

                   DO S(X)

 +21               DO REF^APCHSM02

 +22               DO WRITE^APCHSMU

 +23               XECUTE APCHSURX

 +24               QUIT 

               End DoDot:1

               QUIT 

LDL1REG   ;regular stuff

 +1       ;no frequency so skip it

           IF APCHSINT=""

               XECUTE APCHSURX

               QUIT 

 +2        IF APCHLAST=""

               SET APCHSTEX(1)=$$DATE^APCHSMU($$DATEAGE^APCHSMU(APCHSPAT,APCHMIN))

               Begin DoDot:1

 +3                DO REF^APCHSM02

 +4                DO WRITE^APCHSMU

 +5                XECUTE APCHSURX

 +6                QUIT 

               End DoDot:1

               QUIT 

 +7        SET APCHNEXT=$$FMADD^XLFDT(APCHLAST,APCHSINT)

 +8        IF APCHNEXT>DT

               SET APCHSTEX(1)=$$DATE^APCHSMU(APCHNEXT)

 +9        IF APCHNEXT'>DT

               SET APCHSTEX(1)=$$DATE^APCHSMU(APCHNEXT)

 +10       DO REF^APCHSM02

 +11       DO WRITE^APCHSMU

 +12       XECUTE APCHSURX

 +13       QUIT 

 +14      ;

LDL2      ;

 +1        XECUTE APCHSURX

 +2       ;is item turned on or off

           IF '$$INAC^APCHSMU(APCHSITI)

               QUIT 

 +3       ;is ihd on problem list

           SET X=$$PLTAX^APCHSMU(APCHSPAT,"BGP IHD DXS")

 +4        SET Y=$$LASTITEM^APCHSMU(APCHSPAT,"[BGP IHD DXS]","DX")

 +5        IF Y]""

               IF Y<$$FMADD^XLFDT(DT,-365)

                   SET Y=""

 +6       ;no pl dx and no pov in past year

           IF 'X

               IF 'Y

                   QUIT 

 +7       ;S APCHICAR=$$LASTLDL(APCHSPAT)  ;IF Last one in 5 years NOT >=100 THEN QUIT

 +8       ;S APCHLAST=$P(APCHICAR,U,1)

 +9        SET APCHICAR=$$LASTLAB^APCLAPIU(APCHSPAT,$$FMADD^XLFDT(DT,-(5*365)),DT,,$ORDER(^ATXLAB("B","DM AUDIT LDL CHOLESTEROL TAX",0)),,$ORDER(^ATXAX("B","BGP LDL LOINC CODES",0)),"A")

 +10       SET APCHLAST=$PIECE(APCHICAR,U,1)

 +11      ;last ldl in past 5 years not >=100

           IF 'APCHLAST

               QUIT 

 +12       SET APCHRES=$PIECE(APCHICAR,U,3)

 +13      ;not a valid ldl value

           IF APCHRES'=+APCHRES

               QUIT 

 +14      ;not greater than 100

           IF APCHRES'>100

               QUIT 

 +15       SET APCHSINT=""

           SET APCHSCRI=$$SITECRIT^APCHSMU(APCHSITI)

 +16       IF APCHSCRI

               SET APCHSINT=$$AGESEX^APCHSMU(APCHSITI,APCHSPAT)

               SET APCHMIN=$$MINAGE^APCHSMU(APCHSITI,APCHSPAT)

 +17       IF 'APCHSCRI

               Begin DoDot:1

 +18               IF APCHSAGE<18

                       QUIT 

 +19               SET APCHSINT=365

 +20               SET APCHMIN=18

               End DoDot:1

 +21       SET APCHNEXT=""

           KILL APCHSTEX

 +22       SET APCHTAXN=$ORDER(^ATXLAB("B","DM AUDIT LDL CHOLESTEROL TAX",0))

 +23       IF APCHSINT

               IF APCHTAXN=""

                   SET APCHSTEX(1)="DM AUDIT LDL CHOLESTEROL TAX Taxonomy Missing"

                   DO WRITE^APCHSMU

                   XECUTE APCHSURX

                   QUIT 

 +24       SET APCHOVR=$$OVR^APCHSMU(APCHSPAT,APCHSITI)

 +25       IF $PIECE(APCHOVR,U)>APCHLAST

               Begin DoDot:1

 +26               SET X=$$DATE^APCHSMU($PIECE(APCHOVR,U))_" (per "_$PIECE(APCHOVR,U,2)_")"

                   DO S(X)

                   SET X=$PIECE(APCHOVR,U,3)

                   DO S(X)

 +27               DO REF^APCHSM02

 +28               DO WRITE^APCHSMU

 +29               XECUTE APCHSURX

 +30               QUIT 

               End DoDot:1

               QUIT 

LDL2REG   ;regular stuff

 +1        SET APCHSTEX(1)="Last LDL above goal "_$$FMTE^XLFDT($PIECE(APCHLAST,U))_"  "_APCHRES

           Begin DoDot:1

 +2            DO REF^APCHSM02

 +3            DO WRITE^APCHSMU

 +4            XECUTE APCHSURX

 +5            QUIT 

           End DoDot:1

           QUIT 

 +6        QUIT 

 +7       ;

SETR      ;

 +1        IF $PIECE(V,U,3)<APCHLAST

               QUIT 

 +2        IF APCHLSTR>$PIECE(V,U,3)

               QUIT 

 +3        SET APCHLSTR=$PIECE(V,U,3)

 +4        SET APCHLSTR(1)=$PIECE(V,U,1)

 +5        SET APCHLSTR(2)=$PIECE(V,U,2)

 +6        QUIT 

OSTEOREF  ;

 +1        SET X=""

           KILL APCHLSTR

           SET APCHLSTR=""

 +2        IF X=""

               SET V=$$REF^APCHSMU(APCHSPAT,81,$ORDER(^ICD0("BA",88.98,0)),APCHLAST)

               IF V]""

                   DO SETR

 +3        SET APCHT=$ORDER(^ATXAX("B","BGP OSTEO SCREEN CPTS",0))

 +4        IF APCHT

               SET V=$$RADREF^APCHSMU2(APCHSPAT,APCHLAST,DT,APCHT)

               IF V]""

                   DO SETR

 +5        SET APCHT=$ORDER(^ATXAX("B","BGP OSTEO SCREEN CPTS",0))

 +6        IF APCHT

               SET V=$$CPTREFT^APCHSMU2(APCHSPAT,APCHLAST,DT,APCHT)

               IF V]""

                   DO SETR

 +7        IF APCHLSTR]""

               SET X=$GET(APCHLSTR(1))

               DO S(X)

               SET X=$GET(APCHLSTR(2))

               IF X]""

                   DO S(X)

 +8        QUIT 

 +9       ;

OSTOWT    ;

 +1        KILL APCHV

 +2        DO OSTEOREF

 +3        DO WRITE^APCHSMU

 +4        XECUTE APCHSURX

 +5        QUIT 

OSTEO     ;EP - OSTEOPOROSIS screening

 +1       ;is item turned on or off

           IF '$$INAC^APCHSMU(APCHSITI)

               QUIT 

 +2        SET APCHHOST=""

 +3       ;had osteoporosis dx

           IF $$LASTDX^APCHSMU2(APCHSPAT,"BGP OSTEOPOROSIS DXS",$PIECE(^DPT(DFN,0),U,3),DT)