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

APCHS6A.m

Go to the documentation of this file. 
  1. 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
  1.  ;
  1.  ;cmi/anch/maw 8/27/2007 code set versioninig in HOSCHK, HOSDSP, MINOR
  1.  ;
  1. MINORO ; ******** MINOR 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.  ; <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.  S APCHSFN=80.1,APCHST="PROCEDURE"
  1.  S APCHSS="S %=0,APCHSICD=$P(^AUPNPREF(APCHSI,0),U,6) Q:'APCHSICD  D HOSCHK^APCHS6A I APCHSICD S %=1"
  1.  D DISPREF^APCHS3C
  1.  K APCHSFN,APCHST,APCHSS
  1.  ;
  1.  ; <CLEANUP>
  1. MINOROX K APCHSDFN,APCHSICD,APCHSNRQ,APCHSDAT,APCHSDS,APCHSICL,APCHSIVD,APCHSCOD,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 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.  ;D GETNARR^APCHSUTL
  1.  I APCHSNRQ D GETNARR^APCHSUTL
  1.  ;I APCHSNRQ="" S APCHSNRQ=$P(^ICD0($P(APCHSN,U,1),0),U,4)  cmi/anch/maw 8/28/2007 orig line
  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 code set versioning
  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.  ;W APCHSDS S APCHSNTE="" S APCHSICL=10 D PRTICD^APCHSUTL
  1.  Q
  1. HOSCHK ;
  1.  ;I $D(^TMP($J,"APCHMPRCTAX")) S:'$D(^TMP($J,"APCHMPRCTAX",APCHSICD)) APCHSICD="" Q
  1.  ;
  1.  ;THE FOLLOWING IS FOR ANYONE CALLING THIS API FROM OUTSIDE THIS ROUTINE. (E.G. BCCD)
  1.  ;S APCHSCOD=$P($$ICDOP^ICDEX(APCHSICD,,,"I"),U,2)  ;cmi/anch/maw 8/27/2007 code set versioning
  1.  I $$ICD^ATXAPI(APCHSICD,$O(^ATXAX("B","APCH MINOR SURGICAL PROCS",0)),0) Q
  1.  ;Q:APCHSCOD\1>85
  1.  ;Q:APCHSCOD=69.7
  1.  ;Q:APCHSCOD\1=23
  1.  ;Q:APCHSCOD\1=24
  1.  S APCHSICD=""
  1.  Q
  1. GETOPRV ;get Operating Provider
  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. MINOR ; ************* HISTORY OF SURGERY * 9000010.08 (V PROCEDURE) & V CPT *******
  1.  ; <SETUP>
  1.  K APCHHOSA,APCHHOSC
  1.  I '$D(^AUPNVPRC("AC",APCHSPAT)),'$D(^AUPNVCPT("AC",APCHSPAT)) G MINORX
  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=(9999999-APCHSIVD)
  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(^ICD0($P(APCHSN,U,1),0),U,4)  cmi/anch/maw 8/28/2007 orig line
  1.  ..I APCHSNRQ="" S APCHSNRQ=$P($$ICDOP^ICDEX($P(APCHSN,U,1),APCHCSVD,,"I"),U,5)  ;cmi/anch/maw 8/28/2007 code set versioning
  1.  ..;S APCHSDS="DATE?",Y=$P(APCHSN,U,6) I Y]"" X APCHSCVD S APCHSDS=Y
  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
  1.  ;now go through v cpt
  1.  S APCHT=$O(^ATXAX("B","APCH HS MINOR PROCEDURE CPTS",0))
  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 MINOR PROCEDURE CPTS",F,$O(^ATXAX("B","APCH HS MINOR PROCEDURE CPTS",0)))  ;IHS/CMI/LAB - ICD SPEED UP
  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
  1.  .;Q:'$D(^TMP($J,"APCHMCPTTAX",APCHCPTI))  ;NOT A MINOR CPT
  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.  ...;cmi/anch/maw 8/28/2007 mods for code set versioning
  1.  ...;I APCHSNRQ="" S APCHSNRQ=$P(^ICPT($P(APCHSN,U,1),0),U,2)
  1.  ...N APCHSVDT
  1.  ...S APCHSVDT=$S($P(APCHSN,U,3):$P(+$G(^AUPNVSIT($P(APCHSN,U,3),0)),"."),1:"")
  1.  ...I APCHSNRQ="" S APCHSNRQ=$P($$CPT^ICPTCOD($P(APCHSN,U,1),APCHSVDT),U,3)
  1.  ...;cmi/anch/maw 8/28/2007 end of mods
  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:'$D(^TMP($J,"APCHMCPTTAX",APCHCPTI))  ;NOT A MINOR CPT ;IHS/CMI/LAB - ICD SPEED UP
  1.  .I '$$ICD^ATXAPI(APCHCPTI,APCHT,1) Q  ;not a cpt wanted on this component
  1.  .Q:$D(APCHHOSC(APCHSIVD,"CPT",APCHCPT))
  1.  .S APCHSNRQ=$P(^ICPT(APCHCPTI,0),U,2)
  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.  ; <CLEANUP>
  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^APCHS6A 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  I $$ICD^ATXAPI(APCHCPT,$O(^ATXAX(""B"",""APCH HS MINOR PROCEDURE CPTS"",0)),1) 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,"APCHMPRCTAX"),^TMP($J,"APCHMCPTTAX")
  1.  Q
  1. MINORX K APCHSFN,APCHSOP,APCHST,APCHSS,APCHSDFN,APCHSICD,APCHSNRQ,APCHSDAT,APCHSDS,APCHSICL,APCHSIVD,APCHSCOD,APCHSCNT,APCHSOPN,APCHSOP,Y
  1.  Q