- RAPRC1 ;HISC/FPT AISC/MJK-Procedure Workload Report ;10/21/97 09:08
- ;;5.0;Radiology/Nuclear Medicine;;Mar 16, 1998
- ;
- S Y=BEGDATE D D^RAUTL S BEGDATE=Y
- S Y=ENDDATE D D^RAUTL S ENDDATE=Y
- S X="NOW",%DT="T" D ^%DT K %DT D D^RAUTL S RARUNDTE=Y
- S RA80DASH=$$REPEAT^XLFSTR("-",79),(PAGE,RAEOS)=0
- F RADIV=0:0 S RADIV=$O(^TMP($J,"RA",RADIV)) Q:RAEOS!(RADIV'>0) S RAZ=^(RADIV),RAY=$S($D(^DIC(4,RADIV,0)):$P(^(0),"^"),1:"UNKNOWN") D RAMIS Q:RAEOS S RASUM="",Z=RAZ D HD Q:RAEOS D DIV K RASUM
- Q ; kill variables, close device
- K ^TMP($J,"RA"),^TMP($J,"RA D-TYPE"),^TMP($J,"RA I-TYPE"),^TMP($J,"RAPRC"),^TMP($J,"DIV-IMG")
- K %DT,A,A1,BEGDATE,C,DDH,ENDDATE,I,J,IN,OUT,PAGE,RA80DASH,RABEG,RACNI,RACRT,RAD0,RAEOS,RADFN,RADIV,RADTE,RADTI,RAEND,RAFL,RAI,RAIN,RAITNUM,RAITYPE,RAMIS,RAMUL
- K RANUM,RAOR,RAOUT,RAP0,RAPOP,RAPORT,RAQUIT,RAPRC,RAPRI,RAQI,RARUNDTE,RASTAT,RASUM,RATOT,RAWT,RAWWU,RAXIT,RAY,RAZ,TOT,WWU,X,Y,Z
- K:$D(RAPSTX) RACCESS,RAPSTX
- W ! D CLOSE^RAUTL
- K DUOUT,POP,RAMES,ZTDESC,ZTSAVE
- Q
- ;
- RAMIS S RAMIS=0 F J=0:0 S RAMIS=$O(^TMP($J,"RA",RADIV,RAMIS)) Q:RAEOS!(RAMIS="") S Z=^(RAMIS) D HD Q:RAEOS D PRT
- Q
- ;
- PRT S IN=$P(Z,"^"),OUT=$P(Z,"^",2),TOT=IN+OUT,WWU=$P(Z,"^",3)
- S RAPRC="" F I=0:0 S RAPRC=$O(^TMP($J,"RA",RADIV,RAMIS,RAPRC)) Q:RAPRC="" S Y=^(RAPRC),RAIN=$P(Y,"^"),RAOUT=$P(Y,"^",2),RAWWU=$P(Y,"^",3),RATOT=RAIN+RAOUT D PRT1
- W !!?2,$S($D(RASUM):"DIVISION",1:"AMIS CATEGORY")," TOTALS",?35,$J(IN,5),?42,$J(OUT,5),?49,$J(TOT,5),?63,$J(WWU,5)
- S RAEOS=$$EOS^RAUTL5()
- Q
- PRT1 I ($Y+4)>IOSL S RAEOS=$$EOS^RAUTL5() Q:RAEOS D HD Q:RAEOS
- W !?2,RAPRC,?35,$J(RAIN,5),?42,$J(RAOUT,5),?49,$J(RATOT,5),?56,$J($S(TOT:(100*RATOT)/TOT,1:0),5,1),?63,$J(RAWWU,5),?70,$J($S(WWU:(RAWWU*100)/WWU,1:0),5,1)
- Q
- ;
- HD W:$Y>0 @IOF W !?9,">>>>> Detailed Procedure Workload Report <<<<<" S PAGE=PAGE+1 W ?70,"Page: ",PAGE
- W !!?5,"Division: ",RAY
- W !?1,"Imaging Type: ",RAITYPE,?52,"For period: " W ?64,BEGDATE,?76,"to",!?5,"Run Date: ",RARUNDTE,?64,ENDDATE
- W !!?40,$S(RAMIS="MULP":"No. of Series",1:"Examinations"),?56,"Percent",?70,"Percent"
- W !?2,$S('$D(RASUM):"Procedure",1:"Amis Category"),?35," In",?42," Out",?49,"Total",?56,$S(RAMIS="MULP":"Series",1:" Exams"),?63," WWU",?70," WWU"
- W !,RA80DASH
- W:$D(RASUM) !?10,"(Division Summary)" W:'$D(RASUM) !?5,"Amis: ",$S(RAMIS:RAMIS,1:""),?15,$S($D(^RAMIS(71.1,RAMIS,0)):$P(^(0),"^"),RAMIS="MULP":"SERIES OF AMIS CODES",1:"UNKNOWN")
- I $D(ZTQUEUED) D STOPCHK^RAUTL9 S:$G(ZTSTOP)=1 RAEOS=1
- Q
- ;
- DIV S IN=$P(Z,"^"),OUT=$P(Z,"^",2),TOT=IN+OUT,WWU=$P(Z,"^",3)
- F I=0:0 S RAMIS=$O(^TMP($J,"RA",RADIV,RAMIS)) Q:RAEOS!(RAMIS="") I RAMIS'="MULP",RAMIS<25!(RAMIS=99) S Y=^(RAMIS),RAIN=$P(Y,"^"),RAOUT=$P(Y,"^",2),RAWWU=$P(Y,"^",3),RATOT=RAIN+RAOUT D DIV1 Q:RAEOS
- W !!?2,"DIVISION TOTALS",?35,$J(IN,5),?42,$J(OUT,5),?49,$J(TOT,5),?63,$J(WWU,5)
- W !!,RA80DASH
- F RAMIS=25,26,"MULP" I $D(^TMP($J,"RA",RADIV,RAMIS)) S Y=^(RAMIS),RAIN=$P(Y,"^"),RAOUT=$P(Y,"^",2),RAWWU=$P(Y,"^",3),RATOT=RAIN+RAOUT D DIV1 Q:RAEOS
- Q:RAEOS
- I $O(^TMP($J,"RA",RADIV))]"" S RAEOS=$$EOS^RAUTL5()
- Q
- DIV1 I ($Y+4)>IOSL S RAEOS=$$EOS^RAUTL5() Q:RAEOS D HD Q:RAEOS
- W !,$J($S(RAMIS:RAMIS,1:" "),2),"-",$E($S($D(^RAMIS(71.1,RAMIS,0)):$P(^(0),"^"),RAMIS="MULP":"SERIES OF AMIS CODES",1:"UNKNOWN"),1,30)
- W ?35,$J(RAIN,5),?42,$J(RAOUT,5),?49,$J(RATOT,5),?56,$S(RAMIS="MULP":"",1:$J($S(TOT:(100*RATOT)/TOT,1:0),5,1)),?63,$J(RAWWU,5),?70,$J($S(WWU:(RAWWU*100)/WWU,1:0),5,1)
- Q
- SAVEONE ; Save off the I-Type
- S RAITNUM=+$O(^TMP($J,"DIV-IMG",0))
- S RAITYPE=$P($G(^RA(79.2,RAITNUM,0)),"^")
- S ^TMP($J,"RA I-TYPE",RAITYPE,RAITNUM)=""
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRAPRC1 3604 printed Feb 19, 2025@00:05:02 Page 2
- RAPRC1 ;HISC/FPT AISC/MJK-Procedure Workload Report ;10/21/97 09:08
- +1 ;;5.0;Radiology/Nuclear Medicine;;Mar 16, 1998
- +2 ;
- +3 SET Y=BEGDATE
- DO D^RAUTL
- SET BEGDATE=Y
- +4 SET Y=ENDDATE
- DO D^RAUTL
- SET ENDDATE=Y
- +5 SET X="NOW"
- SET %DT="T"
- DO ^%DT
- KILL %DT
- DO D^RAUTL
- SET RARUNDTE=Y
- +6 SET RA80DASH=$$REPEAT^XLFSTR("-",79)
- SET (PAGE,RAEOS)=0
- +7 FOR RADIV=0:0
- SET RADIV=$ORDER(^TMP($JOB,"RA",RADIV))
- if RAEOS!(RADIV'>0)
- QUIT
- SET RAZ=^(RADIV)
- SET RAY=$SELECT($DATA(^DIC(4,RADIV,0)):$PIECE(^(0),"^"),1:"UNKNOWN")
- DO RAMIS
- if RAEOS
- QUIT
- SET RASUM=""
- SET Z=RAZ
- DO HD
- if RAEOS
- QUIT
- DO DIV
- KILL RASUM
- Q ; kill variables, close device
- +1 KILL ^TMP($JOB,"RA"),^TMP($JOB,"RA D-TYPE"),^TMP($JOB,"RA I-TYPE"),^TMP($JOB,"RAPRC"),^TMP($JOB,"DIV-IMG")
- +2 KILL %DT,A,A1,BEGDATE,C,DDH,ENDDATE,I,J,IN,OUT,PAGE,RA80DASH,RABEG,RACNI,RACRT,RAD0,RAEOS,RADFN,RADIV,RADTE,RADTI,RAEND,RAFL,RAI,RAIN,RAITNUM,RAITYPE,RAMIS,RAMUL
- +3 KILL RANUM,RAOR,RAOUT,RAP0,RAPOP,RAPORT,RAQUIT,RAPRC,RAPRI,RAQI,RARUNDTE,RASTAT,RASUM,RATOT,RAWT,RAWWU,RAXIT,RAY,RAZ,TOT,WWU,X,Y,Z
- +4 if $DATA(RAPSTX)
- KILL RACCESS,RAPSTX
- +5 WRITE !
- DO CLOSE^RAUTL
- +6 KILL DUOUT,POP,RAMES,ZTDESC,ZTSAVE
- +7 QUIT
- +8 ;
- RAMIS SET RAMIS=0
- FOR J=0:0
- SET RAMIS=$ORDER(^TMP($JOB,"RA",RADIV,RAMIS))
- if RAEOS!(RAMIS="")
- QUIT
- SET Z=^(RAMIS)
- DO HD
- if RAEOS
- QUIT
- DO PRT
- +1 QUIT
- +2 ;
- PRT SET IN=$PIECE(Z,"^")
- SET OUT=$PIECE(Z,"^",2)
- SET TOT=IN+OUT
- SET WWU=$PIECE(Z,"^",3)
- +1 SET RAPRC=""
- FOR I=0:0
- SET RAPRC=$ORDER(^TMP($JOB,"RA",RADIV,RAMIS,RAPRC))
- if RAPRC=""
- QUIT
- SET Y=^(RAPRC)
- SET RAIN=$PIECE(Y,"^")
- SET RAOUT=$PIECE(Y,"^",2)
- SET RAWWU=$PIECE(Y,"^",3)
- SET RATOT=RAIN+RAOUT
- DO PRT1
- +2 WRITE !!?2,$SELECT($DATA(RASUM):"DIVISION",1:"AMIS CATEGORY")," TOTALS",?35,$JUSTIFY(IN,5),?42,$JUSTIFY(OUT,5),?49,$JUSTIFY(TOT,5),?63,$JUSTIFY(WWU,5)
- +3 SET RAEOS=$$EOS^RAUTL5()
- +4 QUIT
- PRT1 IF ($Y+4)>IOSL
- SET RAEOS=$$EOS^RAUTL5()
- if RAEOS
- QUIT
- DO HD
- if RAEOS
- QUIT
- +1 WRITE !?2,RAPRC,?35,$JUSTIFY(RAIN,5),?42,$JUSTIFY(RAOUT,5),?49,$JUSTIFY(RATOT,5),?56,$JUSTIFY($SELECT(TOT:(100*RATOT)/TOT,1:0),5,1),?63,$JUSTIFY(RAWWU,5),?70,$JUSTIFY($SELECT(WWU:(RAWWU*100)/WWU,1:0),5,1)
- +2 QUIT
- +3 ;
- HD if $Y>0
- WRITE @IOF
- WRITE !?9,">>>>> Detailed Procedure Workload Report <<<<<"
- SET PAGE=PAGE+1
- WRITE ?70,"Page: ",PAGE
- +1 WRITE !!?5,"Division: ",RAY
- +2 WRITE !?1,"Imaging Type: ",RAITYPE,?52,"For period: "
- WRITE ?64,BEGDATE,?76,"to",!?5,"Run Date: ",RARUNDTE,?64,ENDDATE
- +3 WRITE !!?40,$SELECT(RAMIS="MULP":"No. of Series",1:"Examinations"),?56,"Percent",?70,"Percent"
- +4 WRITE !?2,$SELECT('$DATA(RASUM):"Procedure",1:"Amis Category"),?35," In",?42," Out",?49,"Total",?56,$SELECT(RAMIS="MULP":"Series",1:" Exams"),?63," WWU",?70," WWU"
- +5 WRITE !,RA80DASH
- +6 if $DATA(RASUM)
- WRITE !?10,"(Division Summary)"
- if '$DATA(RASUM)
- WRITE !?5,"Amis: ",$SELECT(RAMIS:RAMIS,1:""),?15,$SELECT($DATA(^RAMIS(71.1,RAMIS,0)):$PIECE(^(0),"^"),RAMIS="MULP":"SERIES OF AMIS CODES",1:"UNKNOWN")
- +7 IF $DATA(ZTQUEUED)
- DO STOPCHK^RAUTL9
- if $GET(ZTSTOP)=1
- SET RAEOS=1
- +8 QUIT
- +9 ;
- DIV SET IN=$PIECE(Z,"^")
- SET OUT=$PIECE(Z,"^",2)
- SET TOT=IN+OUT
- SET WWU=$PIECE(Z,"^",3)
- +1 FOR I=0:0
- SET RAMIS=$ORDER(^TMP($JOB,"RA",RADIV,RAMIS))
- if RAEOS!(RAMIS="")
- QUIT
- IF RAMIS'="MULP"
- IF RAMIS<25!(RAMIS=99)
- SET Y=^(RAMIS)
- SET RAIN=$PIECE(Y,"^")
- SET RAOUT=$PIECE(Y,"^",2)
- SET RAWWU=$PIECE(Y,"^",3)
- SET RATOT=RAIN+RAOUT
- DO DIV1
- if RAEOS
- QUIT
- +2 WRITE !!?2,"DIVISION TOTALS",?35,$JUSTIFY(IN,5),?42,$JUSTIFY(OUT,5),?49,$JUSTIFY(TOT,5),?63,$JUSTIFY(WWU,5)
- +3 WRITE !!,RA80DASH
- +4 FOR RAMIS=25,26,"MULP"
- IF $DATA(^TMP($JOB,"RA",RADIV,RAMIS))
- SET Y=^(RAMIS)
- SET RAIN=$PIECE(Y,"^")
- SET RAOUT=$PIECE(Y,"^",2)
- SET RAWWU=$PIECE(Y,"^",3)
- SET RATOT=RAIN+RAOUT
- DO DIV1
- if RAEOS
- QUIT
- +5 if RAEOS
- QUIT
- +6 IF $ORDER(^TMP($JOB,"RA",RADIV))]""
- SET RAEOS=$$EOS^RAUTL5()
- +7 QUIT
- DIV1 IF ($Y+4)>IOSL
- SET RAEOS=$$EOS^RAUTL5()
- if RAEOS
- QUIT
- DO HD
- if RAEOS
- QUIT
- +1 WRITE !,$JUSTIFY($SELECT(RAMIS:RAMIS,1:" "),2),"-",$EXTRACT($SELECT($DATA(^RAMIS(71.1,RAMIS,0)):$PIECE(^(0),"^"),RAMIS="MULP":"SERIES OF AMIS CODES",1:"UNKNOWN"),1,30)
- +2 WRITE ?35,$JUSTIFY(RAIN,5),?42,$JUSTIFY(RAOUT,5),?49,$JUSTIFY(RATOT,5),?56,$SELECT(RAMIS="MULP":"",1:$JUSTIFY($SELECT(TOT:(100*RATOT)/TOT,1:0),5,1)),?63,$JUSTIFY(RAWWU,5),?70,$JUSTIFY($SELECT(WWU:(RAWWU*100)/WWU,1:0),5,1)
- +3 QUIT
- SAVEONE ; Save off the I-Type
- +1 SET RAITNUM=+$ORDER(^TMP($JOB,"DIV-IMG",0))
- +2 SET RAITYPE=$PIECE($GET(^RA(79.2,RAITNUM,0)),"^")
- +3 SET ^TMP($JOB,"RA I-TYPE",RAITYPE,RAITNUM)=""
- +4 QUIT