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))
IF X'=+X!(G)
QUIT
Begin DoDot:1
+8 SET V=$PIECE(APCH(X),U,5)
IF 'V
QUIT
+9 IF "AH"'[$PIECE($GET(^AUPNVSIT(V,0)),U,7)
QUIT
+10 SET G=1
End DoDot:1
+11 QUIT G
+12 ;
ASHMR8 ;EP - called from hmr item
+1 NEW APCHSTAT
+2 IF '$$INAC^APCHSMU(APCHSITI)
QUIT
+3 ;has IPL of classified
IF $$IPLSNO^APCHSMAS(APCHSPAT,"PXRM ASTHMA CLASSIFIED")
QUIT
+4 ;Q:$$PLTAXAC^APCHSMAS(P,"BJPC ASTHMA CLASSIFIED")
+5 ;asthma severity documented
IF $$LASTASCL^APCHSMAS(APCHSPAT,1)]""
QUIT
+6 ;not a candidate as no pov for asthma classified
IF '$$ASTCLASS(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
ASHMR6 ;EP - called from hmr item
+1 NEW APCHSTAT
+2 IF '$$INAC^APCHSMU(APCHSITI)
QUIT
+3 ;not a candidate
IF '$$HMR6ST^APCHSMAS(APCHSPAT)
QUIT
+4 SET APCHLAST=$$LASTACON^APCHSMAS(APCHSPAT,2)
+5 ;documented in past year
IF $$FMDIFF^XLFDT(DT,APCHLAST)<365
QUIT
+6 SET APCHLAST=""
SET APCHNEXT=""
KILL APCHSTEX
+7 IF $GET(APCHCOLW)=""
SET APCHCOLW=48
+8 DO GETTPT(APCHSITI,APCHCOLW,.APCHSTEX)
+9 DO WRITETP
+10 QUIT
ASHMR7 ;EP - called from hmr item
+1 NEW APCHSTAT,APCHSEV
+2 IF '$$INAC^APCHSMU(APCHSITI)
QUIT
+3 ;not a candidate
SET APCHSEV=$$HMR7ST^APCHSMAS(APCHSPAT)
+4 IF 'APCHSEV
QUIT
+5 SET APCHLAST=""
SET APCHNEXT=""
KILL APCHSTEX
+6 IF $GET(APCHCOLW)=""
SET APCHCOLW=48
+7 DO GETTPT(APCHSITI,APCHCOLW,.APCHSTEX,APCHSEV)
+8 DO WRITETP
+9 QUIT
ASFS1 ;
+1 NEW A,X,K,Y
+2 SET Z=$$FMTE^XLFDT($$LASTDXT^APCLAPIU(APCHSPAT,,,"BGP ASTHMA DXS","D"))
+3 IF Z=""
SET Z=$$PLTAXAC^APCHSMAS(APCHSPAT,"BGP ASTHMA DXS")
SET Z=$PIECE(Z,U,2)
+4 QUIT
ASAP1 ;
+1 NEW A,X,K,Y
+2 SET Z=$PIECE($$HMR2ST^APCHSMAS(APCHSPAT),U,2)
+3 QUIT
+4 ;
ASEV2 ;
+1 SET Z="-- "_$PIECE(EVENT,U,2)
+2 QUIT
ASEV3 ;
+1 SET Z="-- "_$PIECE(EVENT,U,3)
+2 QUIT
ASEV1 ;
+1 SET Z=$PIECE($$LASTACLG^APCHSMAS(APCHSPAT,2),U,2)
+2 IF Z=""
SET Z="None Documented"
+3 QUIT
RUBELLA ;
+1 IF EVENT1="NON-IMMUNE"
Begin DoDot:1
+2 IF EVENT]""
SET Z="Rubella Immunization Status health factor is recorded "_""""_"Non-Immune"_""""_" but there is a record of rubella vaccination on "_$$DATE^APCHSMU(EVENT)_"."
DO RUBWT
QUIT
+3 SET Z=Z_" Patient may be due for Rubella Vaccination"_"."
DO RUBWT
QUIT
End DoDot:1
QUIT
+4 IF EVENT1="INDETERMINATE"
Begin DoDot:1
+5 IF EVENT]""
SET Z="Rubella Immunization Status health factor is recorded "_""""_"Indeterminate"_""""_" but there is a record of rubella vaccination on "_$$DATE^APCHSMU(EVENT)_"."
DO RUBWT
QUIT
+6 SET Z="Rubella Immunization Status health factor is recorded "_""""_"Indeterminate,"_""""_" needs further clinical review."
DO RUBWT
QUIT
End DoDot:1
QUIT
+7 IF EVENT]""
QUIT
+8 SET Z="No Rubella Immunization Status health factor recorded, may be due for rubella vaccination."
DO RUBWT
+9 QUIT
RUBWT ;
+1 NEW APCHLR,V
+2 SET APCHLR=""
+3 SET V=$$REF^APCHSMU(APCHSPAT,9999999.14,$ORDER(^AUTTIMM("C",3,0)),EVENT)
IF V]""
SET APCHLR=V
+4 SET V=$$REF^APCHSMU(APCHSPAT,9999999.14,$ORDER(^AUTTIMM("C",4,0)),EVENT)
IF V]""
IF $PIECE(V,U,3)]$PIECE(APCHLR,U,3)
SET APCHLR=V
+5 SET V=$$REF^APCHSMU(APCHSPAT,9999999.14,$ORDER(^AUTTIMM("C",6,0)),EVENT)
IF V]""
IF $PIECE(V,U,3)]$PIECE(APCHLR,U,3)
SET APCHLR=V
+6 SET V=$$REF^APCHSMU(APCHSPAT,9999999.14,$ORDER(^AUTTIMM("C",38,0)),EVENT)
IF V]""
IF $PIECE(V,U,3)]$PIECE(APCHLR,U,3)
SET APCHLR=V
+7 SET V=$$REF^APCHSMU(APCHSPAT,9999999.14,$ORDER(^AUTTIMM("C",94,0)),EVENT)
IF V]""
IF $PIECE(V,U,3)]$PIECE(APCHLR,U,3)
SET APCHLR=V
+8 IF APCHLR]""
SET X=$PIECE(APCHLR,U)
SET Z=Z_" "_X
SET X=$PIECE(APCHLR,U,2)
IF X]""
SET Z=Z_" "_X
+9 IF APCHLR]""
SET Z=Z_"."
+10 QUIT
ACENDDT ;
+1 SET Z=$PIECE($$MREND^APCHSACG(APCHSPAT),U,2)
+2 QUIT
ACURINDT ;
+1 NEW J
+2 SET Z=$$LASTACUR^APCHSACG(APCHSPAT)
+3 IF Z
SET Z=$$FMTE^XLFDT($PIECE(Z,U,1))
QUIT
+4 SET Z="<never reported>"
+5 QUIT
ACCBCDT ;
+1 NEW J
+2 SET Z=$$LASTACCB^APCHSACG(APCHSPAT)
+3 IF Z
SET Z=$$FMTE^XLFDT($PIECE(Z,U,1))
QUIT
+4 SET Z="<never reported>"
+5 QUIT
ACFOBTDT ;
+1 NEW J
+2 SET Z=$$LASTACFO^APCHSACG(APCHSPAT)
+3 IF Z
SET Z=$$FMTE^XLFDT($PIECE(Z,U,1))
QUIT
+4 SET Z="<never reported>"
+5 QUIT
HEPC ;EP
+1 NEW APCHSTAT
+2 IF '$$INAC^APCHSMU(APCHSITI)
QUIT
+3 IF $$DOB^AUPNPAT(APCHSPAT)<2450101
QUIT
+4 IF $$DOB^AUPNPAT(APCHSPAT)>2651231
QUIT
+5 ;PL/DX/LAB TEST/CPT
IF $$HASHEPC(APCHSPAT)
QUIT
+6 SET APCHLAST=""
SET APCHNEXT=""
KILL APCHSTEX
+7 IF $GET(APCHCOLW)=""
SET APCHCOLW=48
+8 DO GETTPT(APCHSITI,APCHCOLW,.APCHSTEX)
+9 DO WRITETP
+10 QUIT
HASHEPC(P) ;DOES PATIENT HAVE A HEP C DX?
+1 ;problem list subset PXRM HEPATITIS C
+2 ;HAS SNOMED PL
IF $$IPLSNO^APCHSMU1(P,"PXRM HEPATITIS C",1)
QUIT 1
+3 ;HAS DX PL
IF $$PLTAX^APCHSMU(P,"BGP HEPATITIS C DXS",,1)
QUIT 1
+4 ;HAS DX EVER
IF $PIECE($$LASTDX^APCHSMU2(P,"BGP HEPATITIS C DXS"),U)
QUIT 1
+5 ;SNOMED V POV
+6 ;HAS SNOMED V POV
IF $$SNOMEDPV^APCLAPIU(P,$$DOB^AUPNPAT(P),DT,"PXRM HEPATITIS C","D")
QUIT 1
+7 ;has cpt or lab test
IF $$HEPCTEST(P,$$DOB^AUPNPAT(P),DT)
QUIT 1
+8 ;HF
SET D=$$LASTHF^APCHSMU(P,"HCV STATUS")
IF D
QUIT 1
+9 ;HF
SET D=$$LASTHF^APCHSMU(APCHSPAT,"HCV Status")
IF D
QUIT 1
+10 QUIT ""
HEPCTEST(P,BDATE,EDATE) ;
+1 IF '$GET(P)
QUIT ""
+2 IF '$GET(BDATE)
SET BDATE=$$DOB^AUPNPAT(P)
+3 IF '$GET(EDATE)
SET EDATE=DT
+4 NEW I,D
+5 ;LAST LAB TEST BGP HEP C TEST TAX
+6 ;HAS LAB TEST
SET I=$$LASTLAB^APCLAPIU(P,BDATE,EDATE,,$ORDER(^ATXLAB("B","BGP HEP C TESTS TAX",0)),,$ORDER(^ATXAX("B","BGP HEP C TEST LOINC CODES",0)),"A")
IF I
QUIT 1
+7 ;CPT
SET D=$$LASTCPTI^APCHSMU2(P,86803)
IF D
QUIT 1
+8 ;CPT
SET D=$$LASTCPTI^APCHSMU2(P,87902)
IF D
QUIT 1
+9 QUIT ""
