294 lines
9.1 KiB
Mathematica
294 lines
9.1 KiB
Mathematica
LA7VHLU ;DALOI/JMC - HL7 segment builder utility ; 11-25-1998
|
|
;;5.2;AUTOMATED LAB INSTRUMENTS;**46,62,64**;Sep 27, 1994
|
|
;
|
|
; Reference to PROTOCOL file (#101) supported by DBIA #872
|
|
;
|
|
STARTMSG(LA7EVNT,LA76249) ; Create/initialize HL message
|
|
;
|
|
; Call with LA7EVNT = Lab event protocol in file (#101)
|
|
; LA76249 = if entry already exists, do not create new entry
|
|
;
|
|
N LA7MSH,X
|
|
;
|
|
S LA76249=+$G(LA76249)
|
|
D INITHL(LA7EVNT)
|
|
I LA76249<1 S LA76249=$$INIT6249^LA7VHLU
|
|
I $G(HL) D Q
|
|
. N LA7X
|
|
. S LA7X(1)=LA76249,LA7X(2)=$TR(HL,"^","-")
|
|
. D CREATE^LA7LOG(28)
|
|
S X="MSH"_LA7FS_LA7ECH_LA7FS_HL("SAN")_LA7FS_HL("SAF")_LA7FS
|
|
S $P(X,LA7FS,9)=HL("MTN")_$E(LA7ECH,1)_HL("ETN")
|
|
S $P(X,LA7FS,11)=HL("PID")
|
|
S $P(X,LA7FS,12)=HL("VER")
|
|
S:$D(HL("ACAT")) $P(X,LA7FS,15)=HL("ACAT")
|
|
S:$D(HL("APAT")) $P(X,LA7FS,16)=HL("APAT")
|
|
S LA7MSH(0)=X
|
|
D FILE6249^LA7VHLU(LA76249,.LA7MSH)
|
|
;
|
|
Q
|
|
;
|
|
INITHL(LA7EVNT) ; Initialize HL environment
|
|
;
|
|
; Call with LA7EVNT = Lab event protocol in file (#101)
|
|
; HL7 v1.6 interface
|
|
; LA7101 - IEN of event protocol
|
|
; HL - array of output parameters
|
|
; INT - DHCP-to-DHCP only
|
|
;
|
|
K ^TMP("HLS",$J)
|
|
K HL,HLCOMP,HLSUB,HLFS,HLERR,HLMID
|
|
;
|
|
S LA7101=$O(^ORD(101,"B",LA7EVNT,0))
|
|
D INIT^HLFNC2(LA7101,.HL,0)
|
|
S (LA7FS,HLFS)=$G(HL("FS"))
|
|
S (LA7ECH,HLECH)=$G(HL("ECH"))
|
|
S HLCOMP=$E($G(HL("ECH")),1)
|
|
S HLSUB=$E($G(HL("ECH")),4)
|
|
Q
|
|
;
|
|
;
|
|
GEN ; Generate HL7 v1.6 message
|
|
; LA7101 - IEN of event protocol
|
|
; HLARYTYP - array type
|
|
; HLFORMAT - HLMA formatted/not formatted
|
|
; HLMTIEN - IEN in 772 (batch messages)
|
|
; HLRESLT = message ID^error code^error description
|
|
; HLP("CONTPTR") - continuation pointer field value
|
|
; HLP("PRIORITY") - priority field value
|
|
; HLP("NAMESPACE") - package namespace
|
|
;
|
|
N HLEID,HLARYTYP,HLFORMAT,HLMTIEN,HLRESLT,I
|
|
S HLEID=LA7101,HLARYTYP="GM",HLFORMAT=1,HLMTIEN="",HLRESLT=""
|
|
S HLP("NAMESPACE")="LA"
|
|
D GENERATE^HLMA(HLEID,HLARYTYP,HLFORMAT,.HLRESLT,HLMTIEN,.HLP)
|
|
K LA7MID M LA7MID=HLRESLT
|
|
I $P(HLRESLT,"^",2)'="" D CREATE^LA7LOG(23)
|
|
I $O(LA7MID(0)) D
|
|
. S I=0
|
|
. F S I=$O(LA7MID(I)) Q:'I I $L($P(LA7MID,"^",2)) S HLRESLT=LA7MID(I) D CREATE^LA7LOG(23)
|
|
K HLP
|
|
Q
|
|
;
|
|
;
|
|
BUILDSEG(LA7ARRAY,LA7DATA,LA7FS) ; Build HL segment
|
|
; Call with LA7ARRAY = array containing fields to build into a segment,
|
|
; passed by reference.
|
|
; LA7DATA = array used to build segment, pass by reference
|
|
; used to return built segment.
|
|
; LA7FS = HL field separator
|
|
;
|
|
; Returns LA7DATA = array with segment built
|
|
; LA7DATA(0) = if everything fits on one node
|
|
; LA7DATA(0,1...) = multiple elements if >245 characters
|
|
;
|
|
N LA7I,LA7J,LA7LAST,LA7SUB
|
|
;
|
|
K LA7DATA
|
|
;
|
|
S LA7FS=$G(LA7FS)
|
|
;
|
|
; Node to store data in array
|
|
S LA7SUB=0
|
|
;
|
|
; Last element in array
|
|
S LA7LAST=$O(LA7ARRAY(""),-1)
|
|
;
|
|
F LA7I=0:1:LA7LAST D
|
|
. I ($L($G(LA7DATA(LA7SUB)))+$L($G(LA7ARRAY(LA7I))))>245 S LA7SUB=LA7SUB+1
|
|
. I $O(LA7ARRAY(LA7I,""))'="" D
|
|
. . S LA7J=""
|
|
. . F S LA7J=$O(LA7ARRAY(LA7I,LA7J)) Q:LA7J="" D
|
|
. . . I ($L($G(LA7DATA(LA7SUB)))+$L($G(LA7ARRAY(LA7I,LA7J))))>245 S LA7SUB=LA7SUB+1
|
|
. . . S LA7DATA(LA7SUB)=$G(LA7DATA(LA7SUB))_$G(LA7ARRAY(LA7I,LA7J))
|
|
. S LA7DATA(LA7SUB)=$G(LA7DATA(LA7SUB))_$G(LA7ARRAY(LA7I))_LA7FS
|
|
Q
|
|
;
|
|
;
|
|
FILESEG(LA7ROOT,LA7DATA) ; File HL segment in global
|
|
; Call with LA7ROOT = global root used to store HL segment
|
|
; LA7DATA = array with data to file (pass by reference)
|
|
;
|
|
N LA7HLSN,LA7I
|
|
I $G(LA7ROOT)="" Q ; no global root passed.
|
|
;
|
|
; get next subscript number
|
|
S LA7HLSN=($O(@(LA7ROOT)@(""),-1))+1
|
|
;
|
|
; store first 245 characters of segment
|
|
S @LA7ROOT@(LA7HLSN)=$G(LA7DATA(0))
|
|
;
|
|
; if segment >245 characters then store rest of message
|
|
S LA7I=0
|
|
F S LA7I=$O(LA7DATA(LA7I)) Q:LA7I="" S @LA7ROOT@(LA7HLSN,LA7I)=LA7DATA(LA7I)
|
|
;
|
|
Q
|
|
;
|
|
;
|
|
INIT6249() ; Create stub entry in file #62.49
|
|
; Returns ien of entry in #62.49 that was created
|
|
; NOTE: set lock on entry in #62.49, does not release it.
|
|
; calling process should release lock
|
|
;
|
|
N LA7ERR,LA7FDA,LA7IEN,X,Y
|
|
;
|
|
; Lock zeroth node of file.
|
|
L +^LAHM(62.49,0):99999
|
|
I '$T Q -1
|
|
;
|
|
F LA76249=$P(^LAHM(62.49,0),"^",3):1 Q:'$D(^LAHM(62.49,LA76249))
|
|
; Lock entry in file 62.49 - Calling process is responsible for releasing
|
|
; lock when no longer needed.
|
|
L +^LAHM(62.49,LA76249):99999
|
|
I '$T Q -1
|
|
;
|
|
S LA7DT=$$NOW^XLFDT
|
|
S LA7FDA(1,62.49,"+1,",.01)=LA76249 ; message number
|
|
S LA7FDA(1,62.49,"+1,",2)="B" ; status =(B)uilding
|
|
S LA7FDA(1,62.49,"+1,",4)=LA7DT ; Date/time entered
|
|
S LA7IEN(1)=LA76249
|
|
D UPDATE^DIE("S","LA7FDA(1)","LA7IEN","LA7ERR")
|
|
I $D(LA7ERR) S LA76249=-1
|
|
;
|
|
; Unlock zero node
|
|
L -^LAHM(62.49,0)
|
|
Q LA76249
|
|
;
|
|
;
|
|
FILE6249(LA76249,LA7DATA) ; File HL segment in LAHM(62.49) global
|
|
; Call with LA76249 = ien of entry in file # 62.49
|
|
; LA7DATA = array with data to file (pass by reference)
|
|
;
|
|
N LA7I,LA7J,LA7WP
|
|
I '$G(LA76249) Q ; no entry passed.
|
|
;
|
|
; move data in positive number subscripts
|
|
S LA7I="",LA7J=0
|
|
F S LA7I=$O(LA7DATA(LA7I)) Q:LA7I="" D
|
|
. S LA7J=LA7J+1
|
|
. S LA7WP(LA7J)=LA7DATA(LA7I)
|
|
;
|
|
; set blank line which separates each segment
|
|
S LA7WP(LA7J+1)=""
|
|
;
|
|
; file data
|
|
D WP^DIE(62.49,LA76249_",",150,"A","LA7WP")
|
|
Q
|
|
;
|
|
;
|
|
P(LA7X,LA7P,LA7EC) ; get field LA7P from array (passed by ref.)
|
|
; Call with LA7X = array to extract data from, pass by reference.
|
|
; LA7P = field to extract
|
|
; LA7EC = encoding character separator
|
|
;
|
|
; Returns LA7Y = value of requested piece
|
|
;
|
|
N I,L,LA7Y,L1,Y
|
|
S L=0,Y=1,LA7Y=""
|
|
;Y=begining piece of each node, L1=number of pieces in each node
|
|
;L=last piece in each node, quit when last piece is greater than LA7P
|
|
F I=0:1 Q:'$D(LA7X(I)) S L1=$L(LA7X(I),LA7EC),L=L1+Y-1 D Q:Y>LA7P
|
|
. ;if LA7P is less than last piece, this node has field you want
|
|
. S:LA7P'>L LA7Y=LA7Y_$P(LA7X(I),LA7EC,(LA7P-Y+1))
|
|
. S Y=L
|
|
Q LA7Y
|
|
;
|
|
;
|
|
PA(LA7X,LA7P,LA7EC,LA7Y) ; get field LA7P from array (passed by ref.)
|
|
; Call with LA7X = array to extract data from, pass by reference.
|
|
; LA7P = field to extract
|
|
; LA7EC = encoding character separator
|
|
;
|
|
; Returns LA7Y = array value of requested piece (returned by reference)
|
|
;
|
|
N I,L,L1,X,Y
|
|
S (L,LA7Y)=0,Y=1
|
|
;Y=begining piece of each node, L1=number of pieces in each node
|
|
;L=last piece in each node, quit when last piece is greater than LA7P
|
|
F I=0:1 Q:'$D(LA7X(I)) S L1=$L(LA7X(I),LA7EC),L=L1+Y-1 D Q:Y>LA7P
|
|
. ;if LA7P is less than last piece, this node has field you want
|
|
. I LA7P'>L S X=$P(LA7X(I),LA7EC,(LA7P-Y+1)) S:X]"" LA7Y=LA7Y+1,LA7Y(LA7Y)=X
|
|
. S Y=L
|
|
Q
|
|
;
|
|
;
|
|
BLG(LA7ACTN,LA7CHGTY,LA7FS,LA7ECH) ; Build BLG segment - billing information
|
|
; Call with LA7ACTN = billing account Number
|
|
; LA7CHGTY = charge type
|
|
; LA7ECH = HL encoding characters
|
|
;
|
|
; Returns LA7Y
|
|
;
|
|
; Default to CO (contract) for charge type - table 0122
|
|
S LA7CHGTY=$G(LA7CHGTY,"CO")
|
|
S LA7Y="BLG"_LA7FS_LA7FS_LA7CHGTY_LA7FS_$$M11^HLFNC(LA7ACTN,LA7ECH)_LA7FS
|
|
Q LA7Y
|
|
;
|
|
;
|
|
PTEXTID(LA74,LA7UID,LA7Y) ; Retrieve patient's id that was transmitted by other system.
|
|
; Used to build PID-2 when returning results to placer.
|
|
; Looks in file LAB PENDING ORDERS (#69.6) for info pertaining to placer's order.
|
|
; Call with LA74 = ien of placer in INSTITUTION file (#4)
|
|
; LA7UID = placer's specimen identifier (UID, etc.)
|
|
;
|
|
; Returns array LA7Y by reference
|
|
; LA7Y("FS") - original field separator
|
|
; LA7Y("ECH") - original encoding characters used
|
|
; LA7Y("PID-2") - original PID-2 sequence
|
|
; LA7Y("PID-4") - original PID-4 sequence
|
|
;
|
|
N LA7696,LA7X
|
|
;
|
|
S LA74=$G(LA74),LA7UID=$G(LA7UID),LA7Y=""
|
|
;
|
|
; Return null if no values passed
|
|
I LA74<1!(LA7UID="") Q
|
|
;
|
|
S LA7696=$O(^LRO(69.6,"RST",LA74,LA7UID,0))
|
|
I LA7696 D
|
|
. S LA7X=$G(^LRO(69.6,LA7696,700))
|
|
. S LA7Y("FS")=$E(LA7X,1)
|
|
. S LA7Y("ECH")=$E(LA7X,2,5)
|
|
. S LA7Y("PID-2")=$G(^LRO(69.6,LA7696,700.02))
|
|
. S LA7Y("PID-4")=$G(^LRO(69.6,LA7696,700.04))
|
|
Q
|
|
;
|
|
;
|
|
RETOBR(LA74,LA7UID,LA7NLT,LA7Y) ; Retrieve placer's various OBR's that were transmitted by other system.
|
|
; Used to build OBR-4/17/18 when returning results to placer.
|
|
; Looks in file LAB PENDING ORDERS (#69.6) for info pertaining to placer's order.
|
|
;
|
|
; Call with LA74 = ien of placer in INSTITUTION file (#4)
|
|
; LA7UID = placer's specimen identifier (UID, accession number, etc.)
|
|
; LA7NLT = ordered NLT test code
|
|
;
|
|
; Returns array LA7Y by reference
|
|
; LA7Y("FS") - original field separator
|
|
; LA7Y("ECH") - original encoding characters used
|
|
; LA7Y("OBR-4") - original OBR-4 sequence
|
|
; LA7Y("OBR-18") - original OBR-18 sequence
|
|
; LA7Y("OBR-19") - original OBR-19 sequence
|
|
;
|
|
N LA7696,LA76964,LA7X
|
|
;
|
|
S LA74=$G(LA74),LA7UID=$G(LA7UID),LA7Y=""
|
|
;
|
|
; Return null if no values passed
|
|
I LA74<1!(LA7UID="")!(LA7NLT="") Q
|
|
;
|
|
S LA7696=$O(^LRO(69.6,"RST",LA74,LA7UID,0))
|
|
I LA7696<1 Q
|
|
;
|
|
S LA7X=$G(^LRO(69.6,LA7696,700))
|
|
S LA7Y("FS")=$E(LA7X,1)
|
|
S LA7Y("ECH")=$E(LA7X,2,5)
|
|
;
|
|
S LA76964=$O(^LRO(69.6,LA7696,2,"C",LA7NLT,0))
|
|
I LA76964<1 Q
|
|
;
|
|
S LA7Y("OBR-4")=$G(^LRO(69.6,LA7696,2,LA76964,700.04))
|
|
S LA7Y("OBR-18")=$G(^LRO(69.6,LA7696,2,LA76964,700.18))
|
|
S LA7Y("OBR-19")=$G(^LRO(69.6,LA7696,2,LA76964,700.19))
|
|
;
|
|
Q
|