RORX006A ;HOIFO/BH,SG,VAC - LAB UTILIZATION (QUERY & SORT) ;4/7/09 2:07pm
;;1.5;CLINICAL CASE REGISTRIES;**8,13,19,21,31,39**;Feb 17, 2006;Build 4
;
; This routine uses the following IAs:
;
; #2056 GET1^DIQ (supported)
;
;******************************************************************************
;******************************************************************************
; --- ROUTINE MODIFICATION LOG ---
;
;PKG/PATCH DATE DEVELOPER MODIFICATION
;----------- ---------- ----------- ----------------------------------------
;ROR*1.5*8 MAR 2010 V CARR Modified to handle ICD9 filter for
; 'include' or 'exclude'.
;ROR*1.5*13 DEC 2010 A SAUNDERS User can select specific patients,
; clinics, or divisions for the report.
;ROR*1.5*19 FEB 2012 K GUPTA Support for ICD-10 Coding System
;ROR*1.5*21 SEP 2013 T KOPP Add ICN column if Additional Identifier
; requested.
;ROR*1.5*31 MAY 2017 M FERRARESE Adding PACT, PCP , AGE/DOB as additional
; identifiers.
;ROR*1.5*39 JUL 2021 M FERRARESE Setting SSN and LAST4 to zeros
;******************************************************************************
;******************************************************************************
Q
;
;***** LOADS AND PROCESSES THE LAB DATA
;
; DFN Patient IEN (in file #2)
;
; Return Values:
; <0 Error code
; 0 Ok
; >0 Number of non-fatal errors
;
LABDATA(DFN) ;
N DST,ENDT,NR,PTNO,PTNR,PRNT,RC,TSTIEN
S DST=$NA(^TMP("RORX006",$J))
;
;--- Get the data
S DST("RORCB")="$$LTSCB^RORX006A",DST("RORIDT")=""
S RC=$$LTSEARCH^RORUTL10(DFN,RORLTST,.DST,,RORSDT,ROREDT1)
Q:RC<0 RC Q:$D(@DST@("PAT",DFN))<10 0
;
;--- Calculate intermediate totals of the tests
N PTNT ;added 'new' statement
S TSTIEN=0,(PTNR,PTNT)=0
F S TSTIEN=$O(@DST@("PAT",DFN,"R",TSTIEN)) Q:TSTIEN'>0 D
. S NR=+$G(@DST@("PAT",DFN,"R",TSTIEN))
. S PTNR=PTNR+NR ; Number of patient's results
. S PTNT=PTNT+1 ; Number of different tests
. ;---
. S @DST@("RES",TSTIEN,"P")=$G(@DST@("RES",TSTIEN,"P"))+1
. S @DST@("RES",TSTIEN,"R")=$G(@DST@("RES",TSTIEN,"R"))+NR
. ;---
. S TMP=$G(@DST@("RES",TSTIEN,"M"))
. D:NR'<TMP
. . I NR>TMP S @DST@("RES",TSTIEN,"M")=NR_U_1 Q
. . S $P(@DST@("RES",TSTIEN,"M"),U,2)=$P(TMP,U,2)+1
;
;--- Orders
S @DST@("ORD")=$G(@DST@("ORD"))+$G(@DST@("PAT",DFN,"O"))
;
;--- Results
S @DST@("RES1",PTNR)=$G(@DST@("RES1",PTNR))+1
S @DST@("RES1",PTNR,RORPNAME,DFN)=""
;
;--- Other totals
S @DST@("PAT",DFN)=RORLAST4_U_RORDOD_U_$G(RORICN)_U_$G(RORPACT)_U_$G(RORPCP)_U_AGE
S @DST@("PAT",DFN,"R")=PTNR_U_PTNT
S @DST@("PAT")=$G(@DST@("PAT"))+1
S @DST@("RES")=$G(@DST@("RES"))+PTNR
Q 0
;
;***** LAB SEARCH CALLBACK
;
; .ROR8DST Reference to the ROR8DST parameter.
;
; INVDT IEN of the Lab test (inverted date)
;
; .RESULT Reference to a local variable, which contains
; the result (see the $$LTSEARCH^RORUTL10).
;
; Return Values:
; <0 Error code (the search will be aborted)
; 0 Ok
; 1 Skip this result
; 2 Skip this and all remaining results
;
LTSCB(ROR8DST,INVDT,RESULT) ;
N DFN,TMP,TSTIEN
S DFN=+ROR8DST("RORDFN"),TSTIEN=+RESULT(2)
;--- Number of orders
I INVDT'=ROR8DST("RORIDT") D S ROR8DST("RORIDT")=INVDT
. S @ROR8DST@("PAT",DFN,"O")=$G(@ROR8DST@("PAT",DFN,"O"))+1
;--- Number of results
S TMP=$G(@ROR8DST@("PAT",DFN,"R",TSTIEN))
S @ROR8DST@("PAT",DFN,"R",TSTIEN)=TMP+1
Q 0
;
;***** QUERIES THE REGISTRY
;
; FLAGS Flags for the $$SKIP^RORXU005
;
; Return Values:
; <0 Error code
; 0 Ok
; >0 Number of non-fatal errors
;
QUERY(FLAGS) ;
N RORDOD ; Date of death of the current patient
N RORLAST4 ; Last 4 digits of the current patient's SSN
N RORPNAME ; Name of the current patient
N RORPTN ; Number of patients in the registry
N RORICN ; National ICN of patient
N RORPACT ; Primary Care Team
N RORPCP ; Primary Care Physician
;
N CNT,ECNT,IEN,IENS,PATIEN,RC,TMP,VA,VADM,XREFNODE
N RCC,FLAG
N RORCDLIST ; Flag to indicate whether a clinic or division list exists
N RORCDSTDT ; Start date for clinic/division utilization search
N RORCDENDT ; End date for clinic/division utilization search
N AGE,AGETYPE
;
S XREFNODE=$NA(^RORDATA(798,"AC",+RORREG))
S RORPTN=$$REGSIZE^RORUTL02(+RORREG) S:RORPTN<0 RORPTN=0
S (CNT,ECNT,RC)=0
;
;=== Set up Clinic/Division list parameters
S RORCDLIST=$$CDPARMS^RORXU001(.RORTSK,.RORCDSTDT,.RORCDENDT)
;
;--- Browse through the registry records
S IEN=0
S FLAG=$G(RORTSK("PARAMS","ICDFILT","A","FILTER"))
F S IEN=$O(@XREFNODE@(IEN)) Q:IEN'>0 D Q:RC<0
. S TMP=$S(RORPTN>0:CNT/RORPTN,1:"")
. S RC=$$LOOP^RORTSK01(TMP) Q:RC<0
. S IENS=IEN_",",CNT=CNT+1
. ;--- Get the patient DFN
. S PATIEN=$$PTIEN^RORUTL01(IEN) Q:PATIEN'>0
. ;--- Check for patient list and quit if not on list
. I $D(RORTSK("PARAMS","PATIENTS","C")),'$D(RORTSK("PARAMS","PATIENTS","C",PATIEN)) Q
. ;--- Check if the patient should be skipped
. Q:$$SKIP^RORXU005(IEN,FLAGS,RORSDT,ROREDT)
. ;--- Check if ICD Filter Includes or Excludes Patient
. S RCC=0
. I FLAG'="ALL" D
. . S RCC=$$ICD^RORXU010(PATIEN)
. I (FLAG="INCLUDE")&(RCC=0) Q
. I (FLAG="EXCLUDE")&(RCC=1) Q
. ;--- End of ICD Filter check
. ;--- Check for Clinic or Division list and quit if not in list
. I RORCDLIST,'$$CDUTIL^RORXU001(.RORTSK,PATIEN,RORCDSTDT,RORCDENDT) Q
. ;--- Get the patient's data
. D VADEM^RORUTL05(PATIEN,1)
. S RORPNAME=VADM(1),RORLAST4="0000" ;VA("BID")
. S RORDOD=$$DATE^RORXU002($P(VADM(6),U)\1)
. I $$PARAM^RORTSK01("PATIENTS","ICN") S RORICN=$$ICN^RORUTL02(PATIEN)
. I $$PARAM^RORTSK01("PATIENTS","PACT") S RORPACT=$$PACT^RORUTL02(PATIEN)
. I $$PARAM^RORTSK01("PATIENTS","PCP") S RORPCP=$$PCP^RORUTL02(PATIEN)
. S AGETYPE=$$PARAM^RORTSK01("AGE_RANGE","TYPE")
. S AGE=$S(AGETYPE="AGE":$P(VADM(4),U),AGETYPE="DOB":$$DATE^RORXU002($P(VADM(3),U)\1),1:"")
. ;
. ;--- Get the Lab data
. S RC=$$LABDATA(PATIEN)
. I RC Q:RC<0 S ECNT=ECNT+RC
;---
Q $S(RC<0:RC,1:ECNT)
;
;***** SORTS THE RESULTS AND COMPILES THE TOTALS
;
; Return Values:
; <0 Error code
; 0 Ok
; >0 Number of non-fatal errors
;
SORT() ;
N ECNT,IEN,NAME,NDLT,NODE,RC,RORMSG,TMP
S NODE=$NA(^TMP("RORX006",$J)),(ECNT,RC)=0
;---
S RC=$$LOOP^RORTSK01(0) Q:RC<0 RC
Q:$D(@NODE)<10 0
;---
S IEN=0,NDLT=0
F S IEN=$O(@NODE@("RES",IEN)) Q:IEN'>0 D
. S NDLT=NDLT+1
. K RORMSG S NAME=$$GET1^DIQ(60,IEN,.01,,,"RORMSG")
. ;D:$G(DIERR) DBS^RORERR("RORMSG",-9,,,60,IEN)
. D:$G(RORMSG("DIERR")) DBS^RORERR("RORMSG",-9,,,60,IEN)
. S:NAME?." " NAME="Unknown ("_IEN_")"
. S TMP=+$G(@NODE@("RES",IEN,"R"))
. S @NODE@("RES","B",TMP,NAME,IEN)=""
;--- Total numbers of Lab tests
S $P(@NODE@("RES"),U,2)=NDLT
;---
Q $S(RC<0:RC,1:ECNT)
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRORX006A 7285 printed Sep 23, 2025@19:20:25 Page 2
RORX006A ;HOIFO/BH,SG,VAC - LAB UTILIZATION (QUERY & SORT) ;4/7/09 2:07pm
+1 ;;1.5;CLINICAL CASE REGISTRIES;**8,13,19,21,31,39**;Feb 17, 2006;Build 4
+2 ;
+3 ; This routine uses the following IAs:
+4 ;
+5 ; #2056 GET1^DIQ (supported)
+6 ;
+7 ;******************************************************************************
+8 ;******************************************************************************
+9 ; --- ROUTINE MODIFICATION LOG ---
+10 ;
+11 ;PKG/PATCH DATE DEVELOPER MODIFICATION
+12 ;----------- ---------- ----------- ----------------------------------------
+13 ;ROR*1.5*8 MAR 2010 V CARR Modified to handle ICD9 filter for
+14 ; 'include' or 'exclude'.
+15 ;ROR*1.5*13 DEC 2010 A SAUNDERS User can select specific patients,
+16 ; clinics, or divisions for the report.
+17 ;ROR*1.5*19 FEB 2012 K GUPTA Support for ICD-10 Coding System
+18 ;ROR*1.5*21 SEP 2013 T KOPP Add ICN column if Additional Identifier
+19 ; requested.
+20 ;ROR*1.5*31 MAY 2017 M FERRARESE Adding PACT, PCP , AGE/DOB as additional
+21 ; identifiers.
+22 ;ROR*1.5*39 JUL 2021 M FERRARESE Setting SSN and LAST4 to zeros
+23 ;******************************************************************************
+24 ;******************************************************************************
+25 QUIT
+26 ;
+27 ;***** LOADS AND PROCESSES THE LAB DATA
+28 ;
+29 ; DFN Patient IEN (in file #2)
+30 ;
+31 ; Return Values:
+32 ; <0 Error code
+33 ; 0 Ok
+34 ; >0 Number of non-fatal errors
+35 ;
LABDATA(DFN) ;
+1 NEW DST,ENDT,NR,PTNO,PTNR,PRNT,RC,TSTIEN
+2 SET DST=$NAME(^TMP("RORX006",$JOB))
+3 ;
+4 ;--- Get the data
+5 SET DST("RORCB")="$$LTSCB^RORX006A"
SET DST("RORIDT")=""
+6 SET RC=$$LTSEARCH^RORUTL10(DFN,RORLTST,.DST,,RORSDT,ROREDT1)
+7 if RC<0
QUIT RC
if $DATA(@DST@("PAT",DFN))<10
QUIT 0
+8 ;
+9 ;--- Calculate intermediate totals of the tests
+10 ;added 'new' statement
NEW PTNT
+11 SET TSTIEN=0
SET (PTNR,PTNT)=0
+12 FOR
SET TSTIEN=$ORDER(@DST@("PAT",DFN,"R",TSTIEN))
if TSTIEN'>0
QUIT
Begin DoDot:1
+13 SET NR=+$GET(@DST@("PAT",DFN,"R",TSTIEN))
+14 ; Number of patient's results
SET PTNR=PTNR+NR
+15 ; Number of different tests
SET PTNT=PTNT+1
+16 ;---
+17 SET @DST@("RES",TSTIEN,"P")=$GET(@DST@("RES",TSTIEN,"P"))+1
+18 SET @DST@("RES",TSTIEN,"R")=$GET(@DST@("RES",TSTIEN,"R"))+NR
+19 ;---
+20 SET TMP=$GET(@DST@("RES",TSTIEN,"M"))
+21 if NR'<TMP
Begin DoDot:2
+22 IF NR>TMP
SET @DST@("RES",TSTIEN,"M")=NR_U_1
QUIT
+23 SET $PIECE(@DST@("RES",TSTIEN,"M"),U,2)=$PIECE(TMP,U,2)+1
End DoDot:2
End DoDot:1
+24 ;
+25 ;--- Orders
+26 SET @DST@("ORD")=$GET(@DST@("ORD"))+$GET(@DST@("PAT",DFN,"O"))
+27 ;
+28 ;--- Results
+29 SET @DST@("RES1",PTNR)=$GET(@DST@("RES1",PTNR))+1
+30 SET @DST@("RES1",PTNR,RORPNAME,DFN)=""
+31 ;
+32 ;--- Other totals
+33 SET @DST@("PAT",DFN)=RORLAST4_U_RORDOD_U_$GET(RORICN)_U_$GET(RORPACT)_U_$GET(RORPCP)_U_AGE
+34 SET @DST@("PAT",DFN,"R")=PTNR_U_PTNT
+35 SET @DST@("PAT")=$GET(@DST@("PAT"))+1
+36 SET @DST@("RES")=$GET(@DST@("RES"))+PTNR
+37 QUIT 0
+38 ;
+39 ;***** LAB SEARCH CALLBACK
+40 ;
+41 ; .ROR8DST Reference to the ROR8DST parameter.
+42 ;
+43 ; INVDT IEN of the Lab test (inverted date)
+44 ;
+45 ; .RESULT Reference to a local variable, which contains
+46 ; the result (see the $$LTSEARCH^RORUTL10).
+47 ;
+48 ; Return Values:
+49 ; <0 Error code (the search will be aborted)
+50 ; 0 Ok
+51 ; 1 Skip this result
+52 ; 2 Skip this and all remaining results
+53 ;
LTSCB(ROR8DST,INVDT,RESULT) ;
+1 NEW DFN,TMP,TSTIEN
+2 SET DFN=+ROR8DST("RORDFN")
SET TSTIEN=+RESULT(2)
+3 ;--- Number of orders
+4 IF INVDT'=ROR8DST("RORIDT")
Begin DoDot:1
+5 SET @ROR8DST@("PAT",DFN,"O")=$GET(@ROR8DST@("PAT",DFN,"O"))+1
End DoDot:1
SET ROR8DST("RORIDT")=INVDT
+6 ;--- Number of results
+7 SET TMP=$GET(@ROR8DST@("PAT",DFN,"R",TSTIEN))
+8 SET @ROR8DST@("PAT",DFN,"R",TSTIEN)=TMP+1
+9 QUIT 0
+10 ;
+11 ;***** QUERIES THE REGISTRY
+12 ;
+13 ; FLAGS Flags for the $$SKIP^RORXU005
+14 ;
+15 ; Return Values:
+16 ; <0 Error code
+17 ; 0 Ok
+18 ; >0 Number of non-fatal errors
+19 ;
QUERY(FLAGS) ;
+1 ; Date of death of the current patient
NEW RORDOD
+2 ; Last 4 digits of the current patient's SSN
NEW RORLAST4
+3 ; Name of the current patient
NEW RORPNAME
+4 ; Number of patients in the registry
NEW RORPTN
+5 ; National ICN of patient
NEW RORICN
+6 ; Primary Care Team
NEW RORPACT
+7 ; Primary Care Physician
NEW RORPCP
+8 ;
+9 NEW CNT,ECNT,IEN,IENS,PATIEN,RC,TMP,VA,VADM,XREFNODE
+10 NEW RCC,FLAG
+11 ; Flag to indicate whether a clinic or division list exists
NEW RORCDLIST
+12 ; Start date for clinic/division utilization search
NEW RORCDSTDT
+13 ; End date for clinic/division utilization search
NEW RORCDENDT
+14 NEW AGE,AGETYPE
+15 ;
+16 SET XREFNODE=$NAME(^RORDATA(798,"AC",+RORREG))
+17 SET RORPTN=$$REGSIZE^RORUTL02(+RORREG)
if RORPTN<0
SET RORPTN=0
+18 SET (CNT,ECNT,RC)=0
+19 ;
+20 ;=== Set up Clinic/Division list parameters
+21 SET RORCDLIST=$$CDPARMS^RORXU001(.RORTSK,.RORCDSTDT,.RORCDENDT)
+22 ;
+23 ;--- Browse through the registry records
+24 SET IEN=0
+25 SET FLAG=$GET(RORTSK("PARAMS","ICDFILT","A","FILTER"))
+26 FOR
SET IEN=$ORDER(@XREFNODE@(IEN))
if IEN'>0
QUIT
Begin DoDot:1
+27 SET TMP=$SELECT(RORPTN>0:CNT/RORPTN,1:"")
+28 SET RC=$$LOOP^RORTSK01(TMP)
if RC<0
QUIT
+29 SET IENS=IEN_","
SET CNT=CNT+1
+30 ;--- Get the patient DFN
+31 SET PATIEN=$$PTIEN^RORUTL01(IEN)
if PATIEN'>0
QUIT
+32 ;--- Check for patient list and quit if not on list
+33 IF $DATA(RORTSK("PARAMS","PATIENTS","C"))
IF '$DATA(RORTSK("PARAMS","PATIENTS","C",PATIEN))
QUIT
+34 ;--- Check if the patient should be skipped
+35 if $$SKIP^RORXU005(IEN,FLAGS,RORSDT,ROREDT)
QUIT
+36 ;--- Check if ICD Filter Includes or Excludes Patient
+37 SET RCC=0
+38 IF FLAG'="ALL"
Begin DoDot:2
+39 SET RCC=$$ICD^RORXU010(PATIEN)
End DoDot:2
+40 IF (FLAG="INCLUDE")&(RCC=0)
QUIT
+41 IF (FLAG="EXCLUDE")&(RCC=1)
QUIT
+42 ;--- End of ICD Filter check
+43 ;--- Check for Clinic or Division list and quit if not in list
+44 IF RORCDLIST
IF '$$CDUTIL^RORXU001(.RORTSK,PATIEN,RORCDSTDT,RORCDENDT)
QUIT
+45 ;--- Get the patient's data
+46 DO VADEM^RORUTL05(PATIEN,1)
+47 ;VA("BID")
SET RORPNAME=VADM(1)
SET RORLAST4="0000"
+48 SET RORDOD=$$DATE^RORXU002($PIECE(VADM(6),U)\1)
+49 IF $$PARAM^RORTSK01("PATIENTS","ICN")
SET RORICN=$$ICN^RORUTL02(PATIEN)
+50 IF $$PARAM^RORTSK01("PATIENTS","PACT")
SET RORPACT=$$PACT^RORUTL02(PATIEN)
+51 IF $$PARAM^RORTSK01("PATIENTS","PCP")
SET RORPCP=$$PCP^RORUTL02(PATIEN)
+52 SET AGETYPE=$$PARAM^RORTSK01("AGE_RANGE","TYPE")
+53 SET AGE=$SELECT(AGETYPE="AGE":$PIECE(VADM(4),U),AGETYPE="DOB":$$DATE^RORXU002($PIECE(VADM(3),U)\1),1:"")
+54 ;
+55 ;--- Get the Lab data
+56 SET RC=$$LABDATA(PATIEN)
+57 IF RC
if RC<0
QUIT
SET ECNT=ECNT+RC
End DoDot:1
if RC<0
QUIT
+58 ;---
+59 QUIT $SELECT(RC<0:RC,1:ECNT)
+60 ;
+61 ;***** SORTS THE RESULTS AND COMPILES THE TOTALS
+62 ;
+63 ; Return Values:
+64 ; <0 Error code
+65 ; 0 Ok
+66 ; >0 Number of non-fatal errors
+67 ;
SORT() ;
+1 NEW ECNT,IEN,NAME,NDLT,NODE,RC,RORMSG,TMP
+2 SET NODE=$NAME(^TMP("RORX006",$JOB))
SET (ECNT,RC)=0
+3 ;---
+4 SET RC=$$LOOP^RORTSK01(0)
if RC<0
QUIT RC
+5 if $DATA(@NODE)<10
QUIT 0
+6 ;---
+7 SET IEN=0
SET NDLT=0
+8 FOR
SET IEN=$ORDER(@NODE@("RES",IEN))
if IEN'>0
QUIT
Begin DoDot:1
+9 SET NDLT=NDLT+1
+10 KILL RORMSG
SET NAME=$$GET1^DIQ(60,IEN,.01,,,"RORMSG")
+11 ;D:$G(DIERR) DBS^RORERR("RORMSG",-9,,,60,IEN)
+12 if $GET(RORMSG("DIERR"))
DO DBS^RORERR("RORMSG",-9,,,60,IEN)
+13 if NAME?." "
SET NAME="Unknown ("_IEN_")"
+14 SET TMP=+$GET(@NODE@("RES",IEN,"R"))
+15 SET @NODE@("RES","B",TMP,NAME,IEN)=""
End DoDot:1
+16 ;--- Total numbers of Lab tests
+17 SET $PIECE(@NODE@("RES"),U,2)=NDLT
+18 ;---
+19 QUIT $SELECT(RC<0:RC,1:ECNT)
