APCHS6A ; IHS/CMI/LAB - PART 6 OF APCHS -- SUMMARY PRODUCTION COMPONENTS ;
;;2.0;IHS PCC SUITE;**11,12,14**;MAY 14, 2009;Build 12
;
;cmi/anch/maw 8/27/2007 code set versioninig in HOSCHK, HOSDSP, MINOR
;
MINORO ; ******** MINOR HISTORY OF SURGERY * 9000010.08 (V PROCEDURE) *******
; <SETUP>
Q:'$D(^AUPNVPRC("AC",APCHSPAT))
X APCHSCKP Q:$D(APCHSQIT) X:'APCHSNPG APCHSBRK
; <DISPLAY>
S APCHSIVD=0 F APCHSQ=0:0 S APCHSIVD=$O(^AUPNVPRC("AA",APCHSPAT,APCHSIVD)) Q:'APCHSIVD S APCHSDFN=0 F APCHSQ=0:0 S APCHSDFN=$O(^AUPNVPRC("AA",APCHSPAT,APCHSIVD,APCHSDFN)) Q:'APCHSDFN D HOSDSP Q:$D(APCHSQIT)
S APCHSFN=80.1,APCHST="PROCEDURE"
S APCHSS="S %=0,APCHSICD=$P(^AUPNPREF(APCHSI,0),U,6) Q:'APCHSICD D HOSCHK^APCHS6A I APCHSICD S %=1"
D DISPREF^APCHS3C
K APCHSFN,APCHST,APCHSS
;
; <CLEANUP>
MINOROX K APCHSDFN,APCHSICD,APCHSNRQ,APCHSDAT,APCHSDS,APCHSICL,APCHSIVD,APCHSCOD,APCHSOPN,APCHSOP,Y
Q
HOSDSP S APCHSN=^AUPNVPRC(APCHSDFN,0)
S APCHSICD=$P(APCHSN,U,1)
D HOSCHK Q:APCHSICD=""
S APCHCSVD=+^AUPNVSIT($P(APCHSN,U,3),0)\1
D GETICDOP^APCHSUTL
S Y=$P(APCHSN,U,3),Y=+^AUPNVSIT(Y,0)\1 X APCHSCVD S APCHSDAT=Y
S APCHSNRQ=$P(APCHSN,U,4)
;D GETNARR^APCHSUTL
I APCHSNRQ D GETNARR^APCHSUTL
;I APCHSNRQ="" S APCHSNRQ=$P(^ICD0($P(APCHSN,U,1),0),U,4) cmi/anch/maw 8/28/2007 orig line
I APCHSNRQ="" S APCHSNRQ=$P($$ICDOP^ICDEX($P(APCHSN,U,1),+^AUPNVSIT($P(APCHSN,U,3),0)\1,,"I"),U,5) ;cmi/anch/maw 8/28/2007 code set versioning
S APCHSDS="DATE?",Y=$P(APCHSN,U,6) I Y]"" X APCHSCVD S APCHSDS=Y
D GETOPRV
X APCHSCKP Q:$D(APCHSQIT)
W APCHSDS W ?10,APCHSOP S APCHSNTE="" S APCHSICL=26 D PRTICD^APCHSUTL
K APCHSOP
;W APCHSDS S APCHSNTE="" S APCHSICL=10 D PRTICD^APCHSUTL
Q
HOSCHK ;
;I $D(^TMP($J,"APCHMPRCTAX")) S:'$D(^TMP($J,"APCHMPRCTAX",APCHSICD)) APCHSICD="" Q
;
;THE FOLLOWING IS FOR ANYONE CALLING THIS API FROM OUTSIDE THIS ROUTINE. (E.G. BCCD)
;S APCHSCOD=$P($$ICDOP^ICDEX(APCHSICD,,,"I"),U,2) ;cmi/anch/maw 8/27/2007 code set versioning
I $$ICD^ATXAPI(APCHSICD,$O(^ATXAX("B","APCH MINOR SURGICAL PROCS",0)),0) Q
;Q:APCHSCOD\1>85
;Q:APCHSCOD=69.7
;Q:APCHSCOD\1=23
;Q:APCHSCOD\1=24
S APCHSICD=""
Q
GETOPRV ;get Operating Provider
NEW APCHSOPN
S APCHSOP=""
S APCHSOPN=$P(APCHSN,U,11)
Q:'+APCHSOPN
S APCHSOP=$E($S($P($G(^AUTTSITE(1,0)),U,22):$P(^VA(200,APCHSOPN,0),U),1:$P(^DIC(16,APCHSOPN,0),U)),1,15) ;provider name
Q
MINOR ; ************* HISTORY OF SURGERY * 9000010.08 (V PROCEDURE) & V CPT *******
; <SETUP>
K APCHHOSA,APCHHOSC
I '$D(^AUPNVPRC("AC",APCHSPAT)),'$D(^AUPNVCPT("AC",APCHSPAT)) G MINORX
X APCHSCKP Q:$D(APCHSQIT) X:'APCHSNPG APCHSBRK
S APCHSCNT=0
;K ^TMP($J,"APCHMPRCTAX") ;IHS/CMI/LAB - ICD SPEED UP
;S F=$NA(^TMP($J,"APCHMPRCTAX")) ;IHS/CMI/LAB - ICD SPEED UP
;D BLDTAX^ATXAPI("APCH MINOR SURGICAL PROCS",F,$O(^ATXAX("B","APCH MINOR SURGICAL PROCS",0))) ;IHS/CMI/LAB - ICD SPEED UP
; <DISPLAY>
S APCHSIVD=0 F S APCHSIVD=$O(^AUPNVPRC("AA",APCHSPAT,APCHSIVD)) Q:'APCHSIVD D
.S APCHSDFN=0 F S APCHSDFN=$O(^AUPNVPRC("AA",APCHSPAT,APCHSIVD,APCHSDFN)) Q:'APCHSDFN D
..S APCHSICD=$P(^AUPNVPRC(APCHSDFN,0),U)
..S APCHSN=^AUPNVPRC(APCHSDFN,0)
..D HOSCHK Q:APCHSICD=""
..S APCHSCNT=APCHSCNT+1
..S APCHCSVD=(9999999-APCHSIVD)
..D GETICDOP^APCHSUTL
..S Y=$P(APCHSN,U,3),Y=+^AUPNVSIT(Y,0)\1 X APCHSCVD S APCHSDAT=Y
..S APCHSNRQ=$P(APCHSN,U,4)
..I APCHSNRQ D GETNARR^APCHSUTL
..;I APCHSNRQ="" S APCHSNRQ=$P(^ICD0($P(APCHSN,U,1),0),U,4) cmi/anch/maw 8/28/2007 orig line
..I APCHSNRQ="" S APCHSNRQ=$P($$ICDOP^ICDEX($P(APCHSN,U,1),APCHCSVD,,"I"),U,5) ;cmi/anch/maw 8/28/2007 code set versioning
..;S APCHSDS="DATE?",Y=$P(APCHSN,U,6) I Y]"" X APCHSCVD S APCHSDS=Y
..S APCHSDS="DATE?" D
...S Y=$P(APCHSN,U,6) I Y]"" X APCHSCVD S APCHSDS=Y Q
...S Y=(9999999-APCHSIVD) X APCHSCVD S APCHSDS=Y
..D GETOPRV
..S APCHHOSA(APCHSIVD,"PRC",APCHSDFN)=APCHSDS_U_APCHSNRQ_U_APCHSOP
;now go through v cpt
S APCHT=$O(^ATXAX("B","APCH HS MINOR PROCEDURE CPTS",0))
;K ^TMP($J,"APCHMCPTTAX") ;IHS/CMI/LAB - ICD SPEED UP
;S F=$NA(^TMP($J,"APCHMCPTTAX")) ;IHS/CMI/LAB - ICD SPEED UP
;D BLDTAX^ATXAPI("APCH HS MINOR PROCEDURE CPTS",F,$O(^ATXAX("B","APCH HS MINOR PROCEDURE CPTS",0))) ;IHS/CMI/LAB - ICD SPEED UP
S APCHCPTI=0 F S APCHCPTI=$O(^AUPNVCPT("AA",APCHSPAT,APCHCPTI)) Q:APCHCPTI'=+APCHCPTI D
.I '$$ICD^ATXAPI(APCHCPTI,APCHT,1) Q ;not a cpt wanted on this component
.;Q:'$D(^TMP($J,"APCHMCPTTAX",APCHCPTI)) ;NOT A MINOR CPT
.S APCHSIVD=0 F S APCHSIVD=$O(^AUPNVCPT("AA",APCHSPAT,APCHCPTI,APCHSIVD)) Q:APCHSIVD="" D
..S APCHSIEN=0 F S APCHSIEN=$O(^AUPNVCPT("AA",APCHSPAT,APCHCPTI,APCHSIVD,APCHSIEN)) Q:APCHSIEN'=+APCHSIEN D
...S Y=(9999999-APCHSIVD) X APCHSCVD S APCHSDS=Y
...S APCHSN=^AUPNVCPT(APCHSIEN,0)
...S APCHSICD=$P(APCHSN,U,1)
...D GETCPT^APCHSUTL
...S APCHSNRQ=$P(APCHSN,U,4)
...I APCHSNRQ D GETNARR^APCHSUTL
...;cmi/anch/maw 8/28/2007 mods for code set versioning
...;I APCHSNRQ="" S APCHSNRQ=$P(^ICPT($P(APCHSN,U,1),0),U,2)
...N APCHSVDT
...S APCHSVDT=$S($P(APCHSN,U,3):$P(+$G(^AUPNVSIT($P(APCHSN,U,3),0)),"."),1:"")
...I APCHSNRQ="" S APCHSNRQ=$P($$CPT^ICPTCOD($P(APCHSN,U,1),APCHSVDT),U,3)
...;cmi/anch/maw 8/28/2007 end of mods
...S APCHHOSA(APCHSIVD,"CPT",APCHSIEN)=APCHSDS_U_APCHSNRQ_U_$S($P($G(^AUPNVCPT(APCHSIEN,12)),U,4):$$VAL^XBDIQ1(9000010.18,APCHSIEN,1204),1:$$VAL^XBDIQ1(9000010.18,APCHSIEN,1202))_U_APCHSICD
...S APCHHOSC(APCHSIVD,"CPT",$P(^ICPT($P(APCHSN,U,1),0),U,1))=""
;now get all tran codes hcpcs
S APCHSIEN=0 F S APCHSIEN=$O(^AUPNVTC("AC",APCHSPAT,APCHSIEN)) Q:APCHSIEN="" D
.Q:'$D(^AUPNVTC(APCHSIEN))
.S V=$P(^AUPNVTC(APCHSIEN,0),U,3)
.Q:'V
.Q:'$D(^AUPNVSIT(V,0))
.S V=$P($P(^AUPNVSIT(V,0),U),".")
.S Y=V X APCHSCVD S APCHSDS=Y
.S APCHSIVD=9999999-V
.S APCHCPT=$$VAL^XBDIQ1(9000010.33,APCHSIEN,.07)
.S APCHCPTI=$P(^AUPNVTC(APCHSIEN,0),U,7)
.;Q:'$D(^TMP($J,"APCHMCPTTAX",APCHCPTI)) ;NOT A MINOR CPT ;IHS/CMI/LAB - ICD SPEED UP
.I '$$ICD^ATXAPI(APCHCPTI,APCHT,1) Q ;not a cpt wanted on this component
.Q:$D(APCHHOSC(APCHSIVD,"CPT",APCHCPT))
.S APCHSNRQ=$P(^ICPT(APCHCPTI,0),U,2)
.S APCHSICD=APCHCPTI
.D GETCPT^APCHSUTL
.S APCHHOSA(APCHSIVD,"CPT",APCHSIEN)=APCHSDS_U_APCHSNRQ_U_$S($P($G(^AUPNVTC(APCHSIEN,12)),U,4):$$VAL^XBDIQ1(9000010.33,APCHSIEN,1204),1:$$VAL^XBDIQ1(9000010.33,APCHSIEN,1202))_U_APCHSICD
;now display the procedures/cpt codes
S APCHSIVD=0 F S APCHSIVD=$O(APCHHOSA(APCHSIVD)) Q:APCHSIVD=""!($D(APCHSQIT)) D
. X APCHSCKP Q:$D(APCHSQIT)
. S APCHIEN=0 F S APCHIEN=$O(APCHHOSA(APCHSIVD,"PRC",APCHIEN)) Q:APCHIEN'=+APCHIEN!($D(APCHSQIT)) D
.. S APCHSOP=$P(APCHHOSA(APCHSIVD,"PRC",APCHIEN),U,3)
.. S APCHSNRQ=$P(APCHHOSA(APCHSIVD,"PRC",APCHIEN),U,2)
.. S APCHSDS=$P(APCHHOSA(APCHSIVD,"PRC",APCHIEN),U,1)
.. S APCHSICD=$P(APCHHOSA(APCHSIVD,"PRC",APCHIEN),U,4)
.. W APCHSDS,?10,$E(APCHSOP,1,15) S APCHSNTE="" S APCHSICL=26 D PRTICD^APCHSUTL
. S APCHIEN=0 F S APCHIEN=$O(APCHHOSA(APCHSIVD,"CPT",APCHIEN)) Q:APCHIEN'=+APCHIEN!($D(APCHSQIT)) D
.. S APCHSOP=$P(APCHHOSA(APCHSIVD,"CPT",APCHIEN),U,3)
.. S APCHSNRQ=$P(APCHHOSA(APCHSIVD,"CPT",APCHIEN),U,2)
.. S APCHSDS=$P(APCHHOSA(APCHSIVD,"CPT",APCHIEN),U,1)
.. S APCHSICD=$P(APCHHOSA(APCHSIVD,"CPT",APCHIEN),U,4)
.. W APCHSDS,?10,$E(APCHSOP,1,15) S APCHSNTE="" S APCHSICL=26 D PRTICD^APCHSUTL
I 'APCHSCNT X APCHSCKP Q:$D(APCHSQIT) W "Minor procedures are on file but have not been displayed.",!
; <CLEANUP>
; now display refusals for icd procedures
S APCHSFN=80.1,APCHST="PROCEDURE"
S APCHSS="S %=0,APCHSICD=$P(^AUPNPREF(APCHSI,0),U,6) Q:'APCHSICD D HOSCHK^APCHS6A I APCHSICD S %=1"
D DISPREF^APCHS3C
S APCHSFN=81,APCHST="CPT"
S APCHSS="S %=0,APCHCPT=$P(^AUPNPREF(APCHSI,0),U,6) Q:'APCHCPT I $$ICD^ATXAPI(APCHCPT,$O(^ATXAX(""B"",""APCH HS MINOR PROCEDURE CPTS"",0)),1) S %=1"
D DISPREF^APCHS3C
HOSX K APCHSFN,APCHSOP,APCHST,APCHSS,APCHSDFN,APCHSICD,APCHSNRQ,APCHSDAT,APCHSDS,APCHSICL,APCHSIVD,APCHSCOD,APCHSCNT,APCHSOPN,APCHSOP,Y
K APCHHOSA,APCHHOSC
;K ^TMP($J,"APCHMPRCTAX"),^TMP($J,"APCHMCPTTAX")
Q
MINORX K APCHSFN,APCHSOP,APCHST,APCHSS,APCHSDFN,APCHSICD,APCHSNRQ,APCHSDAT,APCHSDS,APCHSICL,APCHSIVD,APCHSCOD,APCHSCNT,APCHSOPN,APCHSOP,Y
Q
APCHS6A ; IHS/CMI/LAB - PART 6 OF APCHS -- SUMMARY PRODUCTION COMPONENTS ;
+1 ;;2.0;IHS PCC SUITE;**11,12,14**;MAY 14, 2009;Build 12
+2 ;
+3 ;cmi/anch/maw 8/27/2007 code set versioninig in HOSCHK, HOSDSP, MINOR
+4 ;
MINORO ; ******** MINOR HISTORY OF SURGERY * 9000010.08 (V PROCEDURE) *******
+1 ; <SETUP>
+2 IF '$DATA(^AUPNVPRC("AC",APCHSPAT))
QUIT
+3 XECUTE APCHSCKP
IF $DATA(APCHSQIT)
QUIT
IF 'APCHSNPG
XECUTE APCHSBRK
+4 ; <DISPLAY>
+5 SET APCHSIVD=0
FOR APCHSQ=0:0
SET APCHSIVD=$ORDER(^AUPNVPRC("AA",APCHSPAT,APCHSIVD))
IF 'APCHSIVD
QUIT
SET APCHSDFN=0
FOR APCHSQ=0:0
SET APCHSDFN=$ORDER(^AUPNVPRC("AA",APCHSPAT,APCHSIVD,APCHSDFN))
IF 'APCHSDFN
QUIT
DO HOSDSP
IF $DATA(APCHSQIT)
QUIT
+6 SET APCHSFN=80.1
SET APCHST="PROCEDURE"
+7 SET APCHSS="S %=0,APCHSICD=$P(^AUPNPREF(APCHSI,0),U,6) Q:'APCHSICD D HOSCHK^APCHS6A I APCHSICD S %=1"
+8 DO DISPREF^APCHS3C
+9 KILL APCHSFN,APCHST,APCHSS
+10 ;
+11 ; <CLEANUP>
MINOROX KILL APCHSDFN,APCHSICD,APCHSNRQ,APCHSDAT,APCHSDS,APCHSICL,APCHSIVD,APCHSCOD,APCHSOPN,APCHSOP,Y
+1 QUIT
HOSDSP SET APCHSN=^AUPNVPRC(APCHSDFN,0)
+1 SET APCHSICD=$PIECE(APCHSN,U,1)
+2 DO HOSCHK
IF APCHSICD=""
QUIT
+3 SET APCHCSVD=+^AUPNVSIT($PIECE(APCHSN,U,3),0)\1
+4 DO GETICDOP^APCHSUTL
+5 SET Y=$PIECE(APCHSN,U,3)
SET Y=+^AUPNVSIT(Y,0)\1
XECUTE APCHSCVD
SET APCHSDAT=Y
+6 SET APCHSNRQ=$PIECE(APCHSN,U,4)
+7 ;D GETNARR^APCHSUTL
+8 IF APCHSNRQ
DO GETNARR^APCHSUTL
+9 ;I APCHSNRQ="" S APCHSNRQ=$P(^ICD0($P(APCHSN,U,1),0),U,4) cmi/anch/maw 8/28/2007 orig line
+10 ;cmi/anch/maw 8/28/2007 code set versioning
IF APCHSNRQ=""
SET APCHSNRQ=$PIECE($$ICDOP^ICDEX($PIECE(APCHSN,U,1),+^AUPNVSIT($PIECE(APCHSN,U,3),0)\1,,"I"),U,5)
+11 SET APCHSDS="DATE?"
SET Y=$PIECE(APCHSN,U,6)
IF Y]""
XECUTE APCHSCVD
SET APCHSDS=Y
+12 DO GETOPRV
+13 XECUTE APCHSCKP
IF $DATA(APCHSQIT)
QUIT
+14 WRITE APCHSDS
WRITE ?10,APCHSOP
SET APCHSNTE=""
SET APCHSICL=26
DO PRTICD^APCHSUTL
+15 KILL APCHSOP
+16 ;W APCHSDS S APCHSNTE="" S APCHSICL=10 D PRTICD^APCHSUTL
+17 QUIT
HOSCHK ;
+1 ;I $D(^TMP($J,"APCHMPRCTAX")) S:'$D(^TMP($J,"APCHMPRCTAX",APCHSICD)) APCHSICD="" Q
+2 ;
+3 ;THE FOLLOWING IS FOR ANYONE CALLING THIS API FROM OUTSIDE THIS ROUTINE. (E.G. BCCD)
+4 ;S APCHSCOD=$P($$ICDOP^ICDEX(APCHSICD,,,"I"),U,2) ;cmi/anch/maw 8/27/2007 code set versioning
+5 IF $$ICD^ATXAPI(APCHSICD,$ORDER(^ATXAX("B","APCH MINOR SURGICAL PROCS",0)),0)
QUIT
+6 ;Q:APCHSCOD\1>85
+7 ;Q:APCHSCOD=69.7
+8 ;Q:APCHSCOD\1=23
+9 ;Q:APCHSCOD\1=24
+10 SET APCHSICD=""
+11 QUIT
GETOPRV ;get Operating Provider
+1 NEW APCHSOPN
+2 SET APCHSOP=""
+3 SET APCHSOPN=$PIECE(APCHSN,U,11)
+4 IF '+APCHSOPN
QUIT
+5 ;provider name
SET APCHSOP=$EXTRACT($SELECT($PIECE($GET(^AUTTSITE(1,0)),U,22):$PIECE(^VA(200,APCHSOPN,0),U),1:$PIECE(^DIC(16,APCHSOPN,0),U)),1,15)
+6 QUIT
MINOR ; ************* HISTORY OF SURGERY * 9000010.08 (V PROCEDURE) & V CPT *******
+1 ; <SETUP>
+2 KILL APCHHOSA,APCHHOSC
+3 IF '$DATA(^AUPNVPRC("AC",APCHSPAT))
IF '$DATA(^AUPNVCPT("AC",APCHSPAT))
GOTO MINORX
+4 XECUTE APCHSCKP
IF $DATA(APCHSQIT)
QUIT
IF 'APCHSNPG
XECUTE APCHSBRK
+5 SET APCHSCNT=0
+6 ;K ^TMP($J,"APCHMPRCTAX") ;IHS/CMI/LAB - ICD SPEED UP
+7 ;S F=$NA(^TMP($J,"APCHMPRCTAX")) ;IHS/CMI/LAB - ICD SPEED UP
+8 ;D BLDTAX^ATXAPI("APCH MINOR SURGICAL PROCS",F,$O(^ATXAX("B","APCH MINOR SURGICAL PROCS",0))) ;IHS/CMI/LAB - ICD SPEED UP
+9 ; <DISPLAY>
+10 SET APCHSIVD=0
FOR
SET APCHSIVD=$ORDER(^AUPNVPRC("AA",APCHSPAT,APCHSIVD))
IF 'APCHSIVD
QUIT
Begin DoDot:1
+11 SET APCHSDFN=0
FOR
SET APCHSDFN=$ORDER(^AUPNVPRC("AA",APCHSPAT,APCHSIVD,APCHSDFN))
IF 'APCHSDFN
QUIT
Begin DoDot:2
+12 SET APCHSICD=$PIECE(^AUPNVPRC(APCHSDFN,0),U)
+13 SET APCHSN=^AUPNVPRC(APCHSDFN,0)
+14 DO HOSCHK
IF APCHSICD=""
QUIT
+15 SET APCHSCNT=APCHSCNT+1
+16 SET APCHCSVD=(9999999-APCHSIVD)
+17 DO GETICDOP^APCHSUTL
+18 SET Y=$PIECE(APCHSN,U,3)
SET Y=+^AUPNVSIT(Y,0)\1
XECUTE APCHSCVD
SET APCHSDAT=Y
+19 SET APCHSNRQ=$PIECE(APCHSN,U,4)
+20 IF APCHSNRQ
DO GETNARR^APCHSUTL
+21 ;I APCHSNRQ="" S APCHSNRQ=$P(^ICD0($P(APCHSN,U,1),0),U,4) cmi/anch/maw 8/28/2007 orig line
+22 ;cmi/anch/maw 8/28/2007 code set versioning
IF APCHSNRQ=""
SET APCHSNRQ=$PIECE($$ICDOP^ICDEX($PIECE(APCHSN,U,1),APCHCSVD,,"I"),U,5)
+23 ;S APCHSDS="DATE?",Y=$P(APCHSN,U,6) I Y]"" X APCHSCVD S APCHSDS=Y
+24 SET APCHSDS="DATE?"
Begin DoDot:3
+25 SET Y=$PIECE(APCHSN,U,6)
IF Y]""
XECUTE APCHSCVD
SET APCHSDS=Y
QUIT
+26 SET Y=(9999999-APCHSIVD)
XECUTE APCHSCVD
SET APCHSDS=Y
End DoDot:3
+27 DO GETOPRV
+28 SET APCHHOSA(APCHSIVD,"PRC",APCHSDFN)=APCHSDS_U_APCHSNRQ_U_APCHSOP
End DoDot:2
End DoDot:1
+29 ;now go through v cpt
+30 SET APCHT=$ORDER(^ATXAX("B","APCH HS MINOR PROCEDURE CPTS",0))
+31 ;K ^TMP($J,"APCHMCPTTAX") ;IHS/CMI/LAB - ICD SPEED UP
+32 ;S F=$NA(^TMP($J,"APCHMCPTTAX")) ;IHS/CMI/LAB - ICD SPEED UP
+33 ;D BLDTAX^ATXAPI("APCH HS MINOR PROCEDURE CPTS",F,$O(^ATXAX("B","APCH HS MINOR PROCEDURE CPTS",0))) ;IHS/CMI/LAB - ICD SPEED UP
+34 SET APCHCPTI=0
FOR
SET APCHCPTI=$ORDER(^AUPNVCPT("AA",APCHSPAT,APCHCPTI))
IF APCHCPTI'=+APCHCPTI
QUIT
Begin DoDot:1
+35 ;not a cpt wanted on this component
IF '$$ICD^ATXAPI(APCHCPTI,APCHT,1)
QUIT
+36 ;Q:'$D(^TMP($J,"APCHMCPTTAX",APCHCPTI)) ;NOT A MINOR CPT
+37 SET APCHSIVD=0
FOR
SET APCHSIVD=$ORDER(^AUPNVCPT("AA",APCHSPAT,APCHCPTI,APCHSIVD))
IF APCHSIVD=""
QUIT
Begin DoDot:2
+38 SET APCHSIEN=0
FOR
SET APCHSIEN=$ORDER(^AUPNVCPT("AA",APCHSPAT,APCHCPTI,APCHSIVD,APCHSIEN))
IF APCHSIEN'=+APCHSIEN
QUIT
Begin DoDot:3
+39 SET Y=(9999999-APCHSIVD)
XECUTE APCHSCVD
SET APCHSDS=Y
+40 SET APCHSN=^AUPNVCPT(APCHSIEN,0)
+41 SET APCHSICD=$PIECE(APCHSN,U,1)
+42 DO GETCPT^APCHSUTL
+43 SET APCHSNRQ=$PIECE(APCHSN,U,4)
+44 IF APCHSNRQ
DO GETNARR^APCHSUTL
+45 ;cmi/anch/maw 8/28/2007 mods for code set versioning
+46 ;I APCHSNRQ="" S APCHSNRQ=$P(^ICPT($P(APCHSN,U,1),0),U,2)
+47 NEW APCHSVDT
+48 SET APCHSVDT=$SELECT($PIECE(APCHSN,U,3):$PIECE(+$GET(^AUPNVSIT($PIECE(APCHSN,U,3),0)),"."),1:"")
+49 IF APCHSNRQ=""
SET APCHSNRQ=$PIECE($$CPT^ICPTCOD($PIECE(APCHSN,U,1),APCHSVDT),U,3)
+50 ;cmi/anch/maw 8/28/2007 end of mods
+51 SET APCHHOSA(APCHSIVD,"CPT",APCHSIEN)=APCHSDS_U_APCHSNRQ_U_$SELECT($PIECE($GET(^AUPNVCPT(APCHSIEN,12)),U,4):$$VAL^XBDIQ1(9000010.18,APCHSIEN,1204),1:$$VAL^XBDIQ1(9000010.18,APCHSIEN,1202))_U_APCHSICD
+52 SET APCHHOSC(APCHSIVD,"CPT",$PIECE(^ICPT($PIECE(APCHSN,U,1),0),U,1))=""
End DoDot:3
End DoDot:2
End DoDot:1
+53 ;now get all tran codes hcpcs
+54 SET APCHSIEN=0
FOR
SET APCHSIEN=$ORDER(^AUPNVTC("AC",APCHSPAT,APCHSIEN))
IF APCHSIEN=""
QUIT
Begin DoDot:1
+55 IF '$DATA(^AUPNVTC(APCHSIEN))
QUIT
+56 SET V=$PIECE(^AUPNVTC(APCHSIEN,0),U,3)
+57 IF 'V
QUIT
+58 IF '$DATA(^AUPNVSIT(V,0))
QUIT
+59 SET V=$PIECE($PIECE(^AUPNVSIT(V,0),U),".")
+60 SET Y=V
XECUTE APCHSCVD
SET APCHSDS=Y
+61 SET APCHSIVD=9999999-V
+62 SET APCHCPT=$$VAL^XBDIQ1(9000010.33,APCHSIEN,.07)
+63 SET APCHCPTI=$PIECE(^AUPNVTC(APCHSIEN,0),U,7)
+64 ;Q:'$D(^TMP($J,"APCHMCPTTAX",APCHCPTI)) ;NOT A MINOR CPT ;IHS/CMI/LAB - ICD SPEED UP
+65 ;not a cpt wanted on this component
IF '$$ICD^ATXAPI(APCHCPTI,APCHT,1)
QUIT
+66 IF $DATA(APCHHOSC(APCHSIVD,"CPT",APCHCPT))
QUIT
+67 SET APCHSNRQ=$PIECE(^ICPT(APCHCPTI,0),U,2)
+68 SET APCHSICD=APCHCPTI
+69 DO GETCPT^APCHSUTL
+70 SET APCHHOSA(APCHSIVD,"CPT",APCHSIEN)=APCHSDS_U_APCHSNRQ_U_$SELECT($PIECE($GET(^AUPNVTC(APCHSIEN,12)),U,4):$$VAL^XBDIQ1(9000010.33,APCHSIEN,1204),1:$$VAL^XBDIQ1(9000010.33,APCHSIEN,1202))_U_APCHSICD
End DoDot:1
+71 ;now display the procedures/cpt codes
+72 SET APCHSIVD=0
FOR
SET APCHSIVD=$ORDER(APCHHOSA(APCHSIVD))
IF APCHSIVD=""!($DATA(APCHSQIT))
QUIT
Begin DoDot:1
+73 XECUTE APCHSCKP
IF $DATA(APCHSQIT)
QUIT
+74 SET APCHIEN=0
FOR
SET APCHIEN=$ORDER(APCHHOSA(APCHSIVD,"PRC",APCHIEN))
IF APCHIEN'=+APCHIEN!($DATA(APCHSQIT))
QUIT
Begin DoDot:2
+75 SET APCHSOP=$PIECE(APCHHOSA(APCHSIVD,"PRC",APCHIEN),U,3)
+76 SET APCHSNRQ=$PIECE(APCHHOSA(APCHSIVD,"PRC",APCHIEN),U,2)
+77 SET APCHSDS=$PIECE(APCHHOSA(APCHSIVD,"PRC",APCHIEN),U,1)
+78 SET APCHSICD=$PIECE(APCHHOSA(APCHSIVD,"PRC",APCHIEN),U,4)
+79 WRITE APCHSDS,?10,$EXTRACT(APCHSOP,1,15)
SET APCHSNTE=""
SET APCHSICL=26
DO PRTICD^APCHSUTL
End DoDot:2
+80 SET APCHIEN=0
FOR
SET APCHIEN=$ORDER(APCHHOSA(APCHSIVD,"CPT",APCHIEN))
IF APCHIEN'=+APCHIEN!($DATA(APCHSQIT))
QUIT
Begin DoDot:2
+81 SET APCHSOP=$PIECE(APCHHOSA(APCHSIVD,"CPT",APCHIEN),U,3)
+82 SET APCHSNRQ=$PIECE(APCHHOSA(APCHSIVD,"CPT",APCHIEN),U,2)
+83 SET APCHSDS=$PIECE(APCHHOSA(APCHSIVD,"CPT",APCHIEN),U,1)
+84 SET APCHSICD=$PIECE(APCHHOSA(APCHSIVD,"CPT",APCHIEN),U,4)
+85 WRITE APCHSDS,?10,$EXTRACT(APCHSOP,1,15)
SET APCHSNTE=""
SET APCHSICL=26
DO PRTICD^APCHSUTL
End DoDot:2
End DoDot:1
+86 IF 'APCHSCNT
XECUTE APCHSCKP
IF $DATA(APCHSQIT)
QUIT
WRITE "Minor procedures are on file but have not been displayed.",!
+87 ; <CLEANUP>
+88 ; now display refusals for icd procedures
+89 SET APCHSFN=80.1
SET APCHST="PROCEDURE"
+90 SET APCHSS="S %=0,APCHSICD=$P(^AUPNPREF(APCHSI,0),U,6) Q:'APCHSICD D HOSCHK^APCHS6A I APCHSICD S %=1"
+91 DO DISPREF^APCHS3C
+92 SET APCHSFN=81
SET APCHST="CPT"
+93 SET APCHSS="S %=0,APCHCPT=$P(^AUPNPREF(APCHSI,0),U,6) Q:'APCHCPT I $$ICD^ATXAPI(APCHCPT,$O(^ATXAX(""B"",""APCH HS MINOR PROCEDURE CPTS"",0)),1) S %=1"
+94 DO DISPREF^APCHS3C
HOSX KILL APCHSFN,APCHSOP,APCHST,APCHSS,APCHSDFN,APCHSICD,APCHSNRQ,APCHSDAT,APCHSDS,APCHSICL,APCHSIVD,APCHSCOD,APCHSCNT,APCHSOPN,APCHSOP,Y
+1 KILL APCHHOSA,APCHHOSC
+2 ;K ^TMP($J,"APCHMPRCTAX"),^TMP($J,"APCHMCPTTAX")
+3 QUIT
MINORX KILL APCHSFN,APCHSOP,APCHST,APCHSS,APCHSDFN,APCHSICD,APCHSNRQ,APCHSDAT,APCHSDS,APCHSICL,APCHSIVD,APCHSCOD,APCHSCNT,APCHSOPN,APCHSOP,Y
+1 QUIT
