- LA7VMSG1 ;DALOI/JMC - LAB ORU (Observation Result) message builder cont'd ;Aug 8, 2008
- ;;5.2;AUTOMATED LAB INSTRUMENTS;**56,46,61,64,68,74**;Sep 27, 1994;Build 229
- ;
- START ; Process entries in queue
- ; Called from LA7VMSG
- ;
- N EID,GBL,HLEID,HLMTIEN,HLRESLT,HLARYTYP,HLECH,HLFS,HLCOMP,HLFORMAT,RSITE
- N LA,LA76248,LA76249,LA76249P,LA7DT,LA7ECH,LA7END,LA7FS,LA7ID,LA7MID,LA7NVAF,LA7ROOT,LA7V,LA7VS,LA7VER,LA7V0N,LA7VIEN,LA7X
- N LAER,LRDFN,LRIDT,LRNT,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
- ;
- D LOCK^DILF("^LAHM(62.49,""HL7 PROCESS"",LA7MTYP)")
- I '$T Q
- ;
- 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="@"
- ;
- Q
- ;
- ;
- SORTPAT ; Sort all results for transmission
- ;
- 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)
- ; Check status of each message to insure that cross-reference is not an orphan which can cause
- ; repetitive message generation and receving problems.
- 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)
- . D LOCK^DILF("^LAHM(62.49,LA76249)") Q:'$T
- . I $P($G(^LAHM(62.49,LA76249,0)),"^",3)'="P" K ^LAHM(62.49,"AC",LA7MTYP,"P",LA76248,LA76249) L -^LAHM(62.49,LA76249) Q
- . 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)
- ;
- Q
- ;
- ;
- 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
- ;
- Q
- ;
- ;
- 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
- ;
- Q
- ;
- ;
- 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
- ;
- Q
- ;
- ;
- 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="",LA7ID=$P(LA76248(0),"^")_"-O-"
- ;
- Q
- ;
- ;
- 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
- I $G(PNM)'="" D
- . D SETID^LA7VHLU1(LA76249,LA7ID,PNM,0)
- . D SETID^LA7VHLU1(LA76249,"",PNM,0)
- I $G(SSN)'="" D
- . D SETID^LA7VHLU1(LA76249,LA7ID,SSN,0)
- . D SETID^LA7VHLU1(LA76249,"",SSN,0)
- ;
- ; 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
- ;
- Q
- ;
- ;
- UPDT6249 ; Update entries in file #62.49
- ;
- N LA7ERR,LA76249,LA76249P
- ;
- ; UNDEF HL array will cause HL7 filers to stop. The $G(HL(x)) prevents the filers from halting on UNDEF error but we
- ; want to log the missing HL array as an error for system monitoring/troubleshooting.
- I $D(HL)<10 D ^%ZTER
- ;
- 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 $P(^LAHM(62.49,LA76249,0),"^",3)'="E" D
- . . 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)=$G(HL("SAN"))
- . S FDA(1,62.49,LA76249_",",103)=$G(HL("SAF"))
- . S FDA(1,62.49,LA76249_",",108)=$G(HL("MTN"))
- . S FDA(1,62.49,LA76249_",",110)=$G(HL("PID"))
- . S FDA(1,62.49,LA76249_",",111)=$G(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
- . D UPID^LA7VHLU1(LA76249)
- ;
- Q
- ;
- ;
- 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
- Q
- ;
- ;
- 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
- . ;
- . D LOCK^DILF("^LRO(69.6,LA7696)")
- . ; 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)
- ;
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLA7VMSG1 8843 printed Feb 18, 2025@23:07:09 Page 2
- LA7VMSG1 ;DALOI/JMC - LAB ORU (Observation Result) message builder cont'd ;Aug 8, 2008
- +1 ;;5.2;AUTOMATED LAB INSTRUMENTS;**56,46,61,64,68,74**;Sep 27, 1994;Build 229
- +2 ;
- START ; Process entries in queue
- +1 ; Called from LA7VMSG
- +2 ;
- +3 NEW EID,GBL,HLEID,HLMTIEN,HLRESLT,HLARYTYP,HLECH,HLFS,HLCOMP,HLFORMAT,RSITE
- +4 NEW LA,LA76248,LA76249,LA76249P,LA7DT,LA7ECH,LA7END,LA7FS,LA7ID,LA7MID,LA7NVAF,LA7ROOT,LA7V,LA7VS,LA7VER,LA7V0N,LA7VIEN,LA7X
- +5 NEW LAER,LRDFN,LRIDT,LRNT,LRSS,LRUID
- +6 ;
- +7 ; variable list
- +8 ; LA("LRUID") - Host Unique ID from the local ACCESSION file (#68)
- +9 ; LA("SITE") - Primary site number of remote site ($$SITE^VASITE)
- +10 ; LA("RUID") - Remote sites Unique ID from ACCESSION file (#68)
- +11 ; LA("ORD") - Free text ordered test name from WKLD CODE file (#64)
- +12 ; LA("LRNLT") - National Laboratory test code from WKLD CODE file (#64)
- +13 ; LA("LRIDT") - Inverse date/time (accession date/time)
- +14 ; LA("LRSS") - test subscript defined in LABORATORY TEST file (#60)
- +15 ; LA("LRDFN") - IEN in LAB DATA file (#63)
- +16 ; LA("ORDT") - Order date
- +17 ; LA(62.49) - entry in #62.49 which contains pointer to results to build
- +18 ;
- +19 DO LOCK^DILF("^LAHM(62.49,""HL7 PROCESS"",LA7MTYP)")
- +20 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 transmission
- +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 ; Check status of each message to insure that cross-reference is not an orphan which can cause
- +10 ; repetitive message generation and receving problems.
- +11 SET LA7ROOT="^LAHM(62.49,""AC"",LA7MTYP,""P"")"
- +12 FOR
- SET LA7ROOT=$QUERY(@LA7ROOT)
- if LA7END
- QUIT
- Begin DoDot:1
- +13 IF $QSUBSCRIPT(LA7ROOT,3)'=LA7MTYP!($QSUBSCRIPT(LA7ROOT,6)<1)
- SET LA7END=1
- QUIT
- +14 SET LA76248=$QSUBSCRIPT(LA7ROOT,5)
- SET LA76249=$QSUBSCRIPT(LA7ROOT,6)
- +15 DO LOCK^DILF("^LAHM(62.49,LA76249)")
- if '$TEST
- QUIT
- +16 IF $PIECE($GET(^LAHM(62.49,LA76249,0)),"^",3)'="P"
- KILL ^LAHM(62.49,"AC",LA7MTYP,"P",LA76248,LA76249)
- LOCK -^LAHM(62.49,LA76249)
- QUIT
- +17 SET LRDFN=$PIECE($GET(^LAHM(62.49,LA76249,63)),"^",8)
- +18 SET LRUID=$PIECE($GET(^LAHM(62.49,LA76249,63)),"^",1)
- +19 IF LRDFN
- IF LRUID'=""
- SET ^TMP("LA76248",$JOB,LA76248,LRDFN,LRUID,LA76249)=""
- +20 LOCK -^LAHM(62.49,LA76249)
- End DoDot:1
- +21 ;
- +22 QUIT
- +23 ;
- +24 ;
- 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=""
- SET LA7ID=$PIECE(LA76248(0),"^")_"-O-"
- +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 IF $GET(PNM)'=""
- Begin DoDot:1
- +15 DO SETID^LA7VHLU1(LA76249,LA7ID,PNM,0)
- +16 DO SETID^LA7VHLU1(LA76249,"",PNM,0)
- End DoDot:1
- +17 IF $GET(SSN)'=""
- Begin DoDot:1
- +18 DO SETID^LA7VHLU1(LA76249,LA7ID,SSN,0)
- +19 DO SETID^LA7VHLU1(LA76249,"",SSN,0)
- End DoDot:1
- +20 ;
- +21 ; Send placer's patient id (PID-3), return in PID-2, return PID-4 with alternate id
- +22 SET (LA7ALTID,LA7EXTID)=""
- +23 DO PTEXTID^LA7VHLU(LA("SITE"),LA("RUID"),.LA7EXTID)
- +24 IF $GET(LA7EXTID("PID-2"))'=""
- SET LA7EXTID=$$CNVFLD^LA7VHLU3(LA7EXTID("PID-2"),LA7EXTID("ECH"),LA7ECH)
- +25 IF $GET(LA7EXTID("PID-4"))'=""
- SET LA7ALTID=$$CNVFLD^LA7VHLU3(LA7EXTID("PID-4"),LA7EXTID("ECH"),LA7ECH)
- +26 ;
- +27 ; Build PID segment
- +28 DO PID^LA7VPID(LRDFN,LA7EXTID,.LA7PID,.LA7PIDSN,.HL,LA7ALTID)
- +29 DO FILESEG^LA7VHLU(GBL,.LA7PID)
- +30 DO FILE6249^LA7VHLU(LA76249P,.LA7PID)
- +31 ;
- +32 ; Build PV1 segment
- +33 ; Not built when sending to DoD facility - not used by CHCS
- +34 IF LA7NVAF'=1
- Begin DoDot:1
- +35 DO PV1^LA7VPID(LRDFN,.LA7PV1,LA7FS,LA7ECH)
- +36 DO FILESEG^LA7VHLU(GBL,.LA7PV1)
- +37 DO FILE6249^LA7VHLU(LA76249P,.LA7PV1)
- End DoDot:1
- +38 ;
- +39 SET LRUID=""
- SET (LA7OBRSN,LA7OBXSN,LA7NTESN)=0
- +40 ;
- +41 QUIT
- +42 ;
- +43 ;
- UPDT6249 ; Update entries in file #62.49
- +1 ;
- +2 NEW LA7ERR,LA76249,LA76249P
- +3 ;
- +4 ; UNDEF HL array will cause HL7 filers to stop. The $G(HL(x)) prevents the filers from halting on UNDEF error but we
- +5 ; want to log the missing HL array as an error for system monitoring/troubleshooting.
- +6 IF $DATA(HL)<10
- DO ^%ZTER
- +7 ;
- +8 SET LA76249=0
- +9 FOR
- SET LA76249=$ORDER(^TMP("LA7VS",$JOB,LA76249))
- if 'LA76249
- QUIT
- Begin DoDot:1
- +10 NEW FDA,LA7ERR
- +11 SET LA76249P=+$GET(^TMP("LA7VS",$JOB,LA76249))
- +12 ; Set pointer to parent on child entry.
- +13 IF LA76249'=LA76249P
- SET FDA(1,62.49,LA76249_",",6)=LA76249P
- +14 IF $PIECE(^LAHM(62.49,LA76249,0),"^",3)'="E"
- Begin DoDot:2
- +15 IF $GET(HL("APAT"))="AL"!($GET(HL("APAT"))="")
- SET FDA(1,62.49,LA76249_",",2)="A"
- +16 IF '$TEST
- SET FDA(1,62.49,LA76249_",",2)="X"
- End DoDot:2
- +17 SET FDA(1,62.49,LA76249_",",102)=$GET(HL("SAN"))
- +18 SET FDA(1,62.49,LA76249_",",103)=$GET(HL("SAF"))
- +19 SET FDA(1,62.49,LA76249_",",108)=$GET(HL("MTN"))
- +20 SET FDA(1,62.49,LA76249_",",110)=$GET(HL("PID"))
- +21 SET FDA(1,62.49,LA76249_",",111)=$GET(HL("VER"))
- +22 IF $PIECE($GET(LA7MID),"^")'=""
- SET FDA(1,62.49,LA76249_",",109)=$PIECE(LA7MID,"^")
- +23 IF $PIECE($GET(LA7MID),"^",2)
- Begin DoDot:2
- +24 SET FDA(1,62.49,LA76249_",",160)=$PIECE(LA7MID,"^",2)
- +25 SET FDA(1,62.49,LA76249_",",161)=$PIECE(LA7MID,"^",3)
- End DoDot:2
- +26 DO FILE^DIE("","FDA(1)","LA7ERR(1)")
- +27 DO CLEAN^DILF
- +28 DO UPID^LA7VHLU1(LA76249)
- End DoDot:1
- +29 ;
- +30 QUIT
- +31 ;
- +32 ;
- 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 DO LOCK^DILF("^LRO(69.6,LA7696)")
- +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
