RAWFR1 ;HISC/GJC-'Wasted Film Report' (1 of 4) ;4/15/96 07:22
;;5.0;Radiology/Nuclear Medicine;;Mar 16, 1998
;
; *** Variable List ***
; ------------------ Validate Rad/Nuc Med User -------------------------
I '($D(RACCESS)\10) D SETVARS^RAPSET1(0) S RAPSTX=""
I '($D(RACCESS)\10) D ACCVIO^RAUTL19,KILL^RAWFR3 Q
; ----------------------------------------------------------------------
K ^TMP($J,"RA WFR") S RATDAY=$$FMTE^XLFDT($$NOW^XLFDT,1)
S RADATE=$$FMTE^XLFDT($$NOW^XLFDT\1,1),RAXIT=0
K X,Y,Z S X="Radiology/Nuclear Med" W @IOF
S Y="*** Wasted Film Report ***",$P(Z,"-",($L(Y)+1))=""
W !?(IOM-$L(X)\2),X,!?(IOM-$L(Y)\2),Y,!?(IOM-$L(Z)\2),Z,!
K DIR,X,Y,Z
S DIR("A")="Do you wish to generate a summary report only"
S DIR("?",1)="Enter 'Y' to generate a general summary report by division."
S DIR("?")="Enter <CR> or 'No' to generate a detailed divisional report."
S DIR("B")="No",DIR(0)="Y" D ^DIR K DIR
I $D(DIRUT) D D KILL^RAWFR3 Q
. W !?5,$C(7),"The 'Summary Report' question must be answered to"
. W !?5,"continue on with the 'Wasted Film Report'."
. Q
S RASYN=+Y W !
DIVITY ; Select division/imaging type
S X=$$DIVLOC^RAUTL7()
I X D KILL^RAWFR3 Q
I $D(RACCESS(DUZ,"DIV-IMG")) D
. D ZEROUT^RAWFR4
. Q
E D KILL^RAWFR3 Q
; *** Start of Exam Status display ***
D DISPXAM^RAWFR4(6)
I RAXIT!('($D(RAWFR)\10)) D KILL^RAWFR3 Q
; *** End of Exam Status display ***
STRTDT ; *** Prompt for Starting Date ***
W ! K DIR S DIR(0)="DA^:"_DT_":PEA"
S DIR("A")="Enter the start date for the search: "
S DIR("?",1)="This is the date from which our search will begin."
S DIR("?",2)="Think of it in terms of 'FROM' and 'TO'. This date is our 'FROM'."
S DIR("?",3)="The starting date must not exceed: "_RADATE_"."
S DIR("?")="Dates associated with a time will not be accepted."
S DIR("B")=RADATE D ^DIR K DIR
I $D(DIRUT) D KILL^RAWFR3 Q
S RABGDTI=Y,RABGDTX=Y(0),RAMBGDT=RABGDTI-.0001
;
ENDDT ; *** Prompt for Ending Date ***
W ! K DIR S DIR(0)="DA^"_RABGDTI_":"_DT_":PEA"
S DIR("A")="Enter the ending date for the search: "
S DIR("?",1)="This is the date in which our search will end."
S DIR("?",2)="Think of it in terms of 'FROM' and 'TO'. This date is our 'TO'."
S DIR("?",3)="The ending date must not exceed: "_RADATE_"."
S DIR("?",4)="The ending date must not precede: "_RABGDTX_"."
S DIR("?")="Dates associated with a time will not be accepted."
S DIR("B")=RABGDTX D ^DIR K DIR
I $D(DIRUT) D KILL^RAWFR3 Q
S RAENDTI=Y,RAENDTX=Y(0),RAMENDT=RAENDTI+.9999
S ZTSAVE("RA*")="",ZTSAVE("^TMP($J,""RA D-TYPE"",")=""
S ZTSAVE("^TMP($J,""RA I-TYPE"",")="",ZTSAVE("^TMP($J,""RA WFR"",")=""
S ZTRTN="START^RAWFR1"
S ZTDESC="Rad/Nuc Med Wasted Film report"
W ! D ZIS^RAUTL
I POP D KILL^RAWFR3 Q
I +$G(RAPOP) D KILL^RAWFR3 Q ;'RAPOP' set to '1' if task is created
START ; Start the sort/print process
U IO S $P(RALINE,"-",$S(IOM=132:133,1:81))=""
S:$D(ZTQUEUED) ZTREQ="@"
S RAHEAD=">>>>> Wasted Film Report <<<<<"
F RADT=RAMBGDT:0:RAMENDT S RADT=$O(^RADPT("AR",RADT)) Q:RADT'>0!(RADT>RAMENDT)!(RAXIT) D
. S RADFN=0 F S RADFN=$O(^RADPT("AR",RADT,RADFN)) Q:RADFN'>0!(RAXIT) D
.. S RADTI=0 F S RADTI=$O(^RADPT("AR",RADT,RADFN,RADTI)) Q:RADTI'>0!(RAXIT) D
... I $G(^RADPT(RADFN,"DT",RADTI,0))]"" D
.... S RARP0=$G(^RADPT(RADFN,"DT",RADTI,0)) D RAEXAM
.... Q
... Q
.. Q
. Q
; If 'RASYN'=1 do summary
I 'RAXIT D:RASYN COMPSUM^RAWFR2 D:'RASYN COMP^RAWFR3
K RACCESS(DUZ,"DIV-IMG") W ! D ^%ZISC
D KILL^RAWFR3
Q
RAEXAM ; Journey through the 'Examination' multiple.
S RAEX=0
F S RAEX=$O(^RADPT(RADFN,"DT",RADTI,"P",RAEX)) Q:RAEX'>0!(RAXIT) D
. I $G(^RADPT(RADFN,"DT",RADTI,"P",RAEX,0))]"" D
.. S RAEX0=$G(^RADPT(RADFN,"DT",RADTI,"P",RAEX,0))
.. S RAEXS=+$P(RAEX0,U,3)
.. I $D(RAWFR(RAEXS)) D SETUP^RAWFR2
.. Q
. Q
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRAWFR1 3960 printed Dec 13, 2024@02:40:36 Page 2
RAWFR1 ;HISC/GJC-'Wasted Film Report' (1 of 4) ;4/15/96 07:22
+1 ;;5.0;Radiology/Nuclear Medicine;;Mar 16, 1998
+2 ;
+3 ; *** Variable List ***
+4 ; ------------------ Validate Rad/Nuc Med User -------------------------
+5 IF '($DATA(RACCESS)\10)
DO SETVARS^RAPSET1(0)
SET RAPSTX=""
+6 IF '($DATA(RACCESS)\10)
DO ACCVIO^RAUTL19
DO KILL^RAWFR3
QUIT
+7 ; ----------------------------------------------------------------------
+8 KILL ^TMP($JOB,"RA WFR")
SET RATDAY=$$FMTE^XLFDT($$NOW^XLFDT,1)
+9 SET RADATE=$$FMTE^XLFDT($$NOW^XLFDT\1,1)
SET RAXIT=0
+10 KILL X,Y,Z
SET X="Radiology/Nuclear Med"
WRITE @IOF
+11 SET Y="*** Wasted Film Report ***"
SET $PIECE(Z,"-",($LENGTH(Y)+1))=""
+12 WRITE !?(IOM-$LENGTH(X)\2),X,!?(IOM-$LENGTH(Y)\2),Y,!?(IOM-$LENGTH(Z)\2),Z,!
+13 KILL DIR,X,Y,Z
+14 SET DIR("A")="Do you wish to generate a summary report only"
+15 SET DIR("?",1)="Enter 'Y' to generate a general summary report by division."
+16 SET DIR("?")="Enter <CR> or 'No' to generate a detailed divisional report."
+17 SET DIR("B")="No"
SET DIR(0)="Y"
DO ^DIR
KILL DIR
+18 IF $DATA(DIRUT)
Begin DoDot:1
+19 WRITE !?5,$CHAR(7),"The 'Summary Report' question must be answered to"
+20 WRITE !?5,"continue on with the 'Wasted Film Report'."
+21 QUIT
End DoDot:1
DO KILL^RAWFR3
QUIT
+22 SET RASYN=+Y
WRITE !
DIVITY ; Select division/imaging type
+1 SET X=$$DIVLOC^RAUTL7()
+2 IF X
DO KILL^RAWFR3
QUIT
+3 IF $DATA(RACCESS(DUZ,"DIV-IMG"))
Begin DoDot:1
+4 DO ZEROUT^RAWFR4
+5 QUIT
End DoDot:1
+6 IF '$TEST
DO KILL^RAWFR3
QUIT
+7 ; *** Start of Exam Status display ***
+8 DO DISPXAM^RAWFR4(6)
+9 IF RAXIT!('($DATA(RAWFR)\10))
DO KILL^RAWFR3
QUIT
+10 ; *** End of Exam Status display ***
STRTDT ; *** Prompt for Starting Date ***
+1 WRITE !
KILL DIR
SET DIR(0)="DA^:"_DT_":PEA"
+2 SET DIR("A")="Enter the start date for the search: "
+3 SET DIR("?",1)="This is the date from which our search will begin."
+4 SET DIR("?",2)="Think of it in terms of 'FROM' and 'TO'. This date is our 'FROM'."
+5 SET DIR("?",3)="The starting date must not exceed: "_RADATE_"."
+6 SET DIR("?")="Dates associated with a time will not be accepted."
+7 SET DIR("B")=RADATE
DO ^DIR
KILL DIR
+8 IF $DATA(DIRUT)
DO KILL^RAWFR3
QUIT
+9 SET RABGDTI=Y
SET RABGDTX=Y(0)
SET RAMBGDT=RABGDTI-.0001
+10 ;
ENDDT ; *** Prompt for Ending Date ***
+1 WRITE !
KILL DIR
SET DIR(0)="DA^"_RABGDTI_":"_DT_":PEA"
+2 SET DIR("A")="Enter the ending date for the search: "
+3 SET DIR("?",1)="This is the date in which our search will end."
+4 SET DIR("?",2)="Think of it in terms of 'FROM' and 'TO'. This date is our 'TO'."
+5 SET DIR("?",3)="The ending date must not exceed: "_RADATE_"."
+6 SET DIR("?",4)="The ending date must not precede: "_RABGDTX_"."
+7 SET DIR("?")="Dates associated with a time will not be accepted."
+8 SET DIR("B")=RABGDTX
DO ^DIR
KILL DIR
+9 IF $DATA(DIRUT)
DO KILL^RAWFR3
QUIT
+10 SET RAENDTI=Y
SET RAENDTX=Y(0)
SET RAMENDT=RAENDTI+.9999
+11 SET ZTSAVE("RA*")=""
SET ZTSAVE("^TMP($J,""RA D-TYPE"",")=""
+12 SET ZTSAVE("^TMP($J,""RA I-TYPE"",")=""
SET ZTSAVE("^TMP($J,""RA WFR"",")=""
+13 SET ZTRTN="START^RAWFR1"
+14 SET ZTDESC="Rad/Nuc Med Wasted Film report"
+15 WRITE !
DO ZIS^RAUTL
+16 IF POP
DO KILL^RAWFR3
QUIT
+17 ;'RAPOP' set to '1' if task is created
IF +$GET(RAPOP)
DO KILL^RAWFR3
QUIT
START ; Start the sort/print process
+1 USE IO
SET $PIECE(RALINE,"-",$SELECT(IOM=132:133,1:81))=""
+2 if $DATA(ZTQUEUED)
SET ZTREQ="@"
+3 SET RAHEAD=">>>>> Wasted Film Report <<<<<"
+4 FOR RADT=RAMBGDT:0:RAMENDT
SET RADT=$ORDER(^RADPT("AR",RADT))
if RADT'>0!(RADT>RAMENDT)!(RAXIT)
QUIT
Begin DoDot:1
+5 SET RADFN=0
FOR
SET RADFN=$ORDER(^RADPT("AR",RADT,RADFN))
if RADFN'>0!(RAXIT)
QUIT
Begin DoDot:2
+6 SET RADTI=0
FOR
SET RADTI=$ORDER(^RADPT("AR",RADT,RADFN,RADTI))
if RADTI'>0!(RAXIT)
QUIT
Begin DoDot:3
+7 IF $GET(^RADPT(RADFN,"DT",RADTI,0))]""
Begin DoDot:4
+8 SET RARP0=$GET(^RADPT(RADFN,"DT",RADTI,0))
DO RAEXAM
+9 QUIT
End DoDot:4
+10 QUIT
End DoDot:3
+11 QUIT
End DoDot:2
+12 QUIT
End DoDot:1
+13 ; If 'RASYN'=1 do summary
+14 IF 'RAXIT
if RASYN
DO COMPSUM^RAWFR2
if 'RASYN
DO COMP^RAWFR3
+15 KILL RACCESS(DUZ,"DIV-IMG")
WRITE !
DO ^%ZISC
+16 DO KILL^RAWFR3
+17 QUIT
RAEXAM ; Journey through the 'Examination' multiple.
+1 SET RAEX=0
+2 FOR
SET RAEX=$ORDER(^RADPT(RADFN,"DT",RADTI,"P",RAEX))
if RAEX'>0!(RAXIT)
QUIT
Begin DoDot:1
+3 IF $GET(^RADPT(RADFN,"DT",RADTI,"P",RAEX,0))]""
Begin DoDot:2
+4 SET RAEX0=$GET(^RADPT(RADFN,"DT",RADTI,"P",RAEX,0))
+5 SET RAEXS=+$PIECE(RAEX0,U,3)
+6 IF $DATA(RAWFR(RAEXS))
DO SETUP^RAWFR2
+7 QUIT
End DoDot:2
+8 QUIT
End DoDot:1
+9 QUIT
