LA7VHLU9 ;VA/DALOI/JMC - HL7 segment builder utility ; 13-Aug-2013 09:09 ; MKK
;;5.2;AUTOMATED LAB INSTRUMENTS;**68,1033**;NOV 01, 1997
;
; Reference to NPI^XUSNPI supported by DBIA #4532
; Reference to QI^XUSNPI supported by DBIA #4532
;
;
XCN(LA7DUZ,LA7DIV,LA7FS,LA7ECH,LA7DMT,LA7IDTYP) ; Build composite ID and name for person
; Call with LA7DUZ = DUZ of person
; If not pointer to #200, then use as literal
; LA7DIV = Institution of user
; LA7FS = HL field separator
; LA7ECH = HL encoding characters
; LA7DMT = flag to indicate delimiters should be demoted
; LA7IDTYP = id type to return (0:DUZ 1:VPID 2:NPI)
;
N I,LA7CS,LA7NPI,LA7SITE,LA7VAF,LA7VPID,LA7X,LA7Y,LA7Z,NAME
;
S (LA7Y,LA7Z)="",LA7DMT=+$G(LA7DMT),LA7IDTYP=+$G(LA7IDTYP)
; If demoting delimiters then use sub-component delimiter instead of component delimiter.
S LA7CS=$E(LA7ECH,$S(LA7DMT=1:4,1:1))
;
; Check if this field has been built previously for this person
I LA7DUZ'="",$D(^TMP($J,"LA7VHLU","99VA200",LA7DUZ,LA7FS_LA7ECH,LA7DMT,LA7IDTYP)) S LA7Y=^TMP($J,"LA7VHLU","99VA200",LA7DUZ,LA7FS_LA7ECH,LA7DMT,LA7IDTYP)
;
; Build from file #200
I LA7Y="",LA7DUZ>0,LA7DUZ?1.N D
. S NAME("FILE")=200,NAME("FIELD")=.01,NAME("IENS")=LA7DUZ
. S LA7Z=$$HLNAME^XLFNAME(.NAME,"S",LA7CS)
. I LA7IDTYP=2 D Q:LA7NPI>0
. . S LA7NPI=$$NPI^XUSNPI("Individual_ID",LA7DUZ,DT)
. . I LA7NPI>0 S $P(LA7Y,LA7CS)=$P(LA7NPI,"^"),$P(LA7Y,LA7CS,9)="USDHHS",$P(LA7Y,LA7CS,11)=$E(LA7NPI,10),$P(LA7Y,LA7CS,12,13)="NPI"_LA7CS_"NPI"
. I LA7IDTYP>0 D Q:LA7VPID'=""
. . S LA7VPID=$$VPID^XUPS(LA7DUZ)
. . I LA7VPID'="" S $P(LA7Y,LA7CS)=LA7VPID,$P(LA7Y,LA7CS,9)="USVHA",$P(LA7Y,LA7CS,13)="PN"
. ; If no institution, use Kernel Site default
. I LA7DIV="" S LA7DIV=+$$KSP^XUPARAM("INST")
. S LA7SITE=$$RETFACID^LA7VHLU2(LA7DIV,0,1)
. I LA7SITE'="" D
. . S LA7VAF=$$GET1^DIQ(4,LA7DIV_",","AGENCY CODE","I")
. . I LA7VAF="V" S LA7SITE="VA"_LA7SITE
. . S LA7DUZ=LA7DUZ_"-"_LA7SITE,$P(LA7Y,LA7CS,8)="99VA4"
. S $P(LA7Y,LA7CS)=LA7DUZ
;
; If only name passed
I LA7Y="",'LA7DUZ D
. S NAME=LA7DUZ
. I LA7DUZ["[",LA7DUZ["]" D
. . S NAME=$P(LA7DUZ,"["),NAME(1)=$P(LA7DUZ,"[",2),NAME(1)=$P(NAME(1),"]")
. . I $P(NAME(1),":",2)?1(1"NPI",1"PN") S $P(LA7Y,LA7CS)=$P(NAME(1),":"),$P(LA7Y,LA7CS,9)=$P(NAME(1),":",4),$P(LA7Y,LA7CS,13)=$P(NAME(1),":",2)
. . I $P(NAME(1),":",2)?1(1"99"1.E,1"L") S $P(LA7Y,LA7CS)=$P(NAME(1),":"),$P(LA7Y,LA7CS,8)=$P(NAME(1),":",2)
. S NAME=$$CHKDATA^LA7VHLU3(NAME,LA7FS_LA7ECH)
. S LA7Z=$$HLNAME^XLFNAME(NAME,"S",LA7CS)
;
I LA7Z'="" F I=1:1:6 S $P(LA7Y,LA7CS,I+1)=$P(LA7Z,LA7CS,I)
;
; Save this field to TMP global to use for subsequent calls.
I LA7DUZ'="" S ^TMP($J,"LA7VHLU","99VA200",LA7DUZ,LA7FS_LA7ECH,LA7DMT,LA7IDTYP)=LA7Y
;
Q LA7Y
;
;
;
XCNTFM(LA7X,LA7ECH) ; Resolve XCN data type to FileMan (last name, first name, mi [id])
; Call with LA7X = HL7 field containing name
; LA7ECH = HL7 encoding characters
;
; Returns LA7Y = ID code^DUZ^FileMan name (DUZ=0 if name not found on local system).
;
N LA7DUZ,LA7IDC,LA7Y,LA7Z,X
;
;
S LA7DUZ=0
;
; Check for VPID
S (LA7IDC,LA7Z)=$P(LA7X,$E(LA7ECH))
I $P(LA7X,$E(LA7ECH),9)="USVHA",$P(LA7X,$E(LA7ECH),13)="PN" D
. S X=$$IEN^XUPS(LA7IDC)
. I X>0 S LA7DUZ=X
;
; Check for NPI
I $P(LA7X,$E(LA7ECH),9)="USDHHS",$P(LA7X,$E(LA7ECH),13)="NPI" D
. S X=$$QI^XUSNPI(LA7IDC)
. I $P(X,"^")="Individual_ID",$P(X,"^",2)>0 S LA7DUZ=X
;
; Check for coding that indicates DUZ from a VA facility
I 'LA7DUZ,LA7Z?.(1.N1"-VA"3N,1.N1"-VA"3N2U) D
. N LA7J,LA7K
. S LA7Z(1)=$P(LA7Z,"-"),LA7Z(2)=$P(LA7Z,"-",2)
. S LA7K=$$FINDSITE^LA7VHLU2(LA7Z(2),1,1)
. S LA7J=$$DIV4^XUSER(.LA7J,LA7Z(1))
. I LA7K,$D(LA7J(LA7K)) S LA7DUZ=LA7Z(1)
;
; Check if code resolves to a valid user.
I 'LA7DUZ,LA7Z=+LA7Z D
. S X=$$ACTIVE^XUSER(LA7Z)
. I X,$P(X,"^",2)'="" S LA7DUZ=LA7Z
;
S LA7Y=$$FMNAME^HLFNC($P(LA7X,$E(LA7ECH),2,6),LA7ECH)
; HL function sometimes returns trailing "," on name
S LA7Y=$$TRIM^XLFSTR(LA7Y,"R",",")
;
; Put identifying code at end of name in "[code:id type:va id type:issuing authority]".
I $P(LA7X,$E(LA7ECH))'="",LA7Y'="" D
. S X=""
. I $P(LA7X,$E(LA7ECH),8)?1(1"99"1.E,1"L") S X=$P(LA7X,$E(LA7ECH),8)
. I $P(LA7X,$E(LA7ECH),9)="USVHA",$P(LA7X,$E(LA7ECH),13)="PN" S X="PN:VPID:USVHA"
. I $P(LA7X,$E(LA7ECH),9)="USDHHS",$P(LA7X,$E(LA7ECH),13)="NPI" S X="NPI:NPI:USDHHS"
. S LA7Y=LA7Y_" ["_$P(LA7X,$E(LA7ECH))_":"_X_"]"
;
Q LA7IDC_"^"_LA7DUZ_"^"_LA7Y
LA7VHLU9 ;VA/DALOI/JMC - HL7 segment builder utility ; 13-Aug-2013 09:09 ; MKK
+1 ;;5.2;AUTOMATED LAB INSTRUMENTS;**68,1033**;NOV 01, 1997
+2 ;
+3 ; Reference to NPI^XUSNPI supported by DBIA #4532
+4 ; Reference to QI^XUSNPI supported by DBIA #4532
+5 ;
+6 ;
XCN(LA7DUZ,LA7DIV,LA7FS,LA7ECH,LA7DMT,LA7IDTYP) ; Build composite ID and name for person
+1 ; Call with LA7DUZ = DUZ of person
+2 ; If not pointer to #200, then use as literal
+3 ; LA7DIV = Institution of user
+4 ; LA7FS = HL field separator
+5 ; LA7ECH = HL encoding characters
+6 ; LA7DMT = flag to indicate delimiters should be demoted
+7 ; LA7IDTYP = id type to return (0:DUZ 1:VPID 2:NPI)
+8 ;
+9 NEW I,LA7CS,LA7NPI,LA7SITE,LA7VAF,LA7VPID,LA7X,LA7Y,LA7Z,NAME
+10 ;
+11 SET (LA7Y,LA7Z)=""
SET LA7DMT=+$GET(LA7DMT)
SET LA7IDTYP=+$GET(LA7IDTYP)
+12 ; If demoting delimiters then use sub-component delimiter instead of component delimiter.
+13 SET LA7CS=$EXTRACT(LA7ECH,$SELECT(LA7DMT=1:4,1:1))
+14 ;
+15 ; Check if this field has been built previously for this person
+16 IF LA7DUZ'=""
IF $DATA(^TMP($JOB,"LA7VHLU","99VA200",LA7DUZ,LA7FS_LA7ECH,LA7DMT,LA7IDTYP))
SET LA7Y=^TMP($JOB,"LA7VHLU","99VA200",LA7DUZ,LA7FS_LA7ECH,LA7DMT,LA7IDTYP)
+17 ;
+18 ; Build from file #200
+19 IF LA7Y=""
IF LA7DUZ>0
IF LA7DUZ?1.N
Begin DoDot:1
+20 SET NAME("FILE")=200
SET NAME("FIELD")=.01
SET NAME("IENS")=LA7DUZ
+21 SET LA7Z=$$HLNAME^XLFNAME(.NAME,"S",LA7CS)
+22 IF LA7IDTYP=2
Begin DoDot:2
+23 SET LA7NPI=$$NPI^XUSNPI("Individual_ID",LA7DUZ,DT)
+24 IF LA7NPI>0
SET $PIECE(LA7Y,LA7CS)=$PIECE(LA7NPI,"^")
SET $PIECE(LA7Y,LA7CS,9)="USDHHS"
SET $PIECE(LA7Y,LA7CS,11)=$EXTRACT(LA7NPI,10)
SET $PIECE(LA7Y,LA7CS,12,13)="NPI"_LA7CS_"NPI"
End DoDot:2
IF LA7NPI>0
QUIT
+25 IF LA7IDTYP>0
Begin DoDot:2
+26 SET LA7VPID=$$VPID^XUPS(LA7DUZ)
+27 IF LA7VPID'=""
SET $PIECE(LA7Y,LA7CS)=LA7VPID
SET $PIECE(LA7Y,LA7CS,9)="USVHA"
SET $PIECE(LA7Y,LA7CS,13)="PN"
End DoDot:2
IF LA7VPID'=""
QUIT
+28 ; If no institution, use Kernel Site default
+29 IF LA7DIV=""
SET LA7DIV=+$$KSP^XUPARAM("INST")
+30 SET LA7SITE=$$RETFACID^LA7VHLU2(LA7DIV,0,1)
+31 IF LA7SITE'=""
Begin DoDot:2
+32 SET LA7VAF=$$GET1^DIQ(4,LA7DIV_",","AGENCY CODE","I")
+33 IF LA7VAF="V"
SET LA7SITE="VA"_LA7SITE
+34 SET LA7DUZ=LA7DUZ_"-"_LA7SITE
SET $PIECE(LA7Y,LA7CS,8)="99VA4"
End DoDot:2
+35 SET $PIECE(LA7Y,LA7CS)=LA7DUZ
End DoDot:1
+36 ;
+37 ; If only name passed
+38 IF LA7Y=""
IF 'LA7DUZ
Begin DoDot:1
+39 SET NAME=LA7DUZ
+40 IF LA7DUZ["["
IF LA7DUZ["]"
Begin DoDot:2
+41 SET NAME=$PIECE(LA7DUZ,"[")
SET NAME(1)=$PIECE(LA7DUZ,"[",2)
SET NAME(1)=$PIECE(NAME(1),"]")
+42 IF $PIECE(NAME(1),":",2)?1(1"NPI",1"PN")
SET $PIECE(LA7Y,LA7CS)=$PIECE(NAME(1),":")
SET $PIECE(LA7Y,LA7CS,9)=$PIECE(NAME(1),":",4)
SET $PIECE(LA7Y,LA7CS,13)=$PIECE(NAME(1),":",2)
+43 IF $PIECE(NAME(1),":",2)?1(1"99"1.E,1"L")
SET $PIECE(LA7Y,LA7CS)=$PIECE(NAME(1),":")
SET $PIECE(LA7Y,LA7CS,8)=$PIECE(NAME(1),":",2)
End DoDot:2
+44 SET NAME=$$CHKDATA^LA7VHLU3(NAME,LA7FS_LA7ECH)
+45 SET LA7Z=$$HLNAME^XLFNAME(NAME,"S",LA7CS)
End DoDot:1
+46 ;
+47 IF LA7Z'=""
FOR I=1:1:6
SET $PIECE(LA7Y,LA7CS,I+1)=$PIECE(LA7Z,LA7CS,I)
+48 ;
+49 ; Save this field to TMP global to use for subsequent calls.
+50 IF LA7DUZ'=""
SET ^TMP($JOB,"LA7VHLU","99VA200",LA7DUZ,LA7FS_LA7ECH,LA7DMT,LA7IDTYP)=LA7Y
+51 ;
+52 QUIT LA7Y
+53 ;
+54 ;
+55 ;
XCNTFM(LA7X,LA7ECH) ; Resolve XCN data type to FileMan (last name, first name, mi [id])
+1 ; Call with LA7X = HL7 field containing name
+2 ; LA7ECH = HL7 encoding characters
+3 ;
+4 ; Returns LA7Y = ID code^DUZ^FileMan name (DUZ=0 if name not found on local system).
+5 ;
+6 NEW LA7DUZ,LA7IDC,LA7Y,LA7Z,X
+7 ;
+8 ;
+9 SET LA7DUZ=0
+10 ;
+11 ; Check for VPID
+12 SET (LA7IDC,LA7Z)=$PIECE(LA7X,$EXTRACT(LA7ECH))
+13 IF $PIECE(LA7X,$EXTRACT(LA7ECH),9)="USVHA"
IF $PIECE(LA7X,$EXTRACT(LA7ECH),13)="PN"
Begin DoDot:1
+14 SET X=$$IEN^XUPS(LA7IDC)
+15 IF X>0
SET LA7DUZ=X
End DoDot:1
+16 ;
+17 ; Check for NPI
+18 IF $PIECE(LA7X,$EXTRACT(LA7ECH),9)="USDHHS"
IF $PIECE(LA7X,$EXTRACT(LA7ECH),13)="NPI"
Begin DoDot:1
+19 SET X=$$QI^XUSNPI(LA7IDC)
+20 IF $PIECE(X,"^")="Individual_ID"
IF $PIECE(X,"^",2)>0
SET LA7DUZ=X
End DoDot:1
+21 ;
+22 ; Check for coding that indicates DUZ from a VA facility
+23 IF 'LA7DUZ
IF LA7Z?.(1.N1"-VA"3N,1.N1"-VA"3N2U)
Begin DoDot:1
+24 NEW LA7J,LA7K
+25 SET LA7Z(1)=$PIECE(LA7Z,"-")
SET LA7Z(2)=$PIECE(LA7Z,"-",2)
+26 SET LA7K=$$FINDSITE^LA7VHLU2(LA7Z(2),1,1)
+27 SET LA7J=$$DIV4^XUSER(.LA7J,LA7Z(1))
+28 IF LA7K
IF $DATA(LA7J(LA7K))
SET LA7DUZ=LA7Z(1)
End DoDot:1
+29 ;
+30 ; Check if code resolves to a valid user.
+31 IF 'LA7DUZ
IF LA7Z=+LA7Z
Begin DoDot:1
+32 SET X=$$ACTIVE^XUSER(LA7Z)
+33 IF X
IF $PIECE(X,"^",2)'=""
SET LA7DUZ=LA7Z
End DoDot:1
+34 ;
+35 SET LA7Y=$$FMNAME^HLFNC($PIECE(LA7X,$EXTRACT(LA7ECH),2,6),LA7ECH)
+36 ; HL function sometimes returns trailing "," on name
+37 SET LA7Y=$$TRIM^XLFSTR(LA7Y,"R",",")
+38 ;
+39 ; Put identifying code at end of name in "[code:id type:va id type:issuing authority]".
+40 IF $PIECE(LA7X,$EXTRACT(LA7ECH))'=""
IF LA7Y'=""
Begin DoDot:1
+41 SET X=""
+42 IF $PIECE(LA7X,$EXTRACT(LA7ECH),8)?1(1"99"1.E,1"L")
SET X=$PIECE(LA7X,$EXTRACT(LA7ECH),8)
+43 IF $PIECE(LA7X,$EXTRACT(LA7ECH),9)="USVHA"
IF $PIECE(LA7X,$EXTRACT(LA7ECH),13)="PN"
SET X="PN:VPID:USVHA"
+44 IF $PIECE(LA7X,$EXTRACT(LA7ECH),9)="USDHHS"
IF $PIECE(LA7X,$EXTRACT(LA7ECH),13)="NPI"
SET X="NPI:NPI:USDHHS"
+45 SET LA7Y=LA7Y_" ["_$PIECE(LA7X,$EXTRACT(LA7ECH))_":"_X_"]"
End DoDot:1
+46 ;
+47 QUIT LA7IDC_"^"_LA7DUZ_"^"_LA7Y
