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

BHSSUPP.m

Go to the documentation of this file. 
  1. BHSSUPP ;IHS/CIA/MGH - Health Summary for Supplements ;22-Apr-2014 09:37;DU
  1.  ;;1.0;HEALTH SUMMARY COMPONENTS;**2,4,9**;March 17, 2006;Build 16
  1.  ;===================================================================
  1.  ;Taken from APCHS9A
  1.  ; IHS/TUCSON/LAB - PART 9 OF APCHS -- SUMMARY PRODUCTION COMPONENTS ;
  1.  ;;2.0;IHS RPMS/PCC Health Summary;**9,10**;JUN 24, 1997
  1.  ;VA version of IHS components for supplemental summaries
  1.  ;Patch 2 code set versioning
  1.  ;------------------------------------------------------------
  1. SUPP ;EP - supplements
  1.  N BHSPAT,BHSC1,BHSC2,BHSCI,BHSCM,BHSP,BHSPI,BHSNYR,BHSBD,BHSNVN,BHSUPI
  1.  S BHSPAT=DFN
  1.  D CKP^GMTSUP Q:$D(GMTSQIT)
  1.  S BHSFOR=0 F  S BHSFOR=$O(GMTSEG(GMTSEGN,90471,BHSFOR)) Q:BHSFOR'=+BHSFOR!($D(GMTSQIT))  D  Q:$D(GMTSQIT)
  1.  .S BHSUPI=$G(GMTSEG(GMTSEGN,90471,BHSFOR))
  1.  .Q:BHSUPI=""
  1.  .Q:'$D(^BHS(90471,BHSUPI))
  1.  .Q:$G(^BHS(90471,BHSUPI,1))=""
  1.  .D SUPPCHK
  1.  .Q:'BHSFOK
  1.  .X ^BHS(90471,BHSUPI,1)
  1. EOJ ;
  1.  K BHSFOK,BHSFOR,BHSUPI,BHSCNT
  1.  Q
  1. SUPPCHK ; <SCREEN>
  1.  I '$O(^BHS(90471,BHSUPI,3,0)) S BHSFOK=1 Q
  1.  S BHSFOK=0
  1.  ;Q:'$O(^AUPNPROB("AC",BHSPAT,0))
  1.  F BHSPI=0:0 S BHSPI=$O(^AUPNPROB("AC",BHSPAT,BHSPI)) Q:'BHSPI  D SUPPCP Q:BHSFOK
  1.  Q:BHSFOK
  1. PVCH ;IHS/CMI/LAB - now check for dx in past year per Bill and Charlton by pcp
  1.  N X,Y,V,D,E,%
  1.  K APCHY,APCHV,^TMP($J,"ALL VISITS")
  1.  S BHSNVN=$S($P($G(^APCHSITE(DUZ(2),11,BHSUPI,0)),U,2):$P($G(^APCHSITE(DUZ(2),11,BHSUPI,0)),U,2),1:1)
  1.  S BHSNYR=$S($P($G(^APCHSITE(DUZ(2),11,BHSUPI,0)),U,3):$P($G(^APCHSITE(DUZ(2),11,BHSUPI,0)),U,3),1:1)
  1.  S BHSNYR=BHSNYR*365
  1.  S BHSBD=$$FMADD^XLFDT(DT,-(BHSNYR))
  1.  S APCHY="^TMP($J,""ALL VISITS"",",%=BHSPAT_"^ALL VISITS;DURING "_$$FMTE^XLFDT($$FMADD^XLFDT(DT,-365))_"-"_$$FMTE^XLFDT(DT),E=$$START1^APCLDF(%,APCHY)
  1.  I '$D(^TMP($J,"ALL VISITS",1)) Q
  1.  S (X,BHSCNT,BHSFOK)=0 F  S X=$O(^TMP($J,"ALL VISITS",X)) Q:X'=+X!(BHSFOK)  S V=$P(^TMP($J,"ALL VISITS",X),U,5) D
  1.  .Q:'$P(^AUPNVSIT(V,0),U,9)
  1.  .Q:$P(^AUPNVSIT(V,0),U,11)
  1.  .Q:"DAHO"'[$P(^AUPNVSIT(V,0),U,7)
  1.  .Q:'$D(^AUPNVPRV("AD",V))
  1.  .Q:'$D(^AUPNVPOV("AD",V))
  1.  .;S (D,Y)=0 F  S Y=$O(^AUPNVPOV("AD",V,Y)) Q:Y'=+Y!(D)  D  S BHSCM=$P($G(^AUPNVPOV(Y,0)),U) I BHSCM S BHSCM=$P($G(^ICD9(BHSCM,0)),U) I BHSCM]"" D CHKCODE
  1.  .;code set versioning
  1.  .N BHSVDT
  1.  .S BHSVDT=$P(+V,".")
  1.  .;Patch 9 for ICD-10
  1.  .I $$AICD^BHSUTL D
  1.  ..S (D,Y)=0 F  S Y=$O(^AUPNVPOV("AD",V,Y)) Q:Y'=+Y!(D)  S BHSCM=$P($G(^AUPNVPOV(Y,0)),U) I BHSCM S BHSCM=$P($$ICDDX^ICDEX(BHSCM,BHSVDT,"","I"),U,2) I BHSCM]"" D CHKCODE
  1.  .E  D
  1.  ..S (D,Y)=0 F  S Y=$O(^AUPNVPOV("AD",V,Y)) Q:Y'=+Y!(D)  S BHSCM=$P($G(^AUPNVPOV(Y,0)),U) I BHSCM S BHSCM=$P($$ICDDX^ICDCODE(BHSCM,BHSVDT),U,2) I BHSCM]"" D CHKCODE
  1.  .Q:'D
  1.  .;S Y=$$PRIMPROV^APCLV(V,"F")
  1.  .;Q:'Y
  1.  .;I $P(^DIC(7,Y,9999999),U,1)=39 S BHSFOK=1 Q
  1.  .;Q:$P($G(^DIC(7,Y,9999999)),U,3)'="Y"
  1.  .S BHSCNT=BHSCNT+1
  1.  .I BHSCNT'<BHSNVN S BHSFOK=1
  1.  .;S BHSFOK=1
  1.  .Q
  1.  K ^TMP($J,"ALL VISITS"),APCHV,APCHY
  1.  Q
  1. CHKCODE ;
  1.  S D=0
  1.  F BHSCI=0:0 S BHSCI=$O(^BHS(90471,BHSUPI,3,BHSCI)) Q:'BHSCI  D CHKCODE1 Q:D
  1.  Q
  1. CHKCODE1 ;
  1.  S D=0
  1.  S BHSC1=$P(^BHS(90471,BHSUPI,3,BHSCI,0),U,1)
  1.  I BHSC1["-" S BHSC2=$P(BHSC1,"-",2),BHSC1=$P(BHSC1,"-",1)
  1.  E  S BHSC2=BHSC1
  1.  S BHSC1=BHSC1_" ",BHSC2=BHSC2_" "
  1.  I BHSC1'](BHSCM_" "),(BHSCM_" ")']BHSC2 S D=1
  1.  Q
  1. SUPPCP ;
  1.  S BHSP=^AUPNPROB(BHSPI,0) Q:$P(BHSP,U,12)'="A"
  1.  ;S BHSCM=$P(^ICD9(+$P(BHSP,U),0),U)
  1.  ;code set versioning
  1.  ;Patch 9 added for ICD-10
  1.  I $$AICD^BHSUTL  S BHSCM=$P($$ICDDX^ICDEX(+$P(BHSP,U),"","","I"),U,2)
  1.  E  S BHSCM=$P($$ICDDX^ICDCODE(+$P(BHSP,U)),U,2)
  1.  F BHSCI=0:0 S BHSCI=$O(^BHS(90471,BHSUPI,3,BHSCI)) Q:'BHSCI  D SUPPCR Q:BHSFOK
  1.  Q
  1. SUPPCR S BHSC1=$P(^BHS(90471,BHSUPI,3,BHSCI,0),U)
  1.  I BHSC1["-" S BHSC2=$P(BHSC1,"-",2),BHSC1=$P(BHSC1,"-",1)
  1.  E  S BHSC2=BHSC1
  1.  S BHSC1=BHSC1_" ",BHSC2=BHSC2_" "
  1.  I BHSC1'](BHSCM_" "),(BHSCM_" ")']BHSC2 S BHSFOK=1
  1.  Q