- 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