LA7VOBX2 ;DALOI/JMC - LAB OBX Segment message builder (AP subscripts) cont'd ;10/20/10 10:21
;;5.2;AUTOMATED LAB INSTRUMENTS;**46,64,68,74**;Sep 27, 1994;Build 229
;
AP ; Build OBX segments for results that are anatomic/surgical pathology subscripts
; Called by LA7VOBX
;
;ZEXCEPT: LA,LA76248,LA7ARRAY,LA7ECH,LA7FS,LA7INTYP,LA7NVAF,LA7OBX,LA7OBXSN,LRDFN,LRIDT,LRSB,LRSS
;
N I,LA7953,LA7ACODE,LA7CODE,LA7DIV,LA7IENS,LA7OBX5,LA7OBX5M,LA7NLT,LA7SUB,LA7SUBFL,LA7VP,LA7WP,LA7X,LA7Y
;
S (LA7953,LA7DIV,LA7VP)=""
;
; Surgical pathology subscript
I LRSS="SP" S LA7SUBFL=63.08
;
; Cytology subscript
I LRSS="CY" S LA7SUBFL=63.09
;
; Electron microscopy subscript
I LRSS="EM" S LA7SUBFL=63.02
;
S LA7IENS=""
F I=3:-1:1 I $P(LRIDT,",",I) S LRIDT(I)=$P(LRIDT,",",I),LA7IENS=LA7IENS_LRIDT(I)_","
S LA7IENS=LA7IENS_LRDFN_","
S LRIDT=$P(LRIDT,",")
S LA7SUB(0)=$G(^LR(LRDFN,LRSS,LRIDT,0))
;
; Get default codes
S LA7NLT=$G(LA("NLT")),LA7CODE=LA7NLT_"!"
S LA7CODE=$$DEFCODE^LA7VHLU5(LRSS,LRSB,LA7CODE,"")
;
; Initialize OBX segment
S LA7OBX(0)="OBX"
;
; Value type
S LA7X=LA7SUBFL,LA7Y=LRSB
I LRSB=1.2 S LA7X=$S(LRSS="SP":63.817,LRSS="CY":63.907,LRSS="EM":63.207,1:""),LA7Y=1
I LRSB="10,1.5" S LA7X=$S(LRSS="SP":63.82,LRSS="CY":63.982,LRSS="EM":63.282,1:""),LA7Y=.01
I LRSB="10,2",LRSS="SP" S LA7X=63.12,LA7Y=2
I LRSB="10,5" S LA7X=$S(LRSS="SP":63.819,LRSS="CY":63.919,LRSS="EM":63.219,1:""),LA7Y=1
S LA7OBX(2)=$$OBX2^LA7VOBX(LA7X,LA7Y)
;
; Observation identifier
S LA7OBX(3)=$$OBX3^LA7VOBX($P(LA7CODE,"!",2),$P(LA7CODE,"!",3),"",LA7FS,LA7ECH,$G(LA7INTYP))
;
; Observation sub-ID - create sub-ID for specimens, supplementary reports and special studies
D SUBID
;
; Build result field
; Check for substitute SNOMED CT on topography
I $P(LRSB,",")=.012 D
. N LA761,LA7J,LA7X,LA7Y,LA7Z,X
. S LA7J=1,LA7X=$G(^LR(LRDFN,LRSS,LRIDT,.1,LRIDT(2),0)),LA7Y=""
. S LA7Z=$O(^LAHM(62.48,LA76248,"SCT","AC",$P(LA7X,"^",6)_";LAB(61,",""))
. S LA761=+$P(LA7X,"^",6)
. I LA761 S LA761(0)=$P($G(^LAB(61,LA761,0)),"^")
. I $P(LRSB,",",2)="",LA761 D
. . S X=$$IEN2SCT^LA7VHLU6(61,LA761,DT,LA7Z)
. . I X>0 S $P(LA7Y,"^",LA7J,LA7J+2)=$P(X,"^",1,3),$P(LA7Y,"^",$S(LA7J=1:7,1:8))=$P(X,"^",4),LA7J=4
. . S $P(LA7Y,"^",LA7J)=LA761,$P(LA7Y,"^",LA7J+1)=LA761(0),$P(LA7Y,"^",LA7J+2)="99VA61",$P(LA7Y,"^",$S(LA7J=1:7,1:8))="5.2"
. . S $P(LA7Y,"^",9)=$P(LA7X,"^")
. . S LA7OBX(2)="CWE"
. I $P(LRSB,",",2)=.01 S LA7Y=$P(LA7X,"^"),LA7OBX(2)="ST"
. I $P(LRSB,",",2)=.06,LA761 D
. . S X=$$IEN2SCT^LA7VHLU6(61,LA761,DT,LA7Z)
. . I X>0 S $P(LA7Y,"^",LA7J,LA7J+2)=$P(X,"^",1,3),$P(LA7Y,"^",$S(LA7J=1:7,1:8))=$P(X,"^",4),LA7J=4
. . S $P(LA7Y,"^",LA7J)=LA761,$P(LA7Y,"^",LA7J+1)=LA761(0),$P(LA7Y,"^",LA7J+2)="99VA61",$P(LA7Y,"^",$S(LA7J=1:7,1:8))="5.2"
. . S $P(LA7Y,"^",9)=$P(LA7X,"^")
. . S LA7OBX(2)="CWE"
. I LA7Y'="" S LA7OBX(5)=$$OBX5^LA7VOBX(LA7Y,LA7OBX(2),LA7FS,LA7ECH)
;
I $P(LRSB,",")'=.012 D
. I $P(LRSB,",")=10,LRSB'="10,5" Q
. I LA7NVAF=1 D DOD Q
. I LRSB=1.2 N LRSB S LA7SUBFL=$S(LRSS="SP":63.817,LRSS="CY":63.907,LRSS="EM":63.207,1:""),LRSB=1
. I LRSB="10,5" N LRSB S LA7SUBFL=$S(LRSS="SP":63.819,LRSS="CY":63.919,LRSS="EM":63.219,1:""),LRSB=1
. D OBX5M^LA7VOBX(LA7SUBFL,LA7IENS,LRSB,.LA7WP,LA7FS,LA7ECH)
. D BUILDSEG^LA7VHLU(.LA7WP,.LA7OBX5M,"")
. M LA7OBX(5)=LA7OBX5M
;
I $P(LRSB,",")=10,LRSB'="10,5" D
. N LA7VAL,LA7SUBFL,LA7X,X
. I LRSS="SP",LRSB="10,2" D Q
. . S LA7VAL=$$GET1^DIQ(63.12,LA7IENS,2)
. . S LA7OBX(5)=$$OBX5^LA7VOBX(LA7VAL,LA7OBX(2),LA7FS,LA7ECH)
. . S LA7OBX(6)=$$OBX6^LA7VOBX("g","",LA7FS,LA7ECH,$G(LA7INTYP))
. I LRSB=10 S LA7SUBFL=$S(LRSS="SP":63.12,LRSS="CY":63.912,LRSS="EM":63.212,1:"")
. I LRSB="10,1.5" S LA7SUBFL=$S(LRSS="SP":63.82,LRSS="CY":63.982,LRSS="EM":63.282,1:"")
. S LA7VAL=$$GET1^DIQ(LA7SUBFL,LA7IENS,.01)
. S LA7X=$$GET1^DIQ(LA7SUBFL,LA7IENS,".01","I")
. I LA7X'="" D
. . S X=$$IEN2SCT^LA7VHLU6(61,LA7X,DT,"")
. . I X>0 S LA7VAL=$P(X,"^",1,3),$P(LA7VAL,"^",7)=$P(X,"^",4),LA7OBX(2)="CWE"
. S LA7OBX(5)=$$OBX5^LA7VOBX(LA7VAL,LA7OBX(2),LA7FS,LA7ECH)
;
; Don't build this segment if no results/value to send
I $G(LA7OBX(5,0))="",$G(LA7OBX(5))="" Q
;
; Build sequence id
S LA7OBX(1)=$$OBX1^LA7VOBX(.LA7OBXSN)
;
; "P"artial, "F"inal , "A"mended results
; If not release date then pending
I '$P(LA7SUB(0),"^",11) D
. I LA7NVAF=1 S LA7OBX(11)="I" Q
. S LA7OBX(11)="P"
;
; If release date then check for changes
I $P(LA7SUB(0),"^",11) D
. I $P(LA7SUB(0),"^",15) S LA7OBX(11)="C"
. E S LA7OBX(11)="F"
;
; Observation date/time - collection date/time per HL7 standard
I $P(LA7SUB(0),"^") S LA7OBX(14)=$$OBX14^LA7VOBX($P(LA7SUB(0),"^"))
;
S LA7DIV=$P($G(^LR(LRDFN,LRSS,LRIDT,"RF")),"^")
I $P(LA7SUB(0),"^",13),$$DIV4^XUSER(.LA7DIV,$P(LA7SUB(0),"^",2)) S LA7DIV=$O(LA7DIV(0))
;
; Facility that performed the testing
S LA7OBX(15)=$$OBX15^LA7VOBX(LA7DIV,LA7FS,LA7ECH)
;
; Person that verified the test
S LA7VP=$P(LA7SUB(0),"^",13)
I LA7VP S LA7OBX(16)=$$OBX16^LA7VOBX(LA7VP,LA7DIV,LA7FS,LA7ECH)
;
; Performing organization name/address
I LA7DIV'="" D
. N LA7DT
. S LA7OBX(23)=$$OBX23^LA7VOBX(4,LA7DIV,LA7FS,LA7ECH)
. S LA7DT=$S($P(LA7SUB(0),"^",11):$P(LA7SUB(0),"^",11),1:$$NOW^XLFDT)
. S LA7OBX(24)=$$OBX24^LA7VOBX(4,LA7DIV,LA7DT,LA7FS,LA7ECH)
;
D BUILDSEG^LA7VHLU(.LA7OBX,.LA7ARRAY,LA7FS)
;
Q
;
;
SUBID ; Build sub-id for "SP" subscript
; Used to identify supplementary reports, specimens and related special studies performed on those specimens.
;
;ZEXCEPT: LA7ECH,LA7FS,LA7IENS,LA7NVAF,LA7OBX,LRDFN,LRIDT,LRSB,LRSS
;
N LA7SUBID
;
S LA7SUBID=""
;
; Sub-id's for specimen multiple
; For DoD/CHCS convert internal entry number to alphabetic character (ASCII 64 + #)
; Create based on relative ien, not absolute. If first entry is ien 2 then sub-id is "A", 2nd entry is "B"
I $P(LRSB,",")=.012 D
. N I,J
. I LA7NVAF'=1 S LA7SUBID="SPEC-"_$P(LA7IENS,",") Q
. S I=0,J=1
. F S I=$O(^LR(LRDFN,LRSS,LRIDT,.1,I)) Q:'I!(I=$P(LA7IENS,",")) S J=J+1
. S LA7SUBID=$C(64+J)
;
; Sub-id's for supplementary reports
I LRSB=1.2 D
. I LA7NVAF=1 S LA7SUBID="1-"_$P(LA7IENS,",",2) Q
. S LA7SUBID="1-"_$P(LA7IENS,",")
;
; Sub-id's for specimens and special studies
I LRSB=10!(LRSB="10,2") S LA7SUBID="10-"_$P(LA7IENS,",")
I LRSB="10,1.5"!(LRSB="10,5") S LA7SUBID="10-"_$P(LA7IENS,",",2)_"."_$P(LA7IENS,",")
;
I LA7SUBID'="" S LA7OBX(4)=$$OBX4^LA7VOBX(LA7SUBID,LA7FS,LA7ECH)
;
Q
;
;
DOD ; Build OBX segment's to special DoD specifications.
; Send word-processing fields as series of OBX's for DoD.
; DoD cannot handle formatted text (FT) data type.
;
;ZEXCEPT: LA7ECH,LA7FS,LA7OBX,LA7VAL,LRDFN,LRIDT,LRSB,LRSS
;
N LA7SB
S LA7OBX(2)="ST",LA7SB=$S(LRSB=.013:.2,LRSB=.014:.3,LRSB=.015:.4,LRSB=.016:.5,1:LRSB)
I LA7SB'=1.2 S LA7VAL=$G(^LR(LRDFN,LRSS,LRIDT(1),LA7SB,LRIDT(2),0))
E S LA7VAL=$G(^LR(LRDFN,LRSS,LRIDT(1),LA7SB,LRIDT(2),1,LRIDT(3),0))
I LA7VAL="" S LA7VAL=" "
S LA7OBX(5)=$$OBX5^LA7VOBX(LA7VAL,LA7OBX(2),LA7FS,LA7ECH)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLA7VOBX2 7158 printed Dec 13, 2024@01:40:51 Page 2
LA7VOBX2 ;DALOI/JMC - LAB OBX Segment message builder (AP subscripts) cont'd ;10/20/10 10:21
+1 ;;5.2;AUTOMATED LAB INSTRUMENTS;**46,64,68,74**;Sep 27, 1994;Build 229
+2 ;
AP ; Build OBX segments for results that are anatomic/surgical pathology subscripts
+1 ; Called by LA7VOBX
+2 ;
+3 ;ZEXCEPT: LA,LA76248,LA7ARRAY,LA7ECH,LA7FS,LA7INTYP,LA7NVAF,LA7OBX,LA7OBXSN,LRDFN,LRIDT,LRSB,LRSS
+4 ;
+5 NEW I,LA7953,LA7ACODE,LA7CODE,LA7DIV,LA7IENS,LA7OBX5,LA7OBX5M,LA7NLT,LA7SUB,LA7SUBFL,LA7VP,LA7WP,LA7X,LA7Y
+6 ;
+7 SET (LA7953,LA7DIV,LA7VP)=""
+8 ;
+9 ; Surgical pathology subscript
+10 IF LRSS="SP"
SET LA7SUBFL=63.08
+11 ;
+12 ; Cytology subscript
+13 IF LRSS="CY"
SET LA7SUBFL=63.09
+14 ;
+15 ; Electron microscopy subscript
+16 IF LRSS="EM"
SET LA7SUBFL=63.02
+17 ;
+18 SET LA7IENS=""
+19 FOR I=3:-1:1
IF $PIECE(LRIDT,",",I)
SET LRIDT(I)=$PIECE(LRIDT,",",I)
SET LA7IENS=LA7IENS_LRIDT(I)_","
+20 SET LA7IENS=LA7IENS_LRDFN_","
+21 SET LRIDT=$PIECE(LRIDT,",")
+22 SET LA7SUB(0)=$GET(^LR(LRDFN,LRSS,LRIDT,0))
+23 ;
+24 ; Get default codes
+25 SET LA7NLT=$GET(LA("NLT"))
SET LA7CODE=LA7NLT_"!"
+26 SET LA7CODE=$$DEFCODE^LA7VHLU5(LRSS,LRSB,LA7CODE,"")
+27 ;
+28 ; Initialize OBX segment
+29 SET LA7OBX(0)="OBX"
+30 ;
+31 ; Value type
+32 SET LA7X=LA7SUBFL
SET LA7Y=LRSB
+33 IF LRSB=1.2
SET LA7X=$SELECT(LRSS="SP":63.817,LRSS="CY":63.907,LRSS="EM":63.207,1:"")
SET LA7Y=1
+34 IF LRSB="10,1.5"
SET LA7X=$SELECT(LRSS="SP":63.82,LRSS="CY":63.982,LRSS="EM":63.282,1:"")
SET LA7Y=.01
+35 IF LRSB="10,2"
IF LRSS="SP"
SET LA7X=63.12
SET LA7Y=2
+36 IF LRSB="10,5"
SET LA7X=$SELECT(LRSS="SP":63.819,LRSS="CY":63.919,LRSS="EM":63.219,1:"")
SET LA7Y=1
+37 SET LA7OBX(2)=$$OBX2^LA7VOBX(LA7X,LA7Y)
+38 ;
+39 ; Observation identifier
+40 SET LA7OBX(3)=$$OBX3^LA7VOBX($PIECE(LA7CODE,"!",2),$PIECE(LA7CODE,"!",3),"",LA7FS,LA7ECH,$GET(LA7INTYP))
+41 ;
+42 ; Observation sub-ID - create sub-ID for specimens, supplementary reports and special studies
+43 DO SUBID
+44 ;
+45 ; Build result field
+46 ; Check for substitute SNOMED CT on topography
+47 IF $PIECE(LRSB,",")=.012
Begin DoDot:1
+48 NEW LA761,LA7J,LA7X,LA7Y,LA7Z,X
+49 SET LA7J=1
SET LA7X=$GET(^LR(LRDFN,LRSS,LRIDT,.1,LRIDT(2),0))
SET LA7Y=""
+50 SET LA7Z=$ORDER(^LAHM(62.48,LA76248,"SCT","AC",$PIECE(LA7X,"^",6)_";LAB(61,",""))
+51 SET LA761=+$PIECE(LA7X,"^",6)
+52 IF LA761
SET LA761(0)=$PIECE($GET(^LAB(61,LA761,0)),"^")
+53 IF $PIECE(LRSB,",",2)=""
IF LA761
Begin DoDot:2
+54 SET X=$$IEN2SCT^LA7VHLU6(61,LA761,DT,LA7Z)
+55 IF X>0
SET $PIECE(LA7Y,"^",LA7J,LA7J+2)=$PIECE(X,"^",1,3)
SET $PIECE(LA7Y,"^",$SELECT(LA7J=1:7,1:8))=$PIECE(X,"^",4)
SET LA7J=4
+56 SET $PIECE(LA7Y,"^",LA7J)=LA761
SET $PIECE(LA7Y,"^",LA7J+1)=LA761(0)
SET $PIECE(LA7Y,"^",LA7J+2)="99VA61"
SET $PIECE(LA7Y,"^",$SELECT(LA7J=1:7,1:8))="5.2"
+57 SET $PIECE(LA7Y,"^",9)=$PIECE(LA7X,"^")
+58 SET LA7OBX(2)="CWE"
End DoDot:2
+59 IF $PIECE(LRSB,",",2)=.01
SET LA7Y=$PIECE(LA7X,"^")
SET LA7OBX(2)="ST"
+60 IF $PIECE(LRSB,",",2)=.06
IF LA761
Begin DoDot:2
+61 SET X=$$IEN2SCT^LA7VHLU6(61,LA761,DT,LA7Z)
+62 IF X>0
SET $PIECE(LA7Y,"^",LA7J,LA7J+2)=$PIECE(X,"^",1,3)
SET $PIECE(LA7Y,"^",$SELECT(LA7J=1:7,1:8))=$PIECE(X,"^",4)
SET LA7J=4
+63 SET $PIECE(LA7Y,"^",LA7J)=LA761
SET $PIECE(LA7Y,"^",LA7J+1)=LA761(0)
SET $PIECE(LA7Y,"^",LA7J+2)="99VA61"
SET $PIECE(LA7Y,"^",$SELECT(LA7J=1:7,1:8))="5.2"
+64 SET $PIECE(LA7Y,"^",9)=$PIECE(LA7X,"^")
+65 SET LA7OBX(2)="CWE"
End DoDot:2
+66 IF LA7Y'=""
SET LA7OBX(5)=$$OBX5^LA7VOBX(LA7Y,LA7OBX(2),LA7FS,LA7ECH)
End DoDot:1
+67 ;
+68 IF $PIECE(LRSB,",")'=.012
Begin DoDot:1
+69 IF $PIECE(LRSB,",")=10
IF LRSB'="10,5"
QUIT
+70 IF LA7NVAF=1
DO DOD
QUIT
+71 IF LRSB=1.2
NEW LRSB
SET LA7SUBFL=$SELECT(LRSS="SP":63.817,LRSS="CY":63.907,LRSS="EM":63.207,1:"")
SET LRSB=1
+72 IF LRSB="10,5"
NEW LRSB
SET LA7SUBFL=$SELECT(LRSS="SP":63.819,LRSS="CY":63.919,LRSS="EM":63.219,1:"")
SET LRSB=1
+73 DO OBX5M^LA7VOBX(LA7SUBFL,LA7IENS,LRSB,.LA7WP,LA7FS,LA7ECH)
+74 DO BUILDSEG^LA7VHLU(.LA7WP,.LA7OBX5M,"")
+75 MERGE LA7OBX(5)=LA7OBX5M
End DoDot:1
+76 ;
+77 IF $PIECE(LRSB,",")=10
IF LRSB'="10,5"
Begin DoDot:1
+78 NEW LA7VAL,LA7SUBFL,LA7X,X
+79 IF LRSS="SP"
IF LRSB="10,2"
Begin DoDot:2
+80 SET LA7VAL=$$GET1^DIQ(63.12,LA7IENS,2)
+81 SET LA7OBX(5)=$$OBX5^LA7VOBX(LA7VAL,LA7OBX(2),LA7FS,LA7ECH)
+82 SET LA7OBX(6)=$$OBX6^LA7VOBX("g","",LA7FS,LA7ECH,$GET(LA7INTYP))
End DoDot:2
QUIT
+83 IF LRSB=10
SET LA7SUBFL=$SELECT(LRSS="SP":63.12,LRSS="CY":63.912,LRSS="EM":63.212,1:"")
+84 IF LRSB="10,1.5"
SET LA7SUBFL=$SELECT(LRSS="SP":63.82,LRSS="CY":63.982,LRSS="EM":63.282,1:"")
+85 SET LA7VAL=$$GET1^DIQ(LA7SUBFL,LA7IENS,.01)
+86 SET LA7X=$$GET1^DIQ(LA7SUBFL,LA7IENS,".01","I")
+87 IF LA7X'=""
Begin DoDot:2
+88 SET X=$$IEN2SCT^LA7VHLU6(61,LA7X,DT,"")
+89 IF X>0
SET LA7VAL=$PIECE(X,"^",1,3)
SET $PIECE(LA7VAL,"^",7)=$PIECE(X,"^",4)
SET LA7OBX(2)="CWE"
End DoDot:2
+90 SET LA7OBX(5)=$$OBX5^LA7VOBX(LA7VAL,LA7OBX(2),LA7FS,LA7ECH)
End DoDot:1
+91 ;
+92 ; Don't build this segment if no results/value to send
+93 IF $GET(LA7OBX(5,0))=""
IF $GET(LA7OBX(5))=""
QUIT
+94 ;
+95 ; Build sequence id
+96 SET LA7OBX(1)=$$OBX1^LA7VOBX(.LA7OBXSN)
+97 ;
+98 ; "P"artial, "F"inal , "A"mended results
+99 ; If not release date then pending
+100 IF '$PIECE(LA7SUB(0),"^",11)
Begin DoDot:1
+101 IF LA7NVAF=1
SET LA7OBX(11)="I"
QUIT
+102 SET LA7OBX(11)="P"
End DoDot:1
+103 ;
+104 ; If release date then check for changes
+105 IF $PIECE(LA7SUB(0),"^",11)
Begin DoDot:1
+106 IF $PIECE(LA7SUB(0),"^",15)
SET LA7OBX(11)="C"
+107 IF '$TEST
SET LA7OBX(11)="F"
End DoDot:1
+108 ;
+109 ; Observation date/time - collection date/time per HL7 standard
+110 IF $PIECE(LA7SUB(0),"^")
SET LA7OBX(14)=$$OBX14^LA7VOBX($PIECE(LA7SUB(0),"^"))
+111 ;
+112 SET LA7DIV=$PIECE($GET(^LR(LRDFN,LRSS,LRIDT,"RF")),"^")
+113 IF $PIECE(LA7SUB(0),"^",13)
IF $$DIV4^XUSER(.LA7DIV,$PIECE(LA7SUB(0),"^",2))
SET LA7DIV=$ORDER(LA7DIV(0))
+114 ;
+115 ; Facility that performed the testing
+116 SET LA7OBX(15)=$$OBX15^LA7VOBX(LA7DIV,LA7FS,LA7ECH)
+117 ;
+118 ; Person that verified the test
+119 SET LA7VP=$PIECE(LA7SUB(0),"^",13)
+120 IF LA7VP
SET LA7OBX(16)=$$OBX16^LA7VOBX(LA7VP,LA7DIV,LA7FS,LA7ECH)
+121 ;
+122 ; Performing organization name/address
+123 IF LA7DIV'=""
Begin DoDot:1
+124 NEW LA7DT
+125 SET LA7OBX(23)=$$OBX23^LA7VOBX(4,LA7DIV,LA7FS,LA7ECH)
+126 SET LA7DT=$SELECT($PIECE(LA7SUB(0),"^",11):$PIECE(LA7SUB(0),"^",11),1:$$NOW^XLFDT)
+127 SET LA7OBX(24)=$$OBX24^LA7VOBX(4,LA7DIV,LA7DT,LA7FS,LA7ECH)
End DoDot:1
+128 ;
+129 DO BUILDSEG^LA7VHLU(.LA7OBX,.LA7ARRAY,LA7FS)
+130 ;
+131 QUIT
+132 ;
+133 ;
SUBID ; Build sub-id for "SP" subscript
+1 ; Used to identify supplementary reports, specimens and related special studies performed on those specimens.
+2 ;
+3 ;ZEXCEPT: LA7ECH,LA7FS,LA7IENS,LA7NVAF,LA7OBX,LRDFN,LRIDT,LRSB,LRSS
+4 ;
+5 NEW LA7SUBID
+6 ;
+7 SET LA7SUBID=""
+8 ;
+9 ; Sub-id's for specimen multiple
+10 ; For DoD/CHCS convert internal entry number to alphabetic character (ASCII 64 + #)
+11 ; Create based on relative ien, not absolute. If first entry is ien 2 then sub-id is "A", 2nd entry is "B"
+12 IF $PIECE(LRSB,",")=.012
Begin DoDot:1
+13 NEW I,J
+14 IF LA7NVAF'=1
SET LA7SUBID="SPEC-"_$PIECE(LA7IENS,",")
QUIT
+15 SET I=0
SET J=1
+16 FOR
SET I=$ORDER(^LR(LRDFN,LRSS,LRIDT,.1,I))
if 'I!(I=$PIECE(LA7IENS,","))
QUIT
SET J=J+1
+17 SET LA7SUBID=$CHAR(64+J)
End DoDot:1
+18 ;
+19 ; Sub-id's for supplementary reports
+20 IF LRSB=1.2
Begin DoDot:1
+21 IF LA7NVAF=1
SET LA7SUBID="1-"_$PIECE(LA7IENS,",",2)
QUIT
+22 SET LA7SUBID="1-"_$PIECE(LA7IENS,",")
End DoDot:1
+23 ;
+24 ; Sub-id's for specimens and special studies
+25 IF LRSB=10!(LRSB="10,2")
SET LA7SUBID="10-"_$PIECE(LA7IENS,",")
+26 IF LRSB="10,1.5"!(LRSB="10,5")
SET LA7SUBID="10-"_$PIECE(LA7IENS,",",2)_"."_$PIECE(LA7IENS,",")
+27 ;
+28 IF LA7SUBID'=""
SET LA7OBX(4)=$$OBX4^LA7VOBX(LA7SUBID,LA7FS,LA7ECH)
+29 ;
+30 QUIT
+31 ;
+32 ;
DOD ; Build OBX segment's to special DoD specifications.
+1 ; Send word-processing fields as series of OBX's for DoD.
+2 ; DoD cannot handle formatted text (FT) data type.
+3 ;
+4 ;ZEXCEPT: LA7ECH,LA7FS,LA7OBX,LA7VAL,LRDFN,LRIDT,LRSB,LRSS
+5 ;
+6 NEW LA7SB
+7 SET LA7OBX(2)="ST"
SET LA7SB=$SELECT(LRSB=.013:.2,LRSB=.014:.3,LRSB=.015:.4,LRSB=.016:.5,1:LRSB)
+8 IF LA7SB'=1.2
SET LA7VAL=$GET(^LR(LRDFN,LRSS,LRIDT(1),LA7SB,LRIDT(2),0))
+9 IF '$TEST
SET LA7VAL=$GET(^LR(LRDFN,LRSS,LRIDT(1),LA7SB,LRIDT(2),1,LRIDT(3),0))
+10 IF LA7VAL=""
SET LA7VAL=" "
+11 SET LA7OBX(5)=$$OBX5^LA7VOBX(LA7VAL,LA7OBX(2),LA7FS,LA7ECH)
+12 QUIT
