SRHLORU ;B'HAM ISC/DLR - Surgery Interface Receiver of ORU messages ; [ 02/06/01 9:27 AM ]
;;3.0; Surgery ;**41,100**;24 Jun 93
; Per VHA Directive 10-93-142, this routine SHOULD NOT be modified.
REC N HLCOMP,HLREP,HLSUB,HLFS,HLECH,II,SG,SRERR,SRES,SRESCNT,SRESAR,SRESNR,SRI,SSN,TYPE,SROP,SRNON,SRHL,Z
K HLMID,PID,SRHL S SRHL("E")=+$G(SRHL("E")),(SRESCNT,SRESAR,SRESNR)=0
S Z=$G(^SRF(CASE,"TIU")) S:$P(Z,"^",2) SRESNR=1 S:$P(Z,"^",4) SRESAR=1
F I=1:1 X HLNEXT Q:HLQUIT'>0 S (MSG,X(I))=HLNODE,SG=$E(HLNODE,1,3),J=0 D D PICK
.S J=0 F S J=$O(HLNODE(J)) Q:'J S X(I,J)=HLNODE(J)
D:SRHL("E")>0 DSCPANCY^SRHLU(.HL)
GEN ;generate the message
D MSA^SRHLUO(1,$S($D(HLP("ERRTEXT")):"AE",1:"AA"))
;HLEID - IEN of Server event protocol
;HLMTIENS - IEN in 772
;HLEIDS - IEN of Client event protocol
;HLARYTYP - acknowledgement array (see V. 1.6 HL7 doc)
;HLFORMAT - is HLMA is pre-formatted HL7 form
;HLRESLTA - message ID and/or the error message (for output)
;HLP("ERRTEXT") - Processing error message
;HLP("CONTPTR") - continuation pointer field value (not used)
;HLP("PRIORITY") - priority field value (not used)
;HLP("SECURITY") - security information (not used)
S HLEID=HL("EID"),HLEIDS=HL("EIDS"),HLARYTYP="GM",HLFORMAT=1,HLRESLTA="",HLMTIENA="",HLP=""
D GENACK^HLMA1(HLEID,HLMTIENS,HLEIDS,HLARYTYP,HLFORMAT,.HLRESLTA,HLMTIENA,.HLP)
EXIT ;
K ^TMP("HLA",$J),SRHL
Q
PICK ;check routine for segment entry point
I $T(@SG)]"" D @SG
I $T(@SG)="" Q
Q
MSH ;;MSH
;process the MSH segment
S (HLFS,HL("FS"))=$E(MSG,4),(HLECH,HL("ECH"))=$E(MSG,5,8)
S HLCOMP=$E(HL("ECH"),1),HLREP=$E(HL("ECH"),2),HLSUB=$E(HL("ECH"),4)
S TYPE=$P(MSG,HL("FS"),9)
Q
PID ;;PID
;process PID segment
N I,PAT
S PID("SSN")=$P(MSG,HL("FS"),20),PAT=$$FMNAME^HLFNC($P(MSG,HL("FS"),6))
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
Q
OBX ;;OBX
;null header for OBR segments sets that are set to ignore or send
Q:$G(OBR)=""
D:$G(OBR)'="" OBX^SRHLUI(MSG,OBR,CASE)
Q
NTE ;;NTE
;null header for OBR segments sets that are set to ignore or send
Q:$G(OBR)=""
D NTE^SRHLUI(MSG,OBR,CASE)
Q
OBR ;;OBR
;process OBR segment as well as underlying OBX's or NTE
N DFN,ID,IEN,SRII,SRNEXT
;set-up the IDentifier and check the mapping file (#133.2) for a match
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
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
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
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
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
.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"))_")."
.D SETDSC^SRHLU(.HL,SRDISC,.SRHL)
;process the OBR identifier that is set to receive
I $$CHECK(IEN)=1 S OBR=$$OBR^SRHLUI(CASE,DFN,IEN,MSG)
Q
CHECK(IEN) ;check for valid receivable segments in file 133.2 (Surgery Interface)
I $G(IEN)="" Q 0
Q $P($G(^SRO(133.2,IEN,0)),U,4)["R"
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSRHLORU 3524 printed Sep 23, 2025@20:15:43 Page 2
SRHLORU ;B'HAM ISC/DLR - Surgery Interface Receiver of ORU messages ; [ 02/06/01 9:27 AM ]
+1 ;;3.0; Surgery ;**41,100**;24 Jun 93
+2 ; Per VHA Directive 10-93-142, this routine SHOULD NOT be modified.
REC NEW HLCOMP,HLREP,HLSUB,HLFS,HLECH,II,SG,SRERR,SRES,SRESCNT,SRESAR,SRESNR,SRI,SSN,TYPE,SROP,SRNON,SRHL,Z
+1 KILL HLMID,PID,SRHL
SET SRHL("E")=+$GET(SRHL("E"))
SET (SRESCNT,SRESAR,SRESNR)=0
+2 SET Z=$GET(^SRF(CASE,"TIU"))
if $PIECE(Z,"^",2)
SET SRESNR=1
if $PIECE(Z,"^",4)
SET SRESAR=1
+3 FOR I=1:1
XECUTE HLNEXT
if HLQUIT'>0
QUIT
SET (MSG,X(I))=HLNODE
SET SG=$EXTRACT(HLNODE,1,3)
SET J=0
Begin DoDot:1
+4 SET J=0
FOR
SET J=$ORDER(HLNODE(J))
if 'J
QUIT
SET X(I,J)=HLNODE(J)
End DoDot:1
DO PICK
+5 if SRHL("E")>0
DO DSCPANCY^SRHLU(.HL)
GEN ;generate the message
+1 DO MSA^SRHLUO(1,$SELECT($DATA(HLP("ERRTEXT")):"AE",1:"AA"))
+2 ;HLEID - IEN of Server event protocol
+3 ;HLMTIENS - IEN in 772
+4 ;HLEIDS - IEN of Client event protocol
+5 ;HLARYTYP - acknowledgement array (see V. 1.6 HL7 doc)
+6 ;HLFORMAT - is HLMA is pre-formatted HL7 form
+7 ;HLRESLTA - message ID and/or the error message (for output)
+8 ;HLP("ERRTEXT") - Processing error message
+9 ;HLP("CONTPTR") - continuation pointer field value (not used)
+10 ;HLP("PRIORITY") - priority field value (not used)
+11 ;HLP("SECURITY") - security information (not used)
+12 SET HLEID=HL("EID")
SET HLEIDS=HL("EIDS")
SET HLARYTYP="GM"
SET HLFORMAT=1
SET HLRESLTA=""
SET HLMTIENA=""
SET HLP=""
+13 DO GENACK^HLMA1(HLEID,HLMTIENS,HLEIDS,HLARYTYP,HLFORMAT,.HLRESLTA,HLMTIENA,.HLP)
EXIT ;
+1 KILL ^TMP("HLA",$JOB),SRHL
+2 QUIT
PICK ;check routine for segment entry point
+1 IF $TEXT(@SG)]""
DO @SG
+2 IF $TEXT(@SG)=""
QUIT
+3 QUIT
MSH ;;MSH
+1 ;process the MSH segment
+2 SET (HLFS,HL("FS"))=$EXTRACT(MSG,4)
SET (HLECH,HL("ECH"))=$EXTRACT(MSG,5,8)
+3 SET HLCOMP=$EXTRACT(HL("ECH"),1)
SET HLREP=$EXTRACT(HL("ECH"),2)
SET HLSUB=$EXTRACT(HL("ECH"),4)
+4 SET TYPE=$PIECE(MSG,HL("FS"),9)
+5 QUIT
PID ;;PID
+1 ;process PID segment
+2 NEW I,PAT
+3 SET PID("SSN")=$PIECE(MSG,HL("FS"),20)
SET PAT=$$FMNAME^HLFNC($PIECE(MSG,HL("FS"),6))
+4 IF $DATA(PAT)
FOR I=0:0
SET I=$ORDER(^DPT("B",PAT,I))
if 'I
QUIT
IF $PIECE(^DPT(I,0),U,9)=PID("SSN")
SET PID("DFN")=I
+5 QUIT
OBX ;;OBX
+1 ;null header for OBR segments sets that are set to ignore or send
+2 if $GET(OBR)=""
QUIT
+3 if $GET(OBR)'=""
DO OBX^SRHLUI(MSG,OBR,CASE)
+4 QUIT
NTE ;;NTE
+1 ;null header for OBR segments sets that are set to ignore or send
+2 if $GET(OBR)=""
QUIT
+3 DO NTE^SRHLUI(MSG,OBR,CASE)
+4 QUIT
OBR ;;OBR
+1 ;process OBR segment as well as underlying OBX's or NTE
+2 NEW DFN,ID,IEN,SRII,SRNEXT
+3 ;set-up the IDentifier and check the mapping file (#133.2) for a match
+4 SET CASE=$PIECE(MSG,HL("FS"),4)
IF 'CASE
SET SRDISC="Unknown Surgery Case Number in "_$PIECE(MSG,HL("FS"),1,2)_"."
DO SETDSC^SRHLU(.HL,SRDISC,.SRHL)
QUIT
+5 IF '$DATA(^SRF(CASE,0))
SET SRDISC="Unknown Surgery Case Number ("_$GET(CASE)_") in "_$PIECE(MSG,HL("FS"),1,2)_"."
DO SETDSC^SRHLU(.HL,SRDISC,.SRHL)
QUIT
+6 SET ID=$PIECE($PIECE(MSG,HL("FS"),5),HLCOMP,2)
IF $GET(ID)=""
SET SRDISC="Unknown OBR identifier ("_$GET(ID)_") for case #"_$GET(CASE)_"."
DO SETDSC^SRHLU(.HL,SRDISC,.SRHL)
QUIT
+7 SET IEN=$ORDER(^SRO(133.2,"AC",ID,0))
IF $GET(IEN)=""
SET SRDISC="Invalid OBR identifier ("_$GET(ID)_") for case #"_$GET(CASE)_"."
DO SETDSC^SRHLU(.HL,SRDISC,.SRHL)
QUIT
+8 IF $DATA(^SRF(CASE,0))
SET DFN=$PIECE(^SRF(CASE,0),U)
IF $DATA(PID("SSN"))
IF $PIECE(^DPT(DFN,0),U,9)'=$GET(PID("SSN"))
Begin DoDot:1
+9 SET SRDISC="SSN mismatch for Surgery Case #"_$GET(CASE)_". Surgery Patient "_$$GET1^DIQ(2,+DFN_",",.01)_" ("_$$GET1^DIQ(2,+40_",",.09)_") is being sent with invalid ID ("_$GET(PID("SSN"))_")."
+10 DO SETDSC^SRHLU(.HL,SRDISC,.SRHL)
End DoDot:1
QUIT
+11 ;process the OBR identifier that is set to receive
+12 IF $$CHECK(IEN)=1
SET OBR=$$OBR^SRHLUI(CASE,DFN,IEN,MSG)
+13 QUIT
CHECK(IEN) ;check for valid receivable segments in file 133.2 (Surgery Interface)
+1 IF $GET(IEN)=""
QUIT 0
+2 QUIT $PIECE($GET(^SRO(133.2,IEN,0)),U,4)["R"
