VAFHLZTA ;ALB/ESD,TDM,KUM - Creation of ZTA segment ;7/18/24 4:29PM
;;5.3;Registration;**68,653,688,806,1121**;Aug 13, 1993;Build 14
;Per VHA Directive 2004-038, this routine should not be modified.
;
; This generic extrinsic function returns the HL7 VA-Specific Temporary Address (ZTA) segment.
;
;
EN(DFN,VAFSTR,VAFNUM,HL) ; Returns HL7 ZTA segment containing temporary address
; data.
;
; Input - DFN as internal entry number of the PATIENT file
; VAFSTR as string of fields requested separated by commas.
; VAFNUM as SetId - set to 1.
; HL *** NOT USED, WILL BE REMOVED AT A LATER TIME ***
;
; Output - string of components forming the ZTA segment.
;
N VAFNODE,VAFY,X,X1
N COMP,HLES,VAFNODE1,HL7STRG,SQ5,CNTRY
I '$G(DFN)!($G(VAFSTR)']"") G QUIT
I $G(HLFS)="" N HLFS S HLFS="^"
I $G(HL("FS"))="" S HL("FS")=HLFS
I $G(HLQ)="" N HLQ S HLQ=""""""
I $G(HLECH)="" N HLECH S HLECH="~|\&"
I $G(HL("ECH"))="" S HL("ECH")=HLECH
S COMP=$E(HLECH,1),HLES=$E(HLECH,3)
S VAFNODE=$G(^DPT(DFN,.121)),VAFNODE1=$G(^DPT(DFN,.122))
S $P(VAFY,HLFS,9)="",VAFSTR=","_VAFSTR_","
S $P(VAFY,HLFS,1)=1 ; SetId equal to 1
I VAFSTR[",2," S X=$P(VAFNODE,"^",9),$P(VAFY,HLFS,2)=$$YN^VAFHLFNC(X) ; Temporary Address Enter/Edit?
I VAFSTR[",3," S X=$$HLDATE^HLFNC($P(VAFNODE,"^",7)),$P(VAFY,HLFS,3)=$S(X]"":X,1:HLQ) ; Temporary Address Start Date
I VAFSTR[",4," S X=$$HLDATE^HLFNC($P(VAFNODE,"^",8)),$P(VAFY,HLFS,4)=$S(X]"":X,1:HLQ) ; Temporary Address End Date
I VAFSTR[",5," D
. K HL7STRG S HL7STRG=$P(VAFNODE,"^",1) D HL7TXT^VAFCQRY1(.HL7STRG,.HL,HLES) S SQ5=$S(HL7STRG="":HLQ,1:HL7STRG)
. K HL7STRG S HL7STRG=$P(VAFNODE,"^",2) D HL7TXT^VAFCQRY1(.HL7STRG,.HL,HLES) S $P(SQ5,COMP,2)=$S(HL7STRG="":HLQ,1:HL7STRG)
. K HL7STRG S HL7STRG=$P(VAFNODE,"^",3) D HL7TXT^VAFCQRY1(.HL7STRG,.HL,HLES) S $P(SQ5,COMP,8)=$S(HL7STRG="":HLQ,1:HL7STRG)
. S CNTRY=$$GET1^DIQ(2,DFN_",",.1223) ;RETURN EXTERNAL VALUE
. I CNTRY="US" S CNTRY="USA"
. K HL7STRG S HL7STRG=$P(VAFNODE,"^",4),$P(SQ5,COMP,3)=$S(HL7STRG="":HLQ,1:HL7STRG)
. I CNTRY=""!(CNTRY="USA") D ;have USA address
. . S X=$$GET1^DIQ(5,+$P(VAFNODE,"^",5)_",",1),$P(SQ5,COMP,4)=$S(X="":HLQ,1:X)
. . S X=$P(VAFNODE,"^",12),$P(SQ5,COMP,5)=$S(X="":HLQ,1:X)
. I CNTRY'="",(CNTRY'="USA") D ;Check for foreign address fields
. . S X=$P(VAFNODE1,"^",1),$P(SQ5,COMP,4)=$S(X="":HLQ,1:X)
. . S X=$P(VAFNODE1,"^",2),$P(SQ5,COMP,5)=$S(X="":HLQ,1:X)
. S $P(SQ5,COMP,6)=$S(CNTRY="":HLQ,1:CNTRY)
. S X=$$GET1^DIQ(2,DFN_",",.12111),$P(SQ5,COMP,9)=$S(X="":HLQ,1:X)
. S $P(VAFY,HLFS,5)=SQ5
I VAFSTR[",6," S X=$$GET1^DIQ(2,DFN_",",.12111),$P(VAFY,HLFS,6)=$S(X="":HLQ,1:X)
I VAFSTR[",7," S X=$$HLPHONE^HLFNC($P(VAFNODE,"^",10)),$P(VAFY,HLFS,7)=$S(X]"":X,1:HLQ) ; Temporary Address Phone
I VAFSTR[",8," S X=$$HLDATE^HLFNC($P(VAFNODE,"^",13)),$P(VAFY,HLFS,8)=$S(X]"":X,1:HLQ) ; Temp Addr Last Updated
I VAFSTR[",9," D ; Temp Addr Site of Change
. S X=$P(VAFNODE,"^",14),X=$$GET1^DIQ(4,(+X)_",",99)
. S $P(VAFY,HLFS,9)=$S(X]"":X,1:HLQ)
;DG*5.3*1121 - Accommodate country code, area code, phone number and extension in Sequence number 10
I VAFSTR[",10," D
. S X=$P(VAFNODE,"^",10)
. I X]"" D
. . N DGINTPH,DGEXT,DGEXT2,DGCNTRY,DGAREA,DGPH
. . S X=$TR(X,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
. . S COMP="~" S DGEXT="" S DGEXT2="" S DGAREA="" S DGPH=""
. . S DGEXT=$P(X,"X",2)
. . S DGEXT=$$CONVPHAN^VAFCQRY3(DGEXT)
. . S DGEXT2=$$GET1^DIQ(2,DFN_",",.12117)
. . S DGEXT2=$$CONVPHAN^VAFCQRY3(DGEXT2)
. . I DGEXT2'="" S DGEXT=DGEXT2
. . S DGEXT=$E(DGEXT,1,6)
. . S DGCNTRY=$$GET1^DIQ(2,DFN_",",.12116,"I")
. . S DGCNTRY=$$CONVPHAN^VAFCQRY3(DGCNTRY)
. . I $G(DGCNTRY)="" S DGCNTRY=1
. . S DGPH=$P(X,"X",1)
. . S DGPH=$$CONVPHAN^VAFCQRY3(DGPH)
. . S DGAREA=$E(DGPH,1,3)
. . S DGPH=$E(DGPH,4,10)
. . I DGPH="" S DGEXT="" S DGCNTRY="" S DGAREA=""
. . S DGINTPH=DGCNTRY_COMP_DGAREA_COMP_DGPH_COMP_DGEXT
. . S $P(VAFY,HLFS,10)=$S(DGINTPH]"":DGINTPH,1:HLQ)
QUIT Q "ZTA"_HLFS_$G(VAFY)
;
NUM(DGNUMBER,DGDIGIT,DGDEC) ; DG*5.3*1121 - Added new function NUM to determine if valid numeric value
;
; Input: DGNUMBER as data element to evaluate
; DGDIGIT as number of digits allowed
; DGDEC as number of decimal places
;
N DGERROR
S DGERROR=0
I DGNUMBER'?.N.1".".2N S DGERROR=1 G NUMQ
I $L($P(DGNUMBER,".",1))>DGDIGIT S DGERROR=1 G NUMQ
I DGNUMBER<0 S DGERROR=1
NUMQ Q DGERROR
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HVAFHLZTA 4517 printed May 22, 2025@00:22:23 Page 2
VAFHLZTA ;ALB/ESD,TDM,KUM - Creation of ZTA segment ;7/18/24 4:29PM
+1 ;;5.3;Registration;**68,653,688,806,1121**;Aug 13, 1993;Build 14
+2 ;Per VHA Directive 2004-038, this routine should not be modified.
+3 ;
+4 ; This generic extrinsic function returns the HL7 VA-Specific Temporary Address (ZTA) segment.
+5 ;
+6 ;
EN(DFN,VAFSTR,VAFNUM,HL) ; Returns HL7 ZTA segment containing temporary address
+1 ; data.
+2 ;
+3 ; Input - DFN as internal entry number of the PATIENT file
+4 ; VAFSTR as string of fields requested separated by commas.
+5 ; VAFNUM as SetId - set to 1.
+6 ; HL *** NOT USED, WILL BE REMOVED AT A LATER TIME ***
+7 ;
+8 ; Output - string of components forming the ZTA segment.
+9 ;
+10 NEW VAFNODE,VAFY,X,X1
+11 NEW COMP,HLES,VAFNODE1,HL7STRG,SQ5,CNTRY
+12 IF '$GET(DFN)!($GET(VAFSTR)']"")
GOTO QUIT
+13 IF $GET(HLFS)=""
NEW HLFS
SET HLFS="^"
+14 IF $GET(HL("FS"))=""
SET HL("FS")=HLFS
+15 IF $GET(HLQ)=""
NEW HLQ
SET HLQ=""""""
+16 IF $GET(HLECH)=""
NEW HLECH
SET HLECH="~|\&"
+17 IF $GET(HL("ECH"))=""
SET HL("ECH")=HLECH
+18 SET COMP=$EXTRACT(HLECH,1)
SET HLES=$EXTRACT(HLECH,3)
+19 SET VAFNODE=$GET(^DPT(DFN,.121))
SET VAFNODE1=$GET(^DPT(DFN,.122))
+20 SET $PIECE(VAFY,HLFS,9)=""
SET VAFSTR=","_VAFSTR_","
+21 ; SetId equal to 1
SET $PIECE(VAFY,HLFS,1)=1
+22 ; Temporary Address Enter/Edit?
IF VAFSTR[",2,"
SET X=$PIECE(VAFNODE,"^",9)
SET $PIECE(VAFY,HLFS,2)=$$YN^VAFHLFNC(X)
+23 ; Temporary Address Start Date
IF VAFSTR[",3,"
SET X=$$HLDATE^HLFNC($PIECE(VAFNODE,"^",7))
SET $PIECE(VAFY,HLFS,3)=$SELECT(X]"":X,1:HLQ)
+24 ; Temporary Address End Date
IF VAFSTR[",4,"
SET X=$$HLDATE^HLFNC($PIECE(VAFNODE,"^",8))
SET $PIECE(VAFY,HLFS,4)=$SELECT(X]"":X,1:HLQ)
+25 IF VAFSTR[",5,"
Begin DoDot:1
+26 KILL HL7STRG
SET HL7STRG=$PIECE(VAFNODE,"^",1)
DO HL7TXT^VAFCQRY1(.HL7STRG,.HL,HLES)
SET SQ5=$SELECT(HL7STRG="":HLQ,1:HL7STRG)
+27 KILL HL7STRG
SET HL7STRG=$PIECE(VAFNODE,"^",2)
DO HL7TXT^VAFCQRY1(.HL7STRG,.HL,HLES)
SET $PIECE(SQ5,COMP,2)=$SELECT(HL7STRG="":HLQ,1:HL7STRG)
+28 KILL HL7STRG
SET HL7STRG=$PIECE(VAFNODE,"^",3)
DO HL7TXT^VAFCQRY1(.HL7STRG,.HL,HLES)
SET $PIECE(SQ5,COMP,8)=$SELECT(HL7STRG="":HLQ,1:HL7STRG)
+29 ;RETURN EXTERNAL VALUE
SET CNTRY=$$GET1^DIQ(2,DFN_",",.1223)
+30 IF CNTRY="US"
SET CNTRY="USA"
+31 KILL HL7STRG
SET HL7STRG=$PIECE(VAFNODE,"^",4)
SET $PIECE(SQ5,COMP,3)=$SELECT(HL7STRG="":HLQ,1:HL7STRG)
+32 ;have USA address
IF CNTRY=""!(CNTRY="USA")
Begin DoDot:2
+33 SET X=$$GET1^DIQ(5,+$PIECE(VAFNODE,"^",5)_",",1)
SET $PIECE(SQ5,COMP,4)=$SELECT(X="":HLQ,1:X)
+34 SET X=$PIECE(VAFNODE,"^",12)
SET $PIECE(SQ5,COMP,5)=$SELECT(X="":HLQ,1:X)
End DoDot:2
+35 ;Check for foreign address fields
IF CNTRY'=""
IF (CNTRY'="USA")
Begin DoDot:2
+36 SET X=$PIECE(VAFNODE1,"^",1)
SET $PIECE(SQ5,COMP,4)=$SELECT(X="":HLQ,1:X)
+37 SET X=$PIECE(VAFNODE1,"^",2)
SET $PIECE(SQ5,COMP,5)=$SELECT(X="":HLQ,1:X)
End DoDot:2
+38 SET $PIECE(SQ5,COMP,6)=$SELECT(CNTRY="":HLQ,1:CNTRY)
+39 SET X=$$GET1^DIQ(2,DFN_",",.12111)
SET $PIECE(SQ5,COMP,9)=$SELECT(X="":HLQ,1:X)
+40 SET $PIECE(VAFY,HLFS,5)=SQ5
End DoDot:1
+41 IF VAFSTR[",6,"
SET X=$$GET1^DIQ(2,DFN_",",.12111)
SET $PIECE(VAFY,HLFS,6)=$SELECT(X="":HLQ,1:X)
+42 ; Temporary Address Phone
IF VAFSTR[",7,"
SET X=$$HLPHONE^HLFNC($PIECE(VAFNODE,"^",10))
SET $PIECE(VAFY,HLFS,7)=$SELECT(X]"":X,1:HLQ)
+43 ; Temp Addr Last Updated
IF VAFSTR[",8,"
SET X=$$HLDATE^HLFNC($PIECE(VAFNODE,"^",13))
SET $PIECE(VAFY,HLFS,8)=$SELECT(X]"":X,1:HLQ)
+44 ; Temp Addr Site of Change
IF VAFSTR[",9,"
Begin DoDot:1
+45 SET X=$PIECE(VAFNODE,"^",14)
SET X=$$GET1^DIQ(4,(+X)_",",99)
+46 SET $PIECE(VAFY,HLFS,9)=$SELECT(X]"":X,1:HLQ)
End DoDot:1
+47 ;DG*5.3*1121 - Accommodate country code, area code, phone number and extension in Sequence number 10
+48 IF VAFSTR[",10,"
Begin DoDot:1
+49 SET X=$PIECE(VAFNODE,"^",10)
+50 IF X]""
Begin DoDot:2
+51 NEW DGINTPH,DGEXT,DGEXT2,DGCNTRY,DGAREA,DGPH
+52 SET X=$TRANSLATE(X,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
+53 SET COMP="~"
SET DGEXT=""
SET DGEXT2=""
SET DGAREA=""
SET DGPH=""
+54 SET DGEXT=$PIECE(X,"X",2)
+55 SET DGEXT=$$CONVPHAN^VAFCQRY3(DGEXT)
+56 SET DGEXT2=$$GET1^DIQ(2,DFN_",",.12117)
+57 SET DGEXT2=$$CONVPHAN^VAFCQRY3(DGEXT2)
+58 IF DGEXT2'=""
SET DGEXT=DGEXT2
+59 SET DGEXT=$EXTRACT(DGEXT,1,6)
+60 SET DGCNTRY=$$GET1^DIQ(2,DFN_",",.12116,"I")
+61 SET DGCNTRY=$$CONVPHAN^VAFCQRY3(DGCNTRY)
+62 IF $GET(DGCNTRY)=""
SET DGCNTRY=1
+63 SET DGPH=$PIECE(X,"X",1)
+64 SET DGPH=$$CONVPHAN^VAFCQRY3(DGPH)
+65 SET DGAREA=$EXTRACT(DGPH,1,3)
+66 SET DGPH=$EXTRACT(DGPH,4,10)
+67 IF DGPH=""
SET DGEXT=""
SET DGCNTRY=""
SET DGAREA=""
+68 SET DGINTPH=DGCNTRY_COMP_DGAREA_COMP_DGPH_COMP_DGEXT
+69 SET $PIECE(VAFY,HLFS,10)=$SELECT(DGINTPH]"":DGINTPH,1:HLQ)
End DoDot:2
End DoDot:1
QUIT QUIT "ZTA"_HLFS_$GET(VAFY)
+1 ;
NUM(DGNUMBER,DGDIGIT,DGDEC) ; DG*5.3*1121 - Added new function NUM to determine if valid numeric value
+1 ;
+2 ; Input: DGNUMBER as data element to evaluate
+3 ; DGDIGIT as number of digits allowed
+4 ; DGDEC as number of decimal places
+5 ;
+6 NEW DGERROR
+7 SET DGERROR=0
+8 IF DGNUMBER'?.N.1".".2N
SET DGERROR=1
GOTO NUMQ
+9 IF $LENGTH($PIECE(DGNUMBER,".",1))>DGDIGIT
SET DGERROR=1
GOTO NUMQ
+10 IF DGNUMBER<0
SET DGERROR=1
NUMQ QUIT DGERROR
+1 ;
