Ignore:
Timestamp:
Jan 4, 2012, 12:05:49 AM (13 years ago)
Author:
George Lilly
Message:

ohum new version

File:
1 edited

Legend:

Unmodified
Added
Removed

  • ccr/branches/ohum/p/C0CQRY1.m

    r1332 r1333  
    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 1
     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.