source: WorldVistAEHR/trunk/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XLFNP176.m@ 1073

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

initial load of WorldVistAEHR

File size: 5.4 KB
Line 
1XLFNP176 ;SFISC/MKO-FIX NEW PERSON NAMES ;3:16 PM 27 Oct 2000
2 ;;8.0;KERNEL;**176**;Jul 10, 1995
3LIST ;; M D^ D D S^ PH D^ R N^ D P M^ D O^ P A^ N P^ C R N A^ L P N
4 Q
5 ;
6FIX N XUFIX,DIRUT
7 D INTRO Q:$D(DIRUT)
8 S XUFIX=$$ASKFIX Q:$D(DIRUT)
9 D DEVSEL Q:$D(DIRUT)
10 U IO
11 ;
12MAIN ;Loop through the New person file; entry point for queued jobs
13 N XUHLIN,XUIEN,XULIST,XUNAM,XUNEW,XUPAGE,XUPC,XUPROB,XUSUF
14 D INIT
15 S XULIST=$P($T(LIST),";;",2,999)
16 ;
17 S XUIEN=0 F S XUIEN=$O(^VA(200,XUIEN)) Q:'XUIEN D Q:$D(DIRUT)
18 . S XUNAM=$P($G(^VA(200,XUIEN,0)),U) Q:XUNAM=""
19 . F XUPC=1:1 S XUSUF=$P(XULIST,U,XUPC) Q:XUSUF="" D Q:$D(DIRUT)
20 .. Q:XUNAM'?@(".E1"""_XUSUF_"""")
21 .. S XUPROB=1
22 .. D BLDCOMP(XUNAM,XUSUF,.XUNEW)
23 .. D WRITE(XUIEN,XUNAM,.XUNEW) Q:$D(DIRUT)
24 .. D:XUFIX FILE(XUIEN,.XUNEW) Q:$D(DIRUT)
25 ;
26 W:'$G(XUPROB) !,"NO PROBLEMS FOUND",!
27 D END
28 Q
29 ;
30BLDCOMP(XUNAM,XUSUF,XUNEW) ;Build new name components
31 K XUNEW
32 S XUNEW=$E(XUNAM,1,$L(XUNAM)-$L(XUSUF))
33 S XUSUF=$TR(XUSUF," ")
34 D NAMECOMP^XLFNAME(.XUNEW)
35 S XUNEW=XUNEW_" "_XUSUF
36 S XUNEW("SUFFIX")=$G(XUNEW("SUFFIX"))_$E(" ",$G(XUNEW("SUFFIX"))]"")_XUSUF
37 Q
38 ;
39WRITE(XUIEN,XUNAM,XUNEW) ;Write info
40 D W() Q:$D(DIRUT)
41 D W("Entry #"_XUIEN) Q:$D(DIRUT)
42 D W("Old Name: "_XUNAM) Q:$D(DIRUT)
43 D W("New Name: "_XUNEW) Q:$D(DIRUT)
44 I $G(XUNEW("GIVEN"))]"" D W(" Given: "_XUNEW("GIVEN"),10) Q:$D(DIRUT)
45 I $G(XUNEW("MIDDLE"))]"" D W("Middle: "_XUNEW("MIDDLE"),10) Q:$D(DIRUT)
46 I $G(XUNEW("FAMILY"))]"" D W("Family: "_XUNEW("FAMILY"),10) Q:$D(DIRUT)
47 I $G(XUNEW("SUFFIX"))]"" D W("Suffix: "_XUNEW("SUFFIX"),10) Q:$D(DIRUT)
48 Q
49 ;
50FILE(XUIEN,XUNEW) ;Correct Name
51 N DIERR,XUFDA,XUMSG,XUNC
52 ;
53 S XUNC=$P($G(^VA(200,XUIEN,3.1)),U)
54 I XUNC,$D(^VA(20,XUNC,0))#2,$P(^(0),U,1,3)="200^.01^"_XUIEN_"," D
55 . S XUFDA(20,XUNC_",",1)=$G(XUNEW("FAMILY"))
56 . S XUFDA(20,XUNC_",",2)=$G(XUNEW("GIVEN"))
57 . S XUFDA(20,XUNC_",",3)=$G(XUNEW("MIDDLE"))
58 . S XUFDA(20,XUNC_",",5)=$G(XUNEW("SUFFIX"))
59 . D FILE^DIE("","XUFDA","XUMSG")
60 ;
61 E D
62 . D W("** Unable to file new name **")
63 . D W(" There is no corresponding entry in the Name Components file.")
64 ;
65 I $G(DIERR) D
66 . N XUI,XUOUT
67 . D MSG^DIALOG("AE","XUOUT","",5,"XUMSG")
68 . D W("** Unable to file new name **") Q:$D(DIRUT)
69 . F XUI=1:1:XUOUT D W(XUOUT(XUI)) Q:$D(DIRUT)
70 Q
71 ;
72W(XUSTR,XUTAB) ;Write XUSTR
73 I $Y+4>IOSL D EOP Q:$D(DIRUT)
74 W !?+$G(XUTAB),$G(XUSTR)
75 Q
76 ;
77EOP ;End-of-page prompt/check
78 I $E(IOST,1,2)="C-" D Q:$D(DIRUT)
79 . N DIR,DIROUT,DTOUT,DUOUT,X,Y
80 . S DIR(0)="E" W ! D ^DIR
81 I $D(ZTQUEUED),$$S^%ZTLOAD S (ZTSTOP,DIRUT)=1 Q
82 W @IOF
83 D HDR
84 Q
85 ;
86HDR ;Print header
87 S ($X,$Y)=0
88 S XUPAGE=$G(XUPAGE)+1
89 I XUFIX W "NEW PERSON NAMES FIXED BY FIX^XLFNP176"
90 E W "HOW FIX^XLFNP176 WOULD FIX NEW PERSON NAMES"
91 W ?(IOM-$L(XUHLIN)-$L(XUPAGE)-1),XUHLIN_XUPAGE
92 W !,$TR($J("",IOM-1)," ","-")
93 Q
94 ;
95ASKFIX() ;Ask whether to file corrected New Person name
96 N DIR,DIROUT,DTOUT,DUOUT,X,Y K DIRUT
97 S DIR(0)="SBA^R:Report Only;F:Fix Names"
98 S DIR("A")="Fix names or just print a Report (F/R)? "
99 S DIR("?",1)="Answer 'R' to print a report of names with a potential problems."
100 S DIR("?")="Answer 'F' to fix the names."
101 W ! D ^DIR
102 Q Y="F"
103 ;
104DEVSEL ;Select device
105 N %ZIS,POP K DIRUT
106 S %ZIS=$S($D(^%ZTSK):"Q",1:"")
107 W ! D ^%ZIS
108 I $G(POP) S DIRUT=1 Q
109 ;
110 ;Queue report
111 I $D(IO("Q")),$D(^%ZTSK) D S DIRUT=1 Q
112 . N ZTSK
113 . S ZTRTN="MAIN^XLFNP176"
114 . S ZTDESC="Names in New Person file with spaces within a suffix."
115 . S ZTSAVE("XUFIX")=""
116 . D ^%ZTLOAD
117 . I $D(ZTSK)#2 W !,"Report queued!",!,"Task number: "_$G(ZTSK),!
118 . E W !,"Report canceled!",!
119 . S IOP="HOME" D ^%ZIS
120 Q
121 ;
122INIT ;Setup
123 N %,%H,X,Y
124 S %H=$H D YX^%DTC
125 S XUHLIN=$P(Y,"@")_" "_$P($P(Y,"@",2),":",1,2)_" PAGE "
126 W:$E(IOST,1,2)="C-" @IOF
127 D HDR
128 Q
129 ;
130END ;Finish up
131 I $D(ZTQUEUED) S ZTREQ="@"
132 E N POP D ^%ZISC
133 Q
134 ;
135INTRO ;
136 N DIR,DIROUT,DUOUT,DTOUT,I,L,S,X,Y
137 W !,"Routine XLFNP176 was released with patch XU*8*176."
138 ;
139 W !!,"This entry point (FIX^XLFNP176) loops through all the entries in the New"
140 W !,"Person file (#200) and looks for names that may have been standardized and"
141 W !,"parsed incorrectly by the Name Standardization Patch XU*8*134. If a name"
142 W !,"in the New Person file prior to the installation of Patch XU*8*134"
143 W !,"contained periods within its suffix, the Post-Install Conversion of that"
144 W !,"patch converted those periods to spaces, and didn't recognize the name"
145 W !,"component as a suffix. This entry point prints a report of names that may"
146 W !,"have the problem, and optionally corrects them."
147 ;
148 W !!,"NOTE: This routine should be run only after Patches XU*8*134 and XU*8*152"
149 W !,"have been installed."
150 ;
151 I '$$PATCH^XPDUTL("XU*8.0*134")!'$$PATCH^XPDUTL("XU*8.0*152") D Q
152 . W !!,$C(7)," It appears that the above two patches have NOT been installed on"
153 . W !," your system. Exiting ...",!
154 . S DIRUT=1
155 ;
156 W !!," It appears that those two patches HAVE been installed in this acccount"
157 W ! S DIR(0)="E" D ^DIR K DIR Q:$D(DIRUT)
158 ;
159 W !!,"Each New Person file Name will be checked to determine whether any"
160 W !,"following strings occur at the end of the Name:",!
161 S L=$P($T(LIST),";;",2,99)
162 F I=1:1:$L(L,U) S S=$P(L,U,I) W:S]"" !," '"_S_"'"
163 ;
164 S DIR(0)="Y"
165 S DIR("A")="Do you wish to use a different list"
166 S DIR("B")="NO"
167 S DIR("?",1)=" Enter 'YES' to exit and modify line tag LIST^XLFNP162."
168 S DIR("?")=" Enter 'NO' to accept the above list and continue."
169 W ! D ^DIR K DIR Q:$D(DIRUT)
170 I Y D Q
171 . W !!," Edit the list at line tag LIST^XLFNP176.",!
172 . S DIRUT=1
173 Q
Note: See TracBrowser for help on using the repository browser.