- 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 Jan 18, 2025@02:41:22 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