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

BHSSUR.m

Go to the documentation of this file. 
  1. BHSSUR ;IHS/CIA/MGH - Health Summary for minor surgery ;14-Dec-2015 16:56;DU
  1.  ;;1.0;HEALTH SUMMARY COMPONENTS;**1,2,9,11,12**;March 17, 2006;Build 3
  1.  ;===================================================================
  1.  ;Taken from APCHS6A
  1.  ; IHS/TUCSON/LAB - PART 6 OF APCHS -- SUMMARY PRODUCTION COMPONENTS ;
  1.  ;;2.0;IHS RPMS/PCC Health Summary;;JUN 24, 1997
  1.  ;VA health summary for minor surgery
  1.  ;Patch 1 made changes up to patch 14 of health summary
  1.  ;Patch 2 made changes for patch 16 of health summary and filters out duplicate ICD0/CPT codes
  1.  ;Patch 12 used new API for taxonomies
  1.  ;
  1. MINORO ; ******** MINOR HISTORY OF SURGERY * 9000010.08 (V PROCEDURE) *******
  1.  ; <SETUP>
  1.  N BHSPAT,BHSNTE,BHSN,BHSQ,TAXIEN
  1.  S BHSPAT=DFN
  1.  S TAXARR="",ARRAY=""
  1.  Q:'$D(^AUPNVPRC("AC",BHSPAT))
  1.  D CKP^GMTSUP Q:$D(GMTSQIT)
  1.  ; <DISPLAY>
  1.  S TAXIEN=$O(^ATXAX("B","APCH MINOR SURGICAL PROCS",0))
  1.  S BHSIVD=0 F BHSQ=0:0 S BHSIVD=$O(^AUPNVPRC("AA",BHSPAT,BHSIVD)) Q:'BHSIVD  D
  1.  .S BHSDFN=0 F BHSQ=0:0 S BHSDFN=$O(^AUPNVPRC("AA",BHSPAT,BHSIVD,BHSDFN)) Q:'BHSDFN  D
  1.  ..D HOSDSP Q:$D(GMTSQIT)
  1.  ;Patch 2 changes for refusals
  1.  S BHSFN=80.1,BHST="PROCEDURE"
  1.  S BHSS="S %=0,BHSICD=$P(^AUPNPREF(BHSI,0),U,6) Q:'BHSICD  D HOSCHK^BHSSUR I BHSICD S %=1"
  1.  D DISPREF^BHSRAD
  1.  K BHSDN,BHST,BHSS
  1.  ;
  1.  ; <CLEANUP>
  1. MINOROX K BHSDFN,BHSICD,BHSNRQ,BHSDAT,BHSDS,BHSICL,BHSIVD,BHSCOD,BHSOPN,BHSOP,Y
  1.  Q
  1. HOSDSP ;Get diagnosis
  1.  N X,Y
  1.  S BHSN=^AUPNVPRC(BHSDFN,0)
  1.  S BHSICD=$P(BHSN,U,1)
  1.  D HOSCHK Q:BHSICD=""
  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.  ;Patch 8 changes
  1.  I BHSNRQ D GETNARR^BHSUTL
  1.  ;I BHSNRQ="" S BHSNRQ=$P(^ICD0($P(BHSN,U,1),0),U,4)
  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  D
  1.  .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 changes
  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 ?10,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,2)  ;cmi/anch/maw 8/27/2007
  1.  ;IHS/MSC/MGH Patch 11
  1.  Q:$$ICD^ATXAPI(BHSCOD,$O(^ATXAX("B","APCH MINOR SURGICAL PROCS",0)),0)
  1.  ;Q:BHSCOD\1>85
  1.  ;Q:BHSCOD=69.7
  1.  ;Q:BHSCOD\1=23
  1.  ;Q:BHSCOD\1=24
  1.  S BHSICD=""
  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
  1. MINOR ; ************* HISTORY OF SURGERY * 9000010.08 (V PROCEDURE) & V CPT *
  1.  ; <SETUP>
  1.  K BHHOSA,BHHOSC,TAXIEN,CODE,BHSNRQ1
  1.  S BHSPAT=DFN
  1.  I '$D(^AUPNVPRC("AC",BHSPAT)),'$D(^AUPNVCPT("AC",BHSPAT)) G MINORX
  1.  D CKP^GMTSUP Q:$D(GMTSQIT)
  1.  S BHSCNT=0
  1.  S TAXIEN=$O(^ATXAX("B","APCH MINOR SURGICAL PROCS",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
  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.  ..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="" 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 BHSNRQ1=$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
  1.  ...S BHSNRQ=$P($$ICDOP^ICDEX($P(BHSN,U,1),BHSDAT,"","I"),U,2)_" "_BHSNRQ1  ;cmi/anch/maw 8/28/2007 code set versioning
  1.  ..E  D
  1.  ...I BHSNRQ="" S BHSNRQ=$P($$ICDOP^ICDCODE($P(BHSN,U,1),BHSDAT),U,5)  ;cmi/anch/maw 8/28/2007 code set versioning
  1.  ..S BHSDS="DATE?",X=$P(BHSN,U,6) I X]"" D REGDT4^GMTSU S BHSDS=X
  1.  ..D GETOPRV
  1.  ..S BHHOSA(BHSIVD,"PRC",BHSDFN)=BHSDS_U_BHSNRQ_U_BHSOP
  1.  ;now go through v cpt
  1.  S BHT=$O(^ATXAX("B","APCH HS MINOR PROCEDURE CPTS",0))
  1.  S BHCPTI=0 F  S BHCPTI=$O(^AUPNVCPT("AA",BHSPAT,BHCPTI)) Q:BHCPTI'=+BHCPTI  D
  1.  .S CODE=$P($G(^ICPT(BHCPTI,0)),U)
  1.  .I '$$ICD^ATXCHK(BHCPTI,BHT,1) Q  ;not a cpt wanted on this component
  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=$S($P(BHSN,U,3):$P(+$G(^AUPNVSIT($P(BHSN,U,3),0)),"."),1:"")
  1.  ...;I BHSNRQ="" S BHSNRQ=$P(^ICPT($P(BHSN,U,1),0),U,2)
  1.  ...I BHSNRQ="" S BHSNRQ=$P($$CPT^ICPTCOD($P(BHSN,U,1),BHSVDT),U,3)
  1.  ...S CODE=$P($$CPT^ICPTCOD($P(BHSN,U,1),BHSVDT),U,2)
  1.  ...;IHS/MSC/MGH filter out duplicates
  1.  ...S MATCH=0
  1.  ...S I="" F  S I=$O(BHHOSA(BHSIVD,"PRC",I)) Q:I=""  D
  1.  ....S Z=$G(BHHOSA(BHSIVD,"PRC",I))
  1.  ....S BHSCPT2=$P(BHSICD,"-",1)
  1.  ....I $D(^ICPT(BHSCPT2,"ICD",0)) D
  1.  .....S SCODE=0 F  S SCODE=$O(^ICPT(BHSCPT2,"ICD",SCODE)) Q:SCODE=""!(SCODE="B")!(MATCH=1)  D
  1.  ......I $P($G(^ICD0(SCODE,0)),U,1)=$P($P(Z,U,4),"-",1) S MATCH=1
  1.  ...I MATCH=0 D
  1.  ....S BHSCNT=BHSCNT+1
  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_CODE
  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=""         ;Patch 12 quit if no CPT on the transcode
  1.  .I '$$ICD^ATXAPI(BHCPTI,BHT,1) Q  ;not a cpt wanted on this component
  1.  .Q:$D(BHHOSC(BHSIVD,"CPT",BHCPT))
  1.  .S BHSNRQ=$P(^ICPT(BHCPTI,0),U,2)
  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.  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)
  1.  .. S BHSNRQ=$P(BHHOSA(BHSIVD,"CPT",BHIEN),U,2)
  1.  .. S BHSDS=$P(BHHOSA(BHSIVD,"CPT",BHIEN),U,1)
  1.  .. S BHSICD=$P(BHHOSA(BHSIVD,"CPT",BHIEN),U,4)
  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.  ; <CLEANUP>
  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^BHSSUR 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^ATXCHK(BHCPT,$O(^ATXAX(""B"",""APCH HS MINOR PROCEDURE CPTS"",0)),1) S %=1"
  1.  D DISPREF^BHSRAD
  1. HOSX K BHSFN,BHSOP,BHST,BHSS,BHSDFN,BHSICD,BHSNRQ,BHSDAT,BHSDS,BHSICL,BHSIVD,BHSCOD,BHSCNT,BHSOPN,BHSOP,Y,X,V
  1.  K BHHOSA,BHHOSC,MATCH,SCODE,I,Z,BHSCPT2
  1.  Q
  1. MINORX K BHSFN,BHSOP,BHST,BHSS,BHSDFN,BHSICD,BHSNRQ,BHSDAT,BHSDS,BHSICL,BHSIVD,BHSCOD,BHSCNT,BHSOPN,BHSOP,Y,X,V,I,Z,BHCPTI,BIEN,BHSIEN,BHT,BHCPT,BHIEN,MATCH,SCODE,BHSCPT2,
  1.  Q