source: WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/VAFCPID2.m@ 642

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

initial load of WorldVistAEHR
File size: 4.6 KB
RevLine 
[613]1VAFCPID2 ;ALB/MLI,PKE-Create generic PID segment ; 22 Jan 2002 10:30 AM
2 ;;5.3;Registration;**149,240,312,428,494**;Aug 13, 1993
3 ; aggressive name re-formatting
4 ;
5NAME(DFN,MPISTR,FLG) ;Being aggressive about where Suffix is placed, extra punctuation
6 ;DFN - ien from Patient file MPISTR - name as stored in Patient file
7 ;FLG - Parameter no longer supported. Originally denoted whether or
8 ; not to update the patient file. Patient file will not be
9 ; updated anymore.
10 I $E(MPISTR,1,14)="MERGING INTO `" S MPISTR=$P($P(MPISTR,"(",2),")") Q ;**240
11 S FLG=0
12 N LAST,FIRST,MIDDLE,SUFFIX,POS,LAST12,LAST2,LAST3,REST,SUF,SEC,SEC12,SEC3,MID12,MID3,FIR12,FIR3,PL,MID3,TMPSTR,TFLG
13 S TFLG="N"
14 S TMPSTR=MPISTR
15 I $E(MPISTR,($L(MPISTR)-4),$L(MPISTR))=" TEST" S MPISTR=$E(MPISTR,1,($L(MPISTR)-4)),TFLG="Y"
16 I MPISTR["'" S MPISTR=$TR(MPISTR,"'","") ;Remove ' punctuation marks from the name
17 S MPISTR=$TR(MPISTR,"."," ") I $E(MPISTR,$L(MPISTR))=" " S MPISTR=$E(MPISTR,1,$L(MPISTR)-1)
18 ;check if 3rd instead of III
19 I $F(MPISTR,"3RD")'=0 S MPISTR=$E(MPISTR,1,$F(MPISTR,"3RD")-4)_"III"_$E(MPISTR,$F(MPISTR,"3RD"),$L(MPISTR))
20 ;check if 2nd instead of II
21 I $F(MPISTR,"2ND")'=0 S MPISTR=$E(MPISTR,1,$F(MPISTR,"2ND")-4)_"II"_$E(MPISTR,$F(MPISTR,"2ND"),$L(MPISTR))
22 I $P(MPISTR,",",3)'="" S PL=$F(MPISTR,","),FIRST=$E(MPISTR,PL,$L(MPISTR)),MPISTR=$P(MPISTR,",")_","_$TR(FIRST,","," ")
23TR I $F(MPISTR," ") S PL=$F(MPISTR," "),MPISTR=$E(MPISTR,1,PL-2)_$E(MPISTR,PL,$L(MPISTR)) G TR
24 ;check for more than three pieces after the comma - ex: last,j.r. first mi
25 I $P(MPISTR,",",2)?.A1" ".A1" ".A1" ".A S REST=$P(MPISTR,",",2) I $E(REST,1,4)?1A1" "1A1" " S POS=$E(REST,1)_$E(REST,3) D
26 .I POS="II"!(POS="IV")!(POS="VI")!(POS="JR")!(POS="SR")!(POS="DR") S SUF="Y" S MPISTR=$P(MPISTR,",")_","_$E(REST,5,$L(REST))_" "_POS,POS="Y"
27 ;move the suffix from the left of the comma to the end of the name str
28 S LAST=$P(MPISTR,","),REST=$P(MPISTR,",",2),POS="N",SUF="N"
29 I LAST?.A1" ".E D
30 .S LAST2=$P(LAST," ",2),LAST12=$E(LAST2,1,2),LAST3=$E(LAST2,3)
31 .I LAST12="V"!(LAST12="V.")!(LAST12="I")!(LAST12="I.") S POS="Y",SUFFIX=LAST2
32 .I LAST12="JR"!(LAST12="SR")!(LAST12="DR")!(LAST12="MD")!(LAST12="II")!(LAST12="IV")!(LAST12="VI") S POS="Y",SUFFIX=LAST2
33 .I POS="Y",(LAST12="II") I LAST3'="",(LAST3'="."),(LAST3'="I") S POS="N",SUFFIX=""
34 .I POS="Y",(LAST12="VI") I LAST3'="",(LAST3'="."),(LAST3'="I") S POS="N",SUFFIX=""
35 .I POS="Y",LAST12'="II",LAST12'="VI" I LAST3'=""&(LAST3'=".") S POS="N"
36 .I LAST12="ES"&(LAST3="Q") S POS="Y",SUFFIX=LAST2
37 .I $D(SUFFIX) S SUFFIX=$TR(SUFFIX,".","")
38 .I POS="Y" S MPISTR=$P(LAST," ")_","_REST_" "_SUFFIX,POS="N",SUF="Y"
39 I POS="N",$P(MPISTR,",")[" " D
40 .S LAST=$P(MPISTR,","),LAST2=$P(LAST," ",2) I $P(LAST," ",3)'="" S MPISTR=$P(LAST," ")_LAST2_" "_$P(LAST," ",3)_","_$P(MPISTR,",",2)
41 ;
42SP ;remove any extra spaces
43 I $F(MPISTR," ") S PL=$F(MPISTR," "),MPISTR=$E(MPISTR,1,PL-2)_$E(MPISTR,PL,$L(MPISTR)) G SP
44 ;Check for middle name existence with suffix to put a place holder of ""
45 S SEC=$P(MPISTR,",",2),FIRST=$P(SEC," "),MIDDLE=$P(SEC," ",2),SUFFIX=$P(SEC," ",3)
46 I SUFFIX="",SUF="Y" S SUFFIX=MIDDLE,MIDDLE="""""",MPISTR=$P(MPISTR,",")_","_FIRST_" "_MIDDLE_" "_SUFFIX
47 ; ^ SUF="Y" means we moved it from left to right of comma
48 I SUFFIX="",SUF="N" D
49 .S MID12=$E(MIDDLE,1,2),MID3=$E(MIDDLE,3) ;Check if MIDDLE is a suffix
50 .I MID12="ES"&(MID3="Q") S POS="Y"
51 .I MID12="JR"!(MID12="SR")!(MID12="DR")!(MID12="MD")!(MID12="II")!(MID12="IV")!(MID12="VI") S POS="Y"
52 .I POS="Y",(MID12="II") I MID3'="",(MID3'="."),(MID3'="I") S POS="N",SUFFIX=""
53 .I POS="Y",(MID12="VI") I MID3'="",(MID3'="."),(MID3'="I") S POS="N",SUFFIX=""
54 .I POS="Y",MID12'="II",MID12'="VI" I MID3'=""&(MID3'=".") S POS="N"
55 .I POS="Y" S SUFFIX=MIDDLE,MIDDLE=""""""
56 .S MPISTR=$P(MPISTR,",")_","_FIRST_" "_MIDDLE_" "_SUFFIX
57 S POS="N"
58 S FIR12=$E(FIRST,1,2),FIR3=$E(FIRST,3) ;check if FIRST is a suffix
59 I FIR12="ES"&(FIR3="Q") S POS="Y"
60 I FIR12="JR"!(FIR12="SR")!(FIR12="DR")!(FIR12="MD")!(FIR12="II")!(FIR12="IV")!(FIR12="VI") S POS="Y"
61 I POS="Y",(FIR12="II") I FIR3'="",(FIR3'="."),(FIR3'="I") S POS="N",SUFFIX=""
62 I POS="Y",(FIR12="VI") I FIR3'="",(FIR3'="."),(FIR3'="I") S POS="N",SUFFIX=""
63 I POS="Y",FIR12'="II",FIR12'="VI" I FIR3'=""&(FIR3'=".") S POS="N"
64 ; if no middle name can't be sure if initials or suffix so will leave as initials
65 I POS="Y",MIDDLE="" S MPISTR=$P(MPISTR,",")_","_$E(FIR12,1)_" "_$E(FIR12,2) S POS="N"
66 I TFLG="Y" S MPISTR=MPISTR_" TEST"
67 I POS="Y" S MPISTR=$P(MPISTR,",")_","_MIDDLE_" "_$S(SUFFIX="":"""""",1:SUFFIX)_" "_FIRST
68SP2 ;remove any extra spaces
69 I $F(MPISTR," ") S PL=$F(MPISTR," "),MPISTR=$E(MPISTR,1,PL-2)_$E(MPISTR,PL,$L(MPISTR)) G SP2
70 I $E(MPISTR,$L(MPISTR))=" " S MPISTR=$E(MPISTR,1,($L(MPISTR)-1))
71 Q
Note: See TracBrowser for help on using the repository browser.