source: FOIAVistA/tag/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XLFNAME4.m@ 1569

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

initial load of FOIAVistA 6/30/08 version

File size: 7.5 KB
Line 
1XLFNAME4 ;CIOFO-SF/MKO-PRINT INFORMATION IN ^XTMP ;11:35 AM 23 Mar 2000
2 ;;8.0;KERNEL;**134**;Jul 10, 1995
3 ;
4PRINT N XUCD,XUCDX,XUFD,XUFDTXT,XUFL,XUHLIN,XUPG,XUREC
5 N DIROUT,DIRUT,DTOUT,DUOUT,POP,X,Y
6 D INTRO
7 ;
8 ;Get file number
9 ;S XUFL=$$READ("Select a file or subfile number","ALL","HLPFIL") Q:XUFL=""
10 S XUFL=200
11 ;
12 ;Get field number
13 ;I XUFL="ALL" S XUFD="ALL"
14 ;E S XUFD=$$READ("Select a field number","ALL","HLPFLD") Q:XUFD=""
15 S XUFD=.01
16 ;
17 ;Get list of codes
18 S XUCD=$$READ("Enter a list of codes to print","ALL","HLPCOD","Enter a list of codes separated by commas, 'ALL', or '??' for more help.")
19 Q:U[XUCD
20 S:XUCD="ALL" XUCD=""
21 I XUCD]"" S XUCD=$$UP^XLFSTR($TR(XUCD," "))
22 ;
23 ;Get list of codes to exclude
24 S XUCDX=$$READ("Enter a list of codes to exclude","","HLPCODX","Enter a list of codes separated by commas, or '??' for more help.")
25 Q:XUCDX=U
26 I XUCDX]"" S XUCDX=$$UP^XLFSTR($TR(XUCDX," "))
27 ;
28 ;Prompt for device
29 S %ZIS="Q" W ! D ^%ZIS Q:$G(POP)
30 I $D(IO("Q")),$D(^%ZTSK) D QUEUE G END
31 U IO
32 ;
33MAIN ;TaskMan entry point
34 D INIT,HDR,CODTAB
35 ;
36 I XUFL="ALL" D
37 . S XUFL=0
38 . F S XUFL=$O(^XTMP("XLFNAME",XUFL)) Q:'XUFL D PFIL(XUFL,XUCD,XUCDX) Q:$D(DIRUT)
39 E I XUFD="ALL" D
40 . D PFIL(XUFL,XUCD,XUCDX)
41 E D PFLD(XUFL,XUFD,XUCD,XUCDX)
42 ;
43 D END
44 Q
45 ;
46PFIL(XUFL,XUCD,XUCDX) ;Print information for a specific file
47 S XUFD=0
48 F S XUFD=$O(^XTMP("XLFNAME",XUFL,XUFD)) Q:'XUFD D PFLD(XUFL,XUFD,XUCD,XUCDX) Q:$D(DIRUT)
49 Q
50 ;
51PFLD(XUFL,XUFD,XUCD,XUCDX) ;Print info for a specific field
52 D HINFO(XUFL,XUFD),EOP Q:$D(DIRUT) D HDR,SUBHDR
53 S XUREC="" F S XUREC=$O(^XTMP("XLFNAME",XUFL,XUFD,XUREC)) Q:XUREC="" D PREC(XUFL,XUFD,XUREC,XUCD,XUCDX) Q:$D(DIRUT)
54 Q
55 ;
56PREC(XUFL,XUFD,XUREC,XUCD,XUCDX) ;Print info for a specific record
57 N C,I,XUOLD,XUNEW,XUCOD,XULN,XUMAT,XUMATX,XUNC
58 ;
59 ;Get old and new name, and Name Components ien
60 S XULN=^XTMP("XLFNAME",XUFL,XUFD,XUREC)
61 S XUOLD=$P(XULN,U),XUNEW=$P(XULN,U,2)
62 ;
63 ;Get note codes
64 S XUCOD="" S XUMAT=$G(XUCD)="",(XUMATX,XUNC)=0
65 S I=0 F S I=$O(^XTMP("XLFNAME",XUFL,XUFD,XUREC,I)) Q:I="" D Q:XUMATX
66 . I I="MIDDLE"!(I="SUFFIX") S XUNC=1
67 . S C=$E(I,1,"NPS"[$E(I)+1)
68 . I 'XUMAT,","_XUCD_","[(","_C_",") S XUMAT=1
69 . I $G(XUCDX)]"",'XUMATX,","_XUCDX_","[(","_C_",") S XUMATX=1
70 . S XUCOD=XUCOD_C_","
71 Q:'XUMAT!XUMATX
72 S:XUCOD?.E1"," XUCOD=$E(XUCOD,1,$L(XUCOD)-1)
73 ;
74 D W(XUREC) Q:$D(DIRUT) W ?15,"Old: "_XUOLD,?60,XUCOD
75 D W("New: "_XUNEW,15) Q:$D(DIRUT)
76 I XUNC D
77 . D W(" Given: "_$P(XULN,U,3),22)
78 . D W("Middle: "_$P(XULN,U,4),22)
79 . D W("Family: "_$P(XULN,U,5),22)
80 . D W("Suffix: "_$P(XULN,U,6),22)
81 D W() Q:$D(DIRUT)
82 Q
83 ;
84W(XUSTR,XUCOL,XUFLG) ;Write line feed and string XUSTR in column XUCOL
85 I $Y+3'<IOSL D EOP Q:$D(DIRUT) D HDR D:'$G(XUFLG) SUBHDR
86 W !?+$G(XUCOL),$G(XUSTR)
87 Q
88 ;
89EOP ;EOP
90 I $E(IOST,1,2)="C-",'$D(ZTQUEUED) D
91 . N DIR,X,Y
92 . S DIR(0)="E" W ! D ^DIR
93 E I $D(ZTQUEUED),$$S^%ZTLOAD S (ZTSTOP,DIRUT)=1
94 W @IOF
95 Q
96 ;
97HDR ;Print header
98 S XUPG=$G(XUPG)+1,$X=0
99 W "^XTMP(""XLFNAME"") LISTING",?(IOM-$L(XUHLIN)-$L(XUPG)-1),XUHLIN_XUPG
100 W !,$TR($J("",IOM-1)," ","-")
101 Q
102 ;
103SUBHDR ;Print subheader
104 W !,"File: #"_XUFL,", Field: "_XUFDTXT
105 W:XUCD]"" !,"Entries that contain any of the following codes: ",XUCD
106 W:XUCDX]"" !,"Excluding entries that contain any of the following codes: ",XUCDX
107 W !!,"Record",?15,"Name",?60,"Codes"
108 W !,"------",?15,$TR($J("",40)," ","-"),?60,"-----"
109 Q
110 ;
111HINFO(XUFL,XUFD) ;Get XUFDTXT for subheader
112 N XULAB
113 D FIELD^DID(XUFL,XUFD,"","LABEL","XULAB")
114 S XUFDTXT=XULAB("LABEL")_" (#"_XUFD_")"
115 Q
116 ;
117READ(PROMPT,DEF,XHELP,HELP) ;Read X, default is ALL
118 N DIR,X,Y,DTOUT,DUOUT,DIRUT,DIROUT
119 S DIR(0)="FO^1:30"
120 S:$G(PROMPT)]"" DIR("A")=PROMPT
121 S DIR("?")=$S($G(HELP)]"":HELP,1:"Enter a number or the word 'ALL'. Enter '??' for more help.")
122 S:$G(XHELP)]"" DIR("??")="^D "_XHELP_"^XLFNAME4"
123 S:$G(DEF)]"" DIR("B")=DEF
124 D ^DIR Q:$D(DUOUT)!$D(DTOUT) U
125 Q Y
126 ;
127HLPFIL ;Execute help for file prompt
128 N I
129 W !,"Enter 'ALL' to select all files, or select one of the following:",!
130 S I=0 F S I=$O(^XTMP("XLFNAME",I)) Q:'I W:$X>70 ! W I_" "_$J("",10-$L(I))
131 Q
132 ;
133HLPFLD ;Execute help for field prompt
134 N I
135 W !,"Enter 'ALL' to select all fields, or select one of the following:",!
136 S I=0 F S I=$O(^XTMP("XLFNAME",XUFL,I)) Q:'I W:$X>70 ! W I_" "_$J("",10-$L(I))
137 Q
138 ;
139HLPCOD ;Executable help for codes prompt
140 N I,T
141 F I=1:1 S T=$P($T(CODTAB+I),";;",2,999) Q:T="$$END" W !,T
142 W !!,"To include entries with specific codes, enter those codes separated by commas,"
143 W !,"or enter 'ALL' to select entries with any code,"
144 Q
145 ;
146HLPCODX ;Executable help for codes prompt
147 N I,T
148 F I=1:1 S T=$P($T(CODTAB+I),";;",2,999) Q:T="$$END" W !,T
149 W !!,"To exclude entries with specific codes, enter those codes separated by commas,"
150 W !,"or press <RET> to exclude no entries."
151 W !!,"This list overrides the list of codes to include."
152 Q
153 ;
154QUEUE ;Queue the report
155 N I,ZTSK
156 ;
157 S ZTRTN="MAIN^XLFNAME4"
158 S ZTDESC="Report of ^XTMP(""XLFNAME"")"
159 F I="XUFL","XUFD","XUCD","XUCDX" S ZTSAVE(I)=""
160 D ^%ZTLOAD
161 ;
162 I $D(ZTSK)#2 W !,"Report queued!",!,"Task number: "_$G(ZTSK),!
163 E W !,"Report canceled!",!
164 ;
165 D HOME^%ZIS
166 Q
167 ;
168INIT ;Set XUHLIN to Date/time/page for header
169 N %,%H,X,Y
170 S %H=$H D YX^%DTC
171 S XUHLIN=$P(Y,"@")_" "_$P($P(Y,"@",2),":",1,2)_" PAGE "
172 W:$E(IOST,1,2)="C-" @IOF
173 Q
174 ;
175END ;Finish up
176 I $D(ZTQUEUED) S ZTREQ="@"
177 E D ^%ZISC
178 Q
179 ;
180INTRO ;Introductory text
181 ;;This entry point prints a report of the information stored in
182 ;;^XTMP("XLFNAME").
183 ;;
184 ;;The New Person Name Standardization conversion is run automatically during
185 ;;the installation of patch XU*8.0*134, as part of the POST-INSTALL ROUTINE
186 ;;(POST^XLFNAME). The conversion records in ^XTMP("XLFNAME") information
187 ;;about each Name that had to be changed to convert it to standard form, or
188 ;;for which assumptions had to be made in breaking the Name into its
189 ;;component parts for storage in the new NAME COMPONENTS file (#20).
190 ;;
191 ;;You can use this report to determine whether any names were standardized
192 ;;or parsed incorrectly. To correct a name or its component parts, go to the
193 ;;"Systems Manager Menu" [EVE], select "User Management" [XUSER], and then
194 ;;"Edit an Existing User" [XUSEREDIT]. From there you can edit the NAME
195 ;;field (#.01) of the NEW PERSON file (#200), as well as the component parts
196 ;;of the Name as they are stored in the NAME COMPONENTS file (#20).
197 ;;
198 ;;$$END
199 N I,T
200 F I=1:1 S T=$P($T(INTRO+I),";;",2,999) Q:T="$$END" W !,T
201 Q
202 ;
203CODTAB ;Code Table
204 ;;Explanation of Codes:
205 ;;--------------------
206 ;; D : The standard name is different from the original name.
207 ;; F : The Family Name starts with ST<period>. The period and
208 ;; following space, if any, were removed.
209 ;; G : There is no Given Name.
210 ;; M : Assumption: There is more than one Given and only one Middle Name.
211 ;; NM : NMI or NMN was used as the Middle Name.
212 ;; NU : A name part contains a number.
213 ;; PE : Periods were removed.
214 ;; PU : Punctuation was removed.
215 ;; SP : Spaces were removed from the Family Name.
216 ;; ST : Text in parentheses was stripped from the name.
217 ;; SU : One or more of the following situations was encountered relating
218 ;; to suffixes:
219 ;; - Suffixes were found immediate to left of the first comma.
220 ;; - I, V, or X was interpreted as a Middle Name.
221 ;; - A name part was interpreted as a Suffix, not a Middle Name.
222 ;; - M.D. or M D was NOT interpreted as a Suffix.
223 ;; - A name part with no vowels was interpreted as a Suffix.
224 ;; - A Suffix was found between commas immediately after the Family Name.
225 ;; T : The standard name was truncated.
226 ;;$$END
227 N I,T
228 F I=1:1 S T=$P($T(CODTAB+I),";;",2,999) Q:T="$$END" D W(T,0,1)
229 Q
Note: See TracBrowser for help on using the repository browser.