LRMLWT ;BPFO/DTG - LAB NTRT LOOP 60 FOR MLTF ;02/10/2016
;;5.2;LAB SERVICE;**468,500**;Sep 27, 1994;Build 29
;
; From option LR NTRT WALK ASSOCIATE
;
; loop through the 60 file by test
EN ; starting point for walking from newest test to oldest test in file 60
; to associate with the MLTF
N DIE,DR,DA,DIQ,LRTN,LRARY,LRSPARY,DT,A,B,C,D,PS,LASTTEST,DIR,LRIEN,LRSPEC,LRSN,LRS,LRN,LSITE,LRNT,LRNTI,AR,LXA,LXB
N LRMLTF,LR64,LR64ER,ER,LRSPERR,LROKS,LRSYSTEM,LRLEC,LRNO,X,Y
N AA,ALA,ALAC,DIC,I,LRCKD,LRELEC,LRLNC,LRLNC0,LT,SCOUNT,OK
S U="^" I $G(DT)="" S DT=$$DT^XLFDT
S B=$$SITE^VASITE,B=$P(B,U,1) I 'B Q ; not set up
S PS=$O(^LAB(66.4,"B",B,0)) I PS="" Q ; 66.4 not set up
;START OF CHANGE FOR LR*5.2*500
S LASTTEST=$$GET1^DIQ(66.4,PS_",",.08)
I LASTTEST]"" S OK=0 D I OK G QUIT
. N LNAME,LRFDA,DIR,DIRUT
. S LNAME=$S(LASTTEST="DONE":"Process Completed",1:$$GET1^DIQ(60,(+LASTTEST)_",",.01))
. S DIR(0)="SO^C:CONTINUE WITH "_LNAME_" ["_LASTTEST_"];S:START OVER"
. S DIR("L",1)=" CONTINUE WITH "_LNAME_" ["_LASTTEST_"] (C)"
. S DIR("L")=" START OVER (S)"
. D ^DIR
. I $D(DIRUT)!(Y="^") W !,*7,"Continuation Method Not Selected. Quitting" S OK=1 Q
. I $G(Y)="S" S LRFDA(66.4,PS_",",.08)="@" D FILE^DIE(,"LRFDA")
;END OF CHANGE FOR LR*5.2*500
ENR S LASTTEST=$$GET1^DIQ(66.4,PS_",",.08)
I LASTTEST="DONE" W !,*7,"Process Has Been Completed" G QUIT
D GET664
I LASTTEST="" S LASTTEST=$O(^LAB(60,"A"),-1) I LASTTEST?1.N S LR64ER=0 D I LR64ER=1 G SETER
. L +^LAB(66.4,PS):30 I '$T S LR64ER=1 Q
. S LASTTEST=LASTTEST+1,DA=PS,DIE="^LAB(66.4,",DR=".08///"_LASTTEST
. D ^DIE
. L -^LAB(66.4,PS)
;
LOOP ; start the process
S LRIEN=LASTTEST K LRSPARY
L1 S LRIEN=$O(^LAB(60,LRIEN),-1) I LRIEN="" S LRIEN="DONE" G LOUT
D GET60T
S LRN=$G(LXA(.01,"E")),LR64ER=0
; check test subscript is valid for NTRT
S AA=$G(LXA(4,"I"))
I AA="WK" S LR64ER=0 D LSET G:LR64ER=1 SETER G L1
I AA="BB" D LSET G:LR64ER=1 SETER G L1
; check test type
S AA=$G(LXA(3,"I"))
I AA="N"!(AA="D") D LSET G:LR64ER=1 SETER G L1
; check for data name
I $G(LXA(5,"I"))="" D LSET G:LR64ER=1 SETER G L1
;
; loop ^LAB(60 specimen level
S LT=0,LRS=0
D Q1 I LRS<1 D S LR64ER=0 D LSET G:LR64ER=1 SETER G ENR
. I SCOUNT<1 W !!,*7," *** This Test ( ",LRN," [",LRIEN,"]) Does Not Have any Specimens",!!
G L2
L2 ;loop through specimens
K DIR,DIRUT
S DIR("A")="Enter The Number For The Specimen to Associate With The MLTF"
S DIR(0)="SO^",ALAC=0
F I=1:1:LRS S ALA=$G(LRSPARY(I)) I ALA'="" S ALAC=ALAC+1 S:ALAC>1 DIR(0)=DIR(0)_";" S DIR(0)=DIR(0)_I_":"_LRSPARY(I)
W !!,"TEST: "_LRN
W !,"SPECIMEN(s)",!
D ^DIR
I $D(DIRUT) G QUIT:$E(X)="^"
I Y'?1.N G LX
S A=$G(LRSPARY(Y)) I A="" W !,*7,"Number out of Range" G L2
S LRSPEC=$P($P(A,"[",2),"]",1),LRSN=$P(A," ",1) I LRSPEC'?1.N W !,*7,"Specimen not found" G L2
L2M ; come here to ask MLTF
K DIR,DA,DIRUT
;START OF CHANGE FOR LR*5.2*500
S DIR(0)="PO^66.3:EMQZ"
;END OF CHANGE FOR LR*5.2*500
S DIR("S")="I '$$SCREEN^XTID(66.3,"""",(+Y_"",""))"
D ^DIR
I $D(DIRUT) G QUIT:$E(X)="^"
I +Y'>0 G LX:LRS<2,L2Q
S LRSPERR=0,LRMLTF=+Y
; check specimen type (based on code from LRLNC0 at CHKSPEC
S LRELEC=$P($G(^LAB(61,LRSPEC,0)),U,9)
S LRLNC0=$$GET1^DIQ(66.3,LRMLTF,.04,"I")
S LRLNC=$P(LRLNC0,"-",1),LRCKD=$P(LRLNC0,"-",2)
S A=0,LRSYSTEM="" F S A=$O(^LAB(95.3,"B",LRLNC,A)) Q:'A S B=$G(^LAB(95.3,A,0)),LRSYSTEM=$P(B,U,8),C=$P(B,U,15) I C=LRCKD Q
; if not found in 95.3
I 'A G L2S
D CHKSPEC G:LROKS=1 L2S
I $D(DIRUT) G QUIT:$E(X)="^"
I LRNO=1 W !,"TEST: ",LRN,!,"SPECIMEN: ",LRSN,! G L2M
G L2S
;
L2S D MSET I LRSPERR=1 G SETER
S A=$$GET1^DIQ(60.01,LT_","_LRIEN,30,"E")
W !,LRSN,": Saved With MLTF ",A,!
S LT=0,LRS=0 K LRSPARY D Q1 I LRS<1 D S LR64ER=0 D LSET G:LR64ER=1 SETER G ENR
. I SCOUNT<1 W !!,*7," *** This Test ( ",LRN," [",LRIEN,"] Does Not Have any Specimens",!! R X:10
G L2
;
L2Q ; ask to see additional specimens
K DIR,DIRUT S DIR(0)="Y",DIR("B")="YES",DIR("A")="Do You Wish to Evaluate Additional Specimens? "
D ^DIR
I $D(DIRUT) G QUIT:$E(X)="^"
I Y=1 S LT=0,LRS=0 K LRSPARY D Q1 W:LRS<1 *7," No More Specimens To Check For This Test" G:LRS<1 LX G L2
G LX
LX ;
K DIR,DIRUT S DIR(0)="Y",DIR("B")="YES",DIR("A")="Do You Wish to go to The Next Test?"
D ^DIR
I $D(DIRUT) G QUIT:$E(X)="^"
I Y=1 S LR64ER=0 D LSET G:LR64ER=1 SETER G ENR
K DIR,DIRUT S DIR(0)="Y",DIR("B")="YES",DIR("A")="Do You Wish to Exit?" D ^DIR
G QUIT:$D(DIRUT) I Y=1 K DIR,DIRUT S LR64ER=0 D G:LRNO=1 QUIT G SETER:LR64ER=1,QUIT
. S LRNO=0,DIR(0)="Y",DIR("B")="YES",DIR("A")="Do You Wish to Skip This Test on Re-Start?" D ^DIR
. I $D(DIRUT) S LRNO=1 Q
. I Y=1 D LSET
G ENR
;
Q1 ; pick up spcimens from test
S SCOUNT=0
Q1A S LT=$O(^LAB(60,LRIEN,1,LT)) I 'LT Q
S SCOUNT=SCOUNT+1
S B=$$GET1^DIQ(60.01,LT_","_LRIEN,30,"I") I B'="" G Q1A
S A=$$GET1^DIQ(60.01,LT_","_LRIEN,.01,"E")
S LRS=LRS+1,LRSPARY(LRS)=A_" ["_LT_"]" ;LT_"-"_A
G Q1A
;
QUIT ;
K DIE,DR,DA,DIQ,LRTN,LRARY,LRSPARY,A,B,C,D,PS,LASTTEST,DIR,LRIEN,LRSPEC,LRSN,LRS,LRN,LSITE,LRNT,LRNTI,AR,LXA,LXB
K LRMLTF,LR64,LR64ER,ER,LRSPERR,LROKS,LRSYSTEM,LRLEC,LRNO
K AA,ALA,ALAC,DIC,I,LRCKD,LRELEC,LRLNC,LRLNC0,LT,SCOUNT,X,Y,OK
Q
;
LOUT D LSET G:LR64ER=1 SETER
I LRIEN="DONE" G QUIT
K LRSPARY
G ENR
;
LSET ;put the last ien in 66.4 .08
N DA,DIE,DR
S DA=PS
L +^LAB(66.4,DA):30 I '$T S LR64ER=1 Q
S DIE="^LAB(66.4,",DR=".08///"_LRIEN D ^DIE
L -^LAB(66.4,DA)
Q
;
SETER ; come here if not able to open files and quit
W !,*7,"unable to open file... EXITING " R X:10 G QUIT
;
MSET ;save the mltf to the 60 file
N DA,DR,DIE,FDA,FFF
L +^LAB(60,LRIEN,1,LRSPEC):30 I '$T S LRSPERR=1 Q
;START OF CHANGE FOR LR*5.2*500
;S DA(1)=+LRIEN,DA=LRSPEC,DR="30///"_LRMLTF,DIE="^LAB(60,"_DA(1)_",1," D ^DIE
K FDA S DA(1)=+LRIEN,DA=LRSPEC,FFF=DA_","_DA(1)_",",FDA(60.01,FFF,30)=LRMLTF D FILE^DIE("","FDA")
K FDA,FFF
;END OF CHANGE FOR LR*5.2*500
L -^LAB(60,LRIEN,1,LRSPEC)
Q
;
GET664 ; get file 66.4 info
S LSITE=$$SITE^VASITE,LSITE=$P(LSITE,U,1)
S LRNT=$O(^LAB(66.4,"B",LSITE,0))
D GETS^DIQ(66.4,LRNT_",","**","IE","AR")
M LRNTI=AR("66.4",LRNT_",") K AR
Q
;
GET60T ; get top of file 60 test info
S DA=LRIEN,DIQ="LXB",DIQ(0)="IE",DIC=60,DR=".01;3;4;5;64.1;5;13;131;132;133" D EN^DIQ1
K LXA M LXA=LXB(60,DA) K LXB
Q
;
CHKSPEC ;Check that specimen of MLTF LOINC code same as specimen of test
S LROKS=1
I LRSYSTEM=$G(LRELEC) Q
I (LRSYSTEM=74!(LRSYSTEM=83)!(LRSYSTEM=114)!(LRSYSTEM=1376))&($G(LRELEC)=74!($G(LRELEC)=83)!($G(LRELEC)=114)!($G(LRELEC)=1376)) Q
S LROKS=0,LRNO=0
W !!,"The MLTF LOINC code that you have selected does not have the"
W !,"same specimen that you chose to test/specimen."
K DIR,DIRUT
S DIR(0)="Y",DIR("A")="Are you sure you want to do this"
S DIR("?")="If you enter yes, the test/specimen will be associated to this MLTF LOINC code."
S DIR("B")="Yes"
D ^DIR
I $D(DIRUT) S LRNO=1 Q
I Y<1 S LRNO=1
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRMLWT 7045 printed Sep 23, 2025@19:53:42 Page 2
LRMLWT ;BPFO/DTG - LAB NTRT LOOP 60 FOR MLTF ;02/10/2016
+1 ;;5.2;LAB SERVICE;**468,500**;Sep 27, 1994;Build 29
+2 ;
+3 ; From option LR NTRT WALK ASSOCIATE
+4 ;
+5 ; loop through the 60 file by test
EN ; starting point for walking from newest test to oldest test in file 60
+1 ; to associate with the MLTF
+2 NEW DIE,DR,DA,DIQ,LRTN,LRARY,LRSPARY,DT,A,B,C,D,PS,LASTTEST,DIR,LRIEN,LRSPEC,LRSN,LRS,LRN,LSITE,LRNT,LRNTI,AR,LXA,LXB
+3 NEW LRMLTF,LR64,LR64ER,ER,LRSPERR,LROKS,LRSYSTEM,LRLEC,LRNO,X,Y
+4 NEW AA,ALA,ALAC,DIC,I,LRCKD,LRELEC,LRLNC,LRLNC0,LT,SCOUNT,OK
+5 SET U="^"
IF $GET(DT)=""
SET DT=$$DT^XLFDT
+6 ; not set up
SET B=$$SITE^VASITE
SET B=$PIECE(B,U,1)
IF 'B
QUIT
+7 ; 66.4 not set up
SET PS=$ORDER(^LAB(66.4,"B",B,0))
IF PS=""
QUIT
+8 ;START OF CHANGE FOR LR*5.2*500
+9 SET LASTTEST=$$GET1^DIQ(66.4,PS_",",.08)
+10 IF LASTTEST]""
SET OK=0
Begin DoDot:1
+11 NEW LNAME,LRFDA,DIR,DIRUT
+12 SET LNAME=$SELECT(LASTTEST="DONE":"Process Completed",1:$$GET1^DIQ(60,(+LASTTEST)_",",.01))
+13 SET DIR(0)="SO^C:CONTINUE WITH "_LNAME_" ["_LASTTEST_"];S:START OVER"
+14 SET DIR("L",1)=" CONTINUE WITH "_LNAME_" ["_LASTTEST_"] (C)"
+15 SET DIR("L")=" START OVER (S)"
+16 DO ^DIR
+17 IF $DATA(DIRUT)!(Y="^")
WRITE !,*7,"Continuation Method Not Selected. Quitting"
SET OK=1
QUIT
+18 IF $GET(Y)="S"
SET LRFDA(66.4,PS_",",.08)="@"
DO FILE^DIE(,"LRFDA")
End DoDot:1
IF OK
GOTO QUIT
+19 ;END OF CHANGE FOR LR*5.2*500
ENR SET LASTTEST=$$GET1^DIQ(66.4,PS_",",.08)
+1 IF LASTTEST="DONE"
WRITE !,*7,"Process Has Been Completed"
GOTO QUIT
+2 DO GET664
+3 IF LASTTEST=""
SET LASTTEST=$ORDER(^LAB(60,"A"),-1)
IF LASTTEST?1.N
SET LR64ER=0
Begin DoDot:1
+4 LOCK +^LAB(66.4,PS):30
IF '$TEST
SET LR64ER=1
QUIT
+5 SET LASTTEST=LASTTEST+1
SET DA=PS
SET DIE="^LAB(66.4,"
SET DR=".08///"_LASTTEST
+6 DO ^DIE
+7 LOCK -^LAB(66.4,PS)
End DoDot:1
IF LR64ER=1
GOTO SETER
+8 ;
LOOP ; start the process
+1 SET LRIEN=LASTTEST
KILL LRSPARY
L1 SET LRIEN=$ORDER(^LAB(60,LRIEN),-1)
IF LRIEN=""
SET LRIEN="DONE"
GOTO LOUT
+1 DO GET60T
+2 SET LRN=$GET(LXA(.01,"E"))
SET LR64ER=0
+3 ; check test subscript is valid for NTRT
+4 SET AA=$GET(LXA(4,"I"))
+5 IF AA="WK"
SET LR64ER=0
DO LSET
if LR64ER=1
GOTO SETER
GOTO L1
+6 IF AA="BB"
DO LSET
if LR64ER=1
GOTO SETER
GOTO L1
+7 ; check test type
+8 SET AA=$GET(LXA(3,"I"))
+9 IF AA="N"!(AA="D")
DO LSET
if LR64ER=1
GOTO SETER
GOTO L1
+10 ; check for data name
+11 IF $GET(LXA(5,"I"))=""
DO LSET
if LR64ER=1
GOTO SETER
GOTO L1
+12 ;
+13 ; loop ^LAB(60 specimen level
+14 SET LT=0
SET LRS=0
+15 DO Q1
IF LRS<1
Begin DoDot:1
+16 IF SCOUNT<1
WRITE !!,*7," *** This Test ( ",LRN," [",LRIEN,"]) Does Not Have any Specimens",!!
End DoDot:1
SET LR64ER=0
DO LSET
if LR64ER=1
GOTO SETER
GOTO ENR
+17 GOTO L2
L2 ;loop through specimens
+1 KILL DIR,DIRUT
+2 SET DIR("A")="Enter The Number For The Specimen to Associate With The MLTF"
+3 SET DIR(0)="SO^"
SET ALAC=0
+4 FOR I=1:1:LRS
SET ALA=$GET(LRSPARY(I))
IF ALA'=""
SET ALAC=ALAC+1
if ALAC>1
SET DIR(0)=DIR(0)_";"
SET DIR(0)=DIR(0)_I_":"_LRSPARY(I)
+5 WRITE !!,"TEST: "_LRN
+6 WRITE !,"SPECIMEN(s)",!
+7 DO ^DIR
+8 IF $DATA(DIRUT)
if $EXTRACT(X)="^"
GOTO QUIT
+9 IF Y'?1.N
GOTO LX
+10 SET A=$GET(LRSPARY(Y))
IF A=""
WRITE !,*7,"Number out of Range"
GOTO L2
+11 SET LRSPEC=$PIECE($PIECE(A,"[",2),"]",1)
SET LRSN=$PIECE(A," ",1)
IF LRSPEC'?1.N
WRITE !,*7,"Specimen not found"
GOTO L2
L2M ; come here to ask MLTF
+1 KILL DIR,DA,DIRUT
+2 ;START OF CHANGE FOR LR*5.2*500
+3 SET DIR(0)="PO^66.3:EMQZ"
+4 ;END OF CHANGE FOR LR*5.2*500
+5 SET DIR("S")="I '$$SCREEN^XTID(66.3,"""",(+Y_"",""))"
+6 DO ^DIR
+7 IF $DATA(DIRUT)
if $EXTRACT(X)="^"
GOTO QUIT
+8 IF +Y'>0
if LRS<2
GOTO LX
GOTO L2Q
+9 SET LRSPERR=0
SET LRMLTF=+Y
+10 ; check specimen type (based on code from LRLNC0 at CHKSPEC
+11 SET LRELEC=$PIECE($GET(^LAB(61,LRSPEC,0)),U,9)
+12 SET LRLNC0=$$GET1^DIQ(66.3,LRMLTF,.04,"I")
+13 SET LRLNC=$PIECE(LRLNC0,"-",1)
SET LRCKD=$PIECE(LRLNC0,"-",2)
+14 SET A=0
SET LRSYSTEM=""
FOR
SET A=$ORDER(^LAB(95.3,"B",LRLNC,A))
if 'A
QUIT
SET B=$GET(^LAB(95.3,A,0))
SET LRSYSTEM=$PIECE(B,U,8)
SET C=$PIECE(B,U,15)
IF C=LRCKD
QUIT
+15 ; if not found in 95.3
+16 IF 'A
GOTO L2S
+17 DO CHKSPEC
if LROKS=1
GOTO L2S
+18 IF $DATA(DIRUT)
if $EXTRACT(X)="^"
GOTO QUIT
+19 IF LRNO=1
WRITE !,"TEST: ",LRN,!,"SPECIMEN: ",LRSN,!
GOTO L2M
+20 GOTO L2S
+21 ;
L2S DO MSET
IF LRSPERR=1
GOTO SETER
+1 SET A=$$GET1^DIQ(60.01,LT_","_LRIEN,30,"E")
+2 WRITE !,LRSN,": Saved With MLTF ",A,!
+3 SET LT=0
SET LRS=0
KILL LRSPARY
DO Q1
IF LRS<1
Begin DoDot:1
+4 IF SCOUNT<1
WRITE !!,*7," *** This Test ( ",LRN," [",LRIEN,"] Does Not Have any Specimens",!!
READ X:10
End DoDot:1
SET LR64ER=0
DO LSET
if LR64ER=1
GOTO SETER
GOTO ENR
+5 GOTO L2
+6 ;
L2Q ; ask to see additional specimens
+1 KILL DIR,DIRUT
SET DIR(0)="Y"
SET DIR("B")="YES"
SET DIR("A")="Do You Wish to Evaluate Additional Specimens? "
+2 DO ^DIR
+3 IF $DATA(DIRUT)
if $EXTRACT(X)="^"
GOTO QUIT
+4 IF Y=1
SET LT=0
SET LRS=0
KILL LRSPARY
DO Q1
if LRS<1
WRITE *7," No More Specimens To Check For This Test"
if LRS<1
GOTO LX
GOTO L2
+5 GOTO LX
LX ;
+1 KILL DIR,DIRUT
SET DIR(0)="Y"
SET DIR("B")="YES"
SET DIR("A")="Do You Wish to go to The Next Test?"
+2 DO ^DIR
+3 IF $DATA(DIRUT)
if $EXTRACT(X)="^"
GOTO QUIT
+4 IF Y=1
SET LR64ER=0
DO LSET
if LR64ER=1
GOTO SETER
GOTO ENR
+5 KILL DIR,DIRUT
SET DIR(0)="Y"
SET DIR("B")="YES"
SET DIR("A")="Do You Wish to Exit?"
DO ^DIR
+6 if $DATA(DIRUT)
GOTO QUIT
IF Y=1
KILL DIR,DIRUT
SET LR64ER=0
Begin DoDot:1
+7 SET LRNO=0
SET DIR(0)="Y"
SET DIR("B")="YES"
SET DIR("A")="Do You Wish to Skip This Test on Re-Start?"
DO ^DIR
+8 IF $DATA(DIRUT)
SET LRNO=1
QUIT
+9 IF Y=1
DO LSET
End DoDot:1
if LRNO=1
GOTO QUIT
if LR64ER=1
GOTO SETER
GOTO QUIT
+10 GOTO ENR
+11 ;
Q1 ; pick up spcimens from test
+1 SET SCOUNT=0
Q1A SET LT=$ORDER(^LAB(60,LRIEN,1,LT))
IF 'LT
QUIT
+1 SET SCOUNT=SCOUNT+1
+2 SET B=$$GET1^DIQ(60.01,LT_","_LRIEN,30,"I")
IF B'=""
GOTO Q1A
+3 SET A=$$GET1^DIQ(60.01,LT_","_LRIEN,.01,"E")
+4 ;LT_"-"_A
SET LRS=LRS+1
SET LRSPARY(LRS)=A_" ["_LT_"]"
+5 GOTO Q1A
+6 ;
QUIT ;
+1 KILL DIE,DR,DA,DIQ,LRTN,LRARY,LRSPARY,A,B,C,D,PS,LASTTEST,DIR,LRIEN,LRSPEC,LRSN,LRS,LRN,LSITE,LRNT,LRNTI,AR,LXA,LXB
+2 KILL LRMLTF,LR64,LR64ER,ER,LRSPERR,LROKS,LRSYSTEM,LRLEC,LRNO
+3 KILL AA,ALA,ALAC,DIC,I,LRCKD,LRELEC,LRLNC,LRLNC0,LT,SCOUNT,X,Y,OK
+4 QUIT
+5 ;
LOUT DO LSET
if LR64ER=1
GOTO SETER
+1 IF LRIEN="DONE"
GOTO QUIT
+2 KILL LRSPARY
+3 GOTO ENR
+4 ;
LSET ;put the last ien in 66.4 .08
+1 NEW DA,DIE,DR
+2 SET DA=PS
+3 LOCK +^LAB(66.4,DA):30
IF '$TEST
SET LR64ER=1
QUIT
+4 SET DIE="^LAB(66.4,"
SET DR=".08///"_LRIEN
DO ^DIE
+5 LOCK -^LAB(66.4,DA)
+6 QUIT
+7 ;
SETER ; come here if not able to open files and quit
+1 WRITE !,*7,"unable to open file... EXITING "
READ X:10
GOTO QUIT
+2 ;
MSET ;save the mltf to the 60 file
+1 NEW DA,DR,DIE,FDA,FFF
+2 LOCK +^LAB(60,LRIEN,1,LRSPEC):30
IF '$TEST
SET LRSPERR=1
QUIT
+3 ;START OF CHANGE FOR LR*5.2*500
+4 ;S DA(1)=+LRIEN,DA=LRSPEC,DR="30///"_LRMLTF,DIE="^LAB(60,"_DA(1)_",1," D ^DIE
+5 KILL FDA
SET DA(1)=+LRIEN
SET DA=LRSPEC
SET FFF=DA_","_DA(1)_","
SET FDA(60.01,FFF,30)=LRMLTF
DO FILE^DIE("","FDA")
+6 KILL FDA,FFF
+7 ;END OF CHANGE FOR LR*5.2*500
+8 LOCK -^LAB(60,LRIEN,1,LRSPEC)
+9 QUIT
+10 ;
GET664 ; get file 66.4 info
+1 SET LSITE=$$SITE^VASITE
SET LSITE=$PIECE(LSITE,U,1)
+2 SET LRNT=$ORDER(^LAB(66.4,"B",LSITE,0))
+3 DO GETS^DIQ(66.4,LRNT_",","**","IE","AR")
+4 MERGE LRNTI=AR("66.4",LRNT_",")
KILL AR
+5 QUIT
+6 ;
GET60T ; get top of file 60 test info
+1 SET DA=LRIEN
SET DIQ="LXB"
SET DIQ(0)="IE"
SET DIC=60
SET DR=".01;3;4;5;64.1;5;13;131;132;133"
DO EN^DIQ1
+2 KILL LXA
MERGE LXA=LXB(60,DA)
KILL LXB
+3 QUIT
+4 ;
CHKSPEC ;Check that specimen of MLTF LOINC code same as specimen of test
+1 SET LROKS=1
+2 IF LRSYSTEM=$GET(LRELEC)
QUIT
+3 IF (LRSYSTEM=74!(LRSYSTEM=83)!(LRSYSTEM=114)!(LRSYSTEM=1376))&($GET(LRELEC)=74!($GET(LRELEC)=83)!($GET(LRELEC)=114)!($GET(LRELEC)=1376))
QUIT
+4 SET LROKS=0
SET LRNO=0
+5 WRITE !!,"The MLTF LOINC code that you have selected does not have the"
+6 WRITE !,"same specimen that you chose to test/specimen."
+7 KILL DIR,DIRUT
+8 SET DIR(0)="Y"
SET DIR("A")="Are you sure you want to do this"
+9 SET DIR("?")="If you enter yes, the test/specimen will be associated to this MLTF LOINC code."
+10 SET DIR("B")="Yes"
+11 DO ^DIR
+12 IF $DATA(DIRUT)
SET LRNO=1
QUIT
+13 IF Y<1
SET LRNO=1
+14 QUIT
