source: FOIAVistA/trunk/r/SURGERY-SR/SRHLORU.m@ 632

Last change on this file since 632 was 628, checked in by George Lilly, 15 years ago

initial load of FOIAVistA 6/30/08 version

File size: 3.4 KB
Line 
1SRHLORU ;B'HAM ISC/DLR - Surgery Interface Receiver of ORU messages ; [ 02/06/01 9:27 AM ]
2 ;;3.0; Surgery ;**41,100**;24 Jun 93
3 ; Per VHA Directive 10-93-142, this routine SHOULD NOT be modified.
4REC N HLCOMP,HLREP,HLSUB,HLFS,HLECH,II,SG,SRERR,SRES,SRESCNT,SRESAR,SRESNR,SRI,SSN,TYPE,SROP,SRNON,SRHL,Z
5 K HLMID,PID,SRHL S SRHL("E")=+$G(SRHL("E")),(SRESCNT,SRESAR,SRESNR)=0
6 S Z=$G(^SRF(CASE,"TIU")) S:$P(Z,"^",2) SRESNR=1 S:$P(Z,"^",4) SRESAR=1
7 F I=1:1 X HLNEXT Q:HLQUIT'>0 S (MSG,X(I))=HLNODE,SG=$E(HLNODE,1,3),J=0 D D PICK
8 .S J=0 F S J=$O(HLNODE(J)) Q:'J S X(I,J)=HLNODE(J)
9 D:SRHL("E")>0 DSCPANCY^SRHLU(.HL)
10GEN ;generate the message
11 D MSA^SRHLUO(1,$S($D(HLP("ERRTEXT")):"AE",1:"AA"))
12 ;HLEID - IEN of Server event protocol
13 ;HLMTIENS - IEN in 772
14 ;HLEIDS - IEN of Client event protocol
15 ;HLARYTYP - acknowledgement array (see V. 1.6 HL7 doc)
16 ;HLFORMAT - is HLMA is pre-formatted HL7 form
17 ;HLRESLTA - message ID and/or the error message (for output)
18 ;HLP("ERRTEXT") - Processing error message
19 ;HLP("CONTPTR") - continuation pointer field value (not used)
20 ;HLP("PRIORITY") - priority field value (not used)
21 ;HLP("SECURITY") - security information (not used)
22 S HLEID=HL("EID"),HLEIDS=HL("EIDS"),HLARYTYP="GM",HLFORMAT=1,HLRESLTA="",HLMTIENA="",HLP=""
23 D GENACK^HLMA1(HLEID,HLMTIENS,HLEIDS,HLARYTYP,HLFORMAT,.HLRESLTA,HLMTIENA,.HLP)
24EXIT ;
25 K ^TMP("HLA",$J),SRHL
26 Q
27PICK ;check routine for segment entry point
28 I $T(@SG)]"" D @SG
29 I $T(@SG)="" Q
30 Q
31MSH ;;MSH
32 ;process the MSH segment
33 S (HLFS,HL("FS"))=$E(MSG,4),(HLECH,HL("ECH"))=$E(MSG,5,8)
34 S HLCOMP=$E(HL("ECH"),1),HLREP=$E(HL("ECH"),2),HLSUB=$E(HL("ECH"),4)
35 S TYPE=$P(MSG,HL("FS"),9)
36 Q
37PID ;;PID
38 ;process PID segment
39 N I,PAT
40 S PID("SSN")=$P(MSG,HL("FS"),20),PAT=$$FMNAME^HLFNC($P(MSG,HL("FS"),6))
41 I $D(PAT) F I=0:0 S I=$O(^DPT("B",PAT,I)) Q:'I I $P(^DPT(I,0),U,9)=PID("SSN") S PID("DFN")=I
42 Q
43OBX ;;OBX
44 ;null header for OBR segments sets that are set to ignore or send
45 Q:$G(OBR)=""
46 D:$G(OBR)'="" OBX^SRHLUI(MSG,OBR,CASE)
47 Q
48NTE ;;NTE
49 ;null header for OBR segments sets that are set to ignore or send
50 Q:$G(OBR)=""
51 D NTE^SRHLUI(MSG,OBR,CASE)
52 Q
53OBR ;;OBR
54 ;process OBR segment as well as underlying OBX's or NTE
55 N DFN,ID,IEN,SRII,SRNEXT
56 ;set-up the IDentifier and check the mapping file (#133.2) for a match
57 S CASE=$P(MSG,HL("FS"),4) I 'CASE S SRDISC="Unknown Surgery Case Number in "_$P(MSG,HL("FS"),1,2)_"." D SETDSC^SRHLU(.HL,SRDISC,.SRHL) Q
58 I '$D(^SRF(CASE,0)) S SRDISC="Unknown Surgery Case Number ("_$G(CASE)_") in "_$P(MSG,HL("FS"),1,2)_"." D SETDSC^SRHLU(.HL,SRDISC,.SRHL) Q
59 S ID=$P($P(MSG,HL("FS"),5),HLCOMP,2) I $G(ID)="" S SRDISC="Unknown OBR identifier ("_$G(ID)_") for case #"_$G(CASE)_"." D SETDSC^SRHLU(.HL,SRDISC,.SRHL) Q
60 S IEN=$O(^SRO(133.2,"AC",ID,0)) I $G(IEN)="" S SRDISC="Invalid OBR identifier ("_$G(ID)_") for case #"_$G(CASE)_"." D SETDSC^SRHLU(.HL,SRDISC,.SRHL) Q
61 I $D(^SRF(CASE,0)) S DFN=$P(^SRF(CASE,0),U) I $D(PID("SSN")),$P(^DPT(DFN,0),U,9)'=$G(PID("SSN")) D Q
62 .S SRDISC="SSN mismatch for Surgery Case #"_$G(CASE)_". Surgery Patient "_$$GET1^DIQ(2,+DFN_",",.01)_" ("_$$GET1^DIQ(2,+40_",",.09)_") is being sent with invalid ID ("_$G(PID("SSN"))_")."
63 .D SETDSC^SRHLU(.HL,SRDISC,.SRHL)
64 ;process the OBR identifier that is set to receive
65 I $$CHECK(IEN)=1 S OBR=$$OBR^SRHLUI(CASE,DFN,IEN,MSG)
66 Q
67CHECK(IEN) ;check for valid receivable segments in file 133.2 (Surgery Interface)
68 I $G(IEN)="" Q 0
69 Q $P($G(^SRO(133.2,IEN,0)),U,4)["R"
Note: See TracBrowser for help on using the repository browser.