BHSBDEM ;IHS/MSC/MGH - Health Summary Demographics ;14-Jan-2014 14:58;DU
;;1.0;HEALTH SUMMARY COMPONENTS;**4,6,9**;March 17,2006;Build 16
;=================================================================
; IHS/CMI/LAB - PART 1A OF APCHS -- SUMMARY PRODUCTION COMPONENTS IHS/MSC/MGH - Health Summary Demographics ;29-Mar-2010 17:14;MGH
;;1.0;HEALTH SUMMARY COMPONENTS;**1,2,3,4**;March 17,2006;
;;2.0;IHS PCC SUITE;**2**;MAY 14, 2009 ;
;Patch 6 update for preferred language
;
BDEMOG ; ******************** BRIEF DEMOGRAPHICS - W/ADV DIRECTIVES ********************
; <SETUP>
N BHSPAT,BHSDN,BHDNAM,BHSDOB,BHSADR,BHSZ,BHSX,BHPLNG
S BHSPAT=DFN
S BHSN=^DPT(BHSPAT,0)
S BHSNAM=$P(BHSN,U,1)
S Y=$P(BHSN,U,3)
I 'Y S BHSDOB="<no date of birth recorded>"
E X ^DD("DD") S BHSDOB=Y
S BHSADR=""
I $D(^DPT(BHSPAT,.11)) S BHSN=^(.11) F BHSI=1:1:6 S BHSP=$P(BHSN,U,BHSI) I BHSP]"" S:BHSI=5 BHSP=$P(^DIC(5,BHSP,0),U,2) S BHSADR=BHSADR_","_BHSP
I $D(^DPT(BHSPAT,.13)) S BHHPH=$P($G(^DPT(BHSPAT,.13)),U),BHWPH=$P($G(^DPT(BHSPAT,.13)),U,2) ;IHS/CMI/GRL
S BHSADR=$E(BHSADR,2,255)
BDEMDSP ; <DISPLAY>
D CKP^GMTSUP Q:$D(GMTSQIT)
I $$DOD^AUPNPAT(BHSPAT)]""!($$VAL^XBDIQ1(9000001,BHSPAT,1114)]"") D
.W "*** DOD: ",$$VAL^XBDIQ1(2,BHSPAT,.351),!
.W "*** CAUSE OF DEATH: " I $$VAL^XBDIQ1(9000001,BHSPAT,1114)]"" D I 1
..W $$VAL^XBDIQ1(9000001,BHSPAT,1114)
..K BHSDSC
..;Patch 9 changed API for ICD-10
..I $$AICD^BHSUTL D
...S BHSDSC=$$ICDD^ICDEX($$VAL^XBDIQ1(9000001,BHSPAT,1114),"BHSDSC",$$DOD^AUPNPAT(BHSPAT)) I $P(BHSDSC,U)=-1 S BHSDSC(1)=$P($$ICDDX^ICDEX($P(^AUPNPAT(BHSPAT,11),U,14),$$DOD^AUPNPAT(BHSPAT)),U,4)
..E S BHSDSC=$$ICDD^ICDCODE($$VAL^XBDIQ1(9000001,BHSPAT,1114),"BHSDSC",$$DOD^AUPNPAT(BHSPAT)) I $P(BHSDSC,U)=-1 S BHSDSC(1)=$P($$ICDDX^ICDCODE($P(^AUPNPAT(BHSPAT,11),U,14),$$DOD^AUPNPAT(BHSPAT)),U,4)
..K ^UTILITY($J,"W")
..S BHSX=0
..S DIWL=0,DIWR=45 F S BHSX=$O(BHSDSC(BHSX)) Q:BHSX'=+BHSX!($D(GMTSQIT)) D
...S X=BHSDSC(BHSX)
...Q:X="CODE TEXT MAY BE INACCURATE"
...Q:X=" "
...D ^DIWP
..S BHSZ=0 F S BHSZ=$O(^UTILITY($J,"W",DIWL,BHSZ)) Q:BHSZ'=+BHSZ D
...Q:$D(GMTSQIT)
...W ?28,^UTILITY($J,"W",DIWL,BHSZ,0),!
.E W !!
.;W !
K ^UTILITY($J,"W"),BHSDSC,DIWL,BHSX,BHSZ,DIWL,DIW
W !,BHSNAM," ",$$VAL^XBDIQ1(2,BHSPAT,.02)," DOB: ",BHSDOB," AGE: ",$$AGE^AUPNPAT(BHSPAT,DT)," SSN: ",$$SSN^BHSDEM(BHSPAT),!
W "TRIBE: ",$$VAL^XBDIQ1(9000001,DFN,1108)," ",$$VAL^XBDIQ1(9000001,DFN,1112),!
I $D(DUZ(2)),DUZ(2),$D(^AUPNPAT(BHSPAT,41,DUZ(2))) S BHSFP=DUZ(2),BHSFAC=$P(^AUPNPAT(BHSPAT,41,BHSFP,0),U,2) W $P(^DIC(4,BHSFP,0),U,1)," HEALTH RECORD NUMBER: ",BHSFAC,!
W:BHSADR]"" BHSADR,!
W "Home Phone: ",$S($G(BHHPH)]"":BHHPH,1:"None")_" "_"Work Phone: ",$S($G(BHWPH)]"":BHWPH,1:"None"),! ;IHS/CMI/GRL
S BHPLNG=$$PREFLANG^APCLAPI7(BHSPAT,DT,"E")
I BHPLNG]"" W "Preferred Language: ",BHPLNG,!
;ADVANCE DIRECTIVES
I $D(^AUPNADVD(BHSPAT,0)) D
.D CKP^GMTSUP Q:$D(GMTSQIT)
.W "Advance Directives: "
.S BHSI=0 F S BHSI=$O(^AUPNADVD(BHSPAT,11,"B",BHSI)) Q:BHSI="" S BHSN=0 F S BHSN=$O(^AUPNADVD(BHSPAT,11,"B",BHSI,BHSN)) Q:BHSN="" S BHSP=BHSN
.S BHIEN=BHSP_","_BHSPAT_"," W ?20,$$GET1^DIQ(9000040.11,BHIEN,.02)," ",$$GET1^DIQ(9000040.11,BHIEN,.03)," Updated: ",$$GET1^DIQ(9000040.11,BHIEN,.01),!
I '$D(^AUPNADVD(BHSPAT,0)) W "Advance Directives: No information on file.",!
D CKP^GMTSUP Q:$D(GMTSQIT)
W "Last Registration Update: ",$$VAL^XBDIQ1(9000001,BHSPAT,.03),!
; <CLEANUP>
BDEMOGX K BHSN,BHSFP,BHSFAC,BHSNAM,BHSDOB,BHSADR,BHSP,BHSI,BHIEN
K BHHPH,BHWPH
Q
;
HOMELOC ; ******************** LOCATION OF HOME ********************
; <SETUP>
Q:'$O(^AUPNPAT(BHSPAT,12,0))
; <DISPLAY>
F BHSI=0:0 S BHSI=$O(^AUPNPAT(BHSPAT,12,BHSI)) Q:'BHSI D CKP^GMTSUP Q:$D(GMTSQIT) W ^AUPNPAT(BHSPAT,12,BHSI,0),!
; <CLEANUP>
HOMELOCX K BHSI
Q
BHSBDEM ;IHS/MSC/MGH - Health Summary Demographics ;14-Jan-2014 14:58;DU
+1 ;;1.0;HEALTH SUMMARY COMPONENTS;**4,6,9**;March 17,2006;Build 16
+2 ;=================================================================
+3 ; IHS/CMI/LAB - PART 1A OF APCHS -- SUMMARY PRODUCTION COMPONENTS IHS/MSC/MGH - Health Summary Demographics ;29-Mar-2010 17:14;MGH
+4 ;;1.0;HEALTH SUMMARY COMPONENTS;**1,2,3,4**;March 17,2006;
+5 ;;2.0;IHS PCC SUITE;**2**;MAY 14, 2009 ;
+6 ;Patch 6 update for preferred language
+7 ;
BDEMOG ; ******************** BRIEF DEMOGRAPHICS - W/ADV DIRECTIVES ********************
+1 ; <SETUP>
+2 NEW BHSPAT,BHSDN,BHDNAM,BHSDOB,BHSADR,BHSZ,BHSX,BHPLNG
+3 SET BHSPAT=DFN
+4 SET BHSN=^DPT(BHSPAT,0)
+5 SET BHSNAM=$PIECE(BHSN,U,1)
+6 SET Y=$PIECE(BHSN,U,3)
+7 IF 'Y
SET BHSDOB="<no date of birth recorded>"
+8 IF '$TEST
XECUTE ^DD("DD")
SET BHSDOB=Y
+9 SET BHSADR=""
+10 IF $DATA(^DPT(BHSPAT,.11))
SET BHSN=^(.11)
FOR BHSI=1:1:6
SET BHSP=$PIECE(BHSN,U,BHSI)
IF BHSP]""
IF BHSI=5
SET BHSP=$PIECE(^DIC(5,BHSP,0),U,2)
SET BHSADR=BHSADR_","_BHSP
+11 ;IHS/CMI/GRL
IF $DATA(^DPT(BHSPAT,.13))
SET BHHPH=$PIECE($GET(^DPT(BHSPAT,.13)),U)
SET BHWPH=$PIECE($GET(^DPT(BHSPAT,.13)),U,2)
+12 SET BHSADR=$EXTRACT(BHSADR,2,255)
BDEMDSP ; <DISPLAY>
+1 DO CKP^GMTSUP
IF $DATA(GMTSQIT)
QUIT
+2 IF $$DOD^AUPNPAT(BHSPAT)]""!($$VAL^XBDIQ1(9000001,BHSPAT,1114)]"")
Begin DoDot:1
+3 WRITE "*** DOD: ",$$VAL^XBDIQ1(2,BHSPAT,.351),!
+4 WRITE "*** CAUSE OF DEATH: "
IF $$VAL^XBDIQ1(9000001,BHSPAT,1114)]""
Begin DoDot:2
+5 WRITE $$VAL^XBDIQ1(9000001,BHSPAT,1114)
+6 KILL BHSDSC
+7 ;Patch 9 changed API for ICD-10
+8 IF $$AICD^BHSUTL
Begin DoDot:3
+9 SET BHSDSC=$$ICDD^ICDEX($$VAL^XBDIQ1(9000001,BHSPAT,1114),"BHSDSC",$$DOD^AUPNPAT(BHSPAT))
IF $PIECE(BHSDSC,U)=-1
SET BHSDSC(1)=$PIECE($$ICDDX^ICDEX($PIECE(^AUPNPAT(BHSPAT,11),U,14),$$DOD^AUPNPAT(BHSPAT)),U,4)
End DoDot:3
+10 IF '$TEST
SET BHSDSC=$$ICDD^ICDCODE($$VAL^XBDIQ1(9000001,BHSPAT,1114),"BHSDSC",$$DOD^AUPNPAT(BHSPAT))
IF $PIECE(BHSDSC,U)=-1
SET BHSDSC(1)=$PIECE($$ICDDX^ICDCODE($PIECE(^AUPNPAT(BHSPAT,11),U,14),$$DOD^AUPNPAT(BHSPAT)),U,4)
+11 KILL ^UTILITY($JOB,"W")
+12 SET BHSX=0
+13 SET DIWL=0
SET DIWR=45
FOR
SET BHSX=$ORDER(BHSDSC(BHSX))
IF BHSX'=+BHSX!($DATA(GMTSQIT))
QUIT
Begin DoDot:3
+14 SET X=BHSDSC(BHSX)
+15 IF X="CODE TEXT MAY BE INACCURATE"
QUIT
+16 IF X=" "
QUIT
+17 DO ^DIWP
End DoDot:3
+18 SET BHSZ=0
FOR
SET BHSZ=$ORDER(^UTILITY($JOB,"W",DIWL,BHSZ))
IF BHSZ'=+BHSZ
QUIT
Begin DoDot:3
+19 IF $DATA(GMTSQIT)
QUIT
+20 WRITE ?28,^UTILITY($JOB,"W",DIWL,BHSZ,0),!
End DoDot:3
End DoDot:2
IF 1
+21 IF '$TEST
WRITE !!
+22 ;W !
End DoDot:1
+23 KILL ^UTILITY($JOB,"W"),BHSDSC,DIWL,BHSX,BHSZ,DIWL,DIW
+24 WRITE !,BHSNAM," ",$$VAL^XBDIQ1(2,BHSPAT,.02)," DOB: ",BHSDOB," AGE: ",$$AGE^AUPNPAT(BHSPAT,DT)," SSN: ",$$SSN^BHSDEM(BHSPAT),!
+25 WRITE "TRIBE: ",$$VAL^XBDIQ1(9000001,DFN,1108)," ",$$VAL^XBDIQ1(9000001,DFN,1112),!
+26 IF $DATA(DUZ(2))
IF DUZ(2)
IF $DATA(^AUPNPAT(BHSPAT,41,DUZ(2)))
SET BHSFP=DUZ(2)
SET BHSFAC=$PIECE(^AUPNPAT(BHSPAT,41,BHSFP,0),U,2)
WRITE $PIECE(^DIC(4,BHSFP,0),U,1)," HEALTH RECORD NUMBER: ",BHSFAC,!
+27 IF BHSADR]""
WRITE BHSADR,!
+28 ;IHS/CMI/GRL
WRITE "Home Phone: ",$SELECT($GET(BHHPH)]"":BHHPH,1:"None")_" "_"Work Phone: ",$SELECT($GET(BHWPH)]"":BHWPH,1:"None"),!
+29 SET BHPLNG=$$PREFLANG^APCLAPI7(BHSPAT,DT,"E")
+30 IF BHPLNG]""
WRITE "Preferred Language: ",BHPLNG,!
+31 ;ADVANCE DIRECTIVES
+32 IF $DATA(^AUPNADVD(BHSPAT,0))
Begin DoDot:1
+33 DO CKP^GMTSUP
IF $DATA(GMTSQIT)
QUIT
+34 WRITE "Advance Directives: "
+35 SET BHSI=0
FOR
SET BHSI=$ORDER(^AUPNADVD(BHSPAT,11,"B",BHSI))
IF BHSI=""
QUIT
SET BHSN=0
FOR
SET BHSN=$ORDER(^AUPNADVD(BHSPAT,11,"B",BHSI,BHSN))
IF BHSN=""
QUIT
SET BHSP=BHSN
+36 SET BHIEN=BHSP_","_BHSPAT_","
WRITE ?20,$$GET1^DIQ(9000040.11,BHIEN,.02)," ",$$GET1^DIQ(9000040.11,BHIEN,.03)," Updated: ",$$GET1^DIQ(9000040.11,BHIEN,.01),!
End DoDot:1
+37 IF '$DATA(^AUPNADVD(BHSPAT,0))
WRITE "Advance Directives: No information on file.",!
+38 DO CKP^GMTSUP
IF $DATA(GMTSQIT)
QUIT
+39 WRITE "Last Registration Update: ",$$VAL^XBDIQ1(9000001,BHSPAT,.03),!
+40 ; <CLEANUP>
BDEMOGX KILL BHSN,BHSFP,BHSFAC,BHSNAM,BHSDOB,BHSADR,BHSP,BHSI,BHIEN
+1 KILL BHHPH,BHWPH
+2 QUIT
+3 ;
HOMELOC ; ******************** LOCATION OF HOME ********************
+1 ; <SETUP>
+2 IF '$ORDER(^AUPNPAT(BHSPAT,12,0))
QUIT
+3 ; <DISPLAY>
+4 FOR BHSI=0:0
SET BHSI=$ORDER(^AUPNPAT(BHSPAT,12,BHSI))
IF 'BHSI
QUIT
DO CKP^GMTSUP
IF $DATA(GMTSQIT)
QUIT
WRITE ^AUPNPAT(BHSPAT,12,BHSI,0),!
+5 ; <CLEANUP>
HOMELOCX KILL BHSI
+1 QUIT
