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

LA7COBX2.m

Go to the documentation of this file. 
  1. LA7COBX2 ;VA/DALOI/JMC - LAB OBX Segment message builder (AP subscripts) cont'd ; 22-Oct-2013 09:22 ; MAW
  1.  ;;5.2;AUTOMATED LAB INSTRUMENTS;**46,1018,64,1027,68,1033**;NOV 01, 1997
  1.  ;
  1. AP ; Build OBX segments for resultss that are anatomic/surgical pathology subscripts
  1.  ; Called by LA7VOBX
  1.  ;
  1.  N LA7953,LA7ACODE,LA7CODE,LA7DIV,LA7IENS,LA7OBX5,LA7OBX5M,LA7SUB,LA7SUBFL,LA7VP,LA7WP,LA7X,LA7Y
  1.  ;
  1.  S (LA7953,LA7DIV,LA7VP)=""
  1.  ;
  1.  ; Surgical pathology subscript
  1.  I LRSS="SP" S LA7SUBFL=63.08
  1.  ;
  1.  ; Cytology subscript
  1.  I LRSS="CY" S LA7SUBFL=63.09
  1.  ;
  1.  ; Electron microscopy subscript
  1.  I LRSS="EM" S LA7SUBFL=63.02
  1.  ;
  1.  S LA7IENS=""
  1.  F I=3:-1:1 I $P(LRIDT,",",I) S LRIDT(I)=$P(LRIDT,",",I),LA7IENS=LA7IENS_LRIDT(I)_","
  1.  S LA7IENS=LA7IENS_LRDFN_","
  1.  S LRIDT=$P(LRIDT,",")
  1.  S LA7SUB(0)=$G(^LR(LRDFN,LRSS,LRIDT,0))
  1.  ;
  1.  ; Get default codes
  1.  S LA7CODE=$$DEFCODE^LA7VHLU5(LRSS,LRSB,"","")
  1.  ;
  1.  ; Initialize OBX segment
  1.  S LA7OBX(0)="OBX"
  1.  ;
  1.  ; Value type
  1.  S LA7X=LA7SUBFL,LA7Y=LRSB
  1.  I LRSB=1.2 S LA7X=$S(LRSS="SP":63.817,LRSS="CY":63.907,LRSS="EM":63.207,1:""),LA7Y=1
  1.  I LRSB="10,1.5" S LA7X=$S(LRSS="SP":63.82,LRSS="CY":63.982,LRSS="EM":63.282,1:""),LA7Y=.01
  1.  I LRSB="10,2",LRSS="SP" S LA7X=63.12,LA7Y=2
  1.  I LRSB="10,5" S LA7X=$S(LRSS="SP":63.819,LRSS="CY":63.919,LRSS="EM":63.219,1:""),LA7Y=1
  1.  S LA7OBX(2)=$$OBX2^LA7VOBX(LA7X,LA7Y)
  1.  ;
  1.  ; Observation identifier
  1.  S LA7OBX(3)=$$OBX3^LA7VOBX($P(LA7CODE,"!",2),$P(LA7CODE,"!",3),"",LA7FS,LA7ECH,$G(LA7INTYP))
  1.  ;
  1.  ; Observation sub-ID
  1.  ; Create sub-ID for supplementary reports and special studies
  1.  D SUBID
  1.  ;
  1.  ; Build result field
  1.  I LRSB=.012 D
  1.  . N LA7I,LA7X,LA7Y
  1.  . S LA7I=0
  1.  . F  S LA7I=$O(^LR(LRDFN,LRSS,LRIDT,.1,LA7I)) Q:'LA7I  D
  1.  . . S LA7X=$G(^LR(LRDFN,LRSS,LRIDT,.1,LA7I,0))
  1.  . . S LA7Y(LA7I)=$P(LA7X,"^")
  1.  . . S LA7OBX(2)="CE" ; Override DD to conform to HL7 standard
  1.  . S LA7OBX(5)=$$OBX5R^LA7VOBX(.LA7Y,LA7OBX(2),LA7FS,LA7ECH)
  1.  ;
  1.  I LRSB'=.012 D
  1.  . I $P(LRSB,",")=10,LRSB'="10,5" Q
  1.  . I LA7NVAF=1 D DOD Q
  1.  . I LRSB=1.2 N LRSB S LA7SUBFL=$S(LRSS="SP":63.817,LRSS="CY":63.907,LRSS="EM":63.207,1:""),LRSB=1
  1.  . I LRSB="10,5" N LRSB S LA7SUBFL=$S(LRSS="SP":63.819,LRSS="CY":63.919,LRSS="EM":63.219,1:""),LRSB=1
  1.  . D OBX5M^LA7VOBX(LA7SUBFL,LA7IENS,LRSB,.LA7WP,LA7FS,LA7ECH)
  1.  . D BUILDSEG^LA7VHLU(.LA7WP,.LA7OBX5M,"")
  1.  . M LA7OBX(5)=LA7OBX5M
  1.  ;
  1.  I $P(LRSB,",")=10,LRSB'="10,5" D
  1.  . N LA7VAL,LA7SUBFL,X
  1.  . I LRSS="SP",LRSB="10,2" D  Q
  1.  . . S LA7VAL=$$GET1^DIQ(63.12,LA7IENS,2)
  1.  . . S LA7OBX(5)=$$OBX5^LA7VOBX(LA7VAL,LA7OBX(2),LA7FS,LA7ECH)
  1.  . . S LA7OBX(6)=$$OBX6^LA7VOBX("g","",LA7FS,LA7ECH,$G(LA7INTYP))
  1.  . I LRSB=10 S LA7SUBFL=$S(LRSS="SP":63.12,LRSS="CY":63.912,LRSS="EM":63.212,1:"")
  1.  . I LRSB="10,1.5" S LA7SUBFL=$S(LRSS="SP":63.82,LRSS="CY":63.982,LRSS="EM":63.282,1:"")
  1.  . S LA7VAL=$$GET1^DIQ(LA7SUBFL,LA7IENS,.01)
  1.  . S X=$$GET1^DIQ(LA7SUBFL,LA7IENS,".01:2")
  1.  . I X'="" S LA7VAL=$S($E(X,1,2)="T-":"",1:"T-")_X_"^"_LA7VAL_"^SNM",LA7OBX(2)="CE"
  1.  . S LA7OBX(5)=$$OBX5^LA7VOBX(LA7VAL,LA7OBX(2),LA7FS,LA7ECH)
  1.  ;
  1.  ; Don't build this segment if no results/value to send
  1.  I $G(LA7OBX(5,0))="",$G(LA7OBX(5))="" Q
  1.  ;
  1.  ; Build sequence id
  1.  S LA7OBX(1)=$$OBX1^LA7VOBX(.LA7OBXSN)
  1.  ;
  1.  ; "P"artial, "F"inal , "A"mended results
  1.  ; If not release date then pending
  1.  I '$P(LA7SUB(0),"^",11) S LA7OBX(11)="P"
  1.  ;
  1.  ; If release date then check for changes
  1.  I $P(LA7SUB(0),"^",11) D
  1.  . I $P(LA7SUB(0),"^",15) S LA7OBX(11)="C"
  1.  . E  S LA7OBX(11)="F"
  1.  ;
  1.  S LA7DIV=$P($G(^LR(LRDFN,LRSS,LRIDT,"RF")),"^")
  1.  I LA7DIV="",$P(LA7SUB(0),"^",13),$$DIV4^XUSER(.LA7DIV,$P(LA7SUB(0),"^",2)) S LA7DIV=$O(LA7DIV(0))
  1.  ;
  1.  ; Facility that performed the testing
  1.  S LA7OBX(15)=$$OBX15^LA7VOBX(LA7DIV,LA7FS,LA7ECH)
  1.  ;
  1.  ; Person that verified the test
  1.  S LA7VP=$P(LA7SUB(0),"^",13)
  1.  I LA7VP S LA7OBX(16)=$$OBX16^LA7VOBX(LA7VP,LA7DIV,LA7FS,LA7ECH)
  1.  ;
  1.  ; Performing organization name/address
  1.  I LA7DIV'="" D
  1.  . N LA7DT
  1.  . S LA7OBX(23)=$$OBX23^LA7VOBX(4,LA7DIV,LA7FS,LA7ECH)
  1.  . S LA7DT=$S($P(LA7SUB(0),"^",11):$P(LA7SUB(0),"^",11),1:$$NOW^XLFDT)
  1.  . S LA7OBX(24)=$$OBX24^LA7VOBX(4,LA7DIV,LA7DT,LA7FS,LA7ECH)
  1.  ;
  1.  D BUILDSEG^LA7VHLU(.LA7OBX,.LA7ARRAY,LA7FS)
  1.  ;
  1.  Q
  1.  ;
  1.  ;
  1. SUBID ; Build sub-id for "SP" subscript
  1.  ; Used to identify supplementary reports, specimens and related special
  1.  ; studies performed on thoese specimens.
  1.  ;
  1.  N LA7SUBID
  1.  ;
  1.  S LA7SUBID=""
  1.  ;
  1.  ; Sub-id's for supplementary reports
  1.  I LRSB=1.2 S LA7SUBID="1."_$P(LA7IENS,",")
  1.  ;
  1.  ; Sub-id's for specimens and special studies
  1.  I LRSB=10!(LRSB="10,2") S LA7SUBID="10."_$P(LA7IENS,",")
  1.  I LRSB="10,1.5"!(LRSB="10,5") S LA7SUBID="10."_$P(LA7IENS,",",2)_"."_$P(LA7IENS,",")
  1.  ;
  1.  I LA7SUBID'="" S LA7OBX(4)=$$OBX4^LA7VOBX(LA7SUBID,LA7FS,LA7ECH)
  1.  ;
  1.  Q
  1.  ;
  1.  ;
  1. DOD ; Build OBX segment's to special DoD specifications.
  1.  ; Send word-processing fields as series of OBX's for DoD.
  1.  ; DoD cannot handle formatted text (FT) data type.
  1.  ;
  1.  S LA7OBX(2)="ST"
  1.  S LA7VAL=$G(^LR(LRDFN,LRSS,$P(LA7IDT,","),LA7SB,$P(LA7IDT,",",2),0))
  1.  I LA7VAL="" S LA7VAL=" "
  1.  S LA7OBX(5)=$$OBX5^LA7VOBX(LA7VAL,LA7OBX(2),LA7FS,LA7ECH)
  1.  Q