BHSDEM ;IHS/MSC/MGH - Health Summary Demographics ;14-Jan-2014 14:59;DU
;;1.0;HEALTH SUMMARY COMPONENTS;**1,2,3,4,6,9**;March 17,2006;Build 16
;==================================================================
;VA health summary comopnents for patient demographics
;Taken from APCHS1
;;2.0;IHS RPMS/PCC Health Summary;**2,8,9,10,11,12**;JUN 24, 1997
;CMI/TUCSON/LAB - patch 2 fix age display
;IHS/CMI/LAB - patch 11, added check for LR nodes to prevent undef
; patch 11, added Notice of Privacy Act data per Shirley Lujan email
;IHS/CMI/LAB - patch 12 added chronic pain registry data per ANMC
;
;Patch 2 added phone number as in patch 16
;Patch 3 SSN is Nremoved
;Patch 4 updated for BJPC patch 2
;Patch 6 added preferred language and cause of death
DEMOG ; ******************** DEMOGRAPHICS ********************
N BHSPAT,BHSN,BHSNAM,BHSSEX,BHSDOB,BHSMNM,BHSFNM
N Y,BHSX,BHOTPH,A,BHSFLD,BHSNL,C,BHTCNT,BHPLNG
S BHSPAT=DFN
; <SETUP>
S BHSN=^DPT(BHSPAT,0)
S BHSNAM=$P(BHSN,U,1)
S BHSEX=$P(BHSN,U,2),BHSEX=$S(BHSEX="M":"MALE",BHSEX="F":"FEMALE",1:"<no sex>")
S Y=$P(BHSN,U,3)
I 'Y S BHSDOB="<NO DATE OF BIRTH>"
E X ^DD("DD") S BHSDOB=Y
S BHSSN=$$SSN(BHSPAT)
;S BHSSN=$P(BHSN,U,9) S:BHSSN]"" BHSSN=$E(BHSSN,1,3)_"-"_$E(BHSSN,4,5)_"-"_$E(BHSSN,6,9)
S BHSN=$G(^DPT(BHSPAT,.24))
S BHSMNM=$P(BHSN,U,3)
S BHSFNM=$P(BHSN,U)
S BHSN=^AUPNPAT(BHSPAT,0)
S Y=$P(BHSN,U,3)
I 'Y S BHSLUD=""
E X ^DD("DD") S BHSLUD=Y
D
. Q:'$D(^DPT(BHSPAT,"LR"))
. S BHSX("LRDFN")=^DPT(BHSPAT,"LR") ; get pt's LRDFN
. D ; get Blood Bank blood type
.. Q:'$D(BHSX("LRDFN"))
.. Q:BHSX("LRDFN")=""
.. Q:'$D(^LR(BHSX("LRDFN"),0))
.. S BHSX("LR")=^LR(BHSX("LRDFN"),0)
.. S BHSX("ABO")=$P($G(BHSX("LR")),U,5)
.. Q:BHSX("ABO")=""
.. S BHSX("Rh")=$P($G(BHSX("LR")),U,6)
.. Q:BHSX("Rh")=""
.. S BHSX("ABO/Rh")=BHSX("ABO")_"/"_BHSX("Rh")
.. S:$D(BHSX("ABO/Rh")) BHSBT="ABO/Rh: "_BHSX("ABO/Rh")
.. Q
. Q
I '$D(BHSX("ABO/Rh")) D ; no BB data - data from ^DPT BType
. S BHSBT=$P(BHSN,U,13)
. S:BHSBT="" BHSBT="no blood type"
. Q
K BHSX ; kill BHSX vars
; end - vjm 9/20/01
S BHSPP=$P(BHSN,U,14)
S:BHSPP=-1 BHSPP="" ;IHS/ANMC/LJF 8/5/99 prevent UNDEF
S:BHSPP="" BHSPP="<none identified>"
I +BHSPP,$P(^DD(9000001,.14,0),U,2)[200 S BHSPP=$P(^VA(200,BHSPP,0),U) ;*** file 200 conversion ***
V ;
S BHSVST="" I $D(^DPT(BHSPAT,"VET"))#2,$P(^("VET"),U)="Y" D VSTAT
S BHSN=$G(^AUPNPAT(BHSPAT,11))
S BHSTR=$P(BHSN,U,8)
I 'BHSTR S BHSTR=",<no tribe>"
E S BHSTR=^AUTTTRI(BHSTR,0) S BHSTR=$P(BHSTR,U,1)_$S($P(BHSTR,U,4)="Y":" <old code>",1:"")
S BHSEL=$P(BHSN,U,12)
S X=$P(^DD(9000001,1112,0),U,3) F BHSI=1:1 S BHSP=$P(X,";",BHSI) Q:BHSP="" I $P(BHSP,":",1)=BHSEL S BHSEL=$P(BHSP,":",2) Q
S BHSCMR=$P(BHSN,U,18) S:BHSCMR="" BHSCMR="<NO COMMUNITY OF RESIDENCE>"
S BHSNL=$P($G(^APCHSITE(DUZ(2),0)),U,4)
S BHSFLD=$P($G(^APCHSITE(DUZ(2),0)),U,5)
I 'BHSNL S BHSNL=2
I BHSFLD="" S BHSFLD="F"
K BHSRE1
S C=0,BHTCNT=0
S X=0 F S X=$O(^AUPNPAT(BHSPAT,13,X)) Q:X'=+X S BHTCNT=BHTCNT+1
I BHSFLD="F" S X=0 F S X=$O(^AUPNPAT(BHSPAT,13,X)) Q:X'=+X!(C=BHSNL) S C=C+1,BHSRE1(C)=^AUPNPAT(BHSPAT,13,X,0)
I BHSFLD="L" S X=9999999 F S X=$O(^AUPNPAT(BHSPAT,13,X),-1) Q:X<1!(C=BHSNL) S C=C+1,BHSRE1(99999-C)=^AUPNPAT(BHSPAT,13,X,0)
;S BHSI=$O(^AUPNPAT(BHSPAT,13,0)) S BHSRE1=$S(BHSI:^(BHSI,0),1:"") S BHSI=$O(^AUPNPAT(BHSPAT,13,BHSI)) S BHSRE2=$S(BHSI:^(BHSI,0),1:"") S:$O(^AUPNPAT(BHSPAT,13,BHSI)) BHSRE2=BHSRE2_" [more]"
S BHSADR=""
I $D(^DPT(BHSPAT,.11)) S BHSN=^(.11) F E=1:1:6 S BHSP=$P(BHSN,U,E) I BHSP]"" S:E=5 BHSP=$P(^DIC(5,BHSP,0),U,2) S BHSADR=BHSADR_","_BHSP
S BHSADR=$E(BHSADR,2,255)
S:BHSADR]"" BHSCMR=BHSCMR_" ("_BHSADR_") "
S BHSN=$G(^DPT(BHSPAT,.13))
S BHSHPH=$P(BHSN,U,1),BHSOPH=$P(BHSN,U,2)
I BHSHPH="",BHSOPH="" S BHSHPH="<no phone numbers recorded>"
S:+BHSHPH BHSHPH="(H) "_BHSHPH
S:BHSOPH]"" BHSOPH="(W) "_BHSOPH S:BHSHPH]"" BHSOPH=" "_BHSOPH
S BHOTPH=$P($G(^AUPNPAT(BHSPAT,18)),U,1)
G DEMDSP
VSTAT S BHSVST="VETERAN"
I $D(^DPT(BHSPAT,.3))#2,$P(^(.3),U)="Y" S BHSVST="SERVICE-CONNECTED "_BHSVST
S BHSN=$G(^DPT(BHSPAT,.32))
I $P(BHSN,U,5) S BHSVST=BHSVST_" "_$P(^DIC(23,$P(BHSN,U,5),0),U,2)
S Y=$P(BHSN,U,6) I Y D VSDT S BHSVST=BHSVST_" ("_Y_"-" S Y=$P(BHSN,U,7) S:'Y BHSVST=BHSVST_"?)" I Y D VSDT S BHSVST=BHSVST_Y_")"
I $D(^DPT(BHSPAT,.31))#2 S BHSN=^(.31) S Y=$P(BHSN,U,3) I Y S BHSVST=BHSVST_" CLAIM# "_Y
Q
VSDT S Y=$E(Y,4,5)_"/"_$E(Y,6,7)_"/"_(1700+$E(Y,1,3))
Q
DEMDSP ; <DISPLAY>
D CKP^GMTSUP Q:$D(GMTSQIT)
;I $$DOD^AUPNPAT(BHSPAT)]"" W "*** DOD: ",$$FMTE^XLFDT($$DOD^AUPNPAT(BHSPAT),"2D")," ***",!
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 new apis 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,DIWR,BHSX,BHSZ,DIWL,DIW
W BHSNAM
W:BHSDOB]"" ?34,"DOB: ",BHSDOB,?51,$$AGE(BHSPAT,DT,"R")
W:BHSEX]"" ?59,BHSEX
D
. I BHSBT["/" W !,?34,BHSBT,! Q
. W:BHSBT]"" ?67,BHSBT,!
. Q
I BHSTR]""!(BHSMNM]"") W:BHSTR]"" $E(BHSTR,1,33) W:BHSSN]"" ?34,"SSN: ",BHSSN W !
W:BHSMNM]"" ?34,"MOTHER'S MAIDEN NAME: ",BHSMNM W !
W BHSHPH,BHSOPH W:BHSFNM]"" ?34,"FATHER'S NAME: ",BHSFNM W !
S BHPLNG=$$PREFLANG^APCLAPI7(BHSPAT,DT,"E")
D
.I BHOTPH]"" W "OTHER PHONE: ",BHOTPH
.I BHPLNG]"" W ?34,"PREFERRED LANGUAGE: ",BHPLNG
.I BHOTPH]""!(BHPLNG)]"" W !
I BHSCMR]"" W BHSCMR,!!
I BHSLUD]""!(BHSEL]"") W:BHSLUD]"" "LAST UPDATED: ",BHSLUD," " W:BHSEL]"" ?34,"ELIGIBILITY: ",BHSEL W !
W:BHSVST]"" BHSVST,!
;IHS/CMI/LAB - patch 11 added Notice of Privacy act display
S BHSNPP=$G(^AUPNNPP(BHSPAT,0))
W !,"NOTICE OF PRIVACY PRACTICES REC'D BY PATIENT? ",$$VAL^XBDIQ1(9000038,BHSPAT,.02)
W !," DATE RECEIVED BY PATIENT: ",$$FMTE^XLFDT($P(BHSNPP,U,3))
W !," WAS ACKNOWLEDGEMENT SIGNED? ",$$VAL^XBDIQ1(9000038,BHSPAT,.04)
I $P(BHSNPP,U,5)]"" D
.W !," REASON: ",$P(BHSNPP,U,5)
W !
K BHSNPP
W !
I $D(^AUPNPAT(BHSPAT,41)) W "HEALTH RECORD NUMBERS:" F BHSFP=0:0 S BHSFP=$O(^AUPNPAT(BHSPAT,41,BHSFP)) Q:'BHSFP S BHSHRN=$P(^(BHSFP,0),U,2),BHSFAC=$P(^DIC(4,BHSFP,0),U,1) W ?24,BHSHRN," ",BHSFAC,!
D CKP^GMTSUP Q:$D(GMTSQIT)
I $O(^BDPRECN("C",BHSPAT,0)) D BDPDISP G REM
W "DESIGNATED PROVIDER: ",BHSPP,!
REM ;
;IHS/ANMC/LAB - added next 3 lines per Mosley 2/12/01
N A
I $P($G(^BWP(BHSPAT,0)),U,25) S A="WOMEN'S HEALTH DESIGNATED PROVIDER" W ?(38-$L(A)),A,": "_$$VAL^XBDIQ1(9002086,BHSPAT,.25),!
I $P($G(^AUPNPAT(BHSPAT,17)),U,1) S A="PRIMARY MENTAL HEALTH PROVIDER" W ?(38-$L(A)),A,": ",$E($$VAL^XBDIQ1(9000001,BHSPAT,1701),1,22),!
I $P($G(^AUPNPAT(BHSPAT,17)),U,4) S A="SECONDARY MENTAL HEALTH PROVIDER" W ?(38-$L(A)),A,": ",$$VAL^XBDIQ1(9000001,BHSPAT,1704),!
;I BHSRE1]"" W "REMARKS:",?9,BHSRE1,! W:BHSRE2]"" ?9,BHSRE2,!
I $D(BHSRE1) W "REMARKS:",! D
.S BHSX=0 F S BHSX=$O(BHSRE1(BHSX)) Q:BHSX=""!($D(GMTSQIT)) D
..D CKP^GMTSUP Q:$D(GMTSQIT)
..W ?1,BHSRE1(BHSX),!
I BHSNL<BHTCNT W ?1,"[more]",!
I $D(^BCPP(BHSPAT)) D ;IHS/ANMC/LAB
.S X="BCPAPI" X ^%ZOSF("TEST") I '$T Q
.W !,"CHRONIC PAIN REGISTRY STATUS: ",$$VAL^XBDIQ1(90246,BHSPAT,.02) ;IHS/ANMC/LAB - added for chronic pain registry
.D ACTAGR^BCPAPI(.APCHAG,BHSPAT,1) W ?45,$S(APCHAG:"Opioid Agreement",1:"No Opioid Agreement"),! ;IHS/ANMC/LAB
D DSPCMSRG
DEMOGX K BHSNAM,BHSTR,BHSEX,BHSDOB,BHSSN,BHSMNM,BHSCMR,BHSEL,BHSFP,BHSFAC,BHSHRN,BHSBT,BHSPP,BHSADR,BHSN,BHSP,BHSI,BHSJ,BHSHPH,BHSOPH,BHSVST,BHSLUD,BHSRE1,BHSRE2,E,X,Y,APCHAG
Q
DSPCMSRG ; DISPLAY MEMBERSHIP IN CMS REGISTER
N BHSJ,BHSI,BHSK
Q:'$D(^ACM(41,"D",BHSPAT))
S BHSJ=1
F BHSI=0:0 S BHSI=$O(^ACM(41,"AC",BHSPAT,BHSI)) Q:'BHSI I $P(^ACM(41.1,BHSI,0),U,7) W:BHSJ "ON CMS REGISTER(S): " D
.S BHSJ=0 W ?21,$P(^ACM(41.1,BHSI,0),U)
.S BHSK=^ACM(41,"AC",BHSPAT,BHSI) W " Status: ",$$VAL^XBDIQ1(9002241,BHSK,1),! ;IHS/CMI/LAB - display was not consisten with CMS
Q
AGE(DFN,D,F) ;EP - Given DFN, return Age.
I '$G(DFN) Q -1
I '$D(^DPT(DFN,0)) Q -1
I $$DOB^AUPNPAT(DFN,"")<0 Q -1
S:$G(D)="" D=DT
S:$G(F)="" F="Y"
NEW DAY,YEAR
S DAY=$$FMDIFF^XLFDT(D,$$DOB^AUPNPAT(DFN,""))
S YEAR=DAY\365.25
I F="Y" Q YEAR
;beginning Y2K fix
;Q $S(%1>2:%1_" YRS",%<31:%1_" DYS",1:%\30_" MOS") ;Y2000
Q $S(YEAR>2:YEAR_" YRS",DAY<31:DAY_" DYS",1:DAY\30_" MOS") ;Y2000
;end Y2K
;
BDPDISP ;display providers from desg prov package
W ?30,"DESIGNATED PROVIDERS",!
S BHSX=0 F S BHSX=$O(^BDPRECN("C",BHSPAT,BHSX)) Q:BHSX'=+BHSX D
.D CKP^GMTSUP Q:$D(GMTSQIT)
.;get category and check health summary status
.S A=$P($G(^BDPRECN(BHSX,0)),U)
.Q:A=""
.Q:'$D(^BDPTCAT(A,0))
.Q:$P(^BDPTCAT(A,0),U,8)="N"
.S A=$$VAL^XBDIQ1(90360.1,BHSX,.01) W ?(38-$L(A)),A,": "_$$VAL^XBDIQ1(90360.1,BHSX,.03),!
.Q
Q
WWDSPL(DFN) ;
N AGE,STAT,SDATE,WW
Q:$E(BHSEX,1)'="F" "" ; Must be a female patient
S STAT="",SDATE=0
S WW=$$WWENPROC(DFN)
I WW D
.S STAT="ENROLLED",SDATE=WW
E D
.S STAT=$$GET1^DIQ(9000001,DFN,1709)
.I $L(STAT) D
..S SDATE=$$GET1^DIQ(9000001,DFN,1710,"I")
.E D
..S AGE=$$AGE^AUPNPAT(DFN)
..S:AGE>29&(AGE<65) STAT="UNKNOWN"
I $L(STAT) D
.W !,"WW Status: ",STAT W:SDATE ?30,"WW Update Date: ",$$FMTE^XLFDT(SDATE)
.W !!
Q
; Return date of WW Enrollment Procedure or Zero
WWENPROC(DFN) ;
N IEN,PDT
S PDT=0
Q:'$G(DFN) PDT
S (IEN,PDT)=0 F S IEN=$O(^BWPCD("C",DFN,IEN)) Q:'IEN D
.I $$GET1^DIQ(9002086.1,IEN,4.01,"I")=1 D
..S PDT=+$$GET1^DIQ(9002086.1,IEN,4.02,"I")
Q PDT
SSN(P) ;EP
I '$G(P) Q ""
I '$D(^DPT(P,0)) Q ""
Q $S($L($P(^DPT(P,0),U,9))=9:$J("XXX-XX-"_$E($P(^DPT(P,0),U,9),6,9),11),1:$J($P(^DPT(P,0),U,9),11))
BHSDEM ;IHS/MSC/MGH - Health Summary Demographics ;14-Jan-2014 14:59;DU
+1 ;;1.0;HEALTH SUMMARY COMPONENTS;**1,2,3,4,6,9**;March 17,2006;Build 16
+2 ;==================================================================
+3 ;VA health summary comopnents for patient demographics
+4 ;Taken from APCHS1
+5 ;;2.0;IHS RPMS/PCC Health Summary;**2,8,9,10,11,12**;JUN 24, 1997
+6 ;CMI/TUCSON/LAB - patch 2 fix age display
+7 ;IHS/CMI/LAB - patch 11, added check for LR nodes to prevent undef
+8 ; patch 11, added Notice of Privacy Act data per Shirley Lujan email
+9 ;IHS/CMI/LAB - patch 12 added chronic pain registry data per ANMC
+10 ;
+11 ;Patch 2 added phone number as in patch 16
+12 ;Patch 3 SSN is Nremoved
+13 ;Patch 4 updated for BJPC patch 2
+14 ;Patch 6 added preferred language and cause of death
DEMOG ; ******************** DEMOGRAPHICS ********************
+1 NEW BHSPAT,BHSN,BHSNAM,BHSSEX,BHSDOB,BHSMNM,BHSFNM
+2 NEW Y,BHSX,BHOTPH,A,BHSFLD,BHSNL,C,BHTCNT,BHPLNG
+3 SET BHSPAT=DFN
+4 ; <SETUP>
+5 SET BHSN=^DPT(BHSPAT,0)
+6 SET BHSNAM=$PIECE(BHSN,U,1)
+7 SET BHSEX=$PIECE(BHSN,U,2)
SET BHSEX=$SELECT(BHSEX="M":"MALE",BHSEX="F":"FEMALE",1:"<no sex>")
+8 SET Y=$PIECE(BHSN,U,3)
+9 IF 'Y
SET BHSDOB="<NO DATE OF BIRTH>"
+10 IF '$TEST
XECUTE ^DD("DD")
SET BHSDOB=Y
+11 SET BHSSN=$$SSN(BHSPAT)
+12 ;S BHSSN=$P(BHSN,U,9) S:BHSSN]"" BHSSN=$E(BHSSN,1,3)_"-"_$E(BHSSN,4,5)_"-"_$E(BHSSN,6,9)
+13 SET BHSN=$GET(^DPT(BHSPAT,.24))
+14 SET BHSMNM=$PIECE(BHSN,U,3)
+15 SET BHSFNM=$PIECE(BHSN,U)
+16 SET BHSN=^AUPNPAT(BHSPAT,0)
+17 SET Y=$PIECE(BHSN,U,3)
+18 IF 'Y
SET BHSLUD=""
+19 IF '$TEST
XECUTE ^DD("DD")
SET BHSLUD=Y
+20 Begin DoDot:1
+21 IF '$DATA(^DPT(BHSPAT,"LR"))
QUIT
+22 ; get pt's LRDFN
SET BHSX("LRDFN")=^DPT(BHSPAT,"LR")
+23 ; get Blood Bank blood type
Begin DoDot:2
+24 IF '$DATA(BHSX("LRDFN"))
QUIT
+25 IF BHSX("LRDFN")=""
QUIT
+26 IF '$DATA(^LR(BHSX("LRDFN"),0))
QUIT
+27 SET BHSX("LR")=^LR(BHSX("LRDFN"),0)
+28 SET BHSX("ABO")=$PIECE($GET(BHSX("LR")),U,5)
+29 IF BHSX("ABO")=""
QUIT
+30 SET BHSX("Rh")=$PIECE($GET(BHSX("LR")),U,6)
+31 IF BHSX("Rh")=""
QUIT
+32 SET BHSX("ABO/Rh")=BHSX("ABO")_"/"_BHSX("Rh")
+33 IF $DATA(BHSX("ABO/Rh"))
SET BHSBT="ABO/Rh: "_BHSX("ABO/Rh")
+34 QUIT
End DoDot:2
+35 QUIT
End DoDot:1
+36 ; no BB data - data from ^DPT BType
IF '$DATA(BHSX("ABO/Rh"))
Begin DoDot:1
+37 SET BHSBT=$PIECE(BHSN,U,13)
+38 IF BHSBT=""
SET BHSBT="no blood type"
+39 QUIT
End DoDot:1
+40 ; kill BHSX vars
KILL BHSX
+41 ; end - vjm 9/20/01
+42 SET BHSPP=$PIECE(BHSN,U,14)
+43 ;IHS/ANMC/LJF 8/5/99 prevent UNDEF
IF BHSPP=-1
SET BHSPP=""
+44 IF BHSPP=""
SET BHSPP="<none identified>"
+45 ;*** file 200 conversion ***
IF +BHSPP
IF $PIECE(^DD(9000001,.14,0),U,2)[200
SET BHSPP=$PIECE(^VA(200,BHSPP,0),U)
V ;
+1 SET BHSVST=""
IF $DATA(^DPT(BHSPAT,"VET"))#2
IF $PIECE(^("VET"),U)="Y"
DO VSTAT
+2 SET BHSN=$GET(^AUPNPAT(BHSPAT,11))
+3 SET BHSTR=$PIECE(BHSN,U,8)
+4 IF 'BHSTR
SET BHSTR=",<no tribe>"
+5 IF '$TEST
SET BHSTR=^AUTTTRI(BHSTR,0)
SET BHSTR=$PIECE(BHSTR,U,1)_$SELECT($PIECE(BHSTR,U,4)="Y":" <old code>",1:"")
+6 SET BHSEL=$PIECE(BHSN,U,12)
+7 SET X=$PIECE(^DD(9000001,1112,0),U,3)
FOR BHSI=1:1
SET BHSP=$PIECE(X,";",BHSI)
IF BHSP=""
QUIT
IF $PIECE(BHSP,":",1)=BHSEL
SET BHSEL=$PIECE(BHSP,":",2)
QUIT
+8 SET BHSCMR=$PIECE(BHSN,U,18)
IF BHSCMR=""
SET BHSCMR="<NO COMMUNITY OF RESIDENCE>"
+9 SET BHSNL=$PIECE($GET(^APCHSITE(DUZ(2),0)),U,4)
+10 SET BHSFLD=$PIECE($GET(^APCHSITE(DUZ(2),0)),U,5)
+11 IF 'BHSNL
SET BHSNL=2
+12 IF BHSFLD=""
SET BHSFLD="F"
+13 KILL BHSRE1
+14 SET C=0
SET BHTCNT=0
+15 SET X=0
FOR
SET X=$ORDER(^AUPNPAT(BHSPAT,13,X))
IF X'=+X
QUIT
SET BHTCNT=BHTCNT+1
+16 IF BHSFLD="F"
SET X=0
FOR
SET X=$ORDER(^AUPNPAT(BHSPAT,13,X))
IF X'=+X!(C=BHSNL)
QUIT
SET C=C+1
SET BHSRE1(C)=^AUPNPAT(BHSPAT,13,X,0)
+17 IF BHSFLD="L"
SET X=9999999
FOR
SET X=$ORDER(^AUPNPAT(BHSPAT,13,X),-1)
IF X<1!(C=BHSNL)
QUIT
SET C=C+1
SET BHSRE1(99999-C)=^AUPNPAT(BHSPAT,13,X,0)
+18 ;S BHSI=$O(^AUPNPAT(BHSPAT,13,0)) S BHSRE1=$S(BHSI:^(BHSI,0),1:"") S BHSI=$O(^AUPNPAT(BHSPAT,13,BHSI)) S BHSRE2=$S(BHSI:^(BHSI,0),1:"") S:$O(^AUPNPAT(BHSPAT,13,BHSI)) BHSRE2=BHSRE2_" [more]"
+19 SET BHSADR=""
+20 IF $DATA(^DPT(BHSPAT,.11))
SET BHSN=^(.11)
FOR E=1:1:6
SET BHSP=$PIECE(BHSN,U,E)
IF BHSP]""
IF E=5
SET BHSP=$PIECE(^DIC(5,BHSP,0),U,2)
SET BHSADR=BHSADR_","_BHSP
+21 SET BHSADR=$EXTRACT(BHSADR,2,255)
+22 IF BHSADR]""
SET BHSCMR=BHSCMR_" ("_BHSADR_") "
+23 SET BHSN=$GET(^DPT(BHSPAT,.13))
+24 SET BHSHPH=$PIECE(BHSN,U,1)
SET BHSOPH=$PIECE(BHSN,U,2)
+25 IF BHSHPH=""
IF BHSOPH=""
SET BHSHPH="<no phone numbers recorded>"
+26 IF +BHSHPH
SET BHSHPH="(H) "_BHSHPH
+27 IF BHSOPH]""
SET BHSOPH="(W) "_BHSOPH
IF BHSHPH]""
SET BHSOPH=" "_BHSOPH
+28 SET BHOTPH=$PIECE($GET(^AUPNPAT(BHSPAT,18)),U,1)
+29 GOTO DEMDSP
VSTAT SET BHSVST="VETERAN"
+1 IF $DATA(^DPT(BHSPAT,.3))#2
IF $PIECE(^(.3),U)="Y"
SET BHSVST="SERVICE-CONNECTED "_BHSVST
+2 SET BHSN=$GET(^DPT(BHSPAT,.32))
+3 IF $PIECE(BHSN,U,5)
SET BHSVST=BHSVST_" "_$PIECE(^DIC(23,$PIECE(BHSN,U,5),0),U,2)
+4 SET Y=$PIECE(BHSN,U,6)
IF Y
DO VSDT
SET BHSVST=BHSVST_" ("_Y_"-"
SET Y=$PIECE(BHSN,U,7)
IF 'Y
SET BHSVST=BHSVST_"?)"
IF Y
DO VSDT
SET BHSVST=BHSVST_Y_")"
+5 IF $DATA(^DPT(BHSPAT,.31))#2
SET BHSN=^(.31)
SET Y=$PIECE(BHSN,U,3)
IF Y
SET BHSVST=BHSVST_" CLAIM# "_Y
+6 QUIT
VSDT SET Y=$EXTRACT(Y,4,5)_"/"_$EXTRACT(Y,6,7)_"/"_(1700+$EXTRACT(Y,1,3))
+1 QUIT
DEMDSP ; <DISPLAY>
+1 DO CKP^GMTSUP
IF $DATA(GMTSQIT)
QUIT
+2 ;I $$DOD^AUPNPAT(BHSPAT)]"" W "*** DOD: ",$$FMTE^XLFDT($$DOD^AUPNPAT(BHSPAT),"2D")," ***",!
+3 IF $$DOD^AUPNPAT(BHSPAT)]""!($$VAL^XBDIQ1(9000001,BHSPAT,1114)]"")
Begin DoDot:1
+4 WRITE "*** DOD: ",$$VAL^XBDIQ1(2,BHSPAT,.351),!
+5 WRITE "*** CAUSE OF DEATH: "
IF $$VAL^XBDIQ1(9000001,BHSPAT,1114)]""
Begin DoDot:2
+6 WRITE $$VAL^XBDIQ1(9000001,BHSPAT,1114)
+7 KILL BHSDSC
+8 ;Patch 9 new apis for ICD-10
+9 IF $$AICD^BHSUTL
Begin DoDot:3
+10 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
+11 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)
+12 KILL ^UTILITY($JOB,"W")
+13 SET BHSX=0
+14 SET DIWL=0
SET DIWR=45
FOR
SET BHSX=$ORDER(BHSDSC(BHSX))
IF BHSX'=+BHSX!($DATA(GMTSQIT))
QUIT
Begin DoDot:3
+15 SET X=BHSDSC(BHSX)
+16 IF X="CODE TEXT MAY BE INACCURATE"
QUIT
+17 IF X=" "
QUIT
+18 DO ^DIWP
End DoDot:3
+19 SET BHSZ=0
FOR
SET BHSZ=$ORDER(^UTILITY($JOB,"W",DIWL,BHSZ))
IF BHSZ'=+BHSZ
QUIT
Begin DoDot:3
+20 IF $DATA(GMTSQIT)
QUIT
+21 WRITE ?28,^UTILITY($JOB,"W",DIWL,BHSZ,0),!
End DoDot:3
End DoDot:2
IF 1
+22 IF '$TEST
WRITE !!
+23 ;W !
End DoDot:1
+24 KILL ^UTILITY($JOB,"W"),BHSDSC,DIWL,DIWR,BHSX,BHSZ,DIWL,DIW
+25 WRITE BHSNAM
+26 IF BHSDOB]""
WRITE ?34,"DOB: ",BHSDOB,?51,$$AGE(BHSPAT,DT,"R")
+27 IF BHSEX]""
WRITE ?59,BHSEX
+28 Begin DoDot:1
+29 IF BHSBT["/"
WRITE !,?34,BHSBT,!
QUIT
+30 IF BHSBT]""
WRITE ?67,BHSBT,!
+31 QUIT
End DoDot:1
+32 IF BHSTR]""!(BHSMNM]"")
IF BHSTR]""
WRITE $EXTRACT(BHSTR,1,33)
IF BHSSN]""
WRITE ?34,"SSN: ",BHSSN
WRITE !
+33 IF BHSMNM]""
WRITE ?34,"MOTHER'S MAIDEN NAME: ",BHSMNM
WRITE !
+34 WRITE BHSHPH,BHSOPH
IF BHSFNM]""
WRITE ?34,"FATHER'S NAME: ",BHSFNM
WRITE !
+35 SET BHPLNG=$$PREFLANG^APCLAPI7(BHSPAT,DT,"E")
+36 Begin DoDot:1
+37 IF BHOTPH]""
WRITE "OTHER PHONE: ",BHOTPH
+38 IF BHPLNG]""
WRITE ?34,"PREFERRED LANGUAGE: ",BHPLNG
+39 IF BHOTPH]""!(BHPLNG)]""
WRITE !
End DoDot:1
+40 IF BHSCMR]""
WRITE BHSCMR,!!
+41 IF BHSLUD]""!(BHSEL]"")
IF BHSLUD]""
WRITE "LAST UPDATED: ",BHSLUD," "
IF BHSEL]""
WRITE ?34,"ELIGIBILITY: ",BHSEL
WRITE !
+42 IF BHSVST]""
WRITE BHSVST,!
+43 ;IHS/CMI/LAB - patch 11 added Notice of Privacy act display
+44 SET BHSNPP=$GET(^AUPNNPP(BHSPAT,0))
+45 WRITE !,"NOTICE OF PRIVACY PRACTICES REC'D BY PATIENT? ",$$VAL^XBDIQ1(9000038,BHSPAT,.02)
+46 WRITE !," DATE RECEIVED BY PATIENT: ",$$FMTE^XLFDT($PIECE(BHSNPP,U,3))
+47 WRITE !," WAS ACKNOWLEDGEMENT SIGNED? ",$$VAL^XBDIQ1(9000038,BHSPAT,.04)
+48 IF $PIECE(BHSNPP,U,5)]""
Begin DoDot:1
+49 WRITE !," REASON: ",$PIECE(BHSNPP,U,5)
End DoDot:1
+50 WRITE !
+51 KILL BHSNPP
+52 WRITE !
+53 IF $DATA(^AUPNPAT(BHSPAT,41))
WRITE "HEALTH RECORD NUMBERS:"
FOR BHSFP=0:0
SET BHSFP=$ORDER(^AUPNPAT(BHSPAT,41,BHSFP))
IF 'BHSFP
QUIT
SET BHSHRN=$PIECE(^(BHSFP,0),U,2)
SET BHSFAC=$PIECE(^DIC(4,BHSFP,0),U,1)
WRITE ?24,BHSHRN," ",BHSFAC,!
+54 DO CKP^GMTSUP
IF $DATA(GMTSQIT)
QUIT
+55 IF $ORDER(^BDPRECN("C",BHSPAT,0))
DO BDPDISP
GOTO REM
+56 WRITE "DESIGNATED PROVIDER: ",BHSPP,!
REM ;
+1 ;IHS/ANMC/LAB - added next 3 lines per Mosley 2/12/01
+2 NEW A
+3 IF $PIECE($GET(^BWP(BHSPAT,0)),U,25)
SET A="WOMEN'S HEALTH DESIGNATED PROVIDER"
WRITE ?(38-$LENGTH(A)),A,": "_$$VAL^XBDIQ1(9002086,BHSPAT,.25),!
+4 IF $PIECE($GET(^AUPNPAT(BHSPAT,17)),U,1)
SET A="PRIMARY MENTAL HEALTH PROVIDER"
WRITE ?(38-$LENGTH(A)),A,": ",$EXTRACT($$VAL^XBDIQ1(9000001,BHSPAT,1701),1,22),!
+5 IF $PIECE($GET(^AUPNPAT(BHSPAT,17)),U,4)
SET A="SECONDARY MENTAL HEALTH PROVIDER"
WRITE ?(38-$LENGTH(A)),A,": ",$$VAL^XBDIQ1(9000001,BHSPAT,1704),!
+6 ;I BHSRE1]"" W "REMARKS:",?9,BHSRE1,! W:BHSRE2]"" ?9,BHSRE2,!
+7 IF $DATA(BHSRE1)
WRITE "REMARKS:",!
Begin DoDot:1
+8 SET BHSX=0
FOR
SET BHSX=$ORDER(BHSRE1(BHSX))
IF BHSX=""!($DATA(GMTSQIT))
QUIT
Begin DoDot:2
+9 DO CKP^GMTSUP
IF $DATA(GMTSQIT)
QUIT
+10 WRITE ?1,BHSRE1(BHSX),!
End DoDot:2
End DoDot:1
+11 IF BHSNL<BHTCNT
WRITE ?1,"[more]",!
+12 ;IHS/ANMC/LAB
IF $DATA(^BCPP(BHSPAT))
Begin DoDot:1
+13 SET X="BCPAPI"
XECUTE ^%ZOSF("TEST")
IF '$TEST
QUIT
+14 ;IHS/ANMC/LAB - added for chronic pain registry
WRITE !,"CHRONIC PAIN REGISTRY STATUS: ",$$VAL^XBDIQ1(90246,BHSPAT,.02)
+15 ;IHS/ANMC/LAB
DO ACTAGR^BCPAPI(.APCHAG,BHSPAT,1)
WRITE ?45,$SELECT(APCHAG:"Opioid Agreement",1:"No Opioid Agreement"),!
End DoDot:1
+16 DO DSPCMSRG
DEMOGX KILL BHSNAM,BHSTR,BHSEX,BHSDOB,BHSSN,BHSMNM,BHSCMR,BHSEL,BHSFP,BHSFAC,BHSHRN,BHSBT,BHSPP,BHSADR,BHSN,BHSP,BHSI,BHSJ,BHSHPH,BHSOPH,BHSVST,BHSLUD,BHSRE1,BHSRE2,E,X,Y,APCHAG
+1 QUIT
DSPCMSRG ; DISPLAY MEMBERSHIP IN CMS REGISTER
+1 NEW BHSJ,BHSI,BHSK
+2 IF '$DATA(^ACM(41,"D",BHSPAT))
QUIT
+3 SET BHSJ=1
+4 FOR BHSI=0:0
SET BHSI=$ORDER(^ACM(41,"AC",BHSPAT,BHSI))
IF 'BHSI
QUIT
IF $PIECE(^ACM(41.1,BHSI,0),U,7)
IF BHSJ
WRITE "ON CMS REGISTER(S): "
Begin DoDot:1
+5 SET BHSJ=0
WRITE ?21,$PIECE(^ACM(41.1,BHSI,0),U)
+6 ;IHS/CMI/LAB - display was not consisten with CMS
SET BHSK=^ACM(41,"AC",BHSPAT,BHSI)
WRITE " Status: ",$$VAL^XBDIQ1(9002241,BHSK,1),!
End DoDot:1
+7 QUIT
AGE(DFN,D,F) ;EP - Given DFN, return Age.
+1 IF '$GET(DFN)
QUIT -1
+2 IF '$DATA(^DPT(DFN,0))
QUIT -1
+3 IF $$DOB^AUPNPAT(DFN,"")<0
QUIT -1
+4 IF $GET(D)=""
SET D=DT
+5 IF $GET(F)=""
SET F="Y"
+6 NEW DAY,YEAR
+7 SET DAY=$$FMDIFF^XLFDT(D,$$DOB^AUPNPAT(DFN,""))
+8 SET YEAR=DAY\365.25
+9 IF F="Y"
QUIT YEAR
+10 ;beginning Y2K fix
+11 ;Q $S(%1>2:%1_" YRS",%<31:%1_" DYS",1:%\30_" MOS") ;Y2000
+12 ;Y2000
QUIT $SELECT(YEAR>2:YEAR_" YRS",DAY<31:DAY_" DYS",1:DAY\30_" MOS")
+13 ;end Y2K
+14 ;
BDPDISP ;display providers from desg prov package
+1 WRITE ?30,"DESIGNATED PROVIDERS",!
+2 SET BHSX=0
FOR
SET BHSX=$ORDER(^BDPRECN("C",BHSPAT,BHSX))
IF BHSX'=+BHSX
QUIT
Begin DoDot:1
+3 DO CKP^GMTSUP
IF $DATA(GMTSQIT)
QUIT
+4 ;get category and check health summary status
+5 SET A=$PIECE($GET(^BDPRECN(BHSX,0)),U)
+6 IF A=""
QUIT
+7 IF '$DATA(^BDPTCAT(A,0))
QUIT
+8 IF $PIECE(^BDPTCAT(A,0),U,8)="N"
QUIT
+9 SET A=$$VAL^XBDIQ1(90360.1,BHSX,.01)
WRITE ?(38-$LENGTH(A)),A,": "_$$VAL^XBDIQ1(90360.1,BHSX,.03),!
+10 QUIT
End DoDot:1
+11 QUIT
WWDSPL(DFN) ;
+1 NEW AGE,STAT,SDATE,WW
+2 ; Must be a female patient
IF $EXTRACT(BHSEX,1)'="F"
QUIT ""
+3 SET STAT=""
SET SDATE=0
+4 SET WW=$$WWENPROC(DFN)
+5 IF WW
Begin DoDot:1
+6 SET STAT="ENROLLED"
SET SDATE=WW
End DoDot:1
+7 IF '$TEST
Begin DoDot:1
+8 SET STAT=$$GET1^DIQ(9000001,DFN,1709)
+9 IF $LENGTH(STAT)
Begin DoDot:2
+10 SET SDATE=$$GET1^DIQ(9000001,DFN,1710,"I")
End DoDot:2
+11 IF '$TEST
Begin DoDot:2
+12 SET AGE=$$AGE^AUPNPAT(DFN)
+13 IF AGE>29&(AGE<65)
SET STAT="UNKNOWN"
End DoDot:2
End DoDot:1
+14 IF $LENGTH(STAT)
Begin DoDot:1
+15 WRITE !,"WW Status: ",STAT
IF SDATE
WRITE ?30,"WW Update Date: ",$$FMTE^XLFDT(SDATE)
+16 WRITE !!
End DoDot:1
+17 QUIT
+18 ; Return date of WW Enrollment Procedure or Zero
WWENPROC(DFN) ;
+1 NEW IEN,PDT
+2 SET PDT=0
+3 IF '$GET(DFN)
QUIT PDT
+4 SET (IEN,PDT)=0
FOR
SET IEN=$ORDER(^BWPCD("C",DFN,IEN))
IF 'IEN
QUIT
Begin DoDot:1
+5 IF $$GET1^DIQ(9002086.1,IEN,4.01,"I")=1
Begin DoDot:2
+6 SET PDT=+$$GET1^DIQ(9002086.1,IEN,4.02,"I")
End DoDot:2
End DoDot:1
+7 QUIT PDT
SSN(P) ;EP
+1 IF '$GET(P)
QUIT ""
+2 IF '$DATA(^DPT(P,0))
QUIT ""
+3 QUIT $SELECT($LENGTH($PIECE(^DPT(P,0),U,9))=9:$JUSTIFY("XXX-XX-"_$EXTRACT($PIECE(^DPT(P,0),U,9),6,9),11),1:$JUSTIFY($PIECE(^DPT(P,0),U,9),11))
