APCHSAS1 ; IHS/CMI/LAB - ;
;;2.0;IHS PCC SUITE;**6,7,10,11**;MAY 14, 2009;Build 58
;
;BJPC v1.0 patch 1
S2(N) ;
S APCHCNT=APCHCNT+1
S APCHTFP(APCHCNT)=N
Q
FMH(APCHSPAT,APCHTFP) ;EP - ASTHMA ******* FAMILY HISTORY * 9000014 *******
; <SETUP>
NEW APCHCNT
S APCHCNT=0
I '$D(^AUPNFH("AC",APCHSPAT)),'$D(^AUPNFHR("AC",APCHSPAT)) Q ;no family history to display
NEW APCHTFH
K APCHTFH,APCHTFP
NEW APCHSDFN,C,R,S,Z,O,APCHO,G
S APCHSDFN=0 F S APCHSDFN=$O(^AUPNFH("AC",APCHSPAT,APCHSDFN)) Q:'APCHSDFN D
.Q:'$D(^AUPNFH(APCHSDFN,0)) ;bad xref
.S C=$P(^AUPNFH(APCHSDFN,0),U)
.S G=0 I $$ICD^ATXAPI(C,$O(^ATXAX("B","BGP ASTHMA DXS",0)),9) S G=1
.;I $$VAL^XBDIQ1(9000014,APCHSDFN,.01)="V17.5" S G=1
.I $$ICD^ATXAPI(C,$O(^ATXAX("B","APCH ASTHMA FAMILY HX",0)),9) S G=1
.Q:'G
.S R=$P(^AUPNFH(APCHSDFN,0),U,9)
.I R="" S R="Z",S=$$VAL^XBDIQ1(9000014,APCHSDFN,.07),Z=S_" ",O=8 D G FMH1
..I S="" S S="UNKNOWN",Z="UNKNOWN "
.S S=$$VAL^XBDIQ1(9000014.1,R,.01),Z=S_" "_$P(^AUPNFHR(R,0),U,3)
.S O=$P(^AUPNFHR(R,0),U) I O S O=$P($G(^AUTTRLSH(O,21)),U,3)
.I 'O S O=8
FMH1 .S APCHTFH(O,S,Z,R,(9999999-$$LDM(APCHSDFN)),APCHSDFN)=""
NEW APCHSO,APCHS,APCHD,APCHC,APCHZ,APCHR,APCHTD,APCHSCVD,APCHSICF,APCHS
S APCHSCVD="S:Y]"""" Y=+Y,Y=$E(Y,4,5)_""/""_$S($E(Y,6,7):$E(Y,6,7)_""/"",1:"""")_$E(Y,2,3)"
S APCHSICF=$S('$D(APCHSTYP):"L",'$D(^APCHSCTL(APCHSTYP,2)):"L",$P(^(2),U,1)]"":$P(^(2),U,1),1:"L")
S APCHO=0 F S APCHO=$O(APCHTFH(APCHO)) Q:APCHO'=+APCHO D FMH2
FMHX K APCHSDFN,APCHSN,APCHSICD,APCHSDAT,APCHSNRQ,APCHSICL,APCHSDFN,APCHTFH,APCHS,APCHZ,APCHR,APCHD
Q
LDM(I) ;get last date modified of Family History or relation
I $G(I)="" Q ""
I '$D(^AUPNFH(I,0)) Q ""
NEW J,D,E
S D=""
S J=$P(^AUPNFH(I,0),U,9) I J S D=$P($G(^AUPNFHR(J,0)),U,9) I D="" S D=$P($G(^AUPNFHR(J,0)),U,11)
S E=$P(^AUPNFH(I,0),U,12) I E>D S D=E
S E=$P(^AUPNFH(I,0),U,3) I E>D S D=E
Q D
FMH2 ;
S APCHS="",APCHC=0 F S APCHS=$O(APCHTFH(APCHO,APCHS)) Q:APCHS="" D
.S APCHZ="" F S APCHZ=$O(APCHTFH(APCHO,APCHS,APCHZ)) Q:APCHZ="" D
..S APCHR="" F S APCHR=$O(APCHTFH(APCHO,APCHS,APCHZ,APCHR)) Q:APCHR="" D
...S APCHTD=$O(APCHTFH(APCHO,APCHS,APCHZ,APCHR,0)),APCHTD=(9999999-APCHTD) S Y=APCHTD X APCHSCVD S APCHTDAT=Y
...S APCHD="",APCHC=0 F S APCHD=$O(APCHTFH(APCHO,APCHS,APCHZ,APCHR,APCHD)) Q:APCHD="" D
....S APCHSDFN="" F S APCHSDFN=$O(APCHTFH(APCHO,APCHS,APCHZ,APCHR,APCHD,APCHSDFN)) Q:APCHSDFN="" D FHDSP
Q
FHDSP S APCHC=APCHC+1
I APCHC=1 S Y=APCHTDAT,$E(Y,14)=APCHZ_" Status: "
S APCHSTAT=""
I 'APCHR D
.S APCHSTAT=$S($P(^AUPNFH(APCHSDFN,0),U,6)]"":$$VAL^XBDIQ1(9000014,APCHSDFN,.06),1:"None")
I APCHR S APCHSTAT=$S($P($G(^AUPNFHR(APCHR,0)),U,4)]"":$$VAL^XBDIQ1(9000014.1,APCHR,.04),1:"None")
I APCHC=1 S Y=Y_APCHSTAT D S2(Y)
I APCHR,$P(^AUPNFHR(APCHR,0),U,5)]""!($P(^AUPNFHR(APCHR,0),U,6)]"") D
.I APCHC=1 S Y="",$E(Y,14)="Age at Death: "_$$VAL^XBDIQ1(9000014.1,APCHR,.05)_" Cause of Death: "_$P(^AUPNFHR(APCHR,0),U,6) D S2(Y)
I APCHR,$P(^AUPNFHR(APCHR,0),U,7)]""!($P(^AUPNFHR(APCHR,0),U,8)]"") D
.I APCHC=1 S Y="",$E(Y,14)="Multiple Birth: "_$$VAL^XBDIQ1(9000014.1,APCHR,.07)_$S($P(^AUPNFHR(APCHR,0),U,7)="Y":" Multiple Birth Type: "_$$VAL^XBDIQ1(9000014.1,APCHR,.08),1:"") D S2(Y) ;_" Date Updated: "_$$VAL^XBDIQ1(9000014.1,R,.09)
S APCHSN=^AUPNFH(APCHSDFN,0)
S APCHSICD=$P(APCHSN,U,1)
S APCHSNRQ=$$VAL^XBDIQ1(9000014,APCHSDFN,.04) I APCHSNRQ="" S APCHSNRQ="MISSING PROVIDER NARRATIVE"
;S APCHSNRQ=$S($D(^AUTNPOV(APCHSNRQ)):$P(^AUTNPOV(APCHSNRQ,0),U,1),1:"***** "_APCHSNRQ_" *****")
S (X,R,S,N,A,P)=""
S APCHSNRQ=APCHSNRQ_" ("_$$VAL^XBDIQ1(9000014,APCHSDFN,.01)_")"
S A=$$VAL^XBDIQ1(9000014,APCHSDFN,.05) I $P(^AUPNFH(APCHSDFN,0),U,15) S A=A_" (APPROXIMATE)" ;I A="" S A=$$VAL^XBDIQ1(9000014,APCHSDFN,.05)
S X=APCHSNRQ
S X=X_$S(A]"":"; Age at Onset: "_A,1:"; Age at Onset: None")
S APCHSICL=14,APCHSNRQ=X
D PRTICD
Q
;
PRTTXT ;EP - PUBLISHED ENTRY POINT
; GENERALIZED TEXT PRINTER
S:'$D(APCHSNTE) APCHSNTE=""
S APCHSDLT=1,APCHSILN=80-APCHSICL-1
F APCHSQ=0:0 D PRTTXT1 Q:APCHSTXT="" D PRTTXT2
K APCHSNTE
K APCHSILN,APCHSDLT,APCHSF,APCHSC,APCHSTXT
Q
PRTTXT1 ;
S:APCHSNRQ]""&(($L(APCHSNRQ)+$L(APCHSTXT)+2)<255) APCHSTXT=$S(APCHSTXT]"":APCHSTXT_"; ",1:"")_APCHSNRQ,APCHSNRQ=""
S:APCHSNTE]""&(APCHSNRQ="")&(($L(APCHSNTE)+$L(APCHSTXT)+2)<255) APCHSTXT=APCHSTXT_APCHSNTE,APCHSNTE=""
Q
PRTTXT2 D GETFRAG S Y="",$E(Y,APCHSICL)=APCHSF D S2(Y) S APCHSICL=APCHSICL+APCHSDLT,APCHSILN=APCHSILN-APCHSDLT,APCHSDLT=0
Q
GETFRAG I $L(APCHSTXT)<APCHSILN S APCHSF=APCHSTXT,APCHSTXT="" Q
F APCHSC=APCHSILN:-1:0 Q:$E(APCHSTXT,APCHSC)=" "
S:APCHSC=0 APCHSC=APCHSILN
S APCHSF=$E(APCHSTXT,1,APCHSC-1),APCHSTXT=$E(APCHSTXT,APCHSC+1,255)
Q
;
PRTICD ;ENTRY POINT
I APCHSICF="N" S:APCHSNRQ="" APCHSNRQ="<no narrative provided>" S APCHSICD=""
S APCHSTXT=""
S:'$D(APCHSNTE) APCHSNTE=""
I APCHSNTE]"" S APCHSNTE=" "_APCHSNTE
D PRTTXT
Q
TXT ;EP - PUBLISHED ENTRY POINT
; GENERALIZED TEXT PRINTER
S:'$D(APCHSNTE) APCHSNTE=""
S APCHSDLT=1,APCHSILN=80-APCHSICL-1
F APCHSQ=0:0 D TXT1 Q:APCHSTXT="" D TXT2
K APCHSNTE
K APCHSILN,APCHSDLT,APCHSF,APCHSC,APCHSTXT
Q
TXT1 ;
S:APCHSNRQ]""&(($L(APCHSNRQ)+$L(APCHSTXT)+2)<255) APCHSTXT=$S(APCHSTXT]"":APCHSTXT_"; ",1:"")_APCHSNRQ,APCHSNRQ=""
S:APCHSNTE]""&(APCHSNRQ="")&(($L(APCHSNTE)+$L(APCHSTXT)+2)<255) APCHSTXT=APCHSTXT_APCHSNTE,APCHSNTE=""
Q
TXT2 D FRAG S Y="",$E(Y,APCHSICL)=APCHSF D S1(Y) S APCHSICL=APCHSICL+APCHSDLT,APCHSILN=APCHSILN-APCHSDLT,APCHSDLT=0
Q
FRAG F APCHSC=APCHSILN:-1:0 Q:$E(APCHSTXT,APCHSC)=" "
S:APCHSC=0 APCHSC=APCHSILN
S APCHSF=$E(APCHSTXT,1,APCHSC-1),APCHSTXT=$E(APCHSTXT,APCHSC+1,255)
Q
;
ICD ;EP - ENTRY POINT print text
NEW C
K Z
S C=0
S:APCHSNRQ="" APCHSNRQ="<no narrative provided>" S APCHSICD=""
S APCHSTXT=""
S:'$D(APCHSNTE) APCHSNTE=""
I APCHSNTE]"" S APCHSNTE=" "_APCHSNTE
D TXT
Q
S1(Y) ;
S C=C+1
S Z(C)=Y
Q
;
N ;EP - called from APCHSAST
;
RELMEDS ;
K APCHL,APCHREL,APCHCONT
D LAST1YRR
S X="Number of Reliever Fills in past 6 months: "_$S($G(APCHREL):APCHREL,1:0) D S^APCHSAST(X,1)
D LAST1YRC
S X="Number of Controller Fills in past 6 months: "_$S($G(APCHCONT):APCHCONT,1:0) D S^APCHSAST(X,1)
;
S X="",$E(X,3)="----------RELIEVER MEDICATIONS (FILLED IN THE PAST 6 MONTHS---------" D S^APCHSAST(X,1)
I '$D(APCHREL) S X="<< No Reliever Medications found. >>" D S^APCHSAST(X,1) G CONTMEDS
K APCHL
M APCHL=APCHREL
D DISPMEDS
CONTMEDS ;
S X="",$E(X,3)="----------CONTROLLER MEDICATIONS (FILLED IN THE PAST 6 MONTHS---------" D S^APCHSAST(X,1)
I '$D(APCHCONT) S X="<< No Controller Medications found. >>" D S^APCHSAST(X,1) G DISPEDUC
K APCHL
M APCHL=APCHCONT
D DISPMEDS
DISPEDUC ;
K APCHEDUC D EDUC(DFN,.APCHEDUC)
I $D(APCHEDUC) D
.S X="Last of each ASTHMA Patient Education done:" D S^APCHSAST(X,1)
.S X=" TOPIC",$E(X,44)="LEVEL OF UNDERSTANDING",$E(X,68)="DATE" D S^APCHSAST(X)
.S X="",$P(X,"-",75)="" D S^APCHSAST(X)
.S N="" F S N=$O(APCHEDUC(N)) Q:N="" S X=$E(N,1,42),$E(X,44)=$E($P(APCHEDUC(N),U,2),1,15),$E(X,65)=$$FMTE^XLFDT($P(APCHEDUC(N),U,1)) D S^APCHSAST(X) D
..I $P(APCHEDUC(N),U,3)]"" S Y=" GOAL CODE: "_$P(APCHEDUC(N),U,3) D S^APCHSAST(Y)
..I $P(APCHEDUC(N),U,4)]"" S Y=" GOAL COMMENT: "_$P(APCHEDUC(N),U,4) D S^APCHSAST(Y)
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^APCHSAST(X,1)
.K APCHAR D ENP^XBDIQ1(90181.01,DFN,1100,"APCHAR(","E")
.S F=0 F S F=$O(APCHAR(1100,F)) Q:F'=+F S X="",$E(X,5)=APCHAR(1100,F) D S^APCHSAST(X)
N1 ;
S X="" D S^APCHSAST(X,1)
K APCHAR,APCHSIG,APCHSP,APCHSSGY
Q
;
DISPMEDS ;
S D=0 F S D=$O(APCHL(D)) Q:D'=+D D
.S E=0 F S E=$O(APCHL(D,E)) Q:E'=+E S N=^AUPNVMED(E,0) D
..S APCHD=$$FMTE^XLFDT($P(^AUPNVSIT($P(N,U,3),0),U),"5D")
..S APCHDC=$P(N,U,8),APCHDYS=$P(N,U,7),APCHMFX=$S($P(N,U,4)="":+N,1:$P(N,U,4)) S:APCHDYS="" APCHDYS=30 S APCHRX=$S($D(^PSRX("APCC",E)):$O(^(E,0)),1:0)
..S APCHCRN=$S(+APCHRX:$D(^PS(55,DFN,"P","CP",APCHRX)),1:0)
..S APCHQTY=$P(N,U,6),APCHSIG=$P(N,U,5)
..S APCHDTM=$P($P(^AUPNVSIT($P(N,U,3),0),U),"."),APCHEXP=""
..S X=$$FMDIFF^XLFDT(DT,APCHDTM)
..I X>APCHDYS S Y=$$FMADD^XLFDT(APCHDTM,APCHDYS) S APCHEXP="-- Ran out "_$$FMTE^XLFDT(Y,"2D")
..S APCHMED=$S($P(N,U,4)="":$P(^PSDRUG(APCHMFX,0),U),1:$P(N,U,4))
..I APCHDC S Y=$$FMTE^XLFDT(APCHDC) S APCHEXP="-- D/C "_Y
..S APCHORTS=$G(^AUPNVMED(E,11))
..I APCHORTS["RETURNED TO STOCK",APCHDC S APCHEXP="--RTS "_Y
..D SIG S APCHSIG=APCHSSGY
..D REF I APCHREF S APCHSIG=APCHSIG_" "_APCHREF_$S(APCHREF=1:" refill",1:" refills")_" left."
..S X=APCHD,$E(X,12)=$S(APCHCRN:"(C)",1:""),$E(X,16)=APCHMED_" #"_APCHQTY_" ("_APCHDYS_" days) "_APCHEXP D S^APCHSAST(X)
..;;S X="",$E(X,17)=$E(APCHSIG,1,62) D S^APCHSAST(X)
..;I $L(APCHSIG)>62 S X="",$E(X,17)=$E(APCHSIG,63,999) D S^APCHSAST(X)
..K ^UTILITY($J,"W") S X=APCHSIG,DIWL=0,DIWR=(IOM-19) D ^DIWP
..S X="",$E(X,17)=$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^APCHSAST(X)
..I $G(^UTILITY($J,"W",0))>1 F F=2:1:$G(^UTILITY($J,"W",0)) S X="",$E(X,17)=$G(^UTILITY($J,"W",0,F,0)) D S^APCHSAST(X)
..K ^UTILITY($J,"W")
..Q
.Q
Q
;
SIG ;CONSTRUCT THE FULL TEXT FROM THE ENCODED SIG
S APCHSSGY="" F APCHSP=1:1:$L(APCHSIG," ") S X=$P(APCHSIG," ",APCHSP) 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(APCHSIG," ",APCHSP-1),Y=$E(Y,$L(Y)) S:Y>1 X=$P(^(9),"^",1)
. S APCHSSGY=APCHSSGY_X_" "
Q
;
REF ;DETERMINE THE NUMBER OF REFILLS REMAINING
I 'APCHRX S APCHREF=0 Q
S APCHRFL=$P(^PSRX(APCHRX,0),U,9) S APCHREF=0 F S APCHREF=$O(^PSRX(APCHRX,1,APCHREF)) Q:'APCHREF S APCHRFL=APCHRFL-1
S APCHREF=APCHRFL
Q
;
LAST1YRR ;
NEW T,E,D,Y,M,G,C,N
S APCHREL=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
..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 APCHREL(D,M)="",APCHREL=APCHREL+1
Q
;
LAST1YRC ;
NEW T,E,D,Y,M,G,C,N
S APCHCONT=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
..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 APCHCONT(D,M)="",APCHCONT=APCHCONT+1
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 APCHE,X,E,%,G,A,N,D,I
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 D=$P(^TMP($J,"A",%),U,1)
.S I=+$P(^TMP($J,"A",%),U,4)
.S N=$P(^AUPNVPED(I,0),U)
.Q:'N
.S N=$P($G(^AUTTEDT(N,0)),U,2)
.I $P(N,"-")="ASM"!($$ICD^ATXAPI(+$$ICDDX^ICDEX($P(N,"-",1)),$O(^ATXAX("B","BGP ASTHMA DXS",0)),9))!($P(N,"-")="PL")!(N="M-MDI")!(N="M-NEB") D
..S APCHE($P(^TMP($J,"A",%),U,2),9999999-D)=$$VAL^XBDIQ1(9000010.16,+$P(^TMP($J,"A",%),U,4),.06)_U_$$VAL^XBDIQ1(9000010.16,+$P(^TMP($J,"A",%),U,4),.13)_U_$$VAL^XBDIQ1(9000010.16,+$P(^TMP($J,"A",%),U,4),.14)
S N="" F S N=$O(APCHE(N)) Q:N="" S DATA(N)=(9999999-$O(APCHE(N,0)))_U_APCHE(N,$O(APCHE(N,0)))
K APCHE,^TMP($J,"A")
Q
;
APCHSAS1 ; IHS/CMI/LAB - ;
+1 ;;2.0;IHS PCC SUITE;**6,7,10,11**;MAY 14, 2009;Build 58
+2 ;
+3 ;BJPC v1.0 patch 1
S2(N) ;
+1 SET APCHCNT=APCHCNT+1
+2 SET APCHTFP(APCHCNT)=N
+3 QUIT
FMH(APCHSPAT,APCHTFP) ;EP - ASTHMA ******* FAMILY HISTORY * 9000014 *******
+1 ; <SETUP>
+2 NEW APCHCNT
+3 SET APCHCNT=0
+4 ;no family history to display
IF '$DATA(^AUPNFH("AC",APCHSPAT))
IF '$DATA(^AUPNFHR("AC",APCHSPAT))
QUIT
+5 NEW APCHTFH
+6 KILL APCHTFH,APCHTFP
+7 NEW APCHSDFN,C,R,S,Z,O,APCHO,G
+8 SET APCHSDFN=0
FOR
SET APCHSDFN=$ORDER(^AUPNFH("AC",APCHSPAT,APCHSDFN))
IF 'APCHSDFN
QUIT
Begin DoDot:1
+9 ;bad xref
IF '$DATA(^AUPNFH(APCHSDFN,0))
QUIT
+10 SET C=$PIECE(^AUPNFH(APCHSDFN,0),U)
+11 SET G=0
IF $$ICD^ATXAPI(C,$ORDER(^ATXAX("B","BGP ASTHMA DXS",0)),9)
SET G=1
+12 ;I $$VAL^XBDIQ1(9000014,APCHSDFN,.01)="V17.5" S G=1
+13 IF $$ICD^ATXAPI(C,$ORDER(^ATXAX("B","APCH ASTHMA FAMILY HX",0)),9)
SET G=1
+14 IF 'G
QUIT
+15 SET R=$PIECE(^AUPNFH(APCHSDFN,0),U,9)
+16 IF R=""
SET R="Z"
SET S=$$VAL^XBDIQ1(9000014,APCHSDFN,.07)
SET Z=S_" "
SET O=8
Begin DoDot:2
+17 IF S=""
SET S="UNKNOWN"
SET Z="UNKNOWN "
End DoDot:2
GOTO FMH1
+18 SET S=$$VAL^XBDIQ1(9000014.1,R,.01)
SET Z=S_" "_$PIECE(^AUPNFHR(R,0),U,3)
+19 SET O=$PIECE(^AUPNFHR(R,0),U)
IF O
SET O=$PIECE($GET(^AUTTRLSH(O,21)),U,3)
+20 IF 'O
SET O=8
FMH1 SET APCHTFH(O,S,Z,R,(9999999-$$LDM(APCHSDFN)),APCHSDFN)=""
End DoDot:1
+1 NEW APCHSO,APCHS,APCHD,APCHC,APCHZ,APCHR,APCHTD,APCHSCVD,APCHSICF,APCHS
+2 SET APCHSCVD="S:Y]"""" Y=+Y,Y=$E(Y,4,5)_""/""_$S($E(Y,6,7):$E(Y,6,7)_""/"",1:"""")_$E(Y,2,3)"
+3 SET APCHSICF=$SELECT('$DATA(APCHSTYP):"L",'$DATA(^APCHSCTL(APCHSTYP,2)):"L",$PIECE(^(2),U,1)]"":$PIECE(^(2),U,1),1:"L")
+4 SET APCHO=0
FOR
SET APCHO=$ORDER(APCHTFH(APCHO))
IF APCHO'=+APCHO
QUIT
DO FMH2
FMHX KILL APCHSDFN,APCHSN,APCHSICD,APCHSDAT,APCHSNRQ,APCHSICL,APCHSDFN,APCHTFH,APCHS,APCHZ,APCHR,APCHD
+1 QUIT
LDM(I) ;get last date modified of Family History or relation
+1 IF $GET(I)=""
QUIT ""
+2 IF '$DATA(^AUPNFH(I,0))
QUIT ""
+3 NEW J,D,E
+4 SET D=""
+5 SET J=$PIECE(^AUPNFH(I,0),U,9)
IF J
SET D=$PIECE($GET(^AUPNFHR(J,0)),U,9)
IF D=""
SET D=$PIECE($GET(^AUPNFHR(J,0)),U,11)
+6 SET E=$PIECE(^AUPNFH(I,0),U,12)
IF E>D
SET D=E
+7 SET E=$PIECE(^AUPNFH(I,0),U,3)
IF E>D
SET D=E
+8 QUIT D
FMH2 ;
+1 SET APCHS=""
SET APCHC=0
FOR
SET APCHS=$ORDER(APCHTFH(APCHO,APCHS))
IF APCHS=""
QUIT
Begin DoDot:1
+2 SET APCHZ=""
FOR
SET APCHZ=$ORDER(APCHTFH(APCHO,APCHS,APCHZ))
IF APCHZ=""
QUIT
Begin DoDot:2
+3 SET APCHR=""
FOR
SET APCHR=$ORDER(APCHTFH(APCHO,APCHS,APCHZ,APCHR))
IF APCHR=""
QUIT
Begin DoDot:3
+4 SET APCHTD=$ORDER(APCHTFH(APCHO,APCHS,APCHZ,APCHR,0))
SET APCHTD=(9999999-APCHTD)
SET Y=APCHTD
XECUTE APCHSCVD
SET APCHTDAT=Y
+5 SET APCHD=""
SET APCHC=0
FOR
SET APCHD=$ORDER(APCHTFH(APCHO,APCHS,APCHZ,APCHR,APCHD))
IF APCHD=""
QUIT
Begin DoDot:4
+6 SET APCHSDFN=""
FOR
SET APCHSDFN=$ORDER(APCHTFH(APCHO,APCHS,APCHZ,APCHR,APCHD,APCHSDFN))
IF APCHSDFN=""
QUIT
DO FHDSP
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+7 QUIT
FHDSP SET APCHC=APCHC+1
+1 IF APCHC=1
SET Y=APCHTDAT
SET $EXTRACT(Y,14)=APCHZ_" Status: "
+2 SET APCHSTAT=""
+3 IF 'APCHR
Begin DoDot:1
+4 SET APCHSTAT=$SELECT($PIECE(^AUPNFH(APCHSDFN,0),U,6)]"":$$VAL^XBDIQ1(9000014,APCHSDFN,.06),1:"None")
End DoDot:1
+5 IF APCHR
SET APCHSTAT=$SELECT($PIECE($GET(^AUPNFHR(APCHR,0)),U,4)]"":$$VAL^XBDIQ1(9000014.1,APCHR,.04),1:"None")
+6 IF APCHC=1
SET Y=Y_APCHSTAT
DO S2(Y)
+7 IF APCHR
IF $PIECE(^AUPNFHR(APCHR,0),U,5)]""!($PIECE(^AUPNFHR(APCHR,0),U,6)]"")
Begin DoDot:1
+8 IF APCHC=1
SET Y=""
SET $EXTRACT(Y,14)="Age at Death: "_$$VAL^XBDIQ1(9000014.1,APCHR,.05)_" Cause of Death: "_$PIECE(^AUPNFHR(APCHR,0),U,6)
DO S2(Y)
End DoDot:1
+9 IF APCHR
IF $PIECE(^AUPNFHR(APCHR,0),U,7)]""!($PIECE(^AUPNFHR(APCHR,0),U,8)]"")
Begin DoDot:1
+10 ;_" Date Updated: "_$$VAL^XBDIQ1(9000014.1,R,.09)
IF APCHC=1
SET Y=""
SET $EXTRACT(Y,14)="Multiple Birth: "_$$VAL^XBDIQ1(9000014.1,APCHR,.07)_$SELECT($PIECE(^AUPNFHR(APCHR,0),U,7)="Y":" Multiple Birth Type: "_$$VAL^XBDIQ1(9000014.1,APCHR,.08),1:"")
DO S2(Y)
End DoDot:1
+11 SET APCHSN=^AUPNFH(APCHSDFN,0)
+12 SET APCHSICD=$PIECE(APCHSN,U,1)
+13 SET APCHSNRQ=$$VAL^XBDIQ1(9000014,APCHSDFN,.04)
IF APCHSNRQ=""
SET APCHSNRQ="MISSING PROVIDER NARRATIVE"
+14 ;S APCHSNRQ=$S($D(^AUTNPOV(APCHSNRQ)):$P(^AUTNPOV(APCHSNRQ,0),U,1),1:"***** "_APCHSNRQ_" *****")
+15 SET (X,R,S,N,A,P)=""
+16 SET APCHSNRQ=APCHSNRQ_" ("_$$VAL^XBDIQ1(9000014,APCHSDFN,.01)_")"
+17 ;I A="" S A=$$VAL^XBDIQ1(9000014,APCHSDFN,.05)
SET A=$$VAL^XBDIQ1(9000014,APCHSDFN,.05)
IF $PIECE(^AUPNFH(APCHSDFN,0),U,15)
SET A=A_" (APPROXIMATE)"
+18 SET X=APCHSNRQ
+19 SET X=X_$SELECT(A]"":"; Age at Onset: "_A,1:"; Age at Onset: None")
+20 SET APCHSICL=14
SET APCHSNRQ=X
+21 DO PRTICD
+22 QUIT
+23 ;
PRTTXT ;EP - PUBLISHED ENTRY POINT
+1 ; GENERALIZED TEXT PRINTER
+2 IF '$DATA(APCHSNTE)
SET APCHSNTE=""
+3 SET APCHSDLT=1
SET APCHSILN=80-APCHSICL-1
+4 FOR APCHSQ=0:0
DO PRTTXT1
IF APCHSTXT=""
QUIT
DO PRTTXT2
+5 KILL APCHSNTE
+6 KILL APCHSILN,APCHSDLT,APCHSF,APCHSC,APCHSTXT
+7 QUIT
PRTTXT1 ;
+1 IF APCHSNRQ]""&(($LENGTH(APCHSNRQ)+$LENGTH(APCHSTXT)+2)<255)
SET APCHSTXT=$SELECT(APCHSTXT]"":APCHSTXT_"; ",1:"")_APCHSNRQ
SET APCHSNRQ=""
+2 IF APCHSNTE]""&(APCHSNRQ="")&(($LENGTH(APCHSNTE)+$LENGTH(APCHSTXT)+2)<255)
SET APCHSTXT=APCHSTXT_APCHSNTE
SET APCHSNTE=""
+3 QUIT
PRTTXT2 DO GETFRAG
SET Y=""
SET $EXTRACT(Y,APCHSICL)=APCHSF
DO S2(Y)
SET APCHSICL=APCHSICL+APCHSDLT
SET APCHSILN=APCHSILN-APCHSDLT
SET APCHSDLT=0
+1 QUIT
GETFRAG IF $LENGTH(APCHSTXT)<APCHSILN
SET APCHSF=APCHSTXT
SET APCHSTXT=""
QUIT
+1 FOR APCHSC=APCHSILN:-1:0
IF $EXTRACT(APCHSTXT,APCHSC)=" "
QUIT
+2 IF APCHSC=0
SET APCHSC=APCHSILN
+3 SET APCHSF=$EXTRACT(APCHSTXT,1,APCHSC-1)
SET APCHSTXT=$EXTRACT(APCHSTXT,APCHSC+1,255)
+4 QUIT
+5 ;
PRTICD ;ENTRY POINT
+1 IF APCHSICF="N"
IF APCHSNRQ=""
SET APCHSNRQ="<no narrative provided>"
SET APCHSICD=""
+2 SET APCHSTXT=""
+3 IF '$DATA(APCHSNTE)
SET APCHSNTE=""
+4 IF APCHSNTE]""
SET APCHSNTE=" "_APCHSNTE
+5 DO PRTTXT
+6 QUIT
TXT ;EP - PUBLISHED ENTRY POINT
+1 ; GENERALIZED TEXT PRINTER
+2 IF '$DATA(APCHSNTE)
SET APCHSNTE=""
+3 SET APCHSDLT=1
SET APCHSILN=80-APCHSICL-1
+4 FOR APCHSQ=0:0
DO TXT1
IF APCHSTXT=""
QUIT
DO TXT2
+5 KILL APCHSNTE
+6 KILL APCHSILN,APCHSDLT,APCHSF,APCHSC,APCHSTXT
+7 QUIT
TXT1 ;
+1 IF APCHSNRQ]""&(($LENGTH(APCHSNRQ)+$LENGTH(APCHSTXT)+2)<255)
SET APCHSTXT=$SELECT(APCHSTXT]"":APCHSTXT_"; ",1:"")_APCHSNRQ
SET APCHSNRQ=""
+2 IF APCHSNTE]""&(APCHSNRQ="")&(($LENGTH(APCHSNTE)+$LENGTH(APCHSTXT)+2)<255)
SET APCHSTXT=APCHSTXT_APCHSNTE
SET APCHSNTE=""
+3 QUIT
TXT2 DO FRAG
SET Y=""
SET $EXTRACT(Y,APCHSICL)=APCHSF
DO S1(Y)
SET APCHSICL=APCHSICL+APCHSDLT
SET APCHSILN=APCHSILN-APCHSDLT
SET APCHSDLT=0
+1 QUIT
FRAG FOR APCHSC=APCHSILN:-1:0
IF $EXTRACT(APCHSTXT,APCHSC)=" "
QUIT
+1 IF APCHSC=0
SET APCHSC=APCHSILN
+2 SET APCHSF=$EXTRACT(APCHSTXT,1,APCHSC-1)
SET APCHSTXT=$EXTRACT(APCHSTXT,APCHSC+1,255)
+3 QUIT
+4 ;
ICD ;EP - ENTRY POINT print text
+1 NEW C
+2 KILL Z
+3 SET C=0
+4 IF APCHSNRQ=""
SET APCHSNRQ="<no narrative provided>"
SET APCHSICD=""
+5 SET APCHSTXT=""
+6 IF '$DATA(APCHSNTE)
SET APCHSNTE=""
+7 IF APCHSNTE]""
SET APCHSNTE=" "_APCHSNTE
+8 DO TXT
+9 QUIT
S1(Y) ;
+1 SET C=C+1
+2 SET Z(C)=Y
+3 QUIT
+4 ;
N ;EP - called from APCHSAST
+1 ;
RELMEDS ;
+1 KILL APCHL,APCHREL,APCHCONT
+2 DO LAST1YRR
+3 SET X="Number of Reliever Fills in past 6 months: "_$SELECT($GET(APCHREL):APCHREL,1:0)
DO S^APCHSAST(X,1)
+4 DO LAST1YRC
+5 SET X="Number of Controller Fills in past 6 months: "_$SELECT($GET(APCHCONT):APCHCONT,1:0)
DO S^APCHSAST(X,1)
+6 ;
+7 SET X=""
SET $EXTRACT(X,3)="----------RELIEVER MEDICATIONS (FILLED IN THE PAST 6 MONTHS---------"
DO S^APCHSAST(X,1)
+8 IF '$DATA(APCHREL)
SET X="<< No Reliever Medications found. >>"
DO S^APCHSAST(X,1)
GOTO CONTMEDS
+9 KILL APCHL
+10 MERGE APCHL=APCHREL
+11 DO DISPMEDS
CONTMEDS ;
+1 SET X=""
SET $EXTRACT(X,3)="----------CONTROLLER MEDICATIONS (FILLED IN THE PAST 6 MONTHS---------"
DO S^APCHSAST(X,1)
+2 IF '$DATA(APCHCONT)
SET X="<< No Controller Medications found. >>"
DO S^APCHSAST(X,1)
GOTO DISPEDUC
+3 KILL APCHL
+4 MERGE APCHL=APCHCONT
+5 DO DISPMEDS
DISPEDUC ;
+1 KILL APCHEDUC
DO EDUC(DFN,.APCHEDUC)
+2 IF $DATA(APCHEDUC)
Begin DoDot:1
+3 SET X="Last of each ASTHMA Patient Education done:"
DO S^APCHSAST(X,1)
+4 SET X=" TOPIC"
SET $EXTRACT(X,44)="LEVEL OF UNDERSTANDING"
SET $EXTRACT(X,68)="DATE"
DO S^APCHSAST(X)
+5 SET X=""
SET $PIECE(X,"-",75)=""
DO S^APCHSAST(X)
+6 SET N=""
FOR
SET N=$ORDER(APCHEDUC(N))
IF N=""
QUIT
SET X=$EXTRACT(N,1,42)
SET $EXTRACT(X,44)=$EXTRACT($PIECE(APCHEDUC(N),U,2),1,15)
SET $EXTRACT(X,65)=$$FMTE^XLFDT($PIECE(APCHEDUC(N),U,1))
DO S^APCHSAST(X)
Begin DoDot:2
+7 IF $PIECE(APCHEDUC(N),U,3)]""
SET Y=" GOAL CODE: "_$PIECE(APCHEDUC(N),U,3)
DO S^APCHSAST(Y)
+8 IF $PIECE(APCHEDUC(N),U,4)]""
SET Y=" GOAL COMMENT: "_$PIECE(APCHEDUC(N),U,4)
DO S^APCHSAST(Y)
End DoDot:2
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^APCHSAST(X,1)
+3 KILL APCHAR
DO ENP^XBDIQ1(90181.01,DFN,1100,"APCHAR(","E")
+4 SET F=0
FOR
SET F=$ORDER(APCHAR(1100,F))
IF F'=+F
QUIT
SET X=""
SET $EXTRACT(X,5)=APCHAR(1100,F)
DO S^APCHSAST(X)
End DoDot:1
N1 ;
+1 SET X=""
DO S^APCHSAST(X,1)
+2 KILL APCHAR,APCHSIG,APCHSP,APCHSSGY
+3 QUIT
+4 ;
DISPMEDS ;
+1 SET D=0
FOR
SET D=$ORDER(APCHL(D))
IF D'=+D
QUIT
Begin DoDot:1
+2 SET E=0
FOR
SET E=$ORDER(APCHL(D,E))
IF E'=+E
QUIT
SET N=^AUPNVMED(E,0)
Begin DoDot:2
+3 SET APCHD=$$FMTE^XLFDT($PIECE(^AUPNVSIT($PIECE(N,U,3),0),U),"5D")
+4 SET APCHDC=$PIECE(N,U,8)
SET APCHDYS=$PIECE(N,U,7)
SET APCHMFX=$SELECT($PIECE(N,U,4)="":+N,1:$PIECE(N,U,4))
IF APCHDYS=""
SET APCHDYS=30
SET APCHRX=$SELECT($DATA(^PSRX("APCC",E)):$ORDER(^(E,0)),1:0)
+5 SET APCHCRN=$SELECT(+APCHRX:$DATA(^PS(55,DFN,"P","CP",APCHRX)),1:0)
+6 SET APCHQTY=$PIECE(N,U,6)
SET APCHSIG=$PIECE(N,U,5)
+7 SET APCHDTM=$PIECE($PIECE(^AUPNVSIT($PIECE(N,U,3),0),U),".")
SET APCHEXP=""
+8 SET X=$$FMDIFF^XLFDT(DT,APCHDTM)
+9 IF X>APCHDYS
SET Y=$$FMADD^XLFDT(APCHDTM,APCHDYS)
SET APCHEXP="-- Ran out "_$$FMTE^XLFDT(Y,"2D")
+10 SET APCHMED=$SELECT($PIECE(N,U,4)="":$PIECE(^PSDRUG(APCHMFX,0),U),1:$PIECE(N,U,4))
+11 IF APCHDC
SET Y=$$FMTE^XLFDT(APCHDC)
SET APCHEXP="-- D/C "_Y
+12 SET APCHORTS=$GET(^AUPNVMED(E,11))
+13 IF APCHORTS["RETURNED TO STOCK"
IF APCHDC
SET APCHEXP="--RTS "_Y
+14 DO SIG
SET APCHSIG=APCHSSGY
+15 DO REF
IF APCHREF
SET APCHSIG=APCHSIG_" "_APCHREF_$SELECT(APCHREF=1:" refill",1:" refills")_" left."
+16 SET X=APCHD
SET $EXTRACT(X,12)=$SELECT(APCHCRN:"(C)",1:"")
SET $EXTRACT(X,16)=APCHMED_" #"_APCHQTY_" ("_APCHDYS_" days) "_APCHEXP
DO S^APCHSAST(X)
+17 ;;S X="",$E(X,17)=$E(APCHSIG,1,62) D S^APCHSAST(X)
+18 ;I $L(APCHSIG)>62 S X="",$E(X,17)=$E(APCHSIG,63,999) D S^APCHSAST(X)
+19 KILL ^UTILITY($JOB,"W")
SET X=APCHSIG
SET DIWL=0
SET DIWR=(IOM-19)
DO ^DIWP
+20 SET X=""
SET $EXTRACT(X,17)=$SELECT($LENGTH($GET(^UTILITY($JOB,"W",0,1,0)))>1:$GET(^UTILITY($JOB,"W",0,1,0)),$LENGTH($GET(^UTILITY($JOB,"W",0,1,0)))=1:"No directions on file",1:" ")
DO S^APCHSAST(X)
+21 IF $GET(^UTILITY($JOB,"W",0))>1
FOR F=2:1:$GET(^UTILITY($JOB,"W",0))
SET X=""
SET $EXTRACT(X,17)=$GET(^UTILITY($JOB,"W",0,F,0))
DO S^APCHSAST(X)
+22 KILL ^UTILITY($JOB,"W")
+23 QUIT
End DoDot:2
+24 QUIT
End DoDot:1
+25 QUIT
+26 ;
SIG ;CONSTRUCT THE FULL TEXT FROM THE ENCODED SIG
+1 SET APCHSSGY=""
FOR APCHSP=1:1:$LENGTH(APCHSIG," ")
SET X=$PIECE(APCHSIG," ",APCHSP)
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(APCHSIG," ",APCHSP-1)
SET Y=$EXTRACT(Y,$LENGTH(Y))
IF Y>1
SET X=$PIECE(^(9),"^",1)
+3 SET APCHSSGY=APCHSSGY_X_" "
End DoDot:1
+4 QUIT
+5 ;
REF ;DETERMINE THE NUMBER OF REFILLS REMAINING
+1 IF 'APCHRX
SET APCHREF=0
QUIT
+2 SET APCHRFL=$PIECE(^PSRX(APCHRX,0),U,9)
SET APCHREF=0
FOR
SET APCHREF=$ORDER(^PSRX(APCHRX,1,APCHREF))
IF 'APCHREF
QUIT
SET APCHRFL=APCHRFL-1
+3 SET APCHREF=APCHRFL
+4 QUIT
+5 ;
LAST1YRR ;
+1 NEW T,E,D,Y,M,G,C,N
+2 SET APCHREL=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 IF T(1)
IF $DATA(^ATXAX(T(1),21,"B",Y))
DO SR
QUIT
+16 IF T(3)
IF $DATA(^ATXAX(T(3),21,"B",Y))
DO SR
QUIT
+17 IF T(5)
IF $DATA(^ATXAX(T(5),21,"B",Y))
DO SR
QUIT
+18 SET N=$PIECE($GET(^PSDRUG(Y,2)),U,4)
+19 IF N=""
QUIT
+20 IF N]""
IF T(2)
IF $DATA(^ATXAX(T(2),21,"B",N))
DO SR
QUIT
+21 IF N]""
IF T(4)
IF $DATA(^ATXAX(T(4),21,"B",N))
DO SR
QUIT
+22 SET C=$PIECE(^PSDRUG(Y,0),U,2)
+23 IF C
IF T(6)
IF $DATA(^ATXAX(T(6),21,"B",C))
DO SR
QUIT
End DoDot:2
+24 QUIT
End DoDot:1
+25 QUIT
SR ;
+1 SET APCHREL(D,M)=""
SET APCHREL=APCHREL+1
+2 QUIT
+3 ;
LAST1YRC ;
+1 NEW T,E,D,Y,M,G,C,N
+2 SET APCHCONT=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 IF T(1)
IF $DATA(^ATXAX(T(1),21,"B",Y))
DO SC
QUIT
+16 IF T(3)
IF $DATA(^ATXAX(T(3),21,"B",Y))
DO SC
QUIT
+17 IF T(5)
IF $DATA(^ATXAX(T(5),21,"B",Y))
DO SC
QUIT
+18 SET N=$PIECE($GET(^PSDRUG(Y,2)),U,4)
+19 IF N=""
QUIT
+20 IF T(2)
IF $DATA(^ATXAX(T(2),21,"B",N))
DO SC
QUIT
+21 IF T(4)
IF $DATA(^ATXAX(T(4),21,"B",N))
DO SC
QUIT
+22 IF T(6)
IF $DATA(^ATXAX(T(6),21,"B",N))
DO SC
QUIT
End DoDot:2
+23 QUIT
End DoDot:1
+24 QUIT
SC ;
+1 SET APCHCONT(D,M)=""
SET APCHCONT=APCHCONT+1
+2 QUIT
+3 ;
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 APCHE,X,E,%,G,A,N,D,I
+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 D=$PIECE(^TMP($JOB,"A",%),U,1)
+11 SET I=+$PIECE(^TMP($JOB,"A",%),U,4)
+12 SET N=$PIECE(^AUPNVPED(I,0),U)
+13 IF 'N
QUIT
+14 SET N=$PIECE($GET(^AUTTEDT(N,0)),U,2)
+15 IF $PIECE(N,"-")="ASM"!($$ICD^ATXAPI(+$$ICDDX^ICDEX($PIECE(N,"-",1)),$ORDER(^ATXAX("B","BGP ASTHMA DXS",0)),9))!($PIECE(N,"-")="PL")!(N="M-MDI")!(N="M-NEB")
Begin DoDot:2
+16 SET APCHE($PIECE(^TMP($JOB,"A",%),U,2),9999999-D)=$$VAL^XBDIQ1(9000010.16,+$PIECE(^TMP($JOB,"A",%),U,4),.06)_U_$$VAL^XBDIQ1(9000010.16,+$PIECE(^TMP($JOB,"A",%),U,4),.13)_U_$$VAL^XBDIQ1(9000010.16,+$PIECE(^TMP($JOB,"A",%),U,4),.1
4)
End DoDot:2
End DoDot:1
+17 SET N=""
FOR
SET N=$ORDER(APCHE(N))
IF N=""
QUIT
SET DATA(N)=(9999999-$ORDER(APCHE(N,0)))_U_APCHE(N,$ORDER(APCHE(N,0)))
+18 KILL APCHE,^TMP($JOB,"A")
+19 QUIT
+20 ;
