LA7VOBRB ;VA/DALOI/JMC - LAB OBR segment builder (cont'd); 13-Aug-2013 09:09 ; MKK
;;5.2;AUTOMATED LAB INSTRUMENTS;**68,1033**;NOV 01, 1997
;
Q
;
;
OBR15 ; Build OBR-15 sequence - specimen source
;
S LA764061=0
S LA7COMP=0 ; specify subcomponent position - primary/alternate
S LA7Y="",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 LA764061<1 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;1;2;3;5","","LA7Z","LA7ERR")
;
; Send non-standard local code as primary
I $P(LA7ALT,"^")'=""!($P(LA7ALT,"^",2)'="") D
. S LA7X=$$CHKDATA^LA7VHLU3($P(LA7ALT,"^"),LA7FS_LA7ECH)
. S $P(LA7Y,$E(LA7ECH,4),1)=LA7X
. S LA7X=$$CHKDATA^LA7VHLU3($P(LA7ALT,"^",2),LA7FS_LA7ECH)
. S $P(LA7Y,$E(LA7ECH,4),2)=LA7X
. S $P(LA7Y,$E(LA7ECH,4),3)=$P(LA7ALT,"^",3)
. S LA7COMP=LA7COMP+3
;
; Send HL7 Table 0070 coding as primary code
I 'LA7SNM,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
;
; Send SNOMED as alternate code
I LA761,$P(LA761(0),"^",2)'="",LA7COMP<6 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),$S(LA7COMP<3:7,1:8))="1974"
. S LA7COMP=LA7COMP+3
;
; If VA code and not HL7 and/or LOINC
I LA764061,LA7Z(64.061,LA764061_",",3)'="",LA7COMP<6 D
. S LA7X=$$CHKDATA^LA7VHLU3(LA7Z(64.061,LA764061_",",3),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)="99VA64.061"
. S $P(LA7Y,$E(LA7ECH,4),$S(LA7COMP<4:7,1:8))="5.2"
;
; 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
;
; Get entry in #62 for this collection sample entry.
I LA762,$P(LA7ALT,"^",5)="",$P(LA7ALT,"^",6)="" D
. S LA7X=$$GET1^DIQ(62,LA762_",",.01,"","LA7ERR")
. S LA7X=$$TRIM^XLFSTR(LA7X,"LR"," ")
. S LA7X=$$CHKDATA^LA7VHLU3(LA7X,LA7FS_LA7ECH)
. S LA7X=LA762_$E(LA7ECH,4)_LA7X_$E(LA7ECH,4)_"99VA62"
. S $P(LA7Y,$E(LA7ECH,1),4)=LA7X
;
; Send collection sample code for DoD.
I $P(LA7ALT,"^",5)'=""!($P(LA7ALT,"^",6)'="") D
. S X=$$CHKDATA^LA7VHLU3($P(LA7ALT,"^",5),LA7FS_LA7ECH)
. S Y=$$CHKDATA^LA7VHLU3($P(LA7ALT,"^",6),LA7FS_LA7ECH)
. S LA7X=X_$E(LA7ECH,4)_Y_$E(LA7ECH,4)_$P(LA7ALT,"^",7)
. S $P(LA7Y,$E(LA7ECH,1),4)=LA7X
;
; 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
LA7VOBRB ;VA/DALOI/JMC - LAB OBR segment builder (cont'd); 13-Aug-2013 09:09 ; MKK
+1 ;;5.2;AUTOMATED LAB INSTRUMENTS;**68,1033**;NOV 01, 1997
+2 ;
+3 QUIT
+4 ;
+5 ;
OBR15 ; Build OBR-15 sequence - specimen source
+1 ;
+2 SET LA764061=0
+3 ; specify subcomponent position - primary/alternate
SET LA7COMP=0
+4 SET LA7Y=""
SET LA7SNM=$GET(LA7SNM)
+5 ;
+6 ; Get entry in #64.061 and SNOMED code for this Topography file #61 entry.
+7 IF LA761>0
Begin DoDot:1
+8 SET LA761(0)=$GET(^LAB(61,LA761,0))
SET LA764061=$PIECE(LA761(0),"^",9)
+9 SET $PIECE(LA7Y,$EXTRACT(LA7ECH,4),9)=$$CHKDATA^LA7VHLU3($PIECE(LA761(0),"^"),LA7FS_LA7ECH)
End DoDot:1
+10 ;
+11 ; If no specimen code then default to HL7 0070 entry "XXX"
+12 IF LA764061<1
Begin DoDot:1
+13 NEW LA7SCR
+14 SET LA7SCR="I $P(^LAB(64.061,Y,0),U,5)=""0070"",$P(^LAB(64.061,Y,0),U,7)=""S"""
+15 SET LA764061=$$FIND1^DIC(64.061,,"X","XXX","D",LA7SCR,"LA7ERR")
End DoDot:1
+16 ;
+17 IF LA764061
DO GETS^DIQ(64.061,LA764061_",",".01;1;2;3;5","","LA7Z","LA7ERR")
+18 ;
+19 ; Send non-standard local code as primary
+20 IF $PIECE(LA7ALT,"^")'=""!($PIECE(LA7ALT,"^",2)'="")
Begin DoDot:1
+21 SET LA7X=$$CHKDATA^LA7VHLU3($PIECE(LA7ALT,"^"),LA7FS_LA7ECH)
+22 SET $PIECE(LA7Y,$EXTRACT(LA7ECH,4),1)=LA7X
+23 SET LA7X=$$CHKDATA^LA7VHLU3($PIECE(LA7ALT,"^",2),LA7FS_LA7ECH)
+24 SET $PIECE(LA7Y,$EXTRACT(LA7ECH,4),2)=LA7X
+25 SET $PIECE(LA7Y,$EXTRACT(LA7ECH,4),3)=$PIECE(LA7ALT,"^",3)
+26 SET LA7COMP=LA7COMP+3
End DoDot:1
+27 ;
+28 ; Send HL7 Table 0070 coding as primary code
+29 IF 'LA7SNM
IF LA764061
IF LA7Z(64.061,LA764061_",",2)'=""
IF LA7COMP<6
Begin DoDot:1
+30 SET LA7X=$$CHKDATA^LA7VHLU3(LA7Z(64.061,LA764061_",",2),LA7FS_LA7ECH)
+31 SET $PIECE(LA7Y,$EXTRACT(LA7ECH,4),LA7COMP+1)=LA7X
+32 SET LA7X=$$CHKDATA^LA7VHLU3(LA7Z(64.061,LA764061_",",.01),LA7FS_LA7ECH)
+33 SET $PIECE(LA7Y,$EXTRACT(LA7ECH,4),LA7COMP+2)=LA7X
+34 SET $PIECE(LA7Y,$EXTRACT(LA7ECH,4),LA7COMP+3)="HL7"_LA7Z(64.061,LA764061_",",5)
+35 SET LA7COMP=LA7COMP+3
End DoDot:1
+36 ;
+37 ; Send SNOMED as alternate code
+38 IF LA761
IF $PIECE(LA761(0),"^",2)'=""
IF LA7COMP<6
Begin DoDot:1
+39 SET $PIECE(LA7Y,$EXTRACT(LA7ECH,4),LA7COMP+1)="T-"_$PIECE(LA761(0),"^",2)
+40 SET LA7X=$$CHKDATA^LA7VHLU3($PIECE(LA761(0),"^"),LA7FS_LA7ECH)
+41 SET $PIECE(LA7Y,$EXTRACT(LA7ECH,4),LA7COMP+2)=LA7X
+42 SET $PIECE(LA7Y,$EXTRACT(LA7ECH,4),LA7COMP+3)="SNM"
+43 SET $PIECE(LA7Y,$EXTRACT(LA7ECH,4),$SELECT(LA7COMP<3:7,1:8))="1974"
+44 SET LA7COMP=LA7COMP+3
End DoDot:1
+45 ;
+46 ; If VA code and not HL7 and/or LOINC
+47 IF LA764061
IF LA7Z(64.061,LA764061_",",3)'=""
IF LA7COMP<6
Begin DoDot:1
+48 SET LA7X=$$CHKDATA^LA7VHLU3(LA7Z(64.061,LA764061_",",3),LA7FS_LA7ECH)
+49 SET $PIECE(LA7Y,$EXTRACT(LA7ECH,4),LA7COMP+1)=LA7X
+50 SET LA7X=$$CHKDATA^LA7VHLU3(LA7Z(64.061,LA764061_",",.01),LA7FS_LA7ECH)
+51 SET $PIECE(LA7Y,$EXTRACT(LA7ECH,4),LA7COMP+2)=LA7X
+52 SET $PIECE(LA7Y,$EXTRACT(LA7ECH,4),LA7COMP+3)="99VA64.061"
+53 SET $PIECE(LA7Y,$EXTRACT(LA7ECH,4),$SELECT(LA7COMP<4:7,1:8))="5.2"
End DoDot:1
+54 ;
+55 ; LA7ALT should contain "CONTROL" in 4th piece if from file #62.3
+56 IF $PIECE(LA7ALT,"^",4)'=""
Begin DoDot:1
+57 NEW LA7TXT
+58 SET LA7TXT=$$CHKDATA^LA7VHLU3($PIECE(LA7ALT,"^",4),LA7FS_LA7ECH)
+59 SET $PIECE(LA7Y,$EXTRACT(LA7ECH,1),3)=LA7TXT
End DoDot:1
+60 ;
+61 ; Get entry in #62 for this collection sample entry.
+62 IF LA762
IF $PIECE(LA7ALT,"^",5)=""
IF $PIECE(LA7ALT,"^",6)=""
Begin DoDot:1
+63 SET LA7X=$$GET1^DIQ(62,LA762_",",.01,"","LA7ERR")
+64 SET LA7X=$$TRIM^XLFSTR(LA7X,"LR"," ")
+65 SET LA7X=$$CHKDATA^LA7VHLU3(LA7X,LA7FS_LA7ECH)
+66 SET LA7X=LA762_$EXTRACT(LA7ECH,4)_LA7X_$EXTRACT(LA7ECH,4)_"99VA62"
+67 SET $PIECE(LA7Y,$EXTRACT(LA7ECH,1),4)=LA7X
End DoDot:1
+68 ;
+69 ; Send collection sample code for DoD.
+70 IF $PIECE(LA7ALT,"^",5)'=""!($PIECE(LA7ALT,"^",6)'="")
Begin DoDot:1
+71 SET X=$$CHKDATA^LA7VHLU3($PIECE(LA7ALT,"^",5),LA7FS_LA7ECH)
+72 SET Y=$$CHKDATA^LA7VHLU3($PIECE(LA7ALT,"^",6),LA7FS_LA7ECH)
+73 SET LA7X=X_$EXTRACT(LA7ECH,4)_Y_$EXTRACT(LA7ECH,4)_$PIECE(LA7ALT,"^",7)
+74 SET $PIECE(LA7Y,$EXTRACT(LA7ECH,1),4)=LA7X
End DoDot:1
+75 ;
+76 ; Send specimen shipping condition - collection method
+77 IF $GET(LA7CM)
Begin DoDot:1
+78 SET X=$$GET1^DIQ(62.93,LA7CM_",",.01)
+79 IF X'=""
SET X=$$CHKDATA^LA7VHLU3(X,LA7FS_LA7ECH)
+80 SET Y=$$GET1^DIQ(62.93,LA7CM_",",.02)
+81 IF Y'=""
SET Y=$$CHKDATA^LA7VHLU3(Y,LA7FS_LA7ECH)
+82 SET LA7X=Y_$EXTRACT(LA7ECH,4)_X_$EXTRACT(LA7ECH,4)_"99VA62.93"
+83 SET $PIECE(LA7Y,$EXTRACT(LA7ECH,1),6)=LA7X
End DoDot:1
+84 QUIT
