- BGP2ASL1 ; IHS/CMI/LAB - DISPLAY IND LISTS 28 Apr 2006 2:10 PM ;
- ;;12.1;IHS CLINICAL REPORTING;;MAY 17, 2012;Build 66
- ;; ;
- NGR ;EP
- K BGPTIND S BGPHIGH=""
- S BGPSUCNT=0,BGPSU="",BGPSUC=0
- S BGPX=0 F S BGPX=$O(^BGPGPDCW(BGPX)) Q:BGPX'=+BGPX S V=$G(^BGPGPDCW(BGPX,0)) D
- .Q:'$D(^BGPGPDCW(BGPX,0))
- .Q:$P(V,U)'=BGPBD
- .Q:$P(V,U,2)'=BGPED
- .Q:$P(V,U,7)'=BGPPER
- .I $G(BGPYGPU),$P(V,U,12)'=9 Q
- .I '$G(BGPYGPU),$P(V,U,12)'=1 Q
- .I $G(BGPCHWE) Q:'$O(^BGPGPDCW(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(^BGPGPDCW(BGPX,0),U,17):"+",1:"")
- .S $E(Y,30)=$$DATE^BGP2UTL($P(V,U))
- .S $E(Y,40)=$$DATE^BGP2UTL($P(V,U,2))
- .S $E(Y,50)=$$DATE^BGP2UTL($P(V,U,5))
- .S $E(Y,60)=$$DATE^BGP2UTL($P(V,U,6))
- .S $E(Y,70)=$$DATE^BGP2UTL($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(^BGPGPDCW(BGPX)) Q:BGPX'=+BGPX S V=$G(^BGPGPDCW(BGPX,0)) D
- .Q:'$D(^BGPGPDCW(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(^BGPGPDCW(BGPX,0),U,17):"+",1:"")
- .S $E(Y,30)=$$DATE^BGP2UTL($P(V,U))
- .S $E(Y,40)=$$DATE^BGP2UTL($P(V,U,2))
- .S $E(Y,50)=$$DATE^BGP2UTL($P(V,U,5))
- .S $E(Y,60)=$$DATE^BGP2UTL($P(V,U,6))
- .S $E(Y,70)=$$DATE^BGP2UTL($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(^BGPELDCW(BGPX)) Q:BGPX'=+BGPX I BGPX S V=$G(^BGPELDCW(BGPX,0)) D
- .Q:'$D(^BGPELDCW(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(^BGPELDCW(BGPX,0),U,17):"+",1:"")
- .S $E(Y,30)=$$DATE^BGP2UTL($P(V,U))
- .S $E(Y,40)=$$DATE^BGP2UTL($P(V,U,2))
- .S $E(Y,50)=$$DATE^BGP2UTL($P(V,U,5))
- .S $E(Y,60)=$$DATE^BGP2UTL($P(V,U,6))
- .S $E(Y,70)=$$DATE^BGP2UTL($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^BGP2UTL($P(V,U))
- .S $E(Y,40)=$$DATE^BGP2UTL($P(V,U,2))
- .S $E(Y,50)=$$DATE^BGP2UTL($P(V,U,5))
- .S $E(Y,60)=$$DATE^BGP2UTL($P(V,U,6))
- .S $E(Y,70)=$$DATE^BGP2UTL($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(^BGPPEDCW(BGPX)) Q:BGPX'=+BGPX I BGPX S V=$G(^BGPPEDCW(BGPX,0)) D
- .Q:'$D(^BGPPEDCW(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(^BGPPEDCW(BGPX,0),U,17):"+",1:"")
- .S $E(Y,30)=$$DATE^BGP2UTL($P(V,U))
- .S $E(Y,40)=$$DATE^BGP2UTL($P(V,U,2))
- .S $E(Y,50)=$$DATE^BGP2UTL($P(V,U,5))
- .S $E(Y,60)=$$DATE^BGP2UTL($P(V,U,6))
- .S $E(Y,70)=$$DATE^BGP2UTL($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^BGP2UTL($P(V,U))
- .S $E(Y,40)=$$DATE^BGP2UTL($P(V,U,2))
- .S $E(Y,50)=$$DATE^BGP2UTL($P(V,U,5))
- .S $E(Y,60)=$$DATE^BGP2UTL($P(V,U,6))
- .S $E(Y,70)=$$DATE^BGP2UTL($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
- ;
- BGP2ASL1 ; IHS/CMI/LAB - DISPLAY IND LISTS 28 Apr 2006 2:10 PM ;
- +1 ;;12.1;IHS CLINICAL REPORTING;;MAY 17, 2012;Build 66
- +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(^BGPGPDCW(BGPX))
- IF BGPX'=+BGPX
- QUIT
- SET V=$GET(^BGPGPDCW(BGPX,0))
- Begin DoDot:1
- +4 IF '$DATA(^BGPGPDCW(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(BGPYGPU)
- IF $PIECE(V,U,12)'=9
- QUIT
- +9 IF '$GET(BGPYGPU)
- IF $PIECE(V,U,12)'=1
- QUIT
- +10 IF $GET(BGPCHWE)
- IF '$ORDER(^BGPGPDCW(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(^BGPGPDCW(BGPX,0),U,17):"+",1:"")
- +18 SET $EXTRACT(Y,30)=$$DATE^BGP2UTL($PIECE(V,U))
- +19 SET $EXTRACT(Y,40)=$$DATE^BGP2UTL($PIECE(V,U,2))
- +20 SET $EXTRACT(Y,50)=$$DATE^BGP2UTL($PIECE(V,U,5))
- +21 SET $EXTRACT(Y,60)=$$DATE^BGP2UTL($PIECE(V,U,6))
- +22 SET $EXTRACT(Y,70)=$$DATE^BGP2UTL($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(^BGPGPDCW(BGPX))
- IF BGPX'=+BGPX
- QUIT
- SET V=$GET(^BGPGPDCW(BGPX,0))
- Begin DoDot:1
- +4 IF '$DATA(^BGPGPDCW(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(^BGPGPDCW(BGPX,0),U,17):"+",1:"")
- +16 SET $EXTRACT(Y,30)=$$DATE^BGP2UTL($PIECE(V,U))
- +17 SET $EXTRACT(Y,40)=$$DATE^BGP2UTL($PIECE(V,U,2))
- +18 SET $EXTRACT(Y,50)=$$DATE^BGP2UTL($PIECE(V,U,5))
- +19 SET $EXTRACT(Y,60)=$$DATE^BGP2UTL($PIECE(V,U,6))
- +20 SET $EXTRACT(Y,70)=$$DATE^BGP2UTL($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(^BGPELDCW(BGPX))
- IF BGPX'=+BGPX
- QUIT
- IF BGPX
- SET V=$GET(^BGPELDCW(BGPX,0))
- Begin DoDot:1
- +4 IF '$DATA(^BGPELDCW(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(^BGPELDCW(BGPX,0),U,17):"+",1:"")
- +16 SET $EXTRACT(Y,30)=$$DATE^BGP2UTL($PIECE(V,U))
- +17 SET $EXTRACT(Y,40)=$$DATE^BGP2UTL($PIECE(V,U,2))
- +18 SET $EXTRACT(Y,50)=$$DATE^BGP2UTL($PIECE(V,U,5))
- +19 SET $EXTRACT(Y,60)=$$DATE^BGP2UTL($PIECE(V,U,6))
- +20 SET $EXTRACT(Y,70)=$$DATE^BGP2UTL($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^BGP2UTL($PIECE(V,U))
- +17 SET $EXTRACT(Y,40)=$$DATE^BGP2UTL($PIECE(V,U,2))
- +18 SET $EXTRACT(Y,50)=$$DATE^BGP2UTL($PIECE(V,U,5))
- +19 SET $EXTRACT(Y,60)=$$DATE^BGP2UTL($PIECE(V,U,6))
- +20 SET $EXTRACT(Y,70)=$$DATE^BGP2UTL($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(^BGPPEDCW(BGPX))
- IF BGPX'=+BGPX
- QUIT
- IF BGPX
- SET V=$GET(^BGPPEDCW(BGPX,0))
- Begin DoDot:1
- +4 IF '$DATA(^BGPPEDCW(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(^BGPPEDCW(BGPX,0),U,17):"+",1:"")
- +15 SET $EXTRACT(Y,30)=$$DATE^BGP2UTL($PIECE(V,U))
- +16 SET $EXTRACT(Y,40)=$$DATE^BGP2UTL($PIECE(V,U,2))
- +17 SET $EXTRACT(Y,50)=$$DATE^BGP2UTL($PIECE(V,U,5))
- +18 SET $EXTRACT(Y,60)=$$DATE^BGP2UTL($PIECE(V,U,6))
- +19 SET $EXTRACT(Y,70)=$$DATE^BGP2UTL($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^BGP2UTL($PIECE(V,U))
- +17 SET $EXTRACT(Y,40)=$$DATE^BGP2UTL($PIECE(V,U,2))
- +18 SET $EXTRACT(Y,50)=$$DATE^BGP2UTL($PIECE(V,U,5))
- +19 SET $EXTRACT(Y,60)=$$DATE^BGP2UTL($PIECE(V,U,6))
- +20 SET $EXTRACT(Y,70)=$$DATE^BGP2UTL($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 ;
