LA7VOBRB ;DALOI/JMC - LAB OBR segment builder (cont'd);Jan 8, 2008
;;5.2;AUTOMATED LAB INSTRUMENTS;**68,74,85**;Sep 27, 1994;Build 4
;
Q
;
;
OBR15 ; Build OBR-15 sequence - specimen source
;
S LA764061=0,LA7Y=""
S LA7COMP=0 ; specify subcomponent position - primary/alternate
; SNOMED code flag (0-do not encode with SNOMED, 1-encode with SNOMED, 2-encode with SNOMED only; no HL70070)
S LA7SNM=$G(LA7SNM)
;
; Get entry in #64.061 and SNOMED code for this Topography file #61 entry.
I LA761>0 D
. S LA761(0)=$G(^LAB(61,LA761,0)),LA764061=$P(LA761(0),"^",9)
. S $P(LA7Y,$E(LA7ECH,4),9)=$$CHKDATA^LA7VHLU3($P(LA761(0),"^"),LA7FS_LA7ECH)
;
; If no specimen code then default to HL7 0070 entry "XXX"
I LA761=0 D
. N LA7SCR
. S LA7SCR="I $P(^LAB(64.061,Y,0),U,5)=""0070"",$P(^LAB(64.061,Y,0),U,7)=""S"""
. S LA764061=$$FIND1^DIC(64.061,,"X","XXX","D",LA7SCR,"LA7ERR")
;
I LA764061 D GETS^DIQ(64.061,LA764061_",",".01;2;5","","LA7Z","LA7ERR")
;
; Send SNOMED as primary code
; If no SNOMED code and SNOMED only then allow HL7
I LA761,LA7SNM D
. ;check for override SNOMED CT ID
. I $G(LA76248)]"",$D(^LAHM(62.48,LA76248,"SCT","AC",LA761_";LAB(61,")) D
. . S $P(LA7ALT,"^",8)=$O(^LAHM(62.48,LA76248,"SCT","AC",LA761_";LAB(61,",0))
. S LA7X=$$IEN2SCT^LA7VHLU6(61,LA761,DT,$P(LA7ALT,"^",8))
. I LA7X="" S:LA7SNM=2 LA7SNM=1 Q
. S $P(LA7X,"^",2)=$$CHKDATA^LA7VHLU3($P(LA7X,"^",2),LA7FS_LA7ECH)
. S $P(LA7Y,$E(LA7ECH,4),LA7COMP+1,LA7COMP+3)=$TR($P(LA7X,"^",1,3),"^",$E(LA7ECH,4))
. S $P(LA7Y,$E(LA7ECH,4),7)=$P(LA7X,"^",4)
. S LA7COMP=LA7COMP+3
;
; Send non-standard local code as alternate unless SNOMED only flag and SNOMED code present.
I $P(LA7ALT,"^")'=""!($P(LA7ALT,"^",2)'="") D
. I LA7SNM=2,LA7COMP Q
. S LA7X=$$CHKDATA^LA7VHLU3($P(LA7ALT,"^"),LA7FS_LA7ECH)
. S $P(LA7Y,$E(LA7ECH,4),LA7COMP+1)=LA7X
. S LA7X=$$CHKDATA^LA7VHLU3($P(LA7ALT,"^",2),LA7FS_LA7ECH)
. S $P(LA7Y,$E(LA7ECH,4),LA7COMP+2)=LA7X
. S $P(LA7Y,$E(LA7ECH,4),LA7COMP+3)=$P(LA7ALT,"^",3)
. S LA7COMP=LA7COMP+3
;
; Send HL7 Table 0070 coding as alternate code
I LA7SNM'=2,LA764061,LA7Z(64.061,LA764061_",",2)'="",LA7COMP<6 D
. S LA7X=$$CHKDATA^LA7VHLU3(LA7Z(64.061,LA764061_",",2),LA7FS_LA7ECH)
. S $P(LA7Y,$E(LA7ECH,4),LA7COMP+1)=LA7X
. S LA7X=$$CHKDATA^LA7VHLU3(LA7Z(64.061,LA764061_",",.01),LA7FS_LA7ECH)
. S $P(LA7Y,$E(LA7ECH,4),LA7COMP+2)=LA7X
. S $P(LA7Y,$E(LA7ECH,4),LA7COMP+3)="HL7"_LA7Z(64.061,LA764061_",",5)
. S LA7COMP=LA7COMP+3
;
; If no code found then default to backups - try SNOMED I then file #61 as local code or HL7 XXX.
I LA761,$P(LA761(0),"^",2)'="",LA7COMP<1 D
. S $P(LA7Y,$E(LA7ECH,4),LA7COMP+1)="T-"_$P(LA761(0),"^",2)
. S LA7X=$$CHKDATA^LA7VHLU3($P(LA761(0),"^"),LA7FS_LA7ECH)
. S $P(LA7Y,$E(LA7ECH,4),LA7COMP+2)=LA7X
. S $P(LA7Y,$E(LA7ECH,4),LA7COMP+3)="SNM"
. S $P(LA7Y,$E(LA7ECH,4),7)="1974"
. S LA7COMP=LA7COMP+3
I LA761,LA7COMP<6 D
. S $P(LA7Y,$E(LA7ECH,4),LA7COMP+1)=LA761
. S LA7X=$$CHKDATA^LA7VHLU3($P(LA761(0),"^"),LA7FS_LA7ECH)
. S $P(LA7Y,$E(LA7ECH,4),LA7COMP+2)=LA7X
. S $P(LA7Y,$E(LA7ECH,4),LA7COMP+3)="99VA61"
. S $P(LA7Y,$E(LA7ECH,4),$S(LA7COMP<3:7,1:8))="5.2"
. S LA7COMP=LA7COMP+3
I LA761=0,LA7COMP<1,LA764061,LA7Z(64.061,LA764061_",",2)'="" D
. S LA7X=$$CHKDATA^LA7VHLU3(LA7Z(64.061,LA764061_",",2),LA7FS_LA7ECH)
. S $P(LA7Y,$E(LA7ECH,4),LA7COMP+1)=LA7X
. S LA7X=$$CHKDATA^LA7VHLU3(LA7Z(64.061,LA764061_",",.01),LA7FS_LA7ECH)
. S $P(LA7Y,$E(LA7ECH,4),LA7COMP+2)=LA7X
. S $P(LA7Y,$E(LA7ECH,4),LA7COMP+3)="HL7"_LA7Z(64.061,LA764061_",",5)
. S LA7COMP=LA7COMP+3
;
; Reverse and send HL70070 as primary and SNOMED as alternate.
; Maintain backward compatibility with VistA LEDI III
I LA7SNM=1.1,$P(LA7Y,$E(LA7ECH,4),3)="SCT",$P(LA7Y,$E(LA7ECH,4),6)="HL70070" D
. N LA7K
. S LA7K=$P(LA7Y,$E(LA7ECH,4),1,3),LA7K(7)=$P(LA7Y,$E(LA7ECH,4),7)
. S $P(LA7Y,$E(LA7ECH,4),1,3)=$P(LA7Y,$E(LA7ECH,4),4,6),$P(LA7Y,$E(LA7ECH,4),7)=$P(LA7Y,$E(LA7ECH,4),8)
. S $P(LA7Y,$E(LA7ECH,4),4,6)=LA7K,$P(LA7Y,$E(LA7ECH,4),8)=LA7K(7)
;
; LA7ALT should contain "CONTROL" in 4th piece if from file #62.3
I $P(LA7ALT,"^",4)'="" D
. N LA7TXT
. S LA7TXT=$$CHKDATA^LA7VHLU3($P(LA7ALT,"^",4),LA7FS_LA7ECH)
. S $P(LA7Y,$E(LA7ECH,1),3)=LA7TXT
;
; Build collection sample in 4th component.
S LA7COMP=0 ; specify subcomponent position - primary/alternate
; Send collection sample SNOMED CT code for DoD.
I LA762,LA7SNM D
. N LA7K,LA7Z
. ;check for override SNOMED CT ID
. I $G(LA76248)]"",$D(^LAHM(62.48,LA76248,"SCT","AC",LA762_";LAB(62,")) D
. . S $P(LA7ALT,"^",9)=$O(^LAHM(62.48,LA76248,"SCT","AC",LA762_";LAB(62,",0))
. S LA7X=$$IEN2SCT^LA7VHLU6(62,LA762,DT,$P(LA7ALT,"^",9))
. S $P(LA7X,"^",2)=$$CHKDATA^LA7VHLU3($P(LA7X,"^",2),LA7FS_LA7ECH)
. S LA7K=$TR($P(LA7X,"^",1,3),"^",$E(LA7ECH,4))
. S $P(LA7K,$E(LA7ECH,4),7)=$P(LA7X,"^",4)
. S LA7Z=$$GET1^DIQ(62,LA762_",",.01,"","LA7ERR"),LA7Z=$$TRIM^XLFSTR(LA7Z,"LR"," ")
. S LA7Z=$$CHKDATA^LA7VHLU3(LA7Z,LA7FS_LA7ECH)
. S $P(LA7K,$E(LA7ECH,4),9)=LA7Z
. S $P(LA7Y,$E(LA7ECH,1),4)=LA7K,LA7COMP=3
;
I $P(LA7ALT,"^",5)'=""!($P(LA7ALT,"^",6)'="") D
. N I
. S X=$$CHKDATA^LA7VHLU3($P(LA7ALT,"^",5),LA7FS_LA7ECH)
. S Y=$$CHKDATA^LA7VHLU3($P(LA7ALT,"^",6),LA7FS_LA7ECH)
. S LA7X=$P(LA7Y,$E(LA7ECH,1),4)
. F I=1,4 I $P(LA7X,$E(LA7ECH,4),I)="" S $P(LA7X,$E(LA7ECH,4),I)=X,$P(LA7X,$E(LA7ECH,4),I+1)=Y,$P(LA7X,$E(LA7ECH,4),I+2)=$P(LA7ALT,"^",7) Q
. S $P(LA7Y,$E(LA7ECH,1),4)=LA7X,LA7COMP=LA7COMP+3
;
; Get entry in #62 for this collection sample entry.
I LA762,LA7COMP<6 D
. N I,LA7Z
. S LA7Z=$$GET1^DIQ(62,LA762_",",.01,"","LA7ERR"),LA7Z=$$TRIM^XLFSTR(LA7Z,"LR"," ")
. S LA7Z=$$CHKDATA^LA7VHLU3(LA7Z,LA7FS_LA7ECH)
. S LA7X=$P(LA7Y,$E(LA7ECH,1),4)
. F I=1,4 I $P(LA7X,$E(LA7ECH,4),I)="" S $P(LA7X,$E(LA7ECH,4),I)=LA762,$P(LA7X,$E(LA7ECH,4),I+1)=LA7Z,$P(LA7X,$E(LA7ECH,4),I+2)="99VA62" Q
. S $P(LA7Y,$E(LA7ECH,1),4)=LA7X,LA7COMP=LA7COMP+3
;
; Send specimen shipping condition - collection method
I $G(LA7CM) D
. S X=$$GET1^DIQ(62.93,LA7CM_",",.01)
. I X'="" S X=$$CHKDATA^LA7VHLU3(X,LA7FS_LA7ECH)
. S Y=$$GET1^DIQ(62.93,LA7CM_",",.02)
. I Y'="" S Y=$$CHKDATA^LA7VHLU3(Y,LA7FS_LA7ECH)
. S LA7X=Y_$E(LA7ECH,4)_X_$E(LA7ECH,4)_"99VA62.93"
. S $P(LA7Y,$E(LA7ECH,1),6)=LA7X
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLA7VOBRB 6345 printed Dec 13, 2024@01:40:49 Page 2
LA7VOBRB ;DALOI/JMC - LAB OBR segment builder (cont'd);Jan 8, 2008
+1 ;;5.2;AUTOMATED LAB INSTRUMENTS;**68,74,85**;Sep 27, 1994;Build 4
+2 ;
+3 QUIT
+4 ;
+5 ;
OBR15 ; Build OBR-15 sequence - specimen source
+1 ;
+2 SET LA764061=0
SET LA7Y=""
+3 ; specify subcomponent position - primary/alternate
SET LA7COMP=0
+4 ; SNOMED code flag (0-do not encode with SNOMED, 1-encode with SNOMED, 2-encode with SNOMED only; no HL70070)
+5 SET LA7SNM=$GET(LA7SNM)
+6 ;
+7 ; Get entry in #64.061 and SNOMED code for this Topography file #61 entry.
+8 IF LA761>0
Begin DoDot:1
+9 SET LA761(0)=$GET(^LAB(61,LA761,0))
SET LA764061=$PIECE(LA761(0),"^",9)
+10 SET $PIECE(LA7Y,$EXTRACT(LA7ECH,4),9)=$$CHKDATA^LA7VHLU3($PIECE(LA761(0),"^"),LA7FS_LA7ECH)
End DoDot:1
+11 ;
+12 ; If no specimen code then default to HL7 0070 entry "XXX"
+13 IF LA761=0
Begin DoDot:1
+14 NEW LA7SCR
+15 SET LA7SCR="I $P(^LAB(64.061,Y,0),U,5)=""0070"",$P(^LAB(64.061,Y,0),U,7)=""S"""
+16 SET LA764061=$$FIND1^DIC(64.061,,"X","XXX","D",LA7SCR,"LA7ERR")
End DoDot:1
+17 ;
+18 IF LA764061
DO GETS^DIQ(64.061,LA764061_",",".01;2;5","","LA7Z","LA7ERR")
+19 ;
+20 ; Send SNOMED as primary code
+21 ; If no SNOMED code and SNOMED only then allow HL7
+22 IF LA761
IF LA7SNM
Begin DoDot:1
+23 ;check for override SNOMED CT ID
+24 IF $GET(LA76248)]""
IF $DATA(^LAHM(62.48,LA76248,"SCT","AC",LA761_";LAB(61,"))
Begin DoDot:2
+25 SET $PIECE(LA7ALT,"^",8)=$ORDER(^LAHM(62.48,LA76248,"SCT","AC",LA761_";LAB(61,",0))
End DoDot:2
+26 SET LA7X=$$IEN2SCT^LA7VHLU6(61,LA761,DT,$PIECE(LA7ALT,"^",8))
+27 IF LA7X=""
if LA7SNM=2
SET LA7SNM=1
QUIT
+28 SET $PIECE(LA7X,"^",2)=$$CHKDATA^LA7VHLU3($PIECE(LA7X,"^",2),LA7FS_LA7ECH)
+29 SET $PIECE(LA7Y,$EXTRACT(LA7ECH,4),LA7COMP+1,LA7COMP+3)=$TRANSLATE($PIECE(LA7X,"^",1,3),"^",$EXTRACT(LA7ECH,4))
+30 SET $PIECE(LA7Y,$EXTRACT(LA7ECH,4),7)=$PIECE(LA7X,"^",4)
+31 SET LA7COMP=LA7COMP+3
End DoDot:1
+32 ;
+33 ; Send non-standard local code as alternate unless SNOMED only flag and SNOMED code present.
+34 IF $PIECE(LA7ALT,"^")'=""!($PIECE(LA7ALT,"^",2)'="")
Begin DoDot:1
+35 IF LA7SNM=2
IF LA7COMP
QUIT
+36 SET LA7X=$$CHKDATA^LA7VHLU3($PIECE(LA7ALT,"^"),LA7FS_LA7ECH)
+37 SET $PIECE(LA7Y,$EXTRACT(LA7ECH,4),LA7COMP+1)=LA7X
+38 SET LA7X=$$CHKDATA^LA7VHLU3($PIECE(LA7ALT,"^",2),LA7FS_LA7ECH)
+39 SET $PIECE(LA7Y,$EXTRACT(LA7ECH,4),LA7COMP+2)=LA7X
+40 SET $PIECE(LA7Y,$EXTRACT(LA7ECH,4),LA7COMP+3)=$PIECE(LA7ALT,"^",3)
+41 SET LA7COMP=LA7COMP+3
End DoDot:1
+42 ;
+43 ; Send HL7 Table 0070 coding as alternate code
+44 IF LA7SNM'=2
IF LA764061
IF LA7Z(64.061,LA764061_",",2)'=""
IF LA7COMP<6
Begin DoDot:1
+45 SET LA7X=$$CHKDATA^LA7VHLU3(LA7Z(64.061,LA764061_",",2),LA7FS_LA7ECH)
+46 SET $PIECE(LA7Y,$EXTRACT(LA7ECH,4),LA7COMP+1)=LA7X
+47 SET LA7X=$$CHKDATA^LA7VHLU3(LA7Z(64.061,LA764061_",",.01),LA7FS_LA7ECH)
+48 SET $PIECE(LA7Y,$EXTRACT(LA7ECH,4),LA7COMP+2)=LA7X
+49 SET $PIECE(LA7Y,$EXTRACT(LA7ECH,4),LA7COMP+3)="HL7"_LA7Z(64.061,LA764061_",",5)
+50 SET LA7COMP=LA7COMP+3
End DoDot:1
+51 ;
+52 ; If no code found then default to backups - try SNOMED I then file #61 as local code or HL7 XXX.
+53 IF LA761
IF $PIECE(LA761(0),"^",2)'=""
IF LA7COMP<1
Begin DoDot:1
+54 SET $PIECE(LA7Y,$EXTRACT(LA7ECH,4),LA7COMP+1)="T-"_$PIECE(LA761(0),"^",2)
+55 SET LA7X=$$CHKDATA^LA7VHLU3($PIECE(LA761(0),"^"),LA7FS_LA7ECH)
+56 SET $PIECE(LA7Y,$EXTRACT(LA7ECH,4),LA7COMP+2)=LA7X
+57 SET $PIECE(LA7Y,$EXTRACT(LA7ECH,4),LA7COMP+3)="SNM"
+58 SET $PIECE(LA7Y,$EXTRACT(LA7ECH,4),7)="1974"
+59 SET LA7COMP=LA7COMP+3
End DoDot:1
+60 IF LA761
IF LA7COMP<6
Begin DoDot:1
+61 SET $PIECE(LA7Y,$EXTRACT(LA7ECH,4),LA7COMP+1)=LA761
+62 SET LA7X=$$CHKDATA^LA7VHLU3($PIECE(LA761(0),"^"),LA7FS_LA7ECH)
+63 SET $PIECE(LA7Y,$EXTRACT(LA7ECH,4),LA7COMP+2)=LA7X
+64 SET $PIECE(LA7Y,$EXTRACT(LA7ECH,4),LA7COMP+3)="99VA61"
+65 SET $PIECE(LA7Y,$EXTRACT(LA7ECH,4),$SELECT(LA7COMP<3:7,1:8))="5.2"
+66 SET LA7COMP=LA7COMP+3
End DoDot:1
+67 IF LA761=0
IF LA7COMP<1
IF LA764061
IF LA7Z(64.061,LA764061_",",2)'=""
Begin DoDot:1
+68 SET LA7X=$$CHKDATA^LA7VHLU3(LA7Z(64.061,LA764061_",",2),LA7FS_LA7ECH)
+69 SET $PIECE(LA7Y,$EXTRACT(LA7ECH,4),LA7COMP+1)=LA7X
+70 SET LA7X=$$CHKDATA^LA7VHLU3(LA7Z(64.061,LA764061_",",.01),LA7FS_LA7ECH)
+71 SET $PIECE(LA7Y,$EXTRACT(LA7ECH,4),LA7COMP+2)=LA7X
+72 SET $PIECE(LA7Y,$EXTRACT(LA7ECH,4),LA7COMP+3)="HL7"_LA7Z(64.061,LA764061_",",5)
+73 SET LA7COMP=LA7COMP+3
End DoDot:1
+74 ;
+75 ; Reverse and send HL70070 as primary and SNOMED as alternate.
+76 ; Maintain backward compatibility with VistA LEDI III
+77 IF LA7SNM=1.1
IF $PIECE(LA7Y,$EXTRACT(LA7ECH,4),3)="SCT"
IF $PIECE(LA7Y,$EXTRACT(LA7ECH,4),6)="HL70070"
Begin DoDot:1
+78 NEW LA7K
+79 SET LA7K=$PIECE(LA7Y,$EXTRACT(LA7ECH,4),1,3)
SET LA7K(7)=$PIECE(LA7Y,$EXTRACT(LA7ECH,4),7)
+80 SET $PIECE(LA7Y,$EXTRACT(LA7ECH,4),1,3)=$PIECE(LA7Y,$EXTRACT(LA7ECH,4),4,6)
SET $PIECE(LA7Y,$EXTRACT(LA7ECH,4),7)=$PIECE(LA7Y,$EXTRACT(LA7ECH,4),8)
+81 SET $PIECE(LA7Y,$EXTRACT(LA7ECH,4),4,6)=LA7K
SET $PIECE(LA7Y,$EXTRACT(LA7ECH,4),8)=LA7K(7)
End DoDot:1
+82 ;
+83 ; LA7ALT should contain "CONTROL" in 4th piece if from file #62.3
+84 IF $PIECE(LA7ALT,"^",4)'=""
Begin DoDot:1
+85 NEW LA7TXT
+86 SET LA7TXT=$$CHKDATA^LA7VHLU3($PIECE(LA7ALT,"^",4),LA7FS_LA7ECH)
+87 SET $PIECE(LA7Y,$EXTRACT(LA7ECH,1),3)=LA7TXT
End DoDot:1
+88 ;
+89 ; Build collection sample in 4th component.
+90 ; specify subcomponent position - primary/alternate
SET LA7COMP=0
+91 ; Send collection sample SNOMED CT code for DoD.
+92 IF LA762
IF LA7SNM
Begin DoDot:1
+93 NEW LA7K,LA7Z
+94 ;check for override SNOMED CT ID
+95 IF $GET(LA76248)]""
IF $DATA(^LAHM(62.48,LA76248,"SCT","AC",LA762_";LAB(62,"))
Begin DoDot:2
+96 SET $PIECE(LA7ALT,"^",9)=$ORDER(^LAHM(62.48,LA76248,"SCT","AC",LA762_";LAB(62,",0))
End DoDot:2
+97 SET LA7X=$$IEN2SCT^LA7VHLU6(62,LA762,DT,$PIECE(LA7ALT,"^",9))
+98 SET $PIECE(LA7X,"^",2)=$$CHKDATA^LA7VHLU3($PIECE(LA7X,"^",2),LA7FS_LA7ECH)
+99 SET LA7K=$TRANSLATE($PIECE(LA7X,"^",1,3),"^",$EXTRACT(LA7ECH,4))
+100 SET $PIECE(LA7K,$EXTRACT(LA7ECH,4),7)=$PIECE(LA7X,"^",4)
+101 SET LA7Z=$$GET1^DIQ(62,LA762_",",.01,"","LA7ERR")
SET LA7Z=$$TRIM^XLFSTR(LA7Z,"LR"," ")
+102 SET LA7Z=$$CHKDATA^LA7VHLU3(LA7Z,LA7FS_LA7ECH)
+103 SET $PIECE(LA7K,$EXTRACT(LA7ECH,4),9)=LA7Z
+104 SET $PIECE(LA7Y,$EXTRACT(LA7ECH,1),4)=LA7K
SET LA7COMP=3
End DoDot:1
+105 ;
+106 IF $PIECE(LA7ALT,"^",5)'=""!($PIECE(LA7ALT,"^",6)'="")
Begin DoDot:1
+107 NEW I
+108 SET X=$$CHKDATA^LA7VHLU3($PIECE(LA7ALT,"^",5),LA7FS_LA7ECH)
+109 SET Y=$$CHKDATA^LA7VHLU3($PIECE(LA7ALT,"^",6),LA7FS_LA7ECH)
+110 SET LA7X=$PIECE(LA7Y,$EXTRACT(LA7ECH,1),4)
+111 FOR I=1,4
IF $PIECE(LA7X,$EXTRACT(LA7ECH,4),I)=""
SET $PIECE(LA7X,$EXTRACT(LA7ECH,4),I)=X
SET $PIECE(LA7X,$EXTRACT(LA7ECH,4),I+1)=Y
SET $PIECE(LA7X,$EXTRACT(LA7ECH,4),I+2)=$PIECE(LA7ALT,"^",7)
QUIT
+112 SET $PIECE(LA7Y,$EXTRACT(LA7ECH,1),4)=LA7X
SET LA7COMP=LA7COMP+3
End DoDot:1
+113 ;
+114 ; Get entry in #62 for this collection sample entry.
+115 IF LA762
IF LA7COMP<6
Begin DoDot:1
+116 NEW I,LA7Z
+117 SET LA7Z=$$GET1^DIQ(62,LA762_",",.01,"","LA7ERR")
SET LA7Z=$$TRIM^XLFSTR(LA7Z,"LR"," ")
+118 SET LA7Z=$$CHKDATA^LA7VHLU3(LA7Z,LA7FS_LA7ECH)
+119 SET LA7X=$PIECE(LA7Y,$EXTRACT(LA7ECH,1),4)
+120 FOR I=1,4
IF $PIECE(LA7X,$EXTRACT(LA7ECH,4),I)=""
SET $PIECE(LA7X,$EXTRACT(LA7ECH,4),I)=LA762
SET $PIECE(LA7X,$EXTRACT(LA7ECH,4),I+1)=LA7Z
SET $PIECE(LA7X,$EXTRACT(LA7ECH,4),I+2)="99VA62"
QUIT
+121 SET $PIECE(LA7Y,$EXTRACT(LA7ECH,1),4)=LA7X
SET LA7COMP=LA7COMP+3
End DoDot:1
+122 ;
+123 ; Send specimen shipping condition - collection method
+124 IF $GET(LA7CM)
Begin DoDot:1
+125 SET X=$$GET1^DIQ(62.93,LA7CM_",",.01)
+126 IF X'=""
SET X=$$CHKDATA^LA7VHLU3(X,LA7FS_LA7ECH)
+127 SET Y=$$GET1^DIQ(62.93,LA7CM_",",.02)
+128 IF Y'=""
SET Y=$$CHKDATA^LA7VHLU3(Y,LA7FS_LA7ECH)
+129 SET LA7X=Y_$EXTRACT(LA7ECH,4)_X_$EXTRACT(LA7ECH,4)_"99VA62.93"
+130 SET $PIECE(LA7Y,$EXTRACT(LA7ECH,1),6)=LA7X
End DoDot:1
+131 QUIT
