- RORX007 ;HCIOFO/BH,SG - RADIOLOGY UTILIZATION ;10/14/05 1:37pm
- ;;1.5;CLINICAL CASE REGISTRIES;**21,31,39**;Feb 17, 2006;Build 4
- ;
- ; This routine uses the following IAs:
- ;
- ; #10061 DEM^VADPT (supported)
- ;
- ;******************************************************************************
- ; --- ROUTINE MODIFICATION LOG ---
- ;
- ;PKG/PATCH DATE DEVELOPER MODIFICATION
- ;----------- ---------- ----------- ----------------------------------------
- ;ROR*1.5*21 SEP 2013 T KOPP Added ICN as last report column if
- ; additional identifier option selected
- ;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
- ;
- ;***** COMPILES THE "RADIOLOGY UTILIZATION" REPORT
- ; REPORT CODE: 007
- ;
- ; .RORTSK Task number and task parameters
- ;
- ; The ^TMP("RORX007",$J) and ^TMP($J,"RAE1") global nodes are
- ; used by this function.
- ;
- ; ^TMP("RORX007",$J,
- ;
- ; "PAT",
- ; DFN,
- ; ProcName) Number of procedures
- ;
- ; "PATSORT",
- ; ProcQnty,
- ; Name,
- ; Last4) Patient data
- ; ^01: Number of different procedures
- ; ^02: Date of death
- ; ^03: National ICN
- ; ^04: Patient Care Team
- ; ^05: Primary Care Provider
- ; ^06: AGE/DOB
- ;
- ; "PROC",
- ; ProcName,
- ; DFN) Number of procedures
- ;
- ; "PROCSORT",
- ; ProcQnty,
- ; ProcName,
- ; CPT) Number of individual patients
- ;
- ; "TOTAL") Category Totals
- ; ^01: Total number of procedures
- ; ^02: Number of different procedures
- ; ^03: Total number of patients
- ; ^04: Number of individual patients
- ;
- ; Return Values:
- ; <0 Error code
- ; 0 Ok
- ;
- RADUTL(RORTSK) ;
- N ROREDT ; End date
- N RORREG ; Registry IEN
- N RORSDT ; Start date
- ;
- N CNT,ECNT,RC,REPORT,RORPTN,SFLAGS,TMP
- ;--- Root node of the report
- S REPORT=$$ADDVAL^RORTSK11(RORTSK,"REPORT")
- Q:REPORT<0 REPORT
- ;
- ;--- Get and prepare the report parameters
- S RORREG=$$PARAM^RORTSK01("REGIEN")
- S RC=$$PARAMS^RORX007A(REPORT,.RORSDT,.ROREDT,.SFLAGS)
- Q:RC<0 RC
- ;
- ;--- Initialize constants and variables
- S RORPTN=$$REGSIZE^RORUTL02(+RORREG) S:RORPTN<0 RORPTN=0
- S ECNT=0 K ^TMP("RORX007",$J)
- ;
- ;--- Report header
- S RC=$$HEADER^RORX007A(REPORT) Q:RC<0 RC
- ;
- D
- . ;--- Query the registry
- . D TPPSETUP^RORTSK01(75)
- . S RC=$$QUERY^RORX007A(SFLAGS)
- . I RC Q:RC<0 S ECNT=ECNT+RC
- . ;--- Sort the data
- . D TPPSETUP^RORTSK01(10)
- . S RC=$$SORT()
- . I RC Q:RC<0 S ECNT=ECNT+RC
- . ;--- Store the results
- . D TPPSETUP^RORTSK01(15)
- . S RC=$$STORE(REPORT)
- . I RC Q:RC<0 S ECNT=ECNT+RC
- ;
- ;--- Cleanup
- K ^TMP("RORX007",$J),^TMP($J,"RAE1")
- Q $S(RC<0:RC,ECNT>0:-43,1:0)
- ;
- ;***** SORTS THE RESULTS AND COMPILES THE TOTALS
- ;
- ; SPCNT Number of patients selected for the report
- ;
- ; Return Values:
- ; <0 Error code
- ; 0 Ok
- ; >0 Number of non-fatal errors
- ;
- SORT(SPCNT) ;
- N DFN,DOD,DPCNT,ECNT,ICN,NAME,NODE,PACT,PCP,PRCNT,PQ,PRN,RC,TMP,TOTAL,VA,VADM,VAHOW,VAROOT,AGETYPE,AGE
- S (ECNT,RC)=0
- S NODE=$NA(^TMP("RORX007",$J))
- Q:$D(@NODE)<10 0
- ;--- Procedures
- S RC=$$LOOP^RORTSK01(0) Q:RC<0 RC
- S PRN=""
- F S PRN=$O(@NODE@("PROC",PRN)) Q:PRN="" D
- . S (DPCNT,PRCNT)=0
- . S DFN=""
- . F S DFN=$O(@NODE@("PROC",PRN,DFN)) Q:DFN="" D
- . . S PQ=$G(@NODE@("PROC",PRN,DFN))
- . . S DPCNT=DPCNT+1,PRCNT=PRCNT+PQ
- . ;---
- . S @NODE@("PROCSORT",PRCNT,$P(PRN,U),$P(PRN,U,2))=DPCNT
- . S TOTAL("DPR")=$G(TOTAL("DPR"))+1 ; Different procedures
- . S TOTAL("TPT")=$G(TOTAL("TPT"))+DPCNT ; Number of patients
- K @NODE@("PROC")
- ;--- Patients
- S RC=$$LOOP^RORTSK01(0.5) Q:RC<0 RC
- S DFN=""
- F S DFN=$O(@NODE@("PAT",DFN)) Q:DFN="" D
- . S (DPCNT,PRCNT)=0
- . D DEM^VADPT
- . S NAME=$G(VADM(1)) Q:NAME=""
- . S LAST4="0000" ;S LAST4=$G(VA("BID")) S:LAST4="" LAST4=" "
- . S DOD=$$DATE^RORXU002($P(VADM(6),U)\1)
- . S ICN=$$ICN^RORUTL02(DFN)
- . S PACT=$$PACT^RORUTL02(DFN)
- . S PCP=$$PCP^RORUTL02(DFN)
- . 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:"")
- . S PRN=""
- . F S PRN=$O(@NODE@("PAT",DFN,PRN)) Q:PRN="" D
- . . S PQ=$G(@NODE@("PAT",DFN,PRN))
- . . S DPCNT=DPCNT+1,PRCNT=PRCNT+PQ
- . ;---
- . S PACT=$S($$PARAM^RORTSK01("PATIENTS","PACT"):PACT,1:"")
- . S PCP=$S($$PARAM^RORTSK01("PATIENTS","PCP"):PCP,1:"")
- . S @NODE@("PATSORT",PRCNT,NAME,LAST4)=DPCNT_U_DOD_U_$S($$PARAM^RORTSK01("PATIENTS","ICN"):ICN,1:"")_U_PACT_U_PCP_U_AGE
- . S TOTAL("TPR")=$G(TOTAL("TPR"))+PRCNT ; Number of procedures
- . S TOTAL("DPT")=$G(TOTAL("DPT"))+1 ; Different patients
- K @NODE@("PAT")
- ;--- Totals
- S TMP=$G(TOTAL("TPR"))_U_$G(TOTAL("DPR"))
- S @NODE@("TOTAL")=TMP_U_$G(TOTAL("TPT"))_U_$G(TOTAL("DPT"))
- ;---
- Q $S(RC<0:RC,1:ECNT)
- ;
- ;***** STORES THE RESULTS
- ;
- ; Return Values:
- ; <0 Error code
- ; 0 Ok
- ; >0 Number of non-fatal errors
- ;
- STORE(PARTAG) ;
- N RORSONLY ; Output summary only
- ;
- N RC,TMP
- S RORSONLY=$$SMRYONLY^RORXU006()
- S RC=0
- ;--- Tables
- Q:$D(^TMP("RORX007",$J))<10 0
- ;--- Procedures
- S RC=$$LOOP^RORTSK01(0) Q:RC<0 RC
- S RC=$$TBLPROC(PARTAG) Q:RC<0 RC
- ;--- Patients
- S RC=$$LOOP^RORTSK01(0.5) Q:RC<0 RC
- S RC=$$TBLPAT(PARTAG) Q:RC<0 RC
- ;--- Totals
- S TMP=$G(^TMP("RORX007",$J,"TOTAL"))
- D ADDVAL^RORTSK11(RORTSK,"NPR",$P(TMP,U,1),PARTAG)
- D ADDVAL^RORTSK11(RORTSK,"NDP",$P(TMP,U,2),PARTAG)
- D ADDVAL^RORTSK11(RORTSK,"NP",$P(TMP,U,4),PARTAG)
- ;---
- Q $S(RC<0:RC,1:0)
- ;
- ;***** STORES THE TABLE OF PATIENTS
- ;
- ; PRNTELMT IEN of the parent tag
- ;
- ; Return Values:
- ; <0 Error code
- ; 0 Ok
- ;
- TBLPAT(PRNTELMT) ;
- N BUF,ITEM,LAST4,MAXUTNUM,NAME,NODE,PRCNT,RC,TABLE,TMP,UTNUM
- S MAXUTNUM=$$PARAM^RORTSK01("MAXUTNUM")
- Q:MAXUTNUM'>0 0
- S TABLE=$$ADDVAL^RORTSK11(RORTSK,"PATIENTS",,PRNTELMT)
- Q:TABLE<0 TABLE
- D ADDATTR^RORTSK11(RORTSK,TABLE,"TABLE","PATIENTS")
- S NODE=$NA(^TMP("RORX007",$J,"PATSORT"))
- ;--- Table
- S PRCNT="",(RC,UTNUM)=0
- F S PRCNT=$O(@NODE@(PRCNT),-1) Q:PRCNT="" D Q:RC
- . S NAME=""
- . F S NAME=$O(@NODE@(PRCNT,NAME)) Q:NAME="" D Q:RC
- . . S LAST4=""
- . . F S LAST4=$O(@NODE@(PRCNT,NAME,LAST4)) Q:LAST4="" D Q:RC
- . . . S ITEM=$$ADDVAL^RORTSK11(RORTSK,"PATIENT",,TABLE)
- . . . D ADDVAL^RORTSK11(RORTSK,"NAME",NAME,ITEM,1)
- . . . D ADDVAL^RORTSK11(RORTSK,"LAST4",LAST4,ITEM,1)
- . . . S BUF=@NODE@(PRCNT,NAME,LAST4)
- . . . S AGETYPE=$$PARAM^RORTSK01("AGE_RANGE","TYPE") I AGETYPE'="ALL" D
- . . . . D ADDVAL^RORTSK11(RORTSK,AGETYPE,$P(BUF,U,6),ITEM,1)
- . . . D ADDVAL^RORTSK11(RORTSK,"DOD",$P(BUF,U,2),ITEM,1)
- . . . D ADDVAL^RORTSK11(RORTSK,"TOTAL",PRCNT,ITEM,1)
- . . . D ADDVAL^RORTSK11(RORTSK,"UNIQUE",+BUF,ITEM,1)
- . . . I $$PARAM^RORTSK01("PATIENTS","ICN") D
- . . . . D ADDVAL^RORTSK11(RORTSK,"ICN",$P(BUF,U,3),ITEM,1)
- . . . I $$PARAM^RORTSK01("PATIENTS","PACT") D
- . . . . D ADDVAL^RORTSK11(RORTSK,"PACT",$P(BUF,U,4),ITEM,1)
- . . . I $$PARAM^RORTSK01("PATIENTS","PCP") D
- . . . . D ADDVAL^RORTSK11(RORTSK,"PCP",$P(BUF,U,5),ITEM,1)
- . . . S UTNUM=UTNUM+1 S:UTNUM'<MAXUTNUM RC=1
- Q:RC<0 RC
- ;---
- Q $S(RC<0:RC,1:0)
- ;
- ;***** STORES THE TABLE OF PROCEDURES
- ;
- ; PRNTELMT IEN of the parent tag
- ;
- ; Return Values:
- ; <0 Error code
- ; 0 Ok
- ;
- TBLPROC(PRNTELMT) ;
- N CPT,ITEM,MINRPNUM,NODE,PRCNT,PRN,TABLE,TMP
- S MINRPNUM=$$PARAM^RORTSK01("MINRPNUM")
- Q:MINRPNUM'>0 0
- S TABLE=$$ADDVAL^RORTSK11(RORTSK,"PROCEDURES",,PRNTELMT)
- Q:TABLE<0 TABLE
- D ADDATTR^RORTSK11(RORTSK,TABLE,"TABLE","PROCEDURES")
- S NODE=$NA(^TMP("RORX007",$J,"PROCSORT"))
- ;--- Table
- S PRCNT="",RC=0
- F S PRCNT=$O(@NODE@(PRCNT),-1) Q:PRCNT<MINRPNUM D Q:RC
- . S PRN=""
- . F S PRN=$O(@NODE@(PRCNT,PRN)) Q:PRN="" D Q:RC
- . . S CPT=""
- . . F S CPT=$O(@NODE@(PRCNT,PRN,CPT)) Q:CPT="" D Q:RC
- . . . S ITEM=$$ADDVAL^RORTSK11(RORTSK,"PROCEDURE",,TABLE)
- . . . D ADDVAL^RORTSK11(RORTSK,"NAME",PRN,ITEM,1)
- . . . D ADDVAL^RORTSK11(RORTSK,"CPT",CPT,ITEM,2)
- . . . S TMP=+@NODE@(PRCNT,PRN,CPT)
- . . . D ADDVAL^RORTSK11(RORTSK,"PATIENTS",TMP,ITEM,1)
- . . . D ADDVAL^RORTSK11(RORTSK,"TOTAL",PRCNT,ITEM,1)
- Q:RC<0 RC
- ;---
- Q $S(RC<0:RC,1:0)
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRORX007 8876 printed Mar 13, 2025@20:49:07 Page 2
- RORX007 ;HCIOFO/BH,SG - RADIOLOGY UTILIZATION ;10/14/05 1:37pm
- +1 ;;1.5;CLINICAL CASE REGISTRIES;**21,31,39**;Feb 17, 2006;Build 4
- +2 ;
- +3 ; This routine uses the following IAs:
- +4 ;
- +5 ; #10061 DEM^VADPT (supported)
- +6 ;
- +7 ;******************************************************************************
- +8 ; --- ROUTINE MODIFICATION LOG ---
- +9 ;
- +10 ;PKG/PATCH DATE DEVELOPER MODIFICATION
- +11 ;----------- ---------- ----------- ----------------------------------------
- +12 ;ROR*1.5*21 SEP 2013 T KOPP Added ICN as last report column if
- +13 ; additional identifier option selected
- +14 ;ROR*1.5*31 MAY 2017 M FERRARESE Adding PACT, PCP, and AGE/DOB as additional
- +15 ; identifiers.
- +16 ;ROR*1.5*39 JUL 2021 M FERRARESE Setting SSN and LAST4 to zeros
- +17 ;******************************************************************************
- +18 QUIT
- +19 ;
- +20 ;***** COMPILES THE "RADIOLOGY UTILIZATION" REPORT
- +21 ; REPORT CODE: 007
- +22 ;
- +23 ; .RORTSK Task number and task parameters
- +24 ;
- +25 ; The ^TMP("RORX007",$J) and ^TMP($J,"RAE1") global nodes are
- +26 ; used by this function.
- +27 ;
- +28 ; ^TMP("RORX007",$J,
- +29 ;
- +30 ; "PAT",
- +31 ; DFN,
- +32 ; ProcName) Number of procedures
- +33 ;
- +34 ; "PATSORT",
- +35 ; ProcQnty,
- +36 ; Name,
- +37 ; Last4) Patient data
- +38 ; ^01: Number of different procedures
- +39 ; ^02: Date of death
- +40 ; ^03: National ICN
- +41 ; ^04: Patient Care Team
- +42 ; ^05: Primary Care Provider
- +43 ; ^06: AGE/DOB
- +44 ;
- +45 ; "PROC",
- +46 ; ProcName,
- +47 ; DFN) Number of procedures
- +48 ;
- +49 ; "PROCSORT",
- +50 ; ProcQnty,
- +51 ; ProcName,
- +52 ; CPT) Number of individual patients
- +53 ;
- +54 ; "TOTAL") Category Totals
- +55 ; ^01: Total number of procedures
- +56 ; ^02: Number of different procedures
- +57 ; ^03: Total number of patients
- +58 ; ^04: Number of individual patients
- +59 ;
- +60 ; Return Values:
- +61 ; <0 Error code
- +62 ; 0 Ok
- +63 ;
- RADUTL(RORTSK) ;
- +1 ; End date
- NEW ROREDT
- +2 ; Registry IEN
- NEW RORREG
- +3 ; Start date
- NEW RORSDT
- +4 ;
- +5 NEW CNT,ECNT,RC,REPORT,RORPTN,SFLAGS,TMP
- +6 ;--- Root node of the report
- +7 SET REPORT=$$ADDVAL^RORTSK11(RORTSK,"REPORT")
- +8 if REPORT<0
- QUIT REPORT
- +9 ;
- +10 ;--- Get and prepare the report parameters
- +11 SET RORREG=$$PARAM^RORTSK01("REGIEN")
- +12 SET RC=$$PARAMS^RORX007A(REPORT,.RORSDT,.ROREDT,.SFLAGS)
- +13 if RC<0
- QUIT RC
- +14 ;
- +15 ;--- Initialize constants and variables
- +16 SET RORPTN=$$REGSIZE^RORUTL02(+RORREG)
- if RORPTN<0
- SET RORPTN=0
- +17 SET ECNT=0
- KILL ^TMP("RORX007",$JOB)
- +18 ;
- +19 ;--- Report header
- +20 SET RC=$$HEADER^RORX007A(REPORT)
- if RC<0
- QUIT RC
- +21 ;
- +22 Begin DoDot:1
- +23 ;--- Query the registry
- +24 DO TPPSETUP^RORTSK01(75)
- +25 SET RC=$$QUERY^RORX007A(SFLAGS)
- +26 IF RC
- if RC<0
- QUIT
- SET ECNT=ECNT+RC
- +27 ;--- Sort the data
- +28 DO TPPSETUP^RORTSK01(10)
- +29 SET RC=$$SORT()
- +30 IF RC
- if RC<0
- QUIT
- SET ECNT=ECNT+RC
- +31 ;--- Store the results
- +32 DO TPPSETUP^RORTSK01(15)
- +33 SET RC=$$STORE(REPORT)
- +34 IF RC
- if RC<0
- QUIT
- SET ECNT=ECNT+RC
- End DoDot:1
- +35 ;
- +36 ;--- Cleanup
- +37 KILL ^TMP("RORX007",$JOB),^TMP($JOB,"RAE1")
- +38 QUIT $SELECT(RC<0:RC,ECNT>0:-43,1:0)
- +39 ;
- +40 ;***** SORTS THE RESULTS AND COMPILES THE TOTALS
- +41 ;
- +42 ; SPCNT Number of patients selected for the report
- +43 ;
- +44 ; Return Values:
- +45 ; <0 Error code
- +46 ; 0 Ok
- +47 ; >0 Number of non-fatal errors
- +48 ;
- SORT(SPCNT) ;
- +1 NEW DFN,DOD,DPCNT,ECNT,ICN,NAME,NODE,PACT,PCP,PRCNT,PQ,PRN,RC,TMP,TOTAL,VA,VADM,VAHOW,VAROOT,AGETYPE,AGE
- +2 SET (ECNT,RC)=0
- +3 SET NODE=$NAME(^TMP("RORX007",$JOB))
- +4 if $DATA(@NODE)<10
- QUIT 0
- +5 ;--- Procedures
- +6 SET RC=$$LOOP^RORTSK01(0)
- if RC<0
- QUIT RC
- +7 SET PRN=""
- +8 FOR
- SET PRN=$ORDER(@NODE@("PROC",PRN))
- if PRN=""
- QUIT
- Begin DoDot:1
- +9 SET (DPCNT,PRCNT)=0
- +10 SET DFN=""
- +11 FOR
- SET DFN=$ORDER(@NODE@("PROC",PRN,DFN))
- if DFN=""
- QUIT
- Begin DoDot:2
- +12 SET PQ=$GET(@NODE@("PROC",PRN,DFN))
- +13 SET DPCNT=DPCNT+1
- SET PRCNT=PRCNT+PQ
- End DoDot:2
- +14 ;---
- +15 SET @NODE@("PROCSORT",PRCNT,$PIECE(PRN,U),$PIECE(PRN,U,2))=DPCNT
- +16 ; Different procedures
- SET TOTAL("DPR")=$GET(TOTAL("DPR"))+1
- +17 ; Number of patients
- SET TOTAL("TPT")=$GET(TOTAL("TPT"))+DPCNT
- End DoDot:1
- +18 KILL @NODE@("PROC")
- +19 ;--- Patients
- +20 SET RC=$$LOOP^RORTSK01(0.5)
- if RC<0
- QUIT RC
- +21 SET DFN=""
- +22 FOR
- SET DFN=$ORDER(@NODE@("PAT",DFN))
- if DFN=""
- QUIT
- Begin DoDot:1
- +23 SET (DPCNT,PRCNT)=0
- +24 DO DEM^VADPT
- +25 SET NAME=$GET(VADM(1))
- if NAME=""
- QUIT
- +26 ;S LAST4=$G(VA("BID")) S:LAST4="" LAST4=" "
- SET LAST4="0000"
- +27 SET DOD=$$DATE^RORXU002($PIECE(VADM(6),U)\1)
- +28 SET ICN=$$ICN^RORUTL02(DFN)
- +29 SET PACT=$$PACT^RORUTL02(DFN)
- +30 SET PCP=$$PCP^RORUTL02(DFN)
- +31 SET AGETYPE=$$PARAM^RORTSK01("AGE_RANGE","TYPE")
- Begin DoDot:2
- +32 SET AGE=$SELECT(AGETYPE="AGE":$PIECE(VADM(4),U),AGETYPE="DOB":$$DATE^RORXU002($PIECE(VADM(3),U)\1),1:"")
- End DoDot:2
- +33 SET PRN=""
- +34 FOR
- SET PRN=$ORDER(@NODE@("PAT",DFN,PRN))
- if PRN=""
- QUIT
- Begin DoDot:2
- +35 SET PQ=$GET(@NODE@("PAT",DFN,PRN))
- +36 SET DPCNT=DPCNT+1
- SET PRCNT=PRCNT+PQ
- End DoDot:2
- +37 ;---
- +38 SET PACT=$SELECT($$PARAM^RORTSK01("PATIENTS","PACT"):PACT,1:"")
- +39 SET PCP=$SELECT($$PARAM^RORTSK01("PATIENTS","PCP"):PCP,1:"")
- +40 SET @NODE@("PATSORT",PRCNT,NAME,LAST4)=DPCNT_U_DOD_U_$SELECT($$PARAM^RORTSK01("PATIENTS","ICN"):ICN,1:"")_U_PACT_U_PCP_U_AGE
- +41 ; Number of procedures
- SET TOTAL("TPR")=$GET(TOTAL("TPR"))+PRCNT
- +42 ; Different patients
- SET TOTAL("DPT")=$GET(TOTAL("DPT"))+1
- End DoDot:1
- +43 KILL @NODE@("PAT")
- +44 ;--- Totals
- +45 SET TMP=$GET(TOTAL("TPR"))_U_$GET(TOTAL("DPR"))
- +46 SET @NODE@("TOTAL")=TMP_U_$GET(TOTAL("TPT"))_U_$GET(TOTAL("DPT"))
- +47 ;---
- +48 QUIT $SELECT(RC<0:RC,1:ECNT)
- +49 ;
- +50 ;***** STORES THE RESULTS
- +51 ;
- +52 ; Return Values:
- +53 ; <0 Error code
- +54 ; 0 Ok
- +55 ; >0 Number of non-fatal errors
- +56 ;
- STORE(PARTAG) ;
- +1 ; Output summary only
- NEW RORSONLY
- +2 ;
- +3 NEW RC,TMP
- +4 SET RORSONLY=$$SMRYONLY^RORXU006()
- +5 SET RC=0
- +6 ;--- Tables
- +7 if $DATA(^TMP("RORX007",$JOB))<10
- QUIT 0
- +8 ;--- Procedures
- +9 SET RC=$$LOOP^RORTSK01(0)
- if RC<0
- QUIT RC
- +10 SET RC=$$TBLPROC(PARTAG)
- if RC<0
- QUIT RC
- +11 ;--- Patients
- +12 SET RC=$$LOOP^RORTSK01(0.5)
- if RC<0
- QUIT RC
- +13 SET RC=$$TBLPAT(PARTAG)
- if RC<0
- QUIT RC
- +14 ;--- Totals
- +15 SET TMP=$GET(^TMP("RORX007",$JOB,"TOTAL"))
- +16 DO ADDVAL^RORTSK11(RORTSK,"NPR",$PIECE(TMP,U,1),PARTAG)
- +17 DO ADDVAL^RORTSK11(RORTSK,"NDP",$PIECE(TMP,U,2),PARTAG)
- +18 DO ADDVAL^RORTSK11(RORTSK,"NP",$PIECE(TMP,U,4),PARTAG)
- +19 ;---
- +20 QUIT $SELECT(RC<0:RC,1:0)
- +21 ;
- +22 ;***** STORES THE TABLE OF PATIENTS
- +23 ;
- +24 ; PRNTELMT IEN of the parent tag
- +25 ;
- +26 ; Return Values:
- +27 ; <0 Error code
- +28 ; 0 Ok
- +29 ;
- TBLPAT(PRNTELMT) ;
- +1 NEW BUF,ITEM,LAST4,MAXUTNUM,NAME,NODE,PRCNT,RC,TABLE,TMP,UTNUM
- +2 SET MAXUTNUM=$$PARAM^RORTSK01("MAXUTNUM")
- +3 if MAXUTNUM'>0
- QUIT 0
- +4 SET TABLE=$$ADDVAL^RORTSK11(RORTSK,"PATIENTS",,PRNTELMT)
- +5 if TABLE<0
- QUIT TABLE
- +6 DO ADDATTR^RORTSK11(RORTSK,TABLE,"TABLE","PATIENTS")
- +7 SET NODE=$NAME(^TMP("RORX007",$JOB,"PATSORT"))
- +8 ;--- Table
- +9 SET PRCNT=""
- SET (RC,UTNUM)=0
- +10 FOR
- SET PRCNT=$ORDER(@NODE@(PRCNT),-1)
- if PRCNT=""
- QUIT
- Begin DoDot:1
- +11 SET NAME=""
- +12 FOR
- SET NAME=$ORDER(@NODE@(PRCNT,NAME))
- if NAME=""
- QUIT
- Begin DoDot:2
- +13 SET LAST4=""
- +14 FOR
- SET LAST4=$ORDER(@NODE@(PRCNT,NAME,LAST4))
- if LAST4=""
- QUIT
- Begin DoDot:3
- +15 SET ITEM=$$ADDVAL^RORTSK11(RORTSK,"PATIENT",,TABLE)
- +16 DO ADDVAL^RORTSK11(RORTSK,"NAME",NAME,ITEM,1)
- +17 DO ADDVAL^RORTSK11(RORTSK,"LAST4",LAST4,ITEM,1)
- +18 SET BUF=@NODE@(PRCNT,NAME,LAST4)
- +19 SET AGETYPE=$$PARAM^RORTSK01("AGE_RANGE","TYPE")
- IF AGETYPE'="ALL"
- Begin DoDot:4
- +20 DO ADDVAL^RORTSK11(RORTSK,AGETYPE,$PIECE(BUF,U,6),ITEM,1)
- End DoDot:4
- +21 DO ADDVAL^RORTSK11(RORTSK,"DOD",$PIECE(BUF,U,2),ITEM,1)
- +22 DO ADDVAL^RORTSK11(RORTSK,"TOTAL",PRCNT,ITEM,1)
- +23 DO ADDVAL^RORTSK11(RORTSK,"UNIQUE",+BUF,ITEM,1)
- +24 IF $$PARAM^RORTSK01("PATIENTS","ICN")
- Begin DoDot:4
- +25 DO ADDVAL^RORTSK11(RORTSK,"ICN",$PIECE(BUF,U,3),ITEM,1)
- End DoDot:4
- +26 IF $$PARAM^RORTSK01("PATIENTS","PACT")
- Begin DoDot:4
- +27 DO ADDVAL^RORTSK11(RORTSK,"PACT",$PIECE(BUF,U,4),ITEM,1)
- End DoDot:4
- +28 IF $$PARAM^RORTSK01("PATIENTS","PCP")
- Begin DoDot:4
- +29 DO ADDVAL^RORTSK11(RORTSK,"PCP",$PIECE(BUF,U,5),ITEM,1)
- End DoDot:4
- +30 SET UTNUM=UTNUM+1
- if UTNUM'<MAXUTNUM
- SET RC=1
- End DoDot:3
- if RC
- QUIT
- End DoDot:2
- if RC
- QUIT
- End DoDot:1
- if RC
- QUIT
- +31 if RC<0
- QUIT RC
- +32 ;---
- +33 QUIT $SELECT(RC<0:RC,1:0)
- +34 ;
- +35 ;***** STORES THE TABLE OF PROCEDURES
- +36 ;
- +37 ; PRNTELMT IEN of the parent tag
- +38 ;
- +39 ; Return Values:
- +40 ; <0 Error code
- +41 ; 0 Ok
- +42 ;
- TBLPROC(PRNTELMT) ;
- +1 NEW CPT,ITEM,MINRPNUM,NODE,PRCNT,PRN,TABLE,TMP
- +2 SET MINRPNUM=$$PARAM^RORTSK01("MINRPNUM")
- +3 if MINRPNUM'>0
- QUIT 0
- +4 SET TABLE=$$ADDVAL^RORTSK11(RORTSK,"PROCEDURES",,PRNTELMT)
- +5 if TABLE<0
- QUIT TABLE
- +6 DO ADDATTR^RORTSK11(RORTSK,TABLE,"TABLE","PROCEDURES")
- +7 SET NODE=$NAME(^TMP("RORX007",$JOB,"PROCSORT"))
- +8 ;--- Table
- +9 SET PRCNT=""
- SET RC=0
- +10 FOR
- SET PRCNT=$ORDER(@NODE@(PRCNT),-1)
- if PRCNT<MINRPNUM
- QUIT
- Begin DoDot:1
- +11 SET PRN=""
- +12 FOR
- SET PRN=$ORDER(@NODE@(PRCNT,PRN))
- if PRN=""
- QUIT
- Begin DoDot:2
- +13 SET CPT=""
- +14 FOR
- SET CPT=$ORDER(@NODE@(PRCNT,PRN,CPT))
- if CPT=""
- QUIT
- Begin DoDot:3
- +15 SET ITEM=$$ADDVAL^RORTSK11(RORTSK,"PROCEDURE",,TABLE)
- +16 DO ADDVAL^RORTSK11(RORTSK,"NAME",PRN,ITEM,1)
- +17 DO ADDVAL^RORTSK11(RORTSK,"CPT",CPT,ITEM,2)
- +18 SET TMP=+@NODE@(PRCNT,PRN,CPT)
- +19 DO ADDVAL^RORTSK11(RORTSK,"PATIENTS",TMP,ITEM,1)
- +20 DO ADDVAL^RORTSK11(RORTSK,"TOTAL",PRCNT,ITEM,1)
- End DoDot:3
- if RC
- QUIT
- End DoDot:2
- if RC
- QUIT
- End DoDot:1
- if RC
- QUIT
- +21 if RC<0
- QUIT RC
- +22 ;---
- +23 QUIT $SELECT(RC<0:RC,1:0)
