source: FOIAVistA/trunk/r/IMAGING-MAG-ZMAG/MAGXCVE.m@ 1757

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

initial load of FOIAVistA 6/30/08 version

File size: 8.7 KB
Line 
1MAGXCVE ;WOIFO/SEB,MLH - Image File Conversion Utilities & Misc. options ; 13 Aug 2003 1:24 PM
2 ;;3.0;IMAGING;**25**;Sep 4, 2003
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 ;
20 ; Entry point for the Mapping File Edit option (MAG IMAGE INDEX MAP EDIT)
21EDIT ;
22 I '$D(^XTMP("MAG30P25","MAPPING")) D I $D(DTOUT)!$D(DUOUT) Q
23 . K DIR S DIR(0)="YU"
24 . S DIR("A",1)="No mapping entries found."
25 . S DIR("A")="Do you want to import a mapping file",DIR("B")="NO"
26 . D ^DIR
27 . I Y D EN^MAGXCVL
28 . Q
29 D MENU
30 Q
31 ;
32 ; List of files available in the Mapping File Edit option.
33MENU ;
34 K DIR S DIR(0)="SUO^1:Short Description Keyword;2:Procedure;"
35 S DIR(0)=DIR(0)_"3:Parent Data File;4:Document Category;5:Object Type;"
36 S DIR(0)=DIR(0)_"6:Service/Section"
37 S DIR("A")="Please choose a file to edit, or <enter> to exit"
38 D ^DIR
39 I $D(DTOUT)!$D(DUOUT) Q
40 I Y="" Q
41 D LOOKUP(Y)
42 G MENU
43 ;
44 ; Look up values in the mappable files.
45LOOKUP(INPUT) N FILENUM,FLDNUM,FILELIST,DIC,Y,ITEMNUM,ITEMTXT,ANS,CT
46 S FILENUM=$P("-1^-1^2005.03^2005.81^2005.02^49",U,INPUT)
47 S FLDNUM=$P("10^6^16^100^3^8",U,INPUT)
48 S FILELIST="Short Description^Procedure^Parent Data File^Document Category"
49 S FILELIST=FILELIST_"^Object Type^Service/Section"
50 S DIC("A")="Select "_$P(FILELIST,U,INPUT)_": "
51 I INPUT>2 D
52 . F D I Y=-1 Q
53 . . W ! S DIC=FILENUM,DIC(0)="AENQ" D ^DIC I Y=-1 Q
54 . . S ITEMNUM=$P(Y,U),ITEMTXT=$P(Y,U,2) D FILE(FLDNUM,ITEMNUM,ITEMTXT)
55 . . Q
56 . Q
57 E D
58 . F D PRLOOKUP(.ITEMTXT,FLDNUM) I ITEMTXT="" Q
59 . Q
60 Q
61 ;
62 ; Custom lookup for the procedures, which is a free text field.
63PRLOOKUP(ITEMTXT,FLDNUM) N CT,ANS,LASTSUB
64PR1 ;
65 ; Can't use ^DIR here because of the way we have to process input of '?'.
66 W !!,"Select ",$S(FLDNUM=10:"Short Description",1:"Procedure Name"),": " R ITEMTXT:DTIME I ITEMTXT="" Q
67 S ITEMTXT=$$UCASE^MAGXCVP(ITEMTXT)
68 I $E(ITEMTXT)="?" S (ANS,ITEMTXT)="" D G PR1
69 . F CT=1:1 S ITEMTXT=$O(^XTMP("MAG30P25","MAPPING",FLDNUM,ITEMTXT)) Q:ITEMTXT=""!(ANS="^") D
70 . . W !?3,ITEMTXT
71 . . I CT#IOSL=0 R !?3,"'^' TO STOP: ",ANS:DTIME I ANS="^" Q
72 . . Q
73 . Q
74 I $E(ITEMTXT)="^" S ITEMTXT="" Q
75 S LASTSUB=$S(FLDNUM=10:"LASTDESC",1:"LASTPROC")
76 I ITEMTXT=" " S ITEMTXT=$G(^XTMP("MAG30P25",LASTSUB)) W " ",$S(ITEMTXT="":"??",1:ITEMTXT) I ITEMTXT="" G PR1
77 S ^XTMP("MAG30P25",LASTSUB)=ITEMTXT
78 I '$D(^XTMP("MAG30P25","MAPPING",FLDNUM,ITEMTXT)) D I ANS="N" Q
79 . W !!,"Do you want to add '",ITEMTXT,"' to the mapping file? N // " R ANS:DTIME
80 . I "Nn"[$E(ANS) S ANS="N" W !!,"OK, entry not added."
81 . Q
82 D FILE(FLDNUM,ITEMTXT,ITEMTXT)
83 Q
84 ;
85 ; Get values for an item described by ITEMNUM and ITEMTXT from file FLDNUM.
86FILE(FLDNUM,ITEMIX,ITEMTXT) N MAPDATA,FLDNFO,CODES,CODE,PC,PKG,DIC,X,Y,VALUE,PKGFND,CH2
87 N AUDREC ; ---- audit record for later reapplication if needed
88 N NEWDATA ; --- new data to be applied to the mapping file (and audit)
89 N CODES ; ----- array for sets of codes
90 N PAIR ; ------ code-value pair
91 ;
92 S MAPDATA=$P($G(^XTMP("MAG30P25","MAPPING",FLDNUM,ITEMIX)),U,2,7)
93 ;
94 ; Get a value for Package.
95PKG S VALUE=$P(MAPDATA,U) I VALUE="" S VALUE="(none)"
96 W !,"Package: ",VALUE," // " R PKG:DTIME S PKG=$$UCASE^MAGXCVP(PKG)
97 I $E(PKG)="^" S CH2=$E(PKG,2) G PKG:CH2="P",CLS:CH2="C",TYP:CH2="T",PRC:CH2="E",SPC:CH2="S",ORG:CH2="O" I CH2="" S Y="" G END
98 I PKG=" " S PKG=$G(^XTMP("MAG30P25","LASTPKG")) W " ",$S(PKG="":"??",1:PKG) I PKG="" G PKG
99 I PKG="@",VALUE="(none)" W !,"No value to delete." G PKG
100 I PKG="@" S:$$DELETE^MAGXCVH $P(MAPDATA,U)="" G END:$D(DTOUT)!$D(DUOUT),PKG
101 D FIELD^DID(2005,40,"","POINTER","FLDNFO") K CODES
102 F PC=1:1 S CODE=$P($P(FLDNFO("POINTER"),";",PC),":") Q:CODE="" S CODES(CODE)=""
103 I $E(PKG)="?" D W ! G PKG
104 . D HELP^MAGXCVH(1) W !,"Valid packages are:"
105 . S CODE="" F S CODE=$O(CODES(CODE)) Q:CODE="" W !,CODE
106 . Q
107 I PKG'="" S PKG=$$PKGPARSE(PKG)
108 S ^XTMP("MAG30P25","LASTPKG")=$S(PKG="":$P(MAPDATA,U),1:PKG)
109 I PKG="" G CLS
110 I PKG]"",'$D(CODES(PKG)) W !,"Unknown package code. Please try again." G PKG
111 I PKG]"" W " ",PKG S $P(MAPDATA,U)=PKG
112 ;
113 ; Get a value for Class.
114CLS S VALUE=$P($P(MAPDATA,U,2),"-",2) I VALUE="" S VALUE="(none)"
115 W !,"Class: ",VALUE," // " R X:DTIME
116 I $E(X)="^" S CH2=$E(X,2) G PKG:CH2="P",CLS:CH2="C",TYP:CH2="T",PRC:CH2="E",SPC:CH2="S",ORG:CH2="O",END:CH2=""
117 I X="" G TYP
118 I X="@",VALUE="(none)" W !,"No value to delete." G CLS
119 I X="@" S:$$DELETE^MAGXCVH $P(MAPDATA,U,2)="" G END:$D(DTOUT)!$D(DUOUT),CLS
120 I $E(X)="?" D HELP^MAGXCVH(2)
121 S DIC=2005.82,DIC(0)="ENQ" D ^DIC I Y=-1 W ! G CLS
122 I Y'=-1 S $P(MAPDATA,U,2)=$TR(Y,U,"-")
123 ;
124 ; Get a value for Type.
125TYP S VALUE=$P($P(MAPDATA,U,3),"-",2) I VALUE="" S VALUE="(none)"
126 W !,"Type: "_VALUE_" // " R X:DTIME
127 I $E(X)="^" S CH2=$E(X,2) G PKG:CH2="P",CLS:CH2="C",TYP:CH2="T",PRC:CH2="E",SPC:CH2="S",ORG:CH2="O",END:CH2=""
128 I X="" G PRC
129 I X="@",VALUE="(none)" W !,"No value to delete." G TYP
130 I X="@" S:$$DELETE^MAGXCVH $P(MAPDATA,U,3)="" G END:$D(DTOUT)!$D(DUOUT),TYP
131 I $E(X)="?" D HELP^MAGXCVH(3)
132 S DIC=2005.83,DIC(0)="ENQ" D ^DIC I Y=-1 W ! G TYP
133 I Y'=-1 S $P(MAPDATA,U,3)=$TR(Y,U,"-")
134 ;
135 ; Get a value for Procedure.
136PRC S VALUE=$P($P(MAPDATA,U,4),"-",2) I VALUE="" S VALUE="(none)"
137 W !,"Procedure/Event: "_VALUE_" // " R X:DTIME
138 I $E(X)="^" S CH2=$E(X,2) G PKG:CH2="P",CLS:CH2="C",TYP:CH2="T",PRC:CH2="E",SPC:CH2="S",ORG:CH2="O",END:CH2=""
139 I X="" G SPC
140 I X="@",VALUE="(none)" W !,"No value to delete." G PRC
141 I X="@" S:$$DELETE^MAGXCVH $P(MAPDATA,U,4)="" G END:$D(DTOUT)!$D(DUOUT),PRC
142 I $E(X)="?" D HELP^MAGXCVH(4)
143 S DIC=2005.85,DIC(0)="ENQ" D ^DIC I Y=-1 W ! G PRC
144 I Y'=-1 S $P(MAPDATA,U,4)=$TR(Y,U,"-")
145 ;
146 ; Get a value for Specialty.
147SPC S VALUE=$P($P(MAPDATA,U,5),"-",2) I VALUE="" S VALUE="(none)"
148 W !,"Specialty: "_VALUE_" // " R X:DTIME
149 I $E(X)="^" S CH2=$E(X,2) G PKG:CH2="P",CLS:CH2="C",TYP:CH2="T",PRC:CH2="E",SPC:CH2="S",ORG:CH2="O",END:CH2=""
150 I X="" G ORG
151 I X="@",VALUE="(none)" W !,"No value to delete." G SPC
152 I X="@" S:$$DELETE^MAGXCVH $P(MAPDATA,U,5)="" G END:$D(DTOUT)!$D(DUOUT),SPC
153 I $E(X)="?" D HELP^MAGXCVH(5)
154 S DIC=2005.84,DIC(0)="ENQ" D ^DIC I Y=-1 W ! G SPC
155 I Y'=-1 S $P(MAPDATA,U,5)=$TR(Y,U,"-")
156 ;
157 ; Get a value for Origin.
158ORG D FIELD^DID(2005,45,"","POINTER","FLDNFO") K CODES
159 F PC=1:1:$L(FLDNFO("POINTER"),";") D
160 . S PAIR=$P(FLDNFO("POINTER"),";",PC)
161 . S CODE=$P(PAIR,":") I CODE]"" S CODES(CODE)=$P(PAIR,":",2)
162 . Q
163 S VALUE=$P(MAPDATA,U,6) I VALUE]"" S VALUE=$G(CODES(VALUE))
164 W !,"Origin: "_VALUE_" // " R X:DTIME E Q
165 I $E(X)="^" S CH2=$E(X,2) G PKG:CH2="P",CLS:CH2="C",TYP:CH2="T",PRC:CH2="E",SPC:CH2="S",ORG:CH2="O",END:CH2=""
166 S ORG=X I ORG="" G END
167 I ORG="@",VALUE="(none)" W !,"No value to delete." G ORG
168 I ORG="@" S:$$DELETE^MAGXCVH $P(MAPDATA,U,6)="" G END:$D(DTOUT)!$D(DUOUT),ORG
169 I $E(ORG)="?" D W ! G ORG
170 . D HELP^MAGXCVH(1) W !,"Valid origins are as follows:"
171 . S CODE="" F S CODE=$O(CODES(CODE)) Q:CODE="" W !,?3,CODE,?8,CODES(CODE)
172 . Q
173 I '$D(CODES(ORG)) D HELP^MAGXCVH(6) G ORG
174 S $P(MAPDATA,U,6)=ORG
175 ;
176END ; File changes into mapping global, mapping global audit, and (if applicable)
177 ; PARENT DATA FILE File (#2005.03) or MAG DESCRIPTIVE CATEGORIES File
178 ; (#2005.81).
179 S NEWDATA=ITEMTXT_U_MAPDATA
180 I $G(^XTMP("MAG30P25","MAPPING",FLDNUM,ITEMIX))'=NEWDATA D
181 . S ^XTMP("MAG30P25","MAPPING",FLDNUM,ITEMIX)=NEWDATA
182 . S IXAUD=$O(^XTMP("MAG30P25","MAPEDITAUD"," "),-1)+1
183 . S AUDREC=($$NOW^XLFDT)_U_DUZ_U_FLDNUM_U_ITEMIX_U_NEWDATA
184 . S ^XTMP("MAG30P25","MAPEDITAUD",IXAUD,0)=AUDREC
185 . I FLDNUM=16!(FLDNUM=100) D DIE^MAGXCVL(FLDNUM,ITEMIX,"^^"_MAPDATA)
186 Q
187 ;
188 ; Parse Package entered and perform partial lookup.
189PKGPARSE(PKG) N PKGFND,CODE,CT,SEL
190 K PKGFND S PKGFND=0,PKG=$$UCASE^MAGXCVP(PKG)
191 I $D(CODES(PKG)) D
192 . S PKGFND=1,PKGFND(1)=PKG
193 . Q
194 E S CODE=PKG F S CODE=$O(CODES(CODE)) Q:CODE=""!($E(CODE,1,$L(PKG))'=PKG) D
195 . S PKGFND=$G(PKGFND)+1,PKGFND(PKGFND)=CODE
196 . Q
197 I PKGFND=0 Q ""
198 I PKGFND=1 Q PKGFND(1)
199 F CT=1:1:PKGFND W !?5,CT,?9,PKGFND(CT)
200 W !,"Choose 1-",PKGFND,": " R SEL:DTIME I SEL="" Q ""
201 I '$D(PKGFND(SEL)) W $C(7),"??" Q "?"
202 Q PKGFND(SEL)
Note: See TracBrowser for help on using the repository browser.