Changeset 1336 for ccr/trunk/p/LA7QRY1.m


Ignore:
Timestamp:
Jan 4, 2012, 9:39:08 PM (12 years ago)
Author:
George Lilly
Message:

removed tabs

File:
1 edited

Legend:

Unmodified
Added
Removed

  • ccr/trunk/p/LA7QRY1.m

    r508 r1336  
    1 LA7QRY1 ;DALOI/JMC - Lab HL7 Query Utility ;01/19/99  13:48
    2         ;;5.2;AUTOMATED LAB INSTRUMENTS;**46,61**;Sep 27, 1994;Build 31
    3         ;
    4         Q
    5         ;
    6 CHKSC   ; Check search NLT/LOINC codes
    7         ;
    8         N J
    9         ;
    10         S J=0
    11         F  S J=$O(LA7SC(J)) Q:'J  D
    12         . N X
    13         . S X=LA7SC(J)
    14         . I $P(X,"^",2)="NLT",$D(^LAM("E",$P(X,"^"))) D  Q
    15         . . S ^TMP("LA7-NLT",$J,$P(X,"^"))=""
    16         . I $P(X,"^",2)="LN",$D(^LAB(95.3,$P($P(X,"^"),"-"))) D  Q
    17         . . S ^TMP("LA7-LN",$J,$P($P(X,"^"),"-"))=""
    18         . S LA7ERR(6)="Unknown search code "_$P(X,"^")_" passed"
    19         . K LA7SC(J)
    20         Q
    21         ;
    22         ;
    23 SPEC    ; Convert HL7 Specimen Codes to File #61, Topography codes
    24         ; Find all topographies that use this HL7 specimen code
    25         N J,K,L
    26         ;
    27         S J=0
    28         F  S J=$O(LA7SPEC(J)) Q:'J  D
    29         . S K=LA7SPEC(J),L=0
    30         . F  S L=$O(^LAB(61,"HL7",K,L)) Q:'L  S ^TMP("LA7-61",$J,L)=""
    31         Q
    32         ;
    33         ;
    34 BUILDMSG        ; Build HL7 message with result of query
    35         ;
    36         N HL,HLECH,HLFS,HLQ,LA,LA763,LA7ECH,LA7FS,LA7MSH,LA7NOMSG,LA7NTESN,LA7NVAF,LA7OBRSN,LA7OBXSN,LA7PIDSN,LA7ROOT,LA7X,X
    37         ;
    38         I $L($G(LA7HL7))'=5 S LA7HL7="|^\~&"
    39         S (HL("FS"),HLFS,LA7FS)=$E(LA7HL7),(HL("ECH"),HLECH,LA7ECH)=$E(LA7HL7,2,5)
    40         S (HLQ,HL("Q"))=""""""
    41         ; Set flag to not send HL7 message
    42         S LA7NOMSG=1
    43         ; Create dummy MSH to pass HL7 delimiters
    44         S LA7MSH(0)="MSH"_LA7FS_LA7ECH_LA7FS
    45         D FILESEG^LA7VHLU(GBL,.LA7MSH)
    46         ;
    47         F X="AUTO-INST","LRDFN","LRIDT","SUB","HUID","NLT","RUID","SITE" S LA(X)=""
    48         ;
    49         ; Take search results and put in HL7 message structure
    50         S LA7ROOT="^TMP(""LA7-QRY"",$J)",(LA7QUIT,LA7PIDSN)=0
    51         ; F  S LA7ROOT=$Q(@LA7ROOT) Q:LA7QUIT  D ;change per John M
    52         F  S LA7ROOT=$Q(@LA7ROOT) Q:LA7ROOT=""  D  Q:LA7QUIT
    53         . I $QS(LA7ROOT,1)'="LA7-QRY"!($QS(LA7ROOT,2)'=$J) S LA7QUIT=1 Q
    54         . I LA("LRDFN")'=$QS(LA7ROOT,3) D PID S LA7OBRSN=0
    55         . I LA("LRIDT")'=$QS(LA7ROOT,4) D ORC,OBR
    56         . I LA("SUB")'=$QS(LA7ROOT,5) D ORC,OBR
    57         . I LA("NLT")'=$P($QS(LA7ROOT,6),"!") D ORC,OBR
    58         . D OBX
    59         ;
    60         Q
    61         ;
    62         ;
    63 PID     ; Build PID segment
    64         ;
    65         N LA7PID
    66         ;
    67         S (LA("LRDFN"),LRDFN)=$QS(LA7ROOT,3)
    68         S LRDPF=$P(^LR(LRDFN,0),"^",2),DFN=$P(^(0),"^",3)
    69         D DEM^LRX
    70         D PID^LA7VPID(LA("LRDFN"),"",.LA7PID,.LA7PIDSN,.HL)
    71         D FILESEG^LA7VHLU(GBL,.LA7PID)
    72         S (LA("LRIDT"),LA("SUB"))=""
    73         Q
    74         ;
    75         ;
    76 ORC     ; Build ORC segment
    77         ;
    78         N X
    79         ;
    80         S LA("LRIDT")=$QS(LA7ROOT,4),LA("SUB")=$QS(LA7ROOT,5)
    81         S LA763(0)=$G(^LR(LA("LRDFN"),LA("SUB"),LA("LRIDT"),0))
    82         S X=$G(^LR(LA("LRDFN"),LA("SUB"),LA("LRIDT"),"ORU"))
    83         S LA("HUID")=$P(X,"^"),LA("SITE")=$P(X,"^",2),LA("RUID")=$P(X,"^",4)
    84         I LA("HUID")="" S LA("HUID")=$P(LA763(0),"^",6)
    85         S LA7NVAF=$$NVAF^LA7VHLU2(0),LA7NTESN=0
    86         D ORC^LA7VORU
    87         S LA("NLT")=""
    88         ;
    89         Q
    90         ;
    91         ;
    92 OBR     ; Build OBR segment
    93         ;
    94         N LA764,LA7NLT
    95         ;
    96         S (LA("NLT"),LA7NLT)=$P($QS(LA7ROOT,6),"!"),(LA764,LA("ORD"))=""
    97         I $L(LA7NLT) D
    98         . S LA764=+$O(^LAM("E",LA7NLT,0))
    99         . I LA764 S LA("ORD")=$$GET1^DIQ(64,LA764_",",.01)
    100         I LA("SUB")="CH" D
    101         . D OBR^LA7VORU
    102         . D NTE^LA7VORU
    103         . S LA7OBXSN=0
    104         ;
    105         Q
    106         ;
    107         ;
    108 OBX     ; Build OBX segment
    109         ;
    110         N LA7DATA,LA7VT
    111         ;
    112         S LA7NTESN=0
    113         I LA("SUB")="MI" D MI^LA7VORU1 Q
    114         I "CYEMSP"[LA("SUB") D AP^LA7VORU2 Q
    115         ;
    116         S LA7VT=$QS(LA7ROOT,7)
    117         D OBX^LA7VOBX(LA("LRDFN"),LA("SUB"),LA("LRIDT"),LA7VT,.LA7DATA,.LA7OBXSN,LA7FS,LA7ECH)
    118         I '$D(LA7DATA) Q
    119         D FILESEG^LA7VHLU(GBL,.LA7DATA)
    120         ; Send any test interpretation from file #60
    121         D INTRP^LA7VORUA
    122         ;
    123         Q
     1LA7QRY1 ;DALOI/JMC - Lab HL7 Query Utility ;01/19/99  13:48
     2 ;;5.2;AUTOMATED LAB INSTRUMENTS;**46,61**;Sep 27, 1994;Build 31
     3 ;
     4 Q
     5 ;
     6CHKSC ; Check search NLT/LOINC codes
     7 ;
     8 N J
     9 ;
     10 S J=0
     11 F  S J=$O(LA7SC(J)) Q:'J  D
     12 . N X
     13 . S X=LA7SC(J)
     14 . I $P(X,"^",2)="NLT",$D(^LAM("E",$P(X,"^"))) D  Q
     15 . . S ^TMP("LA7-NLT",$J,$P(X,"^"))=""
     16 . I $P(X,"^",2)="LN",$D(^LAB(95.3,$P($P(X,"^"),"-"))) D  Q
     17 . . S ^TMP("LA7-LN",$J,$P($P(X,"^"),"-"))=""
     18 . S LA7ERR(6)="Unknown search code "_$P(X,"^")_" passed"
     19 . K LA7SC(J)
     20 Q
     21 ;
     22 ;
     23SPEC ; Convert HL7 Specimen Codes to File #61, Topography codes
     24 ; Find all topographies that use this HL7 specimen code
     25 N J,K,L
     26 ;
     27 S J=0
     28 F  S J=$O(LA7SPEC(J)) Q:'J  D
     29 . S K=LA7SPEC(J),L=0
     30 . F  S L=$O(^LAB(61,"HL7",K,L)) Q:'L  S ^TMP("LA7-61",$J,L)=""
     31 Q
     32 ;
     33 ;
     34BUILDMSG ; Build HL7 message with result of query
     35 ;
     36 N HL,HLECH,HLFS,HLQ,LA,LA763,LA7ECH,LA7FS,LA7MSH,LA7NOMSG,LA7NTESN,LA7NVAF,LA7OBRSN,LA7OBXSN,LA7PIDSN,LA7ROOT,LA7X,X
     37 ;
     38 I $L($G(LA7HL7))'=5 S LA7HL7="|^\~&"
     39 S (HL("FS"),HLFS,LA7FS)=$E(LA7HL7),(HL("ECH"),HLECH,LA7ECH)=$E(LA7HL7,2,5)
     40 S (HLQ,HL("Q"))=""""""
     41 ; Set flag to not send HL7 message
     42 S LA7NOMSG=1
     43 ; Create dummy MSH to pass HL7 delimiters
     44 S LA7MSH(0)="MSH"_LA7FS_LA7ECH_LA7FS
     45 D FILESEG^LA7VHLU(GBL,.LA7MSH)
     46 ;
     47 F X="AUTO-INST","LRDFN","LRIDT","SUB","HUID","NLT","RUID","SITE" S LA(X)=""
     48 ;
     49 ; Take search results and put in HL7 message structure
     50 S LA7ROOT="^TMP(""LA7-QRY"",$J)",(LA7QUIT,LA7PIDSN)=0
     51 ; F  S LA7ROOT=$Q(@LA7ROOT) Q:LA7QUIT  D ;change per John M
     52 F  S LA7ROOT=$Q(@LA7ROOT) Q:LA7ROOT=""  D  Q:LA7QUIT
     53 . I $QS(LA7ROOT,1)'="LA7-QRY"!($QS(LA7ROOT,2)'=$J) S LA7QUIT=1 Q
     54 . I LA("LRDFN")'=$QS(LA7ROOT,3) D PID S LA7OBRSN=0
     55 . I LA("LRIDT")'=$QS(LA7ROOT,4) D ORC,OBR
     56 . I LA("SUB")'=$QS(LA7ROOT,5) D ORC,OBR
     57 . I LA("NLT")'=$P($QS(LA7ROOT,6),"!") D ORC,OBR
     58 . D OBX
     59 ;
     60 Q
     61 ;
     62 ;
     63PID ; Build PID segment
     64 ;
     65 N LA7PID
     66 ;
     67 S (LA("LRDFN"),LRDFN)=$QS(LA7ROOT,3)
     68 S LRDPF=$P(^LR(LRDFN,0),"^",2),DFN=$P(^(0),"^",3)
     69 D DEM^LRX
     70 D PID^LA7VPID(LA("LRDFN"),"",.LA7PID,.LA7PIDSN,.HL)
     71 D FILESEG^LA7VHLU(GBL,.LA7PID)
     72 S (LA("LRIDT"),LA("SUB"))=""
     73 Q
     74 ;
     75 ;
     76ORC ; Build ORC segment
     77 ;
     78 N X
     79 ;
     80 S LA("LRIDT")=$QS(LA7ROOT,4),LA("SUB")=$QS(LA7ROOT,5)
     81 S LA763(0)=$G(^LR(LA("LRDFN"),LA("SUB"),LA("LRIDT"),0))
     82 S X=$G(^LR(LA("LRDFN"),LA("SUB"),LA("LRIDT"),"ORU"))
     83 S LA("HUID")=$P(X,"^"),LA("SITE")=$P(X,"^",2),LA("RUID")=$P(X,"^",4)
     84 I LA("HUID")="" S LA("HUID")=$P(LA763(0),"^",6)
     85 S LA7NVAF=$$NVAF^LA7VHLU2(0),LA7NTESN=0
     86 D ORC^LA7VORU
     87 S LA("NLT")=""
     88 ;
     89 Q
     90 ;
     91 ;
     92OBR ; Build OBR segment
     93 ;
     94 N LA764,LA7NLT
     95 ;
     96 S (LA("NLT"),LA7NLT)=$P($QS(LA7ROOT,6),"!"),(LA764,LA("ORD"))=""
     97 I $L(LA7NLT) D
     98 . S LA764=+$O(^LAM("E",LA7NLT,0))
     99 . I LA764 S LA("ORD")=$$GET1^DIQ(64,LA764_",",.01)
     100 I LA("SUB")="CH" D
     101 . D OBR^LA7VORU
     102 . D NTE^LA7VORU
     103 . S LA7OBXSN=0
     104 ;
     105 Q
     106 ;
     107 ;
     108OBX ; Build OBX segment
     109 ;
     110 N LA7DATA,LA7VT
     111 ;
     112 S LA7NTESN=0
     113 I LA("SUB")="MI" D MI^LA7VORU1 Q
     114 I "CYEMSP"[LA("SUB") D AP^LA7VORU2 Q
     115 ;
     116 S LA7VT=$QS(LA7ROOT,7)
     117 D OBX^LA7VOBX(LA("LRDFN"),LA("SUB"),LA("LRIDT"),LA7VT,.LA7DATA,.LA7OBXSN,LA7FS,LA7ECH)
     118 I '$D(LA7DATA) Q
     119 D FILESEG^LA7VHLU(GBL,.LA7DATA)
     120 ; Send any test interpretation from file #60
     121 D INTRP^LA7VORUA
     122 ;
     123 Q
Note: See TracChangeset for help on using the changeset viewer.