Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: RAPMW

RAPMW.m

Go to the documentation of this file.
  1. RAPMW ;HOIFO/SWM-Radiology Wait Time reports ;03/19/05 12:45
  1. ;;5.0;Radiology/Nuclear Medicine;**67,79,83,99**;Mar 16, 1998;Build 5
  1. ;RVD - 3/19/09 p99
  1. ;
  1. ; ___ set up RACESS array
  1. I $D(DUZ),($O(RACCESS(DUZ,""))']"") D CHECK^RADLQ3(DUZ)
  1. ; ___ new/set/kill other variables
  1. K ^TMP($J)
  1. ;**********************************************************
  1. ;* On Dec. 14, 2006, Dr. Anderson requested that the
  1. ;* RADIAION THERAPY procedure type be dropped from the
  1. ;* Wait Times Report but it may be included in the future.
  1. ;*
  1. ;* If RADIATION THERAPY will be included again, the only
  1. ;* coding that needs to be changed is the line below; it
  1. ;* should be removed. The rest of the coding that handles
  1. ;* exclusion of Procedure Types don't have to be changed
  1. ;* because it uses RAXCLUDE() to exclude procedure types.
  1. ;*
  1. S RAXCLUDE("RADIATION THERAPY")=""
  1. ;*
  1. ;***********************************************************
  1. D SETPTA
  1. S (RATOTAL,RAXIT)=0
  1. W @IOF
  1. W !,"Radiology Outpatient Procedure Wait Time Report"
  1. ; __ get report type
  1. D GETTYP I $D(DIRUT) G EXIT
  1. ; ___ get date range
  1. W !! D GETDATE I $D(DIRUT) G EXIT
  1. ; ___ get division
  1. S X=$$GETDIV() I X G EXIT
  1. ; ___ ask what to ask next, procedure or img typ
  1. D ASKIP I RANX="" G EXIT
  1. I RANX="P" D W "."
  1. .W !!?5,"All PROCEDURE TYPES will be included"
  1. .I $O(RAXCLUDE(""))]"" D
  1. .W ", except "
  1. .S I="" F S I=$O(RAXCLUDE(I)) Q:I="" W I W:$O(RAXCLUDE(I))]"" ", "
  1. .Q
  1. I RANX="C" D I RAQUIT G EXIT
  1. . ; ___ get procedure/CPT CODE(s)
  1. . D GETPROC
  1. . Q
  1. ; *79, skip ask spec imaing type
  1. I "B^D"[RATYP D I $D(DIRUT) G EXIT
  1. . D ASKSORT I $D(DIRUT) Q
  1. . D ASKDAYS
  1. . Q
  1. I "B^D"[RATYP D
  1. .S RATXT="*** The detail report requires a 132 column output device ***"
  1. .S RALINE="",$P(RALINE,"*",$L(RATXT)+1)=""
  1. .W !!?(80-$L(RATXT)\2),RALINE,!?(80-$L(RATXT)\2),RATXT,!?(80-$L(RATXT)\2),RALINE,!
  1. .Q
  1. D GETDEV I RAPOP G EXIT
  1. D START
  1. Q
  1. START ; taskman to del task after job, set Radiology IO
  1. S:$D(ZTQUEUED) ZTREQ="@" S RAIO=$S(IO="":0,1:1) ;RAIO true/false
  1. ; get data
  1. ; remove: inpatient, cancelled
  1. ; keep: specific proc/CPT, imag types if entered
  1. S RASAME=0 ; count # procedures cancelled and re-ordered same day
  1. S RANEG=0 ; count # negative Days Wait
  1. D GETDATA
  1. U:RAIO IO
  1. I "S^B"[RATYP D WRTSUM^RAPMW1 Q:$G(RAS99)!$G(RAL99) ; summary report
  1. I RATYP="B",$E(IOST,1,2)'="C-" W @IOF
  1. I "D^B"[RATYP D WRTDET^RAPMW2 ; detail report
  1. D EXIT
  1. Q
  1. GETTYP ;
  1. S DIR(0)="S^S:Summary;D:Detail;B:Both"
  1. S DIR("A")="Select Report Type",DIR("B")="S"
  1. S DIR("?")="Enter Summary report OR Detail report OR Both reports"
  1. W !!,"Enter Report Type"
  1. D ^DIR K DIR
  1. Q:$D(DIRUT)
  1. S RATYP=Y
  1. Q
  1. GETDATE ; start and end dates
  1. S DIR(0)="D^:"_DT_":AEX"
  1. W !?4,"The starting and ending dates are based upon what was entered at",!?4,"the ""Imaging Exam Date/Time"" prompt during Registration.",!
  1. S DIR("A")="Enter starting date"
  1. S DIR("?")="Enter date to begin searching Exam date from"
  1. D ^DIR K DIR
  1. Q:$D(DIRUT)
  1. S RABDATE=Y
  1. ;
  1. S RADD=91,X1=RABDATE,X2=RADD D C^%DTC S RAMAXDT=X
  1. I RAMAXDT>DT S RAMAXDT=DT W !!?4,"** Ending Date cannot be later than today's date. **",!
  1. S DIR(0)="D^"_RABDATE_":"_RAMAXDT_":AEX"
  1. S DIR("A")="Enter ending date"
  1. S DIR("?",1)="+91 days max. for Summary and Detail."
  1. S DIR("?")="But the Ending Date cannot be later than today's date."
  1. D ^DIR K DIR
  1. Q:$D(DIRUT)
  1. ;
  1. ; RABDATE, RAEDATE original values
  1. ; RABEGDT, RAENDDT used in GETDATA
  1. ; Set to end of day
  1. S RAEDATE=Y,RAENDDT=RAEDATE_.9999
  1. ; Set to include current day
  1. S RABEGDT=(RABDATE-1)_.9999
  1. Q
  1. GETDIV() ;
  1. N X S X=$$SETUPDI^RAUTL7() Q:X 1
  1. D SELDIV^RAUTL7
  1. I '$D(^TMP($J,"RA D-TYPE"))!(RAQUIT) D Q 1
  1. .K RACCESS(DUZ,"DIV-IMG"),^TMP($J,"DIV-IMG")
  1. .Q
  1. Q 0
  1. ASKIP ;
  1. S RANX=""
  1. S DIR(0)="S^C:CPT Code/Procedure Name;P:Procedure Type"
  1. S DIR("?")=" "
  1. S DIR("?",1)=" ""CPT Code/Procedure Name"" will include only the"
  1. S DIR("?",2)=" user selected CPT Codes and Procedure names in this"
  1. S DIR("?",3)=" date range, except for cases that are cancelled, have"
  1. S DIR("?",4)=" no credit, and are inpatient."
  1. S DIR("?",5)=" "
  1. S DIR("?",6)=" ""Procedure Type"" will include all cases in this"
  1. S DIR("?",7)=" date range, except for the 3 exclusions above and also"
  1. S DIR("?",8)=" except if the case is part of a printset and it is not"
  1. S DIR("?",9)=" the highest ranked modality in the printset."
  1. S DIR("A")="What do you want to choose next",DIR("B")="P"
  1. W !!,"Enter next item to select."
  1. D ^DIR K DIR
  1. Q:$D(DIRUT)
  1. S RANX=Y
  1. Q
  1. ; *79 removed GETIMG() section
  1. GETPROC ;
  1. S RADIC="^RAMIS(71,",RADIC(0)="QEAMZ"
  1. S RADIC("A")="Select Procedure/CPT Code: "
  1. S RAUTIL="RA WAIT"
  1. D EN1^RASELCT(.RADIC,RAUTIL)
  1. Q:RAQUIT
  1. S RA1=""
  1. F S RA1=$O(^TMP($J,"RA WAIT",RA1)) Q:RA1="" S RA2=0 D
  1. .F S RA2=$O(^TMP($J,"RA WAIT",RA1,RA2)) Q:'RA2 S ^TMP($J,"RA WAIT2",RA2)="",^TMP($J,"RA WAIT1",RA1)=$P($$NAMCODE^RACPTMSC($P($G(^RAMIS(71,RA2,0)),U,9),DT),U) D
  1. ..;if parent was selected, then save iens of its descendents for FILTER2
  1. ..I $P(^RAMIS(71,RA2,0),U,6)="P" D
  1. ...S RA3=0 F S RA3=$O(^RAMIS(71,RA2,4,"B",RA3)) Q:'RA3 S ^TMP($J,"RA WAIT2",RA3)=""
  1. ...Q
  1. ..Q
  1. .Q
  1. Q
  1. ASKSORT ;
  1. S DIR(0)="S^CN:Case Number;CPT:CPT Code;DD:Date Desired;D:Days Wait;DO:Date of Order;DR:Date of Registration;I:Imaging Type;PN:Patient Name;PT:PROCEDURE TYPE;PROC:Procedure Name"
  1. S DIR("?")="Select which item to use for sorting the Detail Report"
  1. S DIR("A")="Sorted by",DIR("B")="D"
  1. W !!,"Sort report by"
  1. D ^DIR
  1. I $D(DIRUT) K DIR Q
  1. S RASORT=Y
  1. S RASORTNM=Y(0)
  1. S:RASORTNM["Regis" RASORTNM="Dt. Register"
  1. K DIR
  1. Q
  1. ASKDAYS ;
  1. S DIR(0)="N^0:120"
  1. S DIR("A")="Print wait days greater than or equal to"
  1. S DIR("B")="0"
  1. S DIR("?",1)="Enter the minimum number of Days Wait between Date Desired and Registered Date."
  1. S DIR("?",2)="Only cases with Days Wait greater than or equal to this value"
  1. S DIR("?")="will be listed in the detail report."
  1. D ^DIR K DIR Q:$D(DIRUT) S RASINCE=Y
  1. Q
  1. GETDEV ;
  1. W:RATYP="B" !!,"Specify device for both summary and detail reports."
  1. D TASK
  1. D ZIS^RAUTL
  1. Q
  1. TASK ; set vars for taskman
  1. S ZTRTN="START^RAPMW"
  1. S ZTSAVE("RA*")=""
  1. S ZTSAVE("^TMP($J,")=""
  1. S ZTDESC="Radiology Outpatient Wait Time Report"
  1. Q
  1. GETDATA ;
  1. S RABAD=0 ;=0 means nothing bad, so accept case; =1 means reject case
  1. ;loop thru exam date (RADTE)
  1. S RADTE=RABEGDT
  1. F S RADTE=$O(^RADPT("AR",RADTE)) Q:'RADTE Q:(RADTE>RAENDDT) D
  1. .S RADFN="" F S RADFN=$O(^RADPT("AR",RADTE,RADFN)) Q:'RADFN S RABAD=0 D
  1. ..S RADTI="" F S RADTI=$O(^RADPT("AR",RADTE,RADFN,RADTI)) Q:'RADTI D FILTER1^RAPMW1 I 'RABAD D
  1. ...S RACNI=0 F S RACNI=$O(^RADPT(RADFN,"DT",RADTI,"P",RACNI)) Q:'RACNI D FILTER2^RAPMW1 I 'RABAD D CALC^RAPMW2
  1. ...Q
  1. ..Q
  1. .Q
  1. Q
  1. EXIT ;
  1. S:$G(RAS99)!$G(RAL99) RAP99=1
  1. D:'$G(RAP99) CLOSE^RAUTL ;close dev. if it's not a mail wait and time
  1. K I,J,POP,RA0,RA1,RA16,RA2,RA3,RA71REC,RA72,X,X1,X2,Y
  1. K RABAD,RACHKDIV,RACN0,RACNI,RACNISAV,RACNL,RACOL,RACOL14
  1. K RACPT,RADASH,RADD,RADFN,RADIC,RADIV,RADSDT,RADTE,RADTI,RADTORD
  1. K RAH1,RAH3,RAH4,RAH5,RAH6,RAH7,RAH8,RAHD0,RAIMGTYP
  1. K RAIT,RAITYP,RAKEY,RALINE,RAMAX,RAMAXDT,RANEG,RANOW,RANX
  1. K RAOREC,RAORIEN,RAPATND,RAPATNM,RAPG,RAPOP,RAPROCNM,RAPSTX,RAQUIT
  1. K RAR,RAREC,RASAME,RASAME2,RASELDIV,RASINCE,RASORT,RASORTNM
  1. K RAAVG,RATOTAL,RATYP,RAUTIL,RAWAITD,RATXT,RAXDT,RAXIT,RAXMST
  1. K RACPTC,RACPTI,RAHI,RAHIER,RAPCT,RAPCT14,RAPRC,RAPTA,RARY,RAXCLUDE,RAMES
  1. K:'$G(RAP99) RAEDATE,RABDATE,RAENDDT,RABEGDT,^TMP($J),RAIO,RAIOM ;cln var if not mail
  1. ;
  1. ; ^TMP($J,"RA I-TYPE","CT SCAN",ienFile79.2)="" <--*79 not needed
  1. ; ^TMP($J,"RA D-TYPE","SUPPORT ISC",ienFile79)=""
  1. ; ^TMP($J,"RA WAIT",ProcNam,ienFile71)=""<--from EN1^RASELCT
  1. ; ^TMP($J,"RA WAIT1",ProcNam)=CPTcode<--hdr of rpt, SETHD^RAPMW1
  1. ; ^TMP($J,"RA WAIT2",ienFile71)=""<--screen cases, FILTER2^RAPMW1
  1. ;ex. ^TMP($J,"RA WAIT","TEETH",31)=
  1. ;ex. ^TMP($J,"RA WAIT1","TEETH")=70320
  1. ;ex. ^TMP($J,"RA WAIT2",31)=
  1. ; ^TMP($J,"RA WAIT NO ORD",RADFN,RADTI,RACNI)=ienFile75.1
  1. ; ^TMP($J,"RA WAIT NO DSR DT",RADFN,RADTI,RACNI)=ienFile75.1
  1. ; ^TMP($J,"RA WAIT3",RASORT,RADTE,RAPATNM,RACNI)=""<--detail display
  1. Q
  1. SETPTA ;Set up Proc Type Array, w Sherrill Snuggs' Xcel file
  1. ; also setup RATOTAL(), RACOL(,), RAHIER()
  1. N I,J
  1. S I=""
  1. ; RATOTAL(I) sub-total, each Proc Type
  1. ; RAWAITD(I) total wait days, each Proc Type
  1. ; RAAVG(I) average wait days, each Proc Type
  1. ; RACOL14(I) <14 days column
  1. F S I=$O(^RA(73.2,"AC",I)) Q:I="" S RATOTAL(I)=0,RAWAITD(I)=0,RAAVG(I)=0,RACOL14(I,"FR")=0 F J=1:1:5 S RACOL(I,J)=0
  1. S I="unknown",RATOTAL(I)=0,RAWAITD(I)=0,RAAVG(I)=0,RACOL14(I,"FR")=0 F J=1:1:5 S RACOL(I,J)=0
  1. ; Rank Proc Types, needed to pick case from printset
  1. ; 1=Interventional 2=MR 3=CT 4=Card. Stress Test 5=NM
  1. ; 6=US 7=Mammo 8=Plain Film (Gen Rad) 9=Other
  1. S I=""
  1. F S I=$O(RATOTAL(I)) Q:I="" D
  1. .S J=$E(I,1,3)
  1. .S RAHIER(I)=$S(J="CAR":4,J="COM":3,J="GEN":8,J="INT":1,J="MAG":2,J="MAM":7,J="NUC":5,J="ULT":6,1:9)
  1. .Q
  1. Q
  1. ;added in p#99
  1. PWT(RABDATE,RAEDATE) ;entry point of EMAIL performance and wait time as part of a task job
  1. S RAXCLUDE("RADIATION THERAPY")=""
  1. D SETPTA S (RATOTAL,RAXIT)=0
  1. K:$G(RAL99) RAS99
  1. S RANX="P",RATYP="S"
  1. D START
  1. D EXIT
  1. Q