Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: LRMLWT

LRMLWT.m

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