- 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"
- 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"
