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