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

reset to certification routines with tabs

File:
1 edited

Legend:

Unmodified
Added
Removed

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

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