LA7VCIN2 ;VHA/DALOI/JMC - Process Incoming UI Msgs, continued ; 22-Oct-2013 09:22 ; MAW
;;5.2;AUTOMATED LAB INSTRUMENTS;**46,64,1027,1033**;NOV 01, 1997
;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 seperator
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)
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 mainfest received alert/identifiers
I LA7MTYP="ORM",$L($P(LA7SM,"^",2)) D
. S ^TMP("LA7-ORM",$J,LA76248,LA76249,$P(LA7SM,"^",2))=""
. D SETID^LA7VHLU1(LA76249,LA7ID,$P(LA7SM,"^",2))
;
; 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^LA7VHLU4(LA7X,LA7ECH)
I LA7PEB="^^" S LA7PEB=""
;
; Placer's verified by (id^duz^last name, first name, mi [id])
S LA7X=$$P^LA7VHLU(.LA7SEG,12,LA7FS)
S LA7PVB=$$XCNTFM^LA7VHLU4(LA7X,LA7ECH)
I LA7PVB="^^" S LA7PVB=""
;
; Placer's ordering provider (id^duz^last name, first name, mi [id])
S LA7X=$$P^LA7VHLU(.LA7SEG,13,LA7FS)
S LA7POP=$$XCNTFM^LA7VHLU4(LA7X,LA7ECH)
I LA7POP="^^" S LA7POP=""
;
; Enterer's ordering location
S LA7X=$$P^LA7VHLU(.LA7SEG,14,LA7FS)
S LA7Y=$$PLTFM^LA7VHLU4(LA7X,LA7ECH)
S LA7EOL=$P(LA7Y,"^",1,3)
I LA7EOL="^^" 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
; NTE segments contain comments from instruments or other facilities.
; NTE segments following OBR's contain comments which refer to the entire test battery.
; NTE segments following OBX's contain comments which are test specific.
;
; For comments in ORU messages:
; Test specific comments can be prefaced with a site defined prefix -
; see field REMARK PREFIX (#19) in CHEM TEST multiple of AUTOMATED INSTRUMENT (#62.4 file.
; There can be more than one NTE, each will be stored as a comment in ^LAH.
;
N LA7,LA7I,LA7NTE,LA7SOC
;
S LA7SOC=$$P^LA7VHLU(.LA7SEG,3,LA7FS)
S LA7NTE=$$P^LA7VHLU(.LA7SEG,4,LA7FS)
;
; Trim trailing spaces.
I LA7NTE'="" S LA7NTE=$$TRIM^XLFSTR(LA7NTE,"R"," ")
I LA7NTE="" S LA7NTE=" "
;
I LA7MTYP="ORM" D OCOM Q
;
; Check for repeating comments in NTE segment and process
; If "^" in remark then translate to "~" to store.
F LA7I=1:1:$L(LA7NTE,$E(LA7ECH,2)) D
. S LA7RMK=$P(LA7NTE,$E(LA7ECH,2),LA7I)
. I LA7RMK="" Q
. S LA7RMK=$$UNESC^LA7VHLU3(LA7RMK,LA7FS_LA7ECH)
. I LA7RMK["^" S LA7RMK=$TR(LA7RMK,"^","~")
. I LA7MTYP="ORU" D RCOM Q
. I LA7MTYP="ORR",$G(LA7OTYPE)="UA" D RCOM Q
;
Q
;
;
PID ; Process PID segment
N 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 is "SS" or blank
F I=1:1:$L(LA7PTID3,$E(LA7ECH,2)) D
. N J,LA7X,LA7ID
. S X=$P(LA7PTID3,$E(LA7ECH,2),I) Q:'$L(X)
. S LA7PTID3(I)=X,LA7ID=$P(LA7PTID3(I),$E(LA7ECH),5)
. I LA7ID'="","NI^PI"[LA7ID D Q
. . S Y=$P(LA7PTID3(I),$E(LA7ECH))
. . I Y?10N1"V"6N S LA7Y=Y
. . E S LA7Y=Y_"V"_$P(LA7PTID3(I),$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 J=1:1:3 S LA7X(J)=$P(LA7PTID3(I),$E(LA7ECH),J)
. . 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))
;
; Check PID-2 (alternate patient id) if PID-3 did not yield SSN/ICN
F I=1:1:$L(LA7PTID2,$E(LA7ECH,2)) D
. N J,LA7X,LA7ID
. S X=$P(LA7PTID2,$E(LA7ECH,2),I) Q:'$L(X)
. S LA7PTID2(I)=X,LA7ID=$P(LA7PTID2(I),$E(LA7ECH),5)
. I LA7ICN="",LA7ID'="","NI^PI"[LA7ID D Q
. . S Y=$P(LA7PTID2(I),$E(LA7ECH))
. . I Y?10N1"V"6N S LA7Y=Y
. . E S LA7Y=Y_"V"_$P(LA7PTID2(I),$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 J=1:1:3 S LA7X(J)=$P(LA7PTID2(I),$E(LA7ECH),J)
. . 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'="" S LA7PNM=$$FMNAME^HLFNC(LA7X,LA7ECH)
;
; 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 DFN D
. S LRDFN=$P($G(^DPT(DFN,"LR")),"^")
. S LRTDFN=$P($G(^DPT(DFN,"LRT")),"^")
;
; Race for MU2
S LA7RACE=$P($$P^LA7VHLU(.LA7SEG,11,LA7FS),LA7CS)
I $G(LA7RACE)]"" S LA7RACE=$O(^DIC(10,"AHL7",LA7RACE,0))
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
;
;
RCOM ; Store result comments in ORU messages
;
; Don't store remark if same as specimen comment (without "~").
I $G(LA7AA),$G(LA7AD),$G(LA7AN),LA7RMK=$TR($P($G(^LRO(68,LA7AA,1,LA7AD,1,LA7AN,3)),"^",6),"~") Q
; Or patient info (#.091 in file 63) - info previously downloaded
I $G(LA7AA),$G(LA7AD),$G(LA7AN),LA7RMK=$G(^LR(+$G(^LRO(68,LA7AA,1,LA7AD,1,LA7AN,0)),.091)) Q
;
; If test specific, store comment prefix with comments (see LA7VIN5)
I $O(LA7RMK(0,0)) D Q
. N LA7I
. S LA7I=0
. F S LA7I=$O(LA7RMK(0,LA7I)) Q:'LA7I D
. . I '$P(LA7RMK(0,LA7I),"^") Q
. . ; Don't store if status not "FINAL"
. . I $P(LA7RMK(0,LA7I),"^")=2,"CFU"'[$G(LA7ORS) Q
. . D RMKSET^LASET(LA7LWL,LA7ISQN,LA7RMK,$P(LA7RMK(0,LA7I),"^",2))
;
; Store comment in 1 node of ^LAH global
I $P(LA7624(0),"^",17) D RMKSET^LASET(LA7LWL,LA7ISQN,LA7RMK,"")
K LA7RMK
Q
;
;
OCOM ; Store order comments from ORM messages in file #69.6
; Check for repeating comments in NTE segment and process
; If "^" in remark then translate to "~" to store.
;
; If source of comment (LA7SOC) is "RQ" then comment is from CHCS which
; uses a composite data type for NTE-3. VistA only extracts component #9
; which contains the external value of the comment.
;
N LA7DIE,LA7RMK,LA7WP,X
I $G(LA7696)<1 Q
F LA7I=1:1:$L(LA7NTE,$E(LA7ECH,2)) D
. S LA7RMK=$P(LA7NTE,$E(LA7ECH,2),LA7I)
. I LA7SOC="RQ" D
. . S X=$P(LA7RMK,$E(LA7ECH),9)
. . I X'="" S LA7RMK=X
. I LA7RMK="" Q
. S LA7RMK=$$UNESC^LA7VHLU3(LA7RMK,LA7FS_LA7ECH)
. I LA7RMK["^" S LA7RMK=$TR(LA7RMK,"^","~")
. S LA7WP(LA7I,0)=LA7RMK
D WP^DIE(69.6,LA7696_",",99,"A","LA7WP","LA7DIE(99)")
Q
LA7VCIN2 ;VHA/DALOI/JMC - Process Incoming UI Msgs, continued ; 22-Oct-2013 09:22 ; MAW
+1 ;;5.2;AUTOMATED LAB INSTRUMENTS;**46,64,1027,1033**;NOV 01, 1997
+2 ;This routine is a continuation of LA7VIN1 and is only called from there.
+3 QUIT
+4 ;
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 seperator
+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 QUIT
+43 ;
+44 ;
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 mainfest received alert/identifiers
+21 IF LA7MTYP="ORM"
IF $LENGTH($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))
End DoDot:1
+24 ;
+25 ; Order quantity/timing (duration, units, urgency)
+26 SET LA7ODUR=$PIECE($$P^LA7VHLU(.LA7SEG,8,LA7FS),LA7CS,3)
+27 SET LA7ODURU=$PIECE($$P^LA7VHLU(.LA7SEG,8,LA7FS),LA7CS,4)
+28 SET LA7OUR=$PIECE($$P^LA7VHLU(.LA7SEG,8,LA7FS),LA7CS,6)
+29 ;
+30 ; Date/time of transaction
+31 SET LA7ORDT=$$HL7TFM^XLFDT($PIECE($$P^LA7VHLU(.LA7SEG,10,LA7FS),LA7CS),"L")
+32 ;
+33 ; Placer's entered by (id^duz^last name, first name, mi [id])
+34 SET LA7X=$$P^LA7VHLU(.LA7SEG,11,LA7FS)
+35 SET LA7PEB=$$XCNTFM^LA7VHLU4(LA7X,LA7ECH)
+36 IF LA7PEB="^^"
SET LA7PEB=""
+37 ;
+38 ; Placer's verified by (id^duz^last name, first name, mi [id])
+39 SET LA7X=$$P^LA7VHLU(.LA7SEG,12,LA7FS)
+40 SET LA7PVB=$$XCNTFM^LA7VHLU4(LA7X,LA7ECH)
+41 IF LA7PVB="^^"
SET LA7PVB=""
+42 ;
+43 ; Placer's ordering provider (id^duz^last name, first name, mi [id])
+44 SET LA7X=$$P^LA7VHLU(.LA7SEG,13,LA7FS)
+45 SET LA7POP=$$XCNTFM^LA7VHLU4(LA7X,LA7ECH)
+46 IF LA7POP="^^"
SET LA7POP=""
+47 ;
+48 ; Enterer's ordering location
+49 SET LA7X=$$P^LA7VHLU(.LA7SEG,14,LA7FS)
+50 SET LA7Y=$$PLTFM^LA7VHLU4(LA7X,LA7ECH)
+51 SET LA7EOL=$PIECE(LA7Y,"^",1,3)
+52 IF LA7EOL="^^"
SET LA7EOL=""
+53 ;
+54 ; Order control code reason
+55 SET LA7OCR=$$P^LA7VHLU(.LA7SEG,17,LA7FS)
+56 ;
+57 ;
+58 ; If ORM order message, determine specimen collecting site from ORC
+59 ; segment, if none use MSH sending facility value
+60 SET LA7CSITE=""
+61 IF LA7MTYP="ORM"
Begin DoDot:1
+62 SET LA7X=$PIECE($$P^LA7VHLU(.LA7SEG,18,LA7FS),LA7CS)
+63 SET LA7CSITE=$$FINDSITE^LA7VHLU2(LA7X,2,1)
+64 IF LA7CSITE'>0
SET LA7CSITE=$$FINDSITE^LA7VHLU2(LA7SFAC,2,0)
End DoDot:1
+65 ;
+66 QUIT
+67 ;
+68 ;
NTE ; Process NTE segment
+1 ; NTE segments contain comments from instruments or other facilities.
+2 ; NTE segments following OBR's contain comments which refer to the entire test battery.
+3 ; NTE segments following OBX's contain comments which are test specific.
+4 ;
+5 ; For comments in ORU messages:
+6 ; Test specific comments can be prefaced with a site defined prefix -
+7 ; see field REMARK PREFIX (#19) in CHEM TEST multiple of AUTOMATED INSTRUMENT (#62.4 file.
+8 ; There can be more than one NTE, each will be stored as a comment in ^LAH.
+9 ;
+10 NEW LA7,LA7I,LA7NTE,LA7SOC
+11 ;
+12 SET LA7SOC=$$P^LA7VHLU(.LA7SEG,3,LA7FS)
+13 SET LA7NTE=$$P^LA7VHLU(.LA7SEG,4,LA7FS)
+14 ;
+15 ; Trim trailing spaces.
+16 IF LA7NTE'=""
SET LA7NTE=$$TRIM^XLFSTR(LA7NTE,"R"," ")
+17 IF LA7NTE=""
SET LA7NTE=" "
+18 ;
+19 IF LA7MTYP="ORM"
DO OCOM
QUIT
+20 ;
+21 ; Check for repeating comments in NTE segment and process
+22 ; If "^" in remark then translate to "~" to store.
+23 FOR LA7I=1:1:$LENGTH(LA7NTE,$EXTRACT(LA7ECH,2))
Begin DoDot:1
+24 SET LA7RMK=$PIECE(LA7NTE,$EXTRACT(LA7ECH,2),LA7I)
+25 IF LA7RMK=""
QUIT
+26 SET LA7RMK=$$UNESC^LA7VHLU3(LA7RMK,LA7FS_LA7ECH)
+27 IF LA7RMK["^"
SET LA7RMK=$TRANSLATE(LA7RMK,"^","~")
+28 IF LA7MTYP="ORU"
DO RCOM
QUIT
+29 IF LA7MTYP="ORR"
IF $GET(LA7OTYPE)="UA"
DO RCOM
QUIT
End DoDot:1
+30 ;
+31 QUIT
+32 ;
+33 ;
PID ; Process PID segment
+1 NEW 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 is "SS" or blank
+14 FOR I=1:1:$LENGTH(LA7PTID3,$EXTRACT(LA7ECH,2))
Begin DoDot:1
+15 NEW J,LA7X,LA7ID
+16 SET X=$PIECE(LA7PTID3,$EXTRACT(LA7ECH,2),I)
IF '$LENGTH(X)
QUIT
+17 SET LA7PTID3(I)=X
SET LA7ID=$PIECE(LA7PTID3(I),$EXTRACT(LA7ECH),5)
+18 IF LA7ID'=""
IF "NI^PI"[LA7ID
Begin DoDot:2
+19 SET Y=$PIECE(LA7PTID3(I),$EXTRACT(LA7ECH))
+20 IF Y?10N1"V"6N
SET LA7Y=Y
+21 IF '$TEST
SET LA7Y=Y_"V"_$PIECE(LA7PTID3(I),$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 J=1:1:3
SET LA7X(J)=$PIECE(LA7PTID3(I),$EXTRACT(LA7ECH),J)
+26 IF LA7X(1)'?9N.1A
QUIT
+27 IF LA7X(3)="M11"
IF LA7X(2)'=$PIECE($$M11^HLFNC(LA7X(1),LA7ECH),$EXTRACT(LA7ECH),2)
QUIT
+28 SET LA7SSN=LA7X(1)
SET DFN=$ORDER(^DPT("SSN",LA7SSN,0))
End DoDot:2
QUIT
End DoDot:1
+29 ;
+30 ; Check PID-2 (alternate patient id) if PID-3 did not yield SSN/ICN
+31 FOR I=1:1:$LENGTH(LA7PTID2,$EXTRACT(LA7ECH,2))
Begin DoDot:1
+32 NEW J,LA7X,LA7ID
+33 SET X=$PIECE(LA7PTID2,$EXTRACT(LA7ECH,2),I)
IF '$LENGTH(X)
QUIT
+34 SET LA7PTID2(I)=X
SET LA7ID=$PIECE(LA7PTID2(I),$EXTRACT(LA7ECH),5)
+35 IF LA7ICN=""
IF LA7ID'=""
IF "NI^PI"[LA7ID
Begin DoDot:2
+36 SET Y=$PIECE(LA7PTID2(I),$EXTRACT(LA7ECH))
+37 IF Y?10N1"V"6N
SET LA7Y=Y
+38 IF '$TEST
SET LA7Y=Y_"V"_$PIECE(LA7PTID2(I),$EXTRACT(LA7ECH),2)
+39 SET LA7X=$$CHKICN^LA7VHLU2(LA7Y)
+40 IF LA7X>0
SET DFN=$PIECE(LA7X,"^")
SET LA7ICN=$PIECE(LA7X,"^",2)
End DoDot:2
QUIT
+41 IF LA7SSN=""
IF LA7ID="SS"!(LA7ID="")
Begin DoDot:2
+42 FOR J=1:1:3
SET LA7X(J)=$PIECE(LA7PTID2(I),$EXTRACT(LA7ECH),J)
+43 IF LA7X(1)'?9N.1A
QUIT
+44 IF LA7X(3)="M11"
IF LA7X(2)'=$PIECE($$M11^HLFNC(LA7X(1),LA7ECH),$EXTRACT(LA7ECH),2)
QUIT
+45 SET LA7SSN=LA7X(1)
SET DFN=$ORDER(^DPT("SSN",LA7SSN,0))
End DoDot:2
QUIT
End DoDot:1
+46 ;
+47 ; Extract patient name
+48 SET LA7X=$$P^LA7VHLU(.LA7SEG,6,LA7FS)
+49 IF LA7X'=""
SET LA7PNM=$$FMNAME^HLFNC(LA7X,LA7ECH)
+50 ;
+51 ; Extract date of birth
+52 ; Check for degree of precision in 2nd component to provide backward compatibility with HL7 <v2.3
+53 SET LA7X=$$P^LA7VHLU(.LA7SEG,8,LA7FS)
+54 IF LA7X
Begin DoDot:1
+55 SET LA7Y=$PIECE(LA7X,LA7CS,2)
SET LA7X=$PIECE(LA7X,LA7CS,1)
+56 IF (LA7Y=""!(LA7Y="D"))
IF $EXTRACT(LA7X,9,12)="0000"
SET LA7X=$EXTRACT(LA7X,1,8)
+57 SET LA7DOB=$$HL7TFM^XLFDT(LA7X)
+58 IF LA7DOB<1
SET LA7DOB=""
+59 IF LA7Y="L"
SET LA7DOB=$EXTRACT(LA7DOB,1,5)_"00"
+60 IF LA7Y="Y"
SET LA7DOB=$EXTRACT(LA7DOB,1,3)_"0000"
End DoDot:1
+61 ;
+62 ; Extract patient's sex
+63 SET LA7SEX=$$P^LA7VHLU(.LA7SEG,9,LA7FS)
+64 ;
+65 ; Extract patient's race
+66 SET LA7X=$$P^LA7VHLU(.LA7SEG,11,LA7FS)
+67 IF $PIECE(LA7X,LA7CS)'=""
Begin DoDot:1
+68 IF $PIECE(LA7X,LA7CS,3)="0005"
SET $PIECE(LA7X,LA7CS,3)="HL70005"
+69 SET LA7PRACE=$PIECE(LA7X,LA7CS)_":"_$PIECE(LA7X,LA7CS,2)_$SELECT($PIECE(LA7X,LA7CS,3)'="":":"_$PIECE(LA7X,LA7CS,3),1:"")
End DoDot:1
+70 ;
+71 ; Extract patient's SSN and determine DFN
+72 ; If SSN determined previously from PID-3 then compare SSN's
+73 ; If DFN determined previously from ICN then check DFN based on SSN.
+74 SET LA7X=$PIECE($$P^LA7VHLU(.LA7SEG,20,LA7FS),LA7CS)
+75 ; remove "-" if any
SET LA7X=$TRANSLATE(LA7X,"-","")
+76 IF LA7X?9N.1A
Begin DoDot:1
+77 IF LA7SSN'=""
IF LA7X'=LA7SSN
QUIT
+78 SET LA7SSN=LA7X
+79 IF DFN
IF DFN'=$ORDER(^DPT("SSN",LA7SSN,0))
QUIT
+80 SET DFN=$ORDER(^DPT("SSN",LA7SSN,0))
End DoDot:1
+81 IF DFN
Begin DoDot:1
+82 SET LRDFN=$PIECE($GET(^DPT(DFN,"LR")),"^")
+83 SET LRTDFN=$PIECE($GET(^DPT(DFN,"LRT")),"^")
End DoDot:1
+84 ;
+85 ; Race for MU2
+86 SET LA7RACE=$PIECE($$P^LA7VHLU(.LA7SEG,11,LA7FS),LA7CS)
+87 IF $GET(LA7RACE)]""
SET LA7RACE=$ORDER(^DIC(10,"AHL7",LA7RACE,0))
+88 QUIT
+89 ;
+90 ;
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
+8 ;
+9 ;
RCOM ; Store result comments in ORU messages
+1 ;
+2 ; Don't store remark if same as specimen comment (without "~").
+3 IF $GET(LA7AA)
IF $GET(LA7AD)
IF $GET(LA7AN)
IF LA7RMK=$TRANSLATE($PIECE($GET(^LRO(68,LA7AA,1,LA7AD,1,LA7AN,3)),"^",6),"~")
QUIT
+4 ; Or patient info (#.091 in file 63) - info previously downloaded
+5 IF $GET(LA7AA)
IF $GET(LA7AD)
IF $GET(LA7AN)
IF LA7RMK=$GET(^LR(+$GET(^LRO(68,LA7AA,1,LA7AD,1,LA7AN,0)),.091))
QUIT
+6 ;
+7 ; If test specific, store comment prefix with comments (see LA7VIN5)
+8 IF $ORDER(LA7RMK(0,0))
Begin DoDot:1
+9 NEW LA7I
+10 SET LA7I=0
+11 FOR
SET LA7I=$ORDER(LA7RMK(0,LA7I))
IF 'LA7I
QUIT
Begin DoDot:2
+12 IF '$PIECE(LA7RMK(0,LA7I),"^")
QUIT
+13 ; Don't store if status not "FINAL"
+14 IF $PIECE(LA7RMK(0,LA7I),"^")=2
IF "CFU"'[$GET(LA7ORS)
QUIT
+15 DO RMKSET^LASET(LA7LWL,LA7ISQN,LA7RMK,$PIECE(LA7RMK(0,LA7I),"^",2))
End DoDot:2
End DoDot:1
QUIT
+16 ;
+17 ; Store comment in 1 node of ^LAH global
+18 IF $PIECE(LA7624(0),"^",17)
DO RMKSET^LASET(LA7LWL,LA7ISQN,LA7RMK,"")
+19 KILL LA7RMK
+20 QUIT
+21 ;
+22 ;
OCOM ; Store order comments from ORM messages in file #69.6
+1 ; Check for repeating comments in NTE segment and process
+2 ; If "^" in remark then translate to "~" to store.
+3 ;
+4 ; If source of comment (LA7SOC) is "RQ" then comment is from CHCS which
+5 ; uses a composite data type for NTE-3. VistA only extracts component #9
+6 ; which contains the external value of the comment.
+7 ;
+8 NEW LA7DIE,LA7RMK,LA7WP,X
+9 IF $GET(LA7696)<1
QUIT
+10 FOR LA7I=1:1:$LENGTH(LA7NTE,$EXTRACT(LA7ECH,2))
Begin DoDot:1
+11 SET LA7RMK=$PIECE(LA7NTE,$EXTRACT(LA7ECH,2),LA7I)
+12 IF LA7SOC="RQ"
Begin DoDot:2
+13 SET X=$PIECE(LA7RMK,$EXTRACT(LA7ECH),9)
+14 IF X'=""
SET LA7RMK=X
End DoDot:2
+15 IF LA7RMK=""
QUIT
+16 SET LA7RMK=$$UNESC^LA7VHLU3(LA7RMK,LA7FS_LA7ECH)
+17 IF LA7RMK["^"
SET LA7RMK=$TRANSLATE(LA7RMK,"^","~")
+18 SET LA7WP(LA7I,0)=LA7RMK
End DoDot:1
+19 DO WP^DIE(69.6,LA7696_",",99,"A","LA7WP","LA7DIE(99)")
+20 QUIT
