PSOTPHL2 ;BPFO/EL-Query for patient demographics (ORIG: VAFCQRY1) ;09/10/2003 15:00
;;7.0;OUTPATIENT PHARMACY;**146**;DEC 1997
;
;Reference to $$GETDFNS^MPIF002 supported by IA #3634.
;
BLDPID(DFN,CNT,PID,HL,ERR) ;build PID from File #2
N VAFCMN,VAFCMMN,SITE,VAFCZN,SSN,SITE,APID,PDOD,HIST,HISTDT,VAFCHMN,LVL,LVL1,NXT,LNGTH,NXTC,COMP,REP,SUBCOMP,LVL2,X,STATE,CITY,CLAIM,HLECH,HLFS,HLQ,X,STATEIEN
S HLECH=HL("ECH"),HLFS=HL("FS"),HLQ=HL("Q")
S COMP=$E(HL("ECH"),1)
S SUBCOMP=$E(HL("ECH"),4)
S REP=$E(HL("ECH"),2)
;get Patient File MPI node
S VAFCMN=$$MPINODE^MPIFAPI(DFN)
I +VAFCMN<0 S VAFCMN=""
S VAFCZN=^DPT(DFN,0)
S SSN=$P(^DPT(DFN,0),"^",9)
S SITE=$$SITE^VASITE
S APID(2)=CNT
;repeat patient ID list including ICN (NI),SSN (SS),CLAIM# (PN) AND DFN (PI)
S APID(4)=""
;National Identifier (ICN)
I $G(VAFCMN)>0,($E($P(VAFCMN,"^"),1,3)'=$P($$SITE^VASITE,"^",3)) D
. S APID(4)=$P(VAFCMN,"^")_"V"_$P(VAFCMN,"^",2)_COMP_COMP_COMP_"USVHA"_SUBCOMP_SUBCOMP_"HL70363"_COMP_"NI"_COMP_"VA FACILITY ID"_SUBCOMP_$$STA^XUAF4(+SITE)_SUBCOMP_"L"
I $G(SSN)'="" S APID(4)=APID(4)_$S(APID(4)'="":REP,1:"")_SSN_COMP_COMP_COMP_"USSSA"_SUBCOMP_SUBCOMP_"HL70363"_COMP_"SS"_COMP_"VA FACILITY ID"_SUBCOMP_$$STA^XUAF4(+SITE)_SUBCOMP_"L"
I $G(DFN)'="" S APID(4)=APID(4)_$S(APID(4)'="":REP,1:"")_DFN_COMP_COMP_COMP_"USVHA"_SUBCOMP_SUBCOMP_"HL70363"_COMP_"PI"_COMP_"VA FACILITY ID"_SUBCOMP_$$STA^XUAF4(+SITE)_SUBCOMP_"L" D
.;CLAIM#
.I $D(^DPT(DFN,.31)) S CLAIM=$P(^DPT(DFN,.31),"^",3) I +CLAIM>0 S APID(4)=APID(4)_REP_CLAIM_COMP_COMP_COMP_"USVBA"_SUBCOMP_SUBCOMP_"HL70363"_COMP_"PN"_COMP_"VA FACILITY ID"_SUBCOMP_$$STA^XUAF4(+SITE)_SUBCOMP_"L"
;
;patient name (last^first^middle^suffix^prefix^^"L" for legal)
S APID(6)=$$HLNAME^XLFNAME($P(VAFCZN,"^"),"",$E(HL("ECH"),1)) I $P(APID(6),$E(HL("ECH"),1),7)'="L" S $P(APID(6),$E(HL("ECH"),1),7)="L"
;mother's maiden name (last^first^middle^suffix^prefix^^"M" for maiden name)
S APID(7)=HL("Q")
I $D(^DPT(DFN,.24)) S VAFCMMN=$P(^DPT(DFN,.24),"^",3) D
. S APID(7)=$$HLNAME^XLFNAME(VAFCMMN,"",$E(HL("ECH"),1)) I APID(7)="" S APID(7)=HL("Q")
. I $P(APID(7),$E(HL("ECH"),1),7)'="M" S $P(APID(7),$E(HL("ECH"),1),7)="M"
S APID(8)=$$HLDATE^HLFNC($P(VAFCZN,"^",3)) ;date/time of birth
S APID(9)=$P(VAFCZN,"^",2) ;sex
;place of birth city and state
ADDR S APID(12)="" D
. I $D(^DPT(DFN,0)) D
.. ;address info
.. S $P(APID(12),COMP)=$$GET1^DIQ(2,DFN_",",.111) I $P(APID(12),COMP)="" S $P(APID(12),COMP)=HL("Q")
.. N LINE2 S LINE2=$$GET1^DIQ(2,DFN_",",.112) N LINE3 S LINE3=$$GET1^DIQ(2,DFN_",",.113)
.. S $P(APID(12),COMP,2)=LINE2 I $P(APID(12),COMP,2)="" S $P(APID(12),COMP,2)=HL("Q")
.. S $P(APID(12),COMP,8)=LINE3 I $P(APID(12),COMP,8)="" S $P(APID(12),COMP,8)=HL("Q")
.. S $P(APID(12),COMP,3)=$$GET1^DIQ(2,DFN_",",.114) I $P(APID(12),COMP,3)="" S $P(APID(12),COMP,3)=HL("Q")
.. S STATEIEN=$$GET1^DIQ(2,DFN_",",.115,"I") S STATE=$$GET1^DIQ(5,+STATEIEN_",",1) S $P(APID(12),COMP,4)=$G(STATE) I $P(APID(12),COMP,4)="" S $P(APID(12),COMP,4)=HL("Q")
.. S $P(APID(12),COMP,5)=$$GET1^DIQ(2,DFN_",",.1112) I $P(APID(12),COMP,5)="" S $P(APID(12),COMP,5)=HL("Q")
.. S $P(APID(12),COMP,7)="P"
.. ;place of birth information
.. S CITY=$$GET1^DIQ(2,DFN_",",.092) D
... I $G(CITY)'="" S $P(X,COMP,3)=CITY
... I $G(CITY)="" S $P(X,COMP,3)=HL("Q")
... S STATEIEN=$$GET1^DIQ(2,DFN_",",.093,"I") S STATE=$$GET1^DIQ(5,+STATEIEN_",",1) D
.... I $G(STATE)'="" S $P(X,COMP,4)=STATE
.... I $G(STATE)="" S $P(X,COMP,4)=HL("Q")
... S $P(X,COMP,7)="N"
... S APID(12)=$G(APID(12))_REP_X
S APID(13)=$$GET1^DIQ(2,DFN_",",.117) I APID(13)="" S APID(13)=HL("Q") ;county code
N PHONEN,HNUM,WNUM S PHONEN=$G(^DPT(DFN,.13)) S HNUM=$P(PHONEN,"^",1),WNUM=$P(PHONEN,"^",2)
S APID(14)=$$HLPHONE^HLFNC(HNUM)
S APID(15)=$$HLPHONE^HLFNC(WNUM)
D DEM^VADPT
S APID(17)="" I +VADM(10)>0 S X=$P($G(^DIC(11,+VADM(10),0)),"^",3),APID(17)=$S(X="N":"S",X="U":"",X="":HLQ,1:X) ;marital status (DHCP N=HL7 S, U="") ;**477
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))
S APID(30)="" I $D(^DPT(DFN,.35)) S PDOD=$P(^DPT(DFN,.35),"^") S APID(30)=$$HLDATE^HLFNC(PDOD) ;date of death
N X F X=6,7,8,9,13,14,15,17,18,30 I APID(X)="" S APID(X)=HL("Q")
;list of fields used for backwards compatibility with HDR
S APID(20)=SSN ;ssn passed in PID-3
S APID(24)=CITY_" "_STATE ;place of birth (not used) use PID-11 with an 'N' instead
;list of fields not currently used or supported (# is 1 more than seq)
S APID(3)="" ;Patient ID
S APID(5)="" ;Alternate Patient Identifier
S APID(10)="" ;patient alias
S APID(11)="" ;race
S APID(16)="" ;primary language
S APID(19)="" ;patient account #
S APID(21)="" ;drivers lic #
S APID(22)="" ;mother's id
S APID(23)="" ;ethnic group
S APID(25)=""
S APID(26)=""
S APID(27)=""
S APID(28)=""
S APID(29)=""
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 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")
D KVA^VADPT
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSOTPHL2 5710 printed Sep 23, 2025@20:12:21 Page 2
PSOTPHL2 ;BPFO/EL-Query for patient demographics (ORIG: VAFCQRY1) ;09/10/2003 15:00
+1 ;;7.0;OUTPATIENT PHARMACY;**146**;DEC 1997
+2 ;
+3 ;Reference to $$GETDFNS^MPIF002 supported by IA #3634.
+4 ;
BLDPID(DFN,CNT,PID,HL,ERR) ;build PID from File #2
+1 NEW VAFCMN,VAFCMMN,SITE,VAFCZN,SSN,SITE,APID,PDOD,HIST,HISTDT,VAFCHMN,LVL,LVL1,NXT,LNGTH,NXTC,COMP,REP,SUBCOMP,LVL2,X,STATE,CITY,CLAIM,HLECH,HLFS,HLQ,X,STATEIEN
+2 SET HLECH=HL("ECH")
SET HLFS=HL("FS")
SET HLQ=HL("Q")
+3 SET COMP=$EXTRACT(HL("ECH"),1)
+4 SET SUBCOMP=$EXTRACT(HL("ECH"),4)
+5 SET REP=$EXTRACT(HL("ECH"),2)
+6 ;get Patient File MPI node
+7 SET VAFCMN=$$MPINODE^MPIFAPI(DFN)
+8 IF +VAFCMN<0
SET VAFCMN=""
+9 SET VAFCZN=^DPT(DFN,0)
+10 SET SSN=$PIECE(^DPT(DFN,0),"^",9)
+11 SET SITE=$$SITE^VASITE
+12 SET APID(2)=CNT
+13 ;repeat patient ID list including ICN (NI),SSN (SS),CLAIM# (PN) AND DFN (PI)
+14 SET APID(4)=""
+15 ;National Identifier (ICN)
+16 IF $GET(VAFCMN)>0
IF ($EXTRACT($PIECE(VAFCMN,"^"),1,3)'=$PIECE($$SITE^VASITE,"^",3))
Begin DoDot:1
+17 SET APID(4)=$PIECE(VAFCMN,"^")_"V"_$PIECE(VAFCMN,"^",2)_COMP_COMP_COMP_"USVHA"_SUBCOMP_SUBCOMP_"HL70363"_COMP_"NI"_COMP_"VA FACILITY ID"_SUBCOMP_$$STA^XUAF4(+SITE)_SUBCOMP_"L"
End DoDot:1
+18 IF $GET(SSN)'=""
SET APID(4)=APID(4)_$SELECT(APID(4)'="":REP,1:"")_SSN_COMP_COMP_COMP_"USSSA"_SUBCOMP_SUBCOMP_"HL70363"_COMP_"SS"_COMP_"VA FACILITY ID"_SUBCOMP_$$STA^XUAF4(+SITE)_SUBCOMP_"L"
+19 IF $GET(DFN)'=""
SET APID(4)=APID(4)_$SELECT(APID(4)'="":REP,1:"")_DFN_COMP_COMP_COMP_"USVHA"_SUBCOMP_SUBCOMP_"HL70363"_COMP_"PI"_COMP_"VA FACILITY ID"_SUBCOMP_$$STA^XUAF4(+SITE)_SUBCOMP_"L"
Begin DoDot:1
+20 ;CLAIM#
+21 IF $DATA(^DPT(DFN,.31))
SET CLAIM=$PIECE(^DPT(DFN,.31),"^",3)
IF +CLAIM>0
SET APID(4)=APID(4)_REP_CLAIM_COMP_COMP_COMP_"USVBA"_SUBCOMP_SUBCOMP_"HL70363"_COMP_"PN"_COMP_"VA FACILITY ID"_SUBCOMP_$$STA^XUAF4(+SITE)_SUBCOMP_"L"
End DoDot:1
+22 ;
+23 ;patient name (last^first^middle^suffix^prefix^^"L" for legal)
+24 SET APID(6)=$$HLNAME^XLFNAME($PIECE(VAFCZN,"^"),"",$EXTRACT(HL("ECH"),1))
IF $PIECE(APID(6),$EXTRACT(HL("ECH"),1),7)'="L"
SET $PIECE(APID(6),$EXTRACT(HL("ECH"),1),7)="L"
+25 ;mother's maiden name (last^first^middle^suffix^prefix^^"M" for maiden name)
+26 SET APID(7)=HL("Q")
+27 IF $DATA(^DPT(DFN,.24))
SET VAFCMMN=$PIECE(^DPT(DFN,.24),"^",3)
Begin DoDot:1
+28 SET APID(7)=$$HLNAME^XLFNAME(VAFCMMN,"",$EXTRACT(HL("ECH"),1))
IF APID(7)=""
SET APID(7)=HL("Q")
+29 IF $PIECE(APID(7),$EXTRACT(HL("ECH"),1),7)'="M"
SET $PIECE(APID(7),$EXTRACT(HL("ECH"),1),7)="M"
End DoDot:1
+30 ;date/time of birth
SET APID(8)=$$HLDATE^HLFNC($PIECE(VAFCZN,"^",3))
+31 ;sex
SET APID(9)=$PIECE(VAFCZN,"^",2)
+32 ;place of birth city and state
ADDR SET APID(12)=""
Begin DoDot:1
+1 IF $DATA(^DPT(DFN,0))
Begin DoDot:2
+2 ;address info
+3 SET $PIECE(APID(12),COMP)=$$GET1^DIQ(2,DFN_",",.111)
IF $PIECE(APID(12),COMP)=""
SET $PIECE(APID(12),COMP)=HL("Q")
+4 NEW LINE2
SET LINE2=$$GET1^DIQ(2,DFN_",",.112)
NEW LINE3
SET LINE3=$$GET1^DIQ(2,DFN_",",.113)
+5 SET $PIECE(APID(12),COMP,2)=LINE2
IF $PIECE(APID(12),COMP,2)=""
SET $PIECE(APID(12),COMP,2)=HL("Q")
+6 SET $PIECE(APID(12),COMP,8)=LINE3
IF $PIECE(APID(12),COMP,8)=""
SET $PIECE(APID(12),COMP,8)=HL("Q")
+7 SET $PIECE(APID(12),COMP,3)=$$GET1^DIQ(2,DFN_",",.114)
IF $PIECE(APID(12),COMP,3)=""
SET $PIECE(APID(12),COMP,3)=HL("Q")
+8 SET STATEIEN=$$GET1^DIQ(2,DFN_",",.115,"I")
SET STATE=$$GET1^DIQ(5,+STATEIEN_",",1)
SET $PIECE(APID(12),COMP,4)=$GET(STATE)
IF $PIECE(APID(12),COMP,4)=""
SET $PIECE(APID(12),COMP,4)=HL("Q")
+9 SET $PIECE(APID(12),COMP,5)=$$GET1^DIQ(2,DFN_",",.1112)
IF $PIECE(APID(12),COMP,5)=""
SET $PIECE(APID(12),COMP,5)=HL("Q")
+10 SET $PIECE(APID(12),COMP,7)="P"
+11 ;place of birth information
+12 SET CITY=$$GET1^DIQ(2,DFN_",",.092)
Begin DoDot:3
+13 IF $GET(CITY)'=""
SET $PIECE(X,COMP,3)=CITY
+14 IF $GET(CITY)=""
SET $PIECE(X,COMP,3)=HL("Q")
+15 SET STATEIEN=$$GET1^DIQ(2,DFN_",",.093,"I")
SET STATE=$$GET1^DIQ(5,+STATEIEN_",",1)
Begin DoDot:4
+16 IF $GET(STATE)'=""
SET $PIECE(X,COMP,4)=STATE
+17 IF $GET(STATE)=""
SET $PIECE(X,COMP,4)=HL("Q")
End DoDot:4
+18 SET $PIECE(X,COMP,7)="N"
+19 SET APID(12)=$GET(APID(12))_REP_X
End DoDot:3
End DoDot:2
End DoDot:1
+20 ;county code
SET APID(13)=$$GET1^DIQ(2,DFN_",",.117)
IF APID(13)=""
SET APID(13)=HL("Q")
+21 NEW PHONEN,HNUM,WNUM
SET PHONEN=$GET(^DPT(DFN,.13))
SET HNUM=$PIECE(PHONEN,"^",1)
SET WNUM=$PIECE(PHONEN,"^",2)
+22 SET APID(14)=$$HLPHONE^HLFNC(HNUM)
+23 SET APID(15)=$$HLPHONE^HLFNC(WNUM)
+24 DO DEM^VADPT
+25 ;marital status (DHCP N=HL7 S, U="") ;**477
SET APID(17)=""
IF +VADM(10)>0
SET X=$PIECE($GET(^DIC(11,+VADM(10),0)),"^",3)
SET APID(17)=$SELECT(X="N":"S",X="U":"",X="":HLQ,1:X)
+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 ;date of death
SET APID(30)=""
IF $DATA(^DPT(DFN,.35))
SET PDOD=$PIECE(^DPT(DFN,.35),"^")
SET APID(30)=$$HLDATE^HLFNC(PDOD)
+28 NEW X
FOR X=6,7,8,9,13,14,15,17,18,30
IF APID(X)=""
SET APID(X)=HL("Q")
+29 ;list of fields used for backwards compatibility with HDR
+30 ;ssn passed in PID-3
SET APID(20)=SSN
+31 ;place of birth (not used) use PID-11 with an 'N' instead
SET APID(24)=CITY_" "_STATE
+32 ;list of fields not currently used or supported (# is 1 more than seq)
+33 ;Patient ID
SET APID(3)=""
+34 ;Alternate Patient Identifier
SET APID(5)=""
+35 ;patient alias
SET APID(10)=""
+36 ;race
SET APID(11)=""
+37 ;primary language
SET APID(16)=""
+38 ;patient account #
SET APID(19)=""
+39 ;drivers lic #
SET APID(21)=""
+40 ;mother's id
SET APID(22)=""
+41 ;ethnic group
SET APID(23)=""
+42 SET APID(25)=""
+43 SET APID(26)=""
+44 SET APID(27)=""
+45 SET APID(28)=""
+46 SET APID(29)=""
+47 SET APID(31)=""
+48 SET PID(1)="PID"_HL("FS")
+49 SET LVL=1
SET X=1
FOR
SET X=$ORDER(APID(X))
if 'X
QUIT
Begin DoDot:1
+50 SET PID(LVL)=$GET(PID(LVL))
+51 SET NXT=APID(X)
Begin DoDot:2
+52 IF '$ORDER(APID(X,0))
SET NXT=NXT_HL("FS")
+53 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
+54 IF $LENGTH($GET(PID(LVL))_NXT)'>245
SET PID(LVL)=$GET(PID(LVL))_NXT
End DoDot:2
+55 SET LVL2=0
FOR
SET LVL2=$ORDER(APID(X,LVL2))
if 'LVL2
QUIT
Begin DoDot:2
+56 SET NXT=APID(X,LVL2)
Begin DoDot:3
+57 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
+58 IF $LENGTH($GET(PID(LVL))_NXT)'>245
SET PID(LVL)=$GET(PID(LVL))_NXT
+59 IF '$ORDER(APID(X,LVL2))
SET PID(LVL)=PID(LVL)_HL("FS")
End DoDot:3
End DoDot:2
End DoDot:1
+60 DO KVA^VADPT
+61 QUIT
