Routine: LA7VMSG1

LA7VMSG1 ;VA/DALOI/JMC - LAB ORU (Observation Result) message builder cont'd; 13-Aug-2013 09:09 ; MKK

 ;;5.2;AUTOMATED LAB INSTRUMENTS;**46,56,61,1018,64,1027,68,1033**;NOV 01, 1997

START ; Process entries in queue

 ; Called from LA7VMSG

 N LA,LAER,LA7VER

 N EID,HLEID,HLMTIEN,HLRESLT,HLARYTYP,HLECH,HLFS,HLCOMP,HLFORMAT

 N GBL,LA7MID,LA7V,LA7VS,LA7V0N,LA7VIEN,RSITE,LRNT

 N LA76248,LA76249,LA76249P,LA7DT,LA7ECH,LA7END,LA7FS,LA7NVAF,LA7ROOT,LA7X,LRDFN,LRIDT,LRSS,LRUID

 ; variable list

 ; LA("LRUID") - Host Unique ID from the local ACCESSION file (#68)

 ; LA("SITE")  - Primary site number of remote site ($$SITE^VASITE)

 ; LA("RUID")  - Remote sites Unique ID from ACCESSION file (#68)

 ; LA("ORD")   - Free text ordered test name from WKLD CODE file (#64)

 ; LA("LRNLT") - National Laboratory test code from WKLD CODE file (#64)

 ; LA("LRIDT") - Inverse date/time (accession date/time)

 ; LA("LRSS")  - test subscript defined in LABORATORY TEST file (#60)

 ; LA("LRDFN") - IEN in LAB DATA file (#63)

 ; LA("ORDT")  - Order date

 ; LA(62.49)   - entry in #62.49 which contains pointer to results to build

 L +^LAHM(62.49,"HL7 PROCESS",LA7MTYP):0 Q:'$T

 S GBL="^TMP(""HLS"","_$J_")"

 D SORTPAT

 I $D(^TMP("LA76248",$J)) D PROCESS

 D KVAR^LRX

 ; Release lock

 L -^LAHM(62.49,"HL7 PROCESS",LA7MTYP)

 K ^TMP("LA76248",$J),^TMP("LA7VS",$J),^TMP("HLS",$J)

 I $D(ZTQUEUED) S ZTREQ="@"

SORTPAT ; Sort all results for tranmsission

 N LA76248,LA76249,LA7END,LA7ROOT,LRDFN,LRUID

 K ^TMP("LA76248",$J)

 ; Flag to indicate end of global.

 S LA7END=0

 ; Sort by configuration (LA76248), patient (LRDFN), UID (LRUID), file #62.49 ien (LA76249)

 S LA7ROOT="^LAHM(62.49,""AC"",LA7MTYP,""P"")"

 F  S LA7ROOT=$Q(@LA7ROOT) Q:LA7END  D

 . I $QS(LA7ROOT,3)'=LA7MTYP!($QS(LA7ROOT,6)<1) S LA7END=1 Q

 . S LA76248=$QS(LA7ROOT,5),LA76249=$QS(LA7ROOT,6)

 . L +^LAHM(62.49,LA76249):5 Q:'$T

 . S LRDFN=$P($G(^LAHM(62.49,LA76249,63)),"^",8)

 . S LRUID=$P($G(^LAHM(62.49,LA76249,63)),"^",1)

 . I LRDFN,LRUID]"" S ^TMP("LA76248",$J,LA76248,LRDFN,LRUID,LA76249)=""

 . L -^LAHM(62.49,LA76249)

PROCESS ; Process and build messages to be sent

 N LA7101,LA76248,LA76249,LA76249P,LA7INTYP,LA7NTESN,LA7OBRSN,LA7OBXSN,LA7PIDSN,LA7SMSG,LA7VS,LRDFN

 ; Cleanup

 K ^TMP("LA7VS",$J),^TMP("HLS",$J)

 ; Initialize variables

 S (LA76248,LA76249,LA76249P,LA7END,LRDFN)=0,LRUID=""

 ; Process sorted list of results to transmit.

 S LA7ROOT="^TMP(""LA76248"",$J)"

 F  S LA7ROOT=$Q(@LA7ROOT) Q:LA7ROOT=""  D  Q:LA7END

 . I $QS(LA7ROOT,1)'="LA76248"!($QS(LA7ROOT,2)'=$J) S LA7END=1 Q

 . I LA76248'=$QS(LA7ROOT,3) D CONFIG

 . I '$P(LA76248(0),"^",3) Q

 . S LA7INTYP=+$P(LA76248(0),"^",9)

 . S (LA76249,LA(62.49))=$QS(LA7ROOT,6)

 . S LA7X=$G(^LAHM(62.49,LA76249,63))

 . S LA("HUID")=$P(LA7X,U),LA("SITE")=$P(LA7X,U,2),LA("RUID")=$P(LA7X,U,3),LA("ORD")=$P(LA7X,U,4),LA("NLT")=$P(LA7X,U,5),LA("LRIDT")=$P(LA7X,U,6),LA("SUB")=$P(LA7X,U,7),LA("LRDFN")=$P(LA7X,U,8),LA("ORDT")=$P(LA7X,U,9)

 . S LA7NVAF=$$NVAF^LA7VHLU2(+LA("SITE"))

 . I LRUID'=$QS(LA7ROOT,5),LA7SMSG=2 D PAT Q:LA7END

 . I LRDFN'=$QS(LA7ROOT,4) D PAT Q:LA7END

 . S LRUID=$QS(LA7ROOT,5)

 . S ^TMP("LA7VS",$J,LA76249)=LA76249P

 . N LA76249

 . S LA76249=LA76249P

 . I LA7MTYP="ORU" D EN^LA7VORU(.LA)

 . I LA7MTYP="ORR" D EN^LA7VORR1(.LA)

 I LA76249P D SENDMSG

STARTMSG ; Initialize a HL7 message and variables

 N LA7EVNT,SITE

 K ^TMP("LA7VS",$J),@GBL

 S LA76249P=LA76249

 S SITE=$$RETFACID^LA7VHLU2(LA("SITE"),2,1)

 I LA7MTYP="ORU" S LA7EVNT="LA7V Results Reporting to "_SITE

 I LA7MTYP="ORR" S LA7EVNT="LA7V Order Response to "_SITE

 D STARTMSG^LA7VHLU(LA7EVNT,LA76249P)

 I $G(HL) S LA7END=1

SENDMSG ; File HL7 message with HL and LAB packages

 ; No data to send

 I '$D(^TMP("HLS",$J)) Q

 D GEN^LA7VHLU

 I $P(LA7MID,U)=0 D

 . N LA7X

 . S LA7X(1)=LA76249P,LA7X(2)=$TR($P(HLMID,"^",2,3),"^","-")

 . D CREATE^LA7LOG(28)

 D UPDT6249

 D UPDLPD

 S (LA76249P,LA7PIDSN,LA7OBRSN,LA7OBXSN,LA7NTESN)=0

CONFIG ; Setup for this configuration

 ; Send a building message

 I LA76249P D SENDMSG

 ; Retrieve configuration information from #62.48

 S LA76248=$QS(LA7ROOT,3)

 S LA76248(0)=$G(^LAHM(62.48,LA76248,0))

 ; Flag to control message building; 1-one patient/msg, 2-one order/msg

 S LA7SMSG=+$P(LA76248(0),"^",8)

 ; Initialize variables

 S (LA76249,LA76249P,LRDFN)=0

 S LRUID=""

PAT ; Build patient information

 N LA7ALTID,LA7EXTID,LA7PID,LA7PV1

 ; If one patient/msg or one order/msg and message building then send it.

 I LA7SMSG>0,LA76249P D SENDMSG

 ; If no message building then start one.

 I 'LA76249P S LA7PIDSN=0 D STARTMSG Q:LA7END

 ; Setup PID and PV1 segments.

 S LRDFN=$QS(LA7ROOT,4)

 S LRDPF=$P(^LR(LRDFN,0),"^",2),DFN=$P(^(0),"^",3)

 D DEM^LRX

 ; Send placer's patient id (PID-3), return in PID-2, return PID-4 with alternate id

 S (LA7ALTID,LA7EXTID)=""

 D PTEXTID^LA7VHLU(LA("SITE"),LA("RUID"),.LA7EXTID)

 I $G(LA7EXTID("PID-2"))'="" S LA7EXTID=$$CNVFLD^LA7VHLU3(LA7EXTID("PID-2"),LA7EXTID("ECH"),LA7ECH)

 I $G(LA7EXTID("PID-4"))'="" S LA7ALTID=$$CNVFLD^LA7VHLU3(LA7EXTID("PID-4"),LA7EXTID("ECH"),LA7ECH)

 ; Build PID segment

 D PID^LA7VPID(LRDFN,LA7EXTID,.LA7PID,.LA7PIDSN,.HL,LA7ALTID)

 D FILESEG^LA7VHLU(GBL,.LA7PID)

 D FILE6249^LA7VHLU(LA76249P,.LA7PID)

 ; Build PV1 segment

 ; Not built when sending to DoD facility - not used by CHCS

 I LA7NVAF'=1 D

 . D PV1^LA7VPID(LRDFN,.LA7PV1,LA7FS,LA7ECH)

 . D FILESEG^LA7VHLU(GBL,.LA7PV1)

 . D FILE6249^LA7VHLU(LA76249P,.LA7PV1)

 S LRUID="",(LA7OBRSN,LA7OBXSN,LA7NTESN)=0

UPDT6249 ; Update entries in file #62.49

 N LA7ERR,LA76249,LA76249P

 S LA76249=0

 F  S LA76249=$O(^TMP("LA7VS",$J,LA76249)) Q:'LA76249  D

 . N FDA,LA7ERR

 . S LA76249P=+$G(^TMP("LA7VS",$J,LA76249))

 . ; Set pointer to parent on child entry.

 . I LA76249'=LA76249P S FDA(1,62.49,LA76249_",",6)=LA76249P

 . I $G(HL("APAT"))="AL"!($G(HL("APAT"))="") S FDA(1,62.49,LA76249_",",2)="A"

 . E  S FDA(1,62.49,LA76249_",",2)="X"

 . S FDA(1,62.49,LA76249_",",102)=HL("SAN")

 . S FDA(1,62.49,LA76249_",",103)=HL("SAF")

 . S FDA(1,62.49,LA76249_",",108)=HL("MTN")

 . S FDA(1,62.49,LA76249_",",110)=HL("PID")

 . S FDA(1,62.49,LA76249_",",111)=HL("VER")

 . I $P($G(LA7MID),"^")'="" S FDA(1,62.49,LA76249_",",109)=$P(LA7MID,"^")

 . I $P($G(LA7MID),"^",2) D

 . . S FDA(1,62.49,LA76249_",",160)=$P(LA7MID,"^",2)

 . . S FDA(1,62.49,LA76249_",",161)=$P(LA7MID,"^",3)

 . D FILE^DIE("","FDA(1)","LA7ERR(1)")

 . D CLEAN^DILF

UPDLPD ; Update lab pending orders (#69.6) for each entry in #62.49

 N LA76249

 S LA76249=0

 F  S LA76249=$O(^TMP("LA7VS",$J,LA76249)) Q:'LA76249  D UPD696

UPD696 ; Update LAB PENDING ORDERS file #69.6

 N LA74,LA7696,LA76964,LA7ERR,LA7ORDT,LA7STAT,LA7X

 ; Find "Results Available" status in #64.061

 S LA7STAT=$$FIND1^DIC(64.061,"","OMX","Results Available","","I $P(^LAB(64.061,Y,0),U,7)=""U""")

 S LA7X=$G(^LAHM(62.49,LA76249,63))

 ; Ordering institution - pointer to file #4

 S LA74=$P(LA7X,"^",2)

 I LA74="" Q

 ; Ordered test

 S LA7ORDT=$P(LA7X,"^",4)

 I LA7ORDT="" Q

 ; File #69.6 ien and ordered test multiple ien

 S LA7696=0

 F  S LA7696=$O(^LRO(69.6,"RST",LA74,LA("RUID"),LA7696)) Q:'LA7696  D

 . N FDA

 . S LA76964=$O(^LRO(69.6,LA7696,2,"B",LA7ORDT,0))

 . I LA76964<1 Q

. ;

 . L +^LRO(69.6,LA7696):99999

 . ; Cannot get lock on ENTRY in 69.6

 . I '$T D CREATE^LA7LOG(33) Q

. ;

 . ; Store outgoing HL7 message ID

 . S FDA(1,69.64,LA76964_","_LA7696_",",7)=$P(LA7MID,U)

 . ; Set to Results Available.

 . S FDA(1,69.64,LA76964_","_LA7696_",",5)=LA7STAT

 . D FILE^DIE("","FDA(1)","LA7ERR(1)")

 . D CLEAN^DILF

. ;

 . L -^LRO(69.6,LA7696)

LA7VMSG1  ;VA/DALOI/JMC - LAB ORU (Observation Result) message builder cont'd; 13-Aug-2013 09:09 ; MKK

 +1       ;;5.2;AUTOMATED LAB INSTRUMENTS;**46,56,61,1018,64,1027,68,1033**;NOV 01, 1997

 +2       ;

START     ; Process entries in queue

 +1       ; Called from LA7VMSG

 +2       ;

 +3        NEW LA,LAER,LA7VER

 +4        NEW EID,HLEID,HLMTIEN,HLRESLT,HLARYTYP,HLECH,HLFS,HLCOMP,HLFORMAT

 +5        NEW GBL,LA7MID,LA7V,LA7VS,LA7V0N,LA7VIEN,RSITE,LRNT

 +6        NEW LA76248,LA76249,LA76249P,LA7DT,LA7ECH,LA7END,LA7FS,LA7NVAF,LA7ROOT,LA7X,LRDFN,LRIDT,LRSS,LRUID

 +7       ;

 +8       ; variable list

 +9       ; LA("LRUID") - Host Unique ID from the local ACCESSION file (#68)

 +10      ; LA("SITE")  - Primary site number of remote site ($$SITE^VASITE)

 +11      ; LA("RUID")  - Remote sites Unique ID from ACCESSION file (#68)

 +12      ; LA("ORD")   - Free text ordered test name from WKLD CODE file (#64)

 +13      ; LA("LRNLT") - National Laboratory test code from WKLD CODE file (#64)

 +14      ; LA("LRIDT") - Inverse date/time (accession date/time)

 +15      ; LA("LRSS")  - test subscript defined in LABORATORY TEST file (#60)

 +16      ; LA("LRDFN") - IEN in LAB DATA file (#63)

 +17      ; LA("ORDT")  - Order date

 +18      ; LA(62.49)   - entry in #62.49 which contains pointer to results to build

 +19      ;

 +20       LOCK +^LAHM(62.49,"HL7 PROCESS",LA7MTYP):0

           IF '$TEST

               QUIT

 +21      ;

 +22       SET GBL="^TMP(""HLS"","_$JOB_")"

 +23      ;

 +24       DO SORTPAT

 +25       IF $DATA(^TMP("LA76248",$JOB))

               DO PROCESS

 +26       DO KVAR^LRX

 +27      ;

 +28      ; Release lock

 +29       LOCK -^LAHM(62.49,"HL7 PROCESS",LA7MTYP)

 +30      ;

 +31       KILL ^TMP("LA76248",$JOB),^TMP("LA7VS",$JOB),^TMP("HLS",$JOB)

 +32      ;

 +33       IF $DATA(ZTQUEUED)

               SET ZTREQ="@"

 +34      ;

 +35       QUIT

 +36      ;

 +37      ;

SORTPAT   ; Sort all results for tranmsission

 +1       ;

 +2        NEW LA76248,LA76249,LA7END,LA7ROOT,LRDFN,LRUID

 +3       ;

 +4        KILL ^TMP("LA76248",$JOB)

 +5       ; Flag to indicate end of global.

 +6        SET LA7END=0

 +7       ;

 +8       ; Sort by configuration (LA76248), patient (LRDFN), UID (LRUID), file #62.49 ien (LA76249)

 +9        SET LA7ROOT="^LAHM(62.49,""AC"",LA7MTYP,""P"")"

 +10       FOR

               SET LA7ROOT=$QUERY(@LA7ROOT)

               IF LA7END

                   QUIT

               Begin DoDot:1

 +11               IF $QSUBSCRIPT(LA7ROOT,3)'=LA7MTYP!($QSUBSCRIPT(LA7ROOT,6)<1)

                       SET LA7END=1

                       QUIT

 +12               SET LA76248=$QSUBSCRIPT(LA7ROOT,5)

                   SET LA76249=$QSUBSCRIPT(LA7ROOT,6)

 +13               LOCK +^LAHM(62.49,LA76249):5

                   IF '$TEST

                       QUIT

 +14               SET LRDFN=$PIECE($GET(^LAHM(62.49,LA76249,63)),"^",8)

 +15               SET LRUID=$PIECE($GET(^LAHM(62.49,LA76249,63)),"^",1)

 +16               IF LRDFN

                       IF LRUID]""

                           SET ^TMP("LA76248",$JOB,LA76248,LRDFN,LRUID,LA76249)=""

 +17               LOCK -^LAHM(62.49,LA76249)

               End DoDot:1

 +18      ;

 +19       QUIT

 +20      ;

 +21      ;

PROCESS   ; Process and build messages to be sent

 +1       ;

 +2        NEW LA7101,LA76248,LA76249,LA76249P,LA7INTYP,LA7NTESN,LA7OBRSN,LA7OBXSN,LA7PIDSN,LA7SMSG,LA7VS,LRDFN

 +3       ;

 +4       ; Cleanup

 +5        KILL ^TMP("LA7VS",$JOB),^TMP("HLS",$JOB)

 +6       ; Initialize variables

 +7        SET (LA76248,LA76249,LA76249P,LA7END,LRDFN)=0

           SET LRUID=""

 +8       ;

 +9       ; Process sorted list of results to transmit.

 +10       SET LA7ROOT="^TMP(""LA76248"",$J)"

 +11       FOR

               SET LA7ROOT=$QUERY(@LA7ROOT)

               IF LA7ROOT=""

                   QUIT

               Begin DoDot:1

 +12               IF $QSUBSCRIPT(LA7ROOT,1)'="LA76248"!($QSUBSCRIPT(LA7ROOT,2)'=$JOB)

                       SET LA7END=1

                       QUIT

 +13               IF LA76248'=$QSUBSCRIPT(LA7ROOT,3)

                       DO CONFIG

 +14               IF '$PIECE(LA76248(0),"^",3)

                       QUIT

 +15               SET LA7INTYP=+$PIECE(LA76248(0),"^",9)

 +16               SET (LA76249,LA(62.49))=$QSUBSCRIPT(LA7ROOT,6)

 +17               SET LA7X=$GET(^LAHM(62.49,LA76249,63))

 +18               SET LA("HUID")=$PIECE(LA7X,U)

                   SET LA("SITE")=$PIECE(LA7X,U,2)

                   SET LA("RUID")=$PIECE(LA7X,U,3)

                   SET LA("ORD")=$PIECE(LA7X,U,4)

                   SET LA("NLT")=$PIECE(LA7X,U,5)

                   SET LA("LRIDT")=$PIECE(LA7X,U,6)

                   SET LA("SUB")=$PIECE(LA7X,U,7)

                   SET LA("LRDFN")=$PIECE(LA7X,U,8)

                   SET LA("ORDT")=$PIECE(LA7X,U,9)

 +19               SET LA7NVAF=$$NVAF^LA7VHLU2(+LA("SITE"))

 +20               IF LRUID'=$QSUBSCRIPT(LA7ROOT,5)

                       IF LA7SMSG=2

                           DO PAT

                           IF LA7END

                               QUIT

 +21               IF LRDFN'=$QSUBSCRIPT(LA7ROOT,4)

                       DO PAT

                       IF LA7END

                           QUIT

 +22               SET LRUID=$QSUBSCRIPT(LA7ROOT,5)

 +23               SET ^TMP("LA7VS",$JOB,LA76249)=LA76249P

 +24               NEW LA76249

 +25               SET LA76249=LA76249P

 +26               IF LA7MTYP="ORU"

                       DO EN^LA7VORU(.LA)

 +27               IF LA7MTYP="ORR"

                       DO EN^LA7VORR1(.LA)

               End DoDot:1

               IF LA7END

                   QUIT

 +28      ;

 +29       IF LA76249P

               DO SENDMSG

 +30      ;

 +31       QUIT

 +32      ;

 +33      ;

STARTMSG  ; Initialize a HL7 message and variables

 +1       ;

 +2        NEW LA7EVNT,SITE

 +3       ;

 +4        KILL ^TMP("LA7VS",$JOB),@GBL

 +5       ;

 +6        SET LA76249P=LA76249

 +7        SET SITE=$$RETFACID^LA7VHLU2(LA("SITE"),2,1)

 +8       ;

 +9        IF LA7MTYP="ORU"

               SET LA7EVNT="LA7V Results Reporting to "_SITE

 +10       IF LA7MTYP="ORR"

               SET LA7EVNT="LA7V Order Response to "_SITE

 +11       DO STARTMSG^LA7VHLU(LA7EVNT,LA76249P)

 +12       IF $GET(HL)

               SET LA7END=1

 +13      ;

 +14       QUIT

 +15      ;

 +16      ;

SENDMSG   ; File HL7 message with HL and LAB packages

 +1       ;

 +2       ; No data to send

 +3        IF '$DATA(^TMP("HLS",$JOB))

               QUIT

 +4       ;

 +5        DO GEN^LA7VHLU

 +6        IF $PIECE(LA7MID,U)=0

               Begin DoDot:1

 +7                NEW LA7X

 +8                SET LA7X(1)=LA76249P

                   SET LA7X(2)=$TRANSLATE($PIECE(HLMID,"^",2,3),"^","-")

 +9                DO CREATE^LA7LOG(28)

               End DoDot:1

 +10      ;

 +11       DO UPDT6249

 +12       DO UPDLPD

 +13      ;

 +14       SET (LA76249P,LA7PIDSN,LA7OBRSN,LA7OBXSN,LA7NTESN)=0

 +15      ;

 +16       QUIT

 +17      ;

 +18      ;

CONFIG    ; Setup for this configuration

 +1       ;

 +2       ; Send a building message

 +3        IF LA76249P

               DO SENDMSG

 +4       ;

 +5       ; Retrieve configuration information from #62.48

 +6        SET LA76248=$QSUBSCRIPT(LA7ROOT,3)

 +7        SET LA76248(0)=$GET(^LAHM(62.48,LA76248,0))

 +8       ;

 +9       ; Flag to control message building; 1-one patient/msg, 2-one order/msg

 +10       SET LA7SMSG=+$PIECE(LA76248(0),"^",8)

 +11      ;

 +12      ; Initialize variables

 +13       SET (LA76249,LA76249P,LRDFN)=0

 +14       SET LRUID=""

 +15      ;

 +16       QUIT

 +17      ;

 +18      ;

PAT       ; Build patient information

 +1       ;

 +2        NEW LA7ALTID,LA7EXTID,LA7PID,LA7PV1

 +3       ;

 +4       ; If one patient/msg or one order/msg and message building then send it.

 +5        IF LA7SMSG>0

               IF LA76249P

                   DO SENDMSG

 +6       ;

 +7       ; If no message building then start one.

 +8        IF 'LA76249P

               SET LA7PIDSN=0

               DO STARTMSG

               IF LA7END

                   QUIT

 +9       ;

 +10      ; Setup PID and PV1 segments.

 +11       SET LRDFN=$QSUBSCRIPT(LA7ROOT,4)

 +12       SET LRDPF=$PIECE(^LR(LRDFN,0),"^",2)

           SET DFN=$PIECE(^(0),"^",3)

 +13       DO DEM^LRX

 +14      ;

 +15      ; Send placer's patient id (PID-3), return in PID-2, return PID-4 with alternate id

 +16       SET (LA7ALTID,LA7EXTID)=""

 +17       DO PTEXTID^LA7VHLU(LA("SITE"),LA("RUID"),.LA7EXTID)

 +18       IF $GET(LA7EXTID("PID-2"))'=""

               SET LA7EXTID=$$CNVFLD^LA7VHLU3(LA7EXTID("PID-2"),LA7EXTID("ECH"),LA7ECH)

 +19       IF $GET(LA7EXTID("PID-4"))'=""

               SET LA7ALTID=$$CNVFLD^LA7VHLU3(LA7EXTID("PID-4"),LA7EXTID("ECH"),LA7ECH)

 +20      ;

 +21      ; Build PID segment

 +22       DO PID^LA7VPID(LRDFN,LA7EXTID,.LA7PID,.LA7PIDSN,.HL,LA7ALTID)

 +23       DO FILESEG^LA7VHLU(GBL,.LA7PID)

 +24       DO FILE6249^LA7VHLU(LA76249P,.LA7PID)

 +25      ;

 +26      ; Build PV1 segment

 +27      ; Not built when sending to DoD facility - not used by CHCS

 +28       IF LA7NVAF'=1

               Begin DoDot:1

 +29               DO PV1^LA7VPID(LRDFN,.LA7PV1,LA7FS,LA7ECH)

 +30               DO FILESEG^LA7VHLU(GBL,.LA7PV1)

 +31               DO FILE6249^LA7VHLU(LA76249P,.LA7PV1)

               End DoDot:1

 +32      ;

 +33       SET LRUID=""

           SET (LA7OBRSN,LA7OBXSN,LA7NTESN)=0

 +34      ;

 +35       QUIT

 +36      ;

 +37      ;

UPDT6249  ; Update entries in file #62.49

 +1       ;

 +2        NEW LA7ERR,LA76249,LA76249P

 +3       ;

 +4        SET LA76249=0

 +5        FOR

               SET LA76249=$ORDER(^TMP("LA7VS",$JOB,LA76249))

               IF 'LA76249

                   QUIT

               Begin DoDot:1

 +6                NEW FDA,LA7ERR

 +7                SET LA76249P=+$GET(^TMP("LA7VS",$JOB,LA76249))

 +8       ; Set pointer to parent on child entry.

 +9                IF LA76249'=LA76249P

                       SET FDA(1,62.49,LA76249_",",6)=LA76249P

 +10               IF $GET(HL("APAT"))="AL"!($GET(HL("APAT"))="")

                       SET FDA(1,62.49,LA76249_",",2)="A"

 +11              IF '$TEST

                       SET FDA(1,62.49,LA76249_",",2)="X"

 +12               SET FDA(1,62.49,LA76249_",",102)=HL("SAN")

 +13               SET FDA(1,62.49,LA76249_",",103)=HL("SAF")

 +14               SET FDA(1,62.49,LA76249_",",108)=HL("MTN")

 +15               SET FDA(1,62.49,LA76249_",",110)=HL("PID")

 +16               SET FDA(1,62.49,LA76249_",",111)=HL("VER")

 +17               IF $PIECE($GET(LA7MID),"^")'=""

                       SET FDA(1,62.49,LA76249_",",109)=$PIECE(LA7MID,"^")

 +18               IF $PIECE($GET(LA7MID),"^",2)

                       Begin DoDot:2

 +19                       SET FDA(1,62.49,LA76249_",",160)=$PIECE(LA7MID,"^",2)

 +20                       SET FDA(1,62.49,LA76249_",",161)=$PIECE(LA7MID,"^",3)

                       End DoDot:2

 +21               DO FILE^DIE("","FDA(1)","LA7ERR(1)")

 +22               DO CLEAN^DILF

               End DoDot:1

 +23      ;

 +24       QUIT

 +25      ;

 +26      ;

UPDLPD    ; Update lab pending orders (#69.6) for each entry in #62.49

 +1       ;

 +2        NEW LA76249

 +3       ;

 +4        SET LA76249=0

 +5        FOR

               SET LA76249=$ORDER(^TMP("LA7VS",$JOB,LA76249))

               IF 'LA76249

                   QUIT

               DO UPD696

 +6        QUIT

 +7       ;

 +8       ;

UPD696    ; Update LAB PENDING ORDERS file #69.6

 +1       ;

 +2        NEW LA74,LA7696,LA76964,LA7ERR,LA7ORDT,LA7STAT,LA7X

 +3       ;

 +4       ; Find "Results Available" status in #64.061

 +5        SET LA7STAT=$$FIND1^DIC(64.061,"","OMX","Results Available","","I $P(^LAB(64.061,Y,0),U,7)=""U""")

 +6       ;

 +7        SET LA7X=$GET(^LAHM(62.49,LA76249,63))

 +8       ;

 +9       ; Ordering institution - pointer to file #4

 +10       SET LA74=$PIECE(LA7X,"^",2)

 +11       IF LA74=""

               QUIT

 +12      ;

 +13      ; Ordered test

 +14       SET LA7ORDT=$PIECE(LA7X,"^",4)

 +15       IF LA7ORDT=""

               QUIT

 +16      ;

 +17      ; File #69.6 ien and ordered test multiple ien

 +18       SET LA7696=0

 +19       FOR

               SET LA7696=$ORDER(^LRO(69.6,"RST",LA74,LA("RUID"),LA7696))

               IF 'LA7696

                   QUIT

               Begin DoDot:1

 +20               NEW FDA

 +21               SET LA76964=$ORDER(^LRO(69.6,LA7696,2,"B",LA7ORDT,0))

 +22               IF LA76964<1

                       QUIT

 +23      ;

 +24               LOCK +^LRO(69.6,LA7696):99999

 +25      ; Cannot get lock on ENTRY in 69.6

 +26               IF '$TEST

                       DO CREATE^LA7LOG(33)

                       QUIT

 +27      ;

 +28      ; Store outgoing HL7 message ID

 +29               SET FDA(1,69.64,LA76964_","_LA7696_",",7)=$PIECE(LA7MID,U)

 +30      ; Set to Results Available.

 +31               SET FDA(1,69.64,LA76964_","_LA7696_",",5)=LA7STAT

 +32               DO FILE^DIE("","FDA(1)","LA7ERR(1)")

 +33               DO CLEAN^DILF

 +34      ;

 +35               LOCK -^LRO(69.6,LA7696)

               End DoDot:1

 +36      ;

 +37       QUIT

LA7VMSG1.m