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
