- 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
