RORHL17 ;HOIFO/BH,SG - HL7 PROBLEM LIST: OBR,OBX ;1/23/06 2:22pm
;;1.5;CLINICAL CASE REGISTRIES;**10,19,28**;Feb 17, 2006;Build 66
;
; This routine uses the following IAs:
;
; #2308 ^AUPNPROB - PROBLEM file #9000011 (controlled)
; #2644 $$MOD^GMPLUTL3 (controlled)
; #2056 $$GET1^DIQ
; #10103 FMTHL7^XLFDT (supported)
; #5747 $$CODEC^ICDEX (controlled)
;
;******************************************************************************
;******************************************************************************
; --- ROUTINE MODIFICATION LOG ---
;
;PKG/PATCH DATE DEVELOPER MODIFICATION
;----------- ---------- ----------- ----------------------------------------
;ROR*1.5*19 MAY 2012 K GUPTA Support for ICD-10 Coding System.
;
;ROR*1.5*28 APR 2016 T KOPP Set flag for one time extract to
; retrieve problem list entries missed
; from 2009-2011 for HIV/HEPC registries
;
;******************************************************************************
;******************************************************************************
;
Q
;
;***** SEARCHES FOR Problem List 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.
;
; Return Values:
; <0 Error code
; 0 Ok
; >0 Non-fatal error(s)
;
;
EN1(RORDFN,DXDTS) ;
N CS,DFN,GMRVSTR,IDX,PROBIEN,OKDT,RC,RORARR,RORBUF,RORENDT,RORMSG,RORSTDT,RORTMP,TMP,Z
S (ERRCNT,RC)=0
D ECH^RORHL7(.CS)
S RORTMP=$$ALLOC^RORTMP()
;
S IDX=0
F S IDX=$O(DXDTS(16,IDX)) Q:IDX'>0 D Q:RC<0
. S RORSTDT=$P(DXDTS(16,IDX),U),RORENDT=$P(DXDTS(16,IDX),U,2)
. ;--- Check to see is any problems have been entered/modified
. ;--- during the data extraction time frame
. S MDATE=$$MOD^GMPLUTL3(RORDFN)
. ; Don't check LAST DATE MODIFIED for one time data back pull of problem list entries
. I '$G(^XTMP("ROR_ONETIME_PROBLEM_LIST_EXTRACT",1)) Q:$S(MDATE<RORSTDT:1,MDATE'<RORENDT:1,1:0)
. ;--- Find newly entered problems or modified problems
. S PROBIEN=""
. F S PROBIEN=$O(^AUPNPROB("AC",RORDFN,PROBIEN)) Q:'PROBIEN D
. . ; ---
. . ; Check date entered is after 2009 for one time back pull
. . I $G(^XTMP("ROR_ONETIME_PROBLEM_LIST_EXTRACT",1)) S Z=$P($G(^AUPNPROB(PROBIEN,0)),U,8) Q:Z<3090101
. . ; ---
. . S TMP=$$LOAD(.RORARR,PROBIEN) Q:TMP="S"
. . S:TMP>0 ERRCNT=ERRCNT+TMP
. . ;---
. . S TMP=$$OBR(.RORARR)
. . I TMP Q:TMP<0 S ERRCNT=ERRCNT+TMP
. . S TMP=$$OBX(.RORARR)
. . I TMP Q:TMP<0 S ERRCNT=ERRCNT+TMP
;
D FREE^RORTMP(RORTMP)
Q $S(RC<0:RC,1:ERRCNT)
;
;***** VALIDATES THE DATE
CHECK(DATE) ;
Q:DATE'>0 ""
Q:$E(DATE,1,3)>$E(DT,1,3) ""
S:$E(DATE,4,5)="00" $E(DATE,4,5)="01"
S:$E(DATE,6,7)="00" $E(DATE,6,7)="01"
Q $$FM2HL^RORHL7(DATE)
;
;I $E(DATE,1,2)="20",$E(DATE,3,4)>$E(DT,2,3) Q ""
;
;*****
LOAD(RORARR,PROBIEN) ;
N CNT,ERRCNT,IENS,MDATE,NOTE,REC,REC1,SUB3,SUB5,STAT,RORDIAG
K RORARR,@RORTMP S ERRCNT=0
;
S REC=$G(^AUPNPROB(PROBIEN,0))
S REC1=$G(^AUPNPROB(PROBIEN,1))
S MDATE=$P(REC,U,3)
Q:(MDATE<RORSTDT)!(MDATE'<RORENDT) "S"
;
S RORARR("OBR","FACIL")=$P(REC,U,6)
S RORARR("OBR","NMBR")=$P(REC,U,7)
S RORARR("OBR","COND")=$P(REC1,U,2)
S RORARR("OBR","DE")=$$FMTHL7^XLFDT($P(REC,U,8))
S RORARR("OBR","DOO")=$$CHECK($P(REC,U,13))
S RORARR("OBR","DRES")=$$CHECK($P(REC1,U,7)) ;date resolved
;
S RORDIAG=$$CODEC^ICDEX(80,+$P(REC,U))
S:+RORDIAG<0 RORDIAG=""
S:RORDIAG]"" RORDIAG=$$CSNAME^RORHLUT1(80,+$P(REC,U))_":"_RORDIAG
S RORARR("OBR","DIAG")=RORDIAG
;
S RORARR("OBR","DREC")=$$FMTHL7^XLFDT($P(REC1,U,9)) ;date recorded
S RORARR("OBR","RP")=$P(REC1,U,4)
S RORARR("OBR","DLM")=$$FMTHL7^XLFDT(MDATE)
S RORARR("OBR","ST")=$P(REC,U,12)
;
S RORARR("OBX","PR")=$$GET1^DIQ(9000011,PROBIEN,.05,"E")
S RORARR("OBX","PROB")=$$GET1^DIQ(9000011,PROBIEN,1.01,"E")
;
I $D(^AUPNPROB(PROBIEN,11))>1 D
. S SUB3=0,CNT=0
. F S SUB3=$O(^AUPNPROB(PROBIEN,11,SUB3)) Q:'SUB3 D
. . S SUB5=0
. . F S SUB5=$O(^AUPNPROB(PROBIEN,11,SUB3,11,SUB5)) Q:'SUB5 D
. . . S IENS=SUB5_","_SUB3_","_PROBIEN_","
. . . S NOTE=$$GET1^DIQ(9000011.1111,IENS,.03,,,"RORMSG")
. . . S CNT=CNT+1,@RORTMP@(CNT)=NOTE
;
Q ERRCNT
;
;***** PROBLEM LIST OBR SEGMENT BUILDER
;
; Return Values:
; <0 Error code
; 0 Ok
; >0 Non-fatal error(s)
;
OBR(RORARR) ;
N CLASS,CS,DIERR,ERRCNT,PRV,RC,RORMSG,RORSEG,TMP,TMP1
S (ERRCNT,RC)=0
D ECH^RORHL7(.CS)
;
;--- Initialize the segment
S RORSEG(0)="OBR"
;
;--- OBR-3 - Filler Order Number
S RORSEG(3)=RORARR("OBR","FACIL")_RORARR("OBR","NMBR")
;
;--- OBR-4 - Problem List CPT Code
S RORSEG(4)="90125"_CS_"HOSPITAL CARE,NEW, INTERMED."_CS_"C4"
;
;--- OBR-6 - Requested Date/time (Date Entered)
S RORSEG(6)=RORARR("OBR","DE")
;
;--- OBR-7 - Observation Date/Time (Date Appeared)
S RORSEG(7)=RORARR("OBR","DOO")
;
;--- OBR-8 - Observation End Date/Time (Date Resolved/Inactivated)
S RORSEG(8)=RORARR("OBR","DRES")
;
;--- OBR-13 - Relevant Clinical Info. (Diagnosis Code)
S RORSEG(13)=RORARR("OBR","DIAG")
;
;--- OBR-14 - Specimen Received Date/time (Date Recorded)
S RORSEG(14)=RORARR("OBR","DREC")
;
;--- OBR-16 - Ordering Provider
S PRV=RORARR("OBR","RP")
S TMP=$$GET1^DIQ(200,PRV_",",53.5,"E",,"RORMSG")
I $G(DIERR) D S ERRCNT=ERRCNT+1
. D DBS^RORERR("RORMSG",-99,,RORDFN,200,PRV_",")
E S $P(PRV,CS,13)=$$ESCAPE^RORHL7(TMP)
S RORSEG(16)=PRV
;
;--- OBR-20 - Filler Field 1 (Condition of the Record)
S RORSEG(20)=RORARR("OBR","COND")
;
;--- OBR-22 - Results Rpt/Status Change Date/time (Last Modified)
S RORSEG(22)=RORARR("OBR","DLM")
;
;--- OBR-24 - Diagnostic Service ID
S RORSEG(24)="TX"
;
;--- OBR-25 - Result Status (Status of the Problem)
S TMP1=RORARR("OBR","ST")
S TMP=$S(TMP1="A":"F",TMP1="I":"R",1:"")
S RORSEG(25)=TMP
;
;--- OBR-44 - Division
S RORSEG(44)=$$SITE^RORUTL03(CS)
;
;--- Store the segment
D ADDSEG^RORHL7(.RORSEG)
Q ERRCNT
;
;***** PROBLEM LIST OBX SEGMENT(S) BUILDER
;
; Return Values:
; <0 Error code
; 0 Ok
; >0 Non-fatal error(s)
;
OBX(RORARR) ;
N BR,CS,ERRCNT,NDX,OBX3,RC
S (ERRCNT,RC)=0
D ECH^RORHL7(.CS)
S BR=$E(HLECH,3)_".br"_$E(HLECH,3)
;
I $D(RORARR("OBX","PR")) D
. S OBX3="PRVN"_CS_"Provider Narrative"_CS_"VA080"
. D SETOBX(OBX3,"",$$ESCAPE^RORHL7(RORARR("OBX","PR")))
;
I $D(RORARR("OBX","PROB")) D
. S OBX3="EXPR"_CS_"Expression"_CS_"VA080"
. D SETOBX(OBX3,"",$$ESCAPE^RORHL7(RORARR("OBX","PROB")))
;
S OBX3="NOTE"_CS_"Note Narrative"_CS_"VA080"
D SETOBXWP^RORHLUT1(RORTMP,OBX3)
;
Q ERRCNT
;
;*** CREATES AND STORES THE OBX SEGMENT
SETOBX(OBX3,OBX4,OBX5) ;
N RORSEG
;--- Initialize the segment
S RORSEG(0)="OBX"
;--- OBX-2
S RORSEG(2)="FT"
;--- OBX-3
S RORSEG(3)=OBX3
;--- OBX-4
S:$G(OBX4)'="" RORSEG(4)=OBX4
;--- OBX-5
S RORSEG(5)=OBX5
;--- OBX-11
S RORSEG(11)="F"
;--- Store the segment
D ADDSEG^RORHL7(.RORSEG)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRORHL17 7278 printed Apr 09, 2024@20:46:30 Page 2
RORHL17 ;HOIFO/BH,SG - HL7 PROBLEM LIST: OBR,OBX ;1/23/06 2:22pm
+1 ;;1.5;CLINICAL CASE REGISTRIES;**10,19,28**;Feb 17, 2006;Build 66
+2 ;
+3 ; This routine uses the following IAs:
+4 ;
+5 ; #2308 ^AUPNPROB - PROBLEM file #9000011 (controlled)
+6 ; #2644 $$MOD^GMPLUTL3 (controlled)
+7 ; #2056 $$GET1^DIQ
+8 ; #10103 FMTHL7^XLFDT (supported)
+9 ; #5747 $$CODEC^ICDEX (controlled)
+10 ;
+11 ;******************************************************************************
+12 ;******************************************************************************
+13 ; --- ROUTINE MODIFICATION LOG ---
+14 ;
+15 ;PKG/PATCH DATE DEVELOPER MODIFICATION
+16 ;----------- ---------- ----------- ----------------------------------------
+17 ;ROR*1.5*19 MAY 2012 K GUPTA Support for ICD-10 Coding System.
+18 ;
+19 ;ROR*1.5*28 APR 2016 T KOPP Set flag for one time extract to
+20 ; retrieve problem list entries missed
+21 ; from 2009-2011 for HIV/HEPC registries
+22 ;
+23 ;******************************************************************************
+24 ;******************************************************************************
+25 ;
+26 QUIT
+27 ;
+28 ;***** SEARCHES FOR Problem List DATA
+29 ;
+30 ; RORDFN IEN of the patient in the PATIENT file (#2)
+31 ;
+32 ; .DXDTS Reference to a local variable where the
+33 ; data extraction time frames are stored.
+34 ;
+35 ; Return Values:
+36 ; <0 Error code
+37 ; 0 Ok
+38 ; >0 Non-fatal error(s)
+39 ;
+40 ;
EN1(RORDFN,DXDTS) ;
+1 NEW CS,DFN,GMRVSTR,IDX,PROBIEN,OKDT,RC,RORARR,RORBUF,RORENDT,RORMSG,RORSTDT,RORTMP,TMP,Z
+2 SET (ERRCNT,RC)=0
+3 DO ECH^RORHL7(.CS)
+4 SET RORTMP=$$ALLOC^RORTMP()
+5 ;
+6 SET IDX=0
+7 FOR
SET IDX=$ORDER(DXDTS(16,IDX))
if IDX'>0
QUIT
Begin DoDot:1
+8 SET RORSTDT=$PIECE(DXDTS(16,IDX),U)
SET RORENDT=$PIECE(DXDTS(16,IDX),U,2)
+9 ;--- Check to see is any problems have been entered/modified
+10 ;--- during the data extraction time frame
+11 SET MDATE=$$MOD^GMPLUTL3(RORDFN)
+12 ; Don't check LAST DATE MODIFIED for one time data back pull of problem list entries
+13 IF '$GET(^XTMP("ROR_ONETIME_PROBLEM_LIST_EXTRACT",1))
if $SELECT(MDATE<RORSTDT
QUIT
+14 ;--- Find newly entered problems or modified problems
+15 SET PROBIEN=""
+16 FOR
SET PROBIEN=$ORDER(^AUPNPROB("AC",RORDFN,PROBIEN))
if 'PROBIEN
QUIT
Begin DoDot:2
+17 ; ---
+18 ; Check date entered is after 2009 for one time back pull
+19 IF $GET(^XTMP("ROR_ONETIME_PROBLEM_LIST_EXTRACT",1))
SET Z=$PIECE($GET(^AUPNPROB(PROBIEN,0)),U,8)
if Z<3090101
QUIT
+20 ; ---
+21 SET TMP=$$LOAD(.RORARR,PROBIEN)
if TMP="S"
QUIT
+22 if TMP>0
SET ERRCNT=ERRCNT+TMP
+23 ;---
+24 SET TMP=$$OBR(.RORARR)
+25 IF TMP
if TMP<0
QUIT
SET ERRCNT=ERRCNT+TMP
+26 SET TMP=$$OBX(.RORARR)
+27 IF TMP
if TMP<0
QUIT
SET ERRCNT=ERRCNT+TMP
End DoDot:2
End DoDot:1
if RC<0
QUIT
+28 ;
+29 DO FREE^RORTMP(RORTMP)
+30 QUIT $SELECT(RC<0:RC,1:ERRCNT)
+31 ;
+32 ;***** VALIDATES THE DATE
CHECK(DATE) ;
+1 if DATE'>0
QUIT ""
+2 if $EXTRACT(DATE,1,3)>$EXTRACT(DT,1,3)
QUIT ""
+3 if $EXTRACT(DATE,4,5)="00"
SET $EXTRACT(DATE,4,5)="01"
+4 if $EXTRACT(DATE,6,7)="00"
SET $EXTRACT(DATE,6,7)="01"
+5 QUIT $$FM2HL^RORHL7(DATE)
+6 ;
+7 ;I $E(DATE,1,2)="20",$E(DATE,3,4)>$E(DT,2,3) Q ""
+8 ;
+9 ;*****
LOAD(RORARR,PROBIEN) ;
+1 NEW CNT,ERRCNT,IENS,MDATE,NOTE,REC,REC1,SUB3,SUB5,STAT,RORDIAG
+2 KILL RORARR,@RORTMP
SET ERRCNT=0
+3 ;
+4 SET REC=$GET(^AUPNPROB(PROBIEN,0))
+5 SET REC1=$GET(^AUPNPROB(PROBIEN,1))
+6 SET MDATE=$PIECE(REC,U,3)
+7 if (MDATE<RORSTDT)!(MDATE'<RORENDT)
QUIT "S"
+8 ;
+9 SET RORARR("OBR","FACIL")=$PIECE(REC,U,6)
+10 SET RORARR("OBR","NMBR")=$PIECE(REC,U,7)
+11 SET RORARR("OBR","COND")=$PIECE(REC1,U,2)
+12 SET RORARR("OBR","DE")=$$FMTHL7^XLFDT($PIECE(REC,U,8))
+13 SET RORARR("OBR","DOO")=$$CHECK($PIECE(REC,U,13))
+14 ;date resolved
SET RORARR("OBR","DRES")=$$CHECK($PIECE(REC1,U,7))
+15 ;
+16 SET RORDIAG=$$CODEC^ICDEX(80,+$PIECE(REC,U))
+17 if +RORDIAG<0
SET RORDIAG=""
+18 if RORDIAG]""
SET RORDIAG=$$CSNAME^RORHLUT1(80,+$PIECE(REC,U))_":"_RORDIAG
+19 SET RORARR("OBR","DIAG")=RORDIAG
+20 ;
+21 ;date recorded
SET RORARR("OBR","DREC")=$$FMTHL7^XLFDT($PIECE(REC1,U,9))
+22 SET RORARR("OBR","RP")=$PIECE(REC1,U,4)
+23 SET RORARR("OBR","DLM")=$$FMTHL7^XLFDT(MDATE)
+24 SET RORARR("OBR","ST")=$PIECE(REC,U,12)
+25 ;
+26 SET RORARR("OBX","PR")=$$GET1^DIQ(9000011,PROBIEN,.05,"E")
+27 SET RORARR("OBX","PROB")=$$GET1^DIQ(9000011,PROBIEN,1.01,"E")
+28 ;
+29 IF $DATA(^AUPNPROB(PROBIEN,11))>1
Begin DoDot:1
+30 SET SUB3=0
SET CNT=0
+31 FOR
SET SUB3=$ORDER(^AUPNPROB(PROBIEN,11,SUB3))
if 'SUB3
QUIT
Begin DoDot:2
+32 SET SUB5=0
+33 FOR
SET SUB5=$ORDER(^AUPNPROB(PROBIEN,11,SUB3,11,SUB5))
if 'SUB5
QUIT
Begin DoDot:3
+34 SET IENS=SUB5_","_SUB3_","_PROBIEN_","
+35 SET NOTE=$$GET1^DIQ(9000011.1111,IENS,.03,,,"RORMSG")
+36 SET CNT=CNT+1
SET @RORTMP@(CNT)=NOTE
End DoDot:3
End DoDot:2
End DoDot:1
+37 ;
+38 QUIT ERRCNT
+39 ;
+40 ;***** PROBLEM LIST OBR SEGMENT BUILDER
+41 ;
+42 ; Return Values:
+43 ; <0 Error code
+44 ; 0 Ok
+45 ; >0 Non-fatal error(s)
+46 ;
OBR(RORARR) ;
+1 NEW CLASS,CS,DIERR,ERRCNT,PRV,RC,RORMSG,RORSEG,TMP,TMP1
+2 SET (ERRCNT,RC)=0
+3 DO ECH^RORHL7(.CS)
+4 ;
+5 ;--- Initialize the segment
+6 SET RORSEG(0)="OBR"
+7 ;
+8 ;--- OBR-3 - Filler Order Number
+9 SET RORSEG(3)=RORARR("OBR","FACIL")_RORARR("OBR","NMBR")
+10 ;
+11 ;--- OBR-4 - Problem List CPT Code
+12 SET RORSEG(4)="90125"_CS_"HOSPITAL CARE,NEW, INTERMED."_CS_"C4"
+13 ;
+14 ;--- OBR-6 - Requested Date/time (Date Entered)
+15 SET RORSEG(6)=RORARR("OBR","DE")
+16 ;
+17 ;--- OBR-7 - Observation Date/Time (Date Appeared)
+18 SET RORSEG(7)=RORARR("OBR","DOO")
+19 ;
+20 ;--- OBR-8 - Observation End Date/Time (Date Resolved/Inactivated)
+21 SET RORSEG(8)=RORARR("OBR","DRES")
+22 ;
+23 ;--- OBR-13 - Relevant Clinical Info. (Diagnosis Code)
+24 SET RORSEG(13)=RORARR("OBR","DIAG")
+25 ;
+26 ;--- OBR-14 - Specimen Received Date/time (Date Recorded)
+27 SET RORSEG(14)=RORARR("OBR","DREC")
+28 ;
+29 ;--- OBR-16 - Ordering Provider
+30 SET PRV=RORARR("OBR","RP")
+31 SET TMP=$$GET1^DIQ(200,PRV_",",53.5,"E",,"RORMSG")
+32 IF $GET(DIERR)
Begin DoDot:1
+33 DO DBS^RORERR("RORMSG",-99,,RORDFN,200,PRV_",")
End DoDot:1
SET ERRCNT=ERRCNT+1
+34 IF '$TEST
SET $PIECE(PRV,CS,13)=$$ESCAPE^RORHL7(TMP)
+35 SET RORSEG(16)=PRV
+36 ;
+37 ;--- OBR-20 - Filler Field 1 (Condition of the Record)
+38 SET RORSEG(20)=RORARR("OBR","COND")
+39 ;
+40 ;--- OBR-22 - Results Rpt/Status Change Date/time (Last Modified)
+41 SET RORSEG(22)=RORARR("OBR","DLM")
+42 ;
+43 ;--- OBR-24 - Diagnostic Service ID
+44 SET RORSEG(24)="TX"
+45 ;
+46 ;--- OBR-25 - Result Status (Status of the Problem)
+47 SET TMP1=RORARR("OBR","ST")
+48 SET TMP=$SELECT(TMP1="A":"F",TMP1="I":"R",1:"")
+49 SET RORSEG(25)=TMP
+50 ;
+51 ;--- OBR-44 - Division
+52 SET RORSEG(44)=$$SITE^RORUTL03(CS)
+53 ;
+54 ;--- Store the segment
+55 DO ADDSEG^RORHL7(.RORSEG)
+56 QUIT ERRCNT
+57 ;
+58 ;***** PROBLEM LIST OBX SEGMENT(S) BUILDER
+59 ;
+60 ; Return Values:
+61 ; <0 Error code
+62 ; 0 Ok
+63 ; >0 Non-fatal error(s)
+64 ;
OBX(RORARR) ;
+1 NEW BR,CS,ERRCNT,NDX,OBX3,RC
+2 SET (ERRCNT,RC)=0
+3 DO ECH^RORHL7(.CS)
+4 SET BR=$EXTRACT(HLECH,3)_".br"_$EXTRACT(HLECH,3)
+5 ;
+6 IF $DATA(RORARR("OBX","PR"))
Begin DoDot:1
+7 SET OBX3="PRVN"_CS_"Provider Narrative"_CS_"VA080"
+8 DO SETOBX(OBX3,"",$$ESCAPE^RORHL7(RORARR("OBX","PR")))
End DoDot:1
+9 ;
+10 IF $DATA(RORARR("OBX","PROB"))
Begin DoDot:1
+11 SET OBX3="EXPR"_CS_"Expression"_CS_"VA080"
+12 DO SETOBX(OBX3,"",$$ESCAPE^RORHL7(RORARR("OBX","PROB")))
End DoDot:1
+13 ;
+14 SET OBX3="NOTE"_CS_"Note Narrative"_CS_"VA080"
+15 DO SETOBXWP^RORHLUT1(RORTMP,OBX3)
+16 ;
+17 QUIT ERRCNT
+18 ;
+19 ;*** CREATES AND STORES THE OBX SEGMENT
SETOBX(OBX3,OBX4,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-4
+9 if $GET(OBX4)'=""
SET RORSEG(4)=OBX4
+10 ;--- OBX-5
+11 SET RORSEG(5)=OBX5
+12 ;--- OBX-11
+13 SET RORSEG(11)="F"
+14 ;--- Store the segment
+15 DO ADDSEG^RORHL7(.RORSEG)
+16 QUIT
