VAFCQRY1 ;BIR/DLR-Query for patient demographics ;10/30/02 13:58
;;5.3;Registration;**428,474,477,575,627,648,698,711,707,1015**;Aug 13, 1993;Build 21
;
;Reference to $$GETDFNS^MPIF002 supported by IA #3634.
;
BLDPID(DFN,CNT,SEQ,PID,HL,ERR) ;build PID from File #2
; Variable list
; DFN - internal PATIENT (#2) number
; CNT - value to be place in PID seq#1 (SET ID)
; SEQ - variable consisting of sequence numbers delimited by commas
; that will be used to build the message (default is ALL)
; PID (passed by reference) - array location to place PID segment
; result, the array can have existing values when passed.
; HL - array that contains the necessary HL variables (init^hlsub)
; ERR - array that is used to return an error
;
N VAFCMN,VAFCMMN,SITE,VAFCZN,SSN,SITE,APID,HIST,HISTDT,VAFCHMN,NXT,NXTC,COMP,REP,SUBCOMP,STATE,CITY,CLAIM,HLECH,HLFS,HLQ,STATEIEN,SARY,LVL,LNGTH,X,STN,SITA,HLES
I '$D(SEQ) S SEQ="ALL"
I SEQ="" S SEQ="ALL"
I SEQ'="ALL" D
.; setting up temp array to hold fields to be included in message
.N POS,EN S POS=1 F S EN=$P(SEQ,",",POS) Q:EN="" S SARY(EN)="",POS=POS+1
S HLECH=HL("ECH"),HLFS=HL("FS"),HLQ=HL("Q"),(COMP,HL("COMP"))=$E(HL("ECH"),1)
S (SUBCOMP,HL("SUBCOMP"))=$E(HL("ECH"),4),(REP,HL("REP"))=$E(HL("ECH"),2),HLES=$E(HL("ECH"),3)
;get Patient File MPI node
S VAFCMN=""
N X S X="MPIFAPI" X ^%ZOSF("TEST") I $T S VAFCMN=$$MPINODE^MPIFAPI(DFN)
I +VAFCMN<0 S VAFCMN=""
S VAFCZN=^DPT(DFN,0),SSN=$P(^DPT(DFN,0),"^",9)
N VAFCA,VAFCA1 D GETS^DIQ(2,DFN_",","1*","E","VAFCA") ;**698 GETTING ALIAS INFO
;** 707 reformat alias information to include ALIAS SSN in PID-3 with a location reference to the name in PID-5
I $D(VAFCA) N CT,ENT S CT=0,ENT="" F S ENT=$O(VAFCA(2.01,ENT)) Q:ENT="" D
.S CT=CT+1
.S VAFCA1(CT,"NAME")=$G(VAFCA(2.01,ENT,.01,"E"))
.;I $G(VAFCA(2.01,ENT,1,"E"))'="" S VAFCA1("SSN")="",VAFCA1(CT,"SSN")=$G(VAFCA(2.01,ENT,1,"E"))
.S VAFCA1(CT,"SSN")=$G(VAFCA(2.01,ENT,1,"E"))
S SITE=$$SITE^VASITE,STN=$P($$SITE^VASITE,"^",3)
N TMP F TMP=1:1:31 S APID(TMP)=""
S APID(2)=CNT
;list of fields used for backwards compatibility with HDR
I $D(SARY(2))!(SEQ="ALL") I VAFCMN'="" S APID(3)=$P(VAFCMN,"^")_"V"_$P(VAFCMN,"^",2) ;Patient ID
;repeat patient ID list including ICN (NI),SSN (SS),CLAIM# (PN) AND DFN (PI)
I $D(SARY(3))!(SEQ="ALL") D
.S APID(4)=""
.;National Identifier (ICN)
.I VAFCMN'="",+VAFCMN>0 D
..I $E($P(VAFCMN,"^"),1,3)=STN S SITA=STN
..I $E($P(VAFCMN,"^"),1,3)'=STN S SITA="200M" ; **707 update assigning authority for national ICNs to 200M for MPI
..S APID(4)=$P(VAFCMN,"^")_"V"_$P(VAFCMN,"^",2)_COMP_COMP_COMP_"USVHA"_SUBCOMP_SUBCOMP_"0363"_COMP_"NI"_COMP_"VA FACILITY ID"_SUBCOMP_SITA_SUBCOMP_"L" D
..;Assumption that if this is a local ICN at this point send the message with an expiration date of today, so that it will be treated as a deprecated ID and stored on the MPI as such
..I $E($P(VAFCMN,"^"),1,3)=$P($$SITE^VASITE,"^",3) S APID(4)=APID(4)_COMP_COMP_$$HLDATE^HLFNC(DT,"DT") ;**707 TO ONLY SEND DATE NO TIME
.I $G(SSN)'="" S APID(4)=APID(4)_$S(APID(4)'="":REP,1:"")_SSN_COMP_COMP_COMP_"USSSA"_SUBCOMP_SUBCOMP_"0363"_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_"0363"_COMP_"PI"_COMP_"VA FACILITY ID"_SUBCOMP_$$STA^XUAF4(+SITE)_SUBCOMP_"L" D
..;CLAIM# **707 moved dfn and claim number up here since Alias SSN could be many
..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_"0363"_COMP_"PN"_COMP_"VA FACILITY ID"_SUBCOMP_$$STA^XUAF4(+SITE)_SUBCOMP_"L"
.S NXTC=0,LVL=0
.I $D(VAFCA1) D
..;Have Alias SSNs
..S CT=0 F S CT=$O(VAFCA1(CT)) Q:+CT<1 D
...S NXT=$S($G(VAFCA1(CT,"SSN"))="":HL("Q"),1:$G(VAFCA1(CT,"SSN")))_COMP_COMP_COMP_"USSSA"_SUBCOMP_SUBCOMP_"0363"_COMP_"SS"_COMP_"VA FACILITY ID"_SUBCOMP_$$STA^XUAF4(+SITE)_SUBCOMP_"L"_COMP_COMP_$$HLDATE^HLFNC(DT,"DT")
...I LVL=0 D
....I $L(APID(4)_NXT)'>244 S APID(4)=APID(4)_REP_NXT Q
....I $L(APID(4)_NXT)>244 S LVL=1 S LNGTH=244-$L(APID(4)),APID(4)=APID(4)_REP_$E(NXT,1,LNGTH) S LNGTH=LNGTH+1,NXT=$E(NXT,LNGTH,$L(NXT)),NXTC=1
...I LVL>0 D
....I $L($G(APID(4,LVL))_NXT)'>245 S APID(4,LVL)=$G(APID(4,LVL))_$S(NXTC=0:REP,1:"")_NXT Q
....I $L($G(APID(4,LVL))_NXT)>245 S LNGTH=244-$L(APID(4,LVL)),APID(4,LVL)=APID(4,LVL)_REP_$E(NXT,1,LNGTH) S LNGTH=LNGTH+1,NXT=$E(NXT,LNGTH,$L(NXT)) S LVL=LVL+1 S APID(4,LVL)=NXT
...I NXTC=1 S NXTC=0
.I $D(^DPT(DFN,"MPIFHIS")) N HIST S HIST=0 F S HIST=$O(^DPT(DFN,"MPIFHIS",HIST)) Q:'HIST S VAFCHMN=^DPT(DFN,"MPIFHIS",HIST,0) S HISTDT=$P(VAFCHMN,"^",4) D
..;**477 due to a timing issue if checksum and D/T of deprication of ICN is not present hang two seconds and try again if still not able to get ICN set D/T to DT
..I $G(HISTDT)="" H 2 S VAFCHMN=^DPT(DFN,"MPIFHIS",HIST,0) S HISTDT=$P(VAFCHMN,"^",4) I HISTDT="" S HISTDT=DT
..I APID(4)'="" D
...I $E($P(VAFCHMN,"^"),1,3)=STN S SITA=STN
...I $E($P(VAFCHMN,"^"),1,3)'=STN S SITA="200M" ; **707 update assigning authority for national ICNs to 200M for MPI
...S NXT=$P(VAFCHMN,"^")_"V"_$P(VAFCHMN,"^",2)_COMP_COMP_COMP_"USVHA"_SUBCOMP_SUBCOMP_"0363"_COMP_"NI"_COMP_"VA FACILITY ID"_SUBCOMP_SITA_SUBCOMP_"L"_COMP_COMP_$$HLDATE^HLFNC(HISTDT,"DT") ;**648 only send date not time
...I LVL=0 D
....I $L(APID(4)_NXT)'>244 S APID(4)=APID(4)_REP_NXT Q
....I $L(APID(4)_NXT)>244 S LVL=1 S LNGTH=244-$L(APID(4)),APID(4)=APID(4)_REP_$E(NXT,1,LNGTH) S LNGTH=LNGTH+1,NXT=$E(NXT,LNGTH,$L(NXT)),NXTC=1
...I LVL>0 D
....I $L($G(APID(4,LVL))_NXT)'>245 S APID(4,LVL)=$G(APID(4,LVL))_$S(NXTC=0:REP,1:"")_NXT Q
....I $L($G(APID(4,LVL))_NXT)>245 S LNGTH=244-$L(APID(4,LVL)),APID(4,LVL)=APID(4,LVL)_REP_$E(NXT,1,LNGTH) S LNGTH=LNGTH+1,NXT=$E(NXT,LNGTH,$L(NXT)) S LVL=LVL+1 S APID(4,LVL)=NXT
..I NXTC=1 S NXTC=0
..I APID(4)="" D
...I $E($P(VAFCHMN,"^"),1,3)=STN S SITA=STN
...I $E($P(VAFCHMN,"^"),1,3)'=STN S SITA="200M"
...S APID(4)=$P(VAFCHMN,"^")_COMP_COMP_COMP_"USVHA"_SUBCOMP_SUBCOMP_"0363"_COMP_"NI"_COMP_"VA FACILITY ID"_SUBCOMP_SITA_SUBCOMP_"L"_COMP_COMP_$$HLDATE^HLFNC(HISTDT,"DT") ;**707 ONLY DATE NOT TIME
NAMEPID ;patient name (last^first^middle^suffix^prefix^^"L" for legal)
I $D(SARY(5))!(SEQ="ALL") D
.;**711 code REMOVED PREFIX due to issues with existing PATIENT Name Standardization functionality
.N X S X=$P(VAFCZN,"^") D NAME^VAFCPID2(DFN,.X) S APID(6)=$$HLNAME^XLFNAME(X,"",$E(HL("ECH"),1)) I $P(APID(6),$E(HL("ECH"),1),7)'="L" S $P(APID(6),$E(HL("ECH"),1),7)="L"
ALIAS .;patient alias (last^first^middle^suffice^prefix^^"A" for alias - can be multiple)
.N ALIAS,ALIEN,LVL6,NXTC,LNGTH S NXTC=0,LVL6=0
.I $D(VAFCA1) S ALIEN=0 F S ALIEN=$O(VAFCA1(ALIEN)) Q:'ALIEN D
..S ALIAS=$$HLNAME^XLFNAME(VAFCA1(ALIEN,"NAME"),"",$E(HL("ECH"),1))
..Q:ALIAS=""
..S $P(ALIAS,$E(HL("ECH"),1),7)="A"
..I LVL6=0 D
...I $L(APID(6)_ALIAS)'>244 S APID(6)=APID(6)_REP_ALIAS Q
...I $L(APID(6)_ALIAS)>244 S LVL6=1 S LNGTH=244-$L(APID(6)),APID(6)=APID(6)_REP_$E(ALIAS,1,LNGTH) S LNGTH=LNGTH+1,ALIAS=$E(ALIAS,LNGTH,$L(ALIAS)),NXTC=1
..I LVL6>0 D
...I $L($G(APID(6,LVL6))_ALIAS)'>245 S APID(6,LVL6)=$G(APID(6,LVL6))_$S(NXTC=0:REP,1:"")_ALIAS Q
...I $L($G(APID(6,LVL6))_ALIAS)>245 S LNGTH=244-$L(APID(6,LVL6)),APID(6,LVL6)=APID(6,LVL6)_REP_$E(ALIAS,1,LNGTH) S LNGTH=LNGTH+1,ALIAS=$E(ALIAS,LNGTH,$L(ALIAS)) S LVL6=LVL6+1 S APID(6,LVL6)=ALIAS
..I NXTC=1 S NXTC=0
. I APID(6)="" S APID(6)=HL("Q")
MOTHER ;mother's maiden name (last^first^middle^suffix^prefix^^"M" for maiden name)
I $D(SARY(6))!(SEQ="ALL") D
.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"
.I APID(7)="" S APID(7)=HL("Q")
I $D(SARY(7))!(SEQ="ALL") S APID(8)=$$HLDATE^HLFNC($P(VAFCZN,"^",3)) I APID(8)="" S APID(8)=HL("Q") ;date/time of birth
I $D(SARY(8))!(SEQ="ALL") S APID(9)=$P(VAFCZN,"^",2) I APID(9)="" S APID(9)=HL("Q") ;sex
;place of birth city and state
;split into 2 routines **707
D CONT^VAFCQRY3(DFN,.APID,.PID,.HL,HLES,.SARY,SEQ,.ERR,REP,COMP,SSN,VAFCMN)
D KVA^VADPT
Q
HL7TXT(HL7STRG,HL,HLES) ; Replace occurrences of embedded HL7 delimiters with
; HL7 escape sequence
;
; Inputs: HL7STRG - Data string to be checked
; HL("ECH") - HL7 delimiter string
; Delimiters MUST be in the following order,
; Escape, Field, Component, Repeat, Subcomponent
; Example: \^~|&
;
; Output: HL7XTRG - Data string with escape sequence added (if needed)
;
N OCHR,RCHR,RCHRI,TYPE,I,HLES2
;
I $G(HL("COMP"))="" S HL("COMP")=$E(HL("ECH"),1),HL("REP")=$E(HL("ECH"),2),HL("SUBCOMP")=$E(HL("ECH"),4)
; Set HL7 escape char
S HLES2=HLES_HL("FS")_HL("COMP")_HL("REP")_HL("SUBCOMP")
;
; Search for occurrence of each delimiter and replace it with "\<type>\"
F TYPE="E","F","C","R","S" D
. S RCHRI=$S(TYPE="E":1,TYPE="F":2,TYPE="C":3,TYPE="R":4,TYPE="S":5)
. ;
. ; OCHR=original char, RCHR=replacement char
. S OCHR=$E(HLES2,RCHRI),RCHR=$E("EFSRT",RCHRI) Q:'$F(HL7STRG,OCHR)
. F I=1:1 Q:$E(HL7STRG,I)="" I $E(HL7STRG,I)=OCHR S HL7STRG=$E(HL7STRG,1,I-1)_HLES_RCHR_HLES_$E(HL7STRG,I+1,999),I=I+2
Q
Q
VAFCQRY1 ;BIR/DLR-Query for patient demographics ;10/30/02 13:58
+1 ;;5.3;Registration;**428,474,477,575,627,648,698,711,707,1015**;Aug 13, 1993;Build 21
+2 ;
+3 ;Reference to $$GETDFNS^MPIF002 supported by IA #3634.
+4 ;
BLDPID(DFN,CNT,SEQ,PID,HL,ERR) ;build PID from File #2
+1 ; Variable list
+2 ; DFN - internal PATIENT (#2) number
+3 ; CNT - value to be place in PID seq#1 (SET ID)
+4 ; SEQ - variable consisting of sequence numbers delimited by commas
+5 ; that will be used to build the message (default is ALL)
+6 ; PID (passed by reference) - array location to place PID segment
+7 ; result, the array can have existing values when passed.
+8 ; HL - array that contains the necessary HL variables (init^hlsub)
+9 ; ERR - array that is used to return an error
+10 ;
+11 NEW VAFCMN,VAFCMMN,SITE,VAFCZN,SSN,SITE,APID,HIST,HISTDT,VAFCHMN,NXT,NXTC,COMP,REP,SUBCOMP,STATE,CITY,CLAIM,HLECH,HLFS,HLQ,STATEIEN,SARY,LVL,LNGTH,X,STN,SITA,HLES
+12 IF '$DATA(SEQ)
SET SEQ="ALL"
+13 IF SEQ=""
SET SEQ="ALL"
+14 IF SEQ'="ALL"
Begin DoDot:1
+15 ; setting up temp array to hold fields to be included in message
+16 NEW POS,EN
SET POS=1
FOR
SET EN=$PIECE(SEQ,",",POS)
IF EN=""
QUIT
SET SARY(EN)=""
SET POS=POS+1
End DoDot:1
+17 SET HLECH=HL("ECH")
SET HLFS=HL("FS")
SET HLQ=HL("Q")
SET (COMP,HL("COMP"))=$EXTRACT(HL("ECH"),1)
+18 SET (SUBCOMP,HL("SUBCOMP"))=$EXTRACT(HL("ECH"),4)
SET (REP,HL("REP"))=$EXTRACT(HL("ECH"),2)
SET HLES=$EXTRACT(HL("ECH"),3)
+19 ;get Patient File MPI node
+20 SET VAFCMN=""
+21 NEW X
SET X="MPIFAPI"
XECUTE ^%ZOSF("TEST")
IF $TEST
SET VAFCMN=$$MPINODE^MPIFAPI(DFN)
+22 IF +VAFCMN<0
SET VAFCMN=""
+23 SET VAFCZN=^DPT(DFN,0)
SET SSN=$PIECE(^DPT(DFN,0),"^",9)
+24 ;**698 GETTING ALIAS INFO
NEW VAFCA,VAFCA1
DO GETS^DIQ(2,DFN_",","1*","E","VAFCA")
+25 ;** 707 reformat alias information to include ALIAS SSN in PID-3 with a location reference to the name in PID-5
+26 IF $DATA(VAFCA)
NEW CT,ENT
SET CT=0
SET ENT=""
FOR
SET ENT=$ORDER(VAFCA(2.01,ENT))
IF ENT=""
QUIT
Begin DoDot:1
+27 SET CT=CT+1
+28 SET VAFCA1(CT,"NAME")=$GET(VAFCA(2.01,ENT,.01,"E"))
+29 ;I $G(VAFCA(2.01,ENT,1,"E"))'="" S VAFCA1("SSN")="",VAFCA1(CT,"SSN")=$G(VAFCA(2.01,ENT,1,"E"))
+30 SET VAFCA1(CT,"SSN")=$GET(VAFCA(2.01,ENT,1,"E"))
End DoDot:1
+31 SET SITE=$$SITE^VASITE
SET STN=$PIECE($$SITE^VASITE,"^",3)
+32 NEW TMP
FOR TMP=1:1:31
SET APID(TMP)=""
+33 SET APID(2)=CNT
+34 ;list of fields used for backwards compatibility with HDR
+35 ;Patient ID
IF $DATA(SARY(2))!(SEQ="ALL")
IF VAFCMN'=""
SET APID(3)=$PIECE(VAFCMN,"^")_"V"_$PIECE(VAFCMN,"^",2)
+36 ;repeat patient ID list including ICN (NI),SSN (SS),CLAIM# (PN) AND DFN (PI)
+37 IF $DATA(SARY(3))!(SEQ="ALL")
Begin DoDot:1
+38 SET APID(4)=""
+39 ;National Identifier (ICN)
+40 IF VAFCMN'=""
IF +VAFCMN>0
Begin DoDot:2
+41 IF $EXTRACT($PIECE(VAFCMN,"^"),1,3)=STN
SET SITA=STN
+42 ; **707 update assigning authority for national ICNs to 200M for MPI
IF $EXTRACT($PIECE(VAFCMN,"^"),1,3)'=STN
SET SITA="200M"
+43 SET APID(4)=$PIECE(VAFCMN,"^")_"V"_$PIECE(VAFCMN,"^",2)_COMP_COMP_COMP_"USVHA"_SUBCOMP_SUBCOMP_"0363"_COMP_"NI"_COMP_"VA FACILITY ID"_SUBCOMP_SITA_SUBCOMP_"L"
Begin DoDot:3
End DoDot:3
+44 ;Assumption that if this is a local ICN at this point send the message with an expiration date of today, so that it will be treated as a deprecated ID and stored on the MPI as such
+45 ;**707 TO ONLY SEND DATE NO TIME
IF $EXTRACT($PIECE(VAFCMN,"^"),1,3)=$PIECE($$SITE^VASITE,"^",3)
SET APID(4)=APID(4)_COMP_COMP_$$HLDATE^HLFNC(DT,"DT")
End DoDot:2
+46 IF $GET(SSN)'=""
SET APID(4)=APID(4)_$SELECT(APID(4)'="":REP,1:"")_SSN_COMP_COMP_COMP_"USSSA"_SUBCOMP_SUBCOMP_"0363"_COMP_"SS"_COMP_"VA FACILITY ID"_SUBCOMP_$$STA^XUAF4(+SITE)_SUBCOMP_"L"
+47 IF $GET(DFN)'=""
SET APID(4)=APID(4)_$SELECT(APID(4)'="":REP,1:"")_DFN_COMP_COMP_COMP_"USVHA"_SUBCOMP_SUBCOMP_"0363"_COMP_"PI"_COMP_"VA FACILITY ID"_SUBCOMP_$$STA^XUAF4(+SITE)_SUBCOMP_"L"
Begin DoDot:2
+48 ;CLAIM# **707 moved dfn and claim number up here since Alias SSN could be many
+49 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_"0363"_COMP_"PN"_COMP_"VA FACILITY ID"_SUBCOMP_$$STA^XUAF4(+SITE)_SUBCOMP_"L"
End DoDot:2
+50 SET NXTC=0
SET LVL=0
+51 IF $DATA(VAFCA1)
Begin DoDot:2
+52 ;Have Alias SSNs
+53 SET CT=0
FOR
SET CT=$ORDER(VAFCA1(CT))
IF +CT<1
QUIT
Begin DoDot:3
+54 SET NXT=$SELECT($GET(VAFCA1(CT,"SSN"))="":HL("Q"),1:$GET(VAFCA1(CT,"SSN")))_COMP_COMP_COMP_"USSSA"_SUBCOMP_SUBCOMP_"0363"_COMP_"SS"_COMP_"VA FACILITY ID"_SUBCOMP_$$STA^XUAF4(+SITE)_SUBCOMP_"L"_COMP_COMP_$$HLDATE^HLFNC(DT
,"DT")
+55 IF LVL=0
Begin DoDot:4
+56 IF $LENGTH(APID(4)_NXT)'>244
SET APID(4)=APID(4)_REP_NXT
QUIT
+57 IF $LENGTH(APID(4)_NXT)>244
SET LVL=1
SET LNGTH=244-$LENGTH(APID(4))
SET APID(4)=APID(4)_REP_$EXTRACT(NXT,1,LNGTH)
SET LNGTH=LNGTH+1
SET NXT=$EXTRACT(NXT,LNGTH,$LENGTH(NXT))
SET NXTC=1
End DoDot:4
+58 IF LVL>0
Begin DoDot:4
+59 IF $LENGTH($GET(APID(4,LVL))_NXT)'>245
SET APID(4,LVL)=$GET(APID(4,LVL))_$SELECT(NXTC=0:REP,1:"")_NXT
QUIT
+60 IF $LENGTH($GET(APID(4,LVL))_NXT)>245
SET LNGTH=244-$LENGTH(APID(4,LVL))
SET APID(4,LVL)=APID(4,LVL)_REP_$EXTRACT(NXT,1,LNGTH)
SET LNGTH=LNGTH+1
SET NXT=$EXTRACT(NXT,LNGTH,$LENGTH(NXT))
SET LVL=LVL+1
SET APID(4,LVL)=NXT
End DoDot:4
+61 IF NXTC=1
SET NXTC=0
End DoDot:3
End DoDot:2
+62 IF $DATA(^DPT(DFN,"MPIFHIS"))
NEW HIST
SET HIST=0
FOR
SET HIST=$ORDER(^DPT(DFN,"MPIFHIS",HIST))
IF 'HIST
QUIT
SET VAFCHMN=^DPT(DFN,"MPIFHIS",HIST,0)
SET HISTDT=$PIECE(VAFCHMN,"^",4)
Begin DoDot:2
+63 ;**477 due to a timing issue if checksum and D/T of deprication of ICN is not present hang two seconds and try again if still not able to get ICN set D/T to DT
+64 IF $GET(HISTDT)=""
HANG 2
SET VAFCHMN=^DPT(DFN,"MPIFHIS",HIST,0)
SET HISTDT=$PIECE(VAFCHMN,"^",4)
IF HISTDT=""
SET HISTDT=DT
+65 IF APID(4)'=""
Begin DoDot:3
+66 IF $EXTRACT($PIECE(VAFCHMN,"^"),1,3)=STN
SET SITA=STN
+67 ; **707 update assigning authority for national ICNs to 200M for MPI
IF $EXTRACT($PIECE(VAFCHMN,"^"),1,3)'=STN
SET SITA="200M"
+68 ;**648 only send date not time
SET NXT=$PIECE(VAFCHMN,"^")_"V"_$PIECE(VAFCHMN,"^",2)_COMP_COMP_COMP_"USVHA"_SUBCOMP_SUBCOMP_"0363"_COMP_"NI"_COMP_"VA FACILITY ID"_SUBCOMP_SITA_SUBCOMP_"L"_COMP_COMP_$$HLDATE^HLFNC(HISTDT,"DT")
+69 IF LVL=0
Begin DoDot:4
+70 IF $LENGTH(APID(4)_NXT)'>244
SET APID(4)=APID(4)_REP_NXT
QUIT
+71 IF $LENGTH(APID(4)_NXT)>244
SET LVL=1
SET LNGTH=244-$LENGTH(APID(4))
SET APID(4)=APID(4)_REP_$EXTRACT(NXT,1,LNGTH)
SET LNGTH=LNGTH+1
SET NXT=$EXTRACT(NXT,LNGTH,$LENGTH(NXT))
SET NXTC=1
End DoDot:4
+72 IF LVL>0
Begin DoDot:4
+73 IF $LENGTH($GET(APID(4,LVL))_NXT)'>245
SET APID(4,LVL)=$GET(APID(4,LVL))_$SELECT(NXTC=0:REP,1:"")_NXT
QUIT
+74 IF $LENGTH($GET(APID(4,LVL))_NXT)>245
SET LNGTH=244-$LENGTH(APID(4,LVL))
SET APID(4,LVL)=APID(4,LVL)_REP_$EXTRACT(NXT,1,LNGTH)
SET LNGTH=LNGTH+1
SET NXT=$EXTRACT(NXT,LNGTH,$LENGTH(NXT))
SET LVL=LVL+1
SET APID(4,LVL)=NXT
End DoDot:4
End DoDot:3
+75 IF NXTC=1
SET NXTC=0
+76 IF APID(4)=""
Begin DoDot:3
+77 IF $EXTRACT($PIECE(VAFCHMN,"^"),1,3)=STN
SET SITA=STN
+78 IF $EXTRACT($PIECE(VAFCHMN,"^"),1,3)'=STN
SET SITA="200M"
+79 ;**707 ONLY DATE NOT TIME
SET APID(4)=$PIECE(VAFCHMN,"^")_COMP_COMP_COMP_"USVHA"_SUBCOMP_SUBCOMP_"0363"_COMP_"NI"_COMP_"VA FACILITY ID"_SUBCOMP_SITA_SUBCOMP_"L"_COMP_COMP_$$HLDATE^HLFNC(HISTDT,"DT")
End DoDot:3
End DoDot:2
End DoDot:1
NAMEPID ;patient name (last^first^middle^suffix^prefix^^"L" for legal)
+1 IF $DATA(SARY(5))!(SEQ="ALL")
Begin DoDot:1
+2 ;**711 code REMOVED PREFIX due to issues with existing PATIENT Name Standardization functionality
+3 NEW X
SET X=$PIECE(VAFCZN,"^")
DO NAME^VAFCPID2(DFN,.X)
SET APID(6)=$$HLNAME^XLFNAME(X,"",$EXTRACT(HL("ECH"),1))
IF $PIECE(APID(6),$EXTRACT(HL("ECH"),1),7)'="L"
SET $PIECE(APID(6),$EXTRACT(HL("ECH"),1),7)="L"
ALIAS ;patient alias (last^first^middle^suffice^prefix^^"A" for alias - can be multiple)
+1 NEW ALIAS,ALIEN,LVL6,NXTC,LNGTH
SET NXTC=0
SET LVL6=0
+2 IF $DATA(VAFCA1)
SET ALIEN=0
FOR
SET ALIEN=$ORDER(VAFCA1(ALIEN))
IF 'ALIEN
QUIT
Begin DoDot:2
+3 SET ALIAS=$$HLNAME^XLFNAME(VAFCA1(ALIEN,"NAME"),"",$EXTRACT(HL("ECH"),1))
+4 IF ALIAS=""
QUIT
+5 SET $PIECE(ALIAS,$EXTRACT(HL("ECH"),1),7)="A"
+6 IF LVL6=0
Begin DoDot:3
+7 IF $LENGTH(APID(6)_ALIAS)'>244
SET APID(6)=APID(6)_REP_ALIAS
QUIT
+8 IF $LENGTH(APID(6)_ALIAS)>244
SET LVL6=1
SET LNGTH=244-$LENGTH(APID(6))
SET APID(6)=APID(6)_REP_$EXTRACT(ALIAS,1,LNGTH)
SET LNGTH=LNGTH+1
SET ALIAS=$EXTRACT(ALIAS,LNGTH,$LENGTH(ALIAS))
SET NXTC=1
End DoDot:3
+9 IF LVL6>0
Begin DoDot:3
+10 IF $LENGTH($GET(APID(6,LVL6))_ALIAS)'>245
SET APID(6,LVL6)=$GET(APID(6,LVL6))_$SELECT(NXTC=0:REP,1:"")_ALIAS
QUIT
+11 IF $LENGTH($GET(APID(6,LVL6))_ALIAS)>245
SET LNGTH=244-$LENGTH(APID(6,LVL6))
SET APID(6,LVL6)=APID(6,LVL6)_REP_$EXTRACT(ALIAS,1,LNGTH)
SET LNGTH=LNGTH+1
SET ALIAS=$EXTRACT(ALIAS,LNGTH,$LENGTH(ALIAS))
SET LVL6=LVL6+1
SET APID(6,LVL6)=ALIAS
End DoDot:3
+12 IF NXTC=1
SET NXTC=0
End DoDot:2
+13 IF APID(6)=""
SET APID(6)=HL("Q")
End DoDot:1
MOTHER ;mother's maiden name (last^first^middle^suffix^prefix^^"M" for maiden name)
+1 IF $DATA(SARY(6))!(SEQ="ALL")
Begin DoDot:1
+2 SET APID(7)=HL("Q")
+3 IF $DATA(^DPT(DFN,.24))
SET VAFCMMN=$PIECE(^DPT(DFN,.24),"^",3)
Begin DoDot:2
+4 SET APID(7)=$$HLNAME^XLFNAME(VAFCMMN,"",$EXTRACT(HL("ECH"),1))
IF APID(7)=""
SET APID(7)=HL("Q")
+5 IF $PIECE(APID(7),$EXTRACT(HL("ECH"),1),7)'="M"
SET $PIECE(APID(7),$EXTRACT(HL("ECH"),1),7)="M"
End DoDot:2
+6 IF APID(7)=""
SET APID(7)=HL("Q")
End DoDot:1
+7 ;date/time of birth
IF $DATA(SARY(7))!(SEQ="ALL")
SET APID(8)=$$HLDATE^HLFNC($PIECE(VAFCZN,"^",3))
IF APID(8)=""
SET APID(8)=HL("Q")
+8 ;sex
IF $DATA(SARY(8))!(SEQ="ALL")
SET APID(9)=$PIECE(VAFCZN,"^",2)
IF APID(9)=""
SET APID(9)=HL("Q")
+9 ;place of birth city and state
+10 ;split into 2 routines **707
+11 DO CONT^VAFCQRY3(DFN,.APID,.PID,.HL,HLES,.SARY,SEQ,.ERR,REP,COMP,SSN,VAFCMN)
+12 DO KVA^VADPT
+13 QUIT
HL7TXT(HL7STRG,HL,HLES) ; Replace occurrences of embedded HL7 delimiters with
+1 ; HL7 escape sequence
+2 ;
+3 ; Inputs: HL7STRG - Data string to be checked
+4 ; HL("ECH") - HL7 delimiter string
+5 ; Delimiters MUST be in the following order,
+6 ; Escape, Field, Component, Repeat, Subcomponent
+7 ; Example: \^~|&
+8 ;
+9 ; Output: HL7XTRG - Data string with escape sequence added (if needed)
+10 ;
+11 NEW OCHR,RCHR,RCHRI,TYPE,I,HLES2
+12 ;
+13 IF $GET(HL("COMP"))=""
SET HL("COMP")=$EXTRACT(HL("ECH"),1)
SET HL("REP")=$EXTRACT(HL("ECH"),2)
SET HL("SUBCOMP")=$EXTRACT(HL("ECH"),4)
+14 ; Set HL7 escape char
+15 SET HLES2=HLES_HL("FS")_HL("COMP")_HL("REP")_HL("SUBCOMP")
+16 ;
+17 ; Search for occurrence of each delimiter and replace it with "\<type>\"
+18 FOR TYPE="E","F","C","R","S"
Begin DoDot:1
+19 SET RCHRI=$SELECT(TYPE="E":1,TYPE="F":2,TYPE="C":3,TYPE="R":4,TYPE="S":5)
+20 ;
+21 ; OCHR=original char, RCHR=replacement char
+22 SET OCHR=$EXTRACT(HLES2,RCHRI)
SET RCHR=$EXTRACT("EFSRT",RCHRI)
IF '$FIND(HL7STRG,OCHR)
QUIT
+23 FOR I=1:1
IF $EXTRACT(HL7STRG,I)=""
QUIT
IF $EXTRACT(HL7STRG,I)=OCHR
SET HL7STRG=$EXTRACT(HL7STRG,1,I-1)_HLES_RCHR_HLES_$EXTRACT(HL7STRG,I+1,999)
SET I=I+2
End DoDot:1
+24 QUIT
+25 QUIT
