BPCRC7 ; IHS/OIT/MJL - REFERRED CARE GUI RPC ROUTINES ;
;;1.5;BPC;;MAY 26, 2005
GETTEMP(BPCRES,BPCRIEN,BPCPARAM) ;EP CALL FROM REMOTE PROC: BPC GETREFERRALDEF
;
EN1 ;
S U="^",XWBWRAP=1,BPCCTR=0,BPCRIEN=$G(BPCRIEN),BPCPARAM=$G(BPCPARAM)
S BPCS1="`"
K BPCRES,BPCTMP
I BPCRIEN="" S BPCRES(1)=-1,BPCRES(2)="TEMPLATE IEN NOT SENT!" Q
S BPCDTA=$G(^BMCRTNRF(BPCRIEN,0)) I BPCDTA="" S BPCRES(1)=-1,BPCRES(2)="NO DATA AVAILABLE FOR TEMPLATE IEN: "_BPCRIEN Q
D GETTEMP1,KILL
Q
GETTEMP1 ;
S BPCRTYP=$P(BPCDTA,U,4),BPCFAC=$P(BPCDTA,U,5),BPCPROV=$P(BPCDTA,U,6),BPCPVEND=$P(BPCDTA,U,7),BPCTOIHS=$P(BPCDTA,U,8)
S BPCTOPRV=$P(BPCDTA,U,9),BPCPAYOR=$P(BPCDTA,U,11),BPCICD=$P(BPCDTA,U,12),BPCCPT=$P(BPCDTA,U,13),BPCPTYP=$P(BPCDTA,U,14),BPCDRG=$P(BPCDTA,U,21),BPCFDRG=$P(BPCDTA,U,21)
S BPCPRIOR=$P(BPCDTA,U,32)
S BPCDTA=$G(^BMCRTNRF(BPCRIEN,11)),BPCECOST=$P(BPCDTA,U,1),BPCICOST=$P(BPCDTA,U,3),BPCLOS=$P(BPCDTA,U,9),BPCNOVS=$P(BPCDTA,U,11)
S BPCPURP=$G(^BMCRTNRF(BPCRIEN,12)),BPCSNOTE=$G(^BMCRTNRF(BPCRIEN,13))
S BPCSFAC="" I BPCFAC'="" S BPCSFAC=+$G(^AUTTLOC(BPCFAC,0)) S:BPCSFAC BPCSFAC=$P($G(^DIC(4,BPCSFAC,0)),U,1)
S BPCSPROV="" I BPCPROV'="" S BPCSPROV=$P($G(^VA(200,BPCPROV,0)),U,1)
S BPCSPVND="" I BPCPVEND'="" S BPCSPVND=$P($G(^AUTTVNDR(BPCPVEND,0)),U,1)
S BPCSIHS="" I BPCTOIHS'="" S BPCSIHS=$P($G(^AUTTLOC(BPCTOIHS,0)),U,1) S:BPCSIHS'="" BPCSIHS=$P($G(^DIC(4,BPCSIHS,0)),U,1)
S BPCSTPRV="" I BPCTOPRV'="" S BPCSTPRV=$P($G(^BMCLPRV(BPCTOPRV,0)),U,1)
S BPCSICD="" I BPCICD'="" S BPCSICD=$P($G(^BMCTDXC(BPCICD,0)),U,1)
S BPCSCPT="" I BPCCPT'="" S BPCSCPT=$P($G(^BMCTSVC(BPCCPT,0)),U,1)
S BPCSDRG="" I BPCDRG'="" S BPCSDRG=$P($G(^ICD(BPCDRG,0)),U,1)
S BPCSFDRG="" I BPCFDRG'="" S BPCSFDRG=$P($G(^ICD(BPCFDRG,0)),U,1)
S BPCTMP("DATA",0)="DATA"_BPCS1_BPCRTYP_BPCS1_BPCFAC_BPCS1_BPCSFAC_BPCS1_BPCPROV_BPCS1_BPCSPROV_BPCS1_BPCPVEND_BPCS1_BPCSPVND_BPCS1_BPCTOIHS_BPCS1_BPCSIHS
S BPCTMP("DATA",0)=BPCTMP("DATA",0)_BPCS1_BPCTOPRV_BPCS1_BPCSTPRV_BPCS1_BPCPAYOR_BPCS1_BPCICD_BPCS1_BPCSICD_BPCS1_BPCCPT_BPCS1_BPCSCPT_BPCS1_BPCPTYP
S BPCTMP("DATA",0)=BPCTMP("DATA",0)_BPCS1_BPCDRG_BPCS1_BPCSDRG
S BPCTMP("DATA",0)=BPCTMP("DATA",0)_BPCS1_BPCFDRG_BPCS1_BPCSFDRG_BPCS1_BPCPRIOR_BPCS1_BPCECOST_BPCS1_BPCICOST_BPCS1_BPCLOS_BPCS1_BPCNOVS_BPCS1_BPCPURP_BPCS1_BPCSNOTE
D GETSC,GETHX,GETDX,GETPX,SETRESLT
Q
GETSC ;
S BPCX=0,BPCSVCC=0 F S BPCX=$O(^BMCRTNRF(BPCRIEN,21,BPCX)) Q:BPCX="" D GETSC1
S:BPCSVCC BPCCTR=BPCCTR+1,BPCTMP("SVCC",BPCCTR)="SVCC"_BPCS1_BPCSVCC
Q
GETSC1 ;
Q:BPCX'?1.N
S BPCSVCC=BPCSVCC+1,BPCSC=$G(^BMCRTNRF(BPCRIEN,21,BPCX,0))
S BPCSSC="" S:BPCSC'="" BPCSSC=$P($G(^BMCLCAT(BPCSC,0)),U,1)
S:BPCSC'="" BPCCTR=BPCCTR+1,BPCTMP("SVCD",BPCCTR)="SVCD"_BPCS1_BPCSC_BPCS1_BPCSSC
Q
GETHX ;
S BPCX=0,BPCHXC=0 F S BPCX=$O(^BMCRTNRF(BPCRIEN,1,BPCX)) Q:BPCX="" D GETHX1
S:BPCHXC BPCCTR=BPCCTR+1,BPCTMP("HXC",BPCCTR)="HXC"_BPCS1_BPCHXC
Q
GETHX1 ;
Q:BPCX'?1.N
S BPCHXC=BPCHXC+1
S BPCHX=$G(^BMCRTNRF(BPCRIEN,1,BPCX,0))
S:BPCHX'="" BPCCTR=BPCCTR+1,BPCTMP("HXS",BPCCTR)="HXS"_BPCS1_BPCHX
Q
GETDX ;
S BPCX="",BPCDXC=0 F S BPCX=$O(^BMCRTNRF(BPCRIEN,61,"B",BPCX)) Q:BPCX="" D GETDX1
S:BPCDXC BPCCTR=BPCCTR+1,BPCTMP("DXC",BPCCTR)="DXC"_BPCS1_BPCDXC
Q
GETDX1 ;
S BPCDXC=BPCDXC+1,BPCDTA=$G(^ICD9(BPCX,0)),BPCCDE=$P(BPCDTA,U,1),BPCSDX=$P(BPCDTA,U,3),BPCSNAR=""
S BPCCTR=BPCCTR+1,BPCTMP("DXS",BPCCTR)="DXS"_BPCS1_BPCX_BPCS1_BPCCDE_BPCS1_BPCSDX_BPCS1_BPCS1_BPCS1
Q
GETPX ;
S BPCX="",BPCPXC=0 F S BPCX=$O(^BMCRTNRF(BPCRIEN,62,"B",BPCX)) Q:BPCX="" D GETPX1
S:BPCPXC BPCCTR=BPCCTR+1,BPCTMP("PXC",BPCCTR)="PXC"_BPCS1_BPCPXC
Q
GETPX1 ;
S BPCPXC=BPCPXC+1,BPCDTA=$G(^ICPT(BPCX,0)),BPCCDE=$P(BPCDTA,U,1),BPCSPX=$P(BPCDTA,U,2)
S BPCCTR=BPCCTR+1,BPCTMP("PXS",BPCCTR)="PXS"_BPCS1_BPCX_BPCS1_BPCCDE_BPCS1_BPCSPX_BPCS1_BPCS1_BPCS1
Q
SETRESLT ;
S BPCCTR=0,BPCSB1="" F S BPCSB1=$O(BPCTMP(BPCSB1)) Q:BPCSB1="" S BPCSB2="" F S BPCSB2=$O(BPCTMP(BPCSB1,BPCSB2)) Q:BPCSB2="" S BPCCTR=BPCCTR+1,BPCRES(BPCCTR)=BPCTMP(BPCSB1,BPCSB2)
S BPCRES(0)=BPCCTR K BPCTMP
Q
;
KILL ;
K BPCRIEN,BPCPARAM,BPCS1,BPCTMP,BPCDTA,BPCRTYP,BPCFAC,BPCPROV,BPCPVEND,BPCTOIHS,BPCTOPRV,BPCPAYOR,BPCICD,BPCCPT,BPCPTYP,BPCDRG,BPCFDRG,BPCPRIOR,BPCECOST,BPCICOST,BPCLOS,BPCNOVS,BPCPURP,BPCSNOTE,BPCSFAC,BPCSPROV,BPCSPVND,BPCSIHS,BPCSTPRV
K BPCSICD,BPCSCPT,BPCSDRG,BPCSFDRG,BPCSVCC,BPCX,BPCSC,BPCSSC,BPCHXC,BPCHX,BPCDXC,BPCCDE,BPCSDX,BPCSNAR,BPCPXC,BPCDTA,BPCSPX,BPCSB1,BPCSB2,BPCGUI,BPCMAX,BPCMORE,BPCPARAM,BPCN,BPCFLAG,BPCIEN,BPCCTR
Q
TEMPLIST(BPCRES,BPCX,BPCMAX,BPCMORE,BPCPARAM) ;EP CALL FROM REMOTE PROC: BPC GETTEMPLATELIST
;
S BPCGUI=1
EN ;
S U="^",XWBWRAP=1,BPCCTR=0,BPCSUB=$J,BPCC="",BPCMORE=$G(BPCMORE),BPCGUI=$G(BPCGUI),BPCMAX=$G(BPCMAX),BPCX=$G(BPCX),BPCPARAM=$G(BPCPARAM),BPCLEN=$L(BPCX)
S BPCRES="^BPCRES("_BPCSUB_")",BPCN=""
S:'BPCMAX BPCMAX=$S(BPCGUI:50,1:1E10) ;
K ^BPCRES(BPCSUB)
S:BPCX'="" BPCN=$O(^BMCRTNRF("B",BPCX),-1)
I BPCMORE'="" D MORE,KILL Q
D GETTMP1,KILL
Q
GETTMP1 ;
S BPCFLAG=0 F S BPCN=$O(^BMCRTNRF("B",BPCN)) Q:BPCN="" D GETTMP2 Q:BPCFLAG
S ^BPCRES(BPCSUB,0)=BPCCTR
Q
GETTMP2 ;
I BPCX'="",$E(BPCN,1,BPCLEN)'=BPCX S BPCFLAG=1 Q
S BPCIEN="" F S BPCIEN=$O(^BMCRTNRF("B",BPCN,BPCIEN)) Q:BPCIEN="" D SETRES Q:BPCFLAG
Q
SETRES ;
I BPCCTR=BPCMAX D SETMORE S BPCFLAG=1 Q
S BPCCTR=BPCCTR+1,^BPCRES(BPCSUB,BPCCTR)=BPCN_U_BPCIEN
Q
SETMORE ;
S BPCCTR=BPCCTR+1,^BPCRES(BPCSUB,BPCCTR)="..MORE"_U_BPCN_"|"_BPCIEN
Q
MORE ;
S BPCFLAG=0,BPCN=$P(BPCMORE,"|",1),BPCIEN=$P(BPCMORE,"|",2) D SETRES Q:BPCFLAG
F S BPCIEN=$O(^BMCRTNRF("B",BPCN,BPCIEN)) Q:BPCIEN="" D SETRES Q:BPCFLAG
Q:BPCFLAG
D GETTMP1
Q
BPCRC7 ; IHS/OIT/MJL - REFERRED CARE GUI RPC ROUTINES ;
+1 ;;1.5;BPC;;MAY 26, 2005
GETTEMP(BPCRES,BPCRIEN,BPCPARAM) ;EP CALL FROM REMOTE PROC: BPC GETREFERRALDEF
+1 ;
EN1 ;
+1 SET U="^"
SET XWBWRAP=1
SET BPCCTR=0
SET BPCRIEN=$GET(BPCRIEN)
SET BPCPARAM=$GET(BPCPARAM)
+2 SET BPCS1="`"
+3 KILL BPCRES,BPCTMP
+4 IF BPCRIEN=""
SET BPCRES(1)=-1
SET BPCRES(2)="TEMPLATE IEN NOT SENT!"
QUIT
+5 SET BPCDTA=$GET(^BMCRTNRF(BPCRIEN,0))
IF BPCDTA=""
SET BPCRES(1)=-1
SET BPCRES(2)="NO DATA AVAILABLE FOR TEMPLATE IEN: "_BPCRIEN
QUIT
+6 DO GETTEMP1
DO KILL
+7 QUIT
GETTEMP1 ;
+1 SET BPCRTYP=$PIECE(BPCDTA,U,4)
SET BPCFAC=$PIECE(BPCDTA,U,5)
SET BPCPROV=$PIECE(BPCDTA,U,6)
SET BPCPVEND=$PIECE(BPCDTA,U,7)
SET BPCTOIHS=$PIECE(BPCDTA,U,8)
+2 SET BPCTOPRV=$PIECE(BPCDTA,U,9)
SET BPCPAYOR=$PIECE(BPCDTA,U,11)
SET BPCICD=$PIECE(BPCDTA,U,12)
SET BPCCPT=$PIECE(BPCDTA,U,13)
SET BPCPTYP=$PIECE(BPCDTA,U,14)
SET BPCDRG=$PIECE(BPCDTA,U,21)
SET BPCFDRG=$PIECE(BPCDTA,U,21)
+3 SET BPCPRIOR=$PIECE(BPCDTA,U,32)
+4 SET BPCDTA=$GET(^BMCRTNRF(BPCRIEN,11))
SET BPCECOST=$PIECE(BPCDTA,U,1)
SET BPCICOST=$PIECE(BPCDTA,U,3)
SET BPCLOS=$PIECE(BPCDTA,U,9)
SET BPCNOVS=$PIECE(BPCDTA,U,11)
+5 SET BPCPURP=$GET(^BMCRTNRF(BPCRIEN,12))
SET BPCSNOTE=$GET(^BMCRTNRF(BPCRIEN,13))
+6 SET BPCSFAC=""
IF BPCFAC'=""
SET BPCSFAC=+$GET(^AUTTLOC(BPCFAC,0))
IF BPCSFAC
SET BPCSFAC=$PIECE($GET(^DIC(4,BPCSFAC,0)),U,1)
+7 SET BPCSPROV=""
IF BPCPROV'=""
SET BPCSPROV=$PIECE($GET(^VA(200,BPCPROV,0)),U,1)
+8 SET BPCSPVND=""
IF BPCPVEND'=""
SET BPCSPVND=$PIECE($GET(^AUTTVNDR(BPCPVEND,0)),U,1)
+9 SET BPCSIHS=""
IF BPCTOIHS'=""
SET BPCSIHS=$PIECE($GET(^AUTTLOC(BPCTOIHS,0)),U,1)
IF BPCSIHS'=""
SET BPCSIHS=$PIECE($GET(^DIC(4,BPCSIHS,0)),U,1)
+10 SET BPCSTPRV=""
IF BPCTOPRV'=""
SET BPCSTPRV=$PIECE($GET(^BMCLPRV(BPCTOPRV,0)),U,1)
+11 SET BPCSICD=""
IF BPCICD'=""
SET BPCSICD=$PIECE($GET(^BMCTDXC(BPCICD,0)),U,1)
+12 SET BPCSCPT=""
IF BPCCPT'=""
SET BPCSCPT=$PIECE($GET(^BMCTSVC(BPCCPT,0)),U,1)
+13 SET BPCSDRG=""
IF BPCDRG'=""
SET BPCSDRG=$PIECE($GET(^ICD(BPCDRG,0)),U,1)
+14 SET BPCSFDRG=""
IF BPCFDRG'=""
SET BPCSFDRG=$PIECE($GET(^ICD(BPCFDRG,0)),U,1)
+15 SET BPCTMP("DATA",0)="DATA"_BPCS1_BPCRTYP_BPCS1_BPCFAC_BPCS1_BPCSFAC_BPCS1_BPCPROV_BPCS1_BPCSPROV_BPCS1_BPCPVEND_BPCS1_BPCSPVND_BPCS1_BPCTOIHS_BPCS1_BPCSIHS
+16 SET BPCTMP("DATA",0)=BPCTMP("DATA",0)_BPCS1_BPCTOPRV_BPCS1_BPCSTPRV_BPCS1_BPCPAYOR_BPCS1_BPCICD_BPCS1_BPCSICD_BPCS1_BPCCPT_BPCS1_BPCSCPT_BPCS1_BPCPTYP
+17 SET BPCTMP("DATA",0)=BPCTMP("DATA",0)_BPCS1_BPCDRG_BPCS1_BPCSDRG
+18 SET BPCTMP("DATA",0)=BPCTMP("DATA",0)_BPCS1_BPCFDRG_BPCS1_BPCSFDRG_BPCS1_BPCPRIOR_BPCS1_BPCECOST_BPCS1_BPCICOST_BPCS1_BPCLOS_BPCS1_BPCNOVS_BPCS1_BPCPURP_BPCS1_BPCSNOTE
+19 DO GETSC
DO GETHX
DO GETDX
DO GETPX
DO SETRESLT
+20 QUIT
GETSC ;
+1 SET BPCX=0
SET BPCSVCC=0
FOR
SET BPCX=$ORDER(^BMCRTNRF(BPCRIEN,21,BPCX))
IF BPCX=""
QUIT
DO GETSC1
+2 IF BPCSVCC
SET BPCCTR=BPCCTR+1
SET BPCTMP("SVCC",BPCCTR)="SVCC"_BPCS1_BPCSVCC
+3 QUIT
GETSC1 ;
+1 IF BPCX'?1.N
QUIT
+2 SET BPCSVCC=BPCSVCC+1
SET BPCSC=$GET(^BMCRTNRF(BPCRIEN,21,BPCX,0))
+3 SET BPCSSC=""
IF BPCSC'=""
SET BPCSSC=$PIECE($GET(^BMCLCAT(BPCSC,0)),U,1)
+4 IF BPCSC'=""
SET BPCCTR=BPCCTR+1
SET BPCTMP("SVCD",BPCCTR)="SVCD"_BPCS1_BPCSC_BPCS1_BPCSSC
+5 QUIT
GETHX ;
+1 SET BPCX=0
SET BPCHXC=0
FOR
SET BPCX=$ORDER(^BMCRTNRF(BPCRIEN,1,BPCX))
IF BPCX=""
QUIT
DO GETHX1
+2 IF BPCHXC
SET BPCCTR=BPCCTR+1
SET BPCTMP("HXC",BPCCTR)="HXC"_BPCS1_BPCHXC
+3 QUIT
GETHX1 ;
+1 IF BPCX'?1.N
QUIT
+2 SET BPCHXC=BPCHXC+1
+3 SET BPCHX=$GET(^BMCRTNRF(BPCRIEN,1,BPCX,0))
+4 IF BPCHX'=""
SET BPCCTR=BPCCTR+1
SET BPCTMP("HXS",BPCCTR)="HXS"_BPCS1_BPCHX
+5 QUIT
GETDX ;
+1 SET BPCX=""
SET BPCDXC=0
FOR
SET BPCX=$ORDER(^BMCRTNRF(BPCRIEN,61,"B",BPCX))
IF BPCX=""
QUIT
DO GETDX1
+2 IF BPCDXC
SET BPCCTR=BPCCTR+1
SET BPCTMP("DXC",BPCCTR)="DXC"_BPCS1_BPCDXC
+3 QUIT
GETDX1 ;
+1 SET BPCDXC=BPCDXC+1
SET BPCDTA=$GET(^ICD9(BPCX,0))
SET BPCCDE=$PIECE(BPCDTA,U,1)
SET BPCSDX=$PIECE(BPCDTA,U,3)
SET BPCSNAR=""
+2 SET BPCCTR=BPCCTR+1
SET BPCTMP("DXS",BPCCTR)="DXS"_BPCS1_BPCX_BPCS1_BPCCDE_BPCS1_BPCSDX_BPCS1_BPCS1_BPCS1
+3 QUIT
GETPX ;
+1 SET BPCX=""
SET BPCPXC=0
FOR
SET BPCX=$ORDER(^BMCRTNRF(BPCRIEN,62,"B",BPCX))
IF BPCX=""
QUIT
DO GETPX1
+2 IF BPCPXC
SET BPCCTR=BPCCTR+1
SET BPCTMP("PXC",BPCCTR)="PXC"_BPCS1_BPCPXC
+3 QUIT
GETPX1 ;
+1 SET BPCPXC=BPCPXC+1
SET BPCDTA=$GET(^ICPT(BPCX,0))
SET BPCCDE=$PIECE(BPCDTA,U,1)
SET BPCSPX=$PIECE(BPCDTA,U,2)
+2 SET BPCCTR=BPCCTR+1
SET BPCTMP("PXS",BPCCTR)="PXS"_BPCS1_BPCX_BPCS1_BPCCDE_BPCS1_BPCSPX_BPCS1_BPCS1_BPCS1
+3 QUIT
SETRESLT ;
+1 SET BPCCTR=0
SET BPCSB1=""
FOR
SET BPCSB1=$ORDER(BPCTMP(BPCSB1))
IF BPCSB1=""
QUIT
SET BPCSB2=""
FOR
SET BPCSB2=$ORDER(BPCTMP(BPCSB1,BPCSB2))
IF BPCSB2=""
QUIT
SET BPCCTR=BPCCTR+1
SET BPCRES(BPCCTR)=BPCTMP(BPCSB1,BPCSB2)
+2 SET BPCRES(0)=BPCCTR
KILL BPCTMP
+3 QUIT
+4 ;
KILL ;
+1 KILL BPCRIEN,BPCPARAM,BPCS1,BPCTMP,BPCDTA,BPCRTYP,BPCFAC,BPCPROV,BPCPVEND,BPCTOIHS,BPCTOPRV,BPCPAYOR,BPCICD,BPCCPT,BPCPTYP,BPCDRG,BPCFDRG,BPCPRIOR,BPCECOST,BPCICOST,BPCLOS,BPCNOVS,BPCPURP,BPCSNOTE,BPCSFAC,BPCSPROV,BPCSPVND,BPCSIHS,BPCSTPRV
+2 KILL BPCSICD,BPCSCPT,BPCSDRG,BPCSFDRG,BPCSVCC,BPCX,BPCSC,BPCSSC,BPCHXC,BPCHX,BPCDXC,BPCCDE,BPCSDX,BPCSNAR,BPCPXC,BPCDTA,BPCSPX,BPCSB1,BPCSB2,BPCGUI,BPCMAX,BPCMORE,BPCPARAM,BPCN,BPCFLAG,BPCIEN,BPCCTR
+3 QUIT
TEMPLIST(BPCRES,BPCX,BPCMAX,BPCMORE,BPCPARAM) ;EP CALL FROM REMOTE PROC: BPC GETTEMPLATELIST
+1 ;
+2 SET BPCGUI=1
EN ;
+1 SET U="^"
SET XWBWRAP=1
SET BPCCTR=0
SET BPCSUB=$JOB
SET BPCC=""
SET BPCMORE=$GET(BPCMORE)
SET BPCGUI=$GET(BPCGUI)
SET BPCMAX=$GET(BPCMAX)
SET BPCX=$GET(BPCX)
SET BPCPARAM=$GET(BPCPARAM)
SET BPCLEN=$LENGTH(BPCX)
+2 SET BPCRES="^BPCRES("_BPCSUB_")"
SET BPCN=""
+3 ;
IF 'BPCMAX
SET BPCMAX=$SELECT(BPCGUI:50,1:1E10)
+4 KILL ^BPCRES(BPCSUB)
+5 IF BPCX'=""
SET BPCN=$ORDER(^BMCRTNRF("B",BPCX),-1)
+6 IF BPCMORE'=""
DO MORE
DO KILL
QUIT
+7 DO GETTMP1
DO KILL
+8 QUIT
GETTMP1 ;
+1 SET BPCFLAG=0
FOR
SET BPCN=$ORDER(^BMCRTNRF("B",BPCN))
IF BPCN=""
QUIT
DO GETTMP2
IF BPCFLAG
QUIT
+2 SET ^BPCRES(BPCSUB,0)=BPCCTR
+3 QUIT
GETTMP2 ;
+1 IF BPCX'=""
IF $EXTRACT(BPCN,1,BPCLEN)'=BPCX
SET BPCFLAG=1
QUIT
+2 SET BPCIEN=""
FOR
SET BPCIEN=$ORDER(^BMCRTNRF("B",BPCN,BPCIEN))
IF BPCIEN=""
QUIT
DO SETRES
IF BPCFLAG
QUIT
+3 QUIT
SETRES ;
+1 IF BPCCTR=BPCMAX
DO SETMORE
SET BPCFLAG=1
QUIT
+2 SET BPCCTR=BPCCTR+1
SET ^BPCRES(BPCSUB,BPCCTR)=BPCN_U_BPCIEN
+3 QUIT
SETMORE ;
+1 SET BPCCTR=BPCCTR+1
SET ^BPCRES(BPCSUB,BPCCTR)="..MORE"_U_BPCN_"|"_BPCIEN
+2 QUIT
MORE ;
+1 SET BPCFLAG=0
SET BPCN=$PIECE(BPCMORE,"|",1)
SET BPCIEN=$PIECE(BPCMORE,"|",2)
DO SETRES
IF BPCFLAG
QUIT
+2 FOR
SET BPCIEN=$ORDER(^BMCRTNRF("B",BPCN,BPCIEN))
IF BPCIEN=""
QUIT
DO SETRES
IF BPCFLAG
QUIT
+3 IF BPCFLAG
QUIT
+4 DO GETTMP1
+5 QUIT
