Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: LA7VHLU2

LA7VHLU2.m

Go to the documentation of this file.
  1. 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
  1. ;
  1. Q
  1. ;
  1. GETSEG(LA76249,LA7NODE,LA7ARR) ; Returns the next segment from file 62.49
  1. ; during processing of an inbound message. The following variables
  1. ; are used for the processing.
  1. ;
  1. ; Call with LA76249 - Entry in 62.49 where message is
  1. ; LA7NODE - Current ien of "150" wp field
  1. ;
  1. ; Returns LA7ARR - Data is returned in LA7ARR(0) and
  1. ; LA7ARR(n) if segment greater than 245 chars.
  1. ; LA7END - flag that end of message has been reached
  1. ;
  1. N LA7I,LA7END,LA7QUIT
  1. K LA7ARR
  1. S LA76249=+$G(LA76249),LA7NODE=$G(LA7NODE,0),(LA7END,LA7QUIT)=0
  1. ;
  1. S LA7NODE=$O(^LAHM(62.49,LA76249,150,LA7NODE))
  1. I 'LA7NODE S LA7END=1
  1. E D
  1. . S LA7ARR(0)=$G(^LAHM(62.49,LA76249,150,LA7NODE,0)),LA7I=0
  1. . F S LA7NODE=$O(^LAHM(62.49,LA76249,150,LA7NODE)) Q:'LA7NODE D Q:LA7QUIT
  1. . . I $G(^LAHM(62.49,LA76249,150,LA7NODE,0))="" S LA7QUIT=1 Q
  1. . . S LA7I=LA7I+1,LA7ARR(LA7I)=$G(^LAHM(62.49,LA76249,150,LA7NODE,0))
  1. ;
  1. Q LA7END
  1. ;
  1. ;
  1. FINDSITE(LA7Z,LA7TYPE,LA7SEM) ; Look up an institution in file #4
  1. ;
  1. ; Call with LA7Z = value to lookup
  1. ; VA: "VA"(optional) followed by 3-5 character VA site number
  1. ; Non-VA uses 3-5 character site assigned identifier
  1. ; LA7TYPE = 1 (host facility)
  1. ; 2 (collection facility)
  1. ;
  1. ; LA7SEM = 0 (log error message)
  1. ; 1 (suppress error message)
  1. ;
  1. ; Returns LA7Y = ien of entry in INSTITUTION file (#4).
  1. ;
  1. N LA7X,LA7Y
  1. ;
  1. S LA7TYPE=$G(LA7TYPE),LA7Z=$G(LA7Z),LA7Y="",LA7SEM=$G(LA7SEM,1)
  1. ;
  1. ; If VA facility then strip off "VA" before lookup
  1. I $E(LA7Z,1,2)="VA" S LA7X=$E(LA7Z,3,$L(LA7Z))
  1. E S LA7X=LA7Z
  1. ;
  1. ; Lookup in INSTITUTION file (#4)
  1. ; If appears to be a VA station number
  1. I LA7Z?1(3N,3.4N2U,3N1U1N) S LA7Y=$$IDX^XUAF4("VASTANUM",LA7Z)
  1. ; If appears to be a DoD DMIS number
  1. I LA7Z?4N S LA7Y=$$IDX^XUAF4("DMIS",LA7Z)
  1. ; If appears to be a IHS ASUFAC number
  1. I LA7Z?6N S LA7Y=$$IDX^XUAF4("ASUFAC",LA7Z)
  1. ; Else try anything
  1. I 'LA7Y S LA7Y=$$FIND1^DIC(4,"","OMX",LA7X)
  1. ;
  1. ; If unable to find in INSTITUTION file (#4) then try looking in
  1. ; SHIPPING CONFIGURATION file (#62.9) using non-VA identifier.
  1. ; Check that entry is not a VA facility
  1. I LA7Y'>0,LA7X]"" D
  1. . N LA7J,LA7K
  1. . S LA7J=0
  1. . F S LA7J=$O(^LAHM(62.9,LA7J)) Q:'LA7J D Q:LA7Y
  1. . . S LA7J(0)=$G(^LAHM(62.9,LA7J,0))
  1. . . I $P(LA7J(0),"^",4)'=1 Q ; Not active
  1. . . I $P(LA7J(0),"^",12)'=LA7X Q
  1. . . S LA7K=$S(LA7TYPE=1:$P(LA7J(0),"^",3),LA7TYPE=2:$P(LA7J(0),"^",2),1:"")
  1. . . I LA7K,$$NVAF(LA7K) S LA7Y=LA7K
  1. ;
  1. ; No entry found
  1. I 'LA7SEM,LA7Y'>0 D
  1. . N LA7SITE
  1. . S LA7SITE=$S(LA7TYPE=1:"Host",LA7TYPE=2:"Collection",1:"type")_" site: "_$S(LA7Z]"":LA7Z,1:"Blank-no value")
  1. . N LA7X,LA7Y,LA7Z
  1. . D CREATE^LA7LOG(25)
  1. ;
  1. Q LA7Y
  1. ;
  1. ;
  1. RETFACID(LA7Z,LA7TYPE,LA7SEM) ; (RET)urn (FAC)ility (ID)entifier
  1. ;
  1. ; Call with LA7Z = ien of entry in INSTITUTION file (#4).
  1. ;
  1. ; LA7TYPE = 1 (host facility)
  1. ; 2 (collecting facility)
  1. ;
  1. ; LA7SEM = 0 (log error message)
  1. ; 1 (suppress error message)
  1. ;
  1. ; Returns LA7Y = VA site number
  1. ; non-VA site identifier
  1. ;
  1. N I,LA7NVAF,LA7X,LA7Y
  1. S LA7Y="",LA7SEM=$G(LA7SEM,1)
  1. ;
  1. ; Check identifiers on file.
  1. ; If DoD use DMIS code since some DoD also have VA station number.
  1. S LA7NVAF=$$NVAF(LA7Z)
  1. I LA7NVAF=0 S LA7Y=$$ID^XUAF4("VASTANUM",LA7Z)
  1. I LA7NVAF=1 S LA7Y=$$ID^XUAF4("DMIS",LA7Z)
  1. I LA7NVAF=2 S LA7Y=$$ID^XUAF4("ASUFAC",LA7Z)
  1. ;
  1. ; If unable to find in INSTITUTION file (#4) then try looking in
  1. ; SHIPPING CONFIGURATION file (#62.9) using non-VA identifier.
  1. I LA7Y="" D
  1. . N LA7J
  1. . S LA7J=0
  1. . F S LA7J=$O(^LAHM(62.9,LA7J)) Q:'LA7J D
  1. . . S LA7J(0)=$G(^LAHM(62.9,LA7J,0))
  1. . . I $P(LA7J(0),"^",4)'=1 Q ; Not active
  1. . . I LA7TYPE=1,LA7Z=$P(LA7J(0),"^",3) S LA7Y=$P(LA7J(0),"^",12)
  1. . . I LA7TYPE=2,LA7Z=$P(LA7J(0),"^",2) S LA7Y=$P(LA7J(0),"^",12)
  1. . I LA7Y'="" S LA7Y=$$UP^XLFSTR(LA7Y)
  1. ;
  1. ; No entry found
  1. I 'LA7SEM,LA7Y="" D
  1. . N LA7SITE
  1. . S LA7SITE=$S(LA7TYPE=1:"Host",LA7TYPE=2:"Collection",1:"type")_" site: "_$$GET1^DIQ(4,LA7Z_",",.01)
  1. . N LA7X,LA7Y
  1. . D CREATE^LA7LOG(25)
  1. ;
  1. Q LA7Y
  1. ;
  1. ;
  1. FNDOLOC(LRUID) ; Find ordering location
  1. ; Call with LRUID = Accession's UID
  1. ; Returns LA7Y = ordering location^ordering institution
  1. ;
  1. N LRAA,LRAD,LRAN,LA7X,LA7Y,X,Y
  1. ;
  1. S LA7Y=""
  1. S X=$Q(^LRO(68,"C",LRUID))
  1. I $QS(X,3)'=LRUID Q LA7Y
  1. S LA7X=$P($G(^LRO(68,$QS(X,4),1,$QS(X,5),1,$QS(X,6),0)),"^",13)
  1. I 'LA7X Q LA7Y
  1. D GETS^DIQ(44,LA7X_",",".01;3","EI","LA7Y")
  1. S LA7Y=LA7X_"^"_LA7Y(44,LA7X_",",.01,"E")_"^"_LA7Y(44,LA7X_",",3,"I")_"^"_LA7Y(44,LA7X_",",3,"E")
  1. Q LA7Y
  1. ;
  1. ;
  1. CHKICN(LA7X) ; Lookup patient using ICN
  1. ; Call with LA7X = patient's ICN
  1. ; Returns LA7Y = patient's DFN^full ICN
  1. ; -1^error message
  1. ;
  1. ; Note - until MPI can handle full ICN (number,"V" and checksum) as lookup value
  1. ; then confirm if full ICN passed in with full ICN from MPI.
  1. ;
  1. N LA7Y,LA7Z
  1. ;
  1. S (LA7Y,LA7Z)=""
  1. S LA7X(1)=$P(LA7X,"V")
  1. S LA7X(2)=$P(LA7X,"V",2)
  1. I LA7X(2)="" S LA7Y=$$GETDFN^MPIF001(LA7X(1))
  1. E D
  1. . S LA7Y=$$GETDFN^MPIF001(LA7X(1))
  1. . S LA7Z=$$GETICN^MPIF001(LA7Y)
  1. . I LA7X'=LA7Z S LA7Y="-1^Not a valid ICN"
  1. ;
  1. Q LA7Y_"^"_LA7Z
  1. ;
  1. ;
  1. NVAF(LA7X) ; Set flag sending to non-VA facility.
  1. ; Used to code certain segments for other systems, i.e. CHCS-DOD.
  1. ; Call with LA7X = ien of institution in file #4
  1. ; Returns LA7Y = 0 (VA facility)
  1. ; 1 (DoD facility - Army, Navy, Air Force, Coast Guard)
  1. ; 2 (Indian Health Service)
  1. ; 3 (Other - non US Government)
  1. ;
  1. N LA7Y
  1. S LA7Y=""
  1. I LA7X S LA7Y=$$GET1^DIQ(4,LA7X_",",95,"I")
  1. S LA7Y=$S(LA7Y="N":1,LA7Y="AF":1,LA7Y="ARMY":1,LA7Y="USCG":1,LA7Y="I":2,LA7Y="O":3,1:0)
  1. Q LA7Y
  1. ;
  1. ;
  1. FACDNS(LA74,LA7FS,LA7ECH,LA7LV) ; Build facility DNS identifier
  1. ; Call with LA74 = pointer to entry in INSITUTION file (#4)
  1. ; LA7FS = HL field separator
  1. ; LA7ECH = HL encoding characters
  1. ; LA7LV = field (1)/ component (2) level in message
  1. ;
  1. ; Returns LA7Y = STA#~STA-NAME~DNS
  1. ;
  1. N LA7DN,LA7FAC,LA7NVAF,LA7Y
  1. S LA7Y=""
  1. ;
  1. ; Retrieve saved valued
  1. I $D(^TMP($J,"LA7VHLU","INST-DNS",LA74,LA7FS_LA7ECH,LA7LV)) S LA7Y=^TMP($J,"LA7VHLU","INST-DNS",LA74,LA7FS_LA7ECH,LA7LV)
  1. ;
  1. ; Retrieve station # or DMIS code for VA/DoD facilities, ASUFAC for IHS facilities.
  1. ; Others leave blank for now (Jun 2005)
  1. ; Retrieve domain name for this institution.
  1. ; Build component and save for other parts of message building
  1. I LA7Y="" D
  1. . S LA7FAC="",LA7NVAF=$$NVAF(LA74)
  1. . I LA7NVAF<3 S LA7FAC=$$ID^XUAF4($S(LA7NVAF=1:"DMIS",LA7NVAF=2:"ASUFAC",1:"VASTANUM"),LA74)
  1. . S LA7Y=LA7FAC
  1. . S LA7DN=$$WHAT^XUAF4(LA74,60)
  1. . 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"
  1. . S ^TMP($J,"LA7VHLU","INST-DNS",LA74,LA7FS_LA7ECH,LA7LV)=LA7Y
  1. ;
  1. Q LA7Y
  1. ;
  1. ;
  1. RESFID(LA7PRDID,LA7SFAC,LA7CS) ; Resolve facility id to file #4 INSTIUTION file entry.
  1. ; Call with LA7PRDID = Producer's ID field
  1. ; LA7SFAC = sending facility
  1. ; LA7CS = component encoding character
  1. N LA74,LA7I,LA7X,LA7Y
  1. ;
  1. S LA7X=$P(LA7PRDID,LA7CS,2),LA74=""
  1. ;
  1. F LA7I=1,4 D Q:LA74
  1. . I $P(LA7PRDID,LA7CS,LA7I+2)="99VA4" S LA74=$$LKUP^XUAF4($P(LA7PRDID,LA7CS,LA7I))
  1. . I $P(LA7PRDID,LA7CS,LA7I+2)="DNS" S LA74=$$LKUP^XUAF4($P(LA7PRDID,LA7CS,LA7I))
  1. . I $P(LA7PRDID,LA7CS,LA7I+2)?1(1"L-CL",1"CLIA",1"99VACLIA") S LA74=$$IDX^XUAF4("CLIA",$P(LA7PRDID,LA7CS,LA7I))
  1. . I 'LA74 S LA74=$$LKUP^XUAF4($P(LA7PRDID,LA7CS,LA7I+1))
  1. . I 'LA74 S LA74=$$FINDSITE($P(LA7PRDID,LA7CS,LA7I),1,1)
  1. I 'LA74 S LA74=$$FINDSITE($P(LA7SFAC,LA7CS),1,1)
  1. ;
  1. Q LA74
  1. ;
  1. ;
  1. RESPL(LA7X) ; Resolve performing lab from file #63 designation
  1. ;
  1. ; Call with LA7X = lab data reference (entry in file #63, #.12 multiple)
  1. ;
  1. ; Returns LA7Y = file #4 ien of performing lab associated with the result ^ ien of entry in "PL" multiple
  1. ;
  1. N LA7I,LA7J,LA7K,LA7Z,LA7QUIT,LRDFN
  1. S LRDFN=$P(LA7X,","),LA7Y="",LA7Z=LA7X
  1. ;
  1. ; Found a direct hit on this item
  1. D CHKNODE
  1. ;
  1. ; Walk up tree to find any performing lab at a higher level
  1. I LA7Y="" D
  1. . S LA7QUIT=0
  1. . I $P(LA7X,",",2)'="CH" D CHCHK Q
  1. . I $P(LA7X,",",2)?1(1"MI",1"SP",1"CY",1"EM",1"AU") D MIAPCHK Q
  1. ;
  1. Q LA7Y
  1. ;
  1. ;
  1. CHCHK ; Find performing lab for a CH subscript reference
  1. ;
  1. S LA7Z=$P(LA7X,";") D CHKNODE
  1. ;
  1. Q
  1. ;
  1. ;
  1. MIAPCHK ; Find performing lab for a MI and AP subscript reference
  1. ;
  1. I $P(LA7X,";",2)'="" S LA7Z=$P(LA7X,";")
  1. ;
  1. S LA7J=$L(LA7Z,",")
  1. F LA7K=LA7J:-1:4 D Q:LA7Y
  1. . S LA7Z=$P(LA7Z,",",1,LA7K)
  1. . D CHKNODE Q:LA7Y
  1. . I $P(LA7Z,",",LA7K)>0 S $P(LA7Z,",",LA7K)=0 D CHKNODE
  1. ;
  1. 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
  1. ;
  1. Q
  1. ;
  1. ;
  1. CHKNODE ; Check if node exists and return file #4 ien
  1. ;
  1. S LA7I=$O(^LR(LRDFN,"PL","B",LA7Z,0))
  1. I LA7I S LA7Y=$P(^LR(LRDFN,"PL",LA7I,0),"^",2)_"^"_LA7I
  1. Q