- BGP4ASL1 ; IHS/CMI/LAB - DISPLAY IND LISTS 28 Apr 2006 2:10 PM ;
- ;;14.1;IHS CLINICAL REPORTING;;MAY 29, 2014;Build 114
- ;; ;
- NGR ;EP
- K BGPTIND S BGPHIGH=""
- S BGPSUCNT=0,BGPSU="",BGPSUC=0
- S BGPX=0 F S BGPX=$O(^BGPGPDCJ(BGPX)) Q:BGPX'=+BGPX S V=$G(^BGPGPDCJ(BGPX,0)) D
- .Q:'$D(^BGPGPDCJ(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
- .Q:$P(V,U,20) ;DPRV
- .;I $G(BGPCHWE) Q:'$O(^BGPGPDCJ(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(^BGPGPDCJ(BGPX,0),U,17):"+",1:"")
- .S $E(Y,30)=$$DATE^BGP4UTL($P(V,U))
- .S $E(Y,40)=$$DATE^BGP4UTL($P(V,U,2))
- .S $E(Y,50)=$$DATE^BGP4UTL($P(V,U,5))
- .S $E(Y,60)=$$DATE^BGP4UTL($P(V,U,6))
- .S $E(Y,70)=$$DATE^BGP4UTL($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(^BGPGPDCJ(BGPX)) Q:BGPX'=+BGPX S V=$G(^BGPGPDCJ(BGPX,0)) D
- .Q:'$D(^BGPGPDCJ(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(^BGPGPDCJ(BGPX,0),U,17):"+",1:"")
- .S $E(Y,30)=$$DATE^BGP4UTL($P(V,U))
- .S $E(Y,40)=$$DATE^BGP4UTL($P(V,U,2))
- .S $E(Y,50)=$$DATE^BGP4UTL($P(V,U,5))
- .S $E(Y,60)=$$DATE^BGP4UTL($P(V,U,6))
- .S $E(Y,70)=$$DATE^BGP4UTL($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(^BGPELDCJ(BGPX)) Q:BGPX'=+BGPX I BGPX S V=$G(^BGPELDCJ(BGPX,0)) D
- .Q:'$D(^BGPELDCJ(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(^BGPELDCJ(BGPX,0),U,17):"+",1:"")
- .S $E(Y,30)=$$DATE^BGP4UTL($P(V,U))
- .S $E(Y,40)=$$DATE^BGP4UTL($P(V,U,2))
- .S $E(Y,50)=$$DATE^BGP4UTL($P(V,U,5))
- .S $E(Y,60)=$$DATE^BGP4UTL($P(V,U,6))
- .S $E(Y,70)=$$DATE^BGP4UTL($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(^BGPPEDCJ(BGPX)) Q:BGPX'=+BGPX I BGPX S V=$G(^BGPPEDCJ(BGPX,0)) D
- .Q:'$D(^BGPPEDCJ(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
- .Q:$P(V,U,20) ;MEGAN
- .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(^BGPPEDCJ(BGPX,0),U,17):"+",1:"")
- .S $E(Y,30)=$$DATE^BGP4UTL($P(V,U))
- .S $E(Y,40)=$$DATE^BGP4UTL($P(V,U,2))
- .S $E(Y,50)=$$DATE^BGP4UTL($P(V,U,5))
- .S $E(Y,60)=$$DATE^BGP4UTL($P(V,U,6))
- .S $E(Y,70)=$$DATE^BGP4UTL($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)
- BGP4ASL1 ; IHS/CMI/LAB - DISPLAY IND LISTS 28 Apr 2006 2:10 PM ;
- +1 ;;14.1;IHS CLINICAL REPORTING;;MAY 29, 2014;Build 114
- +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(^BGPGPDCJ(BGPX))
- IF BGPX'=+BGPX
- QUIT
- SET V=$GET(^BGPGPDCJ(BGPX,0))
- Begin DoDot:1
- +4 IF '$DATA(^BGPGPDCJ(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 ;DPRV
- IF $PIECE(V,U,20)
- QUIT
- +11 ;I $G(BGPCHWE) Q:'$O(^BGPGPDCJ(BGPX,88888,0))
- +12 IF $PIECE(V,U,5)'=BGPBBD
- QUIT
- +13 IF $PIECE(V,U,6)'=BGPBED
- QUIT
- +14 IF $PIECE(V,U,14)'=BGPBEN
- QUIT
- +15 SET BGPSUC=BGPSUC+1
- SET BGPTIND(BGPSUC,0)=BGPSUC_")"
- +16 SET Y=""
- +17 SET $EXTRACT(Y,4)=$EXTRACT($$SU($PIECE(V,U,11)),1,10)
- +18 SET $EXTRACT(Y,15)=$EXTRACT($$FAC($PIECE(V,U,9)),1,13)_$SELECT($PIECE(^BGPGPDCJ(BGPX,0),U,17):"+",1:"")
- +19 SET $EXTRACT(Y,30)=$$DATE^BGP4UTL($PIECE(V,U))
- +20 SET $EXTRACT(Y,40)=$$DATE^BGP4UTL($PIECE(V,U,2))
- +21 SET $EXTRACT(Y,50)=$$DATE^BGP4UTL($PIECE(V,U,5))
- +22 SET $EXTRACT(Y,60)=$$DATE^BGP4UTL($PIECE(V,U,6))
- +23 SET $EXTRACT(Y,70)=$$DATE^BGP4UTL($PIECE(V,U,13))
- +24 SET BGPTIND(BGPSUC,0)=BGPTIND(BGPSUC,0)_Y
- +25 SET BGPTIND(BGPSUC,BGPSUC)=BGPX
- +26 IF $DATA(BGPSUL(BGPX))
- SET BGPTIND(BGPSUC,0)="*"_BGPTIND(BGPSUC,0)
- +27 QUIT
- End DoDot:1
- +28 SET (VALMCNT,BGPHIGH)=BGPSUC
- +29 QUIT
- +30 ;
- ONM ;EP
- +1 KILL BGPTIND
- SET BGPHIGH=""
- +2 SET BGPSUCNT=0
- SET BGPSU=""
- SET BGPSUC=0
- +3 SET BGPX=0
- FOR
- SET BGPX=$ORDER(^BGPGPDCJ(BGPX))
- IF BGPX'=+BGPX
- QUIT
- SET V=$GET(^BGPGPDCJ(BGPX,0))
- Begin DoDot:1
- +4 IF '$DATA(^BGPGPDCJ(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(^BGPGPDCJ(BGPX,0),U,17):"+",1:"")
- +16 SET $EXTRACT(Y,30)=$$DATE^BGP4UTL($PIECE(V,U))
- +17 SET $EXTRACT(Y,40)=$$DATE^BGP4UTL($PIECE(V,U,2))
- +18 SET $EXTRACT(Y,50)=$$DATE^BGP4UTL($PIECE(V,U,5))
- +19 SET $EXTRACT(Y,60)=$$DATE^BGP4UTL($PIECE(V,U,6))
- +20 SET $EXTRACT(Y,70)=$$DATE^BGP4UTL($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(^BGPELDCJ(BGPX))
- IF BGPX'=+BGPX
- QUIT
- IF BGPX
- SET V=$GET(^BGPELDCJ(BGPX,0))
- Begin DoDot:1
- +4 IF '$DATA(^BGPELDCJ(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(^BGPELDCJ(BGPX,0),U,17):"+",1:"")
- +16 SET $EXTRACT(Y,30)=$$DATE^BGP4UTL($PIECE(V,U))
- +17 SET $EXTRACT(Y,40)=$$DATE^BGP4UTL($PIECE(V,U,2))
- +18 SET $EXTRACT(Y,50)=$$DATE^BGP4UTL($PIECE(V,U,5))
- +19 SET $EXTRACT(Y,60)=$$DATE^BGP4UTL($PIECE(V,U,6))
- +20 SET $EXTRACT(Y,70)=$$DATE^BGP4UTL($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(^BGPPEDCJ(BGPX))
- IF BGPX'=+BGPX
- QUIT
- IF BGPX
- SET V=$GET(^BGPPEDCJ(BGPX,0))
- Begin DoDot:1
- +4 IF '$DATA(^BGPPEDCJ(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 ;MEGAN
- IF $PIECE(V,U,20)
- QUIT
- +12 SET BGPSUC=BGPSUC+1
- SET BGPTIND(BGPSUC,0)=BGPSUC_")"
- +13 SET Y=""
- +14 SET $EXTRACT(Y,4)=$EXTRACT($$SU($PIECE(V,U,10)),1,10)
- +15 SET $EXTRACT(Y,15)=$EXTRACT($$FAC($PIECE(V,U,9)),1,13)_$SELECT($PIECE(^BGPPEDCJ(BGPX,0),U,17):"+",1:"")
- +16 SET $EXTRACT(Y,30)=$$DATE^BGP4UTL($PIECE(V,U))
- +17 SET $EXTRACT(Y,40)=$$DATE^BGP4UTL($PIECE(V,U,2))
- +18 SET $EXTRACT(Y,50)=$$DATE^BGP4UTL($PIECE(V,U,5))
- +19 SET $EXTRACT(Y,60)=$$DATE^BGP4UTL($PIECE(V,U,6))
- +20 SET $EXTRACT(Y,70)=$$DATE^BGP4UTL($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
- 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)
