XUPSSTF ;ALB/CMC - Build STF segment;Aug, 6 2010
;;8.0;KERNEL;**551**;Jul 10, 1995;Build 2
;
Q
EN(XUPSIEN,XUPSSTR,HL,XUPSREC,XUPSSTF) ; -- entry point
;Input:
;XUPSIEN - New Person Internal Entry Number
;XUPSSTR - sequence numbers which should be used (2,3,4,5,6,10,11)
;HL - HL array variables from INIT call
;Output:
;XUPSREC - First 245 characters
;XUPSSTF(1..n)=continuation nodes if results > 245 characters
;
N XUPSSUB1,XUPSSUB2,XUPSSUB3,XUPSSUB4,XUPSSSN,XUPSDOB,XUPSPH
N XUPSNO,XUPSSEX,XUPSNAMC,XUPSNAME,XUPSNAM1,XUPSREP,XUPSVID,XUPSCAT,XUPSNPI,TADDR
N DA,DIE,DR,XUPSNAM2,XUPSVER,XUPSADD,XUPSADDR,XUPSADD1,XUPSADD2,XUPSI,XUPSSEG,HLFS,COMP,SUBCOMP
;
I '$D(HL) S XUPSREC="-1^missing HL variables" Q
S HLFS=HL("FS"),COMP=$E(HL("ECH")),HLES=$E(HL("ECH"),2),SUBCOMP=$E(HL("ECH"),4)
N ARRAY,TMP
S TMP=$$GET^XUPSGS(XUPSIEN,.ARRAY)
I '$D(ARRAY) S XUPSREC="-1^No entry" Q
;SEQUENCE 2
N XUPSRCTR
I XUPSSTR["2," D
.S (XUPSSUB1,XUPSSUB2,XUPSSUB3)=""
.S XUPSRCTR=0
.;DUZ
.S XUPSSUB1=XUPSIEN_COMP_COMP_COMP_"USVHA"_SUBCOMP_SUBCOMP_"0363"_COMP_"PN"_COMP
.S XUPSSUB1=XUPSSUB1_"VA FACILITY ID"_SUBCOMP_$P($$SITE^VASITE(),"^",3)_SUBCOMP_"L"_COMP_COMP
.S XUPSRCTR=XUPSRCTR+1
.S XUPSSEG(2,XUPSRCTR)=XUPSSUB1
.;SSN
.S XUPSSUB2=$S(ARRAY("SSN")]"":ARRAY("SSN"),1:HL("Q"))_COMP_COMP_COMP_"USSSA"_SUBCOMP_SUBCOMP_"0363"_COMP_"SS"
.S XUPSSUB2=XUPSSUB2_COMP_"VA FACILITY ID"_SUBCOMP_$P($$SITE^VASITE(),"^",3)_SUBCOMP_"L"
.S XUPSRCTR=XUPSRCTR+1
.S XUPSSEG(2,XUPSRCTR)=XUPSSUB2
.;NPI
.S $P(XUPSSUB3,COMP,1)=$S(ARRAY("NPI")]"":ARRAY("NPI"),1:HL("Q"))_COMP_COMP_COMP_"USVHA"_SUBCOMP_SUBCOMP_"0363"
.S XUPSSUB3=XUPSSUB3_COMP_"NPI"_COMP_"VA FACILITY ID"_SUBCOMP_$P($$SITE^VASITE(),"^",3)_SUBCOMP_"L"
.S XUPSRCTR=XUPSRCTR+1
.S XUPSSEG(2,XUPSRCTR)=XUPSSUB3
.;Pointer to PAID
.S $P(XUPSSUB4,COMP,1)=$S(ARRAY("PAID")]"":ARRAY("PAID"),1:HL("Q"))_COMP_COMP_COMP_"USVHA"_SUBCOMP_SUBCOMP_"0363"
.S XUPSSUB4=XUPSSUB4_COMP_"EI"_COMP_"VA FACILITY ID"_SUBCOMP_$P($$SITE^VASITE(),"^",3)_SUBCOMP_"L"
.S XUPSRCTR=XUPSRCTR+1
.S XUPSSEG(2,XUPSRCTR)=XUPSSUB4
;NAME
I XUPSSTR["3," D ;get name data
.;patient name last^first^middle^suffix^prefix^^"L" for legal
.S XUPSSEG(3)=$S(ARRAY("Surname")'="":ARRAY("Surname"),1:HL("Q"))_COMP_$S($G(ARRAY("FirstName"))'="":$G(ARRAY("FirstName")),1:HL("Q"))_COMP
.S XUPSSEG(3)=XUPSSEG(3)_$S($G(ARRAY("MiddleName"))'="":$G(ARRAY("MiddleName")),1:HL("Q"))_COMP_$S($G(ARRAY("Suffix"))'="":$G(ARRAY("Suffix")),1:HL("Q"))_COMP
.S XUPSSEG(3)=XUPSSEG(3)_$S($G(ARRAY("Prefix"))'="":$G(ARRAY("Prefix")),1:HL("Q"))_COMP_COMP_"L"
;SEX
I XUPSSTR["5," D ;get sex
.S XUPSSEG(5)=$S($G(ARRAY("Gender"))'="":$G(ARRAY("Gender")),1:HL("Q"))
;DOB
I XUPSSTR["6," D ;get dob
.S XUPSSEG(6)=$S($G(ARRAY("DOB"))'="":$$HLDATE^HLFNC($G(ARRAY("DOB"))),1:HL("Q"))
;Home Phone #
I XUPSSTR[",10" D
.I $G(ARRAY("ResPhone"))]"" S XUPSPH=$$HLPHONE^HLFNC($G(ARRAY("ResPhone"))) D HL7TXT(.XUPSPH,.HL,HLES) ;convert HL characters
.I $G(ARRAY("ResPhone"))="" S XUPSPH=HL("Q")
.;PRN for Home Phone Number.
.S $P(XUPSPH,COMP,2)="PRN",$P(XUPSPH,COMP,3)="PH"
.S XUPSSEG(10)=XUPSPH
;Address
I XUPSSTR[",11" D
.N XUPSA,HL7STRG
.S HL7STRG=$G(ARRAY("ResAddL1"))
.I HL7STRG'="" D HL7TXT(.HL7STRG,.HL,HLES)
.S $P(TADDR,COMP)=$S($G(HL7STRG)'="":HL7STRG,1:HL("Q"))
.S HL7STRG=$G(ARRAY("ResAddL2")) D HL7TXT(.HL7STRG,.HL,HLES)
.S $P(TADDR,COMP,2)=$S($G(HL7STRG)'="":HL7STRG,1:HL("Q"))
.S HL7STRG=$G(ARRAY("ResAddCity")) D HL7TXT(.HL7STRG,.HL,HLES)
.S $P(TADDR,COMP,3)=$S($G(HL7STRG)'="":HL7STRG,1:HL("Q"))
.S $P(TADDR,COMP,4)=$S($G(ARRAY("ResAddState"))'="":$G(ARRAY("ResAddState")),1:HL("Q"))
.S $P(TADDR,COMP,5)=$S($G(ARRAY("ResAddZip4"))'="":ARRAY("ResAddZip4"),1:HL("Q"))
.S HL7STRG=$G(ARRAY("ResAddL3")) D HL7TXT(.HL7STRG,.HL,HLES)
.S $P(TADDR,COMP,8)=$S($G(HL7STRG)'="":HL7STRG,1:HL("Q"))
.;Country set to null - not used by PSIM
.S $P(TADDR,COMP,6)=""
.;Address type set to P for permanent
.S $P(TADDR,COMP,7)="P"
.S XUPSSEG(11)=TADDR
;
D MAKEIT^XUPSHL7B("STF",.XUPSSEG,.XUPSREC,.XUPSSTF)
Q
;
HL7TXT(HL7STRG,HL,HLES) ; Replace occurrences of embedded HL7 delimiters with
; HL7 escape sequence
;
; Inputs: HL7STRG - Data string to be checked
; HL("ECH") - HL7 delimiter string
; Delimiters MUST be in the following order,
; Escape, Field, Component, Repeat, Subcomponent
; Example: \^~|&
;
; Output: HL7XTRG - Data string with escape sequence added (if needed)
;
N OCHR,RCHR,RCHRI,TYPE,I,HLES2
;
I $G(HL("COMP"))="" S HL("COMP")=$E(HL("ECH"),1),HL("REP")=$E(HL("ECH"),2),HL("SUBCOMP")=$E(HL("ECH"),4)
; Set HL7 escape char
S HLES2=HLES_HL("FS")_HL("COMP")_HL("REP")_HL("SUBCOMP")
;
; Search for occurrence of each delimiter and replace it with "\<type>\"
F TYPE="E","F","C","R","S" D
. S RCHRI=$S(TYPE="E":1,TYPE="F":2,TYPE="C":3,TYPE="R":4,TYPE="S":5)
. ;
. ; OCHR=original char, RCHR=replacement char
. S OCHR=$E(HLES2,RCHRI),RCHR=$E("EFSRT",RCHRI) Q:'$F(HL7STRG,OCHR)
. F I=1:1 Q:$E(HL7STRG,I)="" I $E(HL7STRG,I)=OCHR S HL7STRG=$E(HL7STRG,1,I-1)_HLES_RCHR_HLES_$E(HL7STRG,I+1,999),I=I+2
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HXUPSSTF 5190 printed Jan 18, 2025@03:12:58 Page 2
XUPSSTF ;ALB/CMC - Build STF segment;Aug, 6 2010
+1 ;;8.0;KERNEL;**551**;Jul 10, 1995;Build 2
+2 ;
+3 QUIT
EN(XUPSIEN,XUPSSTR,HL,XUPSREC,XUPSSTF) ; -- entry point
+1 ;Input:
+2 ;XUPSIEN - New Person Internal Entry Number
+3 ;XUPSSTR - sequence numbers which should be used (2,3,4,5,6,10,11)
+4 ;HL - HL array variables from INIT call
+5 ;Output:
+6 ;XUPSREC - First 245 characters
+7 ;XUPSSTF(1..n)=continuation nodes if results > 245 characters
+8 ;
+9 NEW XUPSSUB1,XUPSSUB2,XUPSSUB3,XUPSSUB4,XUPSSSN,XUPSDOB,XUPSPH
+10 NEW XUPSNO,XUPSSEX,XUPSNAMC,XUPSNAME,XUPSNAM1,XUPSREP,XUPSVID,XUPSCAT,XUPSNPI,TADDR
+11 NEW DA,DIE,DR,XUPSNAM2,XUPSVER,XUPSADD,XUPSADDR,XUPSADD1,XUPSADD2,XUPSI,XUPSSEG,HLFS,COMP,SUBCOMP
+12 ;
+13 IF '$DATA(HL)
SET XUPSREC="-1^missing HL variables"
QUIT
+14 SET HLFS=HL("FS")
SET COMP=$EXTRACT(HL("ECH"))
SET HLES=$EXTRACT(HL("ECH"),2)
SET SUBCOMP=$EXTRACT(HL("ECH"),4)
+15 NEW ARRAY,TMP
+16 SET TMP=$$GET^XUPSGS(XUPSIEN,.ARRAY)
+17 IF '$DATA(ARRAY)
SET XUPSREC="-1^No entry"
QUIT
+18 ;SEQUENCE 2
+19 NEW XUPSRCTR
+20 IF XUPSSTR["2,"
Begin DoDot:1
+21 SET (XUPSSUB1,XUPSSUB2,XUPSSUB3)=""
+22 SET XUPSRCTR=0
+23 ;DUZ
+24 SET XUPSSUB1=XUPSIEN_COMP_COMP_COMP_"USVHA"_SUBCOMP_SUBCOMP_"0363"_COMP_"PN"_COMP
+25 SET XUPSSUB1=XUPSSUB1_"VA FACILITY ID"_SUBCOMP_$PIECE($$SITE^VASITE(),"^",3)_SUBCOMP_"L"_COMP_COMP
+26 SET XUPSRCTR=XUPSRCTR+1
+27 SET XUPSSEG(2,XUPSRCTR)=XUPSSUB1
+28 ;SSN
+29 SET XUPSSUB2=$SELECT(ARRAY("SSN")]"":ARRAY("SSN"),1:HL("Q"))_COMP_COMP_COMP_"USSSA"_SUBCOMP_SUBCOMP_"0363"_COMP_"SS"
+30 SET XUPSSUB2=XUPSSUB2_COMP_"VA FACILITY ID"_SUBCOMP_$PIECE($$SITE^VASITE(),"^",3)_SUBCOMP_"L"
+31 SET XUPSRCTR=XUPSRCTR+1
+32 SET XUPSSEG(2,XUPSRCTR)=XUPSSUB2
+33 ;NPI
+34 SET $PIECE(XUPSSUB3,COMP,1)=$SELECT(ARRAY("NPI")]"":ARRAY("NPI"),1:HL("Q"))_COMP_COMP_COMP_"USVHA"_SUBCOMP_SUBCOMP_"0363"
+35 SET XUPSSUB3=XUPSSUB3_COMP_"NPI"_COMP_"VA FACILITY ID"_SUBCOMP_$PIECE($$SITE^VASITE(),"^",3)_SUBCOMP_"L"
+36 SET XUPSRCTR=XUPSRCTR+1
+37 SET XUPSSEG(2,XUPSRCTR)=XUPSSUB3
+38 ;Pointer to PAID
+39 SET $PIECE(XUPSSUB4,COMP,1)=$SELECT(ARRAY("PAID")]"":ARRAY("PAID"),1:HL("Q"))_COMP_COMP_COMP_"USVHA"_SUBCOMP_SUBCOMP_"0363"
+40 SET XUPSSUB4=XUPSSUB4_COMP_"EI"_COMP_"VA FACILITY ID"_SUBCOMP_$PIECE($$SITE^VASITE(),"^",3)_SUBCOMP_"L"
+41 SET XUPSRCTR=XUPSRCTR+1
+42 SET XUPSSEG(2,XUPSRCTR)=XUPSSUB4
End DoDot:1
+43 ;NAME
+44 ;get name data
IF XUPSSTR["3,"
Begin DoDot:1
+45 ;patient name last^first^middle^suffix^prefix^^"L" for legal
+46 SET XUPSSEG(3)=$SELECT(ARRAY("Surname")'="":ARRAY("Surname"),1:HL("Q"))_COMP_$SELECT($GET(ARRAY("FirstName"))'="":$GET(ARRAY("FirstName")),1:HL("Q"))_COMP
+47 SET XUPSSEG(3)=XUPSSEG(3)_$SELECT($GET(ARRAY("MiddleName"))'="":$GET(ARRAY("MiddleName")),1:HL("Q"))_COMP_$SELECT($GET(ARRAY("Suffix"))'="":$GET(ARRAY("Suffix")),1:HL("Q"))_COMP
+48 SET XUPSSEG(3)=XUPSSEG(3)_$SELECT($GET(ARRAY("Prefix"))'="":$GET(ARRAY("Prefix")),1:HL("Q"))_COMP_COMP_"L"
End DoDot:1
+49 ;SEX
+50 ;get sex
IF XUPSSTR["5,"
Begin DoDot:1
+51 SET XUPSSEG(5)=$SELECT($GET(ARRAY("Gender"))'="":$GET(ARRAY("Gender")),1:HL("Q"))
End DoDot:1
+52 ;DOB
+53 ;get dob
IF XUPSSTR["6,"
Begin DoDot:1
+54 SET XUPSSEG(6)=$SELECT($GET(ARRAY("DOB"))'="":$$HLDATE^HLFNC($GET(ARRAY("DOB"))),1:HL("Q"))
End DoDot:1
+55 ;Home Phone #
+56 IF XUPSSTR[",10"
Begin DoDot:1
+57 ;convert HL characters
IF $GET(ARRAY("ResPhone"))]""
SET XUPSPH=$$HLPHONE^HLFNC($GET(ARRAY("ResPhone")))
DO HL7TXT(.XUPSPH,.HL,HLES)
+58 IF $GET(ARRAY("ResPhone"))=""
SET XUPSPH=HL("Q")
+59 ;PRN for Home Phone Number.
+60 SET $PIECE(XUPSPH,COMP,2)="PRN"
SET $PIECE(XUPSPH,COMP,3)="PH"
+61 SET XUPSSEG(10)=XUPSPH
End DoDot:1
+62 ;Address
+63 IF XUPSSTR[",11"
Begin DoDot:1
+64 NEW XUPSA,HL7STRG
+65 SET HL7STRG=$GET(ARRAY("ResAddL1"))
+66 IF HL7STRG'=""
DO HL7TXT(.HL7STRG,.HL,HLES)
+67 SET $PIECE(TADDR,COMP)=$SELECT($GET(HL7STRG)'="":HL7STRG,1:HL("Q"))
+68 SET HL7STRG=$GET(ARRAY("ResAddL2"))
DO HL7TXT(.HL7STRG,.HL,HLES)
+69 SET $PIECE(TADDR,COMP,2)=$SELECT($GET(HL7STRG)'="":HL7STRG,1:HL("Q"))
+70 SET HL7STRG=$GET(ARRAY("ResAddCity"))
DO HL7TXT(.HL7STRG,.HL,HLES)
+71 SET $PIECE(TADDR,COMP,3)=$SELECT($GET(HL7STRG)'="":HL7STRG,1:HL("Q"))
+72 SET $PIECE(TADDR,COMP,4)=$SELECT($GET(ARRAY("ResAddState"))'="":$GET(ARRAY("ResAddState")),1:HL("Q"))
+73 SET $PIECE(TADDR,COMP,5)=$SELECT($GET(ARRAY("ResAddZip4"))'="":ARRAY("ResAddZip4"),1:HL("Q"))
+74 SET HL7STRG=$GET(ARRAY("ResAddL3"))
DO HL7TXT(.HL7STRG,.HL,HLES)
+75 SET $PIECE(TADDR,COMP,8)=$SELECT($GET(HL7STRG)'="":HL7STRG,1:HL("Q"))
+76 ;Country set to null - not used by PSIM
+77 SET $PIECE(TADDR,COMP,6)=""
+78 ;Address type set to P for permanent
+79 SET $PIECE(TADDR,COMP,7)="P"
+80 SET XUPSSEG(11)=TADDR
End DoDot:1
+81 ;
+82 DO MAKEIT^XUPSHL7B("STF",.XUPSSEG,.XUPSREC,.XUPSSTF)
+83 QUIT
+84 ;
HL7TXT(HL7STRG,HL,HLES) ; Replace occurrences of embedded HL7 delimiters with
+1 ; HL7 escape sequence
+2 ;
+3 ; Inputs: HL7STRG - Data string to be checked
+4 ; HL("ECH") - HL7 delimiter string
+5 ; Delimiters MUST be in the following order,
+6 ; Escape, Field, Component, Repeat, Subcomponent
+7 ; Example: \^~|&
+8 ;
+9 ; Output: HL7XTRG - Data string with escape sequence added (if needed)
+10 ;
+11 NEW OCHR,RCHR,RCHRI,TYPE,I,HLES2
+12 ;
+13 IF $GET(HL("COMP"))=""
SET HL("COMP")=$EXTRACT(HL("ECH"),1)
SET HL("REP")=$EXTRACT(HL("ECH"),2)
SET HL("SUBCOMP")=$EXTRACT(HL("ECH"),4)
+14 ; Set HL7 escape char
+15 SET HLES2=HLES_HL("FS")_HL("COMP")_HL("REP")_HL("SUBCOMP")
+16 ;
+17 ; Search for occurrence of each delimiter and replace it with "\<type>\"
+18 FOR TYPE="E","F","C","R","S"
Begin DoDot:1
+19 SET RCHRI=$SELECT(TYPE="E":1,TYPE="F":2,TYPE="C":3,TYPE="R":4,TYPE="S":5)
+20 ;
+21 ; OCHR=original char, RCHR=replacement char
+22 SET OCHR=$EXTRACT(HLES2,RCHRI)
SET RCHR=$EXTRACT("EFSRT",RCHRI)
if '$FIND(HL7STRG,OCHR)
QUIT
+23 FOR I=1:1
if $EXTRACT(HL7STRG,I)=""
QUIT
IF $EXTRACT(HL7STRG,I)=OCHR
SET HL7STRG=$EXTRACT(HL7STRG,1,I-1)_HLES_RCHR_HLES_$EXTRACT(HL7STRG,I+1,999)
SET I=I+2
End DoDot:1
+24 QUIT
