RALWKL3 ;HISC/GJC-Workload Reports By Functional Area ;9/23/96 09:00
;;5.0;Radiology/Nuclear Medicine;;Mar 16, 1998
CHK ; Does the data meet the sort criteria?
S C=$P(RAP0,"^",4),C=$S(C="I":1,C="O":2,C="R":3,1:4)
Q:'$P(RAP0,"^",RAPCE) S RAFLD=$S($D(@("^"_RAFILE_"+$P(RAP0,""^"",RAPCE),0)")):$P(^(0),"^"),1:"Unknown")
I 'RAINPUT Q:'$D(^TMP($J,"RAFLD",RAFLD)) ; not all and not a user selected entry
S RAFLD=$E(RAFLD,1,30)
I RAFILE="SC(" Q:C=1
I (RAFILE="DIC(42,"!(RAFILE="DIC(42.4,")!(RAFILE="DIC(49,")) Q:13'[C
F I=0:0 S I=$O(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"M",I)) Q:I'>0 I $D(^(I,0)) S RAQI=+$G(^(0)) D EXTRA^RAUTL12(RAQI)
Q:'$D(^RAMIS(71,+$P(RAP0,"^",2),0)) S RAPRI=$G(^(0)),RAPRC=$E($P(RAPRI,"^"),1,40) Q:'$D(^(2)) F I=0:0 S I=$O(^RAMIS(71,+$P(RAP0,"^",2),2,I)) Q:I'>0 I $D(^(I,0)) S RAZ=$G(^(0)),RAMJ=$S($D(^RAMIS(71.1,+RAZ,0)):^(0),1:"") D PRC^RALWKL
Q:'$D(RAMIS(1))
I J=1 S RAMIS=RAMIS(1),RAWT=RAWT(1),RAMUL=RAMUL(1),RAWT=RAWT*RAMUL,RANUM=RAMUL
I J>1 S RANUM=1,RAWT=0,RAMIS=RAMIS(1) F J=1:1 Q:'$D(RAMIS(J)) S I=RAWT(J),RAMUL=RAMUL(J),RAWT=RAWT+(RAMUL*I)
D STORE K RAMIS,RAWT,RAMUL,RAZ,RAMJ,RAMULP,RAMULPFL,RABILAT,RAOR,RAPORT
Q
STORE ; Store off data into ^TMP global.
I $D(ZTQUEUED) D STOPCHK^RAUTL9 S:$G(ZTSTOP)=1 RAXIT=1 Q:RAXIT
I $D(RAOR) S A=25 D AUX^RALWKL
I $D(RAPORT) S A=26 D AUX^RALWKL
I $D(RAMULP) S A="MULP" D AUX^RALWKL
;----------- Tabulation over all divisions -----------------------------
S X=$G(^TMP($J,"RA",RADIV))
S $P(X,"^",C)=$P(X,"^",C)+RANUM,$P(X,"^",5)=$P(X,"^",5)+RAWT
S ^TMP($J,"RA",RADIV)=X
;----------- Tabulation over all divisions/imaging types ---------------
S X=$G(^TMP($J,"RA",RADIV,RAIMG))
S $P(X,"^",C)=$P(X,"^",C)+RANUM,$P(X,"^",5)=$P(X,"^",5)+RAWT
S ^TMP($J,"RA",RADIV,RAIMG)=X
;------------Tabulation over division/i-type/option parameter ----------
I '$D(^TMP($J,"RA",RADIV,RAIMG,RAFLD))#2 D
. S ^TMP($J,"RA",RADIV,RAIMG,RAFLD)="0^0^0^0^0"
S X=$G(^TMP($J,"RA",RADIV,RAIMG,RAFLD))
S $P(X,"^",C)=$P(X,"^",C)+RANUM,$P(X,"^",5)=$P(X,"^",5)+RAWT
S ^TMP($J,"RA",RADIV,RAIMG,RAFLD)=X
;------------Tabulation over division/option parameter ----------
; ***** Note new '^TMP($J' subscript (RA1) *****
I '$D(^TMP($J,"RA1",RADIV,RAFLD))#2 D
. S ^TMP($J,"RA1",RADIV,RAFLD)="0^0^0^0^0"
S X=$G(^TMP($J,"RA1",RADIV,RAFLD))
S $P(X,"^",C)=$P(X,"^",C)+RANUM,$P(X,"^",5)=$P(X,"^",5)+RAWT
S ^TMP($J,"RA1",RADIV,RAFLD)=X
;----------- Tabulation over division/i-types/option parameter/proc ----
I '$D(^TMP($J,"RA",RADIV,RAIMG,RAFLD,RAMIS,RAPRC)) D
. S ^TMP($J,"RA",RADIV,RAIMG,RAFLD,RAMIS,RAPRC)="0^0^0^0^0"
S X=$G(^TMP($J,"RA",RADIV,RAIMG,RAFLD,RAMIS,RAPRC))
S $P(X,"^",C)=$P(X,"^",C)+RANUM,$P(X,"^",5)=$P(X,"^",5)+RAWT
S ^TMP($J,"RA",RADIV,RAIMG,RAFLD,RAMIS,RAPRC)=X
Q
ALLNOTH() ; Do you want access to all entries in the file or just a subset
; of entries?
; 'RAPRIM' will be defined if accessing this subroutine through the
; Options: RA WKLRES (Resident Report) & RA WKLSTAFF (Staff Report)
N RAINPUT K DIR,X,Y S DIR(0)="YA",DIR("B")="Yes"
S DIR("A")="Do you wish to include all "_$S($G(RAPRIM)=1:"Primary ",1:"")_$G(RATITLE)_"s? "
I $G(RATITLE)="Interpreting Staff" S DIR("A")="Do you wish to include all"_$S($G(RAPRIM)=1:" Primary",1:"")_" Interpreting Staff? "
S DIR("?",1)="Enter 'Yes' to select all entries in the file."
S DIR("?")="Enter 'No' to select a subset of entries in the file."
W ! D ^DIR K DIR Q:$D(DIRUT) ""
S RAINPUT=+Y K DIROUT,DIRUT,DTOUT,DUOUT,X,Y
Q RAINPUT
ONE(Z) ; Check if only one entry in the file. (File specs passed in.)
N RAXREF,RAZERO,X,X1,Y,Y1
S RAXREF="^"_Z_"""B"",",RAZERO="^"_Z
S X=$O(@(RAXREF_""""")")) Q:X']""
S Y=$O(@(RAXREF_""""_X_""")")) Q:Y]""
S X1=+$O(@(RAXREF_""""_X_""",0)")) Q:'X1
S:Z="SC(" Y1=$P($G(@(RAZERO_X1_",0)")),"^")
S:Z'="SC(" Y1=$P($G(@(RAZERO_X1_",0)")),"^")
S ^TMP($J,"RAFLD",Y1,X1)="",RAINPUT=0
Q
SELECT ; Select one-many-all entries from a specific file.
Q:$D(^TMP($J,"RAFLD")) ; Only one entry in the file
N RADIC,RAUTIL S RADIC="^"_RAFILE,RADIC(0)="QEAMZ"
S RADIC("A")="Select "_$G(RATITLE)_": "
S RAUTIL="RAFLD",RAINPUT=$$ALLNOTH()
S:RAINPUT="" RAXIT=1 Q:RAXIT
D:'RAINPUT EN1^RASELCT(.RADIC,RAUTIL,"",RAINPUT)
S RAXIT=RAQUIT K:RAXIT RAINPUT Q:RAXIT
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRALWKL3 4309 printed Dec 13, 2024@02:36:43 Page 2
RALWKL3 ;HISC/GJC-Workload Reports By Functional Area ;9/23/96 09:00
+1 ;;5.0;Radiology/Nuclear Medicine;;Mar 16, 1998
CHK ; Does the data meet the sort criteria?
+1 SET C=$PIECE(RAP0,"^",4)
SET C=$SELECT(C="I":1,C="O":2,C="R":3,1:4)
+2 if '$PIECE(RAP0,"^",RAPCE)
QUIT
SET RAFLD=$SELECT($DATA(@("^"_RAFILE_"+$P(RAP0,""^"",RAPCE),0)")):$PIECE(^(0),"^"),1:"Unknown")
+3 ; not all and not a user selected entry
IF 'RAINPUT
if '$DATA(^TMP($JOB,"RAFLD",RAFLD))
QUIT
+4 SET RAFLD=$EXTRACT(RAFLD,1,30)
+5 IF RAFILE="SC("
if C=1
QUIT
+6 IF (RAFILE="DIC(42,"!(RAFILE="DIC(42.4,")!(RAFILE="DIC(49,"))
if 13'[C
QUIT
+7 FOR I=0:0
SET I=$ORDER(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"M",I))
if I'>0
QUIT
IF $DATA(^(I,0))
SET RAQI=+$GET(^(0))
DO EXTRA^RAUTL12(RAQI)
+8 if '$DATA(^RAMIS(71,+$PIECE(RAP0,"^",2),0))
QUIT
SET RAPRI=$GET(^(0))
SET RAPRC=$EXTRACT($PIECE(RAPRI,"^"),1,40)
if '$DATA(^(2))
QUIT
FOR I=0:0
SET I=$ORDER(^RAMIS(71,+$PIECE(RAP0,"^",2),2,I))
if I'>0
QUIT
IF $DATA(^(I,0))
SET RAZ=$GET(^(0))
SET RAMJ=$SELECT($DATA(^RAMIS(71.1,+RAZ,0)):^(0),1:"")
DO PRC^RALWKL
+9 if '$DATA(RAMIS(1))
QUIT
+10 IF J=1
SET RAMIS=RAMIS(1)
SET RAWT=RAWT(1)
SET RAMUL=RAMUL(1)
SET RAWT=RAWT*RAMUL
SET RANUM=RAMUL
+11 IF J>1
SET RANUM=1
SET RAWT=0
SET RAMIS=RAMIS(1)
FOR J=1:1
if '$DATA(RAMIS(J))
QUIT
SET I=RAWT(J)
SET RAMUL=RAMUL(J)
SET RAWT=RAWT+(RAMUL*I)
+12 DO STORE
KILL RAMIS,RAWT,RAMUL,RAZ,RAMJ,RAMULP,RAMULPFL,RABILAT,RAOR,RAPORT
+13 QUIT
STORE ; Store off data into ^TMP global.
+1 IF $DATA(ZTQUEUED)
DO STOPCHK^RAUTL9
if $GET(ZTSTOP)=1
SET RAXIT=1
if RAXIT
QUIT
+2 IF $DATA(RAOR)
SET A=25
DO AUX^RALWKL
+3 IF $DATA(RAPORT)
SET A=26
DO AUX^RALWKL
+4 IF $DATA(RAMULP)
SET A="MULP"
DO AUX^RALWKL
+5 ;----------- Tabulation over all divisions -----------------------------
+6 SET X=$GET(^TMP($JOB,"RA",RADIV))
+7 SET $PIECE(X,"^",C)=$PIECE(X,"^",C)+RANUM
SET $PIECE(X,"^",5)=$PIECE(X,"^",5)+RAWT
+8 SET ^TMP($JOB,"RA",RADIV)=X
+9 ;----------- Tabulation over all divisions/imaging types ---------------
+10 SET X=$GET(^TMP($JOB,"RA",RADIV,RAIMG))
+11 SET $PIECE(X,"^",C)=$PIECE(X,"^",C)+RANUM
SET $PIECE(X,"^",5)=$PIECE(X,"^",5)+RAWT
+12 SET ^TMP($JOB,"RA",RADIV,RAIMG)=X
+13 ;------------Tabulation over division/i-type/option parameter ----------
+14 IF '$DATA(^TMP($JOB,"RA",RADIV,RAIMG,RAFLD))#2
Begin DoDot:1
+15 SET ^TMP($JOB,"RA",RADIV,RAIMG,RAFLD)="0^0^0^0^0"
End DoDot:1
+16 SET X=$GET(^TMP($JOB,"RA",RADIV,RAIMG,RAFLD))
+17 SET $PIECE(X,"^",C)=$PIECE(X,"^",C)+RANUM
SET $PIECE(X,"^",5)=$PIECE(X,"^",5)+RAWT
+18 SET ^TMP($JOB,"RA",RADIV,RAIMG,RAFLD)=X
+19 ;------------Tabulation over division/option parameter ----------
+20 ; ***** Note new '^TMP($J' subscript (RA1) *****
+21 IF '$DATA(^TMP($JOB,"RA1",RADIV,RAFLD))#2
Begin DoDot:1
+22 SET ^TMP($JOB,"RA1",RADIV,RAFLD)="0^0^0^0^0"
End DoDot:1
+23 SET X=$GET(^TMP($JOB,"RA1",RADIV,RAFLD))
+24 SET $PIECE(X,"^",C)=$PIECE(X,"^",C)+RANUM
SET $PIECE(X,"^",5)=$PIECE(X,"^",5)+RAWT
+25 SET ^TMP($JOB,"RA1",RADIV,RAFLD)=X
+26 ;----------- Tabulation over division/i-types/option parameter/proc ----
+27 IF '$DATA(^TMP($JOB,"RA",RADIV,RAIMG,RAFLD,RAMIS,RAPRC))
Begin DoDot:1
+28 SET ^TMP($JOB,"RA",RADIV,RAIMG,RAFLD,RAMIS,RAPRC)="0^0^0^0^0"
End DoDot:1
+29 SET X=$GET(^TMP($JOB,"RA",RADIV,RAIMG,RAFLD,RAMIS,RAPRC))
+30 SET $PIECE(X,"^",C)=$PIECE(X,"^",C)+RANUM
SET $PIECE(X,"^",5)=$PIECE(X,"^",5)+RAWT
+31 SET ^TMP($JOB,"RA",RADIV,RAIMG,RAFLD,RAMIS,RAPRC)=X
+32 QUIT
ALLNOTH() ; Do you want access to all entries in the file or just a subset
+1 ; of entries?
+2 ; 'RAPRIM' will be defined if accessing this subroutine through the
+3 ; Options: RA WKLRES (Resident Report) & RA WKLSTAFF (Staff Report)
+4 NEW RAINPUT
KILL DIR,X,Y
SET DIR(0)="YA"
SET DIR("B")="Yes"
+5 SET DIR("A")="Do you wish to include all "_$SELECT($GET(RAPRIM)=1:"Primary ",1:"")_$GET(RATITLE)_"s? "
+6 IF $GET(RATITLE)="Interpreting Staff"
SET DIR("A")="Do you wish to include all"_$SELECT($GET(RAPRIM)=1:" Primary",1:"")_" Interpreting Staff? "
+7 SET DIR("?",1)="Enter 'Yes' to select all entries in the file."
+8 SET DIR("?")="Enter 'No' to select a subset of entries in the file."
+9 WRITE !
DO ^DIR
KILL DIR
if $DATA(DIRUT)
QUIT ""
+10 SET RAINPUT=+Y
KILL DIROUT,DIRUT,DTOUT,DUOUT,X,Y
+11 QUIT RAINPUT
ONE(Z) ; Check if only one entry in the file. (File specs passed in.)
+1 NEW RAXREF,RAZERO,X,X1,Y,Y1
+2 SET RAXREF="^"_Z_"""B"","
SET RAZERO="^"_Z
+3 SET X=$ORDER(@(RAXREF_""""")"))
if X']""
QUIT
+4 SET Y=$ORDER(@(RAXREF_""""_X_""")"))
if Y]""
QUIT
+5 SET X1=+$ORDER(@(RAXREF_""""_X_""",0)"))
if 'X1
QUIT
+6 if Z="SC("
SET Y1=$PIECE($GET(@(RAZERO_X1_",0)")),"^")
+7 if Z'="SC("
SET Y1=$PIECE($GET(@(RAZERO_X1_",0)")),"^")
+8 SET ^TMP($JOB,"RAFLD",Y1,X1)=""
SET RAINPUT=0
+9 QUIT
SELECT ; Select one-many-all entries from a specific file.
+1 ; Only one entry in the file
if $DATA(^TMP($JOB,"RAFLD"))
QUIT
+2 NEW RADIC,RAUTIL
SET RADIC="^"_RAFILE
SET RADIC(0)="QEAMZ"
+3 SET RADIC("A")="Select "_$GET(RATITLE)_": "
+4 SET RAUTIL="RAFLD"
SET RAINPUT=$$ALLNOTH()
+5 if RAINPUT=""
SET RAXIT=1
if RAXIT
QUIT
+6 if 'RAINPUT
DO EN1^RASELCT(.RADIC,RAUTIL,"",RAINPUT)
+7 SET RAXIT=RAQUIT
if RAXIT
KILL RAINPUT
if RAXIT
QUIT
+8 QUIT
