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

LA7VHLU.m

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