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