BHSCPT ;IHS/MSC/MGH - Health Summary for V MED file ;31-Dec-2015 13:12;DU
;;1.0;HEALTH SUMMARY COMPONENTS;**2,13**;March 17, 2006;Build 6
;===================================================================
; IHS/TUCSON/LAB - PART 6 OF APCHS -- SUMMARY PRODUCTION COMPONENTS ; [ 05/04/04 2:46 PM ]
;;2.0;IHS RPMS/PCC Health Summary;**11,14,16**;JUN 24, 1997
;Patch 2 added components for CPT codes
CPTALL ;EP - display all cpt codes, date limits are applicable
N BHSPAT,V,Y,BHSNAR
S BHSPAT=DFN
I '$D(^AUPNVCPT("AA",BHSPAT)),'$D(^AUPNVTC("AC",BHSPAT)) Q ;no cpt codes for this patient
; <DISPLAY>
K BHCPTA
S BHCPTI=0 F S BHCPTI=$O(^AUPNVCPT("AA",BHSPAT,BHCPTI)) Q:BHCPTI="" D
.S BHSIVD="" F S BHSIVD=$O(^AUPNVCPT("AA",BHSPAT,BHCPTI,BHSIVD)) Q:BHSIVD=""!(BHSIVD>GMTSDLM) D
..S BHIEN=0 F S BHIEN=$O(^AUPNVCPT("AA",BHSPAT,BHCPTI,BHSIVD,BHIEN)) Q:BHIEN'=+BHIEN D
...S BHCPT=$$VAL^XBDIQ1(9000010.18,BHIEN,.01)
...;IHS/MSC/MGH Patch 13
...S BHSNAR=$$VAL^XBDIQ1(9000010.18,BHIEN,.04)
...I BHSNAR="" S BHCPTA(BHSIVD,BHCPT,BHIEN)=$P($$CPT^ICPTCOD(BHCPTI,(9999999-BHSIVD)),U,3)_U_$$VAL^XBDIQ1(9000010.18,BHIEN,.16)_U_$$VALI^XBDIQ1(9000010,$P(^AUPNVCPT(BHIEN,0),U,3),.06)
...E S BHCPTA(BHSIVD,BHCPT,BHIEN)=BHSNAR_U_$$VAL^XBDIQ1(9000010.18,BHIEN,.16)_U_$$VALI^XBDIQ1(9000010,$P(^AUPNVCPT(BHIEN,0),U,3),.06)
...S Y=$$VALI^XBDIQ1(9000010,$P(^AUPNVCPT(BHIEN,0),U,3),.08) S $P(BHCPTA(BHSIVD,BHCPT,BHIEN),U,4)=Y
;now get tran codes
S BHIEN=0 F S BHIEN=$O(^AUPNVTC("AC",BHSPAT,BHIEN)) Q:BHIEN="" D
.Q:'$D(^AUPNVTC(BHIEN))
.S V=$P(^AUPNVTC(BHIEN,0),U,3)
.Q:'V
.Q:'$D(^AUPNVSIT(V,0))
.S V=$P($P(^AUPNVSIT(V,0),U),".")
.S BHSIVD=9999999-V
.Q:BHSIVD>GMTSDLM
.S BHCPT=$$VAL^XBDIQ1(9000010.33,BHIEN,.07)
.Q:BHCPT=""
.S BHCPTI=$P(^AUPNVTC(BHIEN,0),U,7)
.Q:$D(BHCPTA(BHSIVD,BHCPT))
.S BHCPTA(BHSIVD,BHCPT,BHIEN)=$P($$CPT^ICPTCOD(BHCPTI,(9999999-BHSIVD)),U,3)_U_1_U_$$VALI^XBDIQ1(9000010,$P(^AUPNVTC(BHIEN,0),U,3),.06)
.S Y=$$VALI^XBDIQ1(9000010,$P(^AUPNVTC(BHIEN,0),U,3),.08) S $P(BHCPTA(BHSIVD,BHCPT,BHIEN),U,4)=Y
G:'$D(BHCPTA) CPTALLX
D CKP^GMTSUP Q:$D(GMTSQIT)
W ?28,"CODE",?34,"CPT NARRATIVE",?72,"UNITS",!
S BHSIVD=0 F S BHSIVD=$O(BHCPTA(BHSIVD)) Q:BHSIVD=""!($D(GMTSQIT)) D
.D CKP^GMTSUP Q:$D(GMTSQIT) I GMTSNPG W ?28,"CODE",?34,"CPT NARRATIVE",?72,"UNITS",!
.W $$DATE^BHSMU((9999999-BHSIVD))
.S BHCPT="" F S BHCPT=$O(BHCPTA(BHSIVD,BHCPT)) Q:BHCPT=""!($D(GMTSQIT)) D
..S BHIEN=0 F S BHIEN=$O(BHCPTA(BHSIVD,BHCPT,BHIEN)) Q:BHIEN'=+BHIEN!($D(GMTSQIT)) D
...D CKP^GMTSUP Q:$D(GMTSQIT) I GMTSNPG W ?28,"CODE",?35,"CPT NARRATIVE",?72,"UNITS",!
...S %=$P(BHCPTA(BHSIVD,BHCPT,BHIEN),U,3)
...I % W ?9,$P($G(^AUTTLOC(%,0)),U,2)
...S %=$P(BHCPTA(BHSIVD,BHCPT,BHIEN),U,4)
...I % W ?22,$P($G(^DIC(40.7,%,9999999)),U)
...W ?28,BHCPT,?35,$E($P(BHCPTA(BHSIVD,BHCPT,BHIEN),U,1),1,36)
...W ?73,$P(BHCPTA(BHSIVD,BHCPT,BHIEN),U,2)
...W !
; <CLEANUP>
;now display CPT refusals
S BHST="CPT",BHSFN=81 D DISPREF^BHSRAD
K BHST,BHSFN
CPTALLX K BHSIVD,BHSDAT,BHCPT,BHIEN,BHCPTA,BHCPTI,%
Q
CPTALLC ;EP - health summary component
S BHMRO=0
CPTALLC1 ;EP - display all cpt codes, date limits are applicable
S BHSPAT=DFN
I '$D(^AUPNVCPT("AA",BHSPAT)),'$D(^AUPNVTC("AC",BHSPAT)) Q ;no cpt codes for this patient
; <DISPLAY>
K BHCPTA,BHSNAR
S BHCPTI=0 F S BHCPTI=$O(^AUPNVCPT("AA",BHSPAT,BHCPTI)) Q:BHCPTI="" D
.S BHSIVD="",BHSIVC=0 F S BHSIVD=$O(^AUPNVCPT("AA",BHSPAT,BHCPTI,BHSIVD)) Q:BHSIVD=""!(BHSIVD>GMTSDLM) D
..S BHIEN=0 F S BHIEN=$O(^AUPNVCPT("AA",BHSPAT,BHCPTI,BHSIVD,BHIEN)) Q:BHIEN'=+BHIEN D
...S BHCPT=$$VAL^XBDIQ1(9000010.18,BHIEN,.01)
...;IHS/MSC/MGH Patch 13
...S BHSNAR=$$VAL^XBDIQ1(9000010.18,BHIEN,.04)
...I BHSNAR="" S BHCPTA(BHCPT,BHSIVD,BHIEN)=$P($$CPT^ICPTCOD(BHCPTI,(9999999-BHSIVD)),U,3)_U_$$VAL^XBDIQ1(9000010.18,BHIEN,.16)_U_$$VALI^XBDIQ1(9000010,$P(^AUPNVCPT(BHIEN,0),U,3),.06)
...E S BHCPTA(BHCPT,BHSIVD,BHIEN)=BHSNAR_U_$$VAL^XBDIQ1(9000010.18,BHIEN,.16)_U_$$VALI^XBDIQ1(9000010,$P(^AUPNVCPT(BHIEN,0),U,3),.06)
...S Y=$$VALI^XBDIQ1(9000010,$P(^AUPNVCPT(BHIEN,0),U,3),.08) S $P(BHCPTA(BHCPT,BHSIVD,BHIEN),U,4)=Y
;now get tran codes
S BHIEN=0 F S BHIEN=$O(^AUPNVTC("AC",BHSPAT,BHIEN)) Q:BHIEN="" D
.Q:'$D(^AUPNVTC(BHIEN))
.S V=$P(^AUPNVTC(BHIEN,0),U,3)
.Q:'V
.Q:'$D(^AUPNVSIT(V,0))
.S V=$P($P(^AUPNVSIT(V,0),U),".")
.S BHSIVD=9999999-V
.Q:BHSIVD>GMTSDLM
.S BHCPT=$$VAL^XBDIQ1(9000010.33,BHIEN,.07)
.Q:BHCPT=""
.S BHCPTI=$P(^AUPNVTC(BHIEN,0),U,7)
.Q:$D(BHCPTA(BHCPT,BHSIVD))
.S BHCPTA(BHCPT,BHSIVD,BHIEN)=$P($$CPT^ICPTCOD(BHCPTI,(9999999-BHSIVD)),U,3)_U_1_U_$$VALI^XBDIQ1(9000010,$P(^AUPNVTC(BHIEN,0),U,3),.06)
.S Y=$$VALI^XBDIQ1(9000010,$P(^AUPNVTC(BHIEN,0),U,3),.08) S $P(BHCPTA(BHCPT,BHSIVD,BHIEN),U,4)=Y
G:'$D(BHCPTA) CPTALLCX
D CKP^GMTSUP Q:$D(GMTSQIT)
W ?1,"CODE",?7,"DATE",?17,"CPT NARRATIVE",?54,"UNITS",?60,"FACILITY",?74,"CLN",!
S BHCPT=0,BHMRC=0 F S BHCPT=$O(BHCPTA(BHCPT)) Q:BHCPT=""!($D(GMTSQIT)) D
.D CKP^GMTSUP Q:$D(GMTSQIT) I GMTSNPG W ?1,"CODE",?7,"DATE",?17,"CPT NARRATIVE",?54,"UNITS",?60,"FACILITY",?74,"CLN",!
.W BHCPT
.I BHMRO D MREDISP Q
.S BHSIVD="" F S BHSIVD=$O(BHCPTA(BHCPT,BHSIVD)) Q:BHSIVD=""!($D(GMTSQIT)) D
..S BHMRC=0 S BHIEN=0 F S BHIEN=$O(BHCPTA(BHCPT,BHSIVD,BHIEN)) Q:BHIEN'=+BHIEN!($D(GMTSQIT)) D
...D CKP^GMTSUP Q:$D(GMTSQIT) I GMTSNPG W ?1,"CODE",?7,"DATE",?17,"CPT NARRATIVE",?54,"UNITS",?60,"FACILITY",?74,"CLN",!
...S BHMRC=BHMRC+1
...W ?7,$$DATE^BHSMU((9999999-BHSIVD))
...W ?17,$E($P(BHCPTA(BHCPT,BHSIVD,BHIEN),U,1),1,35)
...W ?54,$P(BHCPTA(BHCPT,BHSIVD,BHIEN),U,2)
...S %=$P(BHCPTA(BHCPT,BHSIVD,BHIEN),U,3)
...I % W ?60,$P($G(^AUTTLOC(%,0)),U,2)
...S %=$P(BHCPTA(BHCPT,BHSIVD,BHIEN),U,4)
...I % W ?74,$E($P($G(^DIC(40.7,%,9999999)),U),1,3)
...W !
; <CLEANUP>
;now display CPT refusals
S BHST="CPT",BHSFN=81 D DISPREF^BHSRAD
K BHST,BHSFN,BHMRO
CPTALLCX K BHSIVD,BHSDAT,BHCPT,BHMRC,BHSIVC,BHIEN,BHCPTA,BHCPTI,%
Q
MREDISP ;
S BHSIVD=0,BHSIVD=$O(BHCPTA(BHCPT,BHSIVD)) Q:BHSIVD>GMTSDLM D
.S BHIEN=0,BHIEN=$O(BHCPTA(BHCPT,BHSIVD,BHIEN)) D
..D CKP^GMTSUP Q:$D(GMTSQIT) I GMTSNPG W ?1,"CODE",?7,"DATE",?17,"CPT NARRATIVE",?54,"UNITS",?60,"FACILITY",?74,"CLN",!
..W ?7,$$DATE^BHSMU((9999999-BHSIVD))
..W ?17,$E($P(BHCPTA(BHCPT,BHSIVD,BHIEN),U,1),1,35)
..W ?54,$P(BHCPTA(BHCPT,BHSIVD,BHIEN),U,2)
..S %=$P(BHCPTA(BHCPT,BHSIVD,BHIEN),U,3)
..I % W ?60,$P($G(^AUTTLOC(%,0)),U,2)
..S %=$P(BHCPTA(BHCPT,BHSIVD,BHIEN),U,4)
..I % W ?74,$P($G(^DIC(40.7,%,9999999)),U)
..W !
.Q
Q
CPTMRE ;EP - health summary component, most recent of each cpt code
S BHMRO=1
G CPTALLC1
BHSCPT ;IHS/MSC/MGH - Health Summary for V MED file ;31-Dec-2015 13:12;DU
+1 ;;1.0;HEALTH SUMMARY COMPONENTS;**2,13**;March 17, 2006;Build 6
+2 ;===================================================================
+3 ; IHS/TUCSON/LAB - PART 6 OF APCHS -- SUMMARY PRODUCTION COMPONENTS ; [ 05/04/04 2:46 PM ]
+4 ;;2.0;IHS RPMS/PCC Health Summary;**11,14,16**;JUN 24, 1997
+5 ;Patch 2 added components for CPT codes
CPTALL ;EP - display all cpt codes, date limits are applicable
+1 NEW BHSPAT,V,Y,BHSNAR
+2 SET BHSPAT=DFN
+3 ;no cpt codes for this patient
IF '$DATA(^AUPNVCPT("AA",BHSPAT))
IF '$DATA(^AUPNVTC("AC",BHSPAT))
QUIT
+4 ; <DISPLAY>
+5 KILL BHCPTA
+6 SET BHCPTI=0
FOR
SET BHCPTI=$ORDER(^AUPNVCPT("AA",BHSPAT,BHCPTI))
IF BHCPTI=""
QUIT
Begin DoDot:1
+7 SET BHSIVD=""
FOR
SET BHSIVD=$ORDER(^AUPNVCPT("AA",BHSPAT,BHCPTI,BHSIVD))
IF BHSIVD=""!(BHSIVD>GMTSDLM)
QUIT
Begin DoDot:2
+8 SET BHIEN=0
FOR
SET BHIEN=$ORDER(^AUPNVCPT("AA",BHSPAT,BHCPTI,BHSIVD,BHIEN))
IF BHIEN'=+BHIEN
QUIT
Begin DoDot:3
+9 SET BHCPT=$$VAL^XBDIQ1(9000010.18,BHIEN,.01)
+10 ;IHS/MSC/MGH Patch 13
+11 SET BHSNAR=$$VAL^XBDIQ1(9000010.18,BHIEN,.04)
+12 IF BHSNAR=""
SET BHCPTA(BHSIVD,BHCPT,BHIEN)=$PIECE($$CPT^ICPTCOD(BHCPTI,(9999999-BHSIVD)),U,3)_U_$$VAL^XBDIQ1(9000010.18,BHIEN,.16)_U_$$VALI^XBDIQ1(9000010,$PIECE(^AUPNVCPT(BHIEN,0),U,3),.06)
+13 IF '$TEST
SET BHCPTA(BHSIVD,BHCPT,BHIEN)=BHSNAR_U_$$VAL^XBDIQ1(9000010.18,BHIEN,.16)_U_$$VALI^XBDIQ1(9000010,$PIECE(^AUPNVCPT(BHIEN,0),U,3),.06)
+14 SET Y=$$VALI^XBDIQ1(9000010,$PIECE(^AUPNVCPT(BHIEN,0),U,3),.08)
SET $PIECE(BHCPTA(BHSIVD,BHCPT,BHIEN),U,4)=Y
End DoDot:3
End DoDot:2
End DoDot:1
+15 ;now get tran codes
+16 SET BHIEN=0
FOR
SET BHIEN=$ORDER(^AUPNVTC("AC",BHSPAT,BHIEN))
IF BHIEN=""
QUIT
Begin DoDot:1
+17 IF '$DATA(^AUPNVTC(BHIEN))
QUIT
+18 SET V=$PIECE(^AUPNVTC(BHIEN,0),U,3)
+19 IF 'V
QUIT
+20 IF '$DATA(^AUPNVSIT(V,0))
QUIT
+21 SET V=$PIECE($PIECE(^AUPNVSIT(V,0),U),".")
+22 SET BHSIVD=9999999-V
+23 IF BHSIVD>GMTSDLM
QUIT
+24 SET BHCPT=$$VAL^XBDIQ1(9000010.33,BHIEN,.07)
+25 IF BHCPT=""
QUIT
+26 SET BHCPTI=$PIECE(^AUPNVTC(BHIEN,0),U,7)
+27 IF $DATA(BHCPTA(BHSIVD,BHCPT))
QUIT
+28 SET BHCPTA(BHSIVD,BHCPT,BHIEN)=$PIECE($$CPT^ICPTCOD(BHCPTI,(9999999-BHSIVD)),U,3)_U_1_U_$$VALI^XBDIQ1(9000010,$PIECE(^AUPNVTC(BHIEN,0),U,3),.06)
+29 SET Y=$$VALI^XBDIQ1(9000010,$PIECE(^AUPNVTC(BHIEN,0),U,3),.08)
SET $PIECE(BHCPTA(BHSIVD,BHCPT,BHIEN),U,4)=Y
End DoDot:1
+30 IF '$DATA(BHCPTA)
GOTO CPTALLX
+31 DO CKP^GMTSUP
IF $DATA(GMTSQIT)
QUIT
+32 WRITE ?28,"CODE",?34,"CPT NARRATIVE",?72,"UNITS",!
+33 SET BHSIVD=0
FOR
SET BHSIVD=$ORDER(BHCPTA(BHSIVD))
IF BHSIVD=""!($DATA(GMTSQIT))
QUIT
Begin DoDot:1
+34 DO CKP^GMTSUP
IF $DATA(GMTSQIT)
QUIT
IF GMTSNPG
WRITE ?28,"CODE",?34,"CPT NARRATIVE",?72,"UNITS",!
+35 WRITE $$DATE^BHSMU((9999999-BHSIVD))
+36 SET BHCPT=""
FOR
SET BHCPT=$ORDER(BHCPTA(BHSIVD,BHCPT))
IF BHCPT=""!($DATA(GMTSQIT))
QUIT
Begin DoDot:2
+37 SET BHIEN=0
FOR
SET BHIEN=$ORDER(BHCPTA(BHSIVD,BHCPT,BHIEN))
IF BHIEN'=+BHIEN!($DATA(GMTSQIT))
QUIT
Begin DoDot:3
+38 DO CKP^GMTSUP
IF $DATA(GMTSQIT)
QUIT
IF GMTSNPG
WRITE ?28,"CODE",?35,"CPT NARRATIVE",?72,"UNITS",!
+39 SET %=$PIECE(BHCPTA(BHSIVD,BHCPT,BHIEN),U,3)
+40 IF %
WRITE ?9,$PIECE($GET(^AUTTLOC(%,0)),U,2)
+41 SET %=$PIECE(BHCPTA(BHSIVD,BHCPT,BHIEN),U,4)
+42 IF %
WRITE ?22,$PIECE($GET(^DIC(40.7,%,9999999)),U)
+43 WRITE ?28,BHCPT,?35,$EXTRACT($PIECE(BHCPTA(BHSIVD,BHCPT,BHIEN),U,1),1,36)
+44 WRITE ?73,$PIECE(BHCPTA(BHSIVD,BHCPT,BHIEN),U,2)
+45 WRITE !
End DoDot:3
End DoDot:2
End DoDot:1
+46 ; <CLEANUP>
+47 ;now display CPT refusals
+48 SET BHST="CPT"
SET BHSFN=81
DO DISPREF^BHSRAD
+49 KILL BHST,BHSFN
CPTALLX KILL BHSIVD,BHSDAT,BHCPT,BHIEN,BHCPTA,BHCPTI,%
+1 QUIT
CPTALLC ;EP - health summary component
+1 SET BHMRO=0
CPTALLC1 ;EP - display all cpt codes, date limits are applicable
+1 SET BHSPAT=DFN
+2 ;no cpt codes for this patient
IF '$DATA(^AUPNVCPT("AA",BHSPAT))
IF '$DATA(^AUPNVTC("AC",BHSPAT))
QUIT
+3 ; <DISPLAY>
+4 KILL BHCPTA,BHSNAR
+5 SET BHCPTI=0
FOR
SET BHCPTI=$ORDER(^AUPNVCPT("AA",BHSPAT,BHCPTI))
IF BHCPTI=""
QUIT
Begin DoDot:1
+6 SET BHSIVD=""
SET BHSIVC=0
FOR
SET BHSIVD=$ORDER(^AUPNVCPT("AA",BHSPAT,BHCPTI,BHSIVD))
IF BHSIVD=""!(BHSIVD>GMTSDLM)
QUIT
Begin DoDot:2
+7 SET BHIEN=0
FOR
SET BHIEN=$ORDER(^AUPNVCPT("AA",BHSPAT,BHCPTI,BHSIVD,BHIEN))
IF BHIEN'=+BHIEN
QUIT
Begin DoDot:3
+8 SET BHCPT=$$VAL^XBDIQ1(9000010.18,BHIEN,.01)
+9 ;IHS/MSC/MGH Patch 13
+10 SET BHSNAR=$$VAL^XBDIQ1(9000010.18,BHIEN,.04)
+11 IF BHSNAR=""
SET BHCPTA(BHCPT,BHSIVD,BHIEN)=$PIECE($$CPT^ICPTCOD(BHCPTI,(9999999-BHSIVD)),U,3)_U_$$VAL^XBDIQ1(9000010.18,BHIEN,.16)_U_$$VALI^XBDIQ1(9000010,$PIECE(^AUPNVCPT(BHIEN,0),U,3),.06)
+12 IF '$TEST
SET BHCPTA(BHCPT,BHSIVD,BHIEN)=BHSNAR_U_$$VAL^XBDIQ1(9000010.18,BHIEN,.16)_U_$$VALI^XBDIQ1(9000010,$PIECE(^AUPNVCPT(BHIEN,0),U,3),.06)
+13 SET Y=$$VALI^XBDIQ1(9000010,$PIECE(^AUPNVCPT(BHIEN,0),U,3),.08)
SET $PIECE(BHCPTA(BHCPT,BHSIVD,BHIEN),U,4)=Y
End DoDot:3
End DoDot:2
End DoDot:1
+14 ;now get tran codes
+15 SET BHIEN=0
FOR
SET BHIEN=$ORDER(^AUPNVTC("AC",BHSPAT,BHIEN))
IF BHIEN=""
QUIT
Begin DoDot:1
+16 IF '$DATA(^AUPNVTC(BHIEN))
QUIT
+17 SET V=$PIECE(^AUPNVTC(BHIEN,0),U,3)
+18 IF 'V
QUIT
+19 IF '$DATA(^AUPNVSIT(V,0))
QUIT
+20 SET V=$PIECE($PIECE(^AUPNVSIT(V,0),U),".")
+21 SET BHSIVD=9999999-V
+22 IF BHSIVD>GMTSDLM
QUIT
+23 SET BHCPT=$$VAL^XBDIQ1(9000010.33,BHIEN,.07)
+24 IF BHCPT=""
QUIT
+25 SET BHCPTI=$PIECE(^AUPNVTC(BHIEN,0),U,7)
+26 IF $DATA(BHCPTA(BHCPT,BHSIVD))
QUIT
+27 SET BHCPTA(BHCPT,BHSIVD,BHIEN)=$PIECE($$CPT^ICPTCOD(BHCPTI,(9999999-BHSIVD)),U,3)_U_1_U_$$VALI^XBDIQ1(9000010,$PIECE(^AUPNVTC(BHIEN,0),U,3),.06)
+28 SET Y=$$VALI^XBDIQ1(9000010,$PIECE(^AUPNVTC(BHIEN,0),U,3),.08)
SET $PIECE(BHCPTA(BHCPT,BHSIVD,BHIEN),U,4)=Y
End DoDot:1
+29 IF '$DATA(BHCPTA)
GOTO CPTALLCX
+30 DO CKP^GMTSUP
IF $DATA(GMTSQIT)
QUIT
+31 WRITE ?1,"CODE",?7,"DATE",?17,"CPT NARRATIVE",?54,"UNITS",?60,"FACILITY",?74,"CLN",!
+32 SET BHCPT=0
SET BHMRC=0
FOR
SET BHCPT=$ORDER(BHCPTA(BHCPT))
IF BHCPT=""!($DATA(GMTSQIT))
QUIT
Begin DoDot:1
+33 DO CKP^GMTSUP
IF $DATA(GMTSQIT)
QUIT
IF GMTSNPG
WRITE ?1,"CODE",?7,"DATE",?17,"CPT NARRATIVE",?54,"UNITS",?60,"FACILITY",?74,"CLN",!
+34 WRITE BHCPT
+35 IF BHMRO
DO MREDISP
QUIT
+36 SET BHSIVD=""
FOR
SET BHSIVD=$ORDER(BHCPTA(BHCPT,BHSIVD))
IF BHSIVD=""!($DATA(GMTSQIT))
QUIT
Begin DoDot:2
+37 SET BHMRC=0
SET BHIEN=0
FOR
SET BHIEN=$ORDER(BHCPTA(BHCPT,BHSIVD,BHIEN))
IF BHIEN'=+BHIEN!($DATA(GMTSQIT))
QUIT
Begin DoDot:3
+38 DO CKP^GMTSUP
IF $DATA(GMTSQIT)
QUIT
IF GMTSNPG
WRITE ?1,"CODE",?7,"DATE",?17,"CPT NARRATIVE",?54,"UNITS",?60,"FACILITY",?74,"CLN",!
+39 SET BHMRC=BHMRC+1
+40 WRITE ?7,$$DATE^BHSMU((9999999-BHSIVD))
+41 WRITE ?17,$EXTRACT($PIECE(BHCPTA(BHCPT,BHSIVD,BHIEN),U,1),1,35)
+42 WRITE ?54,$PIECE(BHCPTA(BHCPT,BHSIVD,BHIEN),U,2)
+43 SET %=$PIECE(BHCPTA(BHCPT,BHSIVD,BHIEN),U,3)
+44 IF %
WRITE ?60,$PIECE($GET(^AUTTLOC(%,0)),U,2)
+45 SET %=$PIECE(BHCPTA(BHCPT,BHSIVD,BHIEN),U,4)
+46 IF %
WRITE ?74,$EXTRACT($PIECE($GET(^DIC(40.7,%,9999999)),U),1,3)
+47 WRITE !
End DoDot:3
End DoDot:2
End DoDot:1
+48 ; <CLEANUP>
+49 ;now display CPT refusals
+50 SET BHST="CPT"
SET BHSFN=81
DO DISPREF^BHSRAD
+51 KILL BHST,BHSFN,BHMRO
CPTALLCX KILL BHSIVD,BHSDAT,BHCPT,BHMRC,BHSIVC,BHIEN,BHCPTA,BHCPTI,%
+1 QUIT
MREDISP ;
+1 SET BHSIVD=0
SET BHSIVD=$ORDER(BHCPTA(BHCPT,BHSIVD))
IF BHSIVD>GMTSDLM
QUIT
Begin DoDot:1
+2 SET BHIEN=0
SET BHIEN=$ORDER(BHCPTA(BHCPT,BHSIVD,BHIEN))
Begin DoDot:2
+3 DO CKP^GMTSUP
IF $DATA(GMTSQIT)
QUIT
IF GMTSNPG
WRITE ?1,"CODE",?7,"DATE",?17,"CPT NARRATIVE",?54,"UNITS",?60,"FACILITY",?74,"CLN",!
+4 WRITE ?7,$$DATE^BHSMU((9999999-BHSIVD))
+5 WRITE ?17,$EXTRACT($PIECE(BHCPTA(BHCPT,BHSIVD,BHIEN),U,1),1,35)
+6 WRITE ?54,$PIECE(BHCPTA(BHCPT,BHSIVD,BHIEN),U,2)
+7 SET %=$PIECE(BHCPTA(BHCPT,BHSIVD,BHIEN),U,3)
+8 IF %
WRITE ?60,$PIECE($GET(^AUTTLOC(%,0)),U,2)
+9 SET %=$PIECE(BHCPTA(BHCPT,BHSIVD,BHIEN),U,4)
+10 IF %
WRITE ?74,$PIECE($GET(^DIC(40.7,%,9999999)),U)
+11 WRITE !
End DoDot:2
+12 QUIT
End DoDot:1
+13 QUIT
CPTMRE ;EP - health summary component, most recent of each cpt code
+1 SET BHMRO=1
+2 GOTO CPTALLC1
