- LA7UIO1 ;DALOI/JMC - Process Download Message for an entry in 62.48 ;12/11/15 16:39
- ;;5.2;AUTOMATED LAB INSTRUMENTS;**66,74,88**;Sep 27, 1994;Build 10
- ;
- ; Reference to PROTOCOL file (#101) supported by ICR #872
- ;
- Q
- ;
- BUILD ; Build one accession into an HL7 message
- ;
- N GBL,HL,I,LA760,LA761,LA7CDT,LA7CMT,LA7CS,LA7ERR,LA7FAC,LA7FS,LA7ECH,LA7HLP,LA7I,LA7ID,LA7LINK,LA7NVAF,LA7OBRSN,LA7PIDSN,LA7SCMT,LA7SID,LA7SPEC,LA7SUB,LA7X,LA7Y
- S GBL="^TMP(""HLS"","_$J_")"
- ;
- I '$D(ZTQUEUED),$G(LRLL) W:$X+5>IOM !,$S($G(LRTYPE):"Cup",1:"Seq"),": " W LA76822,", "
- ;
- S LA7CNT=0
- F I=0,.1,.2,.3,3 S LA76802(I)=$G(^LRO(68,LA768,1,LA76801,1,LA76802,I))
- S LA7X=LA76802(3)
- ; Draw time
- S LA7CDT=+LA7X
- ;
- ; Specimen comment if any, strip "~"
- S LA7SCMT=$TR($P(LA7X,"^",6),"~")
- ;
- ; Specimen
- S LA761=+$G(^LRO(68,LA768,1,LA76801,1,LA76802,5,1,0))
- ; Accession/unique ID - Long (UID) or short (accession #) sample ID
- S LA7ACC=$P(LA76802(.2),"^"),LA7UID=$P(LA76802(.3),"^"),LA7X=$G(^LRO(68,LA768,.4))
- I $P(LA7X,"^",2)="S" S LA7SID=$$RJ^XLFSTR(LA76802,+$P(LA7X,"^",3),"0")
- E S LA7SID=LA7UID
- ;
- ; Start message
- D INIT Q:$G(HL)
- ;
- ; Setup links and subscriber array for HL7 message generation
- S LA76248(0)=$G(^LAHM(62.48,LA76248,0)),LA7Y=$P(LA76248(0),"^")
- I $E(LA7Y,1,5)'="LA7UI"!($P(LA76248(0),"^",9)'=1) Q
- ;
- ; Check if interface has been updagraded to HL7 v2.5.1 otherwise use v2.2 protocol
- S LA7SUB="LA7UI ORM-O01 SUBS"
- S X=$O(^ORD(101,"B",LA7SUB,0))
- I X<1 S LA7SUB="LA7UI ORM-O01 SUBS 2.2"
- ;
- S LA7LINK=LA7SUB_"^"_LA7Y
- S LA7FAC=$P($$SITE^VASITE(DT),"^",3)
- S LA7HLP("SUBSCRIBER")="^^"_LA7FAC_"^"_LA7Y_"^"
- ; Following line used when debugging
- ;S $P(LA7HLP("SUBSCRIBER"),"^",8)="1-1-2"
- ;
- ; Build segments PID, PV1, and ORC/OBR segment for each test to be sent
- D PID,PV1
- S (LA7I,LA7OBRSN)=0
- F S LA7I=$O(LA7ACC(LA7I)) Q:'LA7I D ORC,OBR
- ; Build entry in MESSAGE QUEUE file 62.49
- D SENDMSG
- L -^LAHM(62.49,LA76249)
- D KVAR^LRX
- Q
- ;
- ;
- INIT ; Create/initialize HL message
- ;
- N LA7EVENT,X
- ;
- K @GBL
- S (LA76249,LA7NVAF,LA7PIDSN)=0
- ;
- ; Check if interface has been updagraded to HL7 v2.5.1 otherwise use v2.2 protocol
- S LA7EVENT="LA7UI ORM-O01 EVENT"
- S X=$O(^ORD(101,"B",LA7EVENT,0))
- I X<1 S LA7EVENT="LA7UI ORM-O01 EVENT 2.2"
- D STARTMSG^LA7VHLU(LA7EVENT,.LA76249)
- ;
- S LA7ID=$P(LRAUTO,"^",1)_"-O-"_LA7UID
- ;
- K ^TMP("LA7-ID",$J)
- D SETID^LA7VHLU1(LA76249,"",LA7ID,1)
- D SETID^LA7VHLU1(LA76249,"",LA7UID,0)
- D SETID^LA7VHLU1(LA76249,"",LA7ACC,0)
- S LA7CS=$E(LA7ECH,1)
- I $G(HL) S LA7ERR=28 D UPDT6249^LA7VORM1
- Q
- ;
- ;
- PID ; Build PID segment
- N LA7DATA,LA7FLAG,NAME,PID
- S LRDFN=+LA7ACC0,LRDPF=$P(^LR(LRDFN,0),"^",2),DFN=$P(^(0),"^",3)
- D DEM^LRX
- ;
- S PID(0)="PID"
- S PID(1)=1
- S PID(3)=$$M11^HLFNC(LRDFN)
- ;
- ; Pass patient and referral files through name standardization.
- ; Don't pass lab control and other file's "paient" names thru name standardization as it affects name order.
- I LRDPF?1(1"2",1"67",1"200") S NAME("FILE")=LRDPF,NAME("FIELD")=.01,NAME("IENS")=DFN,LA7FLAG="S"
- E S NAME("FAMILY")=$P(PNM,","),NAME("GIVEN")=$P(PNM,",",2),LA7FLAG=""
- S PID(5)=$$HLNAME^XLFNAME(.NAME,LA7FLAG,LA7CS)
- ;
- ; Date of birth
- I DOB S PID(7)=$$FMTHL7^XLFDT(DOB)
- S PID(8)=$S(SEX'="":SEX,1:"U")
- ;
- ; Race
- D RACE
- ;
- ; Patient's SSN
- I SSN'="" S PID(19)=SSN
- ;
- D BUILDSEG^LA7VHLU(.PID,.LA7DATA,LA7FS)
- D FILESEG^LA7VHLU(GBL,.LA7DATA)
- D FILE6249^LA7VHLU(LA76249,.LA7DATA)
- D SETID^LA7VHLU1(LA76249,"",PNM,0)
- Q
- ;
- ;
- PV1 ; Build PV1 segment
- N LA7PV1,LA7X
- D PV1^LA7VPID(LRDFN,.LA7PV1,LA7FS,LA7ECH)
- ; If not inpatient use patient location from Accession
- I $P(LA7PV1(0),LA7FS,3)'="I" S LA7X=$P($G(LA76802(0)),"^",7) S LA7X=$$CHKDATA^LA7VHLU3(LA7X,LA7FS_LA7ECH) S $P(LA7PV1(0),LA7FS,4)=LA7X
- ;
- D FILESEG^LA7VHLU(GBL,.LA7PV1)
- D FILE6249^LA7VHLU(LA76249,.LA7PV1)
- Q
- ;
- ;
- ORC ; Build ORC segment
- N LA7DATA,ORC
- S ORC(0)="ORC"
- S ORC(1)="NW"
- ;
- ; Placer/filler order number - sample ID
- S ORC(2)=$$ORC2^LA7VORC(LA7SID,LA7FS,LA7ECH)
- S ORC(3)=$$ORC3^LA7VORC(LA7SID,LA7FS,LA7ECH)
- ;
- ; Order/draw time - if no order date/time then try draw time
- I $P(LA76802(0),"^",4) S ORC(9)=$$ORC9^LA7VORC($P(LA76802(0),"^",4))
- I '$P(LA76802(0),"^",4),$P(LA76802(3),"^") S ORC(9)=$$ORC9^LA7VORC($P(LA76802(3),"^"))
- ;
- ; Provider
- S LA7X=$$FNDOLOC^LA7VHLU2(LA7UID)
- S ORC(12)=$$ORC12^LA7VORC($P(LA76802(0),"^",8),$P(LA7X,"^",3),LA7FS,LA7ECH,2)
- ; Provider Callback Number ;**88
- S ORC(14)=$$ORC14^LA7VORC($P(LA76802(0),"^",8),DT,LA7FS,LA7ECH)
- D BUILDSEG^LA7VHLU(.ORC,.LA7DATA,LA7FS)
- D FILESEG^LA7VHLU(GBL,.LA7DATA)
- D FILE6249^LA7VHLU(LA76249,.LA7DATA)
- Q
- ;
- ;
- OBR ; Build OBR segment
- N LA764,LA7ALT,LA7CADR,LA7NLT,LA7TCMT
- K OBR
- ;
- S LA760=+LA7ACC(LA7I)
- S LA764=+$P($G(^LAB(60,LA760,64)),"^")
- S LA7NLT=$P($G(^LAM(LA764,0)),"^",2)
- S LA7TMP=$G(^TMP("LA7",$J,LA7INST,LA7I))
- Q:'LA7TMP
- ;
- S LA7CODE=$P(LA7TMP,"^",6),LA7DATA=$P(LA7TMP,"^",7)
- S OBR(0)="OBR"
- S OBR(1)=$$OBR1^LA7VOBR(.LA7OBRSN)
- ; Placer/filler order number - sample ID
- S OBR(2)=$$OBR2^LA7VOBR(LA7SID,LA7FS,LA7ECH)
- S OBR(3)=$$OBR3^LA7VOBR(LA7SID,LA7FS,LA7ECH)
- ; Test order code
- S LA7ALT=LA7CODE_"^"_$$GET1^DIQ(60,LA760_",",.01)_"^"_"99001"
- S OBR(4)=$$OBR4^LA7VOBR(LA7NLT,LA760,LA7ALT,LA7FS,LA7ECH)
- ; Draw time.
- I $G(LA7CDT) S OBR(7)=$$OBR7^LA7VOBR(LA7CDT)
- ; Infection warning.
- S OBR(12)=$$OBR12^LA7VOBR(LRDFN,LA7FS,LA7ECH)
- ;
- ; Specimen comment
- ; If no specimen comment
- ; then check order for test comments on test
- ; or parent test if panel exploded
- I LA7SCMT'="" S OBR(13)=$$OBR13^LA7VOBR(LA7SCMT,LA7FS,LA7ECH)
- I LA7SCMT="" D
- . S LA7TCMT=$$TESTCMT(LA768,LA76801,LA76802,LA760)
- . I LA7TCMT="" D
- . . N LA760P
- . . S LA760P=$P(LA7ACC(LA7I),"^",3)
- . . I LA760P>0,LA760'=LA760P S LA7TCMT=$$TESTCMT(LA768,LA76801,LA76802,LA760P)
- . I LA7TCMT'="" S OBR(13)=$$OBR13^LA7VOBR(LA7TCMT,LA7FS,LA7ECH)
- ;
- ; Lab Arrival Time
- S OBR(14)=$$OBR14^LA7VOBR($P(LA76802(3),"^",3))
- ; HL7 code from Topography
- S LA7X=$S(LRDPF=62.3:"^^^CONTROL",1:"")
- S OBR(15)=$$OBR15^LA7VOBR(LA761,"",LA7X,LA7FS,LA7ECH)
- ; Ordering provider
- S LA7X=$$FNDOLOC^LA7VHLU2(LA7UID)
- S OBR(16)=$$ORC12^LA7VORC($P(LA76802(0),"^",8),$P(LA7X,"^",3),LA7FS,LA7ECH,2)
- ; Provider Callback Number ;**88
- S OBR(17)=$$ORC14^LA7VORC($P(LA76802(0),"^",8),DT,LA7FS,LA7ECH)
- ; Placer's field #1 - instrument name^card address
- K LA7X
- S LA7X(1)=$P(LRAUTO,"^")
- S LA7CADR=$P($G(^LAB(62.4,LRINST,9)),U,9)
- I LA7CADR'="" S LA7X(2)=LA7CADR
- S OBR(18)=$$OBR18^LA7VOBR(.LA7X,LA7FS,LA7ECH)
- ; Placer's field #2 - tray^cup^lraa^lrad^lran^lracc^lruid
- K LA7X
- ; No tray/cup if don't send tray/cup flag.
- I $G(LRFORCE) S:LA76821 LA7X(1)=LA76821 S:LA76822 LA7X(2)=LA76822
- S LA7X(3)=LA768,LA7X(4)=LA76801,LA7X(5)=LA76802,LA7X(6)=LA7ACC,LA7X(7)=LA7UID
- S OBR(19)=$$OBR19^LA7VOBR(.LA7X,LA7FS,LA7ECH)
- ;
- ; Test urgency
- S OBR(27)=$$OBR27^LA7VOBR("","",+$P(LA7ACC(LA7I),"^",2),LA7FS,LA7ECH)
- ;
- K LA7DATA
- D BUILDSEG^LA7VHLU(.OBR,.LA7DATA,LA7FS)
- D FILESEG^LA7VHLU(GBL,.LA7DATA)
- D FILE6249^LA7VHLU(LA76249,.LA7DATA)
- Q
- ;
- ;
- SENDMSG ; Send the HL7 message.
- N HLL,HLP
- S HLL("LINKS",1)=LA7LINK
- I $D(LA7HLP) M HLP=LA7HLP
- D GEN^LA7VHLU,UPDT6249^LA7VORM1
- Q
- ;
- ;
- TESTCMT(LA768,LA76801,LA76802,LA760) ; Check and build order test comments
- ;
- ; Call with LA768 = IEN of accesseion area
- ; LA76801 = FM accession date
- ; LA76802 = accession number
- ; LA760 = IEN of file #60 test
- ;
- ; Returns LA7CMT = comments in a single string (truncated to 300 characters per HL7 standard)
- ;
- N LA7CMT,LA7I,LA7QUIT,LA7X,LA7Y,LRIEN,LRODT,LRSN
- ;
- S LA7CMT="",LRIEN=0
- S LA7Y=$G(^LRO(68,LA768,1,LA76801,1,LA76802,0))
- S LRODT=+$P(LA7Y,"^",4),LRSN=+$P(LA7Y,"^",5)
- I LRODT>0,LRSN>0 S LRIEN=$O(^LRO(69,LRODT,1,LRSN,2,"B",LA760,0))
- ;
- I LRIEN D
- . S (LA7I,LA7QUIT)=0,LA7X=""
- . F S LA7I=$O(^LRO(69,LRODT,1,LRSN,2,LRIEN,1,LA7I)) Q:LA7I<1 D Q:LA7QUIT
- . . S LA7X=$G(^LRO(69,LRODT,1,LRSN,2,LRIEN,1,LA7I,0))
- . . I $E(LA7X,1,10)="~For Test:" Q
- . . I LA7X'="" S LA7X=$TR(LA7X,"~","")
- . . I LA7CMT'="" S LA7X=" "_LA7X
- . . S LA7CMT=LA7CMT_LA7X
- . . I $L(LA7CMT)>300 S LA7CMT=$E(LA7CMT,1,300),LA7QUIT=1
- ;
- Q LA7CMT
- ;
- ;
- RACE ; Build RACE field in PID segment
- ;
- N CNT,IEN,LA7X,LA7Y,RACE,RACENUM,X,Y
- ;
- S PID(10)=""
- ;
- ; if from PATIENT file (#2) then check RACE array (VADM(12).
- I LRDPF=2,$G(VADM(12)) D Q
- . ; Loop through all races (CNT is repetition location)
- . S RACENUM=0
- . F CNT=1:1 S RACENUM=+$O(VADM(12,RACENUM)) Q:'RACENUM D
- . . ; Fabricate race value -> RACE-METHOD
- . . S RACE=$$PTR2CODE^DGUTL4(+VADM(12,RACENUM),1,2)
- . . S X=$$PTR2CODE^DGUTL4(+$G(VADM(12,RACENUM,1)),3,2)
- . . S:X="" X="UNK"
- . . S RACE=RACE_"-"_X
- . . ; First triplet
- . . S LA7Y(10,CNT,1)=RACE
- . . S LA7Y(10,CNT,2)=$P(VADM(12,RACENUM),"^",2)
- . . S LA7Y(10,CNT,3)="HL70005"
- . . ; Second triplet
- . . S X=$$PTR2CODE^DGUTL4(+VADM(12,RACENUM),1,3)
- . . S LA7Y(10,CNT,4)=X
- . . S LA7Y(10,CNT,5)=$P(VADM(12,RACENUM),"^",2)
- . . S LA7Y(10,CNT,6)="CDC"
- . S IEN=0
- . F S IEN=$O(LA7Y(10,IEN)) Q:IEN="" D
- . . S LA7X=""
- . . F CNT=1:1:6 I LA7Y(10,IEN,CNT)'="" S $P(LA7X,$E(LA7ECH,1),CNT)=LA7Y(10,IEN,CNT)
- . . I LA7X="" Q
- . . I PID(10)'="" S PID(10)=PID(10)_$E(LA7ECH,2)
- . . S PID(10)=PID(10)_LA7X
- ;
- ; if from REFERRAL PATIENT file (#67) then check RACE field.
- I LRDPF=67 D Q
- . S LA7X=$$GET1^DIQ(67,DFN_",",.06,"I")
- . I LA7X<1 Q
- . S PID(10)=$$PTR2CODE^DGUTL4(LA7X,1,2)
- . S $P(PID(10),$E(LA7ECH,1),2)=$$PTR2TEXT^DGUTL4(LA7X,1)
- . S $P(PID(10),$E(LA7ECH,1),3)="HL70005"
- ;
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLA7UIO1 9710 printed Feb 18, 2025@23:06:17 Page 2
- LA7UIO1 ;DALOI/JMC - Process Download Message for an entry in 62.48 ;12/11/15 16:39
- +1 ;;5.2;AUTOMATED LAB INSTRUMENTS;**66,74,88**;Sep 27, 1994;Build 10
- +2 ;
- +3 ; Reference to PROTOCOL file (#101) supported by ICR #872
- +4 ;
- +5 QUIT
- +6 ;
- BUILD ; Build one accession into an HL7 message
- +1 ;
- +2 NEW GBL,HL,I,LA760,LA761,LA7CDT,LA7CMT,LA7CS,LA7ERR,LA7FAC,LA7FS,LA7ECH,LA7HLP,LA7I,LA7ID,LA7LINK,LA7NVAF,LA7OBRSN,LA7PIDSN,LA7SCMT,LA7SID,LA7SPEC,LA7SUB,LA7X,LA7Y
- +3 SET GBL="^TMP(""HLS"","_$JOB_")"
- +4 ;
- +5 IF '$DATA(ZTQUEUED)
- IF $GET(LRLL)
- if $X+5>IOM
- WRITE !,$SELECT($GET(LRTYPE):"Cup",1:"Seq"),": "
- WRITE LA76822,", "
- +6 ;
- +7 SET LA7CNT=0
- +8 FOR I=0,.1,.2,.3,3
- SET LA76802(I)=$GET(^LRO(68,LA768,1,LA76801,1,LA76802,I))
- +9 SET LA7X=LA76802(3)
- +10 ; Draw time
- +11 SET LA7CDT=+LA7X
- +12 ;
- +13 ; Specimen comment if any, strip "~"
- +14 SET LA7SCMT=$TRANSLATE($PIECE(LA7X,"^",6),"~")
- +15 ;
- +16 ; Specimen
- +17 SET LA761=+$GET(^LRO(68,LA768,1,LA76801,1,LA76802,5,1,0))
- +18 ; Accession/unique ID - Long (UID) or short (accession #) sample ID
- +19 SET LA7ACC=$PIECE(LA76802(.2),"^")
- SET LA7UID=$PIECE(LA76802(.3),"^")
- SET LA7X=$GET(^LRO(68,LA768,.4))
- +20 IF $PIECE(LA7X,"^",2)="S"
- SET LA7SID=$$RJ^XLFSTR(LA76802,+$PIECE(LA7X,"^",3),"0")
- +21 IF '$TEST
- SET LA7SID=LA7UID
- +22 ;
- +23 ; Start message
- +24 DO INIT
- if $GET(HL)
- QUIT
- +25 ;
- +26 ; Setup links and subscriber array for HL7 message generation
- +27 SET LA76248(0)=$GET(^LAHM(62.48,LA76248,0))
- SET LA7Y=$PIECE(LA76248(0),"^")
- +28 IF $EXTRACT(LA7Y,1,5)'="LA7UI"!($PIECE(LA76248(0),"^",9)'=1)
- QUIT
- +29 ;
- +30 ; Check if interface has been updagraded to HL7 v2.5.1 otherwise use v2.2 protocol
- +31 SET LA7SUB="LA7UI ORM-O01 SUBS"
- +32 SET X=$ORDER(^ORD(101,"B",LA7SUB,0))
- +33 IF X<1
- SET LA7SUB="LA7UI ORM-O01 SUBS 2.2"
- +34 ;
- +35 SET LA7LINK=LA7SUB_"^"_LA7Y
- +36 SET LA7FAC=$PIECE($$SITE^VASITE(DT),"^",3)
- +37 SET LA7HLP("SUBSCRIBER")="^^"_LA7FAC_"^"_LA7Y_"^"
- +38 ; Following line used when debugging
- +39 ;S $P(LA7HLP("SUBSCRIBER"),"^",8)="1-1-2"
- +40 ;
- +41 ; Build segments PID, PV1, and ORC/OBR segment for each test to be sent
- +42 DO PID
- DO PV1
- +43 SET (LA7I,LA7OBRSN)=0
- +44 FOR
- SET LA7I=$ORDER(LA7ACC(LA7I))
- if 'LA7I
- QUIT
- DO ORC
- DO OBR
- +45 ; Build entry in MESSAGE QUEUE file 62.49
- +46 DO SENDMSG
- +47 LOCK -^LAHM(62.49,LA76249)
- +48 DO KVAR^LRX
- +49 QUIT
- +50 ;
- +51 ;
- INIT ; Create/initialize HL message
- +1 ;
- +2 NEW LA7EVENT,X
- +3 ;
- +4 KILL @GBL
- +5 SET (LA76249,LA7NVAF,LA7PIDSN)=0
- +6 ;
- +7 ; Check if interface has been updagraded to HL7 v2.5.1 otherwise use v2.2 protocol
- +8 SET LA7EVENT="LA7UI ORM-O01 EVENT"
- +9 SET X=$ORDER(^ORD(101,"B",LA7EVENT,0))
- +10 IF X<1
- SET LA7EVENT="LA7UI ORM-O01 EVENT 2.2"
- +11 DO STARTMSG^LA7VHLU(LA7EVENT,.LA76249)
- +12 ;
- +13 SET LA7ID=$PIECE(LRAUTO,"^",1)_"-O-"_LA7UID
- +14 ;
- +15 KILL ^TMP("LA7-ID",$JOB)
- +16 DO SETID^LA7VHLU1(LA76249,"",LA7ID,1)
- +17 DO SETID^LA7VHLU1(LA76249,"",LA7UID,0)
- +18 DO SETID^LA7VHLU1(LA76249,"",LA7ACC,0)
- +19 SET LA7CS=$EXTRACT(LA7ECH,1)
- +20 IF $GET(HL)
- SET LA7ERR=28
- DO UPDT6249^LA7VORM1
- +21 QUIT
- +22 ;
- +23 ;
- PID ; Build PID segment
- +1 NEW LA7DATA,LA7FLAG,NAME,PID
- +2 SET LRDFN=+LA7ACC0
- SET LRDPF=$PIECE(^LR(LRDFN,0),"^",2)
- SET DFN=$PIECE(^(0),"^",3)
- +3 DO DEM^LRX
- +4 ;
- +5 SET PID(0)="PID"
- +6 SET PID(1)=1
- +7 SET PID(3)=$$M11^HLFNC(LRDFN)
- +8 ;
- +9 ; Pass patient and referral files through name standardization.
- +10 ; Don't pass lab control and other file's "paient" names thru name standardization as it affects name order.
- +11 IF LRDPF?1(1"2",1"67",1"200")
- SET NAME("FILE")=LRDPF
- SET NAME("FIELD")=.01
- SET NAME("IENS")=DFN
- SET LA7FLAG="S"
- +12 IF '$TEST
- SET NAME("FAMILY")=$PIECE(PNM,",")
- SET NAME("GIVEN")=$PIECE(PNM,",",2)
- SET LA7FLAG=""
- +13 SET PID(5)=$$HLNAME^XLFNAME(.NAME,LA7FLAG,LA7CS)
- +14 ;
- +15 ; Date of birth
- +16 IF DOB
- SET PID(7)=$$FMTHL7^XLFDT(DOB)
- +17 SET PID(8)=$SELECT(SEX'="":SEX,1:"U")
- +18 ;
- +19 ; Race
- +20 DO RACE
- +21 ;
- +22 ; Patient's SSN
- +23 IF SSN'=""
- SET PID(19)=SSN
- +24 ;
- +25 DO BUILDSEG^LA7VHLU(.PID,.LA7DATA,LA7FS)
- +26 DO FILESEG^LA7VHLU(GBL,.LA7DATA)
- +27 DO FILE6249^LA7VHLU(LA76249,.LA7DATA)
- +28 DO SETID^LA7VHLU1(LA76249,"",PNM,0)
- +29 QUIT
- +30 ;
- +31 ;
- PV1 ; Build PV1 segment
- +1 NEW LA7PV1,LA7X
- +2 DO PV1^LA7VPID(LRDFN,.LA7PV1,LA7FS,LA7ECH)
- +3 ; If not inpatient use patient location from Accession
- +4 IF $PIECE(LA7PV1(0),LA7FS,3)'="I"
- SET LA7X=$PIECE($GET(LA76802(0)),"^",7)
- SET LA7X=$$CHKDATA^LA7VHLU3(LA7X,LA7FS_LA7ECH)
- SET $PIECE(LA7PV1(0),LA7FS,4)=LA7X
- +5 ;
- +6 DO FILESEG^LA7VHLU(GBL,.LA7PV1)
- +7 DO FILE6249^LA7VHLU(LA76249,.LA7PV1)
- +8 QUIT
- +9 ;
- +10 ;
- ORC ; Build ORC segment
- +1 NEW LA7DATA,ORC
- +2 SET ORC(0)="ORC"
- +3 SET ORC(1)="NW"
- +4 ;
- +5 ; Placer/filler order number - sample ID
- +6 SET ORC(2)=$$ORC2^LA7VORC(LA7SID,LA7FS,LA7ECH)
- +7 SET ORC(3)=$$ORC3^LA7VORC(LA7SID,LA7FS,LA7ECH)
- +8 ;
- +9 ; Order/draw time - if no order date/time then try draw time
- +10 IF $PIECE(LA76802(0),"^",4)
- SET ORC(9)=$$ORC9^LA7VORC($PIECE(LA76802(0),"^",4))
- +11 IF '$PIECE(LA76802(0),"^",4)
- IF $PIECE(LA76802(3),"^")
- SET ORC(9)=$$ORC9^LA7VORC($PIECE(LA76802(3),"^"))
- +12 ;
- +13 ; Provider
- +14 SET LA7X=$$FNDOLOC^LA7VHLU2(LA7UID)
- +15 SET ORC(12)=$$ORC12^LA7VORC($PIECE(LA76802(0),"^",8),$PIECE(LA7X,"^",3),LA7FS,LA7ECH,2)
- +16 ; Provider Callback Number ;**88
- +17 SET ORC(14)=$$ORC14^LA7VORC($PIECE(LA76802(0),"^",8),DT,LA7FS,LA7ECH)
- +18 DO BUILDSEG^LA7VHLU(.ORC,.LA7DATA,LA7FS)
- +19 DO FILESEG^LA7VHLU(GBL,.LA7DATA)
- +20 DO FILE6249^LA7VHLU(LA76249,.LA7DATA)
- +21 QUIT
- +22 ;
- +23 ;
- OBR ; Build OBR segment
- +1 NEW LA764,LA7ALT,LA7CADR,LA7NLT,LA7TCMT
- +2 KILL OBR
- +3 ;
- +4 SET LA760=+LA7ACC(LA7I)
- +5 SET LA764=+$PIECE($GET(^LAB(60,LA760,64)),"^")
- +6 SET LA7NLT=$PIECE($GET(^LAM(LA764,0)),"^",2)
- +7 SET LA7TMP=$GET(^TMP("LA7",$JOB,LA7INST,LA7I))
- +8 if 'LA7TMP
- QUIT
- +9 ;
- +10 SET LA7CODE=$PIECE(LA7TMP,"^",6)
- SET LA7DATA=$PIECE(LA7TMP,"^",7)
- +11 SET OBR(0)="OBR"
- +12 SET OBR(1)=$$OBR1^LA7VOBR(.LA7OBRSN)
- +13 ; Placer/filler order number - sample ID
- +14 SET OBR(2)=$$OBR2^LA7VOBR(LA7SID,LA7FS,LA7ECH)
- +15 SET OBR(3)=$$OBR3^LA7VOBR(LA7SID,LA7FS,LA7ECH)
- +16 ; Test order code
- +17 SET LA7ALT=LA7CODE_"^"_$$GET1^DIQ(60,LA760_",",.01)_"^"_"99001"
- +18 SET OBR(4)=$$OBR4^LA7VOBR(LA7NLT,LA760,LA7ALT,LA7FS,LA7ECH)
- +19 ; Draw time.
- +20 IF $GET(LA7CDT)
- SET OBR(7)=$$OBR7^LA7VOBR(LA7CDT)
- +21 ; Infection warning.
- +22 SET OBR(12)=$$OBR12^LA7VOBR(LRDFN,LA7FS,LA7ECH)
- +23 ;
- +24 ; Specimen comment
- +25 ; If no specimen comment
- +26 ; then check order for test comments on test
- +27 ; or parent test if panel exploded
- +28 IF LA7SCMT'=""
- SET OBR(13)=$$OBR13^LA7VOBR(LA7SCMT,LA7FS,LA7ECH)
- +29 IF LA7SCMT=""
- Begin DoDot:1
- +30 SET LA7TCMT=$$TESTCMT(LA768,LA76801,LA76802,LA760)
- +31 IF LA7TCMT=""
- Begin DoDot:2
- +32 NEW LA760P
- +33 SET LA760P=$PIECE(LA7ACC(LA7I),"^",3)
- +34 IF LA760P>0
- IF LA760'=LA760P
- SET LA7TCMT=$$TESTCMT(LA768,LA76801,LA76802,LA760P)
- End DoDot:2
- +35 IF LA7TCMT'=""
- SET OBR(13)=$$OBR13^LA7VOBR(LA7TCMT,LA7FS,LA7ECH)
- End DoDot:1
- +36 ;
- +37 ; Lab Arrival Time
- +38 SET OBR(14)=$$OBR14^LA7VOBR($PIECE(LA76802(3),"^",3))
- +39 ; HL7 code from Topography
- +40 SET LA7X=$SELECT(LRDPF=62.3:"^^^CONTROL",1:"")
- +41 SET OBR(15)=$$OBR15^LA7VOBR(LA761,"",LA7X,LA7FS,LA7ECH)
- +42 ; Ordering provider
- +43 SET LA7X=$$FNDOLOC^LA7VHLU2(LA7UID)
- +44 SET OBR(16)=$$ORC12^LA7VORC($PIECE(LA76802(0),"^",8),$PIECE(LA7X,"^",3),LA7FS,LA7ECH,2)
- +45 ; Provider Callback Number ;**88
- +46 SET OBR(17)=$$ORC14^LA7VORC($PIECE(LA76802(0),"^",8),DT,LA7FS,LA7ECH)
- +47 ; Placer's field #1 - instrument name^card address
- +48 KILL LA7X
- +49 SET LA7X(1)=$PIECE(LRAUTO,"^")
- +50 SET LA7CADR=$PIECE($GET(^LAB(62.4,LRINST,9)),U,9)
- +51 IF LA7CADR'=""
- SET LA7X(2)=LA7CADR
- +52 SET OBR(18)=$$OBR18^LA7VOBR(.LA7X,LA7FS,LA7ECH)
- +53 ; Placer's field #2 - tray^cup^lraa^lrad^lran^lracc^lruid
- +54 KILL LA7X
- +55 ; No tray/cup if don't send tray/cup flag.
- +56 IF $GET(LRFORCE)
- if LA76821
- SET LA7X(1)=LA76821
- if LA76822
- SET LA7X(2)=LA76822
- +57 SET LA7X(3)=LA768
- SET LA7X(4)=LA76801
- SET LA7X(5)=LA76802
- SET LA7X(6)=LA7ACC
- SET LA7X(7)=LA7UID
- +58 SET OBR(19)=$$OBR19^LA7VOBR(.LA7X,LA7FS,LA7ECH)
- +59 ;
- +60 ; Test urgency
- +61 SET OBR(27)=$$OBR27^LA7VOBR("","",+$PIECE(LA7ACC(LA7I),"^",2),LA7FS,LA7ECH)
- +62 ;
- +63 KILL LA7DATA
- +64 DO BUILDSEG^LA7VHLU(.OBR,.LA7DATA,LA7FS)
- +65 DO FILESEG^LA7VHLU(GBL,.LA7DATA)
- +66 DO FILE6249^LA7VHLU(LA76249,.LA7DATA)
- +67 QUIT
- +68 ;
- +69 ;
- SENDMSG ; Send the HL7 message.
- +1 NEW HLL,HLP
- +2 SET HLL("LINKS",1)=LA7LINK
- +3 IF $DATA(LA7HLP)
- MERGE HLP=LA7HLP
- +4 DO GEN^LA7VHLU
- DO UPDT6249^LA7VORM1
- +5 QUIT
- +6 ;
- +7 ;
- TESTCMT(LA768,LA76801,LA76802,LA760) ; Check and build order test comments
- +1 ;
- +2 ; Call with LA768 = IEN of accesseion area
- +3 ; LA76801 = FM accession date
- +4 ; LA76802 = accession number
- +5 ; LA760 = IEN of file #60 test
- +6 ;
- +7 ; Returns LA7CMT = comments in a single string (truncated to 300 characters per HL7 standard)
- +8 ;
- +9 NEW LA7CMT,LA7I,LA7QUIT,LA7X,LA7Y,LRIEN,LRODT,LRSN
- +10 ;
- +11 SET LA7CMT=""
- SET LRIEN=0
- +12 SET LA7Y=$GET(^LRO(68,LA768,1,LA76801,1,LA76802,0))
- +13 SET LRODT=+$PIECE(LA7Y,"^",4)
- SET LRSN=+$PIECE(LA7Y,"^",5)
- +14 IF LRODT>0
- IF LRSN>0
- SET LRIEN=$ORDER(^LRO(69,LRODT,1,LRSN,2,"B",LA760,0))
- +15 ;
- +16 IF LRIEN
- Begin DoDot:1
- +17 SET (LA7I,LA7QUIT)=0
- SET LA7X=""
- +18 FOR
- SET LA7I=$ORDER(^LRO(69,LRODT,1,LRSN,2,LRIEN,1,LA7I))
- if LA7I<1
- QUIT
- Begin DoDot:2
- +19 SET LA7X=$GET(^LRO(69,LRODT,1,LRSN,2,LRIEN,1,LA7I,0))
- +20 IF $EXTRACT(LA7X,1,10)="~For Test:"
- QUIT
- +21 IF LA7X'=""
- SET LA7X=$TRANSLATE(LA7X,"~","")
- +22 IF LA7CMT'=""
- SET LA7X=" "_LA7X
- +23 SET LA7CMT=LA7CMT_LA7X
- +24 IF $LENGTH(LA7CMT)>300
- SET LA7CMT=$EXTRACT(LA7CMT,1,300)
- SET LA7QUIT=1
- End DoDot:2
- if LA7QUIT
- QUIT
- End DoDot:1
- +25 ;
- +26 QUIT LA7CMT
- +27 ;
- +28 ;
- RACE ; Build RACE field in PID segment
- +1 ;
- +2 NEW CNT,IEN,LA7X,LA7Y,RACE,RACENUM,X,Y
- +3 ;
- +4 SET PID(10)=""
- +5 ;
- +6 ; if from PATIENT file (#2) then check RACE array (VADM(12).
- +7 IF LRDPF=2
- IF $GET(VADM(12))
- Begin DoDot:1
- +8 ; Loop through all races (CNT is repetition location)
- +9 SET RACENUM=0
- +10 FOR CNT=1:1
- SET RACENUM=+$ORDER(VADM(12,RACENUM))
- if 'RACENUM
- QUIT
- Begin DoDot:2
- +11 ; Fabricate race value -> RACE-METHOD
- +12 SET RACE=$$PTR2CODE^DGUTL4(+VADM(12,RACENUM),1,2)
- +13 SET X=$$PTR2CODE^DGUTL4(+$GET(VADM(12,RACENUM,1)),3,2)
- +14 if X=""
- SET X="UNK"
- +15 SET RACE=RACE_"-"_X
- +16 ; First triplet
- +17 SET LA7Y(10,CNT,1)=RACE
- +18 SET LA7Y(10,CNT,2)=$PIECE(VADM(12,RACENUM),"^",2)
- +19 SET LA7Y(10,CNT,3)="HL70005"
- +20 ; Second triplet
- +21 SET X=$$PTR2CODE^DGUTL4(+VADM(12,RACENUM),1,3)
- +22 SET LA7Y(10,CNT,4)=X
- +23 SET LA7Y(10,CNT,5)=$PIECE(VADM(12,RACENUM),"^",2)
- +24 SET LA7Y(10,CNT,6)="CDC"
- End DoDot:2
- +25 SET IEN=0
- +26 FOR
- SET IEN=$ORDER(LA7Y(10,IEN))
- if IEN=""
- QUIT
- Begin DoDot:2
- +27 SET LA7X=""
- +28 FOR CNT=1:1:6
- IF LA7Y(10,IEN,CNT)'=""
- SET $PIECE(LA7X,$EXTRACT(LA7ECH,1),CNT)=LA7Y(10,IEN,CNT)
- +29 IF LA7X=""
- QUIT
- +30 IF PID(10)'=""
- SET PID(10)=PID(10)_$EXTRACT(LA7ECH,2)
- +31 SET PID(10)=PID(10)_LA7X
- End DoDot:2
- End DoDot:1
- QUIT
- +32 ;
- +33 ; if from REFERRAL PATIENT file (#67) then check RACE field.
- +34 IF LRDPF=67
- Begin DoDot:1
- +35 SET LA7X=$$GET1^DIQ(67,DFN_",",.06,"I")
- +36 IF LA7X<1
- QUIT
- +37 SET PID(10)=$$PTR2CODE^DGUTL4(LA7X,1,2)
- +38 SET $PIECE(PID(10),$EXTRACT(LA7ECH,1),2)=$$PTR2TEXT^DGUTL4(LA7X,1)
- +39 SET $PIECE(PID(10),$EXTRACT(LA7ECH,1),3)="HL70005"
- End DoDot:1
- QUIT
- +40 ;
- +41 QUIT