- 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 Feb 19, 2025@00:02:59 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