Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: LA7MUSPM

LA7MUSPM.m

Go to the documentation of this file. 
  1. LA7MUSPM ;ihs/cmi/maw - MU2 SPM segment utility ; 22-Oct-2013 09:22 ; MAW
  1.  ;;5.2;BLR IHS REFERENCE LAB;**1033**;NOV 01, 1997
  1.  ;
  1. SPM2(CS,SC,AC) ;-- specimen id
  1.  N SPM2
  1.  S SPM2=CS_AC_SC_"Filler_LIS"_SC_"2.16.840.1.113883.3.72.5.21"_SC_"ISO"
  1.  Q SPM2
  1.  ;
  1. SPM4(CS,ACC,SPC)  ;-- specimen type
  1.  N SPM4,SNM
  1.  S SNM=$$GET1^DIQ(61,SPC,2)
  1.  S SPM4=SNM_CS_$$GET1^DIQ(61,SPC,.01)_CS_"SCT"_CS_$$GET1^DIQ(61,SPC,.08)_CS_$$GET1^DIQ(61,SPC,.01)_CS_"L"_CS_LA7VER_CS_$G(^DIC(9.4,$O(^DIC(9.4,"C","BLR",0)),"VERSION"))
  1.  Q SPM4
  1.  ;
  1. SPM5(CS,ACC,SPC,RI)  ;-- specimen type modifier
  1.  N SPM5
  1.  S SPM5=""
  1.  N RA,ID,TX
  1.  S RA=0 F  S RA=$O(^BLRRLO(RI,4,RA)) Q:'RA  D
  1.  . Q:$P($G(^BLRRLO(RI,4,RA,0)),U,3)'="SPM5"
  1.  . S ID=$P($G(^BLRRLO(RI,4,RA,0)),U,4)
  1.  . S TX=$P($G(^BLRRLO(RI,4,RA,0)),U,5)
  1.  . S SPM5=ID_CS_TX_CS_"SCT"_CS_$E(TX,1,3)_CS_TX_CS_"L"_CS_"2.40"_CS_LA7VER
  1.  Q SPM5
  1.  ;
  1. SPM6(CS,ACC,SPC)  ;-- specimen additives
  1.  ;file 62 new field
  1.  N SPM6,ADD,ADDD
  1.  S SPM6=""
  1.  S ADD=$P($G(^LAB(62,LRSAMP,9,LRAA,1,LA760,"IHS")),U)
  1.  I $G(ADD)]"" S ADDD=$$LOOKTAB^LA7CQRY1("HL7","0371",ADD,$E(LA7ECH))
  1.  I $G(ADD)]"" S SPM6=ADDD_CS_$E($P(ADDD,U),1)_CS_$P(ADDD,U,2)_CS_"L"_CS_"2.5.1"_CS_LA7VER
  1.  Q SPM6
  1.  ;
  1. SPM7(CS,ACC,SPC)  ;-- specimen collection method
  1.  ;file 62 new field
  1.  N SPM7,MTH,METH
  1.  S SPM7=""
  1.  S MTH=$P($G(^LAB(62,LRSAMP,9,LRAA,1,LA760,"IHS")),U,2)
  1.  I $G(MTH)]"",$E(MTH,1)?.N S METH=$$LOOKTAB^LA7CQRY1("","SCT",MTH,$E(LA7ECH))
  1.  I $G(MTH)]"",$E(MTH,1)'?.N S METH=$$LOOKTAB^LA7CQRY1("HL7","0488",MTH,$E(LA7ECH))
  1.  I $G(MTH)]"" S SPM7=METH_CS_$E($P(METH,U),1,4)_CS_$P(METH,U,2)_CS_"L"_CS_"07/31/2012"_CS_LA7VER
  1.  Q SPM7
  1.  ;
  1. SPM8(CS,ACC,SPC)  ;-- specimen source site
  1.  ;file 62 new field, points to 61
  1.  N SPM8,SS,SSS,SSE
  1.  S SPM8=""
  1.  S SS=$P($G(^LAB(62,LRSAMP,9,LRAA,1,LA760,"IHS")),U,3)
  1.  I 'SS Q SPM8
  1.  S SSS=$P($G(^LAB(61,SS,0)),U,2)
  1.  I $G(SSS)]"" S SSE=$$LOOKTAB^LA7CQRY1("","SCT",SSS,$E(LA7ECH))
  1.  I $G(SSS)]"" S SPM8=SSE_CS_$E($P(SSE,U),1,4)_CS_$P(SSE,U,2)_CS_"L"_CS_"07/31/2012"_CS_LA7VER
  1.  Q SPM8
  1.  ;
  1. SPM9(CS,ACC,SPC,RI)  ;-- specimen source site modifier
  1.  N SPM9
  1.  S SPM9=""
  1.  N RA,ID,TX
  1.  S RA=0 F  S RA=$O(^BLRRLO(RI,4,RA)) Q:'RA  D
  1.  . Q:$P($G(^BLRRLO(RI,4,RA,0)),U,3)'="SPM9"
  1.  . S ID=$P($G(^BLRRLO(RI,4,RA,0)),U,4)
  1.  . S TX=$P($G(^BLRRLO(RI,4,RA,0)),U,5)
  1.  . S SPM9=ID_CS_TX_CS_"SCT"_CS_$E(TX,1,3)_CS_TX_CS_"L"_CS_"2.40"_CS_LA7VER
  1.  Q SPM9
  1.  ;
  1. SPM11(CS,ACC,SPC)  ;-- specimen role
  1.  ;file 61 time aspect field
  1.  N SPM11,TA,ID,IDD
  1.  S SPM11=""
  1.  S TA=$P($G(^LAB(61,SPC,0)),U,10)
  1.  I 'TA Q SPM11
  1.  S ID=$E($P($G(^LAB(64.061,TA,0)),U,2),1)
  1.  I $G(ID)]"" S IDD=$$LOOKTAB^LA7CQRY1("HL7","0369",ID,$E(LA7ECH))
  1.  I $G(ID)]"" S SPM11=IDD_CS_ID_CS_$P(IDD,U,2)_CS_"L"_CS_"2.5.1"_CS_LA7VER
  1.  Q SPM11
  1.  ;
  1. SPM12(CS,SC,ACC,SPC)  ;-- specimen collection amount
  1.  N SPM12
  1.  S SPM12=""
  1.  ;TODO MU2 add the following once we determine specimen collection amount
  1.  ;MU2 hard coded per team 7/1/2013
  1.  S SPM12=1_CS_"{#}"_SC_"Number"_SC_"UCUM"_SC_"unit"_SC_"unit"_SC_"L"_SC_"1.1"_SC_LA7VER
  1.  Q SPM12
  1.  ;
  1. SPM17(CS,LDFN,LIDT)  ;-- speciment collection date/time
  1.  N SPM17
  1.  S SPM17=$$FMTHL7^XLFDT($P($G(^LR(LRDFN,LRSS,LRIDT,0)),U))_CS_$$FMTHL7^XLFDT($P($G(^LR(LRDFN,LRSS,LRIDT,0)),U))
  1.  Q SPM17
  1.  ;
  1. SPM18(CS,LDFN,LIDT)  ;-- specimen received date/time
  1.  N SPM18
  1.  S SPM18=$$FMTHL7^XLFDT($P($G(^LR(LRDFN,LRSS,LRIDT,0)),U))
  1.  Q SPM18
  1.  ;
  1. SPM21(CS,ACC,SPC)  ;-- specimen reject reason
  1.  N SPM21
  1.  S SPM21=""
  1.  Q SPM21
  1.  ;