source: WorldVistAEHR/trunk/r/LAB_SERVICE-LR-LS/LRLNCST.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.0 KB
Line 
1LRLNCST ;DALOI/FHS-LIST OF LOINC DEPRECIATED CODES ; 5/14/07 12:56pm
2 ;;5.2;LAB SERVICE;**334**;Sep 27, 1994;Build 12
3EN ;
4 K LRIO,%ZIS,LRIO
5 K DIR,LRANS,Y
6 S DIR(0)="SO^L: List of Deprecated codes;M: Mapped Deprecated codes in use"
7 S DIR("?")="Listing of LOINC deprecated codes"
8 S DIR("?",1)="L = List of all LOINC deprecated codes"
9 S DIR("?",2)="M = List of mapped LOINC deprecated codes"
10 D ^DIR G END:$G(DIRUT)!($G(Y)="")
11 S LRANS=Y
12DEVICE ;
13 S %ZIS="NQO",%ZIS("A")="Select Device: ",%ZIS("B")=""
14 D ^%ZIS I $G(POP) D END Q
15 I IO'=IO(0) D LOAD D END Q
16 I LRANS="M" D LNK,END Q
17 I LRANS="L" D LST,END
18 Q
19LOAD ;
20 N ZTRTN,ZTIO,ZTDESC,ZTDTH
21 S ZTRTN=$S(LRANS="L":"LST^LRLNCST",1:"LNK^LRLNCST")
22 S ZTDTH=$H,ZTDESC="Print laboratory LOINC deprecated codes"
23 S ZTIO=IO
24 D ^%ZTLOAD
25 W !,$S($G(ZTSK):"Tasked to "_ION_" "_ZTSK,1:"Not Tasked")
26 Q
27LST ;Print list of deprecated code
28 I $D(ZTQUEUED) S ZTREQ="@"
29 S LRHDR="List of deprecated codes"
30 S (LRPG,LRLNC)=0 D HDR
31 F S LRLNC=$O(^LAB(95.3,"AD",1,LRLNC)) Q:LRLNC<1 D
32 . K LRANS,ERR
33 . D GETS^DIQ(95.3,LRLNC,".01;80","E","LRANS","ERR")
34 . Q:$D(ERR)
35 . W !,$G(LRANS(95.3,LRLNC_",",.01,"E"))," ",$E($G(LRANS(95.3,LRLNC_",",80,"E")),1,60)
36 . I $Y>(IOSL-4) D HDR
37 D END Q
38LNK ;Provide list of mapped deprecated LOINC codes
39 I $D(ZTQUEUED) S ZTREQ="@"
40 S (LRPG,LRIEN)=0,LRNM="",LRPLINE=0
41 S LRHDR="List of mapped LOINC deprecated codes" D HDR
42 S $P(LRPLN,"+",79)=""
43 F S LRNM=$O(^LAB(60,"B",LRNM)) Q:LRNM="" D
44 . S LRIEN=0 F S LRIEN=$O(^LAB(60,"B",LRNM,LRIEN)) Q:LRIEN<1 D
45 . . Q:$G(^LAB(60,"B",LRNM,LRIEN))
46 . . S LR60NM="["_LRIEN_"] "_LRNM_" ",LRPLINE=0
47 . . D LK64
48 D END Q
49LK64 ;Start looking for NLT linked fields.
50 S LR64=$G(^LAB(60,LRIEN,64)),LRONLT=+LR64,LRRNLT=$P(LR64,U,2)
51 I LRONLT D ORDER
52 I LRRNLT D RESULT
53 Q
54RESULT ;Look up result NLT codes
55 S LRFLD=1
56 D CHK(LRRNLT,LRFLD) Q:$G(LRNOP)
57 D LNC(LRRNLT,LRFLD)
58 Q
59ORDER ;Look up NLT order codes
60 S LRFLD=2
61 D CHK(LRONLT,LRFLD) Q:$G(LRNOP)
62 D DEF(LRONLT,LRFLD)
63 Q
64DEF(LRNLT,FLD) ;Check LOINC default code
65 S LRDEF=+$G(^LAM(LRNLT,9)) I LRDEF D
66 . S LRNLTNM=$P(^LAM(LRNLT,0),U)_" "_$P(^(0),U,2)
67 . I $G(^LAB(95.3,LRDEF,4)) D
68 . . I $Y>(IOSL-6) D HDR
69 . . D:'$G(LRPLINE) PLN
70 . . W !,"Test Name: ",LR60NM
71 . . W !,$S(FLD=1:"RESULT NLT Code LOINC Default ",1:"ORDER NLT Code LOINC Default ")
72 . . W !,"NLT Code: ",LRNLTNM
73 . . W !,LRDEF_"-"_$P(^LAB(95.3,LRDEF,0),U,15)_" "_$G(^LAB(95.3,LRDEF,80)),!
74 Q
75CHK(LRP,FLD) ;Check for valid node
76 S LRNOP=0 I '$D(^LAM(LRP,0)) D Q
77 . D:'$G(LRPLINE) PLN
78 . S LRTXT="is not valid"
79 . S LRMSG="["_LRIEN_"] "_LRNM_$S(FLD=2:" Order NLT ",1:" Result NLT ")_LRTXT
80 . D MSG(LRMSG) S LRNOP=1
81 S LRNODE=^LAM(LRP,0),LRCC=$P($P(^(0),U,2),".")
82 Q
83MSG(MSG) ;Print
84 W !,$$CJ^XLFSTR(MSG,IOM)
85 Q
86LNC(LRNLT,LRFLD) ;Check for LOINC in suffixed NLT codes
87 S:'LRFLD LRFLD=1
88 K LRNOP,LRCC,LRQ,LRQB,NODE
89 S LRCC=$P(^LAM(LRNLT,0),U,2) Q:'LRCC!($G(LRNOP)) D
90 . S LRQB=$P(LRCC,".")
91 . S LRQ=""""_$P(LRCC,".")_".0""",NODE="^LAM(""E"","_LRQ_")"
92 . S NODE=$Q(@NODE) I $P($QS(NODE,2),".")'=LRQB S LRNOP=1 Q
93 . S LRINLT=$QS(NODE,3) D DEF(LRINLT,LRFLD)
94 . D SPEC(LRINLT,3)
95 Q
96SPEC(LRNLT,LRFLD) ;Check specimen time aspect LOINC
97 S LRSPEC=0 F S LRSPEC=$O(^LAM(LRNLT,5,LRSPEC)) Q:LRSPEC<1 D
98 . S LRSPECN=$P($G(^LAB(61,LRSPEC,0)),U)
99 . S LRTASP=0 F S LRTASP=$O(^LAM(LRNLT,5,LRSPEC,1,LRTASP)) Q:LRTASP<1 D
100 . . S LRTASPN=$P($G(^LAB(64.061,LRTASP,0)),U)
101 . . S LRLNC=+$G(^LAM(LRNLT,5,LRSPEC,1,LRTASP,1))
102 . . I LRLNC,$G(^LAB(95.3,LRLNC,4)) D DISP
103 Q
104DISP ;
105 I $Y>(IOSL-5) D HDR
106 D:'$G(LRPLINE) PLN
107 W !,"Test Name: ",LR60NM
108 W !,"NLT Code: ",$P($G(^LAM(LRNLT,0)),U)," ",$P(^(0),U,2)
109 W !," ("_LRSPEC_") "_LRSPECN
110 W !,"LOINC Code: ",LRTASPN_" ["_LRLNC_"-"_$P(^LAB(95.3,LRLNC,0),U,15)_"]"
111 W !,"LOINC Name: ",$G(^LAB(95.3,LRLNC,80))
112 Q
113PLN ;
114 I $Y>(IOSL-6) D HDR
115 W !,LRPLN,!
116 S LRPLINE=1
117 Q
118END ;
119 W !
120 W:$E($G(IOST),1,2)="P-" @IOF
121 D ^%ZISC
122 K ZTSK,ERR,DIRUT,LR64,LRMSG,LRNM,LRNODE,LRNOPE,LRSPEC,LRTXT
123 K DIR,LR60NM,LRANS,LRCC,LRDEF,LRFLD,LRHDR,LRIEN,LRINLT,LRNLTNM,LRONLT,LRPG,LRPLINE
124 K LRLNC,LRPLN,LRQ,LRQB,LRRNLT,LRSPECN,LRTASP,LRTASPN,NODE,POP,X,Y
125 Q
126HDR ;
127 S LRPG=$G(LRPG)+1
128 W @IOF,LRHDR," Page: ",LRPG,!
129 Q
Note: See TracBrowser for help on using the repository browser.