Routine: LA7VOBRA

LA7VOBRA ;DALOI/JMC - LAB OBR segment builder (cont'd) ;03/22/10  17:45

 ;;5.2;AUTOMATED LAB INSTRUMENTS;**46,64,68,74**;Sep 27, 1994;Build 229

 ; This routine is an extension of LA7VOBR and should only be called from that routine.

 ; ZEXCEPT is used to identify variables which are external to a specific TAG

 ;         used in conjunction with Eclipse M-editor.

OBR2 ; Build OBR-2 sequence - placer's specimen id

 ;ZEXCEPT: LA7ECH,LA7FS,LA7ID,LA7X,LA7Y

 S LA7ID=$$CHKDATA^LA7VHLU3(LA7ID,LA7FS_LA7ECH)

 S $P(LA7Y,$E(LA7ECH,1),1)=LA7ID

 I $G(LA7ID("NMSP"))'="" S $P(LA7Y,$E(LA7ECH,1),2)=LA7ID("NMSP")

 I $G(LA7ID("SITE"))'="" D

 . S LA7X=$$FACDNS^LA7VHLU2(LA7ID("SITE"),LA7FS,LA7ECH,1)

 . S $P(LA7Y,$E(LA7ECH),3)=$P(LA7X,$E(LA7ECH),2)

 . S $P(LA7Y,$E(LA7ECH),4)=$P(LA7X,$E(LA7ECH),3)

OBR3 ; Build OBR-3 sequence - filler's specimen id

 ;ZEXCEPT: LA7ECH,LA7FS,LA7ID,LA7X,LA7Y

 S LA7ID=$$CHKDATA^LA7VHLU3(LA7ID,LA7FS_LA7ECH)

 S $P(LA7Y,$E(LA7ECH,1),1)=LA7ID

 I $G(LA7ID("NMSP"))'="" S $P(LA7Y,$E(LA7ECH,1),2)=LA7ID("NMSP")

 I $G(LA7ID("SITE"))'="" D

 . S LA7X=$$FACDNS^LA7VHLU2(LA7ID("SITE"),LA7FS,LA7ECH,1)

 . S $P(LA7Y,$E(LA7ECH),3)=$P(LA7X,$E(LA7ECH),2)

 . S $P(LA7Y,$E(LA7ECH),4)=$P(LA7X,$E(LA7ECH),3)

OBR4 ; Build OBR-4 sequence - Universal service ID

 ;ZEXCEPT: LA760,LA764,LA7ALT,LA7COMP,LA7ECH,LA7FS,LA7NLT,LA7TN,LA7Y,LA7Z

 S LA764=0,LA7Y=""

 ; specify component position - primary/alternate

 S LA7COMP=0

 ; Send non-VA test codes as first coding system

 I LA7ALT'="" D

 . N I

 . F I=1:1:3 S $P(LA7Y,$E(LA7ECH),LA7COMP+I)=$$CHKDATA^LA7VHLU3($P(LA7ALT,"^",I),LA7FS_LA7ECH)

 . S LA7COMP=LA7COMP+I

 ; Send NLT test codes as primary unless non-VA codes then send as alternate code

 I LA7NLT'="" D

 . S LA764=$O(^LAM("E",LA7NLT,0)),LA7Z=""

 . I LA764 S LA7Z=$$GET1^DIQ(64,LA764_",",.01,"I")

 . I LA7Z="" D

 . . N LA7642

 . . S LA764=$O(^LAM("E",$P(LA7NLT,".")_".0000",0))

 . . I LA764 S LA7Z=$$GET1^DIQ(64,LA764_",",.01,"I")

 . . S LA7642=$O(^LAB(64.2,"F","."_$P(LA7NLT,".",2),0))

 . . I LA764,LA7642 S LA7Z=LA7Z_"~"_$$GET1^DIQ(64.2,LA7642_",",.01,"I")

 . S $P(LA7Y,$E(LA7ECH),LA7COMP+1)=$$CHKDATA^LA7VHLU3(LA7NLT,LA7FS_LA7ECH)

 . S $P(LA7Y,$E(LA7ECH),LA7COMP+2)=$$CHKDATA^LA7VHLU3(LA7Z,LA7FS_LA7ECH)

 . S $P(LA7Y,$E(LA7ECH),LA7COMP+3)="99VA64"

 . S LA7COMP=LA7COMP+3

 ; Send file #60 test name if available and no alternate

 I LA7COMP<4,LA760 D

 . S LA7TN=$$GET1^DIQ(60,LA760_",",.01)

 . S $P(LA7Y,$E(LA7ECH),LA7COMP+1)=LA760

 . S $P(LA7Y,$E(LA7ECH),LA7COMP+2)=$$CHKDATA^LA7VHLU3(LA7TN,LA7FS_LA7ECH)

 . S $P(LA7Y,$E(LA7ECH),LA7COMP+3)="99VA60"

OBR9 ; Build OBR-9 sequence - collection volume

 ;ZEXCEPT: LA764061,LA7ECH,LA7FS,LA7IENS,LA7VOL,LA7X,LA7Y

 ; Collection volume

 S $P(LA7Y,$E(LA7ECH,1))=LA7VOL

 I LA764061 D

 . S LA7IENS=LA764061_","

 . D GETS^DIQ(64.061,LA7IENS,".01;1","E","LA7Y")

 . ; Collection Volume units code

 . S $P(LA7X,$E(LA7ECH,4),1)=$G(LA7Y(64.061,LA7IENS,.01,"E"))

 . ; Collection Volume units text

 . S $P(LA7X,$E(LA7ECH,4),2)=$$CHKDATA^LA7VHLU3($G(LA7Y(64.061,LA7IENS,1,"E")),LA7FS_LA7ECH)

 . ; LOINC coding system

 . S $P(LA7X,$E(LA7ECH,4),3)="LN"

 . S $P(LA7Y,$E(LA7ECH,1),2)=LA7X

OBR24 ; Build OBR-24 sequence - diagnostic service id

 ;ZEXCEPT: LA7SS,LA7X,LA7Y

 ; Code non-MI subscripts

 I $P(LA7SS,"^")'="MI" D  Q

 . S LA7X=$P(LA7SS,"^")

 . S LA7Y=$S(LA7X="CH":"CH",LA7X="SP":"SP",LA7X="CY":"CP",LA7X="EM":"PAT",LA7X="AU":"PAT",LA7X="BB":"BLB",1:"LAB")

 ; Code MI subscripts

 S LA7X=$P(LA7SS,"^",2)

 S LA7Y=$S(LA7X=11:"MB",LA7X=14:"PAR",LA7X=18:"MYC",LA7X=22:"MCB",LA7X=33:"VR",1:"MB")

OBR25 ; Build OBR-25 sequence - Result status

 ;ZEXCEPT: LA7FLAG,LA7Y

 S LA7Y=""

 I LA7FLAG="F" S LA7Y="F"

 I LA7FLAG="P" S LA7Y="P"

 I LA7FLAG="A" S LA7Y="A"

 I LA7FLAG="C" S LA7Y="C"

 I LA7FLAG?1.N S LA7Y=$$GET1^DIQ(64.061,LA7FLAG_",",2)

OBR26 ; Build OBR-26 sequence - Parent result

 ;ZEXCEPT: LA7C,LA7ECH,LA7OBX3,LA7OBX4,LA7OBX5,LA7SC,LA7Y

 S LA7Y=""

 ; Move component into sub-component position

 ; Translate component character to sub-component character

 S LA7C=$E(LA7ECH,1),LA7SC=$E(LA7ECH,4)

 ; Parent result observation identifier in 1st component

 I LA7OBX3'="" S $P(LA7Y,$E(LA7ECH,1),1)=$TR(LA7OBX3,LA7C,LA7SC)

 ; Parent sub-id in 2nd component

 I LA7OBX4'="" S $P(LA7Y,$E(LA7ECH,1),2)=$TR(LA7OBX4,LA7C,LA7SC)

 ; Parent test result in 3rd component

 I LA7OBX5'="" S $P(LA7Y,$E(LA7ECH,1),3)=$TR(LA7OBX5,LA7C,LA7SC)

OBR29 ; Build OBR-29 sequence - Parent

 ;ZEXCEPT: LA7ECH,LA7FON,LA7FS,LA7PON,LA7Y,LA7Z

 S LA7Y=""

 I $G(LA7PON)'="" D

 . S LA7Z=$$CHKDATA^LA7VHLU3(LA7PON,LA7FS_LA7ECH)

 . S $P(LA7Y,$E(LA7ECH,1),1)=LA7Z

 I $G(LA7FON)'="" D

 . S LA7Z=$$CHKDATA^LA7VHLU3(LA7FON,LA7FS_LA7ECH)

 . S $P(LA7Y,$E(LA7ECH,1),2)=LA7Z

OBRPF ; Build OBR-18,19,20,21 Placer/Filler #1/#2

 ;ZEXCEPT: LA7ECH,LA7FS,LA7I,LA7X,LA7Y,LA7Z

 S (LA7Y,LA7Z)="",LA7I=0

 F  S LA7I=$O(LA7X(LA7I)) Q:'LA7I  S $P(LA7Z,"^",LA7I)=LA7X(LA7I)

 S LA7Y=$$CHKDATA^LA7VHLU3(LA7Z,LA7FS_LA7ECH)

OBR32 ; Build OBR-32 sequence - Principle Result Interpreter field

 ;ZEXCEPT: LA7DIV,LA7DUZ,LA7ECH,LA7FS,LA7INTYP,LA7PRI,LA7X

 S LA7X=$$XCN^LA7VHLU9(LA7DUZ,LA7DIV,LA7FS,LA7ECH,1,2)

 I $G(LA7INTYP)=30 S $P(LA7PRI,$E(LA7ECH))=$P(LA7X,$E(LA7ECH,4),1,9)

 E  S $P(LA7PRI,$E(LA7ECH))=LA7X

 I LA7DIV S $P(LA7PRI,$E(LA7ECH),7)=$$FACDNS^LA7VHLU2(LA7DIV,LA7FS,LA7ECH,2)

OBR33 ; Build OBR-32 sequence - Assistant Result Interpreter field

 ;ZEXCEPT: LA7ARI,LA7DIV,LA7DUZ,LA7ECH,LA7FS,LA7INTYP,LA7X

 S LA7X=$$XCN^LA7VHLU9(LA7DUZ,LA7DIV,LA7FS,LA7ECH,1,2)

 I $G(LA7INTYP)=30 S $P(LA7ARI,$E(LA7ECH))=$P(LA7X,$E(LA7ECH,4),1,9)

 E  S $P(LA7ARI,$E(LA7ECH))=LA7X

 I LA7DIV S $P(LA7ARI,$E(LA7ECH),7)=$$FACDNS^LA7VHLU2(LA7DIV,LA7FS,LA7ECH,2)

OBR34 ; Build OBR-34 sequence - Technician field

 ;ZEXCEPT: LA7DIV,LA7DUZ,LA7ECH,LA7FS,LA7INTYP,LA7TECH,LA7X

 S LA7X=$$XCN^LA7VHLU9(LA7DUZ,LA7DIV,LA7FS,LA7ECH,1,1)

 I $G(LA7INTYP)=30 S $P(LA7TECH,$E(LA7ECH))=$P(LA7X,$E(LA7ECH,4),1,9)

 E  S $P(LA7TECH,$E(LA7ECH))=LA7X

 I LA7DIV S $P(LA7TECH,$E(LA7ECH),7)=$$FACDNS^LA7VHLU2(LA7DIV,LA7FS,LA7ECH,2)

OBR35 ; Build OBR-35 sequence - Transcriptionist field

 ;ZEXCEPT: LA7DIV,LA7DUZ,LA7ECH,LA7FS,LA7INTYP,LA7TSPT,LA7X

 S LA7X=$$XCN^LA7VHLU9(LA7DUZ,LA7DIV,LA7FS,LA7ECH,1,1)

 I $G(LA7INTYP)=30 S $P(LA7TSPT,$E(LA7ECH))=$P(LA7X,$E(LA7ECH,4),1,9)

 E  S $P(LA7TSPT,$E(LA7ECH))=LA7X

 I LA7DIV S $P(LA7TSPT,$E(LA7ECH),7)=$$FACDNS^LA7VHLU2(LA7DIV,LA7FS,LA7ECH,2)

OBR44 ; Build OBR-44

 ;ZEXCEPT: LA764,LA781,LA7ECH,LA7FS,LA7VAL,LA7X,LA7Y

 S (LA7X,LA7Y,LA7Z)=""

 I LA7VAL="" Q

 ; Send NLT result code

 S LA764=$O(^LAM("E",LA7VAL,0))

 I LA764 S LA7X=$P($G(^LAM(LA764,0)),"^")

 ; If suffixed and not defined then build from primary and suffix code.

 I LA7X="" D

 . N LA7642

 . S LA764=$O(^LAM("E",$P(LA7VAL,".")_".0000",0))

 . I LA764 S LA7X=$$GET1^DIQ(64,LA764_",",.01,"I")

 . S LA7642=$O(^LAB(64.2,"F","."_$P(LA7VAL,".",2),0))

 . I LA764,LA7642 S LA7X=LA7X_"~"_$$GET1^DIQ(64.2,LA7642_",",.01,"I")

 I LA7X'="" S LA7X=$$CHKDATA^LA7VHLU3(LA7X,LA7FS_LA7ECH)

 S $P(LA7Z,$E(LA7ECH,1),1)=LA7VAL

 S $P(LA7Z,$E(LA7ECH,1),2)=LA7X

 S $P(LA7Z,$E(LA7ECH,1),3)="99VA64"

 ;S LA7X=$$GET1^DID(64,"","","PACKAGE REVISION DATA")

 ;S $P(LA7Z,$E(LA7ECH,1),7)=LA7X

 S LA7Y=LA7Z

 ; Check for and build CPT code in primary, move NLT to alternate

 I LA764="" Q

 I '$D(^LAM("AD",LA764,"CPT")) Q

 S LA7X=$O(^LAM("AD",LA764,"CPT",0)),LA781=""

 I LA7X>0 S LA781=+$P($G(^LAM(LA764,4,LA7X,0)),"^")

 I LA781>0 D

 . S LA7X=$$CPT^ICPTCOD(LA781,DT,1)

 . I LA7X<1 Q

 . S LA7Z=$P(LA7X,"^",2)

 . S $P(LA7Z,$E(LA7ECH,1),2)=$$CHKDATA^LA7VHLU3($P(LA7X,"^",3),LA7FS_LA7ECH)

 . S $P(LA7Z,$E(LA7ECH,1),3)=$S($P(LA7X,"^",5)="C":"C4",$P(LA7X,"^",5)="HCPCS":"HCPCS",1:"L")

 . S LA7Y=LA7Z_$E(LA7ECH,1)_$P(LA7Y,$E(LA7ECH,1),1,3)

 ;. S $P(LA7Y,$E(LA7ECH,1),8)=$P(LA7Y,$E(LA7ECH,1),7)

 ;. S $P(LA7Y,$E(LA7ECH,1),7)=$P(LA7X,"^",6)

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLA7VOBRA   8285     printed  Feb 18, 2025@23:07:11                                                                                                                                                                                                    Page 2

LA7VOBRA  ;DALOI/JMC - LAB OBR segment builder (cont'd) ;03/22/10  17:45

 +1       ;;5.2;AUTOMATED LAB INSTRUMENTS;**46,64,68,74**;Sep 27, 1994;Build 229

 +2       ;

 +3       ; This routine is an extension of LA7VOBR and should only be called from that routine.

 +4       ;

 +5       ; ZEXCEPT is used to identify variables which are external to a specific TAG

 +6       ;         used in conjunction with Eclipse M-editor.

 +7        QUIT

 +8       ;

 +9       ;

OBR2      ; Build OBR-2 sequence - placer's specimen id

 +1       ;

 +2       ;ZEXCEPT: LA7ECH,LA7FS,LA7ID,LA7X,LA7Y

 +3       ;

 +4        SET LA7ID=$$CHKDATA^LA7VHLU3(LA7ID,LA7FS_LA7ECH)

 +5        SET $PIECE(LA7Y,$EXTRACT(LA7ECH,1),1)=LA7ID

 +6        IF $GET(LA7ID("NMSP"))'=""

               SET $PIECE(LA7Y,$EXTRACT(LA7ECH,1),2)=LA7ID("NMSP")

 +7        IF $GET(LA7ID("SITE"))'=""

               Begin DoDot:1

 +8                SET LA7X=$$FACDNS^LA7VHLU2(LA7ID("SITE"),LA7FS,LA7ECH,1)

 +9                SET $PIECE(LA7Y,$EXTRACT(LA7ECH),3)=$PIECE(LA7X,$EXTRACT(LA7ECH),2)

 +10               SET $PIECE(LA7Y,$EXTRACT(LA7ECH),4)=$PIECE(LA7X,$EXTRACT(LA7ECH),3)

               End DoDot:1

 +11       QUIT

 +12      ;

 +13      ;

OBR3      ; Build OBR-3 sequence - filler's specimen id

 +1       ;

 +2       ;ZEXCEPT: LA7ECH,LA7FS,LA7ID,LA7X,LA7Y

 +3       ;

 +4        SET LA7ID=$$CHKDATA^LA7VHLU3(LA7ID,LA7FS_LA7ECH)

 +5        SET $PIECE(LA7Y,$EXTRACT(LA7ECH,1),1)=LA7ID

 +6        IF $GET(LA7ID("NMSP"))'=""

               SET $PIECE(LA7Y,$EXTRACT(LA7ECH,1),2)=LA7ID("NMSP")

 +7        IF $GET(LA7ID("SITE"))'=""

               Begin DoDot:1

 +8                SET LA7X=$$FACDNS^LA7VHLU2(LA7ID("SITE"),LA7FS,LA7ECH,1)

 +9                SET $PIECE(LA7Y,$EXTRACT(LA7ECH),3)=$PIECE(LA7X,$EXTRACT(LA7ECH),2)

 +10               SET $PIECE(LA7Y,$EXTRACT(LA7ECH),4)=$PIECE(LA7X,$EXTRACT(LA7ECH),3)

               End DoDot:1

 +11       QUIT

 +12      ;

 +13      ;

OBR4      ; Build OBR-4 sequence - Universal service ID

 +1       ;

 +2       ;ZEXCEPT: LA760,LA764,LA7ALT,LA7COMP,LA7ECH,LA7FS,LA7NLT,LA7TN,LA7Y,LA7Z

 +3       ;

 +4       ;

 +5        SET LA764=0

           SET LA7Y=""

 +6       ; specify component position - primary/alternate

 +7        SET LA7COMP=0

 +8       ;

 +9       ; Send non-VA test codes as first coding system

 +10       IF LA7ALT'=""

               Begin DoDot:1

 +11               NEW I

 +12               FOR I=1:1:3

                       SET $PIECE(LA7Y,$EXTRACT(LA7ECH),LA7COMP+I)=$$CHKDATA^LA7VHLU3($PIECE(LA7ALT,"^",I),LA7FS_LA7ECH)

 +13               SET LA7COMP=LA7COMP+I

               End DoDot:1

 +14      ;

 +15      ; Send NLT test codes as primary unless non-VA codes then send as alternate code

 +16       IF LA7NLT'=""

               Begin DoDot:1

 +17               SET LA764=$ORDER(^LAM("E",LA7NLT,0))

                   SET LA7Z=""

 +18               IF LA764

                       SET LA7Z=$$GET1^DIQ(64,LA764_",",.01,"I")

 +19               IF LA7Z=""

                       Begin DoDot:2

 +20                       NEW LA7642

 +21                       SET LA764=$ORDER(^LAM("E",$PIECE(LA7NLT,".")_".0000",0))

 +22                       IF LA764

                               SET LA7Z=$$GET1^DIQ(64,LA764_",",.01,"I")

 +23                       SET LA7642=$ORDER(^LAB(64.2,"F","."_$PIECE(LA7NLT,".",2),0))

 +24                       IF LA764

                               IF LA7642

                                   SET LA7Z=LA7Z_"~"_$$GET1^DIQ(64.2,LA7642_",",.01,"I")

                       End DoDot:2

 +25               SET $PIECE(LA7Y,$EXTRACT(LA7ECH),LA7COMP+1)=$$CHKDATA^LA7VHLU3(LA7NLT,LA7FS_LA7ECH)

 +26               SET $PIECE(LA7Y,$EXTRACT(LA7ECH),LA7COMP+2)=$$CHKDATA^LA7VHLU3(LA7Z,LA7FS_LA7ECH)

 +27               SET $PIECE(LA7Y,$EXTRACT(LA7ECH),LA7COMP+3)="99VA64"

 +28               SET LA7COMP=LA7COMP+3

               End DoDot:1

 +29      ;

 +30      ; Send file #60 test name if available and no alternate

 +31       IF LA7COMP<4

               IF LA760

                   Begin DoDot:1

 +32                   SET LA7TN=$$GET1^DIQ(60,LA760_",",.01)

 +33                   SET $PIECE(LA7Y,$EXTRACT(LA7ECH),LA7COMP+1)=LA760

 +34                   SET $PIECE(LA7Y,$EXTRACT(LA7ECH),LA7COMP+2)=$$CHKDATA^LA7VHLU3(LA7TN,LA7FS_LA7ECH)

 +35                   SET $PIECE(LA7Y,$EXTRACT(LA7ECH),LA7COMP+3)="99VA60"

                   End DoDot:1

 +36      ;

 +37       QUIT

 +38      ;

 +39      ;

OBR9      ; Build OBR-9 sequence - collection volume

 +1       ;

 +2       ;ZEXCEPT: LA764061,LA7ECH,LA7FS,LA7IENS,LA7VOL,LA7X,LA7Y

 +3       ;

 +4       ; Collection volume

 +5        SET $PIECE(LA7Y,$EXTRACT(LA7ECH,1))=LA7VOL

 +6       ;

 +7        IF LA764061

               Begin DoDot:1

 +8                SET LA7IENS=LA764061_","

 +9                DO GETS^DIQ(64.061,LA7IENS,".01;1","E","LA7Y")

 +10      ; Collection Volume units code

 +11               SET $PIECE(LA7X,$EXTRACT(LA7ECH,4),1)=$GET(LA7Y(64.061,LA7IENS,.01,"E"))

 +12      ; Collection Volume units text

 +13               SET $PIECE(LA7X,$EXTRACT(LA7ECH,4),2)=$$CHKDATA^LA7VHLU3($GET(LA7Y(64.061,LA7IENS,1,"E")),LA7FS_LA7ECH)

 +14      ; LOINC coding system

 +15               SET $PIECE(LA7X,$EXTRACT(LA7ECH,4),3)="LN"

 +16               SET $PIECE(LA7Y,$EXTRACT(LA7ECH,1),2)=LA7X

               End DoDot:1

 +17      ;

 +18       QUIT

 +19      ;

 +20      ;

OBR24     ; Build OBR-24 sequence - diagnostic service id

 +1       ;

 +2       ;ZEXCEPT: LA7SS,LA7X,LA7Y

 +3       ;

 +4       ; Code non-MI subscripts

 +5        IF $PIECE(LA7SS,"^")'="MI"

               Begin DoDot:1

 +6                SET LA7X=$PIECE(LA7SS,"^")

 +7                SET LA7Y=$SELECT(LA7X="CH":"CH",LA7X="SP":"SP",LA7X="CY":"CP",LA7X="EM":"PAT",LA7X="AU":"PAT",LA7X="BB":"BLB",1:"LAB")

               End DoDot:1

               QUIT

 +8       ;

 +9       ; Code MI subscripts

 +10       SET LA7X=$PIECE(LA7SS,"^",2)

 +11       SET LA7Y=$SELECT(LA7X=11:"MB",LA7X=14:"PAR",LA7X=18:"MYC",LA7X=22:"MCB",LA7X=33:"VR",1:"MB")

 +12      ;

 +13       QUIT

 +14      ;

 +15      ;

OBR25     ; Build OBR-25 sequence - Result status

 +1       ;

 +2       ;ZEXCEPT: LA7FLAG,LA7Y

 +3       ;

 +4        SET LA7Y=""

 +5       ;

 +6        IF LA7FLAG="F"

               SET LA7Y="F"

 +7        IF LA7FLAG="P"

               SET LA7Y="P"

 +8        IF LA7FLAG="A"

               SET LA7Y="A"

 +9        IF LA7FLAG="C"

               SET LA7Y="C"

 +10       IF LA7FLAG?1.N

               SET LA7Y=$$GET1^DIQ(64.061,LA7FLAG_",",2)

 +11      ;

 +12       QUIT

 +13      ;

 +14      ;

OBR26     ; Build OBR-26 sequence - Parent result

 +1       ;

 +2       ;ZEXCEPT: LA7C,LA7ECH,LA7OBX3,LA7OBX4,LA7OBX5,LA7SC,LA7Y

 +3       ;

 +4        SET LA7Y=""

 +5       ;

 +6       ; Move component into sub-component position

 +7       ; Translate component character to sub-component character

 +8        SET LA7C=$EXTRACT(LA7ECH,1)

           SET LA7SC=$EXTRACT(LA7ECH,4)

 +9       ;

 +10      ; Parent result observation identifier in 1st component

 +11       IF LA7OBX3'=""

               SET $PIECE(LA7Y,$EXTRACT(LA7ECH,1),1)=$TRANSLATE(LA7OBX3,LA7C,LA7SC)

 +12      ;

 +13      ; Parent sub-id in 2nd component

 +14       IF LA7OBX4'=""

               SET $PIECE(LA7Y,$EXTRACT(LA7ECH,1),2)=$TRANSLATE(LA7OBX4,LA7C,LA7SC)

 +15      ;

 +16      ; Parent test result in 3rd component

 +17       IF LA7OBX5'=""

               SET $PIECE(LA7Y,$EXTRACT(LA7ECH,1),3)=$TRANSLATE(LA7OBX5,LA7C,LA7SC)

 +18      ;

 +19       QUIT

 +20      ;

 +21      ;

OBR29     ; Build OBR-29 sequence - Parent

 +1       ;

 +2       ;ZEXCEPT: LA7ECH,LA7FON,LA7FS,LA7PON,LA7Y,LA7Z

 +3       ;

 +4        SET LA7Y=""

 +5       ;

 +6        IF $GET(LA7PON)'=""

               Begin DoDot:1

 +7                SET LA7Z=$$CHKDATA^LA7VHLU3(LA7PON,LA7FS_LA7ECH)

 +8                SET $PIECE(LA7Y,$EXTRACT(LA7ECH,1),1)=LA7Z

               End DoDot:1

 +9       ;

 +10       IF $GET(LA7FON)'=""

               Begin DoDot:1

 +11               SET LA7Z=$$CHKDATA^LA7VHLU3(LA7FON,LA7FS_LA7ECH)

 +12               SET $PIECE(LA7Y,$EXTRACT(LA7ECH,1),2)=LA7Z

               End DoDot:1

 +13      ;

 +14       QUIT

 +15      ;

 +16      ;

OBRPF     ; Build OBR-18,19,20,21 Placer/Filler #1/#2

 +1       ;

 +2       ;ZEXCEPT: LA7ECH,LA7FS,LA7I,LA7X,LA7Y,LA7Z

 +3       ;

 +4        SET (LA7Y,LA7Z)=""

           SET LA7I=0

 +5        FOR

               SET LA7I=$ORDER(LA7X(LA7I))

               if 'LA7I

                   QUIT

               SET $PIECE(LA7Z,"^",LA7I)=LA7X(LA7I)

 +6        SET LA7Y=$$CHKDATA^LA7VHLU3(LA7Z,LA7FS_LA7ECH)

 +7        QUIT

 +8       ;

 +9       ;

OBR32     ; Build OBR-32 sequence - Principle Result Interpreter field

 +1       ;

 +2       ;ZEXCEPT: LA7DIV,LA7DUZ,LA7ECH,LA7FS,LA7INTYP,LA7PRI,LA7X

 +3       ;

 +4        SET LA7X=$$XCN^LA7VHLU9(LA7DUZ,LA7DIV,LA7FS,LA7ECH,1,2)

 +5        IF $GET(LA7INTYP)=30

               SET $PIECE(LA7PRI,$EXTRACT(LA7ECH))=$PIECE(LA7X,$EXTRACT(LA7ECH,4),1,9)

 +6       IF '$TEST

               SET $PIECE(LA7PRI,$EXTRACT(LA7ECH))=LA7X

 +7        IF LA7DIV

               SET $PIECE(LA7PRI,$EXTRACT(LA7ECH),7)=$$FACDNS^LA7VHLU2(LA7DIV,LA7FS,LA7ECH,2)

 +8        QUIT

 +9       ;

 +10      ;

OBR33     ; Build OBR-32 sequence - Assistant Result Interpreter field

 +1       ;

 +2       ;ZEXCEPT: LA7ARI,LA7DIV,LA7DUZ,LA7ECH,LA7FS,LA7INTYP,LA7X

 +3       ;

 +4       ;

 +5        SET LA7X=$$XCN^LA7VHLU9(LA7DUZ,LA7DIV,LA7FS,LA7ECH,1,2)

 +6        IF $GET(LA7INTYP)=30

               SET $PIECE(LA7ARI,$EXTRACT(LA7ECH))=$PIECE(LA7X,$EXTRACT(LA7ECH,4),1,9)

 +7       IF '$TEST

               SET $PIECE(LA7ARI,$EXTRACT(LA7ECH))=LA7X

 +8        IF LA7DIV

               SET $PIECE(LA7ARI,$EXTRACT(LA7ECH),7)=$$FACDNS^LA7VHLU2(LA7DIV,LA7FS,LA7ECH,2)

 +9        QUIT

 +10      ;

 +11      ;

OBR34     ; Build OBR-34 sequence - Technician field

 +1       ;

 +2       ;ZEXCEPT: LA7DIV,LA7DUZ,LA7ECH,LA7FS,LA7INTYP,LA7TECH,LA7X

 +3       ;

 +4       ;

 +5        SET LA7X=$$XCN^LA7VHLU9(LA7DUZ,LA7DIV,LA7FS,LA7ECH,1,1)

 +6        IF $GET(LA7INTYP)=30

               SET $PIECE(LA7TECH,$EXTRACT(LA7ECH))=$PIECE(LA7X,$EXTRACT(LA7ECH,4),1,9)

 +7       IF '$TEST

               SET $PIECE(LA7TECH,$EXTRACT(LA7ECH))=LA7X

 +8        IF LA7DIV

               SET $PIECE(LA7TECH,$EXTRACT(LA7ECH),7)=$$FACDNS^LA7VHLU2(LA7DIV,LA7FS,LA7ECH,2)

 +9        QUIT

 +10      ;

 +11      ;

OBR35     ; Build OBR-35 sequence - Transcriptionist field

 +1       ;

 +2       ;ZEXCEPT: LA7DIV,LA7DUZ,LA7ECH,LA7FS,LA7INTYP,LA7TSPT,LA7X

 +3       ;

 +4        SET LA7X=$$XCN^LA7VHLU9(LA7DUZ,LA7DIV,LA7FS,LA7ECH,1,1)

 +5        IF $GET(LA7INTYP)=30

               SET $PIECE(LA7TSPT,$EXTRACT(LA7ECH))=$PIECE(LA7X,$EXTRACT(LA7ECH,4),1,9)

 +6       IF '$TEST

               SET $PIECE(LA7TSPT,$EXTRACT(LA7ECH))=LA7X

 +7        IF LA7DIV

               SET $PIECE(LA7TSPT,$EXTRACT(LA7ECH),7)=$$FACDNS^LA7VHLU2(LA7DIV,LA7FS,LA7ECH,2)

 +8        QUIT

 +9       ;

 +10      ;

OBR44     ; Build OBR-44

 +1       ;

 +2       ;ZEXCEPT: LA764,LA781,LA7ECH,LA7FS,LA7VAL,LA7X,LA7Y

 +3       ;

 +4       ;

 +5        SET (LA7X,LA7Y,LA7Z)=""

 +6       ;

 +7        IF LA7VAL=""

               QUIT

 +8       ;

 +9       ; Send NLT result code

 +10       SET LA764=$ORDER(^LAM("E",LA7VAL,0))

 +11       IF LA764

               SET LA7X=$PIECE($GET(^LAM(LA764,0)),"^")

 +12      ;

 +13      ; If suffixed and not defined then build from primary and suffix code.

 +14       IF LA7X=""

               Begin DoDot:1

 +15               NEW LA7642

 +16               SET LA764=$ORDER(^LAM("E",$PIECE(LA7VAL,".")_".0000",0))

 +17               IF LA764

                       SET LA7X=$$GET1^DIQ(64,LA764_",",.01,"I")

 +18               SET LA7642=$ORDER(^LAB(64.2,"F","."_$PIECE(LA7VAL,".",2),0))

 +19               IF LA764

                       IF LA7642

                           SET LA7X=LA7X_"~"_$$GET1^DIQ(64.2,LA7642_",",.01,"I")

               End DoDot:1

 +20      ;

 +21       IF LA7X'=""

               SET LA7X=$$CHKDATA^LA7VHLU3(LA7X,LA7FS_LA7ECH)

 +22       SET $PIECE(LA7Z,$EXTRACT(LA7ECH,1),1)=LA7VAL

 +23       SET $PIECE(LA7Z,$EXTRACT(LA7ECH,1),2)=LA7X

 +24       SET $PIECE(LA7Z,$EXTRACT(LA7ECH,1),3)="99VA64"

 +25      ;S LA7X=$$GET1^DID(64,"","","PACKAGE REVISION DATA")

 +26      ;S $P(LA7Z,$E(LA7ECH,1),7)=LA7X

 +27       SET LA7Y=LA7Z

 +28      ;

 +29      ; Check for and build CPT code in primary, move NLT to alternate

 +30       IF LA764=""

               QUIT

 +31       IF '$DATA(^LAM("AD",LA764,"CPT"))

               QUIT

 +32       SET LA7X=$ORDER(^LAM("AD",LA764,"CPT",0))

           SET LA781=""

 +33       IF LA7X>0

               SET LA781=+$PIECE($GET(^LAM(LA764,4,LA7X,0)),"^")

 +34       IF LA781>0

               Begin DoDot:1

 +35               SET LA7X=$$CPT^ICPTCOD(LA781,DT,1)

 +36               IF LA7X<1

                       QUIT

 +37               SET LA7Z=$PIECE(LA7X,"^",2)

 +38               SET $PIECE(LA7Z,$EXTRACT(LA7ECH,1),2)=$$CHKDATA^LA7VHLU3($PIECE(LA7X,"^",3),LA7FS_LA7ECH)

 +39               SET $PIECE(LA7Z,$EXTRACT(LA7ECH,1),3)=$SELECT($PIECE(LA7X,"^",5)="C":"C4",$PIECE(LA7X,"^",5)="HCPCS":"HCPCS",1:"L")

 +40               SET LA7Y=LA7Z_$EXTRACT(LA7ECH,1)_$PIECE(LA7Y,$EXTRACT(LA7ECH,1),1,3)

               End DoDot:1

 +41      ;. S $P(LA7Y,$E(LA7ECH,1),8)=$P(LA7Y,$E(LA7ECH,1),7)

 +42      ;. S $P(LA7Y,$E(LA7ECH,1),7)=$P(LA7X,"^",6)

 +43      ;

 +44       QUIT

LA7VOBRA.m