APCHS1A ; IHS/CMI/LAB - PART 1A OF APCHS -- SUMMARY PRODUCTION COMPONENTS ;
;;2.0;IHS PCC SUITE;**2,5,11**;MAY 14, 2009;Build 58
;IHS/CMI/LAB - added ssn and pcp to brief demo
;
BDEMOG ; ******************** BRIEF DEMOGRAPHICS ********************
; <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," DOB: ",APCHSDOB," SSN: ",$$SSN^APCHS1(APCHSPAT),! ;$P(^DPT(APCHSPAT,0),U,9),! ;IHS/CMI/LAB - added SSN
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),!
I $O(^BDPRECN("C",APCHSPAT,0)) D BDPDISP^APCHS1 G BDEMOGX
W:$P($G(^AUPNPAT(APCHSPAT,0)),U,14)]"" "DESIGNATED PRIMARY CARE PROVIDER: ",$$VAL^XBDIQ1(9000001,.APCHSPAT,.14),!
;IHS/CMMI/LAB - added next 3 lines per ANMC 2/12/01
W:$P($G(^BWP(APCHSPAT,0)),U,25) "WOMEN'S HEALTH DESIGNATED PROVIDER: ",$$VAL^XBDIQ1(9002086,APCHSPAT,.25),!
W:$P($G(^AUPNPAT(APCHSPAT,17)),U,1) "PRIMARY MENTAL HEALTH PROVIDER: ",$E($$VAL^XBDIQ1(9000001,APCHSPAT,1701),1,22),!
W:$P($G(^AUPNPAT(APCHSPAT,17)),U,4) "SECONDARY MENTAL HEALTH PROVIDER: ",$$VAL^XBDIQ1(9000001,APCHSPAT,1704),!
; <CLEANUP>
BDEMOGX K APCHSN,APCHSFP,APCHSFAC,APCHSNAM,APCHSDOB,APCHSADR,APCHSP,APCHSI
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
APCHS1A ; 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 ;IHS/CMI/LAB - added ssn and pcp to brief demo
+3 ;
BDEMOG ; ******************** BRIEF DEMOGRAPHICS ********************
+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 ;$P(^DPT(APCHSPAT,0),U,9),! ;IHS/CMI/LAB - added SSN
WRITE !,APCHSNAM," DOB: ",APCHSDOB," SSN: ",$$SSN^APCHS1(APCHSPAT),!
+22 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,!
+23 IF APCHSADR]""
WRITE APCHSADR,!
+24 ;IHS/CMI/GRL
WRITE "Home Phone: ",$SELECT($GET(APCHHPH)]"":APCHHPH,1:"None")_" "_"Work Phone: ",$SELECT($GET(APCHWPH)]"":APCHWPH,1:"None"),!
+25 SET APCHPLNG=$$PREFLANG^APCLAPI7(APCHSPAT,DT,"E")
+26 IF APCHPLNG]""
WRITE "Preferred Language: ",APCHPLNG,!
+27 IF $PIECE($GET(^AUPNPAT(APCHSPAT,40)),U,2)]""
WRITE !,"Preferred Method of Receiving Reminders: ",$$VAL^XBDIQ1(9000001,APCHSPAT,4002),!
+28 IF $ORDER(^BDPRECN("C",APCHSPAT,0))
DO BDPDISP^APCHS1
GOTO BDEMOGX
+29 IF $PIECE($GET(^AUPNPAT(APCHSPAT,0)),U,14)]""
WRITE "DESIGNATED PRIMARY CARE PROVIDER: ",$$VAL^XBDIQ1(9000001,.APCHSPAT,.14),!
+30 ;IHS/CMMI/LAB - added next 3 lines per ANMC 2/12/01
+31 IF $PIECE($GET(^BWP(APCHSPAT,0)),U,25)
WRITE "WOMEN'S HEALTH DESIGNATED PROVIDER: ",$$VAL^XBDIQ1(9002086,APCHSPAT,.25),!
+32 IF $PIECE($GET(^AUPNPAT(APCHSPAT,17)),U,1)
WRITE "PRIMARY MENTAL HEALTH PROVIDER: ",$EXTRACT($$VAL^XBDIQ1(9000001,APCHSPAT,1701),1,22),!
+33 IF $PIECE($GET(^AUPNPAT(APCHSPAT,17)),U,4)
WRITE "SECONDARY MENTAL HEALTH PROVIDER: ",$$VAL^XBDIQ1(9000001,APCHSPAT,1704),!
+34 ; <CLEANUP>
BDEMOGX KILL APCHSN,APCHSFP,APCHSFAC,APCHSNAM,APCHSDOB,APCHSADR,APCHSP,APCHSI
+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
