source: FOIAVistA/trunk/r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RAPM.m@ 1250

RAPM ;HOIFO/TH-Radiology Performance Monitors/Indicator; ;5/12/04  10:03
 ;;5.0;Radiology/Nuclear Medicine;**37,44,48,67**;Mar 16, 1998
 ;
 ; *** Application variables: ***
 ;
 ; Exam Date - RADTE (Regular Fileman format)
 ;             RADTI (Inverse Fileman format)
 ; Case Number - RACN               Exam Status - RAEXST
 ; Category of Exam - RACAT         Primary Interpreting Staff - RAPRIM
 ; Date Report Entered - RARPTDT    Verified Date - RAVERDT
 ; Report Status - RARPTST          Page Number - RAPG
 ; Type of Report - RARPT
 ; Internal number of an entry in the Patient file (#2) - RADFN
 ;
INIT ; Check for the existence of RACESS. Pass in user's DUZ!
 I $D(DUZ),($O(RACCESS(DUZ,""))']"") D CHECK^RADLQ3(DUZ)
 ;
 N DIR,DIRUT,RABDATE,RAEDATE,RARPT,DTDIFF,RABEGDT,RAENDDT,RA1
 N RAM,RARAD,RAR,RAMSG,X,Y
 S (RABDATE,RAEDATE,RAANS,RAANS2,RANODIV,RASINCE,RARAD)=""
 ; RANODIV=1 if one or more exams are missing DIVISION
PROMPT ; 
 W @IOF
 W !!,"Radiology Verification Timeliness Report",!!
 ; Prompt for Report Type. Quit if no report type selected
 D GETRPT K DIR Q:$D(DIRUT)
 ; Prompt for Date Range - Quit if no dates selected
 W !! D GETDATE K DIR Q:$D(DIRUT)
 ; Prompt for Radiologist if Short or Both
 D RADIOL^RAPM3
 ; Prompt for Division and Imaging Types
 S X=$$DIVLOC^RAUTL7() I X G EXIT
 I $D(^TMP($J,"RA I-TYPE","VASCULAR LAB")) D
 . K ^TMP($J,"RA I-TYPE","VASCULAR LAB")
 . W !!?5,"*** Imaging type 'Vascular Lab' will not be included in this report ***"
 ; Prompt for sort option if Detail
 D:RARPT'="S" SORT K DIR Q:$D(DIRUT)
 ; Prompt for mail delivery if Short or Both
 I RARPT'="D" D EMAIL^RAPM2 K DIR Q:$D(DIRUT)
 ; Warning for Detail or Both
 I RARPT="D"!(RARPT="B") D
 . S RATXT="*** The detail report requires a 132 column output device ***"
 . S RALINE="",$P(RALINE,"*",$L(RATXT))=""
 . W !!?(80-$L(RATXT)\2),RALINE,!?(80-$L(RATXT)\2),RATXT,!?(80-$L(RATXT)\2),RALINE,!
 .Q
 D DEV
 I RAPOP D  G EXIT
 . I RAANS!(RAANS2) W !?5,"** No mail will be sent **",$C(7)
 . Q
START ; Get data and print the report
 S:$D(ZTQUEUED) ZTREQ="@" S RAIO=$S(IO="":0,1:1)
 D GETDATA
 I RARPT="S"!(RARPT="B") S RAPG=0 D ^RAPM1
 I RARPT="D"!(RARPT="B") S RAPG=0 D ^RAPM2
 ; see if need send email
 D SEND^RAPM2
 D EXIT
 Q
 ;
GETRPT ; Prompt for Summary or Detail or Both reports; Default = Summary Report
 W !,"Enter Report Type"
 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"
 D ^DIR
 Q:$D(DIRUT) 
 S RARPT=Y
 Q
GETDATE ; Prompt for start and end dates
 S DIR(0)="D^:"_DT_":AE"
 I RARPT'="D" D
 . W !!?4,"The begin date for Summary and Both must be at least 10 days before today.",!
 . S X1=DT,X2=-10 D C^%DTC S RA1=X
 . S DIR(0)="D^:"_RA1_":AE"
 . Q
 S DIR("A")="Enter starting date"
 S DIR("?")="Enter date to begin searching from"
 D ^DIR
 Q:$D(DIRUT)
 S RABDATE=Y
 ;
 S RADD=$S(RARPT="S":91,1:31),X1=RABDATE,X2=RADD D C^%DTC S RAMAXDT=X
 ; put 10 day block for summary report or Both
 I RARPT'="D" D
 . W !!?4,"The ending date for Summary and Both must be at least 10 days before today.",!
 . S X1=DT,X2=-10 D C^%DTC S:X<RAMAXDT RAMAXDT=X
 S:RAMAXDT>DT RAMAXDT=DT
 S DIR(0)="D^"_RABDATE_":"_RAMAXDT_":AE"
 S DIR("A")="Enter ending date"
 S DIR("?",1)="     +91 days max. for Summary, +31 days max. for Detail."
 S DIR("?",2)="     And the ending date for the Summary and Both"
 S DIR("?")="     must be at least 10 days before today."
 D ^DIR
 Q:$D(DIRUT)
 ;
 ; Set end date to end of day
 ; RABDATE and RAEDATE are original values
 ; RABEGDT and RAENDDT are used in GETDATA 
 S RAEDATE=Y,RAENDDT=RAEDATE_.9999
 ; Set start date back to include current day
 S RABEGDT=(RABDATE-1)_.9999
 Q
SORT ; Prompt for Sorted by
 W !!,"Sort report by"
 S DIR(0)="S^C:Case Number;E:Category of Exam;I:Imaging Type;P:Patient Name;R:Radiologist;T:Hrs to Transcrip.;V:Hrs to Verif."
 S DIR("A")="Select Sorted by",DIR("B")="C"
 D ^DIR
 Q:$D(DIRUT)
 S RASORT=Y
 S DIR(0)="N^0:240"
 S DIR("A")="Print PENDING and "_$S(RASORT="V":"Verif.",1:"Transrip.")_" hours greater than or equal to"
 S DIR("B")="72"
 S DIR("?")="Enter minimum number of hours elapsed since registration."
 D ^DIR Q:$D(DIRUT)  S RASINCE=Y
 Q
DEV ; Device
 I $D(DIRUT) D EXIT Q
 W:RARPT="B" !!,"Specify device for both summary and detail reports."
 D TASK
 D ZIS^RAUTL
 Q
TASK ; set vars for taskman
 S ZTRTN="START^RAPM"
 S ZTSAVE("RA*")=""
 S ZTSAVE("^TMP($J,""RA D-TYPE"",")=""
 S ZTSAVE("^TMP($J,""RA I-TYPE"",")=""
 S ZTDESC="Radiology Verification Timeliness Report"
 Q
 ;
GETDATA ; Get all the data
 ; Order 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  D
 . . ; Get patient name
 . . S RAPATNM=$$GET1^DIQ(2,RADFN,.01) S:RAPATNM="" RAPATNM=" "
 . . ; Order thru inverse Exam Date (RADTI)
 . . S RADTI="" F  S RADTI=$O(^RADPT("AR",RADTE,RADFN,RADTI)) Q:'RADTI  D CHECK
 . . Q
 . Q
 Q
CHECK ; Check type of image
 Q:'$D(^RADPT(RADFN,"DT",RADTI))  ;no exam data at all
 S RAITYP=$P($G(^RADPT(RADFN,"DT",RADTI,0)),U,2)
 S RAIMGTYP=$P($G(^RA(79.2,+RAITYP,0)),U,1)
 ; quit if img typ is known AND does not match selection
 I RAIMGTYP'="",'$D(^TMP($J,"RA I-TYPE",RAIMGTYP)) Q
 I RAIMGTYP="" S RAIMGTYP="(unknown)"
 ;
 ; Check division - Quit if no division selected
 S RASELDIV=$P($G(^RADPT(RADFN,"DT",RADTI,0)),U,3)
 S RACHKDIV=$P($G(^DIC(4,+RASELDIV,0)),U,1)
 ; quit if div is known AND does not match selection 
 I RACHKDIV'="",'$D(^TMP($J,"RA D-TYPE",RACHKDIV)) Q
 S:RACHKDIV="" RANODIV=1
 ;
 ; Get exam related data
 S RACNI=0 F  S RACNI=$O(^RADPT(RADFN,"DT",RADTI,"P",RACNI)) Q:'RACNI  D
 . S (RACN0,RAEXST,RANUM,RACN,RAPRIM,RAPRIMNM,RACAT,RARPTTXT)=""
 . S (RARPTDT,RAVERDT,RARPTST,RADHT,RADHV,RATDFHR,RAVDFHR)=""
 . ; Get 0 node (RACN0) of ^RADPT(RADFN,"DT",RADTI,"P",RACNI,0)
 . S RACN0=$G(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0))
 . Q:RACN0=""  ; no exam data
 . ; Get Case number: Exam Date - Case Number
 . S RACN=$E(RADTE,4,7)_$E(RADTE,2,3)_"-"_$P(RACN0,U,1)
 . ; Get exam status
 . S RAEXST=$P(RACN0,U,3)
 . Q:RAEXST=""  ; no exam status
 . ; Quit if exam's CREDIT METHOD is 2 = no credit
 . Q:$P(RACN0,U,26)=2
 . ; Quit if exam status is "Cancelled"
 . I $P(^RA(72,RAEXST,0),U,3)=0 Q
 . ; Get number of set - '1' separate; '2' for combined report.
 . S RANUM=$P(RACN0,U,25)
 . ; if member of set > 1 then set RACNI to 99999 to skip remaining cases
 . I RANUM>1 S RACNI=99999
 . ; Get Radiologist (Primary Interpreting Staff) internal # and name. 
 . S RAPRIM=$P(RACN0,U,15)
 . ; if specific radiologist requested, quit if not his/her case
 . I RARAD,RAPRIM'=RARAD Q
 . S RAPRIMNM=$$GET1^DIQ(200,RAPRIM,.01) S:RAPRIMNM="" RAPRIMNM=" "
 . ; Get Category of Exam
 . S RACAT=$P(RACN0,U,4)
 . ; Get Procedure Name
 . S RAPRCN=$P($G(^RAMIS(71,+$P(RACN0,U,2),0)),U)
 . ; Get IEN of imaging report
 . S RARPTTXT=$P(RACN0,U,17)
 . ; Pending if no imaging report OR report doesn't exist in the Report
 . ; file (#74) OR Stub report
 . S RAHASR=0 ;=1 has real report
 . I $D(^RARPT(+RARPTTXT,0)),'$$STUB^RAEDCN1(+RARPTTXT) S RAHASR=1
 . I 'RAHASR D
 . . S ^TMP($J,"RAPM","TR",0)=$G(^TMP($J,"RAPM","TR",0))+1
 . . S ^TMP($J,"RAPM","VR",0)=$G(^TMP($J,"RAPM","VR",0))+1
 . ; Get report info. if real report exists.
 . I RAHASR D RPTINFO^RAPM1
 . D STORE^RAPM2
 . ; Calculate the total number of reports
 . S ^TMP($J,"RAPM","TOTAL")=$G(^TMP($J,"RAPM","TOTAL"))+1
 Q
EXIT ; Exit
 ; Close device
 D CLOSE^RAUTL
 K RACN0,RAEXST,RANUM,RACN,RAPRIM,RAPRIMNM,RACAT,RARPTTXT,RAANS,RATXT
 K DIR,DIRUT,RABDATE,RAEDATE,RARPT,DTDIFF,RABEGDT,RAENDDT,RAITYP,RAIMGTYP,RATYP
 K ZTRTN,ZTSAVE,ZTDESC,RAPG,RASELDIV,RACHKDIV,RACNO,RAVHRS
 K RADIV,RAN,RAIMG,RAREC1,RATOTCNT,RACNI,RADFN,RADTE,RADTI,RAHD,RAPATNM
 K RAPOP,RAPSTX,RAQUIT,RAREC,RARPTDT,RARPTST,RASORT,RASRT,RATDFHR,RAHASR
 K RATDFSEC,RATHRS,RAVDFHR,RAVDFSEC,RAVERDT,RAMES,RALINE,RAMAXDT,RADD
 K RAANS2,RAIOM,RAHDR,RANODIV,RASINCE,RADHT,RADHV,RAVAL,RAPRCN
 K RAXIT,RAIO,RALDENT,RALMAX,RALUSED,RATAIL
 K ^TMP($J)
 Q