LA7VHLU4 ;DALOI/JMC - HL7 segment builder utility ;03/15/11 12:28
;;5.2;AUTOMATED LAB INSTRUMENTS;**46,64,68,74**;Sep 27, 1994;Build 229
;
;
INST(LA74,LA7FS,LA7ECH) ; Build institution field
; Call with LA74 = ien of institution in file #4
; if null/undefined then use Kernel Site file.
; LA7FS = HL field separator
; LA7ECH = HL encoding characters
;
; Returns facility that performed the testing (ID^text^99VA4)
;
N LA7NVAF,LA7X,LA7Y,LA7Z
;
S LA74=$G(LA74),LA7ECH=$G(LA7ECH),LA7Y=""
;
; If no institution, use Kernel Site default
I LA74="" S LA74=+$$KSP^XUPARAM("INST")
;
; Check if this field has been built previously for this institution
I LA74'="",$D(^TMP($J,"LA7VHLU","99VA4",LA74,LA7FS_LA7ECH)) S LA7Y=^TMP($J,"LA7VHLU","99VA4",LA74,LA7FS_LA7ECH)
;
; Value passed not a pointer - only build 2nd component
I LA7Y="",LA74'="",LA74'=+LA74 D
. S $P(LA7Y,$E(LA7ECH,1),2)=$$CHKDATA^LA7VHLU3(LA74,LA7FS_LA7ECH)
;
I LA7Y="",LA74>0,LA74=+LA74 D
. S LA7NVAF=$$NVAF^LA7VHLU2(LA74)
. ; Build id - VA station #/DMIS code/IHS ASUFAC
. I LA7NVAF<3 S LA7Y=$$ID^XUAF4($S(LA7NVAF=1:"DMIS",LA7NVAF=2:"ASUFAC",1:"VASTANUM"),LA74)
. ; Build name using field #100, otherwise #.01
. S LA7Z=$$NAME^XUAF4(LA74)
. S $P(LA7Y,$E(LA7ECH,1),2)=$$CHKDATA^LA7VHLU3(LA7Z,LA7FS_LA7ECH)
. ;
. S $P(LA7Y,$E(LA7ECH,1),3)="99VA4"
;
; Save this field to TMP global to use for subsequent calls.
S ^TMP($J,"LA7VHLU","99VA4",LA74,LA7FS_LA7ECH)=LA7Y
;
Q LA7Y
;
;
XAD(LA7FN,LA7DA,LA7DT,LA7FS,LA7ECH) ; Build extended address
; Call with LA7FN = Source File number
; Presently file #2 (PATIENT), #4 (INSTITUTION) or #200 (NEW PERSON)
; LA7DA = Entry in source file
; LA7DT = As of date in FileMan format
; LA7FS = HL field separator
; LA7ECH = HL encoding characters
;
; Returns extended address
;
N I,LA7X,LA7Y,LA7Z
S LA7Y=""
; Check if this field has been built previously for this institution
I LA7FN,LA7DA,$D(^TMP($J,"LA7VHLU","99VA4A",LA7FN,LA7DA,LA7FS_LA7ECH)) S LA7Y=^TMP($J,"LA7VHLU","99VA4A",LA7FN,LA7DA,LA7FS_LA7ECH)
;
; Build from file #2
I LA7Y="",LA7FN=2,LA7DA D
. N DFN,VAHOW,VAPA,VAERR,VAROOT,VATEST
. S DFN=LA7DA
. I LA7DT S (VATEST("ADD",9),VATEST("ADD",10))=LA7DT
. D ADD^VADPT
. I VAERR Q
. S $P(LA7Y,$E(LA7ECH),1)=$$CHKDATA^LA7VHLU3(VAPA(1),LA7FS_LA7ECH)
. S $P(LA7Y,$E(LA7ECH),2)=$$CHKDATA^LA7VHLU3(VAPA(2),LA7FS_LA7ECH)
. S $P(LA7Y,$E(LA7ECH),3)=$$CHKDATA^LA7VHLU3(VAPA(4),LA7FS_LA7ECH)
. S $P(LA7Y,$E(LA7ECH),4)=$$CHKDATA^LA7VHLU3($P(VAPA(5),"^",2),LA7FS_LA7ECH)
. S $P(LA7Y,$E(LA7ECH),5)=$$CHKDATA^LA7VHLU3(VAPA(11),LA7FS_LA7ECH)
. I VAPA(9) S $P(LA7Y,$E(LA7ECH),7)="C"
. E S $P(LA7Y,$E(LA7ECH),7)="P"
. S $P(LA7Y,$E(LA7ECH),9)=$$CHKDATA^LA7VHLU3($P(VAPA(7),"^",2),LA7FS_LA7ECH)
;
; Get address info from file #4, add 2nd address line
; change state to pointer to file #5
I LA7Y="",LA7FN=4,LA7DA D
. S LA7Z=$$PADD^XUAF4(LA7DA)
. S LA7X=$P(LA7Z,"^"),$P(LA7X,"^",2)=$$WHAT^XUAF4(LA7DA,1.02)
. F I=1,2 I $P(LA7X,"^",I)'="" S $P(LA7X,"^",I)=$$CHKDATA^LA7VHLU3($P(LA7X,"^",I),LA7FS_LA7ECH)
. S LA7Z=$P(LA7Z,"^",2,4),$P(LA7Z,"^",2)=$$GET1^DIQ(4,LA7DA_",",.02,"I")
. S $P(LA7Z,"^")=$$CHKDATA^LA7VHLU3($P(LA7Z,"^"),LA7FS_LA7ECH)
. S LA7Y=$$HLADDR^HLFNC(LA7X,LA7Z,LA7ECH)
;
I LA7Y="",LA7FN=200,LA7DA D
. Q
;
; Save this field to TMP global to use for subsequent calls.
I LA7Y'="" S ^TMP($J,"LA7VHLU","99VA4A",LA7FN,LA7DA,LA7FS_LA7ECH)=LA7Y
;
Q LA7Y
;
;
XON(LA7FN,LA7DA,LA7TYP,LA7FS,LA7ECH) ; Build extended composite name/id for organization
; Call with LA7FN = Source File number - presently #4 (INSTITUTION)
; LA7DA = Entry in source file
; LA7TYP = type of identifier (0/null=station #, 1=CLIA)
; LA7FS = HL field separator
; LA7ECH = HL encoding characters
;
;
N LA7X,LA7Y,LA7Z
;
S LA7Y="",LA7TYP=+$G(LA7TYP)
;
; Check if this field has been built previously for this institution
I LA7FN,LA7DA,$D(^TMP($J,"LA7VHLU","99VA4N",LA7FN,LA7DA,LA7TYP,LA7FS_LA7ECH)) S LA7Y=^TMP($J,"LA7VHLU","99VA4N",LA7FN,LA7DA,LA7TYP,LA7FS_LA7ECH)
;
; Build name using field #100, otherwise #.01
; Send facility id in 3rd component if numeric - conform to standard.
I LA7Y="",LA7FN=4,LA7DA D
. S LA7Z(1)=$P($$NS^XUAF4(LA7DA),"^"),LA7Z(2)=$$WHAT^XUAF4(LA7DA,100)
. S $P(LA7Y,$E(LA7ECH,1),1)=$$CHKDATA^LA7VHLU3(LA7Z(1),LA7FS_LA7ECH)
. S $P(LA7Y,$E(LA7ECH,1),2)="D"
. S LA7X=$$RETFACID^LA7VHLU2(LA7DA,2,1)
. I LA7X'="" D
. . I LA7X?1.N S $P(LA7Y,$E(LA7ECH,1),3)=LA7X
. . S $P(LA7Y,$E(LA7ECH,1),10)=LA7X
. S $P(LA7Y,$E(LA7ECH,1),6)="USVHA"
. S $P(LA7Y,$E(LA7ECH,1),7)="FI"
. S $P(LA7Y,$E(LA7ECH,1),9)="A"
. I LA7Z(2)'="" D
. . S $P(LA7Y,$E(LA7ECH,1),1)=$$CHKDATA^LA7VHLU3(LA7Z(2),LA7FS_LA7ECH)
. . S $P(LA7Y,$E(LA7ECH,1),2)="L"
. I LA7TYP=1 D
. . S LA7X=$$ID^XUAF4("CLIA",LA7DA) Q:LA7X=""
. . S $P(LA7Y,$E(LA7ECH,1),3)=""
. . S $P(LA7Y,$E(LA7ECH,1),6)="CLIA"
. . S $P(LA7Y,$E(LA7ECH,1),7)="LN"
. . S $P(LA7Y,$E(LA7ECH,1),10)=LA7X
;
; Save this field to TMP global to use for subsequent calls.
I LA7Y'="" S ^TMP($J,"LA7VHLU","99VA4N",LA7FN,LA7DA,LA7TYP,LA7FS_LA7ECH)=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).
; Stub until all calls can be converted to call XCNTFM^LA7VHLU9
;
Q $$XCNTFM^LA7VHLU9(LA7X,LA7ECH)
;
;
PLTFM(LA7PL,LA7FS,LA7ECH) ; Resolve location from PL (person location) data type.
; Call with LA7PL = HL7 field containing person location
; LA7FS = HL field separator
; LA7ECH = HL7 encoding characters
;
; Returns LA7Y = file #44 ien^name field (#.01)^division(institution)
;
N LA7X,LA7Y,X,Y
S LA7X=$P(LA7PL,$E(LA7ECH)),(LA7Y,Y)=""
I LA7X?1.N S Y=$$GET1^DIQ(44,LA7X_",",.01)
;
; Check and unescape if needed
S LA7X=$$UNESC^LA7VHLU3(LA7X,LA7FS_LA7ECH)
;
; If not ien try as name
I Y="" D
. S X=$$FIND1^DIC(44,"","X",LA7X,"B^C")
. I X S Y=LA7X,LA7X=X
I Y'="" S LA7Y=LA7X_"^"_Y
E I $P(LA7PL,$E(LA7ECH),2)'="" S LA7Y="^"_$$UNESC^LA7VHLU3($P(LA7PL,$E(LA7ECH),2),LA7FS_LA7ECH)
;
; Process division (institution) - pass 1st sub-component of 4th component
S LA7X=$P(LA7PL,$E(LA7ECH),4)
S LA7X=$P(LA7X,$E(LA7ECH,4))
S LA7X=$$UNESC^LA7VHLU3(LA7X,LA7FS_LA7ECH)
S Y=""
I LA7X'="" S Y=$$FINDSITE^LA7VHLU2(LA7X,1,1)
S $P(LA7Y,"^",3)=Y
;
Q LA7Y
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLA7VHLU4 6747 printed Sep 23, 2025@19:16:11 Page 2
LA7VHLU4 ;DALOI/JMC - HL7 segment builder utility ;03/15/11 12:28
+1 ;;5.2;AUTOMATED LAB INSTRUMENTS;**46,64,68,74**;Sep 27, 1994;Build 229
+2 ;
+3 ;
INST(LA74,LA7FS,LA7ECH) ; Build institution field
+1 ; Call with LA74 = ien of institution in file #4
+2 ; if null/undefined then use Kernel Site file.
+3 ; LA7FS = HL field separator
+4 ; LA7ECH = HL encoding characters
+5 ;
+6 ; Returns facility that performed the testing (ID^text^99VA4)
+7 ;
+8 NEW LA7NVAF,LA7X,LA7Y,LA7Z
+9 ;
+10 SET LA74=$GET(LA74)
SET LA7ECH=$GET(LA7ECH)
SET LA7Y=""
+11 ;
+12 ; If no institution, use Kernel Site default
+13 IF LA74=""
SET LA74=+$$KSP^XUPARAM("INST")
+14 ;
+15 ; Check if this field has been built previously for this institution
+16 IF LA74'=""
IF $DATA(^TMP($JOB,"LA7VHLU","99VA4",LA74,LA7FS_LA7ECH))
SET LA7Y=^TMP($JOB,"LA7VHLU","99VA4",LA74,LA7FS_LA7ECH)
+17 ;
+18 ; Value passed not a pointer - only build 2nd component
+19 IF LA7Y=""
IF LA74'=""
IF LA74'=+LA74
Begin DoDot:1
+20 SET $PIECE(LA7Y,$EXTRACT(LA7ECH,1),2)=$$CHKDATA^LA7VHLU3(LA74,LA7FS_LA7ECH)
End DoDot:1
+21 ;
+22 IF LA7Y=""
IF LA74>0
IF LA74=+LA74
Begin DoDot:1
+23 SET LA7NVAF=$$NVAF^LA7VHLU2(LA74)
+24 ; Build id - VA station #/DMIS code/IHS ASUFAC
+25 IF LA7NVAF<3
SET LA7Y=$$ID^XUAF4($SELECT(LA7NVAF=1:"DMIS",LA7NVAF=2:"ASUFAC",1:"VASTANUM"),LA74)
+26 ; Build name using field #100, otherwise #.01
+27 SET LA7Z=$$NAME^XUAF4(LA74)
+28 SET $PIECE(LA7Y,$EXTRACT(LA7ECH,1),2)=$$CHKDATA^LA7VHLU3(LA7Z,LA7FS_LA7ECH)
+29 ;
+30 SET $PIECE(LA7Y,$EXTRACT(LA7ECH,1),3)="99VA4"
End DoDot:1
+31 ;
+32 ; Save this field to TMP global to use for subsequent calls.
+33 SET ^TMP($JOB,"LA7VHLU","99VA4",LA74,LA7FS_LA7ECH)=LA7Y
+34 ;
+35 QUIT LA7Y
+36 ;
+37 ;
XAD(LA7FN,LA7DA,LA7DT,LA7FS,LA7ECH) ; Build extended address
+1 ; Call with LA7FN = Source File number
+2 ; Presently file #2 (PATIENT), #4 (INSTITUTION) or #200 (NEW PERSON)
+3 ; LA7DA = Entry in source file
+4 ; LA7DT = As of date in FileMan format
+5 ; LA7FS = HL field separator
+6 ; LA7ECH = HL encoding characters
+7 ;
+8 ; Returns extended address
+9 ;
+10 NEW I,LA7X,LA7Y,LA7Z
+11 SET LA7Y=""
+12 ; Check if this field has been built previously for this institution
+13 IF LA7FN
IF LA7DA
IF $DATA(^TMP($JOB,"LA7VHLU","99VA4A",LA7FN,LA7DA,LA7FS_LA7ECH))
SET LA7Y=^TMP($JOB,"LA7VHLU","99VA4A",LA7FN,LA7DA,LA7FS_LA7ECH)
+14 ;
+15 ; Build from file #2
+16 IF LA7Y=""
IF LA7FN=2
IF LA7DA
Begin DoDot:1
+17 NEW DFN,VAHOW,VAPA,VAERR,VAROOT,VATEST
+18 SET DFN=LA7DA
+19 IF LA7DT
SET (VATEST("ADD",9),VATEST("ADD",10))=LA7DT
+20 DO ADD^VADPT
+21 IF VAERR
QUIT
+22 SET $PIECE(LA7Y,$EXTRACT(LA7ECH),1)=$$CHKDATA^LA7VHLU3(VAPA(1),LA7FS_LA7ECH)
+23 SET $PIECE(LA7Y,$EXTRACT(LA7ECH),2)=$$CHKDATA^LA7VHLU3(VAPA(2),LA7FS_LA7ECH)
+24 SET $PIECE(LA7Y,$EXTRACT(LA7ECH),3)=$$CHKDATA^LA7VHLU3(VAPA(4),LA7FS_LA7ECH)
+25 SET $PIECE(LA7Y,$EXTRACT(LA7ECH),4)=$$CHKDATA^LA7VHLU3($PIECE(VAPA(5),"^",2),LA7FS_LA7ECH)
+26 SET $PIECE(LA7Y,$EXTRACT(LA7ECH),5)=$$CHKDATA^LA7VHLU3(VAPA(11),LA7FS_LA7ECH)
+27 IF VAPA(9)
SET $PIECE(LA7Y,$EXTRACT(LA7ECH),7)="C"
+28 IF '$TEST
SET $PIECE(LA7Y,$EXTRACT(LA7ECH),7)="P"
+29 SET $PIECE(LA7Y,$EXTRACT(LA7ECH),9)=$$CHKDATA^LA7VHLU3($PIECE(VAPA(7),"^",2),LA7FS_LA7ECH)
End DoDot:1
+30 ;
+31 ; Get address info from file #4, add 2nd address line
+32 ; change state to pointer to file #5
+33 IF LA7Y=""
IF LA7FN=4
IF LA7DA
Begin DoDot:1
+34 SET LA7Z=$$PADD^XUAF4(LA7DA)
+35 SET LA7X=$PIECE(LA7Z,"^")
SET $PIECE(LA7X,"^",2)=$$WHAT^XUAF4(LA7DA,1.02)
+36 FOR I=1,2
IF $PIECE(LA7X,"^",I)'=""
SET $PIECE(LA7X,"^",I)=$$CHKDATA^LA7VHLU3($PIECE(LA7X,"^",I),LA7FS_LA7ECH)
+37 SET LA7Z=$PIECE(LA7Z,"^",2,4)
SET $PIECE(LA7Z,"^",2)=$$GET1^DIQ(4,LA7DA_",",.02,"I")
+38 SET $PIECE(LA7Z,"^")=$$CHKDATA^LA7VHLU3($PIECE(LA7Z,"^"),LA7FS_LA7ECH)
+39 SET LA7Y=$$HLADDR^HLFNC(LA7X,LA7Z,LA7ECH)
End DoDot:1
+40 ;
+41 IF LA7Y=""
IF LA7FN=200
IF LA7DA
Begin DoDot:1
+42 QUIT
End DoDot:1
+43 ;
+44 ; Save this field to TMP global to use for subsequent calls.
+45 IF LA7Y'=""
SET ^TMP($JOB,"LA7VHLU","99VA4A",LA7FN,LA7DA,LA7FS_LA7ECH)=LA7Y
+46 ;
+47 QUIT LA7Y
+48 ;
+49 ;
XON(LA7FN,LA7DA,LA7TYP,LA7FS,LA7ECH) ; Build extended composite name/id for organization
+1 ; Call with LA7FN = Source File number - presently #4 (INSTITUTION)
+2 ; LA7DA = Entry in source file
+3 ; LA7TYP = type of identifier (0/null=station #, 1=CLIA)
+4 ; LA7FS = HL field separator
+5 ; LA7ECH = HL encoding characters
+6 ;
+7 ;
+8 NEW LA7X,LA7Y,LA7Z
+9 ;
+10 SET LA7Y=""
SET LA7TYP=+$GET(LA7TYP)
+11 ;
+12 ; Check if this field has been built previously for this institution
+13 IF LA7FN
IF LA7DA
IF $DATA(^TMP($JOB,"LA7VHLU","99VA4N",LA7FN,LA7DA,LA7TYP,LA7FS_LA7ECH))
SET LA7Y=^TMP($JOB,"LA7VHLU","99VA4N",LA7FN,LA7DA,LA7TYP,LA7FS_LA7ECH)
+14 ;
+15 ; Build name using field #100, otherwise #.01
+16 ; Send facility id in 3rd component if numeric - conform to standard.
+17 IF LA7Y=""
IF LA7FN=4
IF LA7DA
Begin DoDot:1
+18 SET LA7Z(1)=$PIECE($$NS^XUAF4(LA7DA),"^")
SET LA7Z(2)=$$WHAT^XUAF4(LA7DA,100)
+19 SET $PIECE(LA7Y,$EXTRACT(LA7ECH,1),1)=$$CHKDATA^LA7VHLU3(LA7Z(1),LA7FS_LA7ECH)
+20 SET $PIECE(LA7Y,$EXTRACT(LA7ECH,1),2)="D"
+21 SET LA7X=$$RETFACID^LA7VHLU2(LA7DA,2,1)
+22 IF LA7X'=""
Begin DoDot:2
+23 IF LA7X?1.N
SET $PIECE(LA7Y,$EXTRACT(LA7ECH,1),3)=LA7X
+24 SET $PIECE(LA7Y,$EXTRACT(LA7ECH,1),10)=LA7X
End DoDot:2
+25 SET $PIECE(LA7Y,$EXTRACT(LA7ECH,1),6)="USVHA"
+26 SET $PIECE(LA7Y,$EXTRACT(LA7ECH,1),7)="FI"
+27 SET $PIECE(LA7Y,$EXTRACT(LA7ECH,1),9)="A"
+28 IF LA7Z(2)'=""
Begin DoDot:2
+29 SET $PIECE(LA7Y,$EXTRACT(LA7ECH,1),1)=$$CHKDATA^LA7VHLU3(LA7Z(2),LA7FS_LA7ECH)
+30 SET $PIECE(LA7Y,$EXTRACT(LA7ECH,1),2)="L"
End DoDot:2
+31 IF LA7TYP=1
Begin DoDot:2
+32 SET LA7X=$$ID^XUAF4("CLIA",LA7DA)
if LA7X=""
QUIT
+33 SET $PIECE(LA7Y,$EXTRACT(LA7ECH,1),3)=""
+34 SET $PIECE(LA7Y,$EXTRACT(LA7ECH,1),6)="CLIA"
+35 SET $PIECE(LA7Y,$EXTRACT(LA7ECH,1),7)="LN"
+36 SET $PIECE(LA7Y,$EXTRACT(LA7ECH,1),10)=LA7X
End DoDot:2
End DoDot:1
+37 ;
+38 ; Save this field to TMP global to use for subsequent calls.
+39 IF LA7Y'=""
SET ^TMP($JOB,"LA7VHLU","99VA4N",LA7FN,LA7DA,LA7TYP,LA7FS_LA7ECH)=LA7Y
+40 ;
+41 QUIT LA7Y
+42 ;
+43 ;
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 ; Stub until all calls can be converted to call XCNTFM^LA7VHLU9
+6 ;
+7 QUIT $$XCNTFM^LA7VHLU9(LA7X,LA7ECH)
+8 ;
+9 ;
PLTFM(LA7PL,LA7FS,LA7ECH) ; Resolve location from PL (person location) data type.
+1 ; Call with LA7PL = HL7 field containing person location
+2 ; LA7FS = HL field separator
+3 ; LA7ECH = HL7 encoding characters
+4 ;
+5 ; Returns LA7Y = file #44 ien^name field (#.01)^division(institution)
+6 ;
+7 NEW LA7X,LA7Y,X,Y
+8 SET LA7X=$PIECE(LA7PL,$EXTRACT(LA7ECH))
SET (LA7Y,Y)=""
+9 IF LA7X?1.N
SET Y=$$GET1^DIQ(44,LA7X_",",.01)
+10 ;
+11 ; Check and unescape if needed
+12 SET LA7X=$$UNESC^LA7VHLU3(LA7X,LA7FS_LA7ECH)
+13 ;
+14 ; If not ien try as name
+15 IF Y=""
Begin DoDot:1
+16 SET X=$$FIND1^DIC(44,"","X",LA7X,"B^C")
+17 IF X
SET Y=LA7X
SET LA7X=X
End DoDot:1
+18 IF Y'=""
SET LA7Y=LA7X_"^"_Y
+19 IF '$TEST
IF $PIECE(LA7PL,$EXTRACT(LA7ECH),2)'=""
SET LA7Y="^"_$$UNESC^LA7VHLU3($PIECE(LA7PL,$EXTRACT(LA7ECH),2),LA7FS_LA7ECH)
+20 ;
+21 ; Process division (institution) - pass 1st sub-component of 4th component
+22 SET LA7X=$PIECE(LA7PL,$EXTRACT(LA7ECH),4)
+23 SET LA7X=$PIECE(LA7X,$EXTRACT(LA7ECH,4))
+24 SET LA7X=$$UNESC^LA7VHLU3(LA7X,LA7FS_LA7ECH)
+25 SET Y=""
+26 IF LA7X'=""
SET Y=$$FINDSITE^LA7VHLU2(LA7X,1,1)
+27 SET $PIECE(LA7Y,"^",3)=Y
+28 ;
+29 QUIT LA7Y
