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

BSDX41F.m

Go to the documentation of this file.
  1. BSDX41F ; IHS/OIT/HMW/MSC/SAT - WINDOWS SCHEDULING RPCS ;
  1. ;;3.0;IHS WINDOWS SCHEDULING;;DEC 09, 2010
  1. ;
  1. FMH ; ******* FAMILY HISTORY * 9000014 ******* (APCHS6)
  1. G FMH^APCHS61
  1. PMH ; ******** PERSONAL HISTORY * 9000013 ******* (APCHS6)
  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 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) S BSDXTMP=APCHSDAT S APCHSICL=10 D PRTICD
  1. Q
  1. ;
  1. HOS ; HISTORY OF SURGERY * 9000010.08 (V PROCEDURE) & V CPT ******* (APCHS6)
  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. ; <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^ICDCODE($P(APCHSN,U,1),+^AUPNVSIT($P(APCHSN,U,3),0)\1),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. 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^ATXCHK(APCHCPTI,APCHT,1) Q ;not a cpt wanted on this component
  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 CSV
  1. ...N APCHSVDT
  1. ...S APCHSVDT=$P(+^AUPNVSIT($P(APCHSN,U,3),0),".")
  1. ...;I APCHSNRQ="" S APCHSNRQ=$P(^ICPT($P(APCHSN,U,1),0),U,2) cmi/anch/maw 8/28/2007 orig line
  1. ...I APCHSNRQ="" S APCHSNRQ=$P($$CPT^ICPTCOD($P(APCHSN,U,1),APCHSVDT),U,3) ;cmi/anch/maw 8/28/2007 code set versioning
  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. .I '$$ICD^ATXCHK(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 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. .. S BSDXTMP=APCHSDS_$$FILL^BSDX41(10-$L(APCHSDS))_$E(APCHSOP,1,15) S APCHSNTE="" S APCHSICL=26 D PRTICD
  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. .. S BSDXTMP=APCHSDS_$$FILL^BSDX41(10-$L(APCHSDS))_$E(APCHSOP,1,15) S APCHSNTE="" S APCHSICL=26 D PRTICD
  1. 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)
  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
  1. S APCHSFN=81,APCHST="CPT"
  1. 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"
  1. D DISPREF
  1. HOSX K APCHSFN,APCHSOP,APCHST,APCHSS,APCHSDFN,APCHSICD,APCHSNRQ,APCHSDAT,APCHSDS,APCHSICL,APCHSIVD,APCHSCOD,APCHSCNT,APCHSOPN,APCHSOP,Y
  1. K APCHHOSA,APCHHOSC
  1. Q
  1. ;
  1. HOSCHK ;
  1. ;S APCHSCOD=+^ICD0(APCHSICD,0) cmi/anch/maw
  1. S APCHSCOD=$P($$ICDOP^ICDCODE(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 D
  1. ..S BSDXTMP=$$FILL^BSDX41(27)_"CODE"
  1. ..S BSDXTMP=BSDXTMP_$$FILL^BSDX41(34-$L(BSDXTMP))_"CPT NARRATIVE"
  1. ..S BSDXTMP=BSDXTMP_$$FILL^BSDX41(72-$L(BSDXTMP))_"UNITS"
  1. ..S BSDXI=BSDXI+1 S ^BSDXTMP($J,BSDXI)=BSDXTMP_$C(30)
  1. .S BSDXTMP=$$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 D
  1. ....S BSDXTMP=BSDXTMP_$$FILL^BSDX41(28-$L(BSDXTMP))_"CODE"
  1. ....S BSDXTMP=BSDXTMP_$$FILL^BSDX41(35-$L(BSDXTMP))_"CPT NARRATIVE"
  1. ....S BSDXTMP=BSDXTMP_$$FILL^BSDX41(72-$L(BSDXTMP))_"UNITS"
  1. ....S BSDXI=BSDXI+1 S ^BSDXTMP($J,BSDXI)=BSDXTMP_$C(30)
  1. ....S BSDXTMP=""
  1. ...S %=$P(APCHCPTA(APCHSIVD,APCHCPT,APCHIEN),U,3)
  1. ...I % S BSDXTMP=" "_$P($G(^AUTTLOC(%,0)),U,2)
  1. ...S %=$P(APCHCPTA(APCHSIVD,APCHCPT,APCHIEN),U,4)
  1. ...I % S BSDXTMP=BSDXTMP_$$FILL^BSDX41(22-$L(BSDXTMP))_$P($G(^DIC(40.7,%,9999999)),U)
  1. ...S BSDXTMP=BSDXTMP_$$FILL^BSDX41(28-$L(BSDXTMP))_APCHCPT
  1. ...S BSDXTMP=BSDXTMP_$$FILL^BSDX41(35-$L(BSDXTMP))_$E($P(APCHCPTA(APCHSIVD,APCHCPT,APCHIEN),U,1),1,36)
  1. ...S BSDXTMP=BSDXTMP_$$FILL^BSDX41(73_$L(BSDXTMP))_$P(APCHCPTA(APCHSIVD,APCHCPT,APCHIEN),U,2)
  1. ...S BSDXI=BSDXI+1 S ^BSDXTMP($J,BSDXI)=BSDXTMP_$C(30)
  1. ;
  1. ;display CPT refusals
  1. S APCHST="CPT",APCHSFN=81 D DISPREF
  1. K APCHST,APCHSFN
  1. CPTALLX K APCHSIVD,APCHSDAT,APCHCPT,APCHIEN,APCHCPTA,APCHCPTI
  1. Q
  1. ;
  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 D
  1. ...S BSDXTMP="CODE"_" "_"DATE"
  1. ...S BSDXTMP=BSDXTMP_$$FILL^BSDX41(17-$L(BSDXTMP))_"CPT NARRATIVE"
  1. ...S BSDXTMP=BSDXTMP_$$FILL^BSDX41(54-$L(BSDXTMP))_"UNITS"
  1. ...S BSDXTMP=BSDXTMP_$$FILL^BSDX41(60-$L(BSDXTMP))_"FACILITY"
  1. ...S BSDXTMP=BSDXTMP_$$FILL^BSDX41(74-$L(BSDXTMP))_"CLN"
  1. ...S BSDXI=BSDXI+1 S ^BSDXTMP($J,BSDXI)=BSDXTMP_$C(30)
  1. ..S BSDXTMP=" "_$$DATE^APCHSMU((9999999-APCHSIVD))
  1. ..S BSDXTMP=BSDXTMP_$$FILL^BSDX41(17-$L(BSDXTMP))_$E($P(APCHCPTA(APCHCPT,APCHSIVD,APCHIEN),U,1),1,35)
  1. ..S BSDXTMP=BSDXTMP_$$FILL^BSDX41(54-$L(BSDXTMP))_$P(APCHCPTA(APCHCPT,APCHSIVD,APCHIEN),U,2)
  1. ..S %=$P(APCHCPTA(APCHCPT,APCHSIVD,APCHIEN),U,3)
  1. ..I % S BSDXTMP=BSDXTMP_$$FILL^BSDX41(60-$L(BSDXTMP))_$P($G(^AUTTLOC(%,0)),U,2)
  1. ..S %=$P(APCHCPTA(APCHCPT,APCHSIVD,APCHIEN),U,4)
  1. ..I % S BSDXTMP=BSDXTMP_$$FILL^BSDX41(74-$L(BSDXTMP))_$P($G(^DIC(40.7,%,9999999)),U)
  1. ..S BSDXI=BSDXI+1 S ^BSDXTMP($J,BSDXI)=BSDXTMP_$C(30)
  1. .Q
  1. Q
  1. ;
  1. PRTICD ;ENTRY POINT
  1. I APCHSICF="N" S:APCHSNRQ="" APCHSNRQ="<no narrative provided>" S APCHSICD=""
  1. S APCHSTXT=$G(APCHSICD)
  1. S:'$D(APCHSNTE) APCHSNTE=""
  1. I APCHSNTE]"" S APCHSNTE=" "_APCHSNTE
  1. D PRTTXT
  1. Q
  1. ;
  1. PRTTXT ;PEP - PUBLISHED ENTRY POINT
  1. ; GENERALIZED TEXT PRINTER
  1. S:'$D(APCHSNTE) APCHSNTE=""
  1. S APCHSDLT=1,APCHSILN=IOM-APCHSICL-1
  1. F APCHSQ=0:0 D PRTTXT1 Q:APCHSTXT="" D PRTTXT2
  1. K APCHSNTE
  1. K APCHSILN,APCHSDLT,APCHSF,APCHSC,APCHSTXT
  1. Q
  1. PRTTXT1 ;
  1. S:APCHSNRQ]""&(($L(APCHSNRQ)+$L(APCHSTXT)+2)<255) APCHSTXT=$S(APCHSTXT]"":APCHSTXT_"; ",1:"")_APCHSNRQ,APCHSNRQ=""
  1. S:APCHSNTE]""&(APCHSNRQ="")&(($L(APCHSNTE)+$L(APCHSTXT)+2)<255) APCHSTXT=APCHSTXT_APCHSNTE,APCHSNTE=""
  1. Q
  1. PRTTXT2 D GETFRAG
  1. ;X APCHSCKP Q:$D(APCHSQIT)
  1. S BSDXI=BSDXI+1 S ^BSDXTMP($J,BSDXI)=BSDXTMP_$$FILL^BSDX41(APCHSICL-$L(BSDXTMP))_APCHSF_$C(30)
  1. S APCHSICL=APCHSICL+APCHSDLT,APCHSILN=APCHSILN-APCHSDLT,APCHSDLT=0
  1. Q
  1. GETFRAG I $L(APCHSTXT)<APCHSILN S APCHSF=APCHSTXT,APCHSTXT="" Q
  1. F APCHSC=APCHSILN:-1:0 Q:$E(APCHSTXT,APCHSC)=" "
  1. S:APCHSC=0 APCHSC=APCHSILN
  1. S APCHSF=$E(APCHSTXT,1,APCHSC-1),APCHSTXT=$E(APCHSTXT,APCHSC+1,255)
  1. Q
  1. DISPREF ;EP
  1. X APCHSCKP Q:$D(APCHSQIT)
  1. S APCHSRC=0
  1. S BSDXI=BSDXI+1 S ^BSDXTMP($J,BSDXI)=BSDXTMP_$C(30)
  1. S APCHSX="" F S APCHSX=$O(^AUPNPREF("AA",APCHSPAT,APCHSFN,APCHSX)) Q:APCHSX=""!($D(APCHSQIT)) D
  1. .S APCHSD=0 F S APCHSD=$O(^AUPNPREF("AA",APCHSPAT,APCHSFN,APCHSX,APCHSD)) Q:APCHSD=""!(APCHSD>APCHSDLM)!($D(APCHSQIT)) D
  1. ..S APCHSI=0 F S APCHSI=$O(^AUPNPREF("AA",APCHSPAT,APCHSFN,APCHSX,APCHSD,APCHSI)) Q:APCHSI=""!($D(APCHSQIT)) D
  1. ...I $D(APCHSS) X APCHSS Q:'%
  1. ...S APCHSRC=APCHSRC+1
  1. ...I APCHSRC=1 I APCHST]"" S BSDXI=BSDXI+1 S ^BSDXTMP($J,BSDXI)=BSDXTMP_$C(30) S BSDXTMP=APCHST_" Refusals "
  1. ...X APCHSCKP Q:$D(APCHSQIT)
  1. ...S BSDXTMP=$$VAL^XBDIQ1(9000022,APCHSI,.04)_" -- "_$$VAL^XBDIQ1(9000022,APCHSI,.07)
  1. ...S BSDXTMP=BSDXTMP_$$FILL^BSDX41(60-$L(BSDXTMP))_"("_$$DATE^APCHSMU(9999999-APCHSD)_")"
  1. ...S BSDXI=BSDXI+1 S ^BSDXTMP($J,BSDXI)=BSDXTMP_$C(30)
  1. ..Q
  1. .Q
  1. S BSDXI=BSDXI+1 S ^BSDXTMP($J,BSDXI)=BSDXTMP_$C(30)
  1. K APCHST,APCHSX,APCHSD,APCHSS,APCHSFN,APCHSI
  1. Q