- 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 Jan 18, 2025@02:41:21 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