APCHS6 ; IHS/CMI/LAB - PART 6 OF APCHS -- SUMMARY PRODUCTION COMPONENTS 18 Jun 2008 10:07 AM ; 16 Dec 2015 2:42 PM
;;2.0;IHS PCC SUITE;**4,11,12,14**;MAY 14, 2009;Build 12
;
;
FMH ; ******* FAMILY HISTORY * 9000014 *******
G FMH^APCHS61
PMH ; ******** PERSONAL HISTORY * 9000013 *******
;
Q:'$D(^AUPNPH("AC",APCHSPAT))
X APCHSCKP Q:$D(APCHSQIT) X:'APCHSNPG APCHSBRK
;
S APCHSDFN="" F APCHSQ=0:0 S APCHSDFN=$O(^AUPNPH("AC",APCHSPAT,APCHSDFN)) Q:APCHSDFN="" D PHDSP
;
PMHX K APCHSDFN,APCHSN,APCHSICD,APCHSICL,APCHSNRQ,APCHSDAT,APCHSDTH
Q
PHDSP S APCHSN=^AUPNPH(APCHSDFN,0)
;S APCHSICD=$P(APCHSN,U,1) D GETICDDX^APCHSUTL
S APCHSICD=$P(APCHSN,U,1) D GETICDDX^APCHSUTL
S Y=$P(APCHSN,U,3) X APCHSCVD S APCHSDAT=Y
S APCHSDTH=$P(APCHSN,U,5) I APCHSDTH]"" S Y=APCHSDTH X APCHSCVD S APCHSDTH=Y
S APCHSNRQ=$P(APCHSN,U,4)
D GETNARR^APCHSUTL
K APCHSDTE S:APCHSDTH]"" APCHSNTE="(onset: "_APCHSDTH_")"
X APCHSCKP Q:$D(APCHSQIT) W APCHSDAT S APCHSICL=10 D PRTICD^APCHSUTL
Q
;
HOS ; HISTORY OF SURGERY * 9000010.08 (V PROCEDURE) & V CPT *******
K APCHHOSA,APCHHOSC
I '$D(^AUPNVPRC("AC",APCHSPAT)),'$D(^AUPNVCPT("AC",APCHSPAT)),'$D(^AUPNVTC("AC",APCHSPAT)) G HOSX
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=+^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)
..I APCHSNRQ D GETNARR^APCHSUTL
..I APCHSNRQ="" S APCHSNRQ=$P($$ICDOP^ICDEX($P(APCHSN,U,1),+^AUPNVSIT($P(APCHSN,U,3),0)\1,,"I"),U,5)
..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_U_APCHSICD
;now go through v cpt
;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 MAJOR PROCEDURE CPTS",F,$O(^ATXAX("B","APCH HS MAJOR PROCEDURE CPTS",0))) ;IHS/CMI/LAB - ICD SPEED UP
S APCHT=$O(^ATXAX("B","APCH HS MAJOR PROCEDURE CPTS",0))
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 ;IHS/CMI/LAB - ICD SPEED UP
.;I '$D(^TMP($J,"APCHMCPTTAX",APCHCPTI)) Q ;NOT A MAJOR ONE ;IHS/CMI/LAB - ICD SPEED UP
.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
...N APCHSVDT
...S APCHSVDT=$P(+^AUPNVSIT($P(APCHSN,U,3),0),".")
...I APCHSNRQ="" S APCHSNRQ=$P($$CPT^ICPTCOD($P(APCHSN,U,1),APCHSVDT),U,3)
...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:APCHCPTI="" ;IHS/CMI/LAB - ICD SPEED UP
.I '$$ICD^ATXAPI(APCHCPTI,APCHT,1) Q ;not a cpt wanted on this component ;IHS/CMI/LAB - ICD SPEED UP
.;I '$D(^TMP($J,"APCHMCPTTAX",APCHCPTI)) Q ;NOT A MAJOR ONE ;IHS/CMI/LAB - ICD SPEED UP
.Q:$D(APCHHOSC(APCHSIVD,"CPT",APCHCPT))
.;S APCHSNRQ=$P(^ICPT(APCHCPTI,0),U,2)
.S APCHSNRQ=$P($$CPT^ICPTCOD(APCHCPTI,V),U,3)
.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.",!
;
; 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^APCHS6 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 D HOSCPTCH^APCHS6 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,"APCHMCPTTAX"),^TMP($J,"APCHMPRCTAX")
Q
HOSO ; HISTORY OF SURGERY * 9000010.08 (V PROCEDURE) *******
; <SETUP>
Q:'$D(^AUPNVPRC("AC",APCHSPAT))
X APCHSCKP Q:$D(APCHSQIT) X:'APCHSNPG APCHSBRK
S APCHSCNT=0
; <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)
I 'APCHSCNT X APCHSCKP Q:$D(APCHSQIT) W "Minor procedures are on file but have not been displayed.",!
; <CLEANUP>
HOSOX K APCHSDFN,APCHSICD,APCHSNRQ,APCHSDAT,APCHSDS,APCHSICL,APCHSIVD,APCHSCOD,APCHSCNT,APCHSOPN,APCHSOP,Y
Q
HOSDSP S APCHSN=^AUPNVPRC(APCHSDFN,0)
S APCHSICD=$P(APCHSN,U,1)
D HOSCHK Q:APCHSICD=""
S APCHSCNT=APCHSCNT+1
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)
I APCHSNRQ D GETNARR^APCHSUTL
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 CSV
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
Q
HOSCHK ;PEP - CHECK TO SEE IF A PROCEDURE IS MINOR
;IF ^TMP IS THERE USE IT, OTHERWISE USE OLD SLOW CHECK - RETURN BACK TO $$ICD^ATXAPI
I $$ICD^ATXAPI(APCHSICD,$O(^ATXAX("B","APCH MINOR SURGICAL PROCS",0)),0) S APCHSICD=""
;S APCHSCOD=+^ICD0(APCHSICD,0) cmi/anch/maw
;S APCHSCOD=$P($$ICDOP^ICDEX(APCHSICD),U,2) ;cmi/anch/maw CSV
;I APCHSCOD\1>85 S APCHSICD="" Q
;I APCHSCOD=69.7 S APCHSICD="" Q
;I APCHSCOD\1=23 S APCHSICD="" Q
;I APCHSCOD\1=24 S APCHSICD="" Q
;I $E(APCHSCOD,1,4)="38.9" S APCHSICD="" Q
;I APCHSCOD=73.09 S APCHSICD="" Q
;I APCHSCOD="38.29" S APCHSICD="" Q ;blood draw
;I APCHSCOD="57.94" S APCHSICD="" Q ;insertion of urinary catheter
Q
GETOPRV ;get Operating Prov
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
;;
;
CPTALL ;EP - display all cpt codes, date limits are applicable
I '$D(^AUPNVCPT("AA",APCHSPAT)),'$D(^AUPNVTC("AC",APCHSPAT)) Q
; <DISPLAY>
K APCHCPTA
S APCHCPTI=0 F S APCHCPTI=$O(^AUPNVCPT("AA",APCHSPAT,APCHCPTI)) Q:APCHCPTI="" D
.S APCHSIVD="" F S APCHSIVD=$O(^AUPNVCPT("AA",APCHSPAT,APCHCPTI,APCHSIVD)) Q:APCHSIVD=""!(APCHSIVD>APCHSDLM) D
..S APCHIEN=0 F S APCHIEN=$O(^AUPNVCPT("AA",APCHSPAT,APCHCPTI,APCHSIVD,APCHIEN)) Q:APCHIEN'=+APCHIEN D
...S APCHCPT=$$VAL^XBDIQ1(9000010.18,APCHIEN,.01)
...S APCHCPTA(APCHSIVD,APCHCPT,APCHIEN)=$P($$CPT^ICPTCOD(APCHCPTI,(9999999-APCHSIVD)),U,3)_U_$$VAL^XBDIQ1(9000010.18,APCHIEN,.16)_U_$$VALI^XBDIQ1(9000010,$P(^AUPNVCPT(APCHIEN,0),U,3),.06)
...S Y=$$VALI^XBDIQ1(9000010,$P(^AUPNVCPT(APCHIEN,0),U,3),.08) S $P(APCHCPTA(APCHSIVD,APCHCPT,APCHIEN),U,4)=Y
;now get tran codes
S APCHIEN=0 F S APCHIEN=$O(^AUPNVTC("AC",APCHSPAT,APCHIEN)) Q:APCHIEN="" D
.Q:'$D(^AUPNVTC(APCHIEN))
.S V=$P(^AUPNVTC(APCHIEN,0),U,3)
.Q:'V
.Q:'$D(^AUPNVSIT(V,0))
.S V=$P($P(^AUPNVSIT(V,0),U),".")
.S APCHSIVD=9999999-V
.Q:APCHSIVD>APCHSDLM
.S APCHCPT=$$VAL^XBDIQ1(9000010.33,APCHIEN,.07)
.Q:APCHCPT=""
.S APCHCPTI=$P(^AUPNVTC(APCHIEN,0),U,7)
.Q:$D(APCHCPTA(APCHSIVD,APCHCPT))
.S APCHCPTA(APCHSIVD,APCHCPT,APCHIEN)=$P($$CPT^ICPTCOD(APCHCPTI,(9999999-APCHSIVD)),U,3)_U_1_U_$$VALI^XBDIQ1(9000010,$P(^AUPNVTC(APCHIEN,0),U,3),.06)
.S Y=$$VALI^XBDIQ1(9000010,$P(^AUPNVTC(APCHIEN,0),U,3),.08) S $P(APCHCPTA(APCHSIVD,APCHCPT,APCHIEN),U,4)=Y
G:'$D(APCHCPTA) CPTALLX
X APCHSCKP Q:$D(APCHSQIT)
X:'APCHSNPG APCHSBRK
S APCHSIVD=0 F S APCHSIVD=$O(APCHCPTA(APCHSIVD)) Q:APCHSIVD=""!($D(APCHSQIT)) D
.X APCHSCKP Q:$D(APCHSQIT) I APCHSNPG W ?28,"CODE",?34,"CPT NARRATIVE",?72,"UNITS",!
.W $$DATE^APCHSMU((9999999-APCHSIVD))
.S APCHCPT="" F S APCHCPT=$O(APCHCPTA(APCHSIVD,APCHCPT)) Q:APCHCPT=""!($D(APCHSQIT)) D
..S APCHIEN=0 F S APCHIEN=$O(APCHCPTA(APCHSIVD,APCHCPT,APCHIEN)) Q:APCHIEN'=+APCHIEN!($D(APCHSQIT)) D
...X APCHSCKP Q:$D(APCHSQIT) I APCHSNPG W ?28,"CODE",?35,"CPT NARRATIVE",?72,"UNITS",!
...S %=$P(APCHCPTA(APCHSIVD,APCHCPT,APCHIEN),U,3)
...I % W ?9,$P($G(^AUTTLOC(%,0)),U,2)
...S %=$P(APCHCPTA(APCHSIVD,APCHCPT,APCHIEN),U,4)
...I % W ?22,$P($G(^DIC(40.7,%,9999999)),U)
...W ?28,APCHCPT,?35,$E($P(APCHCPTA(APCHSIVD,APCHCPT,APCHIEN),U,1),1,36)
...W ?73,$P(APCHCPTA(APCHSIVD,APCHCPT,APCHIEN),U,2)
...W !
;
;display CPT refusals
S APCHST="CPT",APCHSFN=81 D DISPREF^APCHS3C
K APCHST,APCHSFN
CPTALLX K APCHSIVD,APCHSDAT,APCHCPT,APCHIEN,APCHCPTA,APCHCPTI
Q
CPTALLC ;EP - CPT DISPLAY
S APCHMRO=0
CPTALLC1 ;EP - display all cpt codes, date limits are applicable
I '$D(^AUPNVCPT("AA",APCHSPAT)),'$D(^AUPNVTC("AC",APCHSPAT)) Q
; <DISPLAY>
K APCHCPTA
S APCHCPTI=0 F S APCHCPTI=$O(^AUPNVCPT("AA",APCHSPAT,APCHCPTI)) Q:APCHCPTI="" D
.S APCHSIVD="",APCHSIVC=0 F S APCHSIVD=$O(^AUPNVCPT("AA",APCHSPAT,APCHCPTI,APCHSIVD)) Q:APCHSIVD=""!(APCHSIVD>APCHSDLM) D
..S APCHIEN=0 F S APCHIEN=$O(^AUPNVCPT("AA",APCHSPAT,APCHCPTI,APCHSIVD,APCHIEN)) Q:APCHIEN'=+APCHIEN D
...S APCHCPT=$$VAL^XBDIQ1(9000010.18,APCHIEN,.01)
...S APCHCPTA(APCHCPT,APCHSIVD,APCHIEN)=$P($$CPT^ICPTCOD(APCHCPTI,(9999999-APCHSIVD)),U,3)_U_$$VAL^XBDIQ1(9000010.18,APCHIEN,.16)_U_$$VALI^XBDIQ1(9000010,$P(^AUPNVCPT(APCHIEN,0),U,3),.06)
...S Y=$$VALI^XBDIQ1(9000010,$P(^AUPNVCPT(APCHIEN,0),U,3),.08) S $P(APCHCPTA(APCHCPT,APCHSIVD,APCHIEN),U,4)=Y
;now get tran codes
S APCHIEN=0 F S APCHIEN=$O(^AUPNVTC("AC",APCHSPAT,APCHIEN)) Q:APCHIEN="" D
.Q:'$D(^AUPNVTC(APCHIEN))
.S V=$P(^AUPNVTC(APCHIEN,0),U,3)
.Q:'V
.Q:'$D(^AUPNVSIT(V,0))
.S V=$P($P(^AUPNVSIT(V,0),U),".")
.S APCHSIVD=9999999-V
.Q:APCHSIVD>APCHSDLM
.S APCHCPT=$$VAL^XBDIQ1(9000010.33,APCHIEN,.07)
.Q:APCHCPT=""
.S APCHCPTI=$P(^AUPNVTC(APCHIEN,0),U,7)
.Q:$D(APCHCPTA(APCHCPT,APCHSIVD))
.S APCHCPTA(APCHCPT,APCHSIVD,APCHIEN)=$P($$CPT^ICPTCOD(APCHCPTI,(9999999-APCHSIVD)),U,3)_U_1_U_$$VALI^XBDIQ1(9000010,$P(^AUPNVTC(APCHIEN,0),U,3),.06)
.S Y=$$VALI^XBDIQ1(9000010,$P(^AUPNVTC(APCHIEN,0),U,3),.08) S $P(APCHCPTA(APCHCPT,APCHSIVD,APCHIEN),U,4)=Y
G:'$D(APCHCPTA) CPTALLCX
X APCHSCKP Q:$D(APCHSQIT)
X:'APCHSNPG APCHSBRK
S APCHCPT=0,APCHMRC=0 F S APCHCPT=$O(APCHCPTA(APCHCPT)) Q:APCHCPT=""!($D(APCHSQIT)) D
.X APCHSCKP Q:$D(APCHSQIT) I APCHSNPG W ?1,"CODE",?7,"DATE",?17,"CPT NARRATIVE",?54,"UNITS",?60,"FACILITY",?74,"CLN",!
.W APCHCPT
.I APCHMRO D MREDISP Q
.S APCHSIVD="" F S APCHSIVD=$O(APCHCPTA(APCHCPT,APCHSIVD)) Q:APCHSIVD=""!($D(APCHSQIT)) D
..S APCHMRC=0 S APCHIEN=0 F S APCHIEN=$O(APCHCPTA(APCHCPT,APCHSIVD,APCHIEN)) Q:APCHIEN'=+APCHIEN!($D(APCHSQIT)) D
...X APCHSCKP Q:$D(APCHSQIT) I APCHSNPG W ?1,"CODE",?7,"DATE",?17,"CPT NARRATIVE",?54,"UNITS",?60,"FACILITY",?74,"CLN",!
...S APCHMRC=APCHMRC+1
...W ?7,$$DATE^APCHSMU((9999999-APCHSIVD))
...W ?17,$E($P(APCHCPTA(APCHCPT,APCHSIVD,APCHIEN),U,1),1,35)
...W ?54,$P(APCHCPTA(APCHCPT,APCHSIVD,APCHIEN),U,2)
...S %=$P(APCHCPTA(APCHCPT,APCHSIVD,APCHIEN),U,3)
...I % W ?60,$P($G(^AUTTLOC(%,0)),U,2)
...S %=$P(APCHCPTA(APCHCPT,APCHSIVD,APCHIEN),U,4)
...I % W ?74,$E($P($G(^DIC(40.7,%,9999999)),U),1,3)
...W !
;display refusals
S APCHST="CPT",APCHSFN=81 D DISPREF^APCHS3C
K APCHST,APCHSFN,APCHMRO
CPTALLCX K APCHSIVD,APCHSDAT,APCHCPT,APCHIEN,APCHCPTA,APCHCPTI
Q
MREDISP ;
S APCHSIVD=0,APCHSIVD=$O(APCHCPTA(APCHCPT,APCHSIVD)) D
.S APCHIEN=0,APCHIEN=$O(APCHCPTA(APCHCPT,APCHSIVD,APCHIEN)) D
..X APCHSCKP Q:$D(APCHSQIT) I APCHSNPG W ?1,"CODE",?7,"DATE",?17,"CPT NARRATIVE",?54,"UNITS",?60,"FACILITY",?74,"CLN",!
..W ?7,$$DATE^APCHSMU((9999999-APCHSIVD))
..W ?17,$E($P(APCHCPTA(APCHCPT,APCHSIVD,APCHIEN),U,1),1,35)
..W ?54,$P(APCHCPTA(APCHCPT,APCHSIVD,APCHIEN),U,2)
..S %=$P(APCHCPTA(APCHCPT,APCHSIVD,APCHIEN),U,3)
..I % W ?60,$P($G(^AUTTLOC(%,0)),U,2)
..S %=$P(APCHCPTA(APCHCPT,APCHSIVD,APCHIEN),U,4)
..I % W ?74,$P($G(^DIC(40.7,%,9999999)),U)
..W !
.Q
Q
CPTMRE ;EP - most recent of each cpt
S APCHMRO=1
G CPTALLC1
APCHS6 ; IHS/CMI/LAB - PART 6 OF APCHS -- SUMMARY PRODUCTION COMPONENTS 18 Jun 2008 10:07 AM ; 16 Dec 2015 2:42 PM
+1 ;;2.0;IHS PCC SUITE;**4,11,12,14**;MAY 14, 2009;Build 12
+2 ;
+3 ;
FMH ; ******* FAMILY HISTORY * 9000014 *******
+1 GOTO FMH^APCHS61
PMH ; ******** PERSONAL HISTORY * 9000013 *******
+1 ;
+2 IF '$DATA(^AUPNPH("AC",APCHSPAT))
QUIT
+3 XECUTE APCHSCKP
IF $DATA(APCHSQIT)
QUIT
IF 'APCHSNPG
XECUTE APCHSBRK
+4 ;
+5 SET APCHSDFN=""
FOR APCHSQ=0:0
SET APCHSDFN=$ORDER(^AUPNPH("AC",APCHSPAT,APCHSDFN))
IF APCHSDFN=""
QUIT
DO PHDSP
+6 ;
PMHX KILL APCHSDFN,APCHSN,APCHSICD,APCHSICL,APCHSNRQ,APCHSDAT,APCHSDTH
+1 QUIT
PHDSP SET APCHSN=^AUPNPH(APCHSDFN,0)
+1 ;S APCHSICD=$P(APCHSN,U,1) D GETICDDX^APCHSUTL
+2 SET APCHSICD=$PIECE(APCHSN,U,1)
DO GETICDDX^APCHSUTL
+3 SET Y=$PIECE(APCHSN,U,3)
XECUTE APCHSCVD
SET APCHSDAT=Y
+4 SET APCHSDTH=$PIECE(APCHSN,U,5)
IF APCHSDTH]""
SET Y=APCHSDTH
XECUTE APCHSCVD
SET APCHSDTH=Y
+5 SET APCHSNRQ=$PIECE(APCHSN,U,4)
+6 DO GETNARR^APCHSUTL
+7 KILL APCHSDTE
IF APCHSDTH]""
SET APCHSNTE="(onset: "_APCHSDTH_")"
+8 XECUTE APCHSCKP
IF $DATA(APCHSQIT)
QUIT
WRITE APCHSDAT
SET APCHSICL=10
DO PRTICD^APCHSUTL
+9 QUIT
+10 ;
HOS ; HISTORY OF SURGERY * 9000010.08 (V PROCEDURE) & V CPT *******
+1 KILL APCHHOSA,APCHHOSC
+2 IF '$DATA(^AUPNVPRC("AC",APCHSPAT))
IF '$DATA(^AUPNVCPT("AC",APCHSPAT))
IF '$DATA(^AUPNVTC("AC",APCHSPAT))
GOTO HOSX
+3 XECUTE APCHSCKP
IF $DATA(APCHSQIT)
QUIT
IF 'APCHSNPG
XECUTE APCHSBRK
+4 SET APCHSCNT=0
+5 ;K ^TMP($J,"APCHMPRCTAX") ;IHS/CMI/LAB - ICD SPEED UP
+6 ;S F=$NA(^TMP($J,"APCHMPRCTAX")) ;IHS/CMI/LAB - ICD SPEED UP
+7 ;D BLDTAX^ATXAPI("APCH MINOR SURGICAL PROCS",F,$O(^ATXAX("B","APCH MINOR SURGICAL PROCS",0))) ;IHS/CMI/LAB - ICD SPEED UP
+8 ; <DISPLAY>
+9 SET APCHSIVD=0
FOR
SET APCHSIVD=$ORDER(^AUPNVPRC("AA",APCHSPAT,APCHSIVD))
IF 'APCHSIVD
QUIT
Begin DoDot:1
+10 SET APCHSDFN=0
FOR
SET APCHSDFN=$ORDER(^AUPNVPRC("AA",APCHSPAT,APCHSIVD,APCHSDFN))
IF 'APCHSDFN
QUIT
Begin DoDot:2
+11 SET APCHSICD=$PIECE(^AUPNVPRC(APCHSDFN,0),U)
+12 SET APCHSN=^AUPNVPRC(APCHSDFN,0)
+13 DO HOSCHK
IF APCHSICD=""
QUIT
+14 SET APCHSCNT=APCHSCNT+1
+15 SET APCHCSVD=+^AUPNVSIT($PIECE(APCHSN,U,3),0)\1
+16 DO GETICDOP^APCHSUTL
+17 SET Y=$PIECE(APCHSN,U,3)
SET Y=+^AUPNVSIT(Y,0)\1
XECUTE APCHSCVD
SET APCHSDAT=Y
+18 SET APCHSNRQ=$PIECE(APCHSN,U,4)
+19 IF APCHSNRQ
DO GETNARR^APCHSUTL
+20 IF APCHSNRQ=""
SET APCHSNRQ=$PIECE($$ICDOP^ICDEX($PIECE(APCHSN,U,1),+^AUPNVSIT($PIECE(APCHSN,U,3),0)\1,,"I"),U,5)
+21 SET APCHSDS="DATE?"
Begin DoDot:3
+22 SET Y=$PIECE(APCHSN,U,6)
IF Y]""
XECUTE APCHSCVD
SET APCHSDS=Y
QUIT
+23 SET Y=(9999999-APCHSIVD)
XECUTE APCHSCVD
SET APCHSDS=Y
End DoDot:3
+24 DO GETOPRV
+25 SET APCHHOSA(APCHSIVD,"PRC",APCHSDFN)=APCHSDS_U_APCHSNRQ_U_APCHSOP_U_APCHSICD
End DoDot:2
End DoDot:1
+26 ;now go through v cpt
+27 ;K ^TMP($J,"APCHMCPTTAX") ;IHS/CMI/LAB - ICD SPEED UP
+28 ;S F=$NA(^TMP($J,"APCHMCPTTAX")) ;IHS/CMI/LAB - ICD SPEED UP
+29 ;D BLDTAX^ATXAPI("APCH HS MAJOR PROCEDURE CPTS",F,$O(^ATXAX("B","APCH HS MAJOR PROCEDURE CPTS",0))) ;IHS/CMI/LAB - ICD SPEED UP
+30 SET APCHT=$ORDER(^ATXAX("B","APCH HS MAJOR PROCEDURE CPTS",0))
+31 SET APCHCPTI=0
FOR
SET APCHCPTI=$ORDER(^AUPNVCPT("AA",APCHSPAT,APCHCPTI))
IF APCHCPTI'=+APCHCPTI
QUIT
Begin DoDot:1
+32 ;not a cpt wanted on this component ;IHS/CMI/LAB - ICD SPEED UP
IF '$$ICD^ATXAPI(APCHCPTI,APCHT,1)
QUIT
+33 ;I '$D(^TMP($J,"APCHMCPTTAX",APCHCPTI)) Q ;NOT A MAJOR ONE ;IHS/CMI/LAB - ICD SPEED UP
+34 SET APCHSIVD=0
FOR
SET APCHSIVD=$ORDER(^AUPNVCPT("AA",APCHSPAT,APCHCPTI,APCHSIVD))
IF APCHSIVD=""
QUIT
Begin DoDot:2
+35 SET APCHSIEN=0
FOR
SET APCHSIEN=$ORDER(^AUPNVCPT("AA",APCHSPAT,APCHCPTI,APCHSIVD,APCHSIEN))
IF APCHSIEN'=+APCHSIEN
QUIT
Begin DoDot:3
+36 SET Y=(9999999-APCHSIVD)
XECUTE APCHSCVD
SET APCHSDS=Y
+37 SET APCHSN=^AUPNVCPT(APCHSIEN,0)
+38 SET APCHSICD=$PIECE(APCHSN,U,1)
+39 DO GETCPT^APCHSUTL
+40 SET APCHSNRQ=$PIECE(APCHSN,U,4)
+41 IF APCHSNRQ
DO GETNARR^APCHSUTL
+42 NEW APCHSVDT
+43 SET APCHSVDT=$PIECE(+^AUPNVSIT($PIECE(APCHSN,U,3),0),".")
+44 IF APCHSNRQ=""
SET APCHSNRQ=$PIECE($$CPT^ICPTCOD($PIECE(APCHSN,U,1),APCHSVDT),U,3)
+45 ;
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
+46 SET APCHHOSC(APCHSIVD,"CPT",$PIECE(^ICPT($PIECE(APCHSN,U,1),0),U,1))=""
End DoDot:3
End DoDot:2
End DoDot:1
+47 ;now get all tran codes hcpcs
+48 SET APCHSIEN=0
FOR
SET APCHSIEN=$ORDER(^AUPNVTC("AC",APCHSPAT,APCHSIEN))
IF APCHSIEN=""
QUIT
Begin DoDot:1
+49 IF '$DATA(^AUPNVTC(APCHSIEN))
QUIT
+50 SET V=$PIECE(^AUPNVTC(APCHSIEN,0),U,3)
+51 IF 'V
QUIT
+52 IF '$DATA(^AUPNVSIT(V,0))
QUIT
+53 SET V=$PIECE($PIECE(^AUPNVSIT(V,0),U),".")
+54 SET Y=V
XECUTE APCHSCVD
SET APCHSDS=Y
+55 SET APCHSIVD=9999999-V
+56 SET APCHCPT=$$VAL^XBDIQ1(9000010.33,APCHSIEN,.07)
+57 SET APCHCPTI=$PIECE(^AUPNVTC(APCHSIEN,0),U,7)
+58 ;IHS/CMI/LAB - ICD SPEED UP
IF APCHCPTI=""
QUIT
+59 ;not a cpt wanted on this component ;IHS/CMI/LAB - ICD SPEED UP
IF '$$ICD^ATXAPI(APCHCPTI,APCHT,1)
QUIT
+60 ;I '$D(^TMP($J,"APCHMCPTTAX",APCHCPTI)) Q ;NOT A MAJOR ONE ;IHS/CMI/LAB - ICD SPEED UP
+61 IF $DATA(APCHHOSC(APCHSIVD,"CPT",APCHCPT))
QUIT
+62 ;S APCHSNRQ=$P(^ICPT(APCHCPTI,0),U,2)
+63 SET APCHSNRQ=$PIECE($$CPT^ICPTCOD(APCHCPTI,V),U,3)
+64 SET APCHSICD=APCHCPTI
+65 DO GETCPT^APCHSUTL
+66 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
+67 ;now display the procedures/cpt codes
+68 SET APCHSIVD=0
FOR
SET APCHSIVD=$ORDER(APCHHOSA(APCHSIVD))
IF APCHSIVD=""!($DATA(APCHSQIT))
QUIT
Begin DoDot:1
+69 XECUTE APCHSCKP
IF $DATA(APCHSQIT)
QUIT
+70 SET APCHIEN=0
FOR
SET APCHIEN=$ORDER(APCHHOSA(APCHSIVD,"PRC",APCHIEN))
IF APCHIEN'=+APCHIEN!($DATA(APCHSQIT))
QUIT
Begin DoDot:2
+71 SET APCHSOP=$PIECE(APCHHOSA(APCHSIVD,"PRC",APCHIEN),U,3)
+72 SET APCHSNRQ=$PIECE(APCHHOSA(APCHSIVD,"PRC",APCHIEN),U,2)
+73 SET APCHSDS=$PIECE(APCHHOSA(APCHSIVD,"PRC",APCHIEN),U,1)
+74 SET APCHSICD=$PIECE(APCHHOSA(APCHSIVD,"PRC",APCHIEN),U,4)
+75 WRITE APCHSDS,?10,$EXTRACT(APCHSOP,1,15)
SET APCHSNTE=""
SET APCHSICL=26
DO PRTICD^APCHSUTL
End DoDot:2
+76 SET APCHIEN=0
FOR
SET APCHIEN=$ORDER(APCHHOSA(APCHSIVD,"CPT",APCHIEN))
IF APCHIEN'=+APCHIEN!($DATA(APCHSQIT))
QUIT
Begin DoDot:2
+77 SET APCHSOP=$PIECE(APCHHOSA(APCHSIVD,"CPT",APCHIEN),U,3)
+78 SET APCHSNRQ=$PIECE(APCHHOSA(APCHSIVD,"CPT",APCHIEN),U,2)
+79 SET APCHSDS=$PIECE(APCHHOSA(APCHSIVD,"CPT",APCHIEN),U,1)
+80 SET APCHSICD=$PIECE(APCHHOSA(APCHSIVD,"CPT",APCHIEN),U,4)
+81 WRITE APCHSDS,?10,$EXTRACT(APCHSOP,1,15)
SET APCHSNTE=""
SET APCHSICL=26
DO PRTICD^APCHSUTL
End DoDot:2
End DoDot:1
+82 IF 'APCHSCNT
XECUTE APCHSCKP
IF $DATA(APCHSQIT)
QUIT
WRITE "Minor procedures are on file but have not been displayed.",!
+83 ;
+84 ; now display refusals for icd procedures
+85 SET APCHSFN=80.1
SET APCHST="PROCEDURE"
+86 SET APCHSS="S %=0,APCHSICD=$P(^AUPNPREF(APCHSI,0),U,6) Q:'APCHSICD D HOSCHK^APCHS6 I APCHSICD S %=1"
+87 DO DISPREF^APCHS3C
+88 SET APCHSFN=81
SET APCHST="CPT"
+89 SET APCHSS="S %=0,APCHCPT=$P(^AUPNPREF(APCHSI,0),U,6) Q:'APCHCPT D HOSCPTCH^APCHS6 S %=1"
+90 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,"APCHMCPTTAX"),^TMP($J,"APCHMPRCTAX")
+3 QUIT
HOSO ; 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 SET APCHSCNT=0
+5 ; <DISPLAY>
+6 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
+7 IF 'APCHSCNT
XECUTE APCHSCKP
IF $DATA(APCHSQIT)
QUIT
WRITE "Minor procedures are on file but have not been displayed.",!
+8 ; <CLEANUP>
HOSOX KILL APCHSDFN,APCHSICD,APCHSNRQ,APCHSDAT,APCHSDS,APCHSICL,APCHSIVD,APCHSCOD,APCHSCNT,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 APCHSCNT=APCHSCNT+1
+4 SET APCHCSVD=+^AUPNVSIT($PIECE(APCHSN,U,3),0)\1
+5 DO GETICDOP^APCHSUTL
+6 SET Y=$PIECE(APCHSN,U,3)
SET Y=+^AUPNVSIT(Y,0)\1
XECUTE APCHSCVD
SET APCHSDAT=Y
+7 SET APCHSNRQ=$PIECE(APCHSN,U,4)
+8 IF APCHSNRQ
DO GETNARR^APCHSUTL
+9 ;cmi/anch/maw 8/28/2007 CSV
IF APCHSNRQ=""
SET APCHSNRQ=$PIECE($$ICDOP^ICDEX($PIECE(APCHSN,U,1),+^AUPNVSIT($PIECE(APCHSN,U,3),0)\1,,"I"),U,5)
+10 SET APCHSDS="DATE?"
SET Y=$PIECE(APCHSN,U,6)
IF Y]""
XECUTE APCHSCVD
SET APCHSDS=Y
+11 DO GETOPRV
+12 XECUTE APCHSCKP
IF $DATA(APCHSQIT)
QUIT
+13 WRITE APCHSDS
WRITE ?10,APCHSOP
SET APCHSNTE=""
SET APCHSICL=26
DO PRTICD^APCHSUTL
+14 KILL APCHSOP
+15 QUIT
HOSCHK ;PEP - CHECK TO SEE IF A PROCEDURE IS MINOR
+1 ;IF ^TMP IS THERE USE IT, OTHERWISE USE OLD SLOW CHECK - RETURN BACK TO $$ICD^ATXAPI
+2 IF $$ICD^ATXAPI(APCHSICD,$ORDER(^ATXAX("B","APCH MINOR SURGICAL PROCS",0)),0)
SET APCHSICD=""
+3 ;S APCHSCOD=+^ICD0(APCHSICD,0) cmi/anch/maw
+4 ;S APCHSCOD=$P($$ICDOP^ICDEX(APCHSICD),U,2) ;cmi/anch/maw CSV
+5 ;I APCHSCOD\1>85 S APCHSICD="" Q
+6 ;I APCHSCOD=69.7 S APCHSICD="" Q
+7 ;I APCHSCOD\1=23 S APCHSICD="" Q
+8 ;I APCHSCOD\1=24 S APCHSICD="" Q
+9 ;I $E(APCHSCOD,1,4)="38.9" S APCHSICD="" Q
+10 ;I APCHSCOD=73.09 S APCHSICD="" Q
+11 ;I APCHSCOD="38.29" S APCHSICD="" Q ;blood draw
+12 ;I APCHSCOD="57.94" S APCHSICD="" Q ;insertion of urinary catheter
+13 QUIT
GETOPRV ;get Operating Prov
+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
+7 ;;
+8 ;
CPTALL ;EP - display all cpt codes, date limits are applicable
+1 IF '$DATA(^AUPNVCPT("AA",APCHSPAT))
IF '$DATA(^AUPNVTC("AC",APCHSPAT))
QUIT
+2 ; <DISPLAY>
+3 KILL APCHCPTA
+4 SET APCHCPTI=0
FOR
SET APCHCPTI=$ORDER(^AUPNVCPT("AA",APCHSPAT,APCHCPTI))
IF APCHCPTI=""
QUIT
Begin DoDot:1
+5 SET APCHSIVD=""
FOR
SET APCHSIVD=$ORDER(^AUPNVCPT("AA",APCHSPAT,APCHCPTI,APCHSIVD))
IF APCHSIVD=""!(APCHSIVD>APCHSDLM)
QUIT
Begin DoDot:2
+6 SET APCHIEN=0
FOR
SET APCHIEN=$ORDER(^AUPNVCPT("AA",APCHSPAT,APCHCPTI,APCHSIVD,APCHIEN))
IF APCHIEN'=+APCHIEN
QUIT
Begin DoDot:3
+7 SET APCHCPT=$$VAL^XBDIQ1(9000010.18,APCHIEN,.01)
+8 SET APCHCPTA(APCHSIVD,APCHCPT,APCHIEN)=$PIECE($$CPT^ICPTCOD(APCHCPTI,(9999999-APCHSIVD)),U,3)_U_$$VAL^XBDIQ1(9000010.18,APCHIEN,.16)_U_$$VALI^XBDIQ1(9000010,$PIECE(^AUPNVCPT(APCHIEN,0),U,3),.06)
+9 SET Y=$$VALI^XBDIQ1(9000010,$PIECE(^AUPNVCPT(APCHIEN,0),U,3),.08)
SET $PIECE(APCHCPTA(APCHSIVD,APCHCPT,APCHIEN),U,4)=Y
End DoDot:3
End DoDot:2
End DoDot:1
+10 ;now get tran codes
+11 SET APCHIEN=0
FOR
SET APCHIEN=$ORDER(^AUPNVTC("AC",APCHSPAT,APCHIEN))
IF APCHIEN=""
QUIT
Begin DoDot:1
+12 IF '$DATA(^AUPNVTC(APCHIEN))
QUIT
+13 SET V=$PIECE(^AUPNVTC(APCHIEN,0),U,3)
+14 IF 'V
QUIT
+15 IF '$DATA(^AUPNVSIT(V,0))
QUIT
+16 SET V=$PIECE($PIECE(^AUPNVSIT(V,0),U),".")
+17 SET APCHSIVD=9999999-V
+18 IF APCHSIVD>APCHSDLM
QUIT
+19 SET APCHCPT=$$VAL^XBDIQ1(9000010.33,APCHIEN,.07)
+20 IF APCHCPT=""
QUIT
+21 SET APCHCPTI=$PIECE(^AUPNVTC(APCHIEN,0),U,7)
+22 IF $DATA(APCHCPTA(APCHSIVD,APCHCPT))
QUIT
+23 SET APCHCPTA(APCHSIVD,APCHCPT,APCHIEN)=$PIECE($$CPT^ICPTCOD(APCHCPTI,(9999999-APCHSIVD)),U,3)_U_1_U_$$VALI^XBDIQ1(9000010,$PIECE(^AUPNVTC(APCHIEN,0),U,3),.06)
+24 SET Y=$$VALI^XBDIQ1(9000010,$PIECE(^AUPNVTC(APCHIEN,0),U,3),.08)
SET $PIECE(APCHCPTA(APCHSIVD,APCHCPT,APCHIEN),U,4)=Y
End DoDot:1
+25 IF '$DATA(APCHCPTA)
GOTO CPTALLX
+26 XECUTE APCHSCKP
IF $DATA(APCHSQIT)
QUIT
+27 IF 'APCHSNPG
XECUTE APCHSBRK
+28 SET APCHSIVD=0
FOR
SET APCHSIVD=$ORDER(APCHCPTA(APCHSIVD))
IF APCHSIVD=""!($DATA(APCHSQIT))
QUIT
Begin DoDot:1
+29 XECUTE APCHSCKP
IF $DATA(APCHSQIT)
QUIT
IF APCHSNPG
WRITE ?28,"CODE",?34,"CPT NARRATIVE",?72,"UNITS",!
+30 WRITE $$DATE^APCHSMU((9999999-APCHSIVD))
+31 SET APCHCPT=""
FOR
SET APCHCPT=$ORDER(APCHCPTA(APCHSIVD,APCHCPT))
IF APCHCPT=""!($DATA(APCHSQIT))
QUIT
Begin DoDot:2
+32 SET APCHIEN=0
FOR
SET APCHIEN=$ORDER(APCHCPTA(APCHSIVD,APCHCPT,APCHIEN))
IF APCHIEN'=+APCHIEN!($DATA(APCHSQIT))
QUIT
Begin DoDot:3
+33 XECUTE APCHSCKP
IF $DATA(APCHSQIT)
QUIT
IF APCHSNPG
WRITE ?28,"CODE",?35,"CPT NARRATIVE",?72,"UNITS",!
+34 SET %=$PIECE(APCHCPTA(APCHSIVD,APCHCPT,APCHIEN),U,3)
+35 IF %
WRITE ?9,$PIECE($GET(^AUTTLOC(%,0)),U,2)
+36 SET %=$PIECE(APCHCPTA(APCHSIVD,APCHCPT,APCHIEN),U,4)
+37 IF %
WRITE ?22,$PIECE($GET(^DIC(40.7,%,9999999)),U)
+38 WRITE ?28,APCHCPT,?35,$EXTRACT($PIECE(APCHCPTA(APCHSIVD,APCHCPT,APCHIEN),U,1),1,36)
+39 WRITE ?73,$PIECE(APCHCPTA(APCHSIVD,APCHCPT,APCHIEN),U,2)
+40 WRITE !
End DoDot:3
End DoDot:2
End DoDot:1
+41 ;
+42 ;display CPT refusals
+43 SET APCHST="CPT"
SET APCHSFN=81
DO DISPREF^APCHS3C
+44 KILL APCHST,APCHSFN
CPTALLX KILL APCHSIVD,APCHSDAT,APCHCPT,APCHIEN,APCHCPTA,APCHCPTI
+1 QUIT
CPTALLC ;EP - CPT DISPLAY
+1 SET APCHMRO=0
CPTALLC1 ;EP - display all cpt codes, date limits are applicable
+1 IF '$DATA(^AUPNVCPT("AA",APCHSPAT))
IF '$DATA(^AUPNVTC("AC",APCHSPAT))
QUIT
+2 ; <DISPLAY>
+3 KILL APCHCPTA
+4 SET APCHCPTI=0
FOR
SET APCHCPTI=$ORDER(^AUPNVCPT("AA",APCHSPAT,APCHCPTI))
IF APCHCPTI=""
QUIT
Begin DoDot:1
+5 SET APCHSIVD=""
SET APCHSIVC=0
FOR
SET APCHSIVD=$ORDER(^AUPNVCPT("AA",APCHSPAT,APCHCPTI,APCHSIVD))
IF APCHSIVD=""!(APCHSIVD>APCHSDLM)
QUIT
Begin DoDot:2
+6 SET APCHIEN=0
FOR
SET APCHIEN=$ORDER(^AUPNVCPT("AA",APCHSPAT,APCHCPTI,APCHSIVD,APCHIEN))
IF APCHIEN'=+APCHIEN
QUIT
Begin DoDot:3
+7 SET APCHCPT=$$VAL^XBDIQ1(9000010.18,APCHIEN,.01)
+8 SET APCHCPTA(APCHCPT,APCHSIVD,APCHIEN)=$PIECE($$CPT^ICPTCOD(APCHCPTI,(9999999-APCHSIVD)),U,3)_U_$$VAL^XBDIQ1(9000010.18,APCHIEN,.16)_U_$$VALI^XBDIQ1(9000010,$PIECE(^AUPNVCPT(APCHIEN,0),U,3),.06)
+9 SET Y=$$VALI^XBDIQ1(9000010,$PIECE(^AUPNVCPT(APCHIEN,0),U,3),.08)
SET $PIECE(APCHCPTA(APCHCPT,APCHSIVD,APCHIEN),U,4)=Y
End DoDot:3
End DoDot:2
End DoDot:1
+10 ;now get tran codes
+11 SET APCHIEN=0
FOR
SET APCHIEN=$ORDER(^AUPNVTC("AC",APCHSPAT,APCHIEN))
IF APCHIEN=""
QUIT
Begin DoDot:1
+12 IF '$DATA(^AUPNVTC(APCHIEN))
QUIT
+13 SET V=$PIECE(^AUPNVTC(APCHIEN,0),U,3)
+14 IF 'V
QUIT
+15 IF '$DATA(^AUPNVSIT(V,0))
QUIT
+16 SET V=$PIECE($PIECE(^AUPNVSIT(V,0),U),".")
+17 SET APCHSIVD=9999999-V
+18 IF APCHSIVD>APCHSDLM
QUIT
+19 SET APCHCPT=$$VAL^XBDIQ1(9000010.33,APCHIEN,.07)
+20 IF APCHCPT=""
QUIT
+21 SET APCHCPTI=$PIECE(^AUPNVTC(APCHIEN,0),U,7)
+22 IF $DATA(APCHCPTA(APCHCPT,APCHSIVD))
QUIT
+23 SET APCHCPTA(APCHCPT,APCHSIVD,APCHIEN)=$PIECE($$CPT^ICPTCOD(APCHCPTI,(9999999-APCHSIVD)),U,3)_U_1_U_$$VALI^XBDIQ1(9000010,$PIECE(^AUPNVTC(APCHIEN,0),U,3),.06)
+24 SET Y=$$VALI^XBDIQ1(9000010,$PIECE(^AUPNVTC(APCHIEN,0),U,3),.08)
SET $PIECE(APCHCPTA(APCHCPT,APCHSIVD,APCHIEN),U,4)=Y
End DoDot:1
+25 IF '$DATA(APCHCPTA)
GOTO CPTALLCX
+26 XECUTE APCHSCKP
IF $DATA(APCHSQIT)
QUIT
+27 IF 'APCHSNPG
XECUTE APCHSBRK
+28 SET APCHCPT=0
SET APCHMRC=0
FOR
SET APCHCPT=$ORDER(APCHCPTA(APCHCPT))
IF APCHCPT=""!($DATA(APCHSQIT))
QUIT
Begin DoDot:1
+29 XECUTE APCHSCKP
IF $DATA(APCHSQIT)
QUIT
IF APCHSNPG
WRITE ?1,"CODE",?7,"DATE",?17,"CPT NARRATIVE",?54,"UNITS",?60,"FACILITY",?74,"CLN",!
+30 WRITE APCHCPT
+31 IF APCHMRO
DO MREDISP
QUIT
+32 SET APCHSIVD=""
FOR
SET APCHSIVD=$ORDER(APCHCPTA(APCHCPT,APCHSIVD))
IF APCHSIVD=""!($DATA(APCHSQIT))
QUIT
Begin DoDot:2
+33 SET APCHMRC=0
SET APCHIEN=0
FOR
SET APCHIEN=$ORDER(APCHCPTA(APCHCPT,APCHSIVD,APCHIEN))
IF APCHIEN'=+APCHIEN!($DATA(APCHSQIT))
QUIT
Begin DoDot:3
+34 XECUTE APCHSCKP
IF $DATA(APCHSQIT)
QUIT
IF APCHSNPG
WRITE ?1,"CODE",?7,"DATE",?17,"CPT NARRATIVE",?54,"UNITS",?60,"FACILITY",?74,"CLN",!
+35 SET APCHMRC=APCHMRC+1
+36 WRITE ?7,$$DATE^APCHSMU((9999999-APCHSIVD))
+37 WRITE ?17,$EXTRACT($PIECE(APCHCPTA(APCHCPT,APCHSIVD,APCHIEN),U,1),1,35)
+38 WRITE ?54,$PIECE(APCHCPTA(APCHCPT,APCHSIVD,APCHIEN),U,2)
+39 SET %=$PIECE(APCHCPTA(APCHCPT,APCHSIVD,APCHIEN),U,3)
+40 IF %
WRITE ?60,$PIECE($GET(^AUTTLOC(%,0)),U,2)
+41 SET %=$PIECE(APCHCPTA(APCHCPT,APCHSIVD,APCHIEN),U,4)
+42 IF %
WRITE ?74,$EXTRACT($PIECE($GET(^DIC(40.7,%,9999999)),U),1,3)
+43 WRITE !
End DoDot:3
End DoDot:2
End DoDot:1
+44 ;display refusals
+45 SET APCHST="CPT"
SET APCHSFN=81
DO DISPREF^APCHS3C
+46 KILL APCHST,APCHSFN,APCHMRO
CPTALLCX KILL APCHSIVD,APCHSDAT,APCHCPT,APCHIEN,APCHCPTA,APCHCPTI
+1 QUIT
MREDISP ;
+1 SET APCHSIVD=0
SET APCHSIVD=$ORDER(APCHCPTA(APCHCPT,APCHSIVD))
Begin DoDot:1
+2 SET APCHIEN=0
SET APCHIEN=$ORDER(APCHCPTA(APCHCPT,APCHSIVD,APCHIEN))
Begin DoDot:2
+3 XECUTE APCHSCKP
IF $DATA(APCHSQIT)
QUIT
IF APCHSNPG
WRITE ?1,"CODE",?7,"DATE",?17,"CPT NARRATIVE",?54,"UNITS",?60,"FACILITY",?74,"CLN",!
+4 WRITE ?7,$$DATE^APCHSMU((9999999-APCHSIVD))
+5 WRITE ?17,$EXTRACT($PIECE(APCHCPTA(APCHCPT,APCHSIVD,APCHIEN),U,1),1,35)
+6 WRITE ?54,$PIECE(APCHCPTA(APCHCPT,APCHSIVD,APCHIEN),U,2)
+7 SET %=$PIECE(APCHCPTA(APCHCPT,APCHSIVD,APCHIEN),U,3)
+8 IF %
WRITE ?60,$PIECE($GET(^AUTTLOC(%,0)),U,2)
+9 SET %=$PIECE(APCHCPTA(APCHCPT,APCHSIVD,APCHIEN),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 - most recent of each cpt
+1 SET APCHMRO=1
+2 GOTO CPTALLC1
