BHSSUR ;IHS/CIA/MGH - Health Summary for minor surgery ;14-Dec-2015 16:56;DU
;;1.0;HEALTH SUMMARY COMPONENTS;**1,2,9,11,12**;March 17, 2006;Build 3
;===================================================================
;Taken from APCHS6A
; IHS/TUCSON/LAB - PART 6 OF APCHS -- SUMMARY PRODUCTION COMPONENTS ;
;;2.0;IHS RPMS/PCC Health Summary;;JUN 24, 1997
;VA health summary for minor surgery
;Patch 1 made changes up to patch 14 of health summary
;Patch 2 made changes for patch 16 of health summary and filters out duplicate ICD0/CPT codes
;Patch 12 used new API for taxonomies
;
MINORO ; ******** MINOR HISTORY OF SURGERY * 9000010.08 (V PROCEDURE) *******
; <SETUP>
N BHSPAT,BHSNTE,BHSN,BHSQ,TAXIEN
S BHSPAT=DFN
S TAXARR="",ARRAY=""
Q:'$D(^AUPNVPRC("AC",BHSPAT))
D CKP^GMTSUP Q:$D(GMTSQIT)
; <DISPLAY>
S TAXIEN=$O(^ATXAX("B","APCH MINOR SURGICAL PROCS",0))
S BHSIVD=0 F BHSQ=0:0 S BHSIVD=$O(^AUPNVPRC("AA",BHSPAT,BHSIVD)) Q:'BHSIVD D
.S BHSDFN=0 F BHSQ=0:0 S BHSDFN=$O(^AUPNVPRC("AA",BHSPAT,BHSIVD,BHSDFN)) Q:'BHSDFN D
..D HOSDSP Q:$D(GMTSQIT)
;Patch 2 changes for refusals
S BHSFN=80.1,BHST="PROCEDURE"
S BHSS="S %=0,BHSICD=$P(^AUPNPREF(BHSI,0),U,6) Q:'BHSICD D HOSCHK^BHSSUR I BHSICD S %=1"
D DISPREF^BHSRAD
K BHSDN,BHST,BHSS
;
; <CLEANUP>
MINOROX K BHSDFN,BHSICD,BHSNRQ,BHSDAT,BHSDS,BHSICL,BHSIVD,BHSCOD,BHSOPN,BHSOP,Y
Q
HOSDSP ;Get diagnosis
N X,Y
S BHSN=^AUPNVPRC(BHSDFN,0)
S BHSICD=$P(BHSN,U,1)
D HOSCHK Q:BHSICD=""
D GETICDOP^BHSUTL
S Y=$P(BHSN,U,3),X=+^AUPNVSIT(Y,0)\1 D REGDT4^GMTSU S BHSDAT=X
S BHSNRQ=$P(BHSN,U,4)
;Patch 8 changes
I BHSNRQ D GETNARR^BHSUTL
;I BHSNRQ="" S BHSNRQ=$P(^ICD0($P(BHSN,U,1),0),U,4)
I $$AICD^BHSUTL D
.I BHSNRQ="" S BHSNRQ=$P($$ICDOP^ICDEX($P(BHSN,U,1),BHSDAT,"","I"),U,5) ;cmi/anch/maw 8/28/2007 code set versioning
E D
.I BHSNRQ="" S BHSNRQ=$P($$ICDOP^ICDCODE($P(BHSN,U,1),BHSDAT),U,5) ;cmi/anch/maw 8/28/2007 code set versioning
;end changes
S BHSDS="DATE?",X=$P(BHSN,U,6) I Y]"" D REGDT4^GMTSU S BHSDS=X
D GETOPRV
D CKP^GMTSUP Q:$D(GMTSQIT)
W BHSDS W ?10,BHSOP S BHSNTE="" S BHSICL=26 D PRTICD^BHSUTL
K BHSOP
Q
HOSCHK ;
;S BHSCOD=+^ICD0(BHSICD,0)
;PATCH 9 for ICD-10
I $$AICD^BHSUTL S BHSCOD=$P($$ICDOP^ICDEX(BHSICD,"","","I"),U,1)
E S BHSCOD=$P($$ICDOP^ICDCODE(BHSICD),U,2) ;cmi/anch/maw 8/27/2007
;IHS/MSC/MGH Patch 11
Q:$$ICD^ATXAPI(BHSCOD,$O(^ATXAX("B","APCH MINOR SURGICAL PROCS",0)),0)
;Q:BHSCOD\1>85
;Q:BHSCOD=69.7
;Q:BHSCOD\1=23
;Q:BHSCOD\1=24
S BHSICD=""
Q
GETOPRV ;get Operating Provider
NEW BHSOPN
S BHSOP=""
S BHSOPN=$P(BHSN,U,11)
Q:'+BHSOPN
S BHSOP=$E($P($G(^VA(200,BHSOPN,0)),U,1),1,15) ;provider name
Q
MINOR ; ************* HISTORY OF SURGERY * 9000010.08 (V PROCEDURE) & V CPT *
; <SETUP>
K BHHOSA,BHHOSC,TAXIEN,CODE,BHSNRQ1
S BHSPAT=DFN
I '$D(^AUPNVPRC("AC",BHSPAT)),'$D(^AUPNVCPT("AC",BHSPAT)) G MINORX
D CKP^GMTSUP Q:$D(GMTSQIT)
S BHSCNT=0
S TAXIEN=$O(^ATXAX("B","APCH MINOR SURGICAL PROCS",0))
; <DISPLAY>
S BHSIVD=0 F S BHSIVD=$O(^AUPNVPRC("AA",BHSPAT,BHSIVD)) Q:'BHSIVD D
.S BHSDFN=0 F S BHSDFN=$O(^AUPNVPRC("AA",BHSPAT,BHSIVD,BHSDFN)) Q:'BHSDFN D
..S BHSICD=$P(^AUPNVPRC(BHSDFN,0),U)
..S BHSN=^AUPNVPRC(BHSDFN,0)
..D HOSCHK Q:BHSICD=""
..S BHSCNT=BHSCNT+1
..D GETICDOP^BHSUTL
..S Y=$P(BHSN,U,3),X=+^AUPNVSIT(Y,0)\1 D REGDT4^GMTSU S BHSDAT=X
..S BHSNRQ=$P(BHSN,U,4)
..I BHSNRQ D GETNARR^BHSUTL
..;I BHSNRQ="" S BHSNRQ=$P(^ICD0($P(BHSN,U,1),0),U,4)
..;Patch 9 for ICD-10
..I $$AICD^BHSUTL D
...I BHSNRQ="" S BHSNRQ1=$P($$ICDOP^ICDEX($P(BHSN,U,1),BHSDAT,"","I"),U,5) ;cmi/anch/maw 8/28/2007 code set versioning
...E S BHSNRQ1=BHSNRQ
...S BHSNRQ=$P($$ICDOP^ICDEX($P(BHSN,U,1),BHSDAT,"","I"),U,2)_" "_BHSNRQ1 ;cmi/anch/maw 8/28/2007 code set versioning
..E D
...I BHSNRQ="" S BHSNRQ=$P($$ICDOP^ICDCODE($P(BHSN,U,1),BHSDAT),U,5) ;cmi/anch/maw 8/28/2007 code set versioning
..S BHSDS="DATE?",X=$P(BHSN,U,6) I X]"" D REGDT4^GMTSU S BHSDS=X
..D GETOPRV
..S BHHOSA(BHSIVD,"PRC",BHSDFN)=BHSDS_U_BHSNRQ_U_BHSOP
;now go through v cpt
S BHT=$O(^ATXAX("B","APCH HS MINOR PROCEDURE CPTS",0))
S BHCPTI=0 F S BHCPTI=$O(^AUPNVCPT("AA",BHSPAT,BHCPTI)) Q:BHCPTI'=+BHCPTI D
.S CODE=$P($G(^ICPT(BHCPTI,0)),U)
.I '$$ICD^ATXCHK(BHCPTI,BHT,1) Q ;not a cpt wanted on this component
.S BHSIVD=0 F S BHSIVD=$O(^AUPNVCPT("AA",BHSPAT,BHCPTI,BHSIVD)) Q:BHSIVD="" D
..S BHSIEN=0 F S BHSIEN=$O(^AUPNVCPT("AA",BHSPAT,BHCPTI,BHSIVD,BHSIEN)) Q:BHSIEN'=+BHSIEN D
...S X=(9999999-BHSIVD) D REGDT4^GMTSU S BHSDS=X
...S BHSN=^AUPNVCPT(BHSIEN,0)
...S BHSICD=$P(BHSN,U,1)
...D GETCPT^BHSUTL
...S BHSNRQ=$P(BHSN,U,4)
...I BHSNRQ D GETNARR^BHSUTL
...N BHSVDT
...S BHSVDT=$S($P(BHSN,U,3):$P(+$G(^AUPNVSIT($P(BHSN,U,3),0)),"."),1:"")
...;I BHSNRQ="" S BHSNRQ=$P(^ICPT($P(BHSN,U,1),0),U,2)
...I BHSNRQ="" S BHSNRQ=$P($$CPT^ICPTCOD($P(BHSN,U,1),BHSVDT),U,3)
...S CODE=$P($$CPT^ICPTCOD($P(BHSN,U,1),BHSVDT),U,2)
...;IHS/MSC/MGH filter out duplicates
...S MATCH=0
...S I="" F S I=$O(BHHOSA(BHSIVD,"PRC",I)) Q:I="" D
....S Z=$G(BHHOSA(BHSIVD,"PRC",I))
....S BHSCPT2=$P(BHSICD,"-",1)
....I $D(^ICPT(BHSCPT2,"ICD",0)) D
.....S SCODE=0 F S SCODE=$O(^ICPT(BHSCPT2,"ICD",SCODE)) Q:SCODE=""!(SCODE="B")!(MATCH=1) D
......I $P($G(^ICD0(SCODE,0)),U,1)=$P($P(Z,U,4),"-",1) S MATCH=1
...I MATCH=0 D
....S BHSCNT=BHSCNT+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
....S BHHOSC(BHSIVD,"CPT",$P(^ICPT($P(BHSN,U,1),0),U,1))=""
;now get all tran codes hcpcs
S BHSIEN=0 F S BHSIEN=$O(^AUPNVTC("AC",BHSPAT,BHSIEN)) Q:BHSIEN="" D
.Q:'$D(^AUPNVTC(BHSIEN))
.S V=$P(^AUPNVTC(BHSIEN,0),U,3)
.Q:'V
.Q:'$D(^AUPNVSIT(V,0))
.S V=$P($P(^AUPNVSIT(V,0),U),".")
.S X=V D REGDT4^GMTSU S BHSDS=X
.S BHSIVD=9999999-V
.S BHCPT=$$VAL^XBDIQ1(9000010.33,BHSIEN,.07)
.S BHCPTI=$P(^AUPNVTC(BHSIEN,0),U,7)
.Q:BHCPTI="" ;Patch 12 quit if no CPT on the transcode
.I '$$ICD^ATXAPI(BHCPTI,BHT,1) Q ;not a cpt wanted on this component
.Q:$D(BHHOSC(BHSIVD,"CPT",BHCPT))
.S BHSNRQ=$P(^ICPT(BHCPTI,0),U,2)
.S BHSICD=BHCPTI
.D GETCPT^BHSUTL
.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
;now display the procedures/cpt codes
S BHSIVD=0 F S BHSIVD=$O(BHHOSA(BHSIVD)) Q:BHSIVD=""!($D(GMTSQIT)) D
. D CKP^GMTSUP Q:$D(GMTSQIT)
. S BHIEN=0 F S BHIEN=$O(BHHOSA(BHSIVD,"PRC",BHIEN)) Q:BHIEN'=+BHIEN!($D(GMTSQIT)) D
.. S BHSOP=$P(BHHOSA(BHSIVD,"PRC",BHIEN),U,3)
.. S BHSNRQ=$P(BHHOSA(BHSIVD,"PRC",BHIEN),U,2)
.. S BHSDS=$P(BHHOSA(BHSIVD,"PRC",BHIEN),U,1)
.. S BHSICD=$P(BHHOSA(BHSIVD,"PRC",BHIEN),U,4)
.. W BHSDS,?12,$E(BHSOP,1,15) S BHSNTE="" S BHSICL=26 D PRTICD^BHSUTL
. S BHIEN=0 F S BHIEN=$O(BHHOSA(BHSIVD,"CPT",BHIEN)) Q:BHIEN'=+BHIEN!($D(GMTSQIT)) D
.. S BHSOP=$P(BHHOSA(BHSIVD,"CPT",BHIEN),U,3)
.. S BHSNRQ=$P(BHHOSA(BHSIVD,"CPT",BHIEN),U,2)
.. S BHSDS=$P(BHHOSA(BHSIVD,"CPT",BHIEN),U,1)
.. S BHSICD=$P(BHHOSA(BHSIVD,"CPT",BHIEN),U,4)
.. W BHSDS,?12,$E(BHSOP,1,15) S BHSNTE="" S BHSICL=26 D PRTICD^BHSUTL
I 'BHSCNT D CKP^GMTSUP Q:$D(GMTSQIT) W "Minor procedures are on file but have not been displayed.",!
; <CLEANUP>
; now display refusals for icd procedures
S BHSFN=80.1,BHST="PROCEDURE"
S BHSS="S %=0,BHSICD=$P(^AUPNPREF(BHSI,0),U,6) Q:'BHSICD D HOSCHK^BHSSUR I BHSICD S %=1"
D DISPREF^BHSRAD
S BHSFN=81,BHST="CPT"
;IHS/MSC/MGH Patch 10
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"
D DISPREF^BHSRAD
HOSX K BHSFN,BHSOP,BHST,BHSS,BHSDFN,BHSICD,BHSNRQ,BHSDAT,BHSDS,BHSICL,BHSIVD,BHSCOD,BHSCNT,BHSOPN,BHSOP,Y,X,V
K BHHOSA,BHHOSC,MATCH,SCODE,I,Z,BHSCPT2
Q
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,
Q
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
+2 ;===================================================================
+3 ;Taken from APCHS6A
+4 ; IHS/TUCSON/LAB - PART 6 OF APCHS -- SUMMARY PRODUCTION COMPONENTS ;
+5 ;;2.0;IHS RPMS/PCC Health Summary;;JUN 24, 1997
+6 ;VA health summary for minor surgery
+7 ;Patch 1 made changes up to patch 14 of health summary
+8 ;Patch 2 made changes for patch 16 of health summary and filters out duplicate ICD0/CPT codes
+9 ;Patch 12 used new API for taxonomies
+10 ;
MINORO ; ******** MINOR HISTORY OF SURGERY * 9000010.08 (V PROCEDURE) *******
+1 ; <SETUP>
+2 NEW BHSPAT,BHSNTE,BHSN,BHSQ,TAXIEN
+3 SET BHSPAT=DFN
+4 SET TAXARR=""
SET ARRAY=""
+5 IF '$DATA(^AUPNVPRC("AC",BHSPAT))
QUIT
+6 DO CKP^GMTSUP
IF $DATA(GMTSQIT)
QUIT
+7 ; <DISPLAY>
+8 SET TAXIEN=$ORDER(^ATXAX("B","APCH MINOR SURGICAL PROCS",0))
+9 SET BHSIVD=0
FOR BHSQ=0:0
SET BHSIVD=$ORDER(^AUPNVPRC("AA",BHSPAT,BHSIVD))
IF 'BHSIVD
QUIT
Begin DoDot:1
+10 SET BHSDFN=0
FOR BHSQ=0:0
SET BHSDFN=$ORDER(^AUPNVPRC("AA",BHSPAT,BHSIVD,BHSDFN))
IF 'BHSDFN
QUIT
Begin DoDot:2
+11 DO HOSDSP
IF $DATA(GMTSQIT)
QUIT
End DoDot:2
End DoDot:1
+12 ;Patch 2 changes for refusals
+13 SET BHSFN=80.1
SET BHST="PROCEDURE"
+14 SET BHSS="S %=0,BHSICD=$P(^AUPNPREF(BHSI,0),U,6) Q:'BHSICD D HOSCHK^BHSSUR I BHSICD S %=1"
+15 DO DISPREF^BHSRAD
+16 KILL BHSDN,BHST,BHSS
+17 ;
+18 ; <CLEANUP>
MINOROX KILL BHSDFN,BHSICD,BHSNRQ,BHSDAT,BHSDS,BHSICL,BHSIVD,BHSCOD,BHSOPN,BHSOP,Y
+1 QUIT
HOSDSP ;Get diagnosis
+1 NEW X,Y
+2 SET BHSN=^AUPNVPRC(BHSDFN,0)
+3 SET BHSICD=$PIECE(BHSN,U,1)
+4 DO HOSCHK
IF BHSICD=""
QUIT
+5 DO GETICDOP^BHSUTL
+6 SET Y=$PIECE(BHSN,U,3)
SET X=+^AUPNVSIT(Y,0)\1
DO REGDT4^GMTSU
SET BHSDAT=X
+7 SET BHSNRQ=$PIECE(BHSN,U,4)
+8 ;Patch 8 changes
+9 IF BHSNRQ
DO GETNARR^BHSUTL
+10 ;I BHSNRQ="" S BHSNRQ=$P(^ICD0($P(BHSN,U,1),0),U,4)
+11 IF $$AICD^BHSUTL
Begin DoDot:1
+12 ;cmi/anch/maw 8/28/2007 code set versioning
IF BHSNRQ=""
SET BHSNRQ=$PIECE($$ICDOP^ICDEX($PIECE(BHSN,U,1),BHSDAT,"","I"),U,5)
End DoDot:1
+13 IF '$TEST
Begin DoDot:1
+14 ;cmi/anch/maw 8/28/2007 code set versioning
IF BHSNRQ=""
SET BHSNRQ=$PIECE($$ICDOP^ICDCODE($PIECE(BHSN,U,1),BHSDAT),U,5)
End DoDot:1
+15 ;end changes
+16 SET BHSDS="DATE?"
SET X=$PIECE(BHSN,U,6)
IF Y]""
DO REGDT4^GMTSU
SET BHSDS=X
+17 DO GETOPRV
+18 DO CKP^GMTSUP
IF $DATA(GMTSQIT)
QUIT
+19 WRITE BHSDS
WRITE ?10,BHSOP
SET BHSNTE=""
SET BHSICL=26
DO PRTICD^BHSUTL
+20 KILL BHSOP
+21 QUIT
HOSCHK ;
+1 ;S BHSCOD=+^ICD0(BHSICD,0)
+2 ;PATCH 9 for ICD-10
+3 IF $$AICD^BHSUTL
SET BHSCOD=$PIECE($$ICDOP^ICDEX(BHSICD,"","","I"),U,1)
+4 ;cmi/anch/maw 8/27/2007
IF '$TEST
SET BHSCOD=$PIECE($$ICDOP^ICDCODE(BHSICD),U,2)
+5 ;IHS/MSC/MGH Patch 11
+6 IF $$ICD^ATXAPI(BHSCOD,$ORDER(^ATXAX("B","APCH MINOR SURGICAL PROCS",0)),0)
QUIT
+7 ;Q:BHSCOD\1>85
+8 ;Q:BHSCOD=69.7
+9 ;Q:BHSCOD\1=23
+10 ;Q:BHSCOD\1=24
+11 SET BHSICD=""
+12 QUIT
GETOPRV ;get Operating Provider
+1 NEW BHSOPN
+2 SET BHSOP=""
+3 SET BHSOPN=$PIECE(BHSN,U,11)
+4 IF '+BHSOPN
QUIT
+5 ;provider name
SET BHSOP=$EXTRACT($PIECE($GET(^VA(200,BHSOPN,0)),U,1),1,15)
+6 QUIT
MINOR ; ************* HISTORY OF SURGERY * 9000010.08 (V PROCEDURE) & V CPT *
+1 ; <SETUP>
+2 KILL BHHOSA,BHHOSC,TAXIEN,CODE,BHSNRQ1
+3 SET BHSPAT=DFN
+4 IF '$DATA(^AUPNVPRC("AC",BHSPAT))
IF '$DATA(^AUPNVCPT("AC",BHSPAT))
GOTO MINORX
+5 DO CKP^GMTSUP
IF $DATA(GMTSQIT)
QUIT
+6 SET BHSCNT=0
+7 SET TAXIEN=$ORDER(^ATXAX("B","APCH MINOR SURGICAL PROCS",0))
+8 ; <DISPLAY>
+9 SET BHSIVD=0
FOR
SET BHSIVD=$ORDER(^AUPNVPRC("AA",BHSPAT,BHSIVD))
IF 'BHSIVD
QUIT
Begin DoDot:1
+10 SET BHSDFN=0
FOR
SET BHSDFN=$ORDER(^AUPNVPRC("AA",BHSPAT,BHSIVD,BHSDFN))
IF 'BHSDFN
QUIT
Begin DoDot:2
+11 SET BHSICD=$PIECE(^AUPNVPRC(BHSDFN,0),U)
+12 SET BHSN=^AUPNVPRC(BHSDFN,0)
+13 DO HOSCHK
IF BHSICD=""
QUIT
+14 SET BHSCNT=BHSCNT+1
+15 DO GETICDOP^BHSUTL
+16 SET Y=$PIECE(BHSN,U,3)
SET X=+^AUPNVSIT(Y,0)\1
DO REGDT4^GMTSU
SET BHSDAT=X
+17 SET BHSNRQ=$PIECE(BHSN,U,4)
+18 IF BHSNRQ
DO GETNARR^BHSUTL
+19 ;I BHSNRQ="" S BHSNRQ=$P(^ICD0($P(BHSN,U,1),0),U,4)
+20 ;Patch 9 for ICD-10
+21 IF $$AICD^BHSUTL
Begin DoDot:3
+22 ;cmi/anch/maw 8/28/2007 code set versioning
IF BHSNRQ=""
SET BHSNRQ1=$PIECE($$ICDOP^ICDEX($PIECE(BHSN,U,1),BHSDAT,"","I"),U,5)
+23 IF '$TEST
SET BHSNRQ1=BHSNRQ
+24 ;cmi/anch/maw 8/28/2007 code set versioning
SET BHSNRQ=$PIECE($$ICDOP^ICDEX($PIECE(BHSN,U,1),BHSDAT,"","I"),U,2)_" "_BHSNRQ1
End DoDot:3
+25 IF '$TEST
Begin DoDot:3
+26 ;cmi/anch/maw 8/28/2007 code set versioning
IF BHSNRQ=""
SET BHSNRQ=$PIECE($$ICDOP^ICDCODE($PIECE(BHSN,U,1),BHSDAT),U,5)
End DoDot:3
+27 SET BHSDS="DATE?"
SET X=$PIECE(BHSN,U,6)
IF X]""
DO REGDT4^GMTSU
SET BHSDS=X
+28 DO GETOPRV
+29 SET BHHOSA(BHSIVD,"PRC",BHSDFN)=BHSDS_U_BHSNRQ_U_BHSOP
End DoDot:2
End DoDot:1
+30 ;now go through v cpt
+31 SET BHT=$ORDER(^ATXAX("B","APCH HS MINOR PROCEDURE CPTS",0))
+32 SET BHCPTI=0
FOR
SET BHCPTI=$ORDER(^AUPNVCPT("AA",BHSPAT,BHCPTI))
IF BHCPTI'=+BHCPTI
QUIT
Begin DoDot:1
+33 SET CODE=$PIECE($GET(^ICPT(BHCPTI,0)),U)
+34 ;not a cpt wanted on this component
IF '$$ICD^ATXCHK(BHCPTI,BHT,1)
QUIT
+35 SET BHSIVD=0
FOR
SET BHSIVD=$ORDER(^AUPNVCPT("AA",BHSPAT,BHCPTI,BHSIVD))
IF BHSIVD=""
QUIT
Begin DoDot:2
+36 SET BHSIEN=0
FOR
SET BHSIEN=$ORDER(^AUPNVCPT("AA",BHSPAT,BHCPTI,BHSIVD,BHSIEN))
IF BHSIEN'=+BHSIEN
QUIT
Begin DoDot:3
+37 SET X=(9999999-BHSIVD)
DO REGDT4^GMTSU
SET BHSDS=X
+38 SET BHSN=^AUPNVCPT(BHSIEN,0)
+39 SET BHSICD=$PIECE(BHSN,U,1)
+40 DO GETCPT^BHSUTL
+41 SET BHSNRQ=$PIECE(BHSN,U,4)
+42 IF BHSNRQ
DO GETNARR^BHSUTL
+43 NEW BHSVDT
+44 SET BHSVDT=$SELECT($PIECE(BHSN,U,3):$PIECE(+$GET(^AUPNVSIT($PIECE(BHSN,U,3),0)),"."),1:"")
+45 ;I BHSNRQ="" S BHSNRQ=$P(^ICPT($P(BHSN,U,1),0),U,2)
+46 IF BHSNRQ=""
SET BHSNRQ=$PIECE($$CPT^ICPTCOD($PIECE(BHSN,U,1),BHSVDT),U,3)
+47 SET CODE=$PIECE($$CPT^ICPTCOD($PIECE(BHSN,U,1),BHSVDT),U,2)
+48 ;IHS/MSC/MGH filter out duplicates
+49 SET MATCH=0
+50 SET I=""
FOR
SET I=$ORDER(BHHOSA(BHSIVD,"PRC",I))
IF I=""
QUIT
Begin DoDot:4
+51 SET Z=$GET(BHHOSA(BHSIVD,"PRC",I))
+52 SET BHSCPT2=$PIECE(BHSICD,"-",1)
+53 IF $DATA(^ICPT(BHSCPT2,"ICD",0))
Begin DoDot:5
+54 SET SCODE=0
FOR
SET SCODE=$ORDER(^ICPT(BHSCPT2,"ICD",SCODE))
IF SCODE=""!(SCODE="B")!(MATCH=1)
QUIT
Begin DoDot:6
+55 IF $PIECE($GET(^ICD0(SCODE,0)),U,1)=$PIECE($PIECE(Z,U,4),"-",1)
SET MATCH=1
End DoDot:6
End DoDot:5
End DoDot:4
+56 IF MATCH=0
Begin DoDot:4
+57 SET BHSCNT=BHSCNT+1
+58 SET BHHOSA(BHSIVD,"CPT",BHSIEN)=BHSDS_U_BHSNRQ_U_$SELECT($PIECE($GET(^AUPNVCPT(BHSIEN,12)),U,4):$$VAL^XBDIQ1(9000010.18,BHSIEN,1204),1:$$VAL^XBDIQ1(9000010.18,BHSIEN,1202))_U_CODE
+59 SET BHHOSC(BHSIVD,"CPT",$PIECE(^ICPT($PIECE(BHSN,U,1),0),U,1))=""
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+60 ;now get all tran codes hcpcs
+61 SET BHSIEN=0
FOR
SET BHSIEN=$ORDER(^AUPNVTC("AC",BHSPAT,BHSIEN))
IF BHSIEN=""
QUIT
Begin DoDot:1
+62 IF '$DATA(^AUPNVTC(BHSIEN))
QUIT
+63 SET V=$PIECE(^AUPNVTC(BHSIEN,0),U,3)
+64 IF 'V
QUIT
+65 IF '$DATA(^AUPNVSIT(V,0))
QUIT
+66 SET V=$PIECE($PIECE(^AUPNVSIT(V,0),U),".")
+67 SET X=V
DO REGDT4^GMTSU
SET BHSDS=X
+68 SET BHSIVD=9999999-V
+69 SET BHCPT=$$VAL^XBDIQ1(9000010.33,BHSIEN,.07)
+70 SET BHCPTI=$PIECE(^AUPNVTC(BHSIEN,0),U,7)
+71 ;Patch 12 quit if no CPT on the transcode
IF BHCPTI=""
QUIT
+72 ;not a cpt wanted on this component
IF '$$ICD^ATXAPI(BHCPTI,BHT,1)
QUIT
+73 IF $DATA(BHHOSC(BHSIVD,"CPT",BHCPT))
QUIT
+74 SET BHSNRQ=$PIECE(^ICPT(BHCPTI,0),U,2)
+75 SET BHSICD=BHCPTI
+76 DO GETCPT^BHSUTL
+77 SET BHHOSA(BHSIVD,"CPT",BHSIEN)=BHSDS_U_BHSNRQ_U_$SELECT($PIECE($GET(^AUPNVTC(BHSIEN,12)),U,4):$$VAL^XBDIQ1(9000010.33,BHSIEN,1204),1:$$VAL^XBDIQ1(9000010.33,BHSIEN,1202))_U_BHSICD
End DoDot:1
+78 ;now display the procedures/cpt codes
+79 SET BHSIVD=0
FOR
SET BHSIVD=$ORDER(BHHOSA(BHSIVD))
IF BHSIVD=""!($DATA(GMTSQIT))
QUIT
Begin DoDot:1
+80 DO CKP^GMTSUP
IF $DATA(GMTSQIT)
QUIT
+81 SET BHIEN=0
FOR
SET BHIEN=$ORDER(BHHOSA(BHSIVD,"PRC",BHIEN))
IF BHIEN'=+BHIEN!($DATA(GMTSQIT))
QUIT
Begin DoDot:2
+82 SET BHSOP=$PIECE(BHHOSA(BHSIVD,"PRC",BHIEN),U,3)
+83 SET BHSNRQ=$PIECE(BHHOSA(BHSIVD,"PRC",BHIEN),U,2)
+84 SET BHSDS=$PIECE(BHHOSA(BHSIVD,"PRC",BHIEN),U,1)
+85 SET BHSICD=$PIECE(BHHOSA(BHSIVD,"PRC",BHIEN),U,4)
+86 WRITE BHSDS,?12,$EXTRACT(BHSOP,1,15)
SET BHSNTE=""
SET BHSICL=26
DO PRTICD^BHSUTL
End DoDot:2
+87 SET BHIEN=0
FOR
SET BHIEN=$ORDER(BHHOSA(BHSIVD,"CPT",BHIEN))
IF BHIEN'=+BHIEN!($DATA(GMTSQIT))
QUIT
Begin DoDot:2
+88 SET BHSOP=$PIECE(BHHOSA(BHSIVD,"CPT",BHIEN),U,3)
+89 SET BHSNRQ=$PIECE(BHHOSA(BHSIVD,"CPT",BHIEN),U,2)
+90 SET BHSDS=$PIECE(BHHOSA(BHSIVD,"CPT",BHIEN),U,1)
+91 SET BHSICD=$PIECE(BHHOSA(BHSIVD,"CPT",BHIEN),U,4)
+92 WRITE BHSDS,?12,$EXTRACT(BHSOP,1,15)
SET BHSNTE=""
SET BHSICL=26
DO PRTICD^BHSUTL
End DoDot:2
End DoDot:1
+93 IF 'BHSCNT
DO CKP^GMTSUP
IF $DATA(GMTSQIT)
QUIT
WRITE "Minor procedures are on file but have not been displayed.",!
+94 ; <CLEANUP>
+95 ; now display refusals for icd procedures
+96 SET BHSFN=80.1
SET BHST="PROCEDURE"
+97 SET BHSS="S %=0,BHSICD=$P(^AUPNPREF(BHSI,0),U,6) Q:'BHSICD D HOSCHK^BHSSUR I BHSICD S %=1"
+98 DO DISPREF^BHSRAD
+99 SET BHSFN=81
SET BHST="CPT"
+100 ;IHS/MSC/MGH Patch 10
+101 SET 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"
+102 DO DISPREF^BHSRAD
HOSX KILL BHSFN,BHSOP,BHST,BHSS,BHSDFN,BHSICD,BHSNRQ,BHSDAT,BHSDS,BHSICL,BHSIVD,BHSCOD,BHSCNT,BHSOPN,BHSOP,Y,X,V
+1 KILL BHHOSA,BHHOSC,MATCH,SCODE,I,Z,BHSCPT2
+2 QUIT
MINORX KILL 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 QUIT
