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