BHSAST1 ;IHS/MSC/MGH - Asthma supplement continued;30-Nov-2015 10:23;DU
;;1.0;HEALTH SUMMARY COMPONENTS;**3,12**;March 17, 2006;Build 3
; IHS/CMI/LAB - ;
;;2.0;IHS PCC SUITE;;MAY 14, 2009
; Patch 12 changed to use new API for taxonomies
;
;BJPC v1.0 patch 1
S2(N) ;
S BHCNT=BHCNT+1
S BHTFP(BHCNT)=N
Q
FMH(BHSPAT,BHTFP) ;EP - ASTHMA ******* FAMILY HISTORY * 9000014 *******
; <SETUP>
NEW BHCNT
S BHCNT=0
I '$D(^AUPNFH("AC",BHSPAT)),'$D(^AUPNFHR("AC",BHSPAT)) Q ;no family history to display
NEW BHTFH
K BHTFH,BHTFP
NEW BHSDFN,C,R,S,Z,O,BHO,G
;IHS/MSC/MGH changed to use new API P12
S BHSDFN=0 F S BHSDFN=$O(^AUPNFH("AC",BHSPAT,BHSDFN)) Q:'BHSDFN D
.Q:'$D(^AUPNFH(BHSDFN,0)) ;bad xref
.S C=$P(^AUPNFH(BHSDFN,0),U)
.S G=0
.I $$ICD^ATXAPI(C,$O(^ATXAX("B","BGP ASTHMA DXS",0)),9) S G=1
.I $$VAL^XBDIQ1(9000014,BHSDFN,.01)="V17.5" S G=1
.Q:'G
.S R=$P(^AUPNFH(BHSDFN,0),U,9)
.I R="" S R="Z",S=$$VAL^XBDIQ1(9000014,BHSDFN,.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 BHTFH(O,S,Z,R,(9999999-$$LDM(BHSDFN)),BHSDFN)=""
NEW BHSO,BHS,BHD,BHC,BHZ,BHR,BHTD,BHSCVD,BHSICF,BHS,BHDC
S BHSCVD="S:Y]"""" Y=+Y,Y=$E(Y,4,5)_""/""_$S($E(Y,6,7):$E(Y,6,7)_""/"",1:"""")_$E(Y,2,3)"
S BHSICF="L"
;$S('$D(APCHSTYP):"L",'$D(^APCHSCTL(APCHSTYP,2)):"L",$P(^(2),U,1)]"":$P(^(2),U,1),1:"L")
S BHO=0 F S BHO=$O(BHTFH(BHO)) Q:BHO'=+BHO D FMH2
FMHX K BHSDFN,BHSN,BHSICD,BHSDAT,BHSNRQ,BHSICL,BHSDFN,BHTFH,BHS,BHZ,BHR,BHD
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 BHS="",BHC=0 F S BHS=$O(BHTFH(BHO,BHS)) Q:BHS="" D
.S BHZ="" F S BHZ=$O(BHTFH(BHO,BHS,BHZ)) Q:BHZ="" D
..S BHR="" F S BHR=$O(BHTFH(BHO,BHS,BHZ,BHR)) Q:BHR="" D
...S BHTD=$O(BHTFH(BHO,BHS,BHZ,BHR,0)),BHTD=(9999999-BHTD) S X=BHTD D REGDT4^GMTSU S BHTDAT=X
...S BHD="",BHC=0 F S BHD=$O(BHTFH(BHO,BHS,BHZ,BHR,BHD)) Q:BHD="" D
....S BHSDFN="" F S BHSDFN=$O(BHTFH(BHO,BHS,BHZ,BHR,BHD,BHSDFN)) Q:BHSDFN="" D FHDSP
Q
FHDSP S BHC=BHC+1
I BHC=1 S Y=BHTDAT,$E(Y,14)=BHZ_" Status: "
S BHSTAT=""
I 'BHR D
.S BHSTAT=$S($P(^AUPNFH(BHSDFN,0),U,6)]"":$$VAL^XBDIQ1(9000014,BHSDFN,.06),1:"None")
I BHR S BHSTAT=$S($P($G(^AUPNFHR(BHR,0)),U,4)]"":$$VAL^XBDIQ1(9000014.1,BHR,.04),1:"None")
I BHC=1 S Y=Y_BHSTAT D S2(Y)
I BHR,$P(^AUPNFHR(BHR,0),U,5)]""!($P(^AUPNFHR(BHR,0),U,6)]"") D
.I BHC=1 S Y="",$E(Y,14)="Age at Death: "_$$VAL^XBDIQ1(9000014.1,BHR,.05)_" Cause of Death: "_$P(^AUPNFHR(BHR,0),U,6) D S2(Y)
I BHR,$P(^AUPNFHR(BHR,0),U,7)]""!($P(^AUPNFHR(BHR,0),U,8)]"") D
.I BHC=1 S Y="",$E(Y,14)="Multiple Birth: "_$$VAL^XBDIQ1(9000014.1,BHR,.07)_$S($P(^AUPNFHR(BHR,0),U,7)="Y":" Multiple Birth Type: "_$$VAL^XBDIQ1(9000014.1,BHR,.08),1:"") D S2(Y) ;_" Date Updated: "_$$VAL^XBDIQ1(9000014.1,R,.09)
S BHSN=^AUPNFH(BHSDFN,0)
S BHSICD=$P(BHSN,U,1)
S BHSNRQ=$P(BHSN,U,4)
S BHSNRQ=$S($D(^AUTNPOV(BHSNRQ)):$P(^AUTNPOV(BHSNRQ,0),U,1),1:"***** "_BHSNRQ_" *****")
S (X,R,S,N,A,P)=""
S BHSNRQ=BHSNRQ_" ("_$$VAL^XBDIQ1(9000014,BHSDFN,.01)_")"
S A=$$VAL^XBDIQ1(9000014,BHSDFN,.11) I A="" S A=$$VAL^XBDIQ1(9000014,BHSDFN,.05)
S X=BHSNRQ
S X=X_$S(A]"":"; Age at Onset: "_A,1:"; Age at Onset: None")
S BHSICL=14,BHSNRQ=X
D PRTICD
Q
;
PRTTXT ;EP - PUBLISHED ENTRY POINT
; GENERALIZED TEXT PRINTER
S:'$D(BHSNTE) BHSNTE=""
S BHSDLT=1,BHSILN=80-BHSICL-1
F BHSQ=0:0 D PRTTXT1 Q:BHSTXT="" D PRTTXT2
K BHSNTE
K BHSILN,BHSDLT,BHSF,BHSC,BHSTXT
Q
PRTTXT1 ;
S:BHSNRQ]""&(($L(BHSNRQ)+$L(BHSTXT)+2)<255) BHSTXT=$S(BHSTXT]"":BHSTXT_"; ",1:"")_BHSNRQ,BHSNRQ=""
S:BHSNTE]""&(BHSNRQ="")&(($L(BHSNTE)+$L(BHSTXT)+2)<255) BHSTXT=BHSTXT_BHSNTE,BHSNTE=""
Q
PRTTXT2 D GETFRAG S Y="",$E(Y,BHSICL)=BHSF D S2(Y) S BHSICL=BHSICL+BHSDLT,BHSILN=BHSILN-BHSDLT,BHSDLT=0
Q
GETFRAG I $L(BHSTXT)<BHSILN S BHSF=BHSTXT,BHSTXT="" Q
F BHSC=BHSILN:-1:0 Q:$E(BHSTXT,BHSC)=" "
S:BHSC=0 BHSC=BHSILN
S BHSF=$E(BHSTXT,1,BHSC-1),BHSTXT=$E(BHSTXT,BHSC+1,255)
Q
;
PRTICD ;ENTRY POINT
I BHSICF="N" S:BHSNRQ="" BHSNRQ="<no narrative provided>" S BHSICD=""
S BHSTXT=""
S:'$D(BHSNTE) BHSNTE=""
I BHSNTE]"" S BHSNTE=" "_BHSNTE
D PRTTXT
Q
TXT ;EP - PUBLISHED ENTRY POINT
; GENERALIZED TEXT PRINTER
S:'$D(BHSNTE) BHSNTE=""
S BHSDLT=1,BHSILN=80-BHSICL-1
F BHSQ=0:0 D TXT1 Q:BHSTXT="" D TXT2
K BHSNTE
K BHSILN,BHSDLT,BHSF,BHSC,BHSTXT
Q
TXT1 ;
S:BHSNRQ]""&(($L(BHSNRQ)+$L(BHSTXT)+2)<255) BHSTXT=$S(BHSTXT]"":BHSTXT_"; ",1:"")_BHSNRQ,BHSNRQ=""
S:BHSNTE]""&(BHSNRQ="")&(($L(BHSNTE)+$L(BHSTXT)+2)<255) BHSTXT=BHSTXT_BHSNTE,BHSNTE=""
Q
TXT2 D FRAG S Y="",$E(Y,BHSICL)=BHSF D S1(Y) S BHSICL=BHSICL+BHSDLT,BHSILN=BHSILN-BHSDLT,BHSDLT=0
Q
FRAG F BHSC=BHSILN:-1:0 Q:$E(BHSTXT,BHSC)=" "
S:BHSC=0 BHSC=BHSILN
S BHSF=$E(BHSTXT,1,BHSC-1),BHSTXT=$E(BHSTXT,BHSC+1,255)
Q
;
ICD ;EP - ENTRY POINT print text
NEW C
K Z
S C=0
S:BHSNRQ="" BHSNRQ="<no narrative provided>" S BHSICD=""
S BHSTXT=""
S:'$D(BHSNTE) BHSNTE=""
I BHSNTE]"" S BHSNTE=" "_BHSNTE
D TXT
Q
S1(Y) ;
S C=C+1
S Z(C)=Y
Q
;
N ;EP - called from APCHSAST
;
RELMEDS ;
K BHL,BHREL,BHCONT
D LAST1YRR
S X="Number of Reliever Fills in past 6 months: "_$S($G(BHREL):BHREL,1:0) D S^BHSAST(X,1)
D LAST1YRC
S X="Number of Controller Fills in past 6 months: "_$S($G(BHCONT):BHCONT,1:0) D S^BHSAST(X,1)
;
S X="",$E(X,3)="----------RELIEVER MEDICATIONS (FILLED IN THE PAST 6 MONTHS---------" D S^BHSAST(X,1)
I '$D(BHREL) S X="<< No Reliever Medications found. >>" D S^BHSAST(X,1) G CONTMEDS
K BHL
M BHL=BHREL
D DISPMEDS
CONTMEDS ;
S X="",$E(X,3)="----------CONTROLLER MEDICATIONS (FILLED IN THE PAST 6 MONTHS---------" D S^BHSAST(X,1)
I '$D(BHCONT) S X="<< No Controller Medications found. >>" D S^BHSAST(X,1) G DISPEDUC
K BHL
M BHL=BHCONT
D DISPMEDS
DISPEDUC ;
K BHEDUC D EDUC(DFN,.BHEDUC)
I $D(BHEDUC) D
.S X="Last of each ASTHMA Patient Education done:" D S^BHSAST(X,1)
.S X=" TOPIC",$E(X,44)="LEVEL OF UNDERSTANDING",$E(X,68)="DATE" D S^BHSAST(X)
.S X="",$P(X,"-",75)="" D S^BHSAST(X)
.S N="" F S N=$O(BHEDUC(N)) Q:N="" S X=$E(N,1,42),$E(X,44)=$E($P(BHEDUC(N),U,2),1,15),$E(X,65)=$$FMTE^XLFDT($P(BHEDUC(N),U,1)) D S^BHSAST(X) D
..I $P(BHEDUC(N),U,3)]"" S Y=" GOAL CODE: "_$P(BHEDUC(N),U,3) D S^BHSAST(Y)
..I $P(BHEDUC(N),U,4)]"" S Y=" GOAL COMMENT: "_$P(BHEDUC(N),U,4) D S^BHSAST(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^BHSAST(X,1)
.K BHAR D ENP^XBDIQ1(90181.01,DFN,1100,"BHAR(","E")
.S F=0 F S F=$O(BHAR(1100,F)) Q:F'=+F S X="",$E(X,5)=BHAR(1100,F) D S^BHSAST(X)
N1 ;
S X="" D S^BHSAST(X,1)
K BHAR,BHSIG,BHSP,BHSSGY
Q
;
DISPMEDS ;
S D=0 F S D=$O(BHL(D)) Q:D'=+D D
.S E=0 F S E=$O(BHL(D,E)) Q:E'=+E S N=^AUPNVMED(E,0) D
..S BHD=$$FMTE^XLFDT($P(^AUPNVSIT($P(N,U,3),0),U),"5D")
..S BHDC=$P(N,U,8),BHDYS=$P(N,U,7),BHMFX=$S($P(N,U,4)="":+N,1:$P(N,U,4)) S:BHDYS="" BHDYS=30 S BHRX=$S($D(^PSRX("APCC",E)):$O(^(E,0)),1:0)
..S BHCRN=$S(+BHRX:$D(^PS(55,DFN,"P","CP",BHRX)),1:0)
..S BHQTY=$P(N,U,6),BHSIG=$P(N,U,5)
..S BHDTM=$P($P(^AUPNVSIT($P(N,U,3),0),U),"."),BHEXP=""
..S X=$$FMDIFF^XLFDT(DT,BHDTM)
..I X>BHDYS S Y=$$FMADD^XLFDT(BHDTM,BHDYS) S BHEXP="-- Ran out "_$$FMTE^XLFDT(Y,"2D")
..S BHMED=$S($P(N,U,4)="":$P(^PSDRUG(BHMFX,0),U),1:$P(N,U,4))
..I BHDC S Y=$$FMTE^XLFDT(BHDC) S BHEXP="-- D/C "_Y
..S BHORTS=$G(^AUPNVMED(E,11))
..I BHORTS["RETURNED TO STOCK",BHDC S BHEXP="--RTS "_Y
..D SIG S BHSIG=BHSSGY
..D REF I BHREF S BHSIG=BHSIG_" "_BHREF_$S(BHREF=1:" refill",1:" refills")_" left."
..S X=BHD,$E(X,12)=$S(BHCRN:"(C)",1:""),$E(X,16)=BHMED_" #"_BHQTY_" ("_BHDYS_" days) "_BHEXP D S^BHSAST(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=BHSIG,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^BHSAST(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^BHSAST(X)
..K ^UTILITY($J,"W")
..Q
.Q
Q
;
SIG ;CONSTRUCT THE FULL TEXT FROM THE ENCODED SIG
S BHSSGY="" F BHSP=1:1:$L(BHSIG," ") S X=$P(BHSIG," ",BHSP) 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(BHSIG," ",BHSP-1),Y=$E(Y,$L(Y)) S:Y>1 X=$P(^(9),"^",1)
. S BHSSGY=BHSSGY_X_" "
Q
;
REF ;DETERMINE THE NUMBER OF REFILLS REMAINING
I 'BHRX S BHREF=0 Q
S BHRFL=$P(^PSRX(BHRX,0),U,9) S BHREF=0 F S BHREF=$O(^PSRX(BHRX,1,BHREF)) Q:'BHREF S BHRFL=BHRFL-1
S BHREF=BHRFL
Q
;
LAST1YRR ;
NEW T,E,D,Y,M,G,C,N
S BHREL=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 BHREL(D,M)="",BHREL=BHREL+1
Q
;
LAST1YRC ;
NEW T,E,D,Y,M,G,C,N
S BHCONT=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 BHCONT(D,M)="",BHCONT=BHCONT+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 BHE,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"!($P(N,"-")="493")!($P(N,"-")="PL")!(N="M-MDI")!(N="M-NEB") D
..S BHE($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(BHE(N)) Q:N="" S DATA(N)=(9999999-$O(BHE(N,0)))_U_BHE(N,$O(BHE(N,0)))
K BHE,^TMP($J,"A")
Q
;
BHSAST1 ;IHS/MSC/MGH - Asthma supplement continued;30-Nov-2015 10:23;DU
+1 ;;1.0;HEALTH SUMMARY COMPONENTS;**3,12**;March 17, 2006;Build 3
+2 ; IHS/CMI/LAB - ;
+3 ;;2.0;IHS PCC SUITE;;MAY 14, 2009
+4 ; Patch 12 changed to use new API for taxonomies
+5 ;
+6 ;BJPC v1.0 patch 1
S2(N) ;
+1 SET BHCNT=BHCNT+1
+2 SET BHTFP(BHCNT)=N
+3 QUIT
FMH(BHSPAT,BHTFP) ;EP - ASTHMA ******* FAMILY HISTORY * 9000014 *******
+1 ; <SETUP>
+2 NEW BHCNT
+3 SET BHCNT=0
+4 ;no family history to display
IF '$DATA(^AUPNFH("AC",BHSPAT))
IF '$DATA(^AUPNFHR("AC",BHSPAT))
QUIT
+5 NEW BHTFH
+6 KILL BHTFH,BHTFP
+7 NEW BHSDFN,C,R,S,Z,O,BHO,G
+8 ;IHS/MSC/MGH changed to use new API P12
+9 SET BHSDFN=0
FOR
SET BHSDFN=$ORDER(^AUPNFH("AC",BHSPAT,BHSDFN))
IF 'BHSDFN
QUIT
Begin DoDot:1
+10 ;bad xref
IF '$DATA(^AUPNFH(BHSDFN,0))
QUIT
+11 SET C=$PIECE(^AUPNFH(BHSDFN,0),U)
+12 SET G=0
+13 IF $$ICD^ATXAPI(C,$ORDER(^ATXAX("B","BGP ASTHMA DXS",0)),9)
SET G=1
+14 IF $$VAL^XBDIQ1(9000014,BHSDFN,.01)="V17.5"
SET G=1
+15 IF 'G
QUIT
+16 SET R=$PIECE(^AUPNFH(BHSDFN,0),U,9)
+17 IF R=""
SET R="Z"
SET S=$$VAL^XBDIQ1(9000014,BHSDFN,.07)
SET Z=S_" "
SET O=8
Begin DoDot:2
+18 IF S=""
SET S="UNKNOWN"
SET Z="UNKNOWN "
End DoDot:2
GOTO FMH1
+19 SET S=$$VAL^XBDIQ1(9000014.1,R,.01)
SET Z=S_" "_$PIECE(^AUPNFHR(R,0),U,3)
+20 SET O=$PIECE(^AUPNFHR(R,0),U)
IF O
SET O=$PIECE($GET(^AUTTRLSH(O,21)),U,3)
+21 IF 'O
SET O=8
FMH1 SET BHTFH(O,S,Z,R,(9999999-$$LDM(BHSDFN)),BHSDFN)=""
End DoDot:1
+1 NEW BHSO,BHS,BHD,BHC,BHZ,BHR,BHTD,BHSCVD,BHSICF,BHS,BHDC
+2 SET BHSCVD="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 BHSICF="L"
+4 ;$S('$D(APCHSTYP):"L",'$D(^APCHSCTL(APCHSTYP,2)):"L",$P(^(2),U,1)]"":$P(^(2),U,1),1:"L")
+5 SET BHO=0
FOR
SET BHO=$ORDER(BHTFH(BHO))
IF BHO'=+BHO
QUIT
DO FMH2
FMHX KILL BHSDFN,BHSN,BHSICD,BHSDAT,BHSNRQ,BHSICL,BHSDFN,BHTFH,BHS,BHZ,BHR,BHD
+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 BHS=""
SET BHC=0
FOR
SET BHS=$ORDER(BHTFH(BHO,BHS))
IF BHS=""
QUIT
Begin DoDot:1
+2 SET BHZ=""
FOR
SET BHZ=$ORDER(BHTFH(BHO,BHS,BHZ))
IF BHZ=""
QUIT
Begin DoDot:2
+3 SET BHR=""
FOR
SET BHR=$ORDER(BHTFH(BHO,BHS,BHZ,BHR))
IF BHR=""
QUIT
Begin DoDot:3
+4 SET BHTD=$ORDER(BHTFH(BHO,BHS,BHZ,BHR,0))
SET BHTD=(9999999-BHTD)
SET X=BHTD
DO REGDT4^GMTSU
SET BHTDAT=X
+5 SET BHD=""
SET BHC=0
FOR
SET BHD=$ORDER(BHTFH(BHO,BHS,BHZ,BHR,BHD))
IF BHD=""
QUIT
Begin DoDot:4
+6 SET BHSDFN=""
FOR
SET BHSDFN=$ORDER(BHTFH(BHO,BHS,BHZ,BHR,BHD,BHSDFN))
IF BHSDFN=""
QUIT
DO FHDSP
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+7 QUIT
FHDSP SET BHC=BHC+1
+1 IF BHC=1
SET Y=BHTDAT
SET $EXTRACT(Y,14)=BHZ_" Status: "
+2 SET BHSTAT=""
+3 IF 'BHR
Begin DoDot:1
+4 SET BHSTAT=$SELECT($PIECE(^AUPNFH(BHSDFN,0),U,6)]"":$$VAL^XBDIQ1(9000014,BHSDFN,.06),1:"None")
End DoDot:1
+5 IF BHR
SET BHSTAT=$SELECT($PIECE($GET(^AUPNFHR(BHR,0)),U,4)]"":$$VAL^XBDIQ1(9000014.1,BHR,.04),1:"None")
+6 IF BHC=1
SET Y=Y_BHSTAT
DO S2(Y)
+7 IF BHR
IF $PIECE(^AUPNFHR(BHR,0),U,5)]""!($PIECE(^AUPNFHR(BHR,0),U,6)]"")
Begin DoDot:1
+8 IF BHC=1
SET Y=""
SET $EXTRACT(Y,14)="Age at Death: "_$$VAL^XBDIQ1(9000014.1,BHR,.05)_" Cause of Death: "_$PIECE(^AUPNFHR(BHR,0),U,6)
DO S2(Y)
End DoDot:1
+9 IF BHR
IF $PIECE(^AUPNFHR(BHR,0),U,7)]""!($PIECE(^AUPNFHR(BHR,0),U,8)]"")
Begin DoDot:1
+10 ;_" Date Updated: "_$$VAL^XBDIQ1(9000014.1,R,.09)
IF BHC=1
SET Y=""
SET $EXTRACT(Y,14)="Multiple Birth: "_$$VAL^XBDIQ1(9000014.1,BHR,.07)_$SELECT($PIECE(^AUPNFHR(BHR,0),U,7)="Y":" Multiple Birth Type: "_$$VAL^XBDIQ1(9000014.1,BHR,.08),1:"")
DO S2(Y)
End DoDot:1
+11 SET BHSN=^AUPNFH(BHSDFN,0)
+12 SET BHSICD=$PIECE(BHSN,U,1)
+13 SET BHSNRQ=$PIECE(BHSN,U,4)
+14 SET BHSNRQ=$SELECT($DATA(^AUTNPOV(BHSNRQ)):$PIECE(^AUTNPOV(BHSNRQ,0),U,1),1:"***** "_BHSNRQ_" *****")
+15 SET (X,R,S,N,A,P)=""
+16 SET BHSNRQ=BHSNRQ_" ("_$$VAL^XBDIQ1(9000014,BHSDFN,.01)_")"
+17 SET A=$$VAL^XBDIQ1(9000014,BHSDFN,.11)
IF A=""
SET A=$$VAL^XBDIQ1(9000014,BHSDFN,.05)
+18 SET X=BHSNRQ
+19 SET X=X_$SELECT(A]"":"; Age at Onset: "_A,1:"; Age at Onset: None")
+20 SET BHSICL=14
SET BHSNRQ=X
+21 DO PRTICD
+22 QUIT
+23 ;
PRTTXT ;EP - PUBLISHED ENTRY POINT
+1 ; GENERALIZED TEXT PRINTER
+2 IF '$DATA(BHSNTE)
SET BHSNTE=""
+3 SET BHSDLT=1
SET BHSILN=80-BHSICL-1
+4 FOR BHSQ=0:0
DO PRTTXT1
IF BHSTXT=""
QUIT
DO PRTTXT2
+5 KILL BHSNTE
+6 KILL BHSILN,BHSDLT,BHSF,BHSC,BHSTXT
+7 QUIT
PRTTXT1 ;
+1 IF BHSNRQ]""&(($LENGTH(BHSNRQ)+$LENGTH(BHSTXT)+2)<255)
SET BHSTXT=$SELECT(BHSTXT]"":BHSTXT_"; ",1:"")_BHSNRQ
SET BHSNRQ=""
+2 IF BHSNTE]""&(BHSNRQ="")&(($LENGTH(BHSNTE)+$LENGTH(BHSTXT)+2)<255)
SET BHSTXT=BHSTXT_BHSNTE
SET BHSNTE=""
+3 QUIT
PRTTXT2 DO GETFRAG
SET Y=""
SET $EXTRACT(Y,BHSICL)=BHSF
DO S2(Y)
SET BHSICL=BHSICL+BHSDLT
SET BHSILN=BHSILN-BHSDLT
SET BHSDLT=0
+1 QUIT
GETFRAG IF $LENGTH(BHSTXT)<BHSILN
SET BHSF=BHSTXT
SET BHSTXT=""
QUIT
+1 FOR BHSC=BHSILN:-1:0
IF $EXTRACT(BHSTXT,BHSC)=" "
QUIT
+2 IF BHSC=0
SET BHSC=BHSILN
+3 SET BHSF=$EXTRACT(BHSTXT,1,BHSC-1)
SET BHSTXT=$EXTRACT(BHSTXT,BHSC+1,255)
+4 QUIT
+5 ;
PRTICD ;ENTRY POINT
+1 IF BHSICF="N"
IF BHSNRQ=""
SET BHSNRQ="<no narrative provided>"
SET BHSICD=""
+2 SET BHSTXT=""
+3 IF '$DATA(BHSNTE)
SET BHSNTE=""
+4 IF BHSNTE]""
SET BHSNTE=" "_BHSNTE
+5 DO PRTTXT
+6 QUIT
TXT ;EP - PUBLISHED ENTRY POINT
+1 ; GENERALIZED TEXT PRINTER
+2 IF '$DATA(BHSNTE)
SET BHSNTE=""
+3 SET BHSDLT=1
SET BHSILN=80-BHSICL-1
+4 FOR BHSQ=0:0
DO TXT1
IF BHSTXT=""
QUIT
DO TXT2
+5 KILL BHSNTE
+6 KILL BHSILN,BHSDLT,BHSF,BHSC,BHSTXT
+7 QUIT
TXT1 ;
+1 IF BHSNRQ]""&(($LENGTH(BHSNRQ)+$LENGTH(BHSTXT)+2)<255)
SET BHSTXT=$SELECT(BHSTXT]"":BHSTXT_"; ",1:"")_BHSNRQ
SET BHSNRQ=""
+2 IF BHSNTE]""&(BHSNRQ="")&(($LENGTH(BHSNTE)+$LENGTH(BHSTXT)+2)<255)
SET BHSTXT=BHSTXT_BHSNTE
SET BHSNTE=""
+3 QUIT
TXT2 DO FRAG
SET Y=""
SET $EXTRACT(Y,BHSICL)=BHSF
DO S1(Y)
SET BHSICL=BHSICL+BHSDLT
SET BHSILN=BHSILN-BHSDLT
SET BHSDLT=0
+1 QUIT
FRAG FOR BHSC=BHSILN:-1:0
IF $EXTRACT(BHSTXT,BHSC)=" "
QUIT
+1 IF BHSC=0
SET BHSC=BHSILN
+2 SET BHSF=$EXTRACT(BHSTXT,1,BHSC-1)
SET BHSTXT=$EXTRACT(BHSTXT,BHSC+1,255)
+3 QUIT
+4 ;
ICD ;EP - ENTRY POINT print text
+1 NEW C
+2 KILL Z
+3 SET C=0
+4 IF BHSNRQ=""
SET BHSNRQ="<no narrative provided>"
SET BHSICD=""
+5 SET BHSTXT=""
+6 IF '$DATA(BHSNTE)
SET BHSNTE=""
+7 IF BHSNTE]""
SET BHSNTE=" "_BHSNTE
+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 BHL,BHREL,BHCONT
+2 DO LAST1YRR
+3 SET X="Number of Reliever Fills in past 6 months: "_$SELECT($GET(BHREL):BHREL,1:0)
DO S^BHSAST(X,1)
+4 DO LAST1YRC
+5 SET X="Number of Controller Fills in past 6 months: "_$SELECT($GET(BHCONT):BHCONT,1:0)
DO S^BHSAST(X,1)
+6 ;
+7 SET X=""
SET $EXTRACT(X,3)="----------RELIEVER MEDICATIONS (FILLED IN THE PAST 6 MONTHS---------"
DO S^BHSAST(X,1)
+8 IF '$DATA(BHREL)
SET X="<< No Reliever Medications found. >>"
DO S^BHSAST(X,1)
GOTO CONTMEDS
+9 KILL BHL
+10 MERGE BHL=BHREL
+11 DO DISPMEDS
CONTMEDS ;
+1 SET X=""
SET $EXTRACT(X,3)="----------CONTROLLER MEDICATIONS (FILLED IN THE PAST 6 MONTHS---------"
DO S^BHSAST(X,1)
+2 IF '$DATA(BHCONT)
SET X="<< No Controller Medications found. >>"
DO S^BHSAST(X,1)
GOTO DISPEDUC
+3 KILL BHL
+4 MERGE BHL=BHCONT
+5 DO DISPMEDS
DISPEDUC ;
+1 KILL BHEDUC
DO EDUC(DFN,.BHEDUC)
+2 IF $DATA(BHEDUC)
Begin DoDot:1
+3 SET X="Last of each ASTHMA Patient Education done:"
DO S^BHSAST(X,1)
+4 SET X=" TOPIC"
SET $EXTRACT(X,44)="LEVEL OF UNDERSTANDING"
SET $EXTRACT(X,68)="DATE"
DO S^BHSAST(X)
+5 SET X=""
SET $PIECE(X,"-",75)=""
DO S^BHSAST(X)
+6 SET N=""
FOR
SET N=$ORDER(BHEDUC(N))
IF N=""
QUIT
SET X=$EXTRACT(N,1,42)
SET $EXTRACT(X,44)=$EXTRACT($PIECE(BHEDUC(N),U,2),1,15)
SET $EXTRACT(X,65)=$$FMTE^XLFDT($PIECE(BHEDUC(N),U,1))
DO S^BHSAST(X)
Begin DoDot:2
+7 IF $PIECE(BHEDUC(N),U,3)]""
SET Y=" GOAL CODE: "_$PIECE(BHEDUC(N),U,3)
DO S^BHSAST(Y)
+8 IF $PIECE(BHEDUC(N),U,4)]""
SET Y=" GOAL COMMENT: "_$PIECE(BHEDUC(N),U,4)
DO S^BHSAST(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^BHSAST(X,1)
+3 KILL BHAR
DO ENP^XBDIQ1(90181.01,DFN,1100,"BHAR(","E")
+4 SET F=0
FOR
SET F=$ORDER(BHAR(1100,F))
IF F'=+F
QUIT
SET X=""
SET $EXTRACT(X,5)=BHAR(1100,F)
DO S^BHSAST(X)
End DoDot:1
N1 ;
+1 SET X=""
DO S^BHSAST(X,1)
+2 KILL BHAR,BHSIG,BHSP,BHSSGY
+3 QUIT
+4 ;
DISPMEDS ;
+1 SET D=0
FOR
SET D=$ORDER(BHL(D))
IF D'=+D
QUIT
Begin DoDot:1
+2 SET E=0
FOR
SET E=$ORDER(BHL(D,E))
IF E'=+E
QUIT
SET N=^AUPNVMED(E,0)
Begin DoDot:2
+3 SET BHD=$$FMTE^XLFDT($PIECE(^AUPNVSIT($PIECE(N,U,3),0),U),"5D")
+4 SET BHDC=$PIECE(N,U,8)
SET BHDYS=$PIECE(N,U,7)
SET BHMFX=$SELECT($PIECE(N,U,4)="":+N,1:$PIECE(N,U,4))
IF BHDYS=""
SET BHDYS=30
SET BHRX=$SELECT($DATA(^PSRX("APCC",E)):$ORDER(^(E,0)),1:0)
+5 SET BHCRN=$SELECT(+BHRX:$DATA(^PS(55,DFN,"P","CP",BHRX)),1:0)
+6 SET BHQTY=$PIECE(N,U,6)
SET BHSIG=$PIECE(N,U,5)
+7 SET BHDTM=$PIECE($PIECE(^AUPNVSIT($PIECE(N,U,3),0),U),".")
SET BHEXP=""
+8 SET X=$$FMDIFF^XLFDT(DT,BHDTM)
+9 IF X>BHDYS
SET Y=$$FMADD^XLFDT(BHDTM,BHDYS)
SET BHEXP="-- Ran out "_$$FMTE^XLFDT(Y,"2D")
+10 SET BHMED=$SELECT($PIECE(N,U,4)="":$PIECE(^PSDRUG(BHMFX,0),U),1:$PIECE(N,U,4))
+11 IF BHDC
SET Y=$$FMTE^XLFDT(BHDC)
SET BHEXP="-- D/C "_Y
+12 SET BHORTS=$GET(^AUPNVMED(E,11))
+13 IF BHORTS["RETURNED TO STOCK"
IF BHDC
SET BHEXP="--RTS "_Y
+14 DO SIG
SET BHSIG=BHSSGY
+15 DO REF
IF BHREF
SET BHSIG=BHSIG_" "_BHREF_$SELECT(BHREF=1:" refill",1:" refills")_" left."
+16 SET X=BHD
SET $EXTRACT(X,12)=$SELECT(BHCRN:"(C)",1:"")
SET $EXTRACT(X,16)=BHMED_" #"_BHQTY_" ("_BHDYS_" days) "_BHEXP
DO S^BHSAST(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=BHSIG
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^BHSAST(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^BHSAST(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 BHSSGY=""
FOR BHSP=1:1:$LENGTH(BHSIG," ")
SET X=$PIECE(BHSIG," ",BHSP)
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(BHSIG," ",BHSP-1)
SET Y=$EXTRACT(Y,$LENGTH(Y))
IF Y>1
SET X=$PIECE(^(9),"^",1)
+3 SET BHSSGY=BHSSGY_X_" "
End DoDot:1
+4 QUIT
+5 ;
REF ;DETERMINE THE NUMBER OF REFILLS REMAINING
+1 IF 'BHRX
SET BHREF=0
QUIT
+2 SET BHRFL=$PIECE(^PSRX(BHRX,0),U,9)
SET BHREF=0
FOR
SET BHREF=$ORDER(^PSRX(BHRX,1,BHREF))
IF 'BHREF
QUIT
SET BHRFL=BHRFL-1
+3 SET BHREF=BHRFL
+4 QUIT
+5 ;
LAST1YRR ;
+1 NEW T,E,D,Y,M,G,C,N
+2 SET BHREL=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 BHREL(D,M)=""
SET BHREL=BHREL+1
+2 QUIT
+3 ;
LAST1YRC ;
+1 NEW T,E,D,Y,M,G,C,N
+2 SET BHCONT=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 BHCONT(D,M)=""
SET BHCONT=BHCONT+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 BHE,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"!($PIECE(N,"-")="493")!($PIECE(N,"-")="PL")!(N="M-MDI")!(N="M-NEB")
Begin DoDot:2
+16 SET BHE($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),.14)
End DoDot:2
End DoDot:1
+17 SET N=""
FOR
SET N=$ORDER(BHE(N))
IF N=""
QUIT
SET DATA(N)=(9999999-$ORDER(BHE(N,0)))_U_BHE(N,$ORDER(BHE(N,0)))
+18 KILL BHE,^TMP($JOB,"A")
+19 QUIT
+20 ;
