BPCRC5 ; IHS/OIT/MJL - FHL-12/11/96 - REFERRED CARE GUI ROUTINES ;
;;1.5;BPC;;MAY 26, 2005
GETREF(BPCRES,BPCRIEN,BPCPARAM) ;;EP CALL FROM REMOTE PROC: BPC GETREFERRALDATA
;
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)="REFERRAL IEN NOT SENT!" D KILL Q
S BPCDTA=$G(^BMCREF(BPCRIEN,0)) I BPCDTA="" S BPCRES(1)=-1,BPCRES(2)="NO DATA AVAILABLE FOR REFERRAL IEN: "_BPCRIEN D KILL Q
D GETREF1,KILL
Q
GETREF1 ;
S BPCIDAT=$P(BPCDTA,U,1),BPCREF=$P(BPCDTA,U,2),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),BPCSTAT=$P(BPCDTA,U,15),BPCDRG=$P(BPCDTA,U,21),BPCCLIN=$P(BPCDTA,U,23)
S BPCUSR=$P(BPCDTA,U,25),BPCCDAT=$P(BPCDTA,U,26),BPCMDAT=$P(BPCDTA,U,27),BPCPRIOR=$P(BPCDTA,U,32),BPCSNDA=$P(BPCDTA,U,34)
S BPCDTA=$G(^BMCREF(BPCRIEN,11)),BPCEBDAT=$P(BPCDTA,U,5),BPCEEDAT=$P(BPCDTA,U,7),BPCABDAT=$P(BPCDTA,U,6),BPCAEDAT=$P(BPCDTA,U,8),BPCELOS=$P(BPCDTA,U,9),BPCALOS=$P(BPCDTA,U,10),BPCNOVIS=$P(BPCDTA,U,11)
S BPCPURP=$G(^BMCREF(BPCRIEN,12)),BPCDTA=$G(^BMCREF(BPCRIEN,13)),BPCSNOTE=$P(BPCDTA,U,1),BPCWDAYS=$P(BPCDTA,U,2)
S BPCSFAC="" I BPCFAC'="" S BPCSFAC=$P($G(^AUTTLOC(BPCFAC,0)),U,1) S:BPCSFAC'="" BPCSFAC=$G(^DIC(4,BPCSFAC,0))
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 BPCSCLIN="" I BPCCLIN'="" S BPCSCLIN=$P($G(^DIC(40.7,BPCCLIN,0)),U,1)
S BPCSUSR="" I BPCUSR'="" S BPCSUSR=$P($G(^VA(200,BPCUSR,0)),U,1)
S BPCTMP("DATA",0)="DATA"_BPCS1_BPCIDAT_BPCS1_BPCPROV_BPCS1_BPCSPROV_BPCS1_BPCRTYP_BPCS1_BPCFAC_BPCS1_BPCSFAC
S BPCTMP("DATA",0)=BPCTMP("DATA",0)_BPCS1_BPCPVEND_BPCS1_BPCSPVND_BPCS1_BPCTOIHS_BPCS1_BPCSIHS_BPCS1_BPCTOPRV_BPCS1_BPCSTPRV_BPCS1_BPCPAYOR_BPCS1_BPCICD_BPCS1_BPCSICD_BPCS1_BPCCPT_BPCS1_BPCSCPT
S BPCTMP("DATA",0)=BPCTMP("DATA",0)_BPCS1_BPCPTYP_BPCS1_BPCCLIN_BPCS1_BPCSCLIN_BPCS1_BPCUSR_BPCS1_BPCSUSR_BPCS1_BPCCDAT
S BPCTMP("DATA",0)=BPCTMP("DATA",0)_BPCS1_BPCPRIOR_BPCS1_BPCSNDA_BPCS1_BPCEBDAT_BPCS1_BPCEEDAT_BPCS1_BPCABDAT_BPCS1_BPCAEDAT_BPCS1_BPCELOS_BPCS1_BPCALOS
S BPCTMP("DATA",0)=BPCTMP("DATA",0)_BPCS1_BPCNOVIS_BPCS1_BPCPURP_BPCS1_BPCSNOTE_BPCS1_BPCWDAYS_BPCS1_BPCDRG_BPCS1_BPCSDRG_BPCS1_BPCREF_BPCS1_BPCSTAT_BPCS1_BPCMDAT
D GETSC,GETHX,GETDX,GETPX,SETRES
Q
GETSC ;
S BPCX=0,BPCSVCC=0 F S BPCX=$O(^BMCREF(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(^BMCREF(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(^BMCREF(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(^BMCREF(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(^BMCDX("AD",BPCRIEN,BPCX)) Q:BPCX="" D GETDX1
S:BPCDXC BPCCTR=BPCCTR+1,BPCTMP("DXC",BPCCTR)="DXC"_BPCS1_BPCDXC
Q
GETDX1 ;
S BPCDTA=$G(^BMCDX(BPCX,0)) Q:BPCDTA=""
S BPCDX=$P(BPCDTA,U,1),BPCNARR=$P(BPCDTA,U,6),BPCTY=$P(BPCDTA,U,4),BPCPRIM=$P(BPCDTA,U,5)
S BPCDXC=BPCDXC+1,BPCDTA=$G(^ICD9(BPCDX,0)),BPCCDE=$P(BPCDTA,U,1),BPCSDX=$P(BPCDTA,U,3),BPCSNAR=""
S:BPCNARR'="" BPCSNAR=$P($G(^AUTNPOV(BPCNARR,0)),U,1)
S BPCCTR=BPCCTR+1,BPCTMP("DXS",BPCCTR)="DXS"_BPCS1_BPCDX_BPCS1_BPCCDE_BPCS1_BPCSDX_BPCS1_BPCSNAR_BPCS1_BPCTY_BPCS1_BPCPRIM
Q
GETPX ;
S BPCX="",BPCPXC=0 F S BPCX=$O(^BMCPX("AD",BPCRIEN,BPCX)) Q:BPCX="" D GETPX1
S:BPCPXC BPCCTR=BPCCTR+1,BPCTMP("PXC",BPCCTR)="PXC"_BPCS1_BPCPXC
Q
GETPX1 ;
S BPCDTA=$G(^BMCPX(BPCX,0)) Q:BPCDTA=""
S BPCPX=$P(BPCDTA,U,1),BPCNARR=$P(BPCDTA,U,6),BPCTY=$P(BPCDTA,U,4),BPCPRIM=$P(BPCDTA,U,5)
S BPCPXC=BPCPXC+1,BPCDTA=$G(^ICPT(BPCPX,0)),BPCCDE=$P(BPCDTA,U,1),BPCSPX=$P(BPCDTA,U,2),BPCSNAR=""
S:BPCNARR'="" BPCSNAR=$P($G(^AUTNPOV(BPCNARR,0)),U,1)
S BPCCTR=BPCCTR+1,BPCTMP("PXS",BPCCTR)="PXS"_BPCS1_BPCPX_BPCS1_BPCCDE_BPCS1_BPCSPX_BPCS1_BPCSNAR_BPCS1_BPCTY_BPCS1_BPCPRIM
Q
SETRES ;
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
;
DRGLIST(BPCRES,BPCX,BPCMAX,BPCMORE,BPCPARAM) ;;EP CALL FROM REMOTE PROC: BPC GETDRGLIST
;
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 BPCSAV=BPCX
I BPCMORE'="" D MORE,KILL Q
I BPCX'="" I $D(^ICD("B",BPCX)) D GETDRG1,KILL Q
S:BPCX'="" BPCN=$O(^ICD("B",BPCX),-1) D GETDRG2,KILL
Q
KILL ;
K BPCDXIEN,BPCNARR,BPCNIEN,BPCERR,BPCFDA,BPCEMSG,BPCFDR,BPCPIEN,BPCPXIEN,BPCS3
K BPCRIEN,BPCPARAM,BPCS1,BPCTMP,BPCDTA,BPCIDAT,BPCREF,BPCRTYP,BPCFAC,BPCPROV,BPCPVEND,BPCTOIHS,BPCTOPRV,BPCPAYOR,BPCICD,BPCCPT,BPCPTYP,BPCSTAT,BPCDRG,BPCCLIN,BPCUSR,BPCCDAT,BPCMDAT
K BPCPRIOR,BPCSNDA,BPCEBDAT,BPCEEDAT,BPCABDAT,BPCAEDAT,BPCELOS,BPCALOS,BPCNOVIS,BPCPURP,BPCSNOTE,BPCWDAYS,BPCSFAC,BPCSPROV,BPCSPVND,BPCSIHS,BPCSTPRV,BPCSICD,BPCSCPT,BPCSDRG
K BPCSCLIN,BPCSUSR,BPCSVCC,BPCSC,BPCSSC,BPCHXC,BPCHX,BPCDXC,BPCDX,BPCTY,BPCNARR,BPCPRIM,BPCSNAR,BPCSDX,BPCCDE,BPCPXC,BPCPX,BPCSPX,BPCSB1,BPCSB2,BPCGUI,BPCX,BPCMAX
K BPCMORE,BPCLEN,BPCN,BPCSAV,BPCIEN,BPCSUB,BPCFLAG,BPCQ,BPCDXS,BPCS2
Q
GETDRG1 ;
S BPCIEN=$O(^ICD("B",BPCX,"")),^BPCRES(BPCSUB,0)=0
I BPCIEN S BPCCDE=$P(^ICD(BPCIEN,0),U,1),^BPCRES(BPCSUB,0)=1,^BPCRES(BPCSUB,1)=BPCCDE_U_BPCIEN
Q
GETDRG2 ;
S BPCFLAG=0
F S BPCN=$O(^ICD("B",BPCN)) Q:BPCN="" S BPCIEN="" D GETDRG3 Q:BPCFLAG
S ^BPCRES(BPCSUB,0)=BPCCTR
Q
GETDRG3 ;
I BPCX'="",$E(BPCN,1,BPCLEN)'=BPCX S BPCFLAG=1 Q
F S BPCIEN=$O(^ICD("B",BPCN,BPCIEN)) Q:BPCIEN="" D SETDRG Q:BPCFLAG
Q
SETDRG ;
I BPCCTR=BPCMAX D SETMORE S BPCFLAG=1 Q
S BPCCTR=BPCCTR+1,^BPCRES(BPCSUB,BPCCTR)=$P(^ICD(BPCIEN,0),U,1)_U_BPCIEN
Q
SETMORE ;
S BPCCTR=BPCCTR+1,^BPCRES(BPCSUB,BPCCTR)="..MORE"_U_BPCIEN_"|"_$P(^ICD(BPCIEN,0),U,1)_"|B"_"|"_BPCN
Q
MORE ;
S BPCFLAG=0,BPCIEN=$P(BPCMORE,"|",1),BPCN=$P(BPCMORE,"|",4) D SETDRG
D:'BPCFLAG GETDRG3 D:'BPCFLAG GETDRG2
S ^BPCRES(BPCSUB,0)=BPCCTR
Q
SETDXS ;EP CALLED WHEN ADDING REFERRALS FROM BPCRC3
F BPCQ=1:1:$L(BPCDXS,BPCS2) S BPCDTA=$P(BPCDXS,BPCS2,BPCQ) D SETDXS1
Q
SETDXS1 ;
S BPCDXIEN=$P(BPCDTA,BPCS3,1),BPCNARR=$P(BPCDTA,BPCS3,2),BPCNIEN=""
D:BPCNARR'="" SETNAR
Q:BPCERR
L +^BMCDX(0):10 I '$T S BPCERR=1 Q
K BPCFDA,BPCEMSG S BPCFDR="BPCFDA(1)"
S BPCFDA(1,90001.01,"+1,",.01)=BPCDXIEN
S BPCFDA(1,90001.01,"+1,",.02)=BPCPIEN
S BPCFDA(1,90001.01,"+1,",.03)=BPCRIEN
S BPCFDA(1,90001.01,"+1,",.04)="P"
S:BPCNIEN'="" BPCFDA(1,90001.01,"+1,",.06)=BPCNIEN
K BPCIEN D UPDATE^DIE("",BPCFDR,"BPCIEN","BPCEMSG")
I $D(BPCEMSG("DIERR")) S BPCERR=1
L -^BMCDX(0)
Q
SETPRCS ;EP CALLED WHEN ADDING REFERRALS FROM BPCRC3
F BPCQ=1:1:$L(BPCPRCS,BPCS2) S BPCDTA=$P(BPCPRCS,BPCS2,BPCQ) D SETPRC1
Q
SETPRC1 ;
S BPCPXIEN=$P(BPCDTA,BPCS3,1),BPCNARR=$P(BPCDTA,BPCS3,2),BPCNIEN=""
D:BPCNARR'="" SETNAR
Q:BPCERR
L +^BMCPX(0):10 I '$T S BPCERR=1 Q
K BPCFDA,BPCEMSG S BPCFDR="BPCFDA(1)"
S BPCFDA(1,90001.02,"+1,",.01)=BPCPXIEN
S BPCFDA(1,90001.02,"+1,",.02)=BPCPIEN
S BPCFDA(1,90001.02,"+1,",.03)=BPCRIEN
S BPCFDA(1,90001.02,"+1,",.04)="P"
S:BPCNIEN'="" BPCFDA(1,90001.02,"+1,",.06)=BPCNIEN
K BPCIEN D UPDATE^DIE("",BPCFDR,"BPCIEN","BPCEMSG")
I $D(BPCEMSG("DIERR")) S BPCERR=1
L -^BMCPX(0)
Q
SETNAR ;
I $D(^AUTNPOV("B",$E(BPCNARR,1,30))) S BPCNIEN=$O(^AUTNPOV("B",$E(BPCNARR,1,30),"")) Q
L +^AUTNPOV(0):10 I '$T S BPCERR=1 Q
K BPCFDA,BPCEMSG S BPCFDR="BPCFDA(1)"
S BPCFDA(1,9999999.27,"+1,",.01)=BPCNARR
K BPCIEN D UPDATE^DIE("",BPCFDR,"BPCIEN","BPCEMSG")
I $D(BPCEMSG("DIERR")) S BPCERR=1
L -^AUTNPOV(0)
I 'BPCERR S BPCNIEN=BPCIEN(1)
Q
BPCRC5 ; IHS/OIT/MJL - FHL-12/11/96 - REFERRED CARE GUI ROUTINES ;
+1 ;;1.5;BPC;;MAY 26, 2005
GETREF(BPCRES,BPCRIEN,BPCPARAM) ;;EP CALL FROM REMOTE PROC: BPC GETREFERRALDATA
+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)="REFERRAL IEN NOT SENT!"
DO KILL
QUIT
+5 SET BPCDTA=$GET(^BMCREF(BPCRIEN,0))
IF BPCDTA=""
SET BPCRES(1)=-1
SET BPCRES(2)="NO DATA AVAILABLE FOR REFERRAL IEN: "_BPCRIEN
DO KILL
QUIT
+6 DO GETREF1
DO KILL
+7 QUIT
GETREF1 ;
+1 SET BPCIDAT=$PIECE(BPCDTA,U,1)
SET BPCREF=$PIECE(BPCDTA,U,2)
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 BPCSTAT=$PIECE(BPCDTA,U,15)
SET BPCDRG=$PIECE(BPCDTA,U,21)
SET BPCCLIN=$PIECE(BPCDTA,U,23)
+3 SET BPCUSR=$PIECE(BPCDTA,U,25)
SET BPCCDAT=$PIECE(BPCDTA,U,26)
SET BPCMDAT=$PIECE(BPCDTA,U,27)
SET BPCPRIOR=$PIECE(BPCDTA,U,32)
SET BPCSNDA=$PIECE(BPCDTA,U,34)
+4 SET BPCDTA=$GET(^BMCREF(BPCRIEN,11))
SET BPCEBDAT=$PIECE(BPCDTA,U,5)
SET BPCEEDAT=$PIECE(BPCDTA,U,7)
SET BPCABDAT=$PIECE(BPCDTA,U,6)
SET BPCAEDAT=$PIECE(BPCDTA,U,8)
SET BPCELOS=$PIECE(BPCDTA,U,9)
SET BPCALOS=$PIECE(BPCDTA,U,10)
SET BPCNOVIS=$PIECE(BPCDTA,U,11)
+5 SET BPCPURP=$GET(^BMCREF(BPCRIEN,12))
SET BPCDTA=$GET(^BMCREF(BPCRIEN,13))
SET BPCSNOTE=$PIECE(BPCDTA,U,1)
SET BPCWDAYS=$PIECE(BPCDTA,U,2)
+6 SET BPCSFAC=""
IF BPCFAC'=""
SET BPCSFAC=$PIECE($GET(^AUTTLOC(BPCFAC,0)),U,1)
IF BPCSFAC'=""
SET BPCSFAC=$GET(^DIC(4,BPCSFAC,0))
+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 BPCSCLIN=""
IF BPCCLIN'=""
SET BPCSCLIN=$PIECE($GET(^DIC(40.7,BPCCLIN,0)),U,1)
+15 SET BPCSUSR=""
IF BPCUSR'=""
SET BPCSUSR=$PIECE($GET(^VA(200,BPCUSR,0)),U,1)
+16 SET BPCTMP("DATA",0)="DATA"_BPCS1_BPCIDAT_BPCS1_BPCPROV_BPCS1_BPCSPROV_BPCS1_BPCRTYP_BPCS1_BPCFAC_BPCS1_BPCSFAC
+17 SET BPCTMP("DATA",0)=BPCTMP("DATA",0)_BPCS1_BPCPVEND_BPCS1_BPCSPVND_BPCS1_BPCTOIHS_BPCS1_BPCSIHS_BPCS1_BPCTOPRV_BPCS1_BPCSTPRV_BPCS1_BPCPAYOR_BPCS1_BPCICD_BPCS1_BPCSICD_BPCS1_BPCCPT_BPCS1_BPCSCPT
+18 SET BPCTMP("DATA",0)=BPCTMP("DATA",0)_BPCS1_BPCPTYP_BPCS1_BPCCLIN_BPCS1_BPCSCLIN_BPCS1_BPCUSR_BPCS1_BPCSUSR_BPCS1_BPCCDAT
+19 SET BPCTMP("DATA",0)=BPCTMP("DATA",0)_BPCS1_BPCPRIOR_BPCS1_BPCSNDA_BPCS1_BPCEBDAT_BPCS1_BPCEEDAT_BPCS1_BPCABDAT_BPCS1_BPCAEDAT_BPCS1_BPCELOS_BPCS1_BPCALOS
+20 SET BPCTMP("DATA",0)=BPCTMP("DATA",0)_BPCS1_BPCNOVIS_BPCS1_BPCPURP_BPCS1_BPCSNOTE_BPCS1_BPCWDAYS_BPCS1_BPCDRG_BPCS1_BPCSDRG_BPCS1_BPCREF_BPCS1_BPCSTAT_BPCS1_BPCMDAT
+21 DO GETSC
DO GETHX
DO GETDX
DO GETPX
DO SETRES
+22 QUIT
GETSC ;
+1 SET BPCX=0
SET BPCSVCC=0
FOR
SET BPCX=$ORDER(^BMCREF(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(^BMCREF(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(^BMCREF(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(^BMCREF(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(^BMCDX("AD",BPCRIEN,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 BPCDTA=$GET(^BMCDX(BPCX,0))
IF BPCDTA=""
QUIT
+2 SET BPCDX=$PIECE(BPCDTA,U,1)
SET BPCNARR=$PIECE(BPCDTA,U,6)
SET BPCTY=$PIECE(BPCDTA,U,4)
SET BPCPRIM=$PIECE(BPCDTA,U,5)
+3 SET BPCDXC=BPCDXC+1
SET BPCDTA=$GET(^ICD9(BPCDX,0))
SET BPCCDE=$PIECE(BPCDTA,U,1)
SET BPCSDX=$PIECE(BPCDTA,U,3)
SET BPCSNAR=""
+4 IF BPCNARR'=""
SET BPCSNAR=$PIECE($GET(^AUTNPOV(BPCNARR,0)),U,1)
+5 SET BPCCTR=BPCCTR+1
SET BPCTMP("DXS",BPCCTR)="DXS"_BPCS1_BPCDX_BPCS1_BPCCDE_BPCS1_BPCSDX_BPCS1_BPCSNAR_BPCS1_BPCTY_BPCS1_BPCPRIM
+6 QUIT
GETPX ;
+1 SET BPCX=""
SET BPCPXC=0
FOR
SET BPCX=$ORDER(^BMCPX("AD",BPCRIEN,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 BPCDTA=$GET(^BMCPX(BPCX,0))
IF BPCDTA=""
QUIT
+2 SET BPCPX=$PIECE(BPCDTA,U,1)
SET BPCNARR=$PIECE(BPCDTA,U,6)
SET BPCTY=$PIECE(BPCDTA,U,4)
SET BPCPRIM=$PIECE(BPCDTA,U,5)
+3 SET BPCPXC=BPCPXC+1
SET BPCDTA=$GET(^ICPT(BPCPX,0))
SET BPCCDE=$PIECE(BPCDTA,U,1)
SET BPCSPX=$PIECE(BPCDTA,U,2)
SET BPCSNAR=""
+4 IF BPCNARR'=""
SET BPCSNAR=$PIECE($GET(^AUTNPOV(BPCNARR,0)),U,1)
+5 SET BPCCTR=BPCCTR+1
SET BPCTMP("PXS",BPCCTR)="PXS"_BPCS1_BPCPX_BPCS1_BPCCDE_BPCS1_BPCSPX_BPCS1_BPCSNAR_BPCS1_BPCTY_BPCS1_BPCPRIM
+6 QUIT
SETRES ;
+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 ;
DRGLIST(BPCRES,BPCX,BPCMAX,BPCMORE,BPCPARAM) ;;EP CALL FROM REMOTE PROC: BPC GETDRGLIST
+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 SET BPCSAV=BPCX
+6 IF BPCMORE'=""
DO MORE
DO KILL
QUIT
+7 IF BPCX'=""
IF $DATA(^ICD("B",BPCX))
DO GETDRG1
DO KILL
QUIT
+8 IF BPCX'=""
SET BPCN=$ORDER(^ICD("B",BPCX),-1)
DO GETDRG2
DO KILL
+9 QUIT
KILL ;
+1 KILL BPCDXIEN,BPCNARR,BPCNIEN,BPCERR,BPCFDA,BPCEMSG,BPCFDR,BPCPIEN,BPCPXIEN,BPCS3
+2 KILL BPCRIEN,BPCPARAM,BPCS1,BPCTMP,BPCDTA,BPCIDAT,BPCREF,BPCRTYP,BPCFAC,BPCPROV,BPCPVEND,BPCTOIHS,BPCTOPRV,BPCPAYOR,BPCICD,BPCCPT,BPCPTYP,BPCSTAT,BPCDRG,BPCCLIN,BPCUSR,BPCCDAT,BPCMDAT
+3 KILL BPCPRIOR,BPCSNDA,BPCEBDAT,BPCEEDAT,BPCABDAT,BPCAEDAT,BPCELOS,BPCALOS,BPCNOVIS,BPCPURP,BPCSNOTE,BPCWDAYS,BPCSFAC,BPCSPROV,BPCSPVND,BPCSIHS,BPCSTPRV,BPCSICD,BPCSCPT,BPCSDRG
+4 KILL BPCSCLIN,BPCSUSR,BPCSVCC,BPCSC,BPCSSC,BPCHXC,BPCHX,BPCDXC,BPCDX,BPCTY,BPCNARR,BPCPRIM,BPCSNAR,BPCSDX,BPCCDE,BPCPXC,BPCPX,BPCSPX,BPCSB1,BPCSB2,BPCGUI,BPCX,BPCMAX
+5 KILL BPCMORE,BPCLEN,BPCN,BPCSAV,BPCIEN,BPCSUB,BPCFLAG,BPCQ,BPCDXS,BPCS2
+6 QUIT
GETDRG1 ;
+1 SET BPCIEN=$ORDER(^ICD("B",BPCX,""))
SET ^BPCRES(BPCSUB,0)=0
+2 IF BPCIEN
SET BPCCDE=$PIECE(^ICD(BPCIEN,0),U,1)
SET ^BPCRES(BPCSUB,0)=1
SET ^BPCRES(BPCSUB,1)=BPCCDE_U_BPCIEN
+3 QUIT
GETDRG2 ;
+1 SET BPCFLAG=0
+2 FOR
SET BPCN=$ORDER(^ICD("B",BPCN))
IF BPCN=""
QUIT
SET BPCIEN=""
DO GETDRG3
IF BPCFLAG
QUIT
+3 SET ^BPCRES(BPCSUB,0)=BPCCTR
+4 QUIT
GETDRG3 ;
+1 IF BPCX'=""
IF $EXTRACT(BPCN,1,BPCLEN)'=BPCX
SET BPCFLAG=1
QUIT
+2 FOR
SET BPCIEN=$ORDER(^ICD("B",BPCN,BPCIEN))
IF BPCIEN=""
QUIT
DO SETDRG
IF BPCFLAG
QUIT
+3 QUIT
SETDRG ;
+1 IF BPCCTR=BPCMAX
DO SETMORE
SET BPCFLAG=1
QUIT
+2 SET BPCCTR=BPCCTR+1
SET ^BPCRES(BPCSUB,BPCCTR)=$PIECE(^ICD(BPCIEN,0),U,1)_U_BPCIEN
+3 QUIT
SETMORE ;
+1 SET BPCCTR=BPCCTR+1
SET ^BPCRES(BPCSUB,BPCCTR)="..MORE"_U_BPCIEN_"|"_$PIECE(^ICD(BPCIEN,0),U,1)_"|B"_"|"_BPCN
+2 QUIT
MORE ;
+1 SET BPCFLAG=0
SET BPCIEN=$PIECE(BPCMORE,"|",1)
SET BPCN=$PIECE(BPCMORE,"|",4)
DO SETDRG
+2 IF 'BPCFLAG
DO GETDRG3
IF 'BPCFLAG
DO GETDRG2
+3 SET ^BPCRES(BPCSUB,0)=BPCCTR
+4 QUIT
SETDXS ;EP CALLED WHEN ADDING REFERRALS FROM BPCRC3
+1 FOR BPCQ=1:1:$LENGTH(BPCDXS,BPCS2)
SET BPCDTA=$PIECE(BPCDXS,BPCS2,BPCQ)
DO SETDXS1
+2 QUIT
SETDXS1 ;
+1 SET BPCDXIEN=$PIECE(BPCDTA,BPCS3,1)
SET BPCNARR=$PIECE(BPCDTA,BPCS3,2)
SET BPCNIEN=""
+2 IF BPCNARR'=""
DO SETNAR
+3 IF BPCERR
QUIT
+4 LOCK +^BMCDX(0):10
IF '$TEST
SET BPCERR=1
QUIT
+5 KILL BPCFDA,BPCEMSG
SET BPCFDR="BPCFDA(1)"
+6 SET BPCFDA(1,90001.01,"+1,",.01)=BPCDXIEN
+7 SET BPCFDA(1,90001.01,"+1,",.02)=BPCPIEN
+8 SET BPCFDA(1,90001.01,"+1,",.03)=BPCRIEN
+9 SET BPCFDA(1,90001.01,"+1,",.04)="P"
+10 IF BPCNIEN'=""
SET BPCFDA(1,90001.01,"+1,",.06)=BPCNIEN
+11 KILL BPCIEN
DO UPDATE^DIE("",BPCFDR,"BPCIEN","BPCEMSG")
+12 IF $DATA(BPCEMSG("DIERR"))
SET BPCERR=1
+13 LOCK -^BMCDX(0)
+14 QUIT
SETPRCS ;EP CALLED WHEN ADDING REFERRALS FROM BPCRC3
+1 FOR BPCQ=1:1:$LENGTH(BPCPRCS,BPCS2)
SET BPCDTA=$PIECE(BPCPRCS,BPCS2,BPCQ)
DO SETPRC1
+2 QUIT
SETPRC1 ;
+1 SET BPCPXIEN=$PIECE(BPCDTA,BPCS3,1)
SET BPCNARR=$PIECE(BPCDTA,BPCS3,2)
SET BPCNIEN=""
+2 IF BPCNARR'=""
DO SETNAR
+3 IF BPCERR
QUIT
+4 LOCK +^BMCPX(0):10
IF '$TEST
SET BPCERR=1
QUIT
+5 KILL BPCFDA,BPCEMSG
SET BPCFDR="BPCFDA(1)"
+6 SET BPCFDA(1,90001.02,"+1,",.01)=BPCPXIEN
+7 SET BPCFDA(1,90001.02,"+1,",.02)=BPCPIEN
+8 SET BPCFDA(1,90001.02,"+1,",.03)=BPCRIEN
+9 SET BPCFDA(1,90001.02,"+1,",.04)="P"
+10 IF BPCNIEN'=""
SET BPCFDA(1,90001.02,"+1,",.06)=BPCNIEN
+11 KILL BPCIEN
DO UPDATE^DIE("",BPCFDR,"BPCIEN","BPCEMSG")
+12 IF $DATA(BPCEMSG("DIERR"))
SET BPCERR=1
+13 LOCK -^BMCPX(0)
+14 QUIT
SETNAR ;
+1 IF $DATA(^AUTNPOV("B",$EXTRACT(BPCNARR,1,30)))
SET BPCNIEN=$ORDER(^AUTNPOV("B",$EXTRACT(BPCNARR,1,30),""))
QUIT
+2 LOCK +^AUTNPOV(0):10
IF '$TEST
SET BPCERR=1
QUIT
+3 KILL BPCFDA,BPCEMSG
SET BPCFDR="BPCFDA(1)"
+4 SET BPCFDA(1,9999999.27,"+1,",.01)=BPCNARR
+5 KILL BPCIEN
DO UPDATE^DIE("",BPCFDR,"BPCIEN","BPCEMSG")
+6 IF $DATA(BPCEMSG("DIERR"))
SET BPCERR=1
+7 LOCK -^AUTNPOV(0)
+8 IF 'BPCERR
SET BPCNIEN=BPCIEN(1)
+9 QUIT
