Routine: LA7UID2

LA7UID2 ;DALOI/JRR - Process Download Message for an entry in 62.48 ; 12/3/1997

 ;;5.2;AUTOMATED LAB INSTRUMENTS;**17,27,57**;Sep 27, 1994

BUILD ; Build one accession into an HL7 message

 ; HL7 package expects the HLSDATA array to contain the msg

 K HLSDATA

 ; Build segments

 D MSH

 Q:$D(LA7ERR)

 D ORC

 D PID

 D PV1

 D OBR

 ; Build entry in MESSAGE QUEUE file 62.49

 D Q6249

 S HLMTN="ORU"

 ; Send message

 D EN1^HLTRANS

 ; Set status to purgeable

 I $G(LA76249),$P($G(^LAHM(62.49,LA76249,0)),"^",3)'="E" D

 . N DIE,DA,DR

 . S DIE="^LAHM(62.49,",DA=LA76249,DR="2////X"

 . D ^DIE

 D KVAR^LRX

MSH ;requires LA7NDAP= IEN in 770 HL7 NON-DHCP APPLICATION file

 D KILL^HLTRANS ;kill HL variables

 S HLNDAP=LA7NDAP ;required variable before calling INIT^HLTRANS

 D INIT^HLTRANS ;set up required HL variables

 K LA7ERR

 I $D(HLERR) D CREATE^LA7LOG(4) S LA7ERR="" QUIT

 S HLSDATA(0)=$$MSH^HLFNC1("ORM")

ORC ;

 K LA7ORC

 S LA7ORC(1)="NW"

 S LA7ORC(3)=$G(^LRO(68,LA768,1,LA76801,1,LA76802,.1))

 S LA7ORC(12)=$P(LA7ACC0,"^",8) ;provider

 S:LA7ORC(12) LA7ORC(12)=$E(HLECH)_$$HLNAME^HLFNC($$GET1^DIQ(200,LA7ORC(12)_",",.01))

 F LA7=0:0 S LA7=$O(LA7ORC(LA7)) Q:'LA7  D

 . S $P(LA7ORC,HLFS,LA7)=LA7ORC(LA7)

 S HLSDATA(3)="ORC"_HLFS_LA7ORC

PID K LA7PID

 S LRDFN=+LA7ACC0 K LRDPF

 D DEM^LRX

 S LA7PID(3)=$$M11^HLFNC(LRDFN)

 S LA7PID(5)=$$HLNAME^HLFNC(PNM)

 I $L(SEX) S LA7PID(8)=$S("FM"[SEX:SEX,1:"U")

 I $L(SSN) S LA7PID(19)=SSN

 I DOB S LA7PID(7)=$$HLDATE^HLFNC(DOB,"DT")

 S LA7PID=""

 F LA7=0:0 S LA7=$O(LA7PID(LA7)) Q:'LA7  D

 . S $P(LA7PID,HLFS,LA7)=LA7PID(LA7)

 S HLSDATA(1)="PID"_HLFS_LA7PID

PV1 K LA7PV1

 S LA7PV1(3)=$P(LA7ACC0,"^",7)

 S LA7PV1=""

 F LA7=0:0 S LA7=$O(LA7PV1(LA7)) Q:'LA7  D

 . S $P(LA7PV1,HLFS,LA7)=LA7PV1(LA7)

 S HLSDATA(2)="PV1"_HLFS_LA7PV1

OBR ;

 I '$D(ZTQUEUED),$G(LRLL) W:$X+5>IOM !,$S($G(LRTYPE):"Cup",1:"Seq"),": " W LA76822,", "

 N LA760,LA7CDT,LA7CMT,LA7I,LA7SPEC

 K LA7OBR

 S LA7CNT=0

 ; Get infection warning if any.

 S LRINFW=$G(^LR(LRDFN,.091))

 ; Collection date/time node.

 S LA7=$G(^LRO(68,LA768,1,LA76801,1,LA76802,3))

 ; Draw time - If time invalid adjust to next lower valid time

 I LA7 D

 . N LA7X

 . S LA7X=$$CHKDT(+LA7)

 . S LA7CDT=$$HLDATE^HLFNC(LA7X,"TS")

 S LA7CMT=$TR($P(LA7,"^",6),"~") ; Specimen comment if any, strip "~".

 S LA7=+$G(^LRO(68,LA768,1,LA76801,1,LA76802,5,1,0)) ;specimen

 S LA7SPEC=$$GET1^DIQ(61,LA7_",","LEDI HL7:HL7 ABBR") ;HL7 code from Topography

 S LA7UID=$P($G(^LRO(68,LA768,1,LA76801,1,LA76802,.3)),"^") ;unique ID

 S LA7ACC=$P($G(^LRO(68,LA768,1,LA76801,1,LA76802,.2)),"^") ;accession

 S LA7I=0

 F  S LA7I=$O(LA7ACC(LA7I)) Q:'LA7I  D

 . K LA7OBR

 . S LA760=+LA7ACC(LA7I)

 . S LA7TMP=$G(^TMP("LA7",$J,LA7INST,LA7I))

 . Q:'LA7TMP

 . S LA7CODE=$P(LA7TMP,"^",6)

 . S LA7DATA=$P(LA7TMP,"^",7)

 . S LA7CNT=LA7CNT+1,LA7OBR(1)=LA7CNT

 . S LA7OBR(4)=LA7CODE_$E(HLECH)_$P(LA7TMP,"^",4)_$E(HLECH)_99001_$E(HLECH)_LA760_"X"_LA7DATA_$E(HLECH)_$P(^LAB(60,LA760,0),"^")_$E(HLECH)_99002

 . I $G(LA7CDT) S LA7OBR(7)=LA7CDT ; Draw time.

 . I $L(LRINFW) S LA7OBR(12)=$E(HLECH)_LRINFW ; Infection warning.

 . S LA7OBR(13)=LA7CMT ; Specimen comment

 . S LA7OBR(15)=LA7SPEC ;HL7 code from Topography

 . I LRDPF'=2 S $P(LA7OBR(15),$E(HLECH),3)=$S(LRDPF=62.3:"CONTROL",1:"")

 . S LRCADR="" S LRCADR=$O(^LAB(62.4,"B",$P(LRAUTO,"^"),LRCADR))

 . S LA7D0=+$G(LRCADR) ;KAT

 . S LRCADR=$P($G(^LAB(62.4,+LRCADR,9)),U,9)

 . S LA7OBR(18)=$P(LRAUTO,"^")_$E(HLECH)_LRCADR ;instrument name^card address

 . K LRCADR ;KAT added instrument address

 . S LA7OBR(19)=""

 . F LA7="LA76821","LA76822","LA768","LA76801","LA76802","LA7ACC","LA7UID" D

 . . I LA7="LA76821",'$G(LRFORCE),LA76821 N LA76821 S LA76821="" ; No tray if don't send tray/cup flag.

 . . I LA7="LA76822",'$G(LRFORCE),LA76822 N LA76822 S LA76822="" ; No cup if don't send tray/cup flag.

 . . S LA7OBR(19)=LA7OBR(19)_@LA7_$E(HLECH)

 . . ; LA7OBR(19)=tray^cup^lraa^lrad^lran^lracc^lruid

 . S LA7=+$P(LA7ACC(LA7I),"^",2) ; Test urgency.

 . S LA7=$P($G(^LAB(62.05,LA7,0)),"^",4) ; HL7 priority from Urgency file.

 . S $P(LA7OBR(27),$E(HLECH),6)=$S($L(LA7):LA7,1:"R") ; HL7 priority, default routine (R).

 . S LA7=$P($G(^LRO(68,LA768,.4)),"^",2)

 . ;KAT-Added using field .04 in Auto Instr file.

 . S LA7D0=+$P($G(^LAB(62.4,+LA7D0,9)),U,10)

 . S LA7OBR(2)=$S(LA7="L":LA7UID,1:$E("0000000000",1,LA7D0-$L(LA76802))_LA76802) ;long or short sample ID

 . K LA7D0

 . F LA7=0:0 S LA7=$O(LA7OBR(LA7)) Q:'LA7  D

 . . S $P(LA7OBR,HLFS,LA7)=LA7OBR(LA7)

 . S HLSDATA(3+LA7CNT)="OBR"_HLFS_LA7OBR

CHKDT(LA7X) ; Check validity of date/time

 ; Adjust invalid times to closest valid time - correct for lab problem

 ; that generated invalid FileMan date/times.

 ; If hours>24 then set to 24 with no minutes/seconds

 ; If minutes greater than 59 then set to 59

 ; If seconds greater than 59 then set to 59

 N I,LA7Y,X

 S LA7Y=$P(LA7X,".",2)

 ; If time present then check otherwise skip and return input.

 I $L(LA7Y) D

 . F I=1:2:5 D

 . . S LA7Y(I)=$E(LA7Y,I,I+1)

 . . I $L(LA7Y(I))=1 S LA7Y(I)=LA7Y(I)_"0"

 . . I LA7Y(I)>$S(I=1:24,1:59) S LA7Y(I)=$S(I=1:24,1:59)

 . . I I=1,LA7Y(1)=24 S LA7Y=24

 . S X="."_LA7Y(1)_LA7Y(3)_LA7Y(5),X=+X

 . S $P(LA7X,".",2)=$P(X,".",2)

 Q LA7X

Q6249 ; create an entry in the MESSAGE QUEUE file to store this message

 N DIC,DINUM,DLAYGO

 S LA7DTIM=$$NOW^XLFDT

 L +^LAHM(62.49,0):9999999

 F X=$P(^LAHM(62.49,0),"^",3):1 Q:'$D(^LAHM(62.49,X))

 S LA76249=X

 K DD,DO

 S DIC="^LAHM(62.49,",DIC(0)="LF",DLAYGO=62.49

 S DINUM=X

 S DIC("DR")="1////O;3////3;4////"_LA7DTIM_";.5////"_LA76248

 S DIC("DR")=DIC("DR")_";2////Q;5////"_$P(LRAUTO,"^",1)_"-O-"_LA7UID

 D FILE^DICN

 L -^LAHM(62.49,0)

 S LA7MSH=HLSDATA(0)

 I HLFS'="^" S LA7MSH=$TR(LA7MSH,"^"," "),LA7MSH=$TR(LA7MSH,HLFS,"^")

 S ^LAHM(62.49,LA76249,100)=LA7MSH

 S LA71=0,LA7=""

 F  S LA7=$O(HLSDATA(LA7)) Q:LA7=""  D

 . S LA71=LA7

 . S ^LAHM(62.49,LA76249,150,LA7+1,0)=HLSDATA(LA7)

 S ^LAHM(62.49,LA76249,150,0)="^^"_LA71_"^"_LA71_"^"_DT

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLA7UID2   6129     printed  Apr 23, 2025@17:54:16                                                                                                                                                                                                     Page 2

LA7UID2   ;DALOI/JRR - Process Download Message for an entry in 62.48 ; 12/3/1997

 +1       ;;5.2;AUTOMATED LAB INSTRUMENTS;**17,27,57**;Sep 27, 1994

 +2        QUIT

 +3       ;

BUILD     ; Build one accession into an HL7 message

 +1       ;

 +2       ; HL7 package expects the HLSDATA array to contain the msg

 +3        KILL HLSDATA

 +4       ;

 +5       ; Build segments

 +6        DO MSH

 +7        if $DATA(LA7ERR)

               QUIT

 +8        DO ORC

 +9        DO PID

 +10       DO PV1

 +11       DO OBR

 +12      ; Build entry in MESSAGE QUEUE file 62.49

 +13       DO Q6249

 +14       SET HLMTN="ORU"

 +15      ; Send message

 +16       DO EN1^HLTRANS

 +17      ;

 +18      ; Set status to purgeable

 +19       IF $GET(LA76249)

               IF $PIECE($GET(^LAHM(62.49,LA76249,0)),"^",3)'="E"

                   Begin DoDot:1

 +20                   NEW DIE,DA,DR

 +21                   SET DIE="^LAHM(62.49,"

                       SET DA=LA76249

                       SET DR="2////X"

 +22                   DO ^DIE

                   End DoDot:1

 +23      ;

 +24       DO KVAR^LRX

 +25       QUIT

 +26      ;

 +27      ;

MSH       ;requires LA7NDAP= IEN in 770 HL7 NON-DHCP APPLICATION file

 +1       ;kill HL variables

           DO KILL^HLTRANS

 +2       ;required variable before calling INIT^HLTRANS

           SET HLNDAP=LA7NDAP

 +3       ;set up required HL variables

           DO INIT^HLTRANS

 +4        KILL LA7ERR

 +5        IF $DATA(HLERR)

               DO CREATE^LA7LOG(4)

               SET LA7ERR=""

               QUIT

 +6        SET HLSDATA(0)=$$MSH^HLFNC1("ORM")

 +7        QUIT

ORC       ;

 +1        KILL LA7ORC

 +2        SET LA7ORC(1)="NW"

 +3        SET LA7ORC(3)=$GET(^LRO(68,LA768,1,LA76801,1,LA76802,.1))

 +4       ;provider

           SET LA7ORC(12)=$PIECE(LA7ACC0,"^",8)

 +5        if LA7ORC(12)

               SET LA7ORC(12)=$EXTRACT(HLECH)_$$HLNAME^HLFNC($$GET1^DIQ(200,LA7ORC(12)_",",.01))

 +6        FOR LA7=0:0

               SET LA7=$ORDER(LA7ORC(LA7))

               if 'LA7

                   QUIT

               Begin DoDot:1

 +7                SET $PIECE(LA7ORC,HLFS,LA7)=LA7ORC(LA7)

               End DoDot:1

 +8        SET HLSDATA(3)="ORC"_HLFS_LA7ORC

 +9        QUIT

PID        KILL LA7PID

 +1        SET LRDFN=+LA7ACC0

           KILL LRDPF

 +2        DO DEM^LRX

 +3        SET LA7PID(3)=$$M11^HLFNC(LRDFN)

 +4        SET LA7PID(5)=$$HLNAME^HLFNC(PNM)

 +5        IF $LENGTH(SEX)

               SET LA7PID(8)=$SELECT("FM"[SEX:SEX,1:"U")

 +6        IF $LENGTH(SSN)

               SET LA7PID(19)=SSN

 +7        IF DOB

               SET LA7PID(7)=$$HLDATE^HLFNC(DOB,"DT")

 +8        SET LA7PID=""

 +9        FOR LA7=0:0

               SET LA7=$ORDER(LA7PID(LA7))

               if 'LA7

                   QUIT

               Begin DoDot:1

 +10               SET $PIECE(LA7PID,HLFS,LA7)=LA7PID(LA7)

               End DoDot:1

 +11       SET HLSDATA(1)="PID"_HLFS_LA7PID

 +12       QUIT

PV1        KILL LA7PV1

 +1        SET LA7PV1(3)=$PIECE(LA7ACC0,"^",7)

 +2        SET LA7PV1=""

 +3        FOR LA7=0:0

               SET LA7=$ORDER(LA7PV1(LA7))

               if 'LA7

                   QUIT

               Begin DoDot:1

 +4                SET $PIECE(LA7PV1,HLFS,LA7)=LA7PV1(LA7)

               End DoDot:1

 +5        SET HLSDATA(2)="PV1"_HLFS_LA7PV1

 +6        QUIT

OBR       ;

 +1        IF '$DATA(ZTQUEUED)

               IF $GET(LRLL)

                   if $X+5>IOM

                       WRITE !,$SELECT($GET(LRTYPE):"Cup",1:"Seq"),": "

                   WRITE LA76822,", "

 +2        NEW LA760,LA7CDT,LA7CMT,LA7I,LA7SPEC

 +3        KILL LA7OBR

 +4        SET LA7CNT=0

 +5       ; Get infection warning if any.

 +6        SET LRINFW=$GET(^LR(LRDFN,.091))

 +7       ; Collection date/time node.

 +8        SET LA7=$GET(^LRO(68,LA768,1,LA76801,1,LA76802,3))

 +9       ; Draw time - If time invalid adjust to next lower valid time

 +10       IF LA7

               Begin DoDot:1

 +11               NEW LA7X

 +12               SET LA7X=$$CHKDT(+LA7)

 +13               SET LA7CDT=$$HLDATE^HLFNC(LA7X,"TS")

               End DoDot:1

 +14      ; Specimen comment if any, strip "~".

           SET LA7CMT=$TRANSLATE($PIECE(LA7,"^",6),"~")

 +15      ;specimen

           SET LA7=+$GET(^LRO(68,LA768,1,LA76801,1,LA76802,5,1,0))

 +16      ;HL7 code from Topography

           SET LA7SPEC=$$GET1^DIQ(61,LA7_",","LEDI HL7:HL7 ABBR")

 +17      ;unique ID

           SET LA7UID=$PIECE($GET(^LRO(68,LA768,1,LA76801,1,LA76802,.3)),"^")

 +18      ;accession

           SET LA7ACC=$PIECE($GET(^LRO(68,LA768,1,LA76801,1,LA76802,.2)),"^")

 +19       SET LA7I=0

 +20       FOR

               SET LA7I=$ORDER(LA7ACC(LA7I))

               if 'LA7I

                   QUIT

               Begin DoDot:1

 +21               KILL LA7OBR

 +22               SET LA760=+LA7ACC(LA7I)

 +23               SET LA7TMP=$GET(^TMP("LA7",$JOB,LA7INST,LA7I))

 +24               if 'LA7TMP

                       QUIT

 +25               SET LA7CODE=$PIECE(LA7TMP,"^",6)

 +26               SET LA7DATA=$PIECE(LA7TMP,"^",7)

 +27               SET LA7CNT=LA7CNT+1

                   SET LA7OBR(1)=LA7CNT

 +28               SET LA7OBR(4)=LA7CODE_$EXTRACT(HLECH)_$PIECE(LA7TMP,"^",4)_$EXTRACT(HLECH)_99001_$EXTRACT(HLECH)_LA760_"X"_LA7DATA_$EXTRACT(HLECH)_$PIECE(^LAB(60,LA760,0),"^")_$EXTRACT(HLECH)_99002

 +29      ; Draw time.

                   IF $GET(LA7CDT)

                       SET LA7OBR(7)=LA7CDT

 +30      ; Infection warning.

                   IF $LENGTH(LRINFW)

                       SET LA7OBR(12)=$EXTRACT(HLECH)_LRINFW

 +31      ; Specimen comment

                   SET LA7OBR(13)=LA7CMT

 +32      ;HL7 code from Topography

                   SET LA7OBR(15)=LA7SPEC

 +33               IF LRDPF'=2

                       SET $PIECE(LA7OBR(15),$EXTRACT(HLECH),3)=$SELECT(LRDPF=62.3:"CONTROL",1:"")

 +34               SET LRCADR=""

                   SET LRCADR=$ORDER(^LAB(62.4,"B",$PIECE(LRAUTO,"^"),LRCADR))

 +35      ;KAT

                   SET LA7D0=+$GET(LRCADR)

 +36               SET LRCADR=$PIECE($GET(^LAB(62.4,+LRCADR,9)),U,9)

 +37      ;instrument name^card address

                   SET LA7OBR(18)=$PIECE(LRAUTO,"^")_$EXTRACT(HLECH)_LRCADR

 +38      ;KAT added instrument address

                   KILL LRCADR

 +39               SET LA7OBR(19)=""

 +40               FOR LA7="LA76821","LA76822","LA768","LA76801","LA76802","LA7ACC","LA7UID"

                       Begin DoDot:2

 +41      ; No tray if don't send tray/cup flag.

                           IF LA7="LA76821"

                               IF '$GET(LRFORCE)

                                   IF LA76821

                                       NEW LA76821

                                       SET LA76821=""

 +42      ; No cup if don't send tray/cup flag.

                           IF LA7="LA76822"

                               IF '$GET(LRFORCE)

                                   IF LA76822

                                       NEW LA76822

                                       SET LA76822=""

 +43                       SET LA7OBR(19)=LA7OBR(19)_@LA7_$EXTRACT(HLECH)

 +44      ; LA7OBR(19)=tray^cup^lraa^lrad^lran^lracc^lruid

                       End DoDot:2

 +45      ; Test urgency.

                   SET LA7=+$PIECE(LA7ACC(LA7I),"^",2)

 +46      ; HL7 priority from Urgency file.

                   SET LA7=$PIECE($GET(^LAB(62.05,LA7,0)),"^",4)

 +47      ; HL7 priority, default routine (R).

                   SET $PIECE(LA7OBR(27),$EXTRACT(HLECH),6)=$SELECT($LENGTH(LA7):LA7,1:"R")

 +48               SET LA7=$PIECE($GET(^LRO(68,LA768,.4)),"^",2)

 +49      ;KAT-Added using field .04 in Auto Instr file.

 +50               SET LA7D0=+$PIECE($GET(^LAB(62.4,+LA7D0,9)),U,10)

 +51      ;long or short sample ID

                   SET LA7OBR(2)=$SELECT(LA7="L":LA7UID,1:$EXTRACT("0000000000",1,LA7D0-$LENGTH(LA76802))_LA76802)

 +52               KILL LA7D0

 +53               FOR LA7=0:0

                       SET LA7=$ORDER(LA7OBR(LA7))

                       if 'LA7

                           QUIT

                       Begin DoDot:2

 +54                       SET $PIECE(LA7OBR,HLFS,LA7)=LA7OBR(LA7)

                       End DoDot:2

 +55               SET HLSDATA(3+LA7CNT)="OBR"_HLFS_LA7OBR

               End DoDot:1

 +56       QUIT

 +57      ;

 +58      ;

CHKDT(LA7X) ; Check validity of date/time

 +1       ; Adjust invalid times to closest valid time - correct for lab problem

 +2       ; that generated invalid FileMan date/times.

 +3       ; If hours>24 then set to 24 with no minutes/seconds

 +4       ; If minutes greater than 59 then set to 59

 +5       ; If seconds greater than 59 then set to 59

 +6       ;

 +7        NEW I,LA7Y,X

 +8       ;

 +9        SET LA7Y=$PIECE(LA7X,".",2)

 +10      ;

 +11      ; If time present then check otherwise skip and return input.

 +12       IF $LENGTH(LA7Y)

               Begin DoDot:1

 +13               FOR I=1:2:5

                       Begin DoDot:2

 +14                       SET LA7Y(I)=$EXTRACT(LA7Y,I,I+1)

 +15                       IF $LENGTH(LA7Y(I))=1

                               SET LA7Y(I)=LA7Y(I)_"0"

 +16                       IF LA7Y(I)>$SELECT(I=1:24,1:59)

                               SET LA7Y(I)=$SELECT(I=1:24,1:59)

 +17                       IF I=1

                               IF LA7Y(1)=24

                                   SET LA7Y=24

                       End DoDot:2

 +18               SET X="."_LA7Y(1)_LA7Y(3)_LA7Y(5)

                   SET X=+X

 +19               SET $PIECE(LA7X,".",2)=$PIECE(X,".",2)

               End DoDot:1

 +20      ;

 +21       QUIT LA7X

 +22      ;

 +23      ;

Q6249     ; create an entry in the MESSAGE QUEUE file to store this message

 +1       ;

 +2        NEW DIC,DINUM,DLAYGO

 +3       ;

 +4        SET LA7DTIM=$$NOW^XLFDT

 +5        LOCK +^LAHM(62.49,0):9999999

 +6        FOR X=$PIECE(^LAHM(62.49,0),"^",3):1

               if '$DATA(^LAHM(62.49,X))

                   QUIT

 +7        SET LA76249=X

 +8        KILL DD,DO

 +9        SET DIC="^LAHM(62.49,"

           SET DIC(0)="LF"

           SET DLAYGO=62.49

 +10       SET DINUM=X

 +11       SET DIC("DR")="1////O;3////3;4////"_LA7DTIM_";.5////"_LA76248

 +12       SET DIC("DR")=DIC("DR")_";2////Q;5////"_$PIECE(LRAUTO,"^",1)_"-O-"_LA7UID

 +13       DO FILE^DICN

 +14       LOCK -^LAHM(62.49,0)

 +15       SET LA7MSH=HLSDATA(0)

 +16       IF HLFS'="^"

               SET LA7MSH=$TRANSLATE(LA7MSH,"^"," ")

               SET LA7MSH=$TRANSLATE(LA7MSH,HLFS,"^")

 +17       SET ^LAHM(62.49,LA76249,100)=LA7MSH

 +18       SET LA71=0

           SET LA7=""

 +19       FOR

               SET LA7=$ORDER(HLSDATA(LA7))

               if LA7=""

                   QUIT

               Begin DoDot:1

 +20               SET LA71=LA7

 +21               SET ^LAHM(62.49,LA76249,150,LA7+1,0)=HLSDATA(LA7)

               End DoDot:1

 +22       SET ^LAHM(62.49,LA76249,150,0)="^^"_LA71_"^"_LA71_"^"_DT

 +23       QUIT

LA7UID2.m