BHSFH1 ; IHS/MSC/MGH - Health summary for family history ;01-Aug-2013 17:22;DU
;;1.0;HEALTH SUMMARY COMONENTS;**8**;March 17, 2006;Build 22
;
;
FMH ;EP - ******* FAMILY HISTORY * 9000014 *******
; <SETUP>
;Same as other family history but without SNOMED codes displayed
N BHSPAT,BHSQ
S BHSPAT=DFN
I '$D(^AUPNFH("AC",BHSPAT)),'$D(^AUPNFHR("AA",BHSPAT)) Q ;no family history to display
D CKP^GMTSUP Q:$D(GMTSQIT)
; <DISPLAY>
K APCHTFH
S BHSDFN=0 F S BHSDFN=$O(^AUPNFH("AC",BHSPAT,BHSDFN)) Q:'BHSDFN D
.Q:'$D(^AUPNFH(BHSDFN,0)) ;bad xref
.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 APCHTFH(O,S,Z,R,(9999999-$$LDM(BHSDFN)),BHSDFN)=""
;get relations with no conditions
S X=0 F S X=$O(^AUPNFHR("AA",BHSPAT,X)) Q:X'=+X S Y=0 F S Y=$O(^AUPNFHR("AA",BHSPAT,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 BHO=0 F S BHO=$O(APCHTFH(BHO)) Q:BHO'=+BHO D FMH2
FMHX K BHSDFN,BHSN,BHSICD,BHSDAT,BHSNRQ,BHSICL,BHSDFN,APCHTFH,BHS,BHZ,BHR,BHD,BHO
K BHC,BHIEN,BHSIVD,BHSTAT,BHTD,BHTDAT,A,T,N,O,P,R,S,X,Y,Z
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 BHS="",BHC=0 F S BHS=$O(APCHTFH(BHO,BHS)) Q:BHS=""!($D(GMTSQIT)) D
.S BHZ="" F S BHZ=$O(APCHTFH(BHO,BHS,BHZ)) Q:BHZ=""!($D(GMTSQIT)) D
..S BHR="" F S BHR=$O(APCHTFH(BHO,BHS,BHZ,BHR)) Q:BHR=""!($D(GMTSQIT)) D
...S BHTD=$O(APCHTFH(BHO,BHS,BHZ,BHR,0)),BHTD=(9999999-BHTD) S X=BHTD D REGDT4^GMTSU S BHTDAT=X S:BHTDAT="/" BHTDAT=""
...S BHD="",BHC=0 F S BHD=$O(APCHTFH(BHO,BHS,BHZ,BHR,BHD)) Q:BHD=""!($D(GMTSQIT)) D
....S BHSDFN="" F S BHSDFN=$O(APCHTFH(BHO,BHS,BHZ,BHR,BHD,BHSDFN)) Q:BHSDFN=""!($D(GMTSQIT)) D FHDSP
;S APCHSDFN="" F APCHSQ=0:0 S APCHSDFN=$O(^AUPNFH("AC",APCHSPAT,APCHSDFN)) Q:APCHSDFN="" D FHDSP
; <CLEANUP>
Q
FHDSP S BHC=BHC+1
I BHC=1 W !,BHTDAT,?14,BHZ," Status: "
S BHSTAT=""
I 'BHR,BHSDFN 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 W BHSTAT,!
I BHR,$P(^AUPNFHR(BHR,0),U,5)]""!($P(^AUPNFHR(BHR,0),U,6)]"") D
.I BHC=1 W ?14,"Age at Death: ",$$VAL^XBDIQ1(9000014.1,BHR,.05)," Cause of Death: ",$S($P(^AUPNFHR(BHR,0),U,6)]"":$P(^AUPNFHR(BHR,0),U,6),1:"Data Not Available"),!
I BHR,$P(^AUPNFHR(BHR,0),U,7)]""!($P(^AUPNFHR(BHR,0),U,8)]"") D
.I BHC=1 W ?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:""),! ;_" Date Updated: "_$$VAL^XBDIQ1(9000014.1,R,.09)
Q:'BHSDFN
S BHSN=^AUPNFH(BHSDFN,0)
S BHSICD=$P(BHSN,U,1) D GETICDDX^BHSUTL
;S Y=$P(APCHSN,U,3) X APCHSCVD S APCHSDAT=Y
S BHSNRQ=$P(BHSN,U,4)
D GETNARR^BHSUTL
D CKP^GMTSUP Q:$D(GMTSQIT) ; W !,APCHSDAT
S (X,R,S,N,A,P)=""
;S R=$$VAL^XBDIQ1(9000014,BHSDFN,.07)
;S BHSNRQ=BHSNRQ_" ("_$$VAL^XBDIQ1(9000014,BHSDFN,.01)_")"
S A="" I BHSDFN S A=$$VAL^XBDIQ1(9000014,BHSDFN,.11) I A="" S A=$$VAL^XBDIQ1(9000014,BHSDFN,.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=BHSNRQ
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 BHSICL=14,BHSNRQ=X
D PRTICD^BHSUTL
Q
;
PWH ;EP - called from component Patient wellness Handout
; <SETUP>
N BHSPAT
S BHSPAT=DFN
D CKP^GMTSUP Q:$D(GMTSQIT)
; <DISPLAY>
K BHTFH
S BHSIVD="" F S BHSIVD=$O(^APCHPWHL("AA",BHSPAT,BHSIVD)) Q:BHSIVD=""!(BHSIVD>GMTSDLM) D
.S BHIEN=0 F S BHIEN=$O(^APCHPWHL("AA",BHSPAT,BHSIVD,BHIEN)) Q:BHIEN'=+BHIEN D
..S BHSN=$G(^APCHPWHL(BHIEN,0))
..I BHSN="" Q
..S N=$$VAL^XBDIQ1(9001027,BHIEN,.02)
..S $P(BHTFH(N),U)=$P($G(BHTFH(N)),U)+1
..S P=$P(BHTFH(N),U)+1
..S $P(BHTFH(N),U,P)=$$DATE^BHSMU($P(^APCHPWHL(BHIEN,0),U,4))
;now display
I '$D(BHTFH) 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 BHSN="" F S BHSN=$O(BHTFH(BHSN)) Q:BHSN=""!($D(GMTSQIT)) D
.W ?2,BHSN,?34,$P(BHTFH(BHSN),U) W ?42,$P(BHTFH(BHSN),U,2)," ",$P(BHTFH(BHSN),U,3)," ",$P(BHTFH(BHSN),U,4)," ",$P(BHTFH(BHSN),U,5),!
.Q
K BHTFH,BHSN
Q
BHSFH1 ; IHS/MSC/MGH - Health summary for family history ;01-Aug-2013 17:22;DU
+1 ;;1.0;HEALTH SUMMARY COMONENTS;**8**;March 17, 2006;Build 22
+2 ;
+3 ;
FMH ;EP - ******* FAMILY HISTORY * 9000014 *******
+1 ; <SETUP>
+2 ;Same as other family history but without SNOMED codes displayed
+3 NEW BHSPAT,BHSQ
+4 SET BHSPAT=DFN
+5 ;no family history to display
IF '$DATA(^AUPNFH("AC",BHSPAT))
IF '$DATA(^AUPNFHR("AA",BHSPAT))
QUIT
+6 DO CKP^GMTSUP
IF $DATA(GMTSQIT)
QUIT
+7 ; <DISPLAY>
+8 KILL APCHTFH
+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 R=$PIECE(^AUPNFH(BHSDFN,0),U,9)
+12 IF R=""
SET R="Z"
SET S=$$VAL^XBDIQ1(9000014,BHSDFN,.07)
SET Z=S_" "
SET O=8
Begin DoDot:2
+13 IF S=""
SET S="UNKNOWN"
SET Z="UNKNOWN "
End DoDot:2
GOTO FMH1
+14 SET S=$$VAL^XBDIQ1(9000014.1,R,.01)
SET Z=S_" "_$PIECE(^AUPNFHR(R,0),U,3)
+15 SET O=$PIECE(^AUPNFHR(R,0),U)
IF O
SET O=$PIECE($GET(^AUTTRLSH(O,21)),U,3)
+16 IF 'O
SET O=8
FMH1 SET APCHTFH(O,S,Z,R,(9999999-$$LDM(BHSDFN)),BHSDFN)=""
End DoDot:1
+1 ;get relations with no conditions
+2 SET X=0
FOR
SET X=$ORDER(^AUPNFHR("AA",BHSPAT,X))
IF X'=+X
QUIT
SET Y=0
FOR
SET Y=$ORDER(^AUPNFHR("AA",BHSPAT,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 BHO=0
FOR
SET BHO=$ORDER(APCHTFH(BHO))
IF BHO'=+BHO
QUIT
DO FMH2
FMHX KILL BHSDFN,BHSN,BHSICD,BHSDAT,BHSNRQ,BHSICL,BHSDFN,APCHTFH,BHS,BHZ,BHR,BHD,BHO
+1 KILL BHC,BHIEN,BHSIVD,BHSTAT,BHTD,BHTDAT,A,T,N,O,P,R,S,X,Y,Z
+2 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 BHS=""
SET BHC=0
FOR
SET BHS=$ORDER(APCHTFH(BHO,BHS))
IF BHS=""!($DATA(GMTSQIT))
QUIT
Begin DoDot:1
+2 SET BHZ=""
FOR
SET BHZ=$ORDER(APCHTFH(BHO,BHS,BHZ))
IF BHZ=""!($DATA(GMTSQIT))
QUIT
Begin DoDot:2
+3 SET BHR=""
FOR
SET BHR=$ORDER(APCHTFH(BHO,BHS,BHZ,BHR))
IF BHR=""!($DATA(GMTSQIT))
QUIT
Begin DoDot:3
+4 SET BHTD=$ORDER(APCHTFH(BHO,BHS,BHZ,BHR,0))
SET BHTD=(9999999-BHTD)
SET X=BHTD
DO REGDT4^GMTSU
SET BHTDAT=X
IF BHTDAT="/"
SET BHTDAT=""
+5 SET BHD=""
SET BHC=0
FOR
SET BHD=$ORDER(APCHTFH(BHO,BHS,BHZ,BHR,BHD))
IF BHD=""!($DATA(GMTSQIT))
QUIT
Begin DoDot:4
+6 SET BHSDFN=""
FOR
SET BHSDFN=$ORDER(APCHTFH(BHO,BHS,BHZ,BHR,BHD,BHSDFN))
IF BHSDFN=""!($DATA(GMTSQIT))
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 BHC=BHC+1
+1 IF BHC=1
WRITE !,BHTDAT,?14,BHZ," Status: "
+2 SET BHSTAT=""
+3 IF 'BHR
IF BHSDFN
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
WRITE BHSTAT,!
+7 IF BHR
IF $PIECE(^AUPNFHR(BHR,0),U,5)]""!($PIECE(^AUPNFHR(BHR,0),U,6)]"")
Begin DoDot:1
+8 IF BHC=1
WRITE ?14,"Age at Death: ",$$VAL^XBDIQ1(9000014.1,BHR,.05)," Cause of Death: ",$SELECT($PIECE(^AUPNFHR(BHR,0),U,6)]"":$PIECE(^AUPNFHR(BHR,0),U,6),1:"Data Not Available"),!
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
WRITE ?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:""),!
End DoDot:1
+11 IF 'BHSDFN
QUIT
+12 SET BHSN=^AUPNFH(BHSDFN,0)
+13 SET BHSICD=$PIECE(BHSN,U,1)
DO GETICDDX^BHSUTL
+14 ;S Y=$P(APCHSN,U,3) X APCHSCVD S APCHSDAT=Y
+15 SET BHSNRQ=$PIECE(BHSN,U,4)
+16 DO GETNARR^BHSUTL
+17 ; W !,APCHSDAT
DO CKP^GMTSUP
IF $DATA(GMTSQIT)
QUIT
+18 SET (X,R,S,N,A,P)=""
+19 ;S R=$$VAL^XBDIQ1(9000014,BHSDFN,.07)
+20 ;S BHSNRQ=BHSNRQ_" ("_$$VAL^XBDIQ1(9000014,BHSDFN,.01)_")"
+21 SET A=""
IF BHSDFN
SET A=$$VAL^XBDIQ1(9000014,BHSDFN,.11)
IF A=""
SET A=$$VAL^XBDIQ1(9000014,BHSDFN,.05)
+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=BHSNRQ
+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 BHSICL=14
SET BHSNRQ=X
+31 DO PRTICD^BHSUTL
+32 QUIT
+33 ;
PWH ;EP - called from component Patient wellness Handout
+1 ; <SETUP>
+2 NEW BHSPAT
+3 SET BHSPAT=DFN
+4 DO CKP^GMTSUP
IF $DATA(GMTSQIT)
QUIT
+5 ; <DISPLAY>
+6 KILL BHTFH
+7 SET BHSIVD=""
FOR
SET BHSIVD=$ORDER(^APCHPWHL("AA",BHSPAT,BHSIVD))
IF BHSIVD=""!(BHSIVD>GMTSDLM)
QUIT
Begin DoDot:1
+8 SET BHIEN=0
FOR
SET BHIEN=$ORDER(^APCHPWHL("AA",BHSPAT,BHSIVD,BHIEN))
IF BHIEN'=+BHIEN
QUIT
Begin DoDot:2
+9 SET BHSN=$GET(^APCHPWHL(BHIEN,0))
+10 IF BHSN=""
QUIT
+11 SET N=$$VAL^XBDIQ1(9001027,BHIEN,.02)
+12 SET $PIECE(BHTFH(N),U)=$PIECE($GET(BHTFH(N)),U)+1
+13 SET P=$PIECE(BHTFH(N),U)+1
+14 SET $PIECE(BHTFH(N),U,P)=$$DATE^BHSMU($PIECE(^APCHPWHL(BHIEN,0),U,4))
End DoDot:2
End DoDot:1
+15 ;now display
+16 IF '$DATA(BHTFH)
WRITE "No Patient Wellness Handouts given to this patient.",!
QUIT
+17 WRITE ?2,"PATIENT WELLNESS HANDOUT TYPE",?34,"# given",?42,"Dates Last 4 Given to Patient",!
+18 WRITE $$REPEAT^XLFSTR("-",79),!
+19 SET BHSN=""
FOR
SET BHSN=$ORDER(BHTFH(BHSN))
IF BHSN=""!($DATA(GMTSQIT))
QUIT
Begin DoDot:1
+20 WRITE ?2,BHSN,?34,$PIECE(BHTFH(BHSN),U)
WRITE ?42,$PIECE(BHTFH(BHSN),U,2)," ",$PIECE(BHTFH(BHSN),U,3)," ",$PIECE(BHTFH(BHSN),U,4)," ",$PIECE(BHTFH(BHSN),U,5),!
+21 QUIT
End DoDot:1
+22 KILL BHTFH,BHSN
+23 QUIT
