BHSAST ;IHS/MSC/MGH - Asthma supplement data ;21-Apr-2014 17:43;DU
;;1.0;HEALTH SUMMARY COMPONENTS;**3,6,9**;March 17,2006;Build 16
;============================================================
; IHS/CMI/LAB - ;16-Jul-2009 09:38;MGH
;;2.0;IHS PCC SUITE;;MAY 14, 2009
;Copy of APCHAST routine in IHS health summary
;BJPC v1.0 patch 1
;Patch 6 upgraded for tobacco
;-----------------------------------------------------
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("BHSAST",$J,"DCS",0),U)+1,$P(^TMP("BHSAST",$J,"DCS",0),U)=%
S ^TMP("BHSAST",$J,"DCS",%)=X
Q
EP(DFN) ;PEP - Asthma supplement for health summary
NEW BHX,APCHQUIT,BHSX
NEW X,Y,Z,A,I,B,E,T
D EP2(DFN)
W ;write out array
D CKP^GMTSUP Q:$D(GMTSQIT)
S BHX=0 F S BHX=$O(^TMP("BHSAST",$J,"DCS",BHX)) Q:BHX'=+BHX!($D(GMTSQIT)) D
.D CKP^GMTSUP Q:$D(GMTSQIT)
.W !,^TMP("BHSAST",$J,"DCS",BHX)
.Q
D CKP^GMTSUP Q:$D(GMTSQIT)
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
K BHF,BHG,BHC,BHSICL,BHSNRP,BHY,BHSNRQ
K BHDG,BHDTM,BHDYS,BHEXP,BHMFX,BHORTS,BHMED,BHPWHT,BHTDAT,BHQTY,BHREF,BHRFL,BHRX,BHSO,BHSTAT,BHDG,BHCRN
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("BHSAST",$J,"DCS"
K ^TMP("BHSAST",$J,"DCS")
S ^TMP("BHSAST",$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 BHSX=0 F S BHSX=$O(^BDPRECN("C",DFN,BHSX)) Q:BHSX'=+BHSX D
..S A=$P($G(^BDPRECN(BHSX,0)),U)
..Q:A=""
..Q:'$D(^BDPTCAT(A,0))
..Q:$P(^BDPTCAT(A,0),U,8)="N"
..S A=$$VAL^XBDIQ1(90360.1,BHSX,.01)
..;S X="",$E(X,(38-$L(A)))=A,X=X_": "_$$VAL^XBDIQ1(90360.1,BHSX,.03) D S(X)
..S X="",X=A,X=X_": "_$$VAL^XBDIQ1(90360.1,BHSX,.03) D S(X)
.Q
E S X="DESIGNATED PRIMARY PROVIDER: "_$$VAL^XBDIQ1(9000001,DFN,.14) D S(X)
D S(" ")
K BHPL,BHASEV D PLASTA(DFN,.BHPL) ;get problem list # and narrative
I '$D(BHPL) S Y="ASTHMA IS NOT ON THIS PATIENT'S PROBLEM LIST; CONSIDER ADDING" D S(Y,1)
I $D(BHPL) D
.S X=0,C=0 F S X=$O(BHPL(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 BHSNRQ=BHPL(X),BHSICL=5 D ICD^BHSAST1
..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 BHX=0 F S BHX=$O(^AUPNPROB(X,11,BHX)) Q:BHX'=+BHX D
...S S=$P(^AUPNPROB(X,11,BHX,0),U,1),S=$S($P(^AUTTLOC(S,0),U,7)]"":$P(^AUTTLOC(S,0),U,7),1:"??")
...S S=$P(BHPL(X)," ")_S
...S BHY=0 F S BHY=$O(^AUPNPROB(X,11,BHX,11,BHY)) Q:BHY'=+BHY D
....S BHSICL=6,BHSNRQ=S_$P(^AUPNPROB(X,11,BHX,11,BHY,0),U)_" "_$$FMTE^XLFDT($P(^AUPNPROB(X,11,BHX,11,BHY,0),U,5))_" "_$P(^AUPNPROB(X,11,BHX,11,BHY,0),U,3) D ICD^BHSAST1
....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 BHTFH
D FMH^BHSAST1(DFN,.BHTFH)
S Y="Asthma-Related FAMILY HEALTH HISTORY: "
I '$D(BHTFH) S Y=Y_"None Documented" D S(Y,1)
I $D(BHTFH) D S(Y,1) D S("Date Last Mod Relation/Status/Diagnosis") D
.S X=0 F S X=$O(BHTFH(X)) Q:X="" D
..I X=1,BHTFH(1)="" Q
..D S(BHTFH(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 Y=$$LASTITEM^APCHSMU(DFN,"ASM-SMP","EDUCATION") 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="" 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 BHG=0 K BHSX
S BHC=$O(^AUTTHF("B","ASTHMA TRIGGERS",0))
G:'BHC TOB
S BHF=0 F S BHF=$O(^AUTTHF("AC",BHC,BHF)) Q:BHF'=+BHF D
.Q:'$D(^AUPNVHF("AA",DFN,BHF))
.S D=$O(^AUPNVHF("AA",DFN,BHF,""))
.S BHG=BHG+1
.S X=" "_$P(^AUTTHF(BHF,0),U),$E(X,35)="Yes, documented on "_$$FMTE^XLFDT((9999999-D)) S BHSX(BHG)=X
S X="Triggers: "_$S('BHG:"No Triggers identified.",1:"") D S(X,1)
S BHG=0 F S BHG=$O(BHSX(BHG)) Q:BHG'=+BHG D S(BHSX(BHG))
TOB ;
;S Y=$$LASTTOBS^APCLAPI1(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(BHL) S X="NO MEASUREMENTS DOCUMENTED" D S(X) G ASFD
S D=0,C=0 F S D=$O(BHL(D)) Q:D'=+D!(C>5) D
.S C=C+1,V=0 F S V=$O(BHL(D,V)) Q:V'=+V D
..S X="",$E(X,3)=$$FMTE^XLFDT((9999999-D),"1D")
..I $P(BHL(D,V),U,3)]"" S $E(X,20)=$P(BHL(D,V),U,3)
..I $P(BHL(D,V),U,4)]"" S $E(X,38)=$P(BHL(D,V),U,4)
..I $P(BHL(D,V),U,5)]"" S $E(X,65)=$P(BHL(D,V),U,5)
..D S(X)
ASFD ;asthma symptom free days
K BHASFD
K BHL
S X=DFN_"^ALL MEAS ASFD"_";DURING "_$$FMADD^XLFDT(DT,-365)_"-"_DT S E=$$START1^APCLDF(X,"BHL(")
I '$D(BHL(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(BHL) 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(BHL(X)) Q:X'=+X S BHL("D",(9999999-$P(BHL(X),U)),+$P(BHL(X),U,4))=BHL(X)
.S D=0,C=0 F S D=$O(BHL("D",D)) Q:D'=+D!(C>3) D
..S I=0,C=C+1 F S I=$O(BHL("D",D,I)) Q:I'=+I D
...S Y=" "_$$FMTE^XLFDT((9999999-D)),$E(Y,20)=$P(BHL("D",D,I),U,2) D S(Y)
;
ADM ;
K BHASFD
K BHL
S X=DFN_"^ALL MEAS ADM"_";DURING "_$$FMADD^XLFDT(DT,-365)_"-"_DT S E=$$START1^APCLDF(X,"BHL(")
I '$D(BHL(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(BHL) 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(BHL(X)) Q:X'=+X S BHL("D",(9999999-$P(BHL(X),U)),+$P(BHL(X),U,4))=BHL(X)
.S D=0,C=0 F S D=$O(BHL("D",D)) Q:D'=+D!(C>3) D
..S I=0,C=C+1 F S I=$O(BHL("D",D,I)) Q:I'=+I D
...S Y=" "_$$FMTE^XLFDT((9999999-D)),$E(Y,20)=$P(BHL("D",D,I),U,2) D S(Y)
;
N ;more stuff
D N^BHSAST1
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
.S I=$P(^AUPNPROB(A,0),U)
.;Patch 9 use new APIs for ICD codes
.I $$AICD^BHSUTL S S=$P($$ICDDX^ICDEX(I,"","","I"),U,2)
.E S S=$P($$ICDDX^ICDCODE(I,""),U,2)
.Q:P=""
.I '$O(^ATXAX("B","BGP ASTHMA DXS",0)),$E(S,1,3)'="493" Q
.I $O(^ATXAX("B","BGP ASTHMA DXS",0)),'$$ICD^ATXCHK(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
.S I=$P(^AUPNPROB(A,0),U)
.;P8 changes for ICD-10
.I $$AICD^BHSUTL S S=$P($$ICDDX^ICDEX(I,"","","I"),U,2)
.E S S=$P($$ICDDX^ICDCODE(I,""),U,2)
.Q:P=""
.I '$O(^ATXAX("B","BGP ASTHMA DXS",0)),$E(S,1,3)'="493" Q
.I $O(^ATXAX("B","BGP ASTHMA DXS",0)),'$$ICD^ATXCHK(I,$O(^ATXAX("B","BGP ASTHMA DXS",0)),9) Q
.S BHPL(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)
..;Patch 8 Use new APIS for codes
..I $$AICD^BHSUTL S S=$P($$ICDDX^ICDEX(A,"","","I"),U,2)
..E S S=$P($$ICDDX^ICDCODE(A,""),U,2)
..I '$O(^ATXAX("B","BGP ASTHMA DXS",0)),$E(S,1,3)'="493" Q
..I $O(^ATXAX("B","BGP ASTHMA DXS",0)),'$$ICD^ATXCHK(A,$O(^ATXAX("B","BGP ASTHMA DXS",0)),9) Q
..S G=1
..Q
.Q
Q G
;
;
;
LAST5 ;
K BHD,BHV,BHL
S M="FVFC",P=3 D GETM
S M="PF",P=4 D GETM
S M="FEF",P=5 D GETM
K BHD,BHV
Q
GETM ;
S X=DFN_"^ALL MEASUREMENT "_M S E=$$START1^APCLDF(X,"BHD(")
S X=0 F S X=$O(BHD(X)) Q:X'=+X D
.S I=+$P(BHD(X),U,4),V=$P(BHD(X),U,5),R=$P(BHD(X),U,2)
.I M'="FVFC" D Q
..Q:$P($G(BHL((9999999-$P($P(^AUPNVSIT(V,0),U),".")),V)),U,P)>$P(^AUPNVMSR(I,0),U,4)
..S $P(BHL((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(BHL((999999-$P($P(^AUPNVSIT(V,0),U),".")),V)),U,3)>Y
.S $P(BHL((9999999-$P($P(^AUPNVSIT(V,0),U),".")),V),U,3)=$P(^AUPNVMSR(I,0),U,4)_" ("_Y_")"
K BHD,BHV
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
.S C=$P($G(^AUPNPROB(X,0)),U)
.Q:C=""
.Q:'$$ICD^ATXCHK(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 ""
BHSAST ;IHS/MSC/MGH - Asthma supplement data ;21-Apr-2014 17:43;DU
+1 ;;1.0;HEALTH SUMMARY COMPONENTS;**3,6,9**;March 17,2006;Build 16
+2 ;============================================================
+3 ; IHS/CMI/LAB - ;16-Jul-2009 09:38;MGH
+4 ;;2.0;IHS PCC SUITE;;MAY 14, 2009
+5 ;Copy of APCHAST routine in IHS health summary
+6 ;BJPC v1.0 patch 1
+7 ;Patch 6 upgraded for tobacco
+8 ;-----------------------------------------------------
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("BHSAST",$JOB,"DCS",0),U)+1
SET $PIECE(^TMP("BHSAST",$JOB,"DCS",0),U)=%
+2 SET ^TMP("BHSAST",$JOB,"DCS",%)=X
+3 QUIT
EP(DFN) ;PEP - Asthma supplement for health summary
+1 NEW BHX,APCHQUIT,BHSX
+2 NEW X,Y,Z,A,I,B,E,T
+3 DO EP2(DFN)
W ;write out array
+1 DO CKP^GMTSUP
IF $DATA(GMTSQIT)
QUIT
+2 SET BHX=0
FOR
SET BHX=$ORDER(^TMP("BHSAST",$JOB,"DCS",BHX))
IF BHX'=+BHX!($DATA(GMTSQIT))
QUIT
Begin DoDot:1
+3 DO CKP^GMTSUP
IF $DATA(GMTSQIT)
QUIT
+4 WRITE !,^TMP("BHSAST",$JOB,"DCS",BHX)
+5 QUIT
End DoDot:1
+6 DO CKP^GMTSUP
IF $DATA(GMTSQIT)
QUIT
+7 DO EOJ
+8 QUIT
+9 ;
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 KILL BHF,BHG,BHC,BHSICL,BHSNRP,BHY,BHSNRQ
+4 KILL BHDG,BHDTM,BHDYS,BHEXP,BHMFX,BHORTS,BHMED,BHPWHT,BHTDAT,BHQTY,BHREF,BHRFL,BHRX,BHSO,BHSTAT,BHDG,BHCRN
+5 QUIT
+1 ;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 ;
+1 ;W:$D(IOF) @IOF
+2 ;W !,APCHSHDR
+3 ;W !,"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("BHSAST",$J,"DCS"
+2 KILL ^TMP("BHSAST",$JOB,"DCS")
+3 SET ^TMP("BHSAST",$JOB,"DCS",0)=0
+4 DO SETARRAY
+5 QUIT
SETARRAY ;set up array containing dm care summary
+1 ;S X=APCHSHDR D 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 BHSX=0
FOR
SET BHSX=$ORDER(^BDPRECN("C",DFN,BHSX))
IF BHSX'=+BHSX
QUIT
Begin DoDot:2
+13 SET A=$PIECE($GET(^BDPRECN(BHSX,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,BHSX,.01)
+18 ;S X="",$E(X,(38-$L(A)))=A,X=X_": "_$$VAL^XBDIQ1(90360.1,BHSX,.03) D S(X)
+19 SET X=""
SET X=A
SET X=X_": "_$$VAL^XBDIQ1(90360.1,BHSX,.03)
DO S(X)
End DoDot:2
+20 QUIT
End DoDot:1
IF 1
+21 IF '$TEST
SET X="DESIGNATED PRIMARY PROVIDER: "_$$VAL^XBDIQ1(9000001,DFN,.14)
DO S(X)
+22 DO S(" ")
+23 ;get problem list # and narrative
KILL BHPL,BHASEV
DO PLASTA(DFN,.BHPL)
+24 IF '$DATA(BHPL)
SET Y="ASTHMA IS NOT ON THIS PATIENT'S PROBLEM LIST; CONSIDER ADDING"
DO S(Y,1)
+25 IF $DATA(BHPL)
Begin DoDot:1
+26 SET X=0
SET C=0
FOR
SET X=$ORDER(BHPL(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 BHSNRQ=BHPL(X)
SET BHSICL=5
DO ICD^BHSAST1
+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 BHX=0
FOR
SET BHX=$ORDER(^AUPNPROB(X,11,BHX))
IF BHX'=+BHX
QUIT
Begin DoDot:3
+41 SET S=$PIECE(^AUPNPROB(X,11,BHX,0),U,1)
SET S=$SELECT($PIECE(^AUTTLOC(S,0),U,7)]"":$PIECE(^AUTTLOC(S,0),U,7),1:"??")
+42 SET S=$PIECE(BHPL(X)," ")_S
+43 SET BHY=0
FOR
SET BHY=$ORDER(^AUPNPROB(X,11,BHX,11,BHY))
IF BHY'=+BHY
QUIT
Begin DoDot:4
+44 SET BHSICL=6
SET BHSNRQ=S_$PIECE(^AUPNPROB(X,11,BHX,11,BHY,0),U)_" "_$$FMTE^XLFDT($PIECE(^AUPNPROB(X,11,BHX,11,BHY,0),U,5))_" "_$PIECE(^AUPNPROB(X,11,BHX,11,BHY,0),U,3)
DO ICD^BHSAST1
+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 BHTFH
+49 DO FMH^BHSAST1(DFN,.BHTFH)
+50 SET Y="Asthma-Related FAMILY HEALTH HISTORY: "
+51 IF '$DATA(BHTFH)
SET Y=Y_"None Documented"
DO S(Y,1)
+52 IF $DATA(BHTFH)
DO S(Y,1)
DO S("Date Last Mod Relation/Status/Diagnosis")
Begin DoDot:1
+53 SET X=0
FOR
SET X=$ORDER(BHTFH(X))
IF X=""
QUIT
Begin DoDot:2
+54 IF X=1
IF BHTFH(1)=""
QUIT
+55 DO S(BHTFH(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 Y=$$LASTITEM^APCHSMU(DFN,"ASM-SMP","EDUCATION")
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)
+64 IF Y=""
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)
+65 IF Y=""
SET X="Date of Last Asthma Action Plan: NEEDS TO BE REVIEWED"
DO S(X,1)
TRIGHF ;trigger health factors
+1 SET BHG=0
KILL BHSX
+2 SET BHC=$ORDER(^AUTTHF("B","ASTHMA TRIGGERS",0))
+3 IF 'BHC
GOTO TOB
+4 SET BHF=0
FOR
SET BHF=$ORDER(^AUTTHF("AC",BHC,BHF))
IF BHF'=+BHF
QUIT
Begin DoDot:1
+5 IF '$DATA(^AUPNVHF("AA",DFN,BHF))
QUIT
+6 SET D=$ORDER(^AUPNVHF("AA",DFN,BHF,""))
+7 SET BHG=BHG+1
+8 SET X=" "_$PIECE(^AUTTHF(BHF,0),U)
SET $EXTRACT(X,35)="Yes, documented on "_$$FMTE^XLFDT((9999999-D))
SET BHSX(BHG)=X
End DoDot:1
+9 SET X="Triggers: "_$SELECT('BHG:"No Triggers identified.",1:"")
DO S(X,1)
+10 SET BHG=0
FOR
SET BHG=$ORDER(BHSX(BHG))
IF BHG'=+BHG
QUIT
DO S(BHSX(BHG))
TOB ;
+1 ;S Y=$$LASTTOBS^APCLAPI1(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(BHL)
SET X="NO MEASUREMENTS DOCUMENTED"
DO S(X)
GOTO ASFD
+5 SET D=0
SET C=0
FOR
SET D=$ORDER(BHL(D))
IF D'=+D!(C>5)
QUIT
Begin DoDot:1
+6 SET C=C+1
SET V=0
FOR
SET V=$ORDER(BHL(D,V))
IF V'=+V
QUIT
Begin DoDot:2
+7 SET X=""
SET $EXTRACT(X,3)=$$FMTE^XLFDT((9999999-D),"1D")
+8 IF $PIECE(BHL(D,V),U,3)]""
SET $EXTRACT(X,20)=$PIECE(BHL(D,V),U,3)
+9 IF $PIECE(BHL(D,V),U,4)]""
SET $EXTRACT(X,38)=$PIECE(BHL(D,V),U,4)
+10 IF $PIECE(BHL(D,V),U,5)]""
SET $EXTRACT(X,65)=$PIECE(BHL(D,V),U,5)
+11 DO S(X)
End DoDot:2
End DoDot:1
ASFD ;asthma symptom free days
+1 KILL BHASFD
+2 KILL BHL
+3 SET X=DFN_"^ALL MEAS ASFD"_";DURING "_$$FMADD^XLFDT(DT,-365)_"-"_DT
SET E=$$START1^APCLDF(X,"BHL(")
+4 IF '$DATA(BHL(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(BHL)
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(BHL(X))
IF X'=+X
QUIT
SET BHL("D",(9999999-$PIECE(BHL(X),U)),+$PIECE(BHL(X),U,4))=BHL(X)
+10 SET D=0
SET C=0
FOR
SET D=$ORDER(BHL("D",D))
IF D'=+D!(C>3)
QUIT
Begin DoDot:2
+11 SET I=0
SET C=C+1
FOR
SET I=$ORDER(BHL("D",D,I))
IF I'=+I
QUIT
Begin DoDot:3
+12 SET Y=" "_$$FMTE^XLFDT((9999999-D))
SET $EXTRACT(Y,20)=$PIECE(BHL("D",D,I),U,2)
DO S(Y)
End DoDot:3
End DoDot:2
End DoDot:1
+13 ;
ADM ;
+1 KILL BHASFD
+2 KILL BHL
+3 SET X=DFN_"^ALL MEAS ADM"_";DURING "_$$FMADD^XLFDT(DT,-365)_"-"_DT
SET E=$$START1^APCLDF(X,"BHL(")
+4 IF '$DATA(BHL(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(BHL)
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(BHL(X))
IF X'=+X
QUIT
SET BHL("D",(9999999-$PIECE(BHL(X),U)),+$PIECE(BHL(X),U,4))=BHL(X)
+10 SET D=0
SET C=0
FOR
SET D=$ORDER(BHL("D",D))
IF D'=+D!(C>3)
QUIT
Begin DoDot:2
+11 SET I=0
SET C=C+1
FOR
SET I=$ORDER(BHL("D",D,I))
IF I'=+I
QUIT
Begin DoDot:3
+12 SET Y=" "_$$FMTE^XLFDT((9999999-D))
SET $EXTRACT(Y,20)=$PIECE(BHL("D",D,I),U,2)
DO S(Y)
End DoDot:3
End DoDot:2
End DoDot:1
+13 ;
N ;more stuff
+1 DO N^BHSAST1
+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 SET I=$PIECE(^AUPNPROB(A,0),U)
+8 ;Patch 9 use new APIs for ICD codes
+9 IF $$AICD^BHSUTL
SET S=$PIECE($$ICDDX^ICDEX(I,"","","I"),U,2)
+10 IF '$TEST
SET S=$PIECE($$ICDDX^ICDCODE(I,""),U,2)
+11 IF P=""
QUIT
+12 IF '$ORDER(^ATXAX("B","BGP ASTHMA DXS",0))
IF $EXTRACT(S,1,3)'="493"
QUIT
+13 IF $ORDER(^ATXAX("B","BGP ASTHMA DXS",0))
IF '$$ICD^ATXCHK(I,$ORDER(^ATXAX("B","BGP ASTHMA DXS",0)),9)
QUIT
+14 SET G=A
+15 QUIT
End DoDot:1
+16 IF G=""
QUIT ""
+17 IF F=1
QUIT 1
+18 IF F=2
SET G=$$PLN(G)
QUIT G
+19 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 SET I=$PIECE(^AUPNPROB(A,0),U)
+9 ;P8 changes for ICD-10
+10 IF $$AICD^BHSUTL
SET S=$PIECE($$ICDDX^ICDEX(I,"","","I"),U,2)
+11 IF '$TEST
SET S=$PIECE($$ICDDX^ICDCODE(I,""),U,2)
+12 IF P=""
QUIT
+13 IF '$ORDER(^ATXAX("B","BGP ASTHMA DXS",0))
IF $EXTRACT(S,1,3)'="493"
QUIT
+14 IF $ORDER(^ATXAX("B","BGP ASTHMA DXS",0))
IF '$$ICD^ATXCHK(I,$ORDER(^ATXAX("B","BGP ASTHMA DXS",0)),9)
QUIT
+15 SET BHPL(A)=$$PLN(A)
+16 QUIT
End DoDot:1
+17 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)
+6 ;Patch 8 Use new APIS for codes
+7 IF $$AICD^BHSUTL
SET S=$PIECE($$ICDDX^ICDEX(A,"","","I"),U,2)
+8 IF '$TEST
SET S=$PIECE($$ICDDX^ICDCODE(A,""),U,2)
+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^ATXCHK(A,$ORDER(^ATXAX("B","BGP ASTHMA DXS",0)),9)
QUIT
+11 SET G=1
+12 QUIT
End DoDot:2
+13 QUIT
End DoDot:1
+14 QUIT G
+15 ;
+16 ;
+17 ;
LAST5 ;
+1 KILL BHD,BHV,BHL
+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 BHD,BHV
+6 QUIT
GETM ;
+1 SET X=DFN_"^ALL MEASUREMENT "_M
SET E=$$START1^APCLDF(X,"BHD(")
+2 SET X=0
FOR
SET X=$ORDER(BHD(X))
IF X'=+X
QUIT
Begin DoDot:1
+3 SET I=+$PIECE(BHD(X),U,4)
SET V=$PIECE(BHD(X),U,5)
SET R=$PIECE(BHD(X),U,2)
+4 IF M'="FVFC"
Begin DoDot:2
+5 IF $PIECE($GET(BHL((9999999-$PIECE($PIECE(^AUPNVSIT(V,0),U),".")),V)),U,P)>$PIECE(^AUPNVMSR(I,0),U,4)
QUIT
+6 SET $PIECE(BHL((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(BHL((999999-$PIECE($PIECE(^AUPNVSIT(V,0),U),".")),V)),U,3)>Y
QUIT
+9 SET $PIECE(BHL((9999999-$PIECE($PIECE(^AUPNVSIT(V,0),U),".")),V),U,3)=$PIECE(^AUPNVMSR(I,0),U,4)_" ("_Y_")"
End DoDot:1
+10 KILL BHD,BHV
+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 SET C=$PIECE($GET(^AUPNPROB(X,0)),U)
+9 IF C=""
QUIT
+10 ;not asthma dx
IF '$$ICD^ATXCHK(C,T,9)
QUIT
+11 ;no classification
IF $PIECE(^AUPNPROB(X,0),U,15)=""
QUIT
+12 SET E=$PIECE(^AUPNPROB(X,0),U,15)
+13 IF E'>$PIECE(S,U,1)
QUIT
+14 SET S=E_U_$$VAL^XBDIQ1(9000011,X,.15)_U_$PIECE(^AUPNPROB(X,0),U,3)
End DoDot:1
+15 IF F=1
QUIT $PIECE(S,U)
+16 IF F=2
QUIT $PIECE(S,U,3)
+17 IF F=3
QUIT $$FMTE^XLFDT($PIECE(S,U,3))
+18 IF F=4
QUIT $PIECE($PIECE(S,U,2),"-",2)
+19 IF F=5
QUIT $PIECE(S,U,2)
+20 QUIT ""
