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

BHSHS1.m

Go to the documentation of this file. 
  1. BHSHS1 ;IHS/CIA/MGH - Health Summary for pt history components ;30-Nov-2015 10:25;DU
  1.  ;;1.0;HEALTH SUMMARY COMPONENTS;**1,2,3,9,10,11,12**;March 17, 2006;Build 3
  1.  ;===================================================================
  1.  ;VA health summary components for history components
  1.  ;includes family hx, personal hx, and surgical hx
  1.  ;Taken from APCHS6
  1.  ; IHS/TUCSON/LAB - PART 6 OF APCHS -- SUMMARY PRODUCTION COMPONENTS ;
  1.  ;;2.0;IHS RPMS/PCC Health Summary;**11**;JUN 24, 1997
  1.  ;Patch 1 changes made up to IHS patch 14
  1.  ;Patch 2 chages made up to IHS patch 16
  1.  ;Patch 3 changes made up to bjpc version 2
  1.  ;Patch 12 used new API for taxonomies
  1. FMH ; ******************** FAMILY HISTORY * 9000014 *******
  1.  ; <SETUP>
  1.  N BHSPAT,BHSQ
  1.  S BHSPAT=DFN
  1.  Q:'$D(^AUPNFH("AC",BHSPAT))
  1.  D CKP^GMTSUP Q:$D(GMTSQIT)
  1.  ; <DISPLAY>
  1.  S BHSDFN="" F BHSQ=0:0 S BHSDFN=$O(^AUPNFH("AC",BHSPAT,BHSDFN)) Q:BHSDFN=""  D FHDSP
  1.  ; <CLEANUP>
  1. FMHX K BHSDFN,BHSN,BHSICD,BHSDAT,BHSNRQ,BHSICL,X,R,S,N,A
  1.  Q
  1. FHDSP S BHSN=^AUPNFH(BHSDFN,0)
  1.  S BHSICD=$P(BHSN,U,1) D GETICDDX^BHSUTL
  1.  S X=$P(BHSN,U,3) D REGDT4^GMTSU S BHSDAT=X
  1.  S BHSNRQ=$P(BHSN,U,4)
  1.  D GETNARR^BHSUTL
  1.  D CKP^GMTSUP Q:$D(GMTSQIT)  W BHSDAT_" " ;S BHSICL=10 D PRTICD^BHSUTL
  1.  S (X,R,S,N,A)=""
  1.  S R=$$VAL^XBDIQ1(9000014,BHSDFN,.07)
  1.  S N=$$VAL^XBDIQ1(9000014,BHSDFN,.04)_" ("_$$VAL^XBDIQ1(9000014,BHSDFN,.01)_")"
  1.  S A=$P(^AUPNFH(BHSDFN,0),U,5)
  1.  S S=$$VAL^XBDIQ1(9000014,BHSDFN,.06)
  1.  S X=X_$S(R]"":R_"; ",1:"")
  1.  S X=X_$S(N]"":N_"; ",1:"")
  1.  S X=X_$S(A]"":A_"; ",1:"")
  1.  S X=X_$S(S]"":S_"; ",1:"")
  1.  W ?10,X,!
  1.  Q
  1.  ;
  1. PMH ; ******************** PERSONAL HISTORY * 9000013 *******
  1.  ; <SETUP>
  1.  N BHSPAT,BHSQ,BHSNTE,X
  1.  S BHSPAT=DFN
  1.  Q:'$D(^AUPNPH("AC",BHSPAT))
  1.  D CKP^GMTSUP Q:$D(GMTSQIT)
  1.  ; <DISPLAY>
  1.  S BHSDFN="" F BHSQ=0:0 S BHSDFN=$O(^AUPNPH("AC",BHSPAT,BHSDFN)) Q:BHSDFN=""  D PHDSP
  1.  ; <CLEANUP>
  1. PMHX K BHSDFN,BHSN,BHSICD,BHSICL,BHSNRQ,BHSDAT,BHSDTH
  1.  Q
  1. PHDSP S BHSN=^AUPNPH(BHSDFN,0)
  1.  S BHSICD=$P(BHSN,U,1) D GETICDDX^BHSUTL
  1.  S X=$P(BHSN,U,3) D REGDT4^GMTSU S BHSDAT=X
  1.  S BHSDTH=$P(BHSN,U,5) I BHSDTH]"" S X=BHSDTH D REGDT4^GMTSU S BHSDTH=X
  1.  S BHSNRQ=$P(BHSN,U,4)
  1.  D GETNARR^BHSUTL
  1.  K BHSDTE S:BHSDTH]"" BHSNTE="(onset: "_BHSDTH_")"
  1.  D CKP^GMTSUP Q:$D(GMTSQIT)  W BHSDAT_" " S BHSICL=10 D PRTICD^BHSUTL
  1.  Q
  1.  ;
  1. HOS ; ************* HISTORY OF SURGERY * 9000010.08 (V PROCEDURE)& CPT *******
  1.  ; <SETUP>
  1.  N BHSPAT,BHSNTE,BHSQ,BHSDFN,BHSICD,BHSN,BHSCNT,BHSNRQ,BHSIVD,BHSDS,BHHOSA,BHSNRQ1
  1.  N BHT,BHCPT,BHSIEN,BHCPTI,BHSCSVD,BHSCPT2,I,MATCH,SCODE,Z,CODE
  1.  S BHSPAT=DFN,BHSCNT=0
  1.  ;Q:'$D(^AUPNVPRC("AC",BHSPAT))
  1.  D CKP^GMTSUP Q:$D(GMTSQIT)
  1.  S BHSCNT=0
  1.  ; <DISPLAY>
  1.  S BHSIVD=0 F  S BHSIVD=$O(^AUPNVPRC("AA",BHSPAT,BHSIVD)) Q:'BHSIVD  D
  1.  .S BHSDFN=0 F   S BHSDFN=$O(^AUPNVPRC("AA",BHSPAT,BHSIVD,BHSDFN)) Q:'BHSDFN  D        ;D HOSDSP Q:$D(GMTSQIT)
  1.  ..S BHSICD=$P(^AUPNVPRC(BHSDFN,0),U)
  1.  ..S BHSN=^AUPNVPRC(BHSDFN,0)
  1.  ..D HOSCHK Q:BHSICD=""
  1.  ..S BHSCNT=BHSCNT+1
  1.  ..S BHSCSVD=+^AUPNVSIT($P(BHSN,U,3),0)\1
  1.  ..D GETICDOP^BHSUTL
  1.  ..S Y=$P(BHSN,U,3),X=+^AUPNVSIT(Y,0)\1 D REGDT4^GMTSU S BHSDAT=X
  1.  ..S BHSNRQ=$P(BHSN,U,4)
  1.  ..I BHSNRQ D GETNARR^BHSUTL
  1.  ..I BHSNRQ="" D
  1.  ...;Patch 9 for ICD-10
  1.  ...S BHSNRQ=$P($$ICDOP^ICDEX($P(BHSN,U,1),+^AUPNVSIT($P(BHSN,U,3),0)\1,"","I"),U,5)  ;cmi/anch/maw 8/28/2007 code set
  1.  ..S BHSNRQ1=$P($$ICDOP^ICDEX($P(BHSN,U,1),BHSDAT,"","I"),U,2)
  1.  ..S BHSDS="DATE?" D
  1.  ...S X=$P(BHSN,U,6) I X]"" D REGDT4^GMTSU S BHSDS=X Q
  1.  ...S X=(9999999-BHSIVD) D REGDT4^GMTSU S BHSDS=X
  1.  ..D GETOPRV
  1.  ..S BHHOSA(BHSIVD,"PRC",BHSDFN)=BHSDS_U_BHSNRQ_U_BHSOP_U_BHSNRQ1
  1.  ;now go through v cpt
  1.  S BHT=$O(^ATXAX("B","APCH HS MAJOR PROCEDURE CPTS",0))
  1.  S BHCPTI=0 F  S BHCPTI=$O(^AUPNVCPT("AA",BHSPAT,BHCPTI)) Q:BHCPTI'=+BHCPTI  D
  1.  .;IHS/MSC/MGH Patch 11 new check
  1.  .S CODE=$P($G(^ICPT(BHCPTI,0)),U)
  1.  .I '$$ICD^ATXAPI(CODE,BHT,1) Q  ;not a cpt wanted on this compone
  1.  .S BHSIVD=0 F  S BHSIVD=$O(^AUPNVCPT("AA",BHSPAT,BHCPTI,BHSIVD)) Q:BHSIVD=""  D
  1.  ..S BHSIEN=0 F  S BHSIEN=$O(^AUPNVCPT("AA",BHSPAT,BHCPTI,BHSIVD,BHSIEN)) Q:BHSIEN'=+BHSIEN  D
  1.  ...S X=(9999999-BHSIVD) D REGDT4^GMTSU S BHSDS=X
  1.  ...S BHSN=^AUPNVCPT(BHSIEN,0)
  1.  ...S BHSICD=$P(BHSN,U,1)
  1.  ...D GETCPT^BHSUTL
  1.  ...S BHSNRQ=$P(BHSN,U,4)
  1.  ...I BHSNRQ D GETNARR^BHSUTL
  1.  ...N BHSVDT
  1.  ...S BHSVDT=$P(+^AUPNVSIT($P(BHSN,U,3),0),".")
  1.  ...I BHSNRQ="" S BHSNRQ=$P($$CPT^ICPTCOD($P(BHSN,U,1),BHSVDT),U,3)
  1.  ...S BHHOSA(BHSIVD,"CPT",BHSIEN)=BHSDS_U_BHSNRQ_U_$S($P($G(^AUPNVCPT(BHSIEN,12)),U,4):$$VAL^XBDIQ1(9000010.18,BHSIEN,1204),1:$$VAL^XBDIQ1(9000010.18,BHSIEN,1202))_U_BHSICD  ;
  1.  ...S BHHOSC(BHSIVD,"CPT",$P(^ICPT($P(BHSN,U,1),0),U,1))=""
  1.  ;now get all tran codes hcpcs
  1.  S BHSIEN=0 F  S BHSIEN=$O(^AUPNVTC("AC",BHSPAT,BHSIEN)) Q:BHSIEN=""  D
  1.  .Q:'$D(^AUPNVTC(BHSIEN))
  1.  .S V=$P(^AUPNVTC(BHSIEN,0),U,3)
  1.  .Q:'V
  1.  .Q:'$D(^AUPNVSIT(V,0))
  1.  .S V=$P($P(^AUPNVSIT(V,0),U),".")
  1.  .S X=V  D REGDT4^GMTSU  S BHSDS=X
  1.  .S BHSIVD=9999999-V
  1.  .S BHCPT=$$VAL^XBDIQ1(9000010.33,BHSIEN,.07)
  1.  .S BHCPTI=$P(^AUPNVTC(BHSIEN,0),U,7)
  1.  .Q:'BHCPTI
  1.  .S CODE=$P($G(^ICPT(BHCPTI,0)),U)
  1.  .I '$$ICD^ATXAPI(CODE,BHT,1) Q  ;not a cpt wanted on this compone
  1.  .Q:$D(BHHOSC(BHSIVD,"CPT",BHCPT))
  1.  .;S BHSNRQ=$P(^ICPT(BHCPTI,0),U,2)
  1.  .S BHSNRQ=$P($$CPT^ICPTCOD(BHCPTI,V),U,3)
  1.  .S BHSICD=BHCPTI
  1.  .D GETCPT^BHSUTL
  1.  .S BHHOSA(BHSIVD,"CPT",BHSIEN)=BHSDS_U_BHSNRQ_U_$S($P($G(^AUPNVTC(BHSIEN,12)),U,4):$$VAL^XBDIQ1(9000010.33,BHSIEN,1204),1:$$VAL^XBDIQ1(9000010.33,BHSIEN,1202))_U_BHSICD
  1.  ;now display the procedures/cpt codes
  1.  W ?1,"TIME",?12,"USER",?30,"CODE AND TEXT",!
  1.  S BHSIVD=0 F  S BHSIVD=$O(BHHOSA(BHSIVD)) Q:BHSIVD=""!($D(GMTSQIT))  D
  1.  .D CKP^GMTSUP Q:$D(GMTSQIT)
  1.  .  S BHIEN=0 F  S BHIEN=$O(BHHOSA(BHSIVD,"PRC",BHIEN)) Q:BHIEN'=+BHIEN!($D(GMTSQIT))  D
  1.  .. S BHSOP=$P(BHHOSA(BHSIVD,"PRC",BHIEN),U,3)
  1.  .. S BHSNRQ=$P(BHHOSA(BHSIVD,"PRC",BHIEN),U,2)
  1.  .. S BHSDS=$P(BHHOSA(BHSIVD,"PRC",BHIEN),U,1)
  1.  .. S BHSICD=$P(BHHOSA(BHSIVD,"PRC",BHIEN),U,4)
  1.  .. W BHSDS,?12,$E(BHSOP,1,15) S BHSNTE="" S BHSICL=26 D PRTICD^BHSUTL
  1.  .  S BHIEN=0 F  S BHIEN=$O(BHHOSA(BHSIVD,"CPT",BHIEN)) Q:BHIEN'=+BHIEN!($D(GMTSQIT))  D
  1.  .. S BHSOP=$P(BHHOSA(BHSIVD,"CPT",BHIEN),U,3)     ;the user
  1.  .. S BHSNRQ=$P(BHHOSA(BHSIVD,"CPT",BHIEN),U,2)    ;the narrative
  1.  .. S BHSDS=$P(BHHOSA(BHSIVD,"CPT",BHIEN),U,1)     ;the date
  1.  .. S BHSICD=$P(BHHOSA(BHSIVD,"CPT",BHIEN),U,4)    ;the code and text
  1.  .. W BHSDS,?12,$E(BHSOP,1,15) S BHSNTE="" S BHSICL=26 D PRTICD^BHSUTL
  1.  I 'BHSCNT D CKP^GMTSUP Q:$D(GMTSQIT)  W "Minor procedures are on file but have not been displayed.",!
  1.  ; now display refusals for icd procedures
  1.  S BHSFN=80.1,BHST="PROCEDURE"
  1.  S BHSS="S %=0,BHSICD=$P(^AUPNPREF(BHSI,0),U,6) Q:'BHSICD  D HOSCHK^BHSHS1 I BHSICD S %=1"
  1.  D DISPREF^BHSRAD
  1.  S BHSFN=81,BHST="CPT"
  1.  ;IHS/MSC/MGH  Patch 10
  1.  S BHSS="S %=0,BHCPT=$P(^AUPNPREF(BHSI,0),U,6) Q:'BHCPT  I $$ICD^ATXAPI(BHCPT,$O(^ATXAX(""B"",""APCH HS MAJOR PROCEDURE CPTS"",0)),1) S %=1"
  1.  D DISPREF^BHSRAD
  1.  ; <CLEANUP>
  1. HOSX K BHSDFN,BHSICD,BHSNRQ,BHSDAT,BHSDS,BHSICL,BHSIVD,BHSCOD,BHSCNT,BHSOPN,BHSOP,Y,BHIEN,BHHOSC,BHSS,BHST,BHSFN,V
  1.  Q
  1. HOSDSP S BHSN=^AUPNVPRC(BHSDFN,0)
  1.  S BHSICD=$P(BHSN,U,1)
  1.  D HOSCHK Q:BHSICD=""
  1.  S BHSCNT=BHSCNT+1
  1.  S BHSCSVD=+^AUPNVSIT($P(BHSN,U,3),0)\1
  1.  D GETICDOP^BHSUTL
  1.  S Y=$P(BHSN,U,3),X=+^AUPNVSIT(Y,0)\1 D REGDT4^GMTSU S BHSDAT=X
  1.  S BHSNRQ=$P(BHSN,U,4)
  1.  ;Fixed patch 1001
  1.  I BHSNRQ D GETNARR^BHSUTL
  1.  ;I BHSNRQ="" S BHSNRQ=$P(^ICD0($P(BHSN,U,1),0),U,4)
  1.  ;Patch 9 for ICD-10
  1.  I $$AICD^BHSUTL D
  1.  .I BHSNRQ="" S BHSNRQ=$P($$ICDOP^ICDEX($P(BHSN,U,1),BHSDAT,"","I"),U,5)  ;cmi/anch/maw 8/28/2007 code set versioning
  1.  .E  S BHSNRQ1=BHSNRQ   ;P11
  1.  .S BHSNRQ=$P($$ICDOP^ICDEX($P(BHSN,U,1),BHSDAT,"","I"),U,2)_" "_BHSNRQ1
  1.  E  I BHSNRQ="" S BHSNRQ=$P($$ICDOP^ICDCODE($P(BHSN,U,1),BHSDAT),U,5)  ;cmi/anch/maw 8/28/2007 code set versioning
  1.  ;end patch
  1.  S BHSDS="DATE?",X=$P(BHSN,U,6) I Y]"" D REGDT4^GMTSU S BHSDS=X
  1.  D GETOPRV
  1.  D CKP^GMTSUP Q:$D(GMTSQIT)
  1.  W BHSDS W ?12,BHSOP S BHSNTE="" S BHSICL=26 D PRTICD^BHSUTL
  1.  K BHSOP
  1.  Q
  1. HOSCHK ;
  1.  ;S BHSCOD=+^ICD0(BHSICD,0)
  1.  ;Patch 9 for ICD-10
  1.  I $$AICD^BHSUTL S BHSCOD=$P($$ICDOP^ICDEX(BHSICD,"","","I"),U,1)
  1.  E  S BHSCOD=$P($$ICDOP^ICDCODE(BHSICD),U,1)
  1.  I $$ICD^ATXAPI(BHSCOD,$O(^ATXAX("B","APCH MINOR SURGICAL PROCS",0)),0) S BHSICD=""
  1.  ;I BHSCOD\1>85 S BHSICD="" Q
  1.  ;I BHSCOD=69.7 S BHSICD="" Q
  1.  ;I BHSCOD\1=23 S BHSICD="" Q
  1.  ;I BHSCOD\1=24 S BHSICD="" Q
  1.  ;I $E(BHSCOD,1,4)="38.9" S BHSICD="" Q
  1.  ;I BHSCOD=73.09 S BHSICD="" Q
  1.  Q
  1. GETOPRV ;get Operating Provider
  1.  NEW BHSOPN
  1.  S BHSOP=""
  1.  S BHSOPN=$P(BHSN,U,11)
  1.  Q:'+BHSOPN
  1.  S BHSOP=$E($P($G(^VA(200,BHSOPN,0)),U,1),1,15)    ;provider name
  1.  Q