- 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
