VAFCPID ;ALB/MLI,PKE-Create generic PID segment ; 21 Nov 2002 3:13 PM
;;5.3;Registration;**91,149,190,415,508,749**;Aug 13, 1993;Build 10
;
; This routine returns the HL7 defined PID segment with its
; mappings to DHCP PATIENT file fields.
;
EN(DFN,VAFSTR,VAFNUM) ; returns PID segment
; Input - DFN as internal entry number of the PATIENT file
; VAFSTR as string of fields requested separated by commas
; VAFNUM as sequential number for SET ID (default=1)
;
; ****Also assumes all HL7 variables returned from****
; INIT^HLTRANS are defined
;
; Output - String containing the desired components of the PID segment
; VAFPID(n) - if the string is longer than 245, the remaining
; characters will be returned in VAFPID(n) where
; n is a sequential number beginning with 1
;
; WARNING: This routine makes external calls to VADPT. Non-namespaced
; variables may be altered.
;
N I,VAFY,VA,VADM,X,X1,Y,OUTPUT,DGNAME,DGMMN,VAPA ; calls VADPT...have to NEW
S VAFSTR=$G(VAFSTR) ; if not defined, just return required fields
S DFN=$G(DFN)
I DFN']"" G QUIT
;Get demographics and permanent address
S VAPA("P")="" D 4^VADPT
S VAFSTR=","_VAFSTR_","
K VAFY
;Set ID (#1)
I VAFSTR[",1," S VAFY(1)=$S($G(VAFNUM):VAFNUM,1:1)
;External ID (#2 - always included)
S X=$$GETICN^MPIF001(DFN) S:(+X=-1) X="" S VAFY(2)=$S(X]"":X,1:HLQ)
;Patient ID (#3 - req)
S VAFY(3)=$$M10^HLFNC(DFN)
;Alternate ID (#4)
I VAFSTR[",4," S X=$G(VA("BID")),VAFY(4)=$S(X]"":X,1:HLQ)
;Name (#5 - req)
S DGNAME("FILE")=2,DGNAME("IENS")=DFN,DGNAME("FIELD")=.01
S X=$$HLNAME^XLFNAME(.DGNAME,"",$E(HLECH)),VAFY(5)=$S(X]"":X,1:HLQ)
;Mother's maiden name (#6)
I VAFSTR[",6," D
.S DGMMN("FILE")=2,DGMMN("IENS")=DFN,DGMMN("FIELD")=.2403
.S X=$$HLNAME^XLFNAME(.DGMMN,"",$E(HLECH)),VAFY(6)=$S(X]"":X,1:HLQ)
;Date of birth (#7)
I VAFSTR[",7," S VAFY(7)=$$HLDATE^HLFNC(+VADM(3))
;Sex (#8)
I VAFSTR[",8," S X=$P(VADM(5),"^",1),VAFY(8)=$S("^M^F^"[("^"_X_"^"):X,1:"U")
;Race (#10)
I VAFSTR[10 D
.N HOW
.S Y=$F(VAFSTR,"10")
.S HOW=$P($E(VAFSTR,Y,$F(VAFSTR,",",Y)),",",1)
.D SEQ10^VAFHLPI1(HOW,HLQ)
;Address (#11)
I VAFSTR[11 D
.N HOW
.S Y=$F(VAFSTR,"11")
.S HOW=$P($E(VAFSTR,Y,$F(VAFSTR,",",Y)),",",1)
.D SEQ11^VAFHLPI2(HOW,HLQ)
;County (#12)
I VAFSTR[12 S X1=$P($G(^DIC(5,+$G(VAPA(5)),1,+$G(VAPA(7)),0)),"^",3),VAFY(12)=$S(X1]"":X1,1:HLQ)
S X=$G(^DPT(DFN,.13))
;Home phone (#13)
I VAFSTR[13 S X1=$$HLPHONE^HLFNC($P(X,"^",1)),VAFY(13)=$S(X1]"":X1,1:HLQ)
;Business phone (#14)
I VAFSTR[14 S X1=$$HLPHONE^HLFNC($P(X,"^",2)),VAFY(14)=$S(X1]"":X1,1:HLQ)
;Marital status (#16)
I VAFSTR[16 S X=$P($G(^DIC(11,+VADM(10),0)),"^",3),VAFY(16)=$S(X="M":"M",X="N":"S",X="S":"A",X]"":X,1:HLQ)
;Religious preference (#17) (if blank send 29 (UNKNOWN))
I VAFSTR[17 S X=$P($G(^DIC(13,+VADM(9),0)),"^",4),VAFY(17)=$S(X]"":X,1:29)
;SSN (#19)
I VAFSTR[19 S X=$P(VADM(2),"^",1),VAFY(19)=$S(X]"":X,1:HLQ)
;Ethnicity (#22)
I VAFSTR[22 D
.N HOW
.S Y=$F(VAFSTR,"22")
.S HOW=$P($E(VAFSTR,Y,$F(VAFSTR,",",Y)),",",1)
.D SEQ22^VAFHLPI1(HOW,HLQ)
;Birth place (#23)
I VAFSTR[23 D
.N DGBC,DGBS
.S DGBC=$$GET1^DIQ(2,DFN,.092,"I")
.S DGBS=$$GET1^DIQ(2,DFN,.093,"E")
.S VAFY(23)=DGBC_" "_DGBS
;Date of death (#29) & Death indicator (#30) (always included if dead)
S X=+VADM(6) I X D
.S VAFY(29)=$$HLDATE^HLFNC(X)
.S VAFY(30)="Y"
;
QUIT D KVA^VADPT
D MAKEIT^VAFHLU("PID",.VAFY,.OUTPUT,.VAFPID)
Q OUTPUT
;
ADDR(VAFADDR,VAFCOUNT) ;Return HL7 address
; Input - VAFADDR as address in format:
; line1^line2^line3^city^state^zip+4
; VAFCOUNT as internal value of county (optional)
; Output - HL7 v2.3 formatted Address_HLFS_County Code
;
; ****Also assumes all HL7 variables returned from****
; INIT^HLTRANS are defined
;
N X,Y,Z S X=$E(HLECH)
;Street address (line 1)
S $P(Y,X,1)=$P(VAFADDR,"^",1)
;Other designation (line 2)
S $P(Y,X,2)=$P(VAFADDR,"^",2)
;City
S $P(Y,X,3)=$P(VAFADDR,"^",4)
;State
S $P(Y,X,4)=$P($G(^DIC(5,+$P(VAFADDR,"^",5),0)),"^",2)
;Zip
S $P(Y,X,5)=$P(VAFADDR,"^",6)
;Other geographic designation (line 3)
S $P(Y,X,8)=$P(VAFADDR,"^",3)
;County
S $P(Y,X,9)=$P($G(^DIC(5,+$P(VAFADDR,"^",5),1,+$G(VAFCOUNT),0)),"^",3)
F Z=1,2,3,4,5,8,9 I $P(Y,X,Z)="" S $P(Y,X,Z)=HLQ
I $G(VAFCOUNT) D
.S $P(Y,HLFS,2)=$P(Y,X,9)
Q Y
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HVAFCPID 4499 printed Nov 22, 2024@18:12:08 Page 2
VAFCPID ;ALB/MLI,PKE-Create generic PID segment ; 21 Nov 2002 3:13 PM
+1 ;;5.3;Registration;**91,149,190,415,508,749**;Aug 13, 1993;Build 10
+2 ;
+3 ; This routine returns the HL7 defined PID segment with its
+4 ; mappings to DHCP PATIENT file fields.
+5 ;
EN(DFN,VAFSTR,VAFNUM) ; returns PID segment
+1 ; Input - DFN as internal entry number of the PATIENT file
+2 ; VAFSTR as string of fields requested separated by commas
+3 ; VAFNUM as sequential number for SET ID (default=1)
+4 ;
+5 ; ****Also assumes all HL7 variables returned from****
+6 ; INIT^HLTRANS are defined
+7 ;
+8 ; Output - String containing the desired components of the PID segment
+9 ; VAFPID(n) - if the string is longer than 245, the remaining
+10 ; characters will be returned in VAFPID(n) where
+11 ; n is a sequential number beginning with 1
+12 ;
+13 ; WARNING: This routine makes external calls to VADPT. Non-namespaced
+14 ; variables may be altered.
+15 ;
+16 ; calls VADPT...have to NEW
NEW I,VAFY,VA,VADM,X,X1,Y,OUTPUT,DGNAME,DGMMN,VAPA
+17 ; if not defined, just return required fields
SET VAFSTR=$GET(VAFSTR)
+18 SET DFN=$GET(DFN)
+19 IF DFN']""
GOTO QUIT
+20 ;Get demographics and permanent address
+21 SET VAPA("P")=""
DO 4^VADPT
+22 SET VAFSTR=","_VAFSTR_","
+23 KILL VAFY
+24 ;Set ID (#1)
+25 IF VAFSTR[",1,"
SET VAFY(1)=$SELECT($GET(VAFNUM):VAFNUM,1:1)
+26 ;External ID (#2 - always included)
+27 SET X=$$GETICN^MPIF001(DFN)
if (+X=-1)
SET X=""
SET VAFY(2)=$SELECT(X]"":X,1:HLQ)
+28 ;Patient ID (#3 - req)
+29 SET VAFY(3)=$$M10^HLFNC(DFN)
+30 ;Alternate ID (#4)
+31 IF VAFSTR[",4,"
SET X=$GET(VA("BID"))
SET VAFY(4)=$SELECT(X]"":X,1:HLQ)
+32 ;Name (#5 - req)
+33 SET DGNAME("FILE")=2
SET DGNAME("IENS")=DFN
SET DGNAME("FIELD")=.01
+34 SET X=$$HLNAME^XLFNAME(.DGNAME,"",$EXTRACT(HLECH))
SET VAFY(5)=$SELECT(X]"":X,1:HLQ)
+35 ;Mother's maiden name (#6)
+36 IF VAFSTR[",6,"
Begin DoDot:1
+37 SET DGMMN("FILE")=2
SET DGMMN("IENS")=DFN
SET DGMMN("FIELD")=.2403
+38 SET X=$$HLNAME^XLFNAME(.DGMMN,"",$EXTRACT(HLECH))
SET VAFY(6)=$SELECT(X]"":X,1:HLQ)
End DoDot:1
+39 ;Date of birth (#7)
+40 IF VAFSTR[",7,"
SET VAFY(7)=$$HLDATE^HLFNC(+VADM(3))
+41 ;Sex (#8)
+42 IF VAFSTR[",8,"
SET X=$PIECE(VADM(5),"^",1)
SET VAFY(8)=$SELECT("^M^F^"[("^"_X_"^"):X,1:"U")
+43 ;Race (#10)
+44 IF VAFSTR[10
Begin DoDot:1
+45 NEW HOW
+46 SET Y=$FIND(VAFSTR,"10")
+47 SET HOW=$PIECE($EXTRACT(VAFSTR,Y,$FIND(VAFSTR,",",Y)),",",1)
+48 DO SEQ10^VAFHLPI1(HOW,HLQ)
End DoDot:1
+49 ;Address (#11)
+50 IF VAFSTR[11
Begin DoDot:1
+51 NEW HOW
+52 SET Y=$FIND(VAFSTR,"11")
+53 SET HOW=$PIECE($EXTRACT(VAFSTR,Y,$FIND(VAFSTR,",",Y)),",",1)
+54 DO SEQ11^VAFHLPI2(HOW,HLQ)
End DoDot:1
+55 ;County (#12)
+56 IF VAFSTR[12
SET X1=$PIECE($GET(^DIC(5,+$GET(VAPA(5)),1,+$GET(VAPA(7)),0)),"^",3)
SET VAFY(12)=$SELECT(X1]"":X1,1:HLQ)
+57 SET X=$GET(^DPT(DFN,.13))
+58 ;Home phone (#13)
+59 IF VAFSTR[13
SET X1=$$HLPHONE^HLFNC($PIECE(X,"^",1))
SET VAFY(13)=$SELECT(X1]"":X1,1:HLQ)
+60 ;Business phone (#14)
+61 IF VAFSTR[14
SET X1=$$HLPHONE^HLFNC($PIECE(X,"^",2))
SET VAFY(14)=$SELECT(X1]"":X1,1:HLQ)
+62 ;Marital status (#16)
+63 IF VAFSTR[16
SET X=$PIECE($GET(^DIC(11,+VADM(10),0)),"^",3)
SET VAFY(16)=$SELECT(X="M":"M",X="N":"S",X="S":"A",X]"":X,1:HLQ)
+64 ;Religious preference (#17) (if blank send 29 (UNKNOWN))
+65 IF VAFSTR[17
SET X=$PIECE($GET(^DIC(13,+VADM(9),0)),"^",4)
SET VAFY(17)=$SELECT(X]"":X,1:29)
+66 ;SSN (#19)
+67 IF VAFSTR[19
SET X=$PIECE(VADM(2),"^",1)
SET VAFY(19)=$SELECT(X]"":X,1:HLQ)
+68 ;Ethnicity (#22)
+69 IF VAFSTR[22
Begin DoDot:1
+70 NEW HOW
+71 SET Y=$FIND(VAFSTR,"22")
+72 SET HOW=$PIECE($EXTRACT(VAFSTR,Y,$FIND(VAFSTR,",",Y)),",",1)
+73 DO SEQ22^VAFHLPI1(HOW,HLQ)
End DoDot:1
+74 ;Birth place (#23)
+75 IF VAFSTR[23
Begin DoDot:1
+76 NEW DGBC,DGBS
+77 SET DGBC=$$GET1^DIQ(2,DFN,.092,"I")
+78 SET DGBS=$$GET1^DIQ(2,DFN,.093,"E")
+79 SET VAFY(23)=DGBC_" "_DGBS
End DoDot:1
+80 ;Date of death (#29) & Death indicator (#30) (always included if dead)
+81 SET X=+VADM(6)
IF X
Begin DoDot:1
+82 SET VAFY(29)=$$HLDATE^HLFNC(X)
+83 SET VAFY(30)="Y"
End DoDot:1
+84 ;
QUIT DO KVA^VADPT
+1 DO MAKEIT^VAFHLU("PID",.VAFY,.OUTPUT,.VAFPID)
+2 QUIT OUTPUT
+3 ;
ADDR(VAFADDR,VAFCOUNT) ;Return HL7 address
+1 ; Input - VAFADDR as address in format:
+2 ; line1^line2^line3^city^state^zip+4
+3 ; VAFCOUNT as internal value of county (optional)
+4 ; Output - HL7 v2.3 formatted Address_HLFS_County Code
+5 ;
+6 ; ****Also assumes all HL7 variables returned from****
+7 ; INIT^HLTRANS are defined
+8 ;
+9 NEW X,Y,Z
SET X=$EXTRACT(HLECH)
+10 ;Street address (line 1)
+11 SET $PIECE(Y,X,1)=$PIECE(VAFADDR,"^",1)
+12 ;Other designation (line 2)
+13 SET $PIECE(Y,X,2)=$PIECE(VAFADDR,"^",2)
+14 ;City
+15 SET $PIECE(Y,X,3)=$PIECE(VAFADDR,"^",4)
+16 ;State
+17 SET $PIECE(Y,X,4)=$PIECE($GET(^DIC(5,+$PIECE(VAFADDR,"^",5),0)),"^",2)
+18 ;Zip
+19 SET $PIECE(Y,X,5)=$PIECE(VAFADDR,"^",6)
+20 ;Other geographic designation (line 3)
+21 SET $PIECE(Y,X,8)=$PIECE(VAFADDR,"^",3)
+22 ;County
+23 SET $PIECE(Y,X,9)=$PIECE($GET(^DIC(5,+$PIECE(VAFADDR,"^",5),1,+$GET(VAFCOUNT),0)),"^",3)
+24 FOR Z=1,2,3,4,5,8,9
IF $PIECE(Y,X,Z)=""
SET $PIECE(Y,X,Z)=HLQ
+25 IF $GET(VAFCOUNT)
Begin DoDot:1
+26 SET $PIECE(Y,HLFS,2)=$PIECE(Y,X,9)
End DoDot:1
+27 QUIT Y
