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
