APCHSTP.m

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

 ;;2.0;IHS PCC SUITE;**2,7,15,16,20**;MAY 14, 2009;Build 25

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

 ; 

 ; 

GETTPT(APCHI,C,R,EVENT,EVENT1) ;EP

 I 'APCHI K R Q

 S EVENT=$G(EVENT)

 S EVENT1=$G(EVENT1)

 K R

 S R(0)=$S($P(^APCHSURV(APCHI,0),U,4)]"":$P(^APCHSURV(APCHI,0),U,4),1:$P(^APCHSURV(APCHI,0),U,1))

 K ^UTILITY($J,"W")

 NEW X,APCHY

 S APCHY=0

 S DIWL=0,DIWR=C,DIWF="" F  S APCHY=$O(^APCHSURV(APCHI,12,APCHY)) Q:APCHY'=+APCHY  D

 .S X=^APCHSURV(APCHI,12,APCHY,0)

 .I X["|" S X=$$INTP(X)

 .D ^DIWP

 S X=0 F  S X=$O(^UTILITY($J,"W",DIWL,X)) Q:X'=+X  S R(X)=^UTILITY($J,"W",DIWL,X,0)

 Q

 ;

INTP(V) ;

 N A,Z,X,K,Y

 ;S X=V

 ;X ^%ZOSF("UPPERCASE")

 S (Y,A)=V

 S Z=$P(A,"|")

 F I=2:2 S J=$P(Y,"|",I) Q:J=""  D

 .S K=$P(J," ")

 .I $T(@K)="" S A="" Q

 .S Z="" D @K

 .S A=$P(A,("|"_J_"|"))_Z_$P(A,("|"_J_"|"),2)

 Q A

 ;

WRITETP ;EP - write out TP

 I $G(APCHSGHR) D  Q

 .NEW A,B

 .S (A,B)=0

 .S APCHRVAL(0)="1^"_$P(^APCHSURV(APCHSITI,0),U)

 .F  S B=$O(APCHSTEX(B)) Q:B'=+B  S A=A+1,APCHRVAL(A)=APCHSTEX(B)

 I 'APCHSANY D FIRST Q:$D(APCHSQIT)  S APCHSANY=1,APCHSNPG=0

 X APCHSCKP Q:$D(APCHSQIT)

 I APCHSNPG S APCHSCT=0,APCHSNPG=0

 S APCHX=$S($P(^APCHSURV(APCHSITI,0),U,4)]"":$P(^APCHSURV(APCHSITI,0),U,4),1:$P(^APCHSURV(APCHSITI,0),U))

 W APCHX

 I $L(APCHX)>28 W !

 ;W ?30,APCHSTEX(1)

 F APCHSL=1:1 Q:'$D(APCHSTEX(APCHSL))!($D(APCHSQIT))  D

 .X APCHSCKP Q:$D(APCHSQIT)

 .W ?30,APCHSTEX(APCHSL),!

 ;W !

 ;S APCHSCT=APCHSCT+1

 ;I '(APCHSCT#2) X APCHSCKP Q:$D(APCHSQIT)  W:'APCHSNPG !

 K APCHSTEX

 Q

 ;

FIRST ;EP

 X APCHSCKP Q:$D(APCHSQIT)  X:'APCHSNPG APCHSBRK

 ;W !

 ;S APCHSCT=0

 Q

 ;

CVD ;EP

 NEW APCHSTAT

 Q:'$$INAC^APCHSMU(APCHSITI)

 I $T(EN^BQITRPHS)="" Q

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

 D EN^BQITRPHS(APCHSPAT,$P(^APCHSURV(APCHSITI,0),U,1),.APCHSBQI)

 K ^UTILITY($J,"W")

 NEW X,APCHY

 S APCHY=0

 S DIWL=0,DIWR=C,DIWF="" F  S APCHY=$O(APCHSBQI(APCHY)) Q:APCHY'=+APCHY  D

 .S X=APCHSBQI(APCHY)

 .D ^DIWP

 S X=0 F  S X=$O(^UTILITY($J,"W",DIWL,X)) Q:X'=+X  S APCHSTEX(X)=^UTILITY($J,"W",DIWL,X,0)

 D WRITETP

 X APCHSURX

 Q

 ;

HEARINQ ;EP

 X APCHSURX

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

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

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

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

 I 'APCHSCRI D

 .Q:APCHSAGE<65

 .S APCHSINT=(2*365)

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

 K APCHSTEX

 I $G(APCHCOLW)="" S APCHCOLW=48

 D GETTPT(APCHSITI,APCHCOLW,.APCHSTEX)

 D WRITETP

 X APCHSURX

 Q

 ;

STRAB ;EP

 X APCHSURX

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

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

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

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

 I 'APCHSCRI D

 .Q:APCHSAGE<3

 .Q:APCHSAGE>4

 .S APCHSINT=(2*365)

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

 K APCHSTEX

 I $G(APCHCOLW)="" S APCHCOLW=48

 D GETTPT(APCHSITI,APCHCOLW,.APCHSTEX)

 D WRITETP

 Q

 ;

ASHMR1 ;EP called from hmr

 ;increase steriods

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

 Q:'$$HMR1ST^APCHSMAS(APCHSPAT)  ;not a candidate for this reminder

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

 I $G(APCHCOLW)="" S APCHCOLW=48

 D GETTPT(APCHSITI,APCHCOLW,.APCHSTEX)

 D WRITETP

 Q

 ;

ASHMR2 ;EP called from health maintenance reminders

 ;asthma management plan

 Q:'$$INAC^APCHSMU(APCHSITI)

 S APCHICAR=""

 NEW APCHX,APCHY,Y

 S APCHX=0 F  S APCHX=$O(^AUTTEDT("C","ASM-SMP",APCHX)) Q:APCHX'=+APCHX  D

 .S Y=$$LASTITEM^APCLAPIU(APCHSPAT,"`"_APCHX,"EDUCATION",,,"A")

 .I Y="" Q

 .S APCHY($P(Y,U,1))=Y

 S APCHICAR=$O(APCHY(0)) I APCHICAR S APCHICAR=APCHY(APCHICAR)

 I APCHICAR="" S APCHICAR=$$LASTAM^APCHSAST(DFN,3)

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

 Q:Y>$$FMADD^XLFDT(DT,-365)  ;asthma plan in place in last year

 Q:'$$HMR2ST^APCHSMAS(APCHSPAT)  ;not a candidate

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

 I $G(APCHCOLW)="" S APCHCOLW=48

 D GETTPT(APCHSITI,APCHCOLW,.APCHSTEX)

 D WRITETP

 Q

 ;

ASHMR5 ;EP - called from hmr item

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

 Q:$P(^AUPNPAT(APCHSPAT,0),U,14)]""

 NEW APCHPRV

 D WHPCP^BDPAPI(APCHSPAT,.APCHPRV)

 I $G(APCHPRV("DESIGNATED PRIMARY PROVIDER"))]"" Q

 Q:'$$HMR5ST^APCHSMAS(APCHSPAT)

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

 I $G(APCHCOLW)="" S APCHCOLW=48

 D GETTPT(APCHSITI,APCHCOLW,.APCHSTEX)

 D WRITETP

 Q

 ;

ASHMR3 ;EP - called from maintenance reminder

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

 I $E(DT,4,5)="04"!($E(DT,4,5)="05")!($E(DT,4,5)="06")!($E(DT,4,5)="07")!($E(DT,4,5)="08") Q  ;don't display in summer

 X APCHSURX

 Q:'$$HMR3ST^APCHSMAS(APCHSPAT)  ;not a candidate for this reminder

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

 S APCHICAR=$$LASTFLU^APCLAPI4(APCHSPAT)

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

 I APCHLAST="" D W3 Q

 S D=$$FMDIFF^XLFDT(DT,APCHLAST)

 I +$E(DT,4,5)>8,D>210 D W3 Q

 I +$E(DT,4,5)<4,D>210 D W3 Q

 Q

W3 ;

 I $G(APCHCOLW)="" S APCHCOLW=48

 D GETTPT(APCHSITI,APCHCOLW,.APCHSTEX)

 D WRITETP

 Q

ASHMR4 ;EP - called from hmr item

 NEW APCHSTAT

 Q:'$$INAC^APCHSMU(APCHSITI)

 Q:$$IPLSNO^APCHSMAS(DFN,"PXRM ASTHMA CLASSIFIED")  ;has IPL of classified

 Q:$$PLTAXAC^APCHSMAS(DFN,"BJPC ASTHMA CLASSIFIED")  ;has ipl of classified

 Q:$$LASTASCL^APCHSMAS(APCHSPAT,1)]""  ;asthma severity documented

 Q:'$$HMR4ST^APCHSMAS(APCHSPAT)  ;not a candidate

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

 I $G(APCHCOLW)="" S APCHCOLW=48

 D GETTPT(APCHSITI,APCHCOLW,.APCHSTEX)

 D WRITETP

 Q

ASTCLASS(P) ;EP

 NEW APCH,G,BD,X,D,V,E

 S G=""

 S BD=$$DOB^AUPNPAT(P)

 S %=P_"^ALL DX [BJPC ASTHMA CLASSIFIED;DURING "_BD_"-"_DT,E=$$START1^APCLDF(%,"APCH(")

 I '$D(APCH) Q ""

 ;SKIP any not A or H

 S (G,X)=0 F  S X=$O(APCH(X)) Q:X'=+X!(G)  D

 .S V=$P(APCH(X),U,5) Q:'V

 .Q:"AH"'[$P($G(^AUPNVSIT(V,0)),U,7)

 .S G=1

 Q G

 ;

ASHMR8 ;EP - called from hmr item

 NEW APCHSTAT

 Q:'$$INAC^APCHSMU(APCHSITI)

 Q:$$IPLSNO^APCHSMAS(APCHSPAT,"PXRM ASTHMA CLASSIFIED")  ;has IPL of classified

 ;Q:$$PLTAXAC^APCHSMAS(P,"BJPC ASTHMA CLASSIFIED")

 Q:$$LASTASCL^APCHSMAS(APCHSPAT,1)]""  ;asthma severity documented

 Q:'$$ASTCLASS(APCHSPAT)  ;not a candidate as no pov for asthma classified

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

 I $G(APCHCOLW)="" S APCHCOLW=48

 D GETTPT(APCHSITI,APCHCOLW,.APCHSTEX)

 D WRITETP

 Q

ASHMR6 ;EP - called from hmr item

 NEW APCHSTAT

 Q:'$$INAC^APCHSMU(APCHSITI)

 Q:'$$HMR6ST^APCHSMAS(APCHSPAT)  ;not a candidate

 S APCHLAST=$$LASTACON^APCHSMAS(APCHSPAT,2)

 I $$FMDIFF^XLFDT(DT,APCHLAST)<365 Q  ;documented in past year

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

 I $G(APCHCOLW)="" S APCHCOLW=48

 D GETTPT(APCHSITI,APCHCOLW,.APCHSTEX)

 D WRITETP

 Q

ASHMR7 ;EP - called from hmr item

 NEW APCHSTAT,APCHSEV

 Q:'$$INAC^APCHSMU(APCHSITI)

 S APCHSEV=$$HMR7ST^APCHSMAS(APCHSPAT)  ;not a candidate

 Q:'APCHSEV

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

 I $G(APCHCOLW)="" S APCHCOLW=48

 D GETTPT(APCHSITI,APCHCOLW,.APCHSTEX,APCHSEV)

 D WRITETP

 Q

ASFS1 ;

 NEW A,X,K,Y

 S Z=$$FMTE^XLFDT($$LASTDXT^APCLAPIU(APCHSPAT,,,"BGP ASTHMA DXS","D"))

 I Z="" S Z=$$PLTAXAC^APCHSMAS(APCHSPAT,"BGP ASTHMA DXS") S Z=$P(Z,U,2)

 Q

ASAP1 ;

 NEW A,X,K,Y

 S Z=$P($$HMR2ST^APCHSMAS(APCHSPAT),U,2)

 Q

 ;

ASEV2 ;

 S Z="-- "_$P(EVENT,U,2)

 Q

ASEV3 ;

 S Z="-- "_$P(EVENT,U,3)

 Q

ASEV1 ;

 S Z=$P($$LASTACLG^APCHSMAS(APCHSPAT,2),U,2)

 I Z="" S Z="None Documented"

 Q

RUBELLA ;

 I EVENT1="NON-IMMUNE" D  Q

 .I EVENT]"" S Z="Rubella Immunization Status health factor is recorded "_""""_"Non-Immune"_""""_" but there is a record of rubella vaccination on "_$$DATE^APCHSMU(EVENT)_"." D RUBWT Q

 .S Z=Z_" Patient may be due for Rubella Vaccination"_"." D RUBWT Q

 I EVENT1="INDETERMINATE" D  Q

 .I EVENT]"" S Z="Rubella Immunization Status health factor is recorded "_""""_"Indeterminate"_""""_" but there is a record of rubella vaccination on "_$$DATE^APCHSMU(EVENT)_"." D RUBWT Q

 .S Z="Rubella Immunization Status health factor is recorded "_""""_"Indeterminate,"_""""_" needs further  clinical review." D RUBWT Q

 I EVENT]"" Q

 S Z="No Rubella Immunization Status health factor recorded, may be due for rubella vaccination." D RUBWT

 Q

RUBWT ;

 NEW APCHLR,V

 S APCHLR=""

 S V=$$REF^APCHSMU(APCHSPAT,9999999.14,$O(^AUTTIMM("C",3,0)),EVENT) I V]"" S APCHLR=V

 S V=$$REF^APCHSMU(APCHSPAT,9999999.14,$O(^AUTTIMM("C",4,0)),EVENT) I V]"",$P(V,U,3)]$P(APCHLR,U,3) S APCHLR=V

 S V=$$REF^APCHSMU(APCHSPAT,9999999.14,$O(^AUTTIMM("C",6,0)),EVENT) I V]"",$P(V,U,3)]$P(APCHLR,U,3) S APCHLR=V

 S V=$$REF^APCHSMU(APCHSPAT,9999999.14,$O(^AUTTIMM("C",38,0)),EVENT) I V]"",$P(V,U,3)]$P(APCHLR,U,3) S APCHLR=V

 S V=$$REF^APCHSMU(APCHSPAT,9999999.14,$O(^AUTTIMM("C",94,0)),EVENT) I V]"",$P(V,U,3)]$P(APCHLR,U,3) S APCHLR=V

 I APCHLR]"" S X=$P(APCHLR,U) S Z=Z_" "_X S X=$P(APCHLR,U,2) I X]"" S Z=Z_" "_X

 I APCHLR]"" S Z=Z_"."

 Q

ACENDDT ;

 S Z=$P($$MREND^APCHSACG(APCHSPAT),U,2)

 Q

ACURINDT ;

 NEW J

 S Z=$$LASTACUR^APCHSACG(APCHSPAT)

 I Z S Z=$$FMTE^XLFDT($P(Z,U,1)) Q

 S Z="<never reported>"

 Q

ACCBCDT ;

 NEW J

 S Z=$$LASTACCB^APCHSACG(APCHSPAT)

 I Z S Z=$$FMTE^XLFDT($P(Z,U,1)) Q

 S Z="<never reported>"

 Q

ACFOBTDT ;

 NEW J

 S Z=$$LASTACFO^APCHSACG(APCHSPAT)

 I Z S Z=$$FMTE^XLFDT($P(Z,U,1)) Q

 S Z="<never reported>"

 Q

HEPC ;EP

 NEW APCHSTAT

 Q:'$$INAC^APCHSMU(APCHSITI)

 Q:$$DOB^AUPNPAT(APCHSPAT)<2450101

 Q:$$DOB^AUPNPAT(APCHSPAT)>2651231

 Q:$$HASHEPC(APCHSPAT)  ;PL/DX/LAB TEST/CPT

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

 I $G(APCHCOLW)="" S APCHCOLW=48

 D GETTPT(APCHSITI,APCHCOLW,.APCHSTEX)

 D WRITETP

 Q

HASHEPC(P)  ;DOES PATIENT HAVE A HEP C DX?

 ;problem list subset PXRM HEPATITIS C

 I $$IPLSNO^APCHSMU1(P,"PXRM HEPATITIS C",1) Q 1  ;HAS SNOMED PL

 I $$PLTAX^APCHSMU(P,"BGP HEPATITIS C DXS",,1) Q 1  ;HAS DX PL

 I $P($$LASTDX^APCHSMU2(P,"BGP HEPATITIS C DXS"),U) Q 1  ;HAS DX EVER

 ;SNOMED V POV

 I $$SNOMEDPV^APCLAPIU(P,$$DOB^AUPNPAT(P),DT,"PXRM HEPATITIS C","D") Q 1  ;HAS SNOMED V POV

 I $$HEPCTEST(P,$$DOB^AUPNPAT(P),DT) Q 1  ;has cpt or lab test

 S D=$$LASTHF^APCHSMU(P,"HCV STATUS") I D Q 1  ;HF

 S D=$$LASTHF^APCHSMU(APCHSPAT,"HCV Status") I D Q 1  ;HF

 Q ""

HEPCTEST(P,BDATE,EDATE) ;

 I '$G(P) Q ""

 I '$G(BDATE) S BDATE=$$DOB^AUPNPAT(P)

 I '$G(EDATE) S EDATE=DT

 NEW I,D

 ;LAST LAB TEST BGP HEP C TEST TAX

 S I=$$LASTLAB^APCLAPIU(P,BDATE,EDATE,,$O(^ATXLAB("B","BGP HEP C TESTS TAX",0)),,$O(^ATXAX("B","BGP HEP C TEST LOINC CODES",0)),"A") I I Q 1  ;HAS LAB TEST

 S D=$$LASTCPTI^APCHSMU2(P,86803) I D Q 1  ;CPT

 S D=$$LASTCPTI^APCHSMU2(P,87902) I D Q 1  ;CPT

 Q ""

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

 +1       ;;2.0;IHS PCC SUITE;**2,7,15,16,20**;MAY 14, 2009;Build 25

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

 +3       ; 

 +4       ; 

GETTPT(APCHI,C,R,EVENT,EVENT1) ;EP

 +1        IF 'APCHI

               KILL R

               QUIT 

 +2        SET EVENT=$GET(EVENT)

 +3        SET EVENT1=$GET(EVENT1)

 +4        KILL R

 +5        SET R(0)=$SELECT($PIECE(^APCHSURV(APCHI,0),U,4)]"":$PIECE(^APCHSURV(APCHI,0),U,4),1:$PIECE(^APCHSURV(APCHI,0),U,1))

 +6        KILL ^UTILITY($JOB,"W")

 +7        NEW X,APCHY

 +8        SET APCHY=0

 +9        SET DIWL=0

           SET DIWR=C

           SET DIWF=""

           FOR 

               SET APCHY=$ORDER(^APCHSURV(APCHI,12,APCHY))

               IF APCHY'=+APCHY

                   QUIT 

               Begin DoDot:1

 +10               SET X=^APCHSURV(APCHI,12,APCHY,0)

 +11               IF X["|"

                       SET X=$$INTP(X)

 +12               DO ^DIWP

               End DoDot:1

 +13       SET X=0

           FOR 

               SET X=$ORDER(^UTILITY($JOB,"W",DIWL,X))

               IF X'=+X

                   QUIT 

               SET R(X)=^UTILITY($JOB,"W",DIWL,X,0)

 +14       QUIT 

 +15      ;

INTP(V)   ;

 +1        NEW A,Z,X,K,Y

 +2       ;S X=V

 +3       ;X ^%ZOSF("UPPERCASE")

 +4        SET (Y,A)=V

 +5        SET Z=$PIECE(A,"|")

 +6        FOR I=2:2

               SET J=$PIECE(Y,"|",I)

               IF J=""

                   QUIT 

               Begin DoDot:1

 +7                SET K=$PIECE(J," ")

 +8                IF $TEXT(@K)=""

                       SET A=""

                       QUIT 

 +9                SET Z=""

                   DO @K

 +10               SET A=$PIECE(A,("|"_J_"|"))_Z_$PIECE(A,("|"_J_"|"),2)

               End DoDot:1

 +11       QUIT A

 +12      ;

WRITETP   ;EP - write out TP

 +1        IF $GET(APCHSGHR)

               Begin DoDot:1

 +2                NEW A,B

 +3                SET (A,B)=0

 +4                SET APCHRVAL(0)="1^"_$PIECE(^APCHSURV(APCHSITI,0),U)

 +5                FOR 

                       SET B=$ORDER(APCHSTEX(B))

                       IF B'=+B

                           QUIT 

                       SET A=A+1

                       SET APCHRVAL(A)=APCHSTEX(B)

               End DoDot:1

               QUIT 

 +6        IF 'APCHSANY

               DO FIRST

               IF $DATA(APCHSQIT)

                   QUIT 

               SET APCHSANY=1

               SET APCHSNPG=0

 +7        XECUTE APCHSCKP

           IF $DATA(APCHSQIT)

               QUIT 

 +8        IF APCHSNPG

               SET APCHSCT=0

               SET APCHSNPG=0

 +9        SET APCHX=$SELECT($PIECE(^APCHSURV(APCHSITI,0),U,4)]"":$PIECE(^APCHSURV(APCHSITI,0),U,4),1:$PIECE(^APCHSURV(APCHSITI,0),U))

 +10       WRITE APCHX

 +11       IF $LENGTH(APCHX)>28

               WRITE !

 +12      ;W ?30,APCHSTEX(1)

 +13       FOR APCHSL=1:1

               IF '$DATA(APCHSTEX(APCHSL))!($DATA(APCHSQIT))

                   QUIT 

               Begin DoDot:1

 +14               XECUTE APCHSCKP

                   IF $DATA(APCHSQIT)

                       QUIT 

 +15               WRITE ?30,APCHSTEX(APCHSL),!

               End DoDot:1

 +16      ;W !

 +17      ;S APCHSCT=APCHSCT+1

 +18      ;I '(APCHSCT#2) X APCHSCKP Q:$D(APCHSQIT)  W:'APCHSNPG !

 +19       KILL APCHSTEX

 +20       QUIT 

 +21      ;

FIRST     ;EP

 +1        XECUTE APCHSCKP

           IF $DATA(APCHSQIT)

               QUIT 

           IF 'APCHSNPG

               XECUTE APCHSBRK

 +2       ;W !

 +3       ;S APCHSCT=0

 +4        QUIT 

 +5       ;

CVD       ;EP

 +1        NEW APCHSTAT

 +2        IF '$$INAC^APCHSMU(APCHSITI)

               QUIT 

 +3        IF $TEXT(EN^BQITRPHS)=""

               QUIT 

 +4        SET APCHLAST=""

           SET APCHNEXT=""

           KILL APCHSTEX,APCHSBQI

 +5        DO EN^BQITRPHS(APCHSPAT,$PIECE(^APCHSURV(APCHSITI,0),U,1),.APCHSBQI)

 +6        KILL ^UTILITY($JOB,"W")

 +7        NEW X,APCHY

 +8        SET APCHY=0

 +9        SET DIWL=0

           SET DIWR=C

           SET DIWF=""

           FOR 

               SET APCHY=$ORDER(APCHSBQI(APCHY))

               IF APCHY'=+APCHY

                   QUIT 

               Begin DoDot:1

 +10               SET X=APCHSBQI(APCHY)

 +11               DO ^DIWP

               End DoDot:1

 +12       SET X=0

           FOR 

               SET X=$ORDER(^UTILITY($JOB,"W",DIWL,X))

               IF X'=+X

                   QUIT 

               SET APCHSTEX(X)=^UTILITY($JOB,"W",DIWL,X,0)

 +13       DO WRITETP

 +14       XECUTE APCHSURX

 +15       QUIT 

 +16      ;

HEARINQ   ;EP

 +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        IF APCHSCRI

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

 +6        IF 'APCHSCRI

               Begin DoDot:1

 +7                IF APCHSAGE<65

                       QUIT 

 +8                SET APCHSINT=(2*365)

               End DoDot:1

 +9       ;no frequency so skip it

           IF APCHSINT=""

               XECUTE APCHSURX

               QUIT 

 +10       KILL APCHSTEX

 +11       IF $GET(APCHCOLW)=""

               SET APCHCOLW=48

 +12       DO GETTPT(APCHSITI,APCHCOLW,.APCHSTEX)

 +13       DO WRITETP

 +14       XECUTE APCHSURX

 +15       QUIT 

 +16      ;

STRAB     ;EP

 +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        IF APCHSCRI

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

 +6        IF 'APCHSCRI

               Begin DoDot:1

 +7                IF APCHSAGE<3

                       QUIT 

 +8                IF APCHSAGE>4

                       QUIT 

 +9                SET APCHSINT=(2*365)

               End DoDot:1

 +10      ;no frequency so skip it

           IF APCHSINT=""

               XECUTE APCHSURX

               QUIT 

 +11       KILL APCHSTEX

 +12       IF $GET(APCHCOLW)=""

               SET APCHCOLW=48

 +13       DO GETTPT(APCHSITI,APCHCOLW,.APCHSTEX)

 +14       DO WRITETP

 +15       QUIT 

 +16      ;

ASHMR1    ;EP called from hmr

 +1       ;increase steriods

 +2       ;is item turned on or off

           IF '$$INAC^APCHSMU(APCHSITI)

               QUIT 

 +3       ;not a candidate for this reminder

           IF '$$HMR1ST^APCHSMAS(APCHSPAT)

               QUIT 

 +4        SET APCHLAST=""

           SET APCHNEXT=""

           KILL APCHSTEX

 +5        IF $GET(APCHCOLW)=""

               SET APCHCOLW=48

 +6        DO GETTPT(APCHSITI,APCHCOLW,.APCHSTEX)

 +7        DO WRITETP

 +8        QUIT 

 +9       ;

ASHMR2    ;EP called from health maintenance reminders

 +1       ;asthma management plan

 +2        IF '$$INAC^APCHSMU(APCHSITI)

               QUIT 

 +3        SET APCHICAR=""

 +4        NEW APCHX,APCHY,Y

 +5        SET APCHX=0

           FOR 

               SET APCHX=$ORDER(^AUTTEDT("C","ASM-SMP",APCHX))

               IF APCHX'=+APCHX

                   QUIT 

               Begin DoDot:1

 +6                SET Y=$$LASTITEM^APCLAPIU(APCHSPAT,"`"_APCHX,"EDUCATION",,,"A")

 +7                IF Y=""

                       QUIT 

 +8                SET APCHY($PIECE(Y,U,1))=Y

               End DoDot:1

 +9        SET APCHICAR=$ORDER(APCHY(0))

           IF APCHICAR

               SET APCHICAR=APCHY(APCHICAR)

 +10       IF APCHICAR=""

               SET APCHICAR=$$LASTAM^APCHSAST(DFN,3)

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

 +12      ;asthma plan in place in last year

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

               QUIT 

 +13      ;not a candidate

           IF '$$HMR2ST^APCHSMAS(APCHSPAT)

               QUIT 

 +14       SET APCHLAST=""

           SET APCHNEXT=""

           KILL APCHSTEX

 +15       IF $GET(APCHCOLW)=""

               SET APCHCOLW=48

 +16       DO GETTPT(APCHSITI,APCHCOLW,.APCHSTEX)

 +17       DO WRITETP

 +18       QUIT 

 +19      ;

ASHMR5    ;EP - called from hmr item

 +1       ;is item turned on or off

           IF '$$INAC^APCHSMU(APCHSITI)

               QUIT 

 +2        IF $PIECE(^AUPNPAT(APCHSPAT,0),U,14)]""

               QUIT 

 +3        NEW APCHPRV

 +4        DO WHPCP^BDPAPI(APCHSPAT,.APCHPRV)

 +5        IF $GET(APCHPRV("DESIGNATED PRIMARY PROVIDER"))]""

               QUIT 

 +6        IF '$$HMR5ST^APCHSMAS(APCHSPAT)

               QUIT 

 +7        SET APCHLAST=""

           SET APCHNEXT=""

           KILL APCHSTEX

 +8        IF $GET(APCHCOLW)=""

               SET APCHCOLW=48

 +9        DO GETTPT(APCHSITI,APCHCOLW,.APCHSTEX)

 +10       DO WRITETP

 +11       QUIT 

 +12      ;

ASHMR3    ;EP - called from maintenance reminder

 +1       ;is item turned on or off

           IF '$$INAC^APCHSMU(APCHSITI)

               QUIT 

 +2       ;don't display in summer

           IF $EXTRACT(DT,4,5)="04"!($EXTRACT(DT,4,5)="05")!($EXTRACT(DT,4,5)="06")!($EXTRACT(DT,4,5)="07")!($EXTRACT(DT,4,5)="08")

               QUIT 

 +3        XECUTE APCHSURX

 +4       ;not a candidate for this reminder

           IF '$$HMR3ST^APCHSMAS(APCHSPAT)

               QUIT 

 +5        SET APCHLAST=""

           SET APCHNEXT=""

           KILL APCHSTEX

 +6        SET APCHICAR=$$LASTFLU^APCLAPI4(APCHSPAT)

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

 +8        IF APCHLAST=""

               DO W3

               QUIT 

 +9        SET D=$$FMDIFF^XLFDT(DT,APCHLAST)

 +10       IF +$EXTRACT(DT,4,5)>8

               IF D>210

                   DO W3

                   QUIT 

 +11       IF +$EXTRACT(DT,4,5)<4

               IF D>210

                   DO W3

                   QUIT 

 +12       QUIT 

W3        ;

 +1        IF $GET(APCHCOLW)=""

               SET APCHCOLW=48

 +2        DO GETTPT(APCHSITI,APCHCOLW,.APCHSTEX)

 +3        DO WRITETP

 +4        QUIT 

ASHMR4    ;EP - called from hmr item

 +1        NEW APCHSTAT

 +2        IF '$$INAC^APCHSMU(APCHSITI)

               QUIT 

 +3       ;has IPL of classified

           IF $$IPLSNO^APCHSMAS(DFN,"PXRM ASTHMA CLASSIFIED")

               QUIT 

 +4       ;has ipl of classified

           IF $$PLTAXAC^APCHSMAS(DFN,"BJPC ASTHMA CLASSIFIED")

               QUIT 

 +5       ;asthma severity documented

           IF $$LASTASCL^APCHSMAS(APCHSPAT,1)]""

               QUIT 

 +6       ;not a candidate

           IF '$$HMR4ST^APCHSMAS(APCHSPAT)

               QUIT 

 +7        SET APCHLAST=""

           SET APCHNEXT=""

           KILL APCHSTEX

 +8        IF $GET(APCHCOLW)=""

               SET APCHCOLW=48

 +9        DO GETTPT(APCHSITI,APCHCOLW,.APCHSTEX)

 +10       DO WRITETP

 +11       QUIT 

ASTCLASS(P) ;EP

 +1        NEW APCH,G,BD,X,D,V,E

 +2        SET G=""

 +3        SET BD=$$DOB^AUPNPAT(P)

 +4        SET %=P_"^ALL DX [BJPC ASTHMA CLASSIFIED;DURING "_BD_"-"_DT

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

 +5        IF '$DATA(APCH)

               QUIT ""

 +6       ;SKIP any not A or H

 +7        SET (G,X)=0

           FOR 

               SET X=$ORDER(APCH(X))