RAWKL ;HISC/FPT AISC/MJK,RMO-Workload Reports ;12/27/00 11:00
;;5.0;Radiology/Nuclear Medicine;**26**;Mar 16, 1998
;
I $O(RACCESS(DUZ,""))="" D SETVARS^RAPSET1(0) S RAPSTX=""
; RAFL flags Tech Rpt and Camera Rpt
SUM S X="-----------------" W !!,RATITLE," Workload Report:",!,X,$E(X,1,$L(RATITLE)) K RAFL1,^TMP($J)
ASKSUM ;
W ! K DIR S DIR(0)="Y",DIR("A")="Do you wish only the summary report",DIR("B")="NO",DIR("?")="Enter YES for a summary report or NO for a detailed report"
D ^DIR K DIR I $D(DIRUT) D Q^RAWKL2 Q
I RATITLE["Interpreting" D Q:RAPRIM=-1
. S RAPRIM=$$PRI($P(RATITLE," ",2)) D:RAPRIM=-1 Q^RAWKL2
. Q
S:Y=0 RAFL1=""
K DIROUT,DIRUT,DTOUT,DUOUT
S X=$$DIVLOC^RAUTL7() I X D Q^RAWKL2 Q
S A="" F S A=$O(RACCESS(DUZ,"DIV-IMG",A)) Q:A']"" D
. Q:'$D(^TMP($J,"RA D-TYPE",A)) S A1=$O(^TMP($J,"RA D-TYPE",A,0))
. Q:A1'>0 S B=""
. F S B=$O(RACCESS(DUZ,"DIV-IMG",A,B)) Q:B']"" D
.. I $D(^TMP($J,"RA I-TYPE",B)) D IT^RALWKL2 I B1?3AP1"-".N S ^TMP($J,"RAWKL",A1,B1)=0
.. Q
. Q
K A,A1,B,B1,RACCESS(DUZ,"DIV-IMG")
S RAINPUT=$$ALLNOTH^RALWKL3() I RAINPUT="" D Q^RAWKL2 Q
I RAINPUT=0 D RSPTR I RAQUIT=1 D Q^RAWKL2 Q
I RAINPUT=0 S RAFLDCNT=0,RALP="" F S RALP=$O(^TMP($J,"RAFLD",RALP)) Q:RALP="" S RAFLDCNT=RAFLDCNT+1
K RALP
D DATE^RAUTL I RAPOP D Q^RAWKL2 Q
S RAXIT=0 D DISPXAM^RALWKL1(RACRT) I RAXIT D Q^RAWKL2 Q
S ZTDESC="Rad/Nuc Med "_RATITLE_" Workload Report",ZTRTN="START^RAWKL" S ZTSAVE("RAFL*")="",ZTSAVE("^TMP($J,""RAWKL"",")="",ZTSAVE("^TMP($J,""RAFLD"",")=""
F RASV="BEGDATE","ENDDATE","RAFILE","RAFLDCNT","RAPCE","RAPSTX","RATITLE","RACRT","RAINPUT","RAPRIM","RACMLIST" S ZTSAVE(RASV)=""
W ! D ZIS^RAUTL I RAPOP D Q^RAWKL2 Q
START ; start processing
U IO K ^TMP($J,"RA") S:$D(ZTQUEUED) ZTREQ="@" K RAEOS
S RABEG=BEGDATE-.0001,RAEND=ENDDATE+.9999,RA80DASH=$$REPEAT^XLFSTR("-",80)
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
D CRIT^RAUTL1 S RACPT=""
S RAITCNT=0,RALP=""
F S RALP=$O(^TMP($J,"RAWKL",RALP)) Q:RALP="" S RAITCNT(RALP)=0,^TMP($J,"RA",RALP)="0^0^0" S RALP1="" F S RALP1=$O(^TMP($J,"RAWKL",RALP,RALP1)) Q:RALP1="" S RAITCNT(RALP)=RAITCNT(RALP)+1,^TMP($J,"RA",RALP,RALP1)="0^0^0"
K RALP,RALP1
F RADTE=RABEG:0:RAEND S RADTE=$O(^RADPT("AR",RADTE)) Q:RADTE'>0!(RADTE>RAEND)!($D(RAEOS)) S RADTI=9999999.9999-RADTE D RADFN^RAWKL1
G:'$D(RAEOS) ^RAWKL2
Q
;
TECH S RAFILE="VA(200,",RACRT=7,RAPCE="TC",RATITLE="Technologist",RAFL="" G RAWKL
;
RES N RAPRIM S RAFILE="VA(200,",RACRT=13,RAPCE=12,RATITLE="Interpreting Resident" G RAWKL
;
STAFF N RAPRIM S RAFILE="VA(200,",RACRT=14,RAPCE=15,RATITLE="Interpreting Staff" D ASK1 I $D(DIRUT) D Q^RAWKL2 Q
G RAWKL
;
PHY S RAFILE="VA(200,",RACRT=12,RAPCE=14,RATITLE="Requesting M.D." G RAWKL
;
ROOM S RAFILE="RA(78.6,",RACRT=11,RAPCE=18,RATITLE="Camera/Equip/Room",RAFL="" G RAWKL
;
RSPTR ; select res/staff/phy/tech/room to include in workload rpts
; Creates ^TMP($J,"RAFLD",File 200 NAME)=""
K ^TMP($J,"RAFLD")
S RACNT=0
; check for one res/staff/tech only
I RACRT=7!(RACRT=13)!(RACRT=14) S RASUBSPT=$S(RACRT=7:"T",RACRT=13:"R",RACRT=14:"S",1:""),RAONECHK=0 F S RAONECHK=$O(^VA(200,"ARC",RASUBSPT,RAONECHK)) Q:RAONECHK=""!(RACNT>1) S RACNT=RACNT+1
I RACNT=1 D RST,KILL Q
; check for one physician only
I RACRT=12 S RAONECHK=0 F S RAONECHK=$O(^XUSEC("PROVIDER",RAONECHK)) Q:RAONECHK=""!(RACNT>1) S RACNT=RACNT+1
I RACNT=1 D P,KILL Q
; check for one camera room only
I RACRT=11 S RAONECHK=$P(^RA(78.6,0),U,4) I RAONECHK=1 S RAIEN=$O(^RA(78.6,0)) Q:RAIEN<1 S RAONENME=$P(^RA(78.6,+RAIEN,0),U,1)_$P(^RA(78.6,+RAIEN,0),U,2),RAONENME=$E(RAONENME,1,30),^TMP($J,"RAFLD",RAONENME)="" D KILL Q
I RACRT=7!(RACRT=13)!(RACRT=14)!(RACRT=12) S RADIC="^VA(200,"
I RACRT=11 S RADIC="^RA(78.6,"
S RADIC(0)="QEAMZ"
S RADIC("A")="Select "_RATITLE_": "
I RACRT=7 S RADIC("S")="I $D(^VA(200,""ARC"",""T"",+Y))"
I RACRT=13 S RADIC("S")="I $D(^VA(200,""ARC"",""R"",+Y))"
I RACRT=14 S RADIC("S")="I $D(^VA(200,""ARC"",""S"",+Y))"
I RACRT=12 S RADIC("S")="I $D(^XUSEC(""PROVIDER"",+Y))"
S RAUTIL="RAFLD"
D EN1^RASELCT(.RADIC,RAUTIL,"",RAINPUT)
KILL ;
K %W,%Y1,DIC,RACNT,RADIC,RAIEN,RAONECHK,RAONENME,RASUBSPT,RAUTIL,X,Y
Q
RST ; resident/staff/tech
S RAIEN=$O(^VA(200,"ARC",RASUBSPT,0)),RAONENME=$P(^VA(200,+RAIEN,0),U,1),RAONENME=$E(RAONENME,1,30),^TMP($J,"RAFLD",RAONENME)=""
Q
P ; physicians
S RAIEN=$O(^XUSEC("PROVIDER",0)),RAONENME=$P(^VA(200,+RAIEN,0),U,1),RAONENME=$E(RAONENME,1,30),^TMP($J,"RAFLD",RAONENME)=""
Q
PRI(RACLS) ; Ask user to include Pri. Res/Staff only in the
; 'Interpreting Res/Staff' report
; Input: RACLS-> 'Resident' or 'Staff'
; Returns: 1 if Pri. Staff only, 0 if Pri. & Sec. Staff included, and
; -1 if exiting without a report
W ! K DIR,DIROUT,DIRUT,DTOUT,DUOUT N X,Y
S DIR(0)="Y",DIR("A")="Count "_RACLS_" when entered as 'secondary'"_$S(RACLS?1"S".E:" staff",1:" resident")_" interpreter",DIR("B")="Yes"
S DIR("?",1)="Answer 'Yes' if both Primary and Secondary "_RACLS_" personnel will be included"
S DIR("?",2)="in this report. Answer 'No' if only Primary "_RACLS_" personnel will be"
S DIR("?")="included in this report. Input a '^' to exit without a report."
D ^DIR S:$D(DIRUT) Y=-1 K DIR,DIROUT,DIRUT,DTOUT,DUOUT
Q $S(+Y=-1:-1,+Y:0,1:1)
ASK1 ; ask user if want to put CPT modifiers as separate line items
K DIR S DIR(0)="Y",DIR("B")="NO"
S DIR("A")="Do you want to count CPT Modifiers separately"
S DIR("?")="Enter YES to put different combinations of CPT modifiers onto separate lines"
W ! D ^DIR K DIR
S:Y RACMLIST=1 ;=1 means to list CPT mods as separate line items
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRAWKL 5727 printed Dec 13, 2024@02:40:40 Page 2
RAWKL ;HISC/FPT AISC/MJK,RMO-Workload Reports ;12/27/00 11:00
+1 ;;5.0;Radiology/Nuclear Medicine;**26**;Mar 16, 1998
+2 ;
+3 IF $ORDER(RACCESS(DUZ,""))=""
DO SETVARS^RAPSET1(0)
SET RAPSTX=""
+4 ; RAFL flags Tech Rpt and Camera Rpt
SUM SET X="-----------------"
WRITE !!,RATITLE," Workload Report:",!,X,$EXTRACT(X,1,$LENGTH(RATITLE))
KILL RAFL1,^TMP($JOB)
ASKSUM ;
+1 WRITE !
KILL DIR
SET DIR(0)="Y"
SET DIR("A")="Do you wish only the summary report"
SET DIR("B")="NO"
SET DIR("?")="Enter YES for a summary report or NO for a detailed report"
+2 DO ^DIR
KILL DIR
IF $DATA(DIRUT)
DO Q^RAWKL2
QUIT
+3 IF RATITLE["Interpreting"
Begin DoDot:1
+4 SET RAPRIM=$$PRI($PIECE(RATITLE," ",2))
if RAPRIM=-1
DO Q^RAWKL2
+5 QUIT
End DoDot:1
if RAPRIM=-1
QUIT
+6 if Y=0
SET RAFL1=""
+7 KILL DIROUT,DIRUT,DTOUT,DUOUT
+8 SET X=$$DIVLOC^RAUTL7()
IF X
DO Q^RAWKL2
QUIT
+9 SET A=""
FOR
SET A=$ORDER(RACCESS(DUZ,"DIV-IMG",A))
if A']""
QUIT
Begin DoDot:1
+10 if '$DATA(^TMP($JOB,"RA D-TYPE",A))
QUIT
SET A1=$ORDER(^TMP($JOB,"RA D-TYPE",A,0))
+11 if A1'>0
QUIT
SET B=""
+12 FOR
SET B=$ORDER(RACCESS(DUZ,"DIV-IMG",A,B))
if B']""
QUIT
Begin DoDot:2
+13 IF $DATA(^TMP($JOB,"RA I-TYPE",B))
DO IT^RALWKL2
IF B1?3AP1"-".N
SET ^TMP($JOB,"RAWKL",A1,B1)=0
+14 QUIT
End DoDot:2
+15 QUIT
End DoDot:1
+16 KILL A,A1,B,B1,RACCESS(DUZ,"DIV-IMG")
+17 SET RAINPUT=$$ALLNOTH^RALWKL3()
IF RAINPUT=""
DO Q^RAWKL2
QUIT
+18 IF RAINPUT=0
DO RSPTR
IF RAQUIT=1
DO Q^RAWKL2
QUIT
+19 IF RAINPUT=0
SET RAFLDCNT=0
SET RALP=""
FOR
SET RALP=$ORDER(^TMP($JOB,"RAFLD",RALP))
if RALP=""
QUIT
SET RAFLDCNT=RAFLDCNT+1
+20 KILL RALP
+21 DO DATE^RAUTL
IF RAPOP
DO Q^RAWKL2
QUIT
+22 SET RAXIT=0
DO DISPXAM^RALWKL1(RACRT)
IF RAXIT
DO Q^RAWKL2
QUIT
+23 SET ZTDESC="Rad/Nuc Med "_RATITLE_" Workload Report"
SET ZTRTN="START^RAWKL"
SET ZTSAVE("RAFL*")=""
SET ZTSAVE("^TMP($J,""RAWKL"",")=""
SET ZTSAVE("^TMP($J,""RAFLD"",")=""
+24 FOR RASV="BEGDATE","ENDDATE","RAFILE","RAFLDCNT","RAPCE","RAPSTX","RATITLE","RACRT","RAINPUT","RAPRIM","RACMLIST"
SET ZTSAVE(RASV)=""
+25 WRITE !
DO ZIS^RAUTL
IF RAPOP
DO Q^RAWKL2
QUIT
START ; start processing
+1 USE IO
KILL ^TMP($JOB,"RA")
if $DATA(ZTQUEUED)
SET ZTREQ="@"
KILL RAEOS
+2 SET RABEG=BEGDATE-.0001
SET RAEND=ENDDATE+.9999
SET RA80DASH=$$REPEAT^XLFSTR("-",80)
+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 DO CRIT^RAUTL1
SET RACPT=""
+7 SET RAITCNT=0
SET RALP=""
+8 FOR
SET RALP=$ORDER(^TMP($JOB,"RAWKL",RALP))
if RALP=""
QUIT
SET RAITCNT(RALP)=0
SET ^TMP($JOB,"RA",RALP)="0^0^0"
SET RALP1=""
FOR
SET RALP1=$ORDER(^TMP($JOB,"RAWKL",RALP,RALP1))
if RALP1=""
QUIT
SET RAITCNT(RALP)=RAITCNT(RALP)+1
SET ^TMP($JOB,"RA",RALP,RALP1)="0^0^0"
+9 KILL RALP,RALP1
+10 FOR RADTE=RABEG:0:RAEND
SET RADTE=$ORDER(^RADPT("AR",RADTE))
if RADTE'>0!(RADTE>RAEND)!($DATA(RAEOS))
QUIT
SET RADTI=9999999.9999-RADTE
DO RADFN^RAWKL1
+11 if '$DATA(RAEOS)
GOTO ^RAWKL2
+12 QUIT
+13 ;
TECH SET RAFILE="VA(200,"
SET RACRT=7
SET RAPCE="TC"
SET RATITLE="Technologist"
SET RAFL=""
GOTO RAWKL
+1 ;
RES NEW RAPRIM
SET RAFILE="VA(200,"
SET RACRT=13
SET RAPCE=12
SET RATITLE="Interpreting Resident"
GOTO RAWKL
+1 ;
STAFF NEW RAPRIM
SET RAFILE="VA(200,"
SET RACRT=14
SET RAPCE=15
SET RATITLE="Interpreting Staff"
DO ASK1
IF $DATA(DIRUT)
DO Q^RAWKL2
QUIT
+1 GOTO RAWKL
+2 ;
PHY SET RAFILE="VA(200,"
SET RACRT=12
SET RAPCE=14
SET RATITLE="Requesting M.D."
GOTO RAWKL
+1 ;
ROOM SET RAFILE="RA(78.6,"
SET RACRT=11
SET RAPCE=18
SET RATITLE="Camera/Equip/Room"
SET RAFL=""
GOTO RAWKL
+1 ;
RSPTR ; select res/staff/phy/tech/room to include in workload rpts
+1 ; Creates ^TMP($J,"RAFLD",File 200 NAME)=""
+2 KILL ^TMP($JOB,"RAFLD")
+3 SET RACNT=0
+4 ; check for one res/staff/tech only
+5 IF RACRT=7!(RACRT=13)!(RACRT=14)
SET RASUBSPT=$SELECT(RACRT=7:"T",RACRT=13:"R",RACRT=14:"S",1:"")
SET RAONECHK=0
FOR
SET RAONECHK=$ORDER(^VA(200,"ARC",RASUBSPT,RAONECHK))
if RAONECHK=""!(RACNT>1)
QUIT
SET RACNT=RACNT+1
+6 IF RACNT=1
DO RST
DO KILL
QUIT
+7 ; check for one physician only
+8 IF RACRT=12
SET RAONECHK=0
FOR
SET RAONECHK=$ORDER(^XUSEC("PROVIDER",RAONECHK))
if RAONECHK=""!(RACNT>1)
QUIT
SET RACNT=RACNT+1
+9 IF RACNT=1
DO P
DO KILL
QUIT
+10 ; check for one camera room only
+11 IF RACRT=11
SET RAONECHK=$PIECE(^RA(78.6,0),U,4)
IF RAONECHK=1
SET RAIEN=$ORDER(^RA(78.6,0))
if RAIEN<1
QUIT
SET RAONENME=$PIECE(^RA(78.6,+RAIEN,0),U,1)_$PIECE(^RA(78.6,+RAIEN,0),U,2)
SET RAONENME=$EXTRACT(RAONENME,1,30)
SET ^TMP($JOB,"RAFLD",RAONENME)=""
DO KILL
QUIT
+12 IF RACRT=7!(RACRT=13)!(RACRT=14)!(RACRT=12)
SET RADIC="^VA(200,"
+13 IF RACRT=11
SET RADIC="^RA(78.6,"
+14 SET RADIC(0)="QEAMZ"
+15 SET RADIC("A")="Select "_RATITLE_": "
+16 IF RACRT=7
SET RADIC("S")="I $D(^VA(200,""ARC"",""T"",+Y))"
+17 IF RACRT=13
SET RADIC("S")="I $D(^VA(200,""ARC"",""R"",+Y))"
+18 IF RACRT=14
SET RADIC("S")="I $D(^VA(200,""ARC"",""S"",+Y))"
+19 IF RACRT=12
SET RADIC("S")="I $D(^XUSEC(""PROVIDER"",+Y))"
+20 SET RAUTIL="RAFLD"
+21 DO EN1^RASELCT(.RADIC,RAUTIL,"",RAINPUT)
KILL ;
+1 KILL %W,%Y1,DIC,RACNT,RADIC,RAIEN,RAONECHK,RAONENME,RASUBSPT,RAUTIL,X,Y
+2 QUIT
RST ; resident/staff/tech
+1 SET RAIEN=$ORDER(^VA(200,"ARC",RASUBSPT,0))
SET RAONENME=$PIECE(^VA(200,+RAIEN,0),U,1)
SET RAONENME=$EXTRACT(RAONENME,1,30)
SET ^TMP($JOB,"RAFLD",RAONENME)=""
+2 QUIT
P ; physicians
+1 SET RAIEN=$ORDER(^XUSEC("PROVIDER",0))
SET RAONENME=$PIECE(^VA(200,+RAIEN,0),U,1)
SET RAONENME=$EXTRACT(RAONENME,1,30)
SET ^TMP($JOB,"RAFLD",RAONENME)=""
+2 QUIT
PRI(RACLS) ; Ask user to include Pri. Res/Staff only in the
+1 ; 'Interpreting Res/Staff' report
+2 ; Input: RACLS-> 'Resident' or 'Staff'
+3 ; Returns: 1 if Pri. Staff only, 0 if Pri. & Sec. Staff included, and
+4 ; -1 if exiting without a report
+5 WRITE !
KILL DIR,DIROUT,DIRUT,DTOUT,DUOUT
NEW X,Y
+6 SET DIR(0)="Y"
SET DIR("A")="Count "_RACLS_" when entered as 'secondary'"_$SELECT(RACLS?1"S".E:" staff",1:" resident")_" interpreter"
SET DIR("B")="Yes"
+7 SET DIR("?",1)="Answer 'Yes' if both Primary and Secondary "_RACLS_" personnel will be included"
+8 SET DIR("?",2)="in this report. Answer 'No' if only Primary "_RACLS_" personnel will be"
+9 SET DIR("?")="included in this report. Input a '^' to exit without a report."
+10 DO ^DIR
if $DATA(DIRUT)
SET Y=-1
KILL DIR,DIROUT,DIRUT,DTOUT,DUOUT
+11 QUIT $SELECT(+Y=-1:-1,+Y:0,1:1)
ASK1 ; ask user if want to put CPT modifiers as separate line items
+1 KILL DIR
SET DIR(0)="Y"
SET DIR("B")="NO"
+2 SET DIR("A")="Do you want to count CPT Modifiers separately"
+3 SET DIR("?")="Enter YES to put different combinations of CPT modifiers onto separate lines"
+4 WRITE !
DO ^DIR
KILL DIR
+5 ;=1 means to list CPT mods as separate line items
if Y
SET RACMLIST=1
+6 QUIT
