LA7VIN2 ;DALOI/JMC - Process Incoming UI Msgs, continued ;06/22/15 13:02
;;5.2;AUTOMATED LAB INSTRUMENTS;**46,64,74,88,87**;Sep 27, 1994;Build 12
;
; Reference to RPCVIC^DPTLK supported by IA #5888
; Reference to DEM^VADPT supported by IA #10061
;
;This routine is a continuation of LA7VIN1 and is only called from there.
Q
;
MSH ; Process MSH segment
N LA7X
;
I $E(LA7SEG(0),1,3)'="MSH" D Q
. S (LA7ABORT,LA7ERR)=7
. D CREATE^LA7LOG(LA7ERR)
;
; Encoding characters
S LA7FS=$E(LA7SEG(0),4)
S LA7CS=$E(LA7SEG(0),5)
S LA7ECH=$E(LA7SEG(0),5,8)
; No field or component separator
I LA7FS=""!(LA7CS="") D
. S (LA7ABORT,LA7ERR)=8
. D CREATE^LA7LOG(LA7ERR)
;
; Sending application
S LA7SAP=$$P^LA7VHLU(.LA7SEG,3,LA7FS)
S LA7ID=LA7SAP_"-I-"
;
; Sending facility
S LA7SFAC=$$P^LA7VHLU(.LA7SEG,4,LA7FS)
;
; Receiving application
S LA7RAP=$$P^LA7VHLU(.LA7SEG,5,LA7FS)
;
; Receiving facility
S LA7RFAC=$$P^LA7VHLU(.LA7SEG,6,LA7FS)
;
; Message date/time from first component
S LA7MEDT=$$HL7TFM^XLFDT($P($$P^LA7VHLU(.LA7SEG,7,LA7FS),LA7CS),"L")
;
; Message type
S LA7X=$$P^LA7VHLU(.LA7SEG,9,LA7FS)
S LA7MTYP=$P(LA7X,LA7CS,1)
;
; Message Control ID
S LA7MID=$$P^LA7VHLU(.LA7SEG,10,LA7FS)
;
; HL7 version
S LA7X=$$P^LA7VHLU(.LA7SEG,12,LA7FS)
S LA7HLV=$P(LA7X,LA7CS,1)
;
; Accept acknowledgement type
S LA7AAT(0)=$$P^LA7VHLU(.LA7SEG,15,LA7FS)
;
; Application acknowledgement type
S LA7AAT(1)=$$P^LA7VHLU(.LA7SEG,16,LA7FS)
;
Q
;
;
ORC ; Process ORC segment
N LA7X,LA7Y
;
; Order control
S LA7OTYPE=$$P^LA7VHLU(.LA7SEG,2,LA7FS)
;
; Place order number
S LA7PON=$$P^LA7VHLU(.LA7SEG,3,LA7FS)
;
; Setup shipping manifest variable
S LA7Y=0
S LA7X=$P($$P^LA7VHLU(.LA7SEG,5,LA7FS),LA7CS)
I LA7X'="" S LA7Y=$O(^LAHM(62.8,"B",LA7X,0))
I LA7Y S LA7628=LA7Y
S LA7SM=LA7Y_"^"_LA7X
;
; Setup shipping configuration variable
I $P(LA7SM,"^") S LA7629=+$P($G(^LAHM(62.8,$P(LA7SM,"^"),0)),"^",2)
E S LA7629=0
;
; Set new order/shipping manifest received alert/identifiers
I LA7MTYP="ORM",$P(LA7SM,"^",2)'="" D
. S ^TMP("LA7-ORM",$J,LA76248,LA76249,$P(LA7SM,"^",2))=""
. D SETID^LA7VHLU1(LA76249,LA7ID,$P(LA7SM,"^",2),1)
. D SETID^LA7VHLU1(LA76249,"",$P(LA7SM,"^",2),0)
;
; Order quantity/timing (duration, units, urgency)
S LA7ODUR=$P($$P^LA7VHLU(.LA7SEG,8,LA7FS),LA7CS,3)
S LA7ODURU=$P($$P^LA7VHLU(.LA7SEG,8,LA7FS),LA7CS,4)
S LA7OUR=$P($$P^LA7VHLU(.LA7SEG,8,LA7FS),LA7CS,6)
;
; Date/time of transaction
S LA7ORDT=$$HL7TFM^XLFDT($P($$P^LA7VHLU(.LA7SEG,10,LA7FS),LA7CS),"L")
;
; Placer's entered by (id^duz^last name, first name, mi [id])
S LA7X=$$P^LA7VHLU(.LA7SEG,11,LA7FS)
S LA7PEB=$$XCNTFM^LA7VHLU9(LA7X,LA7ECH)
I LA7PEB="^0^" S LA7PEB=""
;
; Placer's verified by (id^duz^last name, first name, mi [id])
S LA7X=$$P^LA7VHLU(.LA7SEG,12,LA7FS)
S LA7PVB=$$XCNTFM^LA7VHLU9(LA7X,LA7ECH)
I LA7PVB="^0^" S LA7PVB=""
;
; Placer's ordering provider (id^duz^last name, first name, mi [id])
S LA7X=$$P^LA7VHLU(.LA7SEG,13,LA7FS)
S LA7POP=$$XCNTFM^LA7VHLU9(LA7X,LA7ECH)
I LA7POP="^0^" S LA7POP=""
;
; Enterer's ordering location
S LA7X=$$P^LA7VHLU(.LA7SEG,14,LA7FS)
S LA7Y=$$PLTFM^LA7VHLU4(LA7X,LA7FS,LA7ECH)
S LA7EOL=$P(LA7Y,"^",1,3)
I LA7EOL="^0^" S LA7EOL=""
;
; Order control code reason
S LA7OCR=$$P^LA7VHLU(.LA7SEG,17,LA7FS)
;
;
; If ORM order message, determine specimen collecting site from ORC
; segment, if none use MSH sending facility value
S LA7CSITE=""
I LA7MTYP="ORM" D
. S LA7X=$P($$P^LA7VHLU(.LA7SEG,18,LA7FS),LA7CS)
. S LA7CSITE=$$FINDSITE^LA7VHLU2(LA7X,2,1)
. I LA7CSITE'>0 S LA7CSITE=$$FINDSITE^LA7VHLU2(LA7SFAC,2,0)
;
Q
;
;
NTE ; Process NTE segment
;
D NTE^LA7VIN2A
Q
;
;
PID ; Process PID segment
N LA7I,LA7X,LA7Y,X,Y
;
S (DFN,LA7DOB,LA7ICN,LA7PRACE,LA7PNM,LA7PTID2,LA7PTID3,LA7PTID4,LA7SEX,LA7SSN,LRDFN,LRTDFN)=""
;
; PID Set ID
S LA7SPID=$$P^LA7VHLU(.LA7SEG,2,LA7FS)
;
; Extract patient identifiers
S LA7PTID2=$$P^LA7VHLU(.LA7SEG,3,LA7FS)
S LA7PTID3=$$P^LA7VHLU(.LA7SEG,4,LA7FS)
S LA7PTID4=$$P^LA7VHLU(.LA7SEG,5,LA7FS)
; Resolve ICN if identifier is from MPI
; Assume SSN is identifier if "SS" or blank
F LA7I=1:1:$L(LA7PTID3,$E(LA7ECH,2)) D
. N LA7J,LA7X,LA7ID
. S X=$P(LA7PTID3,$E(LA7ECH,2),LA7I) Q:'$L(X)
. S LA7PTID3(LA7I)=X,LA7ID=$P(LA7PTID3(LA7I),$E(LA7ECH),5)
. I LA7ID'="","NI^PI"[LA7ID D Q
. . S Y=$P(LA7PTID3(LA7I),$E(LA7ECH))
. . I Y?10N1"V"6N S LA7Y=Y
. . E S LA7Y=Y_"V"_$P(LA7PTID3(LA7I),$E(LA7ECH),2)
. . S LA7X=$$CHKICN^LA7VHLU2(LA7Y)
. . I LA7X>0 S DFN=$P(LA7X,"^"),LA7ICN=$P(LA7X,"^",2)
. I LA7ID="SS"!(LA7ID="") D Q
. . F LA7J=1:1:3 S LA7X(LA7J)=$P(LA7PTID3(LA7I),$E(LA7ECH),LA7J)
. . ;following line is commented out in LR*5.2*87
. . ;Veteran Identification Card (VIC) ID's might be received
. . ;in PID segment instead of social security numbers
. . ;I LA7X(1)'?9N.1A Q
. . ;routine DPTLK will return the DFN for an SSN
. . ;or VIC ID
. . I '$G(DFN) D RPCVIC^DPTLK(.DFN,LA7X(1))
. . I LA7X(3)="M11",LA7X(2)'=$P($$M11^HLFNC(LA7X(1),LA7ECH),$E(LA7ECH),2) Q
. . ;following line commented out because VIC ID may have been received
. . ;S LA7SSN=LA7X(1),DFN=$O(^DPT("SSN",LA7SSN,0))
. . ;Determine SSN from DFN returned by DPTLK
. . ;SSN is needed for transaction lookups in
. . ;option Display Lab Universal Interface Message
. . I $G(DFN)>0 D
. . . N VADM
. . . D DEM^VADPT
. . . S LA7SSN=$P(VADM(2),"^")
;
; Check PID-2 (alternate patient id) if PID-3 did not yield SSN/ICN
F LA7I=1:1:$L(LA7PTID2,$E(LA7ECH,2)) D
. N LA7J,LA7X,LA7ID
. S X=$P(LA7PTID2,$E(LA7ECH,2),LA7I) Q:'$L(X)
. S LA7PTID2(LA7I)=X,LA7ID=$P(LA7PTID2(LA7I),$E(LA7ECH),5)
. I LA7ICN="",LA7ID'="","NI^PI"[LA7ID D Q
. . S Y=$P(LA7PTID2(LA7I),$E(LA7ECH))
. . I Y?10N1"V"6N S LA7Y=Y
. . E S LA7Y=Y_"V"_$P(LA7PTID2(LA7I),$E(LA7ECH),2)
. . S LA7X=$$CHKICN^LA7VHLU2(LA7Y)
. . I LA7X>0 S DFN=$P(LA7X,"^"),LA7ICN=$P(LA7X,"^",2)
. I LA7SSN="",LA7ID="SS"!(LA7ID="") D Q
. . F LA7J=1:1:3 S LA7X(LA7J)=$P(LA7PTID2(LA7I),$E(LA7ECH),LA7J)
. . I LA7X(1)'?9N.1A Q
. . I LA7X(3)="M11",LA7X(2)'=$P($$M11^HLFNC(LA7X(1),LA7ECH),$E(LA7ECH),2) Q
. . S LA7SSN=LA7X(1),DFN=$O(^DPT("SSN",LA7SSN,0))
;
; Extract patient name
S LA7X=$$P^LA7VHLU(.LA7SEG,6,LA7FS)
I LA7X'="" D
. S LA7PNM=$$FMNAME^HLFNC(LA7X,LA7ECH)
. D SETID^LA7VHLU1(LA76249,LA7ID,LA7PNM,0)
. D SETID^LA7VHLU1(LA76249,"",LA7PNM,0)
;
; Extract date of birth
; Check for degree of precision in 2nd component to provide backward compatibility with HL7 <v2.3
S LA7X=$$P^LA7VHLU(.LA7SEG,8,LA7FS)
I LA7X D
. S LA7Y=$P(LA7X,LA7CS,2),LA7X=$P(LA7X,LA7CS,1)
. I (LA7Y=""!(LA7Y="D")),$E(LA7X,9,12)="0000" S LA7X=$E(LA7X,1,8)
. S LA7DOB=$$HL7TFM^XLFDT(LA7X)
. I LA7DOB<1 S LA7DOB=""
. I LA7Y="L" S LA7DOB=$E(LA7DOB,1,5)_"00"
. I LA7Y="Y" S LA7DOB=$E(LA7DOB,1,3)_"0000"
;
; Extract patient's sex
S LA7SEX=$$P^LA7VHLU(.LA7SEG,9,LA7FS)
;
; Extract patient's race
S LA7X=$$P^LA7VHLU(.LA7SEG,11,LA7FS)
I $P(LA7X,LA7CS)'="" D
. I $P(LA7X,LA7CS,3)="0005" S $P(LA7X,LA7CS,3)="HL70005"
. S LA7PRACE=$P(LA7X,LA7CS)_":"_$P(LA7X,LA7CS,2)_$S($P(LA7X,LA7CS,3)'="":":"_$P(LA7X,LA7CS,3),1:"")
;
; Extract patient's SSN and determine DFN
; If SSN determined previously from PID-3 then compare SSN's
; If DFN determined previously from ICN then check DFN based on SSN.
S LA7X=$P($$P^LA7VHLU(.LA7SEG,20,LA7FS),LA7CS)
S LA7X=$TR(LA7X,"-","") ; remove "-" if any
I LA7X?9N.1A D
. I LA7SSN'="",LA7X'=LA7SSN Q
. S LA7SSN=LA7X
. I DFN,DFN'=$O(^DPT("SSN",LA7SSN,0)) Q
. S DFN=$O(^DPT("SSN",LA7SSN,0))
I LA7SSN'="" D
. I LA7INTYP>19,LA7INTYP<30 D SETID^LA7VHLU1(LA76249,LA7ID,LA7SSN,1) Q
. D SETID^LA7VHLU1(LA76249,LA7ID,LA7SSN,0)
;If VIC ID sent, set additional identifier for lookup
;VIC ID will always begin with "%"
I $E($G(LA7PTID3))="%" D
. D SETID^LA7VHLU1(LA76249,LA7ID,$P(LA7PTID3,"^"),0)
I DFN S LRDFN=$P($G(^DPT(DFN,"LR")),"^")
;
Q
;
;
PV1 ; Process PV1 segment
;
; PV1 Set ID
S LA7SPV1=$$P^LA7VHLU(.LA7SEG,2,LA7FS)
;
; Extract ordering location
S LA7LOC=$P($$P^LA7VHLU(.LA7SEG,4,LA7FS),LA7CS)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLA7VIN2 8282 printed Nov 22, 2024@16:50:34 Page 2
LA7VIN2 ;DALOI/JMC - Process Incoming UI Msgs, continued ;06/22/15 13:02
+1 ;;5.2;AUTOMATED LAB INSTRUMENTS;**46,64,74,88,87**;Sep 27, 1994;Build 12
+2 ;
+3 ; Reference to RPCVIC^DPTLK supported by IA #5888
+4 ; Reference to DEM^VADPT supported by IA #10061
+5 ;
+6 ;This routine is a continuation of LA7VIN1 and is only called from there.
+7 QUIT
+8 ;
MSH ; Process MSH segment
+1 NEW LA7X
+2 ;
+3 IF $EXTRACT(LA7SEG(0),1,3)'="MSH"
Begin DoDot:1
+4 SET (LA7ABORT,LA7ERR)=7
+5 DO CREATE^LA7LOG(LA7ERR)
End DoDot:1
QUIT
+6 ;
+7 ; Encoding characters
+8 SET LA7FS=$EXTRACT(LA7SEG(0),4)
+9 SET LA7CS=$EXTRACT(LA7SEG(0),5)
+10 SET LA7ECH=$EXTRACT(LA7SEG(0),5,8)
+11 ; No field or component separator
+12 IF LA7FS=""!(LA7CS="")
Begin DoDot:1
+13 SET (LA7ABORT,LA7ERR)=8
+14 DO CREATE^LA7LOG(LA7ERR)
End DoDot:1
+15 ;
+16 ; Sending application
+17 SET LA7SAP=$$P^LA7VHLU(.LA7SEG,3,LA7FS)
+18 SET LA7ID=LA7SAP_"-I-"
+19 ;
+20 ; Sending facility
+21 SET LA7SFAC=$$P^LA7VHLU(.LA7SEG,4,LA7FS)
+22 ;
+23 ; Receiving application
+24 SET LA7RAP=$$P^LA7VHLU(.LA7SEG,5,LA7FS)
+25 ;
+26 ; Receiving facility
+27 SET LA7RFAC=$$P^LA7VHLU(.LA7SEG,6,LA7FS)
+28 ;
+29 ; Message date/time from first component
+30 SET LA7MEDT=$$HL7TFM^XLFDT($PIECE($$P^LA7VHLU(.LA7SEG,7,LA7FS),LA7CS),"L")
+31 ;
+32 ; Message type
+33 SET LA7X=$$P^LA7VHLU(.LA7SEG,9,LA7FS)
+34 SET LA7MTYP=$PIECE(LA7X,LA7CS,1)
+35 ;
+36 ; Message Control ID
+37 SET LA7MID=$$P^LA7VHLU(.LA7SEG,10,LA7FS)
+38 ;
+39 ; HL7 version
+40 SET LA7X=$$P^LA7VHLU(.LA7SEG,12,LA7FS)
+41 SET LA7HLV=$PIECE(LA7X,LA7CS,1)
+42 ;
+43 ; Accept acknowledgement type
+44 SET LA7AAT(0)=$$P^LA7VHLU(.LA7SEG,15,LA7FS)
+45 ;
+46 ; Application acknowledgement type
+47 SET LA7AAT(1)=$$P^LA7VHLU(.LA7SEG,16,LA7FS)
+48 ;
+49 QUIT
+50 ;
+51 ;
ORC ; Process ORC segment
+1 NEW LA7X,LA7Y
+2 ;
+3 ; Order control
+4 SET LA7OTYPE=$$P^LA7VHLU(.LA7SEG,2,LA7FS)
+5 ;
+6 ; Place order number
+7 SET LA7PON=$$P^LA7VHLU(.LA7SEG,3,LA7FS)
+8 ;
+9 ; Setup shipping manifest variable
+10 SET LA7Y=0
+11 SET LA7X=$PIECE($$P^LA7VHLU(.LA7SEG,5,LA7FS),LA7CS)
+12 IF LA7X'=""
SET LA7Y=$ORDER(^LAHM(62.8,"B",LA7X,0))
+13 IF LA7Y
SET LA7628=LA7Y
+14 SET LA7SM=LA7Y_"^"_LA7X
+15 ;
+16 ; Setup shipping configuration variable
+17 IF $PIECE(LA7SM,"^")
SET LA7629=+$PIECE($GET(^LAHM(62.8,$PIECE(LA7SM,"^"),0)),"^",2)
+18 IF '$TEST
SET LA7629=0
+19 ;
+20 ; Set new order/shipping manifest received alert/identifiers
+21 IF LA7MTYP="ORM"
IF $PIECE(LA7SM,"^",2)'=""
Begin DoDot:1
+22 SET ^TMP("LA7-ORM",$JOB,LA76248,LA76249,$PIECE(LA7SM,"^",2))=""
+23 DO SETID^LA7VHLU1(LA76249,LA7ID,$PIECE(LA7SM,"^",2),1)
+24 DO SETID^LA7VHLU1(LA76249,"",$PIECE(LA7SM,"^",2),0)
End DoDot:1
+25 ;
+26 ; Order quantity/timing (duration, units, urgency)
+27 SET LA7ODUR=$PIECE($$P^LA7VHLU(.LA7SEG,8,LA7FS),LA7CS,3)
+28 SET LA7ODURU=$PIECE($$P^LA7VHLU(.LA7SEG,8,LA7FS),LA7CS,4)
+29 SET LA7OUR=$PIECE($$P^LA7VHLU(.LA7SEG,8,LA7FS),LA7CS,6)
+30 ;
+31 ; Date/time of transaction
+32 SET LA7ORDT=$$HL7TFM^XLFDT($PIECE($$P^LA7VHLU(.LA7SEG,10,LA7FS),LA7CS),"L")
+33 ;
+34 ; Placer's entered by (id^duz^last name, first name, mi [id])
+35 SET LA7X=$$P^LA7VHLU(.LA7SEG,11,LA7FS)
+36 SET LA7PEB=$$XCNTFM^LA7VHLU9(LA7X,LA7ECH)
+37 IF LA7PEB="^0^"
SET LA7PEB=""
+38 ;
+39 ; Placer's verified by (id^duz^last name, first name, mi [id])
+40 SET LA7X=$$P^LA7VHLU(.LA7SEG,12,LA7FS)
+41 SET LA7PVB=$$XCNTFM^LA7VHLU9(LA7X,LA7ECH)
+42 IF LA7PVB="^0^"
SET LA7PVB=""
+43 ;
+44 ; Placer's ordering provider (id^duz^last name, first name, mi [id])
+45 SET LA7X=$$P^LA7VHLU(.LA7SEG,13,LA7FS)
+46 SET LA7POP=$$XCNTFM^LA7VHLU9(LA7X,LA7ECH)
+47 IF LA7POP="^0^"
SET LA7POP=""
+48 ;
+49 ; Enterer's ordering location
+50 SET LA7X=$$P^LA7VHLU(.LA7SEG,14,LA7FS)
+51 SET LA7Y=$$PLTFM^LA7VHLU4(LA7X,LA7FS,LA7ECH)
+52 SET LA7EOL=$PIECE(LA7Y,"^",1,3)
+53 IF LA7EOL="^0^"
SET LA7EOL=""
+54 ;
+55 ; Order control code reason
+56 SET LA7OCR=$$P^LA7VHLU(.LA7SEG,17,LA7FS)
+57 ;
+58 ;
+59 ; If ORM order message, determine specimen collecting site from ORC
+60 ; segment, if none use MSH sending facility value
+61 SET LA7CSITE=""
+62 IF LA7MTYP="ORM"
Begin DoDot:1
+63 SET LA7X=$PIECE($$P^LA7VHLU(.LA7SEG,18,LA7FS),LA7CS)
+64 SET LA7CSITE=$$FINDSITE^LA7VHLU2(LA7X,2,1)
+65 IF LA7CSITE'>0
SET LA7CSITE=$$FINDSITE^LA7VHLU2(LA7SFAC,2,0)
End DoDot:1
+66 ;
+67 QUIT
+68 ;
+69 ;
NTE ; Process NTE segment
+1 ;
+2 DO NTE^LA7VIN2A
+3 QUIT
+4 ;
+5 ;
PID ; Process PID segment
+1 NEW LA7I,LA7X,LA7Y,X,Y
+2 ;
+3 SET (DFN,LA7DOB,LA7ICN,LA7PRACE,LA7PNM,LA7PTID2,LA7PTID3,LA7PTID4,LA7SEX,LA7SSN,LRDFN,LRTDFN)=""
+4 ;
+5 ; PID Set ID
+6 SET LA7SPID=$$P^LA7VHLU(.LA7SEG,2,LA7FS)
+7 ;
+8 ; Extract patient identifiers
+9 SET LA7PTID2=$$P^LA7VHLU(.LA7SEG,3,LA7FS)
+10 SET LA7PTID3=$$P^LA7VHLU(.LA7SEG,4,LA7FS)
+11 SET LA7PTID4=$$P^LA7VHLU(.LA7SEG,5,LA7FS)
+12 ; Resolve ICN if identifier is from MPI
+13 ; Assume SSN is identifier if "SS" or blank
+14 FOR LA7I=1:1:$LENGTH(LA7PTID3,$EXTRACT(LA7ECH,2))
Begin DoDot:1
+15 NEW LA7J,LA7X,LA7ID
+16 SET X=$PIECE(LA7PTID3,$EXTRACT(LA7ECH,2),LA7I)
if '$LENGTH(X)
QUIT
+17 SET LA7PTID3(LA7I)=X
SET LA7ID=$PIECE(LA7PTID3(LA7I),$EXTRACT(LA7ECH),5)
+18 IF LA7ID'=""
IF "NI^PI"[LA7ID
Begin DoDot:2
+19 SET Y=$PIECE(LA7PTID3(LA7I),$EXTRACT(LA7ECH))
+20 IF Y?10N1"V"6N
SET LA7Y=Y
+21 IF '$TEST
SET LA7Y=Y_"V"_$PIECE(LA7PTID3(LA7I),$EXTRACT(LA7ECH),2)
+22 SET LA7X=$$CHKICN^LA7VHLU2(LA7Y)
+23 IF LA7X>0
SET DFN=$PIECE(LA7X,"^")
SET LA7ICN=$PIECE(LA7X,"^",2)
End DoDot:2
QUIT
+24 IF LA7ID="SS"!(LA7ID="")
Begin DoDot:2
+25 FOR LA7J=1:1:3
SET LA7X(LA7J)=$PIECE(LA7PTID3(LA7I),$EXTRACT(LA7ECH),LA7J)
+26 ;following line is commented out in LR*5.2*87
+27 ;Veteran Identification Card (VIC) ID's might be received
+28 ;in PID segment instead of social security numbers
+29 ;I LA7X(1)'?9N.1A Q
+30 ;routine DPTLK will return the DFN for an SSN
+31 ;or VIC ID
+32 IF '$GET(DFN)
DO RPCVIC^DPTLK(.DFN,LA7X(1))
+33 IF LA7X(3)="M11"
IF LA7X(2)'=$PIECE($$M11^HLFNC(LA7X(1),LA7ECH),$EXTRACT(LA7ECH),2)
QUIT
+34 ;following line commented out because VIC ID may have been received
+35 ;S LA7SSN=LA7X(1),DFN=$O(^DPT("SSN",LA7SSN,0))
+36 ;Determine SSN from DFN returned by DPTLK
+37 ;SSN is needed for transaction lookups in
+38 ;option Display Lab Universal Interface Message
+39 IF $GET(DFN)>0
Begin DoDot:3
+40 NEW VADM
+41 DO DEM^VADPT
+42 SET LA7SSN=$PIECE(VADM(2),"^")
End DoDot:3
End DoDot:2
QUIT
End DoDot:1
+43 ;
+44 ; Check PID-2 (alternate patient id) if PID-3 did not yield SSN/ICN
+45 FOR LA7I=1:1:$LENGTH(LA7PTID2,$EXTRACT(LA7ECH,2))
Begin DoDot:1
+46 NEW LA7J,LA7X,LA7ID
+47 SET X=$PIECE(LA7PTID2,$EXTRACT(LA7ECH,2),LA7I)
if '$LENGTH(X)
QUIT
+48 SET LA7PTID2(LA7I)=X
SET LA7ID=$PIECE(LA7PTID2(LA7I),$EXTRACT(LA7ECH),5)
+49 IF LA7ICN=""
IF LA7ID'=""
IF "NI^PI"[LA7ID
Begin DoDot:2
+50 SET Y=$PIECE(LA7PTID2(LA7I),$EXTRACT(LA7ECH))
+51 IF Y?10N1"V"6N
SET LA7Y=Y
+52 IF '$TEST
SET LA7Y=Y_"V"_$PIECE(LA7PTID2(LA7I),$EXTRACT(LA7ECH),2)
+53 SET LA7X=$$CHKICN^LA7VHLU2(LA7Y)
+54 IF LA7X>0
SET DFN=$PIECE(LA7X,"^")
SET LA7ICN=$PIECE(LA7X,"^",2)
End DoDot:2
QUIT
+55 IF LA7SSN=""
IF LA7ID="SS"!(LA7ID="")
Begin DoDot:2
+56 FOR LA7J=1:1:3
SET LA7X(LA7J)=$PIECE(LA7PTID2(LA7I),$EXTRACT(LA7ECH),LA7J)
+57 IF LA7X(1)'?9N.1A
QUIT
+58 IF LA7X(3)="M11"
IF LA7X(2)'=$PIECE($$M11^HLFNC(LA7X(1),LA7ECH),$EXTRACT(LA7ECH),2)
QUIT
+59 SET LA7SSN=LA7X(1)
SET DFN=$ORDER(^DPT("SSN",LA7SSN,0))
End DoDot:2
QUIT
End DoDot:1
+60 ;
+61 ; Extract patient name
+62 SET LA7X=$$P^LA7VHLU(.LA7SEG,6,LA7FS)
+63 IF LA7X'=""
Begin DoDot:1
+64 SET LA7PNM=$$FMNAME^HLFNC(LA7X,LA7ECH)
+65 DO SETID^LA7VHLU1(LA76249,LA7ID,LA7PNM,0)
+66 DO SETID^LA7VHLU1(LA76249,"",LA7PNM,0)
End DoDot:1
+67 ;
+68 ; Extract date of birth
+69 ; Check for degree of precision in 2nd component to provide backward compatibility with HL7 <v2.3
+70 SET LA7X=$$P^LA7VHLU(.LA7SEG,8,LA7FS)
+71 IF LA7X
Begin DoDot:1
+72 SET LA7Y=$PIECE(LA7X,LA7CS,2)
SET LA7X=$PIECE(LA7X,LA7CS,1)
+73 IF (LA7Y=""!(LA7Y="D"))
IF $EXTRACT(LA7X,9,12)="0000"
SET LA7X=$EXTRACT(LA7X,1,8)
+74 SET LA7DOB=$$HL7TFM^XLFDT(LA7X)
+75 IF LA7DOB<1
SET LA7DOB=""
+76 IF LA7Y="L"
SET LA7DOB=$EXTRACT(LA7DOB,1,5)_"00"
+77 IF LA7Y="Y"
SET LA7DOB=$EXTRACT(LA7DOB,1,3)_"0000"
End DoDot:1
+78 ;
+79 ; Extract patient's sex
+80 SET LA7SEX=$$P^LA7VHLU(.LA7SEG,9,LA7FS)
+81 ;
+82 ; Extract patient's race
+83 SET LA7X=$$P^LA7VHLU(.LA7SEG,11,LA7FS)
+84 IF $PIECE(LA7X,LA7CS)'=""
Begin DoDot:1
+85 IF $PIECE(LA7X,LA7CS,3)="0005"
SET $PIECE(LA7X,LA7CS,3)="HL70005"
+86 SET LA7PRACE=$PIECE(LA7X,LA7CS)_":"_$PIECE(LA7X,LA7CS,2)_$SELECT($PIECE(LA7X,LA7CS,3)'="":":"_$PIECE(LA7X,LA7CS,3),1:"")
End DoDot:1
+87 ;
+88 ; Extract patient's SSN and determine DFN
+89 ; If SSN determined previously from PID-3 then compare SSN's
+90 ; If DFN determined previously from ICN then check DFN based on SSN.
+91 SET LA7X=$PIECE($$P^LA7VHLU(.LA7SEG,20,LA7FS),LA7CS)
+92 ; remove "-" if any
SET LA7X=$TRANSLATE(LA7X,"-","")
+93 IF LA7X?9N.1A
Begin DoDot:1
+94 IF LA7SSN'=""
IF LA7X'=LA7SSN
QUIT
+95 SET LA7SSN=LA7X
+96 IF DFN
IF DFN'=$ORDER(^DPT("SSN",LA7SSN,0))
QUIT
+97 SET DFN=$ORDER(^DPT("SSN",LA7SSN,0))
End DoDot:1
+98 IF LA7SSN'=""
Begin DoDot:1
+99 IF LA7INTYP>19
IF LA7INTYP<30
DO SETID^LA7VHLU1(LA76249,LA7ID,LA7SSN,1)
QUIT
+100 DO SETID^LA7VHLU1(LA76249,LA7ID,LA7SSN,0)
End DoDot:1
+101 ;If VIC ID sent, set additional identifier for lookup
+102 ;VIC ID will always begin with "%"
+103 IF $EXTRACT($GET(LA7PTID3))="%"
Begin DoDot:1
+104 DO SETID^LA7VHLU1(LA76249,LA7ID,$PIECE(LA7PTID3,"^"),0)
End DoDot:1
+105 IF DFN
SET LRDFN=$PIECE($GET(^DPT(DFN,"LR")),"^")
+106 ;
+107 QUIT
+108 ;
+109 ;
PV1 ; Process PV1 segment
+1 ;
+2 ; PV1 Set ID
+3 SET LA7SPV1=$$P^LA7VHLU(.LA7SEG,2,LA7FS)
+4 ;
+5 ; Extract ordering location
+6 SET LA7LOC=$PIECE($$P^LA7VHLU(.LA7SEG,4,LA7FS),LA7CS)
+7 QUIT
