BGP3ASL1 ; IHS/CMI/LAB - DISPLAY IND LISTS 28 Apr 2006 2:10 PM ;
;;13.0;IHS CLINICAL REPORTING;;NOV 20, 2012;Build 81
;; ;
NGR ;EP
K BGPTIND S BGPHIGH=""
S BGPSUCNT=0,BGPSU="",BGPSUC=0
S BGPX=0 F S BGPX=$O(^BGPGPDCH(BGPX)) Q:BGPX'=+BGPX S V=$G(^BGPGPDCH(BGPX,0)) D
.Q:'$D(^BGPGPDCH(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(^BGPGPDCH(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(^BGPGPDCH(BGPX,0),U,17):"+",1:"")
.S $E(Y,30)=$$DATE^BGP3UTL($P(V,U))
.S $E(Y,40)=$$DATE^BGP3UTL($P(V,U,2))
.S $E(Y,50)=$$DATE^BGP3UTL($P(V,U,5))
.S $E(Y,60)=$$DATE^BGP3UTL($P(V,U,6))
.S $E(Y,70)=$$DATE^BGP3UTL($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(^BGPGPDCH(BGPX)) Q:BGPX'=+BGPX S V=$G(^BGPGPDCH(BGPX,0)) D
.Q:'$D(^BGPGPDCH(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(^BGPGPDCH(BGPX,0),U,17):"+",1:"")
.S $E(Y,30)=$$DATE^BGP3UTL($P(V,U))
.S $E(Y,40)=$$DATE^BGP3UTL($P(V,U,2))
.S $E(Y,50)=$$DATE^BGP3UTL($P(V,U,5))
.S $E(Y,60)=$$DATE^BGP3UTL($P(V,U,6))
.S $E(Y,70)=$$DATE^BGP3UTL($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(^BGPELDCH(BGPX)) Q:BGPX'=+BGPX I BGPX S V=$G(^BGPELDCH(BGPX,0)) D
.Q:'$D(^BGPELDCH(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(^BGPELDCH(BGPX,0),U,17):"+",1:"")
.S $E(Y,30)=$$DATE^BGP3UTL($P(V,U))
.S $E(Y,40)=$$DATE^BGP3UTL($P(V,U,2))
.S $E(Y,50)=$$DATE^BGP3UTL($P(V,U,5))
.S $E(Y,60)=$$DATE^BGP3UTL($P(V,U,6))
.S $E(Y,70)=$$DATE^BGP3UTL($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(^BGPPEDCH(BGPX)) Q:BGPX'=+BGPX I BGPX S V=$G(^BGPPEDCH(BGPX,0)) D
.Q:'$D(^BGPPEDCH(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(^BGPPEDCH(BGPX,0),U,17):"+",1:"")
.S $E(Y,30)=$$DATE^BGP3UTL($P(V,U))
.S $E(Y,40)=$$DATE^BGP3UTL($P(V,U,2))
.S $E(Y,50)=$$DATE^BGP3UTL($P(V,U,5))
.S $E(Y,60)=$$DATE^BGP3UTL($P(V,U,6))
.S $E(Y,70)=$$DATE^BGP3UTL($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)
BGP3ASL1 ; IHS/CMI/LAB - DISPLAY IND LISTS 28 Apr 2006 2:10 PM ;
+1 ;;13.0;IHS CLINICAL REPORTING;;NOV 20, 2012;Build 81
+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(^BGPGPDCH(BGPX))
IF BGPX'=+BGPX
QUIT
SET V=$GET(^BGPGPDCH(BGPX,0))
Begin DoDot:1
+4 IF '$DATA(^BGPGPDCH(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 ;I $G(BGPCHWE) Q:'$O(^BGPGPDCH(BGPX,88888,0))
+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(^BGPGPDCH(BGPX,0),U,17):"+",1:"")
+18 SET $EXTRACT(Y,30)=$$DATE^BGP3UTL($PIECE(V,U))
+19 SET $EXTRACT(Y,40)=$$DATE^BGP3UTL($PIECE(V,U,2))
+20 SET $EXTRACT(Y,50)=$$DATE^BGP3UTL($PIECE(V,U,5))
+21 SET $EXTRACT(Y,60)=$$DATE^BGP3UTL($PIECE(V,U,6))
+22 SET $EXTRACT(Y,70)=$$DATE^BGP3UTL($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(^BGPGPDCH(BGPX))
IF BGPX'=+BGPX
QUIT
SET V=$GET(^BGPGPDCH(BGPX,0))
Begin DoDot:1
+4 IF '$DATA(^BGPGPDCH(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(^BGPGPDCH(BGPX,0),U,17):"+",1:"")
+16 SET $EXTRACT(Y,30)=$$DATE^BGP3UTL($PIECE(V,U))
+17 SET $EXTRACT(Y,40)=$$DATE^BGP3UTL($PIECE(V,U,2))
+18 SET $EXTRACT(Y,50)=$$DATE^BGP3UTL($PIECE(V,U,5))
+19 SET $EXTRACT(Y,60)=$$DATE^BGP3UTL($PIECE(V,U,6))
+20 SET $EXTRACT(Y,70)=$$DATE^BGP3UTL($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(^BGPELDCH(BGPX))
IF BGPX'=+BGPX
QUIT
IF BGPX
SET V=$GET(^BGPELDCH(BGPX,0))
Begin DoDot:1
+4 IF '$DATA(^BGPELDCH(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(^BGPELDCH(BGPX,0),U,17):"+",1:"")
+16 SET $EXTRACT(Y,30)=$$DATE^BGP3UTL($PIECE(V,U))
+17 SET $EXTRACT(Y,40)=$$DATE^BGP3UTL($PIECE(V,U,2))
+18 SET $EXTRACT(Y,50)=$$DATE^BGP3UTL($PIECE(V,U,5))
+19 SET $EXTRACT(Y,60)=$$DATE^BGP3UTL($PIECE(V,U,6))
+20 SET $EXTRACT(Y,70)=$$DATE^BGP3UTL($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(^BGPPEDCH(BGPX))
IF BGPX'=+BGPX
QUIT
IF BGPX
SET V=$GET(^BGPPEDCH(BGPX,0))
Begin DoDot:1
+4 IF '$DATA(^BGPPEDCH(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(^BGPPEDCH(BGPX,0),U,17):"+",1:"")
+15 SET $EXTRACT(Y,30)=$$DATE^BGP3UTL($PIECE(V,U))
+16 SET $EXTRACT(Y,40)=$$DATE^BGP3UTL($PIECE(V,U,2))
+17 SET $EXTRACT(Y,50)=$$DATE^BGP3UTL($PIECE(V,U,5))
+18 SET $EXTRACT(Y,60)=$$DATE^BGP3UTL($PIECE(V,U,6))
+19 SET $EXTRACT(Y,70)=$$DATE^BGP3UTL($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)
