Routine: LRTSTJM1

LRTSTJM1 ;DALOI/STAFF- JAM TESTS ONTO (OR OFF) ACCESSIONS (cont.) ;10/25/11  12:14

 ;;5.2;LAB SERVICE;**350**;Sep 27, 1994;Build 230

EXPLD ;

 S LRTSAD1=0

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

 K LRTSAD1,LRTSAD2,LRTSAD3,LRTSAD4

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

COMPTST ;

 D SCAN

 ; After call to SCAN:

 ;  I LRTSUB=0, then some overlap was found between test being added and the tests already on this accession.

 ;  I LRTSUB=2, then no overlap was found

 I LRTSUB K LRTSAD(2) Q  ;no overlap found

 ; If LRTSUB=0, then only add those atomic tests that are not already on this accession.

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

 N LRBORTYP,LRBBERF

 ; LRBORTYP and LRBBERF are used to backup and restore LRORTYP and LRBERF (respectively)

 ; so that user is only prompted for first atomic test in the panel if it's add-on/reflex,

 ; and isn't prompted for every subsequent atomic test in the panel.

 S (LRTSAD,LRTS)=0 F  S LRTS=$O(LRTSAD(2,LRTS)) Q:'LRTS!($D(LRADDTST))  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

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

 I LRURG D

 . I $D(LRBORTYP) S LRORDTYP=LRBORTYP I $D(LRBBERF) S LRBERF=LRBBERF

 . I '$D(LRBORTYP) D  Q:$D(LRADDTST)

 . . S LRORDTYP=$$ORDTYP()

 . . I LRORDTYP<1 S LRADDTST=1 Q

 . . I $P(LRORDTYP,"^")=2 D

 . . . N LRORDTST

 . . . S LRORDTST=$P($G(^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRTSP,0)),U,9)

 . . . I LRORDTST="" S LRORDTST=LRTSP

 . . . S $P(LRORDTYP,"^",3)=LRORDTST,$P(LRORDTYP,"^",4)=$$NLT^LRVER1(LRORDTST)

 . . I +LRDPF=2,$G(LRSS)'="BB",'$$CHKINP^LRBEBA4(LRDFN,LRODT) S LRBERF=$S(LRORDTYP>0:LRORDTYP-1,1:-1) ;CIDC

 . . S LRBORTYP=LRORDTYP

 . . I $D(LRBERF) S LRBBERF=LRBERF

 . D EN^LRTSTSET

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)

SCAN ;

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

ORDTYP() ; Ask if test is "add on" or "reflex"

 N DIR,DUOUT,DTOUT,DIRUT,LRX,LRY,X,Y

 S DIR(0)="S^1:Add On;2:Reflex",DIR("A")="Type of test order being added"

 D ^DIR

 I $D(DIRUT) S LRY=-1

 E  S LRY=+Y

 I LRY>0 D

 . S LRX=$S(LRY=1:"A",LRY=2:"G",1:"A")

 . S $P(LRY,"^",2)=$$FIND1^DIC(64.061,"","OX",LRX,"D","I $P(^(0),U,5)=""0065""")

 Q LRY

ORUT(LRDFN,LRAA,LRAD,LRAN,LR60,LRORDTYP,LRURG,LRODT,LRSN) ; Setup ORUT node in file #63 for test just added.

 ; Call with LRDFN = file #63 IEN

 ;            LRAA = file #68 IEN

 ;            LRAD = accession date

 ;            LRAN = accession number

 ;            LR60 = file #60 IEN

 ;        LRORDTYP = 1(add)/2(reflex)^file #64.061 ien for code^if reflex parent test^if reflex parent NLT^

 ;           LRURG = file #62.05 urgency ien

 ;          LRORDT = file #69 order date

 ;            LRSN = file #69 order ien

 ; Called by LRTSTJAM

 N LR68,LRFDA,LRFILE,LRIDT,LRIENS,LRJUL,LRNLT,LRORD,LRORIFN,LRORNUM,LRPROV,LRSAMP,LRSPEC,LRSS,LRX,LRY,X,Y

 S LRSS=$P($G(^LRO(68,LRAA,0)),"^",2)

 S LRFILE=$S(LRSS="CH":63.07,LRSS="MI":63.5,LRSS="SP":63.53,LRSS="CY":63.51,LRSS="EM":63.52,1:"")

 Q:'LRFILE

 S LR68(0)=$G(^LRO(68,LRAA,1,LRAD,1,LRAN,0))

 S X=$O(^LRO(68,LRAA,1,LRAD,1,LRAN,5,0))

 S LR68(5)=$G(^LRO(68,LRAA,1,LRAD,1,LRAN,5,X,0))

 S LRORD=$P($G(^LRO(68,LRAA,1,LRAD,1,LRAN,.1)),"^")

 S LRSPEC=$P(LR68(5),"^"),LRSAMP=$P(LR68(5),"^",2)

 S LRNLT=$$NLT^LRVER1(LR60) Q:+LRNLT<1

 S LRPROV=$P(LR68(0),"^",8),LRORNUM=""

 I LRORD D

 . S LRX=$$FMDIFF^XLFDT(DT,$E(DT,1,3)_"0101",1)

 . S LRX=LRX+1,LRJUL=$E("000",1,3-$L(LRX))_LRX

 . S LRORNUM="LR-"_LRORD_"-"_$E(DT,1,3)_LRJUL

 S LRIDT=$P($G(^LRO(68,LRAA,1,LRAD,1,LRAN,3)),"^",5)

 S LRORIFN=$P($G(^LRO(69,LRODT,1,LRSN,0)),"^",11)

 S LRIENS="?+1"_","_LRIDT_","_LRDFN_","

 S LRFDA(5,LRFILE,LRIENS,.01)=LRNLT

 S LRFDA(5,LRFILE,LRIENS,2)=LRURG

 I LRORIFN S LRFDA(5,LRFILE,LRIENS,3)=LRORIFN

 I LRORNUM'="" S LRFDA(5,LRFILE,LRIENS,4)=LRORNUM

 I $P(LRORDTYP,"^",2) S LRFDA(5,LRFILE,LRIENS,5)=$P(LRORDTYP,"^",2)

 ; Check for regular or LEDI provider

 I LRPROV'="" D

 . I LRPROV?1.N S LRFDA(5,LRFILE,LRIENS,6)=LRPROV Q

 . I $E(LRPROV,1,4)="REF:" D  ; If LEDI find LEDI provider info on exisitng test.

 . . S X=0,LRX=""

 . . F  S X=$O(^LR(LRDFN,LRSS,LRIDT,"ORUT",X)) Q:X<1  D  Q:LRX'=""

 . . . S X(0)=$G(^LR(LRDFN,LRSS,LRIDT,X,0))

 . . . I $P(X(0),"^",7)'="" S LRX=$P(X(0),"^",7)

 . . I LRX'="" S LRPROV=LRX

 . S LRFDA(5,LRFILE,LRIENS,7)=LRPROV

 I LRSPEC S LRFDA(5,LRFILE,LRIENS,8)=LRSPEC

 I LRSAMP S LRFDA(5,LRFILE,LRIENS,9)=LRSAMP

 I LR60 S LRFDA(5,LRFILE,LRIENS,13)=LR60

 I $P(LRORDTYP,"^",3) D

 . S LRFDA(5,LRFILE,LRIENS,14)=$P(LRORDTYP,"^",3)

 . S LRFDA(5,LRFILE,LRIENS,15)=$P(LRORDTYP,"^",4)

 D UPDATE^DIE("","LRFDA(5)","LRIENS","")

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRTSTJM1   5435     printed  Feb 18, 2025@23:47                                                                                                                                                                                                       Page 2

LRTSTJM1  ;DALOI/STAFF- JAM TESTS ONTO (OR OFF) ACCESSIONS (cont.) ;10/25/11  12:14

 +1       ;;5.2;LAB SERVICE;**350**;Sep 27, 1994;Build 230

 +2       ;

EXPLD     ;

 +1        SET LRTSAD1=0

 +2        FOR

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

               if 'LRTSAD1

                   QUIT

               DO EXPLD1

 +3        KILL LRTSAD1,LRTSAD2,LRTSAD3,LRTSAD4

 +4        QUIT

 +5       ;

 +6       ;

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

 +4       ;

 +5       ;

COMPTST   ;

 +1       ;

 +2        DO SCAN

 +3       ;

 +4       ; After call to SCAN:

 +5       ;  I LRTSUB=0, then some overlap was found between test being added and the tests already on this accession.

 +6       ;  I LRTSUB=2, then no overlap was found

 +7       ;

 +8       ;no overlap found

           IF LRTSUB

               KILL LRTSAD(2)

               QUIT

 +9       ;

 +10      ; If LRTSUB=0, then only add those atomic tests that are not already on this accession.

 +11      ;

 +12       IF '$LENGTH(LRTSURG)

               DO COMTST2

               SET LRTSURG=LRURG

               IF 'LRURG

                   SET LRTSUB=0

                   QUIT

 +13      ;

 +14       NEW LRBORTYP,LRBBERF

 +15      ; LRBORTYP and LRBBERF are used to backup and restore LRORTYP and LRBERF (respectively)

 +16      ; so that user is only prompted for first atomic test in the panel if it's add-on/reflex,

 +17      ; and isn't prompted for every subsequent atomic test in the panel.

 +18      ;

 +19       SET (LRTSAD,LRTS)=0

FOR

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

               if 'LRTS!($DATA(LRADDTST))

                   QUIT

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

                   DO COMTST1

 +20       if 'LRTSAD

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

 +21       KILL LRTSAD(2),LRTSURG

 +22       QUIT

 +23      ;

 +24      ;

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

 +4        IF LRURG

               Begin DoDot:1

 +5                IF $DATA(LRBORTYP)

                       SET LRORDTYP=LRBORTYP

                       IF $DATA(LRBBERF)

                           SET LRBERF=LRBBERF

 +6                IF '$DATA(LRBORTYP)

                       Begin DoDot:2

 +7                        SET LRORDTYP=$$ORDTYP()

 +8                        IF LRORDTYP<1

                               SET LRADDTST=1

                               QUIT

 +9                        IF $PIECE(LRORDTYP,"^")=2

                               Begin DoDot:3

 +10                               NEW LRORDTST

 +11                               SET LRORDTST=$PIECE($GET(^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRTSP,0)),U,9)

 +12                               IF LRORDTST=""

                                       SET LRORDTST=LRTSP

 +13                               SET $PIECE(LRORDTYP,"^",3)=LRORDTST

                                   SET $PIECE(LRORDTYP,"^",4)=$$NLT^LRVER1(LRORDTST)

                               End DoDot:3

 +14      ;CIDC

                           IF +LRDPF=2

                               IF $GET(LRSS)'="BB"

                                   IF '$$CHKINP^LRBEBA4(LRDFN,LRODT)

                                       SET LRBERF=$SELECT(LRORDTYP>0:LRORDTYP-1,1:-1)

 +15                       SET LRBORTYP=LRORDTYP

 +16                       IF $DATA(LRBERF)

                               SET LRBBERF=LRBERF

                       End DoDot:2

                       if $DATA(LRADDTST)

                           QUIT

 +17               DO EN^LRTSTSET

               End DoDot:1

 +18       QUIT

 +19      ;

 +20      ;

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

 +4       ;

 +5       ;

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

 +3       ;

 +4       ;

ORDTYP()  ; Ask if test is "add on" or "reflex"

 +1        NEW DIR,DUOUT,DTOUT,DIRUT,LRX,LRY,X,Y

 +2        SET DIR(0)="S^1:Add On;2:Reflex"

           SET DIR("A")="Type of test order being added"

 +3        DO ^DIR

 +4        IF $DATA(DIRUT)

               SET LRY=-1

 +5       IF '$TEST

               SET LRY=+Y

 +6        IF LRY>0

               Begin DoDot:1

 +7                SET LRX=$SELECT(LRY=1:"A",LRY=2:"G",1:"A")

 +8                SET $PIECE(LRY,"^",2)=$$FIND1^DIC(64.061,"","OX",LRX,"D","I $P(^(0),U,5)=""0065""")

               End DoDot:1

 +9        QUIT LRY

 +10      ;

 +11      ;

ORUT(LRDFN,LRAA,LRAD,LRAN,LR60,LRORDTYP,LRURG,LRODT,LRSN) ; Setup ORUT node in file #63 for test just added.

 +1       ; Call with LRDFN = file #63 IEN

 +2       ;            LRAA = file #68 IEN

 +3       ;            LRAD = accession date

 +4       ;            LRAN = accession number

 +5       ;            LR60 = file #60 IEN

 +6       ;        LRORDTYP = 1(add)/2(reflex)^file #64.061 ien for code^if reflex parent test^if reflex parent NLT^

 +7       ;           LRURG = file #62.05 urgency ien

 +8       ;          LRORDT = file #69 order date

 +9       ;            LRSN = file #69 order ien

 +10      ;

 +11      ; Called by LRTSTJAM

 +12      ;

 +13       NEW LR68,LRFDA,LRFILE,LRIDT,LRIENS,LRJUL,LRNLT,LRORD,LRORIFN,LRORNUM,LRPROV,LRSAMP,LRSPEC,LRSS,LRX,LRY,X,Y

 +14      ;

 +15       SET LRSS=$PIECE($GET(^LRO(68,LRAA,0)),"^",2)

 +16       SET LRFILE=$SELECT(LRSS="CH":63.07,LRSS="MI":63.5,LRSS="SP":63.53,LRSS="CY":63.51,LRSS="EM":63.52,1:"")

 +17       if 'LRFILE

               QUIT

 +18      ;

 +19       SET LR68(0)=$GET(^LRO(68,LRAA,1,LRAD,1,LRAN,0))

 +20       SET X=$ORDER(^LRO(68,LRAA,1,LRAD,1,LRAN,5,0))

 +21       SET LR68(5)=$GET(^LRO(68,LRAA,1,LRAD,1,LRAN,5,X,0))

 +22       SET LRORD=$PIECE($GET(^LRO(68,LRAA,1,LRAD,1,LRAN,.1)),"^")

 +23       SET LRSPEC=$PIECE(LR68(5),"^")

           SET LRSAMP=$PIECE(LR68(5),"^",2)

 +24       SET LRNLT=$$NLT^LRVER1(LR60)

           if +LRNLT<1

               QUIT

 +25       SET LRPROV=$PIECE(LR68(0),"^",8)

           SET LRORNUM=""

 +26       IF LRORD

               Begin DoDot:1

 +27               SET LRX=$$FMDIFF^XLFDT(DT,$EXTRACT(DT,1,3)_"0101",1)

 +28               SET LRX=LRX+1

                   SET LRJUL=$EXTRACT("000",1,3-$LENGTH(LRX))_LRX

 +29               SET LRORNUM="LR-"_LRORD_"-"_$EXTRACT(DT,1,3)_LRJUL

               End DoDot:1

 +30       SET LRIDT=$PIECE($GET(^LRO(68,LRAA,1,LRAD,1,LRAN,3)),"^",5)

 +31       SET LRORIFN=$PIECE($GET(^LRO(69,LRODT,1,LRSN,0)),"^",11)

 +32      ;

 +33       SET LRIENS="?+1"_","_LRIDT_","_LRDFN_","

 +34       SET LRFDA(5,LRFILE,LRIENS,.01)=LRNLT

 +35       SET LRFDA(5,LRFILE,LRIENS,2)=LRURG

 +36       IF LRORIFN

               SET LRFDA(5,LRFILE,LRIENS,3)=LRORIFN

 +37       IF LRORNUM'=""

               SET LRFDA(5,LRFILE,LRIENS,4)=LRORNUM

 +38       IF $PIECE(LRORDTYP,"^",2)

               SET LRFDA(5,LRFILE,LRIENS,5)=$PIECE(LRORDTYP,"^",2)

 +39      ;

 +40      ; Check for regular or LEDI provider

 +41       IF LRPROV'=""

               Begin DoDot:1

 +42               IF LRPROV?1.N

                       SET LRFDA(5,LRFILE,LRIENS,6)=LRPROV

                       QUIT

 +43      ; If LEDI find LEDI provider info on exisitng test.

                   IF $EXTRACT(LRPROV,1,4)="REF:"

                       Begin DoDot:2

 +44                       SET X=0

                           SET LRX=""

 +45                       FOR

                               SET X=$ORDER(^LR(LRDFN,LRSS,LRIDT,"ORUT",X))

                               if X<1

                                   QUIT

                               Begin DoDot:3

 +46                               SET X(0)=$GET(^LR(LRDFN,LRSS,LRIDT,X,0))

 +47                               IF $PIECE(X(0),"^",7)'=""

                                       SET LRX=$PIECE(X(0),"^",7)

                               End DoDot:3

                               if LRX'=""

                                   QUIT

 +48                       IF LRX'=""

                               SET LRPROV=LRX

                       End DoDot:2

 +49               SET LRFDA(5,LRFILE,LRIENS,7)=LRPROV

               End DoDot:1

 +50      ;

 +51       IF LRSPEC

               SET LRFDA(5,LRFILE,LRIENS,8)=LRSPEC

 +52       IF LRSAMP

               SET LRFDA(5,LRFILE,LRIENS,9)=LRSAMP

 +53       IF LR60

               SET LRFDA(5,LRFILE,LRIENS,13)=LR60

 +54       IF $PIECE(LRORDTYP,"^",3)

               Begin DoDot:1

 +55               SET LRFDA(5,LRFILE,LRIENS,14)=$PIECE(LRORDTYP,"^",3)

 +56               SET LRFDA(5,LRFILE,LRIENS,15)=$PIECE(LRORDTYP,"^",4)

               End DoDot:1

 +57       DO UPDATE^DIE("","LRFDA(5)","LRIENS","")

 +58      ;

 +59       QUIT

LRTSTJM1.m