- BSDX41F ; IHS/OIT/HMW/MSC/SAT - WINDOWS SCHEDULING RPCS ;
- ;;3.0;IHS WINDOWS SCHEDULING;;DEC 09, 2010
- ;
- FMH ; ******* FAMILY HISTORY * 9000014 ******* (APCHS6)
- G FMH^APCHS61
- PMH ; ******** PERSONAL HISTORY * 9000013 ******* (APCHS6)
- ;
- 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 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) S BSDXTMP=APCHSDAT S APCHSICL=10 D PRTICD
- Q
- ;
- HOS ; HISTORY OF SURGERY * 9000010.08 (V PROCEDURE) & V CPT ******* (APCHS6)
- 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
- ; <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^ICDCODE($P(APCHSN,U,1),+^AUPNVSIT($P(APCHSN,U,3),0)\1),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
- 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^ATXCHK(APCHCPTI,APCHT,1) Q ;not a cpt wanted on this component
- .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 CSV
- ...N APCHSVDT
- ...S APCHSVDT=$P(+^AUPNVSIT($P(APCHSN,U,3),0),".")
- ...;I APCHSNRQ="" S APCHSNRQ=$P(^ICPT($P(APCHSN,U,1),0),U,2) cmi/anch/maw 8/28/2007 orig line
- ...I APCHSNRQ="" S APCHSNRQ=$P($$CPT^ICPTCOD($P(APCHSN,U,1),APCHSVDT),U,3) ;cmi/anch/maw 8/28/2007 code set versioning
- ...;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)
- .I '$$ICD^ATXCHK(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 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)
- .. S BSDXTMP=APCHSDS_$$FILL^BSDX41(10-$L(APCHSDS))_$E(APCHSOP,1,15) S APCHSNTE="" S APCHSICL=26 D PRTICD
- . 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)
- .. S BSDXTMP=APCHSDS_$$FILL^BSDX41(10-$L(APCHSDS))_$E(APCHSOP,1,15) S APCHSNTE="" S APCHSICL=26 D PRTICD
- I 'APCHSCNT X APCHSCKP Q:$D(APCHSQIT) S BSDXI=BSDXI+1 S ^BSDXTMP($J,BSDXI)="Minor procedures are on file but have not been displayed."_$C(30)
- ;
- ; 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
- S APCHSFN=81,APCHST="CPT"
- S APCHSS="S %=0,APCHCPT=$P(^AUPNPREF(APCHSI,0),U,6) Q:'APCHCPT I $$ICD^ATXCHK(APCHCPT,$O(^ATXAX(""B"",""APCH HS MAJOR PROCEDURE CPTS"",0)),1) S %=1"
- D DISPREF
- HOSX K APCHSFN,APCHSOP,APCHST,APCHSS,APCHSDFN,APCHSICD,APCHSNRQ,APCHSDAT,APCHSDS,APCHSICL,APCHSIVD,APCHSCOD,APCHSCNT,APCHSOPN,APCHSOP,Y
- K APCHHOSA,APCHHOSC
- Q
- ;
- HOSCHK ;
- ;S APCHSCOD=+^ICD0(APCHSICD,0) cmi/anch/maw
- S APCHSCOD=$P($$ICDOP^ICDCODE(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 D
- ..S BSDXTMP=$$FILL^BSDX41(27)_"CODE"
- ..S BSDXTMP=BSDXTMP_$$FILL^BSDX41(34-$L(BSDXTMP))_"CPT NARRATIVE"
- ..S BSDXTMP=BSDXTMP_$$FILL^BSDX41(72-$L(BSDXTMP))_"UNITS"
- ..S BSDXI=BSDXI+1 S ^BSDXTMP($J,BSDXI)=BSDXTMP_$C(30)
- .S BSDXTMP=$$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 D
- ....S BSDXTMP=BSDXTMP_$$FILL^BSDX41(28-$L(BSDXTMP))_"CODE"
- ....S BSDXTMP=BSDXTMP_$$FILL^BSDX41(35-$L(BSDXTMP))_"CPT NARRATIVE"
- ....S BSDXTMP=BSDXTMP_$$FILL^BSDX41(72-$L(BSDXTMP))_"UNITS"
- ....S BSDXI=BSDXI+1 S ^BSDXTMP($J,BSDXI)=BSDXTMP_$C(30)
- ....S BSDXTMP=""
- ...S %=$P(APCHCPTA(APCHSIVD,APCHCPT,APCHIEN),U,3)
- ...I % S BSDXTMP=" "_$P($G(^AUTTLOC(%,0)),U,2)
- ...S %=$P(APCHCPTA(APCHSIVD,APCHCPT,APCHIEN),U,4)
- ...I % S BSDXTMP=BSDXTMP_$$FILL^BSDX41(22-$L(BSDXTMP))_$P($G(^DIC(40.7,%,9999999)),U)
- ...S BSDXTMP=BSDXTMP_$$FILL^BSDX41(28-$L(BSDXTMP))_APCHCPT
- ...S BSDXTMP=BSDXTMP_$$FILL^BSDX41(35-$L(BSDXTMP))_$E($P(APCHCPTA(APCHSIVD,APCHCPT,APCHIEN),U,1),1,36)
- ...S BSDXTMP=BSDXTMP_$$FILL^BSDX41(73_$L(BSDXTMP))_$P(APCHCPTA(APCHSIVD,APCHCPT,APCHIEN),U,2)
- ...S BSDXI=BSDXI+1 S ^BSDXTMP($J,BSDXI)=BSDXTMP_$C(30)
- ;
- ;display CPT refusals
- S APCHST="CPT",APCHSFN=81 D DISPREF
- K APCHST,APCHSFN
- CPTALLX 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 D
- ...S BSDXTMP="CODE"_" "_"DATE"
- ...S BSDXTMP=BSDXTMP_$$FILL^BSDX41(17-$L(BSDXTMP))_"CPT NARRATIVE"
- ...S BSDXTMP=BSDXTMP_$$FILL^BSDX41(54-$L(BSDXTMP))_"UNITS"
- ...S BSDXTMP=BSDXTMP_$$FILL^BSDX41(60-$L(BSDXTMP))_"FACILITY"
- ...S BSDXTMP=BSDXTMP_$$FILL^BSDX41(74-$L(BSDXTMP))_"CLN"
- ...S BSDXI=BSDXI+1 S ^BSDXTMP($J,BSDXI)=BSDXTMP_$C(30)
- ..S BSDXTMP=" "_$$DATE^APCHSMU((9999999-APCHSIVD))
- ..S BSDXTMP=BSDXTMP_$$FILL^BSDX41(17-$L(BSDXTMP))_$E($P(APCHCPTA(APCHCPT,APCHSIVD,APCHIEN),U,1),1,35)
- ..S BSDXTMP=BSDXTMP_$$FILL^BSDX41(54-$L(BSDXTMP))_$P(APCHCPTA(APCHCPT,APCHSIVD,APCHIEN),U,2)
- ..S %=$P(APCHCPTA(APCHCPT,APCHSIVD,APCHIEN),U,3)
- ..I % S BSDXTMP=BSDXTMP_$$FILL^BSDX41(60-$L(BSDXTMP))_$P($G(^AUTTLOC(%,0)),U,2)
- ..S %=$P(APCHCPTA(APCHCPT,APCHSIVD,APCHIEN),U,4)
- ..I % S BSDXTMP=BSDXTMP_$$FILL^BSDX41(74-$L(BSDXTMP))_$P($G(^DIC(40.7,%,9999999)),U)
- ..S BSDXI=BSDXI+1 S ^BSDXTMP($J,BSDXI)=BSDXTMP_$C(30)
- .Q
- Q
- ;
- PRTICD ;ENTRY POINT
- I APCHSICF="N" S:APCHSNRQ="" APCHSNRQ="<no narrative provided>" S APCHSICD=""
- S APCHSTXT=$G(APCHSICD)
- S:'$D(APCHSNTE) APCHSNTE=""
- I APCHSNTE]"" S APCHSNTE=" "_APCHSNTE
- D PRTTXT
- Q
- ;
- PRTTXT ;PEP - PUBLISHED ENTRY POINT
- ; GENERALIZED TEXT PRINTER
- S:'$D(APCHSNTE) APCHSNTE=""
- S APCHSDLT=1,APCHSILN=IOM-APCHSICL-1
- F APCHSQ=0:0 D PRTTXT1 Q:APCHSTXT="" D PRTTXT2
- K APCHSNTE
- K APCHSILN,APCHSDLT,APCHSF,APCHSC,APCHSTXT
- Q
- PRTTXT1 ;
- S:APCHSNRQ]""&(($L(APCHSNRQ)+$L(APCHSTXT)+2)<255) APCHSTXT=$S(APCHSTXT]"":APCHSTXT_"; ",1:"")_APCHSNRQ,APCHSNRQ=""
- S:APCHSNTE]""&(APCHSNRQ="")&(($L(APCHSNTE)+$L(APCHSTXT)+2)<255) APCHSTXT=APCHSTXT_APCHSNTE,APCHSNTE=""
- Q
- PRTTXT2 D GETFRAG
- ;X APCHSCKP Q:$D(APCHSQIT)
- S BSDXI=BSDXI+1 S ^BSDXTMP($J,BSDXI)=BSDXTMP_$$FILL^BSDX41(APCHSICL-$L(BSDXTMP))_APCHSF_$C(30)
- S APCHSICL=APCHSICL+APCHSDLT,APCHSILN=APCHSILN-APCHSDLT,APCHSDLT=0
- Q
- GETFRAG I $L(APCHSTXT)<APCHSILN S APCHSF=APCHSTXT,APCHSTXT="" Q
- F APCHSC=APCHSILN:-1:0 Q:$E(APCHSTXT,APCHSC)=" "
- S:APCHSC=0 APCHSC=APCHSILN
- S APCHSF=$E(APCHSTXT,1,APCHSC-1),APCHSTXT=$E(APCHSTXT,APCHSC+1,255)
- Q
- DISPREF ;EP
- X APCHSCKP Q:$D(APCHSQIT)
- S APCHSRC=0
- S BSDXI=BSDXI+1 S ^BSDXTMP($J,BSDXI)=BSDXTMP_$C(30)
- S APCHSX="" F S APCHSX=$O(^AUPNPREF("AA",APCHSPAT,APCHSFN,APCHSX)) Q:APCHSX=""!($D(APCHSQIT)) D
- .S APCHSD=0 F S APCHSD=$O(^AUPNPREF("AA",APCHSPAT,APCHSFN,APCHSX,APCHSD)) Q:APCHSD=""!(APCHSD>APCHSDLM)!($D(APCHSQIT)) D
- ..S APCHSI=0 F S APCHSI=$O(^AUPNPREF("AA",APCHSPAT,APCHSFN,APCHSX,APCHSD,APCHSI)) Q:APCHSI=""!($D(APCHSQIT)) D
- ...I $D(APCHSS) X APCHSS Q:'%
- ...S APCHSRC=APCHSRC+1
- ...I APCHSRC=1 I APCHST]"" S BSDXI=BSDXI+1 S ^BSDXTMP($J,BSDXI)=BSDXTMP_$C(30) S BSDXTMP=APCHST_" Refusals "
- ...X APCHSCKP Q:$D(APCHSQIT)
- ...S BSDXTMP=$$VAL^XBDIQ1(9000022,APCHSI,.04)_" -- "_$$VAL^XBDIQ1(9000022,APCHSI,.07)
- ...S BSDXTMP=BSDXTMP_$$FILL^BSDX41(60-$L(BSDXTMP))_"("_$$DATE^APCHSMU(9999999-APCHSD)_")"
- ...S BSDXI=BSDXI+1 S ^BSDXTMP($J,BSDXI)=BSDXTMP_$C(30)
- ..Q
- .Q
- S BSDXI=BSDXI+1 S ^BSDXTMP($J,BSDXI)=BSDXTMP_$C(30)
- K APCHST,APCHSX,APCHSD,APCHSS,APCHSFN,APCHSI
- Q
- BSDX41F ; IHS/OIT/HMW/MSC/SAT - WINDOWS SCHEDULING RPCS ;
- +1 ;;3.0;IHS WINDOWS SCHEDULING;;DEC 09, 2010
- +2 ;
- FMH ; ******* FAMILY HISTORY * 9000014 ******* (APCHS6)
- +1 GOTO FMH^APCHS61
- PMH ; ******** PERSONAL HISTORY * 9000013 ******* (APCHS6)
- +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 SET APCHSICD=$PIECE(APCHSN,U,1)
- DO GETICDDX^APCHSUTL
- +2 SET Y=$PIECE(APCHSN,U,3)
- XECUTE APCHSCVD
- SET APCHSDAT=Y
- +3 SET APCHSDTH=$PIECE(APCHSN,U,5)
- IF APCHSDTH]""
- SET Y=APCHSDTH
- XECUTE APCHSCVD
- SET APCHSDTH=Y
- +4 SET APCHSNRQ=$PIECE(APCHSN,U,4)
- +5 DO GETNARR^APCHSUTL
- +6 KILL APCHSDTE
- IF APCHSDTH]""
- SET APCHSNTE="(onset: "_APCHSDTH_")"
- +7 XECUTE APCHSCKP
- IF $DATA(APCHSQIT)
- QUIT
- SET BSDXTMP=APCHSDAT
- SET APCHSICL=10
- DO PRTICD
- +8 QUIT
- +9 ;
- HOS ; HISTORY OF SURGERY * 9000010.08 (V PROCEDURE) & V CPT ******* (APCHS6)
- +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 ; <DISPLAY>
- +6 SET APCHSIVD=0
- FOR
- SET APCHSIVD=$ORDER(^AUPNVPRC("AA",APCHSPAT,APCHSIVD))
- IF 'APCHSIVD
- QUIT
- Begin DoDot:1
- +7 SET APCHSDFN=0
- FOR
- SET APCHSDFN=$ORDER(^AUPNVPRC("AA",APCHSPAT,APCHSIVD,APCHSDFN))
- IF 'APCHSDFN
- QUIT
- Begin DoDot:2
- +8 SET APCHSICD=$PIECE(^AUPNVPRC(APCHSDFN,0),U)
- +9 SET APCHSN=^AUPNVPRC(APCHSDFN,0)
- +10 DO HOSCHK
- IF APCHSICD=""
- QUIT
- +11 SET APCHSCNT=APCHSCNT+1
- +12 SET APCHCSVD=+^AUPNVSIT($PIECE(APCHSN,U,3),0)\1
- +13 DO GETICDOP^APCHSUTL
- +14 SET Y=$PIECE(APCHSN,U,3)
- SET Y=+^AUPNVSIT(Y,0)\1
- XECUTE APCHSCVD
- SET APCHSDAT=Y
- +15 SET APCHSNRQ=$PIECE(APCHSN,U,4)
- +16 IF APCHSNRQ
- DO GETNARR^APCHSUTL
- +17 IF APCHSNRQ=""
- SET APCHSNRQ=$PIECE($$ICDOP^ICDCODE($PIECE(APCHSN,U,1),+^AUPNVSIT($PIECE(APCHSN,U,3),0)\1),U,5)
- +18 SET APCHSDS="DATE?"
- Begin DoDot:3
- +19 SET Y=$PIECE(APCHSN,U,6)
- IF Y]""
- XECUTE APCHSCVD
- SET APCHSDS=Y
- QUIT
- +20 SET Y=(9999999-APCHSIVD)
- XECUTE APCHSCVD
- SET APCHSDS=Y
- End DoDot:3
- +21 DO GETOPRV
- +22 SET APCHHOSA(APCHSIVD,"PRC",APCHSDFN)=APCHSDS_U_APCHSNRQ_U_APCHSOP_U_APCHSICD
- End DoDot:2
- End DoDot:1
- +23 ;now go through v cpt
- +24 SET APCHT=$ORDER(^ATXAX("B","APCH HS MAJOR PROCEDURE CPTS",0))
- +25 SET APCHCPTI=0
- FOR
- SET APCHCPTI=$ORDER(^AUPNVCPT("AA",APCHSPAT,APCHCPTI))
- IF APCHCPTI'=+APCHCPTI
- QUIT
- Begin DoDot:1
- +26 ;not a cpt wanted on this component
- IF '$$ICD^ATXCHK(APCHCPTI,APCHT,1)
- QUIT
- +27 SET APCHSIVD=0
- FOR
- SET APCHSIVD=$ORDER(^AUPNVCPT("AA",APCHSPAT,APCHCPTI,APCHSIVD))
- IF APCHSIVD=""
- QUIT
- Begin DoDot:2
- +28 SET APCHSIEN=0
- FOR
- SET APCHSIEN=$ORDER(^AUPNVCPT("AA",APCHSPAT,APCHCPTI,APCHSIVD,APCHSIEN))
- IF APCHSIEN'=+APCHSIEN
- QUIT
- Begin DoDot:3
- +29 SET Y=(9999999-APCHSIVD)
- XECUTE APCHSCVD
- SET APCHSDS=Y
- +30 SET APCHSN=^AUPNVCPT(APCHSIEN,0)
- +31 SET APCHSICD=$PIECE(APCHSN,U,1)
- +32 DO GETCPT^APCHSUTL
- +33 SET APCHSNRQ=$PIECE(APCHSN,U,4)
- +34 IF APCHSNRQ
- DO GETNARR^APCHSUTL
- +35 ;cmi/anch/maw 8/28/2007 mods for CSV
- +36 NEW APCHSVDT
- +37 SET APCHSVDT=$PIECE(+^AUPNVSIT($PIECE(APCHSN,U,3),0),".")
- +38 ;I APCHSNRQ="" S APCHSNRQ=$P(^ICPT($P(APCHSN,U,1),0),U,2) cmi/anch/maw 8/28/2007 orig line
- +39 ;cmi/anch/maw 8/28/2007 code set versioning
- IF APCHSNRQ=""
- SET APCHSNRQ=$PIECE($$CPT^ICPTCOD($PIECE(APCHSN,U,1),APCHSVDT),U,3)
- +40 ;cmi/anch/maw 8/28/2007 end of mods
- +41 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
- +42 SET APCHHOSC(APCHSIVD,"CPT",$PIECE(^ICPT($PIECE(APCHSN,U,1),0),U,1))=""
- End DoDot:3
- End DoDot:2
- End DoDot:1
- +43 ;now get all tran codes hcpcs
- +44 SET APCHSIEN=0
- FOR
- SET APCHSIEN=$ORDER(^AUPNVTC("AC",APCHSPAT,APCHSIEN))
- IF APCHSIEN=""
- QUIT
- Begin DoDot:1
- +45 IF '$DATA(^AUPNVTC(APCHSIEN))
- QUIT
- +46 SET V=$PIECE(^AUPNVTC(APCHSIEN,0),U,3)
- +47 IF 'V
- QUIT
- +48 IF '$DATA(^AUPNVSIT(V,0))
- QUIT
- +49 SET V=$PIECE($PIECE(^AUPNVSIT(V,0),U),".")
- +50 SET Y=V
- XECUTE APCHSCVD
- SET APCHSDS=Y
- +51 SET APCHSIVD=9999999-V
- +52 SET APCHCPT=$$VAL^XBDIQ1(9000010.33,APCHSIEN,.07)
- +53 SET APCHCPTI=$PIECE(^AUPNVTC(APCHSIEN,0),U,7)
- +54 ;not a cpt wanted on this component
- IF '$$ICD^ATXCHK(APCHCPTI,APCHT,1)
- QUIT
- +55 IF $DATA(APCHHOSC(APCHSIVD,"CPT",APCHCPT))
- QUIT
- +56 ;S APCHSNRQ=$P(^ICPT(APCHCPTI,0),U,2)
- +57 SET APCHSNRQ=$PIECE($$CPT^ICPTCOD(APCHCPTI,V),U,3)
- +58 SET APCHSICD=APCHCPTI
- +59 DO GETCPT^APCHSUTL
- +60 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
- +61 ;now display the procedures/cpt codes
- +62 SET APCHSIVD=0
- FOR
- SET APCHSIVD=$ORDER(APCHHOSA(APCHSIVD))
- IF APCHSIVD=""!($DATA(APCHSQIT))
- QUIT
- Begin DoDot:1
- +63 XECUTE APCHSCKP
- IF $DATA(APCHSQIT)
- QUIT
- +64 SET APCHIEN=0
- FOR
- SET APCHIEN=$ORDER(APCHHOSA(APCHSIVD,"PRC",APCHIEN))
- IF APCHIEN'=+APCHIEN!($DATA(APCHSQIT))
- QUIT
- Begin DoDot:2
- +65 SET APCHSOP=$PIECE(APCHHOSA(APCHSIVD,"PRC",APCHIEN),U,3)
- +66 SET APCHSNRQ=$PIECE(APCHHOSA(APCHSIVD,"PRC",APCHIEN),U,2)
- +67 SET APCHSDS=$PIECE(APCHHOSA(APCHSIVD,"PRC",APCHIEN),U,1)
- +68 SET APCHSICD=$PIECE(APCHHOSA(APCHSIVD,"PRC",APCHIEN),U,4)
- +69 SET BSDXTMP=APCHSDS_$$FILL^BSDX41(10-$LENGTH(APCHSDS))_$EXTRACT(APCHSOP,1,15)
- SET APCHSNTE=""
- SET APCHSICL=26
- DO PRTICD
- End DoDot:2
- +70 SET APCHIEN=0
- FOR
- SET APCHIEN=$ORDER(APCHHOSA(APCHSIVD,"CPT",APCHIEN))
- IF APCHIEN'=+APCHIEN!($DATA(APCHSQIT))
- QUIT
- Begin DoDot:2
- +71 SET APCHSOP=$PIECE(APCHHOSA(APCHSIVD,"CPT",APCHIEN),U,3)
- +72 SET APCHSNRQ=$PIECE(APCHHOSA(APCHSIVD,"CPT",APCHIEN),U,2)
- +73 SET APCHSDS=$PIECE(APCHHOSA(APCHSIVD,"CPT",APCHIEN),U,1)
- +74 SET APCHSICD=$PIECE(APCHHOSA(APCHSIVD,"CPT",APCHIEN),U,4)
- +75 SET BSDXTMP=APCHSDS_$$FILL^BSDX41(10-$LENGTH(APCHSDS))_$EXTRACT(APCHSOP,1,15)
- SET APCHSNTE=""
- SET APCHSICL=26
- DO PRTICD
- End DoDot:2
- End DoDot:1
- +76 IF 'APCHSCNT
- XECUTE APCHSCKP
- IF $DATA(APCHSQIT)
- QUIT
- SET BSDXI=BSDXI+1
- SET ^BSDXTMP($JOB,BSDXI)="Minor procedures are on file but have not been displayed."_$CHAR(30)
- +77 ;
- +78 ; now display refusals for icd procedures
- +79 SET APCHSFN=80.1
- SET APCHST="PROCEDURE"
- +80 SET APCHSS="S %=0,APCHSICD=$P(^AUPNPREF(APCHSI,0),U,6) Q:'APCHSICD D HOSCHK^APCHS6 I APCHSICD S %=1"
- +81 DO DISPREF
- +82 SET APCHSFN=81
- SET APCHST="CPT"
- +83 SET APCHSS="S %=0,APCHCPT=$P(^AUPNPREF(APCHSI,0),U,6) Q:'APCHCPT I $$ICD^ATXCHK(APCHCPT,$O(^ATXAX(""B"",""APCH HS MAJOR PROCEDURE CPTS"",0)),1) S %=1"
- +84 DO DISPREF
- HOSX KILL APCHSFN,APCHSOP,APCHST,APCHSS,APCHSDFN,APCHSICD,APCHSNRQ,APCHSDAT,APCHSDS,APCHSICL,APCHSIVD,APCHSCOD,APCHSCNT,APCHSOPN,APCHSOP,Y
- +1 KILL APCHHOSA,APCHHOSC
- +2 QUIT
- +3 ;
- HOSCHK ;
- +1 ;S APCHSCOD=+^ICD0(APCHSICD,0) cmi/anch/maw
- +2 ;cmi/anch/maw CSV
- SET APCHSCOD=$PIECE($$ICDOP^ICDCODE(APCHSICD),U,2)
- +3 IF APCHSCOD\1>85
- SET APCHSICD=""
- QUIT
- +4 IF APCHSCOD=69.7
- SET APCHSICD=""
- QUIT
- +5 IF APCHSCOD\1=23
- SET APCHSICD=""
- QUIT
- +6 IF APCHSCOD\1=24
- SET APCHSICD=""
- QUIT
- +7 IF $EXTRACT(APCHSCOD,1,4)="38.9"
- SET APCHSICD=""
- QUIT
- +8 IF APCHSCOD=73.09
- SET APCHSICD=""
- QUIT
- +9 ;blood draw
- IF APCHSCOD="38.29"
- SET APCHSICD=""
- QUIT
- +10 ;insertion of urinary catheter
- IF APCHSCOD="57.94"
- SET APCHSICD=""
- QUIT
- +11 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
- Begin DoDot:2
- +30 SET BSDXTMP=$$FILL^BSDX41(27)_"CODE"
- +31 SET BSDXTMP=BSDXTMP_$$FILL^BSDX41(34-$LENGTH(BSDXTMP))_"CPT NARRATIVE"
- +32 SET BSDXTMP=BSDXTMP_$$FILL^BSDX41(72-$LENGTH(BSDXTMP))_"UNITS"
- +33 SET BSDXI=BSDXI+1
- SET ^BSDXTMP($JOB,BSDXI)=BSDXTMP_$CHAR(30)
- End DoDot:2
- +34 SET BSDXTMP=$$DATE^APCHSMU((9999999-APCHSIVD))
- +35 SET APCHCPT=""
- FOR
- SET APCHCPT=$ORDER(APCHCPTA(APCHSIVD,APCHCPT))
- IF APCHCPT=""!($DATA(APCHSQIT))
- QUIT
- Begin DoDot:2
- +36 SET APCHIEN=0
- FOR
- SET APCHIEN=$ORDER(APCHCPTA(APCHSIVD,APCHCPT,APCHIEN))
- IF APCHIEN'=+APCHIEN!($DATA(APCHSQIT))
- QUIT
- Begin DoDot:3
- +37 XECUTE APCHSCKP
- IF $DATA(APCHSQIT)
- QUIT
- IF APCHSNPG
- Begin DoDot:4
- +38 SET BSDXTMP=BSDXTMP_$$FILL^BSDX41(28-$LENGTH(BSDXTMP))_"CODE"
- +39 SET BSDXTMP=BSDXTMP_$$FILL^BSDX41(35-$LENGTH(BSDXTMP))_"CPT NARRATIVE"
- +40 SET BSDXTMP=BSDXTMP_$$FILL^BSDX41(72-$LENGTH(BSDXTMP))_"UNITS"
- +41 SET BSDXI=BSDXI+1
- SET ^BSDXTMP($JOB,BSDXI)=BSDXTMP_$CHAR(30)
- +42 SET BSDXTMP=""
- End DoDot:4
- +43 SET %=$PIECE(APCHCPTA(APCHSIVD,APCHCPT,APCHIEN),U,3)
- +44 IF %
- SET BSDXTMP=" "_$PIECE($GET(^AUTTLOC(%,0)),U,2)
- +45 SET %=$PIECE(APCHCPTA(APCHSIVD,APCHCPT,APCHIEN),U,4)
- +46 IF %
- SET BSDXTMP=BSDXTMP_$$FILL^BSDX41(22-$LENGTH(BSDXTMP))_$PIECE($GET(^DIC(40.7,%,9999999)),U)
- +47 SET BSDXTMP=BSDXTMP_$$FILL^BSDX41(28-$LENGTH(BSDXTMP))_APCHCPT
- +48 SET BSDXTMP=BSDXTMP_$$FILL^BSDX41(35-$LENGTH(BSDXTMP))_$EXTRACT($PIECE(APCHCPTA(APCHSIVD,APCHCPT,APCHIEN),U,1),1,36)
- +49 SET BSDXTMP=BSDXTMP_$$FILL^BSDX41(73_$LENGTH(BSDXTMP))_$PIECE(APCHCPTA(APCHSIVD,APCHCPT,APCHIEN),U,2)
- +50 SET BSDXI=BSDXI+1
- SET ^BSDXTMP($JOB,BSDXI)=BSDXTMP_$CHAR(30)
- End DoDot:3
- End DoDot:2
- End DoDot:1
- +51 ;
- +52 ;display CPT refusals
- +53 SET APCHST="CPT"
- SET APCHSFN=81
- DO DISPREF
- +54 KILL APCHST,APCHSFN
- CPTALLX KILL APCHSIVD,APCHSDAT,APCHCPT,APCHIEN,APCHCPTA,APCHCPTI
- +1 QUIT
- +2 ;
- 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
- Begin DoDot:3
- +4 SET BSDXTMP="CODE"_" "_"DATE"
- +5 SET BSDXTMP=BSDXTMP_$$FILL^BSDX41(17-$LENGTH(BSDXTMP))_"CPT NARRATIVE"
- +6 SET BSDXTMP=BSDXTMP_$$FILL^BSDX41(54-$LENGTH(BSDXTMP))_"UNITS"
- +7 SET BSDXTMP=BSDXTMP_$$FILL^BSDX41(60-$LENGTH(BSDXTMP))_"FACILITY"
- +8 SET BSDXTMP=BSDXTMP_$$FILL^BSDX41(74-$LENGTH(BSDXTMP))_"CLN"
- +9 SET BSDXI=BSDXI+1
- SET ^BSDXTMP($JOB,BSDXI)=BSDXTMP_$CHAR(30)
- End DoDot:3
- +10 SET BSDXTMP=" "_$$DATE^APCHSMU((9999999-APCHSIVD))
- +11 SET BSDXTMP=BSDXTMP_$$FILL^BSDX41(17-$LENGTH(BSDXTMP))_$EXTRACT($PIECE(APCHCPTA(APCHCPT,APCHSIVD,APCHIEN),U,1),1,35)
- +12 SET BSDXTMP=BSDXTMP_$$FILL^BSDX41(54-$LENGTH(BSDXTMP))_$PIECE(APCHCPTA(APCHCPT,APCHSIVD,APCHIEN),U,2)
- +13 SET %=$PIECE(APCHCPTA(APCHCPT,APCHSIVD,APCHIEN),U,3)
- +14 IF %
- SET BSDXTMP=BSDXTMP_$$FILL^BSDX41(60-$LENGTH(BSDXTMP))_$PIECE($GET(^AUTTLOC(%,0)),U,2)
- +15 SET %=$PIECE(APCHCPTA(APCHCPT,APCHSIVD,APCHIEN),U,4)
- +16 IF %
- SET BSDXTMP=BSDXTMP_$$FILL^BSDX41(74-$LENGTH(BSDXTMP))_$PIECE($GET(^DIC(40.7,%,9999999)),U)
- +17 SET BSDXI=BSDXI+1
- SET ^BSDXTMP($JOB,BSDXI)=BSDXTMP_$CHAR(30)
- End DoDot:2
- +18 QUIT
- End DoDot:1
- +19 QUIT
- +20 ;
- PRTICD ;ENTRY POINT
- +1 IF APCHSICF="N"
- IF APCHSNRQ=""
- SET APCHSNRQ="<no narrative provided>"
- SET APCHSICD=""
- +2 SET APCHSTXT=$GET(APCHSICD)
- +3 IF '$DATA(APCHSNTE)
- SET APCHSNTE=""
- +4 IF APCHSNTE]""
- SET APCHSNTE=" "_APCHSNTE
- +5 DO PRTTXT
- +6 QUIT
- +7 ;
- PRTTXT ;PEP - PUBLISHED ENTRY POINT
- +1 ; GENERALIZED TEXT PRINTER
- +2 IF '$DATA(APCHSNTE)
- SET APCHSNTE=""
- +3 SET APCHSDLT=1
- SET APCHSILN=IOM-APCHSICL-1
- +4 FOR APCHSQ=0:0
- DO PRTTXT1
- IF APCHSTXT=""
- QUIT
- DO PRTTXT2
- +5 KILL APCHSNTE
- +6 KILL APCHSILN,APCHSDLT,APCHSF,APCHSC,APCHSTXT
- +7 QUIT
- PRTTXT1 ;
- +1 IF APCHSNRQ]""&(($LENGTH(APCHSNRQ)+$LENGTH(APCHSTXT)+2)<255)
- SET APCHSTXT=$SELECT(APCHSTXT]"":APCHSTXT_"; ",1:"")_APCHSNRQ
- SET APCHSNRQ=""
- +2 IF APCHSNTE]""&(APCHSNRQ="")&(($LENGTH(APCHSNTE)+$LENGTH(APCHSTXT)+2)<255)
- SET APCHSTXT=APCHSTXT_APCHSNTE
- SET APCHSNTE=""
- +3 QUIT
- PRTTXT2 DO GETFRAG
- +1 ;X APCHSCKP Q:$D(APCHSQIT)
- +2 SET BSDXI=BSDXI+1
- SET ^BSDXTMP($JOB,BSDXI)=BSDXTMP_$$FILL^BSDX41(APCHSICL-$LENGTH(BSDXTMP))_APCHSF_$CHAR(30)
- +3 SET APCHSICL=APCHSICL+APCHSDLT
- SET APCHSILN=APCHSILN-APCHSDLT
- SET APCHSDLT=0
- +4 QUIT
- GETFRAG IF $LENGTH(APCHSTXT)<APCHSILN
- SET APCHSF=APCHSTXT
- SET APCHSTXT=""
- QUIT
- +1 FOR APCHSC=APCHSILN:-1:0
- IF $EXTRACT(APCHSTXT,APCHSC)=" "
- QUIT
- +2 IF APCHSC=0
- SET APCHSC=APCHSILN
- +3 SET APCHSF=$EXTRACT(APCHSTXT,1,APCHSC-1)
- SET APCHSTXT=$EXTRACT(APCHSTXT,APCHSC+1,255)
- +4 QUIT
- DISPREF ;EP
- +1 XECUTE APCHSCKP
- IF $DATA(APCHSQIT)
- QUIT
- +2 SET APCHSRC=0
- +3 SET BSDXI=BSDXI+1
- SET ^BSDXTMP($JOB,BSDXI)=BSDXTMP_$CHAR(30)
- +4 SET APCHSX=""
- FOR
- SET APCHSX=$ORDER(^AUPNPREF("AA",APCHSPAT,APCHSFN,APCHSX))
- IF APCHSX=""!($DATA(APCHSQIT))
- QUIT
- Begin DoDot:1
- +5 SET APCHSD=0
- FOR
- SET APCHSD=$ORDER(^AUPNPREF("AA",APCHSPAT,APCHSFN,APCHSX,APCHSD))
- IF APCHSD=""!(APCHSD>APCHSDLM)!($DATA(APCHSQIT))
- QUIT
- Begin DoDot:2
- +6 SET APCHSI=0
- FOR
- SET APCHSI=$ORDER(^AUPNPREF("AA",APCHSPAT,APCHSFN,APCHSX,APCHSD,APCHSI))
- IF APCHSI=""!($DATA(APCHSQIT))
- QUIT
- Begin DoDot:3
- +7 IF $DATA(APCHSS)
- XECUTE APCHSS
- IF '%
- QUIT
- +8 SET APCHSRC=APCHSRC+1
- +9 IF APCHSRC=1
- IF APCHST]""
- SET BSDXI=BSDXI+1
- SET ^BSDXTMP($JOB,BSDXI)=BSDXTMP_$CHAR(30)
- SET BSDXTMP=APCHST_" Refusals "
- +10 XECUTE APCHSCKP
- IF $DATA(APCHSQIT)
- QUIT
- +11 SET BSDXTMP=$$VAL^XBDIQ1(9000022,APCHSI,.04)_" -- "_$$VAL^XBDIQ1(9000022,APCHSI,.07)
- +12 SET BSDXTMP=BSDXTMP_$$FILL^BSDX41(60-$LENGTH(BSDXTMP))_"("_$$DATE^APCHSMU(9999999-APCHSD)_")"
- +13 SET BSDXI=BSDXI+1
- SET ^BSDXTMP($JOB,BSDXI)=BSDXTMP_$CHAR(30)
- End DoDot:3
- +14 QUIT
- End DoDot:2
- +15 QUIT
- End DoDot:1
- +16 SET BSDXI=BSDXI+1
- SET ^BSDXTMP($JOB,BSDXI)=BSDXTMP_$CHAR(30)
- +17 KILL APCHST,APCHSX,APCHSD,APCHSS,APCHSFN,APCHSI
- +18 QUIT