LR7OU5 ;DALOI/DCM/FHS-NLT LINKING UTILITY SEMI-MANUAL ; 2/23/07 6:53am
;;5.2;LAB SERVICE;**127,201,272,334**;Sep 27, 1994;Build 12
; Reference to ^%ZIS supported by IA #10086
; Reference to ^%ZISC supported by IA #10089
; Reference to ^%ZTLOAD supported by IA #10063
; Reference to ^DIC supported by IA #10007
; Reference to ^DIR supported by IA #10026
; Reference to $$HTE^XLFDT supported by IA #10103
; Reference to $$CJ^XLFDT supported by IA #10104
; Reference to $$LJ^XLFDT supported by IA #10104
EN ;
64 ;User assigns links between 60 and 64 (NLT)
D LLIST G:$G(LREND) END
I '$O(^LAB(60,"AD",0)) D H 5
. W !?5,"You have not yet ran the 'Semi-automatic Linking of file 60 to 64' option",!
. W !?20,"[LR70 60-64 AUTO]",!
. W !,"IT IS STRONGLY RECOMMENDED YOU RUN THE AUTOMATIC OPTION FIRST",!!
W !,$$CJ^XLFSTR("This option will allow you to make links between file 64 (NLT) and file 60.",80)
W !,$$CJ^XLFSTR("You may select ANY NLT code to create ",80)
W !,$$CJ^XLFSTR("a linkage of entries between these two files. ",80)
W !,$$CJ^XLFSTR("Tests with the type of NEITHER or null will be skipped in the Auto Mode.",80)
W !,$$CJ^XLFSTR("ONLY ORDERABLE LAB TEST NEED TO BE LINKED TO WKLD CODES.",80),!
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 START
. D ^LRCAPD K DIR S DIR("A")="Ready to start linkage procedure ",DIR(0)="Y"
. D ^DIR
MSG ;
W ! K DIR S DIR("A")="Ready to proceed",DIR(0)="Y"
D ^DIR G:$D(DIRUT)!($D(DTOUT))!($D(DUOUT))!(Y'=1) END
START W ! K DIR S DIR("A")="Select Linking Method ",DIR(0)="S^M:Manual;S:Semi-Auto",DIR("?")="Linking method description"
W !!,$$CJ^XLFSTR(DIR("A"),80)
F I=1:1 S LN=$P($T(TXT+I),";;",2) Q:LN="END" S DIR("?",I)=LN W !,$$LJ^XLFSTR(LN,80)
W !! K LN D ^DIR K DIR G:$D(DIRUT)!($D(DTOUT))!($D(DUOUT)) END G:Y="M" SEL
LIST ;Print LOINC Code Status
K DIR W !!?5,"Select a starting TEST NAME " R LRN:DTIME G:'$T!($E(LRN)=U) END
LK ;
W ! S AUTO=0 S:$L(LRN)>1 LRN=$E(LRN,1,($L(LRN)-1))
LAB ;
S END="" 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 ;
K DIC 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")
D I $G(LRMIEN) S:($D(^LAM(LRMIEN,0))#2) Y=LRMIEN,Y(0)=^(0),LRCODE=$P(Y(0),U,2),LRMNAME=$P(Y(0),U) G OK
. K LRMIEN D 91^LR7OU4
. Q:'$G(LRMIEN)!'($D(^LAM(+$G(LRMIEN),0))#2) S LRCODE=$P($P(^(0),U,2),".",1)_".0000 " I 'LRCODE W !,"Database is corrupted for WKLD CODE ",LRCODE S LRMIEN="" Q
. S LRMIEN=$O(^LAM("C",LRCODE,0)) Q:('LRMIEN)!'($D(^LAM(LRMIEN,0))#2)
K DIC S DIC="^LAM(",DIC(0)="AQEZNM"
W !,$$CJ^XLFSTR("Select NLT code to be linked with LAB TEST",80),!,$$CJ^XLFSTR(LRDATA,80),!
D ^DIC S:$E(X)=U END=1 Q:$G(END)!(Y<1)
S LRMIEN=+Y,LRMNAME=$P(Y(0),U),LRCODE=$P(Y(0),U,2)
OK I '($D(^LAM(LRMIEN,0))#2) W !!,"Database is corrupted for IEN ",LRMIEN Q
W !!,"60 = ",LRDATA,!,"64 = ",LRMNAME_" "_LRCODE
D LINK^LR7OU4(LRIEN,LRMIEN,AUTO)
Q
END ;
K LREND,LRANS,LRN,LRTY,ZTSAVE D END^LR7OU4
K LINKED,LRMNAME,LRNLT,POP,ZTRTN,ZTDESC,ZTQUEUED
K DIROUT,DIRUT,DTOUT,DUOUT,ZTDESC,X1,X60,X64,Y64 Q
SEL ;
S AUTO=0
K DIC,DIR S DIC("A")="You may select any test in LABORATORY TEST FILE: "
S DIC="^LAB(60,",DIC(0)="AEQZMN" D ^DIC G:Y<1 END
S LRDATA=$P(Y(0),U),(LRIEN,X60)=+Y
I $G(^LAB(60,X60,64)),$D(^LAM(+^(64),0)) S Y64=^(0) D
. W !!?5,"Currently linked to [ ",$P(Y64,U)_" ] "_$P(Y64,U,2),!!
W !!,"Now select ANY WKLD CODE for "_LRDATA,!!
K DIC S DIC="^LAM(",DIC(0)="AEQZNM",DIC("A")="WKLD CODE: "
D ^DIC G:Y<1 SEL S (LRMIEN,X64)=+Y,LRMNAME=$P(Y(0),U),LRCODE=$P(Y(0),U,2)
D OK G SEL
TXT ;;
;; Linking options description
;;ONLY ORDERABLE LAB TEST NEED TO BE LINKED TO WKLD CODES.
;;
;;(S) You can use the semi automated method, which will provide a
;;alphabetical listing of LABORATORY TEST names. The system will prompt
;;you for those tests not already assigned a WKLD CODE.
;;Tests with null TYPE or with the type of NEITHER are excluded.
;;
;;(M) Using the Manual method, you are able to select ANY test
;;regardless of the type field in the LABORATORY TEST file,
;;and assign it a WKLD CODE. If the test is already linked
;;the system will display the code and allow you to change
;;the WKLD CODE assigned. This method will allow you to
;;change linked LABORATORY TEST to another WKLD CODE.
;;END
Q
LLIST ;
W !?5,"Would you like a list of Laboratory Tests"
K DIR S DIR(0)="S^0:No;1:ALL;2:Linked;3:Unlinked" D ^DIR
Q:$D(DIRUT)!($D(DTOUT))!($D(DUOUT))!(Y=0)
S LRANS=Y
K %ZIS S %ZIS="Q" D ^%ZIS Q:POP I $D(IO("Q")) K ZTSAVE S ZTRTN="DQ^LR7OU5",ZTSAVE("LRANS")="",ZTDESC="LAB TEST LIST" D ^%ZTLOAD,^%ZISC Q
DQ U IO I $D(ZTQUEUED) S ZTREQ="@"
W !!?5,"Listing of ",$S(LRANS=1:"ALL",LRANS=2:"LINKED",1:"UNLINKED")," Laboratory Test [ ",$$HTE^XLFDT($H)," ] ",!!
S LRN="" F S LRN=$O(^LAB(60,"B",LRN)) Q:LRN=""!($G(LREND)) S LRIEN="" D
. F S LRIEN=+$O(^LAB(60,"B",LRN,LRIEN)) Q:LRIEN<0!($G(^(LRIEN)))!($G(LREND)) Q:'$D(^LAB(60,LRIEN,0)) S LRTY=$P(^(0),U,3) Q:LRTY="" D
. . I LRANS=1 D PRT Q
. . I LRANS=2,$G(^LAB(60,LRIEN,64)) D PRT Q
. . I LRANS=3,'$G(^LAB(60,LRIEN,64)) D PRT Q
W:$E(IOST,1,2)="P-" @IOF D ^%ZISC Q
PRT ;
W !?5,LRN,?45,$S(LRTY="B":"BOTH",LRTY="N":"NEITHER",LRTY="O":"OUTPUT",1:"INPUT"),!
S LRNLT=$G(^LAB(60,LRIEN,64)) I LRNLT,$D(^LAM(LRNLT,0)) W $P(^(0),U,2),?15,$P(^(0),U)
W ! Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLR7OU5 5761 printed Apr 09, 2024@21:06:24 Page 2
LR7OU5 ;DALOI/DCM/FHS-NLT LINKING UTILITY SEMI-MANUAL ; 2/23/07 6:53am
+1 ;;5.2;LAB SERVICE;**127,201,272,334**;Sep 27, 1994;Build 12
+2 ; Reference to ^%ZIS supported by IA #10086
+3 ; Reference to ^%ZISC supported by IA #10089
+4 ; Reference to ^%ZTLOAD supported by IA #10063
+5 ; Reference to ^DIC supported by IA #10007
+6 ; Reference to ^DIR supported by IA #10026
+7 ; Reference to $$HTE^XLFDT supported by IA #10103
+8 ; Reference to $$CJ^XLFDT supported by IA #10104
+9 ; Reference to $$LJ^XLFDT supported by IA #10104
EN ;
64 ;User assigns links between 60 and 64 (NLT)
+1 DO LLIST
if $GET(LREND)
GOTO END
+2 IF '$ORDER(^LAB(60,"AD",0))
Begin DoDot:1
+3 WRITE !?5,"You have not yet ran the 'Semi-automatic Linking of file 60 to 64' option",!
+4 WRITE !?20,"[LR70 60-64 AUTO]",!
+5 WRITE !,"IT IS STRONGLY RECOMMENDED YOU RUN THE AUTOMATIC OPTION FIRST",!!
End DoDot:1
HANG 5
+6 WRITE !,$$CJ^XLFSTR("This option will allow you to make links between file 64 (NLT) and file 60.",80)
+7 WRITE !,$$CJ^XLFSTR("You may select ANY NLT code to create ",80)
+8 WRITE !,$$CJ^XLFSTR("a linkage of entries between these two files. ",80)
+9 WRITE !,$$CJ^XLFSTR("Tests with the type of NEITHER or null will be skipped in the Auto Mode.",80)
+10 WRITE !,$$CJ^XLFSTR("ONLY ORDERABLE LAB TEST NEED TO BE LINKED TO WKLD CODES.",80),!
+11 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"
+12 DO ^DIR
if $DATA(DIRUT)!($DATA(DTOUT))!($DATA(DUOUT))
GOTO END
IF Y=1
Begin DoDot:1
+13 DO ^LRCAPD
KILL DIR
SET DIR("A")="Ready to start linkage procedure "
SET DIR(0)="Y"
+14 DO ^DIR
End DoDot:1
if $DATA(DIRUT)!($DATA(DTOUT))!($DATA(DUOUT))!(Y=0)
GOTO END
GOTO START
MSG ;
+1 WRITE !
KILL DIR
SET DIR("A")="Ready to proceed"
SET DIR(0)="Y"
+2 DO ^DIR
if $DATA(DIRUT)!($DATA(DTOUT))!($DATA(DUOUT))!(Y'=1)
GOTO END
START WRITE !
KILL DIR
SET DIR("A")="Select Linking Method "
SET DIR(0)="S^M:Manual;S:Semi-Auto"
SET DIR("?")="Linking method description"
+1 WRITE !!,$$CJ^XLFSTR(DIR("A"),80)
+2 FOR I=1:1
SET LN=$PIECE($TEXT(TXT+I),";;",2)
if LN="END"
QUIT
SET DIR("?",I)=LN
WRITE !,$$LJ^XLFSTR(LN,80)
+3 WRITE !!
KILL LN
DO ^DIR
KILL DIR
if $DATA(DIRUT)!($DATA(DTOUT))!($DATA(DUOUT))
GOTO END
if Y="M"
GOTO SEL
LIST ;Print LOINC Code Status
+1 KILL DIR
WRITE !!?5,"Select a starting TEST NAME "
READ LRN:DTIME
if '$TEST!($EXTRACT(LRN)=U)
GOTO END
LK ;
+1 WRITE !
SET AUTO=0
if $LENGTH(LRN)>1
SET LRN=$EXTRACT(LRN,1,($LENGTH(LRN)-1))
LAB ;
+1 SET END=""
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 KILL DIC
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 Begin DoDot:1
+4 KILL LRMIEN
DO 91^LR7OU4
+5 if '$GET(LRMIEN)!'($DATA(^LAM(+$GET(LRMIEN),0))#2)
QUIT
SET LRCODE=$PIECE($PIECE(^(0),U,2),".",1)_".0000 "
IF 'LRCODE
WRITE !,"Database is corrupted for WKLD CODE ",LRCODE
SET LRMIEN=""
QUIT
+6 SET LRMIEN=$ORDER(^LAM("C",LRCODE,0))
if ('LRMIEN)!'($DATA(^LAM(LRMIEN,0))#2)
QUIT
End DoDot:1
IF $GET(LRMIEN)
if ($DATA(^LAM(LRMIEN,0))#2)
SET Y=LRMIEN
SET Y(0)=^(0)
SET LRCODE=$PIECE(Y(0),U,2)
SET LRMNAME=$PIECE(Y(0),U)
GOTO OK
+7 KILL DIC
SET DIC="^LAM("
SET DIC(0)="AQEZNM"
+8 WRITE !,$$CJ^XLFSTR("Select NLT code to be linked with LAB TEST",80),!,$$CJ^XLFSTR(LRDATA,80),!
+9 DO ^DIC
if $EXTRACT(X)=U
SET END=1
if $GET(END)!(Y<1)
QUIT
+10 SET LRMIEN=+Y
SET LRMNAME=$PIECE(Y(0),U)
SET LRCODE=$PIECE(Y(0),U,2)
OK IF '($DATA(^LAM(LRMIEN,0))#2)
WRITE !!,"Database is corrupted for IEN ",LRMIEN
QUIT
+1 WRITE !!,"60 = ",LRDATA,!,"64 = ",LRMNAME_" "_LRCODE
+2 DO LINK^LR7OU4(LRIEN,LRMIEN,AUTO)
+3 QUIT
END ;
+1 KILL LREND,LRANS,LRN,LRTY,ZTSAVE
DO END^LR7OU4
+2 KILL LINKED,LRMNAME,LRNLT,POP,ZTRTN,ZTDESC,ZTQUEUED
+3 KILL DIROUT,DIRUT,DTOUT,DUOUT,ZTDESC,X1,X60,X64,Y64
QUIT
SEL ;
+1 SET AUTO=0
+2 KILL DIC,DIR
SET DIC("A")="You may select any test in LABORATORY TEST FILE: "
+3 SET DIC="^LAB(60,"
SET DIC(0)="AEQZMN"
DO ^DIC
if Y<1
GOTO END
+4 SET LRDATA=$PIECE(Y(0),U)
SET (LRIEN,X60)=+Y
+5 IF $GET(^LAB(60,X60,64))
IF $DATA(^LAM(+^(64),0))
SET Y64=^(0)
Begin DoDot:1
+6 WRITE !!?5,"Currently linked to [ ",$PIECE(Y64,U)_" ] "_$PIECE(Y64,U,2),!!
End DoDot:1
+7 WRITE !!,"Now select ANY WKLD CODE for "_LRDATA,!!
+8 KILL DIC
SET DIC="^LAM("
SET DIC(0)="AEQZNM"
SET DIC("A")="WKLD CODE: "
+9 DO ^DIC
if Y<1
GOTO SEL
SET (LRMIEN,X64)=+Y
SET LRMNAME=$PIECE(Y(0),U)
SET LRCODE=$PIECE(Y(0),U,2)
+10 DO OK
GOTO SEL
TXT ;;
+1 ;; Linking options description
+2 ;;ONLY ORDERABLE LAB TEST NEED TO BE LINKED TO WKLD CODES.
+3 ;;
+4 ;;(S) You can use the semi automated method, which will provide a
+5 ;;alphabetical listing of LABORATORY TEST names. The system will prompt
+6 ;;you for those tests not already assigned a WKLD CODE.
+7 ;;Tests with null TYPE or with the type of NEITHER are excluded.
+8 ;;
+9 ;;(M) Using the Manual method, you are able to select ANY test
+10 ;;regardless of the type field in the LABORATORY TEST file,
+11 ;;and assign it a WKLD CODE. If the test is already linked
+12 ;;the system will display the code and allow you to change
+13 ;;the WKLD CODE assigned. This method will allow you to
+14 ;;change linked LABORATORY TEST to another WKLD CODE.
+15 ;;END
+16 QUIT
LLIST ;
+1 WRITE !?5,"Would you like a list of Laboratory Tests"
+2 KILL DIR
SET DIR(0)="S^0:No;1:ALL;2:Linked;3:Unlinked"
DO ^DIR
+3 if $DATA(DIRUT)!($DATA(DTOUT))!($DATA(DUOUT))!(Y=0)
QUIT
+4 SET LRANS=Y
+5 KILL %ZIS
SET %ZIS="Q"
DO ^%ZIS
if POP
QUIT
IF $DATA(IO("Q"))
KILL ZTSAVE
SET ZTRTN="DQ^LR7OU5"
SET ZTSAVE("LRANS")=""
SET ZTDESC="LAB TEST LIST"
DO ^%ZTLOAD
DO ^%ZISC
QUIT
DQ USE IO
IF $DATA(ZTQUEUED)
SET ZTREQ="@"
+1 WRITE !!?5,"Listing of ",$SELECT(LRANS=1:"ALL",LRANS=2:"LINKED",1:"UNLINKED")," Laboratory Test [ ",$$HTE^XLFDT($HOROLOG)," ] ",!!
+2 SET LRN=""
FOR
SET LRN=$ORDER(^LAB(60,"B",LRN))
if LRN=""!($GET(LREND))
QUIT
SET LRIEN=""
Begin DoDot:1
+3 FOR
SET LRIEN=+$ORDER(^LAB(60,"B",LRN,LRIEN))
if LRIEN<0!($GET(^(LRIEN)))!($GET(LREND))
QUIT
if '$DATA(^LAB(60,LRIEN,0))
QUIT
SET LRTY=$PIECE(^(0),U,3)
if LRTY=""
QUIT
Begin DoDot:2
+4 IF LRANS=1
DO PRT
QUIT
+5 IF LRANS=2
IF $GET(^LAB(60,LRIEN,64))
DO PRT
QUIT
+6 IF LRANS=3
IF '$GET(^LAB(60,LRIEN,64))
DO PRT
QUIT
End DoDot:2
End DoDot:1
+7 if $EXTRACT(IOST,1,2)="P-"
WRITE @IOF
DO ^%ZISC
QUIT
PRT ;
+1 WRITE !?5,LRN,?45,$SELECT(LRTY="B":"BOTH",LRTY="N":"NEITHER",LRTY="O":"OUTPUT",1:"INPUT"),!
+2 SET LRNLT=$GET(^LAB(60,LRIEN,64))
IF LRNLT
IF $DATA(^LAM(LRNLT,0))
WRITE $PIECE(^(0),U,2),?15,$PIECE(^(0),U)
+3 WRITE !
QUIT
