LA7COBRA ;VA/DALOI/JMC - LAB OBR segment builder (cont'd); 22-Oct-2013 09:22 ; MAW
;;5.2;AUTOMATED LAB INSTRUMENTS;**46,1018,64,1027,68,1033**;NOV 01, 1997
;
Q
;
;
OBR2 ; Build OBR-2 sequence - placer's specimen id
;
S LA7ID=$$CHKDATA^LA7VHLU3(LA7ID,LA7FS_LA7ECH)
S $P(LA7Y,$E(LA7ECH,1),1)=LA7ID
I $G(LA7ID("NMSP"))'="" S $P(LA7Y,$E(LA7ECH,1),2)=LA7ID("NMSP")
I $G(LA7ID("SITE"))'="" D
. S LA7X=$$FACDNS^LA7VHLU2(LA7ID("SITE"),LA7FS,LA7ECH,1)
. I $G(LA7INPT),$G(LRSS)'="MI" S $P(LA7Y,$E(LA7ECH),3)=$P(LA7X,$E(LA7ECH),2)
. I $G(LA7INPT),$G(LRSS)'="MI" S $P(LA7Y,$E(LA7ECH),4)=$P(LA7X,$E(LA7ECH),3)
;I $G(LA7INPT),$G(LRSS)="MI" S $P(LA7Y,$E(LA7ECH),2)="NIST EHR" ;mu2 inpatient micro
I $G(LA7INPT),$G(LRSS)'="MI" S $P(LA7Y,$E(LA7ECH),3)="2.16.840.1.113883.3.72.5.24"
I $G(LA7INPT),$G(LRSS)'="MI" S $P(LA7Y,$E(LA7ECH),4)="ISO"
Q
;
;
OBR3 ; Build OBR-3 sequence - filler's specimen id
;
S LA7ID=$$CHKDATA^LA7VHLU3(LA7ID,LA7FS_LA7ECH)
S $P(LA7Y,$E(LA7ECH,1),1)=LA7ID
I $G(LA7ID("NMSP"))'="" S $P(LA7Y,$E(LA7ECH,1),2)=LA7ID("NMSP")
I $G(LA7ID("SITE"))'="" D
. S LA7X=$$FACDNS^LA7VHLU2(LA7ID("SITE"),LA7FS,LA7ECH,1)
. I $G(LA7INPT),$G(LRSS)'="MI" S $P(LA7Y,$E(LA7ECH),3)=$P(LA7X,$E(LA7ECH),2)
. I $G(LA7INPT),$G(LRSS)'="MI" S $P(LA7Y,$E(LA7ECH),4)=$P(LA7X,$E(LA7ECH),3)
I $G(LA7INPT),$G(LRSS)'="MI" S $P(LA7Y,$E(LA7ECH),3)="2.16.840.1.113883.3.72.5.24"
I $G(LA7INPT),$G(LRSS)'="MI" S $P(LA7Y,$E(LA7ECH),4)="ISO"
I $G(LA7INPT),$G(LA7ADDON) S $P(LA7Y,$E(LA7ECH),3)=""
I $G(LA7INPT),$G(LA7ADDON) S $P(LA7Y,$E(LA7ECH),4)=""
Q
;
;
OBR4 ; Build OBR-4 sequence - Universal service ID
;
S LA764=0,LA7Y=""
; specify component position - primary/alternate
S LA7COMP=0
;
; Send non-VA test codes as first coding system
I LA7ALT'="" D
. N I
. F I=1:1:3 S $P(LA7Y,$E(LA7ECH),LA7COMP+I)=$$CHKDATA^LA7VHLU3($P(LA7ALT,"^",I),LA7FS_LA7ECH)
. S LA7COMP=LA7COMP+I
;
; Send NLT test codes as primary unless non-VA codes then send as alternate code
;lets try to get the loinc pointer here FOR MU2
I LA7NLT'="" D
. S LA764=$O(^LAM("E",LA7NLT,0)),LA7Z=""
. I LA764 S LA7Z=$$GET1^DIQ(64,LA764_",",.01,"I")
. I LA7Z="" D
. . N LA7642
. . S LA764=$O(^LAM("E",$P(LA7NLT,".")_".0000",0))
. . I LA764 S LA7Z=$$GET1^DIQ(64,LA764_",",.01,"I")
. . S LA7642=$O(^LAB(64.2,"F","."_$P(LA7NLT,".",2),0))
. . I LA764,LA7642 S LA7Z=LA7Z_"~"_$$GET1^DIQ(64.2,LA7642_",",.01,"I")
. I LRSS="MI",$G(LA7OBRSN)>1 D
.. S LA7953=$P($G(^LAM(LA764,9)),U)
. S $P(LA7Y,$E(LA7ECH),LA7COMP+4)=$$CHKDATA^LA7VHLU3(LA7NLT,LA7FS_LA7ECH)
. S $P(LA7Y,$E(LA7ECH),LA7COMP+5)=$$CHKDATA^LA7VHLU3(LA7Z,LA7FS_LA7ECH)
. S $P(LA7Y,$E(LA7ECH),LA7COMP+6)="L"
. S $P(LA7Y,$E(LA7ECH),LA7COMP+9)=$$CHKDATA^LA7VHLU3(LA7Z,LA7FS_LA7ECH)
. ;S LA7COMP=LA7COMP+3
;I $G(LA760)]"" D
;. N SPI
;. S SPI=0 F S SPI=$O(^LAB(60,LA760,1,SPI)) Q:'SPI!($G(LA7953)) D
;.. S LA7953=$G(^LAB(60,LA760,1,SPI,95.3))
;N LA7WKI
;I $G(LA7NLT)]"" S LA7WKI=$O(^LAM("E",LA7NLT,0))
;I $G(LA7WKI) S LA7953=$P($G(^LAM(LA7WKI,9)),U)
;MU2 we are going to use the IHS LOINC code field for all OBR segments
I $G(LA7953)="" S LA7953=$P($G(^LAB(60,LA760,9999999)),U,2) ;MU2 for panels since no site specimen
I $G(LA7953)'="" D
. N LA7IENS,LA7Z
. S LA7953=$P(LA7953,"-"),LA7IENS=LA7953_","
. D GETS^DIQ(95.3,LA7IENS,".01;80;99.99","E","LA7X")
. ; Invalid code???
. I $G(LA7X(95.3,LA7IENS,.01,"E"))="" Q
. S LA7Z=LA7X(95.3,LA7IENS,.01,"E")
. S LA7Z=$$CHKDATA^LA7VHLU3(LA7Z,LA7FS_LA7ECH)
. S $P(LA7Y,$E(LA7ECH,1),LA7COMP+1)=LA7Z
. S LA7Z=$G(LA7X(95.3,LA7IENS,80,"E"))
. S LA7Z=$$CHKDATA^LA7VHLU3(LA7Z,LA7FS_LA7ECH)
. S $P(LA7Y,$E(LA7ECH,1),LA7COMP+2)=LA7Z
. S $P(LA7Y,$E(LA7ECH,1),LA7COMP+3)="LN"
. S LA7COMP=LA7COMP+4
;
; Send file #60 test name if available and no alternate
I LA7COMP<4,LA760 D
. S LA7TN=$$GET1^DIQ(60,LA760_",",.01)
. S $P(LA7Y,$E(LA7ECH),LA7COMP+1)=LA760
. S $P(LA7Y,$E(LA7ECH),LA7COMP+2)=$$CHKDATA^LA7VHLU3(LA7TN,LA7FS_LA7ECH)
. S $P(LA7Y,$E(LA7ECH),LA7COMP+3)="L"
;
S $P(LA7Y,$E(LA7ECH),7)="2.40"
S $P(LA7Y,$E(LA7ECH),8)="1.0"
I $P(LA7Y,$E(LA7ECH),4)="",$G(LA7INPT) D ;mu2 inpatient
. S $P(LA7Y,$E(LA7ECH),4)=$P(LA7Y,$E(LA7ECH))
. S $P(LA7Y,$E(LA7ECH),5)=$P(LA7Y,$E(LA7ECH),2)
. S $P(LA7Y,$E(LA7ECH),6)="99USI"
. S $P(LA7Y,$E(LA7ECH),9)=$E($P(LA7Y,$E(LA7ECH),2),1,20)
Q
;
;
OBR9 ; Build OBR-9 sequence - collection volume
;
; Collection volume
S $P(LA7Y,$E(LA7ECH,1))=LA7VOL
;
I LA764061 D
. S LA7IENS=LA764061_","
. D GETS^DIQ(64.061,LA7IENS,".01;1","E","LA7Y")
. ; Collection Volume units code
. S $P(LA7X,$E(LA7ECH,4),1)=$G(LA7Y(64.061,LA7IENS,.01,"E"))
. ; Collection Volume units text
. S $P(LA7X,$E(LA7ECH,4),2)=$$CHKDATA^LA7VHLU3($G(LA7Y(64.061,LA7IENS,1,"E")),LA7FS_LA7ECH)
. ; LOINC coding system
. S $P(LA7X,$E(LA7ECH,4),3)="LN"
. S $P(LA7Y,$E(LA7ECH,1),2)=LA7X
;
Q
;
;
OBR24 ; Build OBR-24 sequence - diagnostic service id
;
; Code non-MI subscripts
I $P(LA7SS,"^")'="MI" D Q
. S LA7X=$P(LA7SS,"^")
. S LA7Y=$S(LA7X="CH":"CH",LA7X="SP":"SP",LA7X="CY":"CP",LA7X="EM":"PAT",LA7X="AU":"PAT",LA7X="BB":"BLB",1:"LAB")
;
; Code MI subscripts
S LA7X=$P(LA7SS,"^",2)
S LA7Y=$S(LA7X=11:"MB",LA7X=14:"PAR",LA7X=18:"MYC",LA7X=22:"MCB",LA7X=33:"VR",1:"MB")
;
Q
;
;
OBR25 ; Build OBR-25 sequence - Result status
;
S LA7Y=""
;
I LA7FLAG="F" S LA7Y="F"
I LA7FLAG="P" S LA7Y="P"
I LA7FLAG="A" S LA7Y="A"
I LA7FLAG="C" S LA7Y="C"
I LA7Y="" S LA7Y="F" ;MU2
;
Q
;
;
OBR26 ; Build OBR-26 sequence - Parent result
;
S LA7Y=""
;
; Move component into sub-component position
; Translate component character to sub-component character
S LA7C=$E(LA7ECH,1),LA7SC=$E(LA7ECH,4)
;
; Parent result observation identifier in 1st component
I LA7OBX3'="" S $P(LA7Y,$E(LA7ECH,1),1)=$TR(LA7OBX3,LA7C,LA7SC)
;
; Parent sub-id in 2nd component
I LA7OBX4'="" S $P(LA7Y,$E(LA7ECH,1),2)=$TR(LA7OBX4,LA7C,LA7SC)
;
; Parent test result in 3rd component
I LA7OBX5'="" S $P(LA7Y,$E(LA7ECH,1),3)=$TR(LA7OBX5,LA7C,LA7SC)
I $G(LA7INPT),$G(LA7ADDON) D
. N LNI
. S LNI=$P($G(^LAB(60,LA7ADDON,9999999)),U,2)
. Q:'LNI
. S $P(LA7Y,$E(LA7ECH,1),1)=$TR($P($G(LA7STOR(LNI)),"*"),LA7C,LA7SC)
. S $P(LA7Y,$E(LA7ECH,1),2)=$P($G(LA7STOR(LNI)),"*",2)
I $G(LA7INPT),$G(LRSS)="MI" S $P(LA7Y,$E(LA7ECH),2)=$G(LA7OBRSN)-1
I $G(LA7INPT),$G(LRSS)="MI" S $P(LA7Y,$E(LA7ECH),3,9)="" ;mu2 inpatient micro
;I $G(LA7INPT),$G(LA7ADDON) S $P(LA7Y,$E(LA7ECH),2)=$G(LA7OBRSN)-1
;I $G(LA7INPT),$G(LA7ADDON) S $P(LA7Y,$E(LA7ECH),3)="" ;mu2 inpatient
;
Q
;
;
OBR29 ; Build OBR-29 sequence - Parent
;
S LA7Y=""
;
I $G(LA7PON)'="" D
. S LA7Z=$$CHKDATA^LA7VHLU3(LA7PON,LA7FS_LA7ECH)
. S $P(LA7Y,$E(LA7ECH,1),1)=LA7Z
. I $G(LA7INPT),$G(LRSS)="MI" S $P(LA7Y,$E(LA7ECH,4),2)="LR"
. I $G(LA7INPT),$G(LA7ADDON) S $P(LA7Y,$E(LA7ECH,4),2)="LR"
;
I $G(LA7FON)'="" D
. S LA7Z=$$CHKDATA^LA7VHLU3(LA7FON,LA7FS_LA7ECH)
. S $P(LA7Y,$E(LA7ECH,1),2)=LA7Z
N LA7M
S LA7M=$P(LA7Y,$E(LA7ECH),2)
S $P(LA7M,$E(LA7ECH,4),2)="LIS"
I $G(LA7INPT),$G(LRSS)="MI" S $P(LA7M,$E(LA7ECH,4),2)="LR"
I $G(LA7INPT),$G(LA7ADDON) S $P(LA7M,$E(LA7ECH,4),2)="LR"
S $P(LA7M,$E(LA7ECH,4),3)="2.16.840.1.113883.3.72.6.27"
I $G(LA7INPT),$G(LRSS)="MI" S $P(LA7M,$E(LA7ECH,4),3)=""
I $G(LA7INPT),$G(LA7ADDON) S $P(LA7M,$E(LA7ECH,4),3)="2.16.840.1.113883.3.72.5.24"
S $P(LA7M,$E(LA7ECH,4),4)="ISO"
I $G(LA7INPT),$G(LRSS)="MI" S $P(LA7M,$E(LA7ECH,4),4)=""
I $G(LA7INPT),$G(LA7ADDON) S $P(LA7M,$E(LA7ECH,4),4)="ISO"
I $G(LA7INPT),$G(LA7ADDON) S $P(LA7Y,$E(LA7ECH))=LA7M
S $P(LA7Y,$E(LA7ECH),2)=LA7M
;
Q
;
;
OBRPF ; Build OBR-18,19,20,21 Placer/Filler #1/#2
;
S (LA7Y,LA7Z)="",LA7I=0
F S LA7I=$O(LA7X(LA7I)) Q:'LA7I S $P(LA7Z,"^",LA7I)=LA7X(LA7I)
S LA7Y=$$CHKDATA^LA7VHLU3(LA7Z,LA7FS_LA7ECH)
Q
;
;
OBR32 ; Build OBR-32 sequence - Principle Result Interpreter field
;
S LA7X=$$XCN^LA7CHLU9(LA7DUZ,LA7DIV,LA7FS,LA7ECH,0,2)
S LA7X=$TR(LA7X,$E(LA7ECH),$E(LA7ECH,4)) ;MU2
S $P(LA7PRI,$E(LA7ECH))=$P(LA7X,$E(LA7ECH,4),1,9)
;I LA7DIV S $P(LA7PRI,$E(LA7ECH),7)=$$FACDNS^LA7VHLU2(LA7DIV,LA7FS,LA7ECH,2)
Q
;
;
OBR33 ; Build OBR-32 sequence - Assistant Result Interpreter field
;
S LA7X=$$XCN^LA7CHLU9(LA7DUZ,LA7DIV,LA7FS,LA7ECH,1,2)
S $P(LA7ARI,$E(LA7ECH))=$P(LA7X,$E(LA7ECH,4),1,9)
I LA7DIV S $P(LA7ARI,$E(LA7ECH),7)=$$FACDNS^LA7VHLU2(LA7DIV,LA7FS,LA7ECH,2)
Q
;
OBR34 ; Build OBR-34 sequence - Technician field
;
S LA7X=$$XCN^LA7VHLU9(LA7DUZ,LA7DIV,LA7FS,LA7ECH,1,1)
S $P(LA7TECH,$E(LA7ECH))=$P(LA7X,$E(LA7ECH,4),1,9)
I LA7DIV S $P(LA7TECH,$E(LA7ECH),7)=$$FACDNS^LA7VHLU2(LA7DIV,LA7FS,LA7ECH,2)
Q
;
;
OBR35 ; Build OBR-35 sequence - Transcriptionist field
;
S LA7X=$$XCN^LA7VHLU9(LA7DUZ,LA7DIV,LA7FS,LA7ECH,1,1)
S $P(LA7TSPT,$E(LA7ECH))=$P(LA7X,$E(LA7ECH,4),1,9)
I LA7DIV S $P(LA7TSPT,$E(LA7ECH),7)=$$FACDNS^LA7VHLU2(LA7DIV,LA7FS,LA7ECH,2)
Q
;
;
OBR44 ; Build OBR-44
;
S (LA7X,LA7Y,LA7Z)=""
;
I LA7VAL="" Q
;
; Send NLT result code
S LA764=$O(^LAM("E",LA7VAL,0))
I LA764 S LA7X=$P($G(^LAM(LA764,0)),"^")
;
; If suffixed and not setup then construct from primary and suffix code.
I LA7X="" D
. N LA7642
. S LA764=$O(^LAM("E",$P(LA7VAL,".")_".0000",0))
. I LA764 S LA7X=$$GET1^DIQ(64,LA764_",",.01,"I")
. S LA7642=$O(^LAB(64.2,"F","."_$P(LA7VAL,".",2),0))
. I LA764,LA7642 S LA7X=LA7X_"~"_$$GET1^DIQ(64.2,LA7642_",",.01,"I")
;
I LA7X'="" S LA7X=$$CHKDATA^LA7VHLU3(LA7X,LA7FS_LA7ECH)
S $P(LA7Z,$E(LA7ECH,1),1)=LA7VAL
S $P(LA7Z,$E(LA7ECH,1),2)=LA7X
S $P(LA7Z,$E(LA7ECH,1),3)="99VA64"
;S LA7X=$$GET1^DID(64,"","","PACKAGE REVISION DATA")
;S $P(LA7Z,$E(LA7ECH,1),7)=LA7X
S LA7Y=LA7Z
;
; Check for and build CPT code in primary, move NLT to alternate
I LA764="" Q
I '$D(^LAM("AD",LA764,"CPT")) Q
S LA7X=$O(^LAM("AD",LA764,"CPT",0))
S LA781=+$P($G(^LAM(LA764,4,LA7X,0)),"^")
S LA7X=$$CPT^ICPTCOD(LA781,DT,1)
S LA7Z=$P(LA7X,"^",2)
S $P(LA7Z,$E(LA7ECH,1),2)=$$CHKDATA^LA7VHLU3($P(LA7X,"^",3),LA7FS_LA7ECH)
S $P(LA7Z,$E(LA7ECH,1),3)=$S($P(LA7X,"^",5)="C":"C4",$P(LA7X,"^",5)="HCPCS":"HCPCS",1:"L")
S LA7Y=LA7Z_$E(LA7ECH,1)_$P(LA7Y,$E(LA7ECH,1),1,3)
;S $P(LA7Y,$E(LA7ECH,1),8)=$P(LA7Y,$E(LA7ECH,1),7)
;S $P(LA7Y,$E(LA7ECH,1),7)=$P(LA7X,"^",6)
;
Q
LA7COBRA ;VA/DALOI/JMC - LAB OBR segment builder (cont'd); 22-Oct-2013 09:22 ; MAW
+1 ;;5.2;AUTOMATED LAB INSTRUMENTS;**46,1018,64,1027,68,1033**;NOV 01, 1997
+2 ;
+3 QUIT
+4 ;
+5 ;
OBR2 ; Build OBR-2 sequence - placer's specimen id
+1 ;
+2 SET LA7ID=$$CHKDATA^LA7VHLU3(LA7ID,LA7FS_LA7ECH)
+3 SET $PIECE(LA7Y,$EXTRACT(LA7ECH,1),1)=LA7ID
+4 IF $GET(LA7ID("NMSP"))'=""
SET $PIECE(LA7Y,$EXTRACT(LA7ECH,1),2)=LA7ID("NMSP")
+5 IF $GET(LA7ID("SITE"))'=""
Begin DoDot:1
+6 SET LA7X=$$FACDNS^LA7VHLU2(LA7ID("SITE"),LA7FS,LA7ECH,1)
+7 IF $GET(LA7INPT)
IF $GET(LRSS)'="MI"
SET $PIECE(LA7Y,$EXTRACT(LA7ECH),3)=$PIECE(LA7X,$EXTRACT(LA7ECH),2)
+8 IF $GET(LA7INPT)
IF $GET(LRSS)'="MI"
SET $PIECE(LA7Y,$EXTRACT(LA7ECH),4)=$PIECE(LA7X,$EXTRACT(LA7ECH),3)
End DoDot:1
+9 ;I $G(LA7INPT),$G(LRSS)="MI" S $P(LA7Y,$E(LA7ECH),2)="NIST EHR" ;mu2 inpatient micro
+10 IF $GET(LA7INPT)
IF $GET(LRSS)'="MI"
SET $PIECE(LA7Y,$EXTRACT(LA7ECH),3)="2.16.840.1.113883.3.72.5.24"
+11 IF $GET(LA7INPT)
IF $GET(LRSS)'="MI"
SET $PIECE(LA7Y,$EXTRACT(LA7ECH),4)="ISO"
+12 QUIT
+13 ;
+14 ;
OBR3 ; Build OBR-3 sequence - filler's specimen id
+1 ;
+2 SET LA7ID=$$CHKDATA^LA7VHLU3(LA7ID,LA7FS_LA7ECH)
+3 SET $PIECE(LA7Y,$EXTRACT(LA7ECH,1),1)=LA7ID
+4 IF $GET(LA7ID("NMSP"))'=""
SET $PIECE(LA7Y,$EXTRACT(LA7ECH,1),2)=LA7ID("NMSP")
+5 IF $GET(LA7ID("SITE"))'=""
Begin DoDot:1
+6 SET LA7X=$$FACDNS^LA7VHLU2(LA7ID("SITE"),LA7FS,LA7ECH,1)
+7 IF $GET(LA7INPT)
IF $GET(LRSS)'="MI"
SET $PIECE(LA7Y,$EXTRACT(LA7ECH),3)=$PIECE(LA7X,$EXTRACT(LA7ECH),2)
+8 IF $GET(LA7INPT)
IF $GET(LRSS)'="MI"
SET $PIECE(LA7Y,$EXTRACT(LA7ECH),4)=$PIECE(LA7X,$EXTRACT(LA7ECH),3)
End DoDot:1
+9 IF $GET(LA7INPT)
IF $GET(LRSS)'="MI"
SET $PIECE(LA7Y,$EXTRACT(LA7ECH),3)="2.16.840.1.113883.3.72.5.24"
+10 IF $GET(LA7INPT)
IF $GET(LRSS)'="MI"
SET $PIECE(LA7Y,$EXTRACT(LA7ECH),4)="ISO"
+11 IF $GET(LA7INPT)
IF $GET(LA7ADDON)
SET $PIECE(LA7Y,$EXTRACT(LA7ECH),3)=""
+12 IF $GET(LA7INPT)
IF $GET(LA7ADDON)
SET $PIECE(LA7Y,$EXTRACT(LA7ECH),4)=""
+13 QUIT
+14 ;
+15 ;
OBR4 ; Build OBR-4 sequence - Universal service ID
+1 ;
+2 SET LA764=0
SET LA7Y=""
+3 ; specify component position - primary/alternate
+4 SET LA7COMP=0
+5 ;
+6 ; Send non-VA test codes as first coding system
+7 IF LA7ALT'=""
Begin DoDot:1
+8 NEW I
+9 FOR I=1:1:3
SET $PIECE(LA7Y,$EXTRACT(LA7ECH),LA7COMP+I)=$$CHKDATA^LA7VHLU3($PIECE(LA7ALT,"^",I),LA7FS_LA7ECH)
+10 SET LA7COMP=LA7COMP+I
End DoDot:1
+11 ;
+12 ; Send NLT test codes as primary unless non-VA codes then send as alternate code
+13 ;lets try to get the loinc pointer here FOR MU2
+14 IF LA7NLT'=""
Begin DoDot:1
+15 SET LA764=$ORDER(^LAM("E",LA7NLT,0))
SET LA7Z=""
+16 IF LA764
SET LA7Z=$$GET1^DIQ(64,LA764_",",.01,"I")
+17 IF LA7Z=""
Begin DoDot:2
+18 NEW LA7642
+19 SET LA764=$ORDER(^LAM("E",$PIECE(LA7NLT,".")_".0000",0))
+20 IF LA764
SET LA7Z=$$GET1^DIQ(64,LA764_",",.01,"I")
+21 SET LA7642=$ORDER(^LAB(64.2,"F","."_$PIECE(LA7NLT,".",2),0))
+22 IF LA764
IF LA7642
SET LA7Z=LA7Z_"~"_$$GET1^DIQ(64.2,LA7642_",",.01,"I")
End DoDot:2
+23 IF LRSS="MI"
IF $GET(LA7OBRSN)>1
Begin DoDot:2
+24 SET LA7953=$PIECE($GET(^LAM(LA764,9)),U)
End DoDot:2
+25 SET $PIECE(LA7Y,$EXTRACT(LA7ECH),LA7COMP+4)=$$CHKDATA^LA7VHLU3(LA7NLT,LA7FS_LA7ECH)
+26 SET $PIECE(LA7Y,$EXTRACT(LA7ECH),LA7COMP+5)=$$CHKDATA^LA7VHLU3(LA7Z,LA7FS_LA7ECH)
+27 SET $PIECE(LA7Y,$EXTRACT(LA7ECH),LA7COMP+6)="L"
+28 SET $PIECE(LA7Y,$EXTRACT(LA7ECH),LA7COMP+9)=$$CHKDATA^LA7VHLU3(LA7Z,LA7FS_LA7ECH)
+29 ;S LA7COMP=LA7COMP+3
End DoDot:1
+30 ;I $G(LA760)]"" D
+31 ;. N SPI
+32 ;. S SPI=0 F S SPI=$O(^LAB(60,LA760,1,SPI)) Q:'SPI!($G(LA7953)) D
+33 ;.. S LA7953=$G(^LAB(60,LA760,1,SPI,95.3))
+34 ;N LA7WKI
+35 ;I $G(LA7NLT)]"" S LA7WKI=$O(^LAM("E",LA7NLT,0))
+36 ;I $G(LA7WKI) S LA7953=$P($G(^LAM(LA7WKI,9)),U)
+37 ;MU2 we are going to use the IHS LOINC code field for all OBR segments
+38 ;MU2 for panels since no site specimen
IF $GET(LA7953)=""
SET LA7953=$PIECE($GET(^LAB(60,LA760,9999999)),U,2)
+39 IF $GET(LA7953)'=""
Begin DoDot:1
+40 NEW LA7IENS,LA7Z
+41 SET LA7953=$PIECE(LA7953,"-")
SET LA7IENS=LA7953_","
+42 DO GETS^DIQ(95.3,LA7IENS,".01;80;99.99","E","LA7X")
+43 ; Invalid code???
+44 IF $GET(LA7X(95.3,LA7IENS,.01,"E"))=""
QUIT
+45 SET LA7Z=LA7X(95.3,LA7IENS,.01,"E")
+46 SET LA7Z=$$CHKDATA^LA7VHLU3(LA7Z,LA7FS_LA7ECH)
+47 SET $PIECE(LA7Y,$EXTRACT(LA7ECH,1),LA7COMP+1)=LA7Z
+48 SET LA7Z=$GET(LA7X(95.3,LA7IENS,80,"E"))
+49 SET LA7Z=$$CHKDATA^LA7VHLU3(LA7Z,LA7FS_LA7ECH)
+50 SET $PIECE(LA7Y,$EXTRACT(LA7ECH,1),LA7COMP+2)=LA7Z
+51 SET $PIECE(LA7Y,$EXTRACT(LA7ECH,1),LA7COMP+3)="LN"
+52 SET LA7COMP=LA7COMP+4
End DoDot:1
+53 ;
+54 ; Send file #60 test name if available and no alternate
+55 IF LA7COMP<4
IF LA760
Begin DoDot:1
+56 SET LA7TN=$$GET1^DIQ(60,LA760_",",.01)
+57 SET $PIECE(LA7Y,$EXTRACT(LA7ECH),LA7COMP+1)=LA760
+58 SET $PIECE(LA7Y,$EXTRACT(LA7ECH),LA7COMP+2)=$$CHKDATA^LA7VHLU3(LA7TN,LA7FS_LA7ECH)
+59 SET $PIECE(LA7Y,$EXTRACT(LA7ECH),LA7COMP+3)="L"
End DoDot:1
+60 ;
+61 SET $PIECE(LA7Y,$EXTRACT(LA7ECH),7)="2.40"
+62 SET $PIECE(LA7Y,$EXTRACT(LA7ECH),8)="1.0"
+63 ;mu2 inpatient
IF $PIECE(LA7Y,$EXTRACT(LA7ECH),4)=""
IF $GET(LA7INPT)
Begin DoDot:1
+64 SET $PIECE(LA7Y,$EXTRACT(LA7ECH),4)=$PIECE(LA7Y,$EXTRACT(LA7ECH))
+65 SET $PIECE(LA7Y,$EXTRACT(LA7ECH),5)=$PIECE(LA7Y,$EXTRACT(LA7ECH),2)
+66 SET $PIECE(LA7Y,$EXTRACT(LA7ECH),6)="99USI"
+67 SET $PIECE(LA7Y,$EXTRACT(LA7ECH),9)=$EXTRACT($PIECE(LA7Y,$EXTRACT(LA7ECH),2),1,20)
End DoDot:1
+68 QUIT
+69 ;
+70 ;
OBR9 ; Build OBR-9 sequence - collection volume
+1 ;
+2 ; Collection volume
+3 SET $PIECE(LA7Y,$EXTRACT(LA7ECH,1))=LA7VOL
+4 ;
+5 IF LA764061
Begin DoDot:1
+6 SET LA7IENS=LA764061_","
+7 DO GETS^DIQ(64.061,LA7IENS,".01;1","E","LA7Y")
+8 ; Collection Volume units code
+9 SET $PIECE(LA7X,$EXTRACT(LA7ECH,4),1)=$GET(LA7Y(64.061,LA7IENS,.01,"E"))
+10 ; Collection Volume units text
+11 SET $PIECE(LA7X,$EXTRACT(LA7ECH,4),2)=$$CHKDATA^LA7VHLU3($GET(LA7Y(64.061,LA7IENS,1,"E")),LA7FS_LA7ECH)
+12 ; LOINC coding system
+13 SET $PIECE(LA7X,$EXTRACT(LA7ECH,4),3)="LN"
+14 SET $PIECE(LA7Y,$EXTRACT(LA7ECH,1),2)=LA7X
End DoDot:1
+15 ;
+16 QUIT
+17 ;
+18 ;
OBR24 ; Build OBR-24 sequence - diagnostic service id
+1 ;
+2 ; Code non-MI subscripts
+3 IF $PIECE(LA7SS,"^")'="MI"
Begin DoDot:1
+4 SET LA7X=$PIECE(LA7SS,"^")
+5 SET LA7Y=$SELECT(LA7X="CH":"CH",LA7X="SP":"SP",LA7X="CY":"CP",LA7X="EM":"PAT",LA7X="AU":"PAT",LA7X="BB":"BLB",1:"LAB")
End DoDot:1
QUIT
+6 ;
+7 ; Code MI subscripts
+8 SET LA7X=$PIECE(LA7SS,"^",2)
+9 SET LA7Y=$SELECT(LA7X=11:"MB",LA7X=14:"PAR",LA7X=18:"MYC",LA7X=22:"MCB",LA7X=33:"VR",1:"MB")
+10 ;
+11 QUIT
+12 ;
+13 ;
OBR25 ; Build OBR-25 sequence - Result status
+1 ;
+2 SET LA7Y=""
+3 ;
+4 IF LA7FLAG="F"
SET LA7Y="F"
+5 IF LA7FLAG="P"
SET LA7Y="P"
+6 IF LA7FLAG="A"
SET LA7Y="A"
+7 IF LA7FLAG="C"
SET LA7Y="C"
+8 ;MU2
IF LA7Y=""
SET LA7Y="F"
+9 ;
+10 QUIT
+11 ;
+12 ;
OBR26 ; Build OBR-26 sequence - Parent result
+1 ;
+2 SET LA7Y=""
+3 ;
+4 ; Move component into sub-component position
+5 ; Translate component character to sub-component character
+6 SET LA7C=$EXTRACT(LA7ECH,1)
SET LA7SC=$EXTRACT(LA7ECH,4)
+7 ;
+8 ; Parent result observation identifier in 1st component
+9 IF LA7OBX3'=""
SET $PIECE(LA7Y,$EXTRACT(LA7ECH,1),1)=$TRANSLATE(LA7OBX3,LA7C,LA7SC)
+10 ;
+11 ; Parent sub-id in 2nd component
+12 IF LA7OBX4'=""
SET $PIECE(LA7Y,$EXTRACT(LA7ECH,1),2)=$TRANSLATE(LA7OBX4,LA7C,LA7SC)
+13 ;
+14 ; Parent test result in 3rd component
+15 IF LA7OBX5'=""
SET $PIECE(LA7Y,$EXTRACT(LA7ECH,1),3)=$TRANSLATE(LA7OBX5,LA7C,LA7SC)
+16 IF $GET(LA7INPT)
IF $GET(LA7ADDON)
Begin DoDot:1
+17 NEW LNI
+18 SET LNI=$PIECE($GET(^LAB(60,LA7ADDON,9999999)),U,2)
+19 IF 'LNI
QUIT
+20 SET $PIECE(LA7Y,$EXTRACT(LA7ECH,1),1)=$TRANSLATE($PIECE($GET(LA7STOR(LNI)),"*"),LA7C,LA7SC)
+21 SET $PIECE(LA7Y,$EXTRACT(LA7ECH,1),2)=$PIECE($GET(LA7STOR(LNI)),"*",2)
End DoDot:1
+22 IF $GET(LA7INPT)
IF $GET(LRSS)="MI"
SET $PIECE(LA7Y,$EXTRACT(LA7ECH),2)=$GET(LA7OBRSN)-1
+23 ;mu2 inpatient micro
IF $GET(LA7INPT)
IF $GET(LRSS)="MI"
SET $PIECE(LA7Y,$EXTRACT(LA7ECH),3,9)=""
+24 ;I $G(LA7INPT),$G(LA7ADDON) S $P(LA7Y,$E(LA7ECH),2)=$G(LA7OBRSN)-1
+25 ;I $G(LA7INPT),$G(LA7ADDON) S $P(LA7Y,$E(LA7ECH),3)="" ;mu2 inpatient
+26 ;
+27 QUIT
+28 ;
+29 ;
OBR29 ; Build OBR-29 sequence - Parent
+1 ;
+2 SET LA7Y=""
+3 ;
+4 IF $GET(LA7PON)'=""
Begin DoDot:1
+5 SET LA7Z=$$CHKDATA^LA7VHLU3(LA7PON,LA7FS_LA7ECH)
+6 SET $PIECE(LA7Y,$EXTRACT(LA7ECH,1),1)=LA7Z
+7 IF $GET(LA7INPT)
IF $GET(LRSS)="MI"
SET $PIECE(LA7Y,$EXTRACT(LA7ECH,4),2)="LR"
+8 IF $GET(LA7INPT)
IF $GET(LA7ADDON)
SET $PIECE(LA7Y,$EXTRACT(LA7ECH,4),2)="LR"
End DoDot:1
+9 ;
+10 IF $GET(LA7FON)'=""
Begin DoDot:1
+11 SET LA7Z=$$CHKDATA^LA7VHLU3(LA7FON,LA7FS_LA7ECH)
+12 SET $PIECE(LA7Y,$EXTRACT(LA7ECH,1),2)=LA7Z
End DoDot:1
+13 NEW LA7M
+14 SET LA7M=$PIECE(LA7Y,$EXTRACT(LA7ECH),2)
+15 SET $PIECE(LA7M,$EXTRACT(LA7ECH,4),2)="LIS"
+16 IF $GET(LA7INPT)
IF $GET(LRSS)="MI"
SET $PIECE(LA7M,$EXTRACT(LA7ECH,4),2)="LR"
+17 IF $GET(LA7INPT)
IF $GET(LA7ADDON)
SET $PIECE(LA7M,$EXTRACT(LA7ECH,4),2)="LR"
+18 SET $PIECE(LA7M,$EXTRACT(LA7ECH,4),3)="2.16.840.1.113883.3.72.6.27"
+19 IF $GET(LA7INPT)
IF $GET(LRSS)="MI"
SET $PIECE(LA7M,$EXTRACT(LA7ECH,4),3)=""
+20 IF $GET(LA7INPT)
IF $GET(LA7ADDON)
SET $PIECE(LA7M,$EXTRACT(LA7ECH,4),3)="2.16.840.1.113883.3.72.5.24"
+21 SET $PIECE(LA7M,$EXTRACT(LA7ECH,4),4)="ISO"
+22 IF $GET(LA7INPT)
IF $GET(LRSS)="MI"
SET $PIECE(LA7M,$EXTRACT(LA7ECH,4),4)=""
+23 IF $GET(LA7INPT)
IF $GET(LA7ADDON)
SET $PIECE(LA7M,$EXTRACT(LA7ECH,4),4)="ISO"
+24 IF $GET(LA7INPT)
IF $GET(LA7ADDON)
SET $PIECE(LA7Y,$EXTRACT(LA7ECH))=LA7M
+25 SET $PIECE(LA7Y,$EXTRACT(LA7ECH),2)=LA7M
+26 ;
+27 QUIT
+28 ;
+29 ;
OBRPF ; Build OBR-18,19,20,21 Placer/Filler #1/#2
+1 ;
+2 SET (LA7Y,LA7Z)=""
SET LA7I=0
+3 FOR
SET LA7I=$ORDER(LA7X(LA7I))
IF 'LA7I
QUIT
SET $PIECE(LA7Z,"^",LA7I)=LA7X(LA7I)
+4 SET LA7Y=$$CHKDATA^LA7VHLU3(LA7Z,LA7FS_LA7ECH)
+5 QUIT
+6 ;
+7 ;
OBR32 ; Build OBR-32 sequence - Principle Result Interpreter field
+1 ;
+2 SET LA7X=$$XCN^LA7CHLU9(LA7DUZ,LA7DIV,LA7FS,LA7ECH,0,2)
+3 ;MU2
SET LA7X=$TRANSLATE(LA7X,$EXTRACT(LA7ECH),$EXTRACT(LA7ECH,4))
+4 SET $PIECE(LA7PRI,$EXTRACT(LA7ECH))=$PIECE(LA7X,$EXTRACT(LA7ECH,4),1,9)
+5 ;I LA7DIV S $P(LA7PRI,$E(LA7ECH),7)=$$FACDNS^LA7VHLU2(LA7DIV,LA7FS,LA7ECH,2)
+6 QUIT
+7 ;
+8 ;
OBR33 ; Build OBR-32 sequence - Assistant Result Interpreter field
+1 ;
+2 SET LA7X=$$XCN^LA7CHLU9(LA7DUZ,LA7DIV,LA7FS,LA7ECH,1,2)
+3 SET $PIECE(LA7ARI,$EXTRACT(LA7ECH))=$PIECE(LA7X,$EXTRACT(LA7ECH,4),1,9)
+4 IF LA7DIV
SET $PIECE(LA7ARI,$EXTRACT(LA7ECH),7)=$$FACDNS^LA7VHLU2(LA7DIV,LA7FS,LA7ECH,2)
+5 QUIT
+6 ;
OBR34 ; Build OBR-34 sequence - Technician field
+1 ;
+2 SET LA7X=$$XCN^LA7VHLU9(LA7DUZ,LA7DIV,LA7FS,LA7ECH,1,1)
+3 SET $PIECE(LA7TECH,$EXTRACT(LA7ECH))=$PIECE(LA7X,$EXTRACT(LA7ECH,4),1,9)
+4 IF LA7DIV
SET $PIECE(LA7TECH,$EXTRACT(LA7ECH),7)=$$FACDNS^LA7VHLU2(LA7DIV,LA7FS,LA7ECH,2)
+5 QUIT
+6 ;
+7 ;
OBR35 ; Build OBR-35 sequence - Transcriptionist field
+1 ;
+2 SET LA7X=$$XCN^LA7VHLU9(LA7DUZ,LA7DIV,LA7FS,LA7ECH,1,1)
+3 SET $PIECE(LA7TSPT,$EXTRACT(LA7ECH))=$PIECE(LA7X,$EXTRACT(LA7ECH,4),1,9)
+4 IF LA7DIV
SET $PIECE(LA7TSPT,$EXTRACT(LA7ECH),7)=$$FACDNS^LA7VHLU2(LA7DIV,LA7FS,LA7ECH,2)
+5 QUIT
+6 ;
+7 ;
OBR44 ; Build OBR-44
+1 ;
+2 SET (LA7X,LA7Y,LA7Z)=""
+3 ;
+4 IF LA7VAL=""
QUIT
+5 ;
+6 ; Send NLT result code
+7 SET LA764=$ORDER(^LAM("E",LA7VAL,0))
+8 IF LA764
SET LA7X=$PIECE($GET(^LAM(LA764,0)),"^")
+9 ;
+10 ; If suffixed and not setup then construct from primary and suffix code.
+11 IF LA7X=""
Begin DoDot:1
+12 NEW LA7642
+13 SET LA764=$ORDER(^LAM("E",$PIECE(LA7VAL,".")_".0000",0))
+14 IF LA764
SET LA7X=$$GET1^DIQ(64,LA764_",",.01,"I")
+15 SET LA7642=$ORDER(^LAB(64.2,"F","."_$PIECE(LA7VAL,".",2),0))
+16 IF LA764
IF LA7642
SET LA7X=LA7X_"~"_$$GET1^DIQ(64.2,LA7642_",",.01,"I")
End DoDot:1
+17 ;
+18 IF LA7X'=""
SET LA7X=$$CHKDATA^LA7VHLU3(LA7X,LA7FS_LA7ECH)
+19 SET $PIECE(LA7Z,$EXTRACT(LA7ECH,1),1)=LA7VAL
+20 SET $PIECE(LA7Z,$EXTRACT(LA7ECH,1),2)=LA7X
+21 SET $PIECE(LA7Z,$EXTRACT(LA7ECH,1),3)="99VA64"
+22 ;S LA7X=$$GET1^DID(64,"","","PACKAGE REVISION DATA")
+23 ;S $P(LA7Z,$E(LA7ECH,1),7)=LA7X
+24 SET LA7Y=LA7Z
+25 ;
+26 ; Check for and build CPT code in primary, move NLT to alternate
+27 IF LA764=""
QUIT
+28 IF '$DATA(^LAM("AD",LA764,"CPT"))
QUIT
+29 SET LA7X=$ORDER(^LAM("AD",LA764,"CPT",0))
+30 SET LA781=+$PIECE($GET(^LAM(LA764,4,LA7X,0)),"^")
+31 SET LA7X=$$CPT^ICPTCOD(LA781,DT,1)
+32 SET LA7Z=$PIECE(LA7X,"^",2)
+33 SET $PIECE(LA7Z,$EXTRACT(LA7ECH,1),2)=$$CHKDATA^LA7VHLU3($PIECE(LA7X,"^",3),LA7FS_LA7ECH)
+34 SET $PIECE(LA7Z,$EXTRACT(LA7ECH,1),3)=$SELECT($PIECE(LA7X,"^",5)="C":"C4",$PIECE(LA7X,"^",5)="HCPCS":"HCPCS",1:"L")
+35 SET LA7Y=LA7Z_$EXTRACT(LA7ECH,1)_$PIECE(LA7Y,$EXTRACT(LA7ECH,1),1,3)
+36 ;S $P(LA7Y,$E(LA7ECH,1),8)=$P(LA7Y,$E(LA7ECH,1),7)
+37 ;S $P(LA7Y,$E(LA7ECH,1),7)=$P(LA7X,"^",6)
+38 ;
+39 QUIT
