APCHSMAS ; IHS/CMI/LAB -- CONTINUATION OF ROUTINES ;
;;2.0;IHS PCC SUITE;**5,11,15,16**;MAY 14, 2009;Build 9
;;;
S(X) ;
NEW %,C S (C,%)=0 F S %=$O(APCHSTEX(%)) Q:%'=+% S C=C+1
S APCHSTEX(C+1)=X
Q
W3 ;
S APCHSTEX(1)="If this patient has asthma, consider",APCHSTEX(2)="giving this patient a flu shot,",APCHSTEX(3)="per protocol during the flu season."
D WRITE^APCHSMU
X APCHSURX
Q
HMR1ST(P) ;EP - for indicator 1 is patient eligible?
I $$PIS(P,$$FMADD^XLFDT(DT,-90)) Q 0
I $$LASTACLG(P,1)>1 Q 1 ;if persistent
S APCHSX=$$IPLSNO(P,"PXRM ASTHMA PERSISTENT") I $P(APCHSX,U,1) Q APCHSX
S APCHSX=$$PLTAXAC(P,"BJPC ASTHMA PERSISTENT") I APCHSX Q APCHSX
I $T(ATAG^BQITDUTL)]"" S X=$$ATAG^BQITDUTL(P,"Asthma") I $P(X,U),($P(X,U,2)="P"!($P(X,U,2)="A")) Q 1
S APCHSX=$$NASV(P,$$FMADD^XLFDT(DT,-183),2) I $P(APCHSX,U,1)>2 Q 1_U_"Asthma POVs on "_$$FMTE^XLFDT($P(APCHSX,U,2))_", "_$$FMTE^XLFDT($P(APCHSX,U,3))_" and "_$$FMTE^XLFDT($P(APCHSX,U,4))
Q 0
HMR3ST(P) ;EP - ind 3
I $$LASTACLG(P)>1 Q 1 ;if persistent
;BJPC V2.0 PATCH 15 CR #4133
S APCHSX=$$IPLSNO(P,"PXRM ASTHMA PERSISTENT") I $P(APCHSX,U,1) Q APCHSX
S APCHSX=$$PLTAXAC(P,"BJPC ASTHMA PERSISTENT") I APCHSX Q APCHSX
I $T(ATAG^BQITDUTL)]"" S X=$$ATAG^BQITDUTL(P,"Asthma") I $P(X,U),($P(X,U,2)="P"!($P(X,U,2)="A")) Q 1
I $$PIS(P,$$FMADD^XLFDT(DT,-90)) Q 1
I $$NASV(P,$$FMADD^XLFDT(DT,183))>2 Q 1
Q 0
HMR4ST(P) ;EP - ind 4
I $T(ATAG^BQITDUTL)]"" S X=$$ATAG^BQITDUTL(P,"Asthma") I $P(X,U),($P(X,U,2)="P"!($P(X,U,2)="A")) Q 1
I $$NASV(P,$$FMADD^XLFDT(DT,-183))>2 Q 1
Q 0
HMR5ST(P) ;EP
I $$LASTACLG(P)>1 Q 1 ;if persistent
S APCHSX=$$IPLSNO(P,"PXRM ASTHMA PERSISTENT") I $P(APCHSX,U,1) Q APCHSX
S APCHSX=$$PLTAXAC(P,"BJPC ASTHMA PERSISTENT") I APCHSX Q APCHSX
NEW X
I $T(ATAG^BQITDUTL)]"" S X=$$ATAG^BQITDUTL(P,"Asthma") I $P(X,U),($P(X,U,2)="P"!($P(X,U,2)="A")) Q 1
I $$NASV(P,$$FMADD^XLFDT(DT,-183))>2 Q 1
Q ""
HMR6ST(P) ;EP - ind 4
NEW APCHSX
I $$LASTACLG(P)>1 Q 1 ;if any persistent
S APCHSX=$$IPLSNO(P,"PXRM ASTHMA PERSISTENT") I $P(APCHSX,U,1) Q APCHSX
S APCHSX=$$PLTAXAC(P,"BJPC ASTHMA PERSISTENT") I APCHSX Q APCHSX
NEW X
I $T(ATAG^BQITDUTL)]"" S X=$$ATAG^BQITDUTL(P,"Asthma") I $P(X,U),($P(X,U,2)="P"!($P(X,U,2)="A")) Q 1
I $$NASV(P,$$FMADD^XLFDT(DT,-183))>2 Q 1 ;3 visits for asthma in past 6 months
Q 0
HMR2ST(P) ;EP - candidate for indicator 2?
NEW APCHSX
S APCHSX=$$LASTACLG(P,2)
I $P(APCHSX,U)>1 Q 1_U_"Asthma Severity "_$P(APCHSX,U,2) ;if persistent
S APCHSX=$$IPLSNO(P,"PXRM ASTHMA PERSISTENT") I $P(APCHSX,U,1) Q APCHSX
S APCHSX=$$PLTAXAC(P,"BJPC ASTHMA PERSISTENT") I APCHSX Q APCHSX
I $T(ATAG^BQITDUTL)]"" S X=$$ATAG^BQITDUTL(P,"Asthma") I $P(X,U),($P(X,U,2)="P"!($P(X,U,2)="A")) Q 1_U_"Asthma Diagnostic Tag: "_$S($P(X,U,2)="A":"Accepted",1:"Proposed")_" as of "_$$FMTE^XLFDT($P($P(X,U,3),".",1))
S APCHSX=$$NASV(P,$$FMADD^XLFDT(DT,-183),2) I $P(APCHSX,U,1)>2 Q 1_U_"Asthma POVs on "_$$FMTE^XLFDT($P(APCHSX,U,2))_", "_$$FMTE^XLFDT($P(APCHSX,U,3))_" and "_$$FMTE^XLFDT($P(APCHSX,U,4))
I $$LASTACON(P,1)="N"!($$LASTACON(P,1)="V") Q 1_U_"Most Recent Asthma Control "_$$LASTACON(P,6)
S APCHSX=$$AEXAC(P,$$FMADD^XLFDT(DT,-365),2) I $P(APCHSX,U) Q 1_U_"History of Asthma Exacerbation POV: "_$P(APCHSX,U,2)
S APCHSX=$$ASERV(P,$$FMADD^XLFDT(DT,-365),2) I $P(APCHSX,U) Q 1_U_$P(APCHSX,U,2)
Q 0
HMR7ST(P,R) ;EP - candidate for tp uncontrolled asthma
K R
NEW X
S X=$$ERPAST(P,$$FMADD^XLFDT(DT,-365))
I $P(X,U)>1 Q X
I $$LASTACLG(P,1)>1!($$IPLSNO(P,"PXRM ASTHMA PERSISTENT"))!($$PLTAXAC(P,"BJPC ASTHMA PERSISTENT")) S X=$$ORAL2(P,$$FMADD^XLFDT(DT,-365)) I $P(X,U)>1 Q X ;PERSISTENT
I $$LASTACLG(P,1)=1!($$IPLSNO(P,"PXRM ASTHMA INTERMITTENT")) S X=$$ORAL1(P,$$FMADD^XLFDT(DT,-365)) I X Q X ;INTERMITTENT
S X=$$ERORAL(P,$$FMADD^XLFDT(DT,-365)) I X Q X
Q ""
;
PLTAXAC(P,A) ;EP - is CODE ON PL AND IS IT ACTIVE
I $G(P)="" Q ""
I $G(A)="" Q ""
S S=$G(S)
N T S T=$O(^ATXAX("B",A,0))
I 'T Q ""
N X,Y,I S (X,Y,I)=0 F S X=$O(^AUPNPROB("AC",P,X)) Q:X'=+X!(I) I $D(^AUPNPROB(X,0)) D
.S Y=$P(^AUPNPROB(X,0),U)
.Q:'$$ICD^ATXCHK(Y,T,9)
.Q:$P(^AUPNPROB(X,0),U,12)="D"
.Q:$P(^AUPNPROB(X,0),U,12)="I"
.S I=1_U_$P($$ICDDX^ICDEX(Y,DT),U,4)_" on their Problem List"
Q I
IPLSNO(P,T) ;EP - any problem list entry with a SNOMED in T
NEW OUT,IN,C,G,Y,X,I,SNL,SNI
S OUT="SNL"
S X=$$SUBLST^BSTSAPI(OUT,T)
;BUILD INDEX
S C=0 F S C=$O(SNL(C)) Q:C'=+C S I=$P(SNL(C),U,1) I I]"" S SNI(I)=SNL(C)
K SNL
;LOOP PROBLEM LIST
S (X,G)=""
F S X=$O(^AUPNPROB("APCT",P,X)) Q:X=""!(G) D
.S Y=0 F S Y=$O(^AUPNPROB("APCT",P,X,Y)) Q:Y'=+Y!(G) D
..Q:'$D(^AUPNPROB(Y,0))
..Q:$P(^AUPNPROB(Y,0),U,12)="D" ;deleted
..Q:$P(^AUPNPROB(Y,0),U,12)="I" ;inactive
..I $D(SNI(X)) S G=1_U_$$CONCPT^AUPNVUTL(X)_" on their Problem List"
Q G
AS3PV(P,BD) ;EP
NEW APCH,%,G,C,APCHD,D
S (G,C)=0
S %=P_"^ALL DX [BGP ASTHMA DXS;DURING "_BD_"-"_DT,E=$$START1^APCLDF(%,"APCH(")
I '$D(APCH) Q ""
;reorder by date
S (G,X)=0 F S X=$O(APCH(X)) Q:X'=+X S D=$P(APCH(X),U,1) S APCHD(D)=""
S X=0 F S X=$O(APCHD(X)) Q:X'=+X S C=C+1
I C>2 Q 1
Q ""
;
ERPAST(P,BD) ; - 2 or more visits?
;return #^event 1 text^event 1 date^event 2 text^event 2 date
NEW C,X,V,Z,APCHX,APCHD,%,E,G,P1,P2
K APCHX,APCHD
S %=P_"^ALL VISITS;DURING "_$$FMTE^XLFDT(BD)_"-"_$$FMTE^XLFDT(DT),E=$$START1^APCLDF(%,"APCHX(")
K E
S C=0,X=0,V="" F S X=$O(APCHX(X)) Q:X'=+X D
.S V=$P(APCHX(X),U,5)
.Q:'$D(^AUPNVSIT(V,0))
.Q:$P(^AUPNVSIT(V,0),U,11)
.S G=0
.S Z=$$CLINIC^APCLV(V,"C")
.I Z=30!(Z=80)!($P(^AUPNVSIT(V,0),U,7)="H") S G=1
.Q:'G
.S Z=$$PRIMPOV^APCLV(V,"I")
.Q:'$$ICD^ATXAPI(Z,$O(^ATXAX("B","BGP ASTHMA DXS",0)),9)
.I '$D(E(9999999-$$VD^APCLV(V,"I"))) S C=C+1 S E((9999999-$$VD^APCLV(V,"I")))=V
.Q
I C<2 Q ""
S Z="",G=0
S Z=C
S D=0 F S D=$O(E(D)) Q:D'=+D!(G>1) D
.S G=G+1
.S V=E(D)
.I G=1 S P1=2
.I G=2 S P1=3
.S X=$S($P(^AUPNVSIT(V,0),U,7)="H":"Inpatient Admission with ",1:$$CLINIC^APCLV(V,"E")_" clinic visit with ")
.S X=X_$$PRIMPOV^APCLV(V,"N")_" ("_$$PRIMPOV^APCLV(V,"C")_") on "_$$FMTE^XLFDT($$VD^APCLV(V,"I"))
.S $P(Z,U,P1)=X
.Q
Q Z
;
ERORAL(P,BD) ;EP
;return 1^event 1 text^event 1 date^event 2 text^event 2 date
NEW C,X,V,Z,APCHX,APCHD,%,E,G,APCHMEDS
K APCHX,APCHD
S %=P_"^ALL VISITS;DURING "_$$FMTE^XLFDT(BD)_"-"_$$FMTE^XLFDT(DT),E=$$START1^APCLDF(%,"APCHX(")
K E
S E=""
S C=0,X=0,V="" F S X=$O(APCHX(X)) Q:X'=+X!(E]"") D
.S V=$P(APCHX(X),U,5)
.Q:'$D(^AUPNVSIT(V,0))
.Q:$P(^AUPNVSIT(V,0),U,11)
.S G=0
.S Z=$$CLINIC^APCLV(V,"C")
.I Z=30!(Z=80)!($P(^AUPNVSIT(V,0),U,7)="H") S G=1
.Q:'G
.S Z=$$PRIMPOV^APCLV(V,"I")
.Q:'$$ICD^ATXAPI(Z,$O(^ATXAX("B","BGP ASTHMA DXS",0)),9)
.;NOW CHECK FOR ORAL MEDS 14 DAYS +/- VISIT DATE
.K APCHMEDS
.D GETMEDS^APCHSMU1(P,BD,$$FMADD^XLFDT($$VD^APCLV(V,"I"),-14),"BGP RA GLUCOCORTICOIDS",,"BGP RA GLUCOCORTICOIDS CLASS",,.APCHMEDS)
.I '$D(APCHMEDS) Q
.S Z=0,%="" F S Z=$O(APCHMEDS(Z)) Q:Z'=+Z S %=Z
.S Y=$S($P(^AUPNVSIT(V,0),U,7)="H":"Inpatient Admission with ",1:$$CLINIC^APCLV(V,"E")_" clinic visit with ")
.S Y=Y_$$PRIMPOV^APCLV(V,"N")_" ("_$$PRIMPOV^APCLV(V,"C")_") on "_$$FMTE^XLFDT($$VD^APCLV(V,"I"))
.S E=1_U_Y
.S Y="Oral Corticosteroid Therapy "_$P(APCHMEDS(%),U,2)_" on "_$$FMTE^XLFDT($P(APCHMEDS(%),U))
.S E=E_U_Y
Q E
;
AEXAC(P,BD,F) ;EP
NEW APCH,%,G,C,APCHD,D,E
S F=$G(F)
I F="" S F=1
S (G,C)=0
S %=P_"^ALL DX [APCH ASTHMA EXACERBATION DXS;DURING "_BD_"-"_DT,E=$$START1^APCLDF(%,"APCH(")
I '$D(APCH) Q ""
;A and H only
S E=0 F S E=$O(APCH(E)) Q:E'=+E I "AH"'[$P(^AUPNVSIT($P(APCH(E),U,5),0),U,7) K APCH(E)
I '$D(APCH) Q ""
I F=1 Q 1
S C=$O(APCH(0))
Q 1_U_$$VAL^XBDIQ1(9000010.07,+$P(APCH(C),U,4),.04)_" on "_$$FMTE^XLFDT($P(APCH(C),U))
;
BRON(P,BDATE) ;
I $G(P)="" Q
NEW REL,TOT,Y,X,Z
S REL=$$NREL(P,$$FMADD^XLFDT(DT,-365))
S TOT=$$NASF(P,$$FMADD^XLFDT(DT,-365))
S Y="" I TOT>0 S Y=(REL/(REL+TOT))
Q Y
;
PIS(P,BDATE) ;EP - is patient on inhaled steriods since this date BDATE
I '$G(P) Q ""
NEW APCHMEDS
K APCHMEDS
D GETMEDS^APCHSMU1(P,BDATE,DT,"BAT ASTHMA INHALED STEROIDS","BAT ASTHMA INHLD STEROIDS NDC",,,.APCHMEDS)
I '$D(APCHMEDS) Q 0
Q 1
;
ORAL1(P,BDATE) ;EP - is patient on inhaled steriods since this date BDATE
I '$G(P) Q ""
NEW APCHMEDS,R,G,A,B,C,APCHX,E,%,APCHD
K APCHMEDS
D GETMEDS^APCHSMU1(P,BDATE,DT,"BGP RA GLUCOCORTICOIDS",,"BGP RA GLUCOCORTICOIDS CLASS",,.APCHMEDS)
I '$D(APCHMEDS) Q ""
S G=""
S X=0 F S X=$O(APCHMEDS(X)) Q:X'=+X!(G) D
.S D=$P(APCHMEDS(X),U,1)
.K APCHX,APCHD
.S %=P_"^ALL VISITS;DURING "_$$FMTE^XLFDT(D)_"-"_$$FMTE^XLFDT(D),E=$$START1^APCLDF(%,"APCHX(")
.S A=0 F S A=$O(APCHX(A)) Q:A'=+A D
..S C=$$PRIMPOV^APCLV($P(APCHX(A),U,5),"I") Q:'$$ICD^ATXAPI(C,$O(^ATXAX("B","BGP ASTHMA DXS",0)),9)
..S G=1_U_"Oral Corticosteroid therapy "_$P(APCHMEDS(X),U,2)_" associated with "_$$PRIMPOV^APCLV($P(APCHX(A),U,5),"N")_" ("_$$PRIMPOV^APCLV($P(APCHX(A),U,5),"C")_") on "_$$FMTE^XLFDT($P(APCHMEDS(X),U))
Q G
;
ORAL2(P,BDATE) ;EP - is patient on inhaled steriods since this date BDATE
I '$G(P) Q ""
NEW APCHMEDS,R,G,A,B,C,APCHX,E,%,APCHD
K APCHMEDS
D GETMEDS^APCHSMU1(P,BDATE,DT,"BGP RA GLUCOCORTICOIDS",,"BGP RA GLUCOCORTICOIDS CLASS",,.APCHMEDS)
I '$D(APCHMEDS) Q ""
I '$D(APCHMEDS(2)) Q "" ;doesn't have at least 2 prescriptions
;reorder by date and count 1 per date
K APCHD
S X=0 F S X=$O(APCHMEDS(X)) Q:X'=+X S APCHD($P(APCHMEDS(X),U,1))=APCHMEDS(X)
S G=0,B=1,E=""
S D=0 F S D=$O(APCHD(D)) Q:D'=+D D
.K APCHX
.S %=P_"^ALL VISITS;DURING "_$$FMTE^XLFDT(D)_"-"_$$FMTE^XLFDT(D),R=$$START1^APCLDF(%,"APCHX(")
.S A=0 F S A=$O(APCHX(A)) Q:A'=+A D
..S C=$$PRIMPOV^APCLV($P(APCHX(A),U,5),"I") Q:'$$ICD^ATXAPI(C,$O(^ATXAX("B","BGP ASTHMA DXS",0)),9)
..S G=G+1,B=B+1 S $P(E,U)=G,$P(E,U,B)="Oral Corticosteroid therapy "_$P(APCHD(D),U,2)_" associated with "_$$PRIMPOV^APCLV($P(APCHX(A),U,5),"N")_" ("_$$PRIMPOV^APCLV($P(APCHX(A),U,5),"C")_") on "_$$FMTE^XLFDT($P(APCHD(D),U))
Q E
NREL(P,BDATE) ;EP - reliever?
;number of reliever meds between BDATE and EDATE
NEW X,APCHX,E
S X=P_"^ALL MEDS [BAT ASTHMA RELIEVER MEDS"_";DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(DT) S E=$$START1^APCLDF(X,"BATL(")
I '$D(APCHX(1)) Q 0
NEW C,X S (X,C)=0 F S X=$O(APCHX(X)) Q:X'=+X S C=C+1
Q C
;
ASERV(P,BDATE,F) ;EP - ER ASTHMA visits since BDATE
I '$G(P) Q 0
S F=$G(F)
I F="" S F=1
NEW C,X,V,Z,APCHX,APCHD,%,E,G
K APCHX,APCHD
S %=P_"^ALL VISITS;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(DT),E=$$START1^APCLDF(%,"APCHX(")
S C=0,X=0,V="" F S X=$O(APCHX(X)) Q:X'=+X!(C) D
.S V=$P(APCHX(X),U,5)
.Q:'$D(^AUPNVSIT(V,0))
.Q:$P(^AUPNVSIT(V,0),U,11)
.S Z=$$CLINIC^APCLV(V,"C")
.I Z'=30,Z'=80 Q ;urgent and er only
.S Z=$$PRIMPOV^APCLV(V,"I")
.Q:'$$ICD^ATXAPI(Z,$O(^ATXAX("B","BGP ASTHMA DXS",0)),9)
.S C=1,G=V
I 'C Q ""
I F=1 Q C
Q 1_U_$$PRIMPOV^APCLV(V,"N")_" at "_$$CLINIC^APCLV(V,"E")_" clinic on "_$$FMTE^XLFDT($P($P(^AUPNVSIT(V,0),U),"."))
;
NASV(P,BDATE,F) ;EP - number of asthma visits since BDATE
;count only A, H and any pov
;different dates, not visits
I '$G(P) Q 0
I '$G(F) S F=1
NEW C,X,V,Z,APCHX,APCHD,Y,G
K APCHX,APCHD
S %=P_"^ALL VISITS;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(DT),E=$$START1^APCLDF(%,"APCHX(")
S C=0,X=0,V="" F S X=$O(APCHX(X)) Q:X'=+X D
.S V=$P(APCHX(X),U,5)
.Q:'$D(^AUPNVSIT(V,0))
.Q:"AH"'[$P(^AUPNVSIT(V,0),U,7)
.Q:$P(^AUPNVSIT(V,0),U,11)
.S Z=$$PRIMPOV^APCLV(V,"I")
.Q:'$$ICD^ATXAPI(Z,$O(^ATXAX("B","BGP ASTHMA DXS",0)),9)
.S APCHD((9999999-$P($P(^AUPNVSIT(V,0),U,1),".")))=""
S X=0 F S X=$O(APCHD(X)) Q:X'=+X S C=C+1
I F=1 Q C
NEW R
S R=C
S X=0,V=1 F S X=$O(APCHD(X)) Q:X'=+X S V=V+1,$P(R,U,V)=(9999999-X)
Q R
NASF(P,BDATE) ;EP - number of asthma fill dates since BDATE
I '$G(P) Q ""
NEW APCHX,X,Y,C,E,EDATE K APCHX
S EDATE=$$FMTE^XLFDT(DT),BDATE=$$FMTE^XLFDT(BDATE)
S X=P_"^ALL MEDS [BAT ASTHMA RELIEVER MEDS "_";DURING "_BDATE_"-"_EDATE S E=$$START1^APCLDF(X,"APCHX(")
S (C,X)=0 F S X=$O(APCHX(X)) Q:X'=+X S C=C+1
K APCHX S X=P_"^ALL MEDS [BAT ASTHMA INHALED STEROIDS "_";DURING "_BDATE_"-"_EDATE S E=$$START1^APCLDF(X,"APCHX(")
S (C,X)=0 F S X=$O(APCHX(X)) Q:X'=+X S C=C+1
K APCHX S X=P_"^ALL MEDS [BAT ASTHMA CONTROLLER MEDS "_";DURING "_BDATE_"-"_EDATE S E=$$START1^APCLDF(X,"APCHX(")
S (C,X)=0 F S X=$O(APCHX(X)) Q:X'=+X S C=C+1
Q C
LASTAM(P,F) ;EP - return date of last asthma management plan = yes
I '$G(P) Q ""
I '$G(F) S F=1
NEW D S D=$O(^AUPNVAST("AM",P,0))
I 'D Q ""
I F=1 Q 9999999-D
I F=2 Q $$FMTE^XLFDT(9999999-D)
Q ""
LASTSEV(P,F) ;EP - return last severity recorded
;1 - internal set of codes
;2 - internal date
;3 - external date
;4 - external name
;5 - code and external name
NEW D,LAST,E,S
I '$G(P) Q ""
I '$G(F) S F=1
S D=$O(^AUPNVAST("AS",P,0))
I 'D Q ""
S LAST="",E=0 F S E=$O(^AUPNVAST("AS",P,D,E)) Q:E'=+E S LAST=E
I 'LAST Q ""
S S=^AUPNVAST("AS",P,D,LAST)
I F=1 Q S
I F=2 Q 9999999-D
I F=3 Q $$FMTE^XLFDT(9999999-D)
I F=4 Q $$EXTSET^XBFUNC(9000010.41,.04,S)
I F=5 Q S_"-"_$$EXTSET^XBFUNC(9000010.41,.04,S)
Q ""
;
LASTACLG(P,F) ;EP - return last CLASSIFICATION recorded
NEW D,LAST,E,S,X,T
I '$G(P) Q ""
I '$G(F) S F=1
S T=$O(^ATXAX("B","BGP ASTHMA DXS",0))
I 'T Q ""
S S=""
S X=0 F S X=$O(^AUPNPROB("AC",P,X)) Q:X'=+X D
.Q:$P(^AUPNPROB(X,0),U,12)="D"
.Q:$P(^AUPNPROB(X,0),U,12)="I" ;inactive
.S C=$P($G(^AUPNPROB(X,0)),U)
.Q:C=""
.Q:'$$ICD^ATXAPI(C,T,9) ;not asthma dx
.Q:$P(^AUPNPROB(X,0),U,15)="" ;no classification
.S E=$P(^AUPNPROB(X,0),U,15)
.I E'>$P(S,U,1) Q
.S S=E_U_$$VAL^XBDIQ1(9000011,X,.15)
I F=1 Q $P(S,U)
I F=2 Q S
;
LASTASCL(P,F) ;EP - last CLASSIFICATION
NEW D,LAST,E,S,X,T
I '$G(P) Q ""
I '$G(F) S F=1
S T=$O(^ATXAX("B","BGP ASTHMA DXS",0))
I 'T Q ""
S S=""
K LAST
S X=0 F S X=$O(^AUPNPROB("AC",P,X)) Q:X'=+X D
.Q:$P(^AUPNPROB(X,0),U,12)="D"
.S C=$P($G(^AUPNPROB(X,0)),U)
.Q:C=""
.Q:'$$ICD^ATXAPI(C,T,9)
.Q:$P(^AUPNPROB(X,0),U,15)=""
.S E=$P(^AUPNPROB(X,0),U,15)
.S D=$P(^AUPNPROB(X,0),U,3)
.S LAST(D)=E_U_$$VAL^XBDIQ1(9000011,X,.15)
S S=$O(LAST(0))
I S="" Q ""
I F=1 Q $P(LAST(S),U,1)
Q $P(LAST(S),U,2)
;
LASTACON(P,F) ;EP - last ASTHMA CONTROL
NEW D,LAST,E,S
I '$G(P) Q ""
I '$G(F) S F=1
S D=$O(^AUPNVAST("AAC",P,0))
I 'D Q ""
S LAST="",E=0 F S E=$O(^AUPNVAST("AAC",P,D,E)) Q:E'=+E S LAST=E
I 'LAST Q ""
S S=^AUPNVAST("AAC",P,D,LAST)
I F=1 Q S
I F=2 Q 9999999-D
I F=3 Q $$FMTE^XLFDT(9999999-D)
I F=4 Q $$VAL^XBDIQ1(9000010.41,LAST,.14)
I F=5 Q S_"-"_$$EXTSET^XBFUNC(9000010.41,.14,S)
I F=6 Q $$VAL^XBDIQ1(9000010.41,LAST,.14)_" documented on "_$$FMTE^XLFDT((9999999-D))
I F=7 Q $$FMTE^XLFDT((9999999-D))_" "_$$VAL^XBDIQ1(9000010.41,LAST,.14)
Q ""
;
APCHSMAS ; IHS/CMI/LAB -- CONTINUATION OF ROUTINES ;
+1 ;;2.0;IHS PCC SUITE;**5,11,15,16**;MAY 14, 2009;Build 9
+2 ;;;
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
W3 ;
+1 SET APCHSTEX(1)="If this patient has asthma, consider"
SET APCHSTEX(2)="giving this patient a flu shot,"
SET APCHSTEX(3)="per protocol during the flu season."
+2 DO WRITE^APCHSMU
+3 XECUTE APCHSURX
+4 QUIT
HMR1ST(P) ;EP - for indicator 1 is patient eligible?
+1 IF $$PIS(P,$$FMADD^XLFDT(DT,-90))
QUIT 0
+2 ;if persistent
IF $$LASTACLG(P,1)>1
QUIT 1
+3 SET APCHSX=$$IPLSNO(P,"PXRM ASTHMA PERSISTENT")
IF $PIECE(APCHSX,U,1)
QUIT APCHSX
+4 SET APCHSX=$$PLTAXAC(P,"BJPC ASTHMA PERSISTENT")
IF APCHSX
QUIT APCHSX
+5 IF $TEXT(ATAG^BQITDUTL)]""
SET X=$$ATAG^BQITDUTL(P,"Asthma")
IF $PIECE(X,U)
IF ($PIECE(X,U,2)="P"!($PIECE(X,U,2)="A"))
QUIT 1
+6 SET APCHSX=$$NASV(P,$$FMADD^XLFDT(DT,-183),2)
IF $PIECE(APCHSX,U,1)>2
QUIT 1_U_"Asthma POVs on "_$$FMTE^XLFDT($PIECE(APCHSX,U,2))_", "_$$FMTE^XLFDT($PIECE(APCHSX,U,3))_" and "_$$FMTE^XLFDT($PIECE(APCHSX,U,4))
+7 QUIT 0
HMR3ST(P) ;EP - ind 3
+1 ;if persistent
IF $$LASTACLG(P)>1
QUIT 1
+2 ;BJPC V2.0 PATCH 15 CR #4133
+3 SET APCHSX=$$IPLSNO(P,"PXRM ASTHMA PERSISTENT")
IF $PIECE(APCHSX,U,1)
QUIT APCHSX
+4 SET APCHSX=$$PLTAXAC(P,"BJPC ASTHMA PERSISTENT")
IF APCHSX
QUIT APCHSX
+5 IF $TEXT(ATAG^BQITDUTL)]""
SET X=$$ATAG^BQITDUTL(P,"Asthma")
IF $PIECE(X,U)
IF ($PIECE(X,U,2)="P"!($PIECE(X,U,2)="A"))
QUIT 1
+6 IF $$PIS(P,$$FMADD^XLFDT(DT,-90))
QUIT 1
+7 IF $$NASV(P,$$FMADD^XLFDT(DT,183))>2
QUIT 1
+8 QUIT 0
HMR4ST(P) ;EP - ind 4
+1 IF $TEXT(ATAG^BQITDUTL)]""
SET X=$$ATAG^BQITDUTL(P,"Asthma")
IF $PIECE(X,U)
IF ($PIECE(X,U,2)="P"!($PIECE(X,U,2)="A"))
QUIT 1
+2 IF $$NASV(P,$$FMADD^XLFDT(DT,-183))>2
QUIT 1
+3 QUIT 0
HMR5ST(P) ;EP
+1 ;if persistent
IF $$LASTACLG(P)>1
QUIT 1
+2 SET APCHSX=$$IPLSNO(P,"PXRM ASTHMA PERSISTENT")
IF $PIECE(APCHSX,U,1)
QUIT APCHSX
+3 SET APCHSX=$$PLTAXAC(P,"BJPC ASTHMA PERSISTENT")
IF APCHSX
QUIT APCHSX
+4 NEW X
+5 IF $TEXT(ATAG^BQITDUTL)]""
SET X=$$ATAG^BQITDUTL(P,"Asthma")
IF $PIECE(X,U)
IF ($PIECE(X,U,2)="P"!($PIECE(X,U,2)="A"))
QUIT 1
+6 IF $$NASV(P,$$FMADD^XLFDT(DT,-183))>2
QUIT 1
+7 QUIT ""
HMR6ST(P) ;EP - ind 4
+1 NEW APCHSX
+2 ;if any persistent
IF $$LASTACLG(P)>1
QUIT 1
+3 SET APCHSX=$$IPLSNO(P,"PXRM ASTHMA PERSISTENT")
IF $PIECE(APCHSX,U,1)
QUIT APCHSX
+4 SET APCHSX=$$PLTAXAC(P,"BJPC ASTHMA PERSISTENT")
IF APCHSX
QUIT APCHSX
+5 NEW X
+6 IF $TEXT(ATAG^BQITDUTL)]""
SET X=$$ATAG^BQITDUTL(P,"Asthma")
IF $PIECE(X,U)
IF ($PIECE(X,U,2)="P"!($PIECE(X,U,2)="A"))
QUIT 1
+7 ;3 visits for asthma in past 6 months
IF $$NASV(P,$$FMADD^XLFDT(DT,-183))>2
QUIT 1
+8 QUIT 0
HMR2ST(P) ;EP - candidate for indicator 2?
+1 NEW APCHSX
+2 SET APCHSX=$$LASTACLG(P,2)
+3 ;if persistent
IF $PIECE(APCHSX,U)>1
QUIT 1_U_"Asthma Severity "_$PIECE(APCHSX,U,2)
+4 SET APCHSX=$$IPLSNO(P,"PXRM ASTHMA PERSISTENT")
IF $PIECE(APCHSX,U,1)
QUIT APCHSX
+5 SET APCHSX=$$PLTAXAC(P,"BJPC ASTHMA PERSISTENT")
IF APCHSX
QUIT APCHSX
+6 IF $TEXT(ATAG^BQITDUTL)]""
SET X=$$ATAG^BQITDUTL(P,"Asthma")
IF $PIECE(X,U)
IF ($PIECE(X,U,2)="P"!($PIECE(X,U,2)="A"))
QUIT 1_U_"Asthma Diagnostic Tag: "_$SELECT($PIECE(X,U,2)="A":"Accepted",1:"Proposed")_" as of "_$$FMTE^XLFDT($PIECE($PIECE(X,U,3),".",1))
+7 SET APCHSX=$$NASV(P,$$FMADD^XLFDT(DT,-183),2)
IF $PIECE(APCHSX,U,1)>2
QUIT 1_U_"Asthma POVs on "_$$FMTE^XLFDT($PIECE(APCHSX,U,2))_", "_$$FMTE^XLFDT($PIECE(APCHSX,U,3))_" and "_$$FMTE^XLFDT($PIECE(APCHSX,U,4))
+8 IF $$LASTACON(P,1)="N"!($$LASTACON(P,1)="V")
QUIT 1_U_"Most Recent Asthma Control "_$$LASTACON(P,6)
+9 SET APCHSX=$$AEXAC(P,$$FMADD^XLFDT(DT,-365),2)
IF $PIECE(APCHSX,U)
QUIT 1_U_"History of Asthma Exacerbation POV: "_$PIECE(APCHSX,U,2)
+10 SET APCHSX=$$ASERV(P,$$FMADD^XLFDT(DT,-365),2)
IF $PIECE(APCHSX,U)
QUIT 1_U_$PIECE(APCHSX,U,2)
+11 QUIT 0
HMR7ST(P,R) ;EP - candidate for tp uncontrolled asthma
+1 KILL R
+2 NEW X
+3 SET X=$$ERPAST(P,$$FMADD^XLFDT(DT,-365))
+4 IF $PIECE(X,U)>1
QUIT X
+5 ;PERSISTENT
IF $$LASTACLG(P,1)>1!($$IPLSNO(P,"PXRM ASTHMA PERSISTENT"))!($$PLTAXAC(P,"BJPC ASTHMA PERSISTENT"))
SET X=$$ORAL2(P,$$FMADD^XLFDT(DT,-365))
IF $PIECE(X,U)>1
QUIT X
+6 ;INTERMITTENT
IF $$LASTACLG(P,1)=1!($$IPLSNO(P,"PXRM ASTHMA INTERMITTENT"))
SET X=$$ORAL1(P,$$FMADD^XLFDT(DT,-365))
IF X
QUIT X
+7 SET X=$$ERORAL(P,$$FMADD^XLFDT(DT,-365))
IF X
QUIT X
+8 QUIT ""
+9 ;
PLTAXAC(P,A) ;EP - is CODE ON PL AND IS IT ACTIVE
+1 IF $GET(P)=""
QUIT ""
+2 IF $GET(A)=""
QUIT ""
+3 SET S=$GET(S)
+4 NEW T
SET T=$ORDER(^ATXAX("B",A,0))
+5 IF 'T
QUIT ""
+6 NEW X,Y,I
SET (X,Y,I)=0
FOR
SET X=$ORDER(^AUPNPROB("AC",P,X))
IF X'=+X!(I)
QUIT
IF $DATA(^AUPNPROB(X,0))
Begin DoDot:1
+7 SET Y=$PIECE(^AUPNPROB(X,0),U)
+8 IF '$$ICD^ATXCHK(Y,T,9)
QUIT
+9 IF $PIECE(^AUPNPROB(X,0),U,12)="D"
QUIT
+10 IF $PIECE(^AUPNPROB(X,0),U,12)="I"
QUIT
+11 SET I=1_U_$PIECE($$ICDDX^ICDEX(Y,DT),U,4)_" on their Problem List"
End DoDot:1
+12 QUIT I
IPLSNO(P,T) ;EP - any problem list entry with a SNOMED in T
+1 NEW OUT,IN,C,G,Y,X,I,SNL,SNI
+2 SET OUT="SNL"
+3 SET X=$$SUBLST^BSTSAPI(OUT,T)
+4 ;BUILD INDEX
+5 SET C=0
FOR
SET C=$ORDER(SNL(C))
IF C'=+C
QUIT
SET I=$PIECE(SNL(C),U,1)
IF I]""
SET SNI(I)=SNL(C)
+6 KILL SNL
+7 ;LOOP PROBLEM LIST
+8 SET (X,G)=""
+9 FOR
SET X=$ORDER(^AUPNPROB("APCT",P,X))
IF X=""!(G)
QUIT
Begin DoDot:1
+10 SET Y=0
FOR
SET Y=$ORDER(^AUPNPROB("APCT",P,X,Y))
IF Y'=+Y!(G)
QUIT
Begin DoDot:2
+11 IF '$DATA(^AUPNPROB(Y,0))
QUIT
+12 ;deleted
IF $PIECE(^AUPNPROB(Y,0),U,12)="D"
QUIT
+13 ;inactive
IF $PIECE(^AUPNPROB(Y,0),U,12)="I"
QUIT
+14 IF $DATA(SNI(X))
SET G=1_U_$$CONCPT^AUPNVUTL(X)_" on their Problem List"
End DoDot:2
End DoDot:1
+15 QUIT G
AS3PV(P,BD) ;EP
+1 NEW APCH,%,G,C,APCHD,D
+2 SET (G,C)=0
+3 SET %=P_"^ALL DX [BGP ASTHMA DXS;DURING "_BD_"-"_DT
SET E=$$START1^APCLDF(%,"APCH(")
+4 IF '$DATA(APCH)
QUIT ""
+5 ;reorder by date
+6 SET (G,X)=0
FOR
SET X=$ORDER(APCH(X))
IF X'=+X
QUIT
SET D=$PIECE(APCH(X),U,1)
SET APCHD(D)=""
+7 SET X=0
FOR
SET X=$ORDER(APCHD(X))
IF X'=+X
QUIT
SET C=C+1
+8 IF C>2
QUIT 1
+9 QUIT ""
+10 ;
ERPAST(P,BD) ; - 2 or more visits?
+1 ;return #^event 1 text^event 1 date^event 2 text^event 2 date
+2 NEW C,X,V,Z,APCHX,APCHD,%,E,G,P1,P2
+3 KILL APCHX,APCHD
+4 SET %=P_"^ALL VISITS;DURING "_$$FMTE^XLFDT(BD)_"-"_$$FMTE^XLFDT(DT)
SET E=$$START1^APCLDF(%,"APCHX(")
+5 KILL E
+6 SET C=0
SET X=0
SET V=""
FOR
SET X=$ORDER(APCHX(X))
IF X'=+X
QUIT
Begin DoDot:1
+7 SET V=$PIECE(APCHX(X),U,5)
+8 IF '$DATA(^AUPNVSIT(V,0))
QUIT
+9 IF $PIECE(^AUPNVSIT(V,0),U,11)
QUIT
+10 SET G=0
+11 SET Z=$$CLINIC^APCLV(V,"C")
+12 IF Z=30!(Z=80)!($PIECE(^AUPNVSIT(V,0),U,7)="H")
SET G=1
+13 IF 'G
QUIT
+14 SET Z=$$PRIMPOV^APCLV(V,"I")
+15 IF '$$ICD^ATXAPI(Z,$ORDER(^ATXAX("B","BGP ASTHMA DXS",0)),9)
QUIT
+16 IF '$DATA(E(9999999-$$VD^APCLV(V,"I")))
SET C=C+1
SET E((9999999-$$VD^APCLV(V,"I")))=V
+17 QUIT
End DoDot:1
+18 IF C<2
QUIT ""
+19 SET Z=""
SET G=0
+20 SET Z=C
+21 SET D=0
FOR
SET D=$ORDER(E(D))
IF D'=+D!(G>1)
QUIT
Begin DoDot:1
+22 SET G=G+1
+23 SET V=E(D)
+24 IF G=1
SET P1=2
+25 IF G=2
SET P1=3
+26 SET X=$SELECT($PIECE(^AUPNVSIT(V,0),U,7)="H":"Inpatient Admission with ",1:$$CLINIC^APCLV(V,"E")_" clinic visit with ")
+27 SET X=X_$$PRIMPOV^APCLV(V,"N")_" ("_$$PRIMPOV^APCLV(V,"C")_") on "_$$FMTE^XLFDT($$VD^APCLV(V,"I"))
+28 SET $PIECE(Z,U,P1)=X
+29 QUIT
End DoDot:1
+30 QUIT Z
+31 ;
ERORAL(P,BD) ;EP
+1 ;return 1^event 1 text^event 1 date^event 2 text^event 2 date
+2 NEW C,X,V,Z,APCHX,APCHD,%,E,G,APCHMEDS
+3 KILL APCHX,APCHD
+4 SET %=P_"^ALL VISITS;DURING "_$$FMTE^XLFDT(BD)_"-"_$$FMTE^XLFDT(DT)
SET E=$$START1^APCLDF(%,"APCHX(")
+5 KILL E
+6 SET E=""
+7 SET C=0
SET X=0
SET V=""
FOR
SET X=$ORDER(APCHX(X))
IF X'=+X!(E]"")
QUIT
Begin DoDot:1
+8 SET V=$PIECE(APCHX(X),U,5)
+9 IF '$DATA(^AUPNVSIT(V,0))
QUIT
+10 IF $PIECE(^AUPNVSIT(V,0),U,11)
QUIT
+11 SET G=0
+12 SET Z=$$CLINIC^APCLV(V,"C")
+13 IF Z=30!(Z=80)!($PIECE(^AUPNVSIT(V,0),U,7)="H")
SET G=1
+14 IF 'G
QUIT
+15 SET Z=$$PRIMPOV^APCLV(V,"I")
+16 IF '$$ICD^ATXAPI(Z,$ORDER(^ATXAX("B","BGP ASTHMA DXS",0)),9)
QUIT
+17 ;NOW CHECK FOR ORAL MEDS 14 DAYS +/- VISIT DATE
+18 KILL APCHMEDS
+19 DO GETMEDS^APCHSMU1(P,BD,$$FMADD^XLFDT($$VD^APCLV(V,"I"),-14),"BGP RA GLUCOCORTICOIDS",,"BGP RA GLUCOCORTICOIDS CLASS",,.APCHMEDS)
+20 IF '$DATA(APCHMEDS)
QUIT
+21 SET Z=0
SET %=""
FOR
SET Z=$ORDER(APCHMEDS(Z))
IF Z'=+Z
QUIT
SET %=Z
+22 SET Y=$SELECT($PIECE(^AUPNVSIT(V,0),U,7)="H":"Inpatient Admission with ",1:$$CLINIC^APCLV(V,"E")_" clinic visit with ")
+23 SET Y=Y_$$PRIMPOV^APCLV(V,"N")_" ("_$$PRIMPOV^APCLV(V,"C")_") on "_$$FMTE^XLFDT($$VD^APCLV(V,"I"))
+24 SET E=1_U_Y
+25 SET Y="Oral Corticosteroid Therapy "_$PIECE(APCHMEDS(%),U,2)_" on "_$$FMTE^XLFDT($PIECE(APCHMEDS(%),U))
+26 SET E=E_U_Y
End DoDot:1
+27 QUIT E
+28 ;
AEXAC(P,BD,F) ;EP
+1 NEW APCH,%,G,C,APCHD,D,E
+2 SET F=$GET(F)
+3 IF F=""
SET F=1
+4 SET (G,C)=0
+5 SET %=P_"^ALL DX [APCH ASTHMA EXACERBATION DXS;DURING "_BD_"-"_DT
SET E=$$START1^APCLDF(%,"APCH(")
+6 IF '$DATA(APCH)
QUIT ""
+7 ;A and H only
+8 SET E=0
FOR
SET E=$ORDER(APCH(E))
IF E'=+E
QUIT
IF "AH"'[$PIECE(^AUPNVSIT($PIECE(APCH(E),U,5),0),U,7)
KILL APCH(E)
+9 IF '$DATA(APCH)
QUIT ""
+10 IF F=1
QUIT 1
+11 SET C=$ORDER(APCH(0))
+12 QUIT 1_U_$$VAL^XBDIQ1(9000010.07,+$PIECE(APCH(C),U,4),.04)_" on "_$$FMTE^XLFDT($PIECE(APCH(C),U))
+13 ;
BRON(P,BDATE) ;
+1 IF $GET(P)=""
QUIT
+2 NEW REL,TOT,Y,X,Z
+3 SET REL=$$NREL(P,$$FMADD^XLFDT(DT,-365))
+4 SET TOT=$$NASF(P,$$FMADD^XLFDT(DT,-365))
+5 SET Y=""
IF TOT>0
SET Y=(REL/(REL+TOT))
+6 QUIT Y
+7 ;
PIS(P,BDATE) ;EP - is patient on inhaled steriods since this date BDATE
+1 IF '$GET(P)
QUIT ""
+2 NEW APCHMEDS
+3 KILL APCHMEDS
+4 DO GETMEDS^APCHSMU1(P,BDATE,DT,"BAT ASTHMA INHALED STEROIDS","BAT ASTHMA INHLD STEROIDS NDC",,,.APCHMEDS)
+5 IF '$DATA(APCHMEDS)
QUIT 0
+6 QUIT 1
+7 ;
ORAL1(P,BDATE) ;EP - is patient on inhaled steriods since this date BDATE
+1 IF '$GET(P)
QUIT ""
+2 NEW APCHMEDS,R,G,A,B,C,APCHX,E,%,APCHD
+3 KILL APCHMEDS
+4 DO GETMEDS^APCHSMU1(P,BDATE,DT,"BGP RA GLUCOCORTICOIDS",,"BGP RA GLUCOCORTICOIDS CLASS",,.APCHMEDS)
+5 IF '$DATA(APCHMEDS)
QUIT ""
+6 SET G=""
+7 SET X=0
FOR
SET X=$ORDER(APCHMEDS(X))
IF X'=+X!(G)
QUIT
Begin DoDot:1
+8 SET D=$PIECE(APCHMEDS(X),U,1)
+9 KILL APCHX,APCHD
+10 SET %=P_"^ALL VISITS;DURING "_$$FMTE^XLFDT(D)_"-"_$$FMTE^XLFDT(D)
SET E=$$START1^APCLDF(%,"APCHX(")
+11 SET A=0
FOR
SET A=$ORDER(APCHX(A))
IF A'=+A
QUIT
Begin DoDot:2
+12 SET C=$$PRIMPOV^APCLV($PIECE(APCHX(A),U,5),"I")
IF '$$ICD^ATXAPI(C,$ORDER(^ATXAX("B","BGP ASTHMA DXS",0)),9)
QUIT
+13 SET G=1_U_"Oral Corticosteroid therapy "_$PIECE(APCHMEDS(X),U,2)_" associated with "_$$PRIMPOV^APCLV($PIECE(APCHX(A),U,5),"N")_" ("_$$PRIMPOV^APCLV($PIECE(APCHX(A),U,5),"C")_") on "_$$FMTE^XLFDT($PIECE(APCHMEDS(X),U))
End DoDot:2
End DoDot:1
+14 QUIT G
+15 ;
ORAL2(P,BDATE) ;EP - is patient on inhaled steriods since this date BDATE
+1 IF '$GET(P)
QUIT ""
+2 NEW APCHMEDS,R,G,A,B,C,APCHX,E,%,APCHD
+3 KILL APCHMEDS
+4 DO GETMEDS^APCHSMU1(P,BDATE,DT,"BGP RA GLUCOCORTICOIDS",,"BGP RA GLUCOCORTICOIDS CLASS",,.APCHMEDS)
+5 IF '$DATA(APCHMEDS)
QUIT ""
+6 ;doesn't have at least 2 prescriptions
IF '$DATA(APCHMEDS(2))
QUIT ""
+7 ;reorder by date and count 1 per date
+8 KILL APCHD
+9 SET X=0
FOR
SET X=$ORDER(APCHMEDS(X))
IF X'=+X
QUIT
SET APCHD($PIECE(APCHMEDS(X),U,1))=APCHMEDS(X)
+10 SET G=0
SET B=1
SET E=""
+11 SET D=0
FOR
SET D=$ORDER(APCHD(D))
IF D'=+D
QUIT
Begin DoDot:1
+12 KILL APCHX
+13 SET %=P_"^ALL VISITS;DURING "_$$FMTE^XLFDT(D)_"-"_$$FMTE^XLFDT(D)
SET R=$$START1^APCLDF(%,"APCHX(")
+14 SET A=0
FOR
SET A=$ORDER(APCHX(A))
IF A'=+A
QUIT
Begin DoDot:2
+15 SET C=$$PRIMPOV^APCLV($PIECE(APCHX(A),U,5),"I")
IF '$$ICD^ATXAPI(C,$ORDER(^ATXAX("B","BGP ASTHMA DXS",0)),9)
QUIT
+16 SET G=G+1
SET B=B+1
SET $PIECE(E,U)=G
SET $PIECE(E,U,B)="Oral Corticosteroid therapy "_$PIECE(APCHD(D),U,2)_" associated with "_$$PRIMPOV^APCLV($PIECE(APCHX(A),U,5),"N")_" ("_$$PRIMPOV^APCLV($PIECE(APCHX(A),U,5),"C")_") on "_$$FMTE^XLFDT($PIECE(APCHD(D),U))
End DoDot:2
End DoDot:1
+17 QUIT E
NREL(P,BDATE) ;EP - reliever?
+1 ;number of reliever meds between BDATE and EDATE
+2 NEW X,APCHX,E
+3 SET X=P_"^ALL MEDS [BAT ASTHMA RELIEVER MEDS"_";DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(DT)
SET E=$$START1^APCLDF(X,"BATL(")
+4 IF '$DATA(APCHX(1))
QUIT 0
+5 NEW C,X
SET (X,C)=0
FOR
SET X=$ORDER(APCHX(X))
IF X'=+X
QUIT
SET C=C+1
+6 QUIT C
+7 ;
ASERV(P,BDATE,F) ;EP - ER ASTHMA visits since BDATE
+1 IF '$GET(P)
QUIT 0
+2 SET F=$GET(F)
+3 IF F=""
SET F=1
+4 NEW C,X,V,Z,APCHX,APCHD,%,E,G
+5 KILL APCHX,APCHD
+6 SET %=P_"^ALL VISITS;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(DT)
SET E=$$START1^APCLDF(%,"APCHX(")
+7 SET C=0
SET X=0
SET V=""
FOR
SET X=$ORDER(APCHX(X))
IF X'=+X!(C)
QUIT
Begin DoDot:1
+8 SET V=$PIECE(APCHX(X),U,5)
+9 IF '$DATA(^AUPNVSIT(V,0))
QUIT
+10 IF $PIECE(^AUPNVSIT(V,0),U,11)
QUIT
+11 SET Z=$$CLINIC^APCLV(V,"C")
+12 ;urgent and er only
IF Z'=30
IF Z'=80
QUIT
+13 SET Z=$$PRIMPOV^APCLV(V,"I")
+14 IF '$$ICD^ATXAPI(Z,$ORDER(^ATXAX("B","BGP ASTHMA DXS",0)),9)
QUIT
+15 SET C=1
SET G=V
End DoDot:1
+16 IF 'C
QUIT ""
+17 IF F=1
QUIT C
+18 QUIT 1_U_$$PRIMPOV^APCLV(V,"N")_" at "_$$CLINIC^APCLV(V,"E")_" clinic on "_$$FMTE^XLFDT($PIECE($PIECE(^AUPNVSIT(V,0),U),"."))
+19 ;
NASV(P,BDATE,F) ;EP - number of asthma visits since BDATE
+1 ;count only A, H and any pov
+2 ;different dates, not visits
+3 IF '$GET(P)
QUIT 0
+4 IF '$GET(F)
SET F=1
+5 NEW C,X,V,Z,APCHX,APCHD,Y,G
+6 KILL APCHX,APCHD
+7 SET %=P_"^ALL VISITS;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(DT)
SET E=$$START1^APCLDF(%,"APCHX(")
+8 SET C=0
SET X=0
SET V=""
FOR
SET X=$ORDER(APCHX(X))
IF X'=+X
QUIT
Begin DoDot:1
+9 SET V=$PIECE(APCHX(X),U,5)
+10 IF '$DATA(^AUPNVSIT(V,0))
QUIT
+11 IF "AH"'[$PIECE(^AUPNVSIT(V,0),U,7)
QUIT
+12 IF $PIECE(^AUPNVSIT(V,0),U,11)
QUIT
+13 SET Z=$$PRIMPOV^APCLV(V,"I")
+14 IF '$$ICD^ATXAPI(Z,$ORDER(^ATXAX("B","BGP ASTHMA DXS",0)),9)
QUIT
+15 SET APCHD((9999999-$PIECE($PIECE(^AUPNVSIT(V,0),U,1),".")))=""
End DoDot:1
+16 SET X=0
FOR
SET X=$ORDER(APCHD(X))
IF X'=+X
QUIT
SET C=C+1
+17 IF F=1
QUIT C
+18 NEW R
+19 SET R=C
+20 SET X=0
SET V=1
FOR
SET X=$ORDER(APCHD(X))
IF X'=+X
QUIT
SET V=V+1
SET $PIECE(R,U,V)=(9999999-X)
+21 QUIT R
NASF(P,BDATE) ;EP - number of asthma fill dates since BDATE
+1 IF '$GET(P)
QUIT ""
+2 NEW APCHX,X,Y,C,E,EDATE
KILL APCHX
+3 SET EDATE=$$FMTE^XLFDT(DT)
SET BDATE=$$FMTE^XLFDT(BDATE)
+4 SET X=P_"^ALL MEDS [BAT ASTHMA RELIEVER MEDS "_";DURING "_BDATE_"-"_EDATE
SET E=$$START1^APCLDF(X,"APCHX(")
+5 SET (C,X)=0
FOR
SET X=$ORDER(APCHX(X))
IF X'=+X
QUIT
SET C=C+1
+6 KILL APCHX
SET X=P_"^ALL MEDS [BAT ASTHMA INHALED STEROIDS "_";DURING "_BDATE_"-"_EDATE
SET E=$$START1^APCLDF(X,"APCHX(")
+7 SET (C,X)=0
FOR
SET X=$ORDER(APCHX(X))
IF X'=+X
QUIT
SET C=C+1
+8 KILL APCHX
SET X=P_"^ALL MEDS [BAT ASTHMA CONTROLLER MEDS "_";DURING "_BDATE_"-"_EDATE
SET E=$$START1^APCLDF(X,"APCHX(")
+9 SET (C,X)=0
FOR
SET X=$ORDER(APCHX(X))
IF X'=+X
QUIT
SET C=C+1
+10 QUIT C
LASTAM(P,F) ;EP - return date of last asthma management plan = yes
+1 IF '$GET(P)
QUIT ""
+2 IF '$GET(F)
SET F=1
+3 NEW D
SET D=$ORDER(^AUPNVAST("AM",P,0))
+4 IF 'D
QUIT ""
+5 IF F=1
QUIT 9999999-D
+6 IF F=2
QUIT $$FMTE^XLFDT(9999999-D)
+7 QUIT ""
LASTSEV(P,F) ;EP - return last severity recorded
+1 ;1 - internal set of codes
+2 ;2 - internal date
+3 ;3 - external date
+4 ;4 - external name
+5 ;5 - code and external name
+6 NEW D,LAST,E,S
+7 IF '$GET(P)
QUIT ""
+8 IF '$GET(F)
SET F=1
+9 SET D=$ORDER(^AUPNVAST("AS",P,0))
+10 IF 'D
QUIT ""
+11 SET LAST=""
SET E=0
FOR
SET E=$ORDER(^AUPNVAST("AS",P,D,E))
IF E'=+E
QUIT
SET LAST=E
+12 IF 'LAST
QUIT ""
+13 SET S=^AUPNVAST("AS",P,D,LAST)
+14 IF F=1
QUIT S
+15 IF F=2
QUIT 9999999-D
+16 IF F=3
QUIT $$FMTE^XLFDT(9999999-D)
+17 IF F=4
QUIT $$EXTSET^XBFUNC(9000010.41,.04,S)
+18 IF F=5
QUIT S_"-"_$$EXTSET^XBFUNC(9000010.41,.04,S)
+19 QUIT ""
+20 ;
LASTACLG(P,F) ;EP - return last CLASSIFICATION recorded
+1 NEW D,LAST,E,S,X,T
+2 IF '$GET(P)
QUIT ""
+3 IF '$GET(F)
SET F=1
+4 SET T=$ORDER(^ATXAX("B","BGP ASTHMA DXS",0))
+5 IF 'T
QUIT ""
+6 SET S=""
+7 SET X=0
FOR
SET X=$ORDER(^AUPNPROB("AC",P,X))
IF X'=+X
QUIT
Begin DoDot:1
+8 IF $PIECE(^AUPNPROB(X,0),U,12)="D"
QUIT
+9 ;inactive
IF $PIECE(^AUPNPROB(X,0),U,12)="I"
QUIT
+10 SET C=$PIECE($GET(^AUPNPROB(X,0)),U)
+11 IF C=""
QUIT
+12 ;not asthma dx
IF '$$ICD^ATXAPI(C,T,9)
QUIT
+13 ;no classification
IF $PIECE(^AUPNPROB(X,0),U,15)=""
QUIT
+14 SET E=$PIECE(^AUPNPROB(X,0),U,15)
+15 IF E'>$PIECE(S,U,1)
QUIT
+16 SET S=E_U_$$VAL^XBDIQ1(9000011,X,.15)
End DoDot:1
+17 IF F=1
QUIT $PIECE(S,U)
+18 IF F=2
QUIT S
+19 ;
LASTASCL(P,F) ;EP - last CLASSIFICATION
+1 NEW D,LAST,E,S,X,T
+2 IF '$GET(P)
QUIT ""
+3 IF '$GET(F)
SET F=1
+4 SET T=$ORDER(^ATXAX("B","BGP ASTHMA DXS",0))
+5 IF 'T
QUIT ""
+6 SET S=""
+7 KILL LAST
+8 SET X=0
FOR
SET X=$ORDER(^AUPNPROB("AC",P,X))
IF X'=+X
QUIT
Begin DoDot:1
+9 IF $PIECE(^AUPNPROB(X,0),U,12)="D"
QUIT
+10 SET C=$PIECE($GET(^AUPNPROB(X,0)),U)
+11 IF C=""
QUIT
+12 IF '$$ICD^ATXAPI(C,T,9)
QUIT
+13 IF $PIECE(^AUPNPROB(X,0),U,15)=""
QUIT
+14 SET E=$PIECE(^AUPNPROB(X,0),U,15)
+15 SET D=$PIECE(^AUPNPROB(X,0),U,3)
+16 SET LAST(D)=E_U_$$VAL^XBDIQ1(9000011,X,.15)
End DoDot:1
+17 SET S=$ORDER(LAST(0))
+18 IF S=""
QUIT ""
+19 IF F=1
QUIT $PIECE(LAST(S),U,1)
+20 QUIT $PIECE(LAST(S),U,2)
+21 ;
LASTACON(P,F) ;EP - last ASTHMA CONTROL
+1 NEW D,LAST,E,S
+2 IF '$GET(P)
QUIT ""
+3 IF '$GET(F)
SET F=1
+4 SET D=$ORDER(^AUPNVAST("AAC",P,0))
+5 IF 'D
QUIT ""
+6 SET LAST=""
SET E=0
FOR
SET E=$ORDER(^AUPNVAST("AAC",P,D,E))
IF E'=+E
QUIT
SET LAST=E
+7 IF 'LAST
QUIT ""
+8 SET S=^AUPNVAST("AAC",P,D,LAST)
+9 IF F=1
QUIT S
+10 IF F=2
QUIT 9999999-D
+11 IF F=3
QUIT $$FMTE^XLFDT(9999999-D)
+12 IF F=4
QUIT $$VAL^XBDIQ1(9000010.41,LAST,.14)
+13 IF F=5
QUIT S_"-"_$$EXTSET^XBFUNC(9000010.41,.14,S)
+14 IF F=6
QUIT $$VAL^XBDIQ1(9000010.41,LAST,.14)_" documented on "_$$FMTE^XLFDT((9999999-D))
+15 IF F=7
QUIT $$FMTE^XLFDT((9999999-D))_" "_$$VAL^XBDIQ1(9000010.41,LAST,.14)
+16 QUIT ""
+17 ;
