LA7VORM ;DALOI/DLR - LAB ORM (Order) message PROCESSOR ;06/08/09 17:35
;;5.2;AUTOMATED LAB INSTRUMENTS;**27,42,46,64,74**;Sep 27, 1994;Build 229
;
;
IN ;
D ORM^LA7VHL
Q
;
;
OBR ;;OBR
N LA760,LA76205,LA7629,LA7ACC,LA7CEDT,LA7CSCS,LA7CSNM,LA7CSTY,LA7DCODE,LA7HSITE,LA7I,LA7NCS,LA7OBR4,LA7OK,LA7OTST,LA7OTSTN,LA7PF1,LA7PF2,LA7RCI,LA7SPCS,LA7SPNM,LA7SPTY,LA7X,LA7Y,RTST,RTSTN
;
; OBR Set ID
S LA7SOBR=$$P^LA7VHLU(.LA7SEG,2,LA7FS)
;
; Placer order number
S LA7SID=$$P^LA7VHLU(.LA7SEG,3,LA7FS)
I LA7SID'="" D
. D SETID^LA7VHLU1(LA76249,LA7ID,LA7SID,0)
. D SETID^LA7VHLU1(LA76249,"",LA7SID,0)
;
; Universal service ID
S (LA7OBR4,LA7OTSTN)=$$P^LA7VHLU(.LA7SEG,5,LA7FS)
D FLD2ARR^LA7VHLU7(.LA7OTSTN,LA7FS_LA7ECH)
;
I $G(LA7OTSTN(1))="" D Q
. N LA7X
. S LA7X="PID-"_LA7SPID_"/OBR-"_LA7SOBR
. S LA7AERR=$$CREATE^LA7LOG(26,1)
;
S LA7OTST=$G(LA7OTSTN(2))
I LA7OTST="" S LA7OTST=$G(LA7OTSTN(5))
S RTSTN=$G(LA7OTSTN(4)),RTST=$G(LA7OTSTN(5))
;
; Non-VA system, not using NLT codes/file #60 tests
I LA7OTSTN(3)'="99VA64" D
. I RTSTN="" S RTSTN=LA7OTSTN(1)
. I RTST="" S RTST=LA7OTSTN(2)
;
; No ORC segment
I LA7SEQ<20 S LA7AERR=$$CREATE^LA7LOG(29,1) Q
;
; Missing patient name
I $G(LA7PNM)="" S LA7AERR=$$CREATE^LA7LOG(30,1) Q
;
; Specimen collection date/time
S LA7CDT=$$HL7TFM^XLFDT($P($$P^LA7VHLU(.LA7SEG,8,LA7FS),LA7CS),"L")
;
; Specimen end collection date/time (timed collection)
S LA7CEDT=$$HL7TFM^XLFDT($P($$P^LA7VHLU(.LA7SEG,9,LA7FS),LA7CS),"L")
;
; Collection volume
S LA7VOL=""
S LA7X=$$P^LA7VHLU(.LA7SEG,10,LA7FS)
I $P(LA7X,LA7CS)'="" D
. S $P(LA7VOL,"^")=$P(LA7X,LA7CS) ; volume
. S $P(LA7VOL,"^",2)=$P(LA7X,LA7CS,2) ; volume units
. S $P(LA7VOL,"^",3)=$P(LA7X,LA7CS,3) ; volume coding system
;
; Specimen action code
S LA7X=$$P^LA7VHLU(.LA7SEG,12,LA7FS),LA7SAC=""
I LA7X="A" S LA7SAC="Add ordered tests to the existing specimen"
I LA7X="G" S LA7SAC="Generated order; reflex order"
;
; Danger code
S LA7X=$P($$P^LA7VHLU(.LA7SEG,13,LA7FS),LA7CS,2)
S LA7DCODE=$$UNESC^LA7VHLU3(LA7X,LA7FS_LA7ECH)
I LA7DCODE'="" D
. S LA7DCODE=$$TRIM^XLFSTR(LA7DCODE,"RL"," ")
. S LA7DCODE="Danger Code - "_LA7DCODE
;
; Relevant clinical information
S LA7X=$$P^LA7VHLU(.LA7SEG,14,LA7FS)
S LA7RCI=$$UNESC^LA7VHLU3(LA7X,LA7FS_LA7ECH)
I LA7RCI'="" D
. S LA7RCI=$$TRIM^XLFSTR(LA7RCI,"RL"," ")
. S LA7RCI="Relevant clinical information - "_LA7RCI
;
; Specimen source - specimen code - name of specimen coding system, move SCT code system to primary if needed
K LA7X,LA7Y
S LA7X=$$P^LA7VHLU(.LA7SEG,16,LA7FS)
D FLD2ARR^LA7VHLU7(.LA7X,LA7FS_LA7ECH)
K LA7Y
M LA7Y=LA7X(1)
D CHKCDSYS^LA7SMU2(.LA7Y,.LA7SPTY,"SCT",LA7CS)
;
; Collection sample from body site, move SCT code system to primary if needed
K LA7Y
M LA7Y=LA7X(4)
D CHKCDSYS^LA7SMU2(.LA7Y,.LA7CSTY,"SCT",LA7CS)
K LA7X,LA7Y
;
; Placer's ordering provider (last name, first name, mi [id])
; Only process if LA7POP from ORC-12 is blank.
I LA7POP="" D
. S LA7X=$$P^LA7VHLU(.LA7SEG,17,LA7FS)
. S LA7POP=$$XCNTFM^LA7VHLU9(LA7X,LA7ECH)
. I LA7POP="^0^" S LA7POP=""
;
; Specimen urgency
S LA7UR=$P($$P^LA7VHLU(.LA7SEG,28,LA7FS),LA7CS,6)
; If no urgency see if it came in ORC-7
I LA7UR="" S LA7UR=$G(LA7OUR)
;
; Look for receiving facility in OBR, then use receiving facility from MSH
S LA7X=$P($$P^LA7VHLU(.LA7SEG,35,LA7FS),LA7CS,7)
S LA7HSITE=$$FINDSITE^LA7VHLU2(LA7X,1,1)
I LA7HSITE'>0 S LA7HSITE=$$FINDSITE^LA7VHLU2(LA7RFAC,1,0)
;
; Find an "active" shipping configuration for this pair.
S (LA7629,LA7X)=0
I LA7CSITE,LA7HSITE D
. F S LA7X=$O(^LAHM(62.9,"CH",LA7CSITE,LA7HSITE,LA7X)) Q:'LA7X I $P($G(^LAHM(62.9,LA7X,0)),"^",4) S LA7629=LA7X Q
; Log error and quit if no active shipping configuration identified
I 'LA7629 S LA7AERR=$$CREATE^LA7LOG(39,1) Q
;
S LA7Y=$$DTTO^LA7SMU2(LA7629,.LA7OTSTN,.LA7SPTY,LA7UR,.LA7CSTY),LA7OK=1
S LA760=$P(LA7Y,"^"),LA761=$P(LA7Y,"^",2),LA762=$P(LA7Y,"^",3),LA76205=$P(LA7Y,"^",4)
I $P(LA7Y,"^",5)'="" S LA7OTSTN=$P(LA7Y,"^",5),LA7OTST=$P(LA7Y,"^",6)
F LA7I=1:1:4 I '$P(LA7Y,"^",LA7I) D
. I LA7I>1,LA760,"MISPCYEM"[$P(^LAB(60,LA760,0),"^",4) Q
. S LA7X="No local "_$P("lab test^topography^collection sample^urgency","^",LA7I)_" mapped.",LA7OK=0
. N LA7I,LA7Y
. D CREATE^LA7LOG(47)
I 'LA7OK S LA7AERR="47^A VistA lab test has not been defined for order code "_LA7OTSTN_" and specimen/collection sample combination"
;
; Placer fields 1 & 2
S LA7X=$$P^LA7VHLU(.LA7SEG,19,LA7FS)
I LA7X'="",LA7X[LA7CS S LA7X=$TR(LA7X,LA7CS,"^")
S LA7PF1=$$UNESC^LA7VHLU3(LA7X,LA7FS_LA7ECH)
S LA7X=$$P^LA7VHLU(.LA7SEG,20,LA7FS)
I LA7X'="",LA7X[LA7CS S LA7X=$TR(LA7X,LA7CS,"^")
S LA7PF2=$$UNESC^LA7VHLU3(LA7X,LA7FS_LA7ECH)
S LA7ACC=$P(LA7PF2,"^",6)
;
; New order - add to LAB PENDING ORDERS file #69.6
I LA7OTYPE="NW",LA7OK D NW
;
Q
;
NW ; Create new order in LAB PENDING ORDERS file #69.6
;
N FDA,I,LA76964,LA7DIE,LA7I,LA7IEN,LA7PATID,LA7SSITE,LA7STAT,LA7WP
;
; Get lock on 69.6
;L +^LRO(69.6,0):99999
D LOCK^DILF("^LRO(69.6,0)")
I '$T S LA7AERR=$$CREATE^LA7LOG(31,1) Q
;
S LA7696=$O(^LRO(69.6,"AD",$S($P(LA7SM,"^",2)'="":$P(LA7SM,"^",2),1:0),LA7SID,0))
;
; Find "In-Transit" status in #64.061
S LA7STAT=$$FIND1^DIC(64.061,"","OMX","In-Transit","","I $P(^LAB(64.061,Y,0),U,7)=""U""")
;
; Create entry in LAB PENDING ORDER ENTRY file, log error if not added
I $G(LA7696)'>0 D
. S FDA(1,69.6,"+1,",.01)=LA7PNM
. S FDA(1,69.6,"+1,",6)=LA7STAT
. D UPDATE^DIE("","FDA(1)","LA7IEN","LA7DIE(1)")
. S LA7696=LA7IEN(1)
. I LA7696<1 S LA7AERR=$$CREATE^LA7LOG(32,1)
;
L -^LRO(69.6,0)
I LA7696<1 Q
;
;L +^LRO(69.6,LA7696):99999
D LOCK^DILF("^LRO(69.6,LA7696)")
I '$T D Q ;cannot get lock on ENTRY in 69.6
. S LA7AERR=$$CREATE^LA7LOG(33,1)
;
; Prevent duplication of tests
I $D(^LRO(69.6,LA7696,2,"C",LA7OTSTN)) D UNLOCK Q
;
; Determine entry in INSTITUTION file (#4) that's the sending site.
S LA7SSITE=$$FINDSITE^LA7VHLU2(LA7SFAC,2,0)
;
; Patient id to store with order
S LA7PATID=LA7SSN
I LA7PATID="" D
. S LA7PATID=$P($G(LA7PTID3(1)),$E(LA7ECH))
. I LA7PATID'="" Q
. I LA7PTID4'="" S LA7PATID=$P($P(LA7PTID4,$E(LA7ECH,2)),$E(LA7ECH))
. I LA7PATID'="" Q
. I LA7PTID2'="" S LA7PATID=$P(LA7PTID2,$E(LA7ECH))
;
S FDA(2,69.6,LA7696_",",.01)=LA7PNM
S FDA(2,69.6,LA7696_",",.02)=LA7SEX
S FDA(2,69.6,LA7696_",",.03)=LA7DOB
I $G(LA7PRACE)'="" S FDA(2,69.6,LA7696_",",.06)=LA7PRACE
S FDA(2,69.6,LA7696_",",.09)=LA7PATID
S FDA(2,69.6,LA7696_",",1)=LA7SSITE
S FDA(2,69.6,LA7696_",",2)=LA7CSITE
S FDA(2,69.6,LA7696_",",3)=LA7SID
S FDA(2,69.6,LA7696_",",3.2)=LA7ACC
I LA761 S FDA(2,69.6,LA7696_",",4)=LA761
I LA762 S FDA(2,69.6,LA7696_",",5)=LA762
S FDA(2,69.6,LA7696_",",10)=LA7ORDT
S FDA(2,69.6,LA7696_",",11)=LA7CDT
S FDA(2,69.6,LA7696_",",11.1)=LA7CEDT
S FDA(2,69.6,LA7696_",",14)=LA7MEDT
S FDA(2,69.6,LA7696_",",17)=LA7MID
I $P(LA7SM,"^",2)'="" S LA7X=$P(LA7SM,"^",2)
E S LA7X=LA7SFAC_"-"_$E($$FMTHL7^XLFDT(LA7MEDT),1,8)
S FDA(2,69.6,LA7696_",",18)=LA7X
S FDA(2,69.6,LA7696_",",700)=LA7FS_LA7ECH
I LA7PTID3'="" S FDA(2,69.6,LA7696_",",700.02)=LA7PTID3
I LA7PTID4'="" S FDA(2,69.6,LA7696_",",700.04)=LA7PTID4
D FILE^DIE("","FDA(2)","LA7DIE(2)")
;
; Add test to order
S FDA(3,69.64,"+2,"_LA7696_",",.01)=LA7OTST
S FDA(3,69.64,"+2,"_LA7696_",",1)=LA7OTSTN
S FDA(3,69.64,"+2,"_LA7696_",",2)=RTST
S FDA(3,69.64,"+2,"_LA7696_",",3)=RTSTN
S FDA(3,69.64,"+2,"_LA7696_",",4)=LA7UR
I LA760 S FDA(3,69.64,"+2,"_LA7696_",",11)=LA760
I LA76205 S FDA(3,69.64,"+2,"_LA7696_",",12)=LA76205
I $P(LA7POP,"^",3)'="" S FDA(3,69.64,"+2,"_LA7696_",",13)=$P(LA7POP,"^",3)
I LA7OBR4'="" S FDA(3,69.64,"+2,"_LA7696_",",700.04)=LA7OBR4
I LA7PF1'="" S FDA(3,69.64,"+2,"_LA7696_",",700.18)=LA7PF1
I LA7PF2'="" S FDA(3,69.64,"+2,"_LA7696_",",700.19)=LA7PF2
D UPDATE^DIE("","FDA(3)","LA76964","LA7DIE(3)")
;
; If no test status - set to In-transit.
I $G(LA76964(2)),$P($G(^LRO(69.6,LA7696,2,LA76964(2),0)),"^",6)="" D
. S FDA(4,69.64,LA76964(2)_","_LA7696_",",5)=LA7STAT
. D FILE^DIE("","FDA(4)","LA7DIE(4)")
;
; Check for comments to store with order.
; Begin sections with <space> to avoid FM word wrap.
S LA7I=1
I 'LA760 S LA7WP(LA7I,0)="For test "_LA7OTST
E S LA7WP(LA7I,0)="For test "_$$GET1^DIQ(60,LA760_",",.01)
;
I LA7SAC'="" S LA7I=LA7I+1,LA7WP(LA7I,0)=" "_LA7SAC
;
I LA7DCODE'="" F I=1:250:$L(LA7DCODE) S LA7I=LA7I+1,LA7WP(LA7I,0)=$S(I=1:" ",1:"")_$E(LA7DCODE,I,I+249)
;
I LA7RCI'="" F I=1:250:$L(LA7RCI) S LA7I=LA7I+1,LA7WP(LA7I,0)=$S(I=1:" ",1:"")_$E(LA7RCI,I,I+249)
;
I LA760,"MISPCYEM"[$P(^LAB(60,LA760,0),"^",4) D
. S LA7I=LA7I+1,LA7WP(LA7I,0)=" Specimen source: "
. F I=1,4 I $G(LA7SPTY(I))'="" S LA7WP(LA7I,0)=LA7WP(LA7I,0)_$G(LA7SPTY(I+1))_" ["_$G(LA7SPTY(I))_":"_$G(LA7SPTY(I+2))_"]"_$S(I=1:" ; ",1:"")
. S LA7I=LA7I+1,LA7WP(LA7I,0)=" Collection sample: "
. F I=1,4 I $G(LA7CSTY(I))'="" S LA7WP(LA7I,0)=LA7WP(LA7I,0)_$G(LA7CSTY(I+1))_" ["_$G(LA7CSTY(I))_":"_$G(LA7CSTY(I+2))_"]"_$S(I=1:" ; ",1:"")
;
I $O(LA7WP(1)) D WP^DIE(69.6,LA7696_",",99,"A","LA7WP","LA7DIE(99)")
;
D CLEAN^DILF
D UNLOCK
Q
;
UNLOCK ; unlock entry in file #69.6
L -^LRO(69.6,LA7696)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLA7VORM 9372 printed Apr 09, 2024@20:49:25 Page 2
LA7VORM ;DALOI/DLR - LAB ORM (Order) message PROCESSOR ;06/08/09 17:35
+1 ;;5.2;AUTOMATED LAB INSTRUMENTS;**27,42,46,64,74**;Sep 27, 1994;Build 229
+2 ;
+3 ;
IN ;
+1 DO ORM^LA7VHL
+2 QUIT
+3 ;
+4 ;
OBR ;;OBR
+1 NEW LA760,LA76205,LA7629,LA7ACC,LA7CEDT,LA7CSCS,LA7CSNM,LA7CSTY,LA7DCODE,LA7HSITE,LA7I,LA7NCS,LA7OBR4,LA7OK,LA7OTST,LA7OTSTN,LA7PF1,LA7PF2,LA7RCI,LA7SPCS,LA7SPNM,LA7SPTY,LA7X,LA7Y,RTST,RTSTN
+2 ;
+3 ; OBR Set ID
+4 SET LA7SOBR=$$P^LA7VHLU(.LA7SEG,2,LA7FS)
+5 ;
+6 ; Placer order number
+7 SET LA7SID=$$P^LA7VHLU(.LA7SEG,3,LA7FS)
+8 IF LA7SID'=""
Begin DoDot:1
+9 DO SETID^LA7VHLU1(LA76249,LA7ID,LA7SID,0)
+10 DO SETID^LA7VHLU1(LA76249,"",LA7SID,0)
End DoDot:1
+11 ;
+12 ; Universal service ID
+13 SET (LA7OBR4,LA7OTSTN)=$$P^LA7VHLU(.LA7SEG,5,LA7FS)
+14 DO FLD2ARR^LA7VHLU7(.LA7OTSTN,LA7FS_LA7ECH)
+15 ;
+16 IF $GET(LA7OTSTN(1))=""
Begin DoDot:1
+17 NEW LA7X
+18 SET LA7X="PID-"_LA7SPID_"/OBR-"_LA7SOBR
+19 SET LA7AERR=$$CREATE^LA7LOG(26,1)
End DoDot:1
QUIT
+20 ;
+21 SET LA7OTST=$GET(LA7OTSTN(2))
+22 IF LA7OTST=""
SET LA7OTST=$GET(LA7OTSTN(5))
+23 SET RTSTN=$GET(LA7OTSTN(4))
SET RTST=$GET(LA7OTSTN(5))
+24 ;
+25 ; Non-VA system, not using NLT codes/file #60 tests
+26 IF LA7OTSTN(3)'="99VA64"
Begin DoDot:1
+27 IF RTSTN=""
SET RTSTN=LA7OTSTN(1)
+28 IF RTST=""
SET RTST=LA7OTSTN(2)
End DoDot:1
+29 ;
+30 ; No ORC segment
+31 IF LA7SEQ<20
SET LA7AERR=$$CREATE^LA7LOG(29,1)
QUIT
+32 ;
+33 ; Missing patient name
+34 IF $GET(LA7PNM)=""
SET LA7AERR=$$CREATE^LA7LOG(30,1)
QUIT
+35 ;
+36 ; Specimen collection date/time
+37 SET LA7CDT=$$HL7TFM^XLFDT($PIECE($$P^LA7VHLU(.LA7SEG,8,LA7FS),LA7CS),"L")
+38 ;
+39 ; Specimen end collection date/time (timed collection)
+40 SET LA7CEDT=$$HL7TFM^XLFDT($PIECE($$P^LA7VHLU(.LA7SEG,9,LA7FS),LA7CS),"L")
+41 ;
+42 ; Collection volume
+43 SET LA7VOL=""
+44 SET LA7X=$$P^LA7VHLU(.LA7SEG,10,LA7FS)
+45 IF $PIECE(LA7X,LA7CS)'=""
Begin DoDot:1
+46 ; volume
SET $PIECE(LA7VOL,"^")=$PIECE(LA7X,LA7CS)
+47 ; volume units
SET $PIECE(LA7VOL,"^",2)=$PIECE(LA7X,LA7CS,2)
+48 ; volume coding system
SET $PIECE(LA7VOL,"^",3)=$PIECE(LA7X,LA7CS,3)
End DoDot:1
+49 ;
+50 ; Specimen action code
+51 SET LA7X=$$P^LA7VHLU(.LA7SEG,12,LA7FS)
SET LA7SAC=""
+52 IF LA7X="A"
SET LA7SAC="Add ordered tests to the existing specimen"
+53 IF LA7X="G"
SET LA7SAC="Generated order; reflex order"
+54 ;
+55 ; Danger code
+56 SET LA7X=$PIECE($$P^LA7VHLU(.LA7SEG,13,LA7FS),LA7CS,2)
+57 SET LA7DCODE=$$UNESC^LA7VHLU3(LA7X,LA7FS_LA7ECH)
+58 IF LA7DCODE'=""
Begin DoDot:1
+59 SET LA7DCODE=$$TRIM^XLFSTR(LA7DCODE,"RL"," ")
+60 SET LA7DCODE="Danger Code - "_LA7DCODE
End DoDot:1
+61 ;
+62 ; Relevant clinical information
+63 SET LA7X=$$P^LA7VHLU(.LA7SEG,14,LA7FS)
+64 SET LA7RCI=$$UNESC^LA7VHLU3(LA7X,LA7FS_LA7ECH)
+65 IF LA7RCI'=""
Begin DoDot:1
+66 SET LA7RCI=$$TRIM^XLFSTR(LA7RCI,"RL"," ")
+67 SET LA7RCI="Relevant clinical information - "_LA7RCI
End DoDot:1
+68 ;
+69 ; Specimen source - specimen code - name of specimen coding system, move SCT code system to primary if needed
+70 KILL LA7X,LA7Y
+71 SET LA7X=$$P^LA7VHLU(.LA7SEG,16,LA7FS)
+72 DO FLD2ARR^LA7VHLU7(.LA7X,LA7FS_LA7ECH)
+73 KILL LA7Y
+74 MERGE LA7Y=LA7X(1)
+75 DO CHKCDSYS^LA7SMU2(.LA7Y,.LA7SPTY,"SCT",LA7CS)
+76 ;
+77 ; Collection sample from body site, move SCT code system to primary if needed
+78 KILL LA7Y
+79 MERGE LA7Y=LA7X(4)
+80 DO CHKCDSYS^LA7SMU2(.LA7Y,.LA7CSTY,"SCT",LA7CS)
+81 KILL LA7X,LA7Y
+82 ;
+83 ; Placer's ordering provider (last name, first name, mi [id])
+84 ; Only process if LA7POP from ORC-12 is blank.
+85 IF LA7POP=""
Begin DoDot:1
+86 SET LA7X=$$P^LA7VHLU(.LA7SEG,17,LA7FS)
+87 SET LA7POP=$$XCNTFM^LA7VHLU9(LA7X,LA7ECH)
+88 IF LA7POP="^0^"
SET LA7POP=""
End DoDot:1
+89 ;
+90 ; Specimen urgency
+91 SET LA7UR=$PIECE($$P^LA7VHLU(.LA7SEG,28,LA7FS),LA7CS,6)
+92 ; If no urgency see if it came in ORC-7
+93 IF LA7UR=""
SET LA7UR=$GET(LA7OUR)
+94 ;
+95 ; Look for receiving facility in OBR, then use receiving facility from MSH
+96 SET LA7X=$PIECE($$P^LA7VHLU(.LA7SEG,35,LA7FS),LA7CS,7)
+97 SET LA7HSITE=$$FINDSITE^LA7VHLU2(LA7X,1,1)
+98 IF LA7HSITE'>0
SET LA7HSITE=$$FINDSITE^LA7VHLU2(LA7RFAC,1,0)
+99 ;
+100 ; Find an "active" shipping configuration for this pair.
+101 SET (LA7629,LA7X)=0
+102 IF LA7CSITE
IF LA7HSITE
Begin DoDot:1
+103 FOR
SET LA7X=$ORDER(^LAHM(62.9,"CH",LA7CSITE,LA7HSITE,LA7X))
if 'LA7X
QUIT
IF $PIECE($GET(^LAHM(62.9,LA7X,0)),"^",4)
SET LA7629=LA7X
QUIT
End DoDot:1
+104 ; Log error and quit if no active shipping configuration identified
+105 IF 'LA7629
SET LA7AERR=$$CREATE^LA7LOG(39,1)
QUIT
+106 ;
+107 SET LA7Y=$$DTTO^LA7SMU2(LA7629,.LA7OTSTN,.LA7SPTY,LA7UR,.LA7CSTY)
SET LA7OK=1
+108 SET LA760=$PIECE(LA7Y,"^")
SET LA761=$PIECE(LA7Y,"^",2)
SET LA762=$PIECE(LA7Y,"^",3)
SET LA76205=$PIECE(LA7Y,"^",4)
+109 IF $PIECE(LA7Y,"^",5)'=""
SET LA7OTSTN=$PIECE(LA7Y,"^",5)
SET LA7OTST=$PIECE(LA7Y,"^",6)
+110 FOR LA7I=1:1:4
IF '$PIECE(LA7Y,"^",LA7I)
Begin DoDot:1
+111 IF LA7I>1
IF LA760
IF "MISPCYEM"[$PIECE(^LAB(60,LA760,0),"^",4)
QUIT
+112 SET LA7X="No local "_$PIECE("lab test^topography^collection sample^urgency","^",LA7I)_" mapped."
SET LA7OK=0
+113 NEW LA7I,LA7Y
+114 DO CREATE^LA7LOG(47)
End DoDot:1
+115 IF 'LA7OK
SET LA7AERR="47^A VistA lab test has not been defined for order code "_LA7OTSTN_" and specimen/collection sample combination"
+116 ;
+117 ; Placer fields 1 & 2
+118 SET LA7X=$$P^LA7VHLU(.LA7SEG,19,LA7FS)
+119 IF LA7X'=""
IF LA7X[LA7CS
SET LA7X=$TRANSLATE(LA7X,LA7CS,"^")
+120 SET LA7PF1=$$UNESC^LA7VHLU3(LA7X,LA7FS_LA7ECH)
+121 SET LA7X=$$P^LA7VHLU(.LA7SEG,20,LA7FS)
+122 IF LA7X'=""
IF LA7X[LA7CS
SET LA7X=$TRANSLATE(LA7X,LA7CS,"^")
+123 SET LA7PF2=$$UNESC^LA7VHLU3(LA7X,LA7FS_LA7ECH)
+124 SET LA7ACC=$PIECE(LA7PF2,"^",6)
+125 ;
+126 ; New order - add to LAB PENDING ORDERS file #69.6
+127 IF LA7OTYPE="NW"
IF LA7OK
DO NW
+128 ;
+129 QUIT
+130 ;
NW ; Create new order in LAB PENDING ORDERS file #69.6
+1 ;
+2 NEW FDA,I,LA76964,LA7DIE,LA7I,LA7IEN,LA7PATID,LA7SSITE,LA7STAT,LA7WP
+3 ;
+4 ; Get lock on 69.6
+5 ;L +^LRO(69.6,0):99999
+6 DO LOCK^DILF("^LRO(69.6,0)")
+7 IF '$TEST
SET LA7AERR=$$CREATE^LA7LOG(31,1)
QUIT
+8 ;
+9 SET LA7696=$ORDER(^LRO(69.6,"AD",$SELECT($PIECE(LA7SM,"^",2)'="":$PIECE(LA7SM,"^",2),1:0),LA7SID,0))
+10 ;
+11 ; Find "In-Transit" status in #64.061
+12 SET LA7STAT=$$FIND1^DIC(64.061,"","OMX","In-Transit","","I $P(^LAB(64.061,Y,0),U,7)=""U""")
+13 ;
+14 ; Create entry in LAB PENDING ORDER ENTRY file, log error if not added
+15 IF $GET(LA7696)'>0
Begin DoDot:1
+16 SET FDA(1,69.6,"+1,",.01)=LA7PNM
+17 SET FDA(1,69.6,"+1,",6)=LA7STAT
+18 DO UPDATE^DIE("","FDA(1)","LA7IEN","LA7DIE(1)")
+19 SET LA7696=LA7IEN(1)
+20 IF LA7696<1
SET LA7AERR=$$CREATE^LA7LOG(32,1)
End DoDot:1
+21 ;
+22 LOCK -^LRO(69.6,0)
+23 IF LA7696<1
QUIT
+24 ;
+25 ;L +^LRO(69.6,LA7696):99999
+26 DO LOCK^DILF("^LRO(69.6,LA7696)")
+27 ;cannot get lock on ENTRY in 69.6
IF '$TEST
Begin DoDot:1
+28 SET LA7AERR=$$CREATE^LA7LOG(33,1)
End DoDot:1
QUIT
+29 ;
+30 ; Prevent duplication of tests
+31 IF $DATA(^LRO(69.6,LA7696,2,"C",LA7OTSTN))
DO UNLOCK
QUIT
+32 ;
+33 ; Determine entry in INSTITUTION file (#4) that's the sending site.
+34 SET LA7SSITE=$$FINDSITE^LA7VHLU2(LA7SFAC,2,0)
+35 ;
+36 ; Patient id to store with order
+37 SET LA7PATID=LA7SSN
+38 IF LA7PATID=""
Begin DoDot:1
+39 SET LA7PATID=$PIECE($GET(LA7PTID3(1)),$EXTRACT(LA7ECH))
+40 IF LA7PATID'=""
QUIT
+41 IF LA7PTID4'=""
SET LA7PATID=$PIECE($PIECE(LA7PTID4,$EXTRACT(LA7ECH,2)),$EXTRACT(LA7ECH))
+42 IF LA7PATID'=""
QUIT
+43 IF LA7PTID2'=""
SET LA7PATID=$PIECE(LA7PTID2,$EXTRACT(LA7ECH))
End DoDot:1
+44 ;
+45 SET FDA(2,69.6,LA7696_",",.01)=LA7PNM
+46 SET FDA(2,69.6,LA7696_",",.02)=LA7SEX
+47 SET FDA(2,69.6,LA7696_",",.03)=LA7DOB
+48 IF $GET(LA7PRACE)'=""
SET FDA(2,69.6,LA7696_",",.06)=LA7PRACE
+49 SET FDA(2,69.6,LA7696_",",.09)=LA7PATID
+50 SET FDA(2,69.6,LA7696_",",1)=LA7SSITE
+51 SET FDA(2,69.6,LA7696_",",2)=LA7CSITE
+52 SET FDA(2,69.6,LA7696_",",3)=LA7SID
+53 SET FDA(2,69.6,LA7696_",",3.2)=LA7ACC
+54 IF LA761
SET FDA(2,69.6,LA7696_",",4)=LA761
+55 IF LA762
SET FDA(2,69.6,LA7696_",",5)=LA762
+56 SET FDA(2,69.6,LA7696_",",10)=LA7ORDT
+57 SET FDA(2,69.6,LA7696_",",11)=LA7CDT
+58 SET FDA(2,69.6,LA7696_",",11.1)=LA7CEDT
+59 SET FDA(2,69.6,LA7696_",",14)=LA7MEDT
+60 SET FDA(2,69.6,LA7696_",",17)=LA7MID
+61 IF $PIECE(LA7SM,"^",2)'=""
SET LA7X=$PIECE(LA7SM,"^",2)
+62 IF '$TEST
SET LA7X=LA7SFAC_"-"_$EXTRACT($$FMTHL7^XLFDT(LA7MEDT),1,8)
+63 SET FDA(2,69.6,LA7696_",",18)=LA7X
+64 SET FDA(2,69.6,LA7696_",",700)=LA7FS_LA7ECH
+65 IF LA7PTID3'=""
SET FDA(2,69.6,LA7696_",",700.02)=LA7PTID3
+66 IF LA7PTID4'=""
SET FDA(2,69.6,LA7696_",",700.04)=LA7PTID4
+67 DO FILE^DIE("","FDA(2)","LA7DIE(2)")
+68 ;
+69 ; Add test to order
+70 SET FDA(3,69.64,"+2,"_LA7696_",",.01)=LA7OTST
+71 SET FDA(3,69.64,"+2,"_LA7696_",",1)=LA7OTSTN
+72 SET FDA(3,69.64,"+2,"_LA7696_",",2)=RTST
+73 SET FDA(3,69.64,"+2,"_LA7696_",",3)=RTSTN
+74 SET FDA(3,69.64,"+2,"_LA7696_",",4)=LA7UR
+75 IF LA760
SET FDA(3,69.64,"+2,"_LA7696_",",11)=LA760
+76 IF LA76205
SET FDA(3,69.64,"+2,"_LA7696_",",12)=LA76205
+77 IF $PIECE(LA7POP,"^",3)'=""
SET FDA(3,69.64,"+2,"_LA7696_",",13)=$PIECE(LA7POP,"^",3)
+78 IF LA7OBR4'=""
SET FDA(3,69.64,"+2,"_LA7696_",",700.04)=LA7OBR4
+79 IF LA7PF1'=""
SET FDA(3,69.64,"+2,"_LA7696_",",700.18)=LA7PF1
+80 IF LA7PF2'=""
SET FDA(3,69.64,"+2,"_LA7696_",",700.19)=LA7PF2
+81 DO UPDATE^DIE("","FDA(3)","LA76964","LA7DIE(3)")
+82 ;
+83 ; If no test status - set to In-transit.
+84 IF $GET(LA76964(2))
IF $PIECE($GET(^LRO(69.6,LA7696,2,LA76964(2),0)),"^",6)=""
Begin DoDot:1
+85 SET FDA(4,69.64,LA76964(2)_","_LA7696_",",5)=LA7STAT
+86 DO FILE^DIE("","FDA(4)","LA7DIE(4)")
End DoDot:1
+87 ;
+88 ; Check for comments to store with order.
+89 ; Begin sections with <space> to avoid FM word wrap.
+90 SET LA7I=1
+91 IF 'LA760
SET LA7WP(LA7I,0)="For test "_LA7OTST
+92 IF '$TEST
SET LA7WP(LA7I,0)="For test "_$$GET1^DIQ(60,LA760_",",.01)
+93 ;
+94 IF LA7SAC'=""
SET LA7I=LA7I+1
SET LA7WP(LA7I,0)=" "_LA7SAC
+95 ;
+96 IF LA7DCODE'=""
FOR I=1:250:$LENGTH(LA7DCODE)
SET LA7I=LA7I+1
SET LA7WP(LA7I,0)=$SELECT(I=1:" ",1:"")_$EXTRACT(LA7DCODE,I,I+249)
+97 ;
+98 IF LA7RCI'=""
FOR I=1:250:$LENGTH(LA7RCI)
SET LA7I=LA7I+1
SET LA7WP(LA7I,0)=$SELECT(I=1:" ",1:"")_$EXTRACT(LA7RCI,I,I+249)
+99 ;
+100 IF LA760
IF "MISPCYEM"[$PIECE(^LAB(60,LA760,0),"^",4)
Begin DoDot:1
+101 SET LA7I=LA7I+1
SET LA7WP(LA7I,0)=" Specimen source: "
+102 FOR I=1,4
IF $GET(LA7SPTY(I))'=""
SET LA7WP(LA7I,0)=LA7WP(LA7I,0)_$GET(LA7SPTY(I+1))_" ["_$GET(LA7SPTY(I))_":"_$GET(LA7SPTY(I+2))_"]"_$SELECT(I=1:" ; ",1:"")
+103 SET LA7I=LA7I+1
SET LA7WP(LA7I,0)=" Collection sample: "
+104 FOR I=1,4
IF $GET(LA7CSTY(I))'=""
SET LA7WP(LA7I,0)=LA7WP(LA7I,0)_$GET(LA7CSTY(I+1))_" ["_$GET(LA7CSTY(I))_":"_$GET(LA7CSTY(I+2))_"]"_$SELECT(I=1:" ; ",1:"")
End DoDot:1
+105 ;
+106 IF $ORDER(LA7WP(1))
DO WP^DIE(69.6,LA7696_",",99,"A","LA7WP","LA7DIE(99)")
+107 ;
+108 DO CLEAN^DILF
+109 DO UNLOCK
+110 QUIT
+111 ;
UNLOCK ; unlock entry in file #69.6
+1 LOCK -^LRO(69.6,LA7696)
+2 QUIT
