- RALWKL2 ;HISC/GJC-Workload Reports By Functional Area ;4/12/96 10:15
- ;;5.0;Radiology/Nuclear Medicine;;Mar 16, 1998
- DIVCHK ; Output statistics within division.
- N RA1,RAIMG,RASUM,RATTL0,RATTL1,RAWWU1
- S (RA1,RAIMG,RADIVSUM)="",RASUM=1
- S RAXIT=$$EOS^RAUTL5() D:'RAXIT HD^RALWKL1 Q:RAXIT
- S RATTL0=$G(^TMP($J,"RA",RADIV)),RAWWU1=+$P(RATTL0,"^",5)
- F I=1:1:4 S RATTL1=+$G(RATTL1)+(+$P(RATTL0,"^",I))
- F S RA1=$O(^TMP($J,"RA1",RADIV,RA1)) Q:RA1']"" D Q:RAXIT
- . I $Y>(IOSL-4) S RAXIT=$$EOS^RAUTL5() D:'RAXIT HD^RALWKL1 Q:RAXIT
- . S (RATTL2,RATTL3,RAWWU2)=0
- . S RATTL2=$G(^TMP($J,"RA1",RADIV,RA1)),RAWWU2=$P(RATTL2,"^",5)
- . F I=1:1:4 S RATTL3=+$G(RATTL3)+(+$P(RATTL2,"^",I))
- . W !,$E(RA1,1,28),?30,$J(+$P(RATTL2,"^"),5)
- . W ?36,$J(+$P(RATTL2,"^",2),5),?42,$J(+$P(RATTL2,"^",3),5)
- . W ?48,$J(+$P(RATTL2,"^",4),5),?55,$J(RATTL3,5)
- . W:$D(RAFL) ?62,$J($S(RATTL1:(100*RATTL3)/RATTL1,1:0),5,1)
- . W ?68,$J(RAWWU2,5)
- . W:$D(RAFL) ?75,$J($S(RAWWU1:(100*RAWWU2)/RAWWU1,1:0),5,1)
- . Q
- Q:RAXIT
- I $Y>(IOSL-4) S RAXIT=$$EOS^RAUTL5() D:'RAXIT HD^RALWKL1 Q:RAXIT
- K RADIVSUM
- W !,RALN,!!,"Division Total",?30,$J(+$P(RATTL0,"^"),5)
- W ?36,$J(+$P(RATTL0,"^",2),5),?42,$J(+$P(RATTL0,"^",3),5)
- W ?48,$J(+$P(RATTL0,"^",4),5),?55,$J(RATTL1,5) W:$D(RAFL) ?68,$J(RAWWU1,5)
- I $Y>(IOSL-4) S RAXIT=$$EOS^RAUTL5() D:'RAXIT HD^RALWKL1 Q:RAXIT
- W !!?2,"Imaging Type(s): "
- S RAITHLD=""
- F S RAITHLD=$O(^TMP($J,"RA",RADIV,RAITHLD)) Q:RAXIT!(RAITHLD="") W:$X>(80-25) !?($X+$L("Imaging Type(s):")+3) D
- .I $Y>(IOSL-4) S RAXIT=$$EOS^RAUTL5() D:'RAXIT HD^RALWKL1 Q:RAXIT
- .W $S($D(^RA(79.2,+$P(RAITHLD,"-",2),0)):$P(^(0),U,1),1:"UNKNOWN"),?($X+3)
- K RAITHLD Q:RAXIT
- W !!?3,"# of "_RATITLE_"s selected: "_$S(RAINPUT=1:"ALL",1:$G(RAFLDCNT))
- S RA1=$O(^TMP($J,"RA",RADIV))
- I RA1]"" N RADIV,RAIMG,RAFLD S RADIV=RA1,RASUM=0 D
- . S RA11=$O(^TMP($J,"RA",RADIV,"")) S:RA11]"" RAIMG=RA11
- . I $G(RAIMG)]"" S RA111=$O(^TMP($J,"RA",RADIV,RAIMG,"")) S:RA111]"" RAFLD=RA111 I $G(RAFLD)]"" S RAXIT=$$EOS^RAUTL5() D:'RAXIT HD^RALWKL1
- . Q
- Q
- IMGCHK ; Check for EOS on I-Type
- N RA1,RA11,RA111,RASUM,RATTL0,RATTL1,RATTL2,RATTL3,RAWWU1,RAWWU2
- S (RA111,RAIMGSUM)="",RASUM=1
- I RAPG S RAXIT=$$EOS^RAUTL5() D:'RAXIT HD^RALWKL1 Q:RAXIT
- D:'RAPG HD^RALWKL1 Q:RAXIT
- S RATTL0=$G(^TMP($J,"RA",RADIV,RAIMG)),RAWWU1=+$P(RATTL0,"^",5)
- F I=1:1:4 S RATTL1=+$G(RATTL1)+(+$P(RATTL0,"^",I))
- F S RA111=$O(^TMP($J,"RA",RADIV,RAIMG,RA111)) Q:RA111']"" D Q:RAXIT
- . I $Y>(IOSL-4) S RAXIT=$$EOS^RAUTL5() D:'RAXIT HD^RALWKL1 Q:RAXIT
- . S (RATTL2,RATTL3,RAWWU2)=0
- . S RATTL2=$G(^TMP($J,"RA",RADIV,RAIMG,RA111)),RAWWU2=+$P(RATTL2,"^",5)
- . F I=1:1:4 S RATTL3=+$G(RATTL3)+(+$P(RATTL2,"^",I))
- . W !,$E(RA111,1,28),?30,$J(+$P(RATTL2,"^"),5)
- . W ?36,$J(+$P(RATTL2,"^",2),5),?42,$J(+$P(RATTL2,"^",3),5)
- . W ?48,$J(+$P(RATTL2,"^",4),5),?55,$J(RATTL3,5)
- . W:$D(RAFL) ?62,$J($S(RATTL1:(100*RATTL3)/RATTL1,1:0),5,1)
- . W ?68,$J(RAWWU2,5)
- . W:$D(RAFL) ?75,$J($S(RAWWU1:(100*RAWWU2)/RAWWU1,1:0),5,1)
- . Q
- I $Y>(IOSL-4) S RAXIT=$$EOS^RAUTL5() D:'RAXIT HD^RALWKL1 Q:RAXIT
- K RAIMGSUM
- W !,RALN,!!,"Imaging Type Total",?30,$J(+$P(RATTL0,"^"),5)
- W ?36,$J(+$P(RATTL0,"^",2),5),?42,$J(+$P(RATTL0,"^",3),5)
- W ?48,$J(+$P(RATTL0,"^",4),5),?55,$J(RATTL1,5),?68,$J(RAWWU1,5)
- W !!?3,"# of "_RATITLE_"s selected: "_$S(RAINPUT=1:"ALL",1:$G(RAFLDCNT))
- S RA1=$O(^TMP($J,"RA",RADIV,RAIMG))
- I RA1]"" N RAFLD,RAIMG S RAIMG=RA1,RASUM=0 D
- . S RA11=$O(^TMP($J,"RA",RADIV,RAIMG,"")) Q:RA11']"" S RAFLD=RA11
- . S RA111=$O(^TMP($J,"RA",RADIV,RAIMG,RAFLD,"")) Q:RA111']""
- . S RAXIT=$$EOS^RAUTL5() D:'RAXIT HD^RALWKL1
- . Q
- Q
- PURGE ; Kill & Quit
- K %DT,A,A1,B,B1,BEGDATE,C,DIROUT,DIRUT,DTOUT,DUOUT,ENDDATE,I,J,RA1,RA11
- K RA111,RABEG,RACNI,RACRT,RAD0,RADFN,RADIV,RADIFLG
- K RADIVNME,RADIVSUM,RADTE,RADTI,RAEND,RAFILE,RAFL,RAFL1,RAFLD,RAFLDCNT,RAIMG,RAIMGSUM
- K RAINPUT,RALN,RALN1,RAMES,RAMIS,RANUM,RAP0,RAPCE,RAPG,RAPOP,RAPRC
- K RAPRI,RAQI,RAQUIT,RASUM,RASV,RATDY,RATITLE,RATTL0,RATTL1,RATTL2
- K RATTL3,RAWWU1,RAWWU2,RAXIT,X,Y,ZTDESC,ZTRTN,ZTSAVE
- K ^TMP($J,"RA"),^TMP($J,"RA1"),^TMP($J,"RA D-TYPE"),^TMP($J,"RA I-TYPE")
- K ^TMP($J,"RAFLD") K:$D(RAPSTX) RACCESS,RAPSTX D CLOSE^RAUTL K POP
- Q
- ZEROUT ; Zero out the data globals.
- N A,A1,B,B1
- S A="" F S A=$O(RACCESS(DUZ,"DIV-IMG",A)) Q:A']"" D
- . Q:'$D(^TMP($J,"RA D-TYPE",A)) S A1=$O(^TMP($J,"RA D-TYPE",A,0)) Q:A1'>0 S RADIFLG(A1)=0
- . S ^TMP($J,"RA",A1)="0^0^0^0^0",B=""
- . F S B=$O(RACCESS(DUZ,"DIV-IMG",A,B)) Q:B']"" D
- .. Q:'$D(^TMP($J,"RA I-TYPE",B)) D IT Q:B1'?3AP1"-".N S RADIFLG(A1)=RADIFLG(A1)+1
- .. S ^TMP($J,"RA",A1,B1)="0^0^0^0^0"
- .. Q
- . Q
- K RACCESS(DUZ,"DIV-IMG")
- Q
- IT ; calculate imaging type subscript
- S B1=$O(^RA(79.2,"B",B,0)) Q:B1'>0
- S B1=$E($P($G(^RA(79.2,+B1,0)),U,1),1,3)_"-"_B1
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRALWKL2 4793 printed Feb 19, 2025@00:02:58 Page 2
- RALWKL2 ;HISC/GJC-Workload Reports By Functional Area ;4/12/96 10:15
- +1 ;;5.0;Radiology/Nuclear Medicine;;Mar 16, 1998
- DIVCHK ; Output statistics within division.
- +1 NEW RA1,RAIMG,RASUM,RATTL0,RATTL1,RAWWU1
- +2 SET (RA1,RAIMG,RADIVSUM)=""
- SET RASUM=1
- +3 SET RAXIT=$$EOS^RAUTL5()
- if 'RAXIT
- DO HD^RALWKL1
- if RAXIT
- QUIT
- +4 SET RATTL0=$GET(^TMP($JOB,"RA",RADIV))
- SET RAWWU1=+$PIECE(RATTL0,"^",5)
- +5 FOR I=1:1:4
- SET RATTL1=+$GET(RATTL1)+(+$PIECE(RATTL0,"^",I))
- +6 FOR
- SET RA1=$ORDER(^TMP($JOB,"RA1",RADIV,RA1))
- if RA1']""
- QUIT
- Begin DoDot:1
- +7 IF $Y>(IOSL-4)
- SET RAXIT=$$EOS^RAUTL5()
- if 'RAXIT
- DO HD^RALWKL1
- if RAXIT
- QUIT
- +8 SET (RATTL2,RATTL3,RAWWU2)=0
- +9 SET RATTL2=$GET(^TMP($JOB,"RA1",RADIV,RA1))
- SET RAWWU2=$PIECE(RATTL2,"^",5)
- +10 FOR I=1:1:4
- SET RATTL3=+$GET(RATTL3)+(+$PIECE(RATTL2,"^",I))
- +11 WRITE !,$EXTRACT(RA1,1,28),?30,$JUSTIFY(+$PIECE(RATTL2,"^"),5)
- +12 WRITE ?36,$JUSTIFY(+$PIECE(RATTL2,"^",2),5),?42,$JUSTIFY(+$PIECE(RATTL2,"^",3),5)
- +13 WRITE ?48,$JUSTIFY(+$PIECE(RATTL2,"^",4),5),?55,$JUSTIFY(RATTL3,5)
- +14 if $DATA(RAFL)
- WRITE ?62,$JUSTIFY($SELECT(RATTL1:(100*RATTL3)/RATTL1,1:0),5,1)
- +15 WRITE ?68,$JUSTIFY(RAWWU2,5)
- +16 if $DATA(RAFL)
- WRITE ?75,$JUSTIFY($SELECT(RAWWU1:(100*RAWWU2)/RAWWU1,1:0),5,1)
- +17 QUIT
- End DoDot:1
- if RAXIT
- QUIT
- +18 if RAXIT
- QUIT
- +19 IF $Y>(IOSL-4)
- SET RAXIT=$$EOS^RAUTL5()
- if 'RAXIT
- DO HD^RALWKL1
- if RAXIT
- QUIT
- +20 KILL RADIVSUM
- +21 WRITE !,RALN,!!,"Division Total",?30,$JUSTIFY(+$PIECE(RATTL0,"^"),5)
- +22 WRITE ?36,$JUSTIFY(+$PIECE(RATTL0,"^",2),5),?42,$JUSTIFY(+$PIECE(RATTL0,"^",3),5)
- +23 WRITE ?48,$JUSTIFY(+$PIECE(RATTL0,"^",4),5),?55,$JUSTIFY(RATTL1,5)
- if $DATA(RAFL)
- WRITE ?68,$JUSTIFY(RAWWU1,5)
- +24 IF $Y>(IOSL-4)
- SET RAXIT=$$EOS^RAUTL5()
- if 'RAXIT
- DO HD^RALWKL1
- if RAXIT
- QUIT
- +25 WRITE !!?2,"Imaging Type(s): "
- +26 SET RAITHLD=""
- +27 FOR
- SET RAITHLD=$ORDER(^TMP($JOB,"RA",RADIV,RAITHLD))
- if RAXIT!(RAITHLD="")
- QUIT
- if $X>(80-25)
- WRITE !?($X+$LENGTH("Imaging Type(s):")+3)
- Begin DoDot:1
- +28 IF $Y>(IOSL-4)
- SET RAXIT=$$EOS^RAUTL5()
- if 'RAXIT
- DO HD^RALWKL1
- if RAXIT
- QUIT
- +29 WRITE $SELECT($DATA(^RA(79.2,+$PIECE(RAITHLD,"-",2),0)):$PIECE(^(0),U,1),1:"UNKNOWN"),?($X+3)
- End DoDot:1
- +30 KILL RAITHLD
- if RAXIT
- QUIT
- +31 WRITE !!?3,"# of "_RATITLE_"s selected: "_$SELECT(RAINPUT=1:"ALL",1:$GET(RAFLDCNT))
- +32 SET RA1=$ORDER(^TMP($JOB,"RA",RADIV))
- +33 IF RA1]""
- NEW RADIV,RAIMG,RAFLD
- SET RADIV=RA1
- SET RASUM=0
- Begin DoDot:1
- +34 SET RA11=$ORDER(^TMP($JOB,"RA",RADIV,""))
- if RA11]""
- SET RAIMG=RA11
- +35 IF $GET(RAIMG)]""
- SET RA111=$ORDER(^TMP($JOB,"RA",RADIV,RAIMG,""))
- if RA111]""
- SET RAFLD=RA111
- IF $GET(RAFLD)]""
- SET RAXIT=$$EOS^RAUTL5()
- if 'RAXIT
- DO HD^RALWKL1
- +36 QUIT
- End DoDot:1
- +37 QUIT
- IMGCHK ; Check for EOS on I-Type
- +1 NEW RA1,RA11,RA111,RASUM,RATTL0,RATTL1,RATTL2,RATTL3,RAWWU1,RAWWU2
- +2 SET (RA111,RAIMGSUM)=""
- SET RASUM=1
- +3 IF RAPG
- SET RAXIT=$$EOS^RAUTL5()
- if 'RAXIT
- DO HD^RALWKL1
- if RAXIT
- QUIT
- +4 if 'RAPG
- DO HD^RALWKL1
- if RAXIT
- QUIT
- +5 SET RATTL0=$GET(^TMP($JOB,"RA",RADIV,RAIMG))
- SET RAWWU1=+$PIECE(RATTL0,"^",5)
- +6 FOR I=1:1:4
- SET RATTL1=+$GET(RATTL1)+(+$PIECE(RATTL0,"^",I))
- +7 FOR
- SET RA111=$ORDER(^TMP($JOB,"RA",RADIV,RAIMG,RA111))
- if RA111']""
- QUIT
- Begin DoDot:1
- +8 IF $Y>(IOSL-4)
- SET RAXIT=$$EOS^RAUTL5()
- if 'RAXIT
- DO HD^RALWKL1
- if RAXIT
- QUIT
- +9 SET (RATTL2,RATTL3,RAWWU2)=0
- +10 SET RATTL2=$GET(^TMP($JOB,"RA",RADIV,RAIMG,RA111))
- SET RAWWU2=+$PIECE(RATTL2,"^",5)
- +11 FOR I=1:1:4
- SET RATTL3=+$GET(RATTL3)+(+$PIECE(RATTL2,"^",I))
- +12 WRITE !,$EXTRACT(RA111,1,28),?30,$JUSTIFY(+$PIECE(RATTL2,"^"),5)
- +13 WRITE ?36,$JUSTIFY(+$PIECE(RATTL2,"^",2),5),?42,$JUSTIFY(+$PIECE(RATTL2,"^",3),5)
- +14 WRITE ?48,$JUSTIFY(+$PIECE(RATTL2,"^",4),5),?55,$JUSTIFY(RATTL3,5)
- +15 if $DATA(RAFL)
- WRITE ?62,$JUSTIFY($SELECT(RATTL1:(100*RATTL3)/RATTL1,1:0),5,1)
- +16 WRITE ?68,$JUSTIFY(RAWWU2,5)
- +17 if $DATA(RAFL)
- WRITE ?75,$JUSTIFY($SELECT(RAWWU1:(100*RAWWU2)/RAWWU1,1:0),5,1)
- +18 QUIT
- End DoDot:1
- if RAXIT
- QUIT
- +19 IF $Y>(IOSL-4)
- SET RAXIT=$$EOS^RAUTL5()
- if 'RAXIT
- DO HD^RALWKL1
- if RAXIT
- QUIT
- +20 KILL RAIMGSUM
- +21 WRITE !,RALN,!!,"Imaging Type Total",?30,$JUSTIFY(+$PIECE(RATTL0,"^"),5)
- +22 WRITE ?36,$JUSTIFY(+$PIECE(RATTL0,"^",2),5),?42,$JUSTIFY(+$PIECE(RATTL0,"^",3),5)
- +23 WRITE ?48,$JUSTIFY(+$PIECE(RATTL0,"^",4),5),?55,$JUSTIFY(RATTL1,5),?68,$JUSTIFY(RAWWU1,5)
- +24 WRITE !!?3,"# of "_RATITLE_"s selected: "_$SELECT(RAINPUT=1:"ALL",1:$GET(RAFLDCNT))
- +25 SET RA1=$ORDER(^TMP($JOB,"RA",RADIV,RAIMG))
- +26 IF RA1]""
- NEW RAFLD,RAIMG
- SET RAIMG=RA1
- SET RASUM=0
- Begin DoDot:1
- +27 SET RA11=$ORDER(^TMP($JOB,"RA",RADIV,RAIMG,""))
- if RA11']""
- QUIT
- SET RAFLD=RA11
- +28 SET RA111=$ORDER(^TMP($JOB,"RA",RADIV,RAIMG,RAFLD,""))
- if RA111']""
- QUIT
- +29 SET RAXIT=$$EOS^RAUTL5()
- if 'RAXIT
- DO HD^RALWKL1
- +30 QUIT
- End DoDot:1
- +31 QUIT
- PURGE ; Kill & Quit
- +1 KILL %DT,A,A1,B,B1,BEGDATE,C,DIROUT,DIRUT,DTOUT,DUOUT,ENDDATE,I,J,RA1,RA11
- +2 KILL RA111,RABEG,RACNI,RACRT,RAD0,RADFN,RADIV,RADIFLG
- +3 KILL RADIVNME,RADIVSUM,RADTE,RADTI,RAEND,RAFILE,RAFL,RAFL1,RAFLD,RAFLDCNT,RAIMG,RAIMGSUM
- +4 KILL RAINPUT,RALN,RALN1,RAMES,RAMIS,RANUM,RAP0,RAPCE,RAPG,RAPOP,RAPRC
- +5 KILL RAPRI,RAQI,RAQUIT,RASUM,RASV,RATDY,RATITLE,RATTL0,RATTL1,RATTL2
- +6 KILL RATTL3,RAWWU1,RAWWU2,RAXIT,X,Y,ZTDESC,ZTRTN,ZTSAVE
- +7 KILL ^TMP($JOB,"RA"),^TMP($JOB,"RA1"),^TMP($JOB,"RA D-TYPE"),^TMP($JOB,"RA I-TYPE")
- +8 KILL ^TMP($JOB,"RAFLD")
- if $DATA(RAPSTX)
- KILL RACCESS,RAPSTX
- DO CLOSE^RAUTL
- KILL POP
- +9 QUIT
- ZEROUT ; Zero out the data globals.
- +1 NEW A,A1,B,B1
- +2 SET A=""
- FOR
- SET A=$ORDER(RACCESS(DUZ,"DIV-IMG",A))
- if A']""
- QUIT
- Begin DoDot:1
- +3 if '$DATA(^TMP($JOB,"RA D-TYPE",A))
- QUIT
- SET A1=$ORDER(^TMP($JOB,"RA D-TYPE",A,0))
- if A1'>0
- QUIT
- SET RADIFLG(A1)=0
- +4 SET ^TMP($JOB,"RA",A1)="0^0^0^0^0"
- SET B=""
- +5 FOR
- SET B=$ORDER(RACCESS(DUZ,"DIV-IMG",A,B))
- if B']""
- QUIT
- Begin DoDot:2
- +6 if '$DATA(^TMP($JOB,"RA I-TYPE",B))
- QUIT
- DO IT
- if B1'?3AP1"-".N
- QUIT
- SET RADIFLG(A1)=RADIFLG(A1)+1
- +7 SET ^TMP($JOB,"RA",A1,B1)="0^0^0^0^0"
- +8 QUIT
- End DoDot:2
- +9 QUIT
- End DoDot:1
- +10 KILL RACCESS(DUZ,"DIV-IMG")
- +11 QUIT
- IT ; calculate imaging type subscript
- +1 SET B1=$ORDER(^RA(79.2,"B",B,0))
- if B1'>0
- QUIT
- +2 SET B1=$EXTRACT($PIECE($GET(^RA(79.2,+B1,0)),U,1),1,3)_"-"_B1
- +3 QUIT