source: WorldVistAEHR/trunk/r/LAB_SERVICE-LR-LS/LRLNC63B.m@ 623

Last change on this file since 623 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR

File size: 3.9 KB
Line 
1LRLNC63B ;DALOI/FHS-HISTORICAL LOINC MAPPING MODIFIER ;01/30/2001 15:19
2 ;;5.2;LAB SERVICE;**279**;Sep 27, 1994
3EN ;
4 K DIR W @IOF
5 W !!,$$CJ^XLFSTR("This option will allow you to manage how specific DataNames",80)
6 W !,$$CJ^XLFSTR("will be mapped to LOINC Codes for historical data.",80)
7 W !!,$$LJ^XLFSTR("You are able to override file definitions to correct past LOINC mappings.",80)
8 W !,$$LJ^XLFSTR("Select the CH subsripted test, indicate the suffix to be used.",80)
9 W !,$$LJ^XLFSTR("You can indicate if this suffix should override previous LOINC Mapping.",80),!
10 W !,$$LJ^XLFSTR("This option will REMAP your entire database.",80),!!
11 W !,$$LJ^XLFSTR("This option should only be run on weekends after hours.",80),!
12 S DIR(0)="Y",DIR("A")=" Do you wish to continue "
13 D ^DIR Q:$G(Y)'=1
14 K ^XTMP("LRLNC63",2),^XTMP("LRLNC63","LST"),^TMP("LR",$J),^TMP("LRLNC63",$J),LRCNT,LROX
15SELECT ;Indicate which DATANAMES LOINC definition to be changed.
16 K LRMOD,LRY,NODE
17 S LRY=1
18 F W !! Q:$G(LRY)<1 D
19 . K DIR,X
20 . W !,$$CJ^XLFSTR("Selection can be a 'CH' Atomic or Panel test.",80),!
21 . S DIR("?")="Selection can be an Atomic or Panel test."
22 . S DIR("?",1)="Only those tests with a Result code will be stored."
23 . S DIR(0)="PO^60:EMZ",DIR("S")="I $P(^(0),U,4)=""CH"""
24 . S DIR("A")="Select test you want to modify mapping"
25 . D ^DIR
26 . S LRY=Y Q:Y<1
27 . S LRYY=$P($P(Y(0),U,5),";",2)_U_LRY
28 . D EXPAND
29 ;
30DISPLAY ;Show what has been recorded
31 K DIRUT,LRY
32 I '$O(^TMP("LRLNC63",$J,0)) W !?5,"Nothing was selected, Process Aborted",! Q
33 W @IOF
34 W !,$$CJ^XLFSTR("Here is a list of what you have selected.",80)
35 W !,$$CJ^XLFSTR("[O] indicates override current mapping.",80),!
36 D
37 . D ^%ZIS Q:POP
38 . U IO
39 . N DIR
40 . S DIR="E"
41 . S NODE="^TMP(""LRLNC63"","_$J_",0)" F S NODE=$Q(@NODE) Q:$S(NODE="":1,$QS(NODE,2)'=$J:1,1:0) D Q:$D(DIRUT)
42 . . I $Y>(IOSL-3) D
43 . . . I $E(IOST,1.2)="C-" D ^DIR Q:$D(DIRUT)
44 . . . W @IOF
45 . . . W !,"Here is a list of what you have selected."
46 . . . W !,"[O] indicates override current mapping.",!
47 . . D SHO
48 . W:$E(IOST,1)="P" @IOF
49 . D ^%ZISC
50CHK ;
51 ; K ^TMP("LR",$J)
52 W !
53 I $D(DIRUT) S DIR(0)="Y",DIR("A")=" Do you want to STOP" D ^DIR G:$G(Y)=1 END
54 K DIR S DIR(0)="YO",DIR("A")="You wish to add more" D ^DIR I $G(Y)=1 G SELECT
55 I $G(Y)=U G END
56 ;
57 W !
58 S DIR("A")=" Do you want to delete an entry" D ^DIR G END:$G(Y)=U
59 I $G(Y)=1 D EDIT G DISPLAY
60 I $O(^TMP("LRLNC63",$J,0)) D
61 . S LRMOD=1,ZTSAVE("LRMOD")=""
62 . S NODE="^TMP(""LRLNC63"",0)"
63 . F S NODE=$Q(@NODE) Q:$S($QS(NODE,2)'=$J:1,1:0) D
64 . . S ^XTMP("LRLNC63",2,$QS(NODE,5))=@NODE
65FIRE ;Run the mapping tasking function
66 D QUE^LRLNC63
67 Q
68END ;
69 K DIRUT
70 K ^XTMP("LRLNC63",2)
71 Q
72SHO ;
73 N LRX,LRXY
74 S LRX=@NODE
75 W !,$QS(NODE,3)_" "_$S($P(LRX,U,6):"[O]",1:" "),?7,$E($P(LRX,U,3),1,30),?40,$E($P(LRX,U,4),1,25),?70,"/ ",$P(LRX,U,5)
76 ;S LRXY=$QS(NODE,1)_" "_$P(LRX,U,3)_" - "_$P(LRX,U,4)_" / "_$P(LRX,U,5)_" "_$S($P(LRX,U,6):"Override Yes",1:"")
77 ;W !,LRXY
78 Q
79EDIT ;
80 K DIR,DIRUT
81 S DIR("A")="Delete this entry"
82 S DIR(0)="NO^1:"_LRCNT D ^DIR
83 Q:$D(DIRUT)
84 S LRY=Y I '$D(^TMP("LRLNC63",$J,Y)) W !?5,Y_" Entry not Valid",! G EDIT
85 S NODE="^TMP(""LRLNC63"","_$J_","_Y_",0)"
86 S NODE=$Q(@NODE) I $QS(NODE,2)'=$J W !?5,Y_" Entry not Valid",! G EDIT
87 D SHO
88 S DIR(0)="YO" D ^DIR Q:$D(DIRUT)
89 I $G(Y)=1 K ^TMP("LRLNC63",$J,LRY)
90 G EDIT
91 Q
92EXPAND ;If panel test expand to get parts
93 K ^TMP("LR",$J) S LRCFL=""
94 K DIR,LRTEST,LRX,T1
95 S LRTEST(+LRY)=+LRY_U_^LAB(60,+LRY,0),T1=+LRY
96 S LRNX=0
97 D EX1^LREXPD
98 S DIR(0)="PO^64.2:EMZ",DIR("A")=" Select Suffix Code"
99 D ^DIR Q:Y<1
100 S LRSUF=$P(Y(0),U)_U_$P($P(Y(0),U,2),".",2)
101 K DIR S DIR(0)="YO",DIR("A")="Override previous LOINC mapping"
102 D ^DIR I Y=1 S LRSUF=LRSUF_U_1
103 I $O(^TMP("LR",$J,"TMP",0)) D
104 . S LRN=0 F S LRN=$O(^TMP("LR",$J,"TMP",LRN)) Q:LRN<1 S LRNX=^(LRN) D
105 . . Q:'$P($G(^LAB(60,LRNX,64)),U,2)
106 . . S LRCNT=$G(LRCNT)+1
107 . . S ^TMP("LRLNC63",$J,LRCNT,$P(^LAB(60,LRNX,0),U),LRN)=LRN_U_+LRNX_U_$P(^(0),U)_U_LRSUF
108 Q
Note: See TracBrowser for help on using the repository browser.