LRMLACM ;BPFO/DTG - LAB ASSOCIATE TEST/SPECIMEN TO MLTF ;02/10/2016
;;5.2;LAB SERVICE;**468,500**;Sep 27, 1994;Build 29
;
; Associate Lab Test/Specimen to MLTF
EN ; entry point for association
N LR60IEN,LRIEN,LRSPEC,A,B,C,LXB,LXA,LROKS,LRSYSTEM,LRLEC,LRNO,AA,DA,LXC,LXA,LRSPERR,LRMLTF,DIR,DIRUT,DIC,DIQ
N LR64ER,LRCKD,LRELEC,LRLNC,LRLNC0,LRN,LRSN,LRTNAM,X,Y
S U="^" I $G(DT)="" S DT=$$DT^XLFDT
ENA K DIR,DIRUT
S DIR(0)="PO^60:EQZM",DIR("A")="LABORATORY TEST"
D ^DIR K DIR
I $D(DIRUT) G OUT
I Y<1 G OUT
S (LRIEN)=+Y,LRTNAM=$P(Y,U,2)
D GET60T
; check values
S LRN=$G(LXA(.01,"E")),LR64ER=0
; check test subscript is valid for NTRT
S AA=$G(LXA(4,"I"))
I AA="WK"!(AA="BB")!(AA="AU")!(AA="EM") W !," Subscript is "_AA_" Skipping" G ENA
; check test type
S AA=$G(LXA(3,"I"))
I AA="N"!(AA="D") W !," Test Type is: "_AA_" Skipping" G ENA
; check for data name
I $G(LXA(5,"I"))="" W !," "_LRN_" Missing LOCATION(Data Name) Skipping" G ENA
I $O(^LAB(60,LRIEN,1,0))="" W !," Test "_LRN_" does NOT have any Specimens associated. Skippping" G ENA
;
ENB ; pick up specimen
K DIR,DIRUT
S DIR(0)="PO^LAB(60,"_LRIEN_",1,:EQZM",DIR("A")="SPECIMEN for "_LRN
D ^DIR
I $D(DIRUT) G OUT:$E(X)="^"
I Y<1 G ENA
S LRSPEC=+Y
S DIQ="LXB",DIQ(0)="IE",DIC=60,DR=100,DA=+LRIEN K LXB,^UTILITY("DIQ1",$J)
S DR(60.01)=".01;6;1;2;9.2;9.3;13;30;32;33;34;35",DA(60.01)=LRSPEC
D EN^DIQ1 K ^UTILITY("DIQ1",$J)
K LXC M LXC=LXB("60.01",LRSPEC) K LXB
S LRSN=$G(LXC(.01,"E"))
;
ENM ; mltf lookup
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_"",""))"
S DIR("B")=$G(LXC(30,"E"))
D ^DIR
I Y<1 D G OUT:$D(DIRUT),ENB
. I X'="@" Q
. K DIR,DIRUT
. S DIR(0)="Y",DIR("A")="Are You Sure You Want To Delete This Entry"
. S DIR("?")="If you enter yes, the MLTF association with this test/specimen will be removed."
. S DIR("B")="Yes"
. D ^DIR
. I 'Y!($D(DIRUT)) Q
. I Y=1 D MSD
. ;
I $D(DIRUT) G OUT
I +Y>0&(+Y=$G(LXC(30,"I"))) G ENB
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 ENS
D CHKSPEC G:LROKS=1 ENS
I $D(DIRUT) G OUT:$E(X)="^"
I LRNO=1 W !,"TEST: ",LRN,!,"SPECIMEN: ",LRSN,! G ENM
G ENS
;
ENS D MSET I LRSPERR=1 W !,"NOT able to Save" G ENM
S A=$$GET1^DIQ(60.01,LRSPEC_","_LRIEN,30,"E")
W !!,"Test/Specimen: ",LRN," / ",LRSN,!," Saved With MLTF: ",A,!
G ENB
;
OUT ; exit
K LR60IEN,LRIEN,LRSPEC,A,B,C,AA,DA,LXB,LXA,LROKS,LRSYSTEM,LRLEC,LRNO,LXC,LXA,LRSPERR,LRMLTF,DIR,DIRUT,DIC,DIQ
K LR64ER,LRCKD,LRELEC,LRLNC,LRLNC0,LRN,LRSN,LRTNAM,X,Y
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
;
MSD ; delete the mltf from the 60 file
N LRMLTF S LRMLTF="@" D MSET
K LRMLTF
Q
;
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
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRMLACM 4269 printed Dec 13, 2024@02:17:56 Page 2
LRMLACM ;BPFO/DTG - LAB ASSOCIATE TEST/SPECIMEN TO MLTF ;02/10/2016
+1 ;;5.2;LAB SERVICE;**468,500**;Sep 27, 1994;Build 29
+2 ;
+3 ; Associate Lab Test/Specimen to MLTF
EN ; entry point for association
+1 NEW LR60IEN,LRIEN,LRSPEC,A,B,C,LXB,LXA,LROKS,LRSYSTEM,LRLEC,LRNO,AA,DA,LXC,LXA,LRSPERR,LRMLTF,DIR,DIRUT,DIC,DIQ
+2 NEW LR64ER,LRCKD,LRELEC,LRLNC,LRLNC0,LRN,LRSN,LRTNAM,X,Y
+3 SET U="^"
IF $GET(DT)=""
SET DT=$$DT^XLFDT
ENA KILL DIR,DIRUT
+1 SET DIR(0)="PO^60:EQZM"
SET DIR("A")="LABORATORY TEST"
+2 DO ^DIR
KILL DIR
+3 IF $DATA(DIRUT)
GOTO OUT
+4 IF Y<1
GOTO OUT
+5 SET (LRIEN)=+Y
SET LRTNAM=$PIECE(Y,U,2)
+6 DO GET60T
+7 ; check values
+8 SET LRN=$GET(LXA(.01,"E"))
SET LR64ER=0
+9 ; check test subscript is valid for NTRT
+10 SET AA=$GET(LXA(4,"I"))
+11 IF AA="WK"!(AA="BB")!(AA="AU")!(AA="EM")
WRITE !," Subscript is "_AA_" Skipping"
GOTO ENA
+12 ; check test type
+13 SET AA=$GET(LXA(3,"I"))
+14 IF AA="N"!(AA="D")
WRITE !," Test Type is: "_AA_" Skipping"
GOTO ENA
+15 ; check for data name
+16 IF $GET(LXA(5,"I"))=""
WRITE !," "_LRN_" Missing LOCATION(Data Name) Skipping"
GOTO ENA
+17 IF $ORDER(^LAB(60,LRIEN,1,0))=""
WRITE !," Test "_LRN_" does NOT have any Specimens associated. Skippping"
GOTO ENA
+18 ;
ENB ; pick up specimen
+1 KILL DIR,DIRUT
+2 SET DIR(0)="PO^LAB(60,"_LRIEN_",1,:EQZM"
SET DIR("A")="SPECIMEN for "_LRN
+3 DO ^DIR
+4 IF $DATA(DIRUT)
if $EXTRACT(X)="^"
GOTO OUT
+5 IF Y<1
GOTO ENA
+6 SET LRSPEC=+Y
+7 SET DIQ="LXB"
SET DIQ(0)="IE"
SET DIC=60
SET DR=100
SET DA=+LRIEN
KILL LXB,^UTILITY("DIQ1",$JOB)
+8 SET DR(60.01)=".01;6;1;2;9.2;9.3;13;30;32;33;34;35"
SET DA(60.01)=LRSPEC
+9 DO EN^DIQ1
KILL ^UTILITY("DIQ1",$JOB)
+10 KILL LXC
MERGE LXC=LXB("60.01",LRSPEC)
KILL LXB
+11 SET LRSN=$GET(LXC(.01,"E"))
+12 ;
ENM ; mltf lookup
+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 SET DIR("B")=$GET(LXC(30,"E"))
+7 DO ^DIR
+8 IF Y<1
Begin DoDot:1
+9 IF X'="@"
QUIT
+10 KILL DIR,DIRUT
+11 SET DIR(0)="Y"
SET DIR("A")="Are You Sure You Want To Delete This Entry"
+12 SET DIR("?")="If you enter yes, the MLTF association with this test/specimen will be removed."
+13 SET DIR("B")="Yes"
+14 DO ^DIR
+15 IF 'Y!($DATA(DIRUT))
QUIT
+16 IF Y=1
DO MSD
+17 ;
End DoDot:1
if $DATA(DIRUT)
GOTO OUT
GOTO ENB
+18 IF $DATA(DIRUT)
GOTO OUT
+19 IF +Y>0&(+Y=$GET(LXC(30,"I")))
GOTO ENB
+20 SET LRSPERR=0
SET LRMLTF=+Y
+21 ; check specimen type (based on code from LRLNC0 at CHKSPEC
+22 SET LRELEC=$PIECE($GET(^LAB(61,LRSPEC,0)),U,9)
+23 SET LRLNC0=$$GET1^DIQ(66.3,LRMLTF,.04,"I")
+24 SET LRLNC=$PIECE(LRLNC0,"-",1)
SET LRCKD=$PIECE(LRLNC0,"-",2)
+25 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
+26 ; if not found in 95.3
+27 IF 'A
GOTO ENS
+28 DO CHKSPEC
if LROKS=1
GOTO ENS
+29 IF $DATA(DIRUT)
if $EXTRACT(X)="^"
GOTO OUT
+30 IF LRNO=1
WRITE !,"TEST: ",LRN,!,"SPECIMEN: ",LRSN,!
GOTO ENM
+31 GOTO ENS
+32 ;
ENS DO MSET
IF LRSPERR=1
WRITE !,"NOT able to Save"
GOTO ENM
+1 SET A=$$GET1^DIQ(60.01,LRSPEC_","_LRIEN,30,"E")
+2 WRITE !!,"Test/Specimen: ",LRN," / ",LRSN,!," Saved With MLTF: ",A,!
+3 GOTO ENB
+4 ;
OUT ; exit
+1 KILL LR60IEN,LRIEN,LRSPEC,A,B,C,AA,DA,LXB,LXA,LROKS,LRSYSTEM,LRLEC,LRNO,LXC,LXA,LRSPERR,LRMLTF,DIR,DIRUT,DIC,DIQ
+2 KILL LR64ER,LRCKD,LRELEC,LRLNC,LRLNC0,LRN,LRSN,LRTNAM,X,Y
+3 QUIT
+4 ;
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
+15 ;
MSD ; delete the mltf from the 60 file
+1 NEW LRMLTF
SET LRMLTF="@"
DO MSET
+2 KILL LRMLTF
+3 QUIT
+4 ;
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 ;
