- 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
