source: FOIAVistA/tag/r/IMAGING-MAG-ZMAG/MAGXCVI1.m@ 636

Last change on this file since 636 was 628, checked in by George Lilly, 14 years ago

initial load of FOIAVistA 6/30/08 version
File size: 7.4 KB
Line 
1MAGXCVI1 ;WOIFO/SEB,MLH - Image Index Conversion Generate - subroutines ; 15 Jul 2004 9:01 AM
2 ;;3.0;IMAGING;**17,25,31**;Mar 31, 2005
3 ;; +---------------------------------------------------------------+
4 ;; | Property of the US Government. |
5 ;; | No permission to copy or redistribute this software is given. |
6 ;; | Use of unreleased versions of this software requires the user |
7 ;; | to execute a written test agreement with the VistA Imaging |
8 ;; | Development Office of the Department of Veterans Affairs, |
9 ;; | telephone (301) 734-0100. |
10 ;; | |
11 ;; | The Food and Drug Administration classifies this software as |
12 ;; | a medical device. As such, it may not be changed in any way. |
13 ;; | Modifications to this software may result in an adulterated |
14 ;; | medical device under 21CFR820, the use of which is considered |
15 ;; | to be a violation of US Federal Statutes. |
16 ;; +---------------------------------------------------------------+
17 ;;
18 Q
19 ;
20GENINEW ; SUBROUTINE - Called from GENIEN^MAGXCVI.
21 ; generate new index values for a set of lookup fields not previously indexed on
22 N INDXSPEC ; ----- specialty indexed to
23 N FILEXT ; ------- file extension for type override checking
24 N TYPE ; --------- type mapped to, for override checking
25 ;
26 F FLDNUM=16,10,6,100,3,8 I $G(MAGVALS(FLDNUM,"I"))]"" D GENFLD
27 S FILEXT=$P($P($G(^MAG(2005,CHILD1,0)),U,2),".",2) ; for later checking
28 ;
29 I $P(INDXDATA,U)="" S $P(INDXDATA,U)="NONE" ; package still has no value
30 ;
31 I $P(INDXDATA,U,2)="" D ; class still has no value - base it on type
32 . S TYPE=$P(INDXDATA,U,3)
33 . I TYPE]"" S $P(INDXDATA,U,2)=$P($G(^MAG(2005.83,TYPE,0)),U,2)
34 . Q
35 ;
36 ; if class is ADMIN, no procedure or specialty
37 I $P(INDXDATA,U,2)=8 S $P(INDXDATA,U,4,5)=""
38 ;
39 I $P(INDXDATA,U,3)="" D ; image type still has no value
40 . S $P(INDXDATA,U,3)=$S(FILEXT="TIF":45,1:75) ; document/image
41 . ; special check for documents
42 . I MAGVALS(3,"I")]"",$P($G(^MAG(2005.02,MAGVALS(3,"I"),0)),U)="DOCUMENT" D
43 . . I $P(INDXDATA,U,2)=1 D ; clinical
44 . . . S $P(INDXDATA,U,3)=$O(^MAG(2005.83,"B","MISCELLANEOUS DOCUMENT",""))
45 . . . Q
46 . . E I $P(INDXDATA,U,2)=8 D ; administrative
47 . . . S $P(INDXDATA,U,3)=$O(^MAG(2005.83,"B","MISCELLANEOUS",""))
48 . . . Q
49 . . Q
50 . Q
51 ;
52 ; if Type is ADVANCE DIRECTIVE or PHOTO ID: no Specialty;
53 ; ADVANCE DIRECTIVE must always be Class CLIN/ADMIN;
54 ; PHOTO ID must always be Class ADMIN/CLIN
55 I "^67^84^"[("^"_$P(INDXDATA,U,3)_"^") D
56 . S $P(INDXDATA,U,5)=""
57 . S $P(INDXDATA,U,2)=$S($P(INDXDATA,U,3)=67:7,1:9)
58 . Q
59 ;
60 ; if Type is ENDOSCOPY, delete Type if really non-Endo (i.e., from
61 ; Medicine Package)
62 I $P(INDXDATA,U,4)=6 D
63 . I (" "_$TR($G(MAGVALS(6,"I")),"-","")_" ")[" NONENDO " S $P(INDXDATA,U,4)=""
64 . Q
65 ;
66 ; if no Procedure or Specialty, then...
67 ; if no type, or an image, default to CLIN Class if no Class
68 I $P(INDXDATA,U,4)="",$P(INDXDATA,U,5)="" D
69 . I "^^75^"[("^"_$P(INDXDATA,U,3)_"^"),$P(INDXDATA,U,2)="" D
70 . . S $P(INDXDATA,U,2)=1
71 . . Q
72 . Q
73 ;
74 ; if Specialty is GI and parent file is ENDOSCOPY and current procedure isn't
75 ; a GI procedure, map to ENDO Procedure
76 I $P(INDXDATA,U,5)=3,MAGVALS(16,"I")=699 D
77 . I '$D(^MAG(2005.85,+$P(INDXDATA,U,4),1,"B",3)) S $P(INDXDATA,U,4)=6
78 . Q
79 ;
80 Q
81 ;
82GENFLD ; SUBROUTINE - Called from GENINEW.
83 ; Generate indices for one field.
84 N D0 ; ----------- scratch array index
85 N I ; ------------ scratch string piece index
86 N INDXVAL ; ------ the index value we compute
87 N PRVVAL ; ------- the index value computed from a previous field mapping
88 ;
89 S MAPDATA=""
90 I FLDNUM=3 D ; object type
91 . S MAGVALS(3,"I")=$$UCASE^MAGXCVP($$STRIP^MAGXCVP(MAGVALS(3,"I")))
92 . S MAPDATA=$P($G(^XTMP("MAG30P25","MAPPING",3,MAGVALS(3,"I"))),U,2,999)
93 . Q
94 I FLDNUM=6 D GENF06 ; procedure
95 I FLDNUM=8 D GENF08 ; image save by
96 I FLDNUM=10 D GENF10 ; short description
97 I FLDNUM=16 D ; parent data file
98 . S MAPDATA=$G(^MAG(2005.03,MAGVALS(16,"I"),2))
99 . ; make sure TIUs map properly for CP
100 . I MAGVALS(16,"I")=8925 D
101 . . I (" "_MAGVALS(6,"I")_" ")[" CP " S $P(MAPDATA,U)="CP"
102 . . Q
103 . Q
104 I FLDNUM=100 S MAPDATA=$G(^MAG(2005.81,MAGVALS(100,"I"),2)) ; doc category
105 ; D0: 1=package, 2=class, 3=type, 4=procedure/event, 5=specialty, 6=origin
106 F D0=1:1:6 D
107 . S INDXVAL=$P($P(MAPDATA,U,D0),"-"),PRVVAL=$P(INDXDATA,U,D0)
108 . I INDXVAL]"" D
109 . . I $P(INDXDATA,U,D0)="" D
110 . . . S $P(INDXDATA,U,D0)=INDXVAL
111 . . . Q
112 . . E I D0=5,PRVVAL=48 D
113 . . . ; override previous Specialty of 'SURGERY' if a more precise mapping
114 . . . ; has been found
115 . . . S $P(INDXDATA,U,D0)=INDXVAL
116 . . . Q
117 . . Q
118 . Q
119 Q
120 ;
121GENF06 ; generate indices based on field 6 (Procedure)
122 ; expects MAGVALS, U; returns MAPDATA
123 N TERM ; --- DICOM Modality Defined Term
124 N I ; ------ scratch index
125 N IVAL ; --- positional index value
126 ;
127 S MAGVALS(6,"I")=$$UCASE^MAGXCVP($$STRIP^MAGXCVP($G(MAGVALS(6,"I"))))
128 I $E(MAGVALS(6,"I"),1,2)="+ " D
129 . S MAGVALS(6,"I")=$E(MAGVALS(6,"I"),3,$L(MAGVALS(6,"I")))
130 . Q
131 I MAGVALS(6,"I")[" TEMPLATE" D
132 . S MAGVALS(6,"I")=$P(MAGVALS(6,"I")," TEMPLATE")
133 . Q
134 I MAGVALS(6,"I")]"" D
135 . S MAPDATA=$P($G(^XTMP("MAG30P25","MAPPING",6,MAGVALS(6,"I"))),U,2,999)
136 . ; did they use a DICOM Modality Defined Term?
137 . S TERM=MAGVALS(6,"I")
138 . I $P(TERM," ")="RAD" S TERM=$P(TERM," ",2,999)
139 . I TERM]"",$D(^RAMIS(73.1,"B",TERM)) D
140 . . F I=1:1:6 D
141 . . . S IVAL=$P(MAPDATA,U,I)
142 . . . I IVAL]"" S $P(INDXDATA,U,I)=$P(IVAL,"-")
143 . . . Q
144 . . Q
145 . Q
146 I MAGVALS(6,"I")["NON VA" D
147 . S $P(INDXDATA,U,6)="N"
148 . Q
149 Q
150 ;
151GENF08 ; generate indices based on field 8
152 ; expects MAGVALS, U; returns MAPDATA
153 ; logic: strip trailing 'SERVICE', 'SECTION' and then trailing 'CARE';
154 ; do not tokenize; exact match on mapping
155 N UTYPE ; ----- external value of service/section
156 N SVSECTXT ; -- service/section name, all caps and tokenized
157 ;
158 S UTYPE=$$GET1^DIQ(200,MAGVALS(8,"I")_",",29,"E")
159 I UTYPE]"" D ; tokenize the service/section
160 . S SVSECTXT=$$STRIP^MAGXCVP($$UCASE^MAGXCVP(UTYPE))
161 . I UTYPE?.E1" SERVICE".1"S" S UTYPE=$P(UTYPE," SERVICE")
162 . I UTYPE?.E1" SECTION" S UTYPE=$P(UTYPE," SECTION")
163 . I UTYPE?.E1" CARE" S UTYPE=$P(UTYPE," CARE")
164 . S MAPDATA=$P($G(^XTMP("MAG30P25","MAPPING",8,UTYPE)),U,2,999)
165 . Q
166 Q
167 ;
168GENF10 ; generate indices based on field 10 (Short Description)
169 ; returns MAPDATA
170 N CURMAP ; ---- current mapping value
171 N NEWMAP ; ---- new mapping value
172 N TOKSTR ; ---- a token string that we check for
173 N SHDSCTXT ; -- short description text
174 N TSTSPEC ; --- specialty mapped to, for override checking
175 ;
176 S TOKSTR="",MAPDATA=""
177 S SHDSCTXT=(" "_$$SCRUBTKN^MAGXCVP($$UCASE^MAGXCVP(MAGVALS(10,"I")))_" ")
178 F S TOKSTR=$O(^XTMP("MAG30P25","MAPPING",10,TOKSTR)) Q:TOKSTR="" D
179 . ; Check *every* token - don't stop after the first hit.
180 . ; Set up test string for checking on a standard token boundary (space).
181 . S FLDDATA=$$UCASE^MAGXCVP($G(^XTMP("MAG30P25","MAPPING",10,TOKSTR)))
182 . I SHDSCTXT[(" "_$P(FLDDATA,U)_" ") D
183 . . F I=1:1:6 D
184 . . . S CURMAP=$P(MAPDATA,U,I),NEWMAP=$P(FLDDATA,U,I+1)
185 . . . ; overrides:
186 . . . ; map to a more precise Specialty than 'SURGERY'
187 . . . I I=5,NEWMAP]"",CURMAP=48 S $P(MAPDATA,U,I)=NEWMAP Q
188 . . . ;
189 . . . I CURMAP="" D
190 . . . . ; overrides:
191 . . . . ; don't map to Cardiac Cath if specialty other than Cardiology
192 . . . . I I=4,+NEWMAP=1 S TSTSPEC=$P(INDXDATA,U,5) I TSTSPEC,TSTSPEC-2 Q
193 . . . . S $P(MAPDATA,U,I)=NEWMAP
194 . . . . Q
195 . . . Q
196 . . Q
197 . Q
198 Q
Note: See TracBrowser for help on using the repository browser.