- RAPM ;HOIFO/TH-Radiology Performance Monitors/Indicator; ;5/12/04 10:03
- ;;5.0;Radiology/Nuclear Medicine;**37,44,48,67,99,47**;Mar 16, 1998;Build 21
- ;RVD - 3/19/09 p99.
- ;Supported IA #2056 reference to ^DIQ
- ;Supported IA #10000 reference to C^%DTC
- ;Supported IA #10090 reference to ^DIC(4
- ; *** 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 K RAP99
- S (RABDATE,RAEDATE,RAANS,RAANS2,RANODIV,RASINCE,RARAD)="",RAN=0
- ; 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),RAN=0
- ;added by patch #99
- D GETDATA
- I $G(RAP99) S RAS99=1 D PWT^RAPMW(RABDATE,RAEDATE) ;process partial Wait and Time report
- ;
- ;D GETDATA
- I RARPT="S"!(RARPT="B") S RAPG=0 D ^RAPM1
- I RARPT="D"!(RARPT="B") S RAPG=0 D ^RAPM2
- I $G(RAP99) K RAS99 S RAL99=1 D PWT^RAPMW(RABDATE,RAEDATE) ;process all wait and time reports
- ; 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_":AEX"
- 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_":AEX"
- . 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=91,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 and 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,")=""
- ;S ZTSAVE("^TMP($J,""RA D-TYPE"",")=""
- ;S ZTSAVE("^TMP($J,""RA I-TYPE"",")=""
- S:$G(RAP99) ZTDESC="Radiology Timeliness Performance Reports"
- S:'$G(RAP99) 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)
- . N RASSAN,RACNDSP S RASSAN=$$SSANVAL^RAHLRU1(RADFN,RADTI,RACNI)
- . S RACNDSP=$S((RASSAN'=""):RASSAN,1:RACN)
- . ; 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,RACNDSP,RASSAN
- 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,RAS99,RAL99,RAP99,RAN
- K ^TMP($J)
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRAPM 8890 printed Jan 18, 2025@03:39:35 Page 2
- RAPM ;HOIFO/TH-Radiology Performance Monitors/Indicator; ;5/12/04 10:03
- +1 ;;5.0;Radiology/Nuclear Medicine;**37,44,48,67,99,47**;Mar 16, 1998;Build 21
- +2 ;RVD - 3/19/09 p99.
- +3 ;Supported IA #2056 reference to ^DIQ
- +4 ;Supported IA #10000 reference to C^%DTC
- +5 ;Supported IA #10090 reference to ^DIC(4
- +6 ; *** Application variables: ***
- +7 ;
- +8 ; Exam Date - RADTE (Regular Fileman format)
- +9 ; RADTI (Inverse Fileman format)
- +10 ; Case Number - RACN Exam Status - RAEXST
- +11 ; Category of Exam - RACAT Primary Interpreting Staff - RAPRIM
- +12 ; Date Report Entered - RARPTDT Verified Date - RAVERDT
- +13 ; Report Status - RARPTST Page Number - RAPG
- +14 ; Type of Report - RARPT
- +15 ; Internal number of an entry in the Patient file (#2) - RADFN
- +16 ;
- INIT ; Check for the existence of RACESS. Pass in user's DUZ!
- +1 IF $DATA(DUZ)
- IF ($ORDER(RACCESS(DUZ,""))']"")
- DO CHECK^RADLQ3(DUZ)
- +2 ;
- +3 NEW DIR,DIRUT,RABDATE,RAEDATE,RARPT,DTDIFF,RABEGDT,RAENDDT,RA1
- +4 NEW RAM,RARAD,RAR,RAMSG,X,Y
- KILL RAP99
- +5 SET (RABDATE,RAEDATE,RAANS,RAANS2,RANODIV,RASINCE,RARAD)=""
- SET RAN=0
- +6 ; RANODIV=1 if one or more exams are missing DIVISION
- PROMPT ;
- +1 WRITE @IOF
- +2 WRITE !!,"Radiology Verification Timeliness Report",!!
- +3 ; Prompt for Report Type. Quit if no report type selected
- +4 DO GETRPT
- KILL DIR
- if $DATA(DIRUT)
- QUIT
- +5 ; Prompt for Date Range - Quit if no dates selected
- +6 WRITE !!
- DO GETDATE
- KILL DIR
- if $DATA(DIRUT)
- QUIT
- +7 ; Prompt for Radiologist if Short or Both
- +8 DO RADIOL^RAPM3
- +9 ; Prompt for Division and Imaging Types
- +10 SET X=$$DIVLOC^RAUTL7()
- IF X
- GOTO EXIT
- +11 IF $DATA(^TMP($JOB,"RA I-TYPE","VASCULAR LAB"))
- Begin DoDot:1
- +12 KILL ^TMP($JOB,"RA I-TYPE","VASCULAR LAB")
- +13 WRITE !!?5,"*** Imaging type 'Vascular Lab' will not be included in this report ***"
- End DoDot:1
- +14 ; Prompt for sort option if Detail
- +15 if RARPT'="S"
- DO SORT
- KILL DIR
- if $DATA(DIRUT)
- QUIT
- +16 ; Prompt for mail delivery if Short or Both
- +17 IF RARPT'="D"
- DO EMAIL^RAPM2
- KILL DIR
- if $DATA(DIRUT)
- QUIT
- +18 ; Warning for Detail or Both
- +19 IF RARPT="D"!(RARPT="B")
- Begin DoDot:1
- +20 SET RATXT="*** The detail report requires a 132 column output device ***"
- +21 SET RALINE=""
- SET $PIECE(RALINE,"*",$LENGTH(RATXT))=""
- +22 WRITE !!?(80-$LENGTH(RATXT)\2),RALINE,!?(80-$LENGTH(RATXT)\2),RATXT,!?(80-$LENGTH(RATXT)\2),RALINE,!
- +23 QUIT
- End DoDot:1
- +24 DO DEV
- +25 IF RAPOP
- Begin DoDot:1
- +26 IF RAANS!(RAANS2)
- WRITE !?5,"** No mail will be sent **",$CHAR(7)
- +27 QUIT
- End DoDot:1
- GOTO EXIT
- START ; Get data and print the report
- +1 if $DATA(ZTQUEUED)
- SET ZTREQ="@"
- SET RAIO=$SELECT(IO="":0,1:1)
- SET RAN=0
- +2 ;added by patch #99
- +3 DO GETDATA
- +4 ;process partial Wait and Time report
- IF $GET(RAP99)
- SET RAS99=1
- DO PWT^RAPMW(RABDATE,RAEDATE)
- +5 ;
- +6 ;D GETDATA
- +7 IF RARPT="S"!(RARPT="B")
- SET RAPG=0
- DO ^RAPM1
- +8 IF RARPT="D"!(RARPT="B")
- SET RAPG=0
- DO ^RAPM2
- +9 ;process all wait and time reports
- IF $GET(RAP99)
- KILL RAS99
- SET RAL99=1
- DO PWT^RAPMW(RABDATE,RAEDATE)
- +10 ; see if need send email
- +11 DO SEND^RAPM2
- +12 DO EXIT
- +13 QUIT
- +14 ;
- GETRPT ; Prompt for Summary or Detail or Both reports; Default = Summary Report
- +1 WRITE !,"Enter Report Type"
- +2 SET DIR(0)="S^S:Summary;D:Detail;B:Both"
- +3 SET DIR("A")="Select Report Type"
- SET DIR("B")="S"
- +4 SET DIR("?")="Enter Summary report OR Detail report OR Both reports"
- +5 DO ^DIR
- +6 if $DATA(DIRUT)
- QUIT
- +7 SET RARPT=Y
- +8 QUIT
- GETDATE ; Prompt for start and end dates
- +1 SET DIR(0)="D^:"_DT_":AEX"
- +2 IF RARPT'="D"
- Begin DoDot:1
- +3 WRITE !!?4,"The begin date for Summary and Both must be at least 10 days before today.",!
- +4 SET X1=DT
- SET X2=-10
- DO C^%DTC
- SET RA1=X
- +5 SET DIR(0)="D^:"_RA1_":AEX"
- +6 QUIT
- End DoDot:1
- +7 SET DIR("A")="Enter starting date"
- +8 SET DIR("?")="Enter date to begin searching from"
- +9 DO ^DIR
- +10 if $DATA(DIRUT)
- QUIT
- +11 SET RABDATE=Y
- +12 ;
- +13 SET RADD=91
- SET X1=RABDATE
- SET X2=RADD
- DO C^%DTC
- SET RAMAXDT=X
- +14 ; put 10 day block for summary report or Both
- +15 IF RARPT'="D"
- Begin DoDot:1
- +16 WRITE !!?4,"The ending date for Summary and Both must be at least 10 days before today.",!
- +17 SET X1=DT
- SET X2=-10
- DO C^%DTC
- if X<RAMAXDT
- SET RAMAXDT=X
- End DoDot:1
- +18 if RAMAXDT>DT
- SET RAMAXDT=DT
- +19 SET DIR(0)="D^"_RABDATE_":"_RAMAXDT_":AE"
- +20 SET DIR("A")="Enter ending date"
- +21 SET DIR("?",1)=" +91 days max. for Summary and Detail."
- +22 SET DIR("?",2)=" And the ending date for the Summary and Both"
- +23 SET DIR("?")=" must be at least 10 days before today."
- +24 DO ^DIR
- +25 if $DATA(DIRUT)
- QUIT
- +26 ;
- +27 ; Set end date to end of day
- +28 ; RABDATE and RAEDATE are original values
- +29 ; RABEGDT and RAENDDT are used in GETDATA
- +30 SET RAEDATE=Y
- SET RAENDDT=RAEDATE_.9999
- +31 ; Set start date back to include current day
- +32 SET RABEGDT=(RABDATE-1)_.9999
- +33 QUIT
- SORT ; Prompt for Sorted by
- +1 WRITE !!,"Sort report by"
- +2 SET 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."
- +3 SET DIR("A")="Select Sorted by"
- SET DIR("B")="C"
- +4 DO ^DIR
- +5 if $DATA(DIRUT)
- QUIT
- +6 SET RASORT=Y
- +7 SET DIR(0)="N^0:240"
- +8 SET DIR("A")="Print PENDING and "_$SELECT(RASORT="V":"Verif.",1:"Transrip.")_" hours greater than or equal to"
- +9 SET DIR("B")="72"
- +10 SET DIR("?")="Enter minimum number of hours elapsed since registration."
- +11 DO ^DIR
- if $DATA(DIRUT)
- QUIT
- SET RASINCE=Y
- +12 QUIT
- DEV ; Device
- +1 IF $DATA(DIRUT)
- DO EXIT
- QUIT
- +2 if RARPT="B"
- WRITE !!,"Specify device for both summary and detail reports."
- +3 DO TASK
- +4 DO ZIS^RAUTL
- +5 QUIT
- TASK ; set vars for taskman
- +1 SET ZTRTN="START^RAPM"
- +2 SET ZTSAVE("RA*")=""
- +3 SET ZTSAVE("^TMP($J,")=""
- +4 ;S ZTSAVE("^TMP($J,""RA D-TYPE"",")=""
- +5 ;S ZTSAVE("^TMP($J,""RA I-TYPE"",")=""
- +6 if $GET(RAP99)
- SET ZTDESC="Radiology Timeliness Performance Reports"
- +7 if '$GET(RAP99)
- SET ZTDESC="Radiology Verification Timeliness Report"
- +8 QUIT
- +9 ;
- GETDATA ; Get all the data
- +1 ; Order thru Exam Date (RADTE)
- +2 SET RADTE=RABEGDT
- FOR
- SET RADTE=$ORDER(^RADPT("AR",RADTE))
- if 'RADTE
- QUIT
- if (RADTE>RAENDDT)
- QUIT
- Begin DoDot:1
- +3 SET RADFN=""
- FOR
- SET RADFN=$ORDER(^RADPT("AR",RADTE,RADFN))
- if 'RADFN
- QUIT
- Begin DoDot:2
- +4 ; Get patient name
- +5 SET RAPATNM=$$GET1^DIQ(2,RADFN,.01)
- if RAPATNM=""
- SET RAPATNM=" "
- +6 ; Order thru inverse Exam Date (RADTI)
- +7 SET RADTI=""
- FOR
- SET RADTI=$ORDER(^RADPT("AR",RADTE,RADFN,RADTI))
- if 'RADTI
- QUIT
- DO CHECK
- +8 QUIT
- End DoDot:2
- +9 QUIT
- End DoDot:1
- +10 QUIT
- CHECK ; Check type of image
- +1 ;no exam data at all
- if '$DATA(^RADPT(RADFN,"DT",RADTI))
- QUIT
- +2 SET RAITYP=$PIECE($GET(^RADPT(RADFN,"DT",RADTI,0)),U,2)
- +3 SET RAIMGTYP=$PIECE($GET(^RA(79.2,+RAITYP,0)),U,1)
- +4 ; quit if img typ is known AND does not match selection
- +5 IF RAIMGTYP'=""
- IF '$DATA(^TMP($JOB,"RA I-TYPE",RAIMGTYP))
- QUIT
- +6 IF RAIMGTYP=""
- SET RAIMGTYP="(unknown)"
- +7 ;
- +8 ; Check division - Quit if no division selected
- +9 SET RASELDIV=$PIECE($GET(^RADPT(RADFN,"DT",RADTI,0)),U,3)
- +10 SET RACHKDIV=$PIECE($GET(^DIC(4,+RASELDIV,0)),U,1)
- +11 ; quit if div is known AND does not match selection
- +12 IF RACHKDIV'=""
- IF '$DATA(^TMP($JOB,"RA D-TYPE",RACHKDIV))
- QUIT
- +13 if RACHKDIV=""
- SET RANODIV=1
- +14 ;
- +15 ; Get exam related data
- +16 SET RACNI=0
- FOR
- SET RACNI=$ORDER(^RADPT(RADFN,"DT",RADTI,"P",RACNI))
- if 'RACNI
- QUIT
- Begin DoDot:1
- +17 SET (RACN0,RAEXST,RANUM,RACN,RAPRIM,RAPRIMNM,RACAT,RARPTTXT)=""
- +18 SET (RARPTDT,RAVERDT,RARPTST,RADHT,RADHV,RATDFHR,RAVDFHR)=""
- +19 ; Get 0 node (RACN0) of ^RADPT(RADFN,"DT",RADTI,"P",RACNI,0)
- +20 SET RACN0=$GET(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0))
- +21 ; no exam data
- if RACN0=""
- QUIT
- +22 ; Get Case number: Exam Date - Case Number
- +23 SET RACN=$EXTRACT(RADTE,4,7)_$EXTRACT(RADTE,2,3)_"-"_$PIECE(RACN0,U,1)
- +24 NEW RASSAN,RACNDSP
- SET RASSAN=$$SSANVAL^RAHLRU1(RADFN,RADTI,RACNI)
- +25 SET RACNDSP=$SELECT((RASSAN'=""):RASSAN,1:RACN)
- +26 ; Get exam status
- +27 SET RAEXST=$PIECE(RACN0,U,3)
- +28 ; no exam status
- if RAEXST=""
- QUIT
- +29 ; Quit if exam's CREDIT METHOD is 2 = no credit
- +30 if $PIECE(RACN0,U,26)=2
- QUIT
- +31 ; Quit if exam status is "Cancelled"
- +32 IF $PIECE(^RA(72,RAEXST,0),U,3)=0
- QUIT
- +33 ; Get number of set - '1' separate; '2' for combined report.
- +34 SET RANUM=$PIECE(RACN0,U,25)
- +35 ; if member of set > 1 then set RACNI to 99999 to skip remaining cases
- +36 IF RANUM>1
- SET RACNI=99999
- +37 ; Get Radiologist (Primary Interpreting Staff) internal # and name.
- +38 SET RAPRIM=$PIECE(RACN0,U,15)
- +39 ; if specific radiologist requested, quit if not his/her case
- +40 IF RARAD
- IF RAPRIM'=RARAD
- QUIT
- +41 SET RAPRIMNM=$$GET1^DIQ(200,RAPRIM,.01)
- if RAPRIMNM=""
- SET RAPRIMNM=" "
- +42 ; Get Category of Exam
- +43 SET RACAT=$PIECE(RACN0,U,4)
- +44 ; Get Procedure Name
- +45 SET RAPRCN=$PIECE($GET(^RAMIS(71,+$PIECE(RACN0,U,2),0)),U)
- +46 ; Get IEN of imaging report
- +47 SET RARPTTXT=$PIECE(RACN0,U,17)
- +48 ; Pending if no imaging report OR report doesn't exist in the Report
- +49 ; file (#74) OR Stub report
- +50 ;=1 has real report
- SET RAHASR=0
- +51 IF $DATA(^RARPT(+RARPTTXT,0))
- IF '$$STUB^RAEDCN1(+RARPTTXT)
- SET RAHASR=1
- +52 IF 'RAHASR
- Begin DoDot:2
- +53 SET ^TMP($JOB,"RAPM","TR",0)=$GET(^TMP($JOB,"RAPM","TR",0))+1
- +54 SET ^TMP($JOB,"RAPM","VR",0)=$GET(^TMP($JOB,"RAPM","VR",0))+1
- End DoDot:2
- +55 ; Get report info. if real report exists.
- +56 IF RAHASR
- DO RPTINFO^RAPM1
- +57 DO STORE^RAPM2
- +58 ; Calculate the total number of reports
- +59 SET ^TMP($JOB,"RAPM","TOTAL")=$GET(^TMP($JOB,"RAPM","TOTAL"))+1
- End DoDot:1
- +60 QUIT
- EXIT ; Exit
- +1 ; Close device
- +2 DO CLOSE^RAUTL
- +3 KILL RACN0,RAEXST,RANUM,RACN,RAPRIM,RAPRIMNM,RACAT,RARPTTXT,RAANS,RATXT
- +4 KILL DIR,DIRUT,RABDATE,RAEDATE,RARPT,DTDIFF,RABEGDT,RAENDDT,RAITYP,RAIMGTYP,RATYP
- +5 KILL ZTRTN,ZTSAVE,ZTDESC,RAPG,RASELDIV,RACHKDIV,RACNO,RAVHRS,RACNDSP,RASSAN
- +6 KILL RADIV,RAN,RAIMG,RAREC1,RATOTCNT,RACNI,RADFN,RADTE,RADTI,RAHD,RAPATNM
- +7 KILL RAPOP,RAPSTX,RAQUIT,RAREC,RARPTDT,RARPTST,RASORT,RASRT,RATDFHR,RAHASR
- +8 KILL RATDFSEC,RATHRS,RAVDFHR,RAVDFSEC,RAVERDT,RAMES,RALINE,RAMAXDT,RADD
- +9 KILL RAANS2,RAIOM,RAHDR,RANODIV,RASINCE,RADHT,RADHV,RAVAL,RAPRCN
- +10 KILL RAXIT,RAIO,RALDENT,RALMAX,RALUSED,RATAIL,RAS99,RAL99,RAP99,RAN
- +11 KILL ^TMP($JOB)
- +12 QUIT