BGP1ASL1 ; IHS/CMI/LAB - DISPLAY IND LISTS 28 Apr 2006 2:10 PM ;
;;11.1;IHS CLINICAL REPORTING SYSTEM;;JUN 27, 2011;Build 33
;; ;
NGR ;EP
K BGPTIND S BGPHIGH=""
S BGPSUCNT=0,BGPSU="",BGPSUC=0
S BGPX=0 F S BGPX=$O(^BGPGPDCB(BGPX)) Q:BGPX'=+BGPX S V=$G(^BGPGPDCB(BGPX,0)) D
.Q:'$D(^BGPGPDCB(BGPX,0))
.Q:$P(V,U)'=BGPBD
.Q:$P(V,U,2)'=BGPED
.Q:$P(V,U,7)'=BGPPER
.I $G(BGP1GPU),$P(V,U,12)'=9 Q
.I '$G(BGP1GPU),$P(V,U,12)'=1 Q
.I $G(BGPCHWE) Q:'$O(^BGPGPDCB(BGPX,88888,0))
.Q:$P(V,U,5)'=BGPBBD
.Q:$P(V,U,6)'=BGPBED
.Q:$P(V,U,14)'=BGPBEN
.S BGPSUC=BGPSUC+1,BGPTIND(BGPSUC,0)=BGPSUC_")"
.S Y=""
.S $E(Y,4)=$E($$SU($P(V,U,11)),1,10)
.S $E(Y,15)=$E($$FAC($P(V,U,9)),1,13)_$S($P(^BGPGPDCB(BGPX,0),U,17):"+",1:"")
.S $E(Y,30)=$$DATE^BGP1UTL($P(V,U))
.S $E(Y,40)=$$DATE^BGP1UTL($P(V,U,2))
.S $E(Y,50)=$$DATE^BGP1UTL($P(V,U,5))
.S $E(Y,60)=$$DATE^BGP1UTL($P(V,U,6))
.S $E(Y,70)=$$DATE^BGP1UTL($P(V,U,13))
.S BGPTIND(BGPSUC,0)=BGPTIND(BGPSUC,0)_Y
.S BGPTIND(BGPSUC,BGPSUC)=BGPX
.I $D(BGPSUL(BGPX)) S BGPTIND(BGPSUC,0)="*"_BGPTIND(BGPSUC,0)
.Q
S (VALMCNT,BGPHIGH)=BGPSUC
Q
;
ONM ;EP
K BGPTIND S BGPHIGH=""
S BGPSUCNT=0,BGPSU="",BGPSUC=0
S BGPX=0 F S BGPX=$O(^BGPGPDCB(BGPX)) Q:BGPX'=+BGPX S V=$G(^BGPGPDCB(BGPX,0)) D
.Q:'$D(^BGPGPDCB(BGPX,0))
.Q:$P(V,U)'=BGPBD
.Q:$P(V,U,2)'=BGPED
.Q:$P(V,U,7)'=BGPPER
.Q:$P(V,U,5)'=BGPBBD
.Q:$P(V,U,6)'=BGPBED
.Q:$P(V,U,14)'=BGPBEN
.Q:$P(V,U,12)'=7
.S BGPSUC=BGPSUC+1,BGPTIND(BGPSUC,0)=BGPSUC_")"
.S Y=""
.S $E(Y,4)=$E($$SU($P(V,U,11)),1,10)
.S $E(Y,15)=$E($$FAC($P(V,U,9)),1,13)_$S($P(^BGPGPDCB(BGPX,0),U,17):"+",1:"")
.S $E(Y,30)=$$DATE^BGP1UTL($P(V,U))
.S $E(Y,40)=$$DATE^BGP1UTL($P(V,U,2))
.S $E(Y,50)=$$DATE^BGP1UTL($P(V,U,5))
.S $E(Y,60)=$$DATE^BGP1UTL($P(V,U,6))
.S $E(Y,70)=$$DATE^BGP1UTL($P(V,U,13))
.S BGPTIND(BGPSUC,0)=BGPTIND(BGPSUC,0)_Y
.S BGPTIND(BGPSUC,BGPSUC)=BGPX
.I $D(BGPSUL(BGPX)) S BGPTIND(BGPSUC,0)="*"_BGPTIND(BGPSUC,0)
.Q
S (VALMCNT,BGPHIGH)=BGPSUC
Q
;
ELD ;EP
K BGPTIND S BGPHIGH=""
S BGPSUCNT=0,BGPSU="",BGPSUC=0
S BGPX=0 F S BGPX=$O(^BGPELDCB(BGPX)) Q:BGPX'=+BGPX I BGPX S V=$G(^BGPELDCB(BGPX,0)) D
.Q:'$D(^BGPELDCB(BGPX,0))
.Q:$P(V,U)'=BGPBD
.Q:$P(V,U,2)'=BGPED
.Q:$P(V,U,7)'=BGPPER
.Q:$P(V,U,12)'=5
.Q:$P(V,U,5)'=BGPBBD
.Q:$P(V,U,6)'=BGPBED
.Q:$P(V,U,14)'=BGPBEN
.S BGPSUC=BGPSUC+1,BGPTIND(BGPSUC,0)=BGPSUC_")"
.S Y=""
.S $E(Y,4)=$E($$SU($P(V,U,11)),1,10)
.S $E(Y,15)=$E($$FAC($P(V,U,9)),1,13)_$S($P(^BGPELDCB(BGPX,0),U,17):"+",1:"")
.S $E(Y,30)=$$DATE^BGP1UTL($P(V,U))
.S $E(Y,40)=$$DATE^BGP1UTL($P(V,U,2))
.S $E(Y,50)=$$DATE^BGP1UTL($P(V,U,5))
.S $E(Y,60)=$$DATE^BGP1UTL($P(V,U,6))
.S $E(Y,70)=$$DATE^BGP1UTL($P(V,U,13))
.S BGPTIND(BGPSUC,0)=BGPTIND(BGPSUC,0)_Y
.S BGPTIND(BGPSUC,BGPSUC)=BGPX
.I $D(BGPSUL(BGPX)) S BGPTIND(BGPSUC,0)="*"_BGPTIND(BGPSUC,0)
.Q
S (VALMCNT,BGPHIGH)=BGPSUC
Q
;
HED ;EP
K BGPTIND S BGPHIGH=""
S BGPSUCNT=0,BGPSU="",BGPSUC=0
S BGPX=0 F S BGPX=$O(^BGPHEDCB(BGPX)) Q:'BGPX I BGPX S V=$G(^BGPHEDCB(BGPX,0)) D
.Q:'$D(^BGPHEDCB(BGPX,0))
.Q:$P(V,U)'=BGPBD
.Q:$P(V,U,2)'=BGPED
.Q:$P(V,U,7)'=BGPPER
.Q:$P(V,U,12)'=3
.Q:$P(V,U,5)'=BGPBBD
.Q:$P(V,U,6)'=BGPBED
.Q:$P(V,U,14)'=BGPBEN
.S BGPSUC=BGPSUC+1,BGPTIND(BGPSUC,0)=BGPSUC_")"
.S Y=""
.S $E(Y,4)=$E($$SU($P(V,U,11)),1,10)
.S $E(Y,15)=$E($$FAC($P(V,U,9)),1,13)_$S($P(^BGPHEDCB(BGPX,0),U,17):"+",1:"")
.S $E(Y,30)=$$DATE^BGP1UTL($P(V,U))
.S $E(Y,40)=$$DATE^BGP1UTL($P(V,U,2))
.S $E(Y,50)=$$DATE^BGP1UTL($P(V,U,5))
.S $E(Y,60)=$$DATE^BGP1UTL($P(V,U,6))
.S $E(Y,70)=$$DATE^BGP1UTL($P(V,U,13))
.S BGPTIND(BGPSUC,0)=BGPTIND(BGPSUC,0)_Y
.S BGPTIND(BGPSUC,BGPSUC)=BGPX
.I $D(BGPSUL(BGPX)) S BGPTIND(BGPSUC,0)="*"_BGPTIND(BGPSUC,0)
.Q
S (VALMCNT,BGPHIGH)=BGPSUC
Q
PED ;EP
K BGPTIND S BGPHIGH=""
S BGPSUCNT=0,BGPSU="",BGPSUC=0
S BGPX=0 F S BGPX=$O(^BGPPEDCB(BGPX)) Q:BGPX'=+BGPX I BGPX S V=$G(^BGPPEDCB(BGPX,0)) D
.Q:'$D(^BGPPEDCB(BGPX,0))
.Q:$P(V,U)'=BGPBD
.Q:$P(V,U,2)'=BGPED
.Q:$P(V,U,7)'=BGPPER
.Q:$P(V,U,5)'=BGPBBD
.Q:$P(V,U,6)'=BGPBED
.Q:$P(V,U,11)'=BGPBEN
.S BGPSUC=BGPSUC+1,BGPTIND(BGPSUC,0)=BGPSUC_")"
.S Y=""
.S $E(Y,4)=$E($$SU($P(V,U,10)),1,10)
.S $E(Y,15)=$E($$FAC($P(V,U,9)),1,13)_$S($P(^BGPPEDCB(BGPX,0),U,17):"+",1:"")
.S $E(Y,30)=$$DATE^BGP1UTL($P(V,U))
.S $E(Y,40)=$$DATE^BGP1UTL($P(V,U,2))
.S $E(Y,50)=$$DATE^BGP1UTL($P(V,U,5))
.S $E(Y,60)=$$DATE^BGP1UTL($P(V,U,6))
.S $E(Y,70)=$$DATE^BGP1UTL($P(V,U,13))
.S BGPTIND(BGPSUC,0)=BGPTIND(BGPSUC,0)_Y
.S BGPTIND(BGPSUC,BGPSUC)=BGPX
.I $D(BGPSUL(BGPX)) S BGPTIND(BGPSUC,0)="*"_BGPTIND(BGPSUC,0)
.Q
S (VALMCNT,BGPHIGH)=BGPSUC
Q
FAC(S) ;
NEW N S N=$O(^AUTTLOC("C",S,0))
I N="" Q N
Q $P(^DIC(4,N,0),U)
SU(S) ;
NEW N S N=$O(^AUTTSU("C",S,0))
I N="" Q N
Q $P(^AUTTSU(N,0),U)
EO ;EP
K BGPTIND S BGPHIGH=""
S BGPSUCNT=0,BGPSU="",BGPSUC=0
S BGPX=0 F S BGPX=$O(^BGPEOCB(BGPX)) Q:BGPX'=+BGPX I BGPX S V=$G(^BGPEOCB(BGPX,0)) D
.Q:'$D(^BGPEOCB(BGPX,0))
.Q:$P(V,U)'=BGPBD
.Q:$P(V,U,2)'=BGPED
.Q:$P(V,U,7)'=BGPPER
.Q:$P(V,U,12)'=8
.Q:$P(V,U,5)'=BGPBBD
.Q:$P(V,U,6)'=BGPBED
.Q:$P(V,U,14)'=BGPBEN
.S BGPSUC=BGPSUC+1,BGPTIND(BGPSUC,0)=BGPSUC_")"
.S Y=""
.S $E(Y,4)=$E($$SU($P(V,U,11)),1,10)
.S $E(Y,15)=$E($$FAC($P(V,U,9)),1,13)_$S($P(^BGPEOCB(BGPX,0),U,17):"+",1:"")
.S $E(Y,30)=$$DATE^BGP1UTL($P(V,U))
.S $E(Y,40)=$$DATE^BGP1UTL($P(V,U,2))
.S $E(Y,50)=$$DATE^BGP1UTL($P(V,U,5))
.S $E(Y,60)=$$DATE^BGP1UTL($P(V,U,6))
.S $E(Y,70)=$$DATE^BGP1UTL($P(V,U,13))
.S BGPTIND(BGPSUC,0)=BGPTIND(BGPSUC,0)_Y
.S BGPTIND(BGPSUC,BGPSUC)=BGPX
.I $D(BGPSUL(BGPX)) S BGPTIND(BGPSUC,0)="*"_BGPTIND(BGPSUC,0)
.Q
S (VALMCNT,BGPHIGH)=BGPSUC
Q
;
BGP1ASL1 ; IHS/CMI/LAB - DISPLAY IND LISTS 28 Apr 2006 2:10 PM ;
+1 ;;11.1;IHS CLINICAL REPORTING SYSTEM;;JUN 27, 2011;Build 33
+2 ;; ;
NGR ;EP
+1 KILL BGPTIND
SET BGPHIGH=""
+2 SET BGPSUCNT=0
SET BGPSU=""
SET BGPSUC=0
+3 SET BGPX=0
FOR
SET BGPX=$ORDER(^BGPGPDCB(BGPX))
IF BGPX'=+BGPX
QUIT
SET V=$GET(^BGPGPDCB(BGPX,0))
Begin DoDot:1
+4 IF '$DATA(^BGPGPDCB(BGPX,0))
QUIT
+5 IF $PIECE(V,U)'=BGPBD
QUIT
+6 IF $PIECE(V,U,2)'=BGPED
QUIT
+7 IF $PIECE(V,U,7)'=BGPPER
QUIT
+8 IF $GET(BGP1GPU)
IF $PIECE(V,U,12)'=9
QUIT
+9 IF '$GET(BGP1GPU)
IF $PIECE(V,U,12)'=1
QUIT
+10 IF $GET(BGPCHWE)
IF '$ORDER(^BGPGPDCB(BGPX,88888,0))
QUIT
+11 IF $PIECE(V,U,5)'=BGPBBD
QUIT
+12 IF $PIECE(V,U,6)'=BGPBED
QUIT
+13 IF $PIECE(V,U,14)'=BGPBEN
QUIT
+14 SET BGPSUC=BGPSUC+1
SET BGPTIND(BGPSUC,0)=BGPSUC_")"
+15 SET Y=""
+16 SET $EXTRACT(Y,4)=$EXTRACT($$SU($PIECE(V,U,11)),1,10)
+17 SET $EXTRACT(Y,15)=$EXTRACT($$FAC($PIECE(V,U,9)),1,13)_$SELECT($PIECE(^BGPGPDCB(BGPX,0),U,17):"+",1:"")
+18 SET $EXTRACT(Y,30)=$$DATE^BGP1UTL($PIECE(V,U))
+19 SET $EXTRACT(Y,40)=$$DATE^BGP1UTL($PIECE(V,U,2))
+20 SET $EXTRACT(Y,50)=$$DATE^BGP1UTL($PIECE(V,U,5))
+21 SET $EXTRACT(Y,60)=$$DATE^BGP1UTL($PIECE(V,U,6))
+22 SET $EXTRACT(Y,70)=$$DATE^BGP1UTL($PIECE(V,U,13))
+23 SET BGPTIND(BGPSUC,0)=BGPTIND(BGPSUC,0)_Y
+24 SET BGPTIND(BGPSUC,BGPSUC)=BGPX
+25 IF $DATA(BGPSUL(BGPX))
SET BGPTIND(BGPSUC,0)="*"_BGPTIND(BGPSUC,0)
+26 QUIT
End DoDot:1
+27 SET (VALMCNT,BGPHIGH)=BGPSUC
+28 QUIT
+29 ;
ONM ;EP
+1 KILL BGPTIND
SET BGPHIGH=""
+2 SET BGPSUCNT=0
SET BGPSU=""
SET BGPSUC=0
+3 SET BGPX=0
FOR
SET BGPX=$ORDER(^BGPGPDCB(BGPX))
IF BGPX'=+BGPX
QUIT
SET V=$GET(^BGPGPDCB(BGPX,0))
Begin DoDot:1
+4 IF '$DATA(^BGPGPDCB(BGPX,0))
QUIT
+5 IF $PIECE(V,U)'=BGPBD
QUIT
+6 IF $PIECE(V,U,2)'=BGPED
QUIT
+7 IF $PIECE(V,U,7)'=BGPPER
QUIT
+8 IF $PIECE(V,U,5)'=BGPBBD
QUIT
+9 IF $PIECE(V,U,6)'=BGPBED
QUIT
+10 IF $PIECE(V,U,14)'=BGPBEN
QUIT
+11 IF $PIECE(V,U,12)'=7
QUIT
+12 SET BGPSUC=BGPSUC+1
SET BGPTIND(BGPSUC,0)=BGPSUC_")"
+13 SET Y=""
+14 SET $EXTRACT(Y,4)=$EXTRACT($$SU($PIECE(V,U,11)),1,10)
+15 SET $EXTRACT(Y,15)=$EXTRACT($$FAC($PIECE(V,U,9)),1,13)_$SELECT($PIECE(^BGPGPDCB(BGPX,0),U,17):"+",1:"")
+16 SET $EXTRACT(Y,30)=$$DATE^BGP1UTL($PIECE(V,U))
+17 SET $EXTRACT(Y,40)=$$DATE^BGP1UTL($PIECE(V,U,2))
+18 SET $EXTRACT(Y,50)=$$DATE^BGP1UTL($PIECE(V,U,5))
+19 SET $EXTRACT(Y,60)=$$DATE^BGP1UTL($PIECE(V,U,6))
+20 SET $EXTRACT(Y,70)=$$DATE^BGP1UTL($PIECE(V,U,13))
+21 SET BGPTIND(BGPSUC,0)=BGPTIND(BGPSUC,0)_Y
+22 SET BGPTIND(BGPSUC,BGPSUC)=BGPX
+23 IF $DATA(BGPSUL(BGPX))
SET BGPTIND(BGPSUC,0)="*"_BGPTIND(BGPSUC,0)
+24 QUIT
End DoDot:1
+25 SET (VALMCNT,BGPHIGH)=BGPSUC
+26 QUIT
+27 ;
ELD ;EP
+1 KILL BGPTIND
SET BGPHIGH=""
+2 SET BGPSUCNT=0
SET BGPSU=""
SET BGPSUC=0
+3 SET BGPX=0
FOR
SET BGPX=$ORDER(^BGPELDCB(BGPX))
IF BGPX'=+BGPX
QUIT
IF BGPX
SET V=$GET(^BGPELDCB(BGPX,0))
Begin DoDot:1
+4 IF '$DATA(^BGPELDCB(BGPX,0))
QUIT
+5 IF $PIECE(V,U)'=BGPBD
QUIT
+6 IF $PIECE(V,U,2)'=BGPED
QUIT
+7 IF $PIECE(V,U,7)'=BGPPER
QUIT
+8 IF $PIECE(V,U,12)'=5
QUIT
+9 IF $PIECE(V,U,5)'=BGPBBD
QUIT
+10 IF $PIECE(V,U,6)'=BGPBED
QUIT
+11 IF $PIECE(V,U,14)'=BGPBEN
QUIT
+12 SET BGPSUC=BGPSUC+1
SET BGPTIND(BGPSUC,0)=BGPSUC_")"
+13 SET Y=""
+14 SET $EXTRACT(Y,4)=$EXTRACT($$SU($PIECE(V,U,11)),1,10)
+15 SET $EXTRACT(Y,15)=$EXTRACT($$FAC($PIECE(V,U,9)),1,13)_$SELECT($PIECE(^BGPELDCB(BGPX,0),U,17):"+",1:"")
+16 SET $EXTRACT(Y,30)=$$DATE^BGP1UTL($PIECE(V,U))
+17 SET $EXTRACT(Y,40)=$$DATE^BGP1UTL($PIECE(V,U,2))
+18 SET $EXTRACT(Y,50)=$$DATE^BGP1UTL($PIECE(V,U,5))
+19 SET $EXTRACT(Y,60)=$$DATE^BGP1UTL($PIECE(V,U,6))
+20 SET $EXTRACT(Y,70)=$$DATE^BGP1UTL($PIECE(V,U,13))
+21 SET BGPTIND(BGPSUC,0)=BGPTIND(BGPSUC,0)_Y
+22 SET BGPTIND(BGPSUC,BGPSUC)=BGPX
+23 IF $DATA(BGPSUL(BGPX))
SET BGPTIND(BGPSUC,0)="*"_BGPTIND(BGPSUC,0)
+24 QUIT
End DoDot:1
+25 SET (VALMCNT,BGPHIGH)=BGPSUC
+26 QUIT
+27 ;
HED ;EP
+1 KILL BGPTIND
SET BGPHIGH=""
+2 SET BGPSUCNT=0
SET BGPSU=""
SET BGPSUC=0
+3 SET BGPX=0
FOR
SET BGPX=$ORDER(^BGPHEDCB(BGPX))
IF 'BGPX
QUIT
IF BGPX
SET V=$GET(^BGPHEDCB(BGPX,0))
Begin DoDot:1
+4 IF '$DATA(^BGPHEDCB(BGPX,0))
QUIT
+5 IF $PIECE(V,U)'=BGPBD
QUIT
+6 IF $PIECE(V,U,2)'=BGPED
QUIT
+7 IF $PIECE(V,U,7)'=BGPPER
QUIT
+8 IF $PIECE(V,U,12)'=3
QUIT
+9 IF $PIECE(V,U,5)'=BGPBBD
QUIT
+10 IF $PIECE(V,U,6)'=BGPBED
QUIT
+11 IF $PIECE(V,U,14)'=BGPBEN
QUIT
+12 SET BGPSUC=BGPSUC+1
SET BGPTIND(BGPSUC,0)=BGPSUC_")"
+13 SET Y=""
+14 SET $EXTRACT(Y,4)=$EXTRACT($$SU($PIECE(V,U,11)),1,10)
+15 SET $EXTRACT(Y,15)=$EXTRACT($$FAC($PIECE(V,U,9)),1,13)_$SELECT($PIECE(^BGPHEDCB(BGPX,0),U,17):"+",1:"")
+16 SET $EXTRACT(Y,30)=$$DATE^BGP1UTL($PIECE(V,U))
+17 SET $EXTRACT(Y,40)=$$DATE^BGP1UTL($PIECE(V,U,2))
+18 SET $EXTRACT(Y,50)=$$DATE^BGP1UTL($PIECE(V,U,5))
+19 SET $EXTRACT(Y,60)=$$DATE^BGP1UTL($PIECE(V,U,6))
+20 SET $EXTRACT(Y,70)=$$DATE^BGP1UTL($PIECE(V,U,13))
+21 SET BGPTIND(BGPSUC,0)=BGPTIND(BGPSUC,0)_Y
+22 SET BGPTIND(BGPSUC,BGPSUC)=BGPX
+23 IF $DATA(BGPSUL(BGPX))
SET BGPTIND(BGPSUC,0)="*"_BGPTIND(BGPSUC,0)
+24 QUIT
End DoDot:1
+25 SET (VALMCNT,BGPHIGH)=BGPSUC
+26 QUIT
PED ;EP
+1 KILL BGPTIND
SET BGPHIGH=""
+2 SET BGPSUCNT=0
SET BGPSU=""
SET BGPSUC=0
+3 SET BGPX=0
FOR
SET BGPX=$ORDER(^BGPPEDCB(BGPX))
IF BGPX'=+BGPX
QUIT
IF BGPX
SET V=$GET(^BGPPEDCB(BGPX,0))
Begin DoDot:1
+4 IF '$DATA(^BGPPEDCB(BGPX,0))
QUIT
+5 IF $PIECE(V,U)'=BGPBD
QUIT
+6 IF $PIECE(V,U,2)'=BGPED
QUIT
+7 IF $PIECE(V,U,7)'=BGPPER
QUIT
+8 IF $PIECE(V,U,5)'=BGPBBD
QUIT
+9 IF $PIECE(V,U,6)'=BGPBED
QUIT
+10 IF $PIECE(V,U,11)'=BGPBEN
QUIT
+11 SET BGPSUC=BGPSUC+1
SET BGPTIND(BGPSUC,0)=BGPSUC_")"
+12 SET Y=""
+13 SET $EXTRACT(Y,4)=$EXTRACT($$SU($PIECE(V,U,10)),1,10)
+14 SET $EXTRACT(Y,15)=$EXTRACT($$FAC($PIECE(V,U,9)),1,13)_$SELECT($PIECE(^BGPPEDCB(BGPX,0),U,17):"+",1:"")
+15 SET $EXTRACT(Y,30)=$$DATE^BGP1UTL($PIECE(V,U))
+16 SET $EXTRACT(Y,40)=$$DATE^BGP1UTL($PIECE(V,U,2))
+17 SET $EXTRACT(Y,50)=$$DATE^BGP1UTL($PIECE(V,U,5))
+18 SET $EXTRACT(Y,60)=$$DATE^BGP1UTL($PIECE(V,U,6))
+19 SET $EXTRACT(Y,70)=$$DATE^BGP1UTL($PIECE(V,U,13))
+20 SET BGPTIND(BGPSUC,0)=BGPTIND(BGPSUC,0)_Y
+21 SET BGPTIND(BGPSUC,BGPSUC)=BGPX
+22 IF $DATA(BGPSUL(BGPX))
SET BGPTIND(BGPSUC,0)="*"_BGPTIND(BGPSUC,0)
+23 QUIT
End DoDot:1
+24 SET (VALMCNT,BGPHIGH)=BGPSUC
+25 QUIT
FAC(S) ;
+1 NEW N
SET N=$ORDER(^AUTTLOC("C",S,0))
+2 IF N=""
QUIT N
+3 QUIT $PIECE(^DIC(4,N,0),U)
SU(S) ;
+1 NEW N
SET N=$ORDER(^AUTTSU("C",S,0))
+2 IF N=""
QUIT N
+3 QUIT $PIECE(^AUTTSU(N,0),U)
EO ;EP
+1 KILL BGPTIND
SET BGPHIGH=""
+2 SET BGPSUCNT=0
SET BGPSU=""
SET BGPSUC=0
+3 SET BGPX=0
FOR
SET BGPX=$ORDER(^BGPEOCB(BGPX))
IF BGPX'=+BGPX
QUIT
IF BGPX
SET V=$GET(^BGPEOCB(BGPX,0))
Begin DoDot:1
+4 IF '$DATA(^BGPEOCB(BGPX,0))
QUIT
+5 IF $PIECE(V,U)'=BGPBD
QUIT
+6 IF $PIECE(V,U,2)'=BGPED
QUIT
+7 IF $PIECE(V,U,7)'=BGPPER
QUIT
+8 IF $PIECE(V,U,12)'=8
QUIT
+9 IF $PIECE(V,U,5)'=BGPBBD
QUIT
+10 IF $PIECE(V,U,6)'=BGPBED
QUIT
+11 IF $PIECE(V,U,14)'=BGPBEN
QUIT
+12 SET BGPSUC=BGPSUC+1
SET BGPTIND(BGPSUC,0)=BGPSUC_")"
+13 SET Y=""
+14 SET $EXTRACT(Y,4)=$EXTRACT($$SU($PIECE(V,U,11)),1,10)
+15 SET $EXTRACT(Y,15)=$EXTRACT($$FAC($PIECE(V,U,9)),1,13)_$SELECT($PIECE(^BGPEOCB(BGPX,0),U,17):"+",1:"")
+16 SET $EXTRACT(Y,30)=$$DATE^BGP1UTL($PIECE(V,U))
+17 SET $EXTRACT(Y,40)=$$DATE^BGP1UTL($PIECE(V,U,2))
+18 SET $EXTRACT(Y,50)=$$DATE^BGP1UTL($PIECE(V,U,5))
+19 SET $EXTRACT(Y,60)=$$DATE^BGP1UTL($PIECE(V,U,6))
+20 SET $EXTRACT(Y,70)=$$DATE^BGP1UTL($PIECE(V,U,13))
+21 SET BGPTIND(BGPSUC,0)=BGPTIND(BGPSUC,0)_Y
+22 SET BGPTIND(BGPSUC,BGPSUC)=BGPX
+23 IF $DATA(BGPSUL(BGPX))
SET BGPTIND(BGPSUC,0)="*"_BGPTIND(BGPSUC,0)
+24 QUIT
End DoDot:1
+25 SET (VALMCNT,BGPHIGH)=BGPSUC
+26 QUIT
+27 ;
