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

revised back to 6/30/08 version

Location:
WorldVistAEHR/trunk/r/AUTOMATED_LAB_INSTRUMENTS-LA
Files:
4 edited

Legend:

Unmodified
Added
Removed

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

    r613 r623  
    1 LA7ADL  ;DALOI/JMC - Automatic Download of Test Orders;May 30, 2008
    2         ;;5.2;AUTOMATED LAB INSTRUMENTS;**17,25,23,57,66**;Sep 27, 1994;Build 30
    3         ;
    4         ; This routine will monitor the ^LA("ADL") node to check for accessions which are to have test orders automatically
    5         ; downloaded to another computer system. All entries in the auto instrument file which are flagged for automatic downloading
    6         ; will be checked to see if they contain any tests on the accession. If tests are found then the appropiate download message
    7         ; is constructed and sent.
    8         ;
    9         ;
    10 EN(LA7UID)      ; Set flag to check accession for downloading, start background job if needed.
    11         ; Called by LR7OMERG, LRCONJAM, LRTSTSET, LRWLST1.
    12         ;
    13         ; No UID passed to routine.
    14         I $G(LA7UID)="" Q
    15         ;
    16         ; No instrument flagged for auto downloading.
    17         I '$D(^LAB(62.4,"AE")) Q
    18         ;
    19         ; Quit if "Don't Start/Collect" flag set.
    20         I +$G(^LA("ADL","STOP"),0)=3 Q
    21         ;
    22         ; Lock node in case already downloading this accession, wait until downloading finished.
    23         L +^LA("ADL","Q",LA7UID):60
    24         ;
    25         ; Set flag to check this accession for auto downloading.
    26         S ^LA("ADL","Q",LA7UID)=""
    27         ;
    28         ; Release lock.
    29         L -^LA("ADL","Q",LA7UID)
    30         ;
    31         ; Quit if "Don't Start" flag set.
    32         I +$G(^LA("ADL","STOP"),0)=2 Q
    33         ;
    34         ; Task background job to run.
    35         D CHKTSK
    36         ;
    37         ; Unlock node.
    38         L -^LA("ADL",0)
    39         ;
    40         Q
    41         ;
    42         ;
    43 DQ      ; Entry point from Taskman.
    44         ;
    45         ; Wait for a little while in case another job checking for background job has lock.
    46         L +^LA("ADL",0):10
    47         ; Another process has lock, only want one at a time.
    48         I '$T S:$D(ZTQUEUED) ZTREQ="@" Q
    49         ;
    50         ; No instrument flagged for auto downloading.
    51         I '$D(^LAB(62.4,"AE")) D EXIT Q
    52         ;
    53         ; Quit if "Don't Start/Collect" flags set.
    54         I +$G(^LA("ADL","STOP"),0)>1 Q
    55         ;
    56         ; Update XTMP entry to let auto download know we're running for this process
    57         ;  and build table of tests to check for downloading}
    58         D XTMP,BUILD
    59         ;
    60         F  D UID Q:TOUT>60
    61         D EXIT
    62         Q
    63         ;
    64         ;
    65 UID     ; Start loop to monitor for accessions to download.
    66         ;
    67         S LA7UID="",(TOUT,ZTSTOP)=0
    68         ;
    69         ; Flag set to "Rebuild".
    70         I +$G(^LA("ADL","STOP"))=1,'ZTSTOP D BUILD
    71         ;
    72         F  S LA7UID=$O(^LA("ADL","Q",LA7UID)) Q:LA7UID=""!(ZTSTOP)!(TOUT)  D
    73         . I +$G(^LA("ADL","STOP"))>0 S TOUT=61 Q
    74         . I $$S^%ZTLOAD("Processing Lab UID "_LA7UID) S ZTSTOP=1,TOUT=61 Q
    75         . ; Lock this UID, synch setting/deleting when another job is attempting to set node.
    76         . D LOCK^DILF("^LA(""ADL"",""Q"",LA7UID)")
    77         . ; Unable to get lock, go on to next UID, check again on next go around.
    78         . I '$T Q
    79         . ; Get accession info from ^LRO(68,"C").
    80         . S X=$Q(^LRO(68,"C",LA7UID))
    81         . ; Quit - UID does not match.
    82         . I $QS(X,3)'=LA7UID D CLEANUP Q
    83         . ; Setup accession variables for auto downloading.
    84         . S LRAA=+$QS(X,4),LRAD=+$QS(X,5),LRAN=+$QS(X,6)
    85         . D BLDTST
    86         . S LA7INST=0
    87         . F  S LA7INST=$O(LA7AUTO(LA7INST)) Q:'LA7INST  D
    88         . . D CHKTEST
    89         . . ; No tests on instrument list for this accession.
    90         . . I '$D(LA7ACC) Q
    91         . . S LRINST=LA7INST,LRAUTO=LA7AUTO(LA7INST)
    92         . . N LA7UID
    93         . . ; File build (entry^routine) from fields #93 and #94 in file #62.4.
    94         . . D @$P(LA7AUTO(LA7INST,9),"^",3,4)
    95         . D CLEANUP,XTMP
    96         ;
    97         F  D  Q:$O(^LA("ADL","Q",""))'=""  Q:TOUT>60
    98         . I $G(^LA("ADL","STOP"))>1 S TOUT=61 Q
    99         . ; Task has been requested to stop.
    100         . I $$S^%ZTLOAD("Idle - waiting for new accessions to process") S TOUT=61,ZTSTOP=1 Q
    101         . S TOUT=TOUT+1 H 5 D XTMP
    102         ;
    103         Q
    104         ;
    105         ;
    106 BLDTST  ; Build array of tests on accession to check for downloading
    107         ;
    108         N X,LA760,LA7PCNT
    109         ;
    110         K LA7TREE
    111         S LA760=0
    112         F  S LA760=$O(^LRO(68,LRAA,1,LRAD,1,LRAN,4,LA760)) Q:'LA760  D
    113         . ; Quit if test has been removed from accession.
    114         . S X=$G(^LRO(68,LRAA,1,LRAD,1,LRAN,4,LA760,0),0) Q:'X
    115         . ; If test completed (#4, COMPLETE DATE entered), don't download.
    116         . I $P(X,"^",5) Q
    117         . ; Build array of atomic tests on accession with urgency.
    118         . S LA7PCNT=0
    119         . D UNWIND^LA7ADL1(LA760,$P(X,"^",2),0)
    120         ;
    121         Q
    122         ;
    123         ;
    124 CHKTEST ; Check tests to determine if they should build in message.
    125         ; Array LA7ACC returned with tests to send in message
    126         ;
    127         N LA760,LA761,LA76205,LA768,LA7I,LRDPF,X
    128         ;
    129         K LA7ACC
    130         ;
    131         ; Quit - specimen uncollected & don't download uncollected flag set.
    132         ;        controls exempted.
    133         S LRDPF=$P($G(^LRO(68,LRAA,1,LRAD,1,LRAN,0)),"^",2)
    134         S X=$G(^LRO(68,LRAA,1,LRAD,1,LRAN,3))
    135         I LRDPF'=62.3,'$P(X,"^",3),'$P(^TMP("LA7-INST",$J,LA7INST),"^") Q
    136         ;
    137         S X=$O(^LRO(68,LRAA,1,LRAD,1,LRAN,5,0))
    138         S LA761=$P(^LRO(68,LRAA,1,LRAD,1,LRAN,5,X,0),"^")
    139         S LA760=0
    140         F  S LA760=$O(LA7TREE(LA760)) Q:'LA760  D
    141         . I '$D(^TMP("LA7-INST",$J,LA7INST,LA760)) Q
    142         . S LA7I=0
    143         . F  S LA7I=$O(^TMP("LA7-INST",$J,LA7INST,LA760,LA7I)) Q:'LA7I  D
    144         . . S LA76205=+$P(LA7TREE(LA760),"^")
    145         . . D CHKMASK
    146         ;
    147         Q
    148         ;
    149 CHKMASK ; Check pattern mask for tests that match download pattern mask
    150         ;
    151         ; Any accession area, specimen, urgency
    152         I $D(^TMP("LA7-INST",$J,LA7INST,LA760,LA7I,0,0,0)) D ADD Q
    153         ;
    154         ; Specific accession area, any specimen/urgency
    155         I $D(^TMP("LA7-INST",$J,LA7INST,LA760,LA7I,LRAA,0,0)) D ADD Q
    156         ;
    157         ; Specific specimen, any accession area/urgency
    158         I $D(^TMP("LA7-INST",$J,LA7INST,LA760,LA7I,0,LA761,0)) D ADD Q
    159         ;
    160         ; Specific urgency, any accession area/specimen
    161         I $D(^TMP("LA7-INST",$J,LA7INST,LA760,LA7I,0,0,LA76205)) D ADD Q
    162         ;
    163         ; Specific accession/specimen, any urgency
    164         I $D(^TMP("LA7-INST",$J,LA7INST,LA760,LA7I,LRAA,LA761,0)) D ADD Q
    165         ;
    166         ; Specific specimen/urgency, any accession area
    167         I $D(^TMP("LA7-INST",$J,LA7INST,LA760,LA7I,0,LA761,LA76205)) D ADD Q
    168         ;
    169         ; Specific accession/specimen/urgency
    170         I $D(^TMP("LA7-INST",$J,LA7INST,LA760,LA7I,LRAA,LA761,LA76205)) D ADD Q
    171         ;
    172         Q
    173         ;
    174 ADD     ; Add to list of tests to download
    175         ;
    176         S LA7ACC(LA7I)=LA760_"^"_LA7TREE(LA760)
    177         Q
    178         ;
    179         ;
    180 CLEANUP ; Delete flag after accession has been checked.
    181         ; NOTE: Lock previously set above.
    182         ;
    183         K ^LA("ADL","Q",LA7UID)
    184         ;
    185         ; Release lock on this UID.
    186         L -^LA("ADL","Q",LA7UID)
    187         ;
    188         Q
    189         ;
    190         ;
    191 CHKTSK  ; Check if we shoud task the auto download processing routine.
    192         ; Check if we recently tasked the processing routine for this process by compaing values in the XTMP global.
    193         ; Done to avoid repetitive locking attempts on each new accessione since the FileMan locking API uses a site-defined timeout which is usually 3 seconds
    194         ; but can be more. Slows down the interface if on each accession we are waiting 3 or more seconds for the lock to find out if the processing routine
    195         ; is already running.
    196         ;
    197         N LA7X,LA7Y
    198         S LA7X=$H,LA7Y=$G(^XTMP("LA7ADL",1))
    199         I $P(LA7X,",")=$P(LA7Y,","),($P(LA7X,",",2)-$P(LA7Y,",",2))<240 Q
    200         ;
    201         ; Lock zeroth node.
    202         ; Quit if another process has lock - either another job setting node or the background job.
    203         D LOCK^DILF("^LA(""ADL"",0)")
    204         I '$T Q
    205         ;
    206 ZTSK    ; Task background job to run.
    207         ;
    208         ; Call here to queue this processing routine to run in the background.
    209         ;
    210         ; Task background job if not running.
    211         N ZTDESC,ZTSAVE,ZTDTH,ZTIO,ZTRTN
    212         S ZTRTN="DQ^LA7ADL",ZTDESC="Lab Auto Download",ZTIO="",ZTDTH=$H
    213         D ^%ZTLOAD
    214         ;
    215         Q
    216         ;
    217         ;
    218 BUILD   ; Build TMP global with list of tests for instruments flagged for auto download.
    219         ;
    220         D BUILD^LA7ADL1
    221         ;
    222         ; Set flag to "Running".
    223         D SETSTOP^LA7ADL1(0,$G(DUZ))
    224         ;
    225         Q
    226         ;
    227         ;
    228 XTMP    ; Set/update XTMP with current run time of this processing routine
    229         ;
    230         S DT=$$DT^XLFDT
    231         S ^XTMP("LA7ADL",0)=DT_"^"_DT_"^LAB AUTO DOWNLOAD PROCESS TASKING"
    232         S ^XTMP("LA7ADL",1)=$H
    233         Q
    234         ;
    235         ;
    236 EXIT    ; Exit and cleanup.
    237         ;
    238         ; Release lock on LA("ADL") global.
    239         L -^LA("ADL",0)
    240         ;
    241         K ^TMP("LA7",$J),^TMP($J),^XTMP("LA7ADL",1)
    242         K LA7ADL,LA7AUTO,LA7NVAF,LRAA,LRAD,LRAN,TOUT
    243         ;
    244         ; Clear flag if normal shutdown, no new accessions.
    245         I +$G(^LA("ADL","STOP"))<2 K ^LA("ADL","STOP")
    246         ;
    247         ; Set flag for taskman to cleanup task.
    248         I $D(ZTQUEUED) S ZTREQ="@"
    249         Q
     1LA7ADL ;DALOI/JMC - Automatic Download of Test Orders; 1/30/95 09:00
     2 ;;5.2;AUTOMATED LAB INSTRUMENTS;**17,25,23,57**;Sep 27, 1994
     3 ;
     4 ; This routine will monitor the ^LA("ADL") node to check for accessions which are to have test orders automatically
     5 ; downloaded to another computer system. All entries in the auto instrument file which are flagged for automatic downloading
     6 ; will be checked to see if they contain any tests on the accession. If tests are found then the appropiate download message
     7 ; is constructed and sent.
     8 ;
     9 ;
     10EN(LA7UID) ; Set flag to check accession for downloading, start background job if needed.
     11 ; Called by LR7OMERG, LRCONJAM, LRTSTSET, LRWLST1.
     12 ;
     13 ; No UID passed to routine.
     14 I $G(LA7UID)="" Q
     15 ;
     16 ; No instrument flagged for auto downloading.
     17 I '$D(^LAB(62.4,"AE")) Q
     18 ;
     19 ; Quit if "Don't Start/Collect" flag set.
     20 I +$G(^LA("ADL","STOP"),0)=3 Q
     21 ;
     22 ; Lock node in case already downloading this accession, wait until downloading finished.
     23 L +^LA("ADL","Q",LA7UID):60
     24 ;
     25 ; Set flag to check this accession for auto downloading.
     26 S ^LA("ADL","Q",LA7UID)=""
     27 ;
     28 ; Release lock.
     29 L -^LA("ADL","Q",LA7UID)
     30 ;
     31 ; Quit if "Don't Start" flag set.
     32 I +$G(^LA("ADL","STOP"),0)=2 Q
     33 ;
     34 ; Lock zeroth node.
     35 ; Quit if another process has lock
     36 ; - either another job setting node or the background job.
     37 L +^LA("ADL",0):1
     38 I '$T Q
     39 ;
     40 ; Task background job to run.
     41 N ZTSK
     42 D ZTSK
     43 ;
     44 ; Unlock node.
     45 L -^LA("ADL",0)
     46 ;
     47 Q
     48 ;
     49 ;
     50DQ ; Entry point from Taskman.
     51 ;
     52 ; Set flag for taskman to cleanup task.
     53 I $D(ZTQUEUED) S ZTREQ="@"
     54 ;
     55 ; Wait for a little while in case another job checking for background job has lock.
     56 L +^LA("ADL",0):10
     57 ; Another process has lock, only want one at a time.
     58 I '$T Q
     59 ;
     60 ; No instrument flagged for auto downloading.
     61 I '$D(^LAB(62.4,"AE")) D EXIT Q
     62 ;
     63 ; Quit if "Don't Start/Collect" flags set.
     64 I +$G(^LA("ADL","STOP"),0)>1 Q
     65 ;
     66 D BUILD
     67 ;
     68 F  D UID Q:TOUT>60
     69 D EXIT
     70 Q
     71 ;
     72 ;
     73UID ; Start loop to monitor for accessions to download.
     74 ;
     75 S LA7UID="",(TOUT,ZTSTOP)=0
     76 ;
     77 ; Flag set to "Rebuild".
     78 I +$G(^LA("ADL","STOP"))=1,'ZTSTOP D BUILD
     79 ;
     80 F  S LA7UID=$O(^LA("ADL","Q",LA7UID)) Q:LA7UID=""!(ZTSTOP)!(TOUT)  D
     81 . I +$G(^LA("ADL","STOP"))>0 S TOUT=61 Q
     82 . I $$S^%ZTLOAD S ZTSTOP=1,TOUT=61 Q
     83 . ; Lock this UID, synch setting/deleting when another job is attempting to set node.
     84 . L +^LA("ADL","Q",LA7UID):1
     85 . ; Unable to get lock, go on to next UID, check again on next go around.
     86 . I '$T Q
     87 . ; Get accession info from ^LRO(68,"C").
     88 . S X=$Q(^LRO(68,"C",LA7UID))
     89 . ; Quit - UID does not match.
     90 . I $QS(X,3)'=LA7UID D CLEANUP Q
     91 . ; Setup accession variables for auto downloading.
     92 . S LRAA=+$QS(X,4),LRAD=+$QS(X,5),LRAN=+$QS(X,6)
     93 . D BLDTST
     94 . S LA7INST=0
     95 . F  S LA7INST=$O(LA7AUTO(LA7INST)) Q:'LA7INST  D
     96 . . D CHKTEST
     97 . . ; No tests on instrument list for this accession.
     98 . . I '$D(LA7ACC) Q
     99 . . S LRINST=LA7INST,LRAUTO=LA7AUTO(LA7INST)
     100 . . N LA7UID
     101 . . ; File build (entry^routine) from fields #93 and #94 in file #62.4.
     102 . . D @$P(LA7AUTO(LA7INST,9),"^",3,4)
     103 . D CLEANUP
     104 ;
     105 F  D  Q:$O(^LA("ADL","Q",""))'=""  Q:TOUT>60
     106 . I $G(^LA("ADL","STOP"))>1 S TOUT=61 Q
     107 . ; Task has been requested to stop.
     108 . I $$S^%ZTLOAD S TOUT=61,ZTSTOP=1 Q
     109 . S TOUT=TOUT+1 H 5
     110 ;
     111 Q
     112 ;
     113 ;
     114BLDTST ; Build array of tests on accession to check for downloading
     115 ;
     116 N X,LA760,LA7PCNT
     117 ;
     118 K LA7TREE
     119 S LA760=0
     120 F  S LA760=$O(^LRO(68,LRAA,1,LRAD,1,LRAN,4,LA760)) Q:'LA760  D
     121 . ; Quit if test has been removed from accession.
     122 . S X=$G(^LRO(68,LRAA,1,LRAD,1,LRAN,4,LA760,0),0) Q:'X
     123 . ; If test completed (#4, COMPLETE DATE entered), don't download.
     124 . I $P(X,"^",5) Q
     125 . ; Build array of atomic tests on accession with urgency.
     126 . S LA7PCNT=0
     127 . D UNWIND^LA7ADL1(LA760,$P(X,"^",2),0)
     128 ;
     129 Q
     130 ;
     131 ;
     132CHKTEST ; Check tests to determine if they should build in message.
     133 ; Array LA7ACC returned with tests to send in message
     134 ;
     135 N LA760,LA761,LA76205,LA768,LA7I,LRDPF,X
     136 ;
     137 K LA7ACC
     138 ;
     139 ; Quit - specimen uncollected & don't download uncollected flag set.
     140 ;        controls exempted.
     141 S LRDPF=$P($G(^LRO(68,LRAA,1,LRAD,1,LRAN,0)),"^",2)
     142 S X=$G(^LRO(68,LRAA,1,LRAD,1,LRAN,3))
     143 I LRDPF'=62.3,'$P(X,"^",3),'$P(^TMP("LA7-INST",$J,LA7INST),"^") Q
     144 ;
     145 S X=$O(^LRO(68,LRAA,1,LRAD,1,LRAN,5,0))
     146 S LA761=$P(^LRO(68,LRAA,1,LRAD,1,LRAN,5,X,0),"^")
     147 S LA760=0
     148 F  S LA760=$O(LA7TREE(LA760)) Q:'LA760  D
     149 . I '$D(^TMP("LA7-INST",$J,LA7INST,LA760)) Q
     150 . S LA7I=0
     151 . F  S LA7I=$O(^TMP("LA7-INST",$J,LA7INST,LA760,LA7I)) Q:'LA7I  D
     152 . . S LA76205=+$P(LA7TREE(LA760),"^")
     153 . . D CHKMASK
     154 ;
     155 Q
     156 ;
     157CHKMASK ; Check pattern mask for tests that match download pattern mask
     158 ;
     159 ; Any accession area, specimen, urgency
     160 I $D(^TMP("LA7-INST",$J,LA7INST,LA760,LA7I,0,0,0)) D ADD Q
     161 ;
     162 ; Specific accession area, any specimen/urgency
     163 I $D(^TMP("LA7-INST",$J,LA7INST,LA760,LA7I,LRAA,0,0)) D ADD Q
     164 ;
     165 ; Specific specimen, any accession area/urgency
     166 I $D(^TMP("LA7-INST",$J,LA7INST,LA760,LA7I,0,LA761,0)) D ADD Q
     167 ;
     168 ; Specific urgency, any accession area/specimen
     169 I $D(^TMP("LA7-INST",$J,LA7INST,LA760,LA7I,0,0,LA76205)) D ADD Q
     170 ;
     171 ; Specific accession/specimen, any urgency
     172 I $D(^TMP("LA7-INST",$J,LA7INST,LA760,LA7I,LRAA,LA761,0)) D ADD Q
     173 ;
     174 ; Specific specimen/urgency, any accession area
     175 I $D(^TMP("LA7-INST",$J,LA7INST,LA760,LA7I,0,LA761,LA76205)) D ADD Q
     176 ;
     177 ; Specific accession/specimen/urgency
     178 I $D(^TMP("LA7-INST",$J,LA7INST,LA760,LA7I,LRAA,LA761,LA76205)) D ADD Q
     179 ;
     180 Q
     181 ;
     182ADD ; Add to list of tests to download
     183 ;
     184 S LA7ACC(LA7I)=LA760_"^"_LA7TREE(LA760)
     185 Q
     186 ;
     187 ;
     188CLEANUP ; Delete flag after accession has been checked.
     189 ; NOTE: Lock previously set above.
     190 ;
     191 K ^LA("ADL","Q",LA7UID)
     192 ;
     193 ; Release lock on this UID.
     194 L -^LA("ADL","Q",LA7UID)
     195 ;
     196 Q
     197 ;
     198 ;
     199ZTSK ; Task background job to run.
     200 ;
     201 N ZTDESC,ZTSAVE,ZTDTH,ZTIO,ZTRTN
     202 ;
     203 ; Task background job if not running.
     204 S ZTRTN="DQ^LA7ADL",ZTDESC="Lab Auto Download",ZTIO="",ZTDTH=$H
     205 D ^%ZTLOAD
     206 ;
     207 Q
     208 ;
     209 ;
     210BUILD ; Build TMP global with list of tests for instruments flagged for auto download.
     211 D BUILD^LA7ADL1
     212 ;
     213 ; Set flag to "Running".
     214 D SETSTOP^LA7ADL1(0,$G(DUZ))
     215 ;
     216 Q
     217 ;
     218 ;
     219EXIT ; Exit and cleanup.
     220 ;
     221 ; Release lock on LA("ADL") global.
     222 L -^LA("ADL",0)
     223 ;
     224 K ^TMP("LA7",$J),^TMP($J)
     225 K LA7ADL
     226 K LRAA,LRAD,LRAN
     227 K TOUT
     228 ;
     229 ; Clear flag if normal shutdown, no new accessions.
     230 I +$G(^LA("ADL","STOP"))<2 K ^LA("ADL","STOP")
     231 ;
     232 Q

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

    r613 r623  
    1 LA7UID  ;DALIO/JRR - BUILD HL7 DOWNLOAD TO UI ;May 20, 2008
    2         ;;5.2;AUTOMATED LAB INSTRUMENTS;**17,57,66**;Sep 27, 1994;Build 30
    3         ;
    4         Q
    5         ;
    6 EN      ; This line tag is called from ^LADOWN when downloading
    7         ; a load work list to the Auto Instrument.  LADOWN1 should
    8         ; have already built ^TMP($J with all of the atomic and
    9         ; cosmic tests, ^TMP("LA7",$J holds all of the Instrument defined
    10         ; tests from 62.4.
    11         ; LRLL= IEN in 68.2 Load Worklist file, from field in 62.4
    12         ; LRINST= IEN IN 62.4 Auto Inst file
    13         ; LRAUTO= zero node of 62.4 entry
    14         ;
    15         N LA7MODE
    16         S LA7INST=LRINST
    17         I '$G(LA7ADL) D BLDINST^LA7ADL1(LA7INST,LRLL)
    18         S LA76248=$P($G(^LAB(62.4,+$G(LRINST),0)),"^",8)
    19         I 'LA76248 D  Q
    20         . S XQAMSG="MESSAGE CONFIGURATION not defined in AUTO INSTRUMENT file for "_$P(LRAUTO,"^")
    21         . D ERROR,EXIT
    22         . I '$D(ZTQUEUED) D  ;
    23         . . W $C(7),!!,"You must have a MESSAGE CONFIGURATION defined in field 8 of"
    24         . . W !,"the AUTO INSTRUMENT file before downloading to this instrument!"
    25         . ;
    26         ;
    27         I '$P(^LAHM(62.48,LA76248,0),"^",3) D  Q
    28         . S XQAMSG="STATUS field in the LA7 MESSAGE PARAMETER file not turned on for "_$P(LRAUTO,"^")
    29         . D ERROR,EXIT
    30         . I '$D(ZTQUEUED) D  ;
    31         . . W $C(7),!!,"The STATUS field in the LA7 MESSAGE PARAMETER file must be "
    32         . . W !,"turned on before downloading to this instrument!"
    33         . ;
    34         ;
    35         S LA7MODE=$P(^LAHM(62.48,LA76248,0),"^",4)
    36         ;
    37         ; Call the routine specified in the PROCESS DOWNLOAD field in file 62.48
    38         ; Download for one whole load list is done
    39         X $G(^LAHM(62.48,LA76248,2))
    40         ;
    41 EXIT    I '$G(LA7ADL) K ^TMP("LA7",$J),LA76248
    42         Q
    43         ;
    44         ;
    45 ERROR   ; Send warning of error in Auto Instrument file configuration.
    46         S XQA("G.LAB MESSAGING")=""
    47         D SETUP^XQALERT
    48         K XQA,XQAMSG
    49         Q
     1LA7UID ;DALOI/JMC - BUILD HL7 DOWNLOAD TO UI; 12/3/1997
     2 ;;5.2;AUTOMATED LAB INSTRUMENTS;**17,57**;Sep 27, 1994
     3 Q
     4 ;
     5EN ;; This line tag is called from ^LADOWN when downloading
     6 ;  a load work list to the Auto Instrument.
     7 ;
     8 ; LRLL= IEN in 68.2 Load Worklist file, from field in 62.4
     9 ; LRINST= IEN IN 62.4 Auto Inst file
     10 ; LRAUTO= zero node of 62.4 entry
     11 ;
     12 S LA7INST=LRINST
     13 I '$G(LA7ADL) D BLDINST^LA7ADL1(LA7INST,LRLL)
     14 S LA76248=$P(^LAB(62.4,LA7INST,0),"^",8)
     15 I 'LA76248 D  Q
     16 . I '$D(ZTQUEUED) D
     17 . . W $C(7),!!,"You must have a MESSAGE CONFIGURATION defined in field 8 of"
     18 . . W !,"the AUTO INSTRUMENT file before downloading to this instrument!"
     19 . S XQAMSG="MESSAGE CONFIGURATION not defined in AUTO INSTRUMENT file for "_$P(LRAUTO,"^")
     20 . D ERROR
     21 . D EXIT
     22 ;
     23 I '$P(^LAHM(62.48,LA76248,0),"^",3) D  Q
     24 . I '$D(ZTQUEUED) D
     25 . . W $C(7),!!,"The STATUS field in the MESSAGE PARAMETER file must be "
     26 . . W !,"turned on before downloading to this instrument!"
     27 . S XQAMSG="STATUS field in the MESSAGE PARAMETER file not turned on for "_$P(LRAUTO,"^")
     28 . D ERROR
     29 . D EXIT
     30 ;
     31 S LA7MODE=$P(^LAHM(62.48,LA76248,0),"^",4)
     32 ;
     33 ;
     34CALL ; Call the routine specified in the PROCESS DOWNLOAD field
     35 ; in file 62.48
     36 X $G(^LAHM(62.48,LA76248,2))
     37 ;
     38 ;
     39EXIT ; Download for one whole load list is done
     40 I '$G(LA7ADL) K ^TMP("LA7-INST",$J),LA76248,LA7MODE
     41 Q
     42 ;
     43 ;
     44ERROR ; Send warning of error in Auto Instrument file configuration.
     45 ;
     46 S XQA("G.LAB MESSAGING")=""
     47 D SETUP^XQALERT
     48 Q

  • 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

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

    r613 r623  
    1 LA7VIN5A        ;DALOI/JMC - Process Incoming UI Msgs, continued ;May 29, 2008
    2         ;;5.2;AUTOMATED LAB INSTRUMENTS;**46,64,67,72,66**;Sep 27, 1994;Build 30
    3         ; This routine is a continuation of LA7VIN5.
    4         ; It is performs processing of fields in OBX segments.
    5         Q
    6         ;
    7 XFORM   ; Transform the result based on fields 12,13,14,16,17 in the Chem Test
    8         ; multiple in the Auto Instrument file (62.4), or set on the fly
    9         ; from PARAM 1
    10         N LA7I
    11         S LA7XFORM=LA76241(2)
    12         ;
    13         ; get PARAM 1 overrides
    14         I $D(LA7XFORM(1)),LA7XFORM(1)?1.N S $P(LA7XFORM,"^")=LA7XFORM(1)
    15         F LA7I=2,3,5,6 I $D(LA7XFORM(LA7I)) S $P(LA7XFORM,"^",LA7I)=LA7XFORM(LA7I)
    16         ; set up defaults if field was not answered
    17         ; accept results,yes
    18         I $P(LA7XFORM,"^",3)="" S $P(LA7XFORM,"^",3)=1
    19         ; strip spaces,no
    20         I $P(LA7XFORM,"^",6)="" S $P(LA7XFORM,"^",6)=0
    21         ; now transform
    22         ;
    23         ; Don't accept results
    24         I '$P(LA7XFORM,"^",3) S LA7VAL="" Q
    25         ;
    26         ; Only accept "FINAL" type results
    27         I $P(LA7XFORM,"^",3)=2,"CFUX"'[LA7ORS S LA7VAL="" Q
    28         ;
    29         ; Accept ordered tests only
    30         ; If LEDI interface (10) and message indicates a reflex ("G") or add-on
    31         ; test ("A") then process anyway in case it has not been added to
    32         ; accession.
    33         I $P(LA7XFORM,"^",5) D
    34         . I LA7INTYP=10,LA7SAC?1(1"A",1"G") Q
    35         . S LA7LIMIT=1
    36         ;
    37         ; Decimal places if number of places defined
    38         I $P(LA7XFORM,"^")?1.N D JUSTDEC
    39         ;
    40         ; Strip spaces
    41         I $P(LA7XFORM,"^",6) S LA7VAL=$TR(LA7VAL," ","")
    42         ;
    43         ; Make result a comment
    44         ; Set value to null after making into remark, don't store twice.
    45         I $P(LA7XFORM,"^",2) D
    46         . N LA7Y
    47         . ; Store comment in ^LAH global
    48         . S LA7Y=$P(LA7RMK(0,+LA76241(0)),"^",2)
    49         . D RMKSET^LASET(LA7LWL,LA7ISQN,LA7VAL,LA7Y)
    50         . S LA7VAL=""
    51         Q
    52         ;
    53         ;
    54 CHKDIE  ; Check if value to be stored passes input transform of field in DD
    55         N LA7ERR,LA7Y
    56         ;
    57         ; If result is on a LEDI interface (type=10) then don't check result
    58         ; against FileMan input transform.
    59         ; VistA sends "canc" as test result when test is cancelled.
    60         ; DoD sends "PL Canceled" --> change to "canc" for VistA storage.
    61         I LA7INTYP=10 D  Q
    62         . I LA7VAL="PL Cancelled" S LA7VAL="canc"
    63         . I LA7VAL="PL Canceled" S LA7VAL="canc"
    64         . I LA7VAL="PLCanceled" S LA7VAL="canc"
    65         ;
    66         ; If value fails data checker then log error and suppress result.
    67         D CHK^DIE(LA7SUBFL,LA76304,"H",LA7VAL,.LA7Y,"LA7ERR")
    68         I LA7Y="^" D
    69         . N LA7X
    70         . S LA7X=$G(LA7ERR("DIERR",1,"TEXT",1))
    71         . D CREATE^LA7LOG(37)
    72         . S LA7VAL=""
    73         Q
    74         ;
    75         ;
    76 JUSTDEC ; Justify to number of places specified
    77         ;
    78         N LA7DDTYP,LA7FMT,LA7I,LA7PRFIX,LA7X
    79         ;
    80         ; If LEDI interface (type=10) then skip decimal adjustment
    81         I LA7INTYP=10 Q
    82         ;
    83         ; Get data name field type from DD
    84         ; Only justify if Vista field is numeric or free text.
    85         S LA7DDTYP=$$GET1^DID(LA7SUBFL,LA76304,"","TYPE")
    86         I "NUMERIC^FREE TEXT"'[LA7DDTYP D  Q
    87         . N LA7FLDNM
    88         . S LA7FLDNM=$$GET1^DID(63.04,LA76304,"","LABEL")
    89         . D CREATE^LA7LOG(38)
    90         ;
    91         S LA7X=LA7VAL,(LA7FMT,LA7PRFIX)=""
    92         ;
    93         ; If comma formatted, strip comma and set flag to add back in.
    94         S LA7X=$TR(LA7X,",","")
    95         I LA7X'=LA7VAL S LA7FMT="P"
    96         ;
    97         ; If "<>=" formatted, strip and save to add back in.
    98         F LA7I=1:1:$L(LA7X) Q:$E(LA7X,LA7I)'?1(1"<",1">",1"=")
    99         I LA7I>1 D
    100         . S LA7PRFIX=$E(LA7X,1,LA7I-1)
    101         . S LA7X=$E(LA7X,LA7I,$L(LA7X))
    102         ;
    103         ; Format if starts with number or decimal point, skip other results.
    104         I LA7X?1(1.N,.N1"."1.N) D
    105         . S LA7X=$FN(LA7X,LA7FMT,+LA7XFORM)
    106         . S LA7VAL=LA7PRFIX_LA7X
    107         Q
    108         ;
    109         ;
    110 PRDID(LA7PRDID,LA7SFAC,LA7CS)   ; Process/Store Producer's ID
    111         ; Store where test was performed.
    112         ; Call with LA7PRDID = Producer's ID field
    113         ;            LA7SFAC = sending facility
    114         ;              LA7CS = component encoding character
    115         ;
    116         ; Remove units/reference ranges when Lab UI interface
    117         ; so file #60 settings always used
    118         I $G(LA7INTYP)=1 S $P(^LAH(LA7LWL,1,LA7ISQN,LA76304),"^",5)="" Q
    119         ;
    120         N LA74,LA7I,LA7X,LA7Y
    121         ;
    122         S LA7X=$P(LA7PRDID,LA7CS,2),LA74=""
    123         ;
    124         F LA7I=1,4 D  Q:LA74
    125         . I $P(LA7PRDID,LA7CS,LA7I+2)="99VA4" S LA74=$$LKUP^XUAF4($P(LA7PRDID,LA7CS,LA7I))
    126         . I 'LA74,$P(LA7PRDID,LA7CS,LA7I+2)?1(1"L-CL",1"CLIA",1"99VACLIA") S LA74=$$IDX^XUAF4("CLIA",$P(LA7PRDID,LA7CS,LA7I))
    127         . I 'LA74 S LA74=$$LKUP^XUAF4($P(LA7PRDID,LA7CS,LA7I+1))
    128         . I 'LA74 S LA74=$$FINDSITE^LA7VHLU2($P(LA7PRDID,LA7CS),1,1)
    129         . I 'LA74 S LA74=$$FINDSITE^LA7VHLU2($P(LA7SFAC,LA7CS),1,1)
    130         ;
    131         ; Store producer's id in LAH global with results.
    132         I LA74 S $P(^LAH(LA7LWL,1,LA7ISQN,LA76304),"^",9)=LA74 Q
    133         ;
    134         ; Don't store producer's id as comment.
    135         I '$P(LA76241(2),"^",9) Q
    136         ; If unable to identify producer in file #4
    137         ;  then store as comment if field STORE PRODUCER'S ID (#20) enabled.
    138         I LA7X="" Q
    139         S LA7Y=$P(LA7RMK(0,+LA76241(0)),"^",2)
    140         S LA7X=$S(LA7Y="":"P",1:"p")_"erformed by "_LA7X
    141         D RMKSET^LASET(LA7LWL,LA7ISQN,LA7X,LA7Y)
    142         ;
    143         Q
    144         ;
    145         ;
    146 REFRNG(LA7X)    ; Process/Store References Range.
    147         ; Call with LA7X = reference range to store.
    148         ;
    149         Q:$G(LA7INTYP)=1
    150         N LA7Y,X,Y
    151         ;
    152         ; Check if site does not want to store reference ranges on POC test.
    153         I LA7INTYP>19,LA7INTYP<30,+$P(LA76241(2),"^",10)=0 Q
    154         ;
    155         ; Remove leading and trailing quotes from reference range.
    156         S LA7X=$$TRIM^XLFSTR($G(LA7X),"RL","""")
    157         I LA7X="" Q
    158         ;
    159         S X=$P($G(^LAH(LA7LWL,1,LA7ISQN,LA76304)),"^",5)
    160         ;
    161         ; >lower limit (no upper limit e.g. >10) - store as low value
    162         I LA7X?1">".N.1".".N S $P(X,"!",2)=$TR(LA7X,">",""),LA7X=""
    163         ;
    164         ; <upper limit (no lower limit e.g. <15) - store as high value
    165         I LA7X?1"<".N.1".".N S $P(X,"!",3)=$TR(LA7X,"<",""),LA7X=""
    166         ;
    167         ; Alphabetic reference with hyphen
    168         I LA7X?1.A1"-"1.A S $P(X,"!",2)=$C(34)_LA7X_$C(34),LA7X=""
    169         ;
    170         ; Lower limit value
    171         S Y=$P(LA7X,"-")
    172         I Y'="" D
    173         . I Y?.N.1".".N S $P(X,"!",2)=Y
    174         . E  S $P(X,"!",2)=$C(34)_$$UNESC^LA7VHLU3(Y,LA7FS_LA7ECH)_$C(34)
    175         ;
    176         ; Upper limit value
    177         S Y=$P(LA7X,"-",2)
    178         I Y'="" D
    179         . I Y?.N.1".".N S $P(X,"!",3)=Y
    180         . E  S $P(X,"!",3)=$C(34)_$$UNESC^LA7VHLU3(Y,LA7FS_LA7ECH)_$C(34)
    181         ;
    182         ; Store reference range in LAH global with results.
    183         S $P(^LAH(LA7LWL,1,LA7ISQN,LA76304),"^",5)=X
    184         ;
    185         Q
    186         ;
    187         ;
    188 ABFLAG(LA7X)    ; Process/Store Abnormal Flags.
    189         ; Call with LA7X = abnormal flags to store.
    190         ; Converts flag to interpretation based on HL7 Table 0078.
    191         ; If no match store code instead of interpretation
    192         ;
    193         Q:LA7INTYP=1
    194         N I,LA7I,LA7Y,X
    195         ;
    196         ; Store abnormal flags in LAH global with results.
    197         ; Currently only storing high/low and critical flags
    198         S LA7Y=$S(LA7X="L":"L",LA7X="H":"H",LA7X="LL":"L*",LA7X="HH":"H*",1:"")
    199         S $P(^LAH(LA7LWL,1,LA7ISQN,LA76304),"^",2)=LA7Y
    200         ;
    201         ; Critical or designated abnormal tests generate bulletin/alert
    202         ; on LEDI (type=10) interfaces.
    203         I LA7INTYP=10,LA7Y'="" D
    204         . I $E(LA7Y,2)'="*",'$P(LA76241(2),"^",11) Q
    205         . S LA7I=$O(^TMP("LA7 ABNORMAL RESULTS",$J,""),-1),LA7I=LA7I+1
    206         . S X=LA7LWL_"^"_LA7ISQN_"^"_LA76304_"^"_LA76248_"^"_LA76249_"^"_LA7ORS_"^"_LA7TEST_"^"_$S(LA7TEST(0)'="":LA7TEST(0),1:LA7TEST(2,0))_"^"_$$P^LA7VHLU(.LA7SEG,9,LA7FS)
    207         . S ^TMP("LA7 ABNORMAL RESULTS",$J,LA7I)=X
    208         ;
    209         ; If POC interface and abnormal flag is not handled by VistA above
    210         ;  then store as comment.
    211         I LA7INTYP>19,LA7INTYP<30,LA7Y="",LA7X'="" D
    212         . S X=" L^ H^LL^HH^ <^ >^ N^ A^AA^ U^ D^ B^ W^ S^ R^ I^MS^VS"
    213         . S I=$F(X,LA7X)\3
    214         . S LA7Y="normalcy status - "_$P($T(ABFLAGS+I^LA7VHLU1),";;",2)
    215         . D RMKSET^LASET(LA7LWL,LA7ISQN,LA7Y,$P(LA7RMK(0,+LA76241(0)),"^",2))
    216         ;
    217         Q
    218         ;
    219         ;
    220 EII     ; Store equipment instance identifier in LAH global with results.
    221         ;
    222         N I,LA7X,X
    223         ;
    224         S LA7X=""
    225         F I=1:1:4 D
    226         . S X=$P(LA7EII,LA7CS,I)
    227         . I X="" Q
    228         . S $P(LA7X,"!",I)=$TR(X,"!","~")
    229         I LA7X'="" S $P(^LAH(LA7LWL,1,LA7ISQN,LA76304),"^",11)=LA7X
    230         Q
    231         ;
    232         ;
    233 ORESULTS        ; Process results that accompany order (ORM) messages
    234         ;
    235         N I,LA764,LA7DIE,LA7ERR,LA7I,LA7WP,LA7X,LA7Y,X
    236         S LA7WP(1,0)=" ",LA7I=2,X=""
    237         I LA7RLNC S X="[LOINC "_$$GET1^DIQ(95.3,LA7RLNC_",",.01)_"] "_$$GET1^DIQ(95.3,LA7RLNC_",",80)
    238         I 'LA7RLNC,LA7RNLT D
    239         . S LA764=$$FIND1^DIC(64,"","X",LA7RNLT,"E","","LA7ERR")
    240         . I 'LA764 S LA7RNLT="" Q
    241         . S X="[NLT "_$$GET1^DIQ(64,LA764_",",1)_"] "_$$GET1^DIQ(64,LA764_",",.01,"I")
    242         I 'LA7RLNC,'LA7RNLT D
    243         . I LA7TEST(0)]""!(LA7TEST]"") S X="["_LA7TEST(0,1)_" "_LA7TEST_"] "_LA7TEST(0) Q
    244         . S X="["_LA7TEST(2,1)_" "_LA7TEST(2)_"] "_LA7TEST(2,0)
    245         S LA7WP(LA7I,0)="Test result: "_X
    246         ; Date value
    247         I LA7VTYP="DT" D
    248         . S LA7X=$$P^LA7VHLU(.LA7SEG,6,LA7FS)
    249         . S LA7X=$$HL7TFM^XLFDT(LA7X,"L")
    250         . S LA7I=LA7I+1,LA7WP(LA7I,0)=" Test value: "_LA7X
    251         ; Coded entry
    252         I "CECM"[LA7VTYP D
    253         . S LA7X=$P($$P^LA7VHLU(.LA7SEG,6,LA7FS),LA7CS,2)
    254         . S LA7X=$$UNESC^LA7VHLU3(LA7X,LA7FS_LA7ECH)
    255         . S LA7I=LA7I+1,LA7WP(LA7I,0)=" Test value: "_LA7X_$S(LA7UNITS]"":" "_LA7UNITS,1:"")
    256         ; Numeric/ Structured Numeric value
    257         I "NMSN"[LA7VTYP D
    258         . S LA7X=$$P^LA7VHLU(.LA7SEG,6,LA7FS)
    259         . S LA7X=$$UNESC^LA7VHLU3(LA7X,LA7FS_LA7ECH)
    260         . S LA7I=LA7I+1,LA7WP(LA7I,0)=" Test value: "_LA7X_$S(LA7UNITS]"":" "_LA7UNITS,1:"")
    261         ; String Data/ Formatted Text/ Text Data
    262         I "FTSTX"[LA7VTYP D
    263         . D PA^LA7VHLU(.LA7SEG,6,LA7FS,.LA7X)
    264         . D UNESCFT^LA7VHLU3(.LA7X,LA7FS_LA7ECH,.LA7Y)
    265         . I LA7Y=1,(($L(LA7Y(1,0))+$L(LA7UNITS))<225) S LA7I=LA7I+1,LA7WP(LA7I,0)=" Test value: "_LA7Y(1,0)_$S(LA7UNITS]"":" "_LA7UNITS,1:"") Q
    266         . S LA7I=LA7I+1,LA7WP(LA7I,0)=" Test value:"
    267         . F I=1:1:LA7Y S LA7I=LA7I+1,LA7WP(LA7I,0)=LA7Y(I,0)
    268         . I LA7UNITS'="" S LA7I=LA7I+1,LA7WP(LA7I,0)=" Test units: "_LA7UNITS
    269         ; Normals/ Reference range
    270         S LA7X=$$P^LA7VHLU(.LA7SEG,8,LA7FS)
    271         I LA7X'="" S LA7I=LA7I+1,LA7WP(LA7I,0)=" Test normals: "_LA7X
    272         ; Normalcy status
    273         S LA7X=$$P^LA7VHLU(.LA7SEG,9,LA7FS)
    274         I LA7X'="" D
    275         . S X=" L^ H^LL^HH^ <^ >^ N^ A^AA^ U^ D^ B^ W^ S^ R^ I^MS^VS"
    276         . S I=$F(X,LA7X)\3,LA7X=$P($T(ABFLAGS+I^LA7VHLU1),";;",2)
    277         . I LA7X'="" S LA7I=LA7I+1,LA7WP(LA7I,0)=" Test normalcy status: "_LA7X
    278         I $D(LA7WP) D WP^DIE(69.6,LA7696_",",99,"A","LA7WP","LA7DIE(99)")
    279         Q
     1LA7VIN5A ;DALOI/JMC - Process Incoming UI Msgs, continued ; Jan 12, 2004
     2 ;;5.2;AUTOMATED LAB INSTRUMENTS;**46,64,67,72**;Sep 27, 1994
     3 ; This routine is a continuation of LA7VIN5.
     4 ; It is performs processing of fields in OBX segments.
     5 Q
     6 ;
     7XFORM ; Transform the result based on fields 12,13,14,16,17 in the Chem Test
     8 ; multiple in the Auto Instrument file (62.4), or set on the fly
     9 ; from PARAM 1
     10 N LA7I
     11 S LA7XFORM=LA76241(2)
     12 ;
     13 ; get PARAM 1 overides
     14 I $D(LA7XFORM(1)),LA7XFORM(1)?1.N S $P(LA7XFORM,"^")=LA7XFORM(1)
     15 F LA7I=2,3,5,6 I $D(LA7XFORM(LA7I)) S $P(LA7XFORM,"^",LA7I)=LA7XFORM(LA7I)
     16 ; set up defaults if field was not answered
     17 ; accept results,yes
     18 I $P(LA7XFORM,"^",3)="" S $P(LA7XFORM,"^",3)=1
     19 ; strip spaces,no
     20 I $P(LA7XFORM,"^",6)="" S $P(LA7XFORM,"^",6)=0
     21 ; now transform
     22 ;
     23 ; Don't accept results
     24 I '$P(LA7XFORM,"^",3) S LA7VAL="" Q
     25 ;
     26 ; Only accept "FINAL" type results
     27 I $P(LA7XFORM,"^",3)=2,"CFUX"'[LA7ORS S LA7VAL="" Q
     28 ;
     29 ; Accept ordered tests only
     30 ; If LEDI interface (10) and message indicates a reflex ("G") or add-on
     31 ; test ("A") then process anyway in case it has not been added to
     32 ; accession.
     33 I $P(LA7XFORM,"^",5) D
     34 . I LA7INTYP=10,LA7SAC?1(1"A",1"G") Q
     35 . S LA7LIMIT=1
     36 ;
     37 ; Decimal places if number of places defined
     38 I $P(LA7XFORM,"^")?1.N D JUSTDEC
     39 ;
     40 ; Strip spaces
     41 I $P(LA7XFORM,"^",6) S LA7VAL=$TR(LA7VAL," ","")
     42 ;
     43 ; Make result a comment
     44 ; Set value to null after making into remark, don't store twice.
     45 I $P(LA7XFORM,"^",2) D
     46 . N LA7Y
     47 . ; Store comment in ^LAH global
     48 . S LA7Y=$P(LA7RMK(0,+LA76241(0)),"^",2)
     49 . D RMKSET^LASET(LA7LWL,LA7ISQN,LA7VAL,LA7Y)
     50 . S LA7VAL=""
     51 Q
     52 ;
     53 ;
     54CHKDIE ; Check if value to be stored passes input transform of field in DD
     55 N LA7ERR,LA7Y
     56 ;
     57 ; If result is on a LEDI interface (type=10) then don't check result
     58 ; against FileMan input tranform.
     59 ; VistA sends "canc" as test result when test is cancelled.
     60 ; DoD sends "PL Canceled" --> change to "canc" for VistA storage.
     61 I LA7INTYP=10 D  Q
     62 . I LA7VAL="PL Cancelled" S LA7VAL="canc"
     63 . I LA7VAL="PL Canceled" S LA7VAL="canc"
     64 . I LA7VAL="PLCanceled" S LA7VAL="canc"
     65 ;
     66 ; If value fails data checker then log error and suppress result.
     67 D CHK^DIE(LA7SUBFL,LA76304,"H",LA7VAL,.LA7Y,"LA7ERR")
     68 I LA7Y="^" D
     69 . N LA7X
     70 . S LA7X=$G(LA7ERR("DIERR",1,"TEXT",1))
     71 . D CREATE^LA7LOG(37)
     72 . S LA7VAL=""
     73 Q
     74 ;
     75 ;
     76JUSTDEC ; Justify to number of places specified
     77 ;
     78 N LA7DDTYP,LA7FMT,LA7I,LA7PRFIX,LA7X
     79 ;
     80 ; If LEDI interface (type=10) then skip decimal adjustment
     81 I LA7INTYP=10 Q
     82 ;
     83 ; Get data name field type from DD
     84 ; Only justify if Vista field is numeric or free text.
     85 S LA7DDTYP=$$GET1^DID(LA7SUBFL,LA76304,"","TYPE")
     86 I "NUMERIC^FREE TEXT"'[LA7DDTYP D  Q
     87 . N LA7FLDNM
     88 . S LA7FLDNM=$$GET1^DID(63.04,LA76304,"","LABEL")
     89 . D CREATE^LA7LOG(38)
     90 ;
     91 S LA7X=LA7VAL,(LA7FMT,LA7PRFIX)=""
     92 ;
     93 ; If comma formatted, strip comma and set flag to add back in.
     94 S LA7X=$TR(LA7X,",","")
     95 I LA7X'=LA7VAL S LA7FMT="P"
     96 ;
     97 ; If "<>=" formatted, strip and save to add back in.
     98 F LA7I=1:1:$L(LA7X) Q:$E(LA7X,LA7I)'?1(1"<",1">",1"=")
     99 I LA7I>1 D
     100 . S LA7PRFIX=$E(LA7X,1,LA7I-1)
     101 . S LA7X=$E(LA7X,LA7I,$L(LA7X))
     102 ;
     103 ; Format if starts with number or decimal point, skip other results.
     104 I LA7X?1(1.N,.N1"."1.N) D
     105 . S LA7X=$FN(LA7X,LA7FMT,+LA7XFORM)
     106 . S LA7VAL=LA7PRFIX_LA7X
     107 Q
     108 ;
     109 ;
     110PRDID(LA7PRDID,LA7SFAC,LA7CS) ; Process/Store Producer's ID
     111 ; Store where test was performed.
     112 ; Call with LA7PRDID = Producer's ID field
     113 ;            LA7SFAC = sending facility
     114 ;              LA7CS = component encoding character
     115 ;
     116 N LA74,LA7I,LA7X,LA7Y
     117 ;
     118 S LA7X=$P(LA7PRDID,LA7CS,2),LA74=""
     119 ;
     120 F LA7I=1,4 D  Q:LA74
     121 . I $P(LA7PRDID,LA7CS,LA7I+2)="99VA4" S LA74=$$LKUP^XUAF4($P(LA7PRDID,LA7CS,LA7I))
     122 . I 'LA74 S LA74=$$LKUP^XUAF4($P(LA7PRDID,LA7CS,LA7I+1))
     123 . I 'LA74 S LA74=$$FINDSITE^LA7VHLU2($P(LA7PRDID,LA7CS),1,1)
     124 . I 'LA74 S LA74=$$FINDSITE^LA7VHLU2($P(LA7SFAC,LA7CS),1,1)
     125 ;
     126 ; Store producer's id in LAH global with results.
     127 I LA74 S $P(^LAH(LA7LWL,1,LA7ISQN,LA76304),"^",9)=LA74 Q
     128 ;
     129 ; Don't store producer's id as comment.
     130 I '$P(LA76241(2),"^",9) Q
     131 ; If unable to identify producer in file #4
     132 ;  then store as comment if field STORE PRODUCER'S ID (#20) enabled.
     133 I LA7X="" Q
     134 S LA7Y=$P(LA7RMK(0,+LA76241(0)),"^",2)
     135 S LA7X=$S(LA7Y="":"P",1:"p")_"erformed by "_LA7X
     136 D RMKSET^LASET(LA7LWL,LA7ISQN,LA7X,LA7Y)
     137 ;
     138 Q
     139 ;
     140 ;
     141REFRNG(LA7X) ; Process/Store References Range.
     142 ; Call with LA7X = reference range to store.
     143 ;
     144 N LA7Y,X,Y
     145 ;
     146 ; Check if site does not want to store reference ranges on POC test.
     147 I LA7INTYP>19,LA7INTYP<30,+$P(LA76241(2),"^",10)=0 Q
     148 ;
     149 ; Remove leading and trailing quotes from reference range.
     150 S LA7X=$$TRIM^XLFSTR($G(LA7X),"RL","""")
     151 I LA7X="" Q
     152 ;
     153 S X=$P($G(^LAH(LA7LWL,1,LA7ISQN,LA76304)),"^",5)
     154 ;
     155 ; >lower limit (no upper limit e.g. >10) - store as low value
     156 I LA7X?1">".N.1".".N S $P(X,"!",2)=$TR(LA7X,">",""),LA7X=""
     157 ;
     158 ; <upper limit (no lower limit e.g. <15) - store as high value
     159 I LA7X?1"<".N.1".".N S $P(X,"!",3)=$TR(LA7X,"<",""),LA7X=""
     160 ;
     161 ; Alphabetic reference with hyphen
     162 I LA7X?1.A1"-"1.A S $P(X,"!",2)=$C(34)_LA7X_$C(34),LA7X=""
     163 ;
     164 ; Lower limit value
     165 S Y=$P(LA7X,"-")
     166 I Y'="" D
     167 . I Y?.N.1".".N S $P(X,"!",2)=Y
     168 . E  S $P(X,"!",2)=$C(34)_$$UNESC^LA7VHLU3(Y,LA7FS_LA7ECH)_$C(34)
     169 ;
     170 ; Upper limit value
     171 S Y=$P(LA7X,"-",2)
     172 I Y'="" D
     173 . I Y?.N.1".".N S $P(X,"!",3)=Y
     174 . E  S $P(X,"!",3)=$C(34)_$$UNESC^LA7VHLU3(Y,LA7FS_LA7ECH)_$C(34)
     175 ;
     176 ; Store reference range in LAH global with results.
     177 S $P(^LAH(LA7LWL,1,LA7ISQN,LA76304),"^",5)=X
     178 ;
     179 Q
     180 ;
     181 ;
     182ABFLAG(LA7X) ; Process/Store Abnormal Flags.
     183 ; Call with LA7X = abnormal flags to store.
     184 ; Converts flag to interpretation based on HL7 Table 0078.
     185 ; If no match store code instead of interpretation
     186 ;
     187 N I,LA7I,LA7Y,X
     188 ;
     189 ; Store abnormal flags in LAH global with results.
     190 ; Currently only storing high/low and critical flags
     191 S LA7Y=$S(LA7X="L":"L",LA7X="H":"H",LA7X="LL":"L*",LA7X="HH":"H*",1:"")
     192 S $P(^LAH(LA7LWL,1,LA7ISQN,LA76304),"^",2)=LA7Y
     193 ;
     194 ; Critical or designated abnormal tests generate bulletin/alert
     195 ; on LEDI (type=10) interfaces.
     196 I LA7INTYP=10,LA7Y'="" D
     197 . I $E(LA7Y,2)'="*",'$P(LA76241(2),"^",11) Q
     198 . S LA7I=$O(^TMP("LA7 ABNORMAL RESULTS",$J,""),-1),LA7I=LA7I+1
     199 . S X=LA7LWL_"^"_LA7ISQN_"^"_LA76304_"^"_LA76248_"^"_LA76249_"^"_LA7ORS_"^"_LA7TEST_"^"_$S(LA7TEST(0)'="":LA7TEST(0),1:LA7TEST(2,0))_"^"_$$P^LA7VHLU(.LA7SEG,9,LA7FS)
     200 . S ^TMP("LA7 ABNORMAL RESULTS",$J,LA7I)=X
     201 ;
     202 ; If POC interface and abnormal flag is not handled by VistA above
     203 ;  then store as comment.
     204 I LA7INTYP>19,LA7INTYP<30,LA7Y="",LA7X'="" D
     205 . S X=" L^ H^LL^HH^ <^ >^ N^ A^AA^ U^ D^ B^ W^ S^ R^ I^MS^VS"
     206 . S I=$F(X,LA7X)\3
     207 . S LA7Y="normalcy status - "_$P($T(ABFLAGS+I^LA7VHLU1),";;",2)
     208 . D RMKSET^LASET(LA7LWL,LA7ISQN,LA7Y,$P(LA7RMK(0,+LA76241(0)),"^",2))
     209 ;
     210 Q
     211 ;
     212 ;
     213EII ; Store equipment instance identifier in LAH global with results.
     214 ;
     215 N I,LA7X,X
     216 ;
     217 S LA7X=""
     218 F I=1:1:4 D
     219 . S X=$P(LA7EII,LA7CS,I)
     220 . I X="" Q
     221 . S $P(LA7X,"!",I)=$TR(X,"!","~")
     222 I LA7X'="" S $P(^LAH(LA7LWL,1,LA7ISQN,LA76304),"^",11)=LA7X
     223 Q
     224 ;
     225 ;
     226ORESULTS ; Process results that accompany order (ORM) messages
     227 ;
     228 N I,LA764,LA7DIE,LA7ERR,LA7I,LA7WP,LA7X,LA7Y,X
     229 S LA7WP(1,0)=" ",LA7I=2,X=""
     230 I LA7RLNC S X="[LOINC "_$$GET1^DIQ(95.3,LA7RLNC_",",.01)_"] "_$$GET1^DIQ(95.3,LA7RLNC_",",80)
     231 I 'LA7RLNC,LA7RNLT D
     232 . S LA764=$$FIND1^DIC(64,"","X",LA7RNLT,"E","","LA7ERR")
     233 . I 'LA764 S LA7RNLT="" Q
     234 . S X="[NLT "_$$GET1^DIQ(64,LA764_",",1)_"] "_$$GET1^DIQ(64,LA764_",",.01,"I")
     235 I 'LA7RLNC,'LA7RNLT D
     236 . I LA7TEST(0)]""!(LA7TEST]"") S X="["_LA7TEST(0,1)_" "_LA7TEST_"] "_LA7TEST(0) Q
     237 . S X="["_LA7TEST(2,1)_" "_LA7TEST(2)_"] "_LA7TEST(2,0)
     238 S LA7WP(LA7I,0)="Test result: "_X
     239 ; Date value
     240 I LA7VTYP="DT" D
     241 . S LA7X=$$P^LA7VHLU(.LA7SEG,6,LA7FS)
     242 . S LA7X=$$HL7TFM^XLFDT(LA7X,"L")
     243 . S LA7I=LA7I+1,LA7WP(LA7I,0)=" Test value: "_LA7X
     244 ; Coded entry
     245 I "CECM"[LA7VTYP D
     246 . S LA7X=$P($$P^LA7VHLU(.LA7SEG,6,LA7FS),LA7CS,2)
     247 . S LA7X=$$UNESC^LA7VHLU3(LA7X,LA7FS_LA7ECH)
     248 . S LA7I=LA7I+1,LA7WP(LA7I,0)=" Test value: "_LA7X_$S(LA7UNITS]"":" "_LA7UNITS,1:"")
     249 ; Numeric/ Structured Numeric value
     250 I "NMSN"[LA7VTYP D
     251 . S LA7X=$$P^LA7VHLU(.LA7SEG,6,LA7FS)
     252 . S LA7X=$$UNESC^LA7VHLU3(LA7X,LA7FS_LA7ECH)
     253 . S LA7I=LA7I+1,LA7WP(LA7I,0)=" Test value: "_LA7X_$S(LA7UNITS]"":" "_LA7UNITS,1:"")
     254 ; String Data/ Formatted Text/ Text Data
     255 I "FTSTX"[LA7VTYP D
     256 . D PA^LA7VHLU(.LA7SEG,6,LA7FS,.LA7X)
     257 . D UNESCFT^LA7VHLU3(.LA7X,LA7FS_LA7ECH,.LA7Y)
     258 . I LA7Y=1,(($L(LA7Y(1,0))+$L(LA7UNITS))<225) S LA7I=LA7I+1,LA7WP(LA7I,0)=" Test value: "_LA7Y(1,0)_$S(LA7UNITS]"":" "_LA7UNITS,1:"") Q
     259 . S LA7I=LA7I+1,LA7WP(LA7I,0)=" Test value:"
     260 . F I=1:1:LA7Y S LA7I=LA7I+1,LA7WP(LA7I,0)=LA7Y(I,0)
     261 . I LA7UNITS'="" S LA7I=LA7I+1,LA7WP(LA7I,0)=" Test units: "_LA7UNITS
     262 ; Normals/ Reference range
     263 S LA7X=$$P^LA7VHLU(.LA7SEG,8,LA7FS)
     264 I LA7X'="" S LA7I=LA7I+1,LA7WP(LA7I,0)=" Test normals: "_LA7X
     265 ; Normalcy status
     266 S LA7X=$$P^LA7VHLU(.LA7SEG,9,LA7FS)
     267 I LA7X'="" D
     268 . S X=" L^ H^LL^HH^ <^ >^ N^ A^AA^ U^ D^ B^ W^ S^ R^ I^MS^VS"
     269 . S I=$F(X,LA7X)\3,LA7X=$P($T(ABFLAGS+I^LA7VHLU1),";;",2)
     270 . I LA7X'="" S LA7I=LA7I+1,LA7WP(LA7I,0)=" Test normalcy status: "_LA7X
     271 I $D(LA7WP) D WP^DIE(69.6,LA7696_",",99,"A","LA7WP","LA7DIE(99)")
     272 Q
Note: See TracChangeset for help on using the changeset viewer.