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)
