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