APCHSAS1.m

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