VAFHLPI1 ;BPFO/JRP - EXTENSION OF PID SEGMENT BUILDER VAFHLPID;5-DEC-2001 ; 21 Nov 2002 3:13 PM
;;5.3;Registration;**415**;Aug 13, 1993
;
Q
;
SEQ3(DFN,TYPE,HLENC,HLQ) ;Build specified Patient ID (seq 3)
;Input : DFN - Pointer to Patient file (#2)
; TYPE - Which Patient ID to build
; NI = ICN (default)
; SS = SSN [with dashes]
; PI = DFN
; HLENC - HL7 encoding characters (defaults to ~|\&)
; HLQ - HL7 null designation (defaults to "")
;Output : Value for Patient ID (seq 3)
;Notes : HLQ will be returned on bad input
;
;Check input
S HLENC=$G(HLENC)
S:$L(HLENC)'=4 HLENC="~|\&"
S:'$D(HLQ) HLQ=""""""
S DFN=+$G(DFN)
I '$D(^DPT(DFN,0)) Q HLQ
S TYPE=$G(TYPE,"NI")
S:(",NI,SS,PI,"'[(","_TYPE_",")) TYPE="NI"
;Declare variables
N COMP,REP,SUB,VALUE,ID,TMP
;Break out encoding characters
S COMP=$E(HLENC,1)
S REP=$E(HLENC,2)
S SUB=$E(HLENC,4)
;ID (comp 1)
S ID=""
;ICN
I TYPE="NI" D
.;Don't transmit local ICNs
.I $$IFLOCAL^MPIF001(DFN) S ID="" Q
.S ID=$$GETICN^MPIF001(DFN)
.I (+ID)=-1 S ID=""
;SSN
I TYPE="SS" D
.S ID=$P($G(^DPT(DFN,0)),"^",9)
.I ID'="" S ID=$E(ID,1,3)_"-"_$E(ID,4,5)_"-"_$E(ID,6,10)
;DFN
I TYPE="PI" D
.S ID=DFN
S VALUE=$S(ID="":HLQ,1:ID)
;Check Digit (comp 2) - not used for SSN
I TYPE'="SS" D
.;ICN - pull off check digit
.I TYPE="NI" S $P(VALUE,COMP,2)=$P(ID,"V",2) Q
.;DFN - calculate check digit
.; Note: output of call includes Check Digit Scheme (comp 3)
.S TMP=$$M10^HLFNC(DFN,COMP)
.S $P(VALUE,COMP,2,3)=$P(TMP,COMP,2,3)
;Assigning Authority (comp 4)
S TMP=""
S $P(TMP,SUB,1)=$S(TYPE="SS":"USSSA",1:"USVHA")
S $P(TMP,SUB,3)="L"
S $P(VALUE,COMP,4)=TMP
;Identifier Type Code (comp 5)
S $P(VALUE,COMP,5)=TYPE
;Assigning Facility (comp 6) - only used for DFN
I TYPE="PI" S $P(VALUE,COMP,6)=+$P($$SITE^VASITE(),"^",3)
;Effective Date (comp 7) - only used for DFN
I TYPE="PI" D
.;DFN
.S TMP=$P($G(^DPT(DFN,0)),"^",16)
.S $P(VALUE,COMP,7)=$$HLDATE^HLFNC(TMP,"DT")
;Return value
Q VALUE
;
SEQ10(HOW,HLQ) ;Race
;Input : HOW - Qualifiers denoting how & which race to return
; N = Return new race value (2.02 multiple)
; T = Include text (components 2 & 5)
; B = Include second triplet (components 4 - 6)
; "" = Return historical value (.06 field)
; HLQ - HL7 null designation
;Assumed: VADM() - Output of call to DEM^VADPT
;Output : None - sets nodes in array VAFY
; VAFY(10,1..X) = Repetion X (if no components)
; VAFY(10,1..X,1..Y) = Component Y of repetiton X
;Notes : Validity and existance of input is assumed
; : Use of T & B qualifiers assume use of N qualifier
; : Assumes no individual component is greater than 245
; characters long
;
;Declare variables
N RACENUM,CNT,RACE,X
K VAFY(10)
I (HOW="")!((HOW'["N")&(HOW'["B")&(HOW'["T")) D Q
.;Send historical value (if blank, send 7 (UNKNOWN))
.S X=$$PTR2CODE^DGUTL4(+VADM(8),1,1)
.S VAFY(10,1)=$S(X]"":X,1:7)
;No values on file
I VADM(12)=0 D Q
.;First triplet
.S VAFY(10,1,1)=HLQ
.S VAFY(10,1,2)=$S(HOW["T":HLQ,1:"")
.S VAFY(10,1,3)="0005"
.;Second triplet
.Q:HOW'["B"
.S VAFY(10,1,4)=HLQ
.S VAFY(10,1,5)=$S(HOW["T":HLQ,1:"")
.S VAFY(10,1,6)="CDC"
;Loop through all races (CNT is repetition location)
S RACENUM=0
F CNT=1:1 S RACENUM=+$O(VADM(12,RACENUM)) Q:'RACENUM D
.;Fabricate race value -> RACE-METHOD
.S RACE=$$PTR2CODE^DGUTL4(+VADM(12,RACENUM),1,2)
.S X=$$PTR2CODE^DGUTL4(+$G(VADM(12,RACENUM,1)),3,2)
.S:X="" X="UNK"
.S RACE=RACE_"-"_X
.;First triplet
.S VAFY(10,CNT,1)=RACE
.S VAFY(10,CNT,2)=$S(HOW["T":$P(VADM(12,RACENUM),"^",2),1:"")
.S VAFY(10,CNT,3)="0005"
.;Second triplet
.Q:HOW'["B"
.S X=$$PTR2CODE^DGUTL4(+VADM(12,RACENUM),1,3)
.S VAFY(10,CNT,4)=$S(X="":HLQ,1:X)
.S VAFY(10,CNT,5)=$S(HOW["T":$P(VADM(12,RACENUM),"^",2),1:"")
.S VAFY(10,CNT,6)="CDC"
Q
;
SEQ22(HOW,HLQ) ;Ethnicity
;Input : HOW - Qualifiers denoting how to return ethnicity
; T = Include text (components 2 & 5)
; B = Include second triplet (components 4 - 6)
; "" = Only return components 1 & 3
; HLQ - HL7 null designation
;Assumed: VADM() - Output of call to DEM^VADPT
;Output : None - sets nodes in array VAFY
; VAFY(22,1,1..Y) = Component Y
;Notes : Validity and existance of input is assumed
; : Assumes no individual component is greater than 245
; characters long
;
;Declare variables
N ETHNIC,X,ETHNUM,CNT
K VAFY(22)
;No value on file
I +VADM(11)=0 D Q
.;First triplet
.S VAFY(22,1,1)=HLQ
.S VAFY(22,1,2)=$S(HOW["T":HLQ,1:"")
.S VAFY(22,1,3)="0189"
.;Second triplet
.Q:HOW'["B"
.S VAFY(22,1,4)=HLQ
.S VAFY(22,1,5)=$S(HOW["T":HLQ,1:"")
.S VAFY(22,1,6)="CDC"
;Loop through all ethnicities (CNT is repetition location)
S ETHNUM=0
F CNT=1:1 S ETHNUM=+$O(VADM(11,ETHNUM)) Q:'ETHNUM D
.;Fabricate ethnicity value -> ETHNICITY-METHOD
.S ETHNIC=$$PTR2CODE^DGUTL4(+VADM(11,ETHNUM),2,2)
.S X=$$PTR2CODE^DGUTL4(+$G(VADM(11,ETHNUM,1)),3,2)
.S:X="" X="UNK"
.S ETHNIC=ETHNIC_"-"_X
.;First triplet
.S VAFY(22,CNT,1)=ETHNIC
.S VAFY(22,CNT,2)=$S(HOW["T":$P(VADM(11,ETHNUM),"^",2),1:"")
.S VAFY(22,CNT,3)="0189"
.;Second triplet
.Q:HOW'["B"
.S X=$$PTR2CODE^DGUTL4(+VADM(11,ETHNUM),2,3)
.S VAFY(22,CNT,4)=$S(X="":HLQ,1:X)
.S VAFY(22,CNT,5)=$S(HOW["T":$P(VADM(11,ETHNUM),"^",2),1:"")
.S VAFY(22,CNT,6)="CDC"
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HVAFHLPI1 5664 printed Sep 23, 2025@20:39 Page 2
VAFHLPI1 ;BPFO/JRP - EXTENSION OF PID SEGMENT BUILDER VAFHLPID;5-DEC-2001 ; 21 Nov 2002 3:13 PM
+1 ;;5.3;Registration;**415**;Aug 13, 1993
+2 ;
+3 QUIT
+4 ;
SEQ3(DFN,TYPE,HLENC,HLQ) ;Build specified Patient ID (seq 3)
+1 ;Input : DFN - Pointer to Patient file (#2)
+2 ; TYPE - Which Patient ID to build
+3 ; NI = ICN (default)
+4 ; SS = SSN [with dashes]
+5 ; PI = DFN
+6 ; HLENC - HL7 encoding characters (defaults to ~|\&)
+7 ; HLQ - HL7 null designation (defaults to "")
+8 ;Output : Value for Patient ID (seq 3)
+9 ;Notes : HLQ will be returned on bad input
+10 ;
+11 ;Check input
+12 SET HLENC=$GET(HLENC)
+13 if $LENGTH(HLENC)'=4
SET HLENC="~|\&"
+14 if '$DATA(HLQ)
SET HLQ=""""""
+15 SET DFN=+$GET(DFN)
+16 IF '$DATA(^DPT(DFN,0))
QUIT HLQ
+17 SET TYPE=$GET(TYPE,"NI")
+18 if (",NI,SS,PI,"'[(","_TYPE_","))
SET TYPE="NI"
+19 ;Declare variables
+20 NEW COMP,REP,SUB,VALUE,ID,TMP
+21 ;Break out encoding characters
+22 SET COMP=$EXTRACT(HLENC,1)
+23 SET REP=$EXTRACT(HLENC,2)
+24 SET SUB=$EXTRACT(HLENC,4)
+25 ;ID (comp 1)
+26 SET ID=""
+27 ;ICN
+28 IF TYPE="NI"
Begin DoDot:1
+29 ;Don't transmit local ICNs
+30 IF $$IFLOCAL^MPIF001(DFN)
SET ID=""
QUIT
+31 SET ID=$$GETICN^MPIF001(DFN)
+32 IF (+ID)=-1
SET ID=""
End DoDot:1
+33 ;SSN
+34 IF TYPE="SS"
Begin DoDot:1
+35 SET ID=$PIECE($GET(^DPT(DFN,0)),"^",9)
+36 IF ID'=""
SET ID=$EXTRACT(ID,1,3)_"-"_$EXTRACT(ID,4,5)_"-"_$EXTRACT(ID,6,10)
End DoDot:1
+37 ;DFN
+38 IF TYPE="PI"
Begin DoDot:1
+39 SET ID=DFN
End DoDot:1
+40 SET VALUE=$SELECT(ID="":HLQ,1:ID)
+41 ;Check Digit (comp 2) - not used for SSN
+42 IF TYPE'="SS"
Begin DoDot:1
+43 ;ICN - pull off check digit
+44 IF TYPE="NI"
SET $PIECE(VALUE,COMP,2)=$PIECE(ID,"V",2)
QUIT
+45 ;DFN - calculate check digit
+46 ; Note: output of call includes Check Digit Scheme (comp 3)
+47 SET TMP=$$M10^HLFNC(DFN,COMP)
+48 SET $PIECE(VALUE,COMP,2,3)=$PIECE(TMP,COMP,2,3)
End DoDot:1
+49 ;Assigning Authority (comp 4)
+50 SET TMP=""
+51 SET $PIECE(TMP,SUB,1)=$SELECT(TYPE="SS":"USSSA",1:"USVHA")
+52 SET $PIECE(TMP,SUB,3)="L"
+53 SET $PIECE(VALUE,COMP,4)=TMP
+54 ;Identifier Type Code (comp 5)
+55 SET $PIECE(VALUE,COMP,5)=TYPE
+56 ;Assigning Facility (comp 6) - only used for DFN
+57 IF TYPE="PI"
SET $PIECE(VALUE,COMP,6)=+$PIECE($$SITE^VASITE(),"^",3)
+58 ;Effective Date (comp 7) - only used for DFN
+59 IF TYPE="PI"
Begin DoDot:1
+60 ;DFN
+61 SET TMP=$PIECE($GET(^DPT(DFN,0)),"^",16)
+62 SET $PIECE(VALUE,COMP,7)=$$HLDATE^HLFNC(TMP,"DT")
End DoDot:1
+63 ;Return value
+64 QUIT VALUE
+65 ;
SEQ10(HOW,HLQ) ;Race
+1 ;Input : HOW - Qualifiers denoting how & which race to return
+2 ; N = Return new race value (2.02 multiple)
+3 ; T = Include text (components 2 & 5)
+4 ; B = Include second triplet (components 4 - 6)
+5 ; "" = Return historical value (.06 field)
+6 ; HLQ - HL7 null designation
+7 ;Assumed: VADM() - Output of call to DEM^VADPT
+8 ;Output : None - sets nodes in array VAFY
+9 ; VAFY(10,1..X) = Repetion X (if no components)
+10 ; VAFY(10,1..X,1..Y) = Component Y of repetiton X
+11 ;Notes : Validity and existance of input is assumed
+12 ; : Use of T & B qualifiers assume use of N qualifier
+13 ; : Assumes no individual component is greater than 245
+14 ; characters long
+15 ;
+16 ;Declare variables
+17 NEW RACENUM,CNT,RACE,X
+18 KILL VAFY(10)
+19 IF (HOW="")!((HOW'["N")&(HOW'["B")&(HOW'["T"))
Begin DoDot:1
+20 ;Send historical value (if blank, send 7 (UNKNOWN))
+21 SET X=$$PTR2CODE^DGUTL4(+VADM(8),1,1)
+22 SET VAFY(10,1)=$SELECT(X]"":X,1:7)
End DoDot:1
QUIT
+23 ;No values on file
+24 IF VADM(12)=0
Begin DoDot:1
+25 ;First triplet
+26 SET VAFY(10,1,1)=HLQ
+27 SET VAFY(10,1,2)=$SELECT(HOW["T":HLQ,1:"")
+28 SET VAFY(10,1,3)="0005"
+29 ;Second triplet
+30 if HOW'["B"
QUIT
+31 SET VAFY(10,1,4)=HLQ
+32 SET VAFY(10,1,5)=$SELECT(HOW["T":HLQ,1:"")
+33 SET VAFY(10,1,6)="CDC"
End DoDot:1
QUIT
+34 ;Loop through all races (CNT is repetition location)
+35 SET RACENUM=0
+36 FOR CNT=1:1
SET RACENUM=+$ORDER(VADM(12,RACENUM))
if 'RACENUM
QUIT
Begin DoDot:1
+37 ;Fabricate race value -> RACE-METHOD
+38 SET RACE=$$PTR2CODE^DGUTL4(+VADM(12,RACENUM),1,2)
+39 SET X=$$PTR2CODE^DGUTL4(+$GET(VADM(12,RACENUM,1)),3,2)
+40 if X=""
SET X="UNK"
+41 SET RACE=RACE_"-"_X
+42 ;First triplet
+43 SET VAFY(10,CNT,1)=RACE
+44 SET VAFY(10,CNT,2)=$SELECT(HOW["T":$PIECE(VADM(12,RACENUM),"^",2),1:"")
+45 SET VAFY(10,CNT,3)="0005"
+46 ;Second triplet
+47 if HOW'["B"
QUIT
+48 SET X=$$PTR2CODE^DGUTL4(+VADM(12,RACENUM),1,3)
+49 SET VAFY(10,CNT,4)=$SELECT(X="":HLQ,1:X)
+50 SET VAFY(10,CNT,5)=$SELECT(HOW["T":$PIECE(VADM(12,RACENUM),"^",2),1:"")
+51 SET VAFY(10,CNT,6)="CDC"
End DoDot:1
+52 QUIT
+53 ;
SEQ22(HOW,HLQ) ;Ethnicity
+1 ;Input : HOW - Qualifiers denoting how to return ethnicity
+2 ; T = Include text (components 2 & 5)
+3 ; B = Include second triplet (components 4 - 6)
+4 ; "" = Only return components 1 & 3
+5 ; HLQ - HL7 null designation
+6 ;Assumed: VADM() - Output of call to DEM^VADPT
+7 ;Output : None - sets nodes in array VAFY
+8 ; VAFY(22,1,1..Y) = Component Y
+9 ;Notes : Validity and existance of input is assumed
+10 ; : Assumes no individual component is greater than 245
+11 ; characters long
+12 ;
+13 ;Declare variables
+14 NEW ETHNIC,X,ETHNUM,CNT
+15 KILL VAFY(22)
+16 ;No value on file
+17 IF +VADM(11)=0
Begin DoDot:1
+18 ;First triplet
+19 SET VAFY(22,1,1)=HLQ
+20 SET VAFY(22,1,2)=$SELECT(HOW["T":HLQ,1:"")
+21 SET VAFY(22,1,3)="0189"
+22 ;Second triplet
+23 if HOW'["B"
QUIT
+24 SET VAFY(22,1,4)=HLQ
+25 SET VAFY(22,1,5)=$SELECT(HOW["T":HLQ,1:"")
+26 SET VAFY(22,1,6)="CDC"
End DoDot:1
QUIT
+27 ;Loop through all ethnicities (CNT is repetition location)
+28 SET ETHNUM=0
+29 FOR CNT=1:1
SET ETHNUM=+$ORDER(VADM(11,ETHNUM))
if 'ETHNUM
QUIT
Begin DoDot:1
+30 ;Fabricate ethnicity value -> ETHNICITY-METHOD
+31 SET ETHNIC=$$PTR2CODE^DGUTL4(+VADM(11,ETHNUM),2,2)
+32 SET X=$$PTR2CODE^DGUTL4(+$GET(VADM(11,ETHNUM,1)),3,2)
+33 if X=""
SET X="UNK"
+34 SET ETHNIC=ETHNIC_"-"_X
+35 ;First triplet
+36 SET VAFY(22,CNT,1)=ETHNIC
+37 SET VAFY(22,CNT,2)=$SELECT(HOW["T":$PIECE(VADM(11,ETHNUM),"^",2),1:"")
+38 SET VAFY(22,CNT,3)="0189"
+39 ;Second triplet
+40 if HOW'["B"
QUIT
+41 SET X=$$PTR2CODE^DGUTL4(+VADM(11,ETHNUM),2,3)
+42 SET VAFY(22,CNT,4)=$SELECT(X="":HLQ,1:X)
+43 SET VAFY(22,CNT,5)=$SELECT(HOW["T":$PIECE(VADM(11,ETHNUM),"^",2),1:"")
+44 SET VAFY(22,CNT,6)="CDC"
End DoDot:1
+45 QUIT
