APCHS61.m

APCHS61 ; IHS/CMI/LAB - PART 6 OF APCHS -- SUMMARY PRODUCTION COMPONENTS 18 Jun 2008 10:07 AM ; 

 ;;2.0;IHS PCC SUITE;**7,10,11**;MAY 14, 2009;Build 58

 ;

 ;

FMH ;EP -  ******* FAMILY HISTORY * 9000014 *******

 ; <SETUP>

 I '$D(^AUPNFH("AC",APCHSPAT)),'$D(^AUPNFHR("AA",APCHSPAT)) Q  ;no family history to display

 X APCHSCKP Q:$D(APCHSQIT)  X:'APCHSNPG APCHSBRK

 ; <DISPLAY>

 K APCHTFH

 S APCHSDFN=0 F  S APCHSDFN=$O(^AUPNFH("AC",APCHSPAT,APCHSDFN)) Q:'APCHSDFN  D

 .Q:'$D(^AUPNFH(APCHSDFN,0))  ;bad xref

 .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)=""

 ;get relations with no conditions

 S X=0 F  S X=$O(^AUPNFHR("AA",APCHSPAT,X)) Q:X'=+X  S Y=0 F  S Y=$O(^AUPNFHR("AA",APCHSPAT,X,Y)) Q:Y'=+Y  D

 .I '$D(^AUPNFH("AE",Y)) D

 ..S R=Y

 ..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

 ..S APCHTFH(O,S,Z,R,(9999999-$P(^AUPNFHR(R,0),U,9)),0)=""

 W "Date Last Mod",?14,"Relation/Status/Diagnosis"

 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,9)

 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(APCHSQIT))  D

 .S APCHZ="" F  S APCHZ=$O(APCHTFH(APCHO,APCHS,APCHZ)) Q:APCHZ=""!($D(APCHSQIT))  D

 ..S APCHR="" F  S APCHR=$O(APCHTFH(APCHO,APCHS,APCHZ,APCHR)) Q:APCHR=""!($D(APCHSQIT))  D

 ...S APCHTD=$O(APCHTFH(APCHO,APCHS,APCHZ,APCHR,0)),APCHTD=(9999999-APCHTD) S Y=APCHTD X APCHSCVD S APCHTDAT=Y S:APCHTDAT="/" APCHTDAT=""

 ...S APCHD="",APCHC=0 F  S APCHD=$O(APCHTFH(APCHO,APCHS,APCHZ,APCHR,APCHD)) Q:APCHD=""!($D(APCHSQIT))  D

 ....S APCHSDFN="" F  S APCHSDFN=$O(APCHTFH(APCHO,APCHS,APCHZ,APCHR,APCHD,APCHSDFN)) Q:APCHSDFN=""!($D(APCHSQIT))  D FHDSP

 ;S APCHSDFN="" F APCHSQ=0:0 S APCHSDFN=$O(^AUPNFH("AC",APCHSPAT,APCHSDFN)) Q:APCHSDFN=""  D FHDSP

 ; <CLEANUP>

 Q

FHDSP S APCHC=APCHC+1

 I APCHC=1 W !,APCHTDAT,?14,APCHZ,"  Status: "

 S APCHSTAT=""

 I 'APCHR,APCHSDFN 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 W APCHSTAT,!

 I APCHR,$P(^AUPNFHR(APCHR,0),U,5)]""!($P(^AUPNFHR(APCHR,0),U,6)]"") D

 .I APCHC=1 W ?14,"Age at Death: ",$$VAL^XBDIQ1(9000014.1,APCHR,.05),"  Cause of Death: ",$S($P(^AUPNFHR(APCHR,0),U,6)]"":$P(^AUPNFHR(APCHR,0),U,6),1:"Data Not Available"),!

 I APCHR,$P(^AUPNFHR(APCHR,0),U,7)]""!($P(^AUPNFHR(APCHR,0),U,8)]"") D

 .I APCHC=1 W ?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:""),! ;_"  Date Updated: "_$$VAL^XBDIQ1(9000014.1,R,.09)

 Q:'APCHSDFN

 S APCHSN=^AUPNFH(APCHSDFN,0)

 S APCHSICD=$P(APCHSN,U,1) D GETICDDX^APCHSUTL

 ;S Y=$P(APCHSN,U,3) X APCHSCVD S APCHSDAT=Y

 S APCHSNRQ=$P(APCHSN,U,4)

 S APCHSNRQ=$$PNPROB^AUPNVUTL(APCHSNRQ) ;D GETNARR^APCHSUTL

 X APCHSCKP Q:$D(APCHSQIT)  ;  W !,APCHSDAT

 S (X,R,S,N,A,P)=""

 ;S R=$$VAL^XBDIQ1(9000014,APCHSDFN,.07)

 S APCHSNRQ=APCHSNRQ  ;_" ("_$$VAL^XBDIQ1(9000014,APCHSDFN,.01)_")"

 S A="" I APCHSDFN 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 S=$$VAL^XBDIQ1(9000014,APCHSDFN,.06)

 ;S P=$$VAL^XBDIQ1(9000014,APCHSDFN,.08)

 ;S X=R

 ;I X]"" S X=X_"; "

 S X=APCHSNRQ

 S X=X_$S(A]"":"; Age at Onset: "_A,1:"; Age at Onset: None")

 ;S X=X_$S(S]"":"; Status: "_S,1:"; Status: None")

 ;S X=X_$S(P]"":"; Documented By: "_P,1:"")

 S APCHSICL=14,APCHSNRQ=X

 D PRTICD^APCHSUTL

 Q

 ;

PWH ;EP - called from component Patient wellness Handout

 ; <SETUP>

 X APCHSCKP Q:$D(APCHSQIT)  X:'APCHSNPG APCHSBRK

 ; <DISPLAY>

 K APCHTFH

 S APCHSIVD="" F  S APCHSIVD=$O(^APCHPWHL("AA",APCHSPAT,APCHSIVD)) Q:APCHSIVD=""!(APCHSIVD>APCHSDLM)  D

 .S APCHIEN=0 F  S APCHIEN=$O(^APCHPWHL("AA",APCHSPAT,APCHSIVD,APCHIEN)) Q:APCHIEN'=+APCHIEN  D

 ..S APCHSN=$G(^APCHPWHL(APCHIEN,0))

 ..I APCHSN="" Q

 ..S N=$$VAL^XBDIQ1(9001027,APCHIEN,.02)

 ..S $P(APCHTFH(N),U)=$P($G(APCHTFH(N)),U)+1

 ..S P=$P(APCHTFH(N),U)+1

 ..S $P(APCHTFH(N),U,P)=$$DATE^APCHSMU($P(^APCHPWHL(APCHIEN,0),U,4))

 ;now display

 I '$D(APCHTFH) W "No Patient Wellness Handouts given to this patient.",! Q

 W ?2,"PATIENT WELLNESS HANDOUT TYPE",?34,"# given",?42,"Dates Last 4 Given to Patient",!

 W $$REPEAT^XLFSTR("-",79),!

 S APCHSN="" F  S APCHSN=$O(APCHTFH(APCHSN)) Q:APCHSN=""!($D(APCHSQIT))  D

 .S O=$P(APCHTFH(APCHSN),U,2,99)

 .S N=$L(O,U)

 .W ?2,APCHSN,?34,$P(APCHTFH(APCHSN),U) W ?42,$P(O,U,N)," ",$P(O,U,N-1)," ",$P(O,U,N-2)," ",$P(O,U,N-3),!

 .Q

 K APCHTFH,APCHSN

 Q

AMI ;EP - called from health summary AMI component

 K APCHSTXA

 ; <SETUP>

 Q:'$D(^AUPNVAMI("AA",APCHSPAT))

 X APCHSBRK

 ; <DISPLAY>

 X APCHSCKP Q:$D(APCHSQIT)

 S APCHARR=9999999999,APCHSDLZ=9999999-APCHSDLM

 F  S APCHARR=$O(^AUPNVAMI("AA",APCHSPAT,APCHARR),-1) Q:APCHARR=""!($P(APCHARR,".")<APCHSDLZ)  D

 .S APCHSIVD=0 F  S APCHSIVD=$O(^AUPNVAMI("AA",APCHSPAT,APCHARR,APCHSIVD)) Q:APCHSIVD=""!(APCHSIVD>APCHSDLM)  D

 ..;table them by date,problem or problem,date depending on the component

 ..S X=0 F  S X=$O(^AUPNVAMI("AA",APCHSPAT,APCHARR,APCHSIVD,X)) Q:X'=+X  D

 ...Q:$P($G(^AUPNVAMI(X,5)),U,1)  ;entered in error

 ...S D=9999999-$P(+^AUPNVAMI(X,0),".",1)

 ...S APCHSTXA("DATE",D,X)=""

 D WRITEAMI

 ; <CLEANUP>

AMIX K APCHARR,APCHSTXA,APCHORD,APCHSICL,APCHSTXT,APCHSNRQ

 Q

WP ;

 K ^UTILITY($J,"W")

 I '$O(^AUPNVAMI(APCHX,2,0)) W ! Q

 NEW APCHY

 S APCHY=0

 S DIWL=17,DIWR=79 F  S APCHY=$O(^AUPNVAMI(APCHX,2,APCHY)) Q:APCHY'=+APCHY  D

 .S X=^AUPNVAMI(APCHX,2,APCHY,0) D ^DIWP

 .Q

 S Z=0 F  S Z=$O(^UTILITY($J,"W",DIWL,Z)) Q:Z'=+Z!($D(APCHSQIT))  D

 .X APCHSCKP Q:$D(APCHSQIT)

 .W ?17,^UTILITY($J,"W",DIWL,Z,0),!

 K DIWL,DIWR,DIWF,Z

 K ^UTILITY($J,"W"),APCHY

 Q

WRITEAMI ;

 S APCHSIVD=0 F  S APCHSIVD=$O(APCHSTXA("DATE",APCHSIVD)) Q:APCHSIVD=""!($D(APCHSQIT))  D

 .X APCHSCKP Q:$D(APCHSQIT)

 .S APCHX=0 F  S APCHX=$O(APCHSTXA("DATE",APCHSIVD,APCHX)) Q:APCHX=""!($D(APCHSQIT))  D

 ..W ?3,"Arrived at:  ",$$GET1^DIQ(9000010.62,APCHX,.01),!

 ..W ?3,"Onset of symptoms:  ",$$GET1^DIQ(9000010.62,APCHX,.04),!

 ..W ?6,"Symptoms:  "

 ..D WP

 ..W ?3,"EKG done:  ",$$GET1^DIQ(9000010.62,APCHX,.07),!

 ..;loop through 14 node and display EKG findings

 ..;.01 concept id ,.02 DESC id | .03,, .06 interpreted by

 ..S APCHY=0 F  S APCHY=$O(^AUPNVAMI(APCHX,14,APCHY)) Q:APCHY'=+APCHY!($D(APCHSQIT))  D

 ...;X APCHSCKP Q:$D(APCHSQIT)

 ...S APCHZ=$G(^AUPNVAMI(APCHX,14,APCHY,0))

 ...;W ?6,$$CONCPT^AUPNVUTL($P(APCHZ,U,1)),!

 ...S X="EKG Interpretation:  "_$$DESCPT^AUPNVUTL($P(APCHZ,U,2))_"|"_$$GET1^DIQ(9000010.6214,APCHY_","_APCHX,.03)

 ...S APCHSNRQ="",APCHSTXT=X,APCHSICL=6 D PRTTXT^APCHSUTL

 ...X APCHSCKP Q:$D(APCHSQIT)

 ...W ?6,"Interpreted by:  ",$$GET1^DIQ(9000010.6214,APCHY_","_APCHX,.06),!

 ..;loop through 13 node and display protocols initiated

 ..;.01 free text ,.02 date/time, .03 entered by

 ..X APCHSCKP Q:$D(APCHSQIT)

 ..W ?3,"Standing orders/Protocols Initiated",!

 ..S APCHY=0 F  S APCHY=$O(^AUPNVAMI(APCHX,13,APCHY)) Q:APCHY'=+APCHY!($D(APCHSQIT))  D

 ...X APCHSCKP Q:$D(APCHSQIT)

 ...S APCHZ=^AUPNVAMI(APCHX,13,APCHY,0)

 ...S X=$$GET1^DIQ(9000010.6213,APCHY_","_APCHX,.01)_" "_$$GET1^DIQ(9000010.6213,APCHY_","_APCHX,.02)_" by "_$$GET1^DIQ(9000010.6213,APCHY_","_APCHX,.04)

 ...S APCHSNRQ="",APCHSTXT=X,APCHSICL=6 D PRTTXT^APCHSUTL

 ..I $P(^AUPNVAMI(APCHX,0),U,11)]"" W ?3,"Fibrinolytic therapy started at:  ",$$GET1^DIQ(9000010.62,APCHX,.11)," by ",$$GET1^DIQ(9000010.62,APCHX,.13),!

 ..I $P(^AUPNVAMI(APCHX,0),U,14)]"" D

 ...W ?3,"Fibrinolytic Not Started: ",$$GET1^DIQ(9000010.62,APCHX,.14)," by ",$$GET1^DIQ(9000010.62,APCHX,.16),!

 ...W ?3,"Reason Not Started: ",$$GET1^DIQ(9000010.62,APCHX,.17),!

 .W !

 Q

STROKE ;EP - called from component

 K APCHSTXA

 ; <SETUP>

 Q:'$D(^AUPNVSTR("AA",APCHSPAT))  ;no stroke data

 X APCHSBRK

 ; <DISPLAY>

 X APCHSCKP Q:$D(APCHSQIT)

 S APCHARR=9999999999,APCHSDLZ=9999999-APCHSDLM

 F  S APCHARR=$O(^AUPNVSTR("AA",APCHSPAT,APCHARR),-1) Q:APCHARR=""!($P(APCHARR,".")<APCHSDLZ)  D

 .S APCHSIVD=0 F  S APCHSIVD=$O(^AUPNVSTR("AA",APCHSPAT,APCHARR,APCHSIVD)) Q:APCHSIVD=""!(APCHSIVD>APCHSDLM)  D

 ..;table them by date,problem or problem,date depending on the component

 ..S X=0 F  S X=$O(^AUPNVSTR("AA",APCHSPAT,APCHARR,APCHSIVD,X)) Q:X'=+X  D

 ...Q:$P($G(^AUPNVSTR(X,5)),U,1)  ;entered in error

 ...S D=9999999-$P(+^AUPNVSTR(X,0),".",1)

 ...S APCHSTXA("DATE",D,X)=""

 D WRITEST

 ; <CLEANUP>

STROKEX K APCHARR,APCHSTXA,APCHORD,APCHSICL,APCHSTXT,APCHSNRQ,APCHNODE

 Q

WPSTR ;

 K ^UTILITY($J,"W")

 I '$O(^AUPNVSTR(APCHX,APCHNODE,0)) W ! Q

 NEW APCHY

 S APCHY=0

 S DIWL=17,DIWR=79 F  S APCHY=$O(^AUPNVSTR(APCHX,APCHNODE,APCHY)) Q:APCHY'=+APCHY  D

 .S X=^AUPNVSTR(APCHX,APCHNODE,APCHY,0) D ^DIWP

 .Q

 S Z=0 F  S Z=$O(^UTILITY($J,"W",DIWL,Z)) Q:Z'=+Z!($D(APCHSQIT))  D

 .X APCHSCKP Q:$D(APCHSQIT)

 .W ?17,^UTILITY($J,"W",DIWL,Z,0),!

 K DIWL,DIWR,DIWF,Z

 K ^UTILITY($J,"W"),APCHY

 Q

WRITEST ;

 S APCHSIVD=0 F  S APCHSIVD=$O(APCHSTXA("DATE",APCHSIVD)) Q:APCHSIVD=""!($D(APCHSQIT))  D

 .X APCHSCKP Q:$D(APCHSQIT)

 .S APCHX=0 F  S APCHX=$O(APCHSTXA("DATE",APCHSIVD,APCHX)) Q:APCHX=""!($D(APCHSQIT))  D

 ..W ?3,"Arrived at:  ",$$GET1^DIQ(9000010.63,APCHX,.01),!

 ..W ?6,"Symptoms:  "

 ..;loop through 14 node and display SYMPTOMS findings

 ..;.01 concept id ,.02 DESC id | .03,, .0 WITNESSED by

 ..S APCHY=0 F  S APCHY=$O(^AUPNVSTR(APCHX,14,APCHY)) Q:APCHY'=+APCHY!($D(APCHSQIT))  D

 ...;X APCHSCKP Q:$D(APCHSQIT)

 ...S APCHZ=^AUPNVSTR(APCHX,14,APCHY,0)

 ...W ?6,$$CONCPT^AUPNVUTL($P(APCHZ,U,1)),!

 ...S X=$$DESCPT^AUPNVUTL($P(APCHZ,U,2))_"|"_$$GET1^DIQ(9000010.6314,APCHY_","_APCHX,.03)

 ...S APCHSNRQ="",APCHSTXT=X,APCHSICL=6 D PRTTXT^APCHSUTL

 ...X APCHSCKP Q:$D(APCHSQIT)

 ...W ?6,"Witnessed by:  ",$$GET1^DIQ(9000010.6314,APCHY_","_APCHX,.07),!

 ...W ?6,"Date/Time Witnessed:  ",$$GET1^DIQ(9000010.6314,APCHY_","_APCHX,.08),!

 ..;handedness

 ..X APCHSCKP Q:$D(APCHSQIT)

 ..S APCHY=0,APCHZ="" F  S APCHY=$O(^AUPNVSTR(APCHX,2,APCHY)) Q:APCHY'=+APCHY!($D(APCHSQIT))  D

 ...S:APCHZ]"" APCHZ=APCHZ_"; "

 ...S APCHZ=APCHZ_$$GET1^DIQ(9000010.632,APCHY_","_APCHX,.019)

 ..W ?6,"Handedness: ",APCHZ,!

 ..;loop through 13 node and display protocols initiated

 ..;.01 free text ,.02 date/time, .03 entered by

 ..X APCHSCKP Q:$D(APCHSQIT)

 ..S APCHY=$$WT(APCHX)

 ..I APCHY]"" W ?6,"Weight: ",$P(APCHY,U)," lbs ("_$P(APCHY,U,2),")",!

 ..;X APCHSCKP Q:$D(APCHSQIT)

 ..;total score stroke

 ..S APCHY=0 F  S APCHY=$O(^AUPNVSTR(APCHX,15,APCHY)) Q:APCHY'=+APCHY!($D(APCHQIT))  D

 ...X APCHSCKP Q:$D(APCHSQIT)

 ...W ?6,"Stroke Score: ",$$GET1^DIQ(9000010.6315,APCHY_","_APCHX,.19)," @ ",$$GET1^DIQ(9000010.6315,APCHY_","_APCHX,.02),!

 ..X APCHSCKP Q:$D(APCHSQIT)

 ..W ?3,"Standing orders/Protocols Initiated",!

 ..S APCHY=0 F  S APCHY=$O(^AUPNVSTR(APCHX,13,APCHY)) Q:APCHY'=+APCHY!($D(APCHSQIT))  D

 ...X APCHSCKP Q:$D(APCHSQIT)

 ...S APCHZ=^AUPNVSTR(APCHX,13,APCHY,0)

 ...S X=$$GET1^DIQ(9000010.6313,APCHY_","_APCHX,.01)_" "_$$GET1^DIQ(9000010.6313,APCHY_","_APCHX,.02)_" by "_$$GET1^DIQ(9000010.6313,APCHY_","_APCHX,.04)

 ...S APCHSNRQ="",APCHSTXT=X,APCHSICL=6 D PRTTXT^APCHSUTL

 ..I $P(^AUPNVSTR(APCHX,0),U,11)]"" W ?3,"Fibrinolytic therapy started at:  ",$$GET1^DIQ(9000010.63,APCHX,.11)," by ",$$GET1^DIQ(9000010.3,APCHX,.13),!

 ..I $P(^AUPNVSTR(APCHX,0),U,14)]"" D

 ...W ?3,"Fibrinolytic Not Started: ",$$GET1^DIQ(9000010.63,APCHX,.14)," by ",$$GET1^DIQ(9000010.63,APCHX,.16),!

 ...W ?3,"Reason Not Started: ",$$GET1^DIQ(9000010.63,APCHX,.17),!

 .W !

 Q

WT(V) ;IS THERE A WEIGHT ON THIS DATE?

 NEW D,A,B,C,P

 S A=$$VALI^XBDIQ1(9000010.63,V,.03)

 I 'A Q ""

 I '$D(^AUPNVSIT(A,0)) Q ""

 S D=$P($P(^AUPNVSIT(A,0),U),".")

 S P=$$VALI^XBDIQ1(9000010.63,V,.02)

 I 'P Q ""

 S C=$$LASTITEM^APCLAPIU(P,"WT","MEASUREMENT",D,D,"A")

 I C="" Q ""

 Q $P(C,U,3)_U_$$VAL^XBDIQ1(9000010.01,$P(C,U,6),1201)

APCHS61   ; IHS/CMI/LAB - PART 6 OF APCHS -- SUMMARY PRODUCTION COMPONENTS 18 Jun 2008 10:07 AM ; 

 +1       ;;2.0;IHS PCC SUITE;**7,10,11**;MAY 14, 2009;Build 58

 +2       ;

 +3       ;

FMH       ;EP -  ******* FAMILY HISTORY * 9000014 *******

 +1       ; <SETUP>

 +2       ;no family history to display

           IF '$DATA(^AUPNFH("AC",APCHSPAT))

               IF '$DATA(^AUPNFHR("AA",APCHSPAT))

                   QUIT 

 +3        XECUTE APCHSCKP

           IF $DATA(APCHSQIT)

               QUIT 

           IF 'APCHSNPG

               XECUTE APCHSBRK

 +4       ; <DISPLAY>

 +5        KILL APCHTFH

 +6        SET APCHSDFN=0

           FOR 

               SET APCHSDFN=$ORDER(^AUPNFH("AC",APCHSPAT,APCHSDFN))

               IF 'APCHSDFN

                   QUIT 

               Begin DoDot:1

 +7       ;bad xref

                   IF '$DATA(^AUPNFH(APCHSDFN,0))

                       QUIT 

 +8                SET R=$PIECE(^AUPNFH(APCHSDFN,0),U,9)

 +9                IF R=""

                       SET R="Z"

                       SET S=$$VAL^XBDIQ1(9000014,APCHSDFN,.07)

                       SET Z=S_" "

                       SET O=8

                       Begin DoDot:2

 +10                       IF S=""

                               SET S="UNKNOWN"

                               SET Z="UNKNOWN "

                       End DoDot:2

                       GOTO FMH1

 +11               SET S=$$VAL^XBDIQ1(9000014.1,R,.01)

                   SET Z=S_" "_$PIECE(^AUPNFHR(R,0),U,3)

 +12               SET O=$PIECE(^AUPNFHR(R,0),U)

                   IF O

                       SET O=$PIECE($GET(^AUTTRLSH(O,21)),U,3)

 +13               IF 'O

                       SET O=8

FMH1               SET APCHTFH(O,S,Z,R,(9999999-$$LDM(APCHSDFN)),APCHSDFN)=""

               End DoDot:1

 +1       ;get relations with no conditions

 +2        SET X=0

           FOR 

               SET X=$ORDER(^AUPNFHR("AA",APCHSPAT,X))

               IF X'=+X

                   QUIT 

               SET Y=0

               FOR 

                   SET Y=$ORDER(^AUPNFHR("AA",APCHSPAT,X,Y))

                   IF Y'=+Y

                       QUIT 

                   Begin DoDot:1

 +3                    IF '$DATA(^AUPNFH("AE",Y))

                           Begin DoDot:2

 +4                            SET R=Y

 +5                            SET S=$$VAL^XBDIQ1(9000014.1,R,.01)

                               SET Z=S_" "_$PIECE(^AUPNFHR(R,0),U,3)

 +6                            SET O=$PIECE(^AUPNFHR(R,0),U)

                               IF O

                                   SET O=$PIECE($GET(^AUTTRLSH(O,21)),U,3)

 +7                            IF 'O

                                   SET O=8

 +8                            SET APCHTFH(O,S,Z,R,(9999999-$PIECE(^AUPNFHR(R,0),U,9)),0)=""

                           End DoDot:2

                   End DoDot:1

 +9        WRITE "Date Last Mod",?14,"Relation/Status/Diagnosis"

 +10       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,9)

 +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=""!($DATA(APCHSQIT))

                   QUIT 

               Begin DoDot:1

 +2                SET APCHZ=""

                   FOR 

                       SET APCHZ=$ORDER(APCHTFH(APCHO,APCHS,APCHZ))

                       IF APCHZ=""!($DATA(APCHSQIT))

                           QUIT 

                       Begin DoDot:2

 +3                        SET APCHR=""

                           FOR 

                               SET APCHR=$ORDER(APCHTFH(APCHO,APCHS,APCHZ,APCHR))

                               IF APCHR=""!($DATA(APCHSQIT))

                                   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

                                   IF APCHTDAT="/"

                                       SET APCHTDAT=""

 +5                                SET APCHD=""

                                   SET APCHC=0

                                   FOR 

                                       SET APCHD=$ORDER(APCHTFH(APCHO,APCHS,APCHZ,APCHR,APCHD))

                                       IF APCHD=""!($DATA(APCHSQIT))

                                           QUIT 

                                       Begin DoDot:4

 +6                                        SET APCHSDFN=""

                                           FOR 

                                               SET APCHSDFN=$ORDER(APCHTFH(APCHO,APCHS,APCHZ,APCHR,APCHD,APCHSDFN))

                                               IF APCHSDFN=""!($DATA(APCHSQIT))

                                                   QUIT 

                                               DO FHDSP

                                       End DoDot:4

                               End DoDot:3

                       End DoDot:2

               End DoDot:1

 +7       ;S APCHSDFN="" F APCHSQ=0:0 S APCHSDFN=$O(^AUPNFH("AC",APCHSPAT,APCHSDFN)) Q:APCHSDFN=""  D FHDSP

 +8       ; <CLEANUP>

 +9        QUIT 

FHDSP      SET APCHC=APCHC+1

 +1        IF APCHC=1

               WRITE !,APCHTDAT,?14,APCHZ,"  Status: "

 +2        SET APCHSTAT=""

 +3        IF 'APCHR

               IF APCHSDFN

                   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

               WRITE APCHSTAT,!

 +7        IF APCHR

               IF $PIECE(^AUPNFHR(APCHR,0),U,5)]""!($PIECE(^AUPNFHR(APCHR,0),U,6)]"")

                   Begin DoDot:1

 +8                    IF APCHC=1

                           WRITE ?14,"Age at Death: ",$$VAL^XBDIQ1(9000014.1,APCHR,.05),"  Cause of Death: ",$SELECT($PIECE(^AUPNFHR(APCHR,0),U,6)]"":$PIECE(^AUPNFHR(APCHR,0),U,6),1:"Data Not Available"),!

                   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

                           WRITE ?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:""),!

                   End DoDot:1

 +11       IF 'APCHSDFN

               QUIT 

 +12       SET APCHSN=^AUPNFH(APCHSDFN,0)

 +13       SET APCHSICD=$PIECE(APCHSN,U,1)

           DO GETICDDX^APCHSUTL

 +14      ;S Y=$P(APCHSN,U,3) X APCHSCVD S APCHSDAT=Y

 +15       SET APCHSNRQ=$PIECE(APCHSN,U,4)

 +16      ;D GETNARR^APCHSUTL

           SET APCHSNRQ=$$PNPROB^AUPNVUTL(APCHSNRQ)

 +17      ;  W !,APCHSDAT

           XECUTE APCHSCKP

           IF $DATA(APCHSQIT)

               QUIT 

 +18       SET (X,R,S,N,A,P)=""

 +19      ;S R=$$VAL^XBDIQ1(9000014,APCHSDFN,.07)

 +20      ;_" ("_$$VAL^XBDIQ1(9000014,APCHSDFN,.01)_")"

           SET APCHSNRQ=APCHSNRQ

 +21      ;I A="" S A=$$VAL^XBDIQ1(9000014,APCHSDFN,.05)

           SET A=""

           IF APCHSDFN

               SET A=$$VAL^XBDIQ1(9000014,APCHSDFN,.05)

               IF $PIECE(^AUPNFH(APCHSDFN,0),U,15)

                   SET A=A_" (APPROXIMATE)"

 +22      ;S S=$$VAL^XBDIQ1(9000014,APCHSDFN,.06)

 +23      ;S P=$$VAL^XBDIQ1(9000014,APCHSDFN,.08)

 +24      ;S X=R

 +25      ;I X]"" S X=X_"; "

 +26       SET X=APCHSNRQ

 +27       SET X=X_$SELECT(A]"":"; Age at Onset: "_A,1:"; Age at Onset: None")

 +28      ;S X=X_$S(S]"":"; Status: "_S,1:"; Status: None")

 +29      ;S X=X_$S(P]"":"; Documented By: "_P,1:"")

 +30       SET APCHSICL=14

           SET APCHSNRQ=X

 +31       DO PRTICD^APCHSUTL

 +32       QUIT 

 +33      ;

PWH       ;EP - called from component Patient wellness Handout

 +1       ; <SETUP>

 +2        XECUTE APCHSCKP

           IF $DATA(APCHSQIT)

               QUIT 

           IF 'APCHSNPG

               XECUTE APCHSBRK

 +3       ; <DISPLAY>

 +4        KILL APCHTFH

 +5        SET APCHSIVD=""

           FOR 

               SET APCHSIVD=$ORDER(^APCHPWHL("AA",APCHSPAT,APCHSIVD))

               IF APCHSIVD=""!(APCHSIVD>APCHSDLM)

                   QUIT 

               Begin DoDot:1

 +6                SET APCHIEN=0

                   FOR 

                       SET APCHIEN=$ORDER(^APCHPWHL("AA",APCHSPAT,APCHSIVD,APCHIEN))

                       IF APCHIEN'=+APCHIEN

                           QUIT 

                       Begin DoDot:2

 +7                        SET APCHSN=$GET(^APCHPWHL(APCHIEN,0))

 +8                        IF APCHSN=""

                               QUIT 

 +9                        SET N=$$VAL^XBDIQ1(9001027,APCHIEN,.02)

 +10                       SET $PIECE(APCHTFH(N),U)=$PIECE($GET(APCHTFH(N)),U)+1

 +11                       SET P=$PIECE(APCHTFH(N),U)+1

 +12                       SET $PIECE(APCHTFH(N),U,P)=$$DATE^APCHSMU($PIECE(^APCHPWHL(APCHIEN,0),U,4))

                       End DoDot:2

               End DoDot:1

 +13      ;now display

 +14       IF '$DATA(APCHTFH)

               WRITE "No Patient Wellness Handouts given to this patient.",!

               QUIT 

 +15       WRITE ?2,"PATIENT WELLNESS HANDOUT TYPE",?34,"# given",?42,"Dates Last 4 Given to Patient",!

 +16       WRITE $$REPEAT^XLFSTR("-",79),!

 +17       SET APCHSN=""

           FOR 

               SET APCHSN=$ORDER(APCHTFH(APCHSN))

               IF APCHSN=""!($DATA(APCHSQIT))

                   QUIT 

               Begin DoDot:1

 +18               SET O=$PIECE(APCHTFH(APCHSN),U,2,99)

 +19               SET N=$LENGTH(O,U)

 +20               WRITE ?2,APCHSN,?34,$PIECE(APCHTFH(APCHSN),U)

                   WRITE ?42,$PIECE(O,U,N)," ",$PIECE(O,U,N-1)," ",$PIECE(O,U,N-2)," ",$PIECE(O,U,N-3),!

 +21               QUIT 

               End DoDot:1

 +22       KILL APCHTFH,APCHSN

 +23       QUIT 

AMI       ;EP - called from health summary AMI component

 +1        KILL APCHSTXA