LA7SMU2 ;DALOI/JMC - Shipping Manifest Utility (Cont'd) ; 18 Nov 2014 4:20 PM
;;5.2;AUTOMATED LAB INSTRUMENTS;**46,64,74,80,85**;Sep 27, 1994;Build 4
;
Q
;
; ZEXCEPT is used to identify variables which are external to a specific TAG
; used in conjunction with Eclipse M-editor.
;
DTTO(LA7SCFG,LA7VNLT,LA7HLSC,LA7HLPRI,LA7HLCSC) ; Determine test to order
; Call with LA7SCFG = ien of Shipping Configuration file #62.9
; LA7VNLT = NLT code or non-VA test code (pass by reference)
; LA7HLSC = Specimen Code (pass by reference)
; LA7HLPRI = HL7 Priority Code
; LA7HLCSC = Collection sample (pass by reference)
;
; Returns LA7X = 0^0^0^0^^^ (if unsuccessful)
; LABORATORY TEST (ien file #60)^TOPOGRAPHY (ien file #61)^COLLECTION SAMPLE (ien file #62)^URGENCY (ien file #62.05)^NLT TEST CODE^NLT TEST NAME
;
N I,J,K,L,LA760,LA7X,X,Y,Z
;
; Make sure variables initialized.
S LA7X="0^0^0^0^^^"
I LA7VNLT="" Q LA7X
S LA7SCFG=+$G(LA7SCFG)
I LA7HLPRI="" S LA7HLPRI="R"
;
; If coding systems not defined then assume HL7 Table 0070 and VA NLT file
; Also check for SCT override codes
F I=1,4 D
. I $G(LA7HLSC(I))'="" D
. . I $G(LA7HLSC(I+2))="" S LA7HLSC(I+2)="HL70070"
. . I LA7HLSC(I+2)="SCT",$G(LA76248) S LA7HLSC(I)=$$CHKSCT(LA7HLSC(I),61,LA76248)
. I $G(LA7VNLT(I))'="" D
. . I $G(LA7VNLT(I+2))="" S LA7VNLT(I+2)="L"
. . I $G(LA7VNLT(I+2))="L",$P(^LAHM(62.9,LA7SCFG,0),"^",15)=0 S LA7VNLT(I+2)="99VA64"
. I $G(LA7HLCSC(I))'="" D
. . I $G(LA7HLCSC(I+2))="" S LA7HLCSC(I+2)="L"
. . I LA7HLCSC(I+2)="SCT",$G(LA76248) S LA7HLCSC(I)=$$CHKSCT(LA7HLCSC(I),62,LA76248)
;
; Build index of tests if not previously done for this session.
I '$D(^TMP("LA7TC",$J,LA7SCFG)) D BINDX^LA7SMU2A
;
; Lookup test/specimen/priority/collection sample mapping
F I=1,4 D Q:LA7X
. I $G(LA7VNLT(I))="" Q
. F J=1,4 D Q:LA7X
. . I $G(LA7HLSC(J))="" Q
. . F K=1,4 D Q:LA7X
. . . F L=LA7HLPRI,0 D Q:LA7X
. . . . I $G(LA7HLCSC(K))="" Q
. . . . S X=$G(^TMP("LA7TC",$J,LA7SCFG,LA7VNLT(I+2),LA7VNLT(I),LA7HLSC(J+2),LA7HLSC(J),L,LA7HLCSC(K+2),LA7HLCSC(K)))
. . . . I X S LA7X=X
. . . I LA7X Q
. . . S X=$G(^TMP("LA7TC",$J,LA7SCFG,LA7VNLT(I+2),LA7VNLT(I),LA7HLSC(J+2),LA7HLSC(J),LA7HLPRI))
. . . I X S LA7X=X
. . I LA7X Q
. . S X=$G(^TMP("LA7TC",$J,LA7SCFG,LA7VNLT(I+2),LA7VNLT(I),LA7HLSC(J+2),LA7HLSC(J)))
. . I X S LA7X=X
. I LA7X Q
. F K=1,4 D Q:LA7X
. . F L=LA7HLPRI,0 D Q:LA7X
. . . I $G(LA7HLCSC(K))="" Q
. . . S X=$G(^TMP("LA7TC",$J,LA7SCFG,LA7VNLT(I+2),LA7VNLT(I),0,0,L,LA7HLCSC(K+2),LA7HLCSC(K)))
. . . I X,$P(^LAB(60,$P(X,"^"),0),"^",4)="MI" S LA7X=X Q
. . . S X=$G(^TMP("LA7TC",$J,LA7SCFG,LA7VNLT(I+2),LA7VNLT(I),"HL70070","XXX",L,LA7HLCSC(K+2),LA7HLCSC(K)))
. . . I X,"SPCYEM"[$P(^LAB(60,$P(X,"^"),0),"^",4) S LA7X=X
. I LA7X Q
. S X=$G(^TMP("LA7TC",$J,LA7SCFG,LA7VNLT(I+2),LA7VNLT(I),0,0,0,0,0))
. I X S LA7X=X
;
; If SCT specimen from message does not match SCT assigned to specimen from above
; then set specimen to 0.
I $P(LA7X,"^"),$P(LA7X,"^",2) D
. F J=1,4 I $G(LA7HLSC(J+2))="SCT" D Q
. . N LA7SCTID
. . S LA7SCTID=$$GET1^DIQ(61,$P(LA7X,"^",2)_",",20,"I")
. . I LA7SCTID'="",LA7SCTID'=LA7HLSC(J) D
. . . S $P(LA7X,"^",2)=0
;
; If SCT collection sample from message does not match SCT assigned to collection sample from above
; then set collection sample to 0.
I $P(LA7X,"^"),$P(LA7X,"^",3) D
. F J=1,4 I $G(LA7HLCSC(J+2))="SCT" D Q
. . N LA7SCTID
. . S LA7SCTID=$$GET1^DIQ(62,$P(LA7X,"^",3)_",",20,"I")
. . I LA7SCTID'="",LA7SCTID'=LA7HLCSC(J) D
. . . S $P(LA7X,"^",3)=0
;
; For MI, SP, CY and EM find first specimen when collection sample is not mapped to a specific topography.
; For SP, CY and EM if no specimen then find first specimen mapped to HL7 0070 "XXX".
I $P(LA7X,"^"),'$P(LA7X,"^",2),$P(^LAB(60,$P(LA7X,"^"),0),"^",4)?1(1"MI",1"SP",1"CY",1"EM") D
. S X=""
. F J=1,4 D Q:$P(LA7X,"^",2)
. . I $G(LA7HLSC(J+2))="SCT" D
. . . S X=$O(^LAB(61,"F",LA7HLSC(J),""))
. . . I 'X S X=+$$FINDSCT(61,LA7HLSC(J),LA7HLSC(J+1))
. . I $G(LA7HLSC(J+2))="HL70070" S X=$O(^LAB(61,"HL7",LA7HLSC(J),0))
. . I X>0 S $P(LA7X,"^",2)=X
. I '$P(LA7X,"^",2),$P(^LAB(60,$P(LA7X,"^"),0),"^",4)?1(1"SP",1"CY",1"EM") D
. . S X=$O(^LAB(61,"HL7","XXX",0))
. . I X>0 S $P(LA7X,"^",2)=X
;
; For MI, SP, CY, and EM find first collection sample when no collection sample.
I $P(LA7X,"^"),'$P(LA7X,"^",3),$P(^LAB(60,$P(LA7X,"^"),0),"^",4)?1(1"MI",1"SP",1"CY",1"EM") D
. S X=""
. F J=1,4 D Q:$P(LA7X,"^",3)
. . I $G(LA7HLCSC(J+2))="SCT" D
. . . S X=$O(^LAB(62,"F",LA7HLCSC(J),""))
. . . I 'X S X=+$$FINDSCT(62,LA7HLCSC(J),LA7HLCSC(J+1))
. . I X>0 S $P(LA7X,"^",3)=X
;
; No urgency mapping, get last using this HL7 code or site's default urgency from #69.9
; Find highest non-workload urgency using this priority code else use site's default
I '$P(LA7X,"^",4) D
. S X=$O(^LAB(62.05,"HL7",LA7HLPRI,50),-1)
. I X S $P(LA7X,"^",4)=X
. E S $P(LA7X,"^",4)=+$P($G(^LAB(69.9,1,3)),"^",2)
;
; Check file #60 forced and highest urgency.
I $P(LA7X,"^"),$P(LA7X,"^",4) D
. S X=$G(^LAB(60,$P(LA7X,"^"),0))
. I $P(X,"^",18) S $P(LA7X,"^",4)=$P(X,"^",18) Q
. I $P(X,"^",16),$P(LA7X,"^",4)<$P(X,"^",16) S $P(LA7X,"^",4)=$P(X,"^",16)
;
Q LA7X
;
;
CHKCDSYS(LA7SRC,LA7DEST,LA7CSET,LA7CS) ; Check coding system order on CE/CNE/CWE data types
; Call with LA7SRC = source array by reference
; LA7DEST = destination array by reference
; LA7CSET = code set to move to primary
; LA7CS = component separator
;
; Returns by reference array LA7DEST
;
; If code set in alternate then switch primary and alternate
;
K LA7DEST
;
I $G(LA7SRC(6))'=LA7CSET M LA7DEST=LA7SRC Q
;
N J
F J=1,2,3 D
. S LA7DEST(J)=$G(LA7SRC(J+3)),LA7DEST(J+3)=$G(LA7SRC(J))
. I LA7SRC'="" S $P(LA7DEST,LA7CS,J)=$P(LA7SRC,LA7CS,J+3),$P(LA7DEST,LA7CS,J+3)=$P(LA7SRC,LA7CS,J)
S LA7DEST(7)=$G(LA7SRC(8)),LA7DEST(8)=$G(LA7SRC(7)),LA7DEST(9)=$G(LA7SRC(9))
I $G(LA7SRC)'="" S $P(LA7DEST,LA7CS,7)=$P(LA7SRC,LA7CS,8),$P(LA7DEST,LA7CS,8)=$P(LA7SRC,LA7CS,7),$P(LA7DEST,LA7CS,9)=$P(LA7SRC,LA7CS,9)
;
Q
;
;
CHKSCT(LA7CODE,LA7FILE,LA76248) ;Check for SCT override (substitute).
; Call with LA7CODE = SCT ID code
; LA7FILE = file number of target file (61/62)
; LA76248 = IEN of file #62.48 message configuration
;
; Returns LA7CODE = original or override (substitute) SCT code
;
N LA7X,LA7Y
S LA7X=""
;
I LA7FILE=61,LA76248 S LA7X=$O(^LAHM(62.48,LA76248,"SCT","AD1",LA7CODE,""))
I LA7FILE=62,LA76248 S LA7X=$O(^LAHM(62.48,LA76248,"SCT","AD2",LA7CODE,""))
;
I LA7X>0 D
. S LA7Y=$$IEN2SCT^LA7VHLU6(LA7FILE,LA7X,DT,"")
. I LA7Y>0 S LA7CODE=$P(LA7Y,"^")
;
Q LA7CODE
;
;
FINDSCT(LA7FILE,LA7CODE,LA7TXT) ; Lookup SCT term in Lexicon and if possible add to target file.
; Call with LA7FILE = file number of target file (61/62)
; LA7CODE = SCT ID
; LA7TXT = SCT text
;
N LA74,LA7ERROR,LAHLSEGS,LA7IEN,X,Y
;
;ZEXCEPT: LA76247,LA7CS,LA7ECH,LA7FS,LA7MID,LA7RAP,LA7RFAC,LA7SAP,LA7SFAC
;
;
S LA74=$$RESFID^LA7VHLU2(LA7SFAC,LA7SFAC,LA7CS)
S LAHLSEGS("R4")=LA74
S LAHLSEGS("R6247")=$G(LA76247)
S LAHLSEGS("FSEC")=LA7FS_LA7ECH
S LAHLSEGS("MSH",3)=LA7SAP
S LAHLSEGS("MSH",4)=LA7SFAC
S LAHLSEGS("MSH",5)=LA7RAP
S LAHLSEGS("MSH",6)=LA7RFAC
S LAHLSEGS("MSH",11)=$G(LA7MID)
S LAHLSEGS("OBX",3)=LA7CODE_LA7CS_LA7TXT_LA7CS_"SCT"
;
S LA7IEN=$$EN^LRSCTX(LA7FILE,LA7TXT,LA7CODE,.LAHLSEGS,.LA7ERROR,0)
;
Q LA7IEN
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLA7SMU2 7704 printed Nov 22, 2024@16:49:48 Page 2
LA7SMU2 ;DALOI/JMC - Shipping Manifest Utility (Cont'd) ; 18 Nov 2014 4:20 PM
+1 ;;5.2;AUTOMATED LAB INSTRUMENTS;**46,64,74,80,85**;Sep 27, 1994;Build 4
+2 ;
+3 QUIT
+4 ;
+5 ; ZEXCEPT is used to identify variables which are external to a specific TAG
+6 ; used in conjunction with Eclipse M-editor.
+7 ;
DTTO(LA7SCFG,LA7VNLT,LA7HLSC,LA7HLPRI,LA7HLCSC) ; Determine test to order
+1 ; Call with LA7SCFG = ien of Shipping Configuration file #62.9
+2 ; LA7VNLT = NLT code or non-VA test code (pass by reference)
+3 ; LA7HLSC = Specimen Code (pass by reference)
+4 ; LA7HLPRI = HL7 Priority Code
+5 ; LA7HLCSC = Collection sample (pass by reference)
+6 ;
+7 ; Returns LA7X = 0^0^0^0^^^ (if unsuccessful)
+8 ; LABORATORY TEST (ien file #60)^TOPOGRAPHY (ien file #61)^COLLECTION SAMPLE (ien file #62)^URGENCY (ien file #62.05)^NLT TEST CODE^NLT TEST NAME
+9 ;
+10 NEW I,J,K,L,LA760,LA7X,X,Y,Z
+11 ;
+12 ; Make sure variables initialized.
+13 SET LA7X="0^0^0^0^^^"
+14 IF LA7VNLT=""
QUIT LA7X
+15 SET LA7SCFG=+$GET(LA7SCFG)
+16 IF LA7HLPRI=""
SET LA7HLPRI="R"
+17 ;
+18 ; If coding systems not defined then assume HL7 Table 0070 and VA NLT file
+19 ; Also check for SCT override codes
+20 FOR I=1,4
Begin DoDot:1
+21 IF $GET(LA7HLSC(I))'=""
Begin DoDot:2
+22 IF $GET(LA7HLSC(I+2))=""
SET LA7HLSC(I+2)="HL70070"
+23 IF LA7HLSC(I+2)="SCT"
IF $GET(LA76248)
SET LA7HLSC(I)=$$CHKSCT(LA7HLSC(I),61,LA76248)
End DoDot:2
+24 IF $GET(LA7VNLT(I))'=""
Begin DoDot:2
+25 IF $GET(LA7VNLT(I+2))=""
SET LA7VNLT(I+2)="L"
+26 IF $GET(LA7VNLT(I+2))="L"
IF $PIECE(^LAHM(62.9,LA7SCFG,0),"^",15)=0
SET LA7VNLT(I+2)="99VA64"
End DoDot:2
+27 IF $GET(LA7HLCSC(I))'=""
Begin DoDot:2
+28 IF $GET(LA7HLCSC(I+2))=""
SET LA7HLCSC(I+2)="L"
+29 IF LA7HLCSC(I+2)="SCT"
IF $GET(LA76248)
SET LA7HLCSC(I)=$$CHKSCT(LA7HLCSC(I),62,LA76248)
End DoDot:2
End DoDot:1
+30 ;
+31 ; Build index of tests if not previously done for this session.
+32 IF '$DATA(^TMP("LA7TC",$JOB,LA7SCFG))
DO BINDX^LA7SMU2A
+33 ;
+34 ; Lookup test/specimen/priority/collection sample mapping
+35 FOR I=1,4
Begin DoDot:1
+36 IF $GET(LA7VNLT(I))=""
QUIT
+37 FOR J=1,4
Begin DoDot:2
+38 IF $GET(LA7HLSC(J))=""
QUIT
+39 FOR K=1,4
Begin DoDot:3
+40 FOR L=LA7HLPRI,0
Begin DoDot:4
+41 IF $GET(LA7HLCSC(K))=""
QUIT
+42 SET X=$GET(^TMP("LA7TC",$JOB,LA7SCFG,LA7VNLT(I+2),LA7VNLT(I),LA7HLSC(J+2),LA7HLSC(J),L,LA7HLCSC(K+2),LA7HLCSC(K)))
+43 IF X
SET LA7X=X
End DoDot:4
if LA7X
QUIT
+44 IF LA7X
QUIT
+45 SET X=$GET(^TMP("LA7TC",$JOB,LA7SCFG,LA7VNLT(I+2),LA7VNLT(I),LA7HLSC(J+2),LA7HLSC(J),LA7HLPRI))
+46 IF X
SET LA7X=X
End DoDot:3
if LA7X
QUIT
+47 IF LA7X
QUIT
+48 SET X=$GET(^TMP("LA7TC",$JOB,LA7SCFG,LA7VNLT(I+2),LA7VNLT(I),LA7HLSC(J+2),LA7HLSC(J)))
+49 IF X
SET LA7X=X
End DoDot:2
if LA7X
QUIT
+50 IF LA7X
QUIT
+51 FOR K=1,4
Begin DoDot:2
+52 FOR L=LA7HLPRI,0
Begin DoDot:3
+53 IF $GET(LA7HLCSC(K))=""
QUIT
+54 SET X=$GET(^TMP("LA7TC",$JOB,LA7SCFG,LA7VNLT(I+2),LA7VNLT(I),0,0,L,LA7HLCSC(K+2),LA7HLCSC(K)))
+55 IF X
IF $PIECE(^LAB(60,$PIECE(X,"^"),0),"^",4)="MI"
SET LA7X=X
QUIT
+56 SET X=$GET(^TMP("LA7TC",$JOB,LA7SCFG,LA7VNLT(I+2),LA7VNLT(I),"HL70070","XXX",L,LA7HLCSC(K+2),LA7HLCSC(K)))
+57 IF X
IF "SPCYEM"[$PIECE(^LAB(60,$PIECE(X,"^"),0),"^",4)
SET LA7X=X
End DoDot:3
if LA7X
QUIT
End DoDot:2
if LA7X
QUIT
+58 IF LA7X
QUIT
+59 SET X=$GET(^TMP("LA7TC",$JOB,LA7SCFG,LA7VNLT(I+2),LA7VNLT(I),0,0,0,0,0))
+60 IF X
SET LA7X=X
End DoDot:1
if LA7X
QUIT
+61 ;
+62 ; If SCT specimen from message does not match SCT assigned to specimen from above
+63 ; then set specimen to 0.
+64 IF $PIECE(LA7X,"^")
IF $PIECE(LA7X,"^",2)
Begin DoDot:1
+65 FOR J=1,4
IF $GET(LA7HLSC(J+2))="SCT"
Begin DoDot:2
+66 NEW LA7SCTID
+67 SET LA7SCTID=$$GET1^DIQ(61,$PIECE(LA7X,"^",2)_",",20,"I")
+68 IF LA7SCTID'=""
IF LA7SCTID'=LA7HLSC(J)
Begin DoDot:3
+69 SET $PIECE(LA7X,"^",2)=0
End DoDot:3
End DoDot:2
QUIT
End DoDot:1
+70 ;
+71 ; If SCT collection sample from message does not match SCT assigned to collection sample from above
+72 ; then set collection sample to 0.
+73 IF $PIECE(LA7X,"^")
IF $PIECE(LA7X,"^",3)
Begin DoDot:1
+74 FOR J=1,4
IF $GET(LA7HLCSC(J+2))="SCT"
Begin DoDot:2
+75 NEW LA7SCTID
+76 SET LA7SCTID=$$GET1^DIQ(62,$PIECE(LA7X,"^",3)_",",20,"I")
+77 IF LA7SCTID'=""
IF LA7SCTID'=LA7HLCSC(J)
Begin DoDot:3
+78 SET $PIECE(LA7X,"^",3)=0
End DoDot:3
End DoDot:2
QUIT
End DoDot:1
+79 ;
+80 ; For MI, SP, CY and EM find first specimen when collection sample is not mapped to a specific topography.
+81 ; For SP, CY and EM if no specimen then find first specimen mapped to HL7 0070 "XXX".
+82 IF $PIECE(LA7X,"^")
IF '$PIECE(LA7X,"^",2)
IF $PIECE(^LAB(60,$PIECE(LA7X,"^"),0),"^",4)?1(1"MI",1"SP",1"CY",1"EM")
Begin DoDot:1
+83 SET X=""
+84 FOR J=1,4
Begin DoDot:2
+85 IF $GET(LA7HLSC(J+2))="SCT"
Begin DoDot:3
+86 SET X=$ORDER(^LAB(61,"F",LA7HLSC(J),""))
+87 IF 'X
SET X=+$$FINDSCT(61,LA7HLSC(J),LA7HLSC(J+1))
End DoDot:3
+88 IF $GET(LA7HLSC(J+2))="HL70070"
SET X=$ORDER(^LAB(61,"HL7",LA7HLSC(J),0))
+89 IF X>0
SET $PIECE(LA7X,"^",2)=X
End DoDot:2
if $PIECE(LA7X,"^",2)
QUIT
+90 IF '$PIECE(LA7X,"^",2)
IF $PIECE(^LAB(60,$PIECE(LA7X,"^"),0),"^",4)?1(1"SP",1"CY",1"EM")
Begin DoDot:2
+91 SET X=$ORDER(^LAB(61,"HL7","XXX",0))
+92 IF X>0
SET $PIECE(LA7X,"^",2)=X
End DoDot:2
End DoDot:1
+93 ;
+94 ; For MI, SP, CY, and EM find first collection sample when no collection sample.
+95 IF $PIECE(LA7X,"^")
IF '$PIECE(LA7X,"^",3)
IF $PIECE(^LAB(60,$PIECE(LA7X,"^"),0),"^",4)?1(1"MI",1"SP",1"CY",1"EM")
Begin DoDot:1
+96 SET X=""
+97 FOR J=1,4
Begin DoDot:2
+98 IF $GET(LA7HLCSC(J+2))="SCT"
Begin DoDot:3
+99 SET X=$ORDER(^LAB(62,"F",LA7HLCSC(J),""))
+100 IF 'X
SET X=+$$FINDSCT(62,LA7HLCSC(J),LA7HLCSC(J+1))
End DoDot:3
+101 IF X>0
SET $PIECE(LA7X,"^",3)=X
End DoDot:2
if $PIECE(LA7X,"^",3)
QUIT
End DoDot:1
+102 ;
+103 ; No urgency mapping, get last using this HL7 code or site's default urgency from #69.9
+104 ; Find highest non-workload urgency using this priority code else use site's default
+105 IF '$PIECE(LA7X,"^",4)
Begin DoDot:1
+106 SET X=$ORDER(^LAB(62.05,"HL7",LA7HLPRI,50),-1)
+107 IF X
SET $PIECE(LA7X,"^",4)=X
+108 IF '$TEST
SET $PIECE(LA7X,"^",4)=+$PIECE($GET(^LAB(69.9,1,3)),"^",2)
End DoDot:1
+109 ;
+110 ; Check file #60 forced and highest urgency.
+111 IF $PIECE(LA7X,"^")
IF $PIECE(LA7X,"^",4)
Begin DoDot:1
+112 SET X=$GET(^LAB(60,$PIECE(LA7X,"^"),0))
+113 IF $PIECE(X,"^",18)
SET $PIECE(LA7X,"^",4)=$PIECE(X,"^",18)
QUIT
+114 IF $PIECE(X,"^",16)
IF $PIECE(LA7X,"^",4)<$PIECE(X,"^",16)
SET $PIECE(LA7X,"^",4)=$PIECE(X,"^",16)
End DoDot:1
+115 ;
+116 QUIT LA7X
+117 ;
+118 ;
CHKCDSYS(LA7SRC,LA7DEST,LA7CSET,LA7CS) ; Check coding system order on CE/CNE/CWE data types
+1 ; Call with LA7SRC = source array by reference
+2 ; LA7DEST = destination array by reference
+3 ; LA7CSET = code set to move to primary
+4 ; LA7CS = component separator
+5 ;
+6 ; Returns by reference array LA7DEST
+7 ;
+8 ; If code set in alternate then switch primary and alternate
+9 ;
+10 KILL LA7DEST
+11 ;
+12 IF $GET(LA7SRC(6))'=LA7CSET
MERGE LA7DEST=LA7SRC
QUIT
+13 ;
+14 NEW J
+15 FOR J=1,2,3
Begin DoDot:1
+16 SET LA7DEST(J)=$GET(LA7SRC(J+3))
SET LA7DEST(J+3)=$GET(LA7SRC(J))
+17 IF LA7SRC'=""
SET $PIECE(LA7DEST,LA7CS,J)=$PIECE(LA7SRC,LA7CS,J+3)
SET $PIECE(LA7DEST,LA7CS,J+3)=$PIECE(LA7SRC,LA7CS,J)
End DoDot:1
+18 SET LA7DEST(7)=$GET(LA7SRC(8))
SET LA7DEST(8)=$GET(LA7SRC(7))
SET LA7DEST(9)=$GET(LA7SRC(9))
+19 IF $GET(LA7SRC)'=""
SET $PIECE(LA7DEST,LA7CS,7)=$PIECE(LA7SRC,LA7CS,8)
SET $PIECE(LA7DEST,LA7CS,8)=$PIECE(LA7SRC,LA7CS,7)
SET $PIECE(LA7DEST,LA7CS,9)=$PIECE(LA7SRC,LA7CS,9)
+20 ;
+21 QUIT
+22 ;
+23 ;
CHKSCT(LA7CODE,LA7FILE,LA76248) ;Check for SCT override (substitute).
+1 ; Call with LA7CODE = SCT ID code
+2 ; LA7FILE = file number of target file (61/62)
+3 ; LA76248 = IEN of file #62.48 message configuration
+4 ;
+5 ; Returns LA7CODE = original or override (substitute) SCT code
+6 ;
+7 NEW LA7X,LA7Y
+8 SET LA7X=""
+9 ;
+10 IF LA7FILE=61
IF LA76248
SET LA7X=$ORDER(^LAHM(62.48,LA76248,"SCT","AD1",LA7CODE,""))
+11 IF LA7FILE=62
IF LA76248
SET LA7X=$ORDER(^LAHM(62.48,LA76248,"SCT","AD2",LA7CODE,""))
+12 ;
+13 IF LA7X>0
Begin DoDot:1
+14 SET LA7Y=$$IEN2SCT^LA7VHLU6(LA7FILE,LA7X,DT,"")
+15 IF LA7Y>0
SET LA7CODE=$PIECE(LA7Y,"^")
End DoDot:1
+16 ;
+17 QUIT LA7CODE
+18 ;
+19 ;
FINDSCT(LA7FILE,LA7CODE,LA7TXT) ; Lookup SCT term in Lexicon and if possible add to target file.
+1 ; Call with LA7FILE = file number of target file (61/62)
+2 ; LA7CODE = SCT ID
+3 ; LA7TXT = SCT text
+4 ;
+5 NEW LA74,LA7ERROR,LAHLSEGS,LA7IEN,X,Y
+6 ;
+7 ;ZEXCEPT: LA76247,LA7CS,LA7ECH,LA7FS,LA7MID,LA7RAP,LA7RFAC,LA7SAP,LA7SFAC
+8 ;
+9 ;
+10 SET LA74=$$RESFID^LA7VHLU2(LA7SFAC,LA7SFAC,LA7CS)
+11 SET LAHLSEGS("R4")=LA74
+12 SET LAHLSEGS("R6247")=$GET(LA76247)
+13 SET LAHLSEGS("FSEC")=LA7FS_LA7ECH
+14 SET LAHLSEGS("MSH",3)=LA7SAP
+15 SET LAHLSEGS("MSH",4)=LA7SFAC
+16 SET LAHLSEGS("MSH",5)=LA7RAP
+17 SET LAHLSEGS("MSH",6)=LA7RFAC
+18 SET LAHLSEGS("MSH",11)=$GET(LA7MID)
+19 SET LAHLSEGS("OBX",3)=LA7CODE_LA7CS_LA7TXT_LA7CS_"SCT"
+20 ;
+21 SET LA7IEN=$$EN^LRSCTX(LA7FILE,LA7TXT,LA7CODE,.LAHLSEGS,.LA7ERROR,0)
+22 ;
+23 QUIT LA7IEN
