SRHLUI ;B'ham ISC/DLR - Surgery Interface Utility to process incoming segments ; [ 02/06/01 9:53 PM ]
;;3.0; Surgery ;**41,100**;24 Jun 93
; Per VHA Directive 10-93-142, this routine SHOULD NOT be modified.
;;This routine utilizes the Surgery Interface file (133.2).
OBR(CASE,DFN,IEN,MSG) ;process Observation Request Segment (OBR) fields 3-4,7-8,27
;variables set in the calling routine SRHLORU
; CASE - IEN of the case # in Surgery Case file (#130)
; DFN - IEN of the patient
; IEN - The Observation ID's internal entry number in file 133.2
; MSG - (parameter) HL7 incoming segment
;
K DA,DR,DIE
N LVL,OBR,SRNOCON,SRX
Q:$G(MSG)="" ""
;set the surgery no concurrent case flag
S SRNOCON=1
S OBR=MSG,DA=CASE,DIE=$P(^SRO(133.2,IEN,0),U,2) K DR,DO
;if there is a VISTA Surgery field(s) associated with this entry process the DR strings
I $P(^SRO(133.2,IEN,0),U,3)!($D(^(1,0))) D
.S:$P(^SRO(133.2,IEN,0),U,3) DR=$P(^(0),U,3)_"///^S X="_$$VALUE(IEN) D:$D(^SRO(133.2,IEN,1,0))
..;sets the DR string level (DR and DR(2,...)) for the standard DIE call
..S SRX=0 F S SRX=$O(^SRO(133.2,IEN,1,SRX)) Q:'SRX S LVL=$P(^SRO(133.2,SRX,0),U,9) Q:"12"[$G(LVL)&($G(LVL)="") I $$VALUE(SRX)'="" D:$$CHECK(SRX) DR(LVL,SRX)
.I $D(DR) N SRESQ D
..D ^SROESHL Q:SRESQ
..D DRCHK D ^DIE K DIE,DA,DR,DO I $D(Y) S SRDISC="Unknown OBR identifier ("_$G(ID)_")." D SETDSC^SRHLU(.HL,SRDISC,.SRHL)
Q OBR
CHECK(IEN) ;check universal id or observation id sequence to the Surgery Interface file
I $G(IEN)="" Q 0
Q $P($G(^SRO(133.2,IEN,0)),U,4)["R"
VALUE(XX) ;SET the value of the identified segment field in file 133.2
S ^TMP("SR7",XX)=^SRO(133.2,XX,0)
N VALUE
;set the value of the identifiers based on the sequences identified in file 133.2
S:$P(^SRO(133.2,XX,0),U,6)'="CN" VALUE=$P($P(@$P(^SRO(133.2,XX,0),U,5),HL("FS"),$P($P(^(0),U,8),"-")+1),HLCOMP,$P($P(^(0),U,8),"-",2))
S:$P(^SRO(133.2,XX,0),U,6)="CN" VALUE=$P(@$P(^SRO(133.2,XX,0),U,5),HL("FS"),$P($P(^(0),U,8),"-")+1)
S:VALUE'="" VALUE=$S($P(^SRO(133.2,XX,0),U,6)="TS":$$FMDATE^HLFNC(VALUE),$P(^(0),U,6)="CE":""""_VALUE_"""",$P(^(0),U,6)="TX":""""_VALUE_"""",$P(^(0),U,6)="FT":""""_VALUE_"""",$P(^(0),U,6)="NM":+VALUE,1:VALUE)
I $P(^SRO(133.2,XX,0),U,6)="CN" S VALUE=$$DNAME^SRHLU(VALUE),VALUE=$S(VALUE="":"",1:""""_VALUE_"""")
Q VALUE
DR(LVL,IEN) ;set DR or DR(... string for the FileMan DIE call
Q:$G(LVL)=""!$G(IEN)=""
;set DR string but do not four slash stuff Time Stamped values for multiples
I LVL=1 S VALUE=$$VALUE(IEN) S:VALUE'="" DR=$G(DR)_$S($D(DR):";",1:"")_$P(^SRO(133.2,IEN,0),U,3)_$S($P(^(0),U,6)="TS"&($P(^(0),U,3)'=".01")&('$D(^(1,0))):"/",1:"")_"///"_VALUE
;set DR string but do not four slash stuff Time Stamped values for multiples
I LVL'=1 S VALUE=$$VALUE(IEN) S:VALUE'="" DR(LVL,$P(^SRO(133.2,IEN,0),U,2))=$G(DR(LVL,$P(^(0),U,2)))_$S($D(DR(LVL,$P(^(0),U,2))):";",1:"")_$P(^(0),U,3)_$S($P(^(0),U,6)="TS"&($P(^(0),U,3)'=".01")&('$D(^(1,0))):"/",1:"")_"///"_VALUE
Q
NTE(MSG,OBR,CASE) ;process Observation Segment (OBX) fields 3,5,14,16 and NTE-3
;anesthesia comments
Q:MSG=""
N ID
S ID=$P($P(OBR,HL("FS"),5),HLCOMP,2) I $G(ID)="" S SRDISC="Unknown OBR identifier ("_$G(ID)_")." D SETDSC^SRHLU(.HL,SRDISC,.SRHL) Q
S IEN=$O(^SRO(133.2,"AC",ID,0)) I $G(IEN)="" S SRDISC="Unknown OBR identifier ("_$G(ID)_")." D SETDSC^SRHLU(.HL,SRDISC,.SRHL) Q
Q:$$CHECK(IEN)'=1
I ID="ANESTHESIA" D
.I $P(MSG,HL("FS"),2)>1,'$D(^SRF(CASE,6,1,7,0)) S SRDISC="Invalid sequence this NTE segment, '"_MSG_"'." D SETDSC^SRHLU(.HL,SRDISC,.SRHL) Q
.S:$P(MSG,HL("FS"),2)=1 ^SRF(CASE,6,1,7,0)="^^0^0^"_DT_"^^^^" S ^SRF(CASE,6,1,7,$P(^SRF(CASE,6,1,7,0),U,3)+1,0)=$P(MSG,HL("FS"),4),$P(^(0),U,3)=$P(^SRF(CASE,6,1,7,0),U,3)+1,$P(^(0),U,4)=$P(^(0),U,4)+1,$P(^(0),U,5)=DT
Q
OBX(MSG,OBR,CASE) ;process Observation Segment (OBX) fields 3,5,14,16 and NTE-3
N ID,IEN,NM,OBX,SRESQ,TYPE
S DA=CASE,OBX=MSG
S ID=$P($P(OBR,HL("FS"),5),HLCOMP,2) I $G(ID)="" S SRDISC="Unknown OBR identifier ("_$G(ID)_")." D SETDSC^SRHLU(.HL,SRDISC,.SRHL) Q
S IEN=$O(^SRO(133.2,"AC",ID,0)) I $G(IEN)="" S SRDISC="Unknown OBX identifier ("_$G(ID)_")." D SETDSC^SRHLU(.HL,SRDISC,.SRHL) Q
Q:$$CHECK(IEN)'=1
I $P(^SRO(133.2,IEN,0),U,3) S NM=$$VALUE(IEN) I NM="" S SRDISC="Unknown OBX identifier ("_$G(ID)_")." D SETDSC^SRHLU(.HL,SRDISC,.SRHL) Q
K DIE,DR,DO S DIE=$P(^SRO(133.2,IEN,0),U,2) I DIE="" S SRDISC="Unknown OBX identifier ("_$G(ID)_")." D SETDSC^SRHLU(.HL,SRDISC,.SRHL) Q
I $P(^SRO(133.2,IEN,0),U,3) S DR=$P(^(0),U,3)_"///^S X="_NM D:$D(^SRO(133.2,IEN,1,0))
.S SRX=0 F S SRX=$O(^SRO(133.2,IEN,1,SRX)) Q:'SRX S LVL=$P(^SRO(133.2,SRX,0),U,9) Q:"12"[$G(LVL)&($G(LVL)="") I $$VALUE(SRX)'="" D DR(LVL,SRX)
;set the msg variable to the segment type for the VALUE subroutine
I $P(MSG,HL("FS"))="OBX" S ID=$P($P(MSG,HL("FS"),4),HLCOMP,2) I $G(ID)="" S SRDISC="Unknown OBX identifier ("_$G(ID)_")." D SETDSC^SRHLU(.HL,SRDISC,.SRHL) Q
S IEN=$O(^SRO(133.2,"AC",ID,0)) I $G(IEN)="" S SRDISC="Unknown OBX identifier ("_$G(ID)_")." D SETDSC^SRHLU(.HL,SRDISC,.SRHL) Q
S NM=$$VALUE(IEN) I NM="" Q
;if field is set to receive, then set DR string for DIE call
I $$CHECK(IEN)=1 S LVL=$P(^SRO(133.2,IEN,0),U,9) D DR(LVL,IEN) D:$D(^SRO(133.2,IEN,1,0)) N SRESQ D ^SROESHL Q:SRESQ D ^DIE K DIE,DA,DR,DO
.S SRX=0 F S SRX=$O(^SRO(133.2,IEN,1,SRX)) Q:'SRX S LVL=$P(^SRO(133.2,SRX,0),U,9) Q:"12"[$G(LVL)&($G(LVL)="") I $$VALUE(SRX)'="" D DR(LVL,SRX)
Q
DRCHK ;CHECK DR STRING (for debugging only)
;Check DR string by removing the Quit and adding TMP( global to the loop
Q
S SRCNT=+$G(SRCNT)+1 S SRJ="" F S SRJ=$O(DR(SRJ)) Q:'SRJ S SRK="" F S SRK=$O(DR(SRJ,SRK)) Q:'SRK S SRCNT=SRCNT+1
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSRHLUI 5712 printed Apr 09, 2024@21:47:29 Page 2
SRHLUI ;B'ham ISC/DLR - Surgery Interface Utility to process incoming segments ; [ 02/06/01 9:53 PM ]
+1 ;;3.0; Surgery ;**41,100**;24 Jun 93
+2 ; Per VHA Directive 10-93-142, this routine SHOULD NOT be modified.
+3 ;;This routine utilizes the Surgery Interface file (133.2).
OBR(CASE,DFN,IEN,MSG) ;process Observation Request Segment (OBR) fields 3-4,7-8,27
+1 ;variables set in the calling routine SRHLORU
+2 ; CASE - IEN of the case # in Surgery Case file (#130)
+3 ; DFN - IEN of the patient
+4 ; IEN - The Observation ID's internal entry number in file 133.2
+5 ; MSG - (parameter) HL7 incoming segment
+6 ;
+7 KILL DA,DR,DIE
+8 NEW LVL,OBR,SRNOCON,SRX
+9 if $GET(MSG)=""
QUIT ""
+10 ;set the surgery no concurrent case flag
+11 SET SRNOCON=1
+12 SET OBR=MSG
SET DA=CASE
SET DIE=$PIECE(^SRO(133.2,IEN,0),U,2)
KILL DR,DO
+13 ;if there is a VISTA Surgery field(s) associated with this entry process the DR strings
+14 IF $PIECE(^SRO(133.2,IEN,0),U,3)!($DATA(^(1,0)))
Begin DoDot:1
+15 if $PIECE(^SRO(133.2,IEN,0),U,3)
SET DR=$PIECE(^(0),U,3)_"///^S X="_$$VALUE(IEN)
if $DATA(^SRO(133.2,IEN,1,0))
Begin DoDot:2
+16 ;sets the DR string level (DR and DR(2,...)) for the standard DIE call
+17 SET SRX=0
FOR
SET SRX=$ORDER(^SRO(133.2,IEN,1,SRX))
if 'SRX
QUIT
SET LVL=$PIECE(^SRO(133.2,SRX,0),U,9)
if "12"[$GET(LVL)&($GET(LVL)="")
QUIT
IF $$VALUE(SRX)'=""
if $$CHECK(SRX)
DO DR(LVL,SRX)
End DoDot:2
+18 IF $DATA(DR)
NEW SRESQ
Begin DoDot:2
+19 DO ^SROESHL
if SRESQ
QUIT
+20 DO DRCHK
DO ^DIE
KILL DIE,DA,DR,DO
IF $DATA(Y)
SET SRDISC="Unknown OBR identifier ("_$GET(ID)_")."
DO SETDSC^SRHLU(.HL,SRDISC,.SRHL)
End DoDot:2
End DoDot:1
+21 QUIT OBR
CHECK(IEN) ;check universal id or observation id sequence to the Surgery Interface file
+1 IF $GET(IEN)=""
QUIT 0
+2 QUIT $PIECE($GET(^SRO(133.2,IEN,0)),U,4)["R"
VALUE(XX) ;SET the value of the identified segment field in file 133.2
+1 SET ^TMP("SR7",XX)=^SRO(133.2,XX,0)
+2 NEW VALUE
+3 ;set the value of the identifiers based on the sequences identified in file 133.2
+4 if $PIECE(^SRO(133.2,XX,0),U,6)'="CN"
SET VALUE=$PIECE($PIECE(@$PIECE(^SRO(133.2,XX,0),U,5),HL("FS"),$PIECE($PIECE(^(0),U,8),"-")+1),HLCOMP,$PIECE($PIECE(^(0),U,8),"-",2))
+5 if $PIECE(^SRO(133.2,XX,0),U,6)="CN"
SET VALUE=$PIECE(@$PIECE(^SRO(133.2,XX,0),U,5),HL("FS"),$PIECE($PIECE(^(0),U,8),"-")+1)
+6 if VALUE'=""
SET VALUE=$SELECT($PIECE(^SRO(133.2,XX,0),U,6)="TS":$$FMDATE^HLFNC(VALUE),$PIECE(^(0),U,6)="CE":""""_VALUE_"""",$PIECE(^(0),U,6)="TX":""""_VALUE_"""",$PIECE(^(0),U,6)="FT":""""_VALUE_"""",$PIECE(^(0),U,6)="NM":+VALUE,1:VALUE)
+7 IF $PIECE(^SRO(133.2,XX,0),U,6)="CN"
SET VALUE=$$DNAME^SRHLU(VALUE)
SET VALUE=$SELECT(VALUE="":"",1:""""_VALUE_"""")
+8 QUIT VALUE
DR(LVL,IEN) ;set DR or DR(... string for the FileMan DIE call
+1 if $GET(LVL)=""!$GET(IEN)=""
QUIT
+2 ;set DR string but do not four slash stuff Time Stamped values for multiples
+3 IF LVL=1
SET VALUE=$$VALUE(IEN)
if VALUE'=""
SET DR=$GET(DR)_$SELECT($DATA(DR):";",1:"")_$PIECE(^SRO(133.2,IEN,0),U,3)_$SELECT($PIECE(^(0),U,6)="TS"&($PIECE(^(0),U,3)'=".01")&('$DATA(^(1,0))):"/",1:"")_"///"_VALUE
+4 ;set DR string but do not four slash stuff Time Stamped values for multiples
+5 IF LVL'=1
SET VALUE=$$VALUE(IEN)
if VALUE'=""
SET DR(LVL,$PIECE(^SRO(133.2,IEN,0),U,2))=$GET(DR(LVL,$PIECE(^(0),U,2)))_$SELECT($DATA(DR(LVL,$PIECE(^(0),U,2))):";",1:"")_$PIECE(^(0),U,3)_$SELECT($PIECE(^(0),U,6)="TS"&($PIECE(^(0),U,3)'=".01")&('$DATA(^(1,0))):"/",1:"")_"///"_VALUE
+6 QUIT
NTE(MSG,OBR,CASE) ;process Observation Segment (OBX) fields 3,5,14,16 and NTE-3
+1 ;anesthesia comments
+2 if MSG=""
QUIT
+3 NEW ID
+4 SET ID=$PIECE($PIECE(OBR,HL("FS"),5),HLCOMP,2)
IF $GET(ID)=""
SET SRDISC="Unknown OBR identifier ("_$GET(ID)_")."
DO SETDSC^SRHLU(.HL,SRDISC,.SRHL)
QUIT
+5 SET IEN=$ORDER(^SRO(133.2,"AC",ID,0))
IF $GET(IEN)=""
SET SRDISC="Unknown OBR identifier ("_$GET(ID)_")."
DO SETDSC^SRHLU(.HL,SRDISC,.SRHL)
QUIT
+6 if $$CHECK(IEN)'=1
QUIT
+7 IF ID="ANESTHESIA"
Begin DoDot:1
+8 IF $PIECE(MSG,HL("FS"),2)>1
IF '$DATA(^SRF(CASE,6,1,7,0))
SET SRDISC="Invalid sequence this NTE segment, '"_MSG_"'."
DO SETDSC^SRHLU(.HL,SRDISC,.SRHL)
QUIT
+9 if $PIECE(MSG,HL("FS"),2)=1
SET ^SRF(CASE,6,1,7,0)="^^0^0^"_DT_"^^^^"
SET ^SRF(CASE,6,1,7,$PIECE(^SRF(CASE,6,1,7,0),U,3)+1,0)=$PIECE(MSG,HL("FS"),4)
SET $PIECE(^(0),U,3)=$PIECE(^SRF(CASE,6,1,7,0),U,3)+1
SET $PIECE(^(0),U,4)=$PIECE(^(0),U,4)+1
SET $PIECE(^(0),U,5)=DT
End DoDot:1
+10 QUIT
OBX(MSG,OBR,CASE) ;process Observation Segment (OBX) fields 3,5,14,16 and NTE-3
+1 NEW ID,IEN,NM,OBX,SRESQ,TYPE
+2 SET DA=CASE
SET OBX=MSG
+3 SET ID=$PIECE($PIECE(OBR,HL("FS"),5),HLCOMP,2)
IF $GET(ID)=""
SET SRDISC="Unknown OBR identifier ("_$GET(ID)_")."
DO SETDSC^SRHLU(.HL,SRDISC,.SRHL)
QUIT
+4 SET IEN=$ORDER(^SRO(133.2,"AC",ID,0))
IF $GET(IEN)=""
SET SRDISC="Unknown OBX identifier ("_$GET(ID)_")."
DO SETDSC^SRHLU(.HL,SRDISC,.SRHL)
QUIT
+5 if $$CHECK(IEN)'=1
QUIT
+6 IF $PIECE(^SRO(133.2,IEN,0),U,3)
SET NM=$$VALUE(IEN)
IF NM=""
SET SRDISC="Unknown OBX identifier ("_$GET(ID)_")."
DO SETDSC^SRHLU(.HL,SRDISC,.SRHL)
QUIT
+7 KILL DIE,DR,DO
SET DIE=$PIECE(^SRO(133.2,IEN,0),U,2)
IF DIE=""
SET SRDISC="Unknown OBX identifier ("_$GET(ID)_")."
DO SETDSC^SRHLU(.HL,SRDISC,.SRHL)
QUIT
+8 IF $PIECE(^SRO(133.2,IEN,0),U,3)
SET DR=$PIECE(^(0),U,3)_"///^S X="_NM
if $DATA(^SRO(133.2,IEN,1,0))
Begin DoDot:1
+9 SET SRX=0
FOR
SET SRX=$ORDER(^SRO(133.2,IEN,1,SRX))
if 'SRX
QUIT
SET LVL=$PIECE(^SRO(133.2,SRX,0),U,9)
if "12"[$GET(LVL)&($GET(LVL)="")
QUIT
IF $$VALUE(SRX)'=""
DO DR(LVL,SRX)
End DoDot:1
+10 ;set the msg variable to the segment type for the VALUE subroutine
+11 IF $PIECE(MSG,HL("FS"))="OBX"
SET ID=$PIECE($PIECE(MSG,HL("FS"),4),HLCOMP,2)
IF $GET(ID)=""
SET SRDISC="Unknown OBX identifier ("_$GET(ID)_")."
DO SETDSC^SRHLU(.HL,SRDISC,.SRHL)
QUIT
+12 SET IEN=$ORDER(^SRO(133.2,"AC",ID,0))
IF $GET(IEN)=""
SET SRDISC="Unknown OBX identifier ("_$GET(ID)_")."
DO SETDSC^SRHLU(.HL,SRDISC,.SRHL)
QUIT
+13 SET NM=$$VALUE(IEN)
IF NM=""
QUIT
+14 ;if field is set to receive, then set DR string for DIE call
+15 IF $$CHECK(IEN)=1
SET LVL=$PIECE(^SRO(133.2,IEN,0),U,9)
DO DR(LVL,IEN)
if $DATA(^SRO(133.2,IEN,1,0))
Begin DoDot:1
+16 SET SRX=0
FOR
SET SRX=$ORDER(^SRO(133.2,IEN,1,SRX))
if 'SRX
QUIT
SET LVL=$PIECE(^SRO(133.2,SRX,0),U,9)
if "12"[$GET(LVL)&($GET(LVL)="")
QUIT
IF $$VALUE(SRX)'=""
DO DR(LVL,SRX)
End DoDot:1
NEW SRESQ
DO ^SROESHL
if SRESQ
QUIT
DO ^DIE
KILL DIE,DA,DR,DO
+17 QUIT
DRCHK ;CHECK DR STRING (for debugging only)
+1 ;Check DR string by removing the Quit and adding TMP( global to the loop
+2 QUIT
+3 SET SRCNT=+$GET(SRCNT)+1
SET SRJ=""
FOR
SET SRJ=$ORDER(DR(SRJ))
if 'SRJ
QUIT
SET SRK=""
FOR
SET SRK=$ORDER(DR(SRJ,SRK))
if 'SRK
QUIT
SET SRCNT=SRCNT+1
+4 QUIT
