Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: VAFCPID2

VAFCPID2.m

Go to the documentation of this file.
  1. VAFCPID2 ;ALB/MLI,PKE-Create generic PID segment ; 22 Jan 2002 10:30 AM
  1. ;;5.3;Registration;**149,240,312,428,494**;Aug 13, 1993
  1. ; aggressive name re-formatting
  1. ;
  1. NAME(DFN,MPISTR,FLG) ;Being aggressive about where Suffix is placed, extra punctuation
  1. ;DFN - ien from Patient file MPISTR - name as stored in Patient file
  1. ;FLG - Parameter no longer supported. Originally denoted whether or
  1. ; not to update the patient file. Patient file will not be
  1. ; updated anymore.
  1. I $E(MPISTR,1,14)="MERGING INTO `" S MPISTR=$P($P(MPISTR,"(",2),")") Q ;**240
  1. S FLG=0
  1. N LAST,FIRST,MIDDLE,SUFFIX,POS,LAST12,LAST2,LAST3,REST,SUF,SEC,SEC12,SEC3,MID12,MID3,FIR12,FIR3,PL,MID3,TMPSTR,TFLG
  1. S TFLG="N"
  1. S TMPSTR=MPISTR
  1. I $E(MPISTR,($L(MPISTR)-4),$L(MPISTR))=" TEST" S MPISTR=$E(MPISTR,1,($L(MPISTR)-4)),TFLG="Y"
  1. I MPISTR["'" S MPISTR=$TR(MPISTR,"'","") ;Remove ' punctuation marks from the name
  1. S MPISTR=$TR(MPISTR,"."," ") I $E(MPISTR,$L(MPISTR))=" " S MPISTR=$E(MPISTR,1,$L(MPISTR)-1)
  1. ;check if 3rd instead of III
  1. I $F(MPISTR,"3RD")'=0 S MPISTR=$E(MPISTR,1,$F(MPISTR,"3RD")-4)_"III"_$E(MPISTR,$F(MPISTR,"3RD"),$L(MPISTR))
  1. ;check if 2nd instead of II
  1. I $F(MPISTR,"2ND")'=0 S MPISTR=$E(MPISTR,1,$F(MPISTR,"2ND")-4)_"II"_$E(MPISTR,$F(MPISTR,"2ND"),$L(MPISTR))
  1. I $P(MPISTR,",",3)'="" S PL=$F(MPISTR,","),FIRST=$E(MPISTR,PL,$L(MPISTR)),MPISTR=$P(MPISTR,",")_","_$TR(FIRST,","," ")
  1. TR I $F(MPISTR," ") S PL=$F(MPISTR," "),MPISTR=$E(MPISTR,1,PL-2)_$E(MPISTR,PL,$L(MPISTR)) G TR
  1. ;check for more than three pieces after the comma - ex: last,j.r. first mi
  1. 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
  1. .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"
  1. ;move the suffix from the left of the comma to the end of the name str
  1. S LAST=$P(MPISTR,","),REST=$P(MPISTR,",",2),POS="N",SUF="N"
  1. I LAST?.A1" ".E D
  1. .S LAST2=$P(LAST," ",2),LAST12=$E(LAST2,1,2),LAST3=$E(LAST2,3)
  1. .I LAST12="V"!(LAST12="V.")!(LAST12="I")!(LAST12="I.") S POS="Y",SUFFIX=LAST2
  1. .I LAST12="JR"!(LAST12="SR")!(LAST12="DR")!(LAST12="MD")!(LAST12="II")!(LAST12="IV")!(LAST12="VI") S POS="Y",SUFFIX=LAST2
  1. .I POS="Y",(LAST12="II") I LAST3'="",(LAST3'="."),(LAST3'="I") S POS="N",SUFFIX=""
  1. .I POS="Y",(LAST12="VI") I LAST3'="",(LAST3'="."),(LAST3'="I") S POS="N",SUFFIX=""
  1. .I POS="Y",LAST12'="II",LAST12'="VI" I LAST3'=""&(LAST3'=".") S POS="N"
  1. .I LAST12="ES"&(LAST3="Q") S POS="Y",SUFFIX=LAST2
  1. .I $D(SUFFIX) S SUFFIX=$TR(SUFFIX,".","")
  1. .I POS="Y" S MPISTR=$P(LAST," ")_","_REST_" "_SUFFIX,POS="N",SUF="Y"
  1. I POS="N",$P(MPISTR,",")[" " D
  1. .S LAST=$P(MPISTR,","),LAST2=$P(LAST," ",2) I $P(LAST," ",3)'="" S MPISTR=$P(LAST," ")_LAST2_" "_$P(LAST," ",3)_","_$P(MPISTR,",",2)
  1. ;
  1. SP ;remove any extra spaces
  1. I $F(MPISTR," ") S PL=$F(MPISTR," "),MPISTR=$E(MPISTR,1,PL-2)_$E(MPISTR,PL,$L(MPISTR)) G SP
  1. ;Check for middle name existence with suffix to put a place holder of ""
  1. S SEC=$P(MPISTR,",",2),FIRST=$P(SEC," "),MIDDLE=$P(SEC," ",2),SUFFIX=$P(SEC," ",3)
  1. I SUFFIX="",SUF="Y" S SUFFIX=MIDDLE,MIDDLE="""""",MPISTR=$P(MPISTR,",")_","_FIRST_" "_MIDDLE_" "_SUFFIX
  1. ; ^ SUF="Y" means we moved it from left to right of comma
  1. I SUFFIX="",SUF="N" D
  1. .S MID12=$E(MIDDLE,1,2),MID3=$E(MIDDLE,3) ;Check if MIDDLE is a suffix
  1. .I MID12="ES"&(MID3="Q") S POS="Y"
  1. .I MID12="JR"!(MID12="SR")!(MID12="DR")!(MID12="MD")!(MID12="II")!(MID12="IV")!(MID12="VI") S POS="Y"
  1. .I POS="Y",(MID12="II") I MID3'="",(MID3'="."),(MID3'="I") S POS="N",SUFFIX=""
  1. .I POS="Y",(MID12="VI") I MID3'="",(MID3'="."),(MID3'="I") S POS="N",SUFFIX=""
  1. .I POS="Y",MID12'="II",MID12'="VI" I MID3'=""&(MID3'=".") S POS="N"
  1. .I POS="Y" S SUFFIX=MIDDLE,MIDDLE=""""""
  1. .S MPISTR=$P(MPISTR,",")_","_FIRST_" "_MIDDLE_" "_SUFFIX
  1. S POS="N"
  1. S FIR12=$E(FIRST,1,2),FIR3=$E(FIRST,3) ;check if FIRST is a suffix
  1. I FIR12="ES"&(FIR3="Q") S POS="Y"
  1. I FIR12="JR"!(FIR12="SR")!(FIR12="DR")!(FIR12="MD")!(FIR12="II")!(FIR12="IV")!(FIR12="VI") S POS="Y"
  1. I POS="Y",(FIR12="II") I FIR3'="",(FIR3'="."),(FIR3'="I") S POS="N",SUFFIX=""
  1. I POS="Y",(FIR12="VI") I FIR3'="",(FIR3'="."),(FIR3'="I") S POS="N",SUFFIX=""
  1. I POS="Y",FIR12'="II",FIR12'="VI" I FIR3'=""&(FIR3'=".") S POS="N"
  1. ; if no middle name can't be sure if initials or suffix so will leave as initials
  1. I POS="Y",MIDDLE="" S MPISTR=$P(MPISTR,",")_","_$E(FIR12,1)_" "_$E(FIR12,2) S POS="N"
  1. I TFLG="Y" S MPISTR=MPISTR_" TEST"
  1. I POS="Y" S MPISTR=$P(MPISTR,",")_","_MIDDLE_" "_$S(SUFFIX="":"""""",1:SUFFIX)_" "_FIRST
  1. SP2 ;remove any extra spaces
  1. I $F(MPISTR," ") S PL=$F(MPISTR," "),MPISTR=$E(MPISTR,1,PL-2)_$E(MPISTR,PL,$L(MPISTR)) G SP2
  1. I $E(MPISTR,$L(MPISTR))=" " S MPISTR=$E(MPISTR,1,($L(MPISTR)-1))
  1. Q