APCHSAST ; IHS/CMI/LAB - ; 20 Sep 2010 1:44 PM
;;2.0;IHS PCC SUITE;**2,5,7,11**;MAY 14, 2009;Build 58
;
;BJPC v1.0 patch 1
S(Y,F,C,T) ;EP - set up array
I '$G(F) S F=0
I '$G(T) S T=0
NEW %,X
;blank lines
F F=1:1:F S X="" D S1
S X=Y
I $G(C) S L=$L(Y),T=(80-L)/2 D D S1 Q
.F %=1:1:(T-1) S X=" "_X
F %=1:1:T S X=" "_Y
D S1
Q
S1 ;
S %=$P(^TMP("APCHAST",$J,"DCS",0),U)+1,$P(^TMP("APCHAST",$J,"DCS",0),U)=%
S ^TMP("APCHAST",$J,"DCS",%)=X
Q
EP(DFN) ;PEP - Asthma supplement for health summary
NEW APCHX,APCHQUIT,APCHSX
NEW X,Y,Z,A,I,B,E,T
D EP2(DFN)
W ;write out array
W:$D(IOF) @IOF
K APCHQUIT
S APCHX=0 F S APCHX=$O(^TMP("APCHAST",$J,"DCS",APCHX)) Q:APCHX'=+APCHX!($D(APCHQUIT)) D
.I $Y>(IOSL-3) D HEADER Q:$D(APCHQUIT)
.W !,^TMP("APCHAST",$J,"DCS",APCHX)
.Q
I $D(APCHQUIT) S APCHSQIT=1
D EOJ
Q
;
EOJ ;
;D EN^XBVK("BAT")
K N,%,T,F,X,Y,B,C,E,F,H,L,N,P,T,W,M,T,T1,T2,T3
Q
I $E(IOST)="C",IO=IO(0) W ! S DIR(0)="EO" D ^DIR K DIR I Y=0!(Y="^")!($D(DTOUT)) S APCHQUIT="" Q
HEAD1 ;
W:$D(IOF) @IOF
W !,APCHSHDR
W !,"ASTHMA PATIENT CARE SUMMARY Report Date: ",$$FMTE^XLFDT(DT),!
Q
EP2(DFN) ;EP - PASS DFN get back array of patient care summary
;at this point you are stuck with ^TMP("APCHAST",$J,"DCS"
K ^TMP("APCHAST",$J,"DCS")
S ^TMP("APCHAST",$J,"DCS",0)=0
D SETARRAY
Q
SETARRAY ;set up array containing dm care summary
S X=APCHSHDR D S(X)
S X="ASTHMA PATIENT CARE SUMMARY Report Date: "_$$FMTE^XLFDT(DT) D S(X,1)
S X=$P(^DPT(DFN,0),U),$E(X,35)="HRN: "_$$HRN^AUPNPAT(DFN,DUZ(2)) D S(X,1)
S X="DOB: "_$$DOB^AUPNPAT(DFN,"E")_" Age: "_$$AGE^AUPNPAT(DFN)_" "_$$SEX^AUPNPAT(DFN) ;S Y=$$VAL^XBDIQ1(90181.01,DFN,.02)
S Y="" I $T(ATAG^BQITDUTL)="" S Y="Asthma Diagnostic Tag: Data Not Available" S $E(X,35)=Y
I $T(ATAG^BQITDUTL)]"" S T=$$ATAG^BQITDUTL(DFN,"Asthma") S Y="Asthma Diagnostic Tag: "_$S($P(T,U,2)="P":"Proposed",$P(T,U,2)="A":"Accepted",1:"None") S $E(X,35)=Y
;put icare tag here at in place of asthma register status
; S $E(X,35)="Asthma Register Status: "_$S(Y]"":Y,1:"NOT ON REGISTER") D S(X)
D S(X)
I $O(^BDPRECN("C",DFN,0)) D I 1
.D S(" ")
.S APCHSX=0 F S APCHSX=$O(^BDPRECN("C",DFN,APCHSX)) Q:APCHSX'=+APCHSX D
..S A=$P($G(^BDPRECN(APCHSX,0)),U)
..Q:A=""
..Q:'$D(^BDPTCAT(A,0))
..Q:$P(^BDPTCAT(A,0),U,8)="N"
..S A=$$VAL^XBDIQ1(90360.1,APCHSX,.01)
..;S X="",$E(X,(38-$L(A)))=A,X=X_": "_$$VAL^XBDIQ1(90360.1,APCHSX,.03) D S(X)
..S X="",X=A,X=X_": "_$$VAL^XBDIQ1(90360.1,APCHSX,.03) D S(X)
.Q
E S X="DESIGNATED PRIMARY CARE PROVIDER: "_$$VAL^XBDIQ1(9000001,DFN,.14) D S(X)
D S(" ")
K APCHPL,APCHASEV D PLASTA(DFN,.APCHPL) ;get problem list # and narrative
I '$D(APCHPL) S Y="ASTHMA IS NOT ON THIS PATIENT'S PROBLEM LIST; CONSIDER ADDING" D S(Y,1)
I $D(APCHPL) D
.S X=0,C=0 F S X=$O(APCHPL(X)) Q:X'=+X D
..S C=C+1
..I C=1 S Y="Asthma-Related Problem List: " D S(Y)
..I C'=1 D S("")
..;I C'=1 S Y=" "
..K Z
..S APCHSNRQ=APCHPL(X),APCHSICL=5 D ICD^APCHSAS1
..S D=0 F S D=$O(Z(D)) Q:D="" D
...;I D=1 S Y=Y_Z(D) D S(Y)
...D S(Z(D))
..S Y=" Asthma Severity: "_$S($P(^AUPNPROB(X,0),U,15)]"":$$VAL^XBDIQ1(9000011,X,.15),1:"None Documented") D S(Y)
..S Y=" Date of Onset: "_$S($P(^AUPNPROB(X,0),U,13)]"":$$VAL^XBDIQ1(9000011,X,.13),1:"None Documented") D S(Y)
..S Y=" Date Last Updated: "_$$VAL^XBDIQ1(9000011,X,.03) D S(Y)
..;notes
..S APCHX=0 F S APCHX=$O(^AUPNPROB(X,11,APCHX)) Q:APCHX'=+APCHX D
...S S=$P(^AUPNPROB(X,11,APCHX,0),U,1),S=$S($P(^AUTTLOC(S,0),U,7)]"":$P(^AUTTLOC(S,0),U,7),1:"??")
...S S=$P(APCHPL(X)," ")_S
...S APCHY=0 F S APCHY=$O(^AUPNPROB(X,11,APCHX,11,APCHY)) Q:APCHY'=+APCHY D
....S APCHSICL=6,APCHSNRQ=S_$P(^AUPNPROB(X,11,APCHX,11,APCHY,0),U)_" "_$$FMTE^XLFDT($P(^AUPNPROB(X,11,APCHX,11,APCHY,0),U,5))_" "_$P(^AUPNPROB(X,11,APCHX,11,APCHY,0),U,3) D ICD^APCHSAS1
....S E=0 F S E=$O(Z(E)) Q:E="" D S(Z(E))
S X="Most Recent Control: "_$$LASTACON^APCHSMAS(DFN,7) D S(X,1)
;get and display FH
K APCHTFH
D FMH^APCHSAS1(DFN,.APCHTFH)
S Y="Asthma-Related FAMILY HEALTH HISTORY: "
I '$D(APCHTFH) S Y=Y_"None Documented" D S(Y,1)
I $D(APCHTFH) D S(Y,1) D S("Date Last Mod Relation/Status/Diagnosis") D
.S X=0 F S X=$O(APCHTFH(X)) Q:X="" D
..I X=1,APCHTFH(1)="" Q
..D S(APCHTFH(X))
;S B=$$LASTITEM^APCHSMU(DFN,"BPF","MEASUREMENT","B")
S B=$$PBPF(DFN,"B")
I $P(B,U)]"" S X="Personal Best Peak Flow "_$P(B,U,2)_" liters/minute on "_$$FMTE^XLFDT($P(B,U)) D S(X,1)
I $P(B,U)="" S X="Personal Best Peak Flow: None Documented." D S(X,1)
S X="Peak Flow Zones",$E(X,21)="Green (80-100%)",$E(X,39)=$$GREEN($P(B,U,2)) D S(X,1)
S X="",$E(X,21)="Yellow (50-79%)",$E(X,39)=$$YELLOW($P(B,U,2)) D S(X)
S X="",$E(X,21)="Red (< 50%)",$E(X,39)=$$RED($P(B,U,2)) D S(X)
S APCHX=0,Y="" K APCHY F S APCHX=$O(^AUTTEDT("C","ASM-SMP",APCHX)) Q:APCHX'=+APCHX D
.S APCHY=$$LASTITEM^APCHSMU(DFN,"`"_APCHX,"EDUCATION")
.Q:APCHY=""
.S APCHY($P(APCHY,U,1))=""
S Y=$O(APCHY(0))
I Y]"" S X="Date of Last Asthma Action Plan: "_$$FMTE^XLFDT(Y)_$S($$FMDIFF^XLFDT(DT,Y)>365:" Needs to be reviewed.",1:"") D S(X,1)
I Y="" D
.S Y=$$LASTAM(DFN,1) I Y]"" S X="Date of Last Asthma Management Plan: "_$$FMTE^XLFDT(Y)_$S($$FMDIFF^XLFDT(DT,Y)>365:" Needs to be reviewed.",1:"") D S(X,1)
.I Y="" S X="Date of Last Asthma Action Plan: NEEDS TO BE REVIEWED" D S(X,1)
TRIGHF ;trigger health factors
S APCHG=0 K APCHSX
S APCHC=$O(^AUTTHF("B","ASTHMA TRIGGERS",0))
G:'APCHC TOB
S APCHF=0 F S APCHF=$O(^AUTTHF("AC",APCHC,APCHF)) Q:APCHF'=+APCHF D
.Q:'$D(^AUPNVHF("AA",DFN,APCHF))
.S D=$O(^AUPNVHF("AA",DFN,APCHF,""))
.S APCHG=APCHG+1
.S X=" "_$P(^AUTTHF(APCHF,0),U),$E(X,35)="Yes, documented on "_$$FMTE^XLFDT((9999999-D)) S APCHSX(APCHG)=X
S X="Triggers: "_$S('APCHG:"No Triggers identified.",1:"") D S(X,1)
S APCHG=0 F S APCHG=$O(APCHSX(APCHG)) Q:APCHG'=+APCHG D S(APCHSX(APCHG))
TOB ;
;S Y=$$LASTTOBS^APCLAPI7(DFN,,,"A"),X="Last Recorded TOBACCO Screening: "_$P(Y,U,2)_" "_$$FMTE^XLFDT($P(Y,U,1)) D S(X,1)
S Y=$$LASTSMOK^APCLAPI7(DFN,,,"A"),X="Last TOBACCO (SMOKING) Screening: "_$P(Y,U,2)_" "_$$DATE^APCHSMU($P(Y,U,1)) D S(X,1)
S Y=$$LASTSMLE^APCLAPI7(DFN,,,"A"),X="Last TOBACCO (SMOKELESS) Screening: "_$P(Y,U,2)_" "_$$DATE^APCHSMU($P(Y,U,1)) D S(X,1)
S Y=$$LASTSMEX^APCLAPI7(DFN,,,"A"),X="Last TOBACCO (EXPOSURE) Screening: "_$P(Y,U,2)_" "_$$DATE^APCHSMU($P(Y,U,1)) D S(X,1)
V D LAST5
S X="Last 5 Visits w/LUNG FUNCTION Measurements" D S(X,1)
S X="",$E(X,3)="DATE",$E(X,20)="FEV1/FVC",$E(X,38)="Highest Visit Peak Flow",$E(X,65)="FEF 25-75" D S(X)
S X="",$P(X,"-",75)="" D S(X)
I '$D(APCHL) S X="NO MEASUREMENTS DOCUMENTED" D S(X) G ASFD
S D=0,C=0 F S D=$O(APCHL(D)) Q:D'=+D!(C>5) D
.S C=C+1,V=0 F S V=$O(APCHL(D,V)) Q:V'=+V D
..S X="",$E(X,3)=$$FMTE^XLFDT((9999999-D),"1D")
..I $P(APCHL(D,V),U,3)]"" S $E(X,20)=$P(APCHL(D,V),U,3)
..I $P(APCHL(D,V),U,4)]"" S $E(X,38)=$P(APCHL(D,V),U,4)
..I $P(APCHL(D,V),U,5)]"" S $E(X,65)=$P(APCHL(D,V),U,5)
..D S(X)
ASFD ;asthma symptom free days
K APCHASFD
K APCHL
S X=DFN_"^ALL MEAS ASFD"_";DURING "_$$FMADD^XLFDT(DT,-365)_"-"_DT S E=$$START1^APCLDF(X,"APCHL(")
I '$D(APCHL(1)) S Y="Asthma Symptom-Free Days:" D S(Y,1) D S("Asthma Symptom Free Days should be reviewed at every Asthma visit")
I $D(APCHL) D
.S Y="Asthma Symptom-Free Days:" D S(Y,1)
.S Y=" Visit Date",$E(Y,20)="Symptom-Free Days" D S(Y)
.S X="",$P(X,"-",50)="" D S(X)
.S X=0 F S X=$O(APCHL(X)) Q:X'=+X S APCHL("D",(9999999-$P(APCHL(X),U)),+$P(APCHL(X),U,4))=APCHL(X)
.S D=0,C=0 F S D=$O(APCHL("D",D)) Q:D'=+D!(C>3) D
..S I=0,C=C+1 F S I=$O(APCHL("D",D,I)) Q:I'=+I D
...S Y=" "_$$FMTE^XLFDT((9999999-D)),$E(Y,20)=$P(APCHL("D",D,I),U,2) D S(Y)
;
ADM ;
K APCHASFD
K APCHL
S X=DFN_"^ALL MEAS ADM"_";DURING "_$$FMADD^XLFDT(DT,-365)_"-"_DT S E=$$START1^APCLDF(X,"APCHL(")
I '$D(APCHL(1)) S Y="Asthma Work/School Days Missed:" D S(Y,1) D S("Asthma Work/School days missed should be reviewed at every Asthma visit")
I $D(APCHL) D
.S Y="Asthma Work/School Days Missed:" D S(Y,1)
.S Y=" Visit Date",$E(Y,20)="Work/School Days Missed" D S(Y)
.S X="",$P(X,"-",50)="" D S(X)
.S X=0 F S X=$O(APCHL(X)) Q:X'=+X S APCHL("D",(9999999-$P(APCHL(X),U)),+$P(APCHL(X),U,4))=APCHL(X)
.S D=0,C=0 F S D=$O(APCHL("D",D)) Q:D'=+D!(C>3) D
..S I=0,C=C+1 F S I=$O(APCHL("D",D,I)) Q:I'=+I D
...S Y=" "_$$FMTE^XLFDT((9999999-D)),$E(Y,20)=$P(APCHL("D",D,I),U,2) D S(Y)
;
N ;more stuff
D N^APCHSAS1
Q
;
PBPF(P,F) ;EP - BEST PEAK FLOW
I $G(F)="" S F="D"
NEW APCHY,%,E,Y K APCHY S %=P_"^ALL MEAS BPF",E=$$START1^APCLDF(%,"APCHY(")
S %="",Y=0 F S Y=$O(APCHY(Y)) Q:Y'=+Y I $P(APCHY(Y),U,1)>$P(%,U,1) S %=APCHY(Y)
Q $S(F="D":$P(%,"^"),F="B":$P(%,"^")_"^"_$P(%,"^",2),1:$P(%,"^",2))
;
GREEN(V) ;EP - GREEN VALUE
NEW P,P1
I $G(V)="" Q ""
S P=$J((V*.80),3,0),P1=V
Q P_"-"_V_" liters/minute"
YELLOW(V) ;EP - YELLOW VALUE
NEW P,P1
I $G(V)="" Q ""
S P=(V*.50)
S P=$J(P,3,0)
S P1=(V*.80),P1=P1-1,P1=$J(P1,3,0)
Q P_"-"_P1_" liters/minute"
RED(V,D) ;EP - RED VALUE
NEW P,P1
I $G(V)="" Q ""
S P=((.50*V))
S P=$J(P,3,0)
Q "<"_P_" liters/minute"
;
;
PLAST(P,F) ;EP
;1 return 1 if yes, null if no
;2 return problem number _ provdier narrative
I '$G(P) Q ""
I '$G(F) S F=1
NEW I,A,B,G,S
S G="",A=0 F S A=$O(^AUPNPROB("AC",P,A)) Q:A'=+A!(G]"") D
.Q:$P(^AUPNPROB(A,0),U,12)="D"
.S I=$P(^AUPNPROB(A,0),U) Q:'$D(^ICD9(I,0)) S S=$P(^ICD9(I,0),U)
.I '$O(^ATXAX("B","BGP ASTHMA DXS",0)),$E(S,1,3)'="493" Q
.I $O(^ATXAX("B","BGP ASTHMA DXS",0)),'$$ICD^ATXAPI(I,$O(^ATXAX("B","BGP ASTHMA DXS",0)),9) Q
.S G=A
.Q
I G="" Q ""
I F=1 Q 1
I F=2 S G=$$PLN(G) Q G
Q ""
PLASTA(P,R) ;EP
;1 return 1 if yes, null if no
;2 return problem number _ provdier narrative
I '$G(P) Q ""
I '$G(F) S F=1
NEW I,A,B,G,S
K R
S G="",A=0 F S A=$O(^AUPNPROB("AC",P,A)) Q:A'=+A!(G]"") D
.Q:$P(^AUPNPROB(A,0),U,12)="D"
.S I=$P(^AUPNPROB(A,0),U) Q:'$D(^ICD9(I,0)) S S=$P(^ICD9(I,0),U)
.I '$O(^ATXAX("B","BGP ASTHMA DXS",0)),$E(S,1,3)'="493" Q
.I $O(^ATXAX("B","BGP ASTHMA DXS",0)),'$$ICD^ATXAPI(I,$O(^ATXAX("B","BGP ASTHMA DXS",0)),9) Q
.S APCHPL(A)=$$PLN(A)
.Q
Q
DXAST(P) ;EP
I '$G(P) Q ""
NEW D,I,A,G,S
S (D,G)=0 F S D=$O(^AUPNVPOV("AA",P,D)) Q:D'=+D!(G) D
.S I=0 F S I=$O(^AUPNVPOV("AA",P,D,I)) Q:I'=+I!(G) D
..S A=$P(^AUPNVPOV(I,0),U),S=$P(^ICD9(A,0),U)
..I '$O(^ATXAX("B","BGP ASTHMA DXS",0)),$E(S,1,3)'="493" Q
..I $O(^ATXAX("B","BGP ASTHMA DXS",0)),'$$ICD^ATXAPI(A,$O(^ATXAX("B","BGP ASTHMA DXS",0)),9) Q
..S G=1
..Q
.Q
Q G
;
;
;
LAST5 ;
K APCHD,APCHV,APCHL
S M="FVFC",P=3 D GETM
S M="PF",P=4 D GETM
S M="FEF",P=5 D GETM
K APCHD,APCHV
Q
GETM ;
S X=DFN_"^ALL MEASUREMENT "_M S E=$$START1^APCLDF(X,"APCHD(")
S X=0 F S X=$O(APCHD(X)) Q:X'=+X D
.S I=+$P(APCHD(X),U,4),V=$P(APCHD(X),U,5),R=$P(APCHD(X),U,2)
.I M'="FVFC" D Q
..Q:$P($G(APCHL((9999999-$P($P(^AUPNVSIT(V,0),U),".")),V)),U,P)>$P(^AUPNVMSR(I,0),U,4)
..S $P(APCHL((9999999-$P($P(^AUPNVSIT(V,0),U),".")),V),U,P)=$P(^AUPNVMSR(I,0),U,4)
.S Y=$$FVFC($P(^AUPNVMSR(I,0),U,4))
.Q:$P($G(APCHL((999999-$P($P(^AUPNVSIT(V,0),U),".")),V)),U,3)>Y
.S $P(APCHL((9999999-$P($P(^AUPNVSIT(V,0),U),".")),V),U,3)=$P(^AUPNVMSR(I,0),U,4)_" ("_Y_")"
K APCHD,APCHV
Q
;
FVFC(R) ;
NEW F,S,V
S F=$P(R,"/")
S S=$P(R,"/",2)
I S="" Q ""
I F="" Q ""
I S=0 Q 0
S P=F/S
I $L($P(P,"."))>3 S P=P+.005
Q $$STRIP^XLFSTR($J(P,5,2)," ")
S P=$P(P,".")_"."_$E($P(P,".",2),1,2)
Q P
;
PLN(E) ;
NEW S
S S=$P(^AUPNPROB(E,0),U,6),S=$S('S:"??",$P(^AUTTLOC(S,0),U,7)]"":$P(^AUTTLOC(S,0),U,7),1:"??")
Q S_$P(^AUPNPROB(E,0),U,7)_" "_$$VAL^XBDIQ1(9000011,E,.05)_$S($P(^AUPNPROB(E,0),U,12)="I":" (INACTIVE)",1:"")_" ("_$$VAL^XBDIQ1(9000011,E,.01)_") "
;
LASTAM(P,F) ;EP - return date of last asthma management plan = yes
I '$G(P) Q ""
I '$G(F) S F=1
NEW D,I,V,% S D=$O(^AUPNVAST("AM",P,0))
I 'D Q ""
I F=1 Q 9999999-D
I F=2 Q $$FMTE^XLFDT(9999999-D)
I F=3 D Q %
.S I=$O(^AUPNVAST("AM",P,D,1,0))
.I I S V=$P($G(^AUPNVAST(I,0)),U,3)
.S %=(9999999-D)_"^ASTHMA MANAGEMENT PLAN^^"_V_"^9000010.41^"_I
Q ""
;
LASTSEV(P,F) ;EP - return highest 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"
.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)_U_$P(^AUPNPROB(X,0),U,3)
I F=1 Q $P(S,U)
I F=2 Q $P(S,U,3)
I F=3 Q $$FMTE^XLFDT($P(S,U,3))
I F=4 Q $P($P(S,U,2),"-",2)
I F=5 Q $P(S,U,2)
Q ""
APCHSAST ; IHS/CMI/LAB - ; 20 Sep 2010 1:44 PM
+1 ;;2.0;IHS PCC SUITE;**2,5,7,11**;MAY 14, 2009;Build 58
+2 ;
+3 ;BJPC v1.0 patch 1
S(Y,F,C,T) ;EP - set up array
+1 IF '$GET(F)
SET F=0
+2 IF '$GET(T)
SET T=0
+3 NEW %,X
+4 ;blank lines
+5 FOR F=1:1:F
SET X=""
DO S1
+6 SET X=Y
+7 IF $GET(C)
SET L=$LENGTH(Y)
SET T=(80-L)/2
Begin DoDot:1
+8 FOR %=1:1:(T-1)
SET X=" "_X
End DoDot:1
DO S1
QUIT
+9 FOR %=1:1:T
SET X=" "_Y
+10 DO S1
+11 QUIT
S1 ;
+1 SET %=$PIECE(^TMP("APCHAST",$JOB,"DCS",0),U)+1
SET $PIECE(^TMP("APCHAST",$JOB,"DCS",0),U)=%
+2 SET ^TMP("APCHAST",$JOB,"DCS",%)=X
+3 QUIT
EP(DFN) ;PEP - Asthma supplement for health summary
+1 NEW APCHX,APCHQUIT,APCHSX
+2 NEW X,Y,Z,A,I,B,E,T
+3 DO EP2(DFN)
W ;write out array
+1 IF $DATA(IOF)
WRITE @IOF
+2 KILL APCHQUIT
+3 SET APCHX=0
FOR
SET APCHX=$ORDER(^TMP("APCHAST",$JOB,"DCS",APCHX))
IF APCHX'=+APCHX!($DATA(APCHQUIT))
QUIT
Begin DoDot:1
+4 IF $Y>(IOSL-3)
DO HEADER
IF $DATA(APCHQUIT)
QUIT
+5 WRITE !,^TMP("APCHAST",$JOB,"DCS",APCHX)
+6 QUIT
End DoDot:1
+7 IF $DATA(APCHQUIT)
SET APCHSQIT=1
+8 DO EOJ
+9 QUIT
+10 ;
EOJ ;
+1 ;D EN^XBVK("BAT")
+2 KILL N,%,T,F,X,Y,B,C,E,F,H,L,N,P,T,W,M,T,T1,T2,T3
+3 QUIT
+1 IF $EXTRACT(IOST)="C"
IF IO=IO(0)
WRITE !
SET DIR(0)="EO"
DO ^DIR
KILL DIR
IF Y=0!(Y="^")!($DATA(DTOUT))
SET APCHQUIT=""
QUIT
HEAD1 ;
+1 IF $DATA(IOF)
WRITE @IOF
+2 WRITE !,APCHSHDR
+3 WRITE !,"ASTHMA PATIENT CARE SUMMARY Report Date: ",$$FMTE^XLFDT(DT),!
+4 QUIT
EP2(DFN) ;EP - PASS DFN get back array of patient care summary
+1 ;at this point you are stuck with ^TMP("APCHAST",$J,"DCS"
+2 KILL ^TMP("APCHAST",$JOB,"DCS")
+3 SET ^TMP("APCHAST",$JOB,"DCS",0)=0
+4 DO SETARRAY
+5 QUIT
SETARRAY ;set up array containing dm care summary
+1 SET X=APCHSHDR
DO S(X)
+2 SET X="ASTHMA PATIENT CARE SUMMARY Report Date: "_$$FMTE^XLFDT(DT)
DO S(X,1)
+3 SET X=$PIECE(^DPT(DFN,0),U)
SET $EXTRACT(X,35)="HRN: "_$$HRN^AUPNPAT(DFN,DUZ(2))
DO S(X,1)
+4 ;S Y=$$VAL^XBDIQ1(90181.01,DFN,.02)
SET X="DOB: "_$$DOB^AUPNPAT(DFN,"E")_" Age: "_$$AGE^AUPNPAT(DFN)_" "_$$SEX^AUPNPAT(DFN)
+5 SET Y=""
IF $TEXT(ATAG^BQITDUTL)=""
SET Y="Asthma Diagnostic Tag: Data Not Available"
SET $EXTRACT(X,35)=Y
+6 IF $TEXT(ATAG^BQITDUTL)]""
SET T=$$ATAG^BQITDUTL(DFN,"Asthma")
SET Y="Asthma Diagnostic Tag: "_$SELECT($PIECE(T,U,2)="P":"Proposed",$PIECE(T,U,2)="A":"Accepted",1:"None")
SET $EXTRACT(X,35)=Y
+7 ;put icare tag here at in place of asthma register status
+8 ; S $E(X,35)="Asthma Register Status: "_$S(Y]"":Y,1:"NOT ON REGISTER") D S(X)
+9 DO S(X)
+10 IF $ORDER(^BDPRECN("C",DFN,0))
Begin DoDot:1
+11 DO S(" ")
+12 SET APCHSX=0
FOR
SET APCHSX=$ORDER(^BDPRECN("C",DFN,APCHSX))
IF APCHSX'=+APCHSX
QUIT
Begin DoDot:2
+13 SET A=$PIECE($GET(^BDPRECN(APCHSX,0)),U)
+14 IF A=""
QUIT
+15 IF '$DATA(^BDPTCAT(A,0))
QUIT
+16 IF $PIECE(^BDPTCAT(A,0),U,8)="N"
QUIT
+17 SET A=$$VAL^XBDIQ1(90360.1,APCHSX,.01)
+18 ;S X="",$E(X,(38-$L(A)))=A,X=X_": "_$$VAL^XBDIQ1(90360.1,APCHSX,.03) D S(X)
+19 SET X=""
SET X=A
SET X=X_": "_$$VAL^XBDIQ1(90360.1,APCHSX,.03)
DO S(X)
End DoDot:2
+20 QUIT
End DoDot:1
IF 1
+21 IF '$TEST
SET X="DESIGNATED PRIMARY CARE PROVIDER: "_$$VAL^XBDIQ1(9000001,DFN,.14)
DO S(X)
+22 DO S(" ")
+23 ;get problem list # and narrative
KILL APCHPL,APCHASEV
DO PLASTA(DFN,.APCHPL)
+24 IF '$DATA(APCHPL)
SET Y="ASTHMA IS NOT ON THIS PATIENT'S PROBLEM LIST; CONSIDER ADDING"
DO S(Y,1)
+25 IF $DATA(APCHPL)
Begin DoDot:1
+26 SET X=0
SET C=0
FOR
SET X=$ORDER(APCHPL(X))
IF X'=+X
QUIT
Begin DoDot:2
+27 SET C=C+1
+28 IF C=1
SET Y="Asthma-Related Problem List: "
DO S(Y)
+29 IF C'=1
DO S("")
+30 ;I C'=1 S Y=" "
+31 KILL Z
+32 SET APCHSNRQ=APCHPL(X)
SET APCHSICL=5
DO ICD^APCHSAS1
+33 SET D=0
FOR
SET D=$ORDER(Z(D))
IF D=""
QUIT
Begin DoDot:3
+34 ;I D=1 S Y=Y_Z(D) D S(Y)
+35 DO S(Z(D))
End DoDot:3
+36 SET Y=" Asthma Severity: "_$SELECT($PIECE(^AUPNPROB(X,0),U,15)]"":$$VAL^XBDIQ1(9000011,X,.15),1:"None Documented")
DO S(Y)
+37 SET Y=" Date of Onset: "_$SELECT($PIECE(^AUPNPROB(X,0),U,13)]"":$$VAL^XBDIQ1(9000011,X,.13),1:"None Documented")
DO S(Y)
+38 SET Y=" Date Last Updated: "_$$VAL^XBDIQ1(9000011,X,.03)
DO S(Y)
+39 ;notes
+40 SET APCHX=0
FOR
SET APCHX=$ORDER(^AUPNPROB(X,11,APCHX))
IF APCHX'=+APCHX
QUIT
Begin DoDot:3
+41 SET S=$PIECE(^AUPNPROB(X,11,APCHX,0),U,1)
SET S=$SELECT($PIECE(^AUTTLOC(S,0),U,7)]"":$PIECE(^AUTTLOC(S,0),U,7),1:"??")
+42 SET S=$PIECE(APCHPL(X)," ")_S
+43 SET APCHY=0
FOR
SET APCHY=$ORDER(^AUPNPROB(X,11,APCHX,11,APCHY))
IF APCHY'=+APCHY
QUIT
Begin DoDot:4
+44 SET APCHSICL=6
SET APCHSNRQ=S_$PIECE(^AUPNPROB(X,11,APCHX,11,APCHY,0),U)_" "_$$FMTE^XLFDT($PIECE(^AUPNPROB(X,11,APCHX,11,APCHY,0),U,5))_" "_$PIECE(^AUPNPROB(X,11,APCHX,11,APCHY,0),U,3)
DO ICD^APCHSAS1
+45 SET E=0
FOR
SET E=$ORDER(Z(E))
IF E=""
QUIT
DO S(Z(E))
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+46 SET X="Most Recent Control: "_$$LASTACON^APCHSMAS(DFN,7)
DO S(X,1)
+47 ;get and display FH
+48 KILL APCHTFH
+49 DO FMH^APCHSAS1(DFN,.APCHTFH)
+50 SET Y="Asthma-Related FAMILY HEALTH HISTORY: "
+51 IF '$DATA(APCHTFH)
SET Y=Y_"None Documented"
DO S(Y,1)
+52 IF $DATA(APCHTFH)
DO S(Y,1)
DO S("Date Last Mod Relation/Status/Diagnosis")
Begin DoDot:1
+53 SET X=0
FOR
SET X=$ORDER(APCHTFH(X))
IF X=""
QUIT
Begin DoDot:2
+54 IF X=1
IF APCHTFH(1)=""
QUIT
+55 DO S(APCHTFH(X))
End DoDot:2
End DoDot:1
+56 ;S B=$$LASTITEM^APCHSMU(DFN,"BPF","MEASUREMENT","B")
+57 SET B=$$PBPF(DFN,"B")
+58 IF $PIECE(B,U)]""
SET X="Personal Best Peak Flow "_$PIECE(B,U,2)_" liters/minute on "_$$FMTE^XLFDT($PIECE(B,U))
DO S(X,1)
+59 IF $PIECE(B,U)=""
SET X="Personal Best Peak Flow: None Documented."
DO S(X,1)
+60 SET X="Peak Flow Zones"
SET $EXTRACT(X,21)="Green (80-100%)"
SET $EXTRACT(X,39)=$$GREEN($PIECE(B,U,2))
DO S(X,1)
+61 SET X=""
SET $EXTRACT(X,21)="Yellow (50-79%)"
SET $EXTRACT(X,39)=$$YELLOW($PIECE(B,U,2))
DO S(X)
+62 SET X=""
SET $EXTRACT(X,21)="Red (< 50%)"
SET $EXTRACT(X,39)=$$RED($PIECE(B,U,2))
DO S(X)
+63 SET APCHX=0
SET Y=""
KILL APCHY
FOR
SET APCHX=$ORDER(^AUTTEDT("C","ASM-SMP",APCHX))
IF APCHX'=+APCHX
QUIT
Begin DoDot:1
+64 SET APCHY=$$LASTITEM^APCHSMU(DFN,"`"_APCHX,"EDUCATION")
+65 IF APCHY=""
QUIT
+66 SET APCHY($PIECE(APCHY,U,1))=""
End DoDot:1
+67 SET Y=$ORDER(APCHY(0))
+68 IF Y]""
SET X="Date of Last Asthma Action Plan: "_$$FMTE^XLFDT(Y)_$SELECT($$FMDIFF^XLFDT(DT,Y)>365:" Needs to be reviewed.",1:"")
DO S(X,1)
+69 IF Y=""
Begin DoDot:1
+70 SET Y=$$LASTAM(DFN,1)
IF Y]""
SET X="Date of Last Asthma Management Plan: "_$$FMTE^XLFDT(Y)_$SELECT($$FMDIFF^XLFDT(DT,Y)>365:" Needs to be reviewed.",1:"")
DO S(X,1)
+71 IF Y=""
SET X="Date of Last Asthma Action Plan: NEEDS TO BE REVIEWED"
DO S(X,1)
End DoDot:1
TRIGHF ;trigger health factors
+1 SET APCHG=0
KILL APCHSX
+2 SET APCHC=$ORDER(^AUTTHF("B","ASTHMA TRIGGERS",0))
+3 IF 'APCHC
GOTO TOB
+4 SET APCHF=0
FOR
SET APCHF=$ORDER(^AUTTHF("AC",APCHC,APCHF))
IF APCHF'=+APCHF
QUIT
Begin DoDot:1
+5 IF '$DATA(^AUPNVHF("AA",DFN,APCHF))
QUIT
+6 SET D=$ORDER(^AUPNVHF("AA",DFN,APCHF,""))
+7 SET APCHG=APCHG+1
+8 SET X=" "_$PIECE(^AUTTHF(APCHF,0),U)
SET $EXTRACT(X,35)="Yes, documented on "_$$FMTE^XLFDT((9999999-D))
SET APCHSX(APCHG)=X
End DoDot:1
+9 SET X="Triggers: "_$SELECT('APCHG:"No Triggers identified.",1:"")
DO S(X,1)
+10 SET APCHG=0
FOR
SET APCHG=$ORDER(APCHSX(APCHG))
IF APCHG'=+APCHG
QUIT
DO S(APCHSX(APCHG))
TOB ;
+1 ;S Y=$$LASTTOBS^APCLAPI7(DFN,,,"A"),X="Last Recorded TOBACCO Screening: "_$P(Y,U,2)_" "_$$FMTE^XLFDT($P(Y,U,1)) D S(X,1)
+2 SET Y=$$LASTSMOK^APCLAPI7(DFN,,,"A")
SET X="Last TOBACCO (SMOKING) Screening: "_$PIECE(Y,U,2)_" "_$$DATE^APCHSMU($PIECE(Y,U,1))
DO S(X,1)
+3 SET Y=$$LASTSMLE^APCLAPI7(DFN,,,"A")
SET X="Last TOBACCO (SMOKELESS) Screening: "_$PIECE(Y,U,2)_" "_$$DATE^APCHSMU($PIECE(Y,U,1))
DO S(X,1)
+4 SET Y=$$LASTSMEX^APCLAPI7(DFN,,,"A")
SET X="Last TOBACCO (EXPOSURE) Screening: "_$PIECE(Y,U,2)_" "_$$DATE^APCHSMU($PIECE(Y,U,1))
DO S(X,1)
V DO LAST5
+1 SET X="Last 5 Visits w/LUNG FUNCTION Measurements"
DO S(X,1)
+2 SET X=""
SET $EXTRACT(X,3)="DATE"
SET $EXTRACT(X,20)="FEV1/FVC"
SET $EXTRACT(X,38)="Highest Visit Peak Flow"
SET $EXTRACT(X,65)="FEF 25-75"
DO S(X)
+3 SET X=""
SET $PIECE(X,"-",75)=""
DO S(X)
+4 IF '$DATA(APCHL)
SET X="NO MEASUREMENTS DOCUMENTED"
DO S(X)
GOTO ASFD
+5 SET D=0
SET C=0
FOR
SET D=$ORDER(APCHL(D))
IF D'=+D!(C>5)
QUIT
Begin DoDot:1
+6 SET C=C+1
SET V=0
FOR
SET V=$ORDER(APCHL(D,V))
IF V'=+V
QUIT
Begin DoDot:2
+7 SET X=""
SET $EXTRACT(X,3)=$$FMTE^XLFDT((9999999-D),"1D")
+8 IF $PIECE(APCHL(D,V),U,3)]""
SET $EXTRACT(X,20)=$PIECE(APCHL(D,V),U,3)
+9 IF $PIECE(APCHL(D,V),U,4)]""
SET $EXTRACT(X,38)=$PIECE(APCHL(D,V),U,4)
+10 IF $PIECE(APCHL(D,V),U,5)]""
SET $EXTRACT(X,65)=$PIECE(APCHL(D,V),U,5)
+11 DO S(X)
End DoDot:2
End DoDot:1
ASFD ;asthma symptom free days
+1 KILL APCHASFD
+2 KILL APCHL
+3 SET X=DFN_"^ALL MEAS ASFD"_";DURING "_$$FMADD^XLFDT(DT,-365)_"-"_DT
SET E=$$START1^APCLDF(X,"APCHL(")
+4 IF '$DATA(APCHL(1))
SET Y="Asthma Symptom-Free Days:"
DO S(Y,1)
DO S("Asthma Symptom Free Days should be reviewed at every Asthma visit")
+5 IF $DATA(APCHL)
Begin DoDot:1
+6 SET Y="Asthma Symptom-Free Days:"
DO S(Y,1)
+7 SET Y=" Visit Date"
SET $EXTRACT(Y,20)="Symptom-Free Days"
DO S(Y)
+8 SET X=""
SET $PIECE(X,"-",50)=""
DO S(X)
+9 SET X=0
FOR
SET X=$ORDER(APCHL(X))
IF X'=+X
QUIT
SET APCHL("D",(9999999-$PIECE(APCHL(X),U)),+$PIECE(APCHL(X),U,4))=APCHL(X)
+10 SET D=0
SET C=0
FOR
SET D=$ORDER(APCHL("D",D))
IF D'=+D!(C>3)
QUIT
Begin DoDot:2
+11 SET I=0
SET C=C+1
FOR
SET I=$ORDER(APCHL("D",D,I))
IF I'=+I
QUIT
Begin DoDot:3
+12 SET Y=" "_$$FMTE^XLFDT((9999999-D))
SET $EXTRACT(Y,20)=$PIECE(APCHL("D",D,I),U,2)
DO S(Y)
End DoDot:3
End DoDot:2
End DoDot:1
+13 ;
ADM ;
+1 KILL APCHASFD
+2 KILL APCHL
+3 SET X=DFN_"^ALL MEAS ADM"_";DURING "_$$FMADD^XLFDT(DT,-365)_"-"_DT
SET E=$$START1^APCLDF(X,"APCHL(")
+4 IF '$DATA(APCHL(1))
SET Y="Asthma Work/School Days Missed:"
DO S(Y,1)
DO S("Asthma Work/School days missed should be reviewed at every Asthma visit")
+5 IF $DATA(APCHL)
Begin DoDot:1
+6 SET Y="Asthma Work/School Days Missed:"
DO S(Y,1)
+7 SET Y=" Visit Date"
SET $EXTRACT(Y,20)="Work/School Days Missed"
DO S(Y)
+8 SET X=""
SET $PIECE(X,"-",50)=""
DO S(X)
+9 SET X=0
FOR
SET X=$ORDER(APCHL(X))
IF X'=+X
QUIT
SET APCHL("D",(9999999-$PIECE(APCHL(X),U)),+$PIECE(APCHL(X),U,4))=APCHL(X)
+10 SET D=0
SET C=0
FOR
SET D=$ORDER(APCHL("D",D))
IF D'=+D!(C>3)
QUIT
Begin DoDot:2
+11 SET I=0
SET C=C+1
FOR
SET I=$ORDER(APCHL("D",D,I))
IF I'=+I
QUIT
Begin DoDot:3
+12 SET Y=" "_$$FMTE^XLFDT((9999999-D))
SET $EXTRACT(Y,20)=$PIECE(APCHL("D",D,I),U,2)
DO S(Y)
End DoDot:3
End DoDot:2
End DoDot:1
+13 ;
N ;more stuff
+1 DO N^APCHSAS1
+2 QUIT
+3 ;
PBPF(P,F) ;EP - BEST PEAK FLOW
+1 IF $GET(F)=""
SET F="D"
+2 NEW APCHY,%,E,Y
KILL APCHY
SET %=P_"^ALL MEAS BPF"
SET E=$$START1^APCLDF(%,"APCHY(")
+3 SET %=""
SET Y=0
FOR
SET Y=$ORDER(APCHY(Y))
IF Y'=+Y
QUIT
IF $PIECE(APCHY(Y),U,1)>$PIECE(%,U,1)
SET %=APCHY(Y)
+4 QUIT $SELECT(F="D":$PIECE(%,"^"),F="B":$PIECE(%,"^")_"^"_$PIECE(%,"^",2),1:$PIECE(%,"^",2))
+5 ;
GREEN(V) ;EP - GREEN VALUE
+1 NEW P,P1
+2 IF $GET(V)=""
QUIT ""
+3 SET P=$JUSTIFY((V*.80),3,0)
SET P1=V
+4 QUIT P_"-"_V_" liters/minute"
YELLOW(V) ;EP - YELLOW VALUE
+1 NEW P,P1
+2 IF $GET(V)=""
QUIT ""
+3 SET P=(V*.50)
+4 SET P=$JUSTIFY(P,3,0)
+5 SET P1=(V*.80)
SET P1=P1-1
SET P1=$JUSTIFY(P1,3,0)
+6 QUIT P_"-"_P1_" liters/minute"
RED(V,D) ;EP - RED VALUE
+1 NEW P,P1
+2 IF $GET(V)=""
QUIT ""
+3 SET P=((.50*V))
+4 SET P=$JUSTIFY(P,3,0)
+5 QUIT "<"_P_" liters/minute"
+6 ;
+7 ;
PLAST(P,F) ;EP
+1 ;1 return 1 if yes, null if no
+2 ;2 return problem number _ provdier narrative
+3 IF '$GET(P)
QUIT ""
+4 IF '$GET(F)
SET F=1
+5 NEW I,A,B,G,S
+6 SET G=""
SET A=0
FOR
SET A=$ORDER(^AUPNPROB("AC",P,A))
IF A'=+A!(G]"")
QUIT
Begin DoDot:1
+7 IF $PIECE(^AUPNPROB(A,0),U,12)="D"
QUIT
+8 SET I=$PIECE(^AUPNPROB(A,0),U)
IF '$DATA(^ICD9(I,0))
QUIT
SET S=$PIECE(^ICD9(I,0),U)
+9 IF '$ORDER(^ATXAX("B","BGP ASTHMA DXS",0))
IF $EXTRACT(S,1,3)'="493"
QUIT
+10 IF $ORDER(^ATXAX("B","BGP ASTHMA DXS",0))
IF '$$ICD^ATXAPI(I,$ORDER(^ATXAX("B","BGP ASTHMA DXS",0)),9)
QUIT
+11 SET G=A
+12 QUIT
End DoDot:1
+13 IF G=""
QUIT ""
+14 IF F=1
QUIT 1
+15 IF F=2
SET G=$$PLN(G)
QUIT G
+16 QUIT ""
PLASTA(P,R) ;EP
+1 ;1 return 1 if yes, null if no
+2 ;2 return problem number _ provdier narrative
+3 IF '$GET(P)
QUIT ""
+4 IF '$GET(F)
SET F=1
+5 NEW I,A,B,G,S
+6 KILL R
+7 SET G=""
SET A=0
FOR
SET A=$ORDER(^AUPNPROB("AC",P,A))
IF A'=+A!(G]"")
QUIT
Begin DoDot:1
+8 IF $PIECE(^AUPNPROB(A,0),U,12)="D"
QUIT
+9 SET I=$PIECE(^AUPNPROB(A,0),U)
IF '$DATA(^ICD9(I,0))
QUIT
SET S=$PIECE(^ICD9(I,0),U)
+10 IF '$ORDER(^ATXAX("B","BGP ASTHMA DXS",0))
IF $EXTRACT(S,1,3)'="493"
QUIT
+11 IF $ORDER(^ATXAX("B","BGP ASTHMA DXS",0))
IF '$$ICD^ATXAPI(I,$ORDER(^ATXAX("B","BGP ASTHMA DXS",0)),9)
QUIT
+12 SET APCHPL(A)=$$PLN(A)
+13 QUIT
End DoDot:1
+14 QUIT
DXAST(P) ;EP
+1 IF '$GET(P)
QUIT ""
+2 NEW D,I,A,G,S
+3 SET (D,G)=0
FOR
SET D=$ORDER(^AUPNVPOV("AA",P,D))
IF D'=+D!(G)
QUIT
Begin DoDot:1
+4 SET I=0
FOR
SET I=$ORDER(^AUPNVPOV("AA",P,D,I))
IF I'=+I!(G)
QUIT
Begin DoDot:2
+5 SET A=$PIECE(^AUPNVPOV(I,0),U)
SET S=$PIECE(^ICD9(A,0),U)
+6 IF '$ORDER(^ATXAX("B","BGP ASTHMA DXS",0))
IF $EXTRACT(S,1,3)'="493"
QUIT
+7 IF $ORDER(^ATXAX("B","BGP ASTHMA DXS",0))
IF '$$ICD^ATXAPI(A,$ORDER(^ATXAX("B","BGP ASTHMA DXS",0)),9)
QUIT
+8 SET G=1
+9 QUIT
End DoDot:2
+10 QUIT
End DoDot:1
+11 QUIT G
+12 ;
+13 ;
+14 ;
LAST5 ;
+1 KILL APCHD,APCHV,APCHL
+2 SET M="FVFC"
SET P=3
DO GETM
+3 SET M="PF"
SET P=4
DO GETM
+4 SET M="FEF"
SET P=5
DO GETM
+5 KILL APCHD,APCHV
+6 QUIT
GETM ;
+1 SET X=DFN_"^ALL MEASUREMENT "_M
SET E=$$START1^APCLDF(X,"APCHD(")
+2 SET X=0
FOR
SET X=$ORDER(APCHD(X))
IF X'=+X
QUIT
Begin DoDot:1
+3 SET I=+$PIECE(APCHD(X),U,4)
SET V=$PIECE(APCHD(X),U,5)
SET R=$PIECE(APCHD(X),U,2)
+4 IF M'="FVFC"
Begin DoDot:2
+5 IF $PIECE($GET(APCHL((9999999-$PIECE($PIECE(^AUPNVSIT(V,0),U),".")),V)),U,P)>$PIECE(^AUPNVMSR(I,0),U,4)
QUIT
+6 SET $PIECE(APCHL((9999999-$PIECE($PIECE(^AUPNVSIT(V,0),U),".")),V),U,P)=$PIECE(^AUPNVMSR(I,0),U,4)
End DoDot:2
QUIT
+7 SET Y=$$FVFC($PIECE(^AUPNVMSR(I,0),U,4))
+8 IF $PIECE($GET(APCHL((999999-$PIECE($PIECE(^AUPNVSIT(V,0),U),".")),V)),U,3)>Y
QUIT
+9 SET $PIECE(APCHL((9999999-$PIECE($PIECE(^AUPNVSIT(V,0),U),".")),V),U,3)=$PIECE(^AUPNVMSR(I,0),U,4)_" ("_Y_")"
End DoDot:1
+10 KILL APCHD,APCHV
+11 QUIT
+12 ;
FVFC(R) ;
+1 NEW F,S,V
+2 SET F=$PIECE(R,"/")
+3 SET S=$PIECE(R,"/",2)
+4 IF S=""
QUIT ""
+5 IF F=""
QUIT ""
+6 IF S=0
QUIT 0
+7 SET P=F/S
+8 IF $LENGTH($PIECE(P,"."))>3
SET P=P+.005
+9 QUIT $$STRIP^XLFSTR($JUSTIFY(P,5,2)," ")
+10 SET P=$PIECE(P,".")_"."_$EXTRACT($PIECE(P,".",2),1,2)
+11 QUIT P
+12 ;
PLN(E) ;
+1 NEW S
+2 SET S=$PIECE(^AUPNPROB(E,0),U,6)
SET S=$SELECT('S:"??",$PIECE(^AUTTLOC(S,0),U,7)]"":$PIECE(^AUTTLOC(S,0),U,7),1:"??")
+3 QUIT S_$PIECE(^AUPNPROB(E,0),U,7)_" "_$$VAL^XBDIQ1(9000011,E,.05)_$SELECT($PIECE(^AUPNPROB(E,0),U,12)="I":" (INACTIVE)",1:"")_" ("_$$VAL^XBDIQ1(9000011,E,.01)_") "
+4 ;
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,I,V,%
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 IF F=3
Begin DoDot:1
+8 SET I=$ORDER(^AUPNVAST("AM",P,D,1,0))
+9 IF I
SET V=$PIECE($GET(^AUPNVAST(I,0)),U,3)
+10 SET %=(9999999-D)_"^ASTHMA MANAGEMENT PLAN^^"_V_"^9000010.41^"_I
End DoDot:1
QUIT %
+11 QUIT ""
+12 ;
LASTSEV(P,F) ;EP - return highest 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 SET C=$PIECE($GET(^AUPNPROB(X,0)),U)
+10 IF C=""
QUIT
+11 ;not asthma dx
IF '$$ICD^ATXAPI(C,T,9)
QUIT
+12 ;no classification
IF $PIECE(^AUPNPROB(X,0),U,15)=""
QUIT
+13 SET E=$PIECE(^AUPNPROB(X,0),U,15)
+14 IF E'>$PIECE(S,U,1)
QUIT
+15 SET S=E_U_$$VAL^XBDIQ1(9000011,X,.15)_U_$PIECE(^AUPNPROB(X,0),U,3)
End DoDot:1
+16 IF F=1
QUIT $PIECE(S,U)
+17 IF F=2
QUIT $PIECE(S,U,3)
+18 IF F=3
QUIT $$FMTE^XLFDT($PIECE(S,U,3))
+19 IF F=4
QUIT $PIECE($PIECE(S,U,2),"-",2)
+20 IF F=5
QUIT $PIECE(S,U,2)
+21 QUIT ""
