RALWKL ;HISC/GJC AISC/MJK,RMO-Workload Reports By Functional Area ;4/12/96 07:54
;;5.0;Radiology/Nuclear Medicine;;Mar 16, 1998
;
SUM S X=$L(RATITLE)+$L(" Workload Report:")+1
S $P(RALN1,"-",X)="" K DIR
W @IOF,!?3,RATITLE," Workload Report:",!?3,RALN1,!
S DIR(0)="YA",DIR("A")="Do you wish only the summary report? ",DIR("B")="No"
S DIR("?")="Enter 'Yes' for a summary report, or 'No' for a detailed report."
D ^DIR K DIR I $D(DIRUT) D PURGE^RALWKL2 Q
S RASUM=+Y ; if 'RASUM no summary rpt, else summary rpt
K DIROUT,DIRUT,DTOUT,DUOUT
I $O(RACCESS(DUZ,""))="" D SETVARS^RAPSET1(0) S RAPSTX=""
K ^TMP($J,"RA"),^TMP($J,"RA1"),^TMP($J,"RAFLD") S RAXIT=0
S X=$$DIVLOC^RAUTL7() I X D PURGE^RALWKL2 Q
W ! D ONE^RALWKL3(RAFILE)
I '$D(^TMP($J,"RAFLD")) W ! D SELECT^RALWKL3
I RAXIT D PURGE^RALWKL2 Q
D ZEROUT^RALWKL2 ; Zero out totals for division and imaging type
D DATE^RAUTL
I RAPOP D PURGE^RALWKL2 Q
D DISPXAM^RALWKL1(RACRT)
I RAXIT D PURGE^RALWKL2 Q
DEV ; Save off variables, select a device
S ZTRTN="START^RALWKL" S:$D(RAFL) ZTSAVE("RAFL*")=""
S ZTSAVE("^TMP($J,""RA"",")=""
S ZTSAVE("^TMP($J,""RAFLD"",")=""
S ZTSAVE("^TMP($J,""RA D-TYPE"",")=""
S ZTSAVE("^TMP($J,""RA I-TYPE"",")=""
F RASV="BEGDATE","ENDDATE","RAFILE","RAPCE","RATITLE","RACRT(","RASUM","RAXIT","RAINPUT","RADIFLG(" S ZTSAVE(RASV)=""
W ! D ZIS^RAUTL
I RAPOP D PURGE^RALWKL2 Q
START ; Start the sorting/storing process
U IO S RABEG=BEGDATE-.0001,RAEND=ENDDATE+.9999
S:$D(ZTQUEUED) ZTREQ="@"
I RAINPUT=0 S RAFLDCNT=0,RALP="" F S RALP=$O(^TMP($J,"RAFLD",RALP)) Q:RALP="" S RAFLDCNT=RAFLDCNT+1
K RALP
F RADTE=RABEG:0:RAEND S RADTE=$O(^RADPT("AR",RADTE)) Q:RADTE'>0!(RADTE>RAEND) D Q:RAXIT
. F RADFN=0:0 S RADFN=$O(^RADPT("AR",RADTE,RADFN)) Q:RADFN'>0 D RADTI Q:RAXIT
. Q
D:'RAXIT EN1^RALWKL1
D PURGE^RALWKL2
Q
RADTI ; Traverse the Registered Exam multiple
S RADTI=0
F K RAOR,RABILAT,RAPORT S RADTI=$O(^RADPT("AR",RADTE,RADFN,RADTI)) Q:RADTI'>0 D Q:RAXIT
. I $D(^RADPT(RADFN,"DT",RADTI,0)) S RAD0=$G(^(0)) D RACNI
. Q
Q
RACNI ; Traverse the Examinations multiple
S RADIV=+$P(RAD0,"^",3),RADIV=+$P($G(^RA(79,RADIV,0)),"^"),RADIV=$S($D(^DIC(4,+RADIV,0)):+RADIV,1:99)
S RADIVNME=$S($D(^DIC(4,RADIV,0)):$P(^(0),U,1),1:"Unknown")
Q:'$D(^TMP($J,"RA D-TYPE",RADIVNME)) S RACNI=0
F S RACNI=$O(^RADPT(RADFN,"DT",RADTI,"P",RACNI)) Q:RACNI'>0 D Q:RAXIT
. I $D(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0)) S RAP0=$G(^(0)) D
.. I $D(RACRT(+$P(RAP0,"^",3))) D
... S B=$G(RACRT(+$P(RAP0,"^",3))) D IT^RALWKL2 S RAIMG=$S(B1?3AP1"-".N:B1,1:"") D:RAIMG]"" CHK^RALWKL3
... Q
.. Q
. Q
Q
PRC ; Procedure checks
I +RAZ=25 S RAOR="" Q
I +RAZ=26 S RAPORT="" Q
S:$P(RAZ,"^",3)="Y" RABILAT="" F J=1:1 I '$D(RAMIS(J)) S RAMIS(J)=$S(RAMJ]"":+RAZ,1:99),RAWT(J)=+$P(RAMJ,"^",2),RAMUL(J)=$S(+$P(RAZ,"^",2)>0:+$P(RAZ,U,2),1:1) S:$D(RABILAT)&(RAMUL(J)<2) RAMUL(J)=RAMUL(J)*2 S:J>1 RAMULP="" Q
K RABILAT
Q
;
AUX ;
I '$D(^TMP($J,"RA",RADIV,RAIMG,RAFLD,A,RAPRC)) D
. S ^TMP($J,"RA",RADIV,RAIMG,RAFLD,A,RAPRC)="0^0^0^0^0"
S X=$G(^TMP($J,"RA",RADIV,RAIMG,RAFLD,A,RAPRC))
S $P(X,"^",C)=$P(X,"^",C)+RANUM,$P(X,"^",5)=$P(X,"^",5)+RAWT
S ^TMP($J,"RA",RADIV,RAIMG,RAFLD,A,RAPRC)=X
Q
WARD ; Ward Report Entry Point
S ZTDESC="Rad/Nuc Med Functional Area Ward Rpt."
S RAFILE="DIC(42,",RACRT=5,RAPCE=6,RATITLE="Ward",RAFL="" G RALWKL
;
SERV ; Service Report Entry Point
S ZTDESC="Rad/Nuc Med Functional Area Service Rpt."
S RAFILE="DIC(49,",RACRT=3,RAPCE=7,RATITLE="Service",RAFL="" G RALWKL
;
BEDSEC ; PTF Bedsection Report Entry Point
S ZTDESC="Rad/Nuc Med Functional Area PTF Bedsection Rpt."
S RAFILE="DIC(42.4,",RACRT=2,RAPCE=19,RATITLE="PTF Bedsection",RAFL="" G RALWKL
;
CLINIC ; Clinic Report Entry Point
S ZTDESC="Rad/Nuc Med Functional Area Clinic Rpt."
S RAFILE="SC(",RACRT=1,RAPCE=8,RATITLE="Clinic",RAFL="" G RALWKL
;
SHAR ; Sharing Agreement/Contract Report Entry Point
S ZTDESC="Rad/Nuc Med Functional Area Sharing Agreement/Contract Rpt."
S RAFILE="DIC(34,",RACRT=4,RAPCE=9,RATITLE="Sharing/Contract",RAFL="" G RALWKL
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRALWKL 4128 printed Apr 09, 2024@21:40:16 Page 2
RALWKL ;HISC/GJC AISC/MJK,RMO-Workload Reports By Functional Area ;4/12/96 07:54
+1 ;;5.0;Radiology/Nuclear Medicine;;Mar 16, 1998
+2 ;
SUM SET X=$LENGTH(RATITLE)+$LENGTH(" Workload Report:")+1
+1 SET $PIECE(RALN1,"-",X)=""
KILL DIR
+2 WRITE @IOF,!?3,RATITLE," Workload Report:",!?3,RALN1,!
+3 SET DIR(0)="YA"
SET DIR("A")="Do you wish only the summary report? "
SET DIR("B")="No"
+4 SET DIR("?")="Enter 'Yes' for a summary report, or 'No' for a detailed report."
+5 DO ^DIR
KILL DIR
IF $DATA(DIRUT)
DO PURGE^RALWKL2
QUIT
+6 ; if 'RASUM no summary rpt, else summary rpt
SET RASUM=+Y
+7 KILL DIROUT,DIRUT,DTOUT,DUOUT
+8 IF $ORDER(RACCESS(DUZ,""))=""
DO SETVARS^RAPSET1(0)
SET RAPSTX=""
+9 KILL ^TMP($JOB,"RA"),^TMP($JOB,"RA1"),^TMP($JOB,"RAFLD")
SET RAXIT=0
+10 SET X=$$DIVLOC^RAUTL7()
IF X
DO PURGE^RALWKL2
QUIT
+11 WRITE !
DO ONE^RALWKL3(RAFILE)
+12 IF '$DATA(^TMP($JOB,"RAFLD"))
WRITE !
DO SELECT^RALWKL3
+13 IF RAXIT
DO PURGE^RALWKL2
QUIT
+14 ; Zero out totals for division and imaging type
DO ZEROUT^RALWKL2
+15 DO DATE^RAUTL
+16 IF RAPOP
DO PURGE^RALWKL2
QUIT
+17 DO DISPXAM^RALWKL1(RACRT)
+18 IF RAXIT
DO PURGE^RALWKL2
QUIT
DEV ; Save off variables, select a device
+1 SET ZTRTN="START^RALWKL"
if $DATA(RAFL)
SET ZTSAVE("RAFL*")=""
+2 SET ZTSAVE("^TMP($J,""RA"",")=""
+3 SET ZTSAVE("^TMP($J,""RAFLD"",")=""
+4 SET ZTSAVE("^TMP($J,""RA D-TYPE"",")=""
+5 SET ZTSAVE("^TMP($J,""RA I-TYPE"",")=""
+6 FOR RASV="BEGDATE","ENDDATE","RAFILE","RAPCE","RATITLE","RACRT(","RASUM","RAXIT","RAINPUT","RADIFLG("
SET ZTSAVE(RASV)=""
+7 WRITE !
DO ZIS^RAUTL
+8 IF RAPOP
DO PURGE^RALWKL2
QUIT
START ; Start the sorting/storing process
+1 USE IO
SET RABEG=BEGDATE-.0001
SET RAEND=ENDDATE+.9999
+2 if $DATA(ZTQUEUED)
SET ZTREQ="@"
+3 IF RAINPUT=0
SET RAFLDCNT=0
SET RALP=""
FOR
SET RALP=$ORDER(^TMP($JOB,"RAFLD",RALP))
if RALP=""
QUIT
SET RAFLDCNT=RAFLDCNT+1
+4 KILL RALP
+5 FOR RADTE=RABEG:0:RAEND
SET RADTE=$ORDER(^RADPT("AR",RADTE))
if RADTE'>0!(RADTE>RAEND)
QUIT
Begin DoDot:1
+6 FOR RADFN=0:0
SET RADFN=$ORDER(^RADPT("AR",RADTE,RADFN))
if RADFN'>0
QUIT
DO RADTI
if RAXIT
QUIT
+7 QUIT
End DoDot:1
if RAXIT
QUIT
+8 if 'RAXIT
DO EN1^RALWKL1
+9 DO PURGE^RALWKL2
+10 QUIT
RADTI ; Traverse the Registered Exam multiple
+1 SET RADTI=0
+2 FOR
KILL RAOR,RABILAT,RAPORT
SET RADTI=$ORDER(^RADPT("AR",RADTE,RADFN,RADTI))
if RADTI'>0
QUIT
Begin DoDot:1
+3 IF $DATA(^RADPT(RADFN,"DT",RADTI,0))
SET RAD0=$GET(^(0))
DO RACNI
+4 QUIT
End DoDot:1
if RAXIT
QUIT
+5 QUIT
RACNI ; Traverse the Examinations multiple
+1 SET RADIV=+$PIECE(RAD0,"^",3)
SET RADIV=+$PIECE($GET(^RA(79,RADIV,0)),"^")
SET RADIV=$SELECT($DATA(^DIC(4,+RADIV,0)):+RADIV,1:99)
+2 SET RADIVNME=$SELECT($DATA(^DIC(4,RADIV,0)):$PIECE(^(0),U,1),1:"Unknown")
+3 if '$DATA(^TMP($JOB,"RA D-TYPE",RADIVNME))
QUIT
SET RACNI=0
+4 FOR
SET RACNI=$ORDER(^RADPT(RADFN,"DT",RADTI,"P",RACNI))
if RACNI'>0
QUIT
Begin DoDot:1
+5 IF $DATA(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0))
SET RAP0=$GET(^(0))
Begin DoDot:2
+6 IF $DATA(RACRT(+$PIECE(RAP0,"^",3)))
Begin DoDot:3
+7 SET B=$GET(RACRT(+$PIECE(RAP0,"^",3)))
DO IT^RALWKL2
SET RAIMG=$SELECT(B1?3AP1"-".N:B1,1:"")
if RAIMG]""
DO CHK^RALWKL3
+8 QUIT
End DoDot:3
+9 QUIT
End DoDot:2
+10 QUIT
End DoDot:1
if RAXIT
QUIT
+11 QUIT
PRC ; Procedure checks
+1 IF +RAZ=25
SET RAOR=""
QUIT
+2 IF +RAZ=26
SET RAPORT=""
QUIT
+3 if $PIECE(RAZ,"^",3)="Y"
SET RABILAT=""
FOR J=1:1
IF '$DATA(RAMIS(J))
SET RAMIS(J)=$SELECT(RAMJ]"":+RAZ,1:99)
SET RAWT(J)=+$PIECE(RAMJ,"^",2)
SET RAMUL(J)=$SELECT(+$PIECE(RAZ,"^",2)>0:+$PIECE(RAZ,U,2),1:1)
if $DATA(RABILAT)&(RAMUL(J)<2)
SET RAMUL(J)=RAMUL(J)*2
if J>1
SET RAMULP=""
QUIT
+4 KILL RABILAT
+5 QUIT
+6 ;
AUX ;
+1 IF '$DATA(^TMP($JOB,"RA",RADIV,RAIMG,RAFLD,A,RAPRC))
Begin DoDot:1
+2 SET ^TMP($JOB,"RA",RADIV,RAIMG,RAFLD,A,RAPRC)="0^0^0^0^0"
End DoDot:1
+3 SET X=$GET(^TMP($JOB,"RA",RADIV,RAIMG,RAFLD,A,RAPRC))
+4 SET $PIECE(X,"^",C)=$PIECE(X,"^",C)+RANUM
SET $PIECE(X,"^",5)=$PIECE(X,"^",5)+RAWT
+5 SET ^TMP($JOB,"RA",RADIV,RAIMG,RAFLD,A,RAPRC)=X
+6 QUIT
WARD ; Ward Report Entry Point
+1 SET ZTDESC="Rad/Nuc Med Functional Area Ward Rpt."
+2 SET RAFILE="DIC(42,"
SET RACRT=5
SET RAPCE=6
SET RATITLE="Ward"
SET RAFL=""
GOTO RALWKL
+3 ;
SERV ; Service Report Entry Point
+1 SET ZTDESC="Rad/Nuc Med Functional Area Service Rpt."
+2 SET RAFILE="DIC(49,"
SET RACRT=3
SET RAPCE=7
SET RATITLE="Service"
SET RAFL=""
GOTO RALWKL
+3 ;
BEDSEC ; PTF Bedsection Report Entry Point
+1 SET ZTDESC="Rad/Nuc Med Functional Area PTF Bedsection Rpt."
+2 SET RAFILE="DIC(42.4,"
SET RACRT=2
SET RAPCE=19
SET RATITLE="PTF Bedsection"
SET RAFL=""
GOTO RALWKL
+3 ;
CLINIC ; Clinic Report Entry Point
+1 SET ZTDESC="Rad/Nuc Med Functional Area Clinic Rpt."
+2 SET RAFILE="SC("
SET RACRT=1
SET RAPCE=8
SET RATITLE="Clinic"
SET RAFL=""
GOTO RALWKL
+3 ;
SHAR ; Sharing Agreement/Contract Report Entry Point
+1 SET ZTDESC="Rad/Nuc Med Functional Area Sharing Agreement/Contract Rpt."
+2 SET RAFILE="DIC(34,"
SET RACRT=4
SET RAPCE=9
SET RATITLE="Sharing/Contract"
SET RAFL=""
GOTO RALWKL
