VAFHLPI2 ;ALB/BWF - EXTENSION OF PID SEGMENT BUILDER ;23-APR-2003
;;5.3;Registration;**508,938**;Aug 13, 1993;Build 2
;
Q
;
SEQ11(TYPE,HLQ) ;Patient Address (seq #11)
;
;Input : TYPE - Qualifiers denoting which type of address to return
; P = Include permanent address
; C = Include confidential address
; "" = Only return permanent address (default)
; HLQ - HL7 null designation
;Assumed: VAPA() - Output of call to ADD^VADPT
;Output : None - sets nodes in array VAFY
; VAFY(11,1,1..X) = Primary address
; VAFY(11,2..X,1..X) = Confidential Address
;Notes : Validity and existance of input is assumed
; : Assumes no individual component is greater than 245
; characters long
; : If TYPE = "", line 3 of the permanent address will be added
; to the end of line 2 (instead of being returned separately)
;
;Declare variables
N NODE
K VAFY(11)
I '$D(HLQ) S HLQ=$C(34,34)
S TYPE=$G(TYPE)
I (TYPE'["P"),(TYPE'["C") S TYPE=""
S NODE=1
I TYPE="" D PERMADD
I (TYPE["P") D PERMADD
I (TYPE["C") D CONFADD
Q
;
PERMADD ; Put permanent address into output array
N X
S VAFY(11,NODE,1)=$S(VAPA(1)'="":VAPA(1),1:HLQ)
S VAFY(11,NODE,2)=$S(VAPA(2)'="":VAPA(2),1:HLQ)
I TYPE'["P" S X=VAPA(2)_" "_VAPA(3),VAFY(11,NODE,2)=$S(X'=" ":X,1:HLQ)
S VAFY(11,NODE,3)=$S(VAPA(4)'="":VAPA(4),1:HLQ)
S X=$P($G(^DIC(5,+VAPA(5),0)),"^",2) ;state
I X="",'+VAPA(5) S X=$G(VAPA(23)) ;P938 get province
S VAFY(11,NODE,4)=$S(X'="":X,1:HLQ)
;S VAFY(11,NODE,5)=$S($P(VAPA(6),U,1)'="":$P(VAPA(6),U,1),1:HLQ) ;P938 replaced with 3 following lines
S X=$P(VAPA(6),U,1) ;P938
I X="",$G(VAPA(24))]"" S X=VAPA(24) ;p938 foreign postal code
S VAFY(11,NODE,5)=$S(X'="":X,1:HLQ) ;P938
I TYPE["P" D
.;S VAFY(11,NODE,6)="" ;P938 replaced with line below
.S VAFY(11,NODE,6)=$S(+$G(VAPA(25))>1:$P(VAPA(25),U,2),1:"") ;P938 country
.S VAFY(11,NODE,7)="P"
.S VAFY(11,NODE,8)=$S(VAPA(3)'="":VAPA(3),1:HLQ)
.S X=$P($G(^DIC(5,+VAPA(5),1,+VAPA(7),0)),"^",3)
.S VAFY(11,NODE,9)=$S(X'="":X,1:HLQ)
S NODE=NODE+1
Q
CONFADD ;Put confidential address into output array
N LOOP,ADDTYPE,CSTATE,CCOUNTY,CSTDATE,CENDATE
S CSTATE=$P($G(^DIC(5,+VAPA(17),0)),"^",2)
S CCOUNTY=$P($G(^DIC(5,+VAPA(17),1,+VAPA(19),0)),"^",3)
S CSTDATE=$$HLDATE^HLFNC($P(VAPA(20),"^",1))
S CENDATE=$$HLDATE^HLFNC($P(VAPA(21),"^",1))
F ADDTYPE=1:1:5 D
.I +VAPA(12) I $P($G(VAPA(22,ADDTYPE)),"^",3)="Y" D CONFACT Q
.D CONFIN
Q
CONFACT ;Active confidential address type
S VAFY(11,NODE,1)=$S(VAPA(13)'="":VAPA(13),1:HLQ)
S VAFY(11,NODE,2)=$S(VAPA(14)'="":VAPA(14),1:HLQ)
S VAFY(11,NODE,3)=$S(VAPA(16)'="":VAPA(16),1:HLQ)
S VAFY(11,NODE,4)=$S(CSTATE'="":CSTATE,1:HLQ)
S X=$P(VAPA(18),"^",1),VAFY(11,NODE,5)=$S(X'="":X,1:HLQ)
S VAFY(11,NODE,6)=""
S VAFY(11,NODE,7)=$S(ADDTYPE=1:"VACAE",ADDTYPE=2:"VACAA",ADDTYPE=3:"VACAC",ADDTYPE=4:"VACAM",ADDTYPE=5:"VACAO",1:HLQ)
S VAFY(11,NODE,8)=$S(VAPA(15)'="":VAPA(15),1:HLQ)
S VAFY(11,NODE,9)=$S(CCOUNTY'="":CCOUNTY,1:HLQ)
S VAFY(11,NODE,10)=""
S VAFY(11,NODE,11)=""
S VAFY(11,NODE,12,1)=$S(CSTDATE'="":CSTDATE,1:HLQ)
S VAFY(11,NODE,12,2)=$S(CENDATE'="":CENDATE,1:HLQ)
S NODE=NODE+1
Q
CONFIN ;Inactive confidential address type
N X
F X=1,2,3,4,5,8,9 S VAFY(11,NODE,X)=HLQ
F X=6,10,11 S VAFY(11,NODE,X)=""
S VAFY(11,NODE,7)=$S(ADDTYPE=1:"VACAE",ADDTYPE=2:"VACAA",ADDTYPE=3:"VACAC",ADDTYPE=4:"VACAM",ADDTYPE=5:"VACAO",1:HLQ)
S VAFY(11,NODE,12,1)=HLQ
S VAFY(11,NODE,12,2)=HLQ
S NODE=NODE+1
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HVAFHLPI2 3600 printed Oct 16, 2024@19:03:38 Page 2
VAFHLPI2 ;ALB/BWF - EXTENSION OF PID SEGMENT BUILDER ;23-APR-2003
+1 ;;5.3;Registration;**508,938**;Aug 13, 1993;Build 2
+2 ;
+3 QUIT
+4 ;
SEQ11(TYPE,HLQ) ;Patient Address (seq #11)
+1 ;
+2 ;Input : TYPE - Qualifiers denoting which type of address to return
+3 ; P = Include permanent address
+4 ; C = Include confidential address
+5 ; "" = Only return permanent address (default)
+6 ; HLQ - HL7 null designation
+7 ;Assumed: VAPA() - Output of call to ADD^VADPT
+8 ;Output : None - sets nodes in array VAFY
+9 ; VAFY(11,1,1..X) = Primary address
+10 ; VAFY(11,2..X,1..X) = Confidential Address
+11 ;Notes : Validity and existance of input is assumed
+12 ; : Assumes no individual component is greater than 245
+13 ; characters long
+14 ; : If TYPE = "", line 3 of the permanent address will be added
+15 ; to the end of line 2 (instead of being returned separately)
+16 ;
+17 ;Declare variables
+18 NEW NODE
+19 KILL VAFY(11)
+20 IF '$DATA(HLQ)
SET HLQ=$CHAR(34,34)
+21 SET TYPE=$GET(TYPE)
+22 IF (TYPE'["P")
IF (TYPE'["C")
SET TYPE=""
+23 SET NODE=1
+24 IF TYPE=""
DO PERMADD
+25 IF (TYPE["P")
DO PERMADD
+26 IF (TYPE["C")
DO CONFADD
+27 QUIT
+28 ;
PERMADD ; Put permanent address into output array
+1 NEW X
+2 SET VAFY(11,NODE,1)=$SELECT(VAPA(1)'="":VAPA(1),1:HLQ)
+3 SET VAFY(11,NODE,2)=$SELECT(VAPA(2)'="":VAPA(2),1:HLQ)
+4 IF TYPE'["P"
SET X=VAPA(2)_" "_VAPA(3)
SET VAFY(11,NODE,2)=$SELECT(X'=" ":X,1:HLQ)
+5 SET VAFY(11,NODE,3)=$SELECT(VAPA(4)'="":VAPA(4),1:HLQ)
+6 ;state
SET X=$PIECE($GET(^DIC(5,+VAPA(5),0)),"^",2)
+7 ;P938 get province
IF X=""
IF '+VAPA(5)
SET X=$GET(VAPA(23))
+8 SET VAFY(11,NODE,4)=$SELECT(X'="":X,1:HLQ)
+9 ;S VAFY(11,NODE,5)=$S($P(VAPA(6),U,1)'="":$P(VAPA(6),U,1),1:HLQ) ;P938 replaced with 3 following lines
+10 ;P938
SET X=$PIECE(VAPA(6),U,1)
+11 ;p938 foreign postal code
IF X=""
IF $GET(VAPA(24))]""
SET X=VAPA(24)
+12 ;P938
SET VAFY(11,NODE,5)=$SELECT(X'="":X,1:HLQ)
+13 IF TYPE["P"
Begin DoDot:1
+14 ;S VAFY(11,NODE,6)="" ;P938 replaced with line below
+15 ;P938 country
SET VAFY(11,NODE,6)=$SELECT(+$GET(VAPA(25))>1:$PIECE(VAPA(25),U,2),1:"")
+16 SET VAFY(11,NODE,7)="P"
+17 SET VAFY(11,NODE,8)=$SELECT(VAPA(3)'="":VAPA(3),1:HLQ)
+18 SET X=$PIECE($GET(^DIC(5,+VAPA(5),1,+VAPA(7),0)),"^",3)
+19 SET VAFY(11,NODE,9)=$SELECT(X'="":X,1:HLQ)
End DoDot:1
+20 SET NODE=NODE+1
+21 QUIT
CONFADD ;Put confidential address into output array
+1 NEW LOOP,ADDTYPE,CSTATE,CCOUNTY,CSTDATE,CENDATE
+2 SET CSTATE=$PIECE($GET(^DIC(5,+VAPA(17),0)),"^",2)
+3 SET CCOUNTY=$PIECE($GET(^DIC(5,+VAPA(17),1,+VAPA(19),0)),"^",3)
+4 SET CSTDATE=$$HLDATE^HLFNC($PIECE(VAPA(20),"^",1))
+5 SET CENDATE=$$HLDATE^HLFNC($PIECE(VAPA(21),"^",1))
+6 FOR ADDTYPE=1:1:5
Begin DoDot:1
+7 IF +VAPA(12)
IF $PIECE($GET(VAPA(22,ADDTYPE)),"^",3)="Y"
DO CONFACT
QUIT
+8 DO CONFIN
End DoDot:1
+9 QUIT
CONFACT ;Active confidential address type
+1 SET VAFY(11,NODE,1)=$SELECT(VAPA(13)'="":VAPA(13),1:HLQ)
+2 SET VAFY(11,NODE,2)=$SELECT(VAPA(14)'="":VAPA(14),1:HLQ)
+3 SET VAFY(11,NODE,3)=$SELECT(VAPA(16)'="":VAPA(16),1:HLQ)
+4 SET VAFY(11,NODE,4)=$SELECT(CSTATE'="":CSTATE,1:HLQ)
+5 SET X=$PIECE(VAPA(18),"^",1)
SET VAFY(11,NODE,5)=$SELECT(X'="":X,1:HLQ)
+6 SET VAFY(11,NODE,6)=""
+7 SET VAFY(11,NODE,7)=$SELECT(ADDTYPE=1:"VACAE",ADDTYPE=2:"VACAA",ADDTYPE=3:"VACAC",ADDTYPE=4:"VACAM",ADDTYPE=5:"VACAO",1:HLQ)
+8 SET VAFY(11,NODE,8)=$SELECT(VAPA(15)'="":VAPA(15),1:HLQ)
+9 SET VAFY(11,NODE,9)=$SELECT(CCOUNTY'="":CCOUNTY,1:HLQ)
+10 SET VAFY(11,NODE,10)=""
+11 SET VAFY(11,NODE,11)=""
+12 SET VAFY(11,NODE,12,1)=$SELECT(CSTDATE'="":CSTDATE,1:HLQ)
+13 SET VAFY(11,NODE,12,2)=$SELECT(CENDATE'="":CENDATE,1:HLQ)
+14 SET NODE=NODE+1
+15 QUIT
CONFIN ;Inactive confidential address type
+1 NEW X
+2 FOR X=1,2,3,4,5,8,9
SET VAFY(11,NODE,X)=HLQ
+3 FOR X=6,10,11
SET VAFY(11,NODE,X)=""
+4 SET VAFY(11,NODE,7)=$SELECT(ADDTYPE=1:"VACAE",ADDTYPE=2:"VACAA",ADDTYPE=3:"VACAC",ADDTYPE=4:"VACAM",ADDTYPE=5:"VACAO",1:HLQ)
+5 SET VAFY(11,NODE,12,1)=HLQ
+6 SET VAFY(11,NODE,12,2)=HLQ
+7 SET NODE=NODE+1
+8 QUIT
