BHSAAP2 ;IHS/MSC/MGH - Health summmary for asthma action plan;06-May-2010 10:55;MGH
;;1.0;HEALTH SUMMARY COMONENTS;**4**;March 17, 2006;Build 13
;===============================================================
;copy of APCHAAP2 to print an asthma action plan
; IHS/CMI/LAB - 2.0;IHS PCC SUITE;**2**;MAY 14, 2009
;
PRINT ;EP
N BHSB,BHSC,BHSCRN,BHSD,BHSDC,BHSDTM,BHSDYS,BHSEXP,BHSF,BHSG,BHSRXN,BHSSIG,BHSSP,BHSSSGY,BHSQ,BHSREF
S BHSQ=0
D CKP^GMTSUP Q:$D(GMTSQIT)
W !,$P(^DIC(4,DUZ(2),0),U),?53,"Today's Date: ",$$FMTE^XLFDT(DT),!
W "Patient Name: ",$P(^DPT(DFN,0),U)
W ?45,"Birth Date: ",$$DOB^AUPNPAT(DFN,"E")
W ?71,"Age: ",$$AGE^AUPNPAT(DFN),!
W $$REPEAT^XLFSTR("_",79),!
W "My Doctor: " S X=$$DPCP^APCHPWH1(DFN) W:X $P(^VA(200,X,0),U) W " Phone number: ",$$VAL^XBDIQ1(9999999.06,DUZ(2),.13),!
W " Address: ",$$VAL^XBDIQ1(9999999.06,DUZ(2),.14)_" "_$$VAL^XBDIQ1(9999999.06,DUZ(2),.15)_$S($$VAL^XBDIQ1(9999999.06,DUZ(2),.15)]"":", ",1:" ")
W:$P(^AUTTLOC(DUZ(2),0),U,14) $P(^DIC(5,$$VALI^XBDIQ1(9999999.06,DUZ(2),.16),0),U,2) W " "_$$VAL^XBDIQ1(9999999.06,DUZ(2),.17),!
W "My Pharmacy: ",$$PHARM(DUZ(2),"N")," Phone number: ",$$PHARM(DUZ(2),"P"),!
W "My Contact person: ",$$EC(DFN,"N")," Phone number: ",$$EC(DFN,"P"),!
W $$REPEAT^XLFSTR("_",79),!!
W "Asthma Triggers",!
S BHSG=0 K APCHSX
S BHSC=$O(^AUTTHF("B","ASTHMA TRIGGERS",0))
G:'BHSC AAP
S BHSF=0 F S BHSF=$O(^AUTTHF("AC",BHSC,BHSF)) Q:BHSF'=+BHSF D
.Q:'$D(^AUPNVHF("AA",DFN,BHSF))
.S D=$O(^AUPNVHF("AA",DFN,BHSF,""))
.S X=" "_$P(^AUTTHF(BHSF,0),U),$E(X,40)="Documented on "_$$FMTE^XLFDT((9999999-D)) W ?5,X,! S BHSG=1
I 'BHSG W "No Triggers identified.",!
AAP ;
;I $Y>(IOSL-5) D HEAD Q:APCHQ
D CKP^GMTSUP Q:$D(GMTSQIT)
W !,"ASTHMA ACTION PLAN",!!
S BHSB=$$PBPF^APCHSAST(DFN,"B")
I $P(BHSB,U,2)]"" D
.W "Do your peak flow today. What is your number? What Zone are you in?",!
.;I $Y>(IOSL-3) D HEAD Q:APCHQ
.D CKP^GMTSUP Q:$D(GMTSQIT)
.NEW R,Y,G
.S R=$$REDH($P(BHSB,U,2)) I R]"" S R="0-"_R
.W ?2,$$STRIP^XLFSTR(R," "),?11,"RED ZONE [0-49% of Best Peak Flow]",!
.S Y=$$YELLOW($P(BHSB,U,2),2)
.W ?2,$$STRIP^XLFSTR(Y," "),?11,"YELLOW ZONE [50-79% of Best Peak Flow]",!
.;I $Y>(IOSL-3) D HEAD Q:APCHQ
.D CKP^GMTSUP Q:$D(GMTSQIT)
.S G=$$GREEN($P(BHSB,U,2),2)
.W ?2,$$STRIP^XLFSTR(G," "),?11,"GREEN ZONE [80-100% of Best Peak Flow]",!!
;I $Y>(IOSL-3) D HEAD Q:APCHQ
D CKP^GMTSUP Q:$D(GMTSQIT)
I $P(BHSB,U)="" W ?3,"Your Personal Best Peak Flow: None documented; please discuss with your",!,"provider at your next clinic visit.",!
I $P(BHSB,U)]"" W ?3,"Your Personal Best Peak Flow: ",$P(BHSB,U,2)," liters/minute on ",$$FMTE^XLFDT($P(BHSB,U,1)),!
;I $Y>(IOSL-4) D HEAD Q:APCHQ
D CKP^GMTSUP Q:$D(GMTSQIT)
W !,"Follow these steps to control your asthma.",!
W $$REPEAT^XLFSTR("*",79),!
W !,"RED ZONE "_$S($P(BHSB,U)]"":"[49-0%]",1:"")_" - Need Medical Help!! ",!
;I $Y>(IOSL-4) D HEAD Q:APCHQ
D CKP^GMTSUP Q:$D(GMTSQIT)
I $P(BHSB,U)]"" W "Peak Flow less than ",$$RED($P(BHSB,U,2),.50,2)," liters/minute",!," OR",!
W "You are coughing, short of breath, and wheezing.",!
W "You have trouble walking or talking.",!
;I $Y>(IOSL-3) D HEAD Q:APCHQ
D CKP^GMTSUP Q:$D(GMTSQIT)
W "Your rescue medicine doesn't work.",!
I BHSRELM="" W !,"________________________________________________________________",!
I BHSRELM]"" D Q:$D(GMTSQIT)
.;attempt to wrap directions 70 characters
.K ^UTILITY($J,"W") S X=BHSRELM,DIWL=0,DIWR=70 D ^DIWP
.;S X=$S($L($G(^UTILITY($J,"W",0,1,0)))>1:$G(^UTILITY($J,"W",0,1,0)),$L($G(^UTILITY($J,"W",0,1,0)))=1:"No directions on file",1:" ") D S^APCHPWH1(X)
.F F=1:1:$G(^UTILITY($J,"W",0)) S X=$G(^UTILITY($J,"W",0,F,0)) Q:$D(GMTSQIT) D
..;I $Y>(IOSL-3) D HEAD Q:APCHQ
..D CKP^GMTSUP Q:$D(GMTSQIT)
..W !,X
.K ^UTILITY($J,"W")
.W !
;I $Y>(IOSL-3) D HEAD Q:APCHQ
D CKP^GMTSUP Q:$D(GMTSQIT)
W !,"Ask someone to bring you to the Emergency Room, call 911, or call your doctor.",!
W $$REPEAT^XLFSTR("*",79),!
;I $Y>(IOSL-4) D HEAD Q:APCHQ
D CKP^GMTSUP Q:$D(GMTSQIT)
W "YELLOW ZONE "_$S($P(BHSB,U)]"":"[50-79%]",1:""),"- Asthma is Getting Worse ",!
I $P(BHSB,U)]"" W "Peak Flow is ",$$YELLOW^APCHSAST($P(BHSB,U,2))," liters/minute",!," OR",!
W "You are coughing or wheezing.",!
;I $Y>(IOSL-3) D HEAD Q:APCHQ
D CKP^GMTSUP Q:$D(GMTSQIT)
W "You are waking at night from your asthma.",!
W "You have some trouble doing usual activities.",!
;I $Y>(IOSL-3) D HEAD Q:APCHQ
D CKP^GMTSUP Q:$D(GMTSQIT)
I BHSRESM="" W !,"________________________________________________________________",! I 1
I BHSRESM]"" D Q:$D(GMTSQIT)
.;attempt to wrap directions 70 characters
.K ^UTILITY($J,"W") S X=BHSRESM,DIWL=0,DIWR=70 D ^DIWP
.;S X=$S($L($G(^UTILITY($J,"W",0,1,0)))>1:$G(^UTILITY($J,"W",0,1,0)),$L($G(^UTILITY($J,"W",0,1,0)))=1:"No directions on file",1:" ") D S^APCHPWH1(X)
.F F=1:1:$G(^UTILITY($J,"W",0)) S X=$G(^UTILITY($J,"W",0,F,0)) Q:$D(GMTSQIT) D
..;I $Y>(IOSL-3) D HEAD Q:APCHQ
..D CKP^GMTSUP Q:$D(GMTSQIT)
..W !,X
.K ^UTILITY($J,"W")
.W !
W !,"Keep taking your green zone medications. Check your peak flow readings ",!,"every few hours.",!
;I $Y>(IOSL-3) D HEAD Q:APCHQ
D CKP^GMTSUP Q:$D(GMTSQIT)
W !,"CALL YOUR DOCTOR or care provider IF:",!
W "1. You are in your yellow zone for more than 24-48 hours.",!
;I $Y>(IOSL-3) D HEAD Q:APCHQ
D CKP^GMTSUP Q:$D(GMTSQIT)
W "2. OR You need to use your reliever medication more than every 4 hours.",!
W "3. OR Your symptoms are getting worse.",!
W $$REPEAT^XLFSTR("*",79),!
;I $Y>(IOSL-3) D HEAD Q:APCHQ
D CKP^GMTSUP Q:$D(GMTSQIT)
W !,"GREEN ZONE "_$S($P(BHSB,U)]"":"[100-80%]",1:"")_" - You Are Doing Well ",!
I $P(BHSB,U)]"" W "Peak Flow is ",$$GREEN^APCHSAST($P(BHSB,U,2)),!," OR",!
;I $Y>(IOSL-3) D HEAD Q:APCHQ
D CKP^GMTSUP Q:$D(GMTSQIT)
W "You have no coughing, wheezing, or chest tightness during the day or night.",!
W "You sleep through the night without coughing, wheezing, or chest tightness.",!
;I $Y>(IOSL-3) D HEAD Q:APCHQ
D CKP^GMTSUP Q:$D(GMTSQIT)
W "You can do usual activities.",!
W !,"Take your long-term control medication every day.",!
MEDS ;
RELMEDS ;
K BHSL,BHSREL,BHSCONT
D LAST1YRR
D LAST1YRC
;
CONTMEDS ;
W !!,"Active Controller Medications",!
K BHSL
M BHSL=BHSCONT
D DISPMEDS
W !,"Active Reliever Medications",!
K BHSL
M BHSL=BHSREL
D DISPMEDS
Q
HEAD ;
;I $E(IOST)="C",IO=IO(0) W ! S DIR(0)="EO" D ^DIR K DIR I Y=0!(Y="^")!($D(DTOUT)) S APCHQ=1 Q
HEAD1 ;
W:$D(IOF) @IOF
W !,$P(^DIC(4,DUZ(2),0),U),?53,"Today's Date: ",$$FMTE^XLFDT(DT),!
W "Patient Name: ",$P(^DPT(DFN,0),U)
W ?45,"Birth Date: ",$$DOB^AUPNPAT(DFN,"E")
W ?71,"Age: ",$$AGE^AUPNPAT(DFN),!
W $$REPEAT^XLFSTR("_",79),!!
Q
CTR(X,Y) ;EP - Center X in a field Y wide.
Q $J("",$S($D(Y):Y,1:IOM)-$L(X)\2)_X
;----------
EXIT ;
;D EN^XBVK("APCH")
;D ^XBFMK
Q
PHARM(L,I) ;
NEW %
S %=$O(^PS(59,"C",L,0))
I '%,I="N" Q $P(^DIC(4,L,0),U)
I '%,I="P" Q $$VAL^XBDIQ1(9999999.06,L,.13)
I I="N" Q $P(^PS(59,%,0),U)
I I="P" Q $P(^PS(59,%,0),U,4)
Q ""
;
EC(L,I) ;
NEW %
S F=$S(I="N":.331,1:.3319)
S %=$$VAL^XBDIQ1(2,L,F)
I %]"" Q %
S F=$S(I="N":.211,1:.219)
Q $$VAL^XBDIQ1(2,L,F)
;
GREEN(V,F) ;
NEW P,P1
I $G(V)="" Q ""
S P=(V*.80),P=$J(P,3,0),P1=V
I F=1 Q P_"-"_V_" liters/minute"
Q P_"-"_V
YELLOW(V,F) ;
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)
I F=1 Q P_"-"_P1_" liters/minute"
I F=2 Q P_"-"_P1
RED(V,D,F) ;
NEW P,P1
I $G(V)="" Q ""
I $G(D)="" S D=.50
S P=(V*D)
S P=P+.5,P=$J(P,3,0)
I F=1 Q "<"_P_" liters/minute"
Q $TR(P," ")
;
REDH(V) ;
NEW P
S P=((.50*V)-1)
Q $TR($J(P,3,0)," ")
;
Q
;
DISPMEDS ;EP
N D,E,N,BHSMED,BHSMFX,BHSDC,BHSDYS,BHSCRN,BHSQTY,BHSSIG,BHSDTM,BHSEX,X
N BHSORTS,BHSRX,BHSRFL,BHSSTAT
I '$O(BHSL(0)) W !,"None documented; please discuss with your provider at your next",!,"clinic visit.",! Q
S D=0 F S D=$O(BHSL(D)) Q:D'=+D D
.S E=0 F S E=$O(BHSL(D,E)) Q:E'=+E S N=^AUPNVMED(E,0) D
..S BHSD=$$FMTE^XLFDT($P(^AUPNVSIT($P(N,U,3),0),U),"5D")
..S BHSDC=$P(N,U,8),BHSDYS=$P(N,U,7),BHSMFX=$S($P(N,U,4)="":+N,1:$P(N,U,4)) S:BHSDYS="" BHSDYS=30 S BHSRX=$S($D(^PSRX("APCC",E)):$O(^(E,0)),1:0)
..S BHSCRN=$S(+BHSRX:$D(^PS(55,DFN,"P","CP",BHSRX)),1:0)
..S BHSQTY=$P(N,U,6),BHSSIG=$P(N,U,5)
..S BHSDTM=$P($P(^AUPNVSIT($P(N,U,3),0),U),"."),BHSEXP=""
..S X=$$FMDIFF^XLFDT(DT,BHSDTM)
..I X>BHSDYS S Y=$$FMADD^XLFDT(BHSDTM,BHSDYS) S BHSEXP="-- Ran out "_$$FMTE^XLFDT(Y,"2D")
..S BHSMED=$S($P(N,U,4)="":$P(^PSDRUG(BHSMFX,0),U),1:$P(N,U,4))
..I BHSDC S Y=$$FMTE^XLFDT(BHSDC) S BHSEXP="-- D/C "_Y
..S BHSORTS=$G(^AUPNVMED(E,11))
..I BHSORTS["RETURNED TO STOCK",BHSDC S BHSEXP="--RTS "_Y
..D SIG S BHSSIG=BHSSSGY
..D REF I BHSREF S BHSSIG=BHSSIG_" "_BHSREF_$S(BHSREF=1:" refill",1:" refills")_" left."
..;I $Y>(IOSL-4) D HEAD Q:APCHQ
..D CKP^GMTSUP Q:$D(GMTSQIT)
..S X=BHSD,$E(X,13)=BHSMED_" #"_BHSQTY_" ("_BHSDYS_" days) "_BHSEXP W ?1,X,!
..S X="",$E(X,14)=$E(BHSSIG,1,65) W X,!
..I $L(BHSSIG)>65 S X="",$E(X,14)=$E(BHSSIG,66,999) W X,!
..Q
.Q
Q
;
SIG ;CONSTRUCT THE FULL TEXT FROM THE ENCODED SIG
S BHSSSGY="" F BHSSP=1:1:$L(BHSSIG," ") S X=$P(BHSSIG," ",BHSSP) I X]"" D
. S Y=$O(^PS(51,"B",X,0)) I Y>0 S X=$P(^PS(51,Y,0),"^",2) I $D(^(9)) S Y=$P(BHSSIG," ",BHSSP-1),Y=$E(Y,$L(Y)) S:Y>1 X=$P(^(9),"^",1)
. S BHSSSGY=BHSSSGY_X_" "
Q
;
REF ;DETERMINE THE NUMBER OF REFILLS REMAINING
I 'BHSRX S BHSREF=0 Q
S BHSRFL=$P(^PSRX(BHSRX,0),U,9) S BHSREF=0 F S BHSREF=$O(^PSRX(BHSRX,1,BHSREF)) Q:'BHSREF S BHSRFL=BHSRFL-1
S BHSREF=BHSRFL
Q
;
LAST1YRR ;EP
NEW T,E,D,Y,M,G,C,N
S BHSREL=0
S T(1)=$O(^ATXAX("B","BAT ASTHMA SHRT ACT RELV MEDS",0))
S T(2)=$O(^ATXAX("B","BAT ASTHMA SHRT ACT RELV NDC",0))
S T(3)=$O(^ATXAX("B","BAT ASTHMA SHRT ACT INHLR MEDS",0))
S T(4)=$O(^ATXAX("B","BAT ASTHMA SHRT ACT INHLR NDC",0))
S T(5)=$O(^ATXAX("B","BGP RA GLUCOCORTIOCOIDS MEDS",0))
S T(6)=$O(^ATXAX("B","BGP RA GLUCOCORTIOCOIDS CLASS",0))
S E=9999999-$$FMADD^XLFDT(DT,-183)
S D=0 F S D=$O(^AUPNVMED("AA",DFN,D)) Q:D'=+D!(D>E) D
.S M=0 F S M=$O(^AUPNVMED("AA",DFN,D,M)) Q:M'=+M D
..Q:'$D(^AUPNVMED(M,0))
..S Y=$P(^AUPNVMED(M,0),U)
..Q:'Y
..;is it active?
..I $P(^AUPNVMED(M,0),U,8)]"",$P(^AUPNVMED(M,0),U,8)'>DT Q
..S BHSRXN=$O(^PSRX("APCC",M,0))
..S G=1 I BHSRXN D
...S BHSSTAT=$P($G(^PSRX(BHSRXN,"STA")),U,1)
...I BHSSTAT'=0 S G=0
..I 'G Q
..I T(1),$D(^ATXAX(T(1),21,"B",Y)) D SR Q
..I T(3),$D(^ATXAX(T(3),21,"B",Y)) D SR Q
..I T(5),$D(^ATXAX(T(5),21,"B",Y)) D SR Q
..S N=$P($G(^PSDRUG(Y,2)),U,4)
..Q:N=""
..I N]"",T(2),$D(^ATXAX(T(2),21,"B",N)) D SR Q
..I N]"",T(4),$D(^ATXAX(T(4),21,"B",N)) D SR Q
..S C=$P(^PSDRUG(Y,0),U,2)
..I C,T(6),$D(^ATXAX(T(6),21,"B",C)) D SR Q
.Q
Q
SR ;
S BHSREL(D,M)="",BHSREL=BHSREL+1
Q
;
LAST1YRC ;EP
NEW T,E,D,Y,M,G,C,N
S BHSCONT=0
S T(1)=$O(^ATXAX("B","BAT ASTHMA CONTROLLER MEDS",0))
S T(2)=$O(^ATXAX("B","BAT ASTHMA CONTROLLER NDC",0))
S T(3)=$O(^ATXAX("B","BAT ASTHMA INHALED STEROIDS",0))
S T(4)=$O(^ATXAX("B","BAT ASTHMA INHLD STEROIDS NDC",0))
S T(5)=$O(^ATXAX("B","BAT ASTHMA LEUKOTRIENE MEDS",0))
S T(6)=$O(^ATXAX("B","BAT ASTHMA LEUKOTRIENE NDC",0))
S E=9999999-$$FMADD^XLFDT(DT,-183)
S D=0 F S D=$O(^AUPNVMED("AA",DFN,D)) Q:D'=+D!(D>E) D
.S M=0 F S M=$O(^AUPNVMED("AA",DFN,D,M)) Q:M'=+M D
..Q:'$D(^AUPNVMED(M,0))
..S Y=$P(^AUPNVMED(M,0),U)
..Q:'Y
..;is it active?
..I $P(^AUPNVMED(M,0),U,8)]"",$P(^AUPNVMED(M,0),U,8)'>DT Q
..S BHSRXN=$O(^PSRX("APCC",M,0))
..S G=1 I BHSRXN D
...S BHSSTAT=$P($G(^PSRX(BHSRXN,"STA")),U,1)
...I BHSSTAT'=0 S G=0
..I 'G Q
..I T(1),$D(^ATXAX(T(1),21,"B",Y)) D SC Q
..I T(3),$D(^ATXAX(T(3),21,"B",Y)) D SC Q
..I T(5),$D(^ATXAX(T(5),21,"B",Y)) D SC Q
..S N=$P($G(^PSDRUG(Y,2)),U,4)
..Q:N=""
..I T(2),$D(^ATXAX(T(2),21,"B",N)) D SC Q
..I T(4),$D(^ATXAX(T(4),21,"B",N)) D SC Q
..I T(6),$D(^ATXAX(T(6),21,"B",N)) D SC Q
.Q
Q
SC ;
S BHSCONT(D,M)="",BHSCONT=BHSCONT+1
Q
;
BHSAAP2 ;IHS/MSC/MGH - Health summmary for asthma action plan;06-May-2010 10:55;MGH
+1 ;;1.0;HEALTH SUMMARY COMONENTS;**4**;March 17, 2006;Build 13
+2 ;===============================================================
+3 ;copy of APCHAAP2 to print an asthma action plan
+4 ; IHS/CMI/LAB - 2.0;IHS PCC SUITE;**2**;MAY 14, 2009
+5 ;
PRINT ;EP
+1 NEW BHSB,BHSC,BHSCRN,BHSD,BHSDC,BHSDTM,BHSDYS,BHSEXP,BHSF,BHSG,BHSRXN,BHSSIG,BHSSP,BHSSSGY,BHSQ,BHSREF
+2 SET BHSQ=0
+3 DO CKP^GMTSUP
IF $DATA(GMTSQIT)
QUIT
+4 WRITE !,$PIECE(^DIC(4,DUZ(2),0),U),?53,"Today's Date: ",$$FMTE^XLFDT(DT),!
+5 WRITE "Patient Name: ",$PIECE(^DPT(DFN,0),U)
+6 WRITE ?45,"Birth Date: ",$$DOB^AUPNPAT(DFN,"E")
+7 WRITE ?71,"Age: ",$$AGE^AUPNPAT(DFN),!
+8 WRITE $$REPEAT^XLFSTR("_",79),!
+9 WRITE "My Doctor: "
SET X=$$DPCP^APCHPWH1(DFN)
IF X
WRITE $PIECE(^VA(200,X,0),U)
WRITE " Phone number: ",$$VAL^XBDIQ1(9999999.06,DUZ(2),.13),!
+10 WRITE " Address: ",$$VAL^XBDIQ1(9999999.06,DUZ(2),.14)_" "_$$VAL^XBDIQ1(9999999.06,DUZ(2),.15)_$SELECT($$VAL^XBDIQ1(9999999.06,DUZ(2),.15)]"":", ",1:" ")
+11 IF $PIECE(^AUTTLOC(DUZ(2),0),U,14)
WRITE $PIECE(^DIC(5,$$VALI^XBDIQ1(9999999.06,DUZ(2),.16),0),U,2)
WRITE " "_$$VAL^XBDIQ1(9999999.06,DUZ(2),.17),!
+12 WRITE "My Pharmacy: ",$$PHARM(DUZ(2),"N")," Phone number: ",$$PHARM(DUZ(2),"P"),!
+13 WRITE "My Contact person: ",$$EC(DFN,"N")," Phone number: ",$$EC(DFN,"P"),!
+14 WRITE $$REPEAT^XLFSTR("_",79),!!
+15 WRITE "Asthma Triggers",!
+16 SET BHSG=0
KILL APCHSX
+17 SET BHSC=$ORDER(^AUTTHF("B","ASTHMA TRIGGERS",0))
+18 IF 'BHSC
GOTO AAP
+19 SET BHSF=0
FOR
SET BHSF=$ORDER(^AUTTHF("AC",BHSC,BHSF))
IF BHSF'=+BHSF
QUIT
Begin DoDot:1
+20 IF '$DATA(^AUPNVHF("AA",DFN,BHSF))
QUIT
+21 SET D=$ORDER(^AUPNVHF("AA",DFN,BHSF,""))
+22 SET X=" "_$PIECE(^AUTTHF(BHSF,0),U)
SET $EXTRACT(X,40)="Documented on "_$$FMTE^XLFDT((9999999-D))
WRITE ?5,X,!
SET BHSG=1
End DoDot:1
+23 IF 'BHSG
WRITE "No Triggers identified.",!
AAP ;
+1 ;I $Y>(IOSL-5) D HEAD Q:APCHQ
+2 DO CKP^GMTSUP
IF $DATA(GMTSQIT)
QUIT
+3 WRITE !,"ASTHMA ACTION PLAN",!!
+4 SET BHSB=$$PBPF^APCHSAST(DFN,"B")
+5 IF $PIECE(BHSB,U,2)]""
Begin DoDot:1
+6 WRITE "Do your peak flow today. What is your number? What Zone are you in?",!
+7 ;I $Y>(IOSL-3) D HEAD Q:APCHQ
+8 DO CKP^GMTSUP
IF $DATA(GMTSQIT)
QUIT
+9 NEW R,Y,G
+10 SET R=$$REDH($PIECE(BHSB,U,2))
IF R]""
SET R="0-"_R
+11 WRITE ?2,$$STRIP^XLFSTR(R," "),?11,"RED ZONE [0-49% of Best Peak Flow]",!
+12 SET Y=$$YELLOW($PIECE(BHSB,U,2),2)
+13 WRITE ?2,$$STRIP^XLFSTR(Y," "),?11,"YELLOW ZONE [50-79% of Best Peak Flow]",!
+14 ;I $Y>(IOSL-3) D HEAD Q:APCHQ
+15 DO CKP^GMTSUP
IF $DATA(GMTSQIT)
QUIT
+16 SET G=$$GREEN($PIECE(BHSB,U,2),2)
+17 WRITE ?2,$$STRIP^XLFSTR(G," "),?11,"GREEN ZONE [80-100% of Best Peak Flow]",!!
End DoDot:1
+18 ;I $Y>(IOSL-3) D HEAD Q:APCHQ
+19 DO CKP^GMTSUP
IF $DATA(GMTSQIT)
QUIT
+20 IF $PIECE(BHSB,U)=""
WRITE ?3,"Your Personal Best Peak Flow: None documented; please discuss with your",!,"provider at your next clinic visit.",!
+21 IF $PIECE(BHSB,U)]""
WRITE ?3,"Your Personal Best Peak Flow: ",$PIECE(BHSB,U,2)," liters/minute on ",$$FMTE^XLFDT($PIECE(BHSB,U,1)),!
+22 ;I $Y>(IOSL-4) D HEAD Q:APCHQ
+23 DO CKP^GMTSUP
IF $DATA(GMTSQIT)
QUIT
+24 WRITE !,"Follow these steps to control your asthma.",!
+25 WRITE $$REPEAT^XLFSTR("*",79),!
+26 WRITE !,"RED ZONE "_$SELECT($PIECE(BHSB,U)]"":"[49-0%]",1:"")_" - Need Medical Help!! ",!
+27 ;I $Y>(IOSL-4) D HEAD Q:APCHQ
+28 DO CKP^GMTSUP
IF $DATA(GMTSQIT)
QUIT
+29 IF $PIECE(BHSB,U)]""
WRITE "Peak Flow less than ",$$RED($PIECE(BHSB,U,2),.50,2)," liters/minute",!," OR",!
+30 WRITE "You are coughing, short of breath, and wheezing.",!
+31 WRITE "You have trouble walking or talking.",!
+32 ;I $Y>(IOSL-3) D HEAD Q:APCHQ
+33 DO CKP^GMTSUP
IF $DATA(GMTSQIT)
QUIT
+34 WRITE "Your rescue medicine doesn't work.",!
+35 IF BHSRELM=""
WRITE !,"________________________________________________________________",!
+36 IF BHSRELM]""
Begin DoDot:1
+37 ;attempt to wrap directions 70 characters
+38 KILL ^UTILITY($JOB,"W")
SET X=BHSRELM
SET DIWL=0
SET DIWR=70
DO ^DIWP
+39 ;S X=$S($L($G(^UTILITY($J,"W",0,1,0)))>1:$G(^UTILITY($J,"W",0,1,0)),$L($G(^UTILITY($J,"W",0,1,0)))=1:"No directions on file",1:" ") D S^APCHPWH1(X)
+40 FOR F=1:1:$GET(^UTILITY($JOB,"W",0))
SET X=$GET(^UTILITY($JOB,"W",0,F,0))
IF $DATA(GMTSQIT)
QUIT
Begin DoDot:2
+41 ;I $Y>(IOSL-3) D HEAD Q:APCHQ
+42 DO CKP^GMTSUP
IF $DATA(GMTSQIT)
QUIT
+43 WRITE !,X
End DoDot:2
+44 KILL ^UTILITY($JOB,"W")
+45 WRITE !
End DoDot:1
IF $DATA(GMTSQIT)
QUIT
+46 ;I $Y>(IOSL-3) D HEAD Q:APCHQ
+47 DO CKP^GMTSUP
IF $DATA(GMTSQIT)
QUIT
+48 WRITE !,"Ask someone to bring you to the Emergency Room, call 911, or call your doctor.",!
+49 WRITE $$REPEAT^XLFSTR("*",79),!
+50 ;I $Y>(IOSL-4) D HEAD Q:APCHQ
+51 DO CKP^GMTSUP
IF $DATA(GMTSQIT)
QUIT
+52 WRITE "YELLOW ZONE "_$SELECT($PIECE(BHSB,U)]"":"[50-79%]",1:""),"- Asthma is Getting Worse ",!
+53 IF $PIECE(BHSB,U)]""
WRITE "Peak Flow is ",$$YELLOW^APCHSAST($PIECE(BHSB,U,2))," liters/minute",!," OR",!
+54 WRITE "You are coughing or wheezing.",!
+55 ;I $Y>(IOSL-3) D HEAD Q:APCHQ
+56 DO CKP^GMTSUP
IF $DATA(GMTSQIT)
QUIT
+57 WRITE "You are waking at night from your asthma.",!
+58 WRITE "You have some trouble doing usual activities.",!
+59 ;I $Y>(IOSL-3) D HEAD Q:APCHQ
+60 DO CKP^GMTSUP
IF $DATA(GMTSQIT)
QUIT
+61 IF BHSRESM=""
WRITE !,"________________________________________________________________",!
IF 1
+62 IF BHSRESM]""
Begin DoDot:1
+63 ;attempt to wrap directions 70 characters
+64 KILL ^UTILITY($JOB,"W")
SET X=BHSRESM
SET DIWL=0
SET DIWR=70
DO ^DIWP
+65 ;S X=$S($L($G(^UTILITY($J,"W",0,1,0)))>1:$G(^UTILITY($J,"W",0,1,0)),$L($G(^UTILITY($J,"W",0,1,0)))=1:"No directions on file",1:" ") D S^APCHPWH1(X)
+66 FOR F=1:1:$GET(^UTILITY($JOB,"W",0))
SET X=$GET(^UTILITY($JOB,"W",0,F,0))
IF $DATA(GMTSQIT)
QUIT
Begin DoDot:2
+67 ;I $Y>(IOSL-3) D HEAD Q:APCHQ
+68 DO CKP^GMTSUP
IF $DATA(GMTSQIT)
QUIT
+69 WRITE !,X
End DoDot:2
+70 KILL ^UTILITY($JOB,"W")
+71 WRITE !
End DoDot:1
IF $DATA(GMTSQIT)
QUIT
+72 WRITE !,"Keep taking your green zone medications. Check your peak flow readings ",!,"every few hours.",!
+73 ;I $Y>(IOSL-3) D HEAD Q:APCHQ
+74 DO CKP^GMTSUP
IF $DATA(GMTSQIT)
QUIT
+75 WRITE !,"CALL YOUR DOCTOR or care provider IF:",!
+76 WRITE "1. You are in your yellow zone for more than 24-48 hours.",!
+77 ;I $Y>(IOSL-3) D HEAD Q:APCHQ
+78 DO CKP^GMTSUP
IF $DATA(GMTSQIT)
QUIT
+79 WRITE "2. OR You need to use your reliever medication more than every 4 hours.",!
+80 WRITE "3. OR Your symptoms are getting worse.",!
+81 WRITE $$REPEAT^XLFSTR("*",79),!
+82 ;I $Y>(IOSL-3) D HEAD Q:APCHQ
+83 DO CKP^GMTSUP
IF $DATA(GMTSQIT)
QUIT
+84 WRITE !,"GREEN ZONE "_$SELECT($PIECE(BHSB,U)]"":"[100-80%]",1:"")_" - You Are Doing Well ",!
+85 IF $PIECE(BHSB,U)]""
WRITE "Peak Flow is ",$$GREEN^APCHSAST($PIECE(BHSB,U,2)),!," OR",!
+86 ;I $Y>(IOSL-3) D HEAD Q:APCHQ
+87 DO CKP^GMTSUP
IF $DATA(GMTSQIT)
QUIT
+88 WRITE "You have no coughing, wheezing, or chest tightness during the day or night.",!
+89 WRITE "You sleep through the night without coughing, wheezing, or chest tightness.",!
+90 ;I $Y>(IOSL-3) D HEAD Q:APCHQ
+91 DO CKP^GMTSUP
IF $DATA(GMTSQIT)
QUIT
+92 WRITE "You can do usual activities.",!
+93 WRITE !,"Take your long-term control medication every day.",!
MEDS ;
RELMEDS ;
+1 KILL BHSL,BHSREL,BHSCONT
+2 DO LAST1YRR
+3 DO LAST1YRC
+4 ;
CONTMEDS ;
+1 WRITE !!,"Active Controller Medications",!
+2 KILL BHSL
+3 MERGE BHSL=BHSCONT
+4 DO DISPMEDS
+5 WRITE !,"Active Reliever Medications",!
+6 KILL BHSL
+7 MERGE BHSL=BHSREL
+8 DO DISPMEDS
+9 QUIT
HEAD ;
+1 ;I $E(IOST)="C",IO=IO(0) W ! S DIR(0)="EO" D ^DIR K DIR I Y=0!(Y="^")!($D(DTOUT)) S APCHQ=1 Q
HEAD1 ;
+1 IF $DATA(IOF)
WRITE @IOF
+2 WRITE !,$PIECE(^DIC(4,DUZ(2),0),U),?53,"Today's Date: ",$$FMTE^XLFDT(DT),!
+3 WRITE "Patient Name: ",$PIECE(^DPT(DFN,0),U)
+4 WRITE ?45,"Birth Date: ",$$DOB^AUPNPAT(DFN,"E")
+5 WRITE ?71,"Age: ",$$AGE^AUPNPAT(DFN),!
+6 WRITE $$REPEAT^XLFSTR("_",79),!!
+7 QUIT
CTR(X,Y) ;EP - Center X in a field Y wide.
+1 QUIT $JUSTIFY("",$SELECT($DATA(Y):Y,1:IOM)-$LENGTH(X)\2)_X
+2 ;----------
EXIT ;
+1 ;D EN^XBVK("APCH")
+2 ;D ^XBFMK
+3 QUIT
PHARM(L,I) ;
+1 NEW %
+2 SET %=$ORDER(^PS(59,"C",L,0))
+3 IF '%
IF I="N"
QUIT $PIECE(^DIC(4,L,0),U)
+4 IF '%
IF I="P"
QUIT $$VAL^XBDIQ1(9999999.06,L,.13)
+5 IF I="N"
QUIT $PIECE(^PS(59,%,0),U)
+6 IF I="P"
QUIT $PIECE(^PS(59,%,0),U,4)
+7 QUIT ""
+8 ;
EC(L,I) ;
+1 NEW %
+2 SET F=$SELECT(I="N":.331,1:.3319)
+3 SET %=$$VAL^XBDIQ1(2,L,F)
+4 IF %]""
QUIT %
+5 SET F=$SELECT(I="N":.211,1:.219)
+6 QUIT $$VAL^XBDIQ1(2,L,F)
+7 ;
GREEN(V,F) ;
+1 NEW P,P1
+2 IF $GET(V)=""
QUIT ""
+3 SET P=(V*.80)
SET P=$JUSTIFY(P,3,0)
SET P1=V
+4 IF F=1
QUIT P_"-"_V_" liters/minute"
+5 QUIT P_"-"_V
YELLOW(V,F) ;
+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 IF F=1
QUIT P_"-"_P1_" liters/minute"
+7 IF F=2
QUIT P_"-"_P1
RED(V,D,F) ;
+1 NEW P,P1
+2 IF $GET(V)=""
QUIT ""
+3 IF $GET(D)=""
SET D=.50
+4 SET P=(V*D)
+5 SET P=P+.5
SET P=$JUSTIFY(P,3,0)
+6 IF F=1
QUIT "<"_P_" liters/minute"
+7 QUIT $TRANSLATE(P," ")
+8 ;
REDH(V) ;
+1 NEW P
+2 SET P=((.50*V)-1)
+3 QUIT $TRANSLATE($JUSTIFY(P,3,0)," ")
+4 ;
+5 QUIT
+6 ;
DISPMEDS ;EP
+1 NEW D,E,N,BHSMED,BHSMFX,BHSDC,BHSDYS,BHSCRN,BHSQTY,BHSSIG,BHSDTM,BHSEX,X
+2 NEW BHSORTS,BHSRX,BHSRFL,BHSSTAT
+3 IF '$ORDER(BHSL(0))
WRITE !,"None documented; please discuss with your provider at your next",!,"clinic visit.",!
QUIT
+4 SET D=0
FOR
SET D=$ORDER(BHSL(D))
IF D'=+D
QUIT
Begin DoDot:1
+5 SET E=0
FOR
SET E=$ORDER(BHSL(D,E))
IF E'=+E
QUIT
SET N=^AUPNVMED(E,0)
Begin DoDot:2
+6 SET BHSD=$$FMTE^XLFDT($PIECE(^AUPNVSIT($PIECE(N,U,3),0),U),"5D")
+7 SET BHSDC=$PIECE(N,U,8)
SET BHSDYS=$PIECE(N,U,7)
SET BHSMFX=$SELECT($PIECE(N,U,4)="":+N,1:$PIECE(N,U,4))
IF BHSDYS=""
SET BHSDYS=30
SET BHSRX=$SELECT($DATA(^PSRX("APCC",E)):$ORDER(^(E,0)),1:0)
+8 SET BHSCRN=$SELECT(+BHSRX:$DATA(^PS(55,DFN,"P","CP",BHSRX)),1:0)
+9 SET BHSQTY=$PIECE(N,U,6)
SET BHSSIG=$PIECE(N,U,5)
+10 SET BHSDTM=$PIECE($PIECE(^AUPNVSIT($PIECE(N,U,3),0),U),".")
SET BHSEXP=""
+11 SET X=$$FMDIFF^XLFDT(DT,BHSDTM)
+12 IF X>BHSDYS
SET Y=$$FMADD^XLFDT(BHSDTM,BHSDYS)
SET BHSEXP="-- Ran out "_$$FMTE^XLFDT(Y,"2D")
+13 SET BHSMED=$SELECT($PIECE(N,U,4)="":$PIECE(^PSDRUG(BHSMFX,0),U),1:$PIECE(N,U,4))
+14 IF BHSDC
SET Y=$$FMTE^XLFDT(BHSDC)
SET BHSEXP="-- D/C "_Y
+15 SET BHSORTS=$GET(^AUPNVMED(E,11))
+16 IF BHSORTS["RETURNED TO STOCK"
IF BHSDC
SET BHSEXP="--RTS "_Y
+17 DO SIG
SET BHSSIG=BHSSSGY
+18 DO REF
IF BHSREF
SET BHSSIG=BHSSIG_" "_BHSREF_$SELECT(BHSREF=1:" refill",1:" refills")_" left."
+19 ;I $Y>(IOSL-4) D HEAD Q:APCHQ
+20 DO CKP^GMTSUP
IF $DATA(GMTSQIT)
QUIT
+21 SET X=BHSD
SET $EXTRACT(X,13)=BHSMED_" #"_BHSQTY_" ("_BHSDYS_" days) "_BHSEXP
WRITE ?1,X,!
+22 SET X=""
SET $EXTRACT(X,14)=$EXTRACT(BHSSIG,1,65)
WRITE X,!
+23 IF $LENGTH(BHSSIG)>65
SET X=""
SET $EXTRACT(X,14)=$EXTRACT(BHSSIG,66,999)
WRITE X,!
+24 QUIT
End DoDot:2
+25 QUIT
End DoDot:1
+26 QUIT
+27 ;
SIG ;CONSTRUCT THE FULL TEXT FROM THE ENCODED SIG
+1 SET BHSSSGY=""
FOR BHSSP=1:1:$LENGTH(BHSSIG," ")
SET X=$PIECE(BHSSIG," ",BHSSP)
IF X]""
Begin DoDot:1
+2 SET Y=$ORDER(^PS(51,"B",X,0))
IF Y>0
SET X=$PIECE(^PS(51,Y,0),"^",2)
IF $DATA(^(9))
SET Y=$PIECE(BHSSIG," ",BHSSP-1)
SET Y=$EXTRACT(Y,$LENGTH(Y))
IF Y>1
SET X=$PIECE(^(9),"^",1)
+3 SET BHSSSGY=BHSSSGY_X_" "
End DoDot:1
+4 QUIT
+5 ;
REF ;DETERMINE THE NUMBER OF REFILLS REMAINING
+1 IF 'BHSRX
SET BHSREF=0
QUIT
+2 SET BHSRFL=$PIECE(^PSRX(BHSRX,0),U,9)
SET BHSREF=0
FOR
SET BHSREF=$ORDER(^PSRX(BHSRX,1,BHSREF))
IF 'BHSREF
QUIT
SET BHSRFL=BHSRFL-1
+3 SET BHSREF=BHSRFL
+4 QUIT
+5 ;
LAST1YRR ;EP
+1 NEW T,E,D,Y,M,G,C,N
+2 SET BHSREL=0
+3 SET T(1)=$ORDER(^ATXAX("B","BAT ASTHMA SHRT ACT RELV MEDS",0))
+4 SET T(2)=$ORDER(^ATXAX("B","BAT ASTHMA SHRT ACT RELV NDC",0))
+5 SET T(3)=$ORDER(^ATXAX("B","BAT ASTHMA SHRT ACT INHLR MEDS",0))
+6 SET T(4)=$ORDER(^ATXAX("B","BAT ASTHMA SHRT ACT INHLR NDC",0))
+7 SET T(5)=$ORDER(^ATXAX("B","BGP RA GLUCOCORTIOCOIDS MEDS",0))
+8 SET T(6)=$ORDER(^ATXAX("B","BGP RA GLUCOCORTIOCOIDS CLASS",0))
+9 SET E=9999999-$$FMADD^XLFDT(DT,-183)
+10 SET D=0
FOR
SET D=$ORDER(^AUPNVMED("AA",DFN,D))
IF D'=+D!(D>E)
QUIT
Begin DoDot:1
+11 SET M=0
FOR
SET M=$ORDER(^AUPNVMED("AA",DFN,D,M))
IF M'=+M
QUIT
Begin DoDot:2
+12 IF '$DATA(^AUPNVMED(M,0))
QUIT
+13 SET Y=$PIECE(^AUPNVMED(M,0),U)
+14 IF 'Y
QUIT
+15 ;is it active?
+16 IF $PIECE(^AUPNVMED(M,0),U,8)]""
IF $PIECE(^AUPNVMED(M,0),U,8)'>DT
QUIT
+17 SET BHSRXN=$ORDER(^PSRX("APCC",M,0))
+18 SET G=1
IF BHSRXN
Begin DoDot:3
+19 SET BHSSTAT=$PIECE($GET(^PSRX(BHSRXN,"STA")),U,1)
+20 IF BHSSTAT'=0
SET G=0
End DoDot:3
+21 IF 'G
QUIT
+22 IF T(1)
IF $DATA(^ATXAX(T(1),21,"B",Y))
DO SR
QUIT
+23 IF T(3)
IF $DATA(^ATXAX(T(3),21,"B",Y))
DO SR
QUIT
+24 IF T(5)
IF $DATA(^ATXAX(T(5),21,"B",Y))
DO SR
QUIT
+25 SET N=$PIECE($GET(^PSDRUG(Y,2)),U,4)
+26 IF N=""
QUIT
+27 IF N]""
IF T(2)
IF $DATA(^ATXAX(T(2),21,"B",N))
DO SR
QUIT
+28 IF N]""
IF T(4)
IF $DATA(^ATXAX(T(4),21,"B",N))
DO SR
QUIT
+29 SET C=$PIECE(^PSDRUG(Y,0),U,2)
+30 IF C
IF T(6)
IF $DATA(^ATXAX(T(6),21,"B",C))
DO SR
QUIT
End DoDot:2
+31 QUIT
End DoDot:1
+32 QUIT
SR ;
+1 SET BHSREL(D,M)=""
SET BHSREL=BHSREL+1
+2 QUIT
+3 ;
LAST1YRC ;EP
+1 NEW T,E,D,Y,M,G,C,N
+2 SET BHSCONT=0
+3 SET T(1)=$ORDER(^ATXAX("B","BAT ASTHMA CONTROLLER MEDS",0))
+4 SET T(2)=$ORDER(^ATXAX("B","BAT ASTHMA CONTROLLER NDC",0))
+5 SET T(3)=$ORDER(^ATXAX("B","BAT ASTHMA INHALED STEROIDS",0))
+6 SET T(4)=$ORDER(^ATXAX("B","BAT ASTHMA INHLD STEROIDS NDC",0))
+7 SET T(5)=$ORDER(^ATXAX("B","BAT ASTHMA LEUKOTRIENE MEDS",0))
+8 SET T(6)=$ORDER(^ATXAX("B","BAT ASTHMA LEUKOTRIENE NDC",0))
+9 SET E=9999999-$$FMADD^XLFDT(DT,-183)
+10 SET D=0
FOR
SET D=$ORDER(^AUPNVMED("AA",DFN,D))
IF D'=+D!(D>E)
QUIT
Begin DoDot:1
+11 SET M=0
FOR
SET M=$ORDER(^AUPNVMED("AA",DFN,D,M))
IF M'=+M
QUIT
Begin DoDot:2
+12 IF '$DATA(^AUPNVMED(M,0))
QUIT
+13 SET Y=$PIECE(^AUPNVMED(M,0),U)
+14 IF 'Y
QUIT
+15 ;is it active?
+16 IF $PIECE(^AUPNVMED(M,0),U,8)]""
IF $PIECE(^AUPNVMED(M,0),U,8)'>DT
QUIT
+17 SET BHSRXN=$ORDER(^PSRX("APCC",M,0))
+18 SET G=1
IF BHSRXN
Begin DoDot:3
+19 SET BHSSTAT=$PIECE($GET(^PSRX(BHSRXN,"STA")),U,1)
+20 IF BHSSTAT'=0
SET G=0
End DoDot:3
+21 IF 'G
QUIT
+22 IF T(1)
IF $DATA(^ATXAX(T(1),21,"B",Y))
DO SC
QUIT
+23 IF T(3)
IF $DATA(^ATXAX(T(3),21,"B",Y))
DO SC
QUIT
+24 IF T(5)
IF $DATA(^ATXAX(T(5),21,"B",Y))
DO SC
QUIT
+25 SET N=$PIECE($GET(^PSDRUG(Y,2)),U,4)
+26 IF N=""
QUIT
+27 IF T(2)
IF $DATA(^ATXAX(T(2),21,"B",N))
DO SC
QUIT
+28 IF T(4)
IF $DATA(^ATXAX(T(4),21,"B",N))
DO SC
QUIT
+29 IF T(6)
IF $DATA(^ATXAX(T(6),21,"B",N))
DO SC
QUIT
End DoDot:2
+30 QUIT
End DoDot:1
+31 QUIT
SC ;
+1 SET BHSCONT(D,M)=""
SET BHSCONT=BHSCONT+1
+2 QUIT
+3 ;
