BHSHS1 ;IHS/CIA/MGH - Health Summary for pt history components ;30-Nov-2015 10:25;DU
;;1.0;HEALTH SUMMARY COMPONENTS;**1,2,3,9,10,11,12**;March 17, 2006;Build 3
;===================================================================
;VA health summary components for history components
;includes family hx, personal hx, and surgical hx
;Taken from APCHS6
; IHS/TUCSON/LAB - PART 6 OF APCHS -- SUMMARY PRODUCTION COMPONENTS ;
;;2.0;IHS RPMS/PCC Health Summary;**11**;JUN 24, 1997
;Patch 1 changes made up to IHS patch 14
;Patch 2 chages made up to IHS patch 16
;Patch 3 changes made up to bjpc version 2
;Patch 12 used new API for taxonomies
FMH ; ******************** FAMILY HISTORY * 9000014 *******
; <SETUP>
N BHSPAT,BHSQ
S BHSPAT=DFN
Q:'$D(^AUPNFH("AC",BHSPAT))
D CKP^GMTSUP Q:$D(GMTSQIT)
; <DISPLAY>
S BHSDFN="" F BHSQ=0:0 S BHSDFN=$O(^AUPNFH("AC",BHSPAT,BHSDFN)) Q:BHSDFN="" D FHDSP
; <CLEANUP>
FMHX K BHSDFN,BHSN,BHSICD,BHSDAT,BHSNRQ,BHSICL,X,R,S,N,A
Q
FHDSP S BHSN=^AUPNFH(BHSDFN,0)
S BHSICD=$P(BHSN,U,1) D GETICDDX^BHSUTL
S X=$P(BHSN,U,3) D REGDT4^GMTSU S BHSDAT=X
S BHSNRQ=$P(BHSN,U,4)
D GETNARR^BHSUTL
D CKP^GMTSUP Q:$D(GMTSQIT) W BHSDAT_" " ;S BHSICL=10 D PRTICD^BHSUTL
S (X,R,S,N,A)=""
S R=$$VAL^XBDIQ1(9000014,BHSDFN,.07)
S N=$$VAL^XBDIQ1(9000014,BHSDFN,.04)_" ("_$$VAL^XBDIQ1(9000014,BHSDFN,.01)_")"
S A=$P(^AUPNFH(BHSDFN,0),U,5)
S S=$$VAL^XBDIQ1(9000014,BHSDFN,.06)
S X=X_$S(R]"":R_"; ",1:"")
S X=X_$S(N]"":N_"; ",1:"")
S X=X_$S(A]"":A_"; ",1:"")
S X=X_$S(S]"":S_"; ",1:"")
W ?10,X,!
Q
;
PMH ; ******************** PERSONAL HISTORY * 9000013 *******
; <SETUP>
N BHSPAT,BHSQ,BHSNTE,X
S BHSPAT=DFN
Q:'$D(^AUPNPH("AC",BHSPAT))
D CKP^GMTSUP Q:$D(GMTSQIT)
; <DISPLAY>
S BHSDFN="" F BHSQ=0:0 S BHSDFN=$O(^AUPNPH("AC",BHSPAT,BHSDFN)) Q:BHSDFN="" D PHDSP
; <CLEANUP>
PMHX K BHSDFN,BHSN,BHSICD,BHSICL,BHSNRQ,BHSDAT,BHSDTH
Q
PHDSP S BHSN=^AUPNPH(BHSDFN,0)
S BHSICD=$P(BHSN,U,1) D GETICDDX^BHSUTL
S X=$P(BHSN,U,3) D REGDT4^GMTSU S BHSDAT=X
S BHSDTH=$P(BHSN,U,5) I BHSDTH]"" S X=BHSDTH D REGDT4^GMTSU S BHSDTH=X
S BHSNRQ=$P(BHSN,U,4)
D GETNARR^BHSUTL
K BHSDTE S:BHSDTH]"" BHSNTE="(onset: "_BHSDTH_")"
D CKP^GMTSUP Q:$D(GMTSQIT) W BHSDAT_" " S BHSICL=10 D PRTICD^BHSUTL
Q
;
HOS ; ************* HISTORY OF SURGERY * 9000010.08 (V PROCEDURE)& CPT *******
; <SETUP>
N BHSPAT,BHSNTE,BHSQ,BHSDFN,BHSICD,BHSN,BHSCNT,BHSNRQ,BHSIVD,BHSDS,BHHOSA,BHSNRQ1
N BHT,BHCPT,BHSIEN,BHCPTI,BHSCSVD,BHSCPT2,I,MATCH,SCODE,Z,CODE
S BHSPAT=DFN,BHSCNT=0
;Q:'$D(^AUPNVPRC("AC",BHSPAT))
D CKP^GMTSUP Q:$D(GMTSQIT)
S BHSCNT=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 ;D HOSDSP Q:$D(GMTSQIT)
..S BHSICD=$P(^AUPNVPRC(BHSDFN,0),U)
..S BHSN=^AUPNVPRC(BHSDFN,0)
..D HOSCHK Q:BHSICD=""
..S BHSCNT=BHSCNT+1
..S BHSCSVD=+^AUPNVSIT($P(BHSN,U,3),0)\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="" D
...;Patch 9 for ICD-10
...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
..S BHSNRQ1=$P($$ICDOP^ICDEX($P(BHSN,U,1),BHSDAT,"","I"),U,2)
..S BHSDS="DATE?" D
...S X=$P(BHSN,U,6) I X]"" D REGDT4^GMTSU S BHSDS=X Q
...S X=(9999999-BHSIVD) D REGDT4^GMTSU S BHSDS=X
..D GETOPRV
..S BHHOSA(BHSIVD,"PRC",BHSDFN)=BHSDS_U_BHSNRQ_U_BHSOP_U_BHSNRQ1
;now go through v cpt
S BHT=$O(^ATXAX("B","APCH HS MAJOR PROCEDURE CPTS",0))
S BHCPTI=0 F S BHCPTI=$O(^AUPNVCPT("AA",BHSPAT,BHCPTI)) Q:BHCPTI'=+BHCPTI D
.;IHS/MSC/MGH Patch 11 new check
.S CODE=$P($G(^ICPT(BHCPTI,0)),U)
.I '$$ICD^ATXAPI(CODE,BHT,1) Q ;not a cpt wanted on this compone
.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=$P(+^AUPNVSIT($P(BHSN,U,3),0),".")
...I BHSNRQ="" S BHSNRQ=$P($$CPT^ICPTCOD($P(BHSN,U,1),BHSVDT),U,3)
...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 ;
...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
.S CODE=$P($G(^ICPT(BHCPTI,0)),U)
.I '$$ICD^ATXAPI(CODE,BHT,1) Q ;not a cpt wanted on this compone
.Q:$D(BHHOSC(BHSIVD,"CPT",BHCPT))
.;S BHSNRQ=$P(^ICPT(BHCPTI,0),U,2)
.S BHSNRQ=$P($$CPT^ICPTCOD(BHCPTI,V),U,3)
.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
W ?1,"TIME",?12,"USER",?30,"CODE AND TEXT",!
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) ;the user
.. S BHSNRQ=$P(BHHOSA(BHSIVD,"CPT",BHIEN),U,2) ;the narrative
.. S BHSDS=$P(BHHOSA(BHSIVD,"CPT",BHIEN),U,1) ;the date
.. S BHSICD=$P(BHHOSA(BHSIVD,"CPT",BHIEN),U,4) ;the code and text
.. 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.",!
; 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^BHSHS1 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^ATXAPI(BHCPT,$O(^ATXAX(""B"",""APCH HS MAJOR PROCEDURE CPTS"",0)),1) S %=1"
D DISPREF^BHSRAD
; <CLEANUP>
HOSX K BHSDFN,BHSICD,BHSNRQ,BHSDAT,BHSDS,BHSICL,BHSIVD,BHSCOD,BHSCNT,BHSOPN,BHSOP,Y,BHIEN,BHHOSC,BHSS,BHST,BHSFN,V
Q
HOSDSP S BHSN=^AUPNVPRC(BHSDFN,0)
S BHSICD=$P(BHSN,U,1)
D HOSCHK Q:BHSICD=""
S BHSCNT=BHSCNT+1
S BHSCSVD=+^AUPNVSIT($P(BHSN,U,3),0)\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)
;Fixed patch 1001
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 BHSNRQ=$P($$ICDOP^ICDEX($P(BHSN,U,1),BHSDAT,"","I"),U,5) ;cmi/anch/maw 8/28/2007 code set versioning
.E S BHSNRQ1=BHSNRQ ;P11
.S BHSNRQ=$P($$ICDOP^ICDEX($P(BHSN,U,1),BHSDAT,"","I"),U,2)_" "_BHSNRQ1
E I BHSNRQ="" S BHSNRQ=$P($$ICDOP^ICDCODE($P(BHSN,U,1),BHSDAT),U,5) ;cmi/anch/maw 8/28/2007 code set versioning
;end patch
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 ?12,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,1)
I $$ICD^ATXAPI(BHSCOD,$O(^ATXAX("B","APCH MINOR SURGICAL PROCS",0)),0) S BHSICD=""
;I BHSCOD\1>85 S BHSICD="" Q
;I BHSCOD=69.7 S BHSICD="" Q
;I BHSCOD\1=23 S BHSICD="" Q
;I BHSCOD\1=24 S BHSICD="" Q
;I $E(BHSCOD,1,4)="38.9" S BHSICD="" Q
;I BHSCOD=73.09 S BHSICD="" Q
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
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
+2 ;===================================================================
+3 ;VA health summary components for history components
+4 ;includes family hx, personal hx, and surgical hx
+5 ;Taken from APCHS6
+6 ; IHS/TUCSON/LAB - PART 6 OF APCHS -- SUMMARY PRODUCTION COMPONENTS ;
+7 ;;2.0;IHS RPMS/PCC Health Summary;**11**;JUN 24, 1997
+8 ;Patch 1 changes made up to IHS patch 14
+9 ;Patch 2 chages made up to IHS patch 16
+10 ;Patch 3 changes made up to bjpc version 2
+11 ;Patch 12 used new API for taxonomies
FMH ; ******************** FAMILY HISTORY * 9000014 *******
+1 ; <SETUP>
+2 NEW BHSPAT,BHSQ
+3 SET BHSPAT=DFN
+4 IF '$DATA(^AUPNFH("AC",BHSPAT))
QUIT
+5 DO CKP^GMTSUP
IF $DATA(GMTSQIT)
QUIT
+6 ; <DISPLAY>
+7 SET BHSDFN=""
FOR BHSQ=0:0
SET BHSDFN=$ORDER(^AUPNFH("AC",BHSPAT,BHSDFN))
IF BHSDFN=""
QUIT
DO FHDSP
+8 ; <CLEANUP>
FMHX KILL BHSDFN,BHSN,BHSICD,BHSDAT,BHSNRQ,BHSICL,X,R,S,N,A
+1 QUIT
FHDSP SET BHSN=^AUPNFH(BHSDFN,0)
+1 SET BHSICD=$PIECE(BHSN,U,1)
DO GETICDDX^BHSUTL
+2 SET X=$PIECE(BHSN,U,3)
DO REGDT4^GMTSU
SET BHSDAT=X
+3 SET BHSNRQ=$PIECE(BHSN,U,4)
+4 DO GETNARR^BHSUTL
+5 ;S BHSICL=10 D PRTICD^BHSUTL
DO CKP^GMTSUP
IF $DATA(GMTSQIT)
QUIT
WRITE BHSDAT_" "
+6 SET (X,R,S,N,A)=""
+7 SET R=$$VAL^XBDIQ1(9000014,BHSDFN,.07)
+8 SET N=$$VAL^XBDIQ1(9000014,BHSDFN,.04)_" ("_$$VAL^XBDIQ1(9000014,BHSDFN,.01)_")"
+9 SET A=$PIECE(^AUPNFH(BHSDFN,0),U,5)
+10 SET S=$$VAL^XBDIQ1(9000014,BHSDFN,.06)
+11 SET X=X_$SELECT(R]"":R_"; ",1:"")
+12 SET X=X_$SELECT(N]"":N_"; ",1:"")
+13 SET X=X_$SELECT(A]"":A_"; ",1:"")
+14 SET X=X_$SELECT(S]"":S_"; ",1:"")
+15 WRITE ?10,X,!
+16 QUIT
+17 ;
PMH ; ******************** PERSONAL HISTORY * 9000013 *******
+1 ; <SETUP>
+2 NEW BHSPAT,BHSQ,BHSNTE,X
+3 SET BHSPAT=DFN
+4 IF '$DATA(^AUPNPH("AC",BHSPAT))
QUIT
+5 DO CKP^GMTSUP
IF $DATA(GMTSQIT)
QUIT
+6 ; <DISPLAY>
+7 SET BHSDFN=""
FOR BHSQ=0:0
SET BHSDFN=$ORDER(^AUPNPH("AC",BHSPAT,BHSDFN))
IF BHSDFN=""
QUIT
DO PHDSP
+8 ; <CLEANUP>
PMHX KILL BHSDFN,BHSN,BHSICD,BHSICL,BHSNRQ,BHSDAT,BHSDTH
+1 QUIT
PHDSP SET BHSN=^AUPNPH(BHSDFN,0)
+1 SET BHSICD=$PIECE(BHSN,U,1)
DO GETICDDX^BHSUTL
+2 SET X=$PIECE(BHSN,U,3)
DO REGDT4^GMTSU
SET BHSDAT=X
+3 SET BHSDTH=$PIECE(BHSN,U,5)
IF BHSDTH]""
SET X=BHSDTH
DO REGDT4^GMTSU
SET BHSDTH=X
+4 SET BHSNRQ=$PIECE(BHSN,U,4)
+5 DO GETNARR^BHSUTL
+6 KILL BHSDTE
IF BHSDTH]""
SET BHSNTE="(onset: "_BHSDTH_")"
+7 DO CKP^GMTSUP
IF $DATA(GMTSQIT)
QUIT
WRITE BHSDAT_" "
SET BHSICL=10
DO PRTICD^BHSUTL
+8 QUIT
+9 ;
HOS ; ************* HISTORY OF SURGERY * 9000010.08 (V PROCEDURE)& CPT *******
+1 ; <SETUP>
+2 NEW BHSPAT,BHSNTE,BHSQ,BHSDFN,BHSICD,BHSN,BHSCNT,BHSNRQ,BHSIVD,BHSDS,BHHOSA,BHSNRQ1
+3 NEW BHT,BHCPT,BHSIEN,BHCPTI,BHSCSVD,BHSCPT2,I,MATCH,SCODE,Z,CODE
+4 SET BHSPAT=DFN
SET BHSCNT=0
+5 ;Q:'$D(^AUPNVPRC("AC",BHSPAT))
+6 DO CKP^GMTSUP
IF $DATA(GMTSQIT)
QUIT
+7 SET BHSCNT=0
+8 ; <DISPLAY>
+9 SET BHSIVD=0
FOR
SET BHSIVD=$ORDER(^AUPNVPRC("AA",BHSPAT,BHSIVD))
IF 'BHSIVD
QUIT
Begin DoDot:1
+10 ;D HOSDSP Q:$D(GMTSQIT)
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 SET BHSCSVD=+^AUPNVSIT($PIECE(BHSN,U,3),0)\1
+16 DO GETICDOP^BHSUTL
+17 SET Y=$PIECE(BHSN,U,3)
SET X=+^AUPNVSIT(Y,0)\1
DO REGDT4^GMTSU
SET BHSDAT=X
+18 SET BHSNRQ=$PIECE(BHSN,U,4)
+19 IF BHSNRQ
DO GETNARR^BHSUTL
+20 IF BHSNRQ=""
Begin DoDot:3
+21 ;Patch 9 for ICD-10
+22 ;cmi/anch/maw 8/28/2007 code set
SET BHSNRQ=$PIECE($$ICDOP^ICDEX($PIECE(BHSN,U,1),+^AUPNVSIT($PIECE(BHSN,U,3),0)\1,"","I"),U,5)
End DoDot:3
+23 SET BHSNRQ1=$PIECE($$ICDOP^ICDEX($PIECE(BHSN,U,1),BHSDAT,"","I"),U,2)
+24 SET BHSDS="DATE?"
Begin DoDot:3
+25 SET X=$PIECE(BHSN,U,6)
IF X]""
DO REGDT4^GMTSU
SET BHSDS=X
QUIT
+26 SET X=(9999999-BHSIVD)
DO REGDT4^GMTSU
SET BHSDS=X
End DoDot:3
+27 DO GETOPRV
+28 SET BHHOSA(BHSIVD,"PRC",BHSDFN)=BHSDS_U_BHSNRQ_U_BHSOP_U_BHSNRQ1
End DoDot:2
End DoDot:1
+29 ;now go through v cpt
+30 SET BHT=$ORDER(^ATXAX("B","APCH HS MAJOR PROCEDURE CPTS",0))
+31 SET BHCPTI=0
FOR
SET BHCPTI=$ORDER(^AUPNVCPT("AA",BHSPAT,BHCPTI))
IF BHCPTI'=+BHCPTI
QUIT
Begin DoDot:1
+32 ;IHS/MSC/MGH Patch 11 new check
+33 SET CODE=$PIECE($GET(^ICPT(BHCPTI,0)),U)
+34 ;not a cpt wanted on this compone
IF '$$ICD^ATXAPI(CODE,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=$PIECE(+^AUPNVSIT($PIECE(BHSN,U,3),0),".")
+45 IF BHSNRQ=""
SET BHSNRQ=$PIECE($$CPT^ICPTCOD($PIECE(BHSN,U,1),BHSVDT),U,3)
+46 ;
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_BHSICD
+47 SET BHHOSC(BHSIVD,"CPT",$PIECE(^ICPT($PIECE(BHSN,U,1),0),U,1))=""
End DoDot:3
End DoDot:2
End DoDot:1
+48 ;now get all tran codes hcpcs
+49 SET BHSIEN=0
FOR
SET BHSIEN=$ORDER(^AUPNVTC("AC",BHSPAT,BHSIEN))
IF BHSIEN=""
QUIT
Begin DoDot:1
+50 IF '$DATA(^AUPNVTC(BHSIEN))
QUIT
+51 SET V=$PIECE(^AUPNVTC(BHSIEN,0),U,3)
+52 IF 'V
QUIT
+53 IF '$DATA(^AUPNVSIT(V,0))
QUIT
+54 SET V=$PIECE($PIECE(^AUPNVSIT(V,0),U),".")
+55 SET X=V
DO REGDT4^GMTSU
SET BHSDS=X
+56 SET BHSIVD=9999999-V
+57 SET BHCPT=$$VAL^XBDIQ1(9000010.33,BHSIEN,.07)
+58 SET BHCPTI=$PIECE(^AUPNVTC(BHSIEN,0),U,7)
+59 IF 'BHCPTI
QUIT
+60 SET CODE=$PIECE($GET(^ICPT(BHCPTI,0)),U)
+61 ;not a cpt wanted on this compone
IF '$$ICD^ATXAPI(CODE,BHT,1)
QUIT
+62 IF $DATA(BHHOSC(BHSIVD,"CPT",BHCPT))
QUIT
+63 ;S BHSNRQ=$P(^ICPT(BHCPTI,0),U,2)
+64 SET BHSNRQ=$PIECE($$CPT^ICPTCOD(BHCPTI,V),U,3)
+65 SET BHSICD=BHCPTI
+66 DO GETCPT^BHSUTL
+67 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
+68 ;now display the procedures/cpt codes
+69 WRITE ?1,"TIME",?12,"USER",?30,"CODE AND TEXT",!
+70 SET BHSIVD=0
FOR
SET BHSIVD=$ORDER(BHHOSA(BHSIVD))
IF BHSIVD=""!($DATA(GMTSQIT))
QUIT
Begin DoDot:1
+71 DO CKP^GMTSUP
IF $DATA(GMTSQIT)
QUIT
+72 SET BHIEN=0
FOR
SET BHIEN=$ORDER(BHHOSA(BHSIVD,"PRC",BHIEN))
IF BHIEN'=+BHIEN!($DATA(GMTSQIT))
QUIT
Begin DoDot:2
+73 SET BHSOP=$PIECE(BHHOSA(BHSIVD,"PRC",BHIEN),U,3)
+74 SET BHSNRQ=$PIECE(BHHOSA(BHSIVD,"PRC",BHIEN),U,2)
+75 SET BHSDS=$PIECE(BHHOSA(BHSIVD,"PRC",BHIEN),U,1)
+76 SET BHSICD=$PIECE(BHHOSA(BHSIVD,"PRC",BHIEN),U,4)
+77 WRITE BHSDS,?12,$EXTRACT(BHSOP,1,15)
SET BHSNTE=""
SET BHSICL=26
DO PRTICD^BHSUTL
End DoDot:2
+78 SET BHIEN=0
FOR
SET BHIEN=$ORDER(BHHOSA(BHSIVD,"CPT",BHIEN))
IF BHIEN'=+BHIEN!($DATA(GMTSQIT))
QUIT
Begin DoDot:2
+79 ;the user
SET BHSOP=$PIECE(BHHOSA(BHSIVD,"CPT",BHIEN),U,3)
+80 ;the narrative
SET BHSNRQ=$PIECE(BHHOSA(BHSIVD,"CPT",BHIEN),U,2)
+81 ;the date
SET BHSDS=$PIECE(BHHOSA(BHSIVD,"CPT",BHIEN),U,1)
+82 ;the code and text
SET BHSICD=$PIECE(BHHOSA(BHSIVD,"CPT",BHIEN),U,4)
+83 WRITE BHSDS,?12,$EXTRACT(BHSOP,1,15)
SET BHSNTE=""
SET BHSICL=26
DO PRTICD^BHSUTL
End DoDot:2
End DoDot:1
+84 IF 'BHSCNT
DO CKP^GMTSUP
IF $DATA(GMTSQIT)
QUIT
WRITE "Minor procedures are on file but have not been displayed.",!
+85 ; now display refusals for icd procedures
+86 SET BHSFN=80.1
SET BHST="PROCEDURE"
+87 SET BHSS="S %=0,BHSICD=$P(^AUPNPREF(BHSI,0),U,6) Q:'BHSICD D HOSCHK^BHSHS1 I BHSICD S %=1"
+88 DO DISPREF^BHSRAD
+89 SET BHSFN=81
SET BHST="CPT"
+90 ;IHS/MSC/MGH Patch 10
+91 SET 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"
+92 DO DISPREF^BHSRAD
+93 ; <CLEANUP>
HOSX KILL BHSDFN,BHSICD,BHSNRQ,BHSDAT,BHSDS,BHSICL,BHSIVD,BHSCOD,BHSCNT,BHSOPN,BHSOP,Y,BHIEN,BHHOSC,BHSS,BHST,BHSFN,V
+1 QUIT
HOSDSP SET BHSN=^AUPNVPRC(BHSDFN,0)
+1 SET BHSICD=$PIECE(BHSN,U,1)
+2 DO HOSCHK
IF BHSICD=""
QUIT
+3 SET BHSCNT=BHSCNT+1
+4 SET BHSCSVD=+^AUPNVSIT($PIECE(BHSN,U,3),0)\1
+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 ;Fixed patch 1001
+9 IF BHSNRQ
DO GETNARR^BHSUTL
+10 ;I BHSNRQ="" S BHSNRQ=$P(^ICD0($P(BHSN,U,1),0),U,4)
+11 ;Patch 9 for ICD-10
+12 IF $$AICD^BHSUTL
Begin DoDot:1
+13 ;cmi/anch/maw 8/28/2007 code set versioning
IF BHSNRQ=""
SET BHSNRQ=$PIECE($$ICDOP^ICDEX($PIECE(BHSN,U,1),BHSDAT,"","I"),U,5)
+14 ;P11
IF '$TEST
SET BHSNRQ1=BHSNRQ
+15 SET BHSNRQ=$PIECE($$ICDOP^ICDEX($PIECE(BHSN,U,1),BHSDAT,"","I"),U,2)_" "_BHSNRQ1
End DoDot:1
+16 ;cmi/anch/maw 8/28/2007 code set versioning
IF '$TEST
IF BHSNRQ=""
SET BHSNRQ=$PIECE($$ICDOP^ICDCODE($PIECE(BHSN,U,1),BHSDAT),U,5)
+17 ;end patch
+18 SET BHSDS="DATE?"
SET X=$PIECE(BHSN,U,6)
IF Y]""
DO REGDT4^GMTSU
SET BHSDS=X
+19 DO GETOPRV
+20 DO CKP^GMTSUP
IF $DATA(GMTSQIT)
QUIT
+21 WRITE BHSDS
WRITE ?12,BHSOP
SET BHSNTE=""
SET BHSICL=26
DO PRTICD^BHSUTL
+22 KILL BHSOP
+23 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 IF '$TEST
SET BHSCOD=$PIECE($$ICDOP^ICDCODE(BHSICD),U,1)
+5 IF $$ICD^ATXAPI(BHSCOD,$ORDER(^ATXAX("B","APCH MINOR SURGICAL PROCS",0)),0)
SET BHSICD=""
+6 ;I BHSCOD\1>85 S BHSICD="" Q
+7 ;I BHSCOD=69.7 S BHSICD="" Q
+8 ;I BHSCOD\1=23 S BHSICD="" Q
+9 ;I BHSCOD\1=24 S BHSICD="" Q
+10 ;I $E(BHSCOD,1,4)="38.9" S BHSICD="" Q
+11 ;I BHSCOD=73.09 S BHSICD="" Q
+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
