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

BPCRC4.m

Go to the documentation of this file.
  1. BPCRC4 ; IHS/OIT/MJL - FHL-12/5/96 - REFERRED CARE GUI ROUTINES ;
  1. ;;1.5;BPC;;MAY 26, 2005
  1. PXLIST(BPCRES,BPCX,BPCMAX,BPCMORE,BPCPARAM) ;EP CALL FROM REMOTE PROC: BPC GETCPTLIST
  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(^ICPT("C",BPCX)) S BPCIEN="" D GETKWD,KILL Q
  1. I BPCX?.U1.N D GETNUMS,KILL Q
  1. I BPCX="" D GETCPTBA,KILL Q
  1. S BPCN=$O(^ICPT("C",BPCX),-1) D GETCPT,KILL
  1. Q
  1. KILL ;
  1. K BPCCDE,BPCX,BPCMAX,BPCMORE,BPCPARAM,BPCCTR,BPCC,BPCGUI,BPCLEN,BPCN,BPCSAV,BPCIEN,BPCFLAG,BPCDTA,BPCIDX,BPCSUB,BPCNO,BPCSB
  1. Q
  1. GETKWD ;
  1. S BPCFLAG=0,BPCIDX="C" F S BPCIEN=$O(^ICPT("C",BPCX,BPCIEN)) Q:BPCIEN="" D GETDATA Q:BPCFLAG
  1. S ^BPCRES(BPCSUB,0)=BPCCTR
  1. Q
  1. GETDATA ;
  1. S BPCDTA=$G(^ICPT(BPCIEN,0))
  1. I BPCCTR=BPCMAX D SETMORE S BPCFLAG=1 Q
  1. S BPCCTR=BPCCTR+1,^BPCRES(BPCSUB,BPCCTR)=$P(BPCDTA,U,1)_U_$P(BPCDTA,U,2)_U_BPCIEN
  1. Q
  1. GETNUMS ;
  1. S BPCFLAG=0,BPCN=BPCX_" ",BPCIDX="BA" I '$D(^ICPT("BA",BPCN)) D GETNUMS2 Q
  1. S BPCIEN=$O(^ICPT("BA",BPCN,"")) D:BPCIEN'="" GETDATA
  1. S ^BPCRES(BPCSUB,0)=BPCCTR
  1. Q
  1. GETNUMS2 ;
  1. S:BPCX'="" BPCN=BPCX_" ",BPCN=$O(^ICPT("BA",BPCN),-1) F S BPCN=$O(^ICPT("BA",BPCN)) Q:BPCN="" D GETNUMS3 Q:BPCFLAG
  1. S ^BPCRES(BPCSUB,0)=BPCCTR
  1. Q
  1. GETNUMS3 ;
  1. S BPCX=BPCSAV
  1. I BPCX'="",$E(BPCN,1,BPCLEN)'=BPCX S BPCFLAG=1 Q
  1. S BPCIEN="" F S BPCIEN=$O(^ICPT("BA",BPCN,BPCIEN)) Q:BPCIEN="" D GETDATA Q:BPCFLAG
  1. Q
  1. GETCPTBA ;
  1. S BPCIDX="BA",BPCN=BPCX,BPCFLAG=0 D GETNUMS2
  1. Q
  1. GETCPT ;
  1. S BPCIDX="C",BPCFLAG=0 F S BPCN=$O(^ICPT("C",BPCN)) Q:BPCN="" D GETCPT1 Q:BPCFLAG
  1. I 'BPCFLAG S BPCIDX="BA",BPCN=$O(^ICPT("BA",BPCX),-1) F S BPCN=$O(^ICPT("BA",BPCN)) Q:BPCN="" D GETCPT2 Q:BPCFLAG
  1. S ^BPCRES(BPCSUB,0)=BPCCTR
  1. Q
  1. GETCPT1 ;
  1. S BPCX=BPCSAV
  1. I BPCX'="",$E(BPCN,1,BPCLEN)'=BPCX S BPCFLAG=1 Q
  1. S BPCIEN="" F S BPCIEN=$O(^ICPT("C",BPCN,BPCIEN)) Q:BPCIEN="" D GETDATA Q:BPCFLAG
  1. Q
  1. GETCPT2 ;
  1. S BPCX=BPCSAV
  1. I BPCX'="",$E(BPCN,1,BPCLEN)'=BPCX S BPCFLAG=1 Q
  1. S BPCIEN="" F S BPCIEN=$O(^ICPT("BA",BPCN,BPCIEN)) Q:BPCIEN="" D GETDATA Q:BPCFLAG
  1. Q
  1. GETCPT3 ;
  1. S BPCFLAG=0 F S BPCIEN=$O(^ICPT("C",BPCN,BPCIEN)) Q:BPCIEN="" D GETDATA Q:BPCFLAG
  1. I BPCFLAG S ^BPCRES(BPCSUB,0)=BPCCTR Q
  1. D GETCPT
  1. Q
  1. GETCPT4 ;
  1. S BPCFLAG=0 F S BPCIEN=$O(^ICPT("BA",BPCN,BPCIEN)) Q:BPCIEN="" D GETDATA Q:BPCFLAG
  1. I BPCFLAG S ^BPCRES(BPCSUB,0)=BPCCTR Q
  1. F S BPCN=$O(^ICPT("BA",BPCN)) Q:BPCN="" D GETCPT2 Q:BPCFLAG
  1. S ^BPCRES(BPCSUB,0)=BPCCTR
  1. Q
  1. SETMORE ;
  1. S BPCCTR=BPCCTR+1,^BPCRES(BPCSUB,BPCCTR)="..MORE"_U_BPCIEN_"|"_$P(BPCDTA,U,1)_"|"_$P(BPCDTA,U,2)_"|"_BPCIDX_"|"_BPCN
  1. Q
  1. MORE ;
  1. S BPCCTR=BPCCTR+1,^BPCRES(BPCSUB,BPCCTR)=$P(BPCMORE,"|",2)_U_$P(BPCMORE,"|",3)_U_$P(BPCMORE,"|",1)
  1. I BPCX="" S BPCIDX="BA",BPCN=$P(BPCMORE,"|",2)_" ",BPCFLAG=0 D GETNUMS2 Q
  1. I BPCX'="" I $D(^ICPT("C",BPCX)) S BPCIEN=$P(BPCMORE,"|",1),BPCIDX="C" D GETKWD,KILL Q
  1. I BPCX?.U1.N S BPCX="",BPCN=$P(BPCMORE,"|",2)_" ",BPCFLAG=0,BPCIDX="BA" D GETNUMS2,KILL Q
  1. S BPCIDX=$P(BPCMORE,"|",4),BPCN=$P(BPCMORE,"|",5),BPCIEN=$P(BPCMORE,"|",1) D:BPCIDX="C" GETCPT3 D:BPCIDX="BA" GETCPT4
  1. D KILL
  1. Q
  1. DXLIST(BPCRES,BPCX,BPCMAX,BPCMORE,BPCPARAM) ;EP CALL FROM REMOTE PROC: BPC GETDXLIST
  1. S BPCGUI=1
  1. EN1 ;
  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. K:BPCMORE="" ^BPCTMP(BPCSUB)
  1. S BPCSAV=BPCX
  1. I BPCMORE'="" D DXMORE,KILL Q
  1. I BPCX'="" I $D(^AICDKWLC(1,1,"B",BPCX)) D KWLC S BPCCTR=0 D SETRES,KILL Q
  1. I BPCX'="" I $D(^ICD9("AIHS",BPCX)) S BPCIEN="" D GETDKWD S BPCCTR=0 D SETRES,KILL Q
  1. ;I BPCX?.N.1"."1N.N!(BPCX="") D GETICD,KILL Q
  1. I BPCX?.N.1".".N!(BPCX="") D GETICD,KILL Q
  1. S BPCN=$O(^ICD9("D",BPCX),-1) D GETICD2 S BPCCTR=0 D SETRES,KILL
  1. Q
  1. DXMORE ;
  1. I BPCX?.N.1".".N!(BPCX="") D DXMORE1 S ^BPCRES(BPCSUB,0)=BPCCTR Q
  1. S BPCIEN=$P(BPCMORE,"|",1),BPCCDE=+$P(BPCMORE,"|",2),BPCIDX=$P(BPCMORE,"|",4),BPCN=$P(BPCMORE,"|",5),BPCFLAG=0 D GETDX I BPCFLAG S BPCRES(BPCSUB,0)=BPCCTR Q
  1. D SETRES
  1. Q
  1. DXMORE1 ;
  1. S BPCIEN=$P(BPCMORE,"|",1),BPCN=$P(BPCMORE,"|",5),BPCFLAG=0 D GETDX Q:BPCFLAG
  1. F S BPCIEN=$O(^ICD9("BA",BPCN,BPCIEN)) Q:BPCIEN="" D GETDX Q:BPCFLAG
  1. Q:BPCFLAG
  1. S BPCX="" D GETICD
  1. Q
  1. KWLC ;
  1. S BPCNO=$O(^AICDKWLC(1,1,"B",BPCX,"")) Q:BPCNO=""
  1. S BPCSB=0,BPCFLAG=0 F S BPCSB=$O(^AICDKWLC(1,1,BPCNO,1,BPCSB)) Q:BPCSB="" D KWLC1
  1. S BPCX=BPCSAV
  1. Q
  1. KWLC1 ;
  1. S BPCX=$G(^AICDKWLC(1,1,BPCNO,1,BPCSB,0)) Q:BPCX=""
  1. I $D(^ICD9("AIHS",BPCX)) S BPCIEN="" D GETDKWD Q
  1. S BPCN=$O(^ICD9("D",BPCX),-1) D GETICD2
  1. Q
  1. GETDKWD ;
  1. S BPCFLAG=0,BPCIDX="AIHS",BPCN=BPCX F S BPCIEN=$O(^ICD9("AIHS",BPCN,BPCIEN)) Q:BPCIEN="" D GETDX1
  1. Q
  1. SETRES ;
  1. S BPCCTR=+$G(BPCCTR),BPCCDE=$G(BPCCDE),BPCFLAG=0 F S BPCCDE=$O(^BPCTMP(BPCSUB,BPCCDE)) Q:BPCCDE="" S BPCDTA=^(BPCCDE),BPCIEN=$P(BPCDTA,U,1),BPCN=$P(BPCDTA,U,2),BPCIDX=$P(BPCDTA,U,3) D GETDX Q:BPCFLAG
  1. S ^BPCRES(BPCSUB,0)=BPCCTR
  1. Q
  1. GETICD ;
  1. S BPCIDX="BA",BPCFLAG=0 S:BPCX'="" BPCN=BPCX,BPCN=$O(^ICD9("BA",BPCN),-1) F S BPCN=$O(^ICD9("BA",BPCN)) Q:BPCN="" D GETICD1 Q:BPCFLAG
  1. S ^BPCRES(BPCSUB,0)=BPCCTR
  1. Q
  1. GETICD1 ;
  1. S BPCX=BPCSAV
  1. I BPCX'="",$E(BPCN,1,BPCLEN)'=BPCX S BPCFLAG=1 Q
  1. S BPCIEN="" F S BPCIEN=$O(^ICD9("BA",BPCN,BPCIEN)) Q:BPCIEN="" D GETDX Q:BPCFLAG
  1. Q
  1. GETICD2 ;
  1. S BPCIDX="D",BPCFLAG=0
  1. F S BPCN=$O(^ICD9("D",BPCN)) Q:BPCN="" D GETICD3 Q:BPCFLAG
  1. Q
  1. GETICD3 ;
  1. S BPCX=BPCSAV
  1. I BPCX'="",$E(BPCN,1,BPCLEN)'=BPCX S BPCFLAG=1 Q
  1. S BPCIEN="" F S BPCIEN=$O(^ICD9("D",BPCN,BPCIEN)) Q:BPCIEN="" D GETDX1
  1. Q
  1. GETDX ;
  1. S BPCDTA=$G(^ICD9(BPCIEN,0)) Q:$E(BPCDTA)="E"
  1. I BPCCTR=BPCMAX D SETMORDX S BPCFLAG=1 Q
  1. S BPCCTR=BPCCTR+1,^BPCRES(BPCSUB,BPCCTR)=$P(BPCDTA,U,1)_U_$P(BPCDTA,U,3)_U_BPCIEN
  1. Q
  1. GETDX1 ;
  1. S BPCDTA=$G(^ICD9(BPCIEN,0)) Q:$E(BPCDTA)="E"
  1. S BPCC=$P(BPCDTA,U,1) I $E(BPCC)?1N S BPCC=+BPCC
  1. S:'$D(^BPCTMP(BPCSUB,BPCC)) BPCCTR=BPCCTR+1,^BPCTMP(BPCSUB,BPCC)=BPCIEN_U_BPCN_U_BPCIDX,^BPCTMP(BPCSUB)=BPCCTR
  1. Q
  1. SETMORDX ;
  1. S BPCCTR=BPCCTR+1,^BPCRES(BPCSUB,BPCCTR)="..MORE"_U_BPCIEN_"|"_$P(BPCDTA,U,1)_"|"_$P(BPCDTA,U,3)_"|"_BPCIDX_"|"_BPCN
  1. Q