RORHL05 ;HOIFO/CRT - HL7 AUTOPSY: OBR ; 3/13/06 9:23am
;;1.5;CLINICAL CASE REGISTRIES;**1**;Feb 17, 2006;Build 24
;
; This routine uses the following IAs:
;
; #1995 $$CPT^ICPTCOD (supported)
; #3465 Access to autopsy data (private)
; #10040 Read the INSTITUTION field of file #44 (supported)
; #10090 Read access to the file #4 (supported)
;
Q
;
;***** SEARCHES FOR AUTOPSY 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.
;
; [FORCE] Force the extraction of the autopsy data
;
; Return Values:
; <0 Error code
; 0 Ok
; >0 Non-fatal error(s)
;
EN1(RORDFN,DXDTS,FORCE) ;
N ADATE,ERRCNT,RC,RORLRDFN,RORMSG
S (ERRCNT,RC)=0
;
;--- Check if the autopsy has been performed
S RORLRDFN=+$$LABREF^RORUTL18(RORDFN) Q:RORLRDFN'>0 0
S ADATE=$$GET1^DIQ(63,RORLRDFN_",",11,"I",,"RORMSG")
Q:$G(DIERR) $$DBS^RORERR("RORMSG",-9,,RORDFN,63,RORLRDFN_",")
;
D:ADATE>0
. ;--- Check if the autopsy data should be sent (autopsy date
. ; falls into one of the data extraction time frames or
. ;--- the extraction if forced by the function parameter).
. I '$G(FORCE) S RC=0 D Q:'RC
. . N D1,D2,IDX
. . S IDX=0
. . F S IDX=$O(DXDTS(7,IDX)) Q:IDX'>0 D Q:RC
. . . S D1=$P(DXDTS(7,IDX),U),D2=$P(DXDTS(7,IDX),U,2)
. . . S:(ADATE'<D1)&(ADATE<D2) RC=1
. .
. ;--- Send the data
. S RC=$$OBR(RORLRDFN)
. I RC Q:RC<0 S ERRCNT=ERRCNT+RC
. S RC=$$OBX(RORLRDFN)
. I RC Q:RC<0 S ERRCNT=ERRCNT+RC
;
Q $S(RC<0:RC,1:ERRCNT)
;
;***** AUTOPSY OBR SEGMENT BUILDER
;
; RORLRDFN IEN of Lab Patient Record in File #63
;
; Return Values:
; <0 Error code
; 0 Ok
; >0 Non-fatal error(s)
;
OBR(RORLRDFN) ;
N BUF,CS,ERRCNT,IEN,IENS63,RC,RORMSG,ROROUT,RORSEG,TMP
S (ERRCNT,RC)=0
D ECH^RORHL7(.CS)
;
S IENS63=+$G(RORLRDFN)_","
D GETS^DIQ(63,IENS63,"11;12.1;13.1;14;14.1;14.5;14.7","IE","ROROUT","RORMSG")
I $G(DIERR) D S ERRCNT=ERRCNT+1
. D DBS^RORERR("RORMSG",-9,,,63,IENS63)
;
;--- Initialize the segment
S RORSEG(0)="OBR"
;
;--- OBR-3 - Order #
I $G(ROROUT(63,IENS63,14,"E"))="" D Q RC
. S RC=$$ERROR^RORERR(-95,,,,63,IENS63,14)
S RORSEG(3)=ROROUT(63,IENS63,14,"E")
;
;--- OBR-4 - CPT Code
S BUF=88099,TMP=$$CPT^ICPTCOD(BUF)
I TMP<0 D S ERRCNT=ERRCNT+1,TMP=""
. D ERROR^RORERR(-57,,$P(TMP,U,2),,+TMP,"$$CPT^ICPTCOD")
S $P(BUF,CS,2)=$$ESCAPE^RORHL7($P(TMP,U,3))
S $P(BUF,CS,3)="C4"
S RORSEG(4)=BUF
;
;--- OBR-7 - Autopsy Date/Time
S TMP=$$FMTHL7^XLFDT($G(ROROUT(63,IENS63,11,"I")))
Q:TMP'>0 $$ERROR^RORERR(-95,,,,63,IENS63,11)
S RORSEG(7)=TMP
;
;--- OBR-8 - Date of the final autopsy diagnoses
S RORSEG(8)=$$FMTHL7^XLFDT($G(ROROUT(63,IENS63,13.1,"I")))
;
;--- OBR-16 - Ordering Provider
S RORSEG(16)=$G(ROROUT(63,IENS63,12.1,"I"))
;
;--- OBR-22 - Date/TIme the report is released
S RORSEG(22)=$$FMTHL7^XLFDT($G(ROROUT(63,IENS63,14.7,"I")))
;
;--- OBR-24 - Diagnostic Service ID
S RORSEG(24)="SP"
;
;--- OBR-44 - Division
S TMP=$G(ROROUT(63,IENS63,14.1,"I"))
S IEN=$S(TMP'="":+$O(^SC("B",TMP,0)),1:0)
S RORSEG(44)=$$DIV44^RORHLUT1(IEN,CS)
;
;--- OBR-46 - Service
S BUF=+$G(ROROUT(63,IENS63,14.5,"I"))
D:BUF>0
. S $P(BUF,CS,2)=$G(ROROUT(63,IENS63,14.5,"E"))
. S RORSEG(46)=BUF
;
;--- Store the segment
D ADDSEG^RORHL7(.RORSEG)
Q ERRCNT
;
;***** AUTOPSY OBX SEGMENT BUILDER
;
; RORLRDFN IEN of Lab Patient Record in File #63
;
; Return Values:
; <0 Error code
; 0 Ok
; >0 Non-fatal error(s)
;
OBX(RORLRDFN) ;
;;32.2;;AUCD^Clinical Diagnosis^VA080
;;32.3;;AUPD^Pathological Diagnosis^VA080
;
N BR,BUF,CS,ERRCNT,FLD,I,I1,ICNT,IENS63,IMF,RC,RORMSG,RORSEG,RORTXT,TMP
S (ERRCNT,RC)=0
D ECH^RORHL7(.CS)
S BR=$E(HLECH,3)_".br"_$E(HLECH,3)
;
;--- Initialize the segment
S RORSEG(0)="OBX"
;
;--- OBX-2 - Value Type
S RORSEG(2)="FT"
;
;--- OBX-11 - Observation Result Status
S RORSEG(11)="F"
;
;--- Generate the OBX segments
S IENS63=+$G(RORLRDFN)_","
F IMF=1,2 D
. S BUF=$T(OBX+IMF),FLD=$P(BUF,";;",2)
. K RORMSG,RORTXT,RORSEG(5)
. ;--- OBX-3 - Observation Identifier
. S RORSEG(3)=$P(BUF,";;",3)
. ;--- Load the text
. S TMP=$$GET1^DIQ(63,IENS63,FLD,,"RORTXT","RORMSG")
. I $G(DIERR) D S ERRCNT=ERRCNT+1
. . D DBS^RORERR("RORMSG",-9,,,63,IENS63)
. ;--- Process the text
. S I=$O(RORTXT("")),ICNT=0
. F Q:I="" S I1=$O(RORTXT(I)) D S I=I1
. . ;--- OBX-5 - Observation Value
. . S TMP=$$ESCAPE^RORHL7(RORTXT(I))
. . S ICNT=ICNT+1,RORSEG(5,ICNT)=$S(I1'="":TMP_BR,1:TMP)
. ;--- Store the segment
. D:ICNT>0 ADDSEG^RORHL7(.RORSEG)
;
;---
Q ERRCNT
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRORHL05 4885 printed Apr 09, 2024@20:47:31 Page 2
RORHL05 ;HOIFO/CRT - HL7 AUTOPSY: OBR ; 3/13/06 9:23am
+1 ;;1.5;CLINICAL CASE REGISTRIES;**1**;Feb 17, 2006;Build 24
+2 ;
+3 ; This routine uses the following IAs:
+4 ;
+5 ; #1995 $$CPT^ICPTCOD (supported)
+6 ; #3465 Access to autopsy data (private)
+7 ; #10040 Read the INSTITUTION field of file #44 (supported)
+8 ; #10090 Read access to the file #4 (supported)
+9 ;
+10 QUIT
+11 ;
+12 ;***** SEARCHES FOR AUTOPSY DATA
+13 ;
+14 ; RORDFN IEN of the patient in the PATIENT file (#2)
+15 ;
+16 ; .DXDTS Reference to a local variable where the
+17 ; data extraction time frames are stored.
+18 ;
+19 ; [FORCE] Force the extraction of the autopsy data
+20 ;
+21 ; Return Values:
+22 ; <0 Error code
+23 ; 0 Ok
+24 ; >0 Non-fatal error(s)
+25 ;
EN1(RORDFN,DXDTS,FORCE) ;
+1 NEW ADATE,ERRCNT,RC,RORLRDFN,RORMSG
+2 SET (ERRCNT,RC)=0
+3 ;
+4 ;--- Check if the autopsy has been performed
+5 SET RORLRDFN=+$$LABREF^RORUTL18(RORDFN)
if RORLRDFN'>0
QUIT 0
+6 SET ADATE=$$GET1^DIQ(63,RORLRDFN_",",11,"I",,"RORMSG")
+7 if $GET(DIERR)
QUIT $$DBS^RORERR("RORMSG",-9,,RORDFN,63,RORLRDFN_",")
+8 ;
+9 if ADATE>0
Begin DoDot:1
+10 ;--- Check if the autopsy data should be sent (autopsy date
+11 ; falls into one of the data extraction time frames or
+12 ;--- the extraction if forced by the function parameter).
+13 IF '$GET(FORCE)
SET RC=0
Begin DoDot:2
+14 NEW D1,D2,IDX
+15 SET IDX=0
+16 FOR
SET IDX=$ORDER(DXDTS(7,IDX))
if IDX'>0
QUIT
Begin DoDot:3
+17 SET D1=$PIECE(DXDTS(7,IDX),U)
SET D2=$PIECE(DXDTS(7,IDX),U,2)
+18 if (ADATE'<D1)&(ADATE<D2)
SET RC=1
End DoDot:3
if RC
QUIT
+19 End DoDot:2
if 'RC
QUIT
+20 ;--- Send the data
+21 SET RC=$$OBR(RORLRDFN)
+22 IF RC
if RC<0
QUIT
SET ERRCNT=ERRCNT+RC
+23 SET RC=$$OBX(RORLRDFN)
+24 IF RC
if RC<0
QUIT
SET ERRCNT=ERRCNT+RC
End DoDot:1
+25 ;
+26 QUIT $SELECT(RC<0:RC,1:ERRCNT)
+27 ;
+28 ;***** AUTOPSY OBR SEGMENT BUILDER
+29 ;
+30 ; RORLRDFN IEN of Lab Patient Record in File #63
+31 ;
+32 ; Return Values:
+33 ; <0 Error code
+34 ; 0 Ok
+35 ; >0 Non-fatal error(s)
+36 ;
OBR(RORLRDFN) ;
+1 NEW BUF,CS,ERRCNT,IEN,IENS63,RC,RORMSG,ROROUT,RORSEG,TMP
+2 SET (ERRCNT,RC)=0
+3 DO ECH^RORHL7(.CS)
+4 ;
+5 SET IENS63=+$GET(RORLRDFN)_","
+6 DO GETS^DIQ(63,IENS63,"11;12.1;13.1;14;14.1;14.5;14.7","IE","ROROUT","RORMSG")
+7 IF $GET(DIERR)
Begin DoDot:1
+8 DO DBS^RORERR("RORMSG",-9,,,63,IENS63)
End DoDot:1
SET ERRCNT=ERRCNT+1
+9 ;
+10 ;--- Initialize the segment
+11 SET RORSEG(0)="OBR"
+12 ;
+13 ;--- OBR-3 - Order #
+14 IF $GET(ROROUT(63,IENS63,14,"E"))=""
Begin DoDot:1
+15 SET RC=$$ERROR^RORERR(-95,,,,63,IENS63,14)
End DoDot:1
QUIT RC
+16 SET RORSEG(3)=ROROUT(63,IENS63,14,"E")
+17 ;
+18 ;--- OBR-4 - CPT Code
+19 SET BUF=88099
SET TMP=$$CPT^ICPTCOD(BUF)
+20 IF TMP<0
Begin DoDot:1
+21 DO ERROR^RORERR(-57,,$PIECE(TMP,U,2),,+TMP,"$$CPT^ICPTCOD")
End DoDot:1
SET ERRCNT=ERRCNT+1
SET TMP=""
+22 SET $PIECE(BUF,CS,2)=$$ESCAPE^RORHL7($PIECE(TMP,U,3))
+23 SET $PIECE(BUF,CS,3)="C4"
+24 SET RORSEG(4)=BUF
+25 ;
+26 ;--- OBR-7 - Autopsy Date/Time
+27 SET TMP=$$FMTHL7^XLFDT($GET(ROROUT(63,IENS63,11,"I")))
+28 if TMP'>0
QUIT $$ERROR^RORERR(-95,,,,63,IENS63,11)
+29 SET RORSEG(7)=TMP
+30 ;
+31 ;--- OBR-8 - Date of the final autopsy diagnoses
+32 SET RORSEG(8)=$$FMTHL7^XLFDT($GET(ROROUT(63,IENS63,13.1,"I")))
+33 ;
+34 ;--- OBR-16 - Ordering Provider
+35 SET RORSEG(16)=$GET(ROROUT(63,IENS63,12.1,"I"))
+36 ;
+37 ;--- OBR-22 - Date/TIme the report is released
+38 SET RORSEG(22)=$$FMTHL7^XLFDT($GET(ROROUT(63,IENS63,14.7,"I")))
+39 ;
+40 ;--- OBR-24 - Diagnostic Service ID
+41 SET RORSEG(24)="SP"
+42 ;
+43 ;--- OBR-44 - Division
+44 SET TMP=$GET(ROROUT(63,IENS63,14.1,"I"))
+45 SET IEN=$SELECT(TMP'="":+$ORDER(^SC("B",TMP,0)),1:0)
+46 SET RORSEG(44)=$$DIV44^RORHLUT1(IEN,CS)
+47 ;
+48 ;--- OBR-46 - Service
+49 SET BUF=+$GET(ROROUT(63,IENS63,14.5,"I"))
+50 if BUF>0
Begin DoDot:1
+51 SET $PIECE(BUF,CS,2)=$GET(ROROUT(63,IENS63,14.5,"E"))
+52 SET RORSEG(46)=BUF
End DoDot:1
+53 ;
+54 ;--- Store the segment
+55 DO ADDSEG^RORHL7(.RORSEG)
+56 QUIT ERRCNT
+57 ;
+58 ;***** AUTOPSY OBX SEGMENT BUILDER
+59 ;
+60 ; RORLRDFN IEN of Lab Patient Record in File #63
+61 ;
+62 ; Return Values:
+63 ; <0 Error code
+64 ; 0 Ok
+65 ; >0 Non-fatal error(s)
+66 ;
OBX(RORLRDFN) ;
+1 ;;32.2;;AUCD^Clinical Diagnosis^VA080
+2 ;;32.3;;AUPD^Pathological Diagnosis^VA080
+3 ;
+4 NEW BR,BUF,CS,ERRCNT,FLD,I,I1,ICNT,IENS63,IMF,RC,RORMSG,RORSEG,RORTXT,TMP
+5 SET (ERRCNT,RC)=0
+6 DO ECH^RORHL7(.CS)
+7 SET BR=$EXTRACT(HLECH,3)_".br"_$EXTRACT(HLECH,3)
+8 ;
+9 ;--- Initialize the segment
+10 SET RORSEG(0)="OBX"
+11 ;
+12 ;--- OBX-2 - Value Type
+13 SET RORSEG(2)="FT"
+14 ;
+15 ;--- OBX-11 - Observation Result Status
+16 SET RORSEG(11)="F"
+17 ;
+18 ;--- Generate the OBX segments
+19 SET IENS63=+$GET(RORLRDFN)_","
+20 FOR IMF=1,2
Begin DoDot:1
+21 SET BUF=$TEXT(OBX+IMF)
SET FLD=$PIECE(BUF,";;",2)
+22 KILL RORMSG,RORTXT,RORSEG(5)
+23 ;--- OBX-3 - Observation Identifier
+24 SET RORSEG(3)=$PIECE(BUF,";;",3)
+25 ;--- Load the text
+26 SET TMP=$$GET1^DIQ(63,IENS63,FLD,,"RORTXT","RORMSG")
+27 IF $GET(DIERR)
Begin DoDot:2
+28 DO DBS^RORERR("RORMSG",-9,,,63,IENS63)
End DoDot:2
SET ERRCNT=ERRCNT+1
+29 ;--- Process the text
+30 SET I=$ORDER(RORTXT(""))
SET ICNT=0
+31 FOR
if I=""
QUIT
SET I1=$ORDER(RORTXT(I))
Begin DoDot:2
+32 ;--- OBX-5 - Observation Value
+33 SET TMP=$$ESCAPE^RORHL7(RORTXT(I))
+34 SET ICNT=ICNT+1
SET RORSEG(5,ICNT)=$SELECT(I1'="":TMP_BR,1:TMP)
End DoDot:2
SET I=I1
+35 ;--- Store the segment
+36 if ICNT>0
DO ADDSEG^RORHL7(.RORSEG)
End DoDot:1
+37 ;
+38 ;---
+39 QUIT ERRCNT
