Ignore:
Timestamp:
Dec 4, 2009, 12:11:15 AM (14 years ago)
Author:
George Lilly
Message:

revised back to 6/30/08 version

File:
1 edited

Legend:

Unmodified
Added
Removed

  • WorldVistAEHR/trunk/r/AUTOMATED_LAB_INSTRUMENTS-LA/LA7VIN4.m

    r613 r623  
    1 LA7VIN4 ;DALOI/JMC - Process Incoming UI Msgs, continued ; 7/27/07 11:24am
    2         ;;5.2;AUTOMATED LAB INSTRUMENTS;**46,64,67,66**;Sep 27, 1994;Build 30
    3         ;This routine is a continuation of LA7VIN1 and is only called from there.
    4         Q
    5         ;
    6 OBR     ; Process OBR segments
    7         N I,LA7CUP,LA7ENTRY,LA7IDE,LA7INST,LA7PDUZ,LA7TRAY,LA7X,LA7Y
    8         ;
    9         ; OBR Set ID
    10         S LA7SOBR=$$P^LA7VHLU(.LA7SEG,2,LA7FS)
    11         ;
    12         S LA7X=$$P^LA7VHLU(.LA7SEG,19,LA7FS)
    13         S LA7X=$$UNESC^LA7VHLU3(LA7X,LA7FS_LA7ECH)
    14         S LA7624=0,LA7INST=$P(LA7X,"^") ; extracting 1st piece
    15         ; Look up #62.4 entry from instrument name.
    16         I LA7INST'="" S LA7624=+$O(^LAB(62.4,"B",LA7INST,0))
    17         ;
    18         ; If none then use sending application name to look up #62.4 entry.
    19         I 'LA7624 S LA7624=+$O(^LAB(62.4,"B",LA7SAP,0))
    20         ;
    21         ; Instrument name not found in xref
    22         I 'LA7624 D  Q
    23         . I LA7INST="" D  Q
    24         . . S LA7ERR=10,LA7QUIT=2
    25         . . D CREATE^LA7LOG(LA7ERR)
    26         . S LA7ERR=11,LA7QUIT=2
    27         . D CREATE^LA7LOG(LA7ERR)
    28         S LA7624(0)=$G(^LAB(62.4,LA7624,0))
    29         S LA7ID=$P(LA7624(0),"^")_"-I-"
    30         ;
    31         S LA7LWL=+$P(LA7624(0),"^",4) ;  Load/Work List
    32         S LA7ENTRY=$P(LA7624(0),"^",6) ;LOG,LLIST,IDENT or SEQN
    33         S:LA7ENTRY="" LA7ENTRY="LOG"
    34         ;
    35         ; Placer(sender)/filler order numbers
    36         S LA7X=$$P^LA7VHLU(.LA7SEG,3,LA7FS)
    37         S LA7SID=$P(LA7X,$E(LA7ECH)) F I=2:1:4 S LA7SID(I)=$P(LA7X,$E(LA7ECH),I)
    38         S LA7X=$$P^LA7VHLU(.LA7SEG,4,LA7FS)
    39         S LA7FID=$P(LA7X,$E(LA7ECH)) F I=2:1:4 S LA7FID(I)=$P(LA7X,$E(LA7ECH),I)
    40         ;
    41         ; Test order code - find order NLT code
    42         ; If POC interface then see if NLT is used for ordering code
    43         S LA7X=$$P^LA7VHLU(.LA7SEG,5,LA7FS),LA7ONLT=""
    44         F I=1,4 D  Q:LA7ONLT'=""
    45         . I $P(LA7X,LA7CS,I)'?5N1"."4N Q
    46         . I $P(LA7X,LA7CS,I+2)="99VA64" S LA7ONLT=$P(LA7X,LA7CS,I),LA7ONLT(0)=$P(LA7X,LA7CS,I+1) Q
    47         . I LA7INTYP>19,LA7INTYP<30,$P(LA7X,LA7CS,I+2)="" S LA7ONLT=$P(LA7X,LA7CS,I),LA7ONLT(0)=$P(LA7X,LA7CS,I+1) Q
    48         ;
    49         ; Specimen collection date/time
    50         S LA7CDT=$$HL7TFM^XLFDT($P($$P^LA7VHLU(.LA7SEG,8,LA7FS),LA7CS),"L")
    51         ;
    52         ; Pull info from placer field #2 (OBR-19)
    53         S LA7X=$$P^LA7VHLU(.LA7SEG,20,LA7FS)
    54         S LA7X=$$UNESC^LA7VHLU3(LA7X,LA7FS_LA7ECH)
    55         S LA7TRAY=+$P(LA7X,"^",1) ;Tray
    56         S LA7CUP=+$P(LA7X,"^",2) ; Cup
    57         ; If POC interface set cup to file #62.49 ien
    58         I LA7INTYP>19,LA7INTYP<30 S LA7CUP=LA76249
    59         S LA7AA=$P(LA7X,"^",3) ;  Accession Area
    60         S LA7AD=$P(LA7X,"^",4) ;  Accession Date
    61         S LA7AN=$P(LA7X,"^",5) ;  Accession Entry
    62         S LA7ACC=$P(LA7X,"^",6) ;  Accession
    63         S LA7UID=$P(LA7X,"^",7) ;  Unique ID
    64         I LA7UID'?1(10UN,15UN) S LA7UID=""
    65         ;
    66         ; Sequence Number
    67         ; If point of care interface (20-29) then use file #62.49 ien as IDE
    68         S LA7IDE=$P(LA7X,LA7CS,8)
    69         I LA7INTYP>19,LA7INTYP<30 S LA7IDE=LA76249
    70         ;
    71         ; UID might come as Sample ID
    72         I LA7UID="",LA7SID?1(10UN,15UN) S LA7UID=LA7SID
    73         ;
    74         ; Try to figure out LA7AA LA7AD LA7AN by using the unique ID (UID)
    75         ; accession may have rolled over, use UID to get current accession info.
    76         I LA7UID]"" D
    77         . N X
    78         . S X=$Q(^LRO(68,"C",LA7UID))
    79         . I $QS(X,3)'=LA7UID S LA7UID="" Q  ; UID not on file.
    80         . S LA7AA=+$QS(X,4),LA7AD=+$QS(X,5),LA7AN=+$QS(X,6)
    81         . D SETID^LA7VHLU1(LA76249,LA7ID,LA7UID)
    82         ;
    83         ; If still not known, compute from default accession date and area.
    84         ; Calculate accession date based on accession transform.
    85         I LA7AA<1!(LA7AD<1)!(LA7AN<1) D
    86         . N X
    87         . S LA7AA=+$P(LA7624(0),"^",11)
    88         . S X=$P($G(^LRO(68,LA7AA,0)),U,3)
    89         . S LA7AD=$S(X="D":DT,X="M":$E(DT,1,5)_"00",X="Y":$E(DT,1,3)_"0000",X="Q":$E(DT,1,3)_"0000"+(($E(DT,4,5)-1)\3*300+100),1:DT)
    90         . S LA7AN=+LA7SID
    91         . I LA7AN>0 D SETID^LA7VHLU1(LA76249,LA7ID,LA7AN) Q
    92         . D SETID^LA7VHLU1(LA76249,LA7ID,$S($G(LA7PNM)]"":LA7PNM,$G(LA7SSN)]"":LA7SSN,1:"NO ID"))
    93         ;
    94         ; Zeroth node of accession area.
    95         S LA7AA(0)=$G(^LRO(68,+LA7AA,0))
    96         ; Accession's subscript
    97         S LA7SS=$P(LA7AA(0),"^",2)
    98         ;
    99         ; Specimen action code
    100         S LA7SAC=$$P^LA7VHLU(.LA7SEG,12,LA7FS)
    101         ;
    102         ; Specimen(topography), collection sample, HL7 specimen source
    103         S (LA761,LA762,LA70070,LA7SPEC)=""
    104         S LA7SPTY=$$P^LA7VHLU(.LA7SEG,16,LA7FS)
    105         ;
    106         ; Check if using HL7 table 0070
    107         S LA7X=$P($P(LA7SPTY,LA7CS),$E(LA7ECH,4),3)
    108         I LA7X=""!(LA7X="HL70070") S LA7SPEC=$P($P(LA7SPTY,LA7CS),$E(LA7ECH,4))
    109         ;
    110         I $O(^LRO(68,LA7AA,1,LA7AD,1,LA7AN,5,0)) D
    111         . N X
    112         . S X=$O(^LRO(68,LA7AA,1,LA7AD,1,LA7AN,5,0))
    113         . ; specimen^collection sample
    114         . S X(0)=$G(^LRO(68,LA7AA,1,LA7AD,1,LA7AN,5,X,0))
    115         . S LA761=$P(X(0),"^") ; specimen
    116         . S LA762=$P(X(0),"^",2) ; collection sample
    117         . ; HL7 code
    118         . I LA761 S LA70070=$$GET1^DIQ(61,LA761_",","LEDI HL7:HL7 ABBR")
    119         ;
    120         ; Log error when specimen source does not match accession's specimen
    121         I LA70070'="",LA7SPEC'="",LA70070'=LA7SPEC D
    122         . ; Ignore if specimen related to lab control file #62.3
    123         . I $P($G(^LRO(68,LA7AA,1,LA7AD,1,LA7AN,0)),"^",2)=62.3 Q
    124         . N LA7OBR
    125         . S LA7OBR(15)=LA7SPEC ; backward compatible with old code
    126         . S LA7ERR=22,LA7QUIT=2
    127         . D CREATE^LA7LOG(LA7ERR)
    128         ;
    129         ; Don't continue if flag set to skip this segment
    130         I LA7QUIT Q
    131         ;
    132         ; Placer's ordering provider (id^duz^last name, first name, mi [id])
    133         I $G(LA7POP)="" D
    134         . S LA7POP="",LA7X=$$P^LA7VHLU(.LA7SEG,17,LA7FS)
    135         . I LA7X="" Q
    136         . S LA7POP=$$XCNTFM^LA7VHLU4(LA7X,LA7ECH)
    137         . I LA7POP="^^" S LA7POP=""
    138         ;
    139         ; Create entry in LAH for supported subscripts.
    140         I LA7MTYP="ORR",$G(LA7OTYPE)'="OK","CHMI"[LA7SS D
    141         . D LAGEN
    142         . I $G(LA7ISQN)="" D CREATE^LA7LOG(14) Q
    143         . S LA7I=$O(^TMP("LA7 ORDER STATUS",$J,""),-1),LA7I=LA7I+1
    144         . I LA7ONLT="" S X=$$P^LA7VHLU(.LA7SEG,5,LA7FS),LA7X=$P(X,LA7CS),LA7X(0)=$P(X,LA7CS,2)
    145         . E  S LA7X=LA7ONLT,LA7X(0)=LA7ONLT(0)
    146         . S X=LA7LWL_"^"_LA7ISQN_"^"_LA7X_"^"_LA7X(0)_"^"_LA76248_"^"_LA76249_"^"_LA7OTYPE_"^^"_$P($G(LA7SM),"^",2)
    147         . S ^TMP("LA7 ORDER STATUS",$J,LA7I)=X
    148         . I $G(LA7OCR)'="" S ^TMP("LA7 ORDER STATUS",$J,LA7I,"OCR")=$TR(LA7OCR,LA7CS,"^")
    149         . I $G(LA7MSATM)'="" S ^TMP("LA7 ORDER STATUS",$J,LA7I,"MSA")=LA7MSATM
    150         ;
    151         I LA7MTYP="ORU","CHMI"[LA7SS D
    152         . D LAGEN
    153         . I $G(LA7ISQN)<1 D CREATE^LA7LOG(14) Q
    154         . I LA7INTYP=10,LA7SAC?1(1"A",1"G") D
    155         . . S LA7I=$O(^TMP("LA7 ORDER STATUS",$J,""),-1),LA7I=LA7I+1,LA7SAC(0)=LA7I
    156         . . I LA7ONLT="" S X=$$P^LA7VHLU(.LA7SEG,5,LA7FS),LA7X=$P(X,LA7CS),LA7X(0)=$P(X,LA7CS,2)
    157         . . E  S LA7X=LA7ONLT,LA7X(0)=LA7ONLT(0)
    158         . . S X=LA7LWL_"^"_LA7ISQN_"^"_LA7X_"^"_LA7X(0)_"^"_LA76248_"^"_LA76249_"^"_$G(LA7OTYPE)_"^"_LA7SAC_"^"_$P($G(LA7SM),"^",2)
    159         . . S ^TMP("LA7 ORDER STATUS",$J,LA7I)=X
    160         ;
    161         I LA7INTYP=10,$G(LA7SM)'="",$G(LA7UID)'="" D SMUPDT
    162         Q
    163         ;
    164         ;
    165 LAGEN   ; Sets up variables for call to ^LAGEN,  build entry in LAH
    166         ; requires LA7INST,LA7TRAY,LA7CUP,LA7AA,LA7AD,LA7AN,LA7LWL
    167         ; returns LA7ISQN=subscript to store results in ^LAH global
    168         ;
    169         I LA7ENTRY="LOG" D
    170         . I LA7INTYP>19,LA7INTYP<30 Q
    171         . I '$D(^LRO(68,LA7AA,1,LA7AD,1,LA7AN,0)) D CREATE^LA7LOG(13)
    172         I LA7ENTRY="LLIST" S:'LA7CUP LA7CUP=LA7IDE ;cup=sequence number
    173         ;
    174         K LA7ISQN,LADT,LAGEN
    175         K TRAY,CUP,LWL,WL,LROVER,METH,LOG,IDENT,ISQN
    176         ;
    177         S LA7ISQN=""
    178         S TRAY=+$G(LA7TRAY) S:'TRAY TRAY=1
    179         S CUP=+$G(LA7CUP) S:'CUP CUP=1
    180         ;
    181         S LWL=LA7LWL
    182         I '$D(^LRO(68.2,+LWL,0)) D  Q
    183         . D CREATE^LA7LOG(19)
    184         ;
    185         ; Set accession area to area of specimen, allow multiple areas on same instrument.
    186         S WL=LA7AA
    187         I '$D(^LRO(68,+WL,0)) D  Q
    188         . D CREATE^LA7LOG(20)
    189         S LROVER=$P(LA7624(0),"^",12)
    190         S METH=$P(LA7624(0),"^",10)
    191         S LOG=LA7AN
    192         S IDENT=$P($G(^LRO(68,LA7AA,1,LA7AD,1,LA7AN,0)),"^",6) ;identity field
    193         S IDE=+LA7IDE
    194         S LADT=LA7AD
    195         ;
    196         ; If POC interface call special entry point
    197         D
    198         . N LRDFN ; Protect LRDFN - call into LAGEN can set to 0
    199         . I LA7INTYP>19,LA7INTYP<30 S IDE=LA76249 D POC^LAGEN Q
    200         . D @(LA7ENTRY_"^LAGEN") ;this disregards the CROSS LINK field in 62.4
    201         S LA7ISQN=$G(ISQN)
    202         ;
    203         I LA7ISQN<1 Q
    204         ;
    205         ; Build/store patient demographics array
    206         N I,J,LA7OBRA,LA7PIDA,X,Y
    207         S J="DFN^DOB^ICN^LOC^LRDFN^LRTDFN^PNM^SEX^SSN"
    208         S J(0)="DFN^LA7DOB^LA7ICN^LA7LOC^LRDFN^LRTDFN^LA7PNM^LA7SEX^LA7SSN"
    209         F I=1:1 S X=$P(J,"^",I) Q:X=""  D
    210         . S Y=$P(J(0),"^",I)
    211         . I $G(@Y)'="" S LA7PIDA(X)=@Y
    212         I $D(LA7PIDA) D POI^LAGEN(LA7LWL,LA7ISQN,"PID",.LA7PIDA)
    213         ;
    214         ; Build/store order info array
    215         N LA7ONLTS
    216         I LA7POP'="" S LA7POP=$P(LA7POP," [")
    217         S X=$G(^LAH(LA7LWL,1,LA7ISQN,.1,"OBR","ORDNLT"))
    218         I X'="",LA7ONLT'="",X'[LA7ONLT S LA7ONLTS=X_"^"_LA7ONLT
    219         E  S LA7ONLTS=LA7ONLT
    220         S J="EOL^FID^ORCDT^ORDNLT^ORDP^ORDSPEC^PON^SID^PEB^PVB"
    221         S J(0)="LA7EOL^LA7FID^LA7CDT^LA7ONLTS^LA7POP^LA7SPEC^LA7PON^LA7SID^LA7PEB^LA7PVB"
    222         F I=1:1 S X=$P(J,"^",I) Q:X=""  D
    223         . S Y=$P(J(0),"^",I)
    224         . I $G(@Y)'="" S LA7OBRA(X)=@Y
    225         I $D(LA7OBRA) D POI^LAGEN(LA7LWL,LA7ISQN,"OBR",.LA7OBRA)
    226         ;
    227         ; Store interface type with results
    228         D LATYP^LAGEN(LA7LWL,LA7ISQN,LA7INTYP)
    229         ;
    230         ; Store #62.49 ien with results
    231         D LAMSGID^LAGEN(LA7LWL,LA7ISQN,LA76249)
    232         ;
    233         ; Store method name with LAH entry
    234         D METH^LAGEN(LA7LWL,LA7ISQN,METH)
    235         ;
    236         ; Set flag if POC interface to start POC processing routine when
    237         ; finished - tasked by LA7VIN before shutdown
    238         I LA7INTYP>19,LA7INTYP<30 S LA7INTYP("LWL",LA7LWL)=""
    239         ;
    240         Q
    241         ;
    242         ;
    243 SMUPDT  ; Update shipping manifest in shipping event file #62.85
    244         N LA7DATA,LA7NCS,LA7TST,LA7USID
    245         ;
    246         S LA7USID=$$P^LA7VHLU(.LA7SEG,5,LA7FS) ; Universal Service ID (OBR-4)
    247         S LA7TST=$P(LA7USID,LA7CS,1) ; Test code
    248         S LA7NCS=$P(LA7USID,LA7CS,3) ; Name of coding system
    249         S LA7TST(2)=$P(LA7USID,LA7CS,4) ; Alternate test code
    250         S LA7NCS(2)=$P(LA7USID,LA7CS,6) ; Alternate coding system
    251         ;
    252         ; Determine ordered test, check primary and alternate
    253         S LA7OTST=$$DOT^LA7SMU1(LA7TST,LA7NCS,LA7UID,$P(LA7SM,"^"))
    254         I 'LA7OTST,LA7TST(2)'="" S LA7OTST=$$DOT^LA7SMU1(LA7TST(2),LA7NCS(2),LA7UID,$P(LA7SM,"^"))
    255         ;
    256         ; Flag the Results Received Event in #62.85
    257         I LA7MTYP="ORU" D
    258         . S LA7DATA="SM70"_"^"_LA7MEDT_"^"_$G(LA7OTST)_"^"_$P(LA7SM,"^",2)
    259         . D SEUP^LA7SMU(LA7UID,"2",LA7DATA)
    260         ;
    261         ; Flag the Test Received Event in #62.85
    262         I LA7MTYP="ORR" D
    263         . S LA7DATA="SM55"_"^"_LA7MEDT_"^"_$G(LA7OTST)_"^"_$P(LA7SM,"^",2)
    264         . D SEUP^LA7SMU(LA7UID,"2",LA7DATA)
    265         Q
     1LA7VIN4 ;DALOI/JMC - Process Incoming UI Msgs, continued ; Jan 12, 2004
     2 ;;5.2;AUTOMATED LAB INSTRUMENTS;**46,64,67**;Sep 27, 1994
     3 ;This routine is a continuation of LA7VIN1 and is only called from there.
     4 Q
     5 ;
     6OBR ; Process OBR segments
     7 N I,LA7CUP,LA7ENTRY,LA7IDE,LA7INST,LA7PDUZ,LA7TRAY,LA7X,LA7Y
     8 ;
     9 ; OBR Set ID
     10 S LA7SOBR=$$P^LA7VHLU(.LA7SEG,2,LA7FS)
     11 ;
     12 S LA7X=$$P^LA7VHLU(.LA7SEG,19,LA7FS)
     13 S LA7X=$$UNESC^LA7VHLU3(LA7X,LA7FS_LA7ECH)
     14 S LA7624=0,LA7INST=$P(LA7X,"^") ; extracting 1st piece
     15 ; Look up #62.4 entry from instrument name.
     16 I LA7INST'="" S LA7624=+$O(^LAB(62.4,"B",LA7INST,0))
     17 ;
     18 ; If none then use sending application name to look up #62.4 entry.
     19 I 'LA7624 S LA7624=+$O(^LAB(62.4,"B",LA7SAP,0))
     20 ;
     21 ; Instrument name not found in xref
     22 I 'LA7624 D  Q
     23 . I LA7INST="" D  Q
     24 . . S LA7ERR=10,LA7QUIT=2
     25 . . D CREATE^LA7LOG(LA7ERR)
     26 . S LA7ERR=11,LA7QUIT=2
     27 . D CREATE^LA7LOG(LA7ERR)
     28 S LA7624(0)=$G(^LAB(62.4,LA7624,0))
     29 S LA7ID=$P(LA7624(0),"^")_"-I-"
     30 ;
     31 S LA7LWL=+$P(LA7624(0),"^",4) ;  Load/Work List
     32 S LA7ENTRY=$P(LA7624(0),"^",6) ;LOG,LLIST,IDENT or SEQN
     33 S:LA7ENTRY="" LA7ENTRY="LOG"
     34 ;
     35 ; Placer(sender)/filler order numbers
     36 S LA7X=$$P^LA7VHLU(.LA7SEG,3,LA7FS)
     37 S LA7SID=$P(LA7X,$E(LA7ECH)) F I=2:1:4 S LA7SID(I)=$P(LA7X,$E(LA7ECH),I)
     38 S LA7X=$$P^LA7VHLU(.LA7SEG,4,LA7FS)
     39 S LA7FID=$P(LA7X,$E(LA7ECH)) F I=2:1:4 S LA7FID(I)=$P(LA7X,$E(LA7ECH),I)
     40 ;
     41 ; Test order code - find order NLT code
     42 ; If POC interface then see if NLT is used for ordering code
     43 S LA7X=$$P^LA7VHLU(.LA7SEG,5,LA7FS),LA7ONLT=""
     44 F I=1,4 D  Q:LA7ONLT'=""
     45 . I $P(LA7X,LA7CS,I)'?5N1"."4N Q
     46 . I $P(LA7X,LA7CS,I+2)="99VA64" S LA7ONLT=$P(LA7X,LA7CS,I),LA7ONLT(0)=$P(LA7X,LA7CS,I+1) Q
     47 . I LA7INTYP>19,LA7INTYP<30,$P(LA7X,LA7CS,I+2)="" S LA7ONLT=$P(LA7X,LA7CS,I),LA7ONLT(0)=$P(LA7X,LA7CS,I+1) Q
     48 ;
     49 ; Specimen collection date/time
     50 S LA7CDT=$$HL7TFM^XLFDT($P($$P^LA7VHLU(.LA7SEG,8,LA7FS),LA7CS),"L")
     51 ;
     52 ; Pull info from placer field #2 (OBR-19)
     53 S LA7X=$$P^LA7VHLU(.LA7SEG,20,LA7FS)
     54 S LA7X=$$UNESC^LA7VHLU3(LA7X,LA7FS_LA7ECH)
     55 S LA7TRAY=+$P(LA7X,"^",1) ;Tray
     56 S LA7CUP=+$P(LA7X,"^",2) ; Cup
     57 ; If POC interface set cup to file #62.49 ien
     58 I LA7INTYP>19,LA7INTYP<30 S LA7CUP=LA76249
     59 S LA7AA=$P(LA7X,"^",3) ;  Accession Area
     60 S LA7AD=$P(LA7X,"^",4) ;  Accession Date
     61 S LA7AN=$P(LA7X,"^",5) ;  Accession Entry
     62 S LA7ACC=$P(LA7X,"^",6) ;  Accession
     63 S LA7UID=$P(LA7X,"^",7) ;  Unique ID
     64 I LA7UID'?1(10UN,15UN) S LA7UID=""
     65 ;
     66 ; Sequence Number
     67 ; If point of care interface (20-29) then use file #62.49 ien as IDE
     68 S LA7IDE=$P(LA7X,LA7CS,8)
     69 I LA7INTYP>19,LA7INTYP<30 S LA7IDE=LA76249
     70 ;
     71 ; UID might come as Sample ID
     72 I LA7UID="",LA7SID?1(10UN,15UN) S LA7UID=LA7SID
     73 ;
     74 ; Try to figure out LA7AA LA7AD LA7AN by using the unique ID (UID)
     75 ; accession may have rolled over, use UID to get current accession info.
     76 I LA7UID]"" D
     77 . N X
     78 . S X=$Q(^LRO(68,"C",LA7UID))
     79 . I $QS(X,3)'=LA7UID S LA7UID="" Q  ; UID not on file.
     80 . S LA7AA=+$QS(X,4),LA7AD=+$QS(X,5),LA7AN=+$QS(X,6)
     81 . D SETID^LA7VHLU1(LA76249,LA7ID,LA7UID)
     82 ;
     83 ; If still not known, compute from default accession date and area.
     84 ; Calculate accession date based on accession transform.
     85 I LA7AA<1!(LA7AD<1)!(LA7AN<1) D
     86 . N X
     87 . S LA7AA=+$P(LA7624(0),"^",11)
     88 . S X=$P($G(^LRO(68,LA7AA,0)),U,3)
     89 . S LA7AD=$S(X="D":DT,X="M":$E(DT,1,5)_"00",X="Y":$E(DT,1,3)_"0000",X="Q":$E(DT,1,3)_"0000"+(($E(DT,4,5)-1)\3*300+100),1:DT)
     90 . S LA7AN=+LA7SID
     91 . I LA7AN>0 D SETID^LA7VHLU1(LA76249,LA7ID,LA7AN)
     92 . E  D SETID^LA7VHLU1(LA76249,LA7ID,$S(LA7PNM]"":LA7PNM,LA7SSN]"":LA7SSN,1:"NO ID"))
     93 ;
     94 ; Zeroth node of acession area.
     95 S LA7AA(0)=$G(^LRO(68,+LA7AA,0))
     96 ; Accession's subscript
     97 S LA7SS=$P(LA7AA(0),"^",2)
     98 ;
     99 ; Specimen action code
     100 S LA7SAC=$$P^LA7VHLU(.LA7SEG,12,LA7FS)
     101 ;
     102 ; Specimen(topography), collection sample, HL7 specimen source
     103 S (LA761,LA762,LA70070,LA7SPEC)=""
     104 S LA7SPTY=$$P^LA7VHLU(.LA7SEG,16,LA7FS)
     105 ;
     106 ; Check if using HL7 table 0070
     107 S LA7X=$P($P(LA7SPTY,LA7CS),$E(LA7ECH,4),3)
     108 I LA7X=""!(LA7X="HL70070") S LA7SPEC=$P($P(LA7SPTY,LA7CS),$E(LA7ECH,4))
     109 ;
     110 I $O(^LRO(68,LA7AA,1,LA7AD,1,LA7AN,5,0)) D
     111 . N X
     112 . S X=$O(^LRO(68,LA7AA,1,LA7AD,1,LA7AN,5,0))
     113 . ; specimen^collection sample
     114 . S X(0)=$G(^LRO(68,LA7AA,1,LA7AD,1,LA7AN,5,X,0))
     115 . S LA761=$P(X(0),"^") ; specimen
     116 . S LA762=$P(X(0),"^",2) ; collection sample
     117 . ; HL7 code
     118 . I LA761 S LA70070=$$GET1^DIQ(61,LA761_",","LEDI HL7:HL7 ABBR")
     119 ;
     120 ; Log error when specimen source does not match accession's specimen
     121 I LA70070'="",LA7SPEC'="",LA70070'=LA7SPEC D
     122 . N LA7OBR
     123 . S LA7OBR(15)=LA7SPEC ; backward compatible with old code
     124 . S LA7ERR=22,LA7QUIT=2
     125 . D CREATE^LA7LOG(LA7ERR)
     126 ;
     127 ; Don't continue if flag set to skip this segment
     128 I LA7QUIT Q
     129 ;
     130 ; Placer's ordering provider (id^duz^last name, first name, mi [id])
     131 I $G(LA7POP)="" D
     132 . S LA7POP="",LA7X=$$P^LA7VHLU(.LA7SEG,17,LA7FS)
     133 . I LA7X="" Q
     134 . S LA7POP=$$XCNTFM^LA7VHLU4(LA7X,LA7ECH)
     135 . I LA7POP="^^" S LA7POP=""
     136 ;
     137 ; Create entry in LAH for supported subscripts.
     138 I LA7MTYP="ORR",$G(LA7OTYPE)'="OK","CHMI"[LA7SS D
     139 . D LAGEN
     140 . I $G(LA7ISQN)="" D CREATE^LA7LOG(14) Q
     141 . S LA7I=$O(^TMP("LA7 ORDER STATUS",$J,""),-1),LA7I=LA7I+1
     142 . I LA7ONLT="" S X=$$P^LA7VHLU(.LA7SEG,5,LA7FS),LA7X=$P(X,LA7CS),LA7X(0)=$P(X,LA7CS,2)
     143 . E  S LA7X=LA7ONLT,LA7X(0)=LA7ONLT(0)
     144 . S X=LA7LWL_"^"_LA7ISQN_"^"_LA7X_"^"_LA7X(0)_"^"_LA76248_"^"_LA76249_"^"_LA7OTYPE_"^^"_$P($G(LA7SM),"^",2)
     145 . S ^TMP("LA7 ORDER STATUS",$J,LA7I)=X
     146 . I $G(LA7OCR)'="" S ^TMP("LA7 ORDER STATUS",$J,LA7I,"OCR")=$TR(LA7OCR,LA7CS,"^")
     147 . I $G(LA7MSATM)'="" S ^TMP("LA7 ORDER STATUS",$J,LA7I,"MSA")=LA7MSATM
     148 ;
     149 I LA7MTYP="ORU","CHMI"[LA7SS D
     150 . D LAGEN
     151 . I $G(LA7ISQN)<1 D CREATE^LA7LOG(14) Q
     152 . I LA7INTYP=10,LA7SAC?1(1"A",1"G") D
     153 . . S LA7I=$O(^TMP("LA7 ORDER STATUS",$J,""),-1),LA7I=LA7I+1,LA7SAC(0)=LA7I
     154 . . I LA7ONLT="" S X=$$P^LA7VHLU(.LA7SEG,5,LA7FS),LA7X=$P(X,LA7CS),LA7X(0)=$P(X,LA7CS,2)
     155 . . E  S LA7X=LA7ONLT,LA7X(0)=LA7ONLT(0)
     156 . . S X=LA7LWL_"^"_LA7ISQN_"^"_LA7X_"^"_LA7X(0)_"^"_LA76248_"^"_LA76249_"^"_$G(LA7OTYPE)_"^"_LA7SAC_"^"_$P($G(LA7SM),"^",2)
     157 . . S ^TMP("LA7 ORDER STATUS",$J,LA7I)=X
     158 ;
     159 I LA7INTYP=10,$G(LA7SM)'="",$G(LA7UID)'="" D SMUPDT
     160 Q
     161 ;
     162 ;
     163LAGEN ; Sets up variables for call to ^LAGEN,  build entry in LAH
     164 ; requires LA7INST,LA7TRAY,LA7CUP,LA7AA,LA7AD,LA7AN,LA7LWL
     165 ; returns LA7ISQN=subscript to store results in ^LAH global
     166 ;
     167 I LA7ENTRY="LOG" D
     168 . I LA7INTYP>19,LA7INTYP<30 Q
     169 . I '$D(^LRO(68,LA7AA,1,LA7AD,1,LA7AN,0)) D CREATE^LA7LOG(13)
     170 I LA7ENTRY="LLIST" S:'LA7CUP LA7CUP=LA7IDE ;cup=sequence number
     171 ;
     172 K LA7ISQN,LADT,LAGEN
     173 K TRAY,CUP,LWL,WL,LROVER,METH,LOG,IDENT,ISQN
     174 ;
     175 S LA7ISQN=""
     176 S TRAY=+$G(LA7TRAY) S:'TRAY TRAY=1
     177 S CUP=+$G(LA7CUP) S:'CUP CUP=1
     178 ;
     179 S LWL=LA7LWL
     180 I '$D(^LRO(68.2,+LWL,0)) D  Q
     181 . D CREATE^LA7LOG(19)
     182 ;
     183 ; Set accession area to area of specimen, allow multiple areas on same instrument.
     184 S WL=LA7AA
     185 I '$D(^LRO(68,+WL,0)) D  Q
     186 . D CREATE^LA7LOG(20)
     187 S LROVER=$P(LA7624(0),"^",12)
     188 S METH=$P(LA7624(0),"^",10)
     189 S LOG=LA7AN
     190 S IDENT=$P($G(^LRO(68,LA7AA,1,LA7AD,1,LA7AN,0)),"^",6) ;identity field
     191 S IDE=+LA7IDE
     192 S LADT=LA7AD
     193 ;
     194 ; If POC interface call special entry point
     195 D
     196 . N LRDFN ; Protect LRDFN - call into LAGEN can set to 0
     197 . I LA7INTYP>19,LA7INTYP<30 S IDE=LA76249 D POC^LAGEN Q
     198 . D @(LA7ENTRY_"^LAGEN") ;this disregards the CROSS LINK field in 62.4
     199 S LA7ISQN=$G(ISQN)
     200 ;
     201 I LA7ISQN<1 Q
     202 ;
     203 ; Build/store patient demographics array
     204 N I,J,LA7OBRA,LA7PIDA,X,Y
     205 S J="DFN^DOB^ICN^LOC^LRDFN^LRTDFN^PNM^SEX^SSN"
     206 S J(0)="DFN^LA7DOB^LA7ICN^LA7LOC^LRDFN^LRTDFN^LA7PNM^LA7SEX^LA7SSN"
     207 F I=1:1 S X=$P(J,"^",I) Q:X=""  D
     208 . S Y=$P(J(0),"^",I)
     209 . I $G(@Y)'="" S LA7PIDA(X)=@Y
     210 I $D(LA7PIDA) D POI^LAGEN(LA7LWL,LA7ISQN,"PID",.LA7PIDA)
     211 ;
     212 ; Build/store order info array
     213 N LA7ONLTS
     214 I LA7POP'="" S LA7POP=$P(LA7POP," [")
     215 S X=$G(^LAH(LA7LWL,1,LA7ISQN,.1,"OBR","ORDNLT"))
     216 I X'="",LA7ONLT'="",X'[LA7ONLT S LA7ONLTS=X_"^"_LA7ONLT
     217 E  S LA7ONLTS=LA7ONLT
     218 S J="EOL^FID^ORCDT^ORDNLT^ORDP^ORDSPEC^PON^SID^PEB^PVB"
     219 S J(0)="LA7EOL^LA7FID^LA7CDT^LA7ONLTS^LA7POP^LA7SPEC^LA7PON^LA7SID^LA7PEB^LA7PVB"
     220 F I=1:1 S X=$P(J,"^",I) Q:X=""  D
     221 . S Y=$P(J(0),"^",I)
     222 . I $G(@Y)'="" S LA7OBRA(X)=@Y
     223 I $D(LA7OBRA) D POI^LAGEN(LA7LWL,LA7ISQN,"OBR",.LA7OBRA)
     224 ;
     225 ; Store interface type with results
     226 D LATYP^LAGEN(LA7LWL,LA7ISQN,LA7INTYP)
     227 ;
     228 ; Store #62.49 ien with results
     229 D LAMSGID^LAGEN(LA7LWL,LA7ISQN,LA76249)
     230 ;
     231 ; Store method name with LAH entry
     232 D METH^LAGEN(LA7LWL,LA7ISQN,METH)
     233 ;
     234 ; Set flag if POC interface to start POC processing routine when
     235 ; finished - tasked by LA7VIN before shutdown
     236 I LA7INTYP>19,LA7INTYP<30 S LA7INTYP("LWL",LA7LWL)=""
     237 ;
     238 Q
     239 ;
     240 ;
     241SMUPDT ; Update shipping manifest in shipping event file #62.85
     242 N LA7DATA,LA7NCS,LA7TST,LA7USID
     243 ;
     244 S LA7USID=$$P^LA7VHLU(.LA7SEG,5,LA7FS) ; Universal Service ID (OBR-4)
     245 S LA7TST=$P(LA7USID,LA7CS,1) ; Test code
     246 S LA7NCS=$P(LA7USID,LA7CS,3) ; Name of coding system
     247 S LA7TST(2)=$P(LA7USID,LA7CS,4) ; Alternate test code
     248 S LA7NCS(2)=$P(LA7USID,LA7CS,6) ; Alternate coding system
     249 ;
     250 ; Determine ordered test, check primary and alternate
     251 S LA7OTST=$$DOT^LA7SMU1(LA7TST,LA7NCS,LA7UID,$P(LA7SM,"^"))
     252 I 'LA7OTST,LA7TST(2)'="" S LA7OTST=$$DOT^LA7SMU1(LA7TST(2),LA7NCS(2),LA7UID,$P(LA7SM,"^"))
     253 ;
     254 ; Flag the Results Received Event in #62.85
     255 I LA7MTYP="ORU" D
     256 . S LA7DATA="SM70"_"^"_LA7MEDT_"^"_$G(LA7OTST)_"^"_$P(LA7SM,"^",2)
     257 . D SEUP^LA7SMU(LA7UID,"2",LA7DATA)
     258 ;
     259 ; Flag the Test Received Event in #62.85
     260 I LA7MTYP="ORR" D
     261 . S LA7DATA="SM55"_"^"_LA7MEDT_"^"_$G(LA7OTST)_"^"_$P(LA7SM,"^",2)
     262 . D SEUP^LA7SMU(LA7UID,"2",LA7DATA)
     263 Q
Note: See TracChangeset for help on using the changeset viewer.