Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: BHSAAP2

BHSAAP2.m

Go to the documentation of this file. 
  1. 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
  1.  ;===============================================================
  1.  ;copy of APCHAAP2 to print an asthma action plan
  1.  ; IHS/CMI/LAB - 2.0;IHS PCC SUITE;**2**;MAY 14, 2009
  1.  ;
  1. PRINT ;EP
  1.  N BHSB,BHSC,BHSCRN,BHSD,BHSDC,BHSDTM,BHSDYS,BHSEXP,BHSF,BHSG,BHSRXN,BHSSIG,BHSSP,BHSSSGY,BHSQ,BHSREF
  1.  S BHSQ=0
  1.  D CKP^GMTSUP Q:$D(GMTSQIT)
  1.  W !,$P(^DIC(4,DUZ(2),0),U),?53,"Today's Date: ",$$FMTE^XLFDT(DT),!
  1.  W "Patient Name: ",$P(^DPT(DFN,0),U)
  1.  W ?45,"Birth Date: ",$$DOB^AUPNPAT(DFN,"E")
  1.  W ?71,"Age: ",$$AGE^AUPNPAT(DFN),!
  1.  W $$REPEAT^XLFSTR("_",79),!
  1.  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),!
  1.  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:" ")
  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),!
  1.  W "My Pharmacy: ",$$PHARM(DUZ(2),"N"),"     Phone number: ",$$PHARM(DUZ(2),"P"),!
  1.  W "My Contact person: ",$$EC(DFN,"N"),"     Phone number: ",$$EC(DFN,"P"),!
  1.  W $$REPEAT^XLFSTR("_",79),!!
  1.  W "Asthma Triggers",!
  1.  S BHSG=0 K APCHSX
  1.  S BHSC=$O(^AUTTHF("B","ASTHMA TRIGGERS",0))
  1.  G:'BHSC AAP
  1.  S BHSF=0 F  S BHSF=$O(^AUTTHF("AC",BHSC,BHSF)) Q:BHSF'=+BHSF  D
  1.  .Q:'$D(^AUPNVHF("AA",DFN,BHSF))
  1.  .S D=$O(^AUPNVHF("AA",DFN,BHSF,""))
  1.  .S X="  "_$P(^AUTTHF(BHSF,0),U),$E(X,40)="Documented on "_$$FMTE^XLFDT((9999999-D)) W ?5,X,! S BHSG=1
  1.  I 'BHSG W "No Triggers identified.",!
  1. AAP ;
  1.  ;I $Y>(IOSL-5) D HEAD Q:APCHQ
  1.  D CKP^GMTSUP Q:$D(GMTSQIT)
  1.  W !,"ASTHMA ACTION PLAN",!!
  1.  S BHSB=$$PBPF^APCHSAST(DFN,"B")
  1.  I $P(BHSB,U,2)]"" D
  1.  .W "Do your peak flow today.  What is your number?  What Zone are you in?",!
  1.  .;I $Y>(IOSL-3) D HEAD Q:APCHQ
  1.  .D CKP^GMTSUP Q:$D(GMTSQIT)
  1.  .NEW R,Y,G
  1.  .S R=$$REDH($P(BHSB,U,2)) I R]"" S R="0-"_R
  1.  .W ?2,$$STRIP^XLFSTR(R," "),?11,"RED ZONE [0-49% of Best Peak Flow]",!
  1.  .S Y=$$YELLOW($P(BHSB,U,2),2)
  1.  .W ?2,$$STRIP^XLFSTR(Y," "),?11,"YELLOW ZONE [50-79% of Best Peak Flow]",!
  1.  .;I $Y>(IOSL-3) D HEAD Q:APCHQ
  1.  .D CKP^GMTSUP Q:$D(GMTSQIT)
  1.  .S G=$$GREEN($P(BHSB,U,2),2)
  1.  .W ?2,$$STRIP^XLFSTR(G," "),?11,"GREEN ZONE [80-100% of Best Peak Flow]",!!
  1.  ;I $Y>(IOSL-3) D HEAD Q:APCHQ
  1.  D CKP^GMTSUP Q:$D(GMTSQIT)
  1.  I $P(BHSB,U)="" W ?3,"Your Personal Best Peak Flow:  None documented; please discuss with your",!,"provider at your next clinic visit.",!
  1.  I $P(BHSB,U)]"" W ?3,"Your Personal Best Peak Flow: ",$P(BHSB,U,2)," liters/minute on ",$$FMTE^XLFDT($P(BHSB,U,1)),!
  1.  ;I $Y>(IOSL-4) D HEAD Q:APCHQ
  1.  D CKP^GMTSUP Q:$D(GMTSQIT)
  1.  W !,"Follow these steps to control your asthma.",!
  1.  W $$REPEAT^XLFSTR("*",79),!
  1.  W !,"RED ZONE "_$S($P(BHSB,U)]"":"[49-0%]",1:"")_" - Need Medical Help!!   ",!
  1.  ;I $Y>(IOSL-4) D HEAD Q:APCHQ
  1.  D CKP^GMTSUP Q:$D(GMTSQIT)
  1.  I $P(BHSB,U)]"" W "Peak Flow less than ",$$RED($P(BHSB,U,2),.50,2)," liters/minute",!,"  OR",!
  1.  W "You are coughing, short of breath, and wheezing.",!
  1.  W "You have trouble walking or talking.",!
  1.  ;I $Y>(IOSL-3) D HEAD Q:APCHQ
  1.  D CKP^GMTSUP Q:$D(GMTSQIT)
  1.  W "Your rescue medicine doesn't work.",!
  1.  I BHSRELM="" W !,"________________________________________________________________",!
  1.  I BHSRELM]"" D  Q:$D(GMTSQIT)
  1.  .;attempt to wrap directions 70 characters
  1.  .K ^UTILITY($J,"W") S X=BHSRELM,DIWL=0,DIWR=70 D ^DIWP
  1.  .;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)
  1.  .F F=1:1:$G(^UTILITY($J,"W",0)) S X=$G(^UTILITY($J,"W",0,F,0)) Q:$D(GMTSQIT)  D
  1.  ..;I $Y>(IOSL-3) D HEAD Q:APCHQ
  1.  ..D CKP^GMTSUP Q:$D(GMTSQIT)
  1.  ..W !,X
  1.  .K ^UTILITY($J,"W")
  1.  .W !
  1.  ;I $Y>(IOSL-3) D HEAD Q:APCHQ
  1.  D CKP^GMTSUP Q:$D(GMTSQIT)
  1.  W !,"Ask someone to bring you to the Emergency Room, call 911, or call your doctor.",!
  1.  W $$REPEAT^XLFSTR("*",79),!
  1.  ;I $Y>(IOSL-4) D HEAD Q:APCHQ
  1.  D CKP^GMTSUP Q:$D(GMTSQIT)
  1.  W "YELLOW ZONE "_$S($P(BHSB,U)]"":"[50-79%]",1:""),"- Asthma is Getting Worse   ",!
  1.  I $P(BHSB,U)]"" W "Peak Flow is ",$$YELLOW^APCHSAST($P(BHSB,U,2))," liters/minute",!,"  OR",!
  1.  W "You are coughing or wheezing.",!
  1.  ;I $Y>(IOSL-3) D HEAD Q:APCHQ
  1.  D CKP^GMTSUP Q:$D(GMTSQIT)
  1.  W "You are waking at night from your asthma.",!
  1.  W "You have some trouble doing usual activities.",!
  1.  ;I $Y>(IOSL-3) D HEAD Q:APCHQ
  1.  D CKP^GMTSUP Q:$D(GMTSQIT)
  1.  I BHSRESM="" W !,"________________________________________________________________",! I 1
  1.  I BHSRESM]"" D  Q:$D(GMTSQIT)
  1.  .;attempt to wrap directions 70 characters
  1.  .K ^UTILITY($J,"W") S X=BHSRESM,DIWL=0,DIWR=70 D ^DIWP
  1.  .;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)
  1.  .F F=1:1:$G(^UTILITY($J,"W",0)) S X=$G(^UTILITY($J,"W",0,F,0)) Q:$D(GMTSQIT)  D
  1.  ..;I $Y>(IOSL-3) D HEAD Q:APCHQ
  1.  ..D CKP^GMTSUP Q:$D(GMTSQIT)
  1.  ..W !,X
  1.  .K ^UTILITY($J,"W")
  1.  .W !
  1.  W !,"Keep taking your green zone medications.  Check your peak flow readings ",!,"every few hours.",!
  1.  ;I $Y>(IOSL-3) D HEAD Q:APCHQ
  1.  D CKP^GMTSUP Q:$D(GMTSQIT)
  1.  W !,"CALL YOUR DOCTOR or care provider IF:",!
  1.  W "1. You are in your yellow zone for more than 24-48 hours.",!
  1.  ;I $Y>(IOSL-3) D HEAD Q:APCHQ
  1.  D CKP^GMTSUP Q:$D(GMTSQIT)
  1.  W "2. OR You need to use your reliever medication more than every 4 hours.",!
  1.  W "3. OR Your symptoms are getting worse.",!
  1.  W $$REPEAT^XLFSTR("*",79),!
  1.  ;I $Y>(IOSL-3) D HEAD Q:APCHQ
  1.  D CKP^GMTSUP Q:$D(GMTSQIT)
  1.  W !,"GREEN ZONE "_$S($P(BHSB,U)]"":"[100-80%]",1:"")_" - You Are Doing Well   ",!
  1.  I $P(BHSB,U)]"" W "Peak Flow is ",$$GREEN^APCHSAST($P(BHSB,U,2)),!,"  OR",!
  1.  ;I $Y>(IOSL-3) D HEAD Q:APCHQ
  1.  D CKP^GMTSUP Q:$D(GMTSQIT)
  1.  W "You have no coughing, wheezing, or chest tightness during the day or night.",!
  1.  W "You sleep through the night without coughing, wheezing, or chest tightness.",!
  1.  ;I $Y>(IOSL-3) D HEAD Q:APCHQ
  1.  D CKP^GMTSUP Q:$D(GMTSQIT)
  1.  W "You can do usual activities.",!
  1.  W !,"Take your long-term control medication every day.",!
  1. MEDS ;
  1. RELMEDS ;
  1.  K BHSL,BHSREL,BHSCONT
  1.  D LAST1YRR
  1.  D LAST1YRC
  1.  ;
  1. CONTMEDS ;
  1.  W !!,"Active Controller Medications",!
  1.  K BHSL
  1.  M BHSL=BHSCONT
  1.  D DISPMEDS
  1.  W !,"Active Reliever Medications",!
  1.  K BHSL
  1.  M BHSL=BHSREL
  1.  D DISPMEDS
  1.  Q
  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
  1. HEAD1 ;
  1.  W:$D(IOF) @IOF
  1.  W !,$P(^DIC(4,DUZ(2),0),U),?53,"Today's Date: ",$$FMTE^XLFDT(DT),!
  1.  W "Patient Name: ",$P(^DPT(DFN,0),U)
  1.  W ?45,"Birth Date: ",$$DOB^AUPNPAT(DFN,"E")
  1.  W ?71,"Age: ",$$AGE^AUPNPAT(DFN),!
  1.  W $$REPEAT^XLFSTR("_",79),!!
  1.  Q
  1. CTR(X,Y) ;EP - Center X in a field Y wide.
  1.  Q $J("",$S($D(Y):Y,1:IOM)-$L(X)\2)_X
  1.  ;----------
  1. EXIT ;
  1.  ;D EN^XBVK("APCH")
  1.  ;D ^XBFMK
  1.  Q
  1. PHARM(L,I) ;
  1.  NEW %
  1.  S %=$O(^PS(59,"C",L,0))
  1.  I '%,I="N" Q $P(^DIC(4,L,0),U)
  1.  I '%,I="P" Q $$VAL^XBDIQ1(9999999.06,L,.13)
  1.  I I="N" Q $P(^PS(59,%,0),U)
  1.  I I="P" Q $P(^PS(59,%,0),U,4)
  1.  Q ""
  1.  ;
  1. EC(L,I) ;
  1.  NEW %
  1.  S F=$S(I="N":.331,1:.3319)
  1.  S %=$$VAL^XBDIQ1(2,L,F)
  1.  I %]"" Q %
  1.  S F=$S(I="N":.211,1:.219)
  1.  Q $$VAL^XBDIQ1(2,L,F)
  1.  ;
  1. GREEN(V,F) ;
  1.  NEW P,P1
  1.  I $G(V)="" Q ""
  1.  S P=(V*.80),P=$J(P,3,0),P1=V
  1.  I F=1 Q P_"-"_V_" liters/minute"
  1.  Q P_"-"_V
  1. YELLOW(V,F) ;
  1.  NEW P,P1
  1.  I $G(V)="" Q ""
  1.  S P=(V*.50)
  1.  S P=$J(P,3,0)
  1.  S P1=(V*.80),P1=P1-1,P1=$J(P1,3,0)
  1.  I F=1 Q P_"-"_P1_" liters/minute"
  1.  I F=2 Q P_"-"_P1
  1. RED(V,D,F) ;
  1.  NEW P,P1
  1.  I $G(V)="" Q ""
  1.  I $G(D)="" S D=.50
  1.  S P=(V*D)
  1.  S P=P+.5,P=$J(P,3,0)
  1.  I F=1 Q "<"_P_"   liters/minute"
  1.  Q $TR(P," ")
  1.  ;
  1. REDH(V) ;
  1.  NEW P
  1.  S P=((.50*V)-1)
  1.  Q $TR($J(P,3,0)," ")
  1.  ;
  1.  Q
  1.  ;
  1. DISPMEDS ;EP
  1.  N D,E,N,BHSMED,BHSMFX,BHSDC,BHSDYS,BHSCRN,BHSQTY,BHSSIG,BHSDTM,BHSEX,X
  1.  N BHSORTS,BHSRX,BHSRFL,BHSSTAT
  1.  I '$O(BHSL(0)) W !,"None documented; please discuss with your provider at your next",!,"clinic visit.",! Q
  1.  S D=0 F  S D=$O(BHSL(D)) Q:D'=+D  D
  1.  .S E=0 F  S E=$O(BHSL(D,E)) Q:E'=+E  S N=^AUPNVMED(E,0) D
  1.  ..S BHSD=$$FMTE^XLFDT($P(^AUPNVSIT($P(N,U,3),0),U),"5D")
  1.  ..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)
  1.  ..S BHSCRN=$S(+BHSRX:$D(^PS(55,DFN,"P","CP",BHSRX)),1:0)
  1.  ..S BHSQTY=$P(N,U,6),BHSSIG=$P(N,U,5)
  1.  ..S BHSDTM=$P($P(^AUPNVSIT($P(N,U,3),0),U),"."),BHSEXP=""
  1.  ..S X=$$FMDIFF^XLFDT(DT,BHSDTM)
  1.  ..I X>BHSDYS S Y=$$FMADD^XLFDT(BHSDTM,BHSDYS) S BHSEXP="-- Ran out "_$$FMTE^XLFDT(Y,"2D")
  1.  ..S BHSMED=$S($P(N,U,4)="":$P(^PSDRUG(BHSMFX,0),U),1:$P(N,U,4))
  1.  ..I BHSDC S Y=$$FMTE^XLFDT(BHSDC) S BHSEXP="-- D/C "_Y
  1.  ..S BHSORTS=$G(^AUPNVMED(E,11))
  1.  ..I BHSORTS["RETURNED TO STOCK",BHSDC S BHSEXP="--RTS "_Y
  1.  ..D SIG S BHSSIG=BHSSSGY
  1.  ..D REF I BHSREF S BHSSIG=BHSSIG_" "_BHSREF_$S(BHSREF=1:" refill",1:" refills")_" left."
  1.  ..;I $Y>(IOSL-4) D HEAD Q:APCHQ
  1.  ..D CKP^GMTSUP Q:$D(GMTSQIT)
  1.  ..S X=BHSD,$E(X,13)=BHSMED_" #"_BHSQTY_" ("_BHSDYS_" days) "_BHSEXP W ?1,X,!
  1.  ..S X="",$E(X,14)=$E(BHSSIG,1,65) W X,!
  1.  ..I $L(BHSSIG)>65 S X="",$E(X,14)=$E(BHSSIG,66,999) W X,!
  1.  ..Q
  1.  .Q
  1.  Q
  1.  ;
  1. SIG ;CONSTRUCT THE FULL TEXT FROM THE ENCODED SIG
  1.  S BHSSSGY="" F BHSSP=1:1:$L(BHSSIG," ") S X=$P(BHSSIG," ",BHSSP) I X]"" D
  1.  . 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)
  1.  . S BHSSSGY=BHSSSGY_X_" "
  1.  Q
  1.  ;
  1. REF ;DETERMINE THE NUMBER OF REFILLS REMAINING
  1.  I 'BHSRX S BHSREF=0 Q
  1.  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
  1.  S BHSREF=BHSRFL
  1.  Q
  1.  ;
  1. LAST1YRR ;EP
  1.  NEW T,E,D,Y,M,G,C,N
  1.  S BHSREL=0
  1.  S T(1)=$O(^ATXAX("B","BAT ASTHMA SHRT ACT RELV MEDS",0))
  1.  S T(2)=$O(^ATXAX("B","BAT ASTHMA SHRT ACT RELV NDC",0))
  1.  S T(3)=$O(^ATXAX("B","BAT ASTHMA SHRT ACT INHLR MEDS",0))
  1.  S T(4)=$O(^ATXAX("B","BAT ASTHMA SHRT ACT INHLR NDC",0))
  1.  S T(5)=$O(^ATXAX("B","BGP RA GLUCOCORTIOCOIDS MEDS",0))
  1.  S T(6)=$O(^ATXAX("B","BGP RA GLUCOCORTIOCOIDS CLASS",0))
  1.  S E=9999999-$$FMADD^XLFDT(DT,-183)
  1.  S D=0 F  S D=$O(^AUPNVMED("AA",DFN,D)) Q:D'=+D!(D>E)  D
  1.  .S M=0 F  S M=$O(^AUPNVMED("AA",DFN,D,M)) Q:M'=+M  D
  1.  ..Q:'$D(^AUPNVMED(M,0))
  1.  ..S Y=$P(^AUPNVMED(M,0),U)
  1.  ..Q:'Y
  1.  ..;is it active?
  1.  ..I $P(^AUPNVMED(M,0),U,8)]"",$P(^AUPNVMED(M,0),U,8)'>DT Q
  1.  ..S BHSRXN=$O(^PSRX("APCC",M,0))
  1.  ..S G=1 I BHSRXN D
  1.  ...S BHSSTAT=$P($G(^PSRX(BHSRXN,"STA")),U,1)
  1.  ...I BHSSTAT'=0 S G=0
  1.  ..I 'G Q
  1.  ..I T(1),$D(^ATXAX(T(1),21,"B",Y)) D SR Q
  1.  ..I T(3),$D(^ATXAX(T(3),21,"B",Y)) D SR Q
  1.  ..I T(5),$D(^ATXAX(T(5),21,"B",Y)) D SR Q
  1.  ..S N=$P($G(^PSDRUG(Y,2)),U,4)
  1.  ..Q:N=""
  1.  ..I N]"",T(2),$D(^ATXAX(T(2),21,"B",N)) D SR Q
  1.  ..I N]"",T(4),$D(^ATXAX(T(4),21,"B",N)) D SR Q
  1.  ..S C=$P(^PSDRUG(Y,0),U,2)
  1.  ..I C,T(6),$D(^ATXAX(T(6),21,"B",C)) D SR Q
  1.  .Q
  1.  Q
  1. SR ;
  1.  S BHSREL(D,M)="",BHSREL=BHSREL+1
  1.  Q
  1.  ;
  1. LAST1YRC ;EP
  1.  NEW T,E,D,Y,M,G,C,N
  1.  S BHSCONT=0
  1.  S T(1)=$O(^ATXAX("B","BAT ASTHMA CONTROLLER MEDS",0))
  1.  S T(2)=$O(^ATXAX("B","BAT ASTHMA CONTROLLER NDC",0))
  1.  S T(3)=$O(^ATXAX("B","BAT ASTHMA INHALED STEROIDS",0))
  1.  S T(4)=$O(^ATXAX("B","BAT ASTHMA INHLD STEROIDS NDC",0))
  1.  S T(5)=$O(^ATXAX("B","BAT ASTHMA LEUKOTRIENE MEDS",0))
  1.  S T(6)=$O(^ATXAX("B","BAT ASTHMA LEUKOTRIENE NDC",0))
  1.  S E=9999999-$$FMADD^XLFDT(DT,-183)
  1.  S D=0 F  S D=$O(^AUPNVMED("AA",DFN,D)) Q:D'=+D!(D>E)  D
  1.  .S M=0 F  S M=$O(^AUPNVMED("AA",DFN,D,M)) Q:M'=+M  D
  1.  ..Q:'$D(^AUPNVMED(M,0))
  1.  ..S Y=$P(^AUPNVMED(M,0),U)
  1.  ..Q:'Y
  1.  ..;is it active?
  1.  ..I $P(^AUPNVMED(M,0),U,8)]"",$P(^AUPNVMED(M,0),U,8)'>DT Q
  1.  ..S BHSRXN=$O(^PSRX("APCC",M,0))
  1.  ..S G=1 I BHSRXN D
  1.  ...S BHSSTAT=$P($G(^PSRX(BHSRXN,"STA")),U,1)
  1.  ...I BHSSTAT'=0 S G=0
  1.  ..I 'G Q
  1.  ..I T(1),$D(^ATXAX(T(1),21,"B",Y)) D SC Q
  1.  ..I T(3),$D(^ATXAX(T(3),21,"B",Y)) D SC Q
  1.  ..I T(5),$D(^ATXAX(T(5),21,"B",Y)) D SC Q
  1.  ..S N=$P($G(^PSDRUG(Y,2)),U,4)
  1.  ..Q:N=""
  1.  ..I T(2),$D(^ATXAX(T(2),21,"B",N)) D SC Q
  1.  ..I T(4),$D(^ATXAX(T(4),21,"B",N)) D SC Q
  1.  ..I T(6),$D(^ATXAX(T(6),21,"B",N)) D SC Q
  1.  .Q
  1.  Q
  1. SC ;
  1.  S BHSCONT(D,M)="",BHSCONT=BHSCONT+1
  1.  Q
  1.  ;