- BPCPC1 ; IHS/OIT/MJL - PATIENT CHART GUI ROUTINES ;
- ;;1.5;BPC;;MAY 26, 2005
- DUPPAT(RESULT,BPCNAM,BPCPARAM) ;EP CALL FROM REMOTE PROC: BPC GETDUPPAT
- S U="^",BPCSUB=$J K ^BGURES(BPCSUB),RESULT
- S RESULT="^BGURES("_BPCSUB_")"
- S BPCNAM=$G(BPCNAM),BPCPARAM=$G(BPCPARAM)
- I BPCNAM="" S ^BGURES(BPCSUB,1)="-1",^BGURES(BPCSUB,2)="No Patient Name Parameter Sent!" D KILL Q
- S BPCX=$O(^DPT("B",BPCNAM),-1),BPCC=0,BPCCTR=1 D GETNAM,KILL
- Q
- KILL ;
- K BPCX,BPCY,BPCCTR,BPCC,BPCD,BPCSEX,BPCDOB,BPCSTR,BPCSUB,BPCSSN
- Q
- GETNAM ;
- F S BPCX=$O(^DPT("B",BPCX)) Q:BPCX=""!($E(BPCX,1,$L(BPCNAM))'=BPCNAM) D
- .S BPCY="" F S BPCY=$O(^DPT("B",BPCX,BPCY)) Q:BPCY="" D
- ..S BPCD=^DPT(BPCY,0),BPCRNAM=$P(BPCD,U,1) Q:BPCX'=BPCRNAM
- ..S BPCSEX=$P(BPCD,U,2)
- ..S BPCSEX=$S(BPCSEX="F":"FEMALE",BPCSEX="M":"MALE",1:"UNKNOWN")
- ..S BPCDOB=$P(BPCD,U,3),BPCSSN=$P(BPCD,U,9)
- ..S BPCD=$G(^DPT(BPCY,".24")),BPCMMN=$P(BPCD,U,3)
- ..S BPCSTR=BPCX_U_BPCSEX_U_BPCDOB_U_BPCSSN_U_BPCMMN
- ..S BPCC=BPCC+1,BPCCTR=BPCCTR+1
- ..S ^BGURES(BPCSUB,BPCCTR)=BPCSTR,^BGURES(BPCSUB,1)=BPCC
- I BPCC=0 S ^BGURES(BPCSUB,1)=-2,^BGURES(BPCSUB,2)="NO DUPLICATES"
- Q
- BENELIST(RESULT,BPCX,BPCMAX,BPCMORE,BPCPARAM) ;EP CALL FROM REMOTE PROC: BPC GETBENEFICIARIES
- S U="^",XWBWRAP=1,BPCSUB=$J K ^BGURES(BPCSUB),RESULT
- S RESULT="^BGURES("_BPCSUB_")"
- S BPCX=$G(BPCX),BPCMAX=$G(BPCMAX),BPCMORE=$G(BPCMORE),BPCPARAM=$G(BPCPARAM),BPCLEN=$L(BPCX),BPCCTR=0,BPCFLAG=0
- S BPCN="" S:BPCX'="" BPCN=$O(^AUTTBEN("B",BPCX),-1)
- S:'BPCMAX BPCMAX=50
- I BPCMORE'="" D MORE I BPCFLAG D KILL Q
- D GETBEN,KILL
- Q
- GETBEN ;
- F S BPCN=$O(^AUTTBEN("B",BPCN)) Q:BPCN="" D Q:BPCFLAG
- .I BPCX'="",$E(BPCN,1,BPCLEN)'=BPCX S BPCFLAG=1 Q
- .S BPCIEN="" F S BPCIEN=$O(^AUTTBEN("B",BPCN,BPCIEN)) Q:BPCIEN="" D Q:BPCFLAG
- ..I BPCCTR=BPCMAX D Q
- ...S BPCCTR=BPCCTR+1,^BGURES(BPCSUB,BPCCTR)="..MORE"_U_BPCN_"|"_BPCIEN
- ...S BPCFLAG=1
- ..S BPCCTR=BPCCTR+1,^BGURES(BPCSUB,BPCCTR)=BPCN_U_BPCIEN
- S ^BGURES(BPCSUB,0)=BPCCTR
- Q
- MORE ;
- S BPCN=$P(BPCMORE,"|",1),BPCIEN=$P(BPCMORE,"|",2),BPCCTR=BPCCTR+1
- S ^BGURES(BPCSUB,BPCCTR)=BPCN_U_BPCIEN
- I BPCCTR=BPCMAX S BPCFLAG=1
- Q
- TRIBLIST(RESULT,BPCX,BPCMAX,BPCMORE,BPCPARAM) ;EP CALL FROM REMOTE PROC: BPC GETTRIBES
- S U="^",XWBWRAP=1,BPCSUB=$J K ^BGURES(BPCSUB),RESULT
- S RESULT="^BGURES("_BPCSUB_")"
- S BPCX=$G(BPCX),BPCMAX=$G(BPCMAX),BPCMORE=$G(BPCMORE),BPCPARAM=$G(BPCPARAM),BPCLEN=$L(BPCX),BPCCTR=0,BPCFLAG=0
- S BPCN="" S:BPCX'="" BPCN=$O(^AUTTTRI("B",BPCX),-1)
- S:'BPCMAX BPCMAX=50
- I BPCMORE'="" D MORE I BPCFLAG D KILL Q
- D GETTRI,KILL
- Q
- GETTRI ;
- F S BPCN=$O(^AUTTTRI("B",BPCN)) Q:BPCN="" D Q:BPCFLAG
- .I BPCX'="",$E(BPCN,1,BPCLEN)'=BPCX S BPCFLAG=1 Q
- .S BPCIEN="" F S BPCIEN=$O(^AUTTTRI("B",BPCN,BPCIEN)) Q:BPCIEN="" D Q:BPCFLAG
- ..I BPCCTR=BPCMAX D Q
- ...S BPCCTR=BPCCTR+1,^BGURES(BPCSUB,BPCCTR)="..MORE"_U_BPCN_"|"_BPCIEN
- ...S BPCFLAG=1
- ..S BPCCTR=BPCCTR+1,^BGURES(BPCSUB,BPCCTR)=BPCN_U_BPCIEN
- S ^BGURES(BPCSUB,0)=BPCCTR
- Q
- COMLIST(RESULT,BPCX,BPCMAX,BPCMORE,BPCPARAM) ;EP CALL FROM REMOTE PROC: BPC GETCOMMUNITIES
- S U="^",XWBWRAP=1,BPCSUB=$J K ^BGURES(BPCSUB),RESULT
- S RESULT="^BGURES("_BPCSUB_")"
- S BPCX=$G(BPCX),BPCMAX=$G(BPCMAX),BPCMORE=$G(BPCMORE),BPCPARAM=$G(BPCPARAM),BPCLEN=$L(BPCX),BPCCTR=0,BPCFLAG=0
- S BPCN="" S:BPCX'="" BPCN=$O(^AUTTCOM("B",BPCX),-1)
- S:'BPCMAX BPCMAX=50
- I BPCMORE'="" D MORECOM I BPCFLAG D KILL Q
- D GETCOM,KILL
- Q
- GETCOM ;
- F S BPCN=$O(^AUTTCOM("B",BPCN)) Q:BPCN="" D Q:BPCFLAG
- .I BPCX'="",$E(BPCN,1,BPCLEN)'=BPCX S BPCFLAG=1 Q
- .S BPCIEN="" F S BPCIEN=$O(^AUTTCOM("B",BPCN,BPCIEN)) Q:BPCIEN="" D Q:BPCFLAG
- ..S BPCD=^AUTTCOM(BPCIEN,0),BPCCTY=$P(BPCD,U,2),BPCST=$P(BPCD,U,3)
- ..S BPCCTY=$P($G(^AUTTCTY(BPCCTY,0)),U,1)
- ..S BPCST=$P($G(^DIC(5,BPCST,0)),U,1)
- ..I BPCCTR=BPCMAX D Q
- ...S BPCCTR=BPCCTR+1,^BGURES(BPCSUB,BPCCTR)="..MORE"_U_BPCN_"|"_BPCIEN_"|"_BPCCTY_"|"_BPCST
- ...S BPCFLAG=1
- ..S BPCCTR=BPCCTR+1,^BGURES(BPCSUB,BPCCTR)=BPCN_U_BPCIEN_U_BPCCTY_U_BPCST
- S ^BGURES(BPCSUB,0)=BPCCTR
- Q
- MORECOM ;
- S BPCN=$P(BPCMORE,"|",1),BPCIEN=$P(BPCMORE,"|",2)
- S BPCCTY=$P(BPCMORE,"|",3),BPCST=$P(BPCMORE,"|",4),BPCCTR=BPCCTR+1
- S ^BGURES(BPCSUB,BPCCTR)=BPCN_U_BPCIEN_U_BPCCTY_U_BPCST
- I BPCCTR=BPCMAX S BPCFLAG=1
- Q
- STLIST(RESULT,BPCX,BPCMAX,BPCMORE,BPCPARAM) ;EP CALL FROM REMOTE PROC: BPC GETSTATES
- S U="^",XWBWRAP=1,BPCSUB=$J K ^BGURES(BPCSUB),RESULT
- S RESULT="^BGURES("_BPCSUB_")"
- S BPCX=$G(BPCX),BPCMAX=$G(BPCMAX),BPCMORE=$G(BPCMORE),BPCPARAM=$G(BPCPARAM),BPCLEN=$L(BPCX),BPCCTR=0,BPCFLAG=0
- I BPCX'="" D CKCXF I BPCFLAG D KILL Q
- S BPCN="" S:BPCX'="" BPCN=$O(^DIC(5,"B",BPCX),-1)
- S:'BPCMAX BPCMAX=50
- I BPCMORE'="" D MOREST I BPCFLAG D KILL Q
- D GETST,KILL
- Q
- CKCXF ;
- I $D(^DIC(5,"C",BPCX))=10 D Q
- .S BPCIEN=$O(^DIC(5,"C",BPCX,"")) Q:BPCIEN=""
- .S ^BGURES(BPCSUB,0)=1,^BGURES(BPCSUB,1)=BPCX_U_BPCIEN_U_$P(^DIC(5,BPCIEN,0),U,1)
- .S BPCFLAG=1
- Q
- MOREST ;
- S BPCCDE=$P(BPCMORE,"|",1),BPCIEN=$P(BPCMORE,"|",2)
- S BPCN=$P(BPCMORE,"|",3),BPCCTR=BPCCTR+1
- S ^BGURES(BPCSUB,BPCCTR)=BPCCDE_U_BPCIEN_U_BPCN
- I BPCCTR=BPCMAX S BPCFLAG=1
- Q
- GETST ;
- F S BPCN=$O(^DIC(5,"B",BPCN)) Q:BPCN="" D Q:BPCFLAG
- .I BPCX'="",$E(BPCN,1,BPCLEN)'=BPCX S BPCFLAG=1 Q
- .S BPCIEN="" F S BPCIEN=$O(^DIC(5,"B",BPCN,BPCIEN)) Q:BPCIEN="" D Q:BPCFLAG
- ..S BPCD=^DIC(5,BPCIEN,0),BPCCDE=$P(BPCD,U,2)
- ..I BPCCTR=BPCMAX D Q
- ...S BPCCTR=BPCCTR+1,^BGURES(BPCSUB,BPCCTR)="..MORE"_U_BPCCDE_"|"_BPCIEN_"|"_BPCN
- ...S BPCFLAG=1
- ..S BPCCTR=BPCCTR+1,^BGURES(BPCSUB,BPCCTR)=BPCCDE_U_BPCIEN_U_BPCN
- S ^BGURES(BPCSUB,0)=BPCCTR
- Q
- BPCPC1 ; IHS/OIT/MJL - PATIENT CHART GUI ROUTINES ;
- +1 ;;1.5;BPC;;MAY 26, 2005
- DUPPAT(RESULT,BPCNAM,BPCPARAM) ;EP CALL FROM REMOTE PROC: BPC GETDUPPAT
- +1 SET U="^"
- SET BPCSUB=$JOB
- KILL ^BGURES(BPCSUB),RESULT
- +2 SET RESULT="^BGURES("_BPCSUB_")"
- +3 SET BPCNAM=$GET(BPCNAM)
- SET BPCPARAM=$GET(BPCPARAM)
- +4 IF BPCNAM=""
- SET ^BGURES(BPCSUB,1)="-1"
- SET ^BGURES(BPCSUB,2)="No Patient Name Parameter Sent!"
- DO KILL
- QUIT
- +5 SET BPCX=$ORDER(^DPT("B",BPCNAM),-1)
- SET BPCC=0
- SET BPCCTR=1
- DO GETNAM
- DO KILL
- +6 QUIT
- KILL ;
- +1 KILL BPCX,BPCY,BPCCTR,BPCC,BPCD,BPCSEX,BPCDOB,BPCSTR,BPCSUB,BPCSSN
- +2 QUIT
- GETNAM ;
- +1 FOR
- SET BPCX=$ORDER(^DPT("B",BPCX))
- IF BPCX=""!($EXTRACT(BPCX,1,$LENGTH(BPCNAM))'=BPCNAM)
- QUIT
- Begin DoDot:1
- +2 SET BPCY=""
- FOR
- SET BPCY=$ORDER(^DPT("B",BPCX,BPCY))
- IF BPCY=""
- QUIT
- Begin DoDot:2
- +3 SET BPCD=^DPT(BPCY,0)
- SET BPCRNAM=$PIECE(BPCD,U,1)
- IF BPCX'=BPCRNAM
- QUIT
- +4 SET BPCSEX=$PIECE(BPCD,U,2)
- +5 SET BPCSEX=$SELECT(BPCSEX="F":"FEMALE",BPCSEX="M":"MALE",1:"UNKNOWN")
- +6 SET BPCDOB=$PIECE(BPCD,U,3)
- SET BPCSSN=$PIECE(BPCD,U,9)
- +7 SET BPCD=$GET(^DPT(BPCY,".24"))
- SET BPCMMN=$PIECE(BPCD,U,3)
- +8 SET BPCSTR=BPCX_U_BPCSEX_U_BPCDOB_U_BPCSSN_U_BPCMMN
- +9 SET BPCC=BPCC+1
- SET BPCCTR=BPCCTR+1
- +10 SET ^BGURES(BPCSUB,BPCCTR)=BPCSTR
- SET ^BGURES(BPCSUB,1)=BPCC
- End DoDot:2
- End DoDot:1
- +11 IF BPCC=0
- SET ^BGURES(BPCSUB,1)=-2
- SET ^BGURES(BPCSUB,2)="NO DUPLICATES"
- +12 QUIT
- BENELIST(RESULT,BPCX,BPCMAX,BPCMORE,BPCPARAM) ;EP CALL FROM REMOTE PROC: BPC GETBENEFICIARIES
- +1 SET U="^"
- SET XWBWRAP=1
- SET BPCSUB=$JOB
- KILL ^BGURES(BPCSUB),RESULT
- +2 SET RESULT="^BGURES("_BPCSUB_")"
- +3 SET BPCX=$GET(BPCX)
- SET BPCMAX=$GET(BPCMAX)
- SET BPCMORE=$GET(BPCMORE)
- SET BPCPARAM=$GET(BPCPARAM)
- SET BPCLEN=$LENGTH(BPCX)
- SET BPCCTR=0
- SET BPCFLAG=0
- +4 SET BPCN=""
- IF BPCX'=""
- SET BPCN=$ORDER(^AUTTBEN("B",BPCX),-1)
- +5 IF 'BPCMAX
- SET BPCMAX=50
- +6 IF BPCMORE'=""
- DO MORE
- IF BPCFLAG
- DO KILL
- QUIT
- +7 DO GETBEN
- DO KILL
- +8 QUIT
- GETBEN ;
- +1 FOR
- SET BPCN=$ORDER(^AUTTBEN("B",BPCN))
- IF BPCN=""
- QUIT
- Begin DoDot:1
- +2 IF BPCX'=""
- IF $EXTRACT(BPCN,1,BPCLEN)'=BPCX
- SET BPCFLAG=1
- QUIT
- +3 SET BPCIEN=""
- FOR
- SET BPCIEN=$ORDER(^AUTTBEN("B",BPCN,BPCIEN))
- IF BPCIEN=""
- QUIT
- Begin DoDot:2
- +4 IF BPCCTR=BPCMAX
- Begin DoDot:3
- +5 SET BPCCTR=BPCCTR+1
- SET ^BGURES(BPCSUB,BPCCTR)="..MORE"_U_BPCN_"|"_BPCIEN
- +6 SET BPCFLAG=1
- End DoDot:3
- QUIT
- +7 SET BPCCTR=BPCCTR+1
- SET ^BGURES(BPCSUB,BPCCTR)=BPCN_U_BPCIEN
- End DoDot:2
- IF BPCFLAG
- QUIT
- End DoDot:1
- IF BPCFLAG
- QUIT
- +8 SET ^BGURES(BPCSUB,0)=BPCCTR
- +9 QUIT
- MORE ;
- +1 SET BPCN=$PIECE(BPCMORE,"|",1)
- SET BPCIEN=$PIECE(BPCMORE,"|",2)
- SET BPCCTR=BPCCTR+1
- +2 SET ^BGURES(BPCSUB,BPCCTR)=BPCN_U_BPCIEN
- +3 IF BPCCTR=BPCMAX
- SET BPCFLAG=1
- +4 QUIT
- TRIBLIST(RESULT,BPCX,BPCMAX,BPCMORE,BPCPARAM) ;EP CALL FROM REMOTE PROC: BPC GETTRIBES
- +1 SET U="^"
- SET XWBWRAP=1
- SET BPCSUB=$JOB
- KILL ^BGURES(BPCSUB),RESULT
- +2 SET RESULT="^BGURES("_BPCSUB_")"
- +3 SET BPCX=$GET(BPCX)
- SET BPCMAX=$GET(BPCMAX)
- SET BPCMORE=$GET(BPCMORE)
- SET BPCPARAM=$GET(BPCPARAM)
- SET BPCLEN=$LENGTH(BPCX)
- SET BPCCTR=0
- SET BPCFLAG=0
- +4 SET BPCN=""
- IF BPCX'=""
- SET BPCN=$ORDER(^AUTTTRI("B",BPCX),-1)
- +5 IF 'BPCMAX
- SET BPCMAX=50
- +6 IF BPCMORE'=""
- DO MORE
- IF BPCFLAG
- DO KILL
- QUIT
- +7 DO GETTRI
- DO KILL
- +8 QUIT
- GETTRI ;
- +1 FOR
- SET BPCN=$ORDER(^AUTTTRI("B",BPCN))
- IF BPCN=""
- QUIT
- Begin DoDot:1
- +2 IF BPCX'=""
- IF $EXTRACT(BPCN,1,BPCLEN)'=BPCX
- SET BPCFLAG=1
- QUIT
- +3 SET BPCIEN=""
- FOR
- SET BPCIEN=$ORDER(^AUTTTRI("B",BPCN,BPCIEN))
- IF BPCIEN=""
- QUIT
- Begin DoDot:2
- +4 IF BPCCTR=BPCMAX
- Begin DoDot:3
- +5 SET BPCCTR=BPCCTR+1
- SET ^BGURES(BPCSUB,BPCCTR)="..MORE"_U_BPCN_"|"_BPCIEN
- +6 SET BPCFLAG=1
- End DoDot:3
- QUIT
- +7 SET BPCCTR=BPCCTR+1
- SET ^BGURES(BPCSUB,BPCCTR)=BPCN_U_BPCIEN
- End DoDot:2
- IF BPCFLAG
- QUIT
- End DoDot:1
- IF BPCFLAG
- QUIT
- +8 SET ^BGURES(BPCSUB,0)=BPCCTR
- +9 QUIT
- COMLIST(RESULT,BPCX,BPCMAX,BPCMORE,BPCPARAM) ;EP CALL FROM REMOTE PROC: BPC GETCOMMUNITIES
- +1 SET U="^"
- SET XWBWRAP=1
- SET BPCSUB=$JOB
- KILL ^BGURES(BPCSUB),RESULT
- +2 SET RESULT="^BGURES("_BPCSUB_")"
- +3 SET BPCX=$GET(BPCX)
- SET BPCMAX=$GET(BPCMAX)
- SET BPCMORE=$GET(BPCMORE)
- SET BPCPARAM=$GET(BPCPARAM)
- SET BPCLEN=$LENGTH(BPCX)
- SET BPCCTR=0
- SET BPCFLAG=0
- +4 SET BPCN=""
- IF BPCX'=""
- SET BPCN=$ORDER(^AUTTCOM("B",BPCX),-1)
- +5 IF 'BPCMAX
- SET BPCMAX=50
- +6 IF BPCMORE'=""
- DO MORECOM
- IF BPCFLAG
- DO KILL
- QUIT
- +7 DO GETCOM
- DO KILL
- +8 QUIT
- GETCOM ;
- +1 FOR
- SET BPCN=$ORDER(^AUTTCOM("B",BPCN))
- IF BPCN=""
- QUIT
- Begin DoDot:1
- +2 IF BPCX'=""
- IF $EXTRACT(BPCN,1,BPCLEN)'=BPCX
- SET BPCFLAG=1
- QUIT
- +3 SET BPCIEN=""
- FOR
- SET BPCIEN=$ORDER(^AUTTCOM("B",BPCN,BPCIEN))
- IF BPCIEN=""
- QUIT
- Begin DoDot:2
- +4 SET BPCD=^AUTTCOM(BPCIEN,0)
- SET BPCCTY=$PIECE(BPCD,U,2)
- SET BPCST=$PIECE(BPCD,U,3)
- +5 SET BPCCTY=$PIECE($GET(^AUTTCTY(BPCCTY,0)),U,1)
- +6 SET BPCST=$PIECE($GET(^DIC(5,BPCST,0)),U,1)
- +7 IF BPCCTR=BPCMAX
- Begin DoDot:3
- +8 SET BPCCTR=BPCCTR+1
- SET ^BGURES(BPCSUB,BPCCTR)="..MORE"_U_BPCN_"|"_BPCIEN_"|"_BPCCTY_"|"_BPCST
- +9 SET BPCFLAG=1
- End DoDot:3
- QUIT
- +10 SET BPCCTR=BPCCTR+1
- SET ^BGURES(BPCSUB,BPCCTR)=BPCN_U_BPCIEN_U_BPCCTY_U_BPCST
- End DoDot:2
- IF BPCFLAG
- QUIT
- End DoDot:1
- IF BPCFLAG
- QUIT
- +11 SET ^BGURES(BPCSUB,0)=BPCCTR
- +12 QUIT
- MORECOM ;
- +1 SET BPCN=$PIECE(BPCMORE,"|",1)
- SET BPCIEN=$PIECE(BPCMORE,"|",2)
- +2 SET BPCCTY=$PIECE(BPCMORE,"|",3)
- SET BPCST=$PIECE(BPCMORE,"|",4)
- SET BPCCTR=BPCCTR+1
- +3 SET ^BGURES(BPCSUB,BPCCTR)=BPCN_U_BPCIEN_U_BPCCTY_U_BPCST
- +4 IF BPCCTR=BPCMAX
- SET BPCFLAG=1
- +5 QUIT
- STLIST(RESULT,BPCX,BPCMAX,BPCMORE,BPCPARAM) ;EP CALL FROM REMOTE PROC: BPC GETSTATES
- +1 SET U="^"
- SET XWBWRAP=1
- SET BPCSUB=$JOB
- KILL ^BGURES(BPCSUB),RESULT
- +2 SET RESULT="^BGURES("_BPCSUB_")"
- +3 SET BPCX=$GET(BPCX)
- SET BPCMAX=$GET(BPCMAX)
- SET BPCMORE=$GET(BPCMORE)
- SET BPCPARAM=$GET(BPCPARAM)
- SET BPCLEN=$LENGTH(BPCX)
- SET BPCCTR=0
- SET BPCFLAG=0
- +4 IF BPCX'=""
- DO CKCXF
- IF BPCFLAG
- DO KILL
- QUIT
- +5 SET BPCN=""
- IF BPCX'=""
- SET BPCN=$ORDER(^DIC(5,"B",BPCX),-1)
- +6 IF 'BPCMAX
- SET BPCMAX=50
- +7 IF BPCMORE'=""
- DO MOREST
- IF BPCFLAG
- DO KILL
- QUIT
- +8 DO GETST
- DO KILL
- +9 QUIT
- CKCXF ;
- +1 IF $DATA(^DIC(5,"C",BPCX))=10
- Begin DoDot:1
- +2 SET BPCIEN=$ORDER(^DIC(5,"C",BPCX,""))
- IF BPCIEN=""
- QUIT
- +3 SET ^BGURES(BPCSUB,0)=1
- SET ^BGURES(BPCSUB,1)=BPCX_U_BPCIEN_U_$PIECE(^DIC(5,BPCIEN,0),U,1)
- +4 SET BPCFLAG=1
- End DoDot:1
- QUIT
- +5 QUIT
- MOREST ;
- +1 SET BPCCDE=$PIECE(BPCMORE,"|",1)
- SET BPCIEN=$PIECE(BPCMORE,"|",2)
- +2 SET BPCN=$PIECE(BPCMORE,"|",3)
- SET BPCCTR=BPCCTR+1
- +3 SET ^BGURES(BPCSUB,BPCCTR)=BPCCDE_U_BPCIEN_U_BPCN
- +4 IF BPCCTR=BPCMAX
- SET BPCFLAG=1
- +5 QUIT
- GETST ;
- +1 FOR
- SET BPCN=$ORDER(^DIC(5,"B",BPCN))
- IF BPCN=""
- QUIT
- Begin DoDot:1
- +2 IF BPCX'=""
- IF $EXTRACT(BPCN,1,BPCLEN)'=BPCX
- SET BPCFLAG=1
- QUIT
- +3 SET BPCIEN=""
- FOR
- SET BPCIEN=$ORDER(^DIC(5,"B",BPCN,BPCIEN))
- IF BPCIEN=""
- QUIT
- Begin DoDot:2
- +4 SET BPCD=^DIC(5,BPCIEN,0)
- SET BPCCDE=$PIECE(BPCD,U,2)
- +5 IF BPCCTR=BPCMAX
- Begin DoDot:3
- +6 SET BPCCTR=BPCCTR+1
- SET ^BGURES(BPCSUB,BPCCTR)="..MORE"_U_BPCCDE_"|"_BPCIEN_"|"_BPCN
- +7 SET BPCFLAG=1
- End DoDot:3
- QUIT
- +8 SET BPCCTR=BPCCTR+1
- SET ^BGURES(BPCSUB,BPCCTR)=BPCCDE_U_BPCIEN_U_BPCN
- End DoDot:2
- IF BPCFLAG
- QUIT
- End DoDot:1
- IF BPCFLAG
- QUIT
- +9 SET ^BGURES(BPCSUB,0)=BPCCTR
- +10 QUIT
