- 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 Jan 18, 2025@02:43:02 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