source: WorldVistAEHR/trunk/r/LAB_SERVICE-LR-LS/LRLNCMD.m@ 861

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

initial load of WorldVistAEHR
File size: 4.1 KB
RevLine 
[613]1LRLNCMD ;DALOI/CA/FHS-MAP LAB TESTS TO DEFAULT LOINC CODES ;1-MAY-1999
2 ;;5.2;LAB SERVICE;**232,278,280**;Sep 27,1994
3 ;=================================================================
4 ; Ask VistA test to map-Lookup in Lab Test file #60
5START ;entry point from option LR LOINC MAPPING
6 Q:$D(LRDFONLY)
7 S LREND=0 D TEST
8 I $G(LREND) G EXIT
9 I '$G(LRNLT) G START
10DEFAULT ;ENTRY POINT FROM LRLNC0
11 W !
12 S DIR(0)="Y",DIR("A")="Do you want to see possible LOINC code matches"
13 S DIR("?")="Enter no if you already know the LOINC code."
14 S DIR("B")="No"
15 D ^DIR K DIR
16 I $D(DIRUT),$G(LRLNC1) Q
17 I $D(DIRUT) D EXIT G START
18 I 'Y D ENTERLNC^LRLNCC
19 I $G(LREND),$G(LRLNC1) K LREND Q
20 I $G(LREND) D EXIT G START
21 I '$G(LRCODE) D LOINC
22 I $G(LRNO) D EXIT G START
23 I $G(LREND),$G(LRLNC1) K LREND Q
24 I $G(LREND) D EXIT G START
25 I $G(LRNO) D ENTERLNC^LRLNCC
26 I $G(LREND),$G(LRLNC1) K LREND Q
27 I $G(LREND) D EXIT G START
28CORRECT W !!
29 S DIR(0)="Y",DIR("A")="Is this the correct one"
30 S DIR("B")="Yes"
31 S DIR("?")="Enter no to select a different code."
32 D ^DIR K DIR
33 I $D(DIRUT)!($G(LREND)),$G(LRLNC1) K LREND Q
34 I $D(DIRUT)!($G(LREND)) D EXIT G START
35 I 'Y,$G(LRNO) D ENTERLNC^LRLNCC
36 I 'Y,'$G(LRNO) D LOINC
37 I $G(LRNO) D EXIT G START
38 I $G(LREND),$G(LRLNC1) K LREND Q
39 I $G(LREND) D EXIT G START
40 D LINK
41 I $G(LREND),$G(LRLNC1) K LREND Q
42 I $G(LREND) D EXIT G START
43 D CHECK
44 I $G(LREND),$G(LRLNC1) K LREND Q
45 I $G(LREND) D EXIT G START
46 D MAP
47 I $G(LRLNC1) K LRCODE Q
48 D EXIT
49 G START
50EXIT I $G(LRNLT) L -^LAM(LRNLT,9)
51 K DA,DIC,DIE,DINUM,DIR,DIRUT,DR,DTOUT,I,LRCODE,LRDATA,LREND,LRLNC,LRLNC0,LRLOINC,LRELEC,LRIEN,LRNLT,LRSPEC,LRSPECL,LRSPECN,LRTIME,LRTEST,LRUNITS,S,Y
52 K DD,DO,DLAYGO,LRLNCNAM,LRNO,X,LRNUM,LROLDCD
53 QUIT
54TEST D TEST^LRLNC0
55 Q
56LOINC ;Lookup possible LOINC matches in LAB LOINC file #95.3
57 D FIND^DIC(95.3,"","80","M",LRTEST,"","","I '$G(^(4))","","LRLOINC","")
58CODE ;ask which code to map
59 I +LRLOINC("DILIST",0)=0 D Q
60 .W !!,"No matches found."
61 .S LRNO=1
62 W ! S I=0
63 F S I=$O(LRLOINC("DILIST","ID",I)) Q:'I!$G(LREND) D
64 .I $E(IOST,1,2)="C-",'(I#18) D Q:$G(LREND)
65 ..S DIR(0)="E" D ^DIR
66 ..S:$S($G(DIRUT):1,$G(DUOUT):1,1:0) LREND=1
67 .W !,I,":",LRLOINC("DILIST","ID",I,80)
68 K DIRUT,DUOUT
69 W !!
70 S DIR(0)="N^1:"_$S($G(LREND):I-2,1:$P(LRLOINC("DILIST",0),U),1:0)
71 S DIR("A")="LOINC code to map this test"
72 D ^DIR K DIR,LREND
73 I $D(DIRUT) S LREND=1 Q
74 S LRCODE=LRLOINC("DILIST",1,+Y)
75 D DISPL^LRLNCC
76 Q
77LINK ;Link the code with file 64
78 S LRNLT=+$P(^LAM(LRNLT,0),U,2)
79LR64 ;
80 K DIC,DA
81 W !!
82 S DIC=64,DIC(0)="ENMZ",X=LRNLT
83 D ^DIC
84 I Y=-1!($D(DTOUT))!($D(DUOUT)) K DTOUT,DUOUT S LREND=1 Q
85 S LRNLT=+Y
86 Q
87CHECK ;Check to see if already mapped to a LOINC code
88 Q:'$P($G(^LAM(LRNLT,9)),U)
89 D SHOWPRE
90 I $D(DIRUT)!'Y S LREND=1 Q
91 ;DELETE EXISTING DEFAULT MAPPING
92 S DA=LRNLT
93 S DIE="^LAM(",DR="25////@"
94 D ^DIE
95 K DA,DIE
96 Q
97MAP ;DIE call to add DEFAULT LOINC CODE
98 I '$D(LRDFONLY) S LRDATA=$P(^LAB(60,LRIEN,0),U,12) ;DATA NAME
99 I '$L(LRDATA) S LRDATA=$P(^LAB(60,LRIEN,0),U,4)
100 S LRTIME=$P(^LAB(95.3,LRCODE,0),U,7) ;TIME ASPECT
101 S LRUNITS=$P(^LAB(95.3,LRCODE,0),U,14) ;UNITS
102 L +^LAM(LRNLT):1 I '$T W !,"Another user is editing this record!!" H 5 Q
103 S DIE="^LAM(",DA=LRNLT,DR="25////"_LRCODE_";25.2////"_LRTIME_";25.3////"_LRUNITS_";25.4////"_LRDATA_";25.5////"_$S($D(LRDFONLY):"@",1:LRIEN)
104 D ^DIE
105 L -^LAM(LRNLT)
106MAP2 ;HERE SHOW WHAT WAS MAPPED
107 Q:'$D(^LAM(+$G(LRNLT),0))#2
108 W !!
109 W !,"NLT: ",$P($G(^LAM(LRNLT,0)),U)
110 W !,"WKLD CODE: ",$P($G(^LAM(LRNLT,0)),U,2)
111 K DIC,DR
112 S DIC="^LAM(",DA=LRNLT
113 S S=$Y
114 D EN^DIQ
115 Q
116SHOWPRE ;DISPLAY LOINC CODE ALREADY MAPPED TO NLT
117 S LROLDCD=$P(^LAM(LRNLT,9),U)
118 W !!,"This test is already mapped to:"
119 W !,"Default LOINC code: ",LROLDCD_"-"_$P(^LAB(95.3,+$G(LROLDCD),0),U,15)," ",$G(^LAB(95.3,LROLDCD,80))
120 W !!
121 S DIR(0)="Y",DIR("A")="Do you want to "_$S($D(LRDEL):"delete",1:"change")_" this default mapping",DIR("B")="NO"
122 S:'$D(LRDEL) DIR("?")="If you enter yes, the current default LOINC code will be overwritten with the default LOINC code that you have chosen."
123 S:$D(LRDEL) DIR("?")="If you enter yes, the current default LOINC code will be deleted."
124 D ^DIR K DIR
125 Q
126DELETE ;DELETE/UNMAP DEFAULT LOINC CODE
127 S LREND=0,LRDEL=1 D TEST
128 I $G(LREND) G EXIT
129 D CHECK
130 K LRDEL
131 G EXIT
132 Q
133 Q
Note: See TracBrowser for help on using the repository browser.