RORHL11 ;HOIFO/BH,SG - HL7 CYTOPATHOLOGY DATA: OBR,OBX ;3/13/06 9:24am
;;1.5;CLINICAL CASE REGISTRIES;**1,19**;Feb 17, 2006;Build 43
;
; This routine uses the following IAs:
;
; #4344 $$CYPATH^LA7UTL02 (controlled)
;
;******************************************************************************
;******************************************************************************
; --- ROUTINE MODIFICATION LOG ---
;
;PKG/PATCH DATE DEVELOPER MODIFICATION
;----------- ---------- ----------- ----------------------------------------
;ROR*1.5*19 MAY 2012 K GUPTA Support for ICD-10 Coding System.
;
;******************************************************************************
;******************************************************************************
Q
;
;***** SEARCHES BY SPECIMEN COLLECTION DATE
CD() ;
N ENDT,ERRCNT,IDT,STDT
S ERRCNT=0
S STDT=9999999-RORSTDT
S ENDT=9999999-RORENDT
S IDT=$O(^LR(LRDFN,"CY",STDT))
F S IDT=$O(^LR(LRDFN,"CY",IDT),-1) Q:'IDT!(IDT'>ENDT) D
. S:$$OBROBX(IDT) ERRCNT=ERRCNT+1
Q ERRCNT
;
;***** SEARCHES FOR CYTOPATHOLOGY DATA
;
; RORDFN IEN of the patient in the PATIENT file (#2)
;
; .DXDTS Reference to a local variable where the
; data extraction time frames are stored.
;
; [CDSMODE] Search the data by:
; 0 completion/result date (default)
; 1 specimen collection date
;
; Return Values:
; <0 Error code
; 0 Ok
; >0 Non-fatal error(s)
;
EN1(RORDFN,DXDTS,CDSMODE,RORPTR,RORFILE,HLFS,HLECH) ;
N ERRCNT,IDX,LRDFN,RC,RORENDT,RORIEN,RORSTDT
S (ERRCNT,RC)=0
;
S LRDFN=+$$LABREF^RORUTL18(RORDFN) Q:LRDFN'>0 0
;
S IDX=0
F S IDX=$O(DXDTS(10,IDX)) Q:IDX'>0 D Q:RC<0
. S RORSTDT=$P(DXDTS(10,IDX),U),RORENDT=$P(DXDTS(10,IDX),U,2)
. ;---
. S RC=$S($G(CDSMODE):$$CD(),1:$$RAD())
. S:RC>0 ERRCNT=ERRCNT+RC
;
Q $S(RC<0:RC,1:ERRCNT)
;
;*****
ICD(RPS) ;
Q:$D(@RORTMP@("ICD9"))<10
N CNT,ICDID,INDEX,RORICD,TMP,RORICDSNAM
S ICDID=$$SEGID("ICD","ICD",CS)
S (INDEX,RORICD,RORICDSNAM)="",CNT=0
F S INDEX=$O(@RORTMP@("ICD9",INDEX)) Q:INDEX="" D
. S TMP=$G(@RORTMP@("ICD9",INDEX)) Q:TMP=""
. S CNT=CNT+1,$P(RORICD,RPS,CNT)=TMP
. S:RORICDSNAM="" RORICDSNAM=$$CSNAME^RORHLUT1(80,INDEX)
D:RORICD'="" SETOBX(ICDID,RORICDSNAM_":"_RORICD)
Q
;
;***** CREATES OBR AND OBX SEGMENTS
OBROBX(RORIDT) ;
N ERRCNT,RC,RORMSG,RORTMP,TMP
S (ERRCNT,RC)=0
S RORTMP=$$ALLOC^RORTMP()
;---
I $$CYPATH^LA7UTL02(LRDFN,RORIDT,RORTMP,"RORMSG") D
. S RC=$$OBR(RORTMP,RORIDT)
. I RC S ERRCNT=ERRCNT+1 Q:RC<0
. ;---
. S RC=$$OBX(RORTMP)
. I RC S ERRCNT=ERRCNT+1 Q:RC<0
E D:$D(RORMSG)>1
. N I,INFO S TMP=""
. F I=1:1 S TMP=$O(RORMSG(TMP)) Q:TMP="" S INFO(I)=RORMSG(TMP)
. S RC=$$ERROR^RORERR(-56,,.INFO,,0,"$$CYPATH^LA7UTL02")
;---
D FREE^RORTMP(RORTMP)
Q $S(RC<0:RC,1:ERRCNT)
;
;***** CYTOPATHOLOGY OBR SEGMENT BUILDER
;
; RORTMP Closed root of the array holding lab data
; RORIEN IEN of Cyto Visit
;
; Return Values:
; <0 Error code
; 0 Ok
; >0 Non-fatal error(s)
;
OBR(RORTMP,RORIEN) ;
N CS,CPA,ERRCNT,RC,RORSEG,TMP
S (ERRCNT,RC)=0
D ECH^RORHL7(.CS)
;
;--- Initialize the segment
S RORSEG(0)="OBR"
;
;--- OBR-3 - Cyto Path Acc #
S CPA=$P($G(@RORTMP@("DEMO",RORIEN)),U,2) Q:CPA="" 0
S RORSEG(3)=CPA
;
;--- OBR-4
S RORSEG(4)="88108"_CS_"CYTOPATHOLOGY, CONCENT"_CS_"C4"
;
;--- OBR-7 - Date/Time Specimen Taken
S TMP=$$FMTHL7^XLFDT($P(@RORTMP@("DEMO",RORIEN),U))
I TMP'>0 D Q RC
. S RC=$$ERROR^RORERR(-100,,,,"No specimen date","$$CYPATH^LA7UTL02")
S RORSEG(7)=TMP
;
;--- OBR-24 - Service Section ID
S RORSEG(24)="CP"
;
;--- OBR-44 - Divsion
S RORSEG(44)=$$SITE^RORUTL03(CS)
;
;--- Store the segment
D ADDSEG^RORHL7(.RORSEG)
Q ERRCNT
;
;***** CYTOPATHOLOGY OBX SEGMENT BUILDER
;
; RORTMP Closed root of the array holding lab data
;
; Return Values:
; <0 Error code
; 0 Ok
; >0 Non-fatal error(s)
;
OBX(RORTMP) ;
N CS,ERRCNT,RC,RPS,TMP
S (ERRCNT,RC)=0
D ECH^RORHL7(.CS,,.RPS)
;
D:$D(@RORTMP@("SPEC")) SPECIMEN
D SETOBXWP($$SEGID("BCH","Brief clinical History",CS),"CHIS")
D SETOBXWP($$SEGID("PDIAG","Preoperative Diagnosis",CS),"PREDX")
D SETOBXWP($$SEGID("OF","Operative Findings",CS),"OPERDX")
D SETOBXWP($$SEGID("POPDIAG","Postoperative Diagnosis",CS),"POSTDX")
D SETOBXWP($$SEGID("MICRO","Microscopic Examination",CS),"MICRO")
D SETOBXWP($$SEGID("CDIAG","Cytopathology Diagnosis",CS),"CYTODX")
D ICD(RPS)
;
Q $S(RC<0:RC,1:ERRCNT)
;
;***** SEARCHES BY COMPLETION (RESULT) DATE
RAD() ;
N ERRCNT,IDT,RCDT
S (ERRCNT,IDT)=0
F S IDT=$O(^LR(LRDFN,"CY",IDT)) Q:'IDT D
. S RCDT=$P($G(^LR(LRDFN,"CY",IDT,0)),U,3)
. I RCDT'<RORSTDT,RCDT<RORENDT S:$$OBROBX(IDT) ERRCNT=ERRCNT+1
Q ERRCNT
;
;***** CONSTRUCTS SEGMENT IDENTIFIER
SEGID(PONE,PTWO,CS) ; Create segment identifier
Q PONE_CS_PTWO_CS_"VA080"
;
;***** CREATE AND STORE THE OBX SEGMENTS
SETOBX(OBX3,OBX5) ;
N RORSEG
;--- Initialize the segment
S RORSEG(0)="OBX"
;--- OBX-2
S RORSEG(2)="FT"
;--- OBX-3
S RORSEG(3)=OBX3
;--- OBX-5
S RORSEG(5)=$$ESCAPE^RORHL7(OBX5)
;--- OBX-11
S RORSEG(11)="F"
;--- Store the segment
D ADDSEG^RORHL7(.RORSEG)
Q
;
SETOBXWP(OBX3,SUBS) ;
N BR,CNT,I,I1,RORSEG,TMP
S BR=$E(HLECH,3)_".br"_$E(HLECH,3)
Q:$D(@RORTMP@(SUBS))<10
;--- Initialize the segment
S RORSEG(0)="OBX"
;--- OBX-2 - Value Type
S RORSEG(2)="FT"
;--- OBX-3 - Observation Identifier
S RORSEG(3)=OBX3
;--- OBX-5 - Observation Value
S I=$O(@RORTMP@(SUBS,"")),CNT=0
F Q:I="" S I1=$O(@RORTMP@(SUBS,I)) D S I=I1
. S TMP=$$ESCAPE^RORHL7(@RORTMP@(SUBS,I))
. S CNT=CNT+1,RORSEG(5,CNT)=$S(I1'="":TMP_BR,1:TMP)
;--- OBX-11 - Observation Result Status
S RORSEG(11)="F"
;--- Store the segment
D:$D(RORSEG(5)) ADDSEG^RORHL7(.RORSEG)
Q
;
;***** MAKES SPECIMEN OBX
SPECIMEN ;
N INDEX,RORSPEC,SPECID
S SPECID=$$SEGID("SPEC","Specimen",CS)
S INDEX=""
F S INDEX=$O(@RORTMP@("SPEC",INDEX)) Q:INDEX="" D
. S RORSPEC=$G(@RORTMP@("SPEC",INDEX))
. D:RORSPEC'="" SETOBX(SPECID,RORSPEC)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRORHL11 6326 printed Sep 23, 2025@19:17:55 Page 2
RORHL11 ;HOIFO/BH,SG - HL7 CYTOPATHOLOGY DATA: OBR,OBX ;3/13/06 9:24am
+1 ;;1.5;CLINICAL CASE REGISTRIES;**1,19**;Feb 17, 2006;Build 43
+2 ;
+3 ; This routine uses the following IAs:
+4 ;
+5 ; #4344 $$CYPATH^LA7UTL02 (controlled)
+6 ;
+7 ;******************************************************************************
+8 ;******************************************************************************
+9 ; --- ROUTINE MODIFICATION LOG ---
+10 ;
+11 ;PKG/PATCH DATE DEVELOPER MODIFICATION
+12 ;----------- ---------- ----------- ----------------------------------------
+13 ;ROR*1.5*19 MAY 2012 K GUPTA Support for ICD-10 Coding System.
+14 ;
+15 ;******************************************************************************
+16 ;******************************************************************************
+17 QUIT
+18 ;
+19 ;***** SEARCHES BY SPECIMEN COLLECTION DATE
CD() ;
+1 NEW ENDT,ERRCNT,IDT,STDT
+2 SET ERRCNT=0
+3 SET STDT=9999999-RORSTDT
+4 SET ENDT=9999999-RORENDT
+5 SET IDT=$ORDER(^LR(LRDFN,"CY",STDT))
+6 FOR
SET IDT=$ORDER(^LR(LRDFN,"CY",IDT),-1)
if 'IDT!(IDT'>ENDT)
QUIT
Begin DoDot:1
+7 if $$OBROBX(IDT)
SET ERRCNT=ERRCNT+1
End DoDot:1
+8 QUIT ERRCNT
+9 ;
+10 ;***** SEARCHES FOR CYTOPATHOLOGY DATA
+11 ;
+12 ; RORDFN IEN of the patient in the PATIENT file (#2)
+13 ;
+14 ; .DXDTS Reference to a local variable where the
+15 ; data extraction time frames are stored.
+16 ;
+17 ; [CDSMODE] Search the data by:
+18 ; 0 completion/result date (default)
+19 ; 1 specimen collection date
+20 ;
+21 ; Return Values:
+22 ; <0 Error code
+23 ; 0 Ok
+24 ; >0 Non-fatal error(s)
+25 ;
EN1(RORDFN,DXDTS,CDSMODE,RORPTR,RORFILE,HLFS,HLECH) ;
+1 NEW ERRCNT,IDX,LRDFN,RC,RORENDT,RORIEN,RORSTDT
+2 SET (ERRCNT,RC)=0
+3 ;
+4 SET LRDFN=+$$LABREF^RORUTL18(RORDFN)
if LRDFN'>0
QUIT 0
+5 ;
+6 SET IDX=0
+7 FOR
SET IDX=$ORDER(DXDTS(10,IDX))
if IDX'>0
QUIT
Begin DoDot:1
+8 SET RORSTDT=$PIECE(DXDTS(10,IDX),U)
SET RORENDT=$PIECE(DXDTS(10,IDX),U,2)
+9 ;---
+10 SET RC=$SELECT($GET(CDSMODE):$$CD(),1:$$RAD())
+11 if RC>0
SET ERRCNT=ERRCNT+RC
End DoDot:1
if RC<0
QUIT
+12 ;
+13 QUIT $SELECT(RC<0:RC,1:ERRCNT)
+14 ;
+15 ;*****
ICD(RPS) ;
+1 if $DATA(@RORTMP@("ICD9"))<10
QUIT
+2 NEW CNT,ICDID,INDEX,RORICD,TMP,RORICDSNAM
+3 SET ICDID=$$SEGID("ICD","ICD",CS)
+4 SET (INDEX,RORICD,RORICDSNAM)=""
SET CNT=0
+5 FOR
SET INDEX=$ORDER(@RORTMP@("ICD9",INDEX))
if INDEX=""
QUIT
Begin DoDot:1
+6 SET TMP=$GET(@RORTMP@("ICD9",INDEX))
if TMP=""
QUIT
+7 SET CNT=CNT+1
SET $PIECE(RORICD,RPS,CNT)=TMP
+8 if RORICDSNAM=""
SET RORICDSNAM=$$CSNAME^RORHLUT1(80,INDEX)
End DoDot:1
+9 if RORICD'=""
DO SETOBX(ICDID,RORICDSNAM_":"_RORICD)
+10 QUIT
+11 ;
+12 ;***** CREATES OBR AND OBX SEGMENTS
OBROBX(RORIDT) ;
+1 NEW ERRCNT,RC,RORMSG,RORTMP,TMP
+2 SET (ERRCNT,RC)=0
+3 SET RORTMP=$$ALLOC^RORTMP()
+4 ;---
+5 IF $$CYPATH^LA7UTL02(LRDFN,RORIDT,RORTMP,"RORMSG")
Begin DoDot:1
+6 SET RC=$$OBR(RORTMP,RORIDT)
+7 IF RC
SET ERRCNT=ERRCNT+1
if RC<0
QUIT
+8 ;---
+9 SET RC=$$OBX(RORTMP)
+10 IF RC
SET ERRCNT=ERRCNT+1
if RC<0
QUIT
End DoDot:1
+11 IF '$TEST
if $DATA(RORMSG)>1
Begin DoDot:1
+12 NEW I,INFO
SET TMP=""
+13 FOR I=1:1
SET TMP=$ORDER(RORMSG(TMP))
if TMP=""
QUIT
SET INFO(I)=RORMSG(TMP)
+14 SET RC=$$ERROR^RORERR(-56,,.INFO,,0,"$$CYPATH^LA7UTL02")
End DoDot:1
+15 ;---
+16 DO FREE^RORTMP(RORTMP)
+17 QUIT $SELECT(RC<0:RC,1:ERRCNT)
+18 ;
+19 ;***** CYTOPATHOLOGY OBR SEGMENT BUILDER
+20 ;
+21 ; RORTMP Closed root of the array holding lab data
+22 ; RORIEN IEN of Cyto Visit
+23 ;
+24 ; Return Values:
+25 ; <0 Error code
+26 ; 0 Ok
+27 ; >0 Non-fatal error(s)
+28 ;
OBR(RORTMP,RORIEN) ;
+1 NEW CS,CPA,ERRCNT,RC,RORSEG,TMP
+2 SET (ERRCNT,RC)=0
+3 DO ECH^RORHL7(.CS)
+4 ;
+5 ;--- Initialize the segment
+6 SET RORSEG(0)="OBR"
+7 ;
+8 ;--- OBR-3 - Cyto Path Acc #
+9 SET CPA=$PIECE($GET(@RORTMP@("DEMO",RORIEN)),U,2)
if CPA=""
QUIT 0
+10 SET RORSEG(3)=CPA
+11 ;
+12 ;--- OBR-4
+13 SET RORSEG(4)="88108"_CS_"CYTOPATHOLOGY, CONCENT"_CS_"C4"
+14 ;
+15 ;--- OBR-7 - Date/Time Specimen Taken
+16 SET TMP=$$FMTHL7^XLFDT($PIECE(@RORTMP@("DEMO",RORIEN),U))
+17 IF TMP'>0
Begin DoDot:1
+18 SET RC=$$ERROR^RORERR(-100,,,,"No specimen date","$$CYPATH^LA7UTL02")
End DoDot:1
QUIT RC
+19 SET RORSEG(7)=TMP
+20 ;
+21 ;--- OBR-24 - Service Section ID
+22 SET RORSEG(24)="CP"
+23 ;
+24 ;--- OBR-44 - Divsion
+25 SET RORSEG(44)=$$SITE^RORUTL03(CS)
+26 ;
+27 ;--- Store the segment
+28 DO ADDSEG^RORHL7(.RORSEG)
+29 QUIT ERRCNT
+30 ;
+31 ;***** CYTOPATHOLOGY OBX SEGMENT BUILDER
+32 ;
+33 ; RORTMP Closed root of the array holding lab data
+34 ;
+35 ; Return Values:
+36 ; <0 Error code
+37 ; 0 Ok
+38 ; >0 Non-fatal error(s)
+39 ;
OBX(RORTMP) ;
+1 NEW CS,ERRCNT,RC,RPS,TMP
+2 SET (ERRCNT,RC)=0
+3 DO ECH^RORHL7(.CS,,.RPS)
+4 ;
+5 if $DATA(@RORTMP@("SPEC"))
DO SPECIMEN
+6 DO SETOBXWP($$SEGID("BCH","Brief clinical History",CS),"CHIS")
+7 DO SETOBXWP($$SEGID("PDIAG","Preoperative Diagnosis",CS),"PREDX")
+8 DO SETOBXWP($$SEGID("OF","Operative Findings",CS),"OPERDX")
+9 DO SETOBXWP($$SEGID("POPDIAG","Postoperative Diagnosis",CS),"POSTDX")
+10 DO SETOBXWP($$SEGID("MICRO","Microscopic Examination",CS),"MICRO")
+11 DO SETOBXWP($$SEGID("CDIAG","Cytopathology Diagnosis",CS),"CYTODX")
+12 DO ICD(RPS)
+13 ;
+14 QUIT $SELECT(RC<0:RC,1:ERRCNT)
+15 ;
+16 ;***** SEARCHES BY COMPLETION (RESULT) DATE
RAD() ;
+1 NEW ERRCNT,IDT,RCDT
+2 SET (ERRCNT,IDT)=0
+3 FOR
SET IDT=$ORDER(^LR(LRDFN,"CY",IDT))
if 'IDT
QUIT
Begin DoDot:1
+4 SET RCDT=$PIECE($GET(^LR(LRDFN,"CY",IDT,0)),U,3)
+5 IF RCDT'<RORSTDT
IF RCDT<RORENDT
if $$OBROBX(IDT)
SET ERRCNT=ERRCNT+1
End DoDot:1
+6 QUIT ERRCNT
+7 ;
+8 ;***** CONSTRUCTS SEGMENT IDENTIFIER
SEGID(PONE,PTWO,CS) ; Create segment identifier
+1 QUIT PONE_CS_PTWO_CS_"VA080"
+2 ;
+3 ;***** CREATE AND STORE THE OBX SEGMENTS
SETOBX(OBX3,OBX5) ;
+1 NEW RORSEG
+2 ;--- Initialize the segment
+3 SET RORSEG(0)="OBX"
+4 ;--- OBX-2
+5 SET RORSEG(2)="FT"
+6 ;--- OBX-3
+7 SET RORSEG(3)=OBX3
+8 ;--- OBX-5
+9 SET RORSEG(5)=$$ESCAPE^RORHL7(OBX5)
+10 ;--- OBX-11
+11 SET RORSEG(11)="F"
+12 ;--- Store the segment
+13 DO ADDSEG^RORHL7(.RORSEG)
+14 QUIT
+15 ;
SETOBXWP(OBX3,SUBS) ;
+1 NEW BR,CNT,I,I1,RORSEG,TMP
+2 SET BR=$EXTRACT(HLECH,3)_".br"_$EXTRACT(HLECH,3)
+3 if $DATA(@RORTMP@(SUBS))<10
QUIT
+4 ;--- Initialize the segment
+5 SET RORSEG(0)="OBX"
+6 ;--- OBX-2 - Value Type
+7 SET RORSEG(2)="FT"
+8 ;--- OBX-3 - Observation Identifier
+9 SET RORSEG(3)=OBX3
+10 ;--- OBX-5 - Observation Value
+11 SET I=$ORDER(@RORTMP@(SUBS,""))
SET CNT=0
+12 FOR
if I=""
QUIT
SET I1=$ORDER(@RORTMP@(SUBS,I))
Begin DoDot:1
+13 SET TMP=$$ESCAPE^RORHL7(@RORTMP@(SUBS,I))
+14 SET CNT=CNT+1
SET RORSEG(5,CNT)=$SELECT(I1'="":TMP_BR,1:TMP)
End DoDot:1
SET I=I1
+15 ;--- OBX-11 - Observation Result Status
+16 SET RORSEG(11)="F"
+17 ;--- Store the segment
+18 if $DATA(RORSEG(5))
DO ADDSEG^RORHL7(.RORSEG)
+19 QUIT
+20 ;
+21 ;***** MAKES SPECIMEN OBX
SPECIMEN ;
+1 NEW INDEX,RORSPEC,SPECID
+2 SET SPECID=$$SEGID("SPEC","Specimen",CS)
+3 SET INDEX=""
+4 FOR
SET INDEX=$ORDER(@RORTMP@("SPEC",INDEX))
if INDEX=""
QUIT
Begin DoDot:1
+5 SET RORSPEC=$GET(@RORTMP@("SPEC",INDEX))
+6 if RORSPEC'=""
DO SETOBX(SPECID,RORSPEC)
End DoDot:1
+7 QUIT
