RORX005A ;HOIFO/BH,SG - INPATIENT UTILIZATION (QUERY) ;4/21/09 2:20pm
;;1.5;CLINICAL CASE REGISTRIES;**1,8,10,13,19,21,31,39**;Feb 17, 2006;Build 4
;
; This routine uses the following IAs:
;
; #92 ^DGPT( #45.7 (controlled)
; #417 .01 field and "C" x-ref of file #40.8 (controlled)
; #2056 $$GET1^DIQ (supported)
; #3545 ^DGPT("AAD" (private)
; #10061 IN5^VADPT (supported)
; #10103 FMADD^XLFDT, FMDIFF^XLFDT (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.
;ROR*1.5*19 FEB 2012 K GUPTA Support for ICD-10 Coding System
;ROR*1.5*31 MAY 2017 M FERRARESE Adding PACT,PCP, and AGE/DOB as additional
; identifiers.
;ROR*1.5*39 JUL 2021 M FERRARESE Setting SSN and LAST4 to zeros
;******************************************************************************
;******************************************************************************
Q
;
;***** ADDS THE INPATIENT STAY
;
; DFN Patient IEN (in file #2)
; PTFIEN IEN of the PTF record
; LOS Length of stay
; BSID Bed section ID
; DATE Movement date/time (FileMan)
;
ADDSTAY(DFN,PTFIEN,LOS,BSID,DATE) ;
N DST,I,TMP
S:$G(BSID)="" BSID=0
;--- Number of patients for the bedsection
I 'BSID S DST=$NA(@RORDST@("IP",DFN))
E S DST=$NA(@RORDST@("IPB",BSID)) D:'$D(@DST@("P",DFN))
. S @DST@("P")=$G(@DST@("P"))+1,@DST@("P",DFN)=""
;--- No bed section ID
S:BSID<0 @RORDST@("IPNOBS",RORPNAME,DATE,PTFIEN,DFN)=""
;--- Short stays (visits)
I LOS'>0 S @DST@("V")=$G(@DST@("V"))+1 Q
;--- Days and stays
S @DST@("D")=$G(@DST@("D"))+LOS
S @DST@("S")=$G(@DST@("S"))+1
;--- Lengths of stay for median value calculations
S I=$O(@RORDST@("IPMLOS",BSID,LOS,""),-1)+1
S @RORDST@("IPMLOS",BSID,LOS,I)=""
Q
;
;***** LOADS AND PROCESSES THE INPATIENT DATA
;
; DFN Patient IEN (in file #2)
;
; Return Values:
; <0 Error code
; 0 Ok
; >0 Number of non-fatal errors
;
IPDATA(DFN) ;
N RORDST ; Closed reference to the category node in ^TMP
;
N BSID,DATE,DISDT,ENDT,FACILITY,LOS,PTFIEN,RC,RORMSG,STDT,SUFFIX,TMP,VAHOW,VAIP,VAROOT,XDATE
S RORDST=$NA(^TMP("RORX005",$J))
;---
S XDATE=RORSDT
F S RC=0 D Q:RC<2 S XDATE=$O(^DGPT("AAD",DFN,XDATE)) Q:XDATE'>0
. I XDATE'<ROREDT1 S RC=1 Q
. K DATE,LOS,VAIP S VAIP(16,1)=XDATE
. F D Q:RC
. . S VAIP("D")=+$G(VAIP(16,1))
. . I VAIP("D")'>0 S RC=2 Q
. . D IN5^VADPT
. . I $G(VAIP(1))'>0 S RC=2 Q
. . S DATE=+VAIP(3)
. . Q:+$G(VAIP(4))=3
. . ;--- Check the movement date
. . I DATE'<ROREDT1 S RC=1 Q
. . S:DATE<RORSDT DATE=RORSDT
. . ;--- Check the PTF record - Task removed April 2009
. . S PTFIEN=+$G(VAIP(12)) Q:PTFIEN'>0
. . I '$D(PTFIEN(PTFIEN)) D Q:RC
. . . S PTFIEN(PTFIEN)=0
. . . Q:$$PTF^RORXU001(PTFIEN,"FP",,,.SUFFIX,,.FACILITY)
. . . ;--- Check the suffix
. . . ;I SUFFIX'="" Q:$$VSUFFIX(SUFFIX) ; ROR 1.5
. . . ;--- Check the division
. . . S TMP=$$PARAM^RORTSK01("DIVISIONS","ALL")
. . . I 'TMP D Q:'$D(RORTSK("PARAMS","DIVISIONS","C",DIVIEN))
. . . . S TMP=FACILITY_SUFFIX
. . . . S DIVIEN=$S(TMP'="":+$O(^DG(40.8,"C",TMP,"")),1:0)
. . . K DIVIEN ;kill statement added
. . . S PTFIEN(PTFIEN)=1
. . ;--- Skip the PTF record if necessary
. . Q:'PTFIEN(PTFIEN)
. . ;--- Process the admission (only once)
. . I '$D(LOS) D Q:RC
. . . S LOS=$$LOS(+$G(VAIP(13,1)),+$G(VAIP(17,1)))
. . . D ADDSTAY(DFN,PTFIEN,LOS)
. . ;--- Process the movement
. . S ENDT=$G(VAIP(16,1))\1
. . S:(ENDT'>0)!(ENDT'<ROREDT1) ENDT=ROREDT,RC=2
. . Q:ENDT<RORSDT
. . S LOS=$$FMDIFF^XLFDT(ENDT,DATE\1,1) S:LOS'>0 LOS=0
. . ;--- Use the IEN in the SPECIALTY file (#42.4) as the Bedsection
. . ; ID if it is available (it should be). Otherwise, use the
. . ;--- IEN in the FACILITY TREATING SPECIALTY file (#45.7).
. . I $G(VAIP(8))>0 D
. . . K RORMSG S TMP=$$GET1^DIQ(45.7,+VAIP(8),1,"I",,"RORMSG")
. . . ;D:$G(DIERR) DBS^RORERR("RORMSG",-9,,DFN,45.7,+VAIP(8))
. . . D:$G(RORMSG("DIERR")) DBS^RORERR("RORMSG",-9,,DFN,45.7,+VAIP(8))
. . . S BSID=$S(TMP>0:TMP_";42.4",1:+VAIP(8)_";45.7")
. . E S BSID=-1
. . D ADDSTAY(DFN,PTFIEN,LOS,BSID,+VAIP(3))
. S:$G(DATE)>XDATE XDATE=DATE
;---
Q $S(RC<0:RC,1:0)
;
;***** CALCULATES THE LENGTH OF STAY
LOS(STDT,ENDT) ;
N DAYS
S:STDT<RORSDT STDT=RORSDT
S:(ENDT'>0)!(ENDT>ROREDT) ENDT=ROREDT
S DAYS=$$FMDIFF^XLFDT(ENDT\1,STDT\1,1)
Q $S(DAYS'<0:DAYS,1: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 ROREDT1 ; Day after the end date
N RORLAST4 ; Last 4 digits of the current patient's SSN
N RORPNAME ; Name of the current patient
N RORICN ; National ICN
N RORPACT ; Patient Care team
N RORPCP ; Primary care physician
N RORPTN ; Number of patients in the registry
N AGE,AGETYPE
;
N CNT,ECNT,IEN,IENS,PATIEN,RC,TMP,VA,VADM,XREFNODE
N RCC,FLAG
S XREFNODE=$NA(^RORDATA(798,"AC",+RORREG))
S RORPTN=$$REGSIZE^RORUTL02(+RORREG) S:RORPTN<0 RORPTN=0
S ROREDT1=$$FMADD^XLFDT(ROREDT,1)
S (CNT,ECNT,RC)=0
;--- 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)
. ;--- Filter patient on ICD codes
. 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 filter
. ;
. ;--- Get the patient's data
. D VADEM^RORUTL05(PATIEN,1)
. S RORPNAME=VADM(1),RORLAST4="0000"
. S RORICN=$S($$PARAM^RORTSK01("PATIENTS","ICN"):$$ICN^RORUTL02(PATIEN),1:"")
. S RORPACT=$S($$PARAM^RORTSK01("PATIENTS","PACT"):$$PACT^RORUTL02(PATIEN),1:"")
. S RORPCP=$S($$PARAM^RORTSK01("PATIENTS","PCP"):$$PCP^RORUTL02(PATIEN),1:"")
. S AGETYPE=$$PARAM^RORTSK01("AGE_RANGE","TYPE") D
. . S AGE=$S(AGETYPE="AGE":$P(VADM(4),U),AGETYPE="DOB":$$DATE^RORXU002($P(VADM(3),U)\1),1:"")
. ;
. ;--- Get the inpatient data
. S RC=$$IPDATA(PATIEN)
. I RC S ECNT=ECNT+1 Q:RC<0
. ;
. ;--- Calculate intermediate totals
. S RC=$$TOTALS^RORX005B(PATIEN)
. I RC S ECNT=ECNT+1 Q:RC<0
;---
Q $S(RC<0:RC,1:ECNT)
;
;***** CHECKS THE SUFFIX FOR VALIDITY
;
; SUFFIX Suffix
;
; Return Values:
; 0 Ok
; 1 Invalid suffix
VSUFFIX(SUFFIX) ;
Q '("9AA,9AB,9AC,9AD,9AE,9BB,A0,A4,A5,BU,BV,PA"[SUFFIX)
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRORX005A 7677 printed Apr 09, 2024@20:49:43 Page 2
RORX005A ;HOIFO/BH,SG - INPATIENT UTILIZATION (QUERY) ;4/21/09 2:20pm
+1 ;;1.5;CLINICAL CASE REGISTRIES;**1,8,10,13,19,21,31,39**;Feb 17, 2006;Build 4
+2 ;
+3 ; This routine uses the following IAs:
+4 ;
+5 ; #92 ^DGPT( #45.7 (controlled)
+6 ; #417 .01 field and "C" x-ref of file #40.8 (controlled)
+7 ; #2056 $$GET1^DIQ (supported)
+8 ; #3545 ^DGPT("AAD" (private)
+9 ; #10061 IN5^VADPT (supported)
+10 ; #10103 FMADD^XLFDT, FMDIFF^XLFDT (supported)
+11 ;
+12 ;******************************************************************************
+13 ;******************************************************************************
+14 ; --- ROUTINE MODIFICATION LOG ---
+15 ;
+16 ;PKG/PATCH DATE DEVELOPER MODIFICATION
+17 ;----------- ---------- ----------- ----------------------------------------
+18 ;ROR*1.5*8 MAR 2010 V CARR Modified to handle ICD9 filter for
+19 ; 'include' or 'exclude'.
+20 ;ROR*1.5*13 DEC 2010 A SAUNDERS User can select specific patients.
+21 ;ROR*1.5*19 FEB 2012 K GUPTA Support for ICD-10 Coding System
+22 ;ROR*1.5*31 MAY 2017 M FERRARESE Adding PACT,PCP, and AGE/DOB as additional
+23 ; identifiers.
+24 ;ROR*1.5*39 JUL 2021 M FERRARESE Setting SSN and LAST4 to zeros
+25 ;******************************************************************************
+26 ;******************************************************************************
+27 QUIT
+28 ;
+29 ;***** ADDS THE INPATIENT STAY
+30 ;
+31 ; DFN Patient IEN (in file #2)
+32 ; PTFIEN IEN of the PTF record
+33 ; LOS Length of stay
+34 ; BSID Bed section ID
+35 ; DATE Movement date/time (FileMan)
+36 ;
ADDSTAY(DFN,PTFIEN,LOS,BSID,DATE) ;
+1 NEW DST,I,TMP
+2 if $GET(BSID)=""
SET BSID=0
+3 ;--- Number of patients for the bedsection
+4 IF 'BSID
SET DST=$NAME(@RORDST@("IP",DFN))
+5 IF '$TEST
SET DST=$NAME(@RORDST@("IPB",BSID))
if '$DATA(@DST@("P",DFN))
Begin DoDot:1
+6 SET @DST@("P")=$GET(@DST@("P"))+1
SET @DST@("P",DFN)=""
End DoDot:1
+7 ;--- No bed section ID
+8 if BSID<0
SET @RORDST@("IPNOBS",RORPNAME,DATE,PTFIEN,DFN)=""
+9 ;--- Short stays (visits)
+10 IF LOS'>0
SET @DST@("V")=$GET(@DST@("V"))+1
QUIT
+11 ;--- Days and stays
+12 SET @DST@("D")=$GET(@DST@("D"))+LOS
+13 SET @DST@("S")=$GET(@DST@("S"))+1
+14 ;--- Lengths of stay for median value calculations
+15 SET I=$ORDER(@RORDST@("IPMLOS",BSID,LOS,""),-1)+1
+16 SET @RORDST@("IPMLOS",BSID,LOS,I)=""
+17 QUIT
+18 ;
+19 ;***** LOADS AND PROCESSES THE INPATIENT DATA
+20 ;
+21 ; DFN Patient IEN (in file #2)
+22 ;
+23 ; Return Values:
+24 ; <0 Error code
+25 ; 0 Ok
+26 ; >0 Number of non-fatal errors
+27 ;
IPDATA(DFN) ;
+1 ; Closed reference to the category node in ^TMP
NEW RORDST
+2 ;
+3 NEW BSID,DATE,DISDT,ENDT,FACILITY,LOS,PTFIEN,RC,RORMSG,STDT,SUFFIX,TMP,VAHOW,VAIP,VAROOT,XDATE
+4 SET RORDST=$NAME(^TMP("RORX005",$JOB))
+5 ;---
+6 SET XDATE=RORSDT
+7 FOR
SET RC=0
Begin DoDot:1
+8 IF XDATE'<ROREDT1
SET RC=1
QUIT
+9 KILL DATE,LOS,VAIP
SET VAIP(16,1)=XDATE
+10 FOR
Begin DoDot:2
+11 SET VAIP("D")=+$GET(VAIP(16,1))
+12 IF VAIP("D")'>0
SET RC=2
QUIT
+13 DO IN5^VADPT
+14 IF $GET(VAIP(1))'>0
SET RC=2
QUIT
+15 SET DATE=+VAIP(3)
+16 if +$GET(VAIP(4))=3
QUIT
+17 ;--- Check the movement date
+18 IF DATE'<ROREDT1
SET RC=1
QUIT
+19 if DATE<RORSDT
SET DATE=RORSDT
+20 ;--- Check the PTF record - Task removed April 2009
+21 SET PTFIEN=+$GET(VAIP(12))
if PTFIEN'>0
QUIT
+22 IF '$DATA(PTFIEN(PTFIEN))
Begin DoDot:3
+23 SET PTFIEN(PTFIEN)=0
+24 if $$PTF^RORXU001(PTFIEN,"FP",,,.SUFFIX,,.FACILITY)
QUIT
+25 ;--- Check the suffix
+26 ;I SUFFIX'="" Q:$$VSUFFIX(SUFFIX) ; ROR 1.5
+27 ;--- Check the division
+28 SET TMP=$$PARAM^RORTSK01("DIVISIONS","ALL")
+29 IF 'TMP
Begin DoDot:4
+30 SET TMP=FACILITY_SUFFIX
+31 SET DIVIEN=$SELECT(TMP'="":+$ORDER(^DG(40.8,"C",TMP,"")),1:0)
End DoDot:4
if '$DATA(RORTSK("PARAMS","DIVISIONS","C",DIVIEN))
QUIT
+32 ;kill statement added
KILL DIVIEN
+33 SET PTFIEN(PTFIEN)=1
End DoDot:3
if RC
QUIT
+34 ;--- Skip the PTF record if necessary
+35 if 'PTFIEN(PTFIEN)
QUIT
+36 ;--- Process the admission (only once)
+37 IF '$DATA(LOS)
Begin DoDot:3
+38 SET LOS=$$LOS(+$GET(VAIP(13,1)),+$GET(VAIP(17,1)))
+39 DO ADDSTAY(DFN,PTFIEN,LOS)
End DoDot:3
if RC
QUIT
+40 ;--- Process the movement
+41 SET ENDT=$GET(VAIP(16,1))\1
+42 if (ENDT'>0)!(ENDT'<ROREDT1)
SET ENDT=ROREDT
SET RC=2
+43 if ENDT<RORSDT
QUIT
+44 SET LOS=$$FMDIFF^XLFDT(ENDT,DATE\1,1)
if LOS'>0
SET LOS=0
+45 ;--- Use the IEN in the SPECIALTY file (#42.4) as the Bedsection
+46 ; ID if it is available (it should be). Otherwise, use the
+47 ;--- IEN in the FACILITY TREATING SPECIALTY file (#45.7).
+48 IF $GET(VAIP(8))>0
Begin DoDot:3
+49 KILL RORMSG
SET TMP=$$GET1^DIQ(45.7,+VAIP(8),1,"I",,"RORMSG")
+50 ;D:$G(DIERR) DBS^RORERR("RORMSG",-9,,DFN,45.7,+VAIP(8))
+51 if $GET(RORMSG("DIERR"))
DO DBS^RORERR("RORMSG",-9,,DFN,45.7,+VAIP(8))
+52 SET BSID=$SELECT(TMP>0:TMP_";42.4",1:+VAIP(8)_";45.7")
End DoDot:3
+53 IF '$TEST
SET BSID=-1
+54 DO ADDSTAY(DFN,PTFIEN,LOS,BSID,+VAIP(3))
End DoDot:2
if RC
QUIT
+55 if $GET(DATE)>XDATE
SET XDATE=DATE
End DoDot:1
if RC<2
QUIT
SET XDATE=$ORDER(^DGPT("AAD",DFN,XDATE))
if XDATE'>0
QUIT
+56 ;---
+57 QUIT $SELECT(RC<0:RC,1:0)
+58 ;
+59 ;***** CALCULATES THE LENGTH OF STAY
LOS(STDT,ENDT) ;
+1 NEW DAYS
+2 if STDT<RORSDT
SET STDT=RORSDT
+3 if (ENDT'>0)!(ENDT>ROREDT)
SET ENDT=ROREDT
+4 SET DAYS=$$FMDIFF^XLFDT(ENDT\1,STDT\1,1)
+5 QUIT $SELECT(DAYS'<0:DAYS,1:0)
+6 ;
+7 ;***** QUERIES THE REGISTRY
+8 ;
+9 ; FLAGS Flags for the $$SKIP^RORXU005
+10 ;
+11 ; Return Values:
+12 ; <0 Error code
+13 ; 0 Ok
+14 ; >0 Number of non-fatal errors
+15 ;
QUERY(FLAGS) ;
+1 ; Day after the end date
NEW ROREDT1
+2 ; Last 4 digits of the current patient's SSN
NEW RORLAST4
+3 ; Name of the current patient
NEW RORPNAME
+4 ; National ICN
NEW RORICN
+5 ; Patient Care team
NEW RORPACT
+6 ; Primary care physician
NEW RORPCP
+7 ; Number of patients in the registry
NEW RORPTN
+8 NEW AGE,AGETYPE
+9 ;
+10 NEW CNT,ECNT,IEN,IENS,PATIEN,RC,TMP,VA,VADM,XREFNODE
+11 NEW RCC,FLAG
+12 SET XREFNODE=$NAME(^RORDATA(798,"AC",+RORREG))
+13 SET RORPTN=$$REGSIZE^RORUTL02(+RORREG)
if RORPTN<0
SET RORPTN=0
+14 SET ROREDT1=$$FMADD^XLFDT(ROREDT,1)
+15 SET (CNT,ECNT,RC)=0
+16 ;--- Browse through the registry records
+17 SET IEN=0
+18 SET FLAG=$GET(RORTSK("PARAMS","ICDFILT","A","FILTER"))
+19 FOR
SET IEN=$ORDER(@XREFNODE@(IEN))
if IEN'>0
QUIT
Begin DoDot:1
+20 SET TMP=$SELECT(RORPTN>0:CNT/RORPTN,1:"")
+21 SET RC=$$LOOP^RORTSK01(TMP)
if RC<0
QUIT
+22 SET IENS=IEN_","
SET CNT=CNT+1
+23 ;--- Get the patient DFN
+24 SET PATIEN=$$PTIEN^RORUTL01(IEN)
if PATIEN'>0
QUIT
+25 ;check for patient list and quit if not on list
+26 IF $DATA(RORTSK("PARAMS","PATIENTS","C"))
IF '$DATA(RORTSK("PARAMS","PATIENTS","C",PATIEN))
QUIT
+27 ;--- Check if the patient should be skipped
+28 if $$SKIP^RORXU005(IEN,FLAGS,RORSDT,ROREDT)
QUIT
+29 ;--- Filter patient on ICD codes
+30 SET RCC=0
+31 IF FLAG'="ALL"
Begin DoDot:2
+32 SET RCC=$$ICD^RORXU010(PATIEN)
End DoDot:2
+33 IF (FLAG="INCLUDE")&(RCC=0)
QUIT
+34 IF (FLAG="EXCLUDE")&(RCC=1)
QUIT
+35 ;--- End of filter
+36 ;
+37 ;--- Get the patient's data
+38 DO VADEM^RORUTL05(PATIEN,1)
+39 SET RORPNAME=VADM(1)
SET RORLAST4="0000"
+40 SET RORICN=$SELECT($$PARAM^RORTSK01("PATIENTS","ICN"):$$ICN^RORUTL02(PATIEN),1:"")
+41 SET RORPACT=$SELECT($$PARAM^RORTSK01("PATIENTS","PACT"):$$PACT^RORUTL02(PATIEN),1:"")
+42 SET RORPCP=$SELECT($$PARAM^RORTSK01("PATIENTS","PCP"):$$PCP^RORUTL02(PATIEN),1:"")
+43 SET AGETYPE=$$PARAM^RORTSK01("AGE_RANGE","TYPE")
Begin DoDot:2
+44 SET AGE=$SELECT(AGETYPE="AGE":$PIECE(VADM(4),U),AGETYPE="DOB":$$DATE^RORXU002($PIECE(VADM(3),U)\1),1:"")
End DoDot:2
+45 ;
+46 ;--- Get the inpatient data
+47 SET RC=$$IPDATA(PATIEN)
+48 IF RC
SET ECNT=ECNT+1
if RC<0
QUIT
+49 ;
+50 ;--- Calculate intermediate totals
+51 SET RC=$$TOTALS^RORX005B(PATIEN)
+52 IF RC
SET ECNT=ECNT+1
if RC<0
QUIT
End DoDot:1
if RC<0
QUIT
+53 ;---
+54 QUIT $SELECT(RC<0:RC,1:ECNT)
+55 ;
+56 ;***** CHECKS THE SUFFIX FOR VALIDITY
+57 ;
+58 ; SUFFIX Suffix
+59 ;
+60 ; Return Values:
+61 ; 0 Ok
+62 ; 1 Invalid suffix
VSUFFIX(SUFFIX) ;
+1 QUIT '("9AA,9AB,9AC,9AD,9AE,9BB,A0,A4,A5,BU,BV,PA"[SUFFIX)
