- 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
