LR7OU4 ;DALOI/DCM/FHS/RLM-NLT LINKING UTILITY AUTO ;8/11/97
;;5.2;LAB SERVICE;**127,163,272**;Sep 27, 1994
; Reference to ^DIC supported by IA #10007
; Reference to YN^DICN supported by IA #10009
; Reference to ^DIE supported by IA #10018
; Reference to ^DIK supported by IA #10013
; Reference to ^DIR supported by IA #10026
; Reference to $$CJ^XLFSTR supported by IA #10104
; Reference to $$LOW^XLFSTR supported by IA #10104
EN ;
64 ;Find matches between file 64 and 60
W !,$$CJ^XLFSTR("This option will look for potential matches between file 64 (NLT) and file 60.",80),!,$$CJ^XLFSTR("You will be allowed to create a permanent link between matching entries in",80)
W !,$$CJ^XLFSTR("these files. Tests with the type of NEITHER will be omitted during link phase.",80)
W !!,$$CJ^XLFSTR("ONLY GENERIC NLT CODES CAN BE LINKED TO LAB TEST ",80),!!
W !,$$CJ^XLFSTR("Those LAB TEST already linked to the NLT file will also be omitted.",80),!
LIST ;
K DIR S DIR("A")="Would you like a list of WKLD CODES from LABORATORY TEST file",DIR(0)="Y",DIR("B")="No"
D ^DIR G:$D(DIRUT)!($D(DTOUT))!($D(DUOUT)) END I Y=1 D G:$D(DIRUT)!($D(DTOUT))!($D(DUOUT))!(Y=0) END G LK
. D ^LRCAPD K DIR S DIR("A")="Ready to start linkage procedure ",DIR(0)="Y"
. D ^DIR
W ! K DIR S DIR("A")="Ready to proceed",DIR(0)="Y"
D ^DIR G:$D(DTOUT)!($D(DUOUT))!($D(DIROUT))!(Y'=1) END
LK W !!,$$CJ^XLFSTR("Do you want to automatically link entries when there is an exact match",80)
W !,$$CJ^XLFSTR("on the NAME in both files",80) S %=2 D YN^DICN G:%=-1 END
I %=0 W !!,$$CJ^XLFSTR("Answer YES to automatically link the entries, or NO to be prompted for each",80) G LK
S AUTO=$S(%=1:1,1:0)
LAB ;
S (END,LRN)="" F S LRN=$O(^LAB(60,"B",LRN)) Q:LRN=""!($G(END)) D
. S LRIEN="" F S LRIEN=+$O(^LAB(60,"B",LRN,LRIEN)) Q:LRIEN<1!($G(END)) I '$G(^(LRIEN)) D CHECK
W:'$G(END) !!,$$CJ^XLFSTR("End of loop",80),!
G END
Q
CHECK ;
Q:'$D(^LAB(60,LRIEN,0))#2!($G(^LAB(60,LRIEN,64)))!($G(END))
S LRDATA=$P(^LAB(60,LRIEN,0),U),LRTY=$P(^(0),U,3) Q:LRTY=""!(LRTY="N")
S LRNU=$$UPPER(LRN),LRMIEN=+$O(^LAM("D",LRNU,0)) D:'LRMIEN 91 Q:(('LRMIEN)!($G(END)))
Q:'$D(^LAM(LRMIEN,0))#2 S LRCODE=$P($P(^(0),U,2),".",1)_".0000 " Q:'LRCODE
S LRMIEN=$O(^LAM("C",LRCODE,0)) Q:('LRMIEN)!('$D(^LAM(LRMIEN,0))#2)
S LRMNAME=$P(^LAM(LRMIEN,0),U)
Q:'$D(^LAM(LRMIEN,0)) S LRMNAME=$P(^(0),U)
W !!,"60 = ",LRDATA,!,"64 = ",LRMNAME_" "_LRCODE
D LINK(LRIEN,LRMIEN,AUTO)
Q
91 ;Look for Accession WKLD codes
G:'$O(^LAB(60,LRIEN,9.1,0)) 9
W !!,$C(7),?5,"Did not find a exact name match for Lab Test "_LRDATA
W !," Want to use a Accession WKLD code instead?",!
S I=0 F S I=$O(^LAB(60,LRIEN,9.1,I)) Q:I<1 W:$D(^LAM(I,0))#2 !?2,$P(^(0),U),?50,$P(^(0),U,2)
W ! K DIC S DIC="^LAB(60,"_LRIEN_",9.1,",DIC(0)="AQNMZ",DIC("A")="Select Accession WKLD if appropriate " D ^DIC W !
S:$E(X)=U!($G(DTOUT)) END=1 Q:$G(END) I Y>0 S LRMIEN=+Y Q
9 ;Look for Verify WKLD codes
Q:'$O(^LAB(60,LRIEN,9,0))
W !!,$C(7),?5,"Did not find a exact name match for Lab Test "_LRDATA
W !," Want to use a Verify WKLD code instead?",!
S I=0 F S I=$O(^LAB(60,LRIEN,9,I)) Q:I<1 W:$D(^LAM(I,0))#2 !?2,$P(^(0),U),?50,$P(^(0),U,2)
W ! K DIC S DIC="^LAB(60,"_LRIEN_",9,",DIC(0)="AQNMZ",DIC("A")="Select Verify WKLD if appropriate " D ^DIC W !
S:$E(X)=U!($G(DTOUT)) END=1 Q:$G(END)!(Y<1) S LRMIEN=+Y
Q
LINK(X60,X64,DOIT) ;Link the 2 files
S LRDATA="`"_X60 I DOIT S %=1 G L2
L1 W !?5,"Link the two entries" S %=2 D YN^DICN Q:%=2 I %=-1 S END=1 Q
I $G(DTOUT) S END=1 Q
I %=0 W !,"Enter Yes to link the entries, No to leave it alone." G L1
L2 D:$G(^LAB(60,X60,64)) DXSS
K DIE,DA,DR,DIC S DIE="^LAB(60,",DA=X60,DR="64////^S X=X64",DLAYGO=60 D ^DIE K DLAYGO
XSS K DIE,DA,DR,DIC S DIE="^LAM(",DA=X64,DR="23///^S X=LRDATA;",DR(1,64)="23///^S X=LRDATA;",DR(2,64.023)=".01////LRDATA;",DLAYGO=64
S DIC("V")="I +Y(0)=60" D ^DIE K DIC K DLAYGO
I $G(^LAB(60,X60,64))&($D(^LAM("AE","LAB(60,",X60))) W !?32,"o----LINKED----o",! H 1 Q
W !!?15,"***************** NOT LINKED ***************",!
W !!?5,"Press Return to continue" R X:DTIME S:$G(DTOUT)!($E(X)=U) END=1
Q
DXSS N DIE,DA,DR,DIC,DIK,DLAYGO
S DA(1)=+$G(^LAB(60,X60,64)),DIK="^LAM("_DA(1)_",7,",DLAYGO=64
S DA=$O(^LAM(DA(1),7,"B",X60_";LAB(60,",0))
D:DA&(DA(1)) ^DIK
Q
END ;
Q:$G(LRDBUG)
K %,AUTO,DA,DIC,DIE,DIR,DOIT,DR,END,LRDATA,LRIEN,LRMIEN,LRN,LRNU
K LRSUF,LRTY,X,X60,X64,Y,LRMNAME,D1,D0,DLAYGO,I,LRCODE,END
K FLG,XXX,ZZ,ZZ1,X,Y,Y64,DLAYGO
Q
UPPER(X) ; Convert lower case X to UPPER CASE
Q $TR(X,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
60(X) ;Find matching item in file 60
N XXX S XXX=X K SSS
S X=$O(^LAB(60,"B",X,0)),ZZ1="",ZZ=""
I 'X S X=$O(^LAB(60,"B",XXX)),X=$S($E(X,$L(X))="S"&($E(X,1,$L(X)-1)=XXX):$O(^LAB(60,"B",XXX,0)),1:"") S:$L(X) SSS=1
I X S ZZ=X,X=$P(^LAB(60,X,0),"^"),ZZ1=$P($G(^(64)),"^")
I ZZ1 W !,$P(^LAM(ZZ1,0),"^")_" => "_X,?60,"Already linked" S X="",LINKED=1
Q X
MIXED(X,FLG) ;Return mixed case
;X=TEXT
;FLG-1 all text lower case, 0 mixed case, 2 1st letter of each word caps
N Z,I
I 'FLG S X=$E(X,1)_$$LOW^XLFSTR($E(X,2,$L(X)))
I FLG=1 S X=$$LOW^XLFSTR($E(X,1,$L(X)))
I FLG=2 S Z="" D
. F I=1:1:$L(X," ") S Z=Z_$S(I>1:" ",1:"")_$$MIXED($P(X," ",I),0)
. S X=Z
Q X
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLR7OU4 5320 printed Sep 23, 2025@19:41:30 Page 2
LR7OU4 ;DALOI/DCM/FHS/RLM-NLT LINKING UTILITY AUTO ;8/11/97
+1 ;;5.2;LAB SERVICE;**127,163,272**;Sep 27, 1994
+2 ; Reference to ^DIC supported by IA #10007
+3 ; Reference to YN^DICN supported by IA #10009
+4 ; Reference to ^DIE supported by IA #10018
+5 ; Reference to ^DIK supported by IA #10013
+6 ; Reference to ^DIR supported by IA #10026
+7 ; Reference to $$CJ^XLFSTR supported by IA #10104
+8 ; Reference to $$LOW^XLFSTR supported by IA #10104
EN ;
64 ;Find matches between file 64 and 60
+1 WRITE !,$$CJ^XLFSTR("This option will look for potential matches between file 64 (NLT) and file 60.",80),!,$$CJ^XLFSTR("You will be allowed to create a permanent link between matching entries in",80)
+2 WRITE !,$$CJ^XLFSTR("these files. Tests with the type of NEITHER will be omitted during link phase.",80)
+3 WRITE !!,$$CJ^XLFSTR("ONLY GENERIC NLT CODES CAN BE LINKED TO LAB TEST ",80),!!
+4 WRITE !,$$CJ^XLFSTR("Those LAB TEST already linked to the NLT file will also be omitted.",80),!
LIST ;
+1 KILL DIR
SET DIR("A")="Would you like a list of WKLD CODES from LABORATORY TEST file"
SET DIR(0)="Y"
SET DIR("B")="No"
+2 DO ^DIR
if $DATA(DIRUT)!($DATA(DTOUT))!($DATA(DUOUT))
GOTO END
IF Y=1
Begin DoDot:1
+3 DO ^LRCAPD
KILL DIR
SET DIR("A")="Ready to start linkage procedure "
SET DIR(0)="Y"
+4 DO ^DIR
End DoDot:1
if $DATA(DIRUT)!($DATA(DTOUT))!($DATA(DUOUT))!(Y=0)
GOTO END
GOTO LK
+5 WRITE !
KILL DIR
SET DIR("A")="Ready to proceed"
SET DIR(0)="Y"
+6 DO ^DIR
if $DATA(DTOUT)!($DATA(DUOUT))!($DATA(DIROUT))!(Y'=1)
GOTO END
LK WRITE !!,$$CJ^XLFSTR("Do you want to automatically link entries when there is an exact match",80)
+1 WRITE !,$$CJ^XLFSTR("on the NAME in both files",80)
SET %=2
DO YN^DICN
if %=-1
GOTO END
+2 IF %=0
WRITE !!,$$CJ^XLFSTR("Answer YES to automatically link the entries, or NO to be prompted for each",80)
GOTO LK
+3 SET AUTO=$SELECT(%=1:1,1:0)
LAB ;
+1 SET (END,LRN)=""
FOR
SET LRN=$ORDER(^LAB(60,"B",LRN))
if LRN=""!($GET(END))
QUIT
Begin DoDot:1
+2 SET LRIEN=""
FOR
SET LRIEN=+$ORDER(^LAB(60,"B",LRN,LRIEN))
if LRIEN<1!($GET(END))
QUIT
IF '$GET(^(LRIEN))
DO CHECK
End DoDot:1
+3 if '$GET(END)
WRITE !!,$$CJ^XLFSTR("End of loop",80),!
+4 GOTO END
+5 QUIT
CHECK ;
+1 if '$DATA(^LAB(60,LRIEN,0))#2!($GET(^LAB(60,LRIEN,64)))!($GET(END))
QUIT
+2 SET LRDATA=$PIECE(^LAB(60,LRIEN,0),U)
SET LRTY=$PIECE(^(0),U,3)
if LRTY=""!(LRTY="N")
QUIT
+3 SET LRNU=$$UPPER(LRN)
SET LRMIEN=+$ORDER(^LAM("D",LRNU,0))
if 'LRMIEN
DO 91
if (('LRMIEN)!($GET(END)))
QUIT
+4 if '$DATA(^LAM(LRMIEN,0))#2
QUIT
SET LRCODE=$PIECE($PIECE(^(0),U,2),".",1)_".0000 "
if 'LRCODE
QUIT
+5 SET LRMIEN=$ORDER(^LAM("C",LRCODE,0))
if ('LRMIEN)!('$DATA(^LAM(LRMIEN,0))#2)
QUIT
+6 SET LRMNAME=$PIECE(^LAM(LRMIEN,0),U)
+7 if '$DATA(^LAM(LRMIEN,0))
QUIT
SET LRMNAME=$PIECE(^(0),U)
+8 WRITE !!,"60 = ",LRDATA,!,"64 = ",LRMNAME_" "_LRCODE
+9 DO LINK(LRIEN,LRMIEN,AUTO)
+10 QUIT
91 ;Look for Accession WKLD codes
+1 if '$ORDER(^LAB(60,LRIEN,9.1,0))
GOTO 9
+2 WRITE !!,$CHAR(7),?5,"Did not find a exact name match for Lab Test "_LRDATA
+3 WRITE !," Want to use a Accession WKLD code instead?",!
+4 SET I=0
FOR
SET I=$ORDER(^LAB(60,LRIEN,9.1,I))
if I<1
QUIT
if $DATA(^LAM(I,0))#2
WRITE !?2,$PIECE(^(0),U),?50,$PIECE(^(0),U,2)
+5 WRITE !
KILL DIC
SET DIC="^LAB(60,"_LRIEN_",9.1,"
SET DIC(0)="AQNMZ"
SET DIC("A")="Select Accession WKLD if appropriate "
DO ^DIC
WRITE !
+6 if $EXTRACT(X)=U!($GET(DTOUT))
SET END=1
if $GET(END)
QUIT
IF Y>0
SET LRMIEN=+Y
QUIT
9 ;Look for Verify WKLD codes
+1 if '$ORDER(^LAB(60,LRIEN,9,0))
QUIT
+2 WRITE !!,$CHAR(7),?5,"Did not find a exact name match for Lab Test "_LRDATA
+3 WRITE !," Want to use a Verify WKLD code instead?",!
+4 SET I=0
FOR
SET I=$ORDER(^LAB(60,LRIEN,9,I))
if I<1
QUIT
if $DATA(^LAM(I,0))#2
WRITE !?2,$PIECE(^(0),U),?50,$PIECE(^(0),U,2)
+5 WRITE !
KILL DIC
SET DIC="^LAB(60,"_LRIEN_",9,"
SET DIC(0)="AQNMZ"
SET DIC("A")="Select Verify WKLD if appropriate "
DO ^DIC
WRITE !
+6 if $EXTRACT(X)=U!($GET(DTOUT))
SET END=1
if $GET(END)!(Y<1)
QUIT
SET LRMIEN=+Y
+7 QUIT
LINK(X60,X64,DOIT) ;Link the 2 files
+1 SET LRDATA="`"_X60
IF DOIT
SET %=1
GOTO L2
L1 WRITE !?5,"Link the two entries"
SET %=2
DO YN^DICN
if %=2
QUIT
IF %=-1
SET END=1
QUIT
+1 IF $GET(DTOUT)
SET END=1
QUIT
+2 IF %=0
WRITE !,"Enter Yes to link the entries, No to leave it alone."
GOTO L1
L2 if $GET(^LAB(60,X60,64))
DO DXSS
+1 KILL DIE,DA,DR,DIC
SET DIE="^LAB(60,"
SET DA=X60
SET DR="64////^S X=X64"
SET DLAYGO=60
DO ^DIE
KILL DLAYGO
XSS KILL DIE,DA,DR,DIC
SET DIE="^LAM("
SET DA=X64
SET DR="23///^S X=LRDATA;"
SET DR(1,64)="23///^S X=LRDATA;"
SET DR(2,64.023)=".01////LRDATA;"
SET DLAYGO=64
+1 SET DIC("V")="I +Y(0)=60"
DO ^DIE
KILL DIC
KILL DLAYGO
+2 IF $GET(^LAB(60,X60,64))&($DATA(^LAM("AE","LAB(60,",X60)))
WRITE !?32,"o----LINKED----o",!
HANG 1
QUIT
+3 WRITE !!?15,"***************** NOT LINKED ***************",!
+4 WRITE !!?5,"Press Return to continue"
READ X:DTIME
if $GET(DTOUT)!($EXTRACT(X)=U)
SET END=1
+5 QUIT
DXSS NEW DIE,DA,DR,DIC,DIK,DLAYGO
+1 SET DA(1)=+$GET(^LAB(60,X60,64))
SET DIK="^LAM("_DA(1)_",7,"
SET DLAYGO=64
+2 SET DA=$ORDER(^LAM(DA(1),7,"B",X60_";LAB(60,",0))
+3 if DA&(DA(1))
DO ^DIK
+4 QUIT
END ;
+1 if $GET(LRDBUG)
QUIT
+2 KILL %,AUTO,DA,DIC,DIE,DIR,DOIT,DR,END,LRDATA,LRIEN,LRMIEN,LRN,LRNU
+3 KILL LRSUF,LRTY,X,X60,X64,Y,LRMNAME,D1,D0,DLAYGO,I,LRCODE,END
+4 KILL FLG,XXX,ZZ,ZZ1,X,Y,Y64,DLAYGO
+5 QUIT
UPPER(X) ; Convert lower case X to UPPER CASE
+1 QUIT $TRANSLATE(X,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
60(X) ;Find matching item in file 60
+1 NEW XXX
SET XXX=X
KILL SSS
+2 SET X=$ORDER(^LAB(60,"B",X,0))
SET ZZ1=""
SET ZZ=""
+3 IF 'X
SET X=$ORDER(^LAB(60,"B",XXX))
SET X=$SELECT($EXTRACT(X,$LENGTH(X))="S"&($EXTRACT(X,1,$LENGTH(X)-1)=XXX):$ORDER(^LAB(60,"B",XXX,0)),1:"")
if $LENGTH(X)
SET SSS=1
+4 IF X
SET ZZ=X
SET X=$PIECE(^LAB(60,X,0),"^")
SET ZZ1=$PIECE($GET(^(64)),"^")
+5 IF ZZ1
WRITE !,$PIECE(^LAM(ZZ1,0),"^")_" => "_X,?60,"Already linked"
SET X=""
SET LINKED=1
+6 QUIT X
MIXED(X,FLG) ;Return mixed case
+1 ;X=TEXT
+2 ;FLG-1 all text lower case, 0 mixed case, 2 1st letter of each word caps
+3 NEW Z,I
+4 IF 'FLG
SET X=$EXTRACT(X,1)_$$LOW^XLFSTR($EXTRACT(X,2,$LENGTH(X)))
+5 IF FLG=1
SET X=$$LOW^XLFSTR($EXTRACT(X,1,$LENGTH(X)))
+6 IF FLG=2
SET Z=""
Begin DoDot:1
+7 FOR I=1:1:$LENGTH(X," ")
SET Z=Z_$SELECT(I>1:" ",1:"")_$$MIXED($PIECE(X," ",I),0)
+8 SET X=Z
End DoDot:1
+9 QUIT X
