- RAWFR3 ;HISC/GJC-'Wasted Film Report' (3 of 4) ;4/15/96 07:12
- ;;5.0;Radiology/Nuclear Medicine;;Mar 16, 1998
- ;
- COMP ; Compilation for 'Non-Summary' data
- N RACINE,RAF0,RAHDRFG,RATIO,RAUSED,X2,X3,X4,Y0,Y1,Y2,Y3
- S RAHDRFG=0,X2="" ; 'X2' is the division
- F S X2=$O(^TMP($J,"RA WFR","NS",X2)) Q:X2']""!(RAXIT) D
- . S Y0=$G(^TMP($J,"RA WFR","NS",X2)) ; 'Y0' total # of all films
- . S X3="" ; 'X3' is the imaging location
- . F S X3=$O(^TMP($J,"RA WFR","NS",X2,"I",X3)) Q:X3']""!(RAXIT) D
- .. Q:'$D(^TMP($J,"RA WFR","NS",X2,"I",X3,"WF"))
- .. I RAHDRFG S RAXIT=$$EOS^RAUTL5 Q:RAXIT
- .. S RADIV=X2,RAIMG=X3,(Y0,Y3)=0 D HDR
- .. ; films for a particular imaging type
- .. S X4="" ; wasted film type if 'X1' is "F", tech if 'X1' is "T"
- .. F S X4=$O(^TMP($J,"RA WFR","NS",X2,"I",X3,"WF",X4)) Q:X4']""!(RAXIT) D
- ... S RAUSED=+$O(^RA(78.4,"B",X4,0)) Q:'RAUSED
- ... S RAUSED=+$P(^RA(78.4,RAUSED,0),U,5) Q:'RAUSED
- ... S RAF0=$G(^RA(78.4,RAUSED,0))
- ... S RAUSED=$P(RAF0,U),RACINE=$S($P(RAF0,U,2)="Y":1,1:0)
- ... ;Q:'$D(^TMP($J,"RA WFR","NS",X2,"I",X3,"F",RAUSED))
- ... S Y2=$G(^TMP($J,"RA WFR","NS",X2,"I",X3,"F",RAUSED))
- ... S Y1=$G(^TMP($J,"RA WFR","NS",X2,"I",X3,"WF",X4))
- ... I 'RACINE S Y0=Y0+Y1,Y3=Y3+Y2 ; add to subtotals if not cine type
- ... ; 'Y3' is used for the division summary
- ... S RATIO=$S((Y1+Y2)>0:$J((Y1/(Y1+Y2))*100,5,1),1:0)
- ... W !,X4,?$S(IOM=132:60,1:35),Y2,?$S(IOM=132:75,1:45),Y1
- ... W ?$S(IOM=132:100,1:60),RATIO
- ... I $Y>(IOSL-4) S RAXIT=$$EOS^RAUTL5 Q:RAXIT D HDR
- ... Q
- .. Q:RAXIT W !!?$S(IOM=132:10,1:5),"Subtotals:"
- .. W ?$S(IOM=132:60,1:35),$S('Y3:"",1:Y3)
- .. W ?$S(IOM=132:75,1:45),Y0
- .. W ?$S(IOM=132:100,1:60),$S((Y0+Y3)>0:$J((Y0/(Y0+Y3))*100,5,1),1:0)
- .. S RAHDRFG=1 W !,RALINE
- .. I $Y>(IOSL-4) S RAXIT=$$EOS^RAUTL5 Q:RAXIT D HDR
- .. W !!?5,"* Cine data not included in totals."
- .. Q
- . Q:RAXIT
- . I RATOT>1 D
- .. N X S X=X2 N RASYN,RATIO,RAUSED,X1,X2,X3,X4,Y0,Y1,Y2,Y3
- .. S RASYN=1 D SUMMARY^RAWFR2(X)
- .. Q
- . Q
- Q
- KILL ; Kill and quit
- K %,%CHK,%RET,%Z,DIROUT,DIRUT,DTOUT,DUOUT,I,RABGDTI,RABGDTX,RACCESS
- K RADATE,RADFN,RADIV,RADT,RADTI,RAENDTI,RAENDTX,RAEXST,RAEX,RAEX0
- K RAEXS,RAFLM0,RAFLMNUM,RAFLMS,RAHEAD,RAIBGDT,RAIENDT,RAIMG,RALINE
- K RAMBGDT,RAMENDT,RAMES,RAPG,RAPOP,RAQUIT,RARP0,RASYN,RATAG,RATDAY
- K RATECH,RATOT,RAWFR,RAXIT,X,Y,Z,ZTDESC,ZTRTN,ZTSAVE,POP
- K ^TMP($J,"RA D-TYPE"),^TMP($J,"RA I-TYPE")
- K ^TMP($J,"RA WFR") K:$D(RAPSTX) RACCESS,RAPSTX
- Q
- HDR ; Display/Print the header for the report
- W:$E(IOST,1,2)="C-" @IOF,!
- W:$E(IOST,1,2)'="C-"&(+$G(RAPG)>0) @IOF,!
- S RAPG=+$G(RAPG)+1
- W !?(IOM-$L(RAHEAD)\2),RAHEAD,?$S(IOM=132:122,1:69),"Page: ",RAPG,!
- I RASYN D
- . W !?$S(IOM=132:10,1:5),"Division: ",$G(RADIV)
- . W ?$S(IOM=132:85,1:50),"For Period: ",RABGDTX_" to"
- . W !?$S(IOM=132:10,1:5),"Run Date: ",RATDAY
- . W ?$S(IOM=132:97,1:62),RAENDTX_"."
- E D
- . W !?$S(IOM=132:10,1:5),"Division: ",$G(RADIV)
- . W ?$S(IOM=132:85,1:50),"For Period: ",RABGDTX_" to"
- . W !?$S(IOM=132:10,1:5),"Imaging Type: ",$G(RAIMG)
- . W ?$S(IOM=132:97,1:62),RAENDTX_"."
- . W !?$S(IOM=132:10,1:5),"Run Date: ",RATDAY
- W !!?$S(IOM=132:60,1:35),"Units",?$S(IOM=132:75,1:45),"Units"
- W ?$S(IOM=132:100,1:60),"Percentage"
- W !?$S(IOM=132:60,1:35),"Of Used",?$S(IOM=132:75,1:45),"Of Wasted"
- W ?$S(IOM=132:100,1:60),"Of Wasted"
- W !,"Film Size",?$S(IOM=132:60,1:35),"Films"
- W ?$S(IOM=132:75,1:45),"Films"
- W ?$S(IOM=132:100,1:60),"Film"
- W !,RALINE
- W:RASYN !?$S(IOM=132:10,1:5),"(Division Summary)"
- I $D(ZTQUEUED) D STOPCHK^RAUTL9 S:$G(ZTSTOP)=1 RAXIT=1
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRAWFR3 3586 printed Feb 19, 2025@00:06:54 Page 2
- RAWFR3 ;HISC/GJC-'Wasted Film Report' (3 of 4) ;4/15/96 07:12
- +1 ;;5.0;Radiology/Nuclear Medicine;;Mar 16, 1998
- +2 ;
- COMP ; Compilation for 'Non-Summary' data
- +1 NEW RACINE,RAF0,RAHDRFG,RATIO,RAUSED,X2,X3,X4,Y0,Y1,Y2,Y3
- +2 ; 'X2' is the division
- SET RAHDRFG=0
- SET X2=""
- +3 FOR
- SET X2=$ORDER(^TMP($JOB,"RA WFR","NS",X2))
- if X2']""!(RAXIT)
- QUIT
- Begin DoDot:1
- +4 ; 'Y0' total # of all films
- SET Y0=$GET(^TMP($JOB,"RA WFR","NS",X2))
- +5 ; 'X3' is the imaging location
- SET X3=""
- +6 FOR
- SET X3=$ORDER(^TMP($JOB,"RA WFR","NS",X2,"I",X3))
- if X3']""!(RAXIT)
- QUIT
- Begin DoDot:2
- +7 if '$DATA(^TMP($JOB,"RA WFR","NS",X2,"I",X3,"WF"))
- QUIT
- +8 IF RAHDRFG
- SET RAXIT=$$EOS^RAUTL5
- if RAXIT
- QUIT
- +9 SET RADIV=X2
- SET RAIMG=X3
- SET (Y0,Y3)=0
- DO HDR
- +10 ; films for a particular imaging type
- +11 ; wasted film type if 'X1' is "F", tech if 'X1' is "T"
- SET X4=""
- +12 FOR
- SET X4=$ORDER(^TMP($JOB,"RA WFR","NS",X2,"I",X3,"WF",X4))
- if X4']""!(RAXIT)
- QUIT
- Begin DoDot:3
- +13 SET RAUSED=+$ORDER(^RA(78.4,"B",X4,0))
- if 'RAUSED
- QUIT
- +14 SET RAUSED=+$PIECE(^RA(78.4,RAUSED,0),U,5)
- if 'RAUSED
- QUIT
- +15 SET RAF0=$GET(^RA(78.4,RAUSED,0))
- +16 SET RAUSED=$PIECE(RAF0,U)
- SET RACINE=$SELECT($PIECE(RAF0,U,2)="Y":1,1:0)
- +17 ;Q:'$D(^TMP($J,"RA WFR","NS",X2,"I",X3,"F",RAUSED))
- +18 SET Y2=$GET(^TMP($JOB,"RA WFR","NS",X2,"I",X3,"F",RAUSED))
- +19 SET Y1=$GET(^TMP($JOB,"RA WFR","NS",X2,"I",X3,"WF",X4))
- +20 ; add to subtotals if not cine type
- IF 'RACINE
- SET Y0=Y0+Y1
- SET Y3=Y3+Y2
- +21 ; 'Y3' is used for the division summary
- +22 SET RATIO=$SELECT((Y1+Y2)>0:$JUSTIFY((Y1/(Y1+Y2))*100,5,1),1:0)
- +23 WRITE !,X4,?$SELECT(IOM=132:60,1:35),Y2,?$SELECT(IOM=132:75,1:45),Y1
- +24 WRITE ?$SELECT(IOM=132:100,1:60),RATIO
- +25 IF $Y>(IOSL-4)
- SET RAXIT=$$EOS^RAUTL5
- if RAXIT
- QUIT
- DO HDR
- +26 QUIT
- End DoDot:3
- +27 if RAXIT
- QUIT
- WRITE !!?$SELECT(IOM=132:10,1:5),"Subtotals:"
- +28 WRITE ?$SELECT(IOM=132:60,1:35),$SELECT('Y3:"",1:Y3)
- +29 WRITE ?$SELECT(IOM=132:75,1:45),Y0
- +30 WRITE ?$SELECT(IOM=132:100,1:60),$SELECT((Y0+Y3)>0:$JUSTIFY((Y0/(Y0+Y3))*100,5,1),1:0)
- +31 SET RAHDRFG=1
- WRITE !,RALINE
- +32 IF $Y>(IOSL-4)
- SET RAXIT=$$EOS^RAUTL5
- if RAXIT
- QUIT
- DO HDR
- +33 WRITE !!?5,"* Cine data not included in totals."
- +34 QUIT
- End DoDot:2
- +35 if RAXIT
- QUIT
- +36 IF RATOT>1
- Begin DoDot:2
- +37 NEW X
- SET X=X2
- NEW RASYN,RATIO,RAUSED,X1,X2,X3,X4,Y0,Y1,Y2,Y3
- +38 SET RASYN=1
- DO SUMMARY^RAWFR2(X)
- +39 QUIT
- End DoDot:2
- +40 QUIT
- End DoDot:1
- +41 QUIT
- KILL ; Kill and quit
- +1 KILL %,%CHK,%RET,%Z,DIROUT,DIRUT,DTOUT,DUOUT,I,RABGDTI,RABGDTX,RACCESS
- +2 KILL RADATE,RADFN,RADIV,RADT,RADTI,RAENDTI,RAENDTX,RAEXST,RAEX,RAEX0
- +3 KILL RAEXS,RAFLM0,RAFLMNUM,RAFLMS,RAHEAD,RAIBGDT,RAIENDT,RAIMG,RALINE
- +4 KILL RAMBGDT,RAMENDT,RAMES,RAPG,RAPOP,RAQUIT,RARP0,RASYN,RATAG,RATDAY
- +5 KILL RATECH,RATOT,RAWFR,RAXIT,X,Y,Z,ZTDESC,ZTRTN,ZTSAVE,POP
- +6 KILL ^TMP($JOB,"RA D-TYPE"),^TMP($JOB,"RA I-TYPE")
- +7 KILL ^TMP($JOB,"RA WFR")
- if $DATA(RAPSTX)
- KILL RACCESS,RAPSTX
- +8 QUIT
- HDR ; Display/Print the header for the report
- +1 if $EXTRACT(IOST,1,2)="C-"
- WRITE @IOF,!
- +2 if $EXTRACT(IOST,1,2)'="C-"&(+$GET(RAPG)>0)
- WRITE @IOF,!
- +3 SET RAPG=+$GET(RAPG)+1
- +4 WRITE !?(IOM-$LENGTH(RAHEAD)\2),RAHEAD,?$SELECT(IOM=132:122,1:69),"Page: ",RAPG,!
- +5 IF RASYN
- Begin DoDot:1
- +6 WRITE !?$SELECT(IOM=132:10,1:5),"Division: ",$GET(RADIV)
- +7 WRITE ?$SELECT(IOM=132:85,1:50),"For Period: ",RABGDTX_" to"
- +8 WRITE !?$SELECT(IOM=132:10,1:5),"Run Date: ",RATDAY
- +9 WRITE ?$SELECT(IOM=132:97,1:62),RAENDTX_"."
- End DoDot:1
- +10 IF '$TEST
- Begin DoDot:1
- +11 WRITE !?$SELECT(IOM=132:10,1:5),"Division: ",$GET(RADIV)
- +12 WRITE ?$SELECT(IOM=132:85,1:50),"For Period: ",RABGDTX_" to"
- +13 WRITE !?$SELECT(IOM=132:10,1:5),"Imaging Type: ",$GET(RAIMG)
- +14 WRITE ?$SELECT(IOM=132:97,1:62),RAENDTX_"."
- +15 WRITE !?$SELECT(IOM=132:10,1:5),"Run Date: ",RATDAY
- End DoDot:1
- +16 WRITE !!?$SELECT(IOM=132:60,1:35),"Units",?$SELECT(IOM=132:75,1:45),"Units"
- +17 WRITE ?$SELECT(IOM=132:100,1:60),"Percentage"
- +18 WRITE !?$SELECT(IOM=132:60,1:35),"Of Used",?$SELECT(IOM=132:75,1:45),"Of Wasted"
- +19 WRITE ?$SELECT(IOM=132:100,1:60),"Of Wasted"
- +20 WRITE !,"Film Size",?$SELECT(IOM=132:60,1:35),"Films"
- +21 WRITE ?$SELECT(IOM=132:75,1:45),"Films"
- +22 WRITE ?$SELECT(IOM=132:100,1:60),"Film"
- +23 WRITE !,RALINE
- +24 if RASYN
- WRITE !?$SELECT(IOM=132:10,1:5),"(Division Summary)"
- +25 IF $DATA(ZTQUEUED)
- DO STOPCHK^RAUTL9
- if $GET(ZTSTOP)=1
- SET RAXIT=1
- +26 QUIT