LA7VHLU2 ;DALOI/JMC - HL7 Segment Utility ;July 16, 2008
;;5.2;AUTOMATED LAB INSTRUMENTS;**46,61,64,68,74**;Sep 27, 1994;Build 229
;
Q
;
GETSEG(LA76249,LA7NODE,LA7ARR) ; Returns the next segment from file 62.49
; during processing of an inbound message. The following variables
; are used for the processing.
;
; Call with LA76249 - Entry in 62.49 where message is
; LA7NODE - Current ien of "150" wp field
;
; Returns LA7ARR - Data is returned in LA7ARR(0) and
; LA7ARR(n) if segment greater than 245 chars.
; LA7END - flag that end of message has been reached
;
N LA7I,LA7END,LA7QUIT
K LA7ARR
S LA76249=+$G(LA76249),LA7NODE=$G(LA7NODE,0),(LA7END,LA7QUIT)=0
;
S LA7NODE=$O(^LAHM(62.49,LA76249,150,LA7NODE))
I 'LA7NODE S LA7END=1
E D
. S LA7ARR(0)=$G(^LAHM(62.49,LA76249,150,LA7NODE,0)),LA7I=0
. F S LA7NODE=$O(^LAHM(62.49,LA76249,150,LA7NODE)) Q:'LA7NODE D Q:LA7QUIT
. . I $G(^LAHM(62.49,LA76249,150,LA7NODE,0))="" S LA7QUIT=1 Q
. . S LA7I=LA7I+1,LA7ARR(LA7I)=$G(^LAHM(62.49,LA76249,150,LA7NODE,0))
;
Q LA7END
;
;
FINDSITE(LA7Z,LA7TYPE,LA7SEM) ; Look up an institution in file #4
;
; Call with LA7Z = value to lookup
; VA: "VA"(optional) followed by 3-5 character VA site number
; Non-VA uses 3-5 character site assigned identifier
; LA7TYPE = 1 (host facility)
; 2 (collection facility)
;
; LA7SEM = 0 (log error message)
; 1 (suppress error message)
;
; Returns LA7Y = ien of entry in INSTITUTION file (#4).
;
N LA7X,LA7Y
;
S LA7TYPE=$G(LA7TYPE),LA7Z=$G(LA7Z),LA7Y="",LA7SEM=$G(LA7SEM,1)
;
; If VA facility then strip off "VA" before lookup
I $E(LA7Z,1,2)="VA" S LA7X=$E(LA7Z,3,$L(LA7Z))
E S LA7X=LA7Z
;
; Lookup in INSTITUTION file (#4)
; If appears to be a VA station number
I LA7Z?1(3N,3.4N2U,3N1U1N) S LA7Y=$$IDX^XUAF4("VASTANUM",LA7Z)
; If appears to be a DoD DMIS number
I LA7Z?4N S LA7Y=$$IDX^XUAF4("DMIS",LA7Z)
; If appears to be a IHS ASUFAC number
I LA7Z?6N S LA7Y=$$IDX^XUAF4("ASUFAC",LA7Z)
; Else try anything
I 'LA7Y S LA7Y=$$FIND1^DIC(4,"","OMX",LA7X)
;
; If unable to find in INSTITUTION file (#4) then try looking in
; SHIPPING CONFIGURATION file (#62.9) using non-VA identifier.
; Check that entry is not a VA facility
I LA7Y'>0,LA7X]"" D
. N LA7J,LA7K
. S LA7J=0
. F S LA7J=$O(^LAHM(62.9,LA7J)) Q:'LA7J D Q:LA7Y
. . S LA7J(0)=$G(^LAHM(62.9,LA7J,0))
. . I $P(LA7J(0),"^",4)'=1 Q ; Not active
. . I $P(LA7J(0),"^",12)'=LA7X Q
. . S LA7K=$S(LA7TYPE=1:$P(LA7J(0),"^",3),LA7TYPE=2:$P(LA7J(0),"^",2),1:"")
. . I LA7K,$$NVAF(LA7K) S LA7Y=LA7K
;
; No entry found
I 'LA7SEM,LA7Y'>0 D
. N LA7SITE
. S LA7SITE=$S(LA7TYPE=1:"Host",LA7TYPE=2:"Collection",1:"type")_" site: "_$S(LA7Z]"":LA7Z,1:"Blank-no value")
. N LA7X,LA7Y,LA7Z
. D CREATE^LA7LOG(25)
;
Q LA7Y
;
;
RETFACID(LA7Z,LA7TYPE,LA7SEM) ; (RET)urn (FAC)ility (ID)entifier
;
; Call with LA7Z = ien of entry in INSTITUTION file (#4).
;
; LA7TYPE = 1 (host facility)
; 2 (collecting facility)
;
; LA7SEM = 0 (log error message)
; 1 (suppress error message)
;
; Returns LA7Y = VA site number
; non-VA site identifier
;
N I,LA7NVAF,LA7X,LA7Y
S LA7Y="",LA7SEM=$G(LA7SEM,1)
;
; Check identifiers on file.
; If DoD use DMIS code since some DoD also have VA station number.
S LA7NVAF=$$NVAF(LA7Z)
I LA7NVAF=0 S LA7Y=$$ID^XUAF4("VASTANUM",LA7Z)
I LA7NVAF=1 S LA7Y=$$ID^XUAF4("DMIS",LA7Z)
I LA7NVAF=2 S LA7Y=$$ID^XUAF4("ASUFAC",LA7Z)
;
; If unable to find in INSTITUTION file (#4) then try looking in
; SHIPPING CONFIGURATION file (#62.9) using non-VA identifier.
I LA7Y="" D
. N LA7J
. S LA7J=0
. F S LA7J=$O(^LAHM(62.9,LA7J)) Q:'LA7J D
. . S LA7J(0)=$G(^LAHM(62.9,LA7J,0))
. . I $P(LA7J(0),"^",4)'=1 Q ; Not active
. . I LA7TYPE=1,LA7Z=$P(LA7J(0),"^",3) S LA7Y=$P(LA7J(0),"^",12)
. . I LA7TYPE=2,LA7Z=$P(LA7J(0),"^",2) S LA7Y=$P(LA7J(0),"^",12)
. I LA7Y'="" S LA7Y=$$UP^XLFSTR(LA7Y)
;
; No entry found
I 'LA7SEM,LA7Y="" D
. N LA7SITE
. S LA7SITE=$S(LA7TYPE=1:"Host",LA7TYPE=2:"Collection",1:"type")_" site: "_$$GET1^DIQ(4,LA7Z_",",.01)
. N LA7X,LA7Y
. D CREATE^LA7LOG(25)
;
Q LA7Y
;
;
FNDOLOC(LRUID) ; Find ordering location
; Call with LRUID = Accession's UID
; Returns LA7Y = ordering location^ordering institution
;
N LRAA,LRAD,LRAN,LA7X,LA7Y,X,Y
;
S LA7Y=""
S X=$Q(^LRO(68,"C",LRUID))
I $QS(X,3)'=LRUID Q LA7Y
S LA7X=$P($G(^LRO(68,$QS(X,4),1,$QS(X,5),1,$QS(X,6),0)),"^",13)
I 'LA7X Q LA7Y
D GETS^DIQ(44,LA7X_",",".01;3","EI","LA7Y")
S LA7Y=LA7X_"^"_LA7Y(44,LA7X_",",.01,"E")_"^"_LA7Y(44,LA7X_",",3,"I")_"^"_LA7Y(44,LA7X_",",3,"E")
Q LA7Y
;
;
CHKICN(LA7X) ; Lookup patient using ICN
; Call with LA7X = patient's ICN
; Returns LA7Y = patient's DFN^full ICN
; -1^error message
;
; Note - until MPI can handle full ICN (number,"V" and checksum) as lookup value
; then confirm if full ICN passed in with full ICN from MPI.
;
N LA7Y,LA7Z
;
S (LA7Y,LA7Z)=""
S LA7X(1)=$P(LA7X,"V")
S LA7X(2)=$P(LA7X,"V",2)
I LA7X(2)="" S LA7Y=$$GETDFN^MPIF001(LA7X(1))
E D
. S LA7Y=$$GETDFN^MPIF001(LA7X(1))
. S LA7Z=$$GETICN^MPIF001(LA7Y)
. I LA7X'=LA7Z S LA7Y="-1^Not a valid ICN"
;
Q LA7Y_"^"_LA7Z
;
;
NVAF(LA7X) ; Set flag sending to non-VA facility.
; Used to code certain segments for other systems, i.e. CHCS-DOD.
; Call with LA7X = ien of institution in file #4
; Returns LA7Y = 0 (VA facility)
; 1 (DoD facility - Army, Navy, Air Force, Coast Guard)
; 2 (Indian Health Service)
; 3 (Other - non US Government)
;
N LA7Y
S LA7Y=""
I LA7X S LA7Y=$$GET1^DIQ(4,LA7X_",",95,"I")
S LA7Y=$S(LA7Y="N":1,LA7Y="AF":1,LA7Y="ARMY":1,LA7Y="USCG":1,LA7Y="I":2,LA7Y="O":3,1:0)
Q LA7Y
;
;
FACDNS(LA74,LA7FS,LA7ECH,LA7LV) ; Build facility DNS identifier
; Call with LA74 = pointer to entry in INSITUTION file (#4)
; LA7FS = HL field separator
; LA7ECH = HL encoding characters
; LA7LV = field (1)/ component (2) level in message
;
; Returns LA7Y = STA#~STA-NAME~DNS
;
N LA7DN,LA7FAC,LA7NVAF,LA7Y
S LA7Y=""
;
; Retrieve saved valued
I $D(^TMP($J,"LA7VHLU","INST-DNS",LA74,LA7FS_LA7ECH,LA7LV)) S LA7Y=^TMP($J,"LA7VHLU","INST-DNS",LA74,LA7FS_LA7ECH,LA7LV)
;
; Retrieve station # or DMIS code for VA/DoD facilities, ASUFAC for IHS facilities.
; Others leave blank for now (Jun 2005)
; Retrieve domain name for this institution.
; Build component and save for other parts of message building
I LA7Y="" D
. S LA7FAC="",LA7NVAF=$$NVAF(LA74)
. I LA7NVAF<3 S LA7FAC=$$ID^XUAF4($S(LA7NVAF=1:"DMIS",LA7NVAF=2:"ASUFAC",1:"VASTANUM"),LA74)
. S LA7Y=LA7FAC
. S LA7DN=$$WHAT^XUAF4(LA74,60)
. I LA7DN'="" S LA7DN=$$CHKDATA^LA7VHLU3(LA7DN,LA7FS_LA7ECH),LA7Y=LA7FAC_$S(LA7LV=1:$E(LA7ECH),1:$E(LA7ECH,4))_LA7DN_$S(LA7LV=1:$E(LA7ECH),1:$E(LA7ECH,4))_"DNS"
. S ^TMP($J,"LA7VHLU","INST-DNS",LA74,LA7FS_LA7ECH,LA7LV)=LA7Y
;
Q LA7Y
;
;
RESFID(LA7PRDID,LA7SFAC,LA7CS) ; Resolve facility id to file #4 INSTIUTION file entry.
; Call with LA7PRDID = Producer's ID field
; LA7SFAC = sending facility
; LA7CS = component encoding character
N LA74,LA7I,LA7X,LA7Y
;
S LA7X=$P(LA7PRDID,LA7CS,2),LA74=""
;
F LA7I=1,4 D Q:LA74
. I $P(LA7PRDID,LA7CS,LA7I+2)="99VA4" S LA74=$$LKUP^XUAF4($P(LA7PRDID,LA7CS,LA7I))
. I $P(LA7PRDID,LA7CS,LA7I+2)="DNS" S LA74=$$LKUP^XUAF4($P(LA7PRDID,LA7CS,LA7I))
. I $P(LA7PRDID,LA7CS,LA7I+2)?1(1"L-CL",1"CLIA",1"99VACLIA") S LA74=$$IDX^XUAF4("CLIA",$P(LA7PRDID,LA7CS,LA7I))
. I 'LA74 S LA74=$$LKUP^XUAF4($P(LA7PRDID,LA7CS,LA7I+1))
. I 'LA74 S LA74=$$FINDSITE($P(LA7PRDID,LA7CS,LA7I),1,1)
I 'LA74 S LA74=$$FINDSITE($P(LA7SFAC,LA7CS),1,1)
;
Q LA74
;
;
RESPL(LA7X) ; Resolve performing lab from file #63 designation
;
; Call with LA7X = lab data reference (entry in file #63, #.12 multiple)
;
; Returns LA7Y = file #4 ien of performing lab associated with the result ^ ien of entry in "PL" multiple
;
N LA7I,LA7J,LA7K,LA7Z,LA7QUIT,LRDFN
S LRDFN=$P(LA7X,","),LA7Y="",LA7Z=LA7X
;
; Found a direct hit on this item
D CHKNODE
;
; Walk up tree to find any performing lab at a higher level
I LA7Y="" D
. S LA7QUIT=0
. I $P(LA7X,",",2)'="CH" D CHCHK Q
. I $P(LA7X,",",2)?1(1"MI",1"SP",1"CY",1"EM",1"AU") D MIAPCHK Q
;
Q LA7Y
;
;
CHCHK ; Find performing lab for a CH subscript reference
;
S LA7Z=$P(LA7X,";") D CHKNODE
;
Q
;
;
MIAPCHK ; Find performing lab for a MI and AP subscript reference
;
I $P(LA7X,";",2)'="" S LA7Z=$P(LA7X,";")
;
S LA7J=$L(LA7Z,",")
F LA7K=LA7J:-1:4 D Q:LA7Y
. S LA7Z=$P(LA7Z,",",1,LA7K)
. D CHKNODE Q:LA7Y
. I $P(LA7Z,",",LA7K)>0 S $P(LA7Z,",",LA7K)=0 D CHKNODE
;
I LA7Y="",$P(LA7X,",",2)="MI",$P(LA7X,",",4)=99 F I=1,5,8,11,16 S $P(LA7Z,",",4)=I D CHKNODE Q:LA7Y
;
Q
;
;
CHKNODE ; Check if node exists and return file #4 ien
;
S LA7I=$O(^LR(LRDFN,"PL","B",LA7Z,0))
I LA7I S LA7Y=$P(^LR(LRDFN,"PL",LA7I,0),"^",2)_"^"_LA7I
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLA7VHLU2 9379 printed Oct 16, 2024@17:41 Page 2
LA7VHLU2 ;DALOI/JMC - HL7 Segment Utility ;July 16, 2008
+1 ;;5.2;AUTOMATED LAB INSTRUMENTS;**46,61,64,68,74**;Sep 27, 1994;Build 229
+2 ;
+3 QUIT
+4 ;
GETSEG(LA76249,LA7NODE,LA7ARR) ; Returns the next segment from file 62.49
+1 ; during processing of an inbound message. The following variables
+2 ; are used for the processing.
+3 ;
+4 ; Call with LA76249 - Entry in 62.49 where message is
+5 ; LA7NODE - Current ien of "150" wp field
+6 ;
+7 ; Returns LA7ARR - Data is returned in LA7ARR(0) and
+8 ; LA7ARR(n) if segment greater than 245 chars.
+9 ; LA7END - flag that end of message has been reached
+10 ;
+11 NEW LA7I,LA7END,LA7QUIT
+12 KILL LA7ARR
+13 SET LA76249=+$GET(LA76249)
SET LA7NODE=$GET(LA7NODE,0)
SET (LA7END,LA7QUIT)=0
+14 ;
+15 SET LA7NODE=$ORDER(^LAHM(62.49,LA76249,150,LA7NODE))
+16 IF 'LA7NODE
SET LA7END=1
+17 IF '$TEST
Begin DoDot:1
+18 SET LA7ARR(0)=$GET(^LAHM(62.49,LA76249,150,LA7NODE,0))
SET LA7I=0
+19 FOR
SET LA7NODE=$ORDER(^LAHM(62.49,LA76249,150,LA7NODE))
if 'LA7NODE
QUIT
Begin DoDot:2
+20 IF $GET(^LAHM(62.49,LA76249,150,LA7NODE,0))=""
SET LA7QUIT=1
QUIT
+21 SET LA7I=LA7I+1
SET LA7ARR(LA7I)=$GET(^LAHM(62.49,LA76249,150,LA7NODE,0))
End DoDot:2
if LA7QUIT
QUIT
End DoDot:1
+22 ;
+23 QUIT LA7END
+24 ;
+25 ;
FINDSITE(LA7Z,LA7TYPE,LA7SEM) ; Look up an institution in file #4
+1 ;
+2 ; Call with LA7Z = value to lookup
+3 ; VA: "VA"(optional) followed by 3-5 character VA site number
+4 ; Non-VA uses 3-5 character site assigned identifier
+5 ; LA7TYPE = 1 (host facility)
+6 ; 2 (collection facility)
+7 ;
+8 ; LA7SEM = 0 (log error message)
+9 ; 1 (suppress error message)
+10 ;
+11 ; Returns LA7Y = ien of entry in INSTITUTION file (#4).
+12 ;
+13 NEW LA7X,LA7Y
+14 ;
+15 SET LA7TYPE=$GET(LA7TYPE)
SET LA7Z=$GET(LA7Z)
SET LA7Y=""
SET LA7SEM=$GET(LA7SEM,1)
+16 ;
+17 ; If VA facility then strip off "VA" before lookup
+18 IF $EXTRACT(LA7Z,1,2)="VA"
SET LA7X=$EXTRACT(LA7Z,3,$LENGTH(LA7Z))
+19 IF '$TEST
SET LA7X=LA7Z
+20 ;
+21 ; Lookup in INSTITUTION file (#4)
+22 ; If appears to be a VA station number
+23 IF LA7Z?1(3N,3.4N2U,3N1U1N)
SET LA7Y=$$IDX^XUAF4("VASTANUM",LA7Z)
+24 ; If appears to be a DoD DMIS number
+25 IF LA7Z?4N
SET LA7Y=$$IDX^XUAF4("DMIS",LA7Z)
+26 ; If appears to be a IHS ASUFAC number
+27 IF LA7Z?6N
SET LA7Y=$$IDX^XUAF4("ASUFAC",LA7Z)
+28 ; Else try anything
+29 IF 'LA7Y
SET LA7Y=$$FIND1^DIC(4,"","OMX",LA7X)
+30 ;
+31 ; If unable to find in INSTITUTION file (#4) then try looking in
+32 ; SHIPPING CONFIGURATION file (#62.9) using non-VA identifier.
+33 ; Check that entry is not a VA facility
+34 IF LA7Y'>0
IF LA7X]""
Begin DoDot:1
+35 NEW LA7J,LA7K
+36 SET LA7J=0
+37 FOR
SET LA7J=$ORDER(^LAHM(62.9,LA7J))
if 'LA7J
QUIT
Begin DoDot:2
+38 SET LA7J(0)=$GET(^LAHM(62.9,LA7J,0))
+39 ; Not active
IF $PIECE(LA7J(0),"^",4)'=1
QUIT
+40 IF $PIECE(LA7J(0),"^",12)'=LA7X
QUIT
+41 SET LA7K=$SELECT(LA7TYPE=1:$PIECE(LA7J(0),"^",3),LA7TYPE=2:$PIECE(LA7J(0),"^",2),1:"")
+42 IF LA7K
IF $$NVAF(LA7K)
SET LA7Y=LA7K
End DoDot:2
if LA7Y
QUIT
End DoDot:1
+43 ;
+44 ; No entry found
+45 IF 'LA7SEM
IF LA7Y'>0
Begin DoDot:1
+46 NEW LA7SITE
+47 SET LA7SITE=$SELECT(LA7TYPE=1:"Host",LA7TYPE=2:"Collection",1:"type")_" site: "_$SELECT(LA7Z]"":LA7Z,1:"Blank-no value")
+48 NEW LA7X,LA7Y,LA7Z
+49 DO CREATE^LA7LOG(25)
End DoDot:1
+50 ;
+51 QUIT LA7Y
+52 ;
+53 ;
RETFACID(LA7Z,LA7TYPE,LA7SEM) ; (RET)urn (FAC)ility (ID)entifier
+1 ;
+2 ; Call with LA7Z = ien of entry in INSTITUTION file (#4).
+3 ;
+4 ; LA7TYPE = 1 (host facility)
+5 ; 2 (collecting facility)
+6 ;
+7 ; LA7SEM = 0 (log error message)
+8 ; 1 (suppress error message)
+9 ;
+10 ; Returns LA7Y = VA site number
+11 ; non-VA site identifier
+12 ;
+13 NEW I,LA7NVAF,LA7X,LA7Y
+14 SET LA7Y=""
SET LA7SEM=$GET(LA7SEM,1)
+15 ;
+16 ; Check identifiers on file.
+17 ; If DoD use DMIS code since some DoD also have VA station number.
+18 SET LA7NVAF=$$NVAF(LA7Z)
+19 IF LA7NVAF=0
SET LA7Y=$$ID^XUAF4("VASTANUM",LA7Z)
+20 IF LA7NVAF=1
SET LA7Y=$$ID^XUAF4("DMIS",LA7Z)
+21 IF LA7NVAF=2
SET LA7Y=$$ID^XUAF4("ASUFAC",LA7Z)
+22 ;
+23 ; If unable to find in INSTITUTION file (#4) then try looking in
+24 ; SHIPPING CONFIGURATION file (#62.9) using non-VA identifier.
+25 IF LA7Y=""
Begin DoDot:1
+26 NEW LA7J
+27 SET LA7J=0
+28 FOR
SET LA7J=$ORDER(^LAHM(62.9,LA7J))
if 'LA7J
QUIT
Begin DoDot:2
+29 SET LA7J(0)=$GET(^LAHM(62.9,LA7J,0))
+30 ; Not active
IF $PIECE(LA7J(0),"^",4)'=1
QUIT
+31 IF LA7TYPE=1
IF LA7Z=$PIECE(LA7J(0),"^",3)
SET LA7Y=$PIECE(LA7J(0),"^",12)
+32 IF LA7TYPE=2
IF LA7Z=$PIECE(LA7J(0),"^",2)
SET LA7Y=$PIECE(LA7J(0),"^",12)
End DoDot:2
+33 IF LA7Y'=""
SET LA7Y=$$UP^XLFSTR(LA7Y)
End DoDot:1
+34 ;
+35 ; No entry found
+36 IF 'LA7SEM
IF LA7Y=""
Begin DoDot:1
+37 NEW LA7SITE
+38 SET LA7SITE=$SELECT(LA7TYPE=1:"Host",LA7TYPE=2:"Collection",1:"type")_" site: "_$$GET1^DIQ(4,LA7Z_",",.01)
+39 NEW LA7X,LA7Y
+40 DO CREATE^LA7LOG(25)
End DoDot:1
+41 ;
+42 QUIT LA7Y
+43 ;
+44 ;
FNDOLOC(LRUID) ; Find ordering location
+1 ; Call with LRUID = Accession's UID
+2 ; Returns LA7Y = ordering location^ordering institution
+3 ;
+4 NEW LRAA,LRAD,LRAN,LA7X,LA7Y,X,Y
+5 ;
+6 SET LA7Y=""
+7 SET X=$QUERY(^LRO(68,"C",LRUID))
+8 IF $QSUBSCRIPT(X,3)'=LRUID
QUIT LA7Y
+9 SET LA7X=$PIECE($GET(^LRO(68,$QSUBSCRIPT(X,4),1,$QSUBSCRIPT(X,5),1,$QSUBSCRIPT(X,6),0)),"^",13)
+10 IF 'LA7X
QUIT LA7Y
+11 DO GETS^DIQ(44,LA7X_",",".01;3","EI","LA7Y")
+12 SET LA7Y=LA7X_"^"_LA7Y(44,LA7X_",",.01,"E")_"^"_LA7Y(44,LA7X_",",3,"I")_"^"_LA7Y(44,LA7X_",",3,"E")
+13 QUIT LA7Y
+14 ;
+15 ;
CHKICN(LA7X) ; Lookup patient using ICN
+1 ; Call with LA7X = patient's ICN
+2 ; Returns LA7Y = patient's DFN^full ICN
+3 ; -1^error message
+4 ;
+5 ; Note - until MPI can handle full ICN (number,"V" and checksum) as lookup value
+6 ; then confirm if full ICN passed in with full ICN from MPI.
+7 ;
+8 NEW LA7Y,LA7Z
+9 ;
+10 SET (LA7Y,LA7Z)=""
+11 SET LA7X(1)=$PIECE(LA7X,"V")
+12 SET LA7X(2)=$PIECE(LA7X,"V",2)
+13 IF LA7X(2)=""
SET LA7Y=$$GETDFN^MPIF001(LA7X(1))
+14 IF '$TEST
Begin DoDot:1
+15 SET LA7Y=$$GETDFN^MPIF001(LA7X(1))
+16 SET LA7Z=$$GETICN^MPIF001(LA7Y)
+17 IF LA7X'=LA7Z
SET LA7Y="-1^Not a valid ICN"
End DoDot:1
+18 ;
+19 QUIT LA7Y_"^"_LA7Z
+20 ;
+21 ;
NVAF(LA7X) ; Set flag sending to non-VA facility.
+1 ; Used to code certain segments for other systems, i.e. CHCS-DOD.
+2 ; Call with LA7X = ien of institution in file #4
+3 ; Returns LA7Y = 0 (VA facility)
+4 ; 1 (DoD facility - Army, Navy, Air Force, Coast Guard)
+5 ; 2 (Indian Health Service)
+6 ; 3 (Other - non US Government)
+7 ;
+8 NEW LA7Y
+9 SET LA7Y=""
+10 IF LA7X
SET LA7Y=$$GET1^DIQ(4,LA7X_",",95,"I")
+11 SET LA7Y=$SELECT(LA7Y="N":1,LA7Y="AF":1,LA7Y="ARMY":1,LA7Y="USCG":1,LA7Y="I":2,LA7Y="O":3,1:0)
+12 QUIT LA7Y
+13 ;
+14 ;
FACDNS(LA74,LA7FS,LA7ECH,LA7LV) ; Build facility DNS identifier
+1 ; Call with LA74 = pointer to entry in INSITUTION file (#4)
+2 ; LA7FS = HL field separator
+3 ; LA7ECH = HL encoding characters
+4 ; LA7LV = field (1)/ component (2) level in message
+5 ;
+6 ; Returns LA7Y = STA#~STA-NAME~DNS
+7 ;
+8 NEW LA7DN,LA7FAC,LA7NVAF,LA7Y
+9 SET LA7Y=""
+10 ;
+11 ; Retrieve saved valued
+12 IF $DATA(^TMP($JOB,"LA7VHLU","INST-DNS",LA74,LA7FS_LA7ECH,LA7LV))
SET LA7Y=^TMP($JOB,"LA7VHLU","INST-DNS",LA74,LA7FS_LA7ECH,LA7LV)
+13 ;
+14 ; Retrieve station # or DMIS code for VA/DoD facilities, ASUFAC for IHS facilities.
+15 ; Others leave blank for now (Jun 2005)
+16 ; Retrieve domain name for this institution.
+17 ; Build component and save for other parts of message building
+18 IF LA7Y=""
Begin DoDot:1
+19 SET LA7FAC=""
SET LA7NVAF=$$NVAF(LA74)
+20 IF LA7NVAF<3
SET LA7FAC=$$ID^XUAF4($SELECT(LA7NVAF=1:"DMIS",LA7NVAF=2:"ASUFAC",1:"VASTANUM"),LA74)
+21 SET LA7Y=LA7FAC
+22 SET LA7DN=$$WHAT^XUAF4(LA74,60)
+23 IF LA7DN'=""
SET LA7DN=$$CHKDATA^LA7VHLU3(LA7DN,LA7FS_LA7ECH)
SET LA7Y=LA7FAC_$SELECT(LA7LV=1:$EXTRACT(LA7ECH),1:$EXTRACT(LA7ECH,4))_LA7DN_$SELECT(LA7LV=1:$EXTRACT(LA7ECH),1:$EXTRACT(LA7ECH,4))_"DNS"
+24 SET ^TMP($JOB,"LA7VHLU","INST-DNS",LA74,LA7FS_LA7ECH,LA7LV)=LA7Y
End DoDot:1
+25 ;
+26 QUIT LA7Y
+27 ;
+28 ;
RESFID(LA7PRDID,LA7SFAC,LA7CS) ; Resolve facility id to file #4 INSTIUTION file entry.
+1 ; Call with LA7PRDID = Producer's ID field
+2 ; LA7SFAC = sending facility
+3 ; LA7CS = component encoding character
+4 NEW LA74,LA7I,LA7X,LA7Y
+5 ;
+6 SET LA7X=$PIECE(LA7PRDID,LA7CS,2)
SET LA74=""
+7 ;
+8 FOR LA7I=1,4
Begin DoDot:1
+9 IF $PIECE(LA7PRDID,LA7CS,LA7I+2)="99VA4"
SET LA74=$$LKUP^XUAF4($PIECE(LA7PRDID,LA7CS,LA7I))
+10 IF $PIECE(LA7PRDID,LA7CS,LA7I+2)="DNS"
SET LA74=$$LKUP^XUAF4($PIECE(LA7PRDID,LA7CS,LA7I))
+11 IF $PIECE(LA7PRDID,LA7CS,LA7I+2)?1(1"L-CL",1"CLIA",1"99VACLIA")
SET LA74=$$IDX^XUAF4("CLIA",$PIECE(LA7PRDID,LA7CS,LA7I))
+12 IF 'LA74
SET LA74=$$LKUP^XUAF4($PIECE(LA7PRDID,LA7CS,LA7I+1))
+13 IF 'LA74
SET LA74=$$FINDSITE($PIECE(LA7PRDID,LA7CS,LA7I),1,1)
End DoDot:1
if LA74
QUIT
+14 IF 'LA74
SET LA74=$$FINDSITE($PIECE(LA7SFAC,LA7CS),1,1)
+15 ;
+16 QUIT LA74
+17 ;
+18 ;
RESPL(LA7X) ; Resolve performing lab from file #63 designation
+1 ;
+2 ; Call with LA7X = lab data reference (entry in file #63, #.12 multiple)
+3 ;
+4 ; Returns LA7Y = file #4 ien of performing lab associated with the result ^ ien of entry in "PL" multiple
+5 ;
+6 NEW LA7I,LA7J,LA7K,LA7Z,LA7QUIT,LRDFN
+7 SET LRDFN=$PIECE(LA7X,",")
SET LA7Y=""
SET LA7Z=LA7X
+8 ;
+9 ; Found a direct hit on this item
+10 DO CHKNODE
+11 ;
+12 ; Walk up tree to find any performing lab at a higher level
+13 IF LA7Y=""
Begin DoDot:1
+14 SET LA7QUIT=0
+15 IF $PIECE(LA7X,",",2)'="CH"
DO CHCHK
QUIT
+16 IF $PIECE(LA7X,",",2)?1(1"MI",1"SP",1"CY",1"EM",1"AU")
DO MIAPCHK
QUIT
End DoDot:1
+17 ;
+18 QUIT LA7Y
+19 ;
+20 ;
CHCHK ; Find performing lab for a CH subscript reference
+1 ;
+2 SET LA7Z=$PIECE(LA7X,";")
DO CHKNODE
+3 ;
+4 QUIT
+5 ;
+6 ;
MIAPCHK ; Find performing lab for a MI and AP subscript reference
+1 ;
+2 IF $PIECE(LA7X,";",2)'=""
SET LA7Z=$PIECE(LA7X,";")
+3 ;
+4 SET LA7J=$LENGTH(LA7Z,",")
+5 FOR LA7K=LA7J:-1:4
Begin DoDot:1
+6 SET LA7Z=$PIECE(LA7Z,",",1,LA7K)
+7 DO CHKNODE
if LA7Y
QUIT
+8 IF $PIECE(LA7Z,",",LA7K)>0
SET $PIECE(LA7Z,",",LA7K)=0
DO CHKNODE
End DoDot:1
if LA7Y
QUIT
+9 ;
+10 IF LA7Y=""
IF $PIECE(LA7X,",",2)="MI"
IF $PIECE(LA7X,",",4)=99
FOR I=1,5,8,11,16
SET $PIECE(LA7Z,",",4)=I
DO CHKNODE
if LA7Y
QUIT
+11 ;
+12 QUIT
+13 ;
+14 ;
CHKNODE ; Check if node exists and return file #4 ien
+1 ;
+2 SET LA7I=$ORDER(^LR(LRDFN,"PL","B",LA7Z,0))
+3 IF LA7I
SET LA7Y=$PIECE(^LR(LRDFN,"PL",LA7I,0),"^",2)_"^"_LA7I
+4 QUIT
