- BGP9ASL1 ; IHS/CMI/LAB - DISPLAY IND LISTS 28 Apr 2006 2:10 PM ;
- ;;9.0;IHS CLINICAL REPORTING;;JUL 1, 2009
- ;; ;
- NGR ;EP
- K BGPTIND S BGPHIGH=""
- S BGPSUCNT=0,BGPSU="",BGPSUC=0
- S BGPX=0 F S BGPX=$O(^BGPGPDCN(BGPX)) Q:BGPX'=+BGPX S V=$G(^BGPGPDCN(BGPX,0)) D
- .Q:$P(V,U)'=BGPBD
- .Q:$P(V,U,2)'=BGPED
- .Q:$P(V,U,7)'=BGPPER
- .I $G(BGP9GPU),$P(V,U,12)'=9 Q
- .I '$G(BGP9GPU),$P(V,U,12)'=1 Q
- .I $G(BGPCHWE) Q:'$O(^BGPGPDCN(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(^BGPGPDCN(BGPX,0),U,17):"+",1:"")
- .S $E(Y,30)=$$DATE^BGP9UTL($P(V,U))
- .S $E(Y,40)=$$DATE^BGP9UTL($P(V,U,2))
- .S $E(Y,50)=$$DATE^BGP9UTL($P(V,U,5))
- .S $E(Y,60)=$$DATE^BGP9UTL($P(V,U,6))
- .S $E(Y,70)=$$DATE^BGP9UTL($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(^BGPGPDCN(BGPX)) Q:BGPX'=+BGPX S V=$G(^BGPGPDCN(BGPX,0)) D
- .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(^BGPGPDCN(BGPX,0),U,17):"+",1:"")
- .S $E(Y,30)=$$DATE^BGP9UTL($P(V,U))
- .S $E(Y,40)=$$DATE^BGP9UTL($P(V,U,2))
- .S $E(Y,50)=$$DATE^BGP9UTL($P(V,U,5))
- .S $E(Y,60)=$$DATE^BGP9UTL($P(V,U,6))
- .S $E(Y,70)=$$DATE^BGP9UTL($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(^BGPELDCN(BGPX)) Q:BGPX'=+BGPX I BGPX S V=$G(^BGPELDCN(BGPX,0)) D
- .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(^BGPELDCN(BGPX,0),U,17):"+",1:"")
- .S $E(Y,30)=$$DATE^BGP9UTL($P(V,U))
- .S $E(Y,40)=$$DATE^BGP9UTL($P(V,U,2))
- .S $E(Y,50)=$$DATE^BGP9UTL($P(V,U,5))
- .S $E(Y,60)=$$DATE^BGP9UTL($P(V,U,6))
- .S $E(Y,70)=$$DATE^BGP9UTL($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(^BGPHEDCN(BGPX)) Q:'BGPX I BGPX S V=$G(^BGPHEDCN(BGPX,0)) D
- .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(^BGPHEDCN(BGPX,0),U,17):"+",1:"")
- .S $E(Y,30)=$$DATE^BGP9UTL($P(V,U))
- .S $E(Y,40)=$$DATE^BGP9UTL($P(V,U,2))
- .S $E(Y,50)=$$DATE^BGP9UTL($P(V,U,5))
- .S $E(Y,60)=$$DATE^BGP9UTL($P(V,U,6))
- .S $E(Y,70)=$$DATE^BGP9UTL($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(^BGPPEDCN(BGPX)) Q:BGPX'=+BGPX I BGPX S V=$G(^BGPPEDCN(BGPX,0)) D
- .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(^BGPPEDCN(BGPX,0),U,17):"+",1:"")
- .S $E(Y,30)=$$DATE^BGP9UTL($P(V,U))
- .S $E(Y,40)=$$DATE^BGP9UTL($P(V,U,2))
- .S $E(Y,50)=$$DATE^BGP9UTL($P(V,U,5))
- .S $E(Y,60)=$$DATE^BGP9UTL($P(V,U,6))
- .S $E(Y,70)=$$DATE^BGP9UTL($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(^BGPEOCN(BGPX)) Q:BGPX'=+BGPX I BGPX S V=$G(^BGPEOCN(BGPX,0)) D
- .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(^BGPEOCN(BGPX,0),U,17):"+",1:"")
- .S $E(Y,30)=$$DATE^BGP9UTL($P(V,U))
- .S $E(Y,40)=$$DATE^BGP9UTL($P(V,U,2))
- .S $E(Y,50)=$$DATE^BGP9UTL($P(V,U,5))
- .S $E(Y,60)=$$DATE^BGP9UTL($P(V,U,6))
- .S $E(Y,70)=$$DATE^BGP9UTL($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
- ;
- BGP9ASL1 ; IHS/CMI/LAB - DISPLAY IND LISTS 28 Apr 2006 2:10 PM ;
- +1 ;;9.0;IHS CLINICAL REPORTING;;JUL 1, 2009
- +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(^BGPGPDCN(BGPX))
- IF BGPX'=+BGPX
- QUIT
- SET V=$GET(^BGPGPDCN(BGPX,0))
- Begin DoDot:1
- +4 IF $PIECE(V,U)'=BGPBD
- QUIT
- +5 IF $PIECE(V,U,2)'=BGPED
- QUIT
- +6 IF $PIECE(V,U,7)'=BGPPER
- QUIT
- +7 IF $GET(BGP9GPU)
- IF $PIECE(V,U,12)'=9
- QUIT
- +8 IF '$GET(BGP9GPU)
- IF $PIECE(V,U,12)'=1
- QUIT
- +9 IF $GET(BGPCHWE)
- IF '$ORDER(^BGPGPDCN(BGPX,88888,0))
- QUIT
- +10 IF $PIECE(V,U,5)'=BGPBBD
- QUIT
- +11 IF $PIECE(V,U,6)'=BGPBED
- QUIT
- +12 IF $PIECE(V,U,14)'=BGPBEN
- QUIT
- +13 SET BGPSUC=BGPSUC+1
- SET BGPTIND(BGPSUC,0)=BGPSUC_")"
- +14 SET Y=""
- +15 SET $EXTRACT(Y,4)=$EXTRACT($$SU($PIECE(V,U,11)),1,10)
- +16 SET $EXTRACT(Y,15)=$EXTRACT($$FAC($PIECE(V,U,9)),1,13)_$SELECT($PIECE(^BGPGPDCN(BGPX,0),U,17):"+",1:"")
- +17 SET $EXTRACT(Y,30)=$$DATE^BGP9UTL($PIECE(V,U))
- +18 SET $EXTRACT(Y,40)=$$DATE^BGP9UTL($PIECE(V,U,2))
- +19 SET $EXTRACT(Y,50)=$$DATE^BGP9UTL($PIECE(V,U,5))
- +20 SET $EXTRACT(Y,60)=$$DATE^BGP9UTL($PIECE(V,U,6))
- +21 SET $EXTRACT(Y,70)=$$DATE^BGP9UTL($PIECE(V,U,13))
- +22 SET BGPTIND(BGPSUC,0)=BGPTIND(BGPSUC,0)_Y
- +23 SET BGPTIND(BGPSUC,BGPSUC)=BGPX
- +24 IF $DATA(BGPSUL(BGPX))
- SET BGPTIND(BGPSUC,0)="*"_BGPTIND(BGPSUC,0)
- +25 QUIT
- End DoDot:1
- +26 SET (VALMCNT,BGPHIGH)=BGPSUC
- +27 QUIT
- +28 ;
- ONM ;EP
- +1 KILL BGPTIND
- SET BGPHIGH=""
- +2 SET BGPSUCNT=0
- SET BGPSU=""
- SET BGPSUC=0
- +3 SET BGPX=0
- FOR
- SET BGPX=$ORDER(^BGPGPDCN(BGPX))
- IF BGPX'=+BGPX
- QUIT
- SET V=$GET(^BGPGPDCN(BGPX,0))
- Begin DoDot:1
- +4 IF $PIECE(V,U)'=BGPBD
- QUIT
- +5 IF $PIECE(V,U,2)'=BGPED
- QUIT
- +6 IF $PIECE(V,U,7)'=BGPPER
- QUIT
- +7 IF $PIECE(V,U,5)'=BGPBBD
- QUIT
- +8 IF $PIECE(V,U,6)'=BGPBED
- QUIT
- +9 IF $PIECE(V,U,14)'=BGPBEN
- QUIT
- +10 IF $PIECE(V,U,12)'=7
- QUIT
- +11 SET BGPSUC=BGPSUC+1
- SET BGPTIND(BGPSUC,0)=BGPSUC_")"
- +12 SET Y=""
- +13 SET $EXTRACT(Y,4)=$EXTRACT($$SU($PIECE(V,U,11)),1,10)
- +14 SET $EXTRACT(Y,15)=$EXTRACT($$FAC($PIECE(V,U,9)),1,13)_$SELECT($PIECE(^BGPGPDCN(BGPX,0),U,17):"+",1:"")
- +15 SET $EXTRACT(Y,30)=$$DATE^BGP9UTL($PIECE(V,U))
- +16 SET $EXTRACT(Y,40)=$$DATE^BGP9UTL($PIECE(V,U,2))
- +17 SET $EXTRACT(Y,50)=$$DATE^BGP9UTL($PIECE(V,U,5))
- +18 SET $EXTRACT(Y,60)=$$DATE^BGP9UTL($PIECE(V,U,6))
- +19 SET $EXTRACT(Y,70)=$$DATE^BGP9UTL($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
- +26 ;
- ELD ;EP
- +1 KILL BGPTIND
- SET BGPHIGH=""
- +2 SET BGPSUCNT=0
- SET BGPSU=""
- SET BGPSUC=0
- +3 SET BGPX=0
- FOR
- SET BGPX=$ORDER(^BGPELDCN(BGPX))
- IF BGPX'=+BGPX
- QUIT
- IF BGPX
- SET V=$GET(^BGPELDCN(BGPX,0))
- Begin DoDot:1
- +4 IF $PIECE(V,U)'=BGPBD
- QUIT
- +5 IF $PIECE(V,U,2)'=BGPED
- QUIT
- +6 IF $PIECE(V,U,7)'=BGPPER
- QUIT
- +7 IF $PIECE(V,U,12)'=5
- 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 SET BGPSUC=BGPSUC+1
- SET BGPTIND(BGPSUC,0)=BGPSUC_")"
- +12 SET Y=""
- +13 SET $EXTRACT(Y,4)=$EXTRACT($$SU($PIECE(V,U,11)),1,10)
- +14 SET $EXTRACT(Y,15)=$EXTRACT($$FAC($PIECE(V,U,9)),1,13)_$SELECT($PIECE(^BGPELDCN(BGPX,0),U,17):"+",1:"")
- +15 SET $EXTRACT(Y,30)=$$DATE^BGP9UTL($PIECE(V,U))
- +16 SET $EXTRACT(Y,40)=$$DATE^BGP9UTL($PIECE(V,U,2))
- +17 SET $EXTRACT(Y,50)=$$DATE^BGP9UTL($PIECE(V,U,5))
- +18 SET $EXTRACT(Y,60)=$$DATE^BGP9UTL($PIECE(V,U,6))
- +19 SET $EXTRACT(Y,70)=$$DATE^BGP9UTL($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
- +26 ;
- HED ;EP
- +1 KILL BGPTIND
- SET BGPHIGH=""
- +2 SET BGPSUCNT=0
- SET BGPSU=""
- SET BGPSUC=0
- +3 SET BGPX=0
- FOR
- SET BGPX=$ORDER(^BGPHEDCN(BGPX))
- IF 'BGPX
- QUIT
- IF BGPX
- SET V=$GET(^BGPHEDCN(BGPX,0))
- Begin DoDot:1
- +4 IF $PIECE(V,U)'=BGPBD
- QUIT
- +5 IF $PIECE(V,U,2)'=BGPED
- QUIT
- +6 IF $PIECE(V,U,7)'=BGPPER
- QUIT
- +7 IF $PIECE(V,U,12)'=3
- 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 SET BGPSUC=BGPSUC+1
- SET BGPTIND(BGPSUC,0)=BGPSUC_")"
- +12 SET Y=""
- +13 SET $EXTRACT(Y,4)=$EXTRACT($$SU($PIECE(V,U,11)),1,10)
- +14 SET $EXTRACT(Y,15)=$EXTRACT($$FAC($PIECE(V,U,9)),1,13)_$SELECT($PIECE(^BGPHEDCN(BGPX,0),U,17):"+",1:"")
- +15 SET $EXTRACT(Y,30)=$$DATE^BGP9UTL($PIECE(V,U))
- +16 SET $EXTRACT(Y,40)=$$DATE^BGP9UTL($PIECE(V,U,2))
- +17 SET $EXTRACT(Y,50)=$$DATE^BGP9UTL($PIECE(V,U,5))
- +18 SET $EXTRACT(Y,60)=$$DATE^BGP9UTL($PIECE(V,U,6))
- +19 SET $EXTRACT(Y,70)=$$DATE^BGP9UTL($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
- PED ;EP
- +1 KILL BGPTIND
- SET BGPHIGH=""
- +2 SET BGPSUCNT=0
- SET BGPSU=""
- SET BGPSUC=0
- +3 SET BGPX=0
- FOR
- SET BGPX=$ORDER(^BGPPEDCN(BGPX))
- IF BGPX'=+BGPX
- QUIT
- IF BGPX
- SET V=$GET(^BGPPEDCN(BGPX,0))
- Begin DoDot:1
- +4 IF $PIECE(V,U)'=BGPBD
- QUIT
- +5 IF $PIECE(V,U,2)'=BGPED
- QUIT
- +6 IF $PIECE(V,U,7)'=BGPPER
- QUIT
- +7 IF $PIECE(V,U,5)'=BGPBBD
- QUIT
- +8 IF $PIECE(V,U,6)'=BGPBED
- QUIT
- +9 IF $PIECE(V,U,11)'=BGPBEN
- QUIT
- +10 SET BGPSUC=BGPSUC+1
- SET BGPTIND(BGPSUC,0)=BGPSUC_")"
- +11 SET Y=""
- +12 SET $EXTRACT(Y,4)=$EXTRACT($$SU($PIECE(V,U,10)),1,10)
- +13 SET $EXTRACT(Y,15)=$EXTRACT($$FAC($PIECE(V,U,9)),1,13)_$SELECT($PIECE(^BGPPEDCN(BGPX,0),U,17):"+",1:"")
- +14 SET $EXTRACT(Y,30)=$$DATE^BGP9UTL($PIECE(V,U))
- +15 SET $EXTRACT(Y,40)=$$DATE^BGP9UTL($PIECE(V,U,2))
- +16 SET $EXTRACT(Y,50)=$$DATE^BGP9UTL($PIECE(V,U,5))
- +17 SET $EXTRACT(Y,60)=$$DATE^BGP9UTL($PIECE(V,U,6))
- +18 SET $EXTRACT(Y,70)=$$DATE^BGP9UTL($PIECE(V,U,13))
- +19 SET BGPTIND(BGPSUC,0)=BGPTIND(BGPSUC,0)_Y
- +20 SET BGPTIND(BGPSUC,BGPSUC)=BGPX
- +21 IF $DATA(BGPSUL(BGPX))
- SET BGPTIND(BGPSUC,0)="*"_BGPTIND(BGPSUC,0)
- +22 QUIT
- End DoDot:1
- +23 SET (VALMCNT,BGPHIGH)=BGPSUC
- +24 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(^BGPEOCN(BGPX))
- IF BGPX'=+BGPX
- QUIT
- IF BGPX
- SET V=$GET(^BGPEOCN(BGPX,0))
- Begin DoDot:1
- +4 IF $PIECE(V,U)'=BGPBD
- QUIT
- +5 IF $PIECE(V,U,2)'=BGPED
- QUIT
- +6 IF $PIECE(V,U,7)'=BGPPER
- QUIT
- +7 IF $PIECE(V,U,12)'=8
- 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 SET BGPSUC=BGPSUC+1
- SET BGPTIND(BGPSUC,0)=BGPSUC_")"
- +12 SET Y=""
- +13 SET $EXTRACT(Y,4)=$EXTRACT($$SU($PIECE(V,U,11)),1,10)
- +14 SET $EXTRACT(Y,15)=$EXTRACT($$FAC($PIECE(V,U,9)),1,13)_$SELECT($PIECE(^BGPEOCN(BGPX,0),U,17):"+",1:"")
- +15 SET $EXTRACT(Y,30)=$$DATE^BGP9UTL($PIECE(V,U))
- +16 SET $EXTRACT(Y,40)=$$DATE^BGP9UTL($PIECE(V,U,2))
- +17 SET $EXTRACT(Y,50)=$$DATE^BGP9UTL($PIECE(V,U,5))
- +18 SET $EXTRACT(Y,60)=$$DATE^BGP9UTL($PIECE(V,U,6))
- +19 SET $EXTRACT(Y,70)=$$DATE^BGP9UTL($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
- +26 ;
