Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: BHSDEM

BHSDEM.m

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