- LR7OU5 ;DALOI/DCM/FHS-NLT LINKING UTILITY SEMI-MANUAL ; 2/23/07 6:53am
- ;;5.2;LAB SERVICE;**1028**;NOV 01, 1997;Build 53
- ;;5.2;LAB SERVICE;**127,201,272,334**;Sep 27, 1994;Build 45
- ; 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
- LR7OU5 ;DALOI/DCM/FHS-NLT LINKING UTILITY SEMI-MANUAL ; 2/23/07 6:53am
- +1 ;;5.2;LAB SERVICE;**1028**;NOV 01, 1997;Build 53
- +2 ;;5.2;LAB SERVICE;**127,201,272,334**;Sep 27, 1994;Build 45
- +3 ; Reference to ^%ZIS supported by IA #10086
- +4 ; Reference to ^%ZISC supported by IA #10089
- +5 ; Reference to ^%ZTLOAD supported by IA #10063
- +6 ; Reference to ^DIC supported by IA #10007
- +7 ; Reference to ^DIR supported by IA #10026
- +8 ; Reference to $$HTE^XLFDT supported by IA #10103
- +9 ; Reference to $$CJ^XLFDT supported by IA #10104
- +10 ; 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
