- VAFCPID2 ;ALB/MLI,PKE-Create generic PID segment ; 22 Jan 2002 10:30 AM
- ;;5.3;Registration;**149,240,312,428,494**;Aug 13, 1993
- ; aggressive name re-formatting
- ;
- NAME(DFN,MPISTR,FLG) ;Being aggressive about where Suffix is placed, extra punctuation
- ;DFN - ien from Patient file MPISTR - name as stored in Patient file
- ;FLG - Parameter no longer supported. Originally denoted whether or
- ; not to update the patient file. Patient file will not be
- ; updated anymore.
- I $E(MPISTR,1,14)="MERGING INTO `" S MPISTR=$P($P(MPISTR,"(",2),")") Q ;**240
- S FLG=0
- N LAST,FIRST,MIDDLE,SUFFIX,POS,LAST12,LAST2,LAST3,REST,SUF,SEC,SEC12,SEC3,MID12,MID3,FIR12,FIR3,PL,MID3,TMPSTR,TFLG
- S TFLG="N"
- S TMPSTR=MPISTR
- I $E(MPISTR,($L(MPISTR)-4),$L(MPISTR))=" TEST" S MPISTR=$E(MPISTR,1,($L(MPISTR)-4)),TFLG="Y"
- I MPISTR["'" S MPISTR=$TR(MPISTR,"'","") ;Remove ' punctuation marks from the name
- S MPISTR=$TR(MPISTR,"."," ") I $E(MPISTR,$L(MPISTR))=" " S MPISTR=$E(MPISTR,1,$L(MPISTR)-1)
- ;check if 3rd instead of III
- I $F(MPISTR,"3RD")'=0 S MPISTR=$E(MPISTR,1,$F(MPISTR,"3RD")-4)_"III"_$E(MPISTR,$F(MPISTR,"3RD"),$L(MPISTR))
- ;check if 2nd instead of II
- I $F(MPISTR,"2ND")'=0 S MPISTR=$E(MPISTR,1,$F(MPISTR,"2ND")-4)_"II"_$E(MPISTR,$F(MPISTR,"2ND"),$L(MPISTR))
- I $P(MPISTR,",",3)'="" S PL=$F(MPISTR,","),FIRST=$E(MPISTR,PL,$L(MPISTR)),MPISTR=$P(MPISTR,",")_","_$TR(FIRST,","," ")
- TR I $F(MPISTR," ") S PL=$F(MPISTR," "),MPISTR=$E(MPISTR,1,PL-2)_$E(MPISTR,PL,$L(MPISTR)) G TR
- ;check for more than three pieces after the comma - ex: last,j.r. first mi
- 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
- .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"
- ;move the suffix from the left of the comma to the end of the name str
- S LAST=$P(MPISTR,","),REST=$P(MPISTR,",",2),POS="N",SUF="N"
- I LAST?.A1" ".E D
- .S LAST2=$P(LAST," ",2),LAST12=$E(LAST2,1,2),LAST3=$E(LAST2,3)
- .I LAST12="V"!(LAST12="V.")!(LAST12="I")!(LAST12="I.") S POS="Y",SUFFIX=LAST2
- .I LAST12="JR"!(LAST12="SR")!(LAST12="DR")!(LAST12="MD")!(LAST12="II")!(LAST12="IV")!(LAST12="VI") S POS="Y",SUFFIX=LAST2
- .I POS="Y",(LAST12="II") I LAST3'="",(LAST3'="."),(LAST3'="I") S POS="N",SUFFIX=""
- .I POS="Y",(LAST12="VI") I LAST3'="",(LAST3'="."),(LAST3'="I") S POS="N",SUFFIX=""
- .I POS="Y",LAST12'="II",LAST12'="VI" I LAST3'=""&(LAST3'=".") S POS="N"
- .I LAST12="ES"&(LAST3="Q") S POS="Y",SUFFIX=LAST2
- .I $D(SUFFIX) S SUFFIX=$TR(SUFFIX,".","")
- .I POS="Y" S MPISTR=$P(LAST," ")_","_REST_" "_SUFFIX,POS="N",SUF="Y"
- I POS="N",$P(MPISTR,",")[" " D
- .S LAST=$P(MPISTR,","),LAST2=$P(LAST," ",2) I $P(LAST," ",3)'="" S MPISTR=$P(LAST," ")_LAST2_" "_$P(LAST," ",3)_","_$P(MPISTR,",",2)
- ;
- SP ;remove any extra spaces
- I $F(MPISTR," ") S PL=$F(MPISTR," "),MPISTR=$E(MPISTR,1,PL-2)_$E(MPISTR,PL,$L(MPISTR)) G SP
- ;Check for middle name existence with suffix to put a place holder of ""
- S SEC=$P(MPISTR,",",2),FIRST=$P(SEC," "),MIDDLE=$P(SEC," ",2),SUFFIX=$P(SEC," ",3)
- I SUFFIX="",SUF="Y" S SUFFIX=MIDDLE,MIDDLE="""""",MPISTR=$P(MPISTR,",")_","_FIRST_" "_MIDDLE_" "_SUFFIX
- ; ^ SUF="Y" means we moved it from left to right of comma
- I SUFFIX="",SUF="N" D
- .S MID12=$E(MIDDLE,1,2),MID3=$E(MIDDLE,3) ;Check if MIDDLE is a suffix
- .I MID12="ES"&(MID3="Q") S POS="Y"
- .I MID12="JR"!(MID12="SR")!(MID12="DR")!(MID12="MD")!(MID12="II")!(MID12="IV")!(MID12="VI") S POS="Y"
- .I POS="Y",(MID12="II") I MID3'="",(MID3'="."),(MID3'="I") S POS="N",SUFFIX=""
- .I POS="Y",(MID12="VI") I MID3'="",(MID3'="."),(MID3'="I") S POS="N",SUFFIX=""
- .I POS="Y",MID12'="II",MID12'="VI" I MID3'=""&(MID3'=".") S POS="N"
- .I POS="Y" S SUFFIX=MIDDLE,MIDDLE=""""""
- .S MPISTR=$P(MPISTR,",")_","_FIRST_" "_MIDDLE_" "_SUFFIX
- S POS="N"
- S FIR12=$E(FIRST,1,2),FIR3=$E(FIRST,3) ;check if FIRST is a suffix
- I FIR12="ES"&(FIR3="Q") S POS="Y"
- I FIR12="JR"!(FIR12="SR")!(FIR12="DR")!(FIR12="MD")!(FIR12="II")!(FIR12="IV")!(FIR12="VI") S POS="Y"
- I POS="Y",(FIR12="II") I FIR3'="",(FIR3'="."),(FIR3'="I") S POS="N",SUFFIX=""
- I POS="Y",(FIR12="VI") I FIR3'="",(FIR3'="."),(FIR3'="I") S POS="N",SUFFIX=""
- I POS="Y",FIR12'="II",FIR12'="VI" I FIR3'=""&(FIR3'=".") S POS="N"
- ; if no middle name can't be sure if initials or suffix so will leave as initials
- I POS="Y",MIDDLE="" S MPISTR=$P(MPISTR,",")_","_$E(FIR12,1)_" "_$E(FIR12,2) S POS="N"
- I TFLG="Y" S MPISTR=MPISTR_" TEST"
- I POS="Y" S MPISTR=$P(MPISTR,",")_","_MIDDLE_" "_$S(SUFFIX="":"""""",1:SUFFIX)_" "_FIRST
- SP2 ;remove any extra spaces
- I $F(MPISTR," ") S PL=$F(MPISTR," "),MPISTR=$E(MPISTR,1,PL-2)_$E(MPISTR,PL,$L(MPISTR)) G SP2
- I $E(MPISTR,$L(MPISTR))=" " S MPISTR=$E(MPISTR,1,($L(MPISTR)-1))
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HVAFCPID2 4827 printed Jan 18, 2025@04:02:51 Page 2
- 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
- +2 ; aggressive name re-formatting
- +3 ;
- 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
- +2 ;FLG - Parameter no longer supported. Originally denoted whether or
- +3 ; not to update the patient file. Patient file will not be
- +4 ; updated anymore.
- +5 ;**240
- IF $EXTRACT(MPISTR,1,14)="MERGING INTO `"
- SET MPISTR=$PIECE($PIECE(MPISTR,"(",2),")")
- QUIT
- +6 SET FLG=0
- +7 NEW LAST,FIRST,MIDDLE,SUFFIX,POS,LAST12,LAST2,LAST3,REST,SUF,SEC,SEC12,SEC3,MID12,MID3,FIR12,FIR3,PL,MID3,TMPSTR,TFLG
- +8 SET TFLG="N"
- +9 SET TMPSTR=MPISTR
- +10 IF $EXTRACT(MPISTR,($LENGTH(MPISTR)-4),$LENGTH(MPISTR))=" TEST"
- SET MPISTR=$EXTRACT(MPISTR,1,($LENGTH(MPISTR)-4))
- SET TFLG="Y"
- +11 ;Remove ' punctuation marks from the name
- IF MPISTR["'"
- SET MPISTR=$TRANSLATE(MPISTR,"'","")
- +12 SET MPISTR=$TRANSLATE(MPISTR,"."," ")
- IF $EXTRACT(MPISTR,$LENGTH(MPISTR))=" "
- SET MPISTR=$EXTRACT(MPISTR,1,$LENGTH(MPISTR)-1)
- +13 ;check if 3rd instead of III
- +14 IF $FIND(MPISTR,"3RD")'=0
- SET MPISTR=$EXTRACT(MPISTR,1,$FIND(MPISTR,"3RD")-4)_"III"_$EXTRACT(MPISTR,$FIND(MPISTR,"3RD"),$LENGTH(MPISTR))
- +15 ;check if 2nd instead of II
- +16 IF $FIND(MPISTR,"2ND")'=0
- SET MPISTR=$EXTRACT(MPISTR,1,$FIND(MPISTR,"2ND")-4)_"II"_$EXTRACT(MPISTR,$FIND(MPISTR,"2ND"),$LENGTH(MPISTR))
- +17 IF $PIECE(MPISTR,",",3)'=""
- SET PL=$FIND(MPISTR,",")
- SET FIRST=$EXTRACT(MPISTR,PL,$LENGTH(MPISTR))
- SET MPISTR=$PIECE(MPISTR,",")_","_$TRANSLATE(FIRST,","," ")
- TR IF $FIND(MPISTR," ")
- SET PL=$FIND(MPISTR," ")
- SET MPISTR=$EXTRACT(MPISTR,1,PL-2)_$EXTRACT(MPISTR,PL,$LENGTH(MPISTR))
- GOTO TR
- +1 ;check for more than three pieces after the comma - ex: last,j.r. first mi
- +2 IF $PIECE(MPISTR,",",2)?.A1" ".A1" ".A1" ".A
- SET REST=$PIECE(MPISTR,",",2)
- IF $EXTRACT(REST,1,4)?1A1" "1A1" "
- SET POS=$EXTRACT(REST,1)_$EXTRACT(REST,3)
- Begin DoDot:1
- +3 IF POS="II"!(POS="IV")!(POS="VI")!(POS="JR")!(POS="SR")!(POS="DR")
- SET SUF="Y"
- SET MPISTR=$PIECE(MPISTR,",")_","_$EXTRACT(REST,5,$LENGTH(REST))_" "_POS
- SET POS="Y"
- End DoDot:1
- +4 ;move the suffix from the left of the comma to the end of the name str
- +5 SET LAST=$PIECE(MPISTR,",")
- SET REST=$PIECE(MPISTR,",",2)
- SET POS="N"
- SET SUF="N"
- +6 IF LAST?.A1" ".E
- Begin DoDot:1
- +7 SET LAST2=$PIECE(LAST," ",2)
- SET LAST12=$EXTRACT(LAST2,1,2)
- SET LAST3=$EXTRACT(LAST2,3)
- +8 IF LAST12="V"!(LAST12="V.")!(LAST12="I")!(LAST12="I.")
- SET POS="Y"
- SET SUFFIX=LAST2
- +9 IF LAST12="JR"!(LAST12="SR")!(LAST12="DR")!(LAST12="MD")!(LAST12="II")!(LAST12="IV")!(LAST12="VI")
- SET POS="Y"
- SET SUFFIX=LAST2
- +10 IF POS="Y"
- IF (LAST12="II")
- IF LAST3'=""
- IF (LAST3'=".")
- IF (LAST3'="I")
- SET POS="N"
- SET SUFFIX=""
- +11 IF POS="Y"
- IF (LAST12="VI")
- IF LAST3'=""
- IF (LAST3'=".")
- IF (LAST3'="I")
- SET POS="N"
- SET SUFFIX=""
- +12 IF POS="Y"
- IF LAST12'="II"
- IF LAST12'="VI"
- IF LAST3'=""&(LAST3'=".")
- SET POS="N"
- +13 IF LAST12="ES"&(LAST3="Q")
- SET POS="Y"
- SET SUFFIX=LAST2
- +14 IF $DATA(SUFFIX)
- SET SUFFIX=$TRANSLATE(SUFFIX,".","")
- +15 IF POS="Y"
- SET MPISTR=$PIECE(LAST," ")_","_REST_" "_SUFFIX
- SET POS="N"
- SET SUF="Y"
- End DoDot:1
- +16 IF POS="N"
- IF $PIECE(MPISTR,",")[" "
- Begin DoDot:1
- +17 SET LAST=$PIECE(MPISTR,",")
- SET LAST2=$PIECE(LAST," ",2)
- IF $PIECE(LAST," ",3)'=""
- SET MPISTR=$PIECE(LAST," ")_LAST2_" "_$PIECE(LAST," ",3)_","_$PIECE(MPISTR,",",2)
- End DoDot:1
- +18 ;
- SP ;remove any extra spaces
- +1 IF $FIND(MPISTR," ")
- SET PL=$FIND(MPISTR," ")
- SET MPISTR=$EXTRACT(MPISTR,1,PL-2)_$EXTRACT(MPISTR,PL,$LENGTH(MPISTR))
- GOTO SP
- +2 ;Check for middle name existence with suffix to put a place holder of ""
- +3 SET SEC=$PIECE(MPISTR,",",2)
- SET FIRST=$PIECE(SEC," ")
- SET MIDDLE=$PIECE(SEC," ",2)
- SET SUFFIX=$PIECE(SEC," ",3)
- +4 IF SUFFIX=""
- IF SUF="Y"
- SET SUFFIX=MIDDLE
- SET MIDDLE=""""""
- SET MPISTR=$PIECE(MPISTR,",")_","_FIRST_" "_MIDDLE_" "_SUFFIX
- +5 ; ^ SUF="Y" means we moved it from left to right of comma
- +6 IF SUFFIX=""
- IF SUF="N"
- Begin DoDot:1
- +7 ;Check if MIDDLE is a suffix
- SET MID12=$EXTRACT(MIDDLE,1,2)
- SET MID3=$EXTRACT(MIDDLE,3)
- +8 IF MID12="ES"&(MID3="Q")
- SET POS="Y"
- +9 IF MID12="JR"!(MID12="SR")!(MID12="DR")!(MID12="MD")!(MID12="II")!(MID12="IV")!(MID12="VI")
- SET POS="Y"
- +10 IF POS="Y"
- IF (MID12="II")
- IF MID3'=""
- IF (MID3'=".")
- IF (MID3'="I")
- SET POS="N"
- SET SUFFIX=""
- +11 IF POS="Y"
- IF (MID12="VI")
- IF MID3'=""
- IF (MID3'=".")
- IF (MID3'="I")
- SET POS="N"
- SET SUFFIX=""
- +12 IF POS="Y"
- IF MID12'="II"
- IF MID12'="VI"
- IF MID3'=""&(MID3'=".")
- SET POS="N"
- +13 IF POS="Y"
- SET SUFFIX=MIDDLE
- SET MIDDLE=""""""
- +14 SET MPISTR=$PIECE(MPISTR,",")_","_FIRST_" "_MIDDLE_" "_SUFFIX
- End DoDot:1
- +15 SET POS="N"
- +16 ;check if FIRST is a suffix
- SET FIR12=$EXTRACT(FIRST,1,2)
- SET FIR3=$EXTRACT(FIRST,3)
- +17 IF FIR12="ES"&(FIR3="Q")
- SET POS="Y"
- +18 IF FIR12="JR"!(FIR12="SR")!(FIR12="DR")!(FIR12="MD")!(FIR12="II")!(FIR12="IV")!(FIR12="VI")
- SET POS="Y"
- +19 IF POS="Y"
- IF (FIR12="II")
- IF FIR3'=""
- IF (FIR3'=".")
- IF (FIR3'="I")
- SET POS="N"
- SET SUFFIX=""
- +20 IF POS="Y"
- IF (FIR12="VI")
- IF FIR3'=""
- IF (FIR3'=".")
- IF (FIR3'="I")
- SET POS="N"
- SET SUFFIX=""
- +21 IF POS="Y"
- IF FIR12'="II"
- IF FIR12'="VI"
- IF FIR3'=""&(FIR3'=".")
- SET POS="N"
- +22 ; if no middle name can't be sure if initials or suffix so will leave as initials
- +23 IF POS="Y"
- IF MIDDLE=""
- SET MPISTR=$PIECE(MPISTR,",")_","_$EXTRACT(FIR12,1)_" "_$EXTRACT(FIR12,2)
- SET POS="N"
- +24 IF TFLG="Y"
- SET MPISTR=MPISTR_" TEST"
- +25 IF POS="Y"
- SET MPISTR=$PIECE(MPISTR,",")_","_MIDDLE_" "_$SELECT(SUFFIX="":"""""",1:SUFFIX)_" "_FIRST
- SP2 ;remove any extra spaces
- +1 IF $FIND(MPISTR," ")
- SET PL=$FIND(MPISTR," ")
- SET MPISTR=$EXTRACT(MPISTR,1,PL-2)_$EXTRACT(MPISTR,PL,$LENGTH(MPISTR))
- GOTO SP2
- +2 IF $EXTRACT(MPISTR,$LENGTH(MPISTR))=" "
- SET MPISTR=$EXTRACT(MPISTR,1,($LENGTH(MPISTR)-1))
- +3 QUIT