- 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
