APCHS1C ; IHS/CMI/LAB - PART 1A OF APCHS -- SUMMARY PRODUCTION COMPONENTS ;
;;2.0;IHS PCC SUITE;**2,5,11**;MAY 14, 2009;Build 58
;
;
BDEMOG ; ******************** BRIEF DEMOGRAPHICS - W/ADV DIRECTIVES ********************
; <SETUP>
S APCHSN=^DPT(APCHSPAT,0)
S APCHSNAM=$P(APCHSN,U,1)
S Y=$P(APCHSN,U,3)
I 'Y S APCHSDOB="<no date of birth recorded>"
E X ^DD("DD") S APCHSDOB=Y
S APCHSADR=""
I $D(^DPT(APCHSPAT,.11)) S APCHSN=^(.11) F APCHSI=1:1:6 S APCHSP=$P(APCHSN,U,APCHSI) I APCHSP]"" S:APCHSI=5 APCHSP=$P(^DIC(5,APCHSP,0),U,2) S APCHSADR=APCHSADR_","_APCHSP
I $D(^DPT(APCHSPAT,.13)) S APCHHPH=$P($G(^DPT(APCHSPAT,.13)),U),APCHWPH=$P($G(^DPT(APCHSPAT,.13)),U,2) ;IHS/CMI/GRL
S APCHSADR=$E(APCHSADR,2,255)
BDEMDSP ; <DISPLAY>
X APCHSBRK
I $$DOD^AUPNPAT(APCHSPAT)]""!($$VAL^XBDIQ1(9000001,APCHSPAT,1114)]"") D
.W "*** DOD: ",$$VAL^XBDIQ1(2,APCHSPAT,.351),!
.W "*** CAUSE OF DEATH: " I $$VAL^XBDIQ1(9000001,APCHSPAT,1114)]"" D I 1
..W $$VAL^XBDIQ1(9000001,APCHSPAT,1114)
..K APCHSDSC
..S APCHSDSC=$$ICDD^ICDEX($$VAL^XBDIQ1(9000001,APCHSPAT,1114),"APCHSDSC",$$DOD^AUPNPAT(APCHSPAT)) I $P(APCHSDSC,U)=-1 S APCHSDSC(1)=$P($$ICDDX^ICDEX($P(^AUPNPAT(APCHSPAT,11),U,14),$$DOD^AUPNPAT(APCHSPAT)),U,4)
..K ^UTILITY($J,"W")
..S APCHSX=0
..S DIWL=0,DIWR=45 F S APCHSX=$O(APCHSDSC(APCHSX)) Q:APCHSX'=+APCHSX!($D(APCHSQIT)) D
...S X=APCHSDSC(APCHSX)
...Q:X="CODE TEXT MAY BE INACCURATE"
...Q:X=" "
...D ^DIWP
..S APCHSZ=0 F S APCHSZ=$O(^UTILITY($J,"W",DIWL,APCHSZ)) Q:APCHSZ'=+APCHSZ D
...X APCHSCKP Q:$D(APCHSQIT)
...W ?28,^UTILITY($J,"W",DIWL,APCHSZ,0),!
.E W !
K ^UTILITY($J,"W"),APCHSDSC,DIWL,APCHSX,APCHSZ,DIWL,DIWR
Q:$D(APCHSQIT)
W !,APCHSNAM," ",$$VAL^XBDIQ1(2,APCHSPAT,.02)," DOB: ",APCHSDOB," AGE: ",$$AGE^AUPNPAT(APCHSPAT,DT)," SSN: ",$$SSN^APCHS1(APCHSPAT),!
W "TRIBE: ",$$VAL^XBDIQ1(9000001,DFN,1108)," ",$$VAL^XBDIQ1(9000001,DFN,1112),!
I $D(DUZ(2)),DUZ(2),$D(^AUPNPAT(APCHSPAT,41,DUZ(2))) S APCHSFP=DUZ(2),APCHSFAC=$P(^AUPNPAT(APCHSPAT,41,APCHSFP,0),U,2) W $P(^DIC(4,APCHSFP,0),U,1)," HEALTH RECORD NUMBER: ",APCHSFAC,!
W:APCHSADR]"" APCHSADR,!
W "Home Phone: ",$S($G(APCHHPH)]"":APCHHPH,1:"None")_" "_"Work Phone: ",$S($G(APCHWPH)]"":APCHWPH,1:"None"),! ;IHS/CMI/GRL
S APCHPLNG=$$PREFLANG^APCLAPI7(APCHSPAT,DT,"E")
I APCHPLNG]"" W "Preferred Language: ",APCHPLNG,!
I $P($G(^AUPNPAT(APCHSPAT,40)),U,2)]"" W !,"Preferred Method of Receiving Reminders: ",$$VAL^XBDIQ1(9000001,APCHSPAT,4002),!
;ADVANCE DIRECTIVES
I $D(^AUPNADVD(APCHSPAT,0)) D
.X APCHSCKP Q:$D(APCHSQIT)
.W "Advance Directives: "
.S APCHSI=0 F S APCHSI=$O(^AUPNADVD(APCHSPAT,11,"B",APCHSI)) Q:APCHSI="" S APCHSN=0 F S APCHSN=$O(^AUPNADVD(APCHSPAT,11,"B",APCHSI,APCHSN)) Q:APCHSN="" S APCHSP=APCHSN
.S APCHIEN=APCHSP_","_APCHSPAT_"," W ?20,$$GET1^DIQ(9000040.11,APCHIEN,.02)," ",$$GET1^DIQ(9000040.11,APCHIEN,.03)," Updated: ",$$GET1^DIQ(9000040.11,APCHIEN,.01),!
I '$D(^AUPNADVD(APCHSPAT,0)) W "Advance Directives: No information on file.",!
X APCHSCKP Q:$D(APCHSQIT)
W "Last Registration Update: ",$$VAL^XBDIQ1(9000001,APCHSPAT,.03),!
; <CLEANUP>
BDEMOGX K APCHSN,APCHSFP,APCHSFAC,APCHSNAM,APCHSDOB,APCHSADR,APCHSP,APCHSI,APCHIEN
K APCHHPH,APCHWPH
Q
;
HOMELOC ; ******************** LOCATION OF HOME ********************
; <SETUP>
Q:'$O(^AUPNPAT(APCHSPAT,12,0))
X APCHSBRK
; <DISPLAY>
F APCHSI=0:0 S APCHSI=$O(^AUPNPAT(APCHSPAT,12,APCHSI)) Q:'APCHSI X APCHSCKP Q:$D(APCHSQIT) W ^AUPNPAT(APCHSPAT,12,APCHSI,0),!
; <CLEANUP>
HOMELOCX K APCHSI
Q
APCHS1C ; IHS/CMI/LAB - PART 1A OF APCHS -- SUMMARY PRODUCTION COMPONENTS ;
+1 ;;2.0;IHS PCC SUITE;**2,5,11**;MAY 14, 2009;Build 58
+2 ;
+3 ;
BDEMOG ; ******************** BRIEF DEMOGRAPHICS - W/ADV DIRECTIVES ********************
+1 ; <SETUP>
+2 SET APCHSN=^DPT(APCHSPAT,0)
+3 SET APCHSNAM=$PIECE(APCHSN,U,1)
+4 SET Y=$PIECE(APCHSN,U,3)
+5 IF 'Y
SET APCHSDOB="<no date of birth recorded>"
+6 IF '$TEST
XECUTE ^DD("DD")
SET APCHSDOB=Y
+7 SET APCHSADR=""
+8 IF $DATA(^DPT(APCHSPAT,.11))
SET APCHSN=^(.11)
FOR APCHSI=1:1:6
SET APCHSP=$PIECE(APCHSN,U,APCHSI)
IF APCHSP]""
IF APCHSI=5
SET APCHSP=$PIECE(^DIC(5,APCHSP,0),U,2)
SET APCHSADR=APCHSADR_","_APCHSP
+9 ;IHS/CMI/GRL
IF $DATA(^DPT(APCHSPAT,.13))
SET APCHHPH=$PIECE($GET(^DPT(APCHSPAT,.13)),U)
SET APCHWPH=$PIECE($GET(^DPT(APCHSPAT,.13)),U,2)
+10 SET APCHSADR=$EXTRACT(APCHSADR,2,255)
BDEMDSP ; <DISPLAY>
+1 XECUTE APCHSBRK
+2 IF $$DOD^AUPNPAT(APCHSPAT)]""!($$VAL^XBDIQ1(9000001,APCHSPAT,1114)]"")
Begin DoDot:1
+3 WRITE "*** DOD: ",$$VAL^XBDIQ1(2,APCHSPAT,.351),!
+4 WRITE "*** CAUSE OF DEATH: "
IF $$VAL^XBDIQ1(9000001,APCHSPAT,1114)]""
Begin DoDot:2
+5 WRITE $$VAL^XBDIQ1(9000001,APCHSPAT,1114)
+6 KILL APCHSDSC
+7 SET APCHSDSC=$$ICDD^ICDEX($$VAL^XBDIQ1(9000001,APCHSPAT,1114),"APCHSDSC",$$DOD^AUPNPAT(APCHSPAT))
IF $PIECE(APCHSDSC,U)=-1
SET APCHSDSC(1)=$PIECE($$ICDDX^ICDEX($PIECE(^AUPNPAT(APCHSPAT,11),U,14),$$DOD^AUPNPAT(APCHSPAT)),U,4)
+8 KILL ^UTILITY($JOB,"W")
+9 SET APCHSX=0
+10 SET DIWL=0
SET DIWR=45
FOR
SET APCHSX=$ORDER(APCHSDSC(APCHSX))
IF APCHSX'=+APCHSX!($DATA(APCHSQIT))
QUIT
Begin DoDot:3
+11 SET X=APCHSDSC(APCHSX)
+12 IF X="CODE TEXT MAY BE INACCURATE"
QUIT
+13 IF X=" "
QUIT
+14 DO ^DIWP
End DoDot:3
+15 SET APCHSZ=0
FOR
SET APCHSZ=$ORDER(^UTILITY($JOB,"W",DIWL,APCHSZ))
IF APCHSZ'=+APCHSZ
QUIT
Begin DoDot:3
+16 XECUTE APCHSCKP
IF $DATA(APCHSQIT)
QUIT
+17 WRITE ?28,^UTILITY($JOB,"W",DIWL,APCHSZ,0),!
End DoDot:3
End DoDot:2
IF 1
+18 IF '$TEST
WRITE !
End DoDot:1
+19 KILL ^UTILITY($JOB,"W"),APCHSDSC,DIWL,APCHSX,APCHSZ,DIWL,DIWR
+20 IF $DATA(APCHSQIT)
QUIT
+21 WRITE !,APCHSNAM," ",$$VAL^XBDIQ1(2,APCHSPAT,.02)," DOB: ",APCHSDOB," AGE: ",$$AGE^AUPNPAT(APCHSPAT,DT)," SSN: ",$$SSN^APCHS1(APCHSPAT),!
+22 WRITE "TRIBE: ",$$VAL^XBDIQ1(9000001,DFN,1108)," ",$$VAL^XBDIQ1(9000001,DFN,1112),!
+23 IF $DATA(DUZ(2))
IF DUZ(2)
IF $DATA(^AUPNPAT(APCHSPAT,41,DUZ(2)))
SET APCHSFP=DUZ(2)
SET APCHSFAC=$PIECE(^AUPNPAT(APCHSPAT,41,APCHSFP,0),U,2)
WRITE $PIECE(^DIC(4,APCHSFP,0),U,1)," HEALTH RECORD NUMBER: ",APCHSFAC,!
+24 IF APCHSADR]""
WRITE APCHSADR,!
+25 ;IHS/CMI/GRL
WRITE "Home Phone: ",$SELECT($GET(APCHHPH)]"":APCHHPH,1:"None")_" "_"Work Phone: ",$SELECT($GET(APCHWPH)]"":APCHWPH,1:"None"),!
+26 SET APCHPLNG=$$PREFLANG^APCLAPI7(APCHSPAT,DT,"E")
+27 IF APCHPLNG]""
WRITE "Preferred Language: ",APCHPLNG,!
+28 IF $PIECE($GET(^AUPNPAT(APCHSPAT,40)),U,2)]""
WRITE !,"Preferred Method of Receiving Reminders: ",$$VAL^XBDIQ1(9000001,APCHSPAT,4002),!
+29 ;ADVANCE DIRECTIVES
+30 IF $DATA(^AUPNADVD(APCHSPAT,0))
Begin DoDot:1
+31 XECUTE APCHSCKP
IF $DATA(APCHSQIT)
QUIT
+32 WRITE "Advance Directives: "
+33 SET APCHSI=0
FOR
SET APCHSI=$ORDER(^AUPNADVD(APCHSPAT,11,"B",APCHSI))
IF APCHSI=""
QUIT
SET APCHSN=0
FOR
SET APCHSN=$ORDER(^AUPNADVD(APCHSPAT,11,"B",APCHSI,APCHSN))
IF APCHSN=""
QUIT
SET APCHSP=APCHSN
+34 SET APCHIEN=APCHSP_","_APCHSPAT_","
WRITE ?20,$$GET1^DIQ(9000040.11,APCHIEN,.02)," ",$$GET1^DIQ(9000040.11,APCHIEN,.03)," Updated: ",$$GET1^DIQ(9000040.11,APCHIEN,.01),!
End DoDot:1
+35 IF '$DATA(^AUPNADVD(APCHSPAT,0))
WRITE "Advance Directives: No information on file.",!
+36 XECUTE APCHSCKP
IF $DATA(APCHSQIT)
QUIT
+37 WRITE "Last Registration Update: ",$$VAL^XBDIQ1(9000001,APCHSPAT,.03),!
+38 ; <CLEANUP>
BDEMOGX KILL APCHSN,APCHSFP,APCHSFAC,APCHSNAM,APCHSDOB,APCHSADR,APCHSP,APCHSI,APCHIEN
+1 KILL APCHHPH,APCHWPH
+2 QUIT
+3 ;
HOMELOC ; ******************** LOCATION OF HOME ********************
+1 ; <SETUP>
+2 IF '$ORDER(^AUPNPAT(APCHSPAT,12,0))
QUIT
+3 XECUTE APCHSBRK
+4 ; <DISPLAY>
+5 FOR APCHSI=0:0
SET APCHSI=$ORDER(^AUPNPAT(APCHSPAT,12,APCHSI))
IF 'APCHSI
QUIT
XECUTE APCHSCKP
IF $DATA(APCHSQIT)
QUIT
WRITE ^AUPNPAT(APCHSPAT,12,APCHSI,0),!
+6 ; <CLEANUP>
HOMELOCX KILL APCHSI
+1 QUIT
