RORX015A ;HOIFO/SG,VAC - OUTPATIENT PROCEDURES (QUERY & SORT) ;4/7/09 2:10pm
;;1.5;CLINICAL CASE REGISTRIES;**1,8,13,19,21,25,31,34**;Feb 17, 2006;Build 45
;
; This routine uses the following IAs:
;
; #1995 $$CODEN^ICPTCOD and $$CPT^ICPTCOD (supported)
; #2055 ROOT^DILFD
; #2056 GETS^DIQ
; #2546 GETCPT^SDOE
; #2548 Multiple APIs in SDQ routine (supported)
; #10103 FMADD^XLFDT (supported)
; #5747 $$CODEC^ICDEX, $$CODEN^ICDEX, $$VSTP^ICDEX (controlled)
; #6130 PTFICD^DGPTFUT
;
;******************************************************************************
;******************************************************************************
; --- 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 J SCOTT Support for ICD-10 Coding System.
;ROR*1.5*21 SEP 2013 T KOPP Added ICN as report column if
; additional identifier option selected
;ROR*1.5*25 OCT 2014 T KOPP Added PTF ICD-10 support for 25 diagnoses
;ROR*1.5*31 MAY 2017 M FERRARESE Adding PACT, PCP, and AGE/DOB as additional
; identifiers.
;ROR*1.5*34 SEP 2018 F TRAXLER Adding FUT_APPT and FUT_CLIN
;******************************************************************************
;******************************************************************************
Q
;
;***** SEARCHES FOR INPATIENT PROCEDURES
;
; PTIEN Patient IEN (DFN)
;
; Return Values:
; <0 Error code
; 0 Ok
; >0 Number of non-fatal errors
;
INPAT(PTIEN) ;
N DATE,ERRCNT,IEN,IEN45,IENS,NODE,RC,RORBUF,RORIBUF,RORMSG,XREF,FLD
S (ERRCNT,RC)=0
S XREF=$$ROOT^DILFD(45,,1),XREF=$NA(@XREF@("B",PTIEN))
S IEN45=0
F S IEN45=$O(@XREF@(IEN45)) Q:IEN45'>0 D
. ;--- Surgical procedures
. S NODE=$$ROOT^DILFD(45.01,","_IEN45_",",1)
. S IEN=0
. F S IEN=$O(@NODE@(IEN)) Q:IEN'>0 D
. . S IENS=IEN_","_IEN45_"," K RORBUF
. . ;--- Load the data
. . K RORMSG D GETS^DIQ(45.01,IENS,".01;","I","RORBUF","RORMSG")
. . I $G(RORMSG("DIERR")) D S ERRCNT=ERRCNT+1
. . . D DBS^RORERR("RORMSG",-99,,PTIEN,45.01,IENS)
. . S DATE=$G(RORBUF(45.01,IENS,.01,"I"))
. . Q:(DATE<RORSDT)!(DATE'<ROREDT1)
. . ;--- Generate the output
. . K RORIBUF
. . D PTFICD^DGPTFUT(401,IEN45,IEN,.RORIBUF)
. . S FLD="" F S FLD=$O(RORIBUF(FLD)) Q:FLD="" I $G(RORIBUF(FLD)) D
. . . D PROCSET(PTIEN,"I",+RORIBUF(FLD),DATE)
. ;--- Other procedures
. S NODE=$$ROOT^DILFD(45.05,","_IEN45_",",1)
. S IEN=0
. F S IEN=$O(@NODE@(IEN)) Q:IEN'>0 D
. . S IENS=IEN_","_IEN45_"," K RORBUF
. . ;--- Load the data
. . K RORMSG D GETS^DIQ(45.05,IENS,".01","I","RORBUF","RORMSG")
. . I $G(RORMSG("DIERR")) D S ERRCNT=ERRCNT+1
. . . D DBS^RORERR("RORMSG",-99,,PTIEN,45.05,IENS)
. . S DATE=$G(RORBUF(45.05,IENS,.01,"I"))
. . Q:(DATE<RORSDT)!(DATE'<ROREDT1)
. . ;--- Generate the output
. . K RORIBUF
. . D PTFICD^DGPTFUT(601,IEN45,IEN,.RORIBUF)
. . S FLD="" F S FLD=$O(RORIBUF(FLD)) Q:FLD="" I $G(RORIBUF(FLD)) D
. . . D PROCSET(PTIEN,"I",+RORIBUF(FLD),DATE)
;---
Q $S(RC<0:RC,1:ERRCNT)
;
;***** CALL-BACK PROCEDURE FOR THE OUTPATIENT SEARCH
;
; PTIEN Patient IEN (DFN)
;
OPSCAN(PTIEN) ;
N CPTIEN,DATE,IEN,RORCPT,VDATE
D GETCPT^SDOE(Y,"RORCPT")
Q:$G(RORCPT)'>0
S VDATE=+$P(Y0,U)
;---
S IEN=0
F S IEN=$O(RORCPT(IEN)) Q:IEN'>0 D
. S CPTIEN=+$P(RORCPT(IEN),U),DATE=+$P($G(RORCPT(IEN,12)),U)
. D:CPTIEN>0 PROCSET(PTIEN,"O",CPTIEN,$S(DATE>0:DATE,1:VDATE))
Q
;
;***** SEARCHES FOR OUTPATIENT PROCEDURES
;
; PTIEN Patient IEN (DFN)
;
; Return Values:
; <0 Error code
; 0 Ok
; >0 Number of non-fatal errors
;
OUTPAT(PTIEN) ;
N QUERY
D OPEN^SDQ(.QUERY)
D INDEX^SDQ(.QUERY,"PATIENT/DATE","SET")
D PAT^SDQ(.QUERY,PTIEN,"SET")
D DATE^SDQ(.QUERY,RORSDT,ROREDT1,"SET")
D SCANCB^SDQ(.QUERY,"D OPSCAN^RORX015A("_PTIEN_")","SET")
D ACTIVE^SDQ(.QUERY,"TRUE","SET")
D SCAN^SDQ(.QUERY,"FORWARD")
D CLOSE^SDQ(.QUERY)
Q 0
;
;**** STORES THE PROCEDURE CODE
;
; PTIEN Patient IEN (DFN)
; SOURCE CPT source code ("O" or "I")
; [IEN] IEN of the procedure descriptor (file #81 or #80.1)
; DATE Date when the code was entered
; [CODE] Procedure code (CPT or ICD-9)
;
; Either the IEN or the CODE parameter must be provided.
;
PROCSET(PTIEN,SOURCE,IEN,DATE,CODE) ;
Q:DATE'>0
N TMP
S IEN=+$G(IEN)
;---
I IEN'>0 Q:$G(CODE)="" D Q:IEN'>0
. I SOURCE="O" S IEN=+$$CODEN^ICPTCOD(CODE) Q
. I SOURCE="I" S IEN=+$$CODEN^ICDEX(CODE,80.1) Q
;---
I SOURCE="O",'$$PARAM^RORTSK01("CPTLST","ALL") D Q:'TMP
. S TMP=$D(RORTSK("PARAMS","CPTLST","C",IEN))
I SOURCE="I" Q:$$ICDGRCHK^RORXU008(.RORPTGRP,IEN,RORICDL)
;---
S TMP=+$G(@RORTMP@("PAT",PTIEN,SOURCE,IEN))
S:'TMP!(DATE<TMP) @RORTMP@("PAT",PTIEN,SOURCE,IEN)=DATE
S ^("C")=$G(@RORTMP@("PAT",PTIEN,SOURCE,IEN,"C"))+1 ;naked reference: ^TMP($J,"RORTMP-n") from RORX015
Q
;
;***** 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 RORPTGRP ; Temporary list of ICD groups
N RORPTN ; Number of patients in the registry
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 CNT,ECNT,IEN,IENS,MODE,PTIEN,RC,SKIP,SKIPEDT,SKIPSDT,TMP,UTEDT,UTSDT,XREFNODE
N RCC,FLAG,UTIL
S XREFNODE=$NA(^RORDATA(798,"AC",+RORREG))
S ROREDT1=$$FMADD^XLFDT(ROREDT\1,1)
S (CNT,ECNT,RC)=0,SKIPEDT=ROREDT,SKIPSDT=RORSDT
S:$$PARAM^RORTSK01("PATIENTS","INPATIENT") MODE("I")=1
S:$$PARAM^RORTSK01("PATIENTS","OUTPATIENT") MODE("O")=1
;--- Utilization date range
D:$$PARAM^RORTSK01("PATIENTS","CAREONLY")
. S UTSDT=$$PARAM^RORTSK01("DATE_RANGE_3","START")\1
. S UTEDT=$$PARAM^RORTSK01("DATE_RANGE_3","END")\1
. ;--- Combined date range
. S SKIPSDT=$$DTMIN^RORUTL18(SKIPSDT,UTSDT)
. S SKIPEDT=$$DTMAX^RORUTL18(SKIPEDT,UTEDT)
;--- Number of patients in the registry
S RORPTN=$$REGSIZE^RORUTL02(+RORREG) S:RORPTN<0 RORPTN=0
;
;=== Set up Clinic/Division list parameters
S RORCDLIST=$$CDPARMS^RORXU001(.RORTSK,.RORCDSTDT,.RORCDENDT,1)
;
;=== 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 patient DFN
. S PTIEN=$$PTIEN^RORUTL01(IEN) Q:PTIEN'>0
. ;--- Check for patient list and quit if not on list
. I $D(RORTSK("PARAMS","PATIENTS","C")),'$D(RORTSK("PARAMS","PATIENTS","C",PTIEN)) Q
. ;--- Check if the patient should be skipped
. Q:$$SKIP^RORXU005(IEN,FLAGS,SKIPSDT,SKIPEDT)
. ;--- Check if patient has passed the ICD Filter
. S RCC=0
. I FLAG'="ALL" D
. . S RCC=$$ICD^RORXU010(PTIEN)
. I (FLAG="INCLUDE")&(RCC=0) Q
. I (FLAG="EXCLUDE")&(RCC=1) Q
. ;--- End of ICD check
. M RORPTGRP=RORIGRP("C")
. ;
. ;--- Check for Clinic or Division list and quit if not in list
. I RORCDLIST,'$$CDUTIL^RORXU001(.RORTSK,PTIEN,RORCDSTDT,RORCDENDT) Q
. ;
. ;--- Inpatient codes (ICD)
. I $G(MODE("I")) D I RC Q:RC<0 S ECNT=ECNT+RC
. . S RC=$$INPAT(PTIEN)
. ;--- Outpatient codes (CPT)
. I $G(MODE("O")) D I RC Q:RC<0 S ECNT=ECNT+RC
. . S RC=$$OUTPAT(PTIEN)
. ;
. ;--- If ICD codes from some groups have not been found,
. ;--- then do not consider inpatient procedures at all
. K:$D(RORPTGRP)>1 @RORTMP@("PAT",PTIEN,"I")
. ;---
. S SKIP=($D(@RORTMP@("PAT",PTIEN))<10)
. S:RORPROC<0 SKIP='SKIP
. ;
. ;--- Check for any utilization in the corresponding date range
. I 'SKIP D:$$PARAM^RORTSK01("PATIENTS","CAREONLY")
. . K TMP S TMP("ALL")=1
. . S UTIL=+$$UTIL^RORXU003(UTSDT,UTEDT,PTIEN,.TMP)
. . S:'UTIL SKIP=1
. ;
. ;--- Skip the patient if not all search criteria have been met
. I SKIP K @RORTMP@("PAT",PTIEN) Q
. ;
. ;--- Calculate the patient's totals
. S RC=$$TOTALS(PTIEN)
. 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 IEN,SRC,TMP,TNC,TNDC
;---
S (TNC,TNDC)=0
F SRC="I","O" D
. S IEN=0
. F S IEN=$O(@RORTMP@("PROC",SRC,IEN)) Q:IEN'>0 D
. . S TMP=$P($G(@RORTMP@("PROC",SRC,IEN)),U,2)
. . S:TMP'="" @RORTMP@("PROC","B",TMP,SRC,IEN)=""
. . S TNC=TNC+$G(@RORTMP@("PROC",SRC,IEN,"C"))
. . S TNDC=TNDC+1
S @RORTMP@("PROC")=TNC_U_TNDC
;---
Q 0
;
;***** CALCULATES INTERMEDIATE TOTALS
;
; PTIEN Patient IEN (DFN)
;
; Return Values:
; <0 Error code
; 0 Ok
; >0 Number of non-fatal errors
;
TOTALS(PTIEN) ;
N CNT,CODE,IEN,NAME,PNODE,RC,SRC,TMP,TMP1,TMP2,VA,VADM,AGE,AGETYPE,RORAPPT,RORAPPTINFO,RORCLIN
S PNODE=$NA(@RORTMP@("PAT",PTIEN))
;--- Get and store the patient's data
D VADEM^RORUTL05(PTIEN,1)
S TMP=$S($$PARAM^RORTSK01("PATIENTS","ICN"):$$ICN^RORUTL02(PTIEN),1:"")
S TMP1=$S($$PARAM^RORTSK01("PATIENTS","PACT"):$$PACT^RORUTL02(PTIEN),1:"")
S TMP2=$S($$PARAM^RORTSK01("PATIENTS","PCP"):$$PCP^RORUTL02(PTIEN),1:"")
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:"")
I $$PARAM^RORTSK01("OPTIONS","FUT_APPT") D ;patch 34
. S RORAPPTINFO=$$FUTAPPT^RORUTL02(PTIEN,$$PARAM^RORTSK01("OPTIONS","FUT_APPT"))
. S RORAPPT=$P(RORAPPTINFO,U,1),RORCLIN=$P(RORAPPTINFO,U,2)
S @PNODE=VA("BID")_U_VADM(1)_U_$$DATE^RORXU002(VADM(6)\1)_U_TMP_U_TMP1_U_TMP2_U_AGE_U_$G(RORAPPT)_U_$G(RORCLIN)
S ^("PAT")=$G(@RORTMP@("PAT"))+1 ;naked reference: ^TMP($J,"RORTMP-n") from RORX015
;
F SRC="I","O" D
. S IEN=0
. F S IEN=$O(@PNODE@(SRC,IEN)) Q:IEN'>0 D
. . S CODE=$P($G(@RORTMP@("PROC",SRC,IEN)),U),NAME=""
. . D:CODE=""
. . . I SRC="O" D
. . . . S TMP=$$CPT^ICPTCOD(IEN)
. . . . S:TMP'<0 CODE=$P(TMP,U,2),NAME=$P(TMP,U,3)
. . . E D
. . . . ;S TMP=$$ICDOP^ICDCODE(IEN)
. . . . ;S:TMP'<0 CODE=$P(TMP,U,2),NAME=$P(TMP,U,5)
. . . . S CODE=$$CODEC^ICDEX(80.1,IEN)
. . . . S NAME=$$VSTP^ICDEX(IEN)
. . . S:CODE="" CODE="UNKN"
. . . S:NAME="" NAME="Unknown ("_IEN_")"
. . . S @RORTMP@("PROC",SRC,IEN)=CODE_U_NAME
. . ;---
. . S CNT=+$G(@PNODE@(SRC,IEN,"C"))
. . S ^("C")=$G(@RORTMP@("PROC",SRC,IEN,"C"))+CNT ;naked reference: ^TMP($J,"RORTMP-n") from RORX015
. . S ^("P")=$G(@RORTMP@("PROC",SRC,IEN,"P"))+1 ;naked reference: ^TMP($J,"RORTMP-n") from RORX015
Q 0
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRORX015A 11521 printed Apr 09, 2024@20:49:38 Page 2
RORX015A ;HOIFO/SG,VAC - OUTPATIENT PROCEDURES (QUERY & SORT) ;4/7/09 2:10pm
+1 ;;1.5;CLINICAL CASE REGISTRIES;**1,8,13,19,21,25,31,34**;Feb 17, 2006;Build 45
+2 ;
+3 ; This routine uses the following IAs:
+4 ;
+5 ; #1995 $$CODEN^ICPTCOD and $$CPT^ICPTCOD (supported)
+6 ; #2055 ROOT^DILFD
+7 ; #2056 GETS^DIQ
+8 ; #2546 GETCPT^SDOE
+9 ; #2548 Multiple APIs in SDQ routine (supported)
+10 ; #10103 FMADD^XLFDT (supported)
+11 ; #5747 $$CODEC^ICDEX, $$CODEN^ICDEX, $$VSTP^ICDEX (controlled)
+12 ; #6130 PTFICD^DGPTFUT
+13 ;
+14 ;******************************************************************************
+15 ;******************************************************************************
+16 ; --- ROUTINE MODIFICATION LOG ---
+17 ;
+18 ;PKG/PATCH DATE DEVELOPER MODIFICATION
+19 ;----------- ---------- ----------- ----------------------------------------
+20 ;ROR*1.5*8 MAR 2010 V CARR Modified to handle ICD9 filter for
+21 ; 'include' or 'exclude'.
+22 ;ROR*1.5*13 DEC 2010 A SAUNDERS User can select specific patients,
+23 ; clinics, or divisions for the report.
+24 ;ROR*1.5*19 FEB 2012 J SCOTT Support for ICD-10 Coding System.
+25 ;ROR*1.5*21 SEP 2013 T KOPP Added ICN as report column if
+26 ; additional identifier option selected
+27 ;ROR*1.5*25 OCT 2014 T KOPP Added PTF ICD-10 support for 25 diagnoses
+28 ;ROR*1.5*31 MAY 2017 M FERRARESE Adding PACT, PCP, and AGE/DOB as additional
+29 ; identifiers.
+30 ;ROR*1.5*34 SEP 2018 F TRAXLER Adding FUT_APPT and FUT_CLIN
+31 ;******************************************************************************
+32 ;******************************************************************************
+33 QUIT
+34 ;
+35 ;***** SEARCHES FOR INPATIENT PROCEDURES
+36 ;
+37 ; PTIEN Patient IEN (DFN)
+38 ;
+39 ; Return Values:
+40 ; <0 Error code
+41 ; 0 Ok
+42 ; >0 Number of non-fatal errors
+43 ;
INPAT(PTIEN) ;
+1 NEW DATE,ERRCNT,IEN,IEN45,IENS,NODE,RC,RORBUF,RORIBUF,RORMSG,XREF,FLD
+2 SET (ERRCNT,RC)=0
+3 SET XREF=$$ROOT^DILFD(45,,1)
SET XREF=$NAME(@XREF@("B",PTIEN))
+4 SET IEN45=0
+5 FOR
SET IEN45=$ORDER(@XREF@(IEN45))
if IEN45'>0
QUIT
Begin DoDot:1
+6 ;--- Surgical procedures
+7 SET NODE=$$ROOT^DILFD(45.01,","_IEN45_",",1)
+8 SET IEN=0
+9 FOR
SET IEN=$ORDER(@NODE@(IEN))
if IEN'>0
QUIT
Begin DoDot:2
+10 SET IENS=IEN_","_IEN45_","
KILL RORBUF
+11 ;--- Load the data
+12 KILL RORMSG
DO GETS^DIQ(45.01,IENS,".01;","I","RORBUF","RORMSG")
+13 IF $GET(RORMSG("DIERR"))
Begin DoDot:3
+14 DO DBS^RORERR("RORMSG",-99,,PTIEN,45.01,IENS)
End DoDot:3
SET ERRCNT=ERRCNT+1
+15 SET DATE=$GET(RORBUF(45.01,IENS,.01,"I"))
+16 if (DATE<RORSDT)!(DATE'<ROREDT1)
QUIT
+17 ;--- Generate the output
+18 KILL RORIBUF
+19 DO PTFICD^DGPTFUT(401,IEN45,IEN,.RORIBUF)
+20 SET FLD=""
FOR
SET FLD=$ORDER(RORIBUF(FLD))
if FLD=""
QUIT
IF $GET(RORIBUF(FLD))
Begin DoDot:3
+21 DO PROCSET(PTIEN,"I",+RORIBUF(FLD),DATE)
End DoDot:3
End DoDot:2
+22 ;--- Other procedures
+23 SET NODE=$$ROOT^DILFD(45.05,","_IEN45_",",1)
+24 SET IEN=0
+25 FOR
SET IEN=$ORDER(@NODE@(IEN))
if IEN'>0
QUIT
Begin DoDot:2
+26 SET IENS=IEN_","_IEN45_","
KILL RORBUF
+27 ;--- Load the data
+28 KILL RORMSG
DO GETS^DIQ(45.05,IENS,".01","I","RORBUF","RORMSG")
+29 IF $GET(RORMSG("DIERR"))
Begin DoDot:3
+30 DO DBS^RORERR("RORMSG",-99,,PTIEN,45.05,IENS)
End DoDot:3
SET ERRCNT=ERRCNT+1
+31 SET DATE=$GET(RORBUF(45.05,IENS,.01,"I"))
+32 if (DATE<RORSDT)!(DATE'<ROREDT1)
QUIT
+33 ;--- Generate the output
+34 KILL RORIBUF
+35 DO PTFICD^DGPTFUT(601,IEN45,IEN,.RORIBUF)
+36 SET FLD=""
FOR
SET FLD=$ORDER(RORIBUF(FLD))
if FLD=""
QUIT
IF $GET(RORIBUF(FLD))
Begin DoDot:3
+37 DO PROCSET(PTIEN,"I",+RORIBUF(FLD),DATE)
End DoDot:3
End DoDot:2
End DoDot:1
+38 ;---
+39 QUIT $SELECT(RC<0:RC,1:ERRCNT)
+40 ;
+41 ;***** CALL-BACK PROCEDURE FOR THE OUTPATIENT SEARCH
+42 ;
+43 ; PTIEN Patient IEN (DFN)
+44 ;
OPSCAN(PTIEN) ;
+1 NEW CPTIEN,DATE,IEN,RORCPT,VDATE
+2 DO GETCPT^SDOE(Y,"RORCPT")
+3 if $GET(RORCPT)'>0
QUIT
+4 SET VDATE=+$PIECE(Y0,U)
+5 ;---
+6 SET IEN=0
+7 FOR
SET IEN=$ORDER(RORCPT(IEN))
if IEN'>0
QUIT
Begin DoDot:1
+8 SET CPTIEN=+$PIECE(RORCPT(IEN),U)
SET DATE=+$PIECE($GET(RORCPT(IEN,12)),U)
+9 if CPTIEN>0
DO PROCSET(PTIEN,"O",CPTIEN,$SELECT(DATE>0:DATE,1:VDATE))
End DoDot:1
+10 QUIT
+11 ;
+12 ;***** SEARCHES FOR OUTPATIENT PROCEDURES
+13 ;
+14 ; PTIEN Patient IEN (DFN)
+15 ;
+16 ; Return Values:
+17 ; <0 Error code
+18 ; 0 Ok
+19 ; >0 Number of non-fatal errors
+20 ;
OUTPAT(PTIEN) ;
+1 NEW QUERY
+2 DO OPEN^SDQ(.QUERY)
+3 DO INDEX^SDQ(.QUERY,"PATIENT/DATE","SET")
+4 DO PAT^SDQ(.QUERY,PTIEN,"SET")
+5 DO DATE^SDQ(.QUERY,RORSDT,ROREDT1,"SET")
+6 DO SCANCB^SDQ(.QUERY,"D OPSCAN^RORX015A("_PTIEN_")","SET")
+7 DO ACTIVE^SDQ(.QUERY,"TRUE","SET")
+8 DO SCAN^SDQ(.QUERY,"FORWARD")
+9 DO CLOSE^SDQ(.QUERY)
+10 QUIT 0
+11 ;
+12 ;**** STORES THE PROCEDURE CODE
+13 ;
+14 ; PTIEN Patient IEN (DFN)
+15 ; SOURCE CPT source code ("O" or "I")
+16 ; [IEN] IEN of the procedure descriptor (file #81 or #80.1)
+17 ; DATE Date when the code was entered
+18 ; [CODE] Procedure code (CPT or ICD-9)
+19 ;
+20 ; Either the IEN or the CODE parameter must be provided.
+21 ;
PROCSET(PTIEN,SOURCE,IEN,DATE,CODE) ;
+1 if DATE'>0
QUIT
+2 NEW TMP
+3 SET IEN=+$GET(IEN)
+4 ;---
+5 IF IEN'>0
if $GET(CODE)=""
QUIT
Begin DoDot:1
+6 IF SOURCE="O"
SET IEN=+$$CODEN^ICPTCOD(CODE)
QUIT
+7 IF SOURCE="I"
SET IEN=+$$CODEN^ICDEX(CODE,80.1)
QUIT
End DoDot:1
if IEN'>0
QUIT
+8 ;---
+9 IF SOURCE="O"
IF '$$PARAM^RORTSK01("CPTLST","ALL")
Begin DoDot:1
+10 SET TMP=$DATA(RORTSK("PARAMS","CPTLST","C",IEN))
End DoDot:1
if 'TMP
QUIT
+11 IF SOURCE="I"
if $$ICDGRCHK^RORXU008(.RORPTGRP,IEN,RORICDL)
QUIT
+12 ;---
+13 SET TMP=+$GET(@RORTMP@("PAT",PTIEN,SOURCE,IEN))
+14 if 'TMP!(DATE<TMP)
SET @RORTMP@("PAT",PTIEN,SOURCE,IEN)=DATE
+15 ;naked reference: ^TMP($J,"RORTMP-n") from RORX015
SET ^("C")=$GET(@RORTMP@("PAT",PTIEN,SOURCE,IEN,"C"))+1
+16 QUIT
+17 ;
+18 ;***** QUERIES THE REGISTRY
+19 ;
+20 ; FLAGS Flags for the $$SKIP^RORXU005
+21 ;
+22 ; Return Values:
+23 ; <0 Error code
+24 ; 0 Ok
+25 ; >0 Number of non-fatal errors
+26 ;
QUERY(FLAGS) ;
+1 ; Day after the end date
NEW ROREDT1
+2 ; Temporary list of ICD groups
NEW RORPTGRP
+3 ; Number of patients in the registry
NEW RORPTN
+4 ; Flag to indicate whether a clinic or division list exists
NEW RORCDLIST
+5 ; Start date for clinic/division utilization search
NEW RORCDSTDT
+6 ; End date for clinic/division utilization search
NEW RORCDENDT
+7 ;
+8 NEW CNT,ECNT,IEN,IENS,MODE,PTIEN,RC,SKIP,SKIPEDT,SKIPSDT,TMP,UTEDT,UTSDT,XREFNODE
+9 NEW RCC,FLAG,UTIL
+10 SET XREFNODE=$NAME(^RORDATA(798,"AC",+RORREG))
+11 SET ROREDT1=$$FMADD^XLFDT(ROREDT\1,1)
+12 SET (CNT,ECNT,RC)=0
SET SKIPEDT=ROREDT
SET SKIPSDT=RORSDT
+13 if $$PARAM^RORTSK01("PATIENTS","INPATIENT")
SET MODE("I")=1
+14 if $$PARAM^RORTSK01("PATIENTS","OUTPATIENT")
SET MODE("O")=1
+15 ;--- Utilization date range
+16 if $$PARAM^RORTSK01("PATIENTS","CAREONLY")
Begin DoDot:1
+17 SET UTSDT=$$PARAM^RORTSK01("DATE_RANGE_3","START")\1
+18 SET UTEDT=$$PARAM^RORTSK01("DATE_RANGE_3","END")\1
+19 ;--- Combined date range
+20 SET SKIPSDT=$$DTMIN^RORUTL18(SKIPSDT,UTSDT)
+21 SET SKIPEDT=$$DTMAX^RORUTL18(SKIPEDT,UTEDT)
End DoDot:1
+22 ;--- Number of patients in the registry
+23 SET RORPTN=$$REGSIZE^RORUTL02(+RORREG)
if RORPTN<0
SET RORPTN=0
+24 ;
+25 ;=== Set up Clinic/Division list parameters
+26 SET RORCDLIST=$$CDPARMS^RORXU001(.RORTSK,.RORCDSTDT,.RORCDENDT,1)
+27 ;
+28 ;=== Browse through the registry records
+29 SET IEN=0
+30 SET FLAG=$GET(RORTSK("PARAMS","ICDFILT","A","FILTER"))
+31 FOR
SET IEN=$ORDER(@XREFNODE@(IEN))
if IEN'>0
QUIT
Begin DoDot:1
+32 SET TMP=$SELECT(RORPTN>0:CNT/RORPTN,1:"")
+33 SET RC=$$LOOP^RORTSK01(TMP)
if RC<0
QUIT
+34 SET IENS=IEN_","
SET CNT=CNT+1
+35 ;--- Get patient DFN
+36 SET PTIEN=$$PTIEN^RORUTL01(IEN)
if PTIEN'>0
QUIT
+37 ;--- Check for patient list and quit if not on list
+38 IF $DATA(RORTSK("PARAMS","PATIENTS","C"))
IF '$DATA(RORTSK("PARAMS","PATIENTS","C",PTIEN))
QUIT
+39 ;--- Check if the patient should be skipped
+40 if $$SKIP^RORXU005(IEN,FLAGS,SKIPSDT,SKIPEDT)
QUIT
+41 ;--- Check if patient has passed the ICD Filter
+42 SET RCC=0
+43 IF FLAG'="ALL"
Begin DoDot:2
+44 SET RCC=$$ICD^RORXU010(PTIEN)
End DoDot:2
+45 IF (FLAG="INCLUDE")&(RCC=0)
QUIT
+46 IF (FLAG="EXCLUDE")&(RCC=1)
QUIT
+47 ;--- End of ICD check
+48 MERGE RORPTGRP=RORIGRP("C")
+49 ;
+50 ;--- Check for Clinic or Division list and quit if not in list
+51 IF RORCDLIST
IF '$$CDUTIL^RORXU001(.RORTSK,PTIEN,RORCDSTDT,RORCDENDT)
QUIT
+52 ;
+53 ;--- Inpatient codes (ICD)
+54 IF $GET(MODE("I"))
Begin DoDot:2
+55 SET RC=$$INPAT(PTIEN)
End DoDot:2
IF RC
if RC<0
QUIT
SET ECNT=ECNT+RC
+56 ;--- Outpatient codes (CPT)
+57 IF $GET(MODE("O"))
Begin DoDot:2
+58 SET RC=$$OUTPAT(PTIEN)
End DoDot:2
IF RC
if RC<0
QUIT
SET ECNT=ECNT+RC
+59 ;
+60 ;--- If ICD codes from some groups have not been found,
+61 ;--- then do not consider inpatient procedures at all
+62 if $DATA(RORPTGRP)>1
KILL @RORTMP@("PAT",PTIEN,"I")
+63 ;---
+64 SET SKIP=($DATA(@RORTMP@("PAT",PTIEN))<10)
+65 if RORPROC<0
SET SKIP='SKIP
+66 ;
+67 ;--- Check for any utilization in the corresponding date range
+68 IF 'SKIP
if $$PARAM^RORTSK01("PATIENTS","CAREONLY")
Begin DoDot:2
+69 KILL TMP
SET TMP("ALL")=1
+70 SET UTIL=+$$UTIL^RORXU003(UTSDT,UTEDT,PTIEN,.TMP)
+71 if 'UTIL
SET SKIP=1
End DoDot:2
+72 ;
+73 ;--- Skip the patient if not all search criteria have been met
+74 IF SKIP
KILL @RORTMP@("PAT",PTIEN)
QUIT
+75 ;
+76 ;--- Calculate the patient's totals
+77 SET RC=$$TOTALS(PTIEN)
+78 IF RC
if RC<0
QUIT
SET ECNT=ECNT+RC
End DoDot:1
if RC<0
QUIT
+79 ;---
+80 QUIT $SELECT(RC<0:RC,1:ECNT)
+81 ;
+82 ;***** SORTS THE RESULTS AND COMPILES THE TOTALS
+83 ;
+84 ; Return Values:
+85 ; <0 Error code
+86 ; 0 Ok
+87 ; >0 Number of non-fatal errors
+88 ;
SORT() ;
+1 NEW IEN,SRC,TMP,TNC,TNDC
+2 ;---
+3 SET (TNC,TNDC)=0
+4 FOR SRC="I","O"
Begin DoDot:1
+5 SET IEN=0
+6 FOR
SET IEN=$ORDER(@RORTMP@("PROC",SRC,IEN))
if IEN'>0
QUIT
Begin DoDot:2
+7 SET TMP=$PIECE($GET(@RORTMP@("PROC",SRC,IEN)),U,2)
+8 if TMP'=""
SET @RORTMP@("PROC","B",TMP,SRC,IEN)=""
+9 SET TNC=TNC+$GET(@RORTMP@("PROC",SRC,IEN,"C"))
+10 SET TNDC=TNDC+1
End DoDot:2
End DoDot:1
+11 SET @RORTMP@("PROC")=TNC_U_TNDC
+12 ;---
+13 QUIT 0
+14 ;
+15 ;***** CALCULATES INTERMEDIATE TOTALS
+16 ;
+17 ; PTIEN Patient IEN (DFN)
+18 ;
+19 ; Return Values:
+20 ; <0 Error code
+21 ; 0 Ok
+22 ; >0 Number of non-fatal errors
+23 ;
TOTALS(PTIEN) ;
+1 NEW CNT,CODE,IEN,NAME,PNODE,RC,SRC,TMP,TMP1,TMP2,VA,VADM,AGE,AGETYPE,RORAPPT,RORAPPTINFO,RORCLIN
+2 SET PNODE=$NAME(@RORTMP@("PAT",PTIEN))
+3 ;--- Get and store the patient's data
+4 DO VADEM^RORUTL05(PTIEN,1)
+5 SET TMP=$SELECT($$PARAM^RORTSK01("PATIENTS","ICN"):$$ICN^RORUTL02(PTIEN),1:"")
+6 SET TMP1=$SELECT($$PARAM^RORTSK01("PATIENTS","PACT"):$$PACT^RORUTL02(PTIEN),1:"")
+7 SET TMP2=$SELECT($$PARAM^RORTSK01("PATIENTS","PCP"):$$PCP^RORUTL02(PTIEN),1:"")
+8 SET AGETYPE=$$PARAM^RORTSK01("AGE_RANGE","TYPE")
+9 SET AGE=$SELECT(AGETYPE="AGE":$PIECE(VADM(4),U),AGETYPE="DOB":$$DATE^RORXU002($PIECE(VADM(3),U)\1),1:"")
+10 ;patch 34
IF $$PARAM^RORTSK01("OPTIONS","FUT_APPT")
Begin DoDot:1
+11 SET RORAPPTINFO=$$FUTAPPT^RORUTL02(PTIEN,$$PARAM^RORTSK01("OPTIONS","FUT_APPT"))
+12 SET RORAPPT=$PIECE(RORAPPTINFO,U,1)
SET RORCLIN=$PIECE(RORAPPTINFO,U,2)
End DoDot:1
+13 SET @PNODE=VA("BID")_U_VADM(1)_U_$$DATE^RORXU002(VADM(6)\1)_U_TMP_U_TMP1_U_TMP2_U_AGE_U_$GET(RORAPPT)_U_$GET(RORCLIN)
+14 ;naked reference: ^TMP($J,"RORTMP-n") from RORX015
SET ^("PAT")=$GET(@RORTMP@("PAT"))+1
+15 ;
+16 FOR SRC="I","O"
Begin DoDot:1
+17 SET IEN=0
+18 FOR
SET IEN=$ORDER(@PNODE@(SRC,IEN))
if IEN'>0
QUIT
Begin DoDot:2
+19 SET CODE=$PIECE($GET(@RORTMP@("PROC",SRC,IEN)),U)
SET NAME=""
+20 if CODE=""
Begin DoDot:3
+21 IF SRC="O"
Begin DoDot:4
+22 SET TMP=$$CPT^ICPTCOD(IEN)
+23 if TMP'<0
SET CODE=$PIECE(TMP,U,2)
SET NAME=$PIECE(TMP,U,3)
End DoDot:4
+24 IF '$TEST
Begin DoDot:4
+25 ;S TMP=$$ICDOP^ICDCODE(IEN)
+26 ;S:TMP'<0 CODE=$P(TMP,U,2),NAME=$P(TMP,U,5)
+27 SET CODE=$$CODEC^ICDEX(80.1,IEN)
+28 SET NAME=$$VSTP^ICDEX(IEN)
End DoDot:4
+29 if CODE=""
SET CODE="UNKN"
+30 if NAME=""
SET NAME="Unknown ("_IEN_")"
+31 SET @RORTMP@("PROC",SRC,IEN)=CODE_U_NAME
End DoDot:3
+32 ;---
+33 SET CNT=+$GET(@PNODE@(SRC,IEN,"C"))
+34 ;naked reference: ^TMP($J,"RORTMP-n") from RORX015
SET ^("C")=$GET(@RORTMP@("PROC",SRC,IEN,"C"))+CNT
+35 ;naked reference: ^TMP($J,"RORTMP-n") from RORX015
SET ^("P")=$GET(@RORTMP@("PROC",SRC,IEN,"P"))+1
End DoDot:2
End DoDot:1
+36 QUIT 0
