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

revised back to 6/30/08 version

File:
1 edited

Legend:

Unmodified
Added
Removed

  • WorldVistAEHR/trunk/r/HEALTH_LEVEL_SEVEN-HL/HLOSRVR1.m

    r613 r623  
    1 HLOSRVR1        ;IRMFO-ALB/CJM - Reading messages, sending acks;03/24/2004  14:43 ;07/17/2007
    2         ;;1.6;HEALTH LEVEL SEVEN;**126,130,131,133,134,137**;Oct 13, 1995;Build 21
    3         ;Per VHA Directive 2004-038, this routine should not be modified.
    4         ;
    5 READMSG(HLCSTATE,HLMSTATE)      ;
    6         ;Reads a message.  The header is parsed. Does these checks:
    7         ; 1) Duplicate?
    8         ; 2) Wrong Receiving Facility?
    9         ; 3) Can the Receiving App accept this message, based message type & event?
    10         ; 4) Processing ID must match the receiving system
    11         ; 5) Must have an ID
    12         ; 6) Header must be BHS or MSH
    13         ;
    14         ;Output:
    15         ;  Function returns 1 if the message was read fully, 0 otherwise
    16         ;  HLMSTATE (pass by reference) the message.  It will include the fields for the return ack in HLMSTATE("MSA")
    17         ;
    18         N ACK,SEG,STORE,I
    19         ;
    20         S STORE=1
    21         Q:'$$READHDR^HLOT(.HLCSTATE,.SEG) 0
    22         D SPLITHDR(.SEG)
    23         ;
    24         ;parse the header, stop if unsuccessful because the server cannot know what to do next
    25         I '$$PARSEHDR^HLOPRS(.SEG) D  Q 0
    26         .S HLCSTATE("MESSAGE ENDED")=0
    27         .D CLOSE^HLOT(.HLCSTATE)
    28         D NEWMSG^HLOSRVR2(.HLCSTATE,.HLMSTATE,.SEG)
    29         I HLMSTATE("ID")="" D
    30         .S STORE=0
    31         .I HLMSTATE("HDR","ACCEPT ACK TYPE")="AL" S HLMSTATE("MSA",1)="CE",HLMSTATE("MSA",3)="CONTROL ID MISSING"
    32         I STORE,$$DUP(.HLMSTATE) S STORE=0
    33         ;
    34         ;if the message is not to be stored, just read it and discard the segments
    35         I 'STORE D
    36         .F  Q:'$$READSEG^HLOT(.HLCSTATE,.SEG)
    37         ;
    38         E  D
    39         .N FS
    40         .S FS=HLMSTATE("HDR","FIELD SEPARATOR")
    41         .F  Q:'$$READSEG^HLOT(.HLCSTATE,.SEG)  D
    42         ..N MSA,SEGTYPE,OLDMSGID,CODE,IEN,NEWMSGID,TEXT
    43         ..S SEGTYPE=$E($E(SEG(1),1,3)_$E($G(SEG(2)),1,2),1,3)
    44         ..I SEGTYPE="MSA" D
    45         ...S MSA=SEG(1)_$G(SEG(2))_$G(SEG(3))
    46         ...S OLDMSGID=$P(MSA,FS,3),CODE=$P(MSA,FS,2),TEXT=$E($P(MSA,FS,4),1,30)
    47         ...I $E(CODE,1)'="A" S SEGTYPE="" Q
    48         ...S:$P(OLDMSGID,"-")]"" IEN=$O(^HLB("B",$P(OLDMSGID,"-"),0))
    49         ...S:$G(IEN) IEN=IEN_"^"_$P(OLDMSGID,"-",2)
    50         ..I 'HLMSTATE("BATCH") D
    51         ...D:SEGTYPE="MSA"
    52         ....S HLMSTATE("ACK TO")=OLDMSGID
    53         ....S HLMSTATE("ACK TO","ACK BY")=HLMSTATE("ID")
    54         ....S HLMSTATE("ACK TO","STATUS")=$S(CODE="AA":"SU",1:"ER")
    55         ....I $G(IEN) D
    56         .....S HLMSTATE("ACK TO","IEN")=IEN
    57         .....S HLMSTATE("ACK TO","SEQUENCE QUEUE")=$P($G(^HLB(+IEN,5)),"^")
    58         ....S HLMSTATE("ACK TO","ERROR TEXT")=TEXT
    59         ...D ADDSEG^HLOMSG(.HLMSTATE,.SEG)
    60         ..E  D  ;batch
    61         ...I SEGTYPE="MSH" D
    62         ....D SPLITHDR(.SEG)
    63         ....S NEWMSGID=$P(SEG(2),FS,5)
    64         ....D ADDMSG2^HLOMSG(.HLMSTATE,.SEG)
    65         ...E  D  ;not MSH
    66         ....D:SEGTYPE="MSA"
    67         .....N SUBIEN S SUBIEN=HLMSTATE("BATCH","CURRENT MESSAGE")
    68         .....S HLMSTATE("BATCH","ACK TO",SUBIEN)=OLDMSGID
    69         .....S HLMSTATE("BATCH","ACK TO",SUBIEN,"ACK BY")=NEWMSGID
    70         .....S HLMSTATE("BATCH","ACK TO",SUBIEN,"STATUS")=$S(CODE="AA":"SU",1:"ER")
    71         .....S:$D(IEN) HLMSTATE("BATCH","ACK TO",SUBIEN,"IEN")=IEN
    72         ....D ADDSEG^HLOMSG(.HLMSTATE,.SEG)
    73         .I HLMSTATE("UNSTORED LINES"),HLCSTATE("MESSAGE ENDED"),$$SAVEMSG^HLOF778(.HLMSTATE)
    74         ;
    75         I STORE,'HLCSTATE("MESSAGE ENDED") D
    76         .;reading failed, don't store
    77         .D:HLMSTATE("IEN") DEL778(HLMSTATE("IEN")) D:HLMSTATE("BODY") DEL777(HLMSTATE("BODY"))
    78         .S HLMSTATE("IEN")="",HLMSTATE("BODY")=""
    79         E  D:STORE
    80         .D CHECKMSG(.HLMSTATE)
    81         .D ADDAC(.HLMSTATE) ;so future duplicates are detected
    82         .D COUNT^HLOSTAT(.HLCSTATE,HLMSTATE("HDR","RECEIVING APPLICATION"),HLMSTATE("HDR","SENDING APPLICATION"),$S(HLMSTATE("BATCH"):"BATCH",1:HLMSTATE("HDR","MESSAGE TYPE")_"~"_HLMSTATE("HDR","EVENT")))
    83         ;
    84         D:'HLCSTATE("MESSAGE ENDED") CLOSE^HLOT(.HLCSTATE)
    85         Q HLCSTATE("MESSAGE ENDED")
    86         ;
    87 ADDAC(HLMSTATE) ;adds the AC xref for duplicates detection
    88         ;
    89         N FROM
    90         S FROM=$S(HLMSTATE("HDR","SENDING FACILITY",2)]"":HLMSTATE("HDR","SENDING FACILITY",2),1:HLMSTATE("HDR","SENDING FACILITY",1))
    91         S ^HLB("AC",FROM_HLMSTATE("HDR","SENDING APPLICATION")_HLMSTATE("ID"),HLMSTATE("IEN"))=""
    92         Q
    93         ;
    94 DUP(HLMSTATE)   ;
    95         ;Returns 1 if the message is a duplicate and its ack (if requested) is found, 0 otherwise
    96         ;Input:
    97         ; HLMSTATE (pass by reference) the message being read
    98         ;Output:
    99         ;  Function returns 1 if the message is a duplicate, 0 otherwise
    100         ;  HLMSTATE (pass by reference) IF the message is a duplicate:
    101         ;     returns the prior MSA segment in HLMSTATE("MSA")
    102         ;
    103         N IEN,FROM,DUP
    104         S (IEN,DUP)=0
    105         ;
    106         ;no way to determine!  Bad header will be rejected
    107         Q:(HLMSTATE("ID")="") 0
    108         ;
    109         S FROM=$S(HLMSTATE("HDR","SENDING FACILITY",2)]"":HLMSTATE("HDR","SENDING FACILITY",2),1:HLMSTATE("HDR","SENDING FACILITY",1))
    110         F  S IEN=$O(^HLB("AC",FROM_HLMSTATE("HDR","SENDING APPLICATION")_HLMSTATE("ID"),IEN)) Q:'IEN  D  Q:DUP
    111         .I HLMSTATE("HDR","ACCEPT ACK TYPE")="NE" S DUP=1 Q
    112         .;need the MSA to return
    113         .D  Q
    114         ..N NODE
    115         ..S NODE=$P($G(^HLB(IEN,4)),"^",3,10)
    116         ..S HLMSTATE("MSA",1)=$P(NODE,"|",2)
    117         ..Q:$L(HLMSTATE("MSA",1))'=2
    118         ..S HLMSTATE("MSA",2)=$P(NODE,"|",3)
    119         ..S HLMSTATE("MSA",3)=$P(NODE,"|",4,10)
    120         ..S DUP=1
    121         ;
    122         Q DUP
    123         ;
    124 CHECKMSG(HLMSTATE)      ;
    125         ;Checks the header & MSA segment, sets HLMSTATE("STATUS","ACTION") if the message needs to be passed, determines if completion status should be set
    126         ;Input:
    127         ;  HLMSTATE("HDR") - the parsed header segment
    128         ;Output:
    129         ;  HLMSTATE("STATUS")="ER" if an error is detected
    130         ;  HLMSTATE("STATUS","QUEUE") queue to put the message on
    131         ;  HLMSTATE("STATUS","ACTION")  <tag^rtn> that is the processing routine for the receiving application
    132         ;  HLMSTATE("MSA") - MSA(1)=accept code to be returned, MSA(3)= error txt
    133         ;
    134         N WANTACK,PASS,ACTION,QUEUE,ERROR
    135         M HDR=HLMSTATE("HDR")
    136         S ERROR=0
    137         I HDR("ACCEPT ACK TYPE")="NE",'HLMSTATE("ORIGINAL MODE") D
    138         .S WANTACK=0
    139         E  D
    140         .S WANTACK=1
    141         I HLMSTATE("ORIGINAL MODE") S HLMSTATE("MSA",1)="AE",HLMSTATE("MSA",3)="THIS INTERFACE DOES NOT IMPLEMENT ORIGINAL MODE APPLICATION ACKOWLEDGMENTS",HLMSTATE("STATUS")="ER" Q
    142         I $G(HLMSTATE("ACK TO"))="" D  Q:ERROR
    143         .I '$$ACTION^HLOAPP(.HDR,.ACTION,.QUEUE) S ERROR=1 S:WANTACK HLMSTATE("MSA",1)="CR" S HLMSTATE("MSA",3)="RECEIVING APPLICATION NOT DEFINED",HLMSTATE("STATUS")="ER" Q
    144         .S HLMSTATE("STATUS","ACTION")=$G(ACTION),HLMSTATE("STATUS","QUEUE")=$G(QUEUE)
    145         E  D  Q:ERROR  ;this is an app ack
    146         .;does the original message exist?
    147         .N NODE
    148         .S:+$G(HLMSTATE("ACK TO","IEN")) NODE=$G(^HLB(+HLMSTATE("ACK TO","IEN"),0))
    149         .I $G(NODE)="" S ERROR=1,HLMSTATE("STATUS")="ER",HLMSTATE("ACK TO","IEN")="" S:WANTACK HLMSTATE("MSA",1)="CE" S HLMSTATE("MSA",3)="INITIAL MESSAGE TO APPLICATION ACKNOWLEDGMENT NOT FOUND" Q
    150         .I $P(NODE,"^",7)'="",$P(NODE,"^",7)'=HLMSTATE("ID") S ERROR=1,HLMSTATE("STATUS")="ER",HLMSTATE("ACK TO","IEN")="" S:WANTACK HLMSTATE("MSA",1)="CE" S HLMSTATE("MSA",3)="INITIAL MESSAGE WAS ALREADY ACKED" Q
    151         .I ($P(NODE,"^",11)]"") S HLMSTATE("STATUS","ACTION")=$P(NODE,"^",10,11),HLMSTATE("STATUS","QUEUE")=$S($P(NODE,"^",6)]"":$P(NODE,"^",6),1:"DEFAULT")  Q
    152         .;processing routine for the app ack wasn't found with the original message, look in the HLO Application Registry
    153         .I HLMSTATE("HDR","MESSAGE TYPE")="ACK",HLMSTATE("HDR","EVENT")="" S HDR("EVENT")=$$GETEVENT^HLOCLNT2(+HLMSTATE("ACK TO","IEN"))
    154         .I $$ACTION^HLOAPP(.HDR,.ACTION,.QUEUE) S HLMSTATE("STATUS","ACTION")=$G(ACTION),HLMSTATE("STATUS","QUEUE")=$G(QUEUE)
    155         ;
    156         I HDR("PROCESSING ID")'=HLCSTATE("SYSTEM","PROCESSING ID") S:WANTACK HLMSTATE("MSA",1)="CR" S HLMSTATE("STATUS")="ER",HLMSTATE("MSA",3)="SYSTEM PROCESSING ID="_HLCSTATE("SYSTEM","PROCESSING ID") Q
    157         ;
    158         ;wrong receiving facility?  This is hard to check if the sender is not VistA, because the HL7 standard permits different coding systems to be used. This check is only for DNS or station number.
    159         S PASS=0
    160         D
    161         .;if its an ack to an existing message, don't check the receiving facility
    162         .I $G(HLMSTATE("ACK TO"))]"" S PASS=1 Q
    163         .I HDR("RECEIVING FACILITY",1)=HLCSTATE("SYSTEM","STATION") S PASS=1 Q
    164         .I HDR("RECEIVING FACILITY",3)'="DNS" S PASS=1 Q
    165         .I HDR("RECEIVING FACILITY",2)="" S PASS=1 Q
    166         .I $P(HDR("RECEIVING FACILITY",2),":")[HLCSTATE("SYSTEM","DOMAIN") S PASS=1 Q
    167         .I HLCSTATE("SYSTEM","DOMAIN")[$P(HDR("RECEIVING FACILITY",2),":") S PASS=1 Q
    168         I 'PASS S HLMSTATE("STATUS")="ER",HLMSTATE("MSA",3)="RECEIVING FACILITY IS "_HLCSTATE("SYSTEM","DOMAIN") S:WANTACK HLMSTATE("MSA",1)="CE"
    169         I PASS,WANTACK S HLMSTATE("MSA",1)="CA"
    170         Q
    171         ;
    172 DEL777(IEN777)  ;delete a record from file 777 where the read did not complete
    173         ;
    174         K ^HLA(IEN777,0)
    175         Q
    176 DEL778(IEN778)  ;delete a record from file 778 where the read did not complete
    177         ;
    178         K ^HLB(IEN778,0)
    179         Q
    180         ;
    181 SPLITHDR(HDR)   ;
    182         ;splits hdr segment into two lines, first being just components 1-6
    183         ;
    184         N TEMP,FS
    185         D SQUISH(.HDR)
    186         S FS=$E($G(HDR(1)),4)
    187         S TEMP(1)=$P($G(HDR(1)),FS,1,6)
    188         S TEMP(2)=""
    189         I $L(TEMP(1))<$L($G(HDR(1))) S TEMP(2)=FS_$P($G(HDR(1)),FS,7,20)
    190         S HDR(2)=TEMP(2)_$G(HDR(2))
    191         S HDR(1)=TEMP(1)
    192         Q
    193         ;
    194 SQUISH(SEG)     ;
    195         ;reformat the segment array into full lines
    196         ;
    197         ;nothing to do if less than 2 lines
    198         Q:'$O(SEG(1))
    199         ;
    200         N A,I,J,K,MAX,COUNT,LEN
    201         S MAX=$S($G(HLCSTATE("SYSTEM","MAXSTRING"))>256:HLCSTATE("SYSTEM","MAXSTRING"),1:256)
    202         S (COUNT,I)=0,J=1
    203         F  S I=$O(SEG(I)) Q:'I  D
    204         .S LEN=$L(SEG(I))
    205         .F K=1:1:LEN D
    206         ..S A(J)=$G(A(J))_$E(SEG(I),K)
    207         ..S COUNT=COUNT+1
    208         ..I (COUNT>(MAX-1)) S COUNT=0,J=J+1
    209         K SEG
    210         M SEG=A
    211         Q
    212         ;
    213 ERROR   ;error trap
    214         S $ETRAP="Q:$QUIT """" Q"
    215         D END^HLOSRVR
    216         ;
    217         ;multi-listener should stop execution, only a single server may continue
    218         I $P($G(HLCSTATE("LINK","SERVER")),"^",2)'="S" D  Q:$QUIT "" Q
    219         .;don't log these errors
    220         .I ($ECODE["READ")!($ECODE["NOTOPEN")!($ECODE["DEVNOTOPN")!($ECODE["WRITE")!($ECODE["OPENERR") D
    221         ..;
    222         .E  D
    223         ..D ^%ZTER
    224         ;
    225         ;debugging?
    226         I $G(^HLTMP("LOG ALL ERRORS"))!($ECODE["EDITED") Q:$QUIT "" Q
    227         ;
    228         ;possibly an endless loop?
    229         N HOUR
    230         S HOUR=$E($$NOW^XLFDT,1,10)
    231         I ($G(^TMP("HL7 ERRORS",$J,HOUR,$P($ECODE,",",2)))>30) Q:$QUIT "" Q
    232         ;
    233         ;resume execution for the single listener
    234         S ^TMP("HL7 ERRORS",$J,HOUR,$P($ECODE,",",2))=$G(^TMP("HL7 ERRORS",$J,HOUR,$P($ECODE,",",2)))+1
    235         D UNWIND^%ZTER
    236         Q
     1HLOSRVR1 ;IRMFO-ALB/CJM - Reading messages, sending acks;03/24/2004  14:43 ;03/26/2007
     2 ;;1.6;HEALTH LEVEL SEVEN;**126,130,131,133,134**;Oct 13, 1995;Build 30
     3 ;Per VHA Directive 2004-038, this routine should not be modified.
     4 ;
     5READMSG(HLCSTATE,HLMSTATE) ;
     6 ;Reads a message.  The header is parsed. Does these checks:
     7 ; 1) Duplicate?
     8 ; 2) Wrong Receiving Facility?
     9 ; 3) Can the Receiving App accept this message, based message type & event?
     10 ; 4) Processing ID must match the receiving system
     11 ; 5) Must have an ID
     12 ; 6) Header must be BHS or MSH
     13 ;
     14 ;Output:
     15 ;  Function returns 1 if the message was read fully, 0 otherwise
     16 ;  HLMSTATE (pass by reference) the message.  It will include the fields for the return ack in HLMSTATE("MSA")
     17 ;
     18 N ACK,SEG,STORE,I
     19 ;
     20 S STORE=1
     21 Q:'$$READHDR^HLOT(.HLCSTATE,.SEG) 0
     22 D SPLITHDR(.SEG)
     23 ;
     24 ;parse the header, stop if unsuccessful because the server cannot know what to do next
     25 I '$$PARSEHDR^HLOPRS(.SEG) D  Q 0
     26 .S HLCSTATE("MESSAGE ENDED")=0
     27 .D CLOSE^HLOT(.HLCSTATE)
     28 D NEWMSG^HLOSRVR2(.HLCSTATE,.HLMSTATE,.SEG)
     29 I HLMSTATE("ID")="" D
     30 .S STORE=0
     31 .I HLMSTATE("HDR","ACCEPT ACK TYPE")="AL" S HLMSTATE("MSA",1)="CE",HLMSTATE("MSA",3)="CONTROL ID MISSING"
     32 I STORE,$$DUP(.HLMSTATE) S STORE=0
     33 ;
     34 ;if the message is not to be stored, just read it and discard the segments
     35 I 'STORE D
     36 .F  Q:'$$READSEG^HLOT(.HLCSTATE,.SEG)
     37 ;
     38 E  D
     39 .N FS
     40 .S FS=HLMSTATE("HDR","FIELD SEPARATOR")
     41 .F  Q:'$$READSEG^HLOT(.HLCSTATE,.SEG)  D
     42 ..N MSA,SEGTYPE,OLDMSGID,CODE,IEN,NEWMSGID,TEXT
     43 ..S SEGTYPE=$E($E(SEG(1),1,3)_$E($G(SEG(2)),1,2),1,3)
     44 ..I SEGTYPE="MSA" D
     45 ...S MSA=SEG(1)_$G(SEG(2))_$G(SEG(3))
     46 ...S OLDMSGID=$P(MSA,FS,3),CODE=$P(MSA,FS,2),TEXT=$E($P(MSA,FS,4),1,30)
     47 ...I $E(CODE,1)'="A" S SEGTYPE="" Q
     48 ...S:$P(OLDMSGID,"-")]"" IEN=$O(^HLB("B",$P(OLDMSGID,"-"),0))
     49 ...S:$G(IEN) IEN=IEN_"^"_$P(OLDMSGID,"-",2)
     50 ..I 'HLMSTATE("BATCH") D
     51 ...D:SEGTYPE="MSA"
     52 ....S HLMSTATE("ACK TO")=OLDMSGID
     53 ....S HLMSTATE("ACK TO","ACK BY")=HLMSTATE("ID")
     54 ....S HLMSTATE("ACK TO","STATUS")=$S(CODE="AA":"SU",1:"AE")
     55 ....S:$D(IEN) HLMSTATE("ACK TO","IEN")=IEN
     56 ....S HLMSTATE("ACK TO","ERROR TEXT")=TEXT
     57 ...D ADDSEG^HLOMSG(.HLMSTATE,.SEG)
     58 ..E  D  ;batch
     59 ...I SEGTYPE="MSH" D
     60 ....D SPLITHDR(.SEG)
     61 ....S NEWMSGID=$P(SEG(2),FS,5)
     62 ....D ADDMSG2^HLOMSG(.HLMSTATE,.SEG)
     63 ...E  D  ;not MSH
     64 ....D:SEGTYPE="MSA"
     65 .....N SUBIEN S SUBIEN=HLMSTATE("BATCH","CURRENT MESSAGE")
     66 .....S HLMSTATE("BATCH","ACK TO",SUBIEN)=OLDMSGID
     67 .....S HLMSTATE("BATCH","ACK TO",SUBIEN,"ACK BY")=NEWMSGID
     68 .....S HLMSTATE("BATCH","ACK TO",SUBIEN,"STATUS")=$S(CODE="AA":"SU",1:"AE")
     69 .....S:$D(IEN) HLMSTATE("BATCH","ACK TO",SUBIEN,"IEN")=IEN
     70 ....D ADDSEG^HLOMSG(.HLMSTATE,.SEG)
     71 .I HLMSTATE("UNSTORED LINES"),HLCSTATE("MESSAGE ENDED"),$$SAVEMSG^HLOF778(.HLMSTATE)
     72 ;
     73 I STORE,'HLCSTATE("MESSAGE ENDED") D
     74 .;reading failed, don't store
     75 .D:HLMSTATE("IEN") DEL778(HLMSTATE("IEN")) D:HLMSTATE("BODY") DEL777(HLMSTATE("BODY"))
     76 .S HLMSTATE("IEN")="",HLMSTATE("BODY")=""
     77 E  D:STORE
     78 .D CHECKMSG(.HLMSTATE)
     79 .D ADDAC(.HLMSTATE) ;so future duplicates are detected
     80 .D COUNT^HLOSTAT(.HLCSTATE,HLMSTATE("HDR","RECEIVING APPLICATION"),HLMSTATE("HDR","SENDING APPLICATION"),$S(HLMSTATE("BATCH"):"BATCH",1:HLMSTATE("HDR","MESSAGE TYPE")_"~"_HLMSTATE("HDR","EVENT")))
     81 ;
     82 D:'HLCSTATE("MESSAGE ENDED") CLOSE^HLOT(.HLCSTATE)
     83 Q HLCSTATE("MESSAGE ENDED")
     84 ;
     85ADDAC(HLMSTATE) ;adds the AC xref for duplicates detection
     86 ;
     87 N FROM
     88 S FROM=$S(HLMSTATE("HDR","SENDING FACILITY",2)]"":HLMSTATE("HDR","SENDING FACILITY",2),1:HLMSTATE("HDR","SENDING FACILITY",1))
     89 S ^HLB("AC",FROM_HLMSTATE("HDR","SENDING APPLICATION")_HLMSTATE("ID"),HLMSTATE("IEN"))=""
     90 Q
     91 ;
     92DUP(HLMSTATE) ;
     93 ;Returns 1 if the message is a duplicate and its ack (if requested) is found, 0 otherwise
     94 ;Input:
     95 ; HLMSTATE (pass by reference) the message being read
     96 ;Output:
     97 ;  Function returns 1 if the message is a duplicate, 0 otherwise
     98 ;  HLMSTATE (pass by reference) IF the message is a duplicate:
     99 ;     returns the prior MSA segment in HLMSTATE("MSA")
     100 ;
     101 N IEN,FROM,DUP
     102 S (IEN,DUP)=0
     103 ;
     104 ;no way to determine!  Bad header will be rejected
     105 Q:(HLMSTATE("ID")="") 0
     106 ;
     107 S FROM=$S(HLMSTATE("HDR","SENDING FACILITY",2)]"":HLMSTATE("HDR","SENDING FACILITY",2),1:HLMSTATE("HDR","SENDING FACILITY",1))
     108 F  S IEN=$O(^HLB("AC",FROM_HLMSTATE("HDR","SENDING APPLICATION")_HLMSTATE("ID"),IEN)) Q:'IEN  D  Q:DUP
     109 .I HLMSTATE("HDR","ACCEPT ACK TYPE")="NE" S DUP=1 Q
     110 .;need the MSA to return
     111 .D  Q
     112 ..N NODE
     113 ..S NODE=$P($G(^HLB(IEN,4)),"^",3,10)
     114 ..S HLMSTATE("MSA",1)=$P(NODE,"|",2)
     115 ..Q:$L(HLMSTATE("MSA",1))'=2
     116 ..S HLMSTATE("MSA",2)=$P(NODE,"|",3)
     117 ..S HLMSTATE("MSA",3)=$P(NODE,"|",4,10)
     118 ..S DUP=1
     119 ;
     120 Q DUP
     121 ;
     122CHECKMSG(HLMSTATE) ;
     123 ;Checks the header & MSA segment, sets HLMSTATE("STATUS","ACTION") if the message needs to be passed, determines if completion status should be set
     124 ;Input:
     125 ;  HLMSTATE("HDR") - the parsed header segment
     126 ;Output:
     127 ;  HLMSTATE("STATUS")="SE" if an error is detected
     128 ;  HLMSTATE("STATUS","QUEUE") queue to put the message on
     129 ;  HLMSTATE("STATUS","ACTION")  <tag^rtn> that is the processing routine for the receiving application
     130 ;  HLMSTATE("MSA") - MSA(1)=accept code to be returned, MSA(3)= error txt
     131 ;
     132 N WANTACK,PASS,ACTION,QUEUE,ERROR
     133 M HDR=HLMSTATE("HDR")
     134 S ERROR=0
     135 I HDR("ACCEPT ACK TYPE")="NE",'HLMSTATE("ORIGINAL MODE") D
     136 .S WANTACK=0
     137 E  D
     138 .S WANTACK=1
     139 I HLMSTATE("ORIGINAL MODE") S HLMSTATE("MSA",1)="AE",HLMSTATE("MSA",3)="THIS INTERFACE DOES NOT IMPLEMENT ORIGINAL MODE APPLICATION ACKOWLEDGMENTS",HLMSTATE("STATUS")="SE" Q
     140 I $G(HLMSTATE("ACK TO"))="" D  Q:ERROR
     141 .I '$$ACTION^HLOAPP(.HDR,.ACTION,.QUEUE) S ERROR=1 S:WANTACK HLMSTATE("MSA",1)="CR" S HLMSTATE("MSA",3)="RECEIVING APPLICATION NOT DEFINED",HLMSTATE("STATUS")="SE" Q
     142 .S HLMSTATE("STATUS","ACTION")=$G(ACTION),HLMSTATE("STATUS","QUEUE")=$G(QUEUE)
     143 E  D  Q:ERROR  ;this is an app ack
     144 .;does the original message exist?
     145 .N NODE
     146 .S:+$G(HLMSTATE("ACK TO","IEN")) NODE=$G(^HLB(+HLMSTATE("ACK TO","IEN"),0))
     147 .I $G(NODE)="" S ERROR=1,HLMSTATE("STATUS")="SE",HLMSTATE("ACK TO","IEN")="" S:WANTACK HLMSTATE("MSA",1)="CE" S HLMSTATE("MSA",3)="INITIAL MESSAGE TO APPLICATION ACKNOWLEDGMENT NOT FOUND" Q
     148 .I $P(NODE,"^",7)'="",$P(NODE,"^",7)'=HLMSTATE("ID") S ERROR=1,HLMSTATE("STATUS")="SE",HLMSTATE("ACK TO","IEN")="" S:WANTACK HLMSTATE("MSA",1)="CE" S HLMSTATE("MSA",3)="INITIAL MESSAGE WAS ALREADY ACKED" Q
     149 .I ($P(NODE,"^",11)]"") S HLMSTATE("STATUS","ACTION")=$P(NODE,"^",10,11),HLMSTATE("STATUS","QUEUE")=$S($P(NODE,"^",6)]"":$P(NODE,"^",6),1:"DEFAULT")  Q
     150 .;processing routine for the app ack wasn't found with the original message, look in the HLO Application Registry
     151 .I HLMSTATE("HDR","MESSAGE TYPE")="ACK",HLMSTATE("HDR","EVENT")="" S HDR("EVENT")=$$GETEVENT^HLOCLNT2(+HLMSTATE("ACK TO","IEN"))
     152 .I $$ACTION^HLOAPP(.HDR,.ACTION,.QUEUE) S HLMSTATE("STATUS","ACTION")=$G(ACTION),HLMSTATE("STATUS","QUEUE")=$G(QUEUE)
     153 ;
     154 I HDR("PROCESSING ID")'=HLCSTATE("SYSTEM","PROCESSING ID") S:WANTACK HLMSTATE("MSA",1)="CR" S HLMSTATE("STATUS")="SE",HLMSTATE("MSA",3)="SYSTEM PROCESSING ID="_HLCSTATE("SYSTEM","PROCESSING ID") Q
     155 ;
     156 ;wrong receiving facility?  This is hard to check if the sender is not VistA, because the HL7 standard permits different coding systems to be used. This check is only for DNS or station number.
     157 S PASS=0
     158 D
     159 .;if its an ack to an existing message, don't check the receiving facility
     160 .I $G(HLMSTATE("ACK TO"))]"" S PASS=1 Q
     161 .I HDR("RECEIVING FACILITY",1)=HLCSTATE("SYSTEM","STATION") S PASS=1 Q
     162 .I HDR("RECEIVING FACILITY",3)'="DNS" S PASS=1 Q
     163 .I HDR("RECEIVING FACILITY",2)="" S PASS=1 Q
     164 .I $P(HDR("RECEIVING FACILITY",2),":")[HLCSTATE("SYSTEM","DOMAIN") S PASS=1 Q
     165 .I HLCSTATE("SYSTEM","DOMAIN")[$P(HDR("RECEIVING FACILITY",2),":") S PASS=1 Q
     166 I 'PASS S HLMSTATE("STATUS")="SE",HLMSTATE("MSA",3)="RECEIVING FACILITY IS "_HLCSTATE("SYSTEM","DOMAIN") S:WANTACK HLMSTATE("MSA",1)="CE"
     167 I PASS,WANTACK S HLMSTATE("MSA",1)="CA"
     168 Q
     169 ;
     170DEL777(IEN777) ;delete a record from file 777 where the read did not complete
     171 ;
     172 K ^HLA(IEN777,0)
     173 Q
     174DEL778(IEN778) ;delete a record from file 778 where the read did not complete
     175 ;
     176 K ^HLB(IEN778,0)
     177 Q
     178 ;
     179SPLITHDR(HDR) ;
     180 ;splits hdr segment into two lines, first being just components 1-6
     181 ;
     182 N TEMP,FS
     183 D SQUISH(.HDR)
     184 S FS=$E($G(HDR(1)),4)
     185 S TEMP(1)=$P($G(HDR(1)),FS,1,6)
     186 S TEMP(2)=""
     187 I $L(TEMP(1))<$L($G(HDR(1))) S TEMP(2)=FS_$P($G(HDR(1)),FS,7,20)
     188 S HDR(2)=TEMP(2)_$G(HDR(2))
     189 S HDR(1)=TEMP(1)
     190 Q
     191 ;
     192SQUISH(SEG) ;
     193 ;reformat the segment array into full lines
     194 ;
     195 ;nothing to do if less than 2 lines
     196 Q:'$O(SEG(1))
     197 ;
     198 N A,I,J,K,MAX,COUNT,LEN
     199 S MAX=$S($G(HLCSTATE("SYSTEM","MAXSTRING"))>256:HLCSTATE("SYSTEM","MAXSTRING"),1:256)
     200 S (COUNT,I)=0,J=1
     201 F  S I=$O(SEG(I)) Q:'I  D
     202 .S LEN=$L(SEG(I))
     203 .F K=1:1:LEN D
     204 ..S A(J)=$G(A(J))_$E(SEG(I),K)
     205 ..S COUNT=COUNT+1
     206 ..I (COUNT>(MAX-1)) S COUNT=0,J=J+1
     207 K SEG
     208 M SEG=A
     209 Q
     210 ;
     211ERROR ;error trap
     212 S $ETRAP="Q:$QUIT """" Q"
     213 D END^HLOSRVR
     214 ;
     215 ;concurrent server connections (multi-listener) should stop execution, only a single server may continue
     216 I $P($G(HLCSTATE("LINK","SERVER")),"^",2)'="S" D  Q:$QUIT "" Q
     217 .;don't log these common errors
     218 .I ($ECODE["READ")!($ECODE["NOTOPEN")!($ECODE["DEVNOTOPN")!($ECODE["WRITE")!($ECODE["OPENERR") D
     219 ..;
     220 .E  D
     221 ..D ^%ZTER
     222 ;
     223 ;while debugging quit on all errors
     224 I $G(^HLTMP("LOG ALL ERRORS"))!($ECODE["EDITED") Q:$QUIT "" Q
     225 ;
     226 ;a lot of errors of the same time may indicate an endless loop, so keep a count and quit if large count
     227 N HOUR
     228 S HOUR=$E($$NOW^XLFDT,1,10)
     229 ;
     230 I ($G(^TMP("HL7 ERRORS",$J,HOUR,$P($ECODE,",",2)))>30) Q:$QUIT "" Q
     231 ;
     232 ;resume execution for the single listener
     233 S ^TMP("HL7 ERRORS",$J,HOUR,$P($ECODE,",",2))=$G(^TMP("HL7 ERRORS",$J,HOUR,$P($ECODE,",",2)))+1
     234 D UNWIND^%ZTER
     235 Q
Note: See TracChangeset for help on using the changeset viewer.