- 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 Feb 19, 2025@00:29:42 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 ;