- BHSFH ; IHS/MSC/MGH - Health summary for family history ;17-Jul-2014 14:19;DU
- ;;1.0;HEALTH SUMMARY COMONENTS;**3,8,9**;March 17, 2006;Build 16
- ;
- ;
- FMH ;EP - ******* FAMILY HISTORY * 9000014 *******
- ; <SETUP>
- 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 BHSNRQ=BHSNRQ_" ("_$$VAL^XBDIQ1(9000014,BHSDFN,.14)_")"
- 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
- BHSFH ; IHS/MSC/MGH - Health summary for family history ;17-Jul-2014 14:19;DU
- +1 ;;1.0;HEALTH SUMMARY COMONENTS;**3,8,9**;March 17, 2006;Build 16
- +2 ;
- +3 ;
- FMH ;EP - ******* FAMILY HISTORY * 9000014 *******
- +1 ; <SETUP>
- +2 NEW BHSPAT,BHSQ
- +3 SET BHSPAT=DFN
- +4 ;no family history to display
- IF '$DATA(^AUPNFH("AC",BHSPAT))
- IF '$DATA(^AUPNFHR("AA",BHSPAT))
- QUIT
- +5 DO CKP^GMTSUP
- IF $DATA(GMTSQIT)
- QUIT
- +6 ; <DISPLAY>
- +7 KILL APCHTFH
- +8 SET BHSDFN=0
- FOR
- SET BHSDFN=$ORDER(^AUPNFH("AC",BHSPAT,BHSDFN))
- IF 'BHSDFN
- QUIT
- Begin DoDot:1
- +9 ;bad xref
- IF '$DATA(^AUPNFH(BHSDFN,0))
- QUIT
- +10 SET R=$PIECE(^AUPNFH(BHSDFN,0),U,9)
- +11 IF R=""
- SET R="Z"
- SET S=$$VAL^XBDIQ1(9000014,BHSDFN,.07)
- SET Z=S_" "
- SET O=8
- Begin DoDot:2
- +12 IF S=""
- SET S="UNKNOWN"
- SET Z="UNKNOWN "
- End DoDot:2
- GOTO FMH1
- +13 SET S=$$VAL^XBDIQ1(9000014.1,R,.01)
- SET Z=S_" "_$PIECE(^AUPNFHR(R,0),U,3)
- +14 SET O=$PIECE(^AUPNFHR(R,0),U)
- IF O
- SET O=$PIECE($GET(^AUTTRLSH(O,21)),U,3)
- +15 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 BHSNRQ=BHSNRQ_" ("_$$VAL^XBDIQ1(9000014,BHSDFN,.14)_")"
- +22 SET A=""
- IF BHSDFN
- SET A=$$VAL^XBDIQ1(9000014,BHSDFN,.11)
- IF A=""
- SET A=$$VAL^XBDIQ1(9000014,BHSDFN,.05)
- +23 ;S S=$$VAL^XBDIQ1(9000014,APCHSDFN,.06)
- +24 ;S P=$$VAL^XBDIQ1(9000014,APCHSDFN,.08)
- +25 ;S X=R
- +26 ;I X]"" S X=X_"; "
- +27 SET X=BHSNRQ
- +28 SET X=X_$SELECT(A]"":"; Age at Onset: "_A,1:"; Age at Onset: None")
- +29 ;S X=X_$S(S]"":"; Status: "_S,1:"; Status: None")
- +30 ;S X=X_$S(P]"":"; Documented By: "_P,1:"")
- +31 SET BHSICL=14
- SET BHSNRQ=X
- +32 DO PRTICD^BHSUTL
- +33 QUIT
- +34 ;
- 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
