BRARPT3 ; IHS/ADC/PDW - Radiology Exam Roster by Technologist, Proc. ;
;;5.0;Radiology/Nuclear Medicine;;Feb 20, 2004
;
D ^XBKVAR K BRADIC
PROMPT ;
S:'$D(IOF) IOF="!!"
W @IOF,!?19 F I=1:1:40 W "-"
W !?19,"| *** FILM USAGE BY TECHNOLOGIST *** |"
W !?19 F I=1:1:40 W "-"
;
;---> GET DATE RANGE, RETURNS "RABEGDT" AND "RAENDDT".
D DATE^RAUTL G:RAPOP EXIT
S RABEGDT=BEGDATE,RAENDDT=ENDDATE
;
S BRAY=0
TECH ;---> SELECT TECHNOLOGISTS.
S BRADIR="technologist",BRAVAR="RATECH",BRAGBL="^VA(200,"
S BRADIC=200,BRADIC("S")="I $D(^VA(200,""ARC"",""T"",Y))"
D SELECT^BRARPT1 K BRADIC("S")
G:'BRAY EXIT
;
PROC ;---> SELECT PROCEDURES.
S BRADIR="procedure",BRADIC=71
S BRAVAR="RAPRC",BRAGBL="^RAMIS(71,"
D SELECT^BRARPT1
G:'BRAY EXIT
;
;
;G TASKMAN
EXAMS ;---> PROMPT FOR DISPLAYING EACH EXAM.
W ! S DIR("A")="Do you wish to display each exam and film size"
S DIR(0)="Y",DIR("B")="Y",RAEX=0
S DIR("?",1)="Answer ""YES"" to display each individual exam and"
S DIR("?",2)="film size under each Radiology Procedure."
S DIR("?")="Answer ""NO"" to display only procedures and their totals."
D ^DIR K DIR,X
I $D(DIRUT) G EXIT
I Y S RAEX=1 K Y
;
TASKMAN ;---> TASKMAN STUFF.
S ZTRTN="START^BRARPT3"
F RASV="RABEGDT","RAENDDT","RAEX","RAPRC(","RATECH(" D
.S ZTSAVE(RASV)=""
;
DEV ;---> GET DEVICE AND/OR QUEUE.
W ! D ZIS^RAUTL G:RAPOP EXIT
;
START ;---> TASKMAN STARTING POINT.
D SORT
;
PRINT D ^BRARPT4
;
EXIT ;
K DIC,DIR,DIRUT,I,K,L,N,O,P,RAPOP,Q,R,RABEGDT,RACNI,RAD0,RADFN,RADIAG
K RADTE,RADTI,RAEND,RAENDDT,RAEX,RAMES,RANAME,RAP0,RAPAGE,RAPRC,RARAD
K RASV,RATCH,RATECH,BRADIC,BRADIR,BRAGBL,BRAVAR,BRAY
K ^TMP($J,"RA"),X,Y,ZTDESC,ZTRTN,ZTSAVE
Q
;
;
SORT ;---> SORT EXAMS FOR SELECTED CRITERIA.
K ^TMP($J,"RA")
S RADTE=RABEGDT-.0001,RAEND=RAENDDT+.9999
F S RADTE=$O(^RADPT("AR",RADTE)) Q:RADTE'>0!(RADTE>RAEND) D
.S RADTI=9999999.9999-RADTE
.D RADFN
Q
;
RADFN S RADFN=0
F S RADFN=$O(^RADPT("AR",RADTE,RADFN)) Q:RADFN'>0 D
.Q:'$D(^RADPT(RADFN,"DT",RADTI,0))
.;---> RAD0=ZERO NODE OF VISIT.
.S RAD0=^RADPT(RADFN,"DT",RADTI,0)
.D RACNI
Q
;
RACNI S RACNI=0
F S RACNI=$O(^RADPT(RADFN,"DT",RADTI,"P",RACNI)) Q:RACNI'>0 D
.Q:'$D(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0))
.;---> RAP0=ZERO NODE OF EXAM.
.S RAP0=^RADPT(RADFN,"DT",RADTI,"P",RACNI,0)
.;---> IF NOT ALL PROCEDURES, THEN QUIT IF NOT ONE OF THE SELECTED.
.Q:'$P(RAP0,U,2) I '$D(RAPRC("ALL")) Q:'$D(RAPRC($P(RAP0,U,2)))
.;---> LOOP THROUGH TECHS.
.N F,T
.S T=0 F S T=$O(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"TC",T)) Q:'T D
..S RATECH=$P(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"TC",T,0),U)
..Q:'RATECH Q:('$D(RATECH(RATECH)))&('$D(RATECH("ALL")))
..;---> LOOP THROUGH FILM SIZES.
..S F=0 F S F=$O(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"F",F)) Q:'F D
...S RAFILM0=^RADPT(RADFN,"DT",RADTI,"P",RACNI,"F",F,0),RAFILM=+^(0)
...Q:'RAFILM
...D SET
Q
SET ;
;---> GET DIVISION SUBSCRIPT.
S RADIV=$S($D(^RA(79,+$P(RAD0,"^",3),0)):+$P(RAD0,"^",3),1:9999)
;---> GET TECHNOLOGIST SUBSCRIPT.
Q:'$D(^VA(200,RATECH,0)) S RATCH=$E($P(^(0),U),1,30)
;---> GET PROCEDURE SUBSCRIPT.
S RAPRC=$E($P(^RAMIS(71,$P(RAP0,U,2),0),U),1,29)
;---> GET PATIENT NAME SUBSCRIPT.
S RANAME=$P(^DPT(RADFN,0),U)
;---> SET ^TMP(NODE=CASE#^CHART#^FILM SIZE^TOTAL FILMS^RETAKES
;S X=$P(RAP0,U)_U_$$HRCN^BDGF2(RADFN,DUZ("2"))_U_RAFILM
S X=$P(RAP0,U)_U_$$HRCN^BDGF2(RADFN,DUZ("2"))_U_$P(RAFILM0,U,2)_U_$P(RAFILM0,U,9)
S ^TMP($J,"RA",RADIV,RATCH,RAPRC,RANAME,RADTE,RAFILM)=X
Q
BRARPT3 ; IHS/ADC/PDW - Radiology Exam Roster by Technologist, Proc. ;
+1 ;;5.0;Radiology/Nuclear Medicine;;Feb 20, 2004
+2 ;
+3 DO ^XBKVAR
KILL BRADIC
PROMPT ;
+1 IF '$DATA(IOF)
SET IOF="!!"
+2 WRITE @IOF,!?19
FOR I=1:1:40
WRITE "-"
+3 WRITE !?19,"| *** FILM USAGE BY TECHNOLOGIST *** |"
+4 WRITE !?19
FOR I=1:1:40
WRITE "-"
+5 ;
+6 ;---> GET DATE RANGE, RETURNS "RABEGDT" AND "RAENDDT".
+7 DO DATE^RAUTL
IF RAPOP
GOTO EXIT
+8 SET RABEGDT=BEGDATE
SET RAENDDT=ENDDATE
+9 ;
+10 SET BRAY=0
TECH ;---> SELECT TECHNOLOGISTS.
+1 SET BRADIR="technologist"
SET BRAVAR="RATECH"
SET BRAGBL="^VA(200,"
+2 SET BRADIC=200
SET BRADIC("S")="I $D(^VA(200,""ARC"",""T"",Y))"
+3 DO SELECT^BRARPT1
KILL BRADIC("S")
+4 IF 'BRAY
GOTO EXIT
+5 ;
PROC ;---> SELECT PROCEDURES.
+1 SET BRADIR="procedure"
SET BRADIC=71
+2 SET BRAVAR="RAPRC"
SET BRAGBL="^RAMIS(71,"
+3 DO SELECT^BRARPT1
+4 IF 'BRAY
GOTO EXIT
+5 ;
+6 ;
+7 ;G TASKMAN
EXAMS ;---> PROMPT FOR DISPLAYING EACH EXAM.
+1 WRITE !
SET DIR("A")="Do you wish to display each exam and film size"
+2 SET DIR(0)="Y"
SET DIR("B")="Y"
SET RAEX=0
+3 SET DIR("?",1)="Answer ""YES"" to display each individual exam and"
+4 SET DIR("?",2)="film size under each Radiology Procedure."
+5 SET DIR("?")="Answer ""NO"" to display only procedures and their totals."
+6 DO ^DIR
KILL DIR,X
+7 IF $DATA(DIRUT)
GOTO EXIT
+8 IF Y
SET RAEX=1
KILL Y
+9 ;
TASKMAN ;---> TASKMAN STUFF.
+1 SET ZTRTN="START^BRARPT3"
+2 FOR RASV="RABEGDT","RAENDDT","RAEX","RAPRC(","RATECH("
Begin DoDot:1
+3 SET ZTSAVE(RASV)=""
End DoDot:1
+4 ;
DEV ;---> GET DEVICE AND/OR QUEUE.
+1 WRITE !
DO ZIS^RAUTL
IF RAPOP
GOTO EXIT
+2 ;
START ;---> TASKMAN STARTING POINT.
+1 DO SORT
+2 ;
PRINT DO ^BRARPT4
+1 ;
EXIT ;
+1 KILL DIC,DIR,DIRUT,I,K,L,N,O,P,RAPOP,Q,R,RABEGDT,RACNI,RAD0,RADFN,RADIAG
+2 KILL RADTE,RADTI,RAEND,RAENDDT,RAEX,RAMES,RANAME,RAP0,RAPAGE,RAPRC,RARAD
+3 KILL RASV,RATCH,RATECH,BRADIC,BRADIR,BRAGBL,BRAVAR,BRAY
+4 KILL ^TMP($JOB,"RA"),X,Y,ZTDESC,ZTRTN,ZTSAVE
+5 QUIT
+6 ;
+7 ;
SORT ;---> SORT EXAMS FOR SELECTED CRITERIA.
+1 KILL ^TMP($JOB,"RA")
+2 SET RADTE=RABEGDT-.0001
SET RAEND=RAENDDT+.9999
+3 FOR
SET RADTE=$ORDER(^RADPT("AR",RADTE))
IF RADTE'>0!(RADTE>RAEND)
QUIT
Begin DoDot:1
+4 SET RADTI=9999999.9999-RADTE
+5 DO RADFN
End DoDot:1
+6 QUIT
+7 ;
RADFN SET RADFN=0
+1 FOR
SET RADFN=$ORDER(^RADPT("AR",RADTE,RADFN))
IF RADFN'>0
QUIT
Begin DoDot:1
+2 IF '$DATA(^RADPT(RADFN,"DT",RADTI,0))
QUIT
+3 ;---> RAD0=ZERO NODE OF VISIT.
+4 SET RAD0=^RADPT(RADFN,"DT",RADTI,0)
+5 DO RACNI
End DoDot:1
+6 QUIT
+7 ;
RACNI SET RACNI=0
+1 FOR
SET RACNI=$ORDER(^RADPT(RADFN,"DT",RADTI,"P",RACNI))
IF RACNI'>0
QUIT
Begin DoDot:1
+2 IF '$DATA(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0))
QUIT
+3 ;---> RAP0=ZERO NODE OF EXAM.
+4 SET RAP0=^RADPT(RADFN,"DT",RADTI,"P",RACNI,0)
+5 ;---> IF NOT ALL PROCEDURES, THEN QUIT IF NOT ONE OF THE SELECTED.
+6 IF '$PIECE(RAP0,U,2)
QUIT
IF '$DATA(RAPRC("ALL"))
IF '$DATA(RAPRC($PIECE(RAP0,U,2)))
QUIT
+7 ;---> LOOP THROUGH TECHS.
+8 NEW F,T
+9 SET T=0
FOR
SET T=$ORDER(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"TC",T))
IF 'T
QUIT
Begin DoDot:2
+10 SET RATECH=$PIECE(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"TC",T,0),U)
+11 IF 'RATECH
QUIT
IF ('$DATA(RATECH(RATECH)))&('$DATA(RATECH("ALL")))
QUIT
+12 ;---> LOOP THROUGH FILM SIZES.
+13 SET F=0
FOR
SET F=$ORDER(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"F",F))
IF 'F
QUIT
Begin DoDot:3
+14 SET RAFILM0=^RADPT(RADFN,"DT",RADTI,"P",RACNI,"F",F,0)
SET RAFILM=+^(0)
+15 IF 'RAFILM
QUIT
+16 DO SET
End DoDot:3
End DoDot:2
End DoDot:1
+17 QUIT
SET ;
+1 ;---> GET DIVISION SUBSCRIPT.
+2 SET RADIV=$SELECT($DATA(^RA(79,+$PIECE(RAD0,"^",3),0)):+$PIECE(RAD0,"^",3),1:9999)
+3 ;---> GET TECHNOLOGIST SUBSCRIPT.
+4 IF '$DATA(^VA(200,RATECH,0))
QUIT
SET RATCH=$EXTRACT($PIECE(^(0),U),1,30)
+5 ;---> GET PROCEDURE SUBSCRIPT.
+6 SET RAPRC=$EXTRACT($PIECE(^RAMIS(71,$PIECE(RAP0,U,2),0),U),1,29)
+7 ;---> GET PATIENT NAME SUBSCRIPT.
+8 SET RANAME=$PIECE(^DPT(RADFN,0),U)
+9 ;---> SET ^TMP(NODE=CASE#^CHART#^FILM SIZE^TOTAL FILMS^RETAKES
+10 ;S X=$P(RAP0,U)_U_$$HRCN^BDGF2(RADFN,DUZ("2"))_U_RAFILM
+11 SET X=$PIECE(RAP0,U)_U_$$HRCN^BDGF2(RADFN,DUZ("2"))_U_$PIECE(RAFILM0,U,2)_U_$PIECE(RAFILM0,U,9)
+12 SET ^TMP($JOB,"RA",RADIV,RATCH,RAPRC,RANAME,RADTE,RAFILM)=X
+13 QUIT
