SRHLVORU ;B'HAM ISC/DLR - Surgery Interface Receiver of ORU message ; [ 05/06/98 7:14 AM ]
;;3.0; Surgery ;**41**;24 Jun 93
; Per VHA Directive 10-93-142, this routine SHOULD NOT be modified.
;processing of incoming ORU message
; 1. process MSH - create field separator and other encoding characters
; 2. process PID - establish patient IEN
; 3. process OBR - create observation identifier and stuff fields
; a. process OBX - using OBR identifier stuff fields
; b. process NTE - using OBR identifier stuff anesthesia comment
; 4. use ^TMP("SRHL" global to create a descrepancy report if needed
;
; Troubleshooting
; What to do if a field is not being added?
; 1. View descrepancy message.
; 2. Check the Flag Interface Fields option for a receive flag.
; 3. Check to see if the field has an input transform.
;
REC N DFN,DFN1,HLCOMP,HLREP,HLSUB,II,SG,SRERR,SRI,SRHLX,SSN,TYPE,QOBR
S QOBR=1 ;flag for stopping OBR segments from being processed
S UPDATE=0
S SRHLX=1 K ^TMP("SRHL")
S SRNOCON=1 ;no concurrent case information
S II=0 F S II=$O(^HL(772,HLDA,"IN",II)) Q:'II!$D(HLERR) S MSG=^HL(772,HLDA,"IN",II,0),SG=$E(^(0),1,3) D PICK
I $D(DR)&('$D(HLERR))&($G(QOBR)=0) D ^DIE K DR,DO,DIE
EXIT ;
S HLMTN="ACK",HLSDT=1,SRI=1
D MSA^SRHLVUO(.SRI,$S($D(HLERR):"AE",1:"AA"))
I $D(HLERR) D ERR^SRHLVUO(.SRI,.SRERR)
W:$G(HLERR)'="" !,"ERROR ",$G(HLERR)
W:$G(HLERR)="" !,"NO ERROR"
D EN^HLTRANS
I $D(^TMP("SRHL")) K DIC S DIC="^XMB(3.8,",X="SRHL DISCREPANCY" D ^DIC K DIC Q:Y=-1 D REPORT(HLMID)
Q
PICK ;check routine for segment entry point
I $T(@SG)]"" D @SG
I $T(@SG)="" S HLERR="Invalid segment "_$G(SG)_" in message "_$G(TYPE) Q
Q
MSH ;process the MSH segment
S HLFS=$E(MSG,4),HLECH=$E(MSG,5,8)
S HLCOMP=$E(HLECH,1),HLREP=$E(HLECH,2),HLSUB=$E(HLECH,4)
S TYPE=$P(MSG,HLFS,9)
Q
PID ;process PID segment
N I,PAT,SSN
S SSN=$P(MSG,HLFS,20),PAT=$$FMNAME^HLFNC($P(MSG,HLFS,6))
I $G(PAT)'="" F I=0:0 S I=$O(^DPT("B",PAT,I)) Q:'I S DFN=I
I $G(SSN)'="" S DFN1=$O(^DPT("SSN",SSN,0))
I $G(DFN)=""&($G(DFN1)="") S HLERR="Invalid Patient Name or SSN"
E I $G(DFN)'=$G(DFN1) S ^TMP("SRHL",SRHLX)=PAT_" does not match SSN, "_SSN_".",SRHLX=SRHLX+1
Q
OBX ;OBX segments processing
I '$D(HLERR)&($G(QOBR)=0) D:'$D(DR)&($D(OBR)) OBR^SRHLVUI("",OBR) D OBX^SRHLVUI2(MSG,OBR) I UPDATE=1 W !,"DR ",DR D ^DIE K DR,DO S UPDATE=0
Q
NTE ;NTE segment processing
I $D(DR)&('$D(HLERR))&($G(QOBR)=0) D ^DIE K DR,DO
I '$D(HLERR)&($G(QOBR)'=1)&($D(OBR)) D NTE^SRHLVUI2(MSG,OBR)
Q
DSC Q
OBR ;OBR segment processing
I $D(DR)&('$D(HLERR))&($G(QOBR)=0) W !,"OBR DR",DR D ^DIE K DR,DO,DIE
N CASE,CDFN,ID,IEN
S QOBR=0
;set-up the IDentifier and check the mapping file (#133.2) for a match
S ID=$P($P(MSG,HLFS,5),HLCOMP,2) I $G(ID)="" S HLERR="Missing OBR identifier" Q
S IEN=$O(^SRO(133.2,"AC",ID,0)) I $G(IEN)="" D SET("Invalid OBR identifier",OBR,"",.SRHLX) Q
S CASE=$P(MSG,HLFS,4) I CASE="" S HLERR="NULL Case Number" Q
I '$D(^SRF(CASE,0)) S HLERR="Invalid Surgery Case Number" Q
I $D(^SRF(CASE,0)) S CDFN=$P(^SRF(CASE,0),U) I CDFN'=$G(DFN)&((CDFN'=$G(DFN1))) S HLERR="Mismatch of PID patient and Case patient" Q
;get the next OBR segment that is set to receive
I $$CHECK(IEN)'=1 S QOBR=1 Q
S (SRTN,DA)=CASE,DIE=$P(^SRO(133.2,IEN,0),U,2)
;process the OBR identifier that is set to receive
I $$CHECK(IEN)=1 S OBR=MSG D:'$D(HLERR) OBR^SRHLVUI(IEN,OBR)
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"
REPORT(HLMID) ;creates discrepancy report to be mailed to SR HL7 mailgroup
S XMSUB="Message #"_HLMID_" contains Surgery application discrepancies."
S XMY("G.SRHL DISCREPANCY")=""
S XMTEXT="^TMP(""SRHL"","
D ^XMD
Q
SET(ECODE,OBR,OBX,SRHLX) ;sets up discrepancy global
S ^TMP("SRHL",SRHLX)=ECODE_" at position OBR-"_$P(OBR,HLFS,2)_$S($G(OBX)'="":" OBX-"_$P(OBX,HLFS,2),1:"")_".",SRHLX=SRHLX+1
Q
SRHLVORU ;B'HAM ISC/DLR - Surgery Interface Receiver of ORU message ; [ 05/06/98 7:14 AM ]
+1 ;;3.0; Surgery ;**41**;24 Jun 93
+2 ; Per VHA Directive 10-93-142, this routine SHOULD NOT be modified.
+3 ;processing of incoming ORU message
+4 ; 1. process MSH - create field separator and other encoding characters
+5 ; 2. process PID - establish patient IEN
+6 ; 3. process OBR - create observation identifier and stuff fields
+7 ; a. process OBX - using OBR identifier stuff fields
+8 ; b. process NTE - using OBR identifier stuff anesthesia comment
+9 ; 4. use ^TMP("SRHL" global to create a descrepancy report if needed
+10 ;
+11 ; Troubleshooting
+12 ; What to do if a field is not being added?
+13 ; 1. View descrepancy message.
+14 ; 2. Check the Flag Interface Fields option for a receive flag.
+15 ; 3. Check to see if the field has an input transform.
+16 ;
REC NEW DFN,DFN1,HLCOMP,HLREP,HLSUB,II,SG,SRERR,SRI,SRHLX,SSN,TYPE,QOBR
+1 ;flag for stopping OBR segments from being processed
SET QOBR=1
+2 SET UPDATE=0
+3 SET SRHLX=1
KILL ^TMP("SRHL")
+4 ;no concurrent case information
SET SRNOCON=1
+5 SET II=0
FOR
SET II=$ORDER(^HL(772,HLDA,"IN",II))
IF 'II!$DATA(HLERR)
QUIT
SET MSG=^HL(772,HLDA,"IN",II,0)
SET SG=$EXTRACT(^(0),1,3)
DO PICK
+6 IF $DATA(DR)&('$DATA(HLERR))&($GET(QOBR)=0)
DO ^DIE
KILL DR,DO,DIE
EXIT ;
+1 SET HLMTN="ACK"
SET HLSDT=1
SET SRI=1
+2 DO MSA^SRHLVUO(.SRI,$SELECT($DATA(HLERR):"AE",1:"AA"))
+3 IF $DATA(HLERR)
DO ERR^SRHLVUO(.SRI,.SRERR)
+4 IF $GET(HLERR)'=""
WRITE !,"ERROR ",$GET(HLERR)
+5 IF $GET(HLERR)=""
WRITE !,"NO ERROR"
+6 DO EN^HLTRANS
+7 IF $DATA(^TMP("SRHL"))
KILL DIC
SET DIC="^XMB(3.8,"
SET X="SRHL DISCREPANCY"
DO ^DIC
KILL DIC
IF Y=-1
QUIT
DO REPORT(HLMID)
+8 QUIT
PICK ;check routine for segment entry point
+1 IF $TEXT(@SG)]""
DO @SG
+2 IF $TEXT(@SG)=""
SET HLERR="Invalid segment "_$GET(SG)_" in message "_$GET(TYPE)
QUIT
+3 QUIT
MSH ;process the MSH segment
+1 SET HLFS=$EXTRACT(MSG,4)
SET HLECH=$EXTRACT(MSG,5,8)
+2 SET HLCOMP=$EXTRACT(HLECH,1)
SET HLREP=$EXTRACT(HLECH,2)
SET HLSUB=$EXTRACT(HLECH,4)
+3 SET TYPE=$PIECE(MSG,HLFS,9)
+4 QUIT
PID ;process PID segment
+1 NEW I,PAT,SSN
+2 SET SSN=$PIECE(MSG,HLFS,20)
SET PAT=$$FMNAME^HLFNC($PIECE(MSG,HLFS,6))
+3 IF $GET(PAT)'=""
FOR I=0:0
SET I=$ORDER(^DPT("B",PAT,I))
IF 'I
QUIT
SET DFN=I
+4 IF $GET(SSN)'=""
SET DFN1=$ORDER(^DPT("SSN",SSN,0))
+5 IF $GET(DFN)=""&($GET(DFN1)="")
SET HLERR="Invalid Patient Name or SSN"
+6 IF '$TEST
IF $GET(DFN)'=$GET(DFN1)
SET ^TMP("SRHL",SRHLX)=PAT_" does not match SSN, "_SSN_"."
SET SRHLX=SRHLX+1
+7 QUIT
OBX ;OBX segments processing
+1 IF '$DATA(HLERR)&($GET(QOBR)=0)
IF '$DATA(DR)&($DATA(OBR))
DO OBR^SRHLVUI("",OBR)
DO OBX^SRHLVUI2(MSG,OBR)
IF UPDATE=1
WRITE !,"DR ",DR
DO ^DIE
KILL DR,DO
SET UPDATE=0
+2 QUIT
NTE ;NTE segment processing
+1 IF $DATA(DR)&('$DATA(HLERR))&($GET(QOBR)=0)
DO ^DIE
KILL DR,DO
+2 IF '$DATA(HLERR)&($GET(QOBR)'=1)&($DATA(OBR))
DO NTE^SRHLVUI2(MSG,OBR)
+3 QUIT
DSC QUIT
OBR ;OBR segment processing
+1 IF $DATA(DR)&('$DATA(HLERR))&($GET(QOBR)=0)
WRITE !,"OBR DR",DR
DO ^DIE
KILL DR,DO,DIE
+2 NEW CASE,CDFN,ID,IEN
+3 SET QOBR=0
+4 ;set-up the IDentifier and check the mapping file (#133.2) for a match
+5 SET ID=$PIECE($PIECE(MSG,HLFS,5),HLCOMP,2)
IF $GET(ID)=""
SET HLERR="Missing OBR identifier"
QUIT
+6 SET IEN=$ORDER(^SRO(133.2,"AC",ID,0))
IF $GET(IEN)=""
DO SET("Invalid OBR identifier",OBR,"",.SRHLX)
QUIT
+7 SET CASE=$PIECE(MSG,HLFS,4)
IF CASE=""
SET HLERR="NULL Case Number"
QUIT
+8 IF '$DATA(^SRF(CASE,0))
SET HLERR="Invalid Surgery Case Number"
QUIT
+9 IF $DATA(^SRF(CASE,0))
SET CDFN=$PIECE(^SRF(CASE,0),U)
IF CDFN'=$GET(DFN)&((CDFN'=$GET(DFN1)))
SET HLERR="Mismatch of PID patient and Case patient"
QUIT
+10 ;get the next OBR segment that is set to receive
+11 IF $$CHECK(IEN)'=1
SET QOBR=1
QUIT
+12 SET (SRTN,DA)=CASE
SET DIE=$PIECE(^SRO(133.2,IEN,0),U,2)
+13 ;process the OBR identifier that is set to receive
+14 IF $$CHECK(IEN)=1
SET OBR=MSG
IF '$DATA(HLERR)
DO OBR^SRHLVUI(IEN,OBR)
+15 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"
REPORT(HLMID) ;creates discrepancy report to be mailed to SR HL7 mailgroup
+1 SET XMSUB="Message #"_HLMID_" contains Surgery application discrepancies."
+2 SET XMY("G.SRHL DISCREPANCY")=""
+3 SET XMTEXT="^TMP(""SRHL"","
+4 DO ^XMD
+5 QUIT
SET(ECODE,OBR,OBX,SRHLX) ;sets up discrepancy global
+1 SET ^TMP("SRHL",SRHLX)=ECODE_" at position OBR-"_$PIECE(OBR,HLFS,2)_$SELECT($GET(OBX)'="":" OBX-"_$PIECE(OBX,HLFS,2),1:"")_"."
SET SRHLX=SRHLX+1
+2 QUIT
