Changeset 438


Ignore:
Timestamp:
Apr 28, 2009, 10:37:09 PM (12 years ago)
Author:
George Lilly
Message:

changes to lab extract

Location:
ccr/trunk/p
Files:
2 edited

Legend:

Unmodified
Added
Removed
  • ccr/trunk/p/C0CLA7Q.m

    r435 r438  
    1 C0CLA7Q ;WV/JMC - CCD/CCR Lab HL7 Query Utility ;Apr 13, 2009
     1C0CLA7Q ;WV/JMC - CCD/CCR Lab HL7 Query Utility ;Apr 21, 2009
    22        ;;n.n;;****;
    33        ;
     
    6969        ; Call from LA7QRY2
    7070        ;
    71         N DFN,C0C60,C0C63,C0CACC,C0CDA,C0CDT,C0CLN,C0CPDA,C0CPTEST,C0CTEST,X
     71        N DFN,C0C60,C0C63,C0CACC,C0CDA,C0CDT,C0CLN,C0CPDA,C0CPTEST,C0CSPEC,C0CTEST,X
    7272        ;
    7373        S DFN=$P(^LR(LRDFN,0),"^",3)
    7474        S C0C63(0)=^LR(LRDFN,LRSS,LRIDT,0)
    75         S C0CDT=$P(C0C63(0),"^"),C0CACC=$P(C0C63(0),"^",6)
     75        S C0CDT=$P(C0C63(0),"^"),C0CACC=$P(C0C63(0),"^",6),C0CSPEC=$P(C0C63(0),"^",5)
     76        S (C0CTEST,C0CTEST(64),C0CPTEST,C0CPTEST(64),C0CLN)=""
    7677        ;
    7778        ; ^AUPNVLAB("ALR1",5380,3080307.211055,"EKT 0307 48",188,5427202)=""
    7879        ;
    79         S C0C60=0,C0CLN=""
     80        S C0C60=""
    8081        F  S C0C60=$O(^LAB(60,"C",LRSS_";"_LRSB_";1",C0C60)) Q:'C0C60  D  Q:C0CLN'=""
    81         . S C0CDA=$O(^AUPNVLAB("ALR1",DFN,C0CDT,C0CACC,C0C60,0))
     82        . D FINDDT
    8283        . I C0CDA<1 Q
    8384        . S C0CLN=$P($G(^AUPNVLAB(C0CDA,11)),"^",13)
    8485        . S C0CPDA=$P($G(^AUPNVLAB(C0CDA,12)),"^",8)
    8586        . I C0CPDA="" S C0CPDA=C0CDA
    86         . S C0CTEST=$P($G(^AUPNVLAB(C0CDA,0)),"^")
    87         . S C0CPTEST=$P($G(^AUPNVLAB(C0CPDA,0)),"^")
     87        . S C0CTEST=$P($G(^AUPNVLAB(C0CDA,0)),"^"),X=$P($G(^LAB(60,C0CTEST,64)),"^",2)
     88        . I X S C0CTEST(64)=$P($G(^LAM(X,0)),"^",2)
     89        . S C0CPTEST=$P($G(^AUPNVLAB(C0CPDA,0)),"^"),X=$P($G(^LAB(60,C0CPTEST,64)),"^")
     90        . I X S C0CPTEST(64)=$P($G(^LAM(X,0)),"^",2)
    8891        . S ^TMP("C0C-VLAB",$J,1,C0CDA)=""
    8992        . I C0CDA'=C0CPDA S ^TMP("C0C-VLAB",$J,1,C0CPDA)=""
    90         . S ^TMP("C0C-VLAB",$J,2,LRDFN,LRSS,LRIDT,LRSB)=C0CLN_"^"_C0CDA_"^"_C0CTEST_"^"_C0CPDA_"^"_C0CPTEST
     93        . S ^TMP("C0C-VLAB",$J,2,LRDFN,LRSS,LRIDT,LRSB)=C0CPTEST(64)_"^"_C0CTEST(64)_"^"_C0CLN_"^"_C0CDA_"^"_C0CTEST_"^"_C0CPDA_"^"_C0CPTEST
     94        ;
     95        S X=$P(LA7X,"^",3)
     96        ; If order NLT then update if no order NLT
     97        I C0CPTEST(64),$P(X,"!")="" S $P(X,"!")=C0CPTEST(64)
     98        ;
     99        ; If result NLT then update if no result NLT
     100        I C0CTEST(64),$P(X,"!",2)="" S $P(X,"!",2)=C0CTEST(64)
    91101        ;
    92102        ; If LOINC found then update variable with LN code
    93         I C0CLN'="" D
    94         . S X=$P(LA7X,"^",3)
    95         . I $P(X,"!",3)="" S $P(X,"!",3)=C0CLN
    96         . S $P(LA7X,"^",3)=X
     103        I C0CLN'="",$P(X,"!",3)="" S $P(X,"!",3)=C0CLN
     104        ;
     105        S $P(LA7X,"^",3)=X
     106        ;
     107        Q
     108        ;
     109        ;
     110TMPCHK  ; Check if LN/NLT codes saved from V LAB file above and use when building OBR/OBX segments
     111        ; Called from LA7VOBX1
     112        ;
     113        N I,X
     114        ;
     115        S X=$G(^TMP("C0C-VLAB",$J,2,LRDFN,LRSS,LRIDT,LRSB))
     116        I X="" Q
     117        F I=1:1:3 I $P(LA7X,"!",I)="",$P(X,"^",I)'="" S $P(LA7X,"!",I)=$P(X,"^",I)
     118        S $P(LA7VAL,"^",3)=LA7X
    97119        ;
    98120        Q
     
    125147        ;
    126148        Q
     149        ;
     150        ;
     151FINDDT  ; Find entry in V LAB for the date/time or one close to it.
     152        ; RPMS stores related specimen entries under the same date/time.
     153        ; Lab file #63 creates unique entries with slightly different times.
     154        ;
     155        S C0CDA=$O(^AUPNVLAB("ALR1",DFN,C0CACC,C0C60,C0CDT,0))
     156        I C0CDA>0 Q
     157        ;
     158        ; If entry found then confirm that specimen type matches.
     159        N C0CDTY
     160        S C0CDTY=$O(^AUPNVLAB("ALR1",DFN,C0CACC,C0C60,0))
     161        I C0CDTY D
     162        . I $P(C0CDT,".")'=$P(C0CDTY,".") Q
     163        . S C0CDA=$O(^AUPNVLAB("ALR1",DFN,C0CACC,C0C60,C0CDTY,0))
     164        . I C0CSPEC'=$P($G(^AUPNVLAB(C0CDA,11)),"^",3) S C0CDA=""
     165        ;
     166        Q
  • ccr/trunk/p/LA7VOBX1.m

    r435 r438  
    1 LA7VOBX1 ;DALOI/JMC - LAB OBX Segment message builder (CH subscript) cont'd; 04/14/09
     1LA7VOBX1 ;DALOI/JMC - LAB OBX Segment message builder (CH subscript) cont'd; 04/21/09
    22 ;;5.2;AUTOMATED LAB INSTRUMENTS;**46,61,63**;Sep 27, 1994
    33 ; JMC - mods to check for IHS V LAB file
     
    1919 I LA7X]"","BO"'[LA7X Q
    2020 I LA7X="",'$$OKTOSND^LA7VHLU1(LRSS,LRSB,+$P($P(LA7VAL,"^",3),"!",5)) Q
    21  ;
    22  ; If no result NLT or LOINC try to determine from file #60
    23  S LA7X=$P(LA7VAL,"^",3)
    24   ; Check for no LOINC in 63 and LOINC found in V LAB file.
    25  I $P(LA7X,"!",3)="",$D(^TMP("C0C-VLAB",$J,2,LRDFN,LRSS,LRIDT,LRSB)) S $P(LA7X,"!",3)=$P(^TMP("C0C-VLAB",$J,2,LRDFN,LRSS,LRIDT,LRSB),"^")
    2621        ;
    27  I $P(LA7X,"!",2)=""!($P(LA7X,"!",3)="") S $P(LA7VAL,"^",3)=$$DEFCODE^LA7VHLU5(LRSS,LRSB,LA7X,$P(LA76304(0),"^",5))
    28  ; No result NLT code - log error
     22        ; If no result NLT or LOINC try to determine from file #60
     23        S LA7X=$P(LA7VAL,"^",3)
     24        ; WV check for IHS - NLT/LN codes from V LAB file
     25        I $D(^AUPNVLAB) D TMPCHK^C0CLA7Q
     26        ;
     27        I $P(LA7X,"!",2)=""!($P(LA7X,"!",3)="") S $P(LA7VAL,"^",3)=$$DEFCODE^LA7VHLU5(LRSS,LRSB,LA7X,$P(LA76304(0),"^",5))
     28        ; No result NLT code - log error
    2929 I $P($P(LA7VAL,"^",3),"!",2)="" D
    3030 . N LA7X
Note: See TracChangeset for help on using the changeset viewer.