BHSCPT1 ;IHS/MSC/MGH - Health Summary for V CPT file ;31-Dec-2015 13:12;DU
;;1.0;HEALTH SUMMARY COMPONENTS;**7,9,13**;March 17, 2006;Build 6
;===================================================================
; IHS/TUCSON/LAB - PART 6 OF APCHS -- SUMMARY PRODUCTION COMPONENTS ; [ 05/04/04 2:46 PM ]
;Patch 7 added component for CPT selection codes
CPT ;EP - display cpt codes for select items, date limits are applicable
;For selected procedures see if you have a match
N GMTSI,GMTSF,GMTSC,CPT,CPTSEL
Q:'$D(GMTSEG(GMTSEGN,81))
S GMTSI=0 F GMTSI=0:0 S GMTSI=$O(GMTSEG(GMTSEGN,81,GMTSI)) Q:'+GMTSI D
.S CPT=$G(GMTSEG(GMTSEGN,81,GMTSI))
.S CPTSEL(CPT)=""
D SEL(.CPTSEL)
Q
SEL(ITEMS) ;
N BHSPAT,V,Y,OLDCPT,CNT,BHCPTI,BHSIVD,BHCPT,BHCPTA,BHIEN,BHSIVD,BHSNAR
S BHSPAT=DFN
I '$D(^AUPNVCPT("AA",BHSPAT)) Q ;no cpt codes for this patient
; <DISPLAY>
K BHCPTA
I $D(ITEMS)>0 D
.S CODE=0 F S CODE=$O(ITEMS(CODE)) Q:CODE="" D
..S LKUP=$P($G(^ICPT(CODE,0)),U,1)
..S BHCPTI=$O(^ICPT("BA",$G(LKUP)_" ",0))
..Q:BHCPTI=""
..S CNT=0
..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!(CNT+1>GMTSNDM) 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
....S CNT=CNT+1
D CKP^GMTSUP Q:$D(GMTSQIT)
W "DATE",?10,"LOC",?30,"CODE",?36,"CPT NARRATIVE",?72,"UNITS",!
S OLDCPT=""
S BHCPT=0 F S BHCPT=$O(BHCPTA(BHCPT)) Q:BHCPT=""!($D(GMTSQIT)) D
.D CKP^GMTSUP Q:$D(GMTSQIT) I GMTSNPG W "DATE",?10,"LOC",?30,"CODE",?36,"CPT NARRATIVE",?72,"UNITS",!
.I BHCPT'=OLDCPT W ! S OLDCPT=BHCPT
.S BHSIVD="" F S BHSIVD=$O(BHCPTA(BHCPT,BHSIVD)) Q:BHSIVD=""!($D(GMTSQIT)) D
..W $$DATE^BHSMU((9999999-BHSIVD))
..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 "DATE",?10,"LOC",?30,"CODE",?36,"CPT NARRATIVE",?72,"UNITS",!
...S %=$P(BHCPTA(BHCPT,BHSIVD,BHIEN),U,3)
...I % W ?10,$P($G(^AUTTLOC(%,0)),U,2)
...S %=$P(BHCPTA(BHCPT,BHSIVD,BHIEN),U,4)
...I % W ?22,$P($G(^DIC(40.7,%,9999999)),U)
...W ?30,BHCPT,?37,$E($P(BHCPTA(BHCPT,BHSIVD,BHIEN),U,1),1,36)
...W ?73,$P(BHCPTA(BHCPT,BHSIVD,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,%,CODE,CPTSEL
Q
BHSCPT1 ;IHS/MSC/MGH - Health Summary for V CPT file ;31-Dec-2015 13:12;DU
+1 ;;1.0;HEALTH SUMMARY COMPONENTS;**7,9,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 ;Patch 7 added component for CPT selection codes
CPT ;EP - display cpt codes for select items, date limits are applicable
+1 ;For selected procedures see if you have a match
+2 NEW GMTSI,GMTSF,GMTSC,CPT,CPTSEL
+3 IF '$DATA(GMTSEG(GMTSEGN,81))
QUIT
+4 SET GMTSI=0
FOR GMTSI=0:0
SET GMTSI=$ORDER(GMTSEG(GMTSEGN,81,GMTSI))
IF '+GMTSI
QUIT
Begin DoDot:1
+5 SET CPT=$GET(GMTSEG(GMTSEGN,81,GMTSI))
+6 SET CPTSEL(CPT)=""
End DoDot:1
+7 DO SEL(.CPTSEL)
+8 QUIT
SEL(ITEMS) ;
+1 NEW BHSPAT,V,Y,OLDCPT,CNT,BHCPTI,BHSIVD,BHCPT,BHCPTA,BHIEN,BHSIVD,BHSNAR
+2 SET BHSPAT=DFN
+3 ;no cpt codes for this patient
IF '$DATA(^AUPNVCPT("AA",BHSPAT))
QUIT
+4 ; <DISPLAY>
+5 KILL BHCPTA
+6 IF $DATA(ITEMS)>0
Begin DoDot:1
+7 SET CODE=0
FOR
SET CODE=$ORDER(ITEMS(CODE))
IF CODE=""
QUIT
Begin DoDot:2
+8 SET LKUP=$PIECE($GET(^ICPT(CODE,0)),U,1)
+9 SET BHCPTI=$ORDER(^ICPT("BA",$GET(LKUP)_" ",0))
+10 IF BHCPTI=""
QUIT
+11 SET CNT=0
+12 SET BHSIVD=""
FOR
SET BHSIVD=$ORDER(^AUPNVCPT("AA",BHSPAT,BHCPTI,BHSIVD))
IF BHSIVD=""!(BHSIVD>GMTSDLM)
QUIT
Begin DoDot:3
+13 SET BHIEN=0
FOR
SET BHIEN=$ORDER(^AUPNVCPT("AA",BHSPAT,BHCPTI,BHSIVD,BHIEN))
IF BHIEN'=+BHIEN!(CNT+1>GMTSNDM)
QUIT
Begin DoDot:4
+14 SET BHCPT=$$VAL^XBDIQ1(9000010.18,BHIEN,.01)
+15 ;IHS/MSC/MGH Patch 13
+16 SET BHSNAR=$$VAL^XBDIQ1(9000010.18,BHIEN,.04)
+17 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)
+18 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)
+19 SET Y=$$VALI^XBDIQ1(9000010,$PIECE(^AUPNVCPT(BHIEN,0),U,3),.08)
SET $PIECE(BHCPTA(BHCPT,BHSIVD,BHIEN),U,4)=Y
+20 SET CNT=CNT+1
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+21 DO CKP^GMTSUP
IF $DATA(GMTSQIT)
QUIT
+22 WRITE "DATE",?10,"LOC",?30,"CODE",?36,"CPT NARRATIVE",?72,"UNITS",!
+23 SET OLDCPT=""
+24 SET BHCPT=0
FOR
SET BHCPT=$ORDER(BHCPTA(BHCPT))
IF BHCPT=""!($DATA(GMTSQIT))
QUIT
Begin DoDot:1
+25 DO CKP^GMTSUP
IF $DATA(GMTSQIT)
QUIT
IF GMTSNPG
WRITE "DATE",?10,"LOC",?30,"CODE",?36,"CPT NARRATIVE",?72,"UNITS",!
+26 IF BHCPT'=OLDCPT
WRITE !
SET OLDCPT=BHCPT
+27 SET BHSIVD=""
FOR
SET BHSIVD=$ORDER(BHCPTA(BHCPT,BHSIVD))
IF BHSIVD=""!($DATA(GMTSQIT))
QUIT
Begin DoDot:2
+28 WRITE $$DATE^BHSMU((9999999-BHSIVD))
+29 SET BHIEN=0
FOR
SET BHIEN=$ORDER(BHCPTA(BHCPT,BHSIVD,BHIEN))
IF BHIEN'=+BHIEN!($DATA(GMTSQIT))
QUIT
Begin DoDot:3
+30 DO CKP^GMTSUP
IF $DATA(GMTSQIT)
QUIT
IF GMTSNPG
WRITE "DATE",?10,"LOC",?30,"CODE",?36,"CPT NARRATIVE",?72,"UNITS",!
+31 SET %=$PIECE(BHCPTA(BHCPT,BHSIVD,BHIEN),U,3)
+32 IF %
WRITE ?10,$PIECE($GET(^AUTTLOC(%,0)),U,2)
+33 SET %=$PIECE(BHCPTA(BHCPT,BHSIVD,BHIEN),U,4)
+34 IF %
WRITE ?22,$PIECE($GET(^DIC(40.7,%,9999999)),U)
+35 WRITE ?30,BHCPT,?37,$EXTRACT($PIECE(BHCPTA(BHCPT,BHSIVD,BHIEN),U,1),1,36)
+36 WRITE ?73,$PIECE(BHCPTA(BHCPT,BHSIVD,BHIEN),U,2)
+37 WRITE !
End DoDot:3
End DoDot:2
End DoDot:1
+38 ; <CLEANUP>
+39 ;now display CPT refusals
+40 ;S BHST="CPT",BHSFN=81 D DISPREF^BHSRAD
+41 ;K BHST,BHSFN
CPTALLX KILL BHSIVD,BHSDAT,BHCPT,BHIEN,BHCPTA,BHCPTI,%,CODE,CPTSEL
+1 QUIT
