VAFCQRY4 ;BIR/CMC-CONT TO BLD PID 2.4 SEGMENT ;1/23/06
;;5.3;Registration;**707,1015**;Aug 13, 1993;Build 21
;
CONT(DFN,APID,PID,HL,HLES,SARY,SEQ,ERROR,REP,COMP) ; continue to bld pid segment
N X,LVL,LVL2,PDOD,NXT,LNGTH
D DEM^VADPT
I $D(SARY(10))!(SEQ="ALL") D
.N RACE,IEN
.;**575 ADDING RACE FROM THE NEW RACE INFORMATION MULTIPLE
.I VADM(12)>0 D
..S RACE="",IEN=0
..D SEQ10^VAFHLPI1("N",HL("Q"))
..F S IEN=$O(VAFY(10,IEN)) Q:IEN="" D
...I IEN>1 S RACE=RACE_REP
...S RACE=RACE_VAFY(10,IEN,1)_COMP_VAFY(10,IEN,2)_COMP_VAFY(10,IEN,3)_COMP_$P(VAFY(10,IEN,1),"-",1,2)_COMP_COMP_"CDC"
.I VADM(12)=0 S RACE=HL("Q")
.K VAFY(10)
.S APID(11)=RACE
I $D(SARY(22))!(SEQ="ALL") D
.;**575 ADDING ETHNICITY FROM THE NEW ETHNICITY INFORMATION MULTIPLE
.I $G(VADM(11))'=0 D
..D SEQ22^VAFHLPI1("N",HL("Q"))
..S APID(23)=VAFY(22,1,1)_COMP_VAFY(22,1,2)_COMP_VAFY(22,1,3)_COMP_$P(VAFY(22,1,1),"-",1,2)_COMP_COMP_"CDC"
.I $G(VADM(11))=0 S APID(23)=HL("Q") ;ethnic group
.K VAFY(22)
I $D(SARY(16))!(SEQ="ALL") D
.S APID(17)="" I +VADM(10)>0 S X=$P($G(^DIC(11,+VADM(10),0)),"^",3),APID(17)=$S(X="S":"A",X="N":"S",X="U":"",X="":HL("Q"),1:X) ;marital status (DHCP N=HL7 S, DHCP S=HL7 A, U="") ;**477 **575
.I APID(17)="" S APID(17)=HL("Q")
I $D(SARY(17))!(SEQ="ALL") D
.S APID(18)="" I +VADM(9)>0 S APID(18)=$P($G(^DIC(13,+VADM(9),0)),"^",4) I APID(18)="" S APID(18)=29 ;religious pref (if blank send 29 (UNKNOWN))
.I APID(18)="" S APID(18)=HL("Q")
I $D(SARY(29))!(SEQ="ALL") D
.S APID(30)="" I $D(^DPT(DFN,.35)) S PDOD=$P(^DPT(DFN,.35),"^") S APID(30)=$$HLDATE^HLFNC(PDOD) ;date of death
.I APID(30)="" S APID(30)=HL("Q")
I $D(SARY(24))!(SEQ="ALL") S APID(25)=$P($G(^DPT(DFN,"MPIMB")),"^") ;**575 multiple birth indicator
;list of fields not currently used or supported (# is 1 more than seq)
I $D(SARY(4))!(SEQ="ALL") S APID(5)="" ;Alternate Patient Identifier
I $D(SARY(9))!(SEQ="ALL") S APID(10)="" ;patient alias
I $D(SARY(15))!(SEQ="ALL") S APID(16)="" ;primary language
I $D(SARY(18))!(SEQ="ALL") S APID(19)="" ;patient account #
I $D(SARY(20))!(SEQ="ALL") S APID(21)="" ;drivers lic #
I $D(SARY(21))!(SEQ="ALL") S APID(22)="" ;mother's id
I $D(SARY(25))!(SEQ="ALL") S APID(26)=""
I $D(SARY(26))!(SEQ="ALL") S APID(27)=""
I $D(SARY(27))!(SEQ="ALL") S APID(28)=""
I $D(SARY(28))!(SEQ="ALL") S APID(29)=""
I $D(SARY(30))!(SEQ="ALL") S APID(31)=""
S PID(1)="PID"_HL("FS")
S LVL=1,X=1 F S X=$O(APID(X)) Q:'X D
.S PID(LVL)=$G(PID(LVL))
.S NXT=APID(X) D
..I '$O(APID(X,0)) S NXT=NXT_HL("FS")
..I $L($G(PID(LVL))_NXT)>245 D
... S LNGTH=245-$L(PID(LVL)),PID(LVL)=PID(LVL)_$E(NXT,1,LNGTH)
... S LNGTH=LNGTH+1,NXT=$E(NXT,LNGTH,$L(NXT)),LVL=LVL+1
..I $L($G(PID(LVL))_NXT)'>245 S PID(LVL)=$G(PID(LVL))_NXT
.S LVL2=0 F S LVL2=$O(APID(X,LVL2)) Q:'LVL2 D
..S NXT=APID(X,LVL2) D
...I $L($G(PID(LVL))_NXT)>245 S LNGTH=245-$L(PID(LVL)),PID(LVL)=PID(LVL)_$E(NXT,1,LNGTH) S LNGTH=LNGTH+1,NXT=$E(NXT,LNGTH,$L(NXT)),LVL=LVL+1
...I $L($G(PID(LVL))_NXT)'>245 S PID(LVL)=$G(PID(LVL))_NXT
...I '$O(APID(X,LVL2)) S PID(LVL)=PID(LVL)_HL("FS")
K VADM
Q
VAFCQRY4 ;BIR/CMC-CONT TO BLD PID 2.4 SEGMENT ;1/23/06
+1 ;;5.3;Registration;**707,1015**;Aug 13, 1993;Build 21
+2 ;
CONT(DFN,APID,PID,HL,HLES,SARY,SEQ,ERROR,REP,COMP) ; continue to bld pid segment
+1 NEW X,LVL,LVL2,PDOD,NXT,LNGTH
+2 DO DEM^VADPT
+3 IF $DATA(SARY(10))!(SEQ="ALL")
Begin DoDot:1
+4 NEW RACE,IEN
+5 ;**575 ADDING RACE FROM THE NEW RACE INFORMATION MULTIPLE
+6 IF VADM(12)>0
Begin DoDot:2
+7 SET RACE=""
SET IEN=0
+8 DO SEQ10^VAFHLPI1("N",HL("Q"))
+9 FOR
SET IEN=$ORDER(VAFY(10,IEN))
IF IEN=""
QUIT
Begin DoDot:3
+10 IF IEN>1
SET RACE=RACE_REP
+11 SET RACE=RACE_VAFY(10,IEN,1)_COMP_VAFY(10,IEN,2)_COMP_VAFY(10,IEN,3)_COMP_$PIECE(VAFY(10,IEN,1),"-",1,2)_COMP_COMP_"CDC"
End DoDot:3
End DoDot:2
+12 IF VADM(12)=0
SET RACE=HL("Q")
+13 KILL VAFY(10)
+14 SET APID(11)=RACE
End DoDot:1
+15 IF $DATA(SARY(22))!(SEQ="ALL")
Begin DoDot:1
+16 ;**575 ADDING ETHNICITY FROM THE NEW ETHNICITY INFORMATION MULTIPLE
+17 IF $GET(VADM(11))'=0
Begin DoDot:2
+18 DO SEQ22^VAFHLPI1("N",HL("Q"))
+19 SET APID(23)=VAFY(22,1,1)_COMP_VAFY(22,1,2)_COMP_VAFY(22,1,3)_COMP_$PIECE(VAFY(22,1,1),"-",1,2)_COMP_COMP_"CDC"
End DoDot:2
+20 ;ethnic group
IF $GET(VADM(11))=0
SET APID(23)=HL("Q")
+21 KILL VAFY(22)
End DoDot:1
+22 IF $DATA(SARY(16))!(SEQ="ALL")
Begin DoDot:1
+23 ;marital status (DHCP N=HL7 S, DHCP S=HL7 A, U="") ;**477 **575
SET APID(17)=""
IF +VADM(10)>0
SET X=$PIECE($GET(^DIC(11,+VADM(10),0)),"^",3)
SET APID(17)=$SELECT(X="S":"A",X="N":"S",X="U":"",X="":HL("Q"),1:X)
+24 IF APID(17)=""
SET APID(17)=HL("Q")
End DoDot:1
+25 IF $DATA(SARY(17))!(SEQ="ALL")
Begin DoDot:1
+26 ;religious pref (if blank send 29 (UNKNOWN))
SET APID(18)=""
IF +VADM(9)>0
SET APID(18)=$PIECE($GET(^DIC(13,+VADM(9),0)),"^",4)
IF APID(18)=""
SET APID(18)=29
+27 IF APID(18)=""
SET APID(18)=HL("Q")
End DoDot:1
+28 IF $DATA(SARY(29))!(SEQ="ALL")
Begin DoDot:1
+29 ;date of death
SET APID(30)=""
IF $DATA(^DPT(DFN,.35))
SET PDOD=$PIECE(^DPT(DFN,.35),"^")
SET APID(30)=$$HLDATE^HLFNC(PDOD)
+30 IF APID(30)=""
SET APID(30)=HL("Q")
End DoDot:1
+31 ;**575 multiple birth indicator
IF $DATA(SARY(24))!(SEQ="ALL")
SET APID(25)=$PIECE($GET(^DPT(DFN,"MPIMB")),"^")
+32 ;list of fields not currently used or supported (# is 1 more than seq)
+33 ;Alternate Patient Identifier
IF $DATA(SARY(4))!(SEQ="ALL")
SET APID(5)=""
+34 ;patient alias
IF $DATA(SARY(9))!(SEQ="ALL")
SET APID(10)=""
+35 ;primary language
IF $DATA(SARY(15))!(SEQ="ALL")
SET APID(16)=""
+36 ;patient account #
IF $DATA(SARY(18))!(SEQ="ALL")
SET APID(19)=""
+37 ;drivers lic #
IF $DATA(SARY(20))!(SEQ="ALL")
SET APID(21)=""
+38 ;mother's id
IF $DATA(SARY(21))!(SEQ="ALL")
SET APID(22)=""
+39 IF $DATA(SARY(25))!(SEQ="ALL")
SET APID(26)=""
+40 IF $DATA(SARY(26))!(SEQ="ALL")
SET APID(27)=""
+41 IF $DATA(SARY(27))!(SEQ="ALL")
SET APID(28)=""
+42 IF $DATA(SARY(28))!(SEQ="ALL")
SET APID(29)=""
+43 IF $DATA(SARY(30))!(SEQ="ALL")
SET APID(31)=""
+44 SET PID(1)="PID"_HL("FS")
+45 SET LVL=1
SET X=1
FOR
SET X=$ORDER(APID(X))
IF 'X
QUIT
Begin DoDot:1
+46 SET PID(LVL)=$GET(PID(LVL))
+47 SET NXT=APID(X)
Begin DoDot:2
+48 IF '$ORDER(APID(X,0))
SET NXT=NXT_HL("FS")
+49 IF $LENGTH($GET(PID(LVL))_NXT)>245
Begin DoDot:3
+50 SET LNGTH=245-$LENGTH(PID(LVL))
SET PID(LVL)=PID(LVL)_$EXTRACT(NXT,1,LNGTH)
+51 SET LNGTH=LNGTH+1
SET NXT=$EXTRACT(NXT,LNGTH,$LENGTH(NXT))
SET LVL=LVL+1
End DoDot:3
+52 IF $LENGTH($GET(PID(LVL))_NXT)'>245
SET PID(LVL)=$GET(PID(LVL))_NXT
End DoDot:2
+53 SET LVL2=0
FOR
SET LVL2=$ORDER(APID(X,LVL2))
IF 'LVL2
QUIT
Begin DoDot:2
+54 SET NXT=APID(X,LVL2)
Begin DoDot:3
+55 IF $LENGTH($GET(PID(LVL))_NXT)>245
SET LNGTH=245-$LENGTH(PID(LVL))
SET PID(LVL)=PID(LVL)_$EXTRACT(NXT,1,LNGTH)
SET LNGTH=LNGTH+1
SET NXT=$EXTRACT(NXT,LNGTH,$LENGTH(NXT))
SET LVL=LVL+1
+56 IF $LENGTH($GET(PID(LVL))_NXT)'>245
SET PID(LVL)=$GET(PID(LVL))_NXT
+57 IF '$ORDER(APID(X,LVL2))
SET PID(LVL)=PID(LVL)_HL("FS")
End DoDot:3
End DoDot:2
End DoDot:1
+58 KILL VADM
+59 QUIT
