source: WorldVistAEHR/trunk/r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RAPMW.m@ 1384

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