Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: RAWFR1

RAWFR1.m

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