Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: APCHS6

APCHS6.m

Go to the documentation of this file.
  1. 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
  1. ;
  1. ;
  1. FMH ; ******* FAMILY HISTORY * 9000014 *******
  1. G FMH^APCHS61
  1. PMH ; ******** PERSONAL HISTORY * 9000013 *******
  1. ;
  1. Q:'$D(^AUPNPH("AC",APCHSPAT))
  1. X APCHSCKP Q:$D(APCHSQIT) X:'APCHSNPG APCHSBRK
  1. ;
  1. S APCHSDFN="" F APCHSQ=0:0 S APCHSDFN=$O(^AUPNPH("AC",APCHSPAT,APCHSDFN)) Q:APCHSDFN="" D PHDSP
  1. ;
  1. PMHX K APCHSDFN,APCHSN,APCHSICD,APCHSICL,APCHSNRQ,APCHSDAT,APCHSDTH
  1. Q
  1. PHDSP S APCHSN=^AUPNPH(APCHSDFN,0)
  1. ;S APCHSICD=$P(APCHSN,U,1) D GETICDDX^APCHSUTL
  1. S APCHSICD=$P(APCHSN,U,1) D GETICDDX^APCHSUTL
  1. S Y=$P(APCHSN,U,3) X APCHSCVD S APCHSDAT=Y
  1. S APCHSDTH=$P(APCHSN,U,5) I APCHSDTH]"" S Y=APCHSDTH X APCHSCVD S APCHSDTH=Y
  1. S APCHSNRQ=$P(APCHSN,U,4)
  1. D GETNARR^APCHSUTL
  1. K APCHSDTE S:APCHSDTH]"" APCHSNTE="(onset: "_APCHSDTH_")"
  1. X APCHSCKP Q:$D(APCHSQIT) W APCHSDAT S APCHSICL=10 D PRTICD^APCHSUTL
  1. Q
  1. ;
  1. HOS ; HISTORY OF SURGERY * 9000010.08 (V PROCEDURE) & V CPT *******
  1. K APCHHOSA,APCHHOSC
  1. I '$D(^AUPNVPRC("AC",APCHSPAT)),'$D(^AUPNVCPT("AC",APCHSPAT)),'$D(^AUPNVTC("AC",APCHSPAT)) G HOSX
  1. X APCHSCKP Q:$D(APCHSQIT) X:'APCHSNPG APCHSBRK
  1. S APCHSCNT=0
  1. ;K ^TMP($J,"APCHMPRCTAX") ;IHS/CMI/LAB - ICD SPEED UP
  1. ;S F=$NA(^TMP($J,"APCHMPRCTAX")) ;IHS/CMI/LAB - ICD SPEED UP
  1. ;D BLDTAX^ATXAPI("APCH MINOR SURGICAL PROCS",F,$O(^ATXAX("B","APCH MINOR SURGICAL PROCS",0))) ;IHS/CMI/LAB - ICD SPEED UP
  1. ; <DISPLAY>
  1. S APCHSIVD=0 F S APCHSIVD=$O(^AUPNVPRC("AA",APCHSPAT,APCHSIVD)) Q:'APCHSIVD D
  1. .S APCHSDFN=0 F S APCHSDFN=$O(^AUPNVPRC("AA",APCHSPAT,APCHSIVD,APCHSDFN)) Q:'APCHSDFN D
  1. ..S APCHSICD=$P(^AUPNVPRC(APCHSDFN,0),U)
  1. ..S APCHSN=^AUPNVPRC(APCHSDFN,0)
  1. ..D HOSCHK Q:APCHSICD=""
  1. ..S APCHSCNT=APCHSCNT+1
  1. ..S APCHCSVD=+^AUPNVSIT($P(APCHSN,U,3),0)\1
  1. ..D GETICDOP^APCHSUTL
  1. ..S Y=$P(APCHSN,U,3),Y=+^AUPNVSIT(Y,0)\1 X APCHSCVD S APCHSDAT=Y
  1. ..S APCHSNRQ=$P(APCHSN,U,4)
  1. ..I APCHSNRQ D GETNARR^APCHSUTL
  1. ..I APCHSNRQ="" S APCHSNRQ=$P($$ICDOP^ICDEX($P(APCHSN,U,1),+^AUPNVSIT($P(APCHSN,U,3),0)\1,,"I"),U,5)
  1. ..S APCHSDS="DATE?" D
  1. ...S Y=$P(APCHSN,U,6) I Y]"" X APCHSCVD S APCHSDS=Y Q
  1. ...S Y=(9999999-APCHSIVD) X APCHSCVD S APCHSDS=Y
  1. ..D GETOPRV
  1. ..S APCHHOSA(APCHSIVD,"PRC",APCHSDFN)=APCHSDS_U_APCHSNRQ_U_APCHSOP_U_APCHSICD
  1. ;now go through v cpt
  1. ;K ^TMP($J,"APCHMCPTTAX") ;IHS/CMI/LAB - ICD SPEED UP
  1. ;S F=$NA(^TMP($J,"APCHMCPTTAX")) ;IHS/CMI/LAB - ICD SPEED UP
  1. ;D BLDTAX^ATXAPI("APCH HS MAJOR PROCEDURE CPTS",F,$O(^ATXAX("B","APCH HS MAJOR PROCEDURE CPTS",0))) ;IHS/CMI/LAB - ICD SPEED UP
  1. S APCHT=$O(^ATXAX("B","APCH HS MAJOR PROCEDURE CPTS",0))
  1. S APCHCPTI=0 F S APCHCPTI=$O(^AUPNVCPT("AA",APCHSPAT,APCHCPTI)) Q:APCHCPTI'=+APCHCPTI D
  1. .I '$$ICD^ATXAPI(APCHCPTI,APCHT,1) Q ;not a cpt wanted on this component ;IHS/CMI/LAB - ICD SPEED UP
  1. .;I '$D(^TMP($J,"APCHMCPTTAX",APCHCPTI)) Q ;NOT A MAJOR ONE ;IHS/CMI/LAB - ICD SPEED UP
  1. .S APCHSIVD=0 F S APCHSIVD=$O(^AUPNVCPT("AA",APCHSPAT,APCHCPTI,APCHSIVD)) Q:APCHSIVD="" D
  1. ..S APCHSIEN=0 F S APCHSIEN=$O(^AUPNVCPT("AA",APCHSPAT,APCHCPTI,APCHSIVD,APCHSIEN)) Q:APCHSIEN'=+APCHSIEN D
  1. ...S Y=(9999999-APCHSIVD) X APCHSCVD S APCHSDS=Y
  1. ...S APCHSN=^AUPNVCPT(APCHSIEN,0)
  1. ...S APCHSICD=$P(APCHSN,U,1)
  1. ...D GETCPT^APCHSUTL
  1. ...S APCHSNRQ=$P(APCHSN,U,4)
  1. ...I APCHSNRQ D GETNARR^APCHSUTL
  1. ...N APCHSVDT
  1. ...S APCHSVDT=$P(+^AUPNVSIT($P(APCHSN,U,3),0),".")
  1. ...I APCHSNRQ="" S APCHSNRQ=$P($$CPT^ICPTCOD($P(APCHSN,U,1),APCHSVDT),U,3)
  1. ...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 ;
  1. ...S APCHHOSC(APCHSIVD,"CPT",$P(^ICPT($P(APCHSN,U,1),0),U,1))=""
  1. ;now get all tran codes hcpcs
  1. S APCHSIEN=0 F S APCHSIEN=$O(^AUPNVTC("AC",APCHSPAT,APCHSIEN)) Q:APCHSIEN="" D
  1. .Q:'$D(^AUPNVTC(APCHSIEN))
  1. .S V=$P(^AUPNVTC(APCHSIEN,0),U,3)
  1. .Q:'V
  1. .Q:'$D(^AUPNVSIT(V,0))
  1. .S V=$P($P(^AUPNVSIT(V,0),U),".")
  1. .S Y=V X APCHSCVD S APCHSDS=Y
  1. .S APCHSIVD=9999999-V
  1. .S APCHCPT=$$VAL^XBDIQ1(9000010.33,APCHSIEN,.07)
  1. .S APCHCPTI=$P(^AUPNVTC(APCHSIEN,0),U,7)
  1. .Q:APCHCPTI="" ;IHS/CMI/LAB - ICD SPEED UP
  1. .I '$$ICD^ATXAPI(APCHCPTI,APCHT,1) Q ;not a cpt wanted on this component ;IHS/CMI/LAB - ICD SPEED UP
  1. .;I '$D(^TMP($J,"APCHMCPTTAX",APCHCPTI)) Q ;NOT A MAJOR ONE ;IHS/CMI/LAB - ICD SPEED UP
  1. .Q:$D(APCHHOSC(APCHSIVD,"CPT",APCHCPT))
  1. .;S APCHSNRQ=$P(^ICPT(APCHCPTI,0),U,2)
  1. .S APCHSNRQ=$P($$CPT^ICPTCOD(APCHCPTI,V),U,3)
  1. .S APCHSICD=APCHCPTI
  1. .D GETCPT^APCHSUTL
  1. .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
  1. ;now display the procedures/cpt codes
  1. S APCHSIVD=0 F S APCHSIVD=$O(APCHHOSA(APCHSIVD)) Q:APCHSIVD=""!($D(APCHSQIT)) D
  1. . X APCHSCKP Q:$D(APCHSQIT)
  1. . S APCHIEN=0 F S APCHIEN=$O(APCHHOSA(APCHSIVD,"PRC",APCHIEN)) Q:APCHIEN'=+APCHIEN!($D(APCHSQIT)) D
  1. .. S APCHSOP=$P(APCHHOSA(APCHSIVD,"PRC",APCHIEN),U,3)
  1. .. S APCHSNRQ=$P(APCHHOSA(APCHSIVD,"PRC",APCHIEN),U,2)
  1. .. S APCHSDS=$P(APCHHOSA(APCHSIVD,"PRC",APCHIEN),U,1)
  1. .. S APCHSICD=$P(APCHHOSA(APCHSIVD,"PRC",APCHIEN),U,4)
  1. .. W APCHSDS,?10,$E(APCHSOP,1,15) S APCHSNTE="" S APCHSICL=26 D PRTICD^APCHSUTL
  1. . S APCHIEN=0 F S APCHIEN=$O(APCHHOSA(APCHSIVD,"CPT",APCHIEN)) Q:APCHIEN'=+APCHIEN!($D(APCHSQIT)) D
  1. .. S APCHSOP=$P(APCHHOSA(APCHSIVD,"CPT",APCHIEN),U,3)
  1. .. S APCHSNRQ=$P(APCHHOSA(APCHSIVD,"CPT",APCHIEN),U,2)
  1. .. S APCHSDS=$P(APCHHOSA(APCHSIVD,"CPT",APCHIEN),U,1)
  1. .. S APCHSICD=$P(APCHHOSA(APCHSIVD,"CPT",APCHIEN),U,4)
  1. .. W APCHSDS,?10,$E(APCHSOP,1,15) S APCHSNTE="" S APCHSICL=26 D PRTICD^APCHSUTL
  1. I 'APCHSCNT X APCHSCKP Q:$D(APCHSQIT) W "Minor procedures are on file but have not been displayed.",!
  1. ;
  1. ; now display refusals for icd procedures
  1. S APCHSFN=80.1,APCHST="PROCEDURE"
  1. S APCHSS="S %=0,APCHSICD=$P(^AUPNPREF(APCHSI,0),U,6) Q:'APCHSICD D HOSCHK^APCHS6 I APCHSICD S %=1"
  1. D DISPREF^APCHS3C
  1. S APCHSFN=81,APCHST="CPT"
  1. S APCHSS="S %=0,APCHCPT=$P(^AUPNPREF(APCHSI,0),U,6) Q:'APCHCPT D HOSCPTCH^APCHS6 S %=1"
  1. D DISPREF^APCHS3C
  1. HOSX K APCHSFN,APCHSOP,APCHST,APCHSS,APCHSDFN,APCHSICD,APCHSNRQ,APCHSDAT,APCHSDS,APCHSICL,APCHSIVD,APCHSCOD,APCHSCNT,APCHSOPN,APCHSOP,Y
  1. K APCHHOSA,APCHHOSC
  1. ;K ^TMP($J,"APCHMCPTTAX"),^TMP($J,"APCHMPRCTAX")
  1. Q
  1. HOSO ; HISTORY OF SURGERY * 9000010.08 (V PROCEDURE) *******
  1. ; <SETUP>
  1. Q:'$D(^AUPNVPRC("AC",APCHSPAT))
  1. X APCHSCKP Q:$D(APCHSQIT) X:'APCHSNPG APCHSBRK
  1. S APCHSCNT=0
  1. ; <DISPLAY>
  1. 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)
  1. I 'APCHSCNT X APCHSCKP Q:$D(APCHSQIT) W "Minor procedures are on file but have not been displayed.",!
  1. ; <CLEANUP>
  1. HOSOX K APCHSDFN,APCHSICD,APCHSNRQ,APCHSDAT,APCHSDS,APCHSICL,APCHSIVD,APCHSCOD,APCHSCNT,APCHSOPN,APCHSOP,Y
  1. Q
  1. HOSDSP S APCHSN=^AUPNVPRC(APCHSDFN,0)
  1. S APCHSICD=$P(APCHSN,U,1)
  1. D HOSCHK Q:APCHSICD=""
  1. S APCHSCNT=APCHSCNT+1
  1. S APCHCSVD=+^AUPNVSIT($P(APCHSN,U,3),0)\1
  1. D GETICDOP^APCHSUTL
  1. S Y=$P(APCHSN,U,3),Y=+^AUPNVSIT(Y,0)\1 X APCHSCVD S APCHSDAT=Y
  1. S APCHSNRQ=$P(APCHSN,U,4)
  1. I APCHSNRQ D GETNARR^APCHSUTL
  1. 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
  1. S APCHSDS="DATE?",Y=$P(APCHSN,U,6) I Y]"" X APCHSCVD S APCHSDS=Y
  1. D GETOPRV
  1. X APCHSCKP Q:$D(APCHSQIT)
  1. W APCHSDS W ?10,APCHSOP S APCHSNTE="" S APCHSICL=26 D PRTICD^APCHSUTL
  1. K APCHSOP
  1. Q
  1. 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
  1. I $$ICD^ATXAPI(APCHSICD,$O(^ATXAX("B","APCH MINOR SURGICAL PROCS",0)),0) S APCHSICD=""
  1. ;S APCHSCOD=+^ICD0(APCHSICD,0) cmi/anch/maw
  1. ;S APCHSCOD=$P($$ICDOP^ICDEX(APCHSICD),U,2) ;cmi/anch/maw CSV
  1. ;I APCHSCOD\1>85 S APCHSICD="" Q
  1. ;I APCHSCOD=69.7 S APCHSICD="" Q
  1. ;I APCHSCOD\1=23 S APCHSICD="" Q
  1. ;I APCHSCOD\1=24 S APCHSICD="" Q
  1. ;I $E(APCHSCOD,1,4)="38.9" S APCHSICD="" Q
  1. ;I APCHSCOD=73.09 S APCHSICD="" Q
  1. ;I APCHSCOD="38.29" S APCHSICD="" Q ;blood draw
  1. ;I APCHSCOD="57.94" S APCHSICD="" Q ;insertion of urinary catheter
  1. Q
  1. GETOPRV ;get Operating Prov
  1. NEW APCHSOPN
  1. S APCHSOP=""
  1. S APCHSOPN=$P(APCHSN,U,11)
  1. Q:'+APCHSOPN
  1. 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
  1. Q
  1. ;;
  1. ;
  1. CPTALL ;EP - display all cpt codes, date limits are applicable
  1. I '$D(^AUPNVCPT("AA",APCHSPAT)),'$D(^AUPNVTC("AC",APCHSPAT)) Q
  1. ; <DISPLAY>
  1. K APCHCPTA
  1. S APCHCPTI=0 F S APCHCPTI=$O(^AUPNVCPT("AA",APCHSPAT,APCHCPTI)) Q:APCHCPTI="" D
  1. .S APCHSIVD="" F S APCHSIVD=$O(^AUPNVCPT("AA",APCHSPAT,APCHCPTI,APCHSIVD)) Q:APCHSIVD=""!(APCHSIVD>APCHSDLM) D
  1. ..S APCHIEN=0 F S APCHIEN=$O(^AUPNVCPT("AA",APCHSPAT,APCHCPTI,APCHSIVD,APCHIEN)) Q:APCHIEN'=+APCHIEN D
  1. ...S APCHCPT=$$VAL^XBDIQ1(9000010.18,APCHIEN,.01)
  1. ...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)
  1. ...S Y=$$VALI^XBDIQ1(9000010,$P(^AUPNVCPT(APCHIEN,0),U,3),.08) S $P(APCHCPTA(APCHSIVD,APCHCPT,APCHIEN),U,4)=Y
  1. ;now get tran codes
  1. S APCHIEN=0 F S APCHIEN=$O(^AUPNVTC("AC",APCHSPAT,APCHIEN)) Q:APCHIEN="" D
  1. .Q:'$D(^AUPNVTC(APCHIEN))
  1. .S V=$P(^AUPNVTC(APCHIEN,0),U,3)
  1. .Q:'V
  1. .Q:'$D(^AUPNVSIT(V,0))
  1. .S V=$P($P(^AUPNVSIT(V,0),U),".")
  1. .S APCHSIVD=9999999-V
  1. .Q:APCHSIVD>APCHSDLM
  1. .S APCHCPT=$$VAL^XBDIQ1(9000010.33,APCHIEN,.07)
  1. .Q:APCHCPT=""
  1. .S APCHCPTI=$P(^AUPNVTC(APCHIEN,0),U,7)
  1. .Q:$D(APCHCPTA(APCHSIVD,APCHCPT))
  1. .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)
  1. .S Y=$$VALI^XBDIQ1(9000010,$P(^AUPNVTC(APCHIEN,0),U,3),.08) S $P(APCHCPTA(APCHSIVD,APCHCPT,APCHIEN),U,4)=Y
  1. G:'$D(APCHCPTA) CPTALLX
  1. X APCHSCKP Q:$D(APCHSQIT)
  1. X:'APCHSNPG APCHSBRK
  1. S APCHSIVD=0 F S APCHSIVD=$O(APCHCPTA(APCHSIVD)) Q:APCHSIVD=""!($D(APCHSQIT)) D
  1. .X APCHSCKP Q:$D(APCHSQIT) I APCHSNPG W ?28,"CODE",?34,"CPT NARRATIVE",?72,"UNITS",!
  1. .W $$DATE^APCHSMU((9999999-APCHSIVD))
  1. .S APCHCPT="" F S APCHCPT=$O(APCHCPTA(APCHSIVD,APCHCPT)) Q:APCHCPT=""!($D(APCHSQIT)) D
  1. ..S APCHIEN=0 F S APCHIEN=$O(APCHCPTA(APCHSIVD,APCHCPT,APCHIEN)) Q:APCHIEN'=+APCHIEN!($D(APCHSQIT)) D
  1. ...X APCHSCKP Q:$D(APCHSQIT) I APCHSNPG W ?28,"CODE",?35,"CPT NARRATIVE",?72,"UNITS",!
  1. ...S %=$P(APCHCPTA(APCHSIVD,APCHCPT,APCHIEN),U,3)
  1. ...I % W ?9,$P($G(^AUTTLOC(%,0)),U,2)
  1. ...S %=$P(APCHCPTA(APCHSIVD,APCHCPT,APCHIEN),U,4)
  1. ...I % W ?22,$P($G(^DIC(40.7,%,9999999)),U)
  1. ...W ?28,APCHCPT,?35,$E($P(APCHCPTA(APCHSIVD,APCHCPT,APCHIEN),U,1),1,36)
  1. ...W ?73,$P(APCHCPTA(APCHSIVD,APCHCPT,APCHIEN),U,2)
  1. ...W !
  1. ;
  1. ;display CPT refusals
  1. S APCHST="CPT",APCHSFN=81 D DISPREF^APCHS3C
  1. K APCHST,APCHSFN
  1. CPTALLX K APCHSIVD,APCHSDAT,APCHCPT,APCHIEN,APCHCPTA,APCHCPTI
  1. Q
  1. CPTALLC ;EP - CPT DISPLAY
  1. S APCHMRO=0
  1. CPTALLC1 ;EP - display all cpt codes, date limits are applicable
  1. I '$D(^AUPNVCPT("AA",APCHSPAT)),'$D(^AUPNVTC("AC",APCHSPAT)) Q
  1. ; <DISPLAY>
  1. K APCHCPTA
  1. S APCHCPTI=0 F S APCHCPTI=$O(^AUPNVCPT("AA",APCHSPAT,APCHCPTI)) Q:APCHCPTI="" D
  1. .S APCHSIVD="",APCHSIVC=0 F S APCHSIVD=$O(^AUPNVCPT("AA",APCHSPAT,APCHCPTI,APCHSIVD)) Q:APCHSIVD=""!(APCHSIVD>APCHSDLM) D
  1. ..S APCHIEN=0 F S APCHIEN=$O(^AUPNVCPT("AA",APCHSPAT,APCHCPTI,APCHSIVD,APCHIEN)) Q:APCHIEN'=+APCHIEN D
  1. ...S APCHCPT=$$VAL^XBDIQ1(9000010.18,APCHIEN,.01)
  1. ...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)
  1. ...S Y=$$VALI^XBDIQ1(9000010,$P(^AUPNVCPT(APCHIEN,0),U,3),.08) S $P(APCHCPTA(APCHCPT,APCHSIVD,APCHIEN),U,4)=Y
  1. ;now get tran codes
  1. S APCHIEN=0 F S APCHIEN=$O(^AUPNVTC("AC",APCHSPAT,APCHIEN)) Q:APCHIEN="" D
  1. .Q:'$D(^AUPNVTC(APCHIEN))
  1. .S V=$P(^AUPNVTC(APCHIEN,0),U,3)
  1. .Q:'V
  1. .Q:'$D(^AUPNVSIT(V,0))
  1. .S V=$P($P(^AUPNVSIT(V,0),U),".")
  1. .S APCHSIVD=9999999-V
  1. .Q:APCHSIVD>APCHSDLM
  1. .S APCHCPT=$$VAL^XBDIQ1(9000010.33,APCHIEN,.07)
  1. .Q:APCHCPT=""
  1. .S APCHCPTI=$P(^AUPNVTC(APCHIEN,0),U,7)
  1. .Q:$D(APCHCPTA(APCHCPT,APCHSIVD))
  1. .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)
  1. .S Y=$$VALI^XBDIQ1(9000010,$P(^AUPNVTC(APCHIEN,0),U,3),.08) S $P(APCHCPTA(APCHCPT,APCHSIVD,APCHIEN),U,4)=Y
  1. G:'$D(APCHCPTA) CPTALLCX
  1. X APCHSCKP Q:$D(APCHSQIT)
  1. X:'APCHSNPG APCHSBRK
  1. S APCHCPT=0,APCHMRC=0 F S APCHCPT=$O(APCHCPTA(APCHCPT)) Q:APCHCPT=""!($D(APCHSQIT)) D
  1. .X APCHSCKP Q:$D(APCHSQIT) I APCHSNPG W ?1,"CODE",?7,"DATE",?17,"CPT NARRATIVE",?54,"UNITS",?60,"FACILITY",?74,"CLN",!
  1. .W APCHCPT
  1. .I APCHMRO D MREDISP Q
  1. .S APCHSIVD="" F S APCHSIVD=$O(APCHCPTA(APCHCPT,APCHSIVD)) Q:APCHSIVD=""!($D(APCHSQIT)) D
  1. ..S APCHMRC=0 S APCHIEN=0 F S APCHIEN=$O(APCHCPTA(APCHCPT,APCHSIVD,APCHIEN)) Q:APCHIEN'=+APCHIEN!($D(APCHSQIT)) D
  1. ...X APCHSCKP Q:$D(APCHSQIT) I APCHSNPG W ?1,"CODE",?7,"DATE",?17,"CPT NARRATIVE",?54,"UNITS",?60,"FACILITY",?74,"CLN",!
  1. ...S APCHMRC=APCHMRC+1
  1. ...W ?7,$$DATE^APCHSMU((9999999-APCHSIVD))
  1. ...W ?17,$E($P(APCHCPTA(APCHCPT,APCHSIVD,APCHIEN),U,1),1,35)
  1. ...W ?54,$P(APCHCPTA(APCHCPT,APCHSIVD,APCHIEN),U,2)
  1. ...S %=$P(APCHCPTA(APCHCPT,APCHSIVD,APCHIEN),U,3)
  1. ...I % W ?60,$P($G(^AUTTLOC(%,0)),U,2)
  1. ...S %=$P(APCHCPTA(APCHCPT,APCHSIVD,APCHIEN),U,4)
  1. ...I % W ?74,$E($P($G(^DIC(40.7,%,9999999)),U),1,3)
  1. ...W !
  1. ;display refusals
  1. S APCHST="CPT",APCHSFN=81 D DISPREF^APCHS3C
  1. K APCHST,APCHSFN,APCHMRO
  1. CPTALLCX K APCHSIVD,APCHSDAT,APCHCPT,APCHIEN,APCHCPTA,APCHCPTI
  1. Q
  1. MREDISP ;
  1. S APCHSIVD=0,APCHSIVD=$O(APCHCPTA(APCHCPT,APCHSIVD)) D
  1. .S APCHIEN=0,APCHIEN=$O(APCHCPTA(APCHCPT,APCHSIVD,APCHIEN)) D
  1. ..X APCHSCKP Q:$D(APCHSQIT) I APCHSNPG W ?1,"CODE",?7,"DATE",?17,"CPT NARRATIVE",?54,"UNITS",?60,"FACILITY",?74,"CLN",!
  1. ..W ?7,$$DATE^APCHSMU((9999999-APCHSIVD))
  1. ..W ?17,$E($P(APCHCPTA(APCHCPT,APCHSIVD,APCHIEN),U,1),1,35)
  1. ..W ?54,$P(APCHCPTA(APCHCPT,APCHSIVD,APCHIEN),U,2)
  1. ..S %=$P(APCHCPTA(APCHCPT,APCHSIVD,APCHIEN),U,3)
  1. ..I % W ?60,$P($G(^AUTTLOC(%,0)),U,2)
  1. ..S %=$P(APCHCPTA(APCHCPT,APCHSIVD,APCHIEN),U,4)
  1. ..I % W ?74,$P($G(^DIC(40.7,%,9999999)),U)
  1. ..W !
  1. .Q
  1. Q
  1. CPTMRE ;EP - most recent of each cpt
  1. S APCHMRO=1
  1. G CPTALLC1