- 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