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

LR7OU4.m

Go to the documentation of this file. 
  1. LR7OU4 ;DALOI/DCM/FHS/RLM-NLT LINKING UTILITY AUTO ;8/11/97
  1.  ;;5.2T9;LR;**1018**;Nov 17, 2004
  1.  ;;5.2;LAB SERVICE;**127,163,272**;Sep 27, 1994
  1.  ; Reference to ^DIC supported by IA #10007
  1.  ; Reference to YN^DICN supported by IA #10009
  1.  ; Reference to ^DIE supported by IA #10018
  1.  ; Reference to ^DIK supported by IA #10013
  1.  ; Reference to ^DIR supported by IA #10026
  1.  ; Reference to $$CJ^XLFSTR supported by IA #10104
  1.  ; Reference to $$LOW^XLFSTR supported by IA #10104
  1. EN ;
  1. 64 ;Find matches between file 64 and 60
  1.  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)
  1.  W !,$$CJ^XLFSTR("these files. Tests with the type of NEITHER will be omitted during link phase.",80)
  1.  W !!,$$CJ^XLFSTR("ONLY GENERIC NLT CODES CAN BE LINKED TO LAB TEST ",80),!!
  1.  W !,$$CJ^XLFSTR("Those LAB TEST already linked to the NLT file will also be omitted.",80),!
  1. LIST ;
  1.  K DIR S DIR("A")="Would you like a list of WKLD CODES from LABORATORY TEST file",DIR(0)="Y",DIR("B")="No"
  1.  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
  1.  . D ^LRCAPD K DIR S DIR("A")="Ready to start linkage procedure ",DIR(0)="Y"
  1.  . D ^DIR
  1.  W ! K DIR S DIR("A")="Ready to proceed",DIR(0)="Y"
  1.  D ^DIR G:$D(DTOUT)!($D(DUOUT))!($D(DIROUT))!(Y'=1) END
  1. LK W !!,$$CJ^XLFSTR("Do you want to automatically link entries when there is an exact match",80)
  1.  W !,$$CJ^XLFSTR("on the NAME in both files",80) S %=2 D YN^DICN G:%=-1 END
  1.  I %=0 W !!,$$CJ^XLFSTR("Answer YES to automatically link the entries, or NO to be prompted for each",80) G LK
  1.  S AUTO=$S(%=1:1,1:0)
  1. LAB ;
  1.  S (END,LRN)="" F  S LRN=$O(^LAB(60,"B",LRN)) Q:LRN=""!($G(END))  D
  1.  . S LRIEN="" F  S LRIEN=+$O(^LAB(60,"B",LRN,LRIEN)) Q:LRIEN<1!($G(END))  I '$G(^(LRIEN)) D CHECK
  1.  W:'$G(END) !!,$$CJ^XLFSTR("End of loop",80),!
  1.  G END
  1.  Q
  1. CHECK ;
  1.  Q:'$D(^LAB(60,LRIEN,0))#2!($G(^LAB(60,LRIEN,64)))!($G(END))
  1.  S LRDATA=$P(^LAB(60,LRIEN,0),U),LRTY=$P(^(0),U,3) Q:LRTY=""!(LRTY="N")
  1.  S LRNU=$$UPPER(LRN),LRMIEN=+$O(^LAM("D",LRNU,0)) D:'LRMIEN 91 Q:(('LRMIEN)!($G(END)))
  1.  Q:'$D(^LAM(LRMIEN,0))#2  S LRCODE=$P($P(^(0),U,2),".",1)_".0000 " Q:'LRCODE
  1.  S LRMIEN=$O(^LAM("C",LRCODE,0)) Q:('LRMIEN)!('$D(^LAM(LRMIEN,0))#2)
  1.  S LRMNAME=$P(^LAM(LRMIEN,0),U)
  1.  Q:'$D(^LAM(LRMIEN,0))  S LRMNAME=$P(^(0),U)
  1.  W !!,"60 = ",LRDATA,!,"64 = ",LRMNAME_"   "_LRCODE
  1.  D LINK(LRIEN,LRMIEN,AUTO)
  1.  Q
  1. 91 ;Look for Accession WKLD codes
  1.  G:'$O(^LAB(60,LRIEN,9.1,0)) 9
  1.  W !!,$C(7),?5,"Did not find a exact name match for Lab Test "_LRDATA
  1.  W !," Want to use a Accession WKLD code instead?",!
  1.  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)
  1.  W ! K DIC S DIC="^LAB(60,"_LRIEN_",9.1,",DIC(0)="AQNMZ",DIC("A")="Select Accession WKLD if appropriate " D ^DIC W !
  1.  S:$E(X)=U!($G(DTOUT)) END=1 Q:$G(END)  I Y>0 S LRMIEN=+Y Q
  1. 9 ;Look for Verify WKLD codes
  1.  Q:'$O(^LAB(60,LRIEN,9,0))
  1.  W !!,$C(7),?5,"Did not find a exact name match for Lab Test "_LRDATA
  1.  W !," Want to use a Verify WKLD code instead?",!
  1.  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)
  1.  W ! K DIC S DIC="^LAB(60,"_LRIEN_",9,",DIC(0)="AQNMZ",DIC("A")="Select Verify WKLD if appropriate " D ^DIC W !
  1.  S:$E(X)=U!($G(DTOUT)) END=1 Q:$G(END)!(Y<1)  S LRMIEN=+Y
  1.  Q
  1.  S LRDATA="`"_X60 I DOIT S %=1 G L2
  1. L1 W !?5,"Link the two entries" S %=2 D YN^DICN Q:%=2  I %=-1 S END=1 Q
  1.  I $G(DTOUT) S END=1 Q
  1.  I %=0 W !,"Enter Yes to link the entries, No to leave it alone." G L1
  1. L2 D:$G(^LAB(60,X60,64)) DXSS
  1.  K DIE,DA,DR,DIC S DIE="^LAB(60,",DA=X60,DR="64////^S X=X64",DLAYGO=60 D ^DIE K DLAYGO
  1. 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
  1.  S DIC("V")="I +Y(0)=60" D ^DIE K DIC K DLAYGO
  1.  I $G(^LAB(60,X60,64))&($D(^LAM("AE","LAB(60,",X60))) W !?32,"o----LINKED----o",! H 1 Q
  1.  W !!?15,"***************** NOT LINKED ***************",!
  1.  W !!?5,"Press Return to continue" R X:DTIME S:$G(DTOUT)!($E(X)=U) END=1
  1.  Q
  1. DXSS N DIE,DA,DR,DIC,DIK,DLAYGO
  1.  S DA(1)=+$G(^LAB(60,X60,64)),DIK="^LAM("_DA(1)_",7,",DLAYGO=64
  1.  S DA=$O(^LAM(DA(1),7,"B",X60_";LAB(60,",0))
  1.  D:DA&(DA(1)) ^DIK
  1.  Q
  1. END ;
  1.  Q:$G(LRDBUG)
  1.  K %,AUTO,DA,DIC,DIE,DIR,DOIT,DR,END,LRDATA,LRIEN,LRMIEN,LRN,LRNU
  1.  K LRSUF,LRTY,X,X60,X64,Y,LRMNAME,D1,D0,DLAYGO,I,LRCODE,END
  1.  K FLG,XXX,ZZ,ZZ1,X,Y,Y64,DLAYGO
  1.  Q
  1. UPPER(X) ; Convert lower case X to UPPER CASE
  1.  Q $TR(X,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
  1. 60(X) ;Find matching item in file 60
  1.  N XXX S XXX=X K SSS
  1.  S X=$O(^LAB(60,"B",X,0)),ZZ1="",ZZ=""
  1.  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
  1.  I X S ZZ=X,X=$P(^LAB(60,X,0),"^"),ZZ1=$P($G(^(64)),"^")
  1.  I ZZ1 W !,$P(^LAM(ZZ1,0),"^")_" => "_X,?60,"Already linked" S X="",LINKED=1
  1.  Q X
  1. MIXED(X,FLG) ;Return mixed case
  1.  ;X=TEXT
  1.  ;FLG-1 all text lower case, 0 mixed case, 2 1st letter of each word caps
  1.  N Z,I
  1.  I 'FLG S X=$E(X,1)_$$LOW^XLFSTR($E(X,2,$L(X)))
  1.  I FLG=1 S X=$$LOW^XLFSTR($E(X,1,$L(X)))
  1.  I FLG=2 S Z="" D
  1.  . F I=1:1:$L(X," ") S Z=Z_$S(I>1:" ",1:"")_$$MIXED($P(X," ",I),0)
  1.  . S X=Z
  1.  Q X