- SRHLUO4C ;B'HAM ISC\DLR - Surgery Interface (Cont.) Utility for SRHLUO4 ; [ 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.
- CHECK(FLD) ;uses file 133.2 IEN to check INTERFACE field is set to send or
- N VALUE,ID
- S VALUE=0
- I FLD="" Q VALUE
- ;check to see if this field has already been processed
- I $D(CNT(FLD)) Q VALUE
- S CNT(FLD)=1
- I '$D(^SRO(133.2,FLD,0)) Q VALUE
- I '$D(^SRF(CASE,"NON")) S ID=$O(^SRO(133.2,"AC","PROCEDURE",0)) I ID=FLD S VALUE=0 Q VALUE
- I $D(^SRF(CASE,"NON")) S ID=$O(^SRO(133.2,"AC","OPERATION",0)) I ID=FLD S VALUE=1 Q VALUE
- I $P(^SRO(133.2,FLD,0),U,4)["S" S VALUE=1
- Q VALUE
- VALUE(IEN,FILE,SRST,FIELD) ;uses file 133.2 IEN to get the value from SRHL, create by GETS^DIQ(), and return it in an HL7 format. (ONLY OBR and OBX segments)
- N VALUE
- Q:'$D(SRHL(FILE,SRST,FIELD,$S($P(^SRO(133.2,IEN,0),U,6)="TS":"I",$P(^(0),U,6)="CN":"I",1:"E"))) ""
- S VALUE=SRHL(FILE,SRST,FIELD,$S($P(^SRO(133.2,IEN,0),U,6)="TS":"I",$P(^(0),U,6)="CN":"I",1:"E"))
- I $P(^SRO(133.2,IEN,0),U,6)="CE" S VALUE=$P(^(0),U,10)_HLCOMP_VALUE_HLCOMP_$P(^(0),U,11)
- I $P(^SRO(133.2,IEN,0),U,6)="CN" S VALUE=$$HNAME^SRHLU(VALUE)
- I $P(^SRO(133.2,IEN,0),U,6)="TS" S VALUE=$$HLDATE^HLFNC(VALUE)
- K SRHL(FILE,SRST,FIELD)
- Q VALUE
- MSG(OBR,OBX,NTE) ;create ^TMP(SRENT global by processing OBR and underlying OBX segments
- N SRX,SRY
- S SRX=0 F S SRX=$O(OBR(SRX)) Q:'SRX I $P($P(OBR(SRX),HL("FS"),5),HLCOMP,5)'=""!$D(OBX(SRX))!$P(OBR(SRX),HL("FS"),8)'=""!$P(OBR(SRX),HL("FS"),9)'="" S SROBR=SROBR+1,SRI=SRI+1,$P(OBR(SRX),HL("FS"),2)=SROBR D
- .S ^TMP(SRENT,$J,SRI)=OBR(SRX)
- .I $D(NTE(SRX)) S SRY=0 F S SRY=$O(NTE(SRX,SRY)) Q:'SRY S SRI=SRI+1,^TMP(SRENT,$J,SRI)=NTE(SRX,SRY)
- .S (OBX,SRY)=0 F S SRY=$O(OBX(SRX,SRY)) Q:'SRY S OBX=OBX+1,SRI=SRI+1,$P(OBX(SRX,SRY),HL("FS"),2)=OBX,$P(OBX(SRX,SRY),HL("FS"),12)="F",^TMP(SRENT,$J,SRI)=OBX(SRX,SRY)
- Q
- MSGV(OBR,OBX,NTE) ;create ^TMP("HLS" global by processing OBR and underlying OBX segments
- N SRX,SRY
- S SRX=0 F S SRX=$O(OBR(SRX)) Q:'SRX I $P($P(OBR(SRX),HLFS,5),HLCOMP,5)'=""!$D(OBX(SRX))!$P(OBR(SRX),HLFS,8)'=""!$P(OBR(SRX),HLFS,9)'="" S SROBR=SROBR+1,SRI=SRI+1,$P(OBR(SRX),HLFS,2)=SROBR D
- .S ^TMP("HLS",$J,HLSDT,SRI)=OBR(SRX)
- .I $D(NTE(SRX)) S SRY=0 F S SRY=$O(NTE(SRX,SRY)) Q:'SRY S SRI=SRI+1,^TMP("HLS",$J,HLSDT,SRI)=NTE(SRX,SRY)
- .S (OBX,SRY)=0 F S SRY=$O(OBX(SRX,SRY)) Q:'SRY S OBX=OBX+1,SRI=SRI+1,$P(OBX(SRX,SRY),HLFS,2)=OBX,$P(OBX(SRX,SRY),HLFS,12)="F",^TMP("HLS",$J,HLSDT,SRI)=OBX(SRX,SRY)
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSRHLUO4C 2561 printed Feb 19, 2025@00:05:59 Page 2
- SRHLUO4C ;B'HAM ISC\DLR - Surgery Interface (Cont.) Utility for SRHLUO4 ; [ 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.
- CHECK(FLD) ;uses file 133.2 IEN to check INTERFACE field is set to send or
- +1 NEW VALUE,ID
- +2 SET VALUE=0
- +3 IF FLD=""
- QUIT VALUE
- +4 ;check to see if this field has already been processed
- +5 IF $DATA(CNT(FLD))
- QUIT VALUE
- +6 SET CNT(FLD)=1
- +7 IF '$DATA(^SRO(133.2,FLD,0))
- QUIT VALUE
- +8 IF '$DATA(^SRF(CASE,"NON"))
- SET ID=$ORDER(^SRO(133.2,"AC","PROCEDURE",0))
- IF ID=FLD
- SET VALUE=0
- QUIT VALUE
- +9 IF $DATA(^SRF(CASE,"NON"))
- SET ID=$ORDER(^SRO(133.2,"AC","OPERATION",0))
- IF ID=FLD
- SET VALUE=1
- QUIT VALUE
- +10 IF $PIECE(^SRO(133.2,FLD,0),U,4)["S"
- SET VALUE=1
- +11 QUIT VALUE
- VALUE(IEN,FILE,SRST,FIELD) ;uses file 133.2 IEN to get the value from SRHL, create by GETS^DIQ(), and return it in an HL7 format. (ONLY OBR and OBX segments)
- +1 NEW VALUE
- +2 if '$DATA(SRHL(FILE,SRST,FIELD,$SELECT($PIECE(^SRO(133.2,IEN,0),U,6)="TS"
- QUIT ""
- +3 SET VALUE=SRHL(FILE,SRST,FIELD,$SELECT($PIECE(^SRO(133.2,IEN,0),U,6)="TS":"I",$PIECE(^(0),U,6)="CN":"I",1:"E"))
- +4 IF $PIECE(^SRO(133.2,IEN,0),U,6)="CE"
- SET VALUE=$PIECE(^(0),U,10)_HLCOMP_VALUE_HLCOMP_$PIECE(^(0),U,11)
- +5 IF $PIECE(^SRO(133.2,IEN,0),U,6)="CN"
- SET VALUE=$$HNAME^SRHLU(VALUE)
- +6 IF $PIECE(^SRO(133.2,IEN,0),U,6)="TS"
- SET VALUE=$$HLDATE^HLFNC(VALUE)
- +7 KILL SRHL(FILE,SRST,FIELD)
- +8 QUIT VALUE
- MSG(OBR,OBX,NTE) ;create ^TMP(SRENT global by processing OBR and underlying OBX segments
- +1 NEW SRX,SRY
- +2 SET SRX=0
- FOR
- SET SRX=$ORDER(OBR(SRX))
- if 'SRX
- QUIT
- IF $PIECE($PIECE(OBR(SRX),HL("FS"),5),HLCOMP,5)'=""!$DATA(OBX(SRX))!$PIECE(OBR(SRX),HL("FS"),8)'=""!$PIECE(OBR(SRX),HL("FS"),9)'=""
- SET SROBR=SROBR+1
- SET SRI=SRI+1
- SET $PIECE(OBR(SRX),HL("FS"),2)=SROBR
- Begin DoDot:1
- +3 SET ^TMP(SRENT,$JOB,SRI)=OBR(SRX)
- +4 IF $DATA(NTE(SRX))
- SET SRY=0
- FOR
- SET SRY=$ORDER(NTE(SRX,SRY))
- if 'SRY
- QUIT
- SET SRI=SRI+1
- SET ^TMP(SRENT,$JOB,SRI)=NTE(SRX,SRY)
- +5 SET (OBX,SRY)=0
- FOR
- SET SRY=$ORDER(OBX(SRX,SRY))
- if 'SRY
- QUIT
- SET OBX=OBX+1
- SET SRI=SRI+1
- SET $PIECE(OBX(SRX,SRY),HL("FS"),2)=OBX
- SET $PIECE(OBX(SRX,SRY),HL("FS"),12)="F"
- SET ^TMP(SRENT,$JOB,SRI)=OBX(SRX,SRY)
- End DoDot:1
- +6 QUIT
- MSGV(OBR,OBX,NTE) ;create ^TMP("HLS" global by processing OBR and underlying OBX segments
- +1 NEW SRX,SRY
- +2 SET SRX=0
- FOR
- SET SRX=$ORDER(OBR(SRX))
- if 'SRX
- QUIT
- IF $PIECE($PIECE(OBR(SRX),HLFS,5),HLCOMP,5)'=""!$DATA(OBX(SRX))!$PIECE(OBR(SRX),HLFS,8)'=""!$PIECE(OBR(SRX),HLFS,9)'=""
- SET SROBR=SROBR+1
- SET SRI=SRI+1
- SET $PIECE(OBR(SRX),HLFS,2)=SROBR
- Begin DoDot:1
- +3 SET ^TMP("HLS",$JOB,HLSDT,SRI)=OBR(SRX)
- +4 IF $DATA(NTE(SRX))
- SET SRY=0
- FOR
- SET SRY=$ORDER(NTE(SRX,SRY))
- if 'SRY
- QUIT
- SET SRI=SRI+1
- SET ^TMP("HLS",$JOB,HLSDT,SRI)=NTE(SRX,SRY)
- +5 SET (OBX,SRY)=0
- FOR
- SET SRY=$ORDER(OBX(SRX,SRY))
- if 'SRY
- QUIT
- SET OBX=OBX+1
- SET SRI=SRI+1
- SET $PIECE(OBX(SRX,SRY),HLFS,2)=OBX
- SET $PIECE(OBX(SRX,SRY),HLFS,12)="F"
- SET ^TMP("HLS",$JOB,HLSDT,SRI)=OBX(SRX,SRY)
- End DoDot:1
- +6 QUIT