source: WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/VAFCQRY4.m@ 1742

Last change on this file since 1742 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR

File size: 3.0 KB
Line 
1VAFCQRY4 ;BIR/CMC-CONT TO BLD PID 2.4 SEGMENT ;1/23/06
2 ;;5.3;Registration;**707**;Aug 13, 1993;Build 14
3 ;
4CONT(DFN,APID,PID,HL,HLES,SARY,SEQ,ERROR,REP,COMP) ; continue to bld pid segment
5 N X,LVL,LVL2,PDOD,NXT,LNGTH
6 D DEM^VADPT
7 I $D(SARY(10))!(SEQ="ALL") D
8 .N RACE,IEN
9 .;**575 ADDING RACE FROM THE NEW RACE INFORMATION MULTIPLE
10 .I VADM(12)>0 D
11 ..S RACE="",IEN=0
12 ..D SEQ10^VAFHLPI1("N",HL("Q"))
13 ..F S IEN=$O(VAFY(10,IEN)) Q:IEN="" D
14 ...I IEN>1 S RACE=RACE_REP
15 ...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"
16 .I VADM(12)=0 S RACE=HL("Q")
17 .K VAFY(10)
18 .S APID(11)=RACE
19 I $D(SARY(22))!(SEQ="ALL") D
20 .;**575 ADDING ETHNICITY FROM THE NEW ETHNICITY INFORMATION MULTIPLE
21 .I $G(VADM(11))'=0 D
22 ..D SEQ22^VAFHLPI1("N",HL("Q"))
23 ..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"
24 .I $G(VADM(11))=0 S APID(23)=HL("Q") ;ethnic group
25 .K VAFY(22)
26 I $D(SARY(16))!(SEQ="ALL") D
27 .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
28 .I APID(17)="" S APID(17)=HL("Q")
29 I $D(SARY(17))!(SEQ="ALL") D
30 .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))
31 .I APID(18)="" S APID(18)=HL("Q")
32 I $D(SARY(29))!(SEQ="ALL") D
33 .S APID(30)="" I $D(^DPT(DFN,.35)) S PDOD=$P(^DPT(DFN,.35),"^") S APID(30)=$$HLDATE^HLFNC(PDOD) ;date of death
34 .I APID(30)="" S APID(30)=HL("Q")
35 I $D(SARY(24))!(SEQ="ALL") S APID(25)=$P($G(^DPT(DFN,"MPIMB")),"^") ;**575 multiple birth indicator
36 ;list of fields not currently used or supported (# is 1 more than seq)
37 I $D(SARY(4))!(SEQ="ALL") S APID(5)="" ;Alternate Patient Identifier
38 I $D(SARY(9))!(SEQ="ALL") S APID(10)="" ;patient alias
39 I $D(SARY(15))!(SEQ="ALL") S APID(16)="" ;primary language
40 I $D(SARY(18))!(SEQ="ALL") S APID(19)="" ;patient account #
41 I $D(SARY(20))!(SEQ="ALL") S APID(21)="" ;drivers lic #
42 I $D(SARY(21))!(SEQ="ALL") S APID(22)="" ;mother's id
43 I $D(SARY(25))!(SEQ="ALL") S APID(26)=""
44 I $D(SARY(26))!(SEQ="ALL") S APID(27)=""
45 I $D(SARY(27))!(SEQ="ALL") S APID(28)=""
46 I $D(SARY(28))!(SEQ="ALL") S APID(29)=""
47 I $D(SARY(30))!(SEQ="ALL") S APID(31)=""
48 S PID(1)="PID"_HL("FS")
49 S LVL=1,X=1 F S X=$O(APID(X)) Q:'X D
50 .S PID(LVL)=$G(PID(LVL))
51 .S NXT=APID(X) D
52 ..I '$O(APID(X,0)) S NXT=NXT_HL("FS")
53 ..I $L($G(PID(LVL))_NXT)>245 D
54 ... S LNGTH=245-$L(PID(LVL)),PID(LVL)=PID(LVL)_$E(NXT,1,LNGTH)
55 ... S LNGTH=LNGTH+1,NXT=$E(NXT,LNGTH,$L(NXT)),LVL=LVL+1
56 ..I $L($G(PID(LVL))_NXT)'>245 S PID(LVL)=$G(PID(LVL))_NXT
57 .S LVL2=0 F S LVL2=$O(APID(X,LVL2)) Q:'LVL2 D
58 ..S NXT=APID(X,LVL2) D
59 ...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
60 ...I $L($G(PID(LVL))_NXT)'>245 S PID(LVL)=$G(PID(LVL))_NXT
61 ...I '$O(APID(X,LVL2)) S PID(LVL)=PID(LVL)_HL("FS")
62 K VADM
63 Q
Note: See TracBrowser for help on using the repository browser.