source: ccr/trunk/p/C0CVOBX1.m@ 1654

Last change on this file since 1654 was 1586, checked in by Sam Habiel, 12 years ago

Changed license to AGPL. Some clean-up for XINDEX
  • Property svn:mergeinfo set to (toggle deleted branches)
    /ccr/branches/ohum/o-old/p/C0CVOBX1.m1290
    /ccr/branches/ohum/p/C0CVOBX1.m1291-1543
    /ccr/branches/ohum/p/p/C0CVOBX1.m1287-1289
File size: 4.5 KB
Line 
1LA7VOBX1 ;DALOI/JMC - LAB OBX Segment message builder (CH subscript) cont'd; 04/21/09
2 ;;1.2;CCD/CCR GENERATION UTILITIES;;Oct 30, 2012;Build 50
3 ; JMC - mods to check for IHS V LAB file
4 ;
5 ; (C) 2009 John McCormack
6 ; This program is free software: you can redistribute it and/or modify
7 ; it under the terms of the GNU Affero General Public License as
8 ; published by the Free Software Foundation, either version 3 of the
9 ; License, or (at your option) any later version.
10 ;
11 ; This program is distributed in the hope that it will be useful,
12 ; but WITHOUT ANY WARRANTY; without even the implied warranty of
13 ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
14 ; GNU Affero General Public License for more details.
15 ;
16 ; You should have received a copy of the GNU Affero General Public License
17 ; along with this program. If not, see <http://www.gnu.org/licenses/>.
18 ;
19CH ; Observation/Result segment for "CH" subscript results.
20 ; Called by LA7VOBX
21 ;
22 N LA76304,LA7ALT,LA7DIV,LA7I,LA7X,LA7Y,X
23 ;
24 ; "CH" subscript requires a dataname
25 I '$G(LRSB) Q
26 ;
27 ; get result node from LR global.
28 S LA76304(0)=$G(^LR(LRDFN,LRSS,LRIDT,0))
29 S LA7VAL=$G(^LR(LRDFN,LRSS,LRIDT,LRSB))
30 ;
31 ; Check if test is OK to send - (O)utput or (B)oth
32 S LA7X=$P(LA7VAL,"^",12)
33 I LA7X]"","BO"'[LA7X Q
34 I LA7X="",'$$OKTOSND^LA7VHLU1(LRSS,LRSB,+$P($P(LA7VAL,"^",3),"!",5)) Q
35 ;
36 ; If no result NLT or LOINC try to determine from file #60
37 S LA7X=$P(LA7VAL,"^",3)
38 ; WV check for IHS - NLT/LN codes from V LAB file
39 I $D(^AUPNVLAB) D TMPCHK^C0CLA7Q
40 ;
41 I $P(LA7X,"!",2)=""!($P(LA7X,"!",3)="") S $P(LA7VAL,"^",3)=$$DEFCODE^LA7VHLU5(LRSS,LRSB,LA7X,$P(LA76304(0),"^",5))
42 ; No result NLT code - log error
43 I $P($P(LA7VAL,"^",3),"!",2)="" D
44 . N LA7X
45 . S LA7X="["_LRSB_"]"_$$GET1^DID(63.04,LRSB,"","LABEL")
46 . D CREATE^LA7LOG(36)
47 ;
48 ; something missing - No NLT code, etc.
49 I LA7VAL="" Q
50 ;
51 ; Check for missing units/reference ranges
52 S LA7X=$P(LA7VAL,"^",5)
53 ;
54 ; Results missing units, lookup in file #60
55 I $P(LA7X,"!",7)="" S $P(LA7X,"!",7)=$P($$REFUNIT^LA7VHLU1(LRSB,$P(LA76304(0),"^",5)),"^",3)
56 ;
57 ; If results missing reference ranges, use values from file #60.
58 I $P(LA7X,"!",2)="",$P(LA7X,"!",3)="",$P(LA7X,"!",11)="",$P(LA7X,"!",12)="" D
59 . S LA7Y=$$REFUNIT^LA7VHLU1(LRSB,$P(LA76304(0),"^",5))
60 . S $P(LA7X,"!",2)=$P(LA7Y,"^")
61 . S $P(LA7X,"!",3)=$P(LA7Y,"^",2)
62 . S $P(LA7X,"!",11)=$P(LA7Y,"^",6)
63 . S $P(LA7X,"!",12)=$P(LA7Y,"^",7)
64 ; Use therapeutic low/high if low/high missing.
65 I $P(LA7X,"!",2)="",$P(LA7X,"!",3)="" D
66 . S $P(LA7X,"!",2)=$P(LA7X,"!",11)
67 . S $P(LA7X,"!",3)=$P(LA7X,"!",12)
68 ;
69 ; Evaluate low/high reference ranges in case M code in these fields.
70 S:$G(SEX)="" SEX="M" S:$G(AGE)="" AGE=99
71 F LA7I=2,3 I $E($P(LA7X,"!",LA7I),1,3)="$S(" D
72 . S @("X="_$P(LA7X,"!",LA7I))
73 . S $P(LA7X,"!",LA7I)=X
74 ;
75 ; Put units/reference ranges back in variable LA7VAL
76 S $P(LA7VAL,"^",5)=LA7X
77 ;
78 ; Initialize OBX segment
79 S LA7OBX(0)="OBX"
80 S LA7OBX(1)=$$OBX1^LA7VOBX(.LA7OBXSN)
81 ;
82 ; Value type
83 S LA7OBX(2)=$$OBX2^LA7VOBX(63.04,LRSB)
84 ;
85 ; Observation identifer
86 ; build alternate code based on dataname from file #63 in case it's needed
87 S LA7X=$P(LA7VAL,"^",3)
88 S LA7ALT="CH"_LRSB_"^"_$$GET1^DID(63.04,LRSB,"","LABEL")_"^"_"99VA63"
89 S LA7OBX(3)=$$OBX3^LA7VOBX($P(LA7X,"!",2),$P(LA7X,"!",3),LA7ALT,LA7FS,LA7ECH)
90 ;
91 ; Test value
92 S LA7OBX(5)=$$OBX5^LA7VOBX($P(LA7VAL,"^"),LA7OBX(2),LA7FS,LA7ECH)
93 ;
94 ; Units - remove leading and trailing spaces
95 S LA7X=$P(LA7VAL,"^",5),LA7X=$$TRIM^XLFSTR(LA7X,"LR"," ")
96 S LA7OBX(6)=$$OBX6^LA7VOBX($P(LA7X,"!",7),"",LA7FS,LA7ECH)
97 ;
98 ; Reference range
99 S LA7OBX(7)=$$OBX7^LA7VOBX($P(LA7X,"!",2),$P(LA7X,"!",3),LA7FS,LA7ECH)
100 ;
101 ; Abnormal flags
102 S LA7OBX(8)=$$OBX8^LA7VOBX($P(LA7VAL,U,2))
103 ;
104 ; "P"artial or "F"inal results
105 S LA7OBX(11)=$$OBX11^LA7VOBX($S("canccommentpending"[$P(LA7VAL,"^"):$P(LA7VAL,"^"),1:"F"))
106 ;
107 ; Observation date/time - collection date/time per HL7 standard
108 I $P(LA76304(0),"^") S LA7OBX(14)=$$OBX14^LA7VOBX($P(LA76304(0),"^"))
109 ;
110 S LA7DIV=$P(LA7VAL,"^",9)
111 I LA7DIV="",$$DIV4^XUSER(.LA7DIV,$P(LA7VAL,"^",4)) S LA7DIV=$O(LA7DIV(0))
112 ;
113 ; Facility that performed the testing
114 S LA7OBX(15)=$$OBX15^LA7VOBX(LA7DIV,LA7FS,LA7ECH)
115 ;
116 ; Person that verified the test
117 S LA7OBX(16)=$$OBX16^LA7VOBX($P(LA7VAL,"^",4),LA7DIV,LA7FS,LA7ECH)
118 ;
119 ; Observation method
120 S LA7X=$P($P(LA7VAL,"^",3),"!",4)
121 I LA7X S LA7OBX(17)=$$OBX17^LA7VOBX(LA7X,LA7FS,LA7ECH)
122 ;
123 ; Equipment entity identifier
124 I $L($P(LA7VAL,"^",11)) S LA7OBX(18)=$$OBX18^LA7VOBX($P(LA7VAL,"^",11),LA7FS,LA7ECH)
125 ;
126 D BUILDSEG^LA7VHLU(.LA7OBX,.LA7ARRAY,LA7FS)
127 ;
128 Q
Note: See TracBrowser for help on using the repository browser.