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
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
;
; 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
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
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
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
;
;
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","")
;
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRTSTJM1 5435 printed Oct 16, 2024@18:21:52 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
