RAPMW3 ;HOIFO/SWM-Radiology Wait Time reports ;3/20/09 14:10
;;5.0;Radiology/Nuclear Medicine;**99**;Mar 16, 1998;Build 5
;rvd - 3/20/09 p99
; Supported IA #2320 reference to ^%ZISH
Q
EN1 ;
W !,"*****************************************************************"
W !,"This routine requires a tab-delimited VMS text file for input."
W !,"This text file should come from Sherrill Snuggs' Xcel file."
W !,"ALL DATA FROM FILE 73.2 WILL BE DELETED BEFORE IMPORTING VMS FILE."
W !,"Only the 1st of duplicate CPT Codes would be imported."
W !,"*****************************************************************"
S RADIR="USER$:[TEMP]"
W !!,"Enter VMS directory :"_RADIR_"//" R X:DTIME
Q:X="^" S:X'="" RADIR=X
R !!,"Enter VMS file name :",RAVMS:DTIME
Q:"^"[RAVMS
S RAFILE=RADIR_RAVMS
W !!,"Full name of input file is ",RAFILE,!
S DIR(0)="Y",DIR("A",1)="Import includes deletion of all existing data from file 73.2.",DIR("A",2)=" "
S DIR("A")="Do you want to import data from "_RAFILE
S DIR("B")="No"
D ^DIR K DIR I 'Y W !!?5,"Nothing Done." D CLEANUP Q
D OPEN^%ZISH("FILE",RADIR,RAVMS,"R")
I POP W !?3,"** This file cannot be opened. **" G ABEND
D DATDEL ;delete all current data, if any, from file
S RATAB=$C(9),RACOUNT=0,RAREAD=0
S RATXT="Loading data into FM file 73.2."
D DISP
R1 U IO R X:DTIME I $$STATUS^%ZISH G EOF
K A S RAREAD=RAREAD+1
F I=1:1:8 S A(I)=$P(X,RATAB,I)
I A(1)'?5AN D G R1 ; skip header record
. S RATXT="First field is "_A(1)_", record is not imported"
. D DISP
. Q
I A(1)="" D G R1 ; skip null record
. S RATXT="First field is null, record is not imported"
. D DISP
. Q
I $O(^RA(73.2,"B",A(1),0)) D G R1 ; skip duplicate CPT Code
. S RATXT="Duplicate CPT Code not imported = "_A(1)
. D DISP
. Q
S A(5)=$$PARSE(A(5))
S A(8)=$E(A(8),1) S:A(8)'="Y" A(8)="" ; Y or null only
D SETREC S RACOUNT=RACOUNT+1 I '(RACOUNT#10) U 0 W "."
G R1
EOF D CLOSE^%ZISH("FILE")
S RATXT=RAREAD_" records read, "_RACOUNT_" records loaded." D DISP
D CLEANUP
Q
PARSE(RA) ; parse Descriptor -- remove double quotes and trailing blanks if any
N I,B
Q:RA="" RA
S:$E(RA,1)="""" RA=$E(RA,2,$L(RA))
S:$E(RA,$L(RA))="""" RA=$E(RA,1,($L(RA)-1))
Q:$E(RA,$L(RA))'=" " RA ; Last char is non-blank
F I=$L(RA):-1:1 Q:$E(RA,I)'=" " S B=$E(RA,1,I-1)
S RA=B
Q RA
DATDEL ; Delete all data from file 73.2
S RATXT="File 73.2 hasn't been set up yet, so no data to delete."
I '$D(^RA(73.2,0))#2 D DISP Q
S RATXT="File 73.2 doesn't have any data, so nothing to delete."
I '$O(^RA(73.2,0)) D DISP Q
S RATXT="Deleting data from FM file #73.2..."
D DISP
S I=0 F S I=$O(^RA(73.2,I)) Q:'I K ^RA(73.2,I)
K ^RA(73.2,"B"),^RA(73.2,"AC")
S $P(^RA(73.2,0),"^",3,4)="^0"
Q
SETREC ;
S RA=$P(^RA(73.2,0),"^",3)
S2 S RA=RA+1 I $D(^RA(73.2,RA,0))#2 G S2 ;find next un-used ien
F I=1,2,3,4,6,7,8 S $P(^RA(73.2,RA,0),"^",I)=A(I)
S ^RA(73.2,RA,1)=A(5)
S ^RA(73.2,"B",A(1),RA)=""
S:A(2)]"" ^RA(73.2,"AC",A(2),RA)=""
S $P(^RA(73.2,0),"^",3)=RA
S $P(^RA(73.2,0),"^",4)=$P(^RA(73.2,0),"^",4)+1
Q
ABEND U 0 W !,"Processing abended."
D CLEANUP
Q
DISP ;display one-line text either interactively or within KIDS installation
I '$D(XPDNM)#2 U 0 W !!?5,RATXT
E D BMES^XPDUTL(RATXT)
Q
CLEANUP ;
K A,F,I,POP,RA,RACOUNT,RADIR,RAFILE,RAREAD,RATAB,RATXT,RAVMS,X,Y
Q
;
HD ;Header for email <=30 Days Performance Value Summary.
;S RAN=RAN+1,^TMP($J,"RAPM",RAN)=""
;S RAN=RAN+1,^TMP($J,"RAPM",RAN)=RAH1_" Page: 1"
S RAN=RAN+1,^TMP($J,"RAPM",RAN)="",RAN=RAN+1
S ^TMP($J,"RAPM",RAN)=RAH3,RAN=RAN+1
S I=0 F S I=$O(RAH4(I)) Q:'I S ^TMP($J,"RAPM",RAN)=RAH4(I),RAN=RAN+1
S RAN=RAN+1,^TMP($J,"RAPM",RAN)=RAH5_" "
S RAN=RAN+1,^TMP($J,"RAPM",RAN)=RAH8_" "
Q
HDSUM ;
S RATOTAL=0
S:$G(^TMP($J,"RAPM","TOTAL"))>0 RATOTAL=($G(^TMP($J,"RAPM","VR",1))+$G(^(2)))/$G(^TMP($J,"RAPM","TOTAL"))*100
S RAN=RAN+1,^TMP($J,"RAPM",RAN)=""
S RAN=RAN+1,^TMP($J,"RAPM",RAN)="PERFORMANCE VALUE SUMMARY"
S RAN=RAN+1,^TMP($J,"RAPM",RAN)="-------------------------"
S RAN=RAN+1,^TMP($J,"RAPM",RAN)=""
S RAN=RAN+1,^TMP($J,"RAPM",RAN)=$J(RATOTAL,0,1)_"% - Report verification timeliness performance value"
S RAN=RAN+1,^TMP($J,"RAPM",RAN)=""
S RAN=RAN+1,^TMP($J,"RAPM",RAN)="Wait Time performance values:"
S RAN=RAN+1,^TMP($J,"RAPM",RAN)=""
S RAN=RAN+1,^TMP($J,"RAPM",RAN)=" % %"
S RAN=RAN+1,^TMP($J,"RAPM",RAN)=" <=14 <=30 PROCEDURE"
S RAN=RAN+1,^TMP($J,"RAPM",RAN)=" Days Days TYPE"
S RAN=RAN+1,^TMP($J,"RAPM",RAN)="----------------------------------------------"
Q
;
HD1 ;Header for email Wait and Time Performamce Report.
N I
S RAN=RAN+1,^TMP($J,"RAPM",RAN)=""
S RAN=RAN+1,^TMP($J,"RAPM",RAN)="",RAN=RAN+1
S ^TMP($J,"RAPM",RAN)=RAH1_" Page: 1"
S RAN=RAN+1,^TMP($J,"RAPM",RAN)=""
S RAN=RAN+1
S ^TMP($J,"RAPM",RAN)=RAH3,RAN=RAN+1
S I=0 F S I=$O(RAH4(I)) Q:'I S ^TMP($J,"RAPM",RAN)=RAH4(I),RAN=RAN+1
S RAN=RAN+1,^TMP($J,"RAPM",RAN)=RAH5_" ",RAN=RAN+1
S I=0 F S I=$O(RAH6(I)) Q:'I S ^TMP($J,"RAPM",RAN)=RAH6(I),RAN=RAN+1
S RAN=RAN+1
S I=0 F S I=$O(RAH7(I)) Q:'I S ^TMP($J,"RAPM",RAN)=RAH7(I),RAN=RAN+1
S RAN=RAN+1,^TMP($J,"RAPM",RAN)=RAH8_" "
Q
HDSUM1 ;
S RAN=RAN+1,^TMP($J,"RAPM",RAN)="",RAN=RAN+1
S ^TMP($J,"RAPM",RAN)="Total number of procedures registered during specified exam date range: "_RATOTAL
Q
;
RAJOB ;PARTIAL process email wait and time report
S RAN=1 N I,J
N RASP3,RASP4,RASP6,RASP8,RASP10,RASP15,RASP20,RASP25,RASP31
S $P(RASP3," ",3)="",$P(RASP4," ",4)="",$P(RASP6," ",6)="",$P(RASP8," ",8)="",$P(RASP10," ",10)=""
S $P(RASP15," ",15)="",$P(RASP20," ",20)="",$P(RASP25," ",25)="",$P(RASP31," ",31)=""
D HD D HDSUM S RAPG=RAPG+1
S I="" F S I=$O(RACOL(I)) Q:I="" D
.S:$D(RACOL14(I,"FR")) RAPCT(I,"FR")=$S(RATOTAL(I)>0:$J(RACOL14(I,"FR")/RATOTAL(I)*100,5,1),1:$J(0,5,1))
.F J=1:1:5 S RAPCT(I,J)=$S(RATOTAL(I)>0:$J(RACOL(I,J)/RATOTAL(I)*100,5,1),1:$J(0,5,1)),RACOL(I,J)=$J(RACOL(I,J),7)
.S RAAVG(I)=$S(RATOTAL(I)>0:$J(RAWAITD(I)/RATOTAL(I),7,0),1:"")
.I I="unknown",RATOTAL(I)=0 K RATOTAL(I),RACOL(I) Q ;remove "unknown" row if 0s
.I RANX="C",RATOTAL(I)=0 K RATOTAL(I),RACOL(I) Q ;remov 0 row if by CPT
.I $D(RAXCLUDE(I)) K RATOTAL(I),RACOL(I) Q ;remove excluded Proc Type
.S RATOTAL(I)=$J(RATOTAL(I),8)
S I="" F S I=$O(RACOL(I)) Q:I="" D
.S RAN=RAN+1
.S ^TMP($J,"RAPM",RAN)=$E(RAPCT(I,"FR")_RASP10,1,10)_$E(RAPCT(I,1)_RASP10,1,10)_$J($S(I="unknown":""""_I_"""",1:I),26)
S RAN=RAN+1,^TMP($J,"RAPM",RAN)=""
Q
;
COLHDS(X) ; moved from RAPMW1
I X=1 D
.S RAN=RAN+1 S ^TMP($J,"RAPM",RAN)="" S RAN=RAN+1
.S ^TMP($J,"RAPM",RAN)="PROCEDURE <=30"
.S RAN=RAN+1
.S ^TMP($J,"RAPM",RAN)="TYPE Days"
.S RAN=RAN+1
.S ^TMP($J,"RAPM",RAN)="------------------------- ------"
I X=2 D
.S RAN=RAN+1 S ^TMP($J,"RAPM",RAN)="" S RAN=RAN+1
.S ^TMP($J,"RAPM",RAN)="PROCEDURE <=30"
.S RAN=RAN+1
.S ^TMP($J,"RAPM",RAN)="TYPE Days"
.S RAN=RAN+1
.S ^TMP($J,"RAPM",RAN)="------------------------- ------"
Q
;
I RANEG D
.S RAN=RAN+1,^TMP($J,"RAPM",RAN)="",RAN=RAN+1
.S ^TMP($J,"RAPM",RAN)=RASP3_"(There "_$S(RANEG=1:"is",1:"are")_" "_RANEG_" case"_$S(RANEG=1:"",1:"s")_" with negative days wait included in the first column.)"
.;S RAN=RAN+1,^TMP($J,"RAPM",RAN)="",RAN=RAN+1
S RAMAX=$S($D(RATOTAL("unknown")):33,1:28)
S RAN=RAN+1,^TMP($J,"RAPM",RAN)=""
F I=1:1:RAMAX Q:RAXIT S ^TMP($J,"RAPM",RAN)=RASP4_$P($T(FOOTS2+I),";;",2),RAN=RAN+1
Q
;
RAJOB1 ;process mail wait and time report
N RASP3,RASP4,RASP6,RASP8,RASP25,I,J
S $P(RASP3," ",3)="",$P(RASP4," ",4)="",$P(RASP6," ",6)="",$P(RASP8," ",8)="",$P(RASP25," ",25)=""
D HD1 D HDSUM1 S RAPG=RAPG+1
S I="" F S I=$O(RACOL(I)) Q:I="" D
.S:$D(RACOL14(I,"FR")) RAPCT(I,"FR")=$S(RATOTAL(I)>0:$J(RACOL14(I,"FR")/RATOTAL(I)*100,5,1),1:$J(0,5,1)),RACOL14(I,"FR")=$J(RACOL14(I,"FR"),7)
.F J=1:1:5 S RAPCT(I,J)=$S(RATOTAL(I)>0:$J(RACOL(I,J)/RATOTAL(I)*100,5,1),1:$J(0,5,1)),RACOL(I,J)=$J(RACOL(I,J),7)
.S RAAVG(I)=$S(RATOTAL(I)>0:$J(RAWAITD(I)/RATOTAL(I),7,0),1:"")
.I I="unknown",RATOTAL(I)=0 K RATOTAL(I),RACOL(I) Q ;remove "unknown" row if 0s
.I RANX="C",RATOTAL(I)=0 K RATOTAL(I),RACOL(I) Q ;remov 0 row if by CPT
.I $D(RAXCLUDE(I)) K RATOTAL(I),RACOL(I) Q ;remove excluded Proc Type
.S RATOTAL(I)=$J(RATOTAL(I),8)
S RAN=RAN+1,^TMP($J,"RAPM",RAN)="",RAN=RAN+1
S ^TMP($J,"RAPM",RAN)=" DAYS WAIT -- PERCENTAGES"
;S RAN=RAN+1,^TMP($J,"RAPM",RAN)=""
D COL1(1)
S I="" F S I=$O(RACOL(I)) Q:I="" D
.S RAN=RAN+1
.S ^TMP($J,"RAPM",RAN)=$E($S(I="unknown":""""_I_"""",1:I)_RASP25,1,26)_" "_RAPCT(I,"FR")_" "_RAPCT(I,1)_" "_RAPCT(I,2)_" "_RAPCT(I,3)_" "_RAPCT(I,4)_" "_RAPCT(I,5)
S RAN=RAN+1,^TMP($J,"RAPM",RAN)=""
S RAN=RAN+1,^TMP($J,"RAPM",RAN)=" DAYS WAIT -- COUNTS"
;S RAN=RAN+1,^TMP($J,"RAPM",RAN)=""
D COL1(2)
S I="" F S I=$O(RACOL(I)) Q:I="" D
.S RAN=RAN+1
.S ^TMP($J,"RAPM",RAN)=$E($S(I="unknown":""""_I_"""",1:I)_RASP25,1,26)_""_RACOL14(I,"FR")_""_RACOL(I,1)_""_RACOL(I,2)_""_RACOL(I,3)_""_RACOL(I,4)_""_RACOL(I,5)_""_RATOTAL(I)_""_$S(RAAVG(I)="":" -",1:RAAVG(I))
S RAN=RAN+1,^TMP($J,"RAPM",RAN)=" ",RAN=RAN+1
F I=1:1 S J=$P($T(DAY14+I),";;",2) Q:J="" S ^TMP($J,"RAPM",RAN)=J,RAN=RAN+1
S ^TMP($J,"RAPM",RAN)=" ",RAN=RAN+1
S ^TMP($J,"RAPM",RAN)="Number of procedures cancelled and re-ordered on the same day = "_RASAME
D FOOTS
Q
;
COL1(X) ; moved from RAPMW1
I X=1 D
.S RAN=RAN+1 S ^TMP($J,"RAPM",RAN)="" S RAN=RAN+1
.S ^TMP($J,"RAPM",RAN)="PROCEDURE <=14 <=30 31-60 61-90 91-120 >120"
.S RAN=RAN+1
.S ^TMP($J,"RAPM",RAN)="TYPE Days Days Days Days Days Days"
.S RAN=RAN+1
.S ^TMP($J,"RAPM",RAN)="-------------------------- ----- ----- ----- ----- ----- -----"
I X=2 D
.S RAN=RAN+1 S ^TMP($J,"RAPM",RAN)="" S RAN=RAN+1
.S ^TMP($J,"RAPM",RAN)="PROCEDURE <=14 <=30 31-60 61-90 91-120 >120 ROW Avg."
.S RAN=RAN+1
.S ^TMP($J,"RAPM",RAN)="TYPE Days Days Days Days Days Days TOTAL Days"
.S RAN=RAN+1
.S ^TMP($J,"RAPM",RAN)="--------------------------- ----- ----- ----- ----- ----- ----- ----- -----"
Q
;
;;
;;1. Cancelled, "No Credit", inpatient cases, and not the highest modality
;; of a printset are excluded from this report. (See 3. below.)
;;
;;2. Columns represent # of days wait from the Registered date (the date/
;; time entered at the "Imaging Exam Date/Time:" prompt) backwards to the
;; Date Desired for the ordered procedure. The calculation is based on
;; the number of different days and not rounded off by hours. The "31-60"
;; column represents those orders that were registered 31 days or more but
;; less than 61 days after the Date Desired.
;;
;;3. If the user did not select a specific CPT Code or Procedure Name,
;; then the cases from a printset (group of cases that share the same
;; report) will have only the case with the highest modality printed.
;; The modalities have this hierarchical order, where (1) is the highest:
;; (1) Interventional, (2) MRI, (3) CT, (4) Cardiac Stress test,
;; (5) Nuc Med, (6) US, (7) Mammo, (8) General Rad (9) Other
;;
;;4. "Procedure Types" are assigned by a national CPT code look-up table
;; and may differ from locally defined "Imaging Types." Therefore the
;; number of procedures in each category may not be the same as other
;; radiology management reports.
;;
;;5. "Avg. Days" is the average days wait. It is calculated from the sum
;; of the days wait for that Procedure Type, divided by the count of cases
;; included in this report for that Procedure Type. Negative days wait
;; is counted as 0. A "-" means an average cannot be calculated.
;;
;;6. Procedure Type of "unknown" refers to either cases that have no
;; matching procedure type in the spreadsheet of CPT Codes provided
;; by the Office of Patient Care Services, or cases that are missing
;; data for the procedure.
;;
;
DAY14 ;
;; The "<=14 Days" column contains data that is also in the "<=30
;; Days" column. The reason that performance is calculated for both
;; <=14 days and <=30 days is so that facilities can track their
;; performance to a 14 day performance standard rather than a 30
;; day standard if they choose to do so.
;;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRAPMW3 12695 printed Sep 23, 2025@20:14:48 Page 2
RAPMW3 ;HOIFO/SWM-Radiology Wait Time reports ;3/20/09 14:10
+1 ;;5.0;Radiology/Nuclear Medicine;**99**;Mar 16, 1998;Build 5
+2 ;rvd - 3/20/09 p99
+3 ; Supported IA #2320 reference to ^%ZISH
+4 QUIT
EN1 ;
+1 WRITE !,"*****************************************************************"
+2 WRITE !,"This routine requires a tab-delimited VMS text file for input."
+3 WRITE !,"This text file should come from Sherrill Snuggs' Xcel file."
+4 WRITE !,"ALL DATA FROM FILE 73.2 WILL BE DELETED BEFORE IMPORTING VMS FILE."
+5 WRITE !,"Only the 1st of duplicate CPT Codes would be imported."
+6 WRITE !,"*****************************************************************"
+7 SET RADIR="USER$:[TEMP]"
+8 WRITE !!,"Enter VMS directory :"_RADIR_"//"
READ X:DTIME
+9 if X="^"
QUIT
if X'=""
SET RADIR=X
+10 READ !!,"Enter VMS file name :",RAVMS:DTIME
+11 if "^"[RAVMS
QUIT
+12 SET RAFILE=RADIR_RAVMS
+13 WRITE !!,"Full name of input file is ",RAFILE,!
+14 SET DIR(0)="Y"
SET DIR("A",1)="Import includes deletion of all existing data from file 73.2."
SET DIR("A",2)=" "
+15 SET DIR("A")="Do you want to import data from "_RAFILE
+16 SET DIR("B")="No"
+17 DO ^DIR
KILL DIR
IF 'Y
WRITE !!?5,"Nothing Done."
DO CLEANUP
QUIT
+18 DO OPEN^%ZISH("FILE",RADIR,RAVMS,"R")
+19 IF POP
WRITE !?3,"** This file cannot be opened. **"
GOTO ABEND
+20 ;delete all current data, if any, from file
DO DATDEL
+21 SET RATAB=$CHAR(9)
SET RACOUNT=0
SET RAREAD=0
+22 SET RATXT="Loading data into FM file 73.2."
+23 DO DISP
R1 USE IO
READ X:DTIME
IF $$STATUS^%ZISH
GOTO EOF
+1 KILL A
SET RAREAD=RAREAD+1
+2 FOR I=1:1:8
SET A(I)=$PIECE(X,RATAB,I)
+3 ; skip header record
IF A(1)'?5AN
Begin DoDot:1
+4 SET RATXT="First field is "_A(1)_", record is not imported"
+5 DO DISP
+6 QUIT
End DoDot:1
GOTO R1
+7 ; skip null record
IF A(1)=""
Begin DoDot:1
+8 SET RATXT="First field is null, record is not imported"
+9 DO DISP
+10 QUIT
End DoDot:1
GOTO R1
+11 ; skip duplicate CPT Code
IF $ORDER(^RA(73.2,"B",A(1),0))
Begin DoDot:1
+12 SET RATXT="Duplicate CPT Code not imported = "_A(1)
+13 DO DISP
+14 QUIT
End DoDot:1
GOTO R1
+15 SET A(5)=$$PARSE(A(5))
+16 ; Y or null only
SET A(8)=$EXTRACT(A(8),1)
if A(8)'="Y"
SET A(8)=""
+17 DO SETREC
SET RACOUNT=RACOUNT+1
IF '(RACOUNT#10)
USE 0
WRITE "."
+18 GOTO R1
EOF DO CLOSE^%ZISH("FILE")
+1 SET RATXT=RAREAD_" records read, "_RACOUNT_" records loaded."
DO DISP
+2 DO CLEANUP
+3 QUIT
PARSE(RA) ; parse Descriptor -- remove double quotes and trailing blanks if any
+1 NEW I,B
+2 if RA=""
QUIT RA
+3 if $EXTRACT(RA,1)=""""
SET RA=$EXTRACT(RA,2,$LENGTH(RA))
+4 if $EXTRACT(RA,$LENGTH(RA))=""""
SET RA=$EXTRACT(RA,1,($LENGTH(RA)-1))
+5 ; Last char is non-blank
if $EXTRACT(RA,$LENGTH(RA))'=" "
QUIT RA
+6 FOR I=$LENGTH(RA):-1:1
if $EXTRACT(RA,I)'=" "
QUIT
SET B=$EXTRACT(RA,1,I-1)
+7 SET RA=B
+8 QUIT RA
DATDEL ; Delete all data from file 73.2
+1 SET RATXT="File 73.2 hasn't been set up yet, so no data to delete."
+2 IF '$DATA(^RA(73.2,0))#2
DO DISP
QUIT
+3 SET RATXT="File 73.2 doesn't have any data, so nothing to delete."
+4 IF '$ORDER(^RA(73.2,0))
DO DISP
QUIT
+5 SET RATXT="Deleting data from FM file #73.2..."
+6 DO DISP
+7 SET I=0
FOR
SET I=$ORDER(^RA(73.2,I))
if 'I
QUIT
KILL ^RA(73.2,I)
+8 KILL ^RA(73.2,"B"),^RA(73.2,"AC")
+9 SET $PIECE(^RA(73.2,0),"^",3,4)="^0"
+10 QUIT
SETREC ;
+1 SET RA=$PIECE(^RA(73.2,0),"^",3)
S2 ;find next un-used ien
SET RA=RA+1
IF $DATA(^RA(73.2,RA,0))#2
GOTO S2
+1 FOR I=1,2,3,4,6,7,8
SET $PIECE(^RA(73.2,RA,0),"^",I)=A(I)
+2 SET ^RA(73.2,RA,1)=A(5)
+3 SET ^RA(73.2,"B",A(1),RA)=""
+4 if A(2)]""
SET ^RA(73.2,"AC",A(2),RA)=""
+5 SET $PIECE(^RA(73.2,0),"^",3)=RA
+6 SET $PIECE(^RA(73.2,0),"^",4)=$PIECE(^RA(73.2,0),"^",4)+1
+7 QUIT
ABEND USE 0
WRITE !,"Processing abended."
+1 DO CLEANUP
+2 QUIT
DISP ;display one-line text either interactively or within KIDS installation
+1 IF '$DATA(XPDNM)#2
USE 0
WRITE !!?5,RATXT
+2 IF '$TEST
DO BMES^XPDUTL(RATXT)
+3 QUIT
CLEANUP ;
+1 KILL A,F,I,POP,RA,RACOUNT,RADIR,RAFILE,RAREAD,RATAB,RATXT,RAVMS,X,Y
+2 QUIT
+3 ;
HD ;Header for email <=30 Days Performance Value Summary.
+1 ;S RAN=RAN+1,^TMP($J,"RAPM",RAN)=""
+2 ;S RAN=RAN+1,^TMP($J,"RAPM",RAN)=RAH1_" Page: 1"
+3 SET RAN=RAN+1
SET ^TMP($JOB,"RAPM",RAN)=""
SET RAN=RAN+1
+4 SET ^TMP($JOB,"RAPM",RAN)=RAH3
SET RAN=RAN+1
+5 SET I=0
FOR
SET I=$ORDER(RAH4(I))
if 'I
QUIT
SET ^TMP($JOB,"RAPM",RAN)=RAH4(I)
SET RAN=RAN+1
+6 SET RAN=RAN+1
SET ^TMP($JOB,"RAPM",RAN)=RAH5_" "
+7 SET RAN=RAN+1
SET ^TMP($JOB,"RAPM",RAN)=RAH8_" "
+8 QUIT
HDSUM ;
+1 SET RATOTAL=0
+2 if $GET(^TMP($JOB,"RAPM","TOTAL"))>0
SET RATOTAL=($GET(^TMP($JOB,"RAPM","VR",1))+$GET(^(2)))/$GET(^TMP($JOB,"RAPM","TOTAL"))*100
+3 SET RAN=RAN+1
SET ^TMP($JOB,"RAPM",RAN)=""
+4 SET RAN=RAN+1
SET ^TMP($JOB,"RAPM",RAN)="PERFORMANCE VALUE SUMMARY"
+5 SET RAN=RAN+1
SET ^TMP($JOB,"RAPM",RAN)="-------------------------"
+6 SET RAN=RAN+1
SET ^TMP($JOB,"RAPM",RAN)=""
+7 SET RAN=RAN+1
SET ^TMP($JOB,"RAPM",RAN)=$JUSTIFY(RATOTAL,0,1)_"% - Report verification timeliness performance value"
+8 SET RAN=RAN+1
SET ^TMP($JOB,"RAPM",RAN)=""
+9 SET RAN=RAN+1
SET ^TMP($JOB,"RAPM",RAN)="Wait Time performance values:"
+10 SET RAN=RAN+1
SET ^TMP($JOB,"RAPM",RAN)=""
+11 SET RAN=RAN+1
SET ^TMP($JOB,"RAPM",RAN)=" % %"
+12 SET RAN=RAN+1
SET ^TMP($JOB,"RAPM",RAN)=" <=14 <=30 PROCEDURE"
+13 SET RAN=RAN+1
SET ^TMP($JOB,"RAPM",RAN)=" Days Days TYPE"
+14 SET RAN=RAN+1
SET ^TMP($JOB,"RAPM",RAN)="----------------------------------------------"
+15 QUIT
+16 ;
HD1 ;Header for email Wait and Time Performamce Report.
+1 NEW I
+2 SET RAN=RAN+1
SET ^TMP($JOB,"RAPM",RAN)=""
+3 SET RAN=RAN+1
SET ^TMP($JOB,"RAPM",RAN)=""
SET RAN=RAN+1
+4 SET ^TMP($JOB,"RAPM",RAN)=RAH1_" Page: 1"
+5 SET RAN=RAN+1
SET ^TMP($JOB,"RAPM",RAN)=""
+6 SET RAN=RAN+1
+7 SET ^TMP($JOB,"RAPM",RAN)=RAH3
SET RAN=RAN+1
+8 SET I=0
FOR
SET I=$ORDER(RAH4(I))
if 'I
QUIT
SET ^TMP($JOB,"RAPM",RAN)=RAH4(I)
SET RAN=RAN+1
+9 SET RAN=RAN+1
SET ^TMP($JOB,"RAPM",RAN)=RAH5_" "
SET RAN=RAN+1
+10 SET I=0
FOR
SET I=$ORDER(RAH6(I))
if 'I
QUIT
SET ^TMP($JOB,"RAPM",RAN)=RAH6(I)
SET RAN=RAN+1
+11 SET RAN=RAN+1
+12 SET I=0
FOR
SET I=$ORDER(RAH7(I))
if 'I
QUIT
SET ^TMP($JOB,"RAPM",RAN)=RAH7(I)
SET RAN=RAN+1
+13 SET RAN=RAN+1
SET ^TMP($JOB,"RAPM",RAN)=RAH8_" "
+14 QUIT
HDSUM1 ;
+1 SET RAN=RAN+1
SET ^TMP($JOB,"RAPM",RAN)=""
SET RAN=RAN+1
+2 SET ^TMP($JOB,"RAPM",RAN)="Total number of procedures registered during specified exam date range: "_RATOTAL
+3 QUIT
+4 ;
RAJOB ;PARTIAL process email wait and time report
+1 SET RAN=1
NEW I,J
+2 NEW RASP3,RASP4,RASP6,RASP8,RASP10,RASP15,RASP20,RASP25,RASP31
+3 SET $PIECE(RASP3," ",3)=""
SET $PIECE(RASP4," ",4)=""
SET $PIECE(RASP6," ",6)=""
SET $PIECE(RASP8," ",8)=""
SET $PIECE(RASP10," ",10)=""
+4 SET $PIECE(RASP15," ",15)=""
SET $PIECE(RASP20," ",20)=""
SET $PIECE(RASP25," ",25)=""
SET $PIECE(RASP31," ",31)=""
+5 DO HD
DO HDSUM
SET RAPG=RAPG+1
+6 SET I=""
FOR
SET I=$ORDER(RACOL(I))
if I=""
QUIT
Begin DoDot:1
+7 if $DATA(RACOL14(I,"FR"))
SET RAPCT(I,"FR")=$SELECT(RATOTAL(I)>0:$JUSTIFY(RACOL14(I,"FR")/RATOTAL(I)*100,5,1),1:$JUSTIFY(0,5,1))
+8 FOR J=1:1:5
SET RAPCT(I,J)=$SELECT(RATOTAL(I)>0:$JUSTIFY(RACOL(I,J)/RATOTAL(I)*100,5,1),1:$JUSTIFY(0,5,1))
SET RACOL(I,J)=$JUSTIFY(RACOL(I,J),7)
+9 SET RAAVG(I)=$SELECT(RATOTAL(I)>0:$JUSTIFY(RAWAITD(I)/RATOTAL(I),7,0),1:"")
+10 ;remove "unknown" row if 0s
IF I="unknown"
IF RATOTAL(I)=0
KILL RATOTAL(I),RACOL(I)
QUIT
+11 ;remov 0 row if by CPT
IF RANX="C"
IF RATOTAL(I)=0
KILL RATOTAL(I),RACOL(I)
QUIT
+12 ;remove excluded Proc Type
IF $DATA(RAXCLUDE(I))
KILL RATOTAL(I),RACOL(I)
QUIT
+13 SET RATOTAL(I)=$JUSTIFY(RATOTAL(I),8)
End DoDot:1
+14 SET I=""
FOR
SET I=$ORDER(RACOL(I))
if I=""
QUIT
Begin DoDot:1
+15 SET RAN=RAN+1
+16 SET ^TMP($JOB,"RAPM",RAN)=$EXTRACT(RAPCT(I,"FR")_RASP10,1,10)_$EXTRACT(RAPCT(I,1)_RASP10,1,10)_$JUSTIFY($SELECT(I="unknown":""""_I_"""",1:I),26)
End DoDot:1
+17 SET RAN=RAN+1
SET ^TMP($JOB,"RAPM",RAN)=""
+18 QUIT
+19 ;
COLHDS(X) ; moved from RAPMW1
+1 IF X=1
Begin DoDot:1
+2 SET RAN=RAN+1
SET ^TMP($JOB,"RAPM",RAN)=""
SET RAN=RAN+1
+3 SET ^TMP($JOB,"RAPM",RAN)="PROCEDURE <=30"
+4 SET RAN=RAN+1
+5 SET ^TMP($JOB,"RAPM",RAN)="TYPE Days"
+6 SET RAN=RAN+1
+7 SET ^TMP($JOB,"RAPM",RAN)="------------------------- ------"
End DoDot:1
+8 IF X=2
Begin DoDot:1
+9 SET RAN=RAN+1
SET ^TMP($JOB,"RAPM",RAN)=""
SET RAN=RAN+1
+10 SET ^TMP($JOB,"RAPM",RAN)="PROCEDURE <=30"
+11 SET RAN=RAN+1
+12 SET ^TMP($JOB,"RAPM",RAN)="TYPE Days"
+13 SET RAN=RAN+1
+14 SET ^TMP($JOB,"RAPM",RAN)="------------------------- ------"
End DoDot:1
+15 QUIT
+16 ;
+1 IF RANEG
Begin DoDot:1
+2 SET RAN=RAN+1
SET ^TMP($JOB,"RAPM",RAN)=""
SET RAN=RAN+1
+3 SET ^TMP($JOB,"RAPM",RAN)=RASP3_"(There "_$SELECT(RANEG=1:"is",1:"are")_" "_RANEG_" case"_$SELECT(RANEG=1:"",1:"s")_" with negative days wait included in the first column.)"
+4 ;S RAN=RAN+1,^TMP($J,"RAPM",RAN)="",RAN=RAN+1
End DoDot:1
+5 SET RAMAX=$SELECT($DATA(RATOTAL("unknown")):33,1:28)
+6 SET RAN=RAN+1
SET ^TMP($JOB,"RAPM",RAN)=""
+7 FOR I=1:1:RAMAX
if RAXIT
QUIT
SET ^TMP($JOB,"RAPM",RAN)=RASP4_$PIECE($TEXT(FOOTS2+I),";;",2)
SET RAN=RAN+1
+8 QUIT
+9 ;
RAJOB1 ;process mail wait and time report
+1 NEW RASP3,RASP4,RASP6,RASP8,RASP25,I,J
+2 SET $PIECE(RASP3," ",3)=""
SET $PIECE(RASP4," ",4)=""
SET $PIECE(RASP6," ",6)=""
SET $PIECE(RASP8," ",8)=""
SET $PIECE(RASP25," ",25)=""
+3 DO HD1
DO HDSUM1
SET RAPG=RAPG+1
+4 SET I=""
FOR
SET I=$ORDER(RACOL(I))
if I=""
QUIT
Begin DoDot:1
+5 if $DATA(RACOL14(I,"FR"))
SET RAPCT(I,"FR")=$SELECT(RATOTAL(I)>0:$JUSTIFY(RACOL14(I,"FR")/RATOTAL(I)*100,5,1),1:$JUSTIFY(0,5,1))
SET RACOL14(I,"FR")=$JUSTIFY(RACOL14(I,"FR"),7)
+6 FOR J=1:1:5
SET RAPCT(I,J)=$SELECT(RATOTAL(I)>0:$JUSTIFY(RACOL(I,J)/RATOTAL(I)*100,5,1),1:$JUSTIFY(0,5,1))
SET RACOL(I,J)=$JUSTIFY(RACOL(I,J),7)
+7 SET RAAVG(I)=$SELECT(RATOTAL(I)>0:$JUSTIFY(RAWAITD(I)/RATOTAL(I),7,0),1:"")
+8 ;remove "unknown" row if 0s
IF I="unknown"
IF RATOTAL(I)=0
KILL RATOTAL(I),RACOL(I)
QUIT
+9 ;remov 0 row if by CPT
IF RANX="C"
IF RATOTAL(I)=0
KILL RATOTAL(I),RACOL(I)
QUIT
+10 ;remove excluded Proc Type
IF $DATA(RAXCLUDE(I))
KILL RATOTAL(I),RACOL(I)
QUIT
+11 SET RATOTAL(I)=$JUSTIFY(RATOTAL(I),8)
End DoDot:1
+12 SET RAN=RAN+1
SET ^TMP($JOB,"RAPM",RAN)=""
SET RAN=RAN+1
+13 SET ^TMP($JOB,"RAPM",RAN)=" DAYS WAIT -- PERCENTAGES"
+14 ;S RAN=RAN+1,^TMP($J,"RAPM",RAN)=""
+15 DO COL1(1)
+16 SET I=""
FOR
SET I=$ORDER(RACOL(I))
if I=""
QUIT
Begin DoDot:1
+17 SET RAN=RAN+1
+18 SET ^TMP($JOB,"RAPM",RAN)=$EXTRACT($SELECT(I="unknown":""""_I_"""",1:I)_RASP25,1,26)_" "_RAPCT(I,"FR")_" "_RAPCT(I,1)_" "_RAPCT(I,2)_" "_RAPCT(I,3)_" "_RAPCT(I,4)_" "_RAPCT(I,5)
End DoDot:1
+19 SET RAN=RAN+1
SET ^TMP($JOB,"RAPM",RAN)=""
+20 SET RAN=RAN+1
SET ^TMP($JOB,"RAPM",RAN)=" DAYS WAIT -- COUNTS"
+21 ;S RAN=RAN+1,^TMP($J,"RAPM",RAN)=""
+22 DO COL1(2)
+23 SET I=""
FOR
SET I=$ORDER(RACOL(I))
if I=""
QUIT
Begin DoDot:1
+24 SET RAN=RAN+1
+25 SET ^TMP($JOB,"RAPM",RAN)=$EXTRACT($SELECT(I="unknown":""""_I_"""",1:I)_RASP25,1,26)_""_RACOL14(I,"FR")_""_RACOL(I,1)_""_RACOL(I,2)_""_RACOL(I,3)_""_RACOL(I,4)_""_RACOL(I,5)_""_RATOTAL(I)_""_$SELECT(RAAVG(I)="":" -",1:RAAVG(I))
End DoDot:1
+26 SET RAN=RAN+1
SET ^TMP($JOB,"RAPM",RAN)=" "
SET RAN=RAN+1
+27 FOR I=1:1
SET J=$PIECE($TEXT(DAY14+I),";;",2)
if J=""
QUIT
SET ^TMP($JOB,"RAPM",RAN)=J
SET RAN=RAN+1
+28 SET ^TMP($JOB,"RAPM",RAN)=" "
SET RAN=RAN+1
+29 SET ^TMP($JOB,"RAPM",RAN)="Number of procedures cancelled and re-ordered on the same day = "_RASAME
+30 DO FOOTS
+31 QUIT
+32 ;
COL1(X) ; moved from RAPMW1
+1 IF X=1
Begin DoDot:1
+2 SET RAN=RAN+1
SET ^TMP($JOB,"RAPM",RAN)=""
SET RAN=RAN+1
+3 SET ^TMP($JOB,"RAPM",RAN)="PROCEDURE <=14 <=30 31-60 61-90 91-120 >120"
+4 SET RAN=RAN+1
+5 SET ^TMP($JOB,"RAPM",RAN)="TYPE Days Days Days Days Days Days"
+6 SET RAN=RAN+1
+7 SET ^TMP($JOB,"RAPM",RAN)="-------------------------- ----- ----- ----- ----- ----- -----"
End DoDot:1
+8 IF X=2
Begin DoDot:1
+9 SET RAN=RAN+1
SET ^TMP($JOB,"RAPM",RAN)=""
SET RAN=RAN+1
+10 SET ^TMP($JOB,"RAPM",RAN)="PROCEDURE <=14 <=30 31-60 61-90 91-120 >120 ROW Avg."
+11 SET RAN=RAN+1
+12 SET ^TMP($JOB,"RAPM",RAN)="TYPE Days Days Days Days Days Days TOTAL Days"
+13 SET RAN=RAN+1
+14 SET ^TMP($JOB,"RAPM",RAN)="--------------------------- ----- ----- ----- ----- ----- ----- ----- -----"
End DoDot:1
+15 QUIT
+16 ;
+1 ;;
+2 ;;1. Cancelled, "No Credit", inpatient cases, and not the highest modality
+3 ;; of a printset are excluded from this report. (See 3. below.)
+4 ;;
+5 ;;2. Columns represent # of days wait from the Registered date (the date/
+6 ;; time entered at the "Imaging Exam Date/Time:" prompt) backwards to the
+7 ;; Date Desired for the ordered procedure. The calculation is based on
+8 ;; the number of different days and not rounded off by hours. The "31-60"
+9 ;; column represents those orders that were registered 31 days or more but
+10 ;; less than 61 days after the Date Desired.
+11 ;;
+12 ;;3. If the user did not select a specific CPT Code or Procedure Name,
+13 ;; then the cases from a printset (group of cases that share the same
+14 ;; report) will have only the case with the highest modality printed.
+15 ;; The modalities have this hierarchical order, where (1) is the highest:
+16 ;; (1) Interventional, (2) MRI, (3) CT, (4) Cardiac Stress test,
+17 ;; (5) Nuc Med, (6) US, (7) Mammo, (8) General Rad (9) Other
+18 ;;
+19 ;;4. "Procedure Types" are assigned by a national CPT code look-up table
+20 ;; and may differ from locally defined "Imaging Types." Therefore the
+21 ;; number of procedures in each category may not be the same as other
+22 ;; radiology management reports.
+23 ;;
+24 ;;5. "Avg. Days" is the average days wait. It is calculated from the sum
+25 ;; of the days wait for that Procedure Type, divided by the count of cases
+26 ;; included in this report for that Procedure Type. Negative days wait
+27 ;; is counted as 0. A "-" means an average cannot be calculated.
+28 ;;
+29 ;;6. Procedure Type of "unknown" refers to either cases that have no
+30 ;; matching procedure type in the spreadsheet of CPT Codes provided
+31 ;; by the Office of Patient Care Services, or cases that are missing
+32 ;; data for the procedure.
+33 ;;
+34 ;
DAY14 ;
+1 ;; The "<=14 Days" column contains data that is also in the "<=30
+2 ;; Days" column. The reason that performance is calculated for both
+3 ;; <=14 days and <=30 days is so that facilities can track their
+4 ;; performance to a 14 day performance standard rather than a 30
+5 ;; day standard if they choose to do so.
+6 ;;
