LR7OGO.m

LR7OGO ;SLC/STAFF- Interim report rpc other ;12/12/97  14:22

 ;;5.2;LAB SERVICE;**187,411**;Sep 27, 1994;Build 2

 ;

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^LR7OGU(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

 S:'$D(^LRO(69.2,AA,7,DUZ,1,0)) ^(0)="^69.3PA^0^0"

 S ^LRO(69.2,AA,7,DUZ,0)=DUZ_"^"_DT

 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

 S ^LRO(69.2,AA,7,DUZ,0)=DUZ_"^"_DT

 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

 S ^LRO(69.2,AA,7,DUZ,0)=DUZ_"^"_DT

 Q

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---LR7OGO   4199     printed  Feb 18, 2025@23:31:07                                                                                                                                                                                                      Page 2

LR7OGO    ;SLC/STAFF- Interim report rpc other ;12/12/97  14:22

 +1       ;;5.2;LAB SERVICE;**187,411**;Sep 27, 1994;Build 2

 +2       ;

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^LR7OGU(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       if '$DATA(^LRO(69.2,AA,7,DUZ,1,0))

               SET ^(0)="^69.3PA^0^0"

 +18       SET ^LRO(69.2,AA,7,DUZ,0)=DUZ_"^"_DT

 +19       QUIT 

 +20      ;

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       SET ^LRO(69.2,AA,7,DUZ,0)=DUZ_"^"_DT

 +12       QUIT 

 +13      ;

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       SET ^LRO(69.2,AA,7,DUZ,0)=DUZ_"^"_DT

 +13       QUIT