BATSUM ; IHS/CMI/LAB - ;
;;1.0;IHS ASTHMA REGISTER;;FEB 19, 2003
;
S(Y,F,C,T) ;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 register summary
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 $E(X,35)="Asthma Register Status: "_$S(Y]"":Y,1:"NOT ON REGISTER") D S(X)
S X="Problem List: "
S Y=$$PLAST^BATU(DFN,2) ;get problem list # and narrative
I Y="" S Y="ASTHMA IS NOT ON THIS PATIENT'S PROBLEM LIST"
S X=X_Y D S(X)
S X="Primary Care Provider: "_$$VAL^XBDIQ1(9000001,DFN,.14) D S(X)
S X="Last Asthma Visit: "_$$LASTAV^BATU(DFN,3),$E(X,35)="Calculated Next Due: "_$$FMTE^XLFDT($$NEXT^BATU(DFN)) D S(X,1)
S BATPBF=$$LASTPBF^BATU(DFN)
I BATPBF]"" S X="Personal Best Peak Flow "_BATPBF_" liters/minute on "_$$LASTPBF^BATU(DFN,2) D S(X,1)
I BATPBF="" S X="Personal Best Peak Flow NOT documented. NEEDS TO BE REVIEWED" D S(X,1)
S X="Peak Flow Zones",$E(X,20)="Green (80-100%)",$E(X,39)=$$GREEN(BATPBF) D S(X,1)
S X="",$E(X,20)="Yellow (50-79%)",$E(X,39)=$$YELLOW(BATPBF) D S(X)
S X="",$E(X,20)="Red (< 50%)",$E(X,39)=$$RED(BATPBF) D S(X)
S Y=$$LASTSEV^BATU(DFN,5)
I Y="" S X="Severity NOT DOCUMENTED, NEEDS TO BE REVIEWED" D S(X,1)
I Y]"" S X="Severity "_Y_" documented on "_$$LASTSEV^BATU(DFN,3) D S(X,1)
S Y=$$LASTAM^BATU(DFN,2) I Y]"" S X="Date of Last Asthma Management Plan: "_Y D S(X,1)
I Y="" S X="Date of Last Asthma Managment Plan: NEEDS TO BE REVIEWED" D S(X,1)
S X="Triggers (Last Documented Value)" D S(X,1)
S X="",Y=$$LASTETS^BATU(DFN,1),$E(X,8)="ETS",$E(X,28)=$S(Y]"":Y,1:"NOT DOCUMENTED, NEEDS TO BE REVIEWED"),$E(X,35)=$S(Y]"":$$LASTETS^BATU(DFN,2),1:"") D S(X)
S X="",Y=$$LASTPARM^BATU(DFN,1),$E(X,8)="PARTICULATE MATTER",$E(X,28)=$S(Y]"":Y,1:"NOT DOCUMENTED, NEEDS TO BE REVIEWED"),$E(X,35)=$S(Y]"":$$LASTPARM^BATU(DFN,2),1:"") D S(X)
S X="",Y=$$LASTDM^BATU(DFN,1),$E(X,8)="DUST MITE",$E(X,28)=$S(Y]"":Y,1:"NOT DOCUMENTED, NEEDS TO BE REVIEWED"),$E(X,35)=$S(Y]"":$$LASTDM^BATU(DFN,2),1:"") D S(X)
;smoking heath factor - LAST RECORDED
S Y=$$LASTHF(DFN,"TOBACCO"),X="Last Recorded TOBACCO Health Factor: "_$P(Y,U,2)_" "_$$FMTE^XLFDT($P(Y,U)) D S(X,1)
V D LAST5
S X="Last 5 Asthma Visits - LUNG FUNCTION" D S(X,1)
S X="",$E(X,3)="DATE",$E(X,20)="FEV 1",$E(X,38)="FEF 25-75",$E(X,56)="PEF/Best PF" D S(X)
S X="",$P(X,"-",75)="" D S(X)
I '$D(BATL) S X="NO ASTHMA VISITS ON FILE" D S(X) G N
S Y=0 F S Y=$O(BATL(Y)) Q:Y'=+Y S E=BATL(Y) D
.S X="",$E(X,3)=$$FMTE^XLFDT($P($P(^AUPNVSIT($P(^AUPNVAST(E,0),U,3),0),U),"."),"1D"),$E(X,20)=$P(^AUPNVAST(E,0),U,5)_" % predicted"
.S $E(X,38)=$P(^AUPNVAST(E,0),U,6)_" % predicted",$E(X,56)=$P(^AUPNVAST(E,0),U,7)_" liters/minute" D S(X)
N ;more stuff
S Y=$$NREL^BATU(DFN,$$FMTE^XLFDT($$FMADD^XLFDT(DT,-365)),$$FMTE^XLFDT(DT))
S X="Number of Reliever Fills in past 12 months: "_Y D S(X,1)
;last 5 medication prescriptions filled
S T=$O(^ATXAX("B","BAT ASTHMA RELIEVER MEDS",0))
I 'T S X="BAT ASTHMA RELIEVER MEDS taxonomy missing - cannot display meds" D S(X,1) G COMN
S T=$O(^ATXAX("B","BAT ASTHMA CONTROLLER MEDS",0))
I 'T S X="BAT ASTHMA CONTROLLER MEDS taxonomy missing - cannot display meds" D S(X,1) G COMN
S T=$O(^ATXAX("B","BAT ASTHMA INHALED STEROIDS",0))
I 'T S X="BAT ASTHMA INHALED STEROIDS MEDS taxonomy missing - cannot display meds" D S(X,1) G COMN
D LAST1YRM
I '$D(BATL) S X="<< No Asthma Medications found. >>" D S(X,1) G COMN
S X="",$E(X,3)="----------ASTHMA MEDICATIONS (ALL PRESCRIPTIONS FILLED IN PAST YEAR)---------" D S(X,1)
S D=0 F S D=$O(BATL(D)) Q:D'=+D D
.S E=0 F S E=$O(BATL(D,E)) Q:E'=+E S N=^AUPNVMED(E,0) D
..S BATD=$$FMTE^XLFDT($P(^AUPNVSIT($P(N,U,3),0),U),"5D")
..S BATDC=$P(N,U,8),BATDYS=$P(N,U,7),BATMFX=$S($P(N,U,4)="":+N,1:$P(N,U,4)) S:BATDYS="" BATDYS=30 S BATRX=$S($D(^PSRX("APCC",E)):$O(^(E,0)),1:0)
..S BATCRN=$S(+BATRX:$D(^PS(55,DFN,"P","CP",BATRX)),1:0)
..S BATQTY=$P(N,U,6),BATSIG=$P(N,U,5)
..S BATDTM=$P($P(^AUPNVSIT($P(N,U,3),0),U),"."),BATEXP=""
..S X=$$FMDIFF^XLFDT(DT,BATDTM)
..I X>BATDYS S Y=$$FMADD^XLFDT(BATDTM,BATDYS) S BATEXP="-- Ran out "_$$FMTE^XLFDT(Y,"2D")
..S BATMED=$S($P(N,U,4)="":$P(^PSDRUG(BATMFX,0),U),1:$P(N,U,4))
..I BATDC S Y=$$FMTE^XLFDT(BATDC) S BATEXP="-- D/C "_Y
..S BATORTS=$G(^AUPNVMED(E,11))
..I BATORTS["RETURNED TO STOCK",BATDC S BATEXP="--RTS "_Y
..D SIG S BATSIG=BATSSGY
..D REF I BATREF S BATSIG=BATSIG_" "_BATREF_$S(BATREF=1:" refill",1:" refills")_" left."
..S X=BATD,$E(X,9)=$S(BATCRN:"(C)",1:""),$E(X,13)=BATMED_" #"_BATQTY_" ("_BATDYS_" days) "_BATEXP D S(X)
..S X="",$E(X,14)=$E(BATSIG,1,65) D S(X)
..I $L(BATSIG)>65 S X="",$E(X,14)=$E(BATSIG,66,999) D S(X)
..Q
.Q
K BATEDUC D EDUC(DFN,.BATEDUC)
I $D(BATEDUC) D
.S X="Last of each ASTHMA Patient Education done:" D S(X,1)
.S N="" F S N=$O(BATEDUC(N)) Q:N="" S X=" "_N,$E(X,50)=$$FMTE^XLFDT(BATEDUC(N)) D S(X)
COMN ;if comments/notes in register print them
I $O(^BATREG(DFN,11,0)) D
.S X="",$E(X,3)="Comments/Notes from Register:" D S(X,1)
.K BATAR D ENP^XBDIQ1(90181.01,DFN,1100,"BATAR(","E")
.S F=0 F S F=$O(BATAR(1100,F)) Q:F'=+F S X="",$E(X,5)=BATAR(1100,F) D S(X)
N1 ;
S X="" D S(X,1)
K BATAR,BATSIG,BATSP,BATSSGY
Q
SIG ;CONSTRUCT THE FULL TEXT FROM THE ENCODED SIG
S BATSSGY="" F BATSP=1:1:$L(BATSIG," ") S X=$P(BATSIG," ",BATSP) 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(BATSIG," ",BATSP-1),Y=$E(Y,$L(Y)) S:Y>1 X=$P(^(9),"^",1)
. S BATSSGY=BATSSGY_X_" "
Q
;
REF ;DETERMINE THE NUMBER OF REFILLS REMAINING
I 'BATRX S BATREF=0 Q
S BATRFL=$P(^PSRX(BATRX,0),U,9) S BATREF=0 F S BATREF=$O(^PSRX(BATRX,1,BATREF)) Q:'BATREF S BATRFL=BATRFL-1
S BATREF=BATRFL
Q
GREEN(V) ;
NEW P,P1
S P=$J((V*.80),3,0),P1=V
Q P_"-"_V_" liters/minute"
YELLOW(V) ;
NEW P,P1
S P=$J((V*.50),3,0),P1=$J((V*.79),3,0)
Q P_"-"_P1_" liters/minute"
RED(V) ;
NEW P,P1
S P=$J((V*.50),3,0)
Q "< "_P_" liters/minute"
;
LAST1YRM ;
NEW T,T1,T2,E,D,Y,M
S T=$O(^ATXAX("B","BAT ASTHMA RELIEVER MEDS",0))
S T1=$O(^ATXAX("B","BAT ASTHMA INHALED STEROIDS",0))
S T2=$O(^ATXAX("B","BAT ASTHMA CONTROLLER MEDS",0))
K BATL
S E=9999999-$$FMADD^XLFDT(DT,-365)
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 S Y=$P(^AUPNVMED(M,0),U) I $D(^ATXAX(T,21,"B",Y))!($D(^ATXAX(T1,21,"B",Y)))!($D(^ATXAX(T2,21,"B",Y))) S BATL(D,M)=""
.Q
Q
LAST5 ;
K BATL
NEW D,E,C S (D,C)=0 F S D=$O(^AUPNVAST("AA",DFN,D)) Q:D'=+D!(C>4) D
.K BATL1 S E=0 F S E=$O(^AUPNVAST("AA",DFN,D,E)) Q:E'=+E D
..S BATL1(9999999-E)=E
.S E=0 F S E=$O(BATL1(E)) Q:E'=+E!(C>4) S BATL(E)=BATL1(E),C=C+1
.Q
Q
EDUC(P,DATA) ;EP pass back array of all asthma educ topics
;any topic that begins with ASM or 493
K DATA
I '$G(P) Q
NEW BATE,X,E,%,G,A,N,D
K ^TMP($J,"A")
S A="^TMP($J,""A"","
S X=P_"^ALL EDUC;" S E=$$START1^APCLDF(X,A)
I '$D(^TMP($J,"A",1)) Q
S %=0 F S %=$O(^TMP($J,"A",%)) Q:%'=+% D
.S N=$P(^TMP($J,"A",%),U,2),D=$P(^TMP($J,"A",%),U,1)
.I $E(N,1,3)="ASM"!($E(N,1,3)="493") D
..S BATE(N,9999999-D)=""
S N="" F S N=$O(BATE(N)) Q:N="" S DATA(N)=(9999999-$O(BATE(N,0)))
K BATE,^TMP($J,"A")
Q
LASTHF(P,C,F) ;EP - get last factor in category C for patient P
I '$G(P) Q ""
I $G(C)="" Q ""
I $G(F)="" S F=""
S C=$O(^AUTTHF("B",C,0)) ;ien of category passed
I '$G(C) Q ""
NEW H,D,O S H=0 K O
F S H=$O(^AUTTHF("AC",C,H)) Q:'+H D
. Q:'$D(^AUPNVHF("AA",P,H))
. S D=$O(^AUPNVHF("AA",P,H,""))
. Q:'D
. S O(D)=$O(^AUPNVHF("AA",P,H,D,""))
. Q
S D=$O(O(0))
I D="" Q D
I F="S" Q $P($G(^AUPNVHF(O(D),0)),U,6)
Q 9999999-D_"^"_$$VAL^XBDIQ1(9000010.23,O(D),.01)
;
BATSUM ; IHS/CMI/LAB - ;
+1 ;;1.0;IHS ASTHMA REGISTER;;FEB 19, 2003
+2 ;
S(Y,F,C,T) ;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 register summary
+1 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 DO 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 SET X="DOB: "_$$DOB^AUPNPAT(DFN,"E")_" Age: "_$$AGE^AUPNPAT(DFN)_" "_$$SEX^AUPNPAT(DFN)
SET Y=$$VAL^XBDIQ1(90181.01,DFN,.02)
SET $EXTRACT(X,35)="Asthma Register Status: "_$SELECT(Y]"":Y,1:"NOT ON REGISTER")
DO S(X)
+5 SET X="Problem List: "
+6 ;get problem list # and narrative
SET Y=$$PLAST^BATU(DFN,2)
+7 IF Y=""
SET Y="ASTHMA IS NOT ON THIS PATIENT'S PROBLEM LIST"
+8 SET X=X_Y
DO S(X)
+9 SET X="Primary Care Provider: "_$$VAL^XBDIQ1(9000001,DFN,.14)
DO S(X)
+10 SET X="Last Asthma Visit: "_$$LASTAV^BATU(DFN,3)
SET $EXTRACT(X,35)="Calculated Next Due: "_$$FMTE^XLFDT($$NEXT^BATU(DFN))
DO S(X,1)
+11 SET BATPBF=$$LASTPBF^BATU(DFN)
+12 IF BATPBF]""
SET X="Personal Best Peak Flow "_BATPBF_" liters/minute on "_$$LASTPBF^BATU(DFN,2)
DO S(X,1)
+13 IF BATPBF=""
SET X="Personal Best Peak Flow NOT documented. NEEDS TO BE REVIEWED"
DO S(X,1)
+14 SET X="Peak Flow Zones"
SET $EXTRACT(X,20)="Green (80-100%)"
SET $EXTRACT(X,39)=$$GREEN(BATPBF)
DO S(X,1)
+15 SET X=""
SET $EXTRACT(X,20)="Yellow (50-79%)"
SET $EXTRACT(X,39)=$$YELLOW(BATPBF)
DO S(X)
+16 SET X=""
SET $EXTRACT(X,20)="Red (< 50%)"
SET $EXTRACT(X,39)=$$RED(BATPBF)
DO S(X)
+17 SET Y=$$LASTSEV^BATU(DFN,5)
+18 IF Y=""
SET X="Severity NOT DOCUMENTED, NEEDS TO BE REVIEWED"
DO S(X,1)
+19 IF Y]""
SET X="Severity "_Y_" documented on "_$$LASTSEV^BATU(DFN,3)
DO S(X,1)
+20 SET Y=$$LASTAM^BATU(DFN,2)
IF Y]""
SET X="Date of Last Asthma Management Plan: "_Y
DO S(X,1)
+21 IF Y=""
SET X="Date of Last Asthma Managment Plan: NEEDS TO BE REVIEWED"
DO S(X,1)
+22 SET X="Triggers (Last Documented Value)"
DO S(X,1)
+23 SET X=""
SET Y=$$LASTETS^BATU(DFN,1)
SET $EXTRACT(X,8)="ETS"
SET $EXTRACT(X,28)=$SELECT(Y]"":Y,1:"NOT DOCUMENTED, NEEDS TO BE REVIEWED")
SET $EXTRACT(X,35)=$SELECT(Y]"":$$LASTETS^BATU(DFN,2),1:"")
DO S(X)
+24 SET X=""
SET Y=$$LASTPARM^BATU(DFN,1)
SET $EXTRACT(X,8)="PARTICULATE MATTER"
SET $EXTRACT(X,28)=$SELECT(Y]"":Y,1:"NOT DOCUMENTED, NEEDS TO BE REVIEWED")
SET $EXTRACT(X,35)=$SELECT(Y]"":$$LASTPARM^BATU(DFN,2),1:"")
DO S(X)
+25 SET X=""
SET Y=$$LASTDM^BATU(DFN,1)
SET $EXTRACT(X,8)="DUST MITE"
SET $EXTRACT(X,28)=$SELECT(Y]"":Y,1:"NOT DOCUMENTED, NEEDS TO BE REVIEWED")
SET $EXTRACT(X,35)=$SELECT(Y]"":$$LASTDM^BATU(DFN,2),1:"")
DO S(X)
+26 ;smoking heath factor - LAST RECORDED
+27 SET Y=$$LASTHF(DFN,"TOBACCO")
SET X="Last Recorded TOBACCO Health Factor: "_$PIECE(Y,U,2)_" "_$$FMTE^XLFDT($PIECE(Y,U))
DO S(X,1)
V DO LAST5
+1 SET X="Last 5 Asthma Visits - LUNG FUNCTION"
DO S(X,1)
+2 SET X=""
SET $EXTRACT(X,3)="DATE"
SET $EXTRACT(X,20)="FEV 1"
SET $EXTRACT(X,38)="FEF 25-75"
SET $EXTRACT(X,56)="PEF/Best PF"
DO S(X)
+3 SET X=""
SET $PIECE(X,"-",75)=""
DO S(X)
+4 IF '$DATA(BATL)
SET X="NO ASTHMA VISITS ON FILE"
DO S(X)
GOTO N
+5 SET Y=0
FOR
SET Y=$ORDER(BATL(Y))
IF Y'=+Y
QUIT
SET E=BATL(Y)
Begin DoDot:1
+6 SET X=""
SET $EXTRACT(X,3)=$$FMTE^XLFDT($PIECE($PIECE(^AUPNVSIT($PIECE(^AUPNVAST(E,0),U,3),0),U),"."),"1D")
SET $EXTRACT(X,20)=$PIECE(^AUPNVAST(E,0),U,5)_" % predicted"
+7 SET $EXTRACT(X,38)=$PIECE(^AUPNVAST(E,0),U,6)_" % predicted"
SET $EXTRACT(X,56)=$PIECE(^AUPNVAST(E,0),U,7)_" liters/minute"
DO S(X)
End DoDot:1
N ;more stuff
+1 SET Y=$$NREL^BATU(DFN,$$FMTE^XLFDT($$FMADD^XLFDT(DT,-365)),$$FMTE^XLFDT(DT))
+2 SET X="Number of Reliever Fills in past 12 months: "_Y
DO S(X,1)
+3 ;last 5 medication prescriptions filled
+4 SET T=$ORDER(^ATXAX("B","BAT ASTHMA RELIEVER MEDS",0))
+5 IF 'T
SET X="BAT ASTHMA RELIEVER MEDS taxonomy missing - cannot display meds"
DO S(X,1)
GOTO COMN
+6 SET T=$ORDER(^ATXAX("B","BAT ASTHMA CONTROLLER MEDS",0))
+7 IF 'T
SET X="BAT ASTHMA CONTROLLER MEDS taxonomy missing - cannot display meds"
DO S(X,1)
GOTO COMN
+8 SET T=$ORDER(^ATXAX("B","BAT ASTHMA INHALED STEROIDS",0))
+9 IF 'T
SET X="BAT ASTHMA INHALED STEROIDS MEDS taxonomy missing - cannot display meds"
DO S(X,1)
GOTO COMN
+10 DO LAST1YRM
+11 IF '$DATA(BATL)
SET X="<< No Asthma Medications found. >>"
DO S(X,1)
GOTO COMN
+12 SET X=""
SET $EXTRACT(X,3)="----------ASTHMA MEDICATIONS (ALL PRESCRIPTIONS FILLED IN PAST YEAR)---------"
DO S(X,1)
+13 SET D=0
FOR
SET D=$ORDER(BATL(D))
IF D'=+D
QUIT
Begin DoDot:1
+14 SET E=0
FOR
SET E=$ORDER(BATL(D,E))
IF E'=+E
QUIT
SET N=^AUPNVMED(E,0)
Begin DoDot:2
+15 SET BATD=$$FMTE^XLFDT($PIECE(^AUPNVSIT($PIECE(N,U,3),0),U),"5D")
+16 SET BATDC=$PIECE(N,U,8)
SET BATDYS=$PIECE(N,U,7)
SET BATMFX=$SELECT($PIECE(N,U,4)="":+N,1:$PIECE(N,U,4))
IF BATDYS=""
SET BATDYS=30
SET BATRX=$SELECT($DATA(^PSRX("APCC",E)):$ORDER(^(E,0)),1:0)
+17 SET BATCRN=$SELECT(+BATRX:$DATA(^PS(55,DFN,"P","CP",BATRX)),1:0)
+18 SET BATQTY=$PIECE(N,U,6)
SET BATSIG=$PIECE(N,U,5)
+19 SET BATDTM=$PIECE($PIECE(^AUPNVSIT($PIECE(N,U,3),0),U),".")
SET BATEXP=""
+20 SET X=$$FMDIFF^XLFDT(DT,BATDTM)
+21 IF X>BATDYS
SET Y=$$FMADD^XLFDT(BATDTM,BATDYS)
SET BATEXP="-- Ran out "_$$FMTE^XLFDT(Y,"2D")
+22 SET BATMED=$SELECT($PIECE(N,U,4)="":$PIECE(^PSDRUG(BATMFX,0),U),1:$PIECE(N,U,4))
+23 IF BATDC
SET Y=$$FMTE^XLFDT(BATDC)
SET BATEXP="-- D/C "_Y
+24 SET BATORTS=$GET(^AUPNVMED(E,11))
+25 IF BATORTS["RETURNED TO STOCK"
IF BATDC
SET BATEXP="--RTS "_Y
+26 DO SIG
SET BATSIG=BATSSGY
+27 DO REF
IF BATREF
SET BATSIG=BATSIG_" "_BATREF_$SELECT(BATREF=1:" refill",1:" refills")_" left."
+28 SET X=BATD
SET $EXTRACT(X,9)=$SELECT(BATCRN:"(C)",1:"")
SET $EXTRACT(X,13)=BATMED_" #"_BATQTY_" ("_BATDYS_" days) "_BATEXP
DO S(X)
+29 SET X=""
SET $EXTRACT(X,14)=$EXTRACT(BATSIG,1,65)
DO S(X)
+30 IF $LENGTH(BATSIG)>65
SET X=""
SET $EXTRACT(X,14)=$EXTRACT(BATSIG,66,999)
DO S(X)
+31 QUIT
End DoDot:2
+32 QUIT
End DoDot:1
+33 KILL BATEDUC
DO EDUC(DFN,.BATEDUC)
+34 IF $DATA(BATEDUC)
Begin DoDot:1
+35 SET X="Last of each ASTHMA Patient Education done:"
DO S(X,1)
+36 SET N=""
FOR
SET N=$ORDER(BATEDUC(N))
IF N=""
QUIT
SET X=" "_N
SET $EXTRACT(X,50)=$$FMTE^XLFDT(BATEDUC(N))
DO S(X)
End DoDot:1
COMN ;if comments/notes in register print them
+1 IF $ORDER(^BATREG(DFN,11,0))
Begin DoDot:1
+2 SET X=""
SET $EXTRACT(X,3)="Comments/Notes from Register:"
DO S(X,1)
+3 KILL BATAR
DO ENP^XBDIQ1(90181.01,DFN,1100,"BATAR(","E")
+4 SET F=0
FOR
SET F=$ORDER(BATAR(1100,F))
IF F'=+F
QUIT
SET X=""
SET $EXTRACT(X,5)=BATAR(1100,F)
DO S(X)
End DoDot:1
N1 ;
+1 SET X=""
DO S(X,1)
+2 KILL BATAR,BATSIG,BATSP,BATSSGY
+3 QUIT
SIG ;CONSTRUCT THE FULL TEXT FROM THE ENCODED SIG
+1 SET BATSSGY=""
FOR BATSP=1:1:$LENGTH(BATSIG," ")
SET X=$PIECE(BATSIG," ",BATSP)
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(BATSIG," ",BATSP-1)
SET Y=$EXTRACT(Y,$LENGTH(Y))
IF Y>1
SET X=$PIECE(^(9),"^",1)
+3 SET BATSSGY=BATSSGY_X_" "
End DoDot:1
+4 QUIT
+5 ;
REF ;DETERMINE THE NUMBER OF REFILLS REMAINING
+1 IF 'BATRX
SET BATREF=0
QUIT
+2 SET BATRFL=$PIECE(^PSRX(BATRX,0),U,9)
SET BATREF=0
FOR
SET BATREF=$ORDER(^PSRX(BATRX,1,BATREF))
IF 'BATREF
QUIT
SET BATRFL=BATRFL-1
+3 SET BATREF=BATRFL
+4 QUIT
GREEN(V) ;
+1 NEW P,P1
+2 SET P=$JUSTIFY((V*.80),3,0)
SET P1=V
+3 QUIT P_"-"_V_" liters/minute"
YELLOW(V) ;
+1 NEW P,P1
+2 SET P=$JUSTIFY((V*.50),3,0)
SET P1=$JUSTIFY((V*.79),3,0)
+3 QUIT P_"-"_P1_" liters/minute"
RED(V) ;
+1 NEW P,P1
+2 SET P=$JUSTIFY((V*.50),3,0)
+3 QUIT "< "_P_" liters/minute"
+4 ;
LAST1YRM ;
+1 NEW T,T1,T2,E,D,Y,M
+2 SET T=$ORDER(^ATXAX("B","BAT ASTHMA RELIEVER MEDS",0))
+3 SET T1=$ORDER(^ATXAX("B","BAT ASTHMA INHALED STEROIDS",0))
+4 SET T2=$ORDER(^ATXAX("B","BAT ASTHMA CONTROLLER MEDS",0))
+5 KILL BATL
+6 SET E=9999999-$$FMADD^XLFDT(DT,-365)
+7 SET D=0
FOR
SET D=$ORDER(^AUPNVMED("AA",DFN,D))
IF D'=+D!(D>E)
QUIT
Begin DoDot:1
+8 SET M=0
FOR
SET M=$ORDER(^AUPNVMED("AA",DFN,D,M))
IF M'=+M
QUIT
SET Y=$PIECE(^AUPNVMED(M,0),U)
IF $DATA(^ATXAX(T,21,"B",Y))!($DATA(^ATXAX(T1,21,"B",Y)))!($DATA(^ATXAX(T2,21,"B",Y)))
SET BATL(D,M)=""
+9 QUIT
End DoDot:1
+10 QUIT
LAST5 ;
+1 KILL BATL
+2 NEW D,E,C
SET (D,C)=0
FOR
SET D=$ORDER(^AUPNVAST("AA",DFN,D))
IF D'=+D!(C>4)
QUIT
Begin DoDot:1
+3 KILL BATL1
SET E=0
FOR
SET E=$ORDER(^AUPNVAST("AA",DFN,D,E))
IF E'=+E
QUIT
Begin DoDot:2
+4 SET BATL1(9999999-E)=E
End DoDot:2
+5 SET E=0
FOR
SET E=$ORDER(BATL1(E))
IF E'=+E!(C>4)
QUIT
SET BATL(E)=BATL1(E)
SET C=C+1
+6 QUIT
End DoDot:1
+7 QUIT
EDUC(P,DATA) ;EP pass back array of all asthma educ topics
+1 ;any topic that begins with ASM or 493
+2 KILL DATA
+3 IF '$GET(P)
QUIT
+4 NEW BATE,X,E,%,G,A,N,D
+5 KILL ^TMP($JOB,"A")
+6 SET A="^TMP($J,""A"","
+7 SET X=P_"^ALL EDUC;"
SET E=$$START1^APCLDF(X,A)
+8 IF '$DATA(^TMP($JOB,"A",1))
QUIT
+9 SET %=0
FOR
SET %=$ORDER(^TMP($JOB,"A",%))
IF %'=+%
QUIT
Begin DoDot:1
+10 SET N=$PIECE(^TMP($JOB,"A",%),U,2)
SET D=$PIECE(^TMP($JOB,"A",%),U,1)
+11 IF $EXTRACT(N,1,3)="ASM"!($EXTRACT(N,1,3)="493")
Begin DoDot:2
+12 SET BATE(N,9999999-D)=""
End DoDot:2
End DoDot:1
+13 SET N=""
FOR
SET N=$ORDER(BATE(N))
IF N=""
QUIT
SET DATA(N)=(9999999-$ORDER(BATE(N,0)))
+14 KILL BATE,^TMP($JOB,"A")
+15 QUIT
LASTHF(P,C,F) ;EP - get last factor in category C for patient P
+1 IF '$GET(P)
QUIT ""
+2 IF $GET(C)=""
QUIT ""
+3 IF $GET(F)=""
SET F=""
+4 ;ien of category passed
SET C=$ORDER(^AUTTHF("B",C,0))
+5 IF '$GET(C)
QUIT ""
+6 NEW H,D,O
SET H=0
KILL O
+7 FOR
SET H=$ORDER(^AUTTHF("AC",C,H))
IF '+H
QUIT
Begin DoDot:1
+8 IF '$DATA(^AUPNVHF("AA",P,H))
QUIT
+9 SET D=$ORDER(^AUPNVHF("AA",P,H,""))
+10 IF 'D
QUIT
+11 SET O(D)=$ORDER(^AUPNVHF("AA",P,H,D,""))
+12 QUIT
End DoDot:1
+13 SET D=$ORDER(O(0))
+14 IF D=""
QUIT D
+15 IF F="S"
QUIT $PIECE($GET(^AUPNVHF(O(D),0)),U,6)
+16 QUIT 9999999-D_"^"_$$VAL^XBDIQ1(9000010.23,O(D),.01)
+17 ;
