SRHLUO4 ;B'HAM ISC\DLR - Surgery Interface (Cont.) Utilities for building Outgoing HL7 Segments ; [ 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.
OBR(SRI,CASE,SRENT) ;Observation
;variables
; OBR(obr) & OBX(obr,x) = temp array for processing segments
; CNT(IEN) - eliminates redundant processing in file 133.2
; SRHL - local array built by GETS^DIQ() call
;
;process all OBR and underlying OBX segments
MAIN N CNT,FIELD,FILE,FLAGS,IEN,SEQ,SRST,SRX,SRY,SRY1,SROBR,TAR,TMPOBR
S (SROBR,SRX)=0 F S SRX=$O(^SRO(133.2,SRX)) Q:'SRX I $D(^SRO(133.2,SRX,2,0)) K OBR,OBX,NTE,TMPOBR I $$CHECK^SRHLUO4C(SRX) D POBR,POBX D MSG^SRHLUO4C(.OBR,.OBX,.NTE)
EXIT ;
K DIQ,DA,DR,OBR,OBX,NTE
Q
POBR ;sets up the DIQ
K SRHL,HDR,SR
;setup the variables for the GETS^DIQ() call
S TAR="SRHL",FLAGS="IEN",IENS=CASE_",",SRST=""
;check multiple entries to process using the GETS call
I $D(^SRO(133.2,SRX,1,0)) D INIT(SRX) I FIELD'="" S FIELD=FIELD_"*" D GETS^DIQ(FILE,IENS,FIELD,FLAGS,TAR)
;OBR-4 text identifier
S (TMPOBR,HDR)="OBR"_HL("FS")_HL("FS")_HL("FS")_CASE_HL("FS")_$P(^SRO(133.2,SRX,0),U,10)_HLCOMP_$P(^(0),U)_HLCOMP_$P(^(0),U,11)
;process all subordinate sequences (1 node)
S SRY=0 F S SRY=$O(^SRO(133.2,SRX,1,SRY)) Q:'SRY D:$$CHECK^SRHLUO4C(SRY)
.D INIT(SRY)
.;GETS file 130 fields or multiples if file 133.2 has 1 node
.I FILE=130 S FIELDS=FIELD_$S($D(^SRO(133.2,SRY,1,0)):"*",1:"") D GETS^DIQ(FILE,IENS,FIELDS,FLAGS,TAR)
.;process fields that are not multiples and do not have subordinate sequences
.I '$D(^SRO(133.2,SRY,1,0)) S SRST="" F S SRST=$O(SRHL(FILE,SRST)) Q:SRST="" D:$D(SRHL(FILE,SRST,FIELD,$S($P(^SRO(133.2,SRY,0),U,6)="TS":"I",$P(^(0),U,6)="CN":"I",1:"E")))
..S:'$D(OBR(SRST)) OBR(SRST)=HDR S $P(OBR(SRST),HL("FS"),SEQ)=$S($P(OBR(SRST),HL("FS"),SEQ)="":"",1:$P(OBR(SRST),HL("FS"),SEQ)_HLCOMP)_$$VALUE^SRHLUO4C(SRY,FILE,SRST,FIELD)
.;process all multiples and subordinate sequences
.I $D(^SRO(133.2,SRY,1,0)) S SRY1=$O(^SRO(133.2,SRY,1,0)) I $$CHECK^SRHLUO4C(SRY1) S SRST="" F S SRST=$O(SRHL($P(^SRO(133.2,SRY1,0),U,2),SRST)) Q:SRST="" D
..D INIT(SRY1) Q:'$D(SRHL(FILE,SRST,FIELD,$S($P(^SRO(133.2,SRY1,0),U,6)="TS":"I",$P(^(0),U,6)="CN":"I",1:"E")))
..S FLD=$P(SRST,",",2,4),SEQ=$P($P(^SRO(133.2,SRY1,0),U,8),"-")+1
..;process level 3 multiples: move lower level 2 info up to level 3 and level 2 info for other multiples at level 3
..I $D(OBR(FLD))!$D(SR(FLD)) S OBR(SRST)=$S($D(OBR(FLD)):OBR(FLD),1:SR(FLD)) I $D(OBR(FLD)) S SR(FLD)=OBR(FLD) K OBR(FLD)
..S $P(OBR(SRST),HL("FS"),SEQ)=$$VALUE^SRHLUO4C(SRY1,FILE,SRST,FIELD)
.K SR
Q
POBX ;process the underlying OBX & NTE segments
S (SRY,OBX)=0 F S SRY=$O(^SRO(133.2,SRX,2,SRY)) Q:'SRY D:$$CHECK^SRHLUO4C(SRY)
.D INIT(SRY) I FILE=130 S:$D(^SRO(133.2,SRY,1,0)) FIELD=FIELD_"*" D GETS^DIQ(FILE,IENS,FIELD,FLAGS,TAR)
.I $P(^SRO(133.2,SRY,0),U,5)="NTE" D Q
..S SRST="",SRZ=0 F S SRST=$O(SRHL(FILE,SRST)) Q:SRST="" S FLD=$S('$D(OBR(SRST)):$P(SRST,",",2,4),1:SRST) F S SRZ=$O(SRHL(FILE,SRST,FIELD,SRZ)) Q:'SRZ S NTE(FLD,SRZ)="NTE"_HL("FS")_SRZ_HL("FS")_"P"_HL("FS")_SRHL(FILE,SRST,FIELD,SRZ)
.S HDR="OBX"_HL("FS")_HL("FS")_$P(^SRO(133.2,SRY,0),U,6)_HL("FS")_$P(^(0),U,10)_HLCOMP_$P(^(0),U)_HLCOMP_$P(^(0),U,11),OBX=OBX+1
.;process non-multiple entries with or without 1 nodes
.S SRST="" F S SRST=$O(SRHL(FILE,SRST)) Q:SRST="" S VALUE=$$VALUE^SRHLUO4C(SRY,FILE,SRST,FIELD) I VALUE'="" D
..S OBX(SRST,OBX)=HDR,SEQ=$P($P(^SRO(133.2,SRY,0),U,8),"-")+1,$P(OBX(SRST,OBX),HL("FS"),SEQ)=$S($P(OBX(SRST,OBX),HL("FS"),SEQ)="":"",1:$P(OBX(SRST,OBX),HL("FS"),SEQ)_HLCOMP)_VALUE
..S:$P(^SRO(133.2,SRY,0),U,12)'="" $P(OBX(SRST,OBX),HL("FS"),7)=$P(^(0),U,12)
..I '$D(OBR(SRST)) S OBR(SRST)=TMPOBR
..;process the subordinate sequences
..S SRY1=0,CNT(SRY)=1 F S SRY1=$O(^SRO(133.2,SRY,1,SRY1)) Q:'SRY1 S CNT(SRY1)=1 D INIT(SRY1) S FLD=$S('$D(OBR(SRST)):$P(SRST,",",2,4),1:SRST),$P(OBX(FLD,OBX),HL("FS"),SEQ)=$$VALUE^SRHLUO4C(SRY1,FILE,SRST,FIELD)
..;reset FILE for the SRHL array loop
..D INIT(SRY)
.;process all multiple entries
.I $D(^SRO(133.2,SRY,1,0)) S SRY1=$O(^SRO(133.2,SRY,1,0)) I SRY1>0 D INIT(SRY1) S SRST="" F S SRST=$O(SRHL(FILE,SRST)) Q:SRST="" D
..;process all of the subordinate sequences (all 1 nodes)
..S OBX=OBX+1,SRY1=0 F S SRY1=$O(^SRO(133.2,SRY,1,SRY1)) Q:'SRY1 D INIT(SRY1) S FLD=$S('$D(OBR(SRST)):$P(SRST,",",2,4),1:SRST),VALUE=$$VALUE^SRHLUO4C(SRY1,FILE,SRST,FIELD) D:VALUE'=""
...S:SEQ=4 OBX(FLD,OBX)=HDR_HLCOMP_VALUE,$P(OBX(FLD,OBX),HL("FS"),7)=$P(^SRO(133.2,SRY1,0),U,12) S:SEQ'=4 $P(OBX(FLD,OBX),HL("FS"),SEQ)=VALUE
...;S:SEQ=4 OBX(SRST,OBX)=HDR_HLCOMP_VALUE S:SEQ'=4 $P(OBX(FLD,OBX),HL("FS"),SEQ)=VALUE
Q
INIT(IEN) ;initialize FILE FIELD and SEQ
S FILE=$P(^SRO(133.2,IEN,0),U,2),FIELD=$P(^(0),U,3),SEQ=$P($P(^(0),U,8),"-")+1
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSRHLUO4 4902 printed Jan 18, 2025@03:40:39 Page 2
SRHLUO4 ;B'HAM ISC\DLR - Surgery Interface (Cont.) Utilities for building Outgoing HL7 Segments ; [ 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.
OBR(SRI,CASE,SRENT) ;Observation
+1 ;variables
+2 ; OBR(obr) & OBX(obr,x) = temp array for processing segments
+3 ; CNT(IEN) - eliminates redundant processing in file 133.2
+4 ; SRHL - local array built by GETS^DIQ() call
+5 ;
+6 ;process all OBR and underlying OBX segments
MAIN NEW CNT,FIELD,FILE,FLAGS,IEN,SEQ,SRST,SRX,SRY,SRY1,SROBR,TAR,TMPOBR
+1 SET (SROBR,SRX)=0
FOR
SET SRX=$ORDER(^SRO(133.2,SRX))
if 'SRX
QUIT
IF $DATA(^SRO(133.2,SRX,2,0))
KILL OBR,OBX,NTE,TMPOBR
IF $$CHECK^SRHLUO4C(SRX)
DO POBR
DO POBX
DO MSG^SRHLUO4C(.OBR,.OBX,.NTE)
EXIT ;
+1 KILL DIQ,DA,DR,OBR,OBX,NTE
+2 QUIT
POBR ;sets up the DIQ
+1 KILL SRHL,HDR,SR
+2 ;setup the variables for the GETS^DIQ() call
+3 SET TAR="SRHL"
SET FLAGS="IEN"
SET IENS=CASE_","
SET SRST=""
+4 ;check multiple entries to process using the GETS call
+5 IF $DATA(^SRO(133.2,SRX,1,0))
DO INIT(SRX)
IF FIELD'=""
SET FIELD=FIELD_"*"
DO GETS^DIQ(FILE,IENS,FIELD,FLAGS,TAR)
+6 ;OBR-4 text identifier
+7 SET (TMPOBR,HDR)="OBR"_HL("FS")_HL("FS")_HL("FS")_CASE_HL("FS")_$PIECE(^SRO(133.2,SRX,0),U,10)_HLCOMP_$PIECE(^(0),U)_HLCOMP_$PIECE(^(0),U,11)
+8 ;process all subordinate sequences (1 node)
+9 SET SRY=0
FOR
SET SRY=$ORDER(^SRO(133.2,SRX,1,SRY))
if 'SRY
QUIT
if $$CHECK^SRHLUO4C(SRY)
Begin DoDot:1
+10 DO INIT(SRY)
+11 ;GETS file 130 fields or multiples if file 133.2 has 1 node
+12 IF FILE=130
SET FIELDS=FIELD_$SELECT($DATA(^SRO(133.2,SRY,1,0)):"*",1:"")
DO GETS^DIQ(FILE,IENS,FIELDS,FLAGS,TAR)
+13 ;process fields that are not multiples and do not have subordinate sequences
+14 IF '$DATA(^SRO(133.2,SRY,1,0))
SET SRST=""
FOR
SET SRST=$ORDER(SRHL(FILE,SRST))
if SRST=""
QUIT
if $DATA(SRHL(FILE,SRST,FIELD,$SELECT($PIECE(^SRO(133.2,SRY,0),U,6)="TS"
Begin DoDot:2
+15 if '$DATA(OBR(SRST))
SET OBR(SRST)=HDR
SET $PIECE(OBR(SRST),HL("FS"),SEQ)=$SELECT($PIECE(OBR(SRST),HL("FS"),SEQ)="":"",1:$PIECE(OBR(SRST),HL("FS"),SEQ)_HLCOMP)_$$VALUE^SRHLUO4C(SRY,FILE,SRST,FIELD)
End DoDot:2
+16 ;process all multiples and subordinate sequences
+17 IF $DATA(^SRO(133.2,SRY,1,0))
SET SRY1=$ORDER(^SRO(133.2,SRY,1,0))
IF $$CHECK^SRHLUO4C(SRY1)
SET SRST=""
FOR
SET SRST=$ORDER(SRHL($PIECE(^SRO(133.2,SRY1,0),U,2),SRST))
if SRST=""
QUIT
Begin DoDot:2
+18 DO INIT(SRY1)
if '$DATA(SRHL(FILE,SRST,FIELD,$SELECT($PIECE(^SRO(133.2,SRY1,0),U,6)="TS"
QUIT
+19 SET FLD=$PIECE(SRST,",",2,4)
SET SEQ=$PIECE($PIECE(^SRO(133.2,SRY1,0),U,8),"-")+1
+20 ;process level 3 multiples: move lower level 2 info up to level 3 and level 2 info for other multiples at level 3
+21 IF $DATA(OBR(FLD))!$DATA(SR(FLD))
SET OBR(SRST)=$SELECT($DATA(OBR(FLD)):OBR(FLD),1:SR(FLD))
IF $DATA(OBR(FLD))
SET SR(FLD)=OBR(FLD)
KILL OBR(FLD)
+22 SET $PIECE(OBR(SRST),HL("FS"),SEQ)=$$VALUE^SRHLUO4C(SRY1,FILE,SRST,FIELD)
End DoDot:2
+23 KILL SR
End DoDot:1
+24 QUIT
POBX ;process the underlying OBX & NTE segments
+1 SET (SRY,OBX)=0
FOR
SET SRY=$ORDER(^SRO(133.2,SRX,2,SRY))
if 'SRY
QUIT
if $$CHECK^SRHLUO4C(SRY)
Begin DoDot:1
+2 DO INIT(SRY)
IF FILE=130
if $DATA(^SRO(133.2,SRY,1,0))
SET FIELD=FIELD_"*"
DO GETS^DIQ(FILE,IENS,FIELD,FLAGS,TAR)
+3 IF $PIECE(^SRO(133.2,SRY,0),U,5)="NTE"
Begin DoDot:2
+4 SET SRST=""
SET SRZ=0
FOR
SET SRST=$ORDER(SRHL(FILE,SRST))
if SRST=""
QUIT
SET FLD=$SELECT('$DATA(OBR(SRST)):$PIECE(SRST,",",2,4),1:SRST)
FOR
SET SRZ=$ORDER(SRHL(FILE,SRST,FIELD,SRZ))
if 'SRZ
QUIT
SET NTE(FLD,SRZ)="NTE"_HL("FS")_SRZ_HL("FS")_"P"_HL("FS")_SRHL(FILE,SRST,FIELD,SRZ)
End DoDot:2
QUIT
+5 SET HDR="OBX"_HL("FS")_HL("FS")_$PIECE(^SRO(133.2,SRY,0),U,6)_HL("FS")_$PIECE(^(0),U,10)_HLCOMP_$PIECE(^(0),U)_HLCOMP_$PIECE(^(0),U,11)
SET OBX=OBX+1
+6 ;process non-multiple entries with or without 1 nodes
+7 SET SRST=""
FOR
SET SRST=$ORDER(SRHL(FILE,SRST))
if SRST=""
QUIT
SET VALUE=$$VALUE^SRHLUO4C(SRY,FILE,SRST,FIELD)
IF VALUE'=""
Begin DoDot:2
+8 SET OBX(SRST,OBX)=HDR
SET SEQ=$PIECE($PIECE(^SRO(133.2,SRY,0),U,8),"-")+1
SET $PIECE(OBX(SRST,OBX),HL("FS"),SEQ)=$SELECT($PIECE(OBX(SRST,OBX),HL("FS"),SEQ)="":"",1:$PIECE(OBX(SRST,OBX),HL("FS"),SEQ)_HLCOMP)_VALUE
+9 if $PIECE(^SRO(133.2,SRY,0),U,12)'=""
SET $PIECE(OBX(SRST,OBX),HL("FS"),7)=$PIECE(^(0),U,12)
+10 IF '$DATA(OBR(SRST))
SET OBR(SRST)=TMPOBR
+11 ;process the subordinate sequences
+12 SET SRY1=0
SET CNT(SRY)=1
FOR
SET SRY1=$ORDER(^SRO(133.2,SRY,1,SRY1))
if 'SRY1
QUIT
SET CNT(SRY1)=1
DO INIT(SRY1)
SET FLD=$SELECT('$DATA(OBR(SRST)):$PIECE(SRST,",",2,4),1:SRST)
SET $PIECE(OBX(FLD,OBX),HL("FS"),SEQ)=$$VALUE^SRHLUO4C(SRY1,FILE,SRST,FIELD)
+13 ;reset FILE for the SRHL array loop
+14 DO INIT(SRY)
End DoDot:2
+15 ;process all multiple entries
+16 IF $DATA(^SRO(133.2,SRY,1,0))
SET SRY1=$ORDER(^SRO(133.2,SRY,1,0))
IF SRY1>0
DO INIT(SRY1)
SET SRST=""
FOR
SET SRST=$ORDER(SRHL(FILE,SRST))
if SRST=""
QUIT
Begin DoDot:2
+17 ;process all of the subordinate sequences (all 1 nodes)
+18 SET OBX=OBX+1
SET SRY1=0
FOR
SET SRY1=$ORDER(^SRO(133.2,SRY,1,SRY1))
if 'SRY1
QUIT
DO INIT(SRY1)
SET FLD=$SELECT('$DATA(OBR(SRST)):$PIECE(SRST,",",2,4),1:SRST)
SET VALUE=$$VALUE^SRHLUO4C(SRY1,FILE,SRST,FIELD)
if VALUE'=""
Begin DoDot:3
+19 if SEQ=4
SET OBX(FLD,OBX)=HDR_HLCOMP_VALUE
SET $PIECE(OBX(FLD,OBX),HL("FS"),7)=$PIECE(^SRO(133.2,SRY1,0),U,12)
if SEQ'=4
SET $PIECE(OBX(FLD,OBX),HL("FS"),SEQ)=VALUE
+20 ;S:SEQ=4 OBX(SRST,OBX)=HDR_HLCOMP_VALUE S:SEQ'=4 $P(OBX(FLD,OBX),HL("FS"),SEQ)=VALUE
End DoDot:3
End DoDot:2
End DoDot:1
+21 QUIT
INIT(IEN) ;initialize FILE FIELD and SEQ
+1 SET FILE=$PIECE(^SRO(133.2,IEN,0),U,2)
SET FIELD=$PIECE(^(0),U,3)
SET SEQ=$PIECE($PIECE(^(0),U,8),"-")+1
+2 QUIT
