source: WorldVistAEHR/trunk/r/LAB_SERVICE-LR-LS/LRLNCSUF.m@ 1006

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

initial load of WorldVistAEHR

File size: 4.1 KB
Line 
1LRLNCSUF ;DALOI/RSH-PRINT WKLD/NLT CODE LOINC MAPPINGS ;1-OCT-1998
2 ;;5.2;LAB SERVICE;**232**;Sep 27,1994
3EN ;
4 W @IOF,!! S LREND=0
5 W $$CJ^XLFSTR("This option will print WORKLOAD CODES and their LOINC CODES.",IOM)
6 W !,$$CJ^XLFSTR("You may use the option 'MAP LOINC TEST TO NLT' to make necessary changes.",IOM)
7ASK ;
8 K DIR S DIR(0)="S^1:Ready to print WORKLOAD CODES MAPPED TO LOINC;2:Abort"
9 D ^DIR K DIR
10 G END:$S($G(DIRUT):1,$G(DUOUT):1,$G(DTOUT):1,Y=2:1,1:0)
11 S LRSEL=Y K %ZIS S %ZIS="Q" D ^%ZIS
12 G END:POP
13 I IO'=IO(0) S ZTRTN="DQ^LRLNCSUF",ZTIO=ION,ZTDESC="Print WKLD CODES MAPPED TO LOINC",ZTSAVE("LRSEL")="" D ^%ZTLOAD I $D(ZTSK)'[0 W !!?5," Tasked to Print on : ",ION G END
14 W @IOF D DQ
15 D END
16 Q
17DQ ;
18 N DIR,LREND
19 S $P(LRLINE,"=",IOM)="",LRTOP=1
20 S:$D(ZTQUEUED) ZTREQ="@" S LRPDT=$$FMTE^XLFDT($$NOW^XLFDT,"1P")
21 S (LRPAGE,LRCNT,LREND)=0
22 S LRDEF=""
23 D HDR
24 ;SORT BY TEST
25 S LRNODE="^LAB(60,""B"",0)",LRCNT=0
26 F S LRNODE=$Q(@LRNODE) Q:$QS(LRNODE,2)'="B" Q:$G(LREND) D
27 . Q:$G(@LRNODE)!($G(LREND))
28 . S LRTSTNM=$QS(LRNODE,3)
29 . S LRIEN=+$QS(LRNODE,4)
30 . S (LRLOINC,LRSMPIEN,LRVWKIEN,LRACCIEN)=""
31 . S LRX=$G(^LAB(60,LRIEN,0)) Q:$P(LRX,U,3)="N"
32 . S LRVACD=$P($G(^LAB(60,LRIEN,64)),U)
33 . S LRRNLT=$P($G(^LAB(60,LRIEN,64)),U,2)
34 . D SMPCD D:$G(LRSMPIEN) GRNLT(LRSMPIEN)
35 . D VRWKD D:$G(LRVWKIEN) GRNLT(LRVWKIEN)
36 . D ACWK D:$G(LRACCIEN) GRNLT(LRACCIEN)
37 . I LRSMPIEN=""&(LRVWKIEN="")&(LRACCIEN="") D
38 . . I ($G(LRRNLT)) D GRNLT(LRRNLT)
39 . . I LRRNLT="" D
40 . . . W !,LRTSTNM,?45,"THERE IS NO RESULT NLT CODE"
41 . . . W !,LRLINE
42 . . . I $Y>24 D HDR,TOP Q:$G(LREND)
43 Q
44SMPCD ;GET SAMPLE WORKLOAD CODE
45 S (LRD1,LRD2)=0
46 F S LRD1=+$O(^LAB(60,LRIEN,3,LRD1)) Q:LRD1<1 D
47 . Q:'$O(^LAB(60,LRIEN,3,LRD1,9,0))
48 . F S LRD2=+$O(^LAB(60,LRIEN,3,LRD1,9,LRD2)) Q:LRD2<1 D
49 . . S LRSREC=$G(^LAB(60,LRIEN,LRD1,9,LRD2,0))
50 . . S LRSMPIEN=$P(LRSREC,U)
51 Q
52VRWKD ;GET VERIFY WORKLOAD CODE
53 S LRD1=0 Q:'$O(^LAB(60,LRIEN,9,0))
54 F S LRD1=+$O(^LAB(60,LRIEN,9,LRD1)) Q:'LRD1 D
55 . S LRVREC=$G(^LAB(60,LRIEN,9,LRD1,0))
56 . S LRVWKIEN=$P(LRVREC,U)
57 Q
58ACWK ;GET ACCESSION WORKLOAD CODE
59 S LRSUB=0
60 Q:'$O(^LAB(60,LRIEN,9.1,0))
61 F S LRSUB=+$O(^LAB(60,LRIEN,9.1,LRSUB)) Q:LRSUB<1 D
62 . S LRREC=$G(^LAB(60,LRIEN,9.1,LRSUB,0))
63 . S LRACCIEN=$P(LRREC,U)
64 Q
65GRNLT(LRNLTIEN) ;GET RESULT NLT CODE
66 Q:$G(^LAM(LRNLTIEN,0))=""
67 Q:'$D(^LAM(LRNLTIEN,0))#2!($P($G(^LAM(LRNLTIEN,0)),U,2)="") S LRNAME=$P(^(0),U),LRCODE=$P(^(0),U,2)
68 D TOP Q:$G(LREND)
69 I $O(^LAM(LRNLTIEN,5,0)) D GTLNC
70SDEFCD ;SET DEFAULT LOINC CODE
71 I $G(^LAM(LRNLTIEN,9)) S LRDEF=$P(^(0),U)
72 E S LRDEF="" ;USE GENERIC SUFFIX CODE
73 I '$O(^LAM(LRNLTIEN,5,0)) D PRT
74 Q
75GTLNC ;GET LOINC CODE BASED ON THE SPECIMEN
76 S LRSPEC=0 F S LRSPEC=+$O(^LAM(LRNLTIEN,5,LRSPEC)) Q:LRSPEC<1!($G(LREND)) D
77 . D TOP Q:$G(LREND)
78 . S LRASP=0 F S LRASP=+$O(^LAM(LRNLTIEN,5,LRSPEC,1,LRASP)) Q:LRASP<1 D
79 . . D TOP Q:$G(LREND)
80 . . S LRX=+$G(^LAM(LRNLTIEN,5,LRSPEC,1,LRASP,1))
81 . . I $D(^LAB(95.3,LRX,0))#2 S LRLOINC=$P(^(0),U)
82 . . S LRSPNM=$P($G(^LAB(61,LRSPEC,0)),U),LRFULL=$G(^LAB(95.3,LRX,80))
83 . . I $G(LRLOINC) D PRT
84 . . S (LRLOINC,LRFULL)=""
85 Q
86PRT ;PRINT INFO
87 D TOP Q:$G(LREND)
88 W !?2,$G(LRTSTNM),?47,$G(LRSPNM)
89 W !?2,$G(LRNLTIEN),?12,LRCODE_" "_$G(LRNAME)
90 I LRLOINC'="" W !,"LOINC CODE = ",LRLOINC," ",$G(LRFULL)
91 I LRDEF'="" W !,"DEFAULT LOINC CODE = ",$G(LRDEF)
92 I LRLOINC!LRDEF S LRCNT=LRCNT+1
93 W !,LRLINE
94 I $Y>24 D HDR,TOP Q:$G(LREND)
95 Q
96END ;
97 I $G(LRCNT) W !?15,"Total Number of Mapped WKLD CODES/Specimens: ",LRCNT,!
98 I $E(IOST)="P-" W @IOF
99 D ^%ZISC
100 K DIR,DIRUT,DUOUT,LRACCIEN,LRASP,LRCODE,LRCNT,LRD1,LRD2,LRDEF
101 K LREND,LRFULL,LRIEN,LRLINE,LRLOINC,LRNAME,LRNLTIEN,LRNODE,LRPAGE
102 K LRPDT,LRREC,LRRNLT,LRSEL,LRSMPIEN,LRSPEC,LRSPNM,LRSREC,LRSUB
103 K LRTOP,LRTSTNM,LRVACD,LRVREC,LRVWKIEN,LRX,POP,ZTIO,ZTDESC,ZTRTN,ZTSAVE
104 ;
105 Q
106TOP ;
107 Q:$G(LREND)
108 Q:$Y<(IOSL-4)
109 I $E(IOST,1,2)="C-" D Q:$G(LREND)
110 . S DIR(0)="E" D ^DIR
111 . S:$S($G(DIRUT):1,$G(DUOUT):1,1:0) LREND=1
112HDR ;
113 I $G(LRPAGE) W @IOF
114 S LRPAGE=$G(LRPAGE)+1
115 Q:'$G(LRTOP)
116 W !,$$CJ^XLFSTR("Alphabetical Listing of Laboratory Tests ",IOM)
117 W !,$$CJ^XLFSTR("that are Mapped to LOINC Codes.",IOM)
118 W !,?5,LRPDT,?60,"Page: ",LRPAGE
119 W !!,"LABORATORY TEST NAME",?45,"SPECIMEN"
120 W !,"NLT IEN # WKLD CODE Name ",!
121 Q
Note: See TracBrowser for help on using the repository browser.