LRTSTJM1.m

LRTSTJM1 ; IHS/DIR/FJE - JAM TESTS ONTO (OR OFF) ACCESSIONS (cont.) 10/10/91 14:00 ;

 ;;5.2;LR;**1013**;JUL 15, 2002

 ;

 ;;5.2;LAB SERVICE;;Sep 27, 1994

 ;

EXPLD ;

 S LRTSAD1=0 F  S LRTSAD1=$O(LRTSAD(LRTSUB,LRTSAD1)) Q:'LRTSAD1  D EXPLD1

 K LRTSAD1,LRTSAD2,LRTSAD3,LRTSAD4

 Q

EXPLD1 ;

 Q:'$O(^LAB(60,LRTSAD1,2,0))  S LRTSAD4=LRTSAD1 N LRTSAD1,LRTSAD2,LRTSAD3 S LRTSAD2=LRTSAD4,LRTSAD3=0 K LRTSAD4

 F  S LRTSAD3=$O(^LAB(60,LRTSAD2,2,LRTSAD3)) Q:'LRTSAD3  I $D(^(LRTSAD3,0)),'$D(LRTSAD(LRTSUB,+^(0))) S LRTSAD1=+^(0),LRTSAD(LRTSUB,LRTSAD1)="" D EXPLD1

 Q

COMPTST ;

 D SCAN K:LRTSUB LRTSAD(2) Q:LRTSUB

 I '$L(LRTSURG) D COMTST2 S LRTSURG=LRURG I 'LRURG S LRTSUB=0 Q

 S (LRTSAD,LRTS)=0 F  S LRTS=$O(LRTSAD(2,LRTS)) Q:'LRTS  I '$D(LRTSAD(1,LRTS)) D COMTST1

 W:'LRTSAD !,"All the individual tests for this panel",!,"are already included on this accession."

 K LRTSAD(2),LRTSURG

 Q

COMTST1 ;

 Q:$O(^LAB(60,LRTS,2,0))

 S LRTSAD=1,(Y,LRURG)=$S($L(LRTSURG):LRTSURG,1:$P(^LAB(60,LRTS,0),U,18)) W:'$L(Y) !,$P(^LAB(60,LRTS,0),U,1)

 D COMTST2:'$L(Y) S LRFLG=1 G:LRURG SETTST^LRTSTJAM

 Q

COMTST2 ;

 S DIC=62.05,DIC("B")="ROUTINE",DIC(0)="AEMOQ" D ^DIC K DIC("B") I Y<1 W !,"URGENCY must be defined.  Test not added." S LRURG=0 Q

 W !,"  ...OK" S %=1 D YN^DICN G COMTST2:%=2 S LRURG=$S((%<1):0,1:+Y)

 Q

SCAN ;

 N LRTS S LRTS=0 F  S LRTS=$O(LRTSAD(2,LRTS)) Q:'LRTS  I $D(LRTSAD(1,LRTS)) S LRTSUB=0

 Q

LRTSTJM1  ; IHS/DIR/FJE - JAM TESTS ONTO (OR OFF) ACCESSIONS (cont.) 10/10/91 14:00 ;

 +1       ;;5.2;LR;**1013**;JUL 15, 2002

 +2       ;

 +3       ;;5.2;LAB SERVICE;;Sep 27, 1994

 +4       ;

EXPLD     ;

 +1        SET LRTSAD1=0

           FOR 

               SET LRTSAD1=$ORDER(LRTSAD(LRTSUB,LRTSAD1))

               IF 'LRTSAD1

                   QUIT 

               DO EXPLD1

 +2        KILL LRTSAD1,LRTSAD2,LRTSAD3,LRTSAD4

 +3        QUIT 

EXPLD1    ;

 +1        IF '$ORDER(^LAB(60,LRTSAD1,2,0))

               QUIT 

           SET LRTSAD4=LRTSAD1

           NEW LRTSAD1,LRTSAD2,LRTSAD3

           SET LRTSAD2=LRTSAD4

           SET LRTSAD3=0

           KILL LRTSAD4

 +2        FOR 

               SET LRTSAD3=$ORDER(^LAB(60,LRTSAD2,2,LRTSAD3))

               IF 'LRTSAD3

                   QUIT 

               IF $DATA(^(LRTSAD3,0))

                   IF '$DATA(LRTSAD(LRTSUB,+^(0)))

                       SET LRTSAD1=+^(0)

                       SET LRTSAD(LRTSUB,LRTSAD1)=""

                       DO EXPLD1

 +3        QUIT 

COMPTST   ;

 +1        DO SCAN

           IF LRTSUB

               KILL LRTSAD(2)

           IF LRTSUB

               QUIT 

 +2        IF '$LENGTH(LRTSURG)

               DO COMTST2

               SET LRTSURG=LRURG

               IF 'LRURG

                   SET LRTSUB=0

                   QUIT 

 +3        SET (LRTSAD,LRTS)=0

           FOR 

               SET LRTS=$ORDER(LRTSAD(2,LRTS))

               IF 'LRTS

                   QUIT 

               IF '$DATA(LRTSAD(1,LRTS))

                   DO COMTST1

 +4        IF 'LRTSAD

               WRITE !,"All the individual tests for this panel",!,"are already included on this accession."

 +5        KILL LRTSAD(2),LRTSURG

 +6        QUIT 

COMTST1   ;

 +1        IF $ORDER(^LAB(60,LRTS,2,0))

               QUIT 

 +2        SET LRTSAD=1

           SET (Y,LRURG)=$SELECT($LENGTH(LRTSURG):LRTSURG,1:$PIECE(^LAB(60,LRTS,0),U,18))

           IF '$LENGTH(Y)

               WRITE !,$PIECE(^LAB(60,LRTS,0),U,1)

 +3        IF '$LENGTH(Y)

               DO COMTST2

           SET LRFLG=1

           IF LRURG

               GOTO SETTST^LRTSTJAM

 +4        QUIT 

COMTST2   ;

 +1        SET DIC=62.05

           SET DIC("B")="ROUTINE"

           SET DIC(0)="AEMOQ"

           DO ^DIC

           KILL DIC("B")

           IF Y<1

               WRITE !,"URGENCY must be defined.  Test not added."

               SET LRURG=0

               QUIT 

 +2        WRITE !,"  ...OK"

           SET %=1

           DO YN^DICN

           IF %=2

               GOTO COMTST2

           SET LRURG=$SELECT((%<1):0,1:+Y)

 +3        QUIT 

SCAN      ;

 +1        NEW LRTS

           SET LRTS=0

           FOR 

               SET LRTS=$ORDER(LRTSAD(2,LRTS))

               IF 'LRTS

                   QUIT 

               IF $DATA(LRTSAD(1,LRTS))

                   SET LRTSUB=0

 +2        QUIT