- 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
