- 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.
- ;;
- 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 ;;
