- 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
