- RALWKL1 ;HISC/GJC-Workload Reports By Functional Area ;4/12/96 10:18
- ;;5.0;Radiology/Nuclear Medicine;;Mar 16, 1998
- EN1 ; Entry point
- S X="NOW",%DT="T" D ^%DT K %DT D D^RAUTL S RATDY=Y,$P(RALN,"-",81)=""
- S BEGDATE("X")=$$FMTE^XLFDT(BEGDATE,1)
- S ENDDATE("X")=$$FMTE^XLFDT(ENDDATE,1),RAPG=0 W:$Y>0 @IOF
- I RASUM D EN1^RALWKL4 Q ; Do summary report quit.
- S RADIV=$O(^TMP($J,"RA","")),RAIMG=$O(^TMP($J,"RA",RADIV,""))
- S RADIV="" F S RADIV=$O(^TMP($J,"RA",RADIV)) Q:RADIV']"" D Q:RAXIT
- . S RAIMG="" F S RAIMG=$O(^TMP($J,"RA",RADIV,RAIMG)) Q:RAIMG']"" D Q:RAXIT
- .. S RAFLD=""
- .. F S RAFLD=$O(^TMP($J,"RA",RADIV,RAIMG,RAFLD)) Q:RAFLD']"" D Q:RAXIT
- ... S RATTL0=$G(^TMP($J,"RA",RADIV,RAIMG,RAFLD)),RAWWU1=$P(RATTL0,"^",5)
- ... S RATTL1=0 F I=1:1:4 S RATTL1=RATTL1+$P(RATTL0,"^",I)
- ... S RAMIS=0
- ... F S RAMIS=$O(^TMP($J,"RA",RADIV,RAIMG,RAFLD,RAMIS)) Q:RAMIS'>0 D Q:RAXIT
- .... Q:RAMIS'<25&(RAMIS'=27)&(RAMIS'=99) S RAPRC=""
- .... F S RAPRC=$O(^TMP($J,"RA",RADIV,RAIMG,RAFLD,RAMIS,RAPRC)) Q:RAPRC']"" D Q:RAXIT
- ..... D PRT1
- ..... Q
- .... Q
- ... D:'RAXIT TOT
- ... Q
- .. D:'RAXIT IMGCHK^RALWKL2
- .. Q
- . D:'RAXIT&(RADIFLG(RADIV)>1) DIVCHK^RALWKL2
- . Q
- Q
- PRT1 ; Tabulate the data for non summary report, output the data.
- S RATTL2=$G(^TMP($J,"RA",RADIV,RAIMG,RAFLD,RAMIS,RAPRC))
- S RAWWU2=$P(RATTL2,"^",5),RATTL3=0 ; Total up the first four pieces.
- F I=1:1:4 S RATTL3=RATTL3+$P(RATTL2,"^",I)
- D:'RAPG HD Q:RAXIT
- I $Y>(IOSL-4) S RAXIT=$$EOS^RAUTL5() D:'RAXIT HD Q:RAXIT
- W !,$E(RAPRC,1,28),?30,$J(+$P(RATTL2,"^"),5),?36,$J(+$P(RATTL2,"^",2),5)
- W ?42,$J(+$P(RATTL2,"^",3),5),?48,$J(+$P(RATTL2,"^",4),5)
- W ?55,$J(RATTL3,5),?62,$J($S(RATTL1:(100*RATTL3)/RATTL1,1:0),5,1)
- I $D(RAFL) D
- . W ?68,$J(RAWWU2,5),?75,$J($S(RAWWU1:(RAWWU2*100)/RAWWU1,1:0),5,1)
- . Q
- Q
- TOT ; Total within Service, Ward, Clinic, etc.
- I 'RATTL1,('RAWWU1) Q
- I $Y>(IOSL-4) S RAXIT=$$EOS^RAUTL5() D:'RAXIT HD Q:RAXIT
- W !!,$G(RATITLE)_" Total"
- W ?30,$J(+$P(RATTL0,"^"),5),?36,$J(+$P(RATTL0,"^",2),5)
- W ?42,$J(+$P(RATTL0,"^",3),5),?48,$J(+$P(RATTL0,"^",4),5)
- W ?55,$J(RATTL1,5)
- W:$D(RAFL) ?68,$J(RAWWU1,5)
- W !,RALN N RA1 S RA1=$O(^TMP($J,"RA",RADIV,RAIMG,RAFLD))
- I RA1]"" N RAFLD S RAFLD=RA1,RAXIT=$$EOS^RAUTL5() D:'RAXIT HD
- Q
- HD ; Header
- I RAPG!($E(IOST,1,2)="C-") W:$Y>0 @IOF
- S RAPG=RAPG+1
- W !?5,">>> "_RATITLE_" Workload Report <<<"
- W ?70,"Page: ",RAPG
- W !!?4,"Division: ",$S($D(^DIC(4,+RADIV,0)):$P(^(0),U,1),1:"UNKNOWN")
- W:'$D(RADIVSUM) !,"Imaging Type: ",$S($D(^RA(79.2,+$P(RAIMG,"-",2),0)):$P(^(0),U,1),1:"UNKNOWN")
- W ?52,"For period: ",?64,BEGDATE("X"),?77,"to"
- W !?4,"Run Date: ",RATDY,?64,ENDDATE("X")
- W !!?32,"-------Examinations------",!?62,"% of" W:$D(RAFL) ?75," % of"
- W !,$S('RASUM:"Procedure",1:RATITLE),?30," Inpt",?36," Opt"
- W ?42," Res",?48,"Other",?55,"Total",?62,"Exams"
- W:$D(RAFL) ?68," WWU",?75," WWU"
- W !,RALN
- W:$D(RADIVSUM) !?10,"(Division Summary)" ; set in DIVCHK^RALWKL2
- W:$D(RAIMGSUM) !?10,"(Imaging Type Summary)" ; set in IMGCHK^RALWKL2
- W:'$D(RADIVSUM)&('$D(RAIMGSUM))&('RASUM) !?10,RATITLE,": ",$G(RAFLD)
- I $D(ZTQUEUED) D STOPCHK^RAUTL9 S:$G(ZTSTOP)=1 RAXIT=1
- Q
- DISPXAM(A) ; Display Examination Statuses which meet certain criteria.
- ; 'A' is the equivalent of the variable 'RACRT'. This code is related
- ; to the 'CRIT^RAUTL1' subroutine. This sets up the RACRT local array
- ; according to I-Type.
- N RA,RAHD,UNDRLN,X,Y,Z
- S RAHD(0)="The entries printed for this report will be based only"
- S RAHD(1)="on exams that are in one of the following statuses:"
- W !!?(IOM-$L(RAHD(0))\2),RAHD(0),!?(IOM-$L(RAHD(1))\2),RAHD(1)
- S X="" F S X=$O(^TMP($J,"RA I-TYPE",X)) Q:X']"" D Q:RAXIT
- . I $D(^RA(72,"AA",X)) K UNDRLN S Y="" D
- .. I $Y>(IOSL-4) S RAXIT=$$EOS^RAUTL5() Q:RAXIT W @IOF
- .. S $P(UNDRLN,"-",($L(X)+1))="" W !!?10,X,!?10,UNDRLN
- .. F S Y=$O(^RA(72,"AA",X,Y)) Q:Y']"" D Q:RAXIT
- ... S Z=0 F S Z=$O(^RA(72,"AA",X,Y,Z)) Q:'Z D Q:RAXIT
- .... S RA(0)=$G(^RA(72,Z,0)),RA(.3)=$G(^RA(72,Z,.3))
- .... S RA(.3,A)=$P(RA(.3),"^",A)
- .... I RA(0)]"",(RA(.3)]""),(RA(.3,A)]""),("Yy"[RA(.3,A)) D
- ..... S RACRT(Z)=X ; Where 'X' is the I-Type
- ..... I $Y>(IOSL-4) S RAXIT=$$EOS^RAUTL5() Q:RAXIT D
- ...... W @IOF,!?10,X,!?10,UNDRLN
- ...... Q
- ..... W !?15,$P(RA(0),"^")
- ..... Q
- .... Q
- ... Q
- .. Q
- . Q
- Q
- RALWKL1 ;HISC/GJC-Workload Reports By Functional Area ;4/12/96 10:18
- +1 ;;5.0;Radiology/Nuclear Medicine;;Mar 16, 1998
- EN1 ; Entry point
- +1 SET X="NOW"
- SET %DT="T"
- DO ^%DT
- KILL %DT
- DO D^RAUTL
- SET RATDY=Y
- SET $PIECE(RALN,"-",81)=""
- +2 SET BEGDATE("X")=$$FMTE^XLFDT(BEGDATE,1)
- +3 SET ENDDATE("X")=$$FMTE^XLFDT(ENDDATE,1)
- SET RAPG=0
- IF $Y>0
- WRITE @IOF
- +4 ; Do summary report quit.
- IF RASUM
- DO EN1^RALWKL4
- QUIT
- +5 SET RADIV=$ORDER(^TMP($JOB,"RA",""))
- SET RAIMG=$ORDER(^TMP($JOB,"RA",RADIV,""))
- +6 SET RADIV=""
- FOR
- SET RADIV=$ORDER(^TMP($JOB,"RA",RADIV))
- IF RADIV']""
- QUIT
- Begin DoDot:1
- +7 SET RAIMG=""
- FOR
- SET RAIMG=$ORDER(^TMP($JOB,"RA",RADIV,RAIMG))
- IF RAIMG']""
- QUIT
- Begin DoDot:2
- +8 SET RAFLD=""
- +9 FOR
- SET RAFLD=$ORDER(^TMP($JOB,"RA",RADIV,RAIMG,RAFLD))
- IF RAFLD']""
- QUIT
- Begin DoDot:3
- +10 SET RATTL0=$GET(^TMP($JOB,"RA",RADIV,RAIMG,RAFLD))
- SET RAWWU1=$PIECE(RATTL0,"^",5)
- +11 SET RATTL1=0
- FOR I=1:1:4
- SET RATTL1=RATTL1+$PIECE(RATTL0,"^",I)
- +12 SET RAMIS=0
- +13 FOR
- SET RAMIS=$ORDER(^TMP($JOB,"RA",RADIV,RAIMG,RAFLD,RAMIS))
- IF RAMIS'>0
- QUIT
- Begin DoDot:4
- +14 IF RAMIS'<25&(RAMIS'=27)&(RAMIS'=99)
- QUIT
- SET RAPRC=""
- +15 FOR
- SET RAPRC=$ORDER(^TMP($JOB,"RA",RADIV,RAIMG,RAFLD,RAMIS,RAPRC))
- IF RAPRC']""
- QUIT
- Begin DoDot:5
- +16 DO PRT1
- +17 QUIT
- End DoDot:5
- IF RAXIT
- QUIT
- +18 QUIT
- End DoDot:4
- IF RAXIT
- QUIT
- +19 IF 'RAXIT
- DO TOT
- +20 QUIT
- End DoDot:3
- IF RAXIT
- QUIT
- +21 IF 'RAXIT
- DO IMGCHK^RALWKL2
- +22 QUIT
- End DoDot:2
- IF RAXIT
- QUIT
- +23 IF 'RAXIT&(RADIFLG(RADIV)>1)
- DO DIVCHK^RALWKL2
- +24 QUIT
- End DoDot:1
- IF RAXIT
- QUIT
- +25 QUIT
- PRT1 ; Tabulate the data for non summary report, output the data.
- +1 SET RATTL2=$GET(^TMP($JOB,"RA",RADIV,RAIMG,RAFLD,RAMIS,RAPRC))
- +2 ; Total up the first four pieces.
- SET RAWWU2=$PIECE(RATTL2,"^",5)
- SET RATTL3=0
- +3 FOR I=1:1:4
- SET RATTL3=RATTL3+$PIECE(RATTL2,"^",I)
- +4 IF 'RAPG
- DO HD
- IF RAXIT
- QUIT
- +5 IF $Y>(IOSL-4)
- SET RAXIT=$$EOS^RAUTL5()
- IF 'RAXIT
- DO HD
- IF RAXIT
- QUIT
- +6 WRITE !,$EXTRACT(RAPRC,1,28),?30,$JUSTIFY(+$PIECE(RATTL2,"^"),5),?36,$JUSTIFY(+$PIECE(RATTL2,"^",2),5)
- +7 WRITE ?42,$JUSTIFY(+$PIECE(RATTL2,"^",3),5),?48,$JUSTIFY(+$PIECE(RATTL2,"^",4),5)
- +8 WRITE ?55,$JUSTIFY(RATTL3,5),?62,$JUSTIFY($SELECT(RATTL1:(100*RATTL3)/RATTL1,1:0),5,1)
- +9 IF $DATA(RAFL)
- Begin DoDot:1
- +10 WRITE ?68,$JUSTIFY(RAWWU2,5),?75,$JUSTIFY($SELECT(RAWWU1:(RAWWU2*100)/RAWWU1,1:0),5,1)
- +11 QUIT
- End DoDot:1
- +12 QUIT
- TOT ; Total within Service, Ward, Clinic, etc.
- +1 IF 'RATTL1
- IF ('RAWWU1)
- QUIT
- +2 IF $Y>(IOSL-4)
- SET RAXIT=$$EOS^RAUTL5()
- IF 'RAXIT
- DO HD
- IF RAXIT
- QUIT
- +3 WRITE !!,$GET(RATITLE)_" Total"
- +4 WRITE ?30,$JUSTIFY(+$PIECE(RATTL0,"^"),5),?36,$JUSTIFY(+$PIECE(RATTL0,"^",2),5)
- +5 WRITE ?42,$JUSTIFY(+$PIECE(RATTL0,"^",3),5),?48,$JUSTIFY(+$PIECE(RATTL0,"^",4),5)
- +6 WRITE ?55,$JUSTIFY(RATTL1,5)
- +7 IF $DATA(RAFL)
- WRITE ?68,$JUSTIFY(RAWWU1,5)
- +8 WRITE !,RALN
- NEW RA1
- SET RA1=$ORDER(^TMP($JOB,"RA",RADIV,RAIMG,RAFLD))
- +9 IF RA1]""
- NEW RAFLD
- SET RAFLD=RA1
- SET RAXIT=$$EOS^RAUTL5()
- IF 'RAXIT
- DO HD
- +10 QUIT
- HD ; Header
- +1 IF RAPG!($EXTRACT(IOST,1,2)="C-")
- IF $Y>0
- WRITE @IOF
- +2 SET RAPG=RAPG+1
- +3 WRITE !?5,">>> "_RATITLE_" Workload Report <<<"
- +4 WRITE ?70,"Page: ",RAPG
- +5 WRITE !!?4,"Division: ",$SELECT($DATA(^DIC(4,+RADIV,0)):$PIECE(^(0),U,1),1:"UNKNOWN")
- +6 IF '$DATA(RADIVSUM)
- WRITE !,"Imaging Type: ",$SELECT($DATA(^RA(79.2,+$PIECE(RAIMG,"-",2),0)):$PIECE(^(0),U,1),1:"UNKNOWN")
- +7 WRITE ?52,"For period: ",?64,BEGDATE("X"),?77,"to"
- +8 WRITE !?4,"Run Date: ",RATDY,?64,ENDDATE("X")
- +9 WRITE !!?32,"-------Examinations------",!?62,"% of"
- IF $DATA(RAFL)
- WRITE ?75," % of"
- +10 WRITE !,$SELECT('RASUM:"Procedure",1:RATITLE),?30," Inpt",?36," Opt"
- +11 WRITE ?42," Res",?48,"Other",?55,"Total",?62,"Exams"
- +12 IF $DATA(RAFL)
- WRITE ?68," WWU",?75," WWU"
- +13 WRITE !,RALN
- +14 ; set in DIVCHK^RALWKL2
- IF $DATA(RADIVSUM)
- WRITE !?10,"(Division Summary)"
- +15 ; set in IMGCHK^RALWKL2
- IF $DATA(RAIMGSUM)
- WRITE !?10,"(Imaging Type Summary)"
- +16 IF '$DATA(RADIVSUM)&('$DATA(RAIMGSUM))&('RASUM)
- WRITE !?10,RATITLE,": ",$GET(RAFLD)
- +17 IF $DATA(ZTQUEUED)
- DO STOPCHK^RAUTL9
- IF $GET(ZTSTOP)=1
- SET RAXIT=1
- +18 QUIT
- DISPXAM(A) ; Display Examination Statuses which meet certain criteria.
- +1 ; 'A' is the equivalent of the variable 'RACRT'. This code is related
- +2 ; to the 'CRIT^RAUTL1' subroutine. This sets up the RACRT local array
- +3 ; according to I-Type.
- +4 NEW RA,RAHD,UNDRLN,X,Y,Z
- +5 SET RAHD(0)="The entries printed for this report will be based only"
- +6 SET RAHD(1)="on exams that are in one of the following statuses:"
- +7 WRITE !!?(IOM-$LENGTH(RAHD(0))\2),RAHD(0),!?(IOM-$LENGTH(RAHD(1))\2),RAHD(1)
- +8 SET X=""
- FOR
- SET X=$ORDER(^TMP($JOB,"RA I-TYPE",X))
- IF X']""
- QUIT
- Begin DoDot:1
- +9 IF $DATA(^RA(72,"AA",X))
- KILL UNDRLN
- SET Y=""
- Begin DoDot:2
- +10 IF $Y>(IOSL-4)
- SET RAXIT=$$EOS^RAUTL5()
- IF RAXIT
- QUIT
- WRITE @IOF
- +11 SET $PIECE(UNDRLN,"-",($LENGTH(X)+1))=""
- WRITE !!?10,X,!?10,UNDRLN
- +12 FOR
- SET Y=$ORDER(^RA(72,"AA",X,Y))
- IF Y']""
- QUIT
- Begin DoDot:3
- +13 SET Z=0
- FOR
- SET Z=$ORDER(^RA(72,"AA",X,Y,Z))
- IF 'Z
- QUIT
- Begin DoDot:4
- +14 SET RA(0)=$GET(^RA(72,Z,0))
- SET RA(.3)=$GET(^RA(72,Z,.3))
- +15 SET RA(.3,A)=$PIECE(RA(.3),"^",A)
- +16 IF RA(0)]""
- IF (RA(.3)]"")
- IF (RA(.3,A)]"")
- IF ("Yy"[RA(.3,A))
- Begin DoDot:5
- +17 ; Where 'X' is the I-Type
- SET RACRT(Z)=X
- +18 IF $Y>(IOSL-4)
- SET RAXIT=$$EOS^RAUTL5()
- IF RAXIT
- QUIT
- Begin DoDot:6
- +19 WRITE @IOF,!?10,X,!?10,UNDRLN
- +20 QUIT
- End DoDot:6
- +21 WRITE !?15,$PIECE(RA(0),"^")
- +22 QUIT
- End DoDot:5
- +23 QUIT
- End DoDot:4
- IF RAXIT
- QUIT
- +24 QUIT
- End DoDot:3
- IF RAXIT
- QUIT
- +25 QUIT
- End DoDot:2
- +26 QUIT
- End DoDot:1
- IF RAXIT
- QUIT
- +27 QUIT
