BPC7OGO ; IHS/OIT/MJL - Interim report rpc other 12/12/97 14:22 ;
;;1.5;BPC;;MAY 26, 2005
;;
;;5.2;LAB SERVICE;**187**;Sep 27, 1994
;
ALLTESTS(Y,FROM,DIR) ; from ORWLRR
N I,IEN,CNT S I=0,CNT=44
F Q:I'<CNT S FROM=$O(^LAB(60,"B",FROM),DIR) Q:FROM="" D
.S IEN=0 F S IEN=$O(^LAB(60,"B",FROM,IEN)) Q:'IEN D
..Q:"BO"'[$P($G(^LAB(60,IEN,0)),U,3)
..S I=I+1,Y(I)=IEN_U_FROM
Q
;
ATESTS(Y,TEST) ; from ORWLRR
N CNT,NUM,PANEL K PANEL
S CNT=0
I 'TEST Q
D TEST^BPC7OGU(TEST,.PANEL)
S NUM=0 F S NUM=$O(PANEL(NUM)) Q:NUM<1 D
.S TEST=+PANEL(NUM)_U_$P($G(^LAB(60,+PANEL(NUM),0)),U)
.S CNT=CNT+1,Y(CNT)=TEST
Q
;
ATG(Y,TESTGRP,USER) ; from ORWLRR
N AA,CNT,NUM,TEST
S AA=+$O(^LRO(68,"B","CHEMISTRY",0))
Q:'TESTGRP Q:'USER Q:'AA
S CNT=0
S NUM=0 F S NUM=$O(^LRO(69.2,AA,7,USER,60,TESTGRP,1,NUM)) Q:NUM<1 S TEST=+$G(^(NUM,0)) I TEST D
.S TEST=TEST_U_$P(^LAB(60,TEST,0),U)
.S CNT=CNT+1,Y(CNT)=TEST
Q
;
ATOMICS(Y,FROM,DIR) ; from ORWLRR
N I,IEN,CNT S I=0,CNT=44
F Q:I'<CNT S FROM=$O(^LAB(60,"B",FROM),DIR) Q:FROM="" D
.S IEN=0 F S IEN=$O(^LAB(60,"B",FROM,IEN)) Q:'IEN D
..Q:'$L($P($G(^LAB(60,IEN,0)),U,5)) Q:"BO"'[$P($G(^(0)),U,3)
..S I=I+1,Y(I)=IEN_U_FROM
Q
;
CHEMTEST(Y,FROM,DIR) ; from ORWLRR
N I,IEN,CNT S I=0,CNT=44
F Q:I'<CNT S FROM=$O(^LAB(60,"B",FROM),DIR) Q:FROM="" D
.S IEN=0 F S IEN=$O(^LAB(60,"B",FROM,IEN)) Q:'IEN D
..Q:"BO"'[$P($G(^LAB(60,IEN,0)),U,3)
..Q:$P($G(^LAB(60,IEN,0)),U,4)'="CH"
..S I=I+1,Y(I)=IEN_U_FROM
Q
;
PARAM(Y) ; from ORWLRR
S Y=$G(^LAB(69.9,1,1))
Q
;
SPEC(Y,FROM,DIR) ; from ORWLRR
N I,IEN,CNT S I=0,CNT=44
F Q:I'<CNT S FROM=$O(^LAB(61,"B",FROM),DIR) Q:FROM="" D
.S IEN=0 F S IEN=$O(^LAB(61,"B",FROM,IEN)) Q:'IEN D
..S I=I+1,Y(I)=IEN_U_FROM
Q
;
TG(Y,USER) ; from ORWLRR
N AA,CNT,LINE,NAME,NUM,TEST,TESTGRP,TNUM
S AA=+$O(^LRO(68,"B","CHEMISTRY",0))
Q:'USER Q:'AA
S CNT=0
S NUM=0 F S NUM=$O(^LRO(69.2,AA,7,USER,60,NUM)) Q:NUM<1 S TESTGRP=+$G(^(NUM,0)) I TESTGRP D
.S LINE=TESTGRP_") "
.S TNUM=0 F S TNUM=$O(^LRO(69.2,AA,7,USER,60,NUM,1,TNUM)) Q:TNUM<1 S TEST=+$G(^(TNUM,0)) I TEST D
..S NAME=$P($G(^LAB(60,TEST,.1)),U)
..I '$L(NAME) S NAME=$P($G(^LAB(60,TEST,0)),U)
..I $L(NAME) S LINE=LINE_NAME_", "
.I $E(LINE,$L(LINE)-1,$L(LINE))=", " S LINE=$E(LINE,1,$L(LINE)-2)
.S CNT=CNT+1,Y(CNT)=NUM_U_LINE
Q
;
USERS(Y,FROM,DIR) ; from ORWLRR
N AA,CNT,I,IEN
S AA=+$O(^LRO(68,"B","CHEMISTRY",0))
Q:'AA
S I=0,CNT=17
F Q:I'<CNT S FROM=$O(^VA(200,"B",FROM),DIR) Q:FROM="" D
.S IEN=0 F S IEN=$O(^VA(200,"B",FROM,IEN)) Q:'IEN D
..I '$O(^LRO(69.2,AA,7,IEN,60,0)) Q
..S I=I+1,Y(I)=IEN_U_FROM
Q
;
UTGA(Y,TESTS) ; from ORWLRR
N AA,CNT,NEWNUM,NUM,TEST
S AA=$O(^LRO(68,"B","CHEMISTRY",0))
I 'AA Q
I '$D(^LRO(69.2,AA,7,DUZ,60,0)) D
.S ^LRO(69.2,AA,7,DUZ,60,0)="^69.35A^1^1"
.S NEWNUM=1
E D
.S NEWNUM=$P(^LRO(69.2,AA,7,DUZ,60,0),U,3)+1
.F Q:'$D(^LRO(69.2,AA,7,DUZ,60,NEWNUM)) S NEWNUM=NEWNUM+1
.S $P(^LRO(69.2,AA,7,DUZ,60,0),U,3,4)=NEWNUM_U_NEWNUM
S ^LRO(69.2,AA,7,DUZ,60,NEWNUM,0)=NEWNUM
S NUM=0
S CNT=0 F S CNT=$O(TESTS(CNT)) Q:CNT<1 S TEST=+TESTS(CNT) I TEST D
.S NUM=NUM+1
.S ^LRO(69.2,AA,7,DUZ,60,NEWNUM,1,NUM,0)=TEST
S ^LRO(69.2,AA,7,DUZ,60,NEWNUM,1,0)="^69.36PA^"_NUM_U_NUM
Q
;
UTGD(Y,TGRP) ; from ORWLRR
N AA,CNT,NEWNUM,NUM,TEST
S AA=$O(^LRO(68,"B","CHEMISTRY",0))
I 'AA Q
S NEWNUM=TGRP
I '$D(^LRO(69.2,AA,7,DUZ,60,NEWNUM,0)) Q
K ^LRO(69.2,AA,7,DUZ,60,NEWNUM)
S NUM=0
S CNT=0 F S CNT=$O(^LRO(69.2,AA,7,DUZ,60,CNT)) Q:CNT<1 D
.S NUM=NUM+1
S ^LRO(69.2,AA,7,DUZ,60,0)="^69.35A^"_NUM_U_NUM
Q
;
UTGR(Y,TESTS,TGRP) ; from ORWLRR
N AA,CNT,NEWNUM,NUM,TEST
S AA=$O(^LRO(68,"B","CHEMISTRY",0))
I 'AA Q
S NEWNUM=TGRP
I '$D(^LRO(69.2,AA,7,DUZ,60,NEWNUM,0)) Q
K ^LRO(69.2,AA,7,DUZ,60,NEWNUM,1)
S NUM=0
S CNT=0 F S CNT=$O(TESTS(CNT)) Q:CNT<1 S TEST=+TESTS(CNT) I TEST D
.S NUM=NUM+1
.S ^LRO(69.2,AA,7,DUZ,60,NEWNUM,1,NUM,0)=TEST
S ^LRO(69.2,AA,7,DUZ,60,NEWNUM,1,0)="^69.36PA^"_NUM_U_NUM
Q
BPC7OGO ; IHS/OIT/MJL - Interim report rpc other 12/12/97 14:22 ;
+1 ;;1.5;BPC;;MAY 26, 2005
+2 ;;
+3 ;;5.2;LAB SERVICE;**187**;Sep 27, 1994
+4 ;
ALLTESTS(Y,FROM,DIR) ; from ORWLRR
+1 NEW I,IEN,CNT
SET I=0
SET CNT=44
+2 FOR
IF I'<CNT
QUIT
SET FROM=$ORDER(^LAB(60,"B",FROM),DIR)
IF FROM=""
QUIT
Begin DoDot:1
+3 SET IEN=0
FOR
SET IEN=$ORDER(^LAB(60,"B",FROM,IEN))
IF 'IEN
QUIT
Begin DoDot:2
+4 IF "BO"'[$PIECE($GET(^LAB(60,IEN,0)),U,3)
QUIT
+5 SET I=I+1
SET Y(I)=IEN_U_FROM
End DoDot:2
End DoDot:1
+6 QUIT
+7 ;
ATESTS(Y,TEST) ; from ORWLRR
+1 NEW CNT,NUM,PANEL
KILL PANEL
+2 SET CNT=0
+3 IF 'TEST
QUIT
+4 DO TEST^BPC7OGU(TEST,.PANEL)
+5 SET NUM=0
FOR
SET NUM=$ORDER(PANEL(NUM))
IF NUM<1
QUIT
Begin DoDot:1
+6 SET TEST=+PANEL(NUM)_U_$PIECE($GET(^LAB(60,+PANEL(NUM),0)),U)
+7 SET CNT=CNT+1
SET Y(CNT)=TEST
End DoDot:1
+8 QUIT
+9 ;
ATG(Y,TESTGRP,USER) ; from ORWLRR
+1 NEW AA,CNT,NUM,TEST
+2 SET AA=+$ORDER(^LRO(68,"B","CHEMISTRY",0))
+3 IF 'TESTGRP
QUIT
IF 'USER
QUIT
IF 'AA
QUIT
+4 SET CNT=0
+5 SET NUM=0
FOR
SET NUM=$ORDER(^LRO(69.2,AA,7,USER,60,TESTGRP,1,NUM))
IF NUM<1
QUIT
SET TEST=+$GET(^(NUM,0))
IF TEST
Begin DoDot:1
+6 SET TEST=TEST_U_$PIECE(^LAB(60,TEST,0),U)
+7 SET CNT=CNT+1
SET Y(CNT)=TEST
End DoDot:1
+8 QUIT
+9 ;
ATOMICS(Y,FROM,DIR) ; from ORWLRR
+1 NEW I,IEN,CNT
SET I=0
SET CNT=44
+2 FOR
IF I'<CNT
QUIT
SET FROM=$ORDER(^LAB(60,"B",FROM),DIR)
IF FROM=""
QUIT
Begin DoDot:1
+3 SET IEN=0
FOR
SET IEN=$ORDER(^LAB(60,"B",FROM,IEN))
IF 'IEN
QUIT
Begin DoDot:2
+4 IF '$LENGTH($PIECE($GET(^LAB(60,IEN,0)),U,5))
QUIT
IF "BO"'[$PIECE($GET(^(0)),U,3)
QUIT
+5 SET I=I+1
SET Y(I)=IEN_U_FROM
End DoDot:2
End DoDot:1
+6 QUIT
+7 ;
CHEMTEST(Y,FROM,DIR) ; from ORWLRR
+1 NEW I,IEN,CNT
SET I=0
SET CNT=44
+2 FOR
IF I'<CNT
QUIT
SET FROM=$ORDER(^LAB(60,"B",FROM),DIR)
IF FROM=""
QUIT
Begin DoDot:1
+3 SET IEN=0
FOR
SET IEN=$ORDER(^LAB(60,"B",FROM,IEN))
IF 'IEN
QUIT
Begin DoDot:2
+4 IF "BO"'[$PIECE($GET(^LAB(60,IEN,0)),U,3)
QUIT
+5 IF $PIECE($GET(^LAB(60,IEN,0)),U,4)'="CH"
QUIT
+6 SET I=I+1
SET Y(I)=IEN_U_FROM
End DoDot:2
End DoDot:1
+7 QUIT
+8 ;
PARAM(Y) ; from ORWLRR
+1 SET Y=$GET(^LAB(69.9,1,1))
+2 QUIT
+3 ;
SPEC(Y,FROM,DIR) ; from ORWLRR
+1 NEW I,IEN,CNT
SET I=0
SET CNT=44
+2 FOR
IF I'<CNT
QUIT
SET FROM=$ORDER(^LAB(61,"B",FROM),DIR)
IF FROM=""
QUIT
Begin DoDot:1
+3 SET IEN=0
FOR
SET IEN=$ORDER(^LAB(61,"B",FROM,IEN))
IF 'IEN
QUIT
Begin DoDot:2
+4 SET I=I+1
SET Y(I)=IEN_U_FROM
End DoDot:2
End DoDot:1
+5 QUIT
+6 ;
TG(Y,USER) ; from ORWLRR
+1 NEW AA,CNT,LINE,NAME,NUM,TEST,TESTGRP,TNUM
+2 SET AA=+$ORDER(^LRO(68,"B","CHEMISTRY",0))
+3 IF 'USER
QUIT
IF 'AA
QUIT
+4 SET CNT=0
+5 SET NUM=0
FOR
SET NUM=$ORDER(^LRO(69.2,AA,7,USER,60,NUM))
IF NUM<1
QUIT
SET TESTGRP=+$GET(^(NUM,0))
IF TESTGRP
Begin DoDot:1
+6 SET LINE=TESTGRP_") "
+7 SET TNUM=0
FOR
SET TNUM=$ORDER(^LRO(69.2,AA,7,USER,60,NUM,1,TNUM))
IF TNUM<1
QUIT
SET TEST=+$GET(^(TNUM,0))
IF TEST
Begin DoDot:2
+8 SET NAME=$PIECE($GET(^LAB(60,TEST,.1)),U)
+9 IF '$LENGTH(NAME)
SET NAME=$PIECE($GET(^LAB(60,TEST,0)),U)
+10 IF $LENGTH(NAME)
SET LINE=LINE_NAME_", "
End DoDot:2
+11 IF $EXTRACT(LINE,$LENGTH(LINE)-1,$LENGTH(LINE))=", "
SET LINE=$EXTRACT(LINE,1,$LENGTH(LINE)-2)
+12 SET CNT=CNT+1
SET Y(CNT)=NUM_U_LINE
End DoDot:1
+13 QUIT
+14 ;
USERS(Y,FROM,DIR) ; from ORWLRR
+1 NEW AA,CNT,I,IEN
+2 SET AA=+$ORDER(^LRO(68,"B","CHEMISTRY",0))
+3 IF 'AA
QUIT
+4 SET I=0
SET CNT=17
+5 FOR
IF I'<CNT
QUIT
SET FROM=$ORDER(^VA(200,"B",FROM),DIR)
IF FROM=""
QUIT
Begin DoDot:1
+6 SET IEN=0
FOR
SET IEN=$ORDER(^VA(200,"B",FROM,IEN))
IF 'IEN
QUIT
Begin DoDot:2
+7 IF '$ORDER(^LRO(69.2,AA,7,IEN,60,0))
QUIT
+8 SET I=I+1
SET Y(I)=IEN_U_FROM
End DoDot:2
End DoDot:1
+9 QUIT
+10 ;
UTGA(Y,TESTS) ; from ORWLRR
+1 NEW AA,CNT,NEWNUM,NUM,TEST
+2 SET AA=$ORDER(^LRO(68,"B","CHEMISTRY",0))
+3 IF 'AA
QUIT
+4 IF '$DATA(^LRO(69.2,AA,7,DUZ,60,0))
Begin DoDot:1
+5 SET ^LRO(69.2,AA,7,DUZ,60,0)="^69.35A^1^1"
+6 SET NEWNUM=1
End DoDot:1
+7 IF '$TEST
Begin DoDot:1
+8 SET NEWNUM=$PIECE(^LRO(69.2,AA,7,DUZ,60,0),U,3)+1
+9 FOR
IF '$DATA(^LRO(69.2,AA,7,DUZ,60,NEWNUM))
QUIT
SET NEWNUM=NEWNUM+1
+10 SET $PIECE(^LRO(69.2,AA,7,DUZ,60,0),U,3,4)=NEWNUM_U_NEWNUM
End DoDot:1
+11 SET ^LRO(69.2,AA,7,DUZ,60,NEWNUM,0)=NEWNUM
+12 SET NUM=0
+13 SET CNT=0
FOR
SET CNT=$ORDER(TESTS(CNT))
IF CNT<1
QUIT
SET TEST=+TESTS(CNT)
IF TEST
Begin DoDot:1
+14 SET NUM=NUM+1
+15 SET ^LRO(69.2,AA,7,DUZ,60,NEWNUM,1,NUM,0)=TEST
End DoDot:1
+16 SET ^LRO(69.2,AA,7,DUZ,60,NEWNUM,1,0)="^69.36PA^"_NUM_U_NUM
+17 QUIT
+18 ;
UTGD(Y,TGRP) ; from ORWLRR
+1 NEW AA,CNT,NEWNUM,NUM,TEST
+2 SET AA=$ORDER(^LRO(68,"B","CHEMISTRY",0))
+3 IF 'AA
QUIT
+4 SET NEWNUM=TGRP
+5 IF '$DATA(^LRO(69.2,AA,7,DUZ,60,NEWNUM,0))
QUIT
+6 KILL ^LRO(69.2,AA,7,DUZ,60,NEWNUM)
+7 SET NUM=0
+8 SET CNT=0
FOR
SET CNT=$ORDER(^LRO(69.2,AA,7,DUZ,60,CNT))
IF CNT<1
QUIT
Begin DoDot:1
+9 SET NUM=NUM+1
End DoDot:1
+10 SET ^LRO(69.2,AA,7,DUZ,60,0)="^69.35A^"_NUM_U_NUM
+11 QUIT
+12 ;
UTGR(Y,TESTS,TGRP) ; from ORWLRR
+1 NEW AA,CNT,NEWNUM,NUM,TEST
+2 SET AA=$ORDER(^LRO(68,"B","CHEMISTRY",0))
+3 IF 'AA
QUIT
+4 SET NEWNUM=TGRP
+5 IF '$DATA(^LRO(69.2,AA,7,DUZ,60,NEWNUM,0))
QUIT
+6 KILL ^LRO(69.2,AA,7,DUZ,60,NEWNUM,1)
+7 SET NUM=0
+8 SET CNT=0
FOR
SET CNT=$ORDER(TESTS(CNT))
IF CNT<1
QUIT
SET TEST=+TESTS(CNT)
IF TEST
Begin DoDot:1
+9 SET NUM=NUM+1
+10 SET ^LRO(69.2,AA,7,DUZ,60,NEWNUM,1,NUM,0)=TEST
End DoDot:1
+11 SET ^LRO(69.2,AA,7,DUZ,60,NEWNUM,1,0)="^69.36PA^"_NUM_U_NUM
+12 QUIT
