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

BPCRC5.m

Go to the documentation of this file. 
  1. BPCRC5 ; IHS/OIT/MJL - FHL-12/11/96 - REFERRED CARE GUI ROUTINES ;
  1.  ;;1.5;BPC;;MAY 26, 2005
  1. GETREF(BPCRES,BPCRIEN,BPCPARAM) ;;EP CALL FROM REMOTE PROC: BPC GETREFERRALDATA
  1.  ;
  1. EN1 ;
  1.  S U="^",XWBWRAP=1,BPCCTR=0,BPCRIEN=$G(BPCRIEN),BPCPARAM=$G(BPCPARAM)
  1.  S BPCS1="`"
  1.  K BPCRES,BPCTMP
  1.  I BPCRIEN="" S BPCRES(1)=-1,BPCRES(2)="REFERRAL IEN NOT SENT!" D KILL Q
  1.  S BPCDTA=$G(^BMCREF(BPCRIEN,0)) I BPCDTA="" S BPCRES(1)=-1,BPCRES(2)="NO DATA AVAILABLE FOR REFERRAL IEN: "_BPCRIEN D KILL Q
  1.  D GETREF1,KILL
  1.  Q
  1. GETREF1 ;
  1.  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)
  1.  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)
  1.  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)
  1.  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)
  1.  S BPCPURP=$G(^BMCREF(BPCRIEN,12)),BPCDTA=$G(^BMCREF(BPCRIEN,13)),BPCSNOTE=$P(BPCDTA,U,1),BPCWDAYS=$P(BPCDTA,U,2)
  1.  S BPCSFAC="" I BPCFAC'="" S BPCSFAC=$P($G(^AUTTLOC(BPCFAC,0)),U,1) S:BPCSFAC'="" BPCSFAC=$G(^DIC(4,BPCSFAC,0))
  1.  S BPCSPROV="" I BPCPROV'="" S BPCSPROV=$P($G(^VA(200,BPCPROV,0)),U,1)
  1.  S BPCSPVND="" I BPCPVEND'="" S BPCSPVND=$P($G(^AUTTVNDR(BPCPVEND,0)),U,1)
  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)
  1.  S BPCSTPRV="" I BPCTOPRV'="" S BPCSTPRV=$P($G(^BMCLPRV(BPCTOPRV,0)),U,1)
  1.  S BPCSICD="" I BPCICD'="" S BPCSICD=$P($G(^BMCTDXC(BPCICD,0)),U,1)
  1.  S BPCSCPT="" I BPCCPT'="" S BPCSCPT=$P($G(^BMCTSVC(BPCCPT,0)),U,1)
  1.  S BPCSDRG="" I BPCDRG'="" S BPCSDRG=$P($G(^ICD(BPCDRG,0)),U,1)
  1.  S BPCSCLIN="" I BPCCLIN'="" S BPCSCLIN=$P($G(^DIC(40.7,BPCCLIN,0)),U,1)
  1.  S BPCSUSR="" I BPCUSR'="" S BPCSUSR=$P($G(^VA(200,BPCUSR,0)),U,1)
  1.  S BPCTMP("DATA",0)="DATA"_BPCS1_BPCIDAT_BPCS1_BPCPROV_BPCS1_BPCSPROV_BPCS1_BPCRTYP_BPCS1_BPCFAC_BPCS1_BPCSFAC
  1.  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
  1.  S BPCTMP("DATA",0)=BPCTMP("DATA",0)_BPCS1_BPCPTYP_BPCS1_BPCCLIN_BPCS1_BPCSCLIN_BPCS1_BPCUSR_BPCS1_BPCSUSR_BPCS1_BPCCDAT
  1.  S BPCTMP("DATA",0)=BPCTMP("DATA",0)_BPCS1_BPCPRIOR_BPCS1_BPCSNDA_BPCS1_BPCEBDAT_BPCS1_BPCEEDAT_BPCS1_BPCABDAT_BPCS1_BPCAEDAT_BPCS1_BPCELOS_BPCS1_BPCALOS
  1.  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
  1.  D GETSC,GETHX,GETDX,GETPX,SETRES
  1.  Q
  1. GETSC ;
  1.  S BPCX=0,BPCSVCC=0 F  S BPCX=$O(^BMCREF(BPCRIEN,21,BPCX)) Q:BPCX=""  D GETSC1
  1.  S:BPCSVCC BPCCTR=BPCCTR+1,BPCTMP("SVCC",BPCCTR)="SVCC"_BPCS1_BPCSVCC
  1.  Q
  1. GETSC1 ;
  1.  Q:BPCX'?1.N
  1.  S BPCSVCC=BPCSVCC+1,BPCSC=$G(^BMCREF(BPCRIEN,21,BPCX,0))
  1.  S BPCSSC="" S:BPCSC'="" BPCSSC=$P($G(^BMCLCAT(BPCSC,0)),U,1)
  1.  S:BPCSC'="" BPCCTR=BPCCTR+1,BPCTMP("SVCD",BPCCTR)="SVCD"_BPCS1_BPCSC_BPCS1_BPCSSC
  1.  Q
  1. GETHX ;
  1.  S BPCX=0,BPCHXC=0 F  S BPCX=$O(^BMCREF(BPCRIEN,1,BPCX)) Q:BPCX=""  D GETHX1
  1.  S:BPCHXC BPCCTR=BPCCTR+1,BPCTMP("HXC",BPCCTR)="HXC"_BPCS1_BPCHXC
  1.  Q
  1. GETHX1 ;
  1.  Q:BPCX'?1.N
  1.  S BPCHXC=BPCHXC+1
  1.  S BPCHX=$G(^BMCREF(BPCRIEN,1,BPCX,0))
  1.  S:BPCHX'="" BPCCTR=BPCCTR+1,BPCTMP("HXS",BPCCTR)="HXS"_BPCS1_BPCHX
  1.  Q
  1. GETDX ;
  1.  S BPCX="",BPCDXC=0 F  S BPCX=$O(^BMCDX("AD",BPCRIEN,BPCX)) Q:BPCX=""  D GETDX1
  1.  S:BPCDXC BPCCTR=BPCCTR+1,BPCTMP("DXC",BPCCTR)="DXC"_BPCS1_BPCDXC
  1.  Q
  1. GETDX1 ;
  1.  S BPCDTA=$G(^BMCDX(BPCX,0)) Q:BPCDTA=""
  1.  S BPCDX=$P(BPCDTA,U,1),BPCNARR=$P(BPCDTA,U,6),BPCTY=$P(BPCDTA,U,4),BPCPRIM=$P(BPCDTA,U,5)
  1.  S BPCDXC=BPCDXC+1,BPCDTA=$G(^ICD9(BPCDX,0)),BPCCDE=$P(BPCDTA,U,1),BPCSDX=$P(BPCDTA,U,3),BPCSNAR=""
  1.  S:BPCNARR'="" BPCSNAR=$P($G(^AUTNPOV(BPCNARR,0)),U,1)
  1.  S BPCCTR=BPCCTR+1,BPCTMP("DXS",BPCCTR)="DXS"_BPCS1_BPCDX_BPCS1_BPCCDE_BPCS1_BPCSDX_BPCS1_BPCSNAR_BPCS1_BPCTY_BPCS1_BPCPRIM
  1.  Q
  1. GETPX ;
  1.  S BPCX="",BPCPXC=0 F  S BPCX=$O(^BMCPX("AD",BPCRIEN,BPCX)) Q:BPCX=""  D GETPX1
  1.  S:BPCPXC BPCCTR=BPCCTR+1,BPCTMP("PXC",BPCCTR)="PXC"_BPCS1_BPCPXC
  1.  Q
  1. GETPX1 ;
  1.  S BPCDTA=$G(^BMCPX(BPCX,0)) Q:BPCDTA=""
  1.  S BPCPX=$P(BPCDTA,U,1),BPCNARR=$P(BPCDTA,U,6),BPCTY=$P(BPCDTA,U,4),BPCPRIM=$P(BPCDTA,U,5)
  1.  S BPCPXC=BPCPXC+1,BPCDTA=$G(^ICPT(BPCPX,0)),BPCCDE=$P(BPCDTA,U,1),BPCSPX=$P(BPCDTA,U,2),BPCSNAR=""
  1.  S:BPCNARR'="" BPCSNAR=$P($G(^AUTNPOV(BPCNARR,0)),U,1)
  1.  S BPCCTR=BPCCTR+1,BPCTMP("PXS",BPCCTR)="PXS"_BPCS1_BPCPX_BPCS1_BPCCDE_BPCS1_BPCSPX_BPCS1_BPCSNAR_BPCS1_BPCTY_BPCS1_BPCPRIM
  1.  Q
  1. SETRES ;
  1.  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)
  1.  S BPCRES(0)=BPCCTR K BPCTMP
  1.  Q
  1.  ;
  1. DRGLIST(BPCRES,BPCX,BPCMAX,BPCMORE,BPCPARAM) ;;EP CALL FROM REMOTE PROC: BPC GETDRGLIST
  1.  ;
  1.  S BPCGUI=1
  1. EN ;
  1.  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)
  1.  S BPCRES="^BPCRES("_BPCSUB_")",BPCN=""
  1.  S:'BPCMAX BPCMAX=$S(BPCGUI:50,1:1E10) ;
  1.  K ^BPCRES(BPCSUB)
  1.  S BPCSAV=BPCX
  1.  I BPCMORE'="" D MORE,KILL Q
  1.  I BPCX'="" I $D(^ICD("B",BPCX)) D GETDRG1,KILL Q
  1.  S:BPCX'="" BPCN=$O(^ICD("B",BPCX),-1) D GETDRG2,KILL
  1.  Q
  1. KILL ;
  1.  K BPCDXIEN,BPCNARR,BPCNIEN,BPCERR,BPCFDA,BPCEMSG,BPCFDR,BPCPIEN,BPCPXIEN,BPCS3
  1.  K BPCRIEN,BPCPARAM,BPCS1,BPCTMP,BPCDTA,BPCIDAT,BPCREF,BPCRTYP,BPCFAC,BPCPROV,BPCPVEND,BPCTOIHS,BPCTOPRV,BPCPAYOR,BPCICD,BPCCPT,BPCPTYP,BPCSTAT,BPCDRG,BPCCLIN,BPCUSR,BPCCDAT,BPCMDAT
  1.  K BPCPRIOR,BPCSNDA,BPCEBDAT,BPCEEDAT,BPCABDAT,BPCAEDAT,BPCELOS,BPCALOS,BPCNOVIS,BPCPURP,BPCSNOTE,BPCWDAYS,BPCSFAC,BPCSPROV,BPCSPVND,BPCSIHS,BPCSTPRV,BPCSICD,BPCSCPT,BPCSDRG
  1.  K BPCSCLIN,BPCSUSR,BPCSVCC,BPCSC,BPCSSC,BPCHXC,BPCHX,BPCDXC,BPCDX,BPCTY,BPCNARR,BPCPRIM,BPCSNAR,BPCSDX,BPCCDE,BPCPXC,BPCPX,BPCSPX,BPCSB1,BPCSB2,BPCGUI,BPCX,BPCMAX
  1.  K BPCMORE,BPCLEN,BPCN,BPCSAV,BPCIEN,BPCSUB,BPCFLAG,BPCQ,BPCDXS,BPCS2
  1.  Q
  1. GETDRG1 ;
  1.  S BPCIEN=$O(^ICD("B",BPCX,"")),^BPCRES(BPCSUB,0)=0
  1.  I BPCIEN S BPCCDE=$P(^ICD(BPCIEN,0),U,1),^BPCRES(BPCSUB,0)=1,^BPCRES(BPCSUB,1)=BPCCDE_U_BPCIEN
  1.  Q
  1. GETDRG2 ;
  1.  S BPCFLAG=0
  1.  F  S BPCN=$O(^ICD("B",BPCN)) Q:BPCN=""  S BPCIEN="" D GETDRG3 Q:BPCFLAG
  1.  S ^BPCRES(BPCSUB,0)=BPCCTR
  1.  Q
  1. GETDRG3 ;
  1.  I BPCX'="",$E(BPCN,1,BPCLEN)'=BPCX S BPCFLAG=1 Q
  1.  F  S BPCIEN=$O(^ICD("B",BPCN,BPCIEN)) Q:BPCIEN=""  D SETDRG Q:BPCFLAG
  1.  Q
  1. SETDRG ;
  1.  I BPCCTR=BPCMAX D SETMORE S BPCFLAG=1 Q
  1.  S BPCCTR=BPCCTR+1,^BPCRES(BPCSUB,BPCCTR)=$P(^ICD(BPCIEN,0),U,1)_U_BPCIEN
  1.  Q
  1. SETMORE ;
  1.  S BPCCTR=BPCCTR+1,^BPCRES(BPCSUB,BPCCTR)="..MORE"_U_BPCIEN_"|"_$P(^ICD(BPCIEN,0),U,1)_"|B"_"|"_BPCN
  1.  Q
  1. MORE ;
  1.  S BPCFLAG=0,BPCIEN=$P(BPCMORE,"|",1),BPCN=$P(BPCMORE,"|",4) D SETDRG
  1.  D:'BPCFLAG GETDRG3 D:'BPCFLAG GETDRG2
  1.  S ^BPCRES(BPCSUB,0)=BPCCTR
  1.  Q
  1. SETDXS ;EP CALLED WHEN ADDING REFERRALS FROM BPCRC3
  1.  F BPCQ=1:1:$L(BPCDXS,BPCS2) S BPCDTA=$P(BPCDXS,BPCS2,BPCQ) D SETDXS1
  1.  Q
  1. SETDXS1 ;
  1.  S BPCDXIEN=$P(BPCDTA,BPCS3,1),BPCNARR=$P(BPCDTA,BPCS3,2),BPCNIEN=""
  1.  D:BPCNARR'="" SETNAR
  1.  Q:BPCERR
  1.  L +^BMCDX(0):10 I '$T S BPCERR=1 Q
  1.  K BPCFDA,BPCEMSG S BPCFDR="BPCFDA(1)"
  1.  S BPCFDA(1,90001.01,"+1,",.01)=BPCDXIEN
  1.  S BPCFDA(1,90001.01,"+1,",.02)=BPCPIEN
  1.  S BPCFDA(1,90001.01,"+1,",.03)=BPCRIEN
  1.  S BPCFDA(1,90001.01,"+1,",.04)="P"
  1.  S:BPCNIEN'="" BPCFDA(1,90001.01,"+1,",.06)=BPCNIEN
  1.  K BPCIEN D UPDATE^DIE("",BPCFDR,"BPCIEN","BPCEMSG")
  1.  I $D(BPCEMSG("DIERR")) S BPCERR=1
  1.  L -^BMCDX(0)
  1.  Q
  1. SETPRCS ;EP CALLED WHEN ADDING REFERRALS FROM BPCRC3
  1.  F BPCQ=1:1:$L(BPCPRCS,BPCS2) S BPCDTA=$P(BPCPRCS,BPCS2,BPCQ) D SETPRC1
  1.  Q
  1. SETPRC1 ;
  1.  S BPCPXIEN=$P(BPCDTA,BPCS3,1),BPCNARR=$P(BPCDTA,BPCS3,2),BPCNIEN=""
  1.  D:BPCNARR'="" SETNAR
  1.  Q:BPCERR
  1.  L +^BMCPX(0):10 I '$T S BPCERR=1 Q
  1.  K BPCFDA,BPCEMSG S BPCFDR="BPCFDA(1)"
  1.  S BPCFDA(1,90001.02,"+1,",.01)=BPCPXIEN
  1.  S BPCFDA(1,90001.02,"+1,",.02)=BPCPIEN
  1.  S BPCFDA(1,90001.02,"+1,",.03)=BPCRIEN
  1.  S BPCFDA(1,90001.02,"+1,",.04)="P"
  1.  S:BPCNIEN'="" BPCFDA(1,90001.02,"+1,",.06)=BPCNIEN
  1.  K BPCIEN D UPDATE^DIE("",BPCFDR,"BPCIEN","BPCEMSG")
  1.  I $D(BPCEMSG("DIERR")) S BPCERR=1
  1.  L -^BMCPX(0)
  1.  Q
  1. SETNAR ;
  1.  I $D(^AUTNPOV("B",$E(BPCNARR,1,30))) S BPCNIEN=$O(^AUTNPOV("B",$E(BPCNARR,1,30),"")) Q
  1.  L +^AUTNPOV(0):10 I '$T S BPCERR=1 Q
  1.  K BPCFDA,BPCEMSG S BPCFDR="BPCFDA(1)"
  1.  S BPCFDA(1,9999999.27,"+1,",.01)=BPCNARR
  1.  K BPCIEN D UPDATE^DIE("",BPCFDR,"BPCIEN","BPCEMSG")
  1.  I $D(BPCEMSG("DIERR")) S BPCERR=1
  1.  L -^AUTNPOV(0)
  1.  I 'BPCERR S BPCNIEN=BPCIEN(1)
  1.  Q