- 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 Feb 19, 2025@00:06:52 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