BRARPT5 ; IHS/ADC/PDW - Radiology Exam Roster by Room, Procedure. ;
;;5.0;Radiology/Nuclear Medicine;;Feb 20, 2004
;
D ^XBKVAR K BRADIC
PROMPT ;
S:'$D(IOF) IOF="!!"
W @IOF,!?22 F I=1:1:33 W "-"
W !?22,"| *** EXAM ROSTER BY ROOM *** |"
W !?22 F I=1:1:33 W "-"
;
;---> GET DATE RANGE, RETURNS "RABEGDT" AND "RAENDDT".
D DATE^RAUTL G:RAPOP EXIT
S RABEGDT=BEGDATE,RAENDDT=ENDDATE
;
S BRAY=0
ROOM ;---> SELECT ROOMS.
S BRADIR="room",BRAVAR="RAROOM",BRAGBL="^RA(78.6,",BRADIC=78.6
D SELECT^BRARPT1
G:'BRAY EXIT
;
PROC ;---> SELECT PROCEDURES.
S BRADIR="procedure",BRADIC=71
S BRAVAR="RAPRC",BRAGBL="^RAMIS(71,"
D SELECT^BRARPT1
G:'BRAY EXIT
;
;
EXAMS ;---> PROMPT FOR DISPLAYING EACH EXAM.
W ! S DIR("A")="Do you wish to display each exam"
S DIR(0)="Y",DIR("B")="Y",RAEX=0
S X="Answer ""YES"" to display each individual exam under each"
S DIR("?",1)=X_" 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^BRARPT5"
F RASV="RABEGDT","RAENDDT","RAEX","RAPRC(","RAROOM(" 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 ^BRARPT6
;
EXIT ;
K DIC,DIR,DIRUT,I,N,O,P,RAPOP,Q,R,RABEGDT,RACNI,RAD0,RADFN,RADIAG,RADTE
K RADTI,RAEND,RAENDDT,RAEX,RAMES,RANAME,RAP0,RAPAGE,RAPRC,RARAD,RAROOM
K RASV,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 ROOMS, THEN QUIT IF NOT ONE OF THE SELECTED.
.Q:'$P(RAP0,U,18) I '$D(RAROOM("ALL")) Q:'$D(RAROOM($P(RAP0,U,18)))
.;---> IF NOT ALL PROCEDURES, THEN QUIT IF NOT ONE OF THE SELECTED.
.I '$D(RAPRC("ALL")) Q:'$P(RAP0,U,2) Q:'$D(RAPRC($P(RAP0,U,2)))
.;---> GET PRIMARY TECH. IF MORE THAN ONE, APPEND "(+)".
.S T=$O(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"TC",0)) Q:'T D
..S RATECH=$P(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"TC",T,0),U)
..I $O(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"TC",T)) S RATECH=RATECH_"(+)"
.D SET
Q
SET ;
;---> GET DIVISION SUBSCRIPT.
S RADIV=$S($D(^RA(79,+$P(RAD0,"^",3),0)):+$P(RAD0,"^",3),1:9999)
;---> GET ROOM SUBSCRIPT.
S RAROOM=$P(^RA(78.6,$P(RAP0,U,18),0),U)_" - "_$P(^(0),U,2)
;---> 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_RATECH
S ^TMP($J,"RA",RADIV,RAROOM,RAPRC,RANAME,RADTE)=X
Q
BRARPT5 ; IHS/ADC/PDW - Radiology Exam Roster by Room, Procedure. ;
+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,!?22
FOR I=1:1:33
WRITE "-"
+3 WRITE !?22,"| *** EXAM ROSTER BY ROOM *** |"
+4 WRITE !?22
FOR I=1:1:33
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
ROOM ;---> SELECT ROOMS.
+1 SET BRADIR="room"
SET BRAVAR="RAROOM"
SET BRAGBL="^RA(78.6,"
SET BRADIC=78.6
+2 DO SELECT^BRARPT1
+3 IF 'BRAY
GOTO EXIT
+4 ;
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 ;
EXAMS ;---> PROMPT FOR DISPLAYING EACH EXAM.
+1 WRITE !
SET DIR("A")="Do you wish to display each exam"
+2 SET DIR(0)="Y"
SET DIR("B")="Y"
SET RAEX=0
+3 SET X="Answer ""YES"" to display each individual exam under each"
+4 SET DIR("?",1)=X_" 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^BRARPT5"
+2 FOR RASV="RABEGDT","RAENDDT","RAEX","RAPRC(","RAROOM("
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 ^BRARPT6
+1 ;
EXIT ;
+1 KILL DIC,DIR,DIRUT,I,N,O,P,RAPOP,Q,R,RABEGDT,RACNI,RAD0,RADFN,RADIAG,RADTE
+2 KILL RADTI,RAEND,RAENDDT,RAEX,RAMES,RANAME,RAP0,RAPAGE,RAPRC,RARAD,RAROOM
+3 KILL RASV,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 ROOMS, THEN QUIT IF NOT ONE OF THE SELECTED.
+6 IF '$PIECE(RAP0,U,18)
QUIT
IF '$DATA(RAROOM("ALL"))
IF '$DATA(RAROOM($PIECE(RAP0,U,18)))
QUIT
+7 ;---> IF NOT ALL PROCEDURES, THEN QUIT IF NOT ONE OF THE SELECTED.
+8 IF '$DATA(RAPRC("ALL"))
IF '$PIECE(RAP0,U,2)
QUIT
IF '$DATA(RAPRC($PIECE(RAP0,U,2)))
QUIT
+9 ;---> GET PRIMARY TECH. IF MORE THAN ONE, APPEND "(+)".
+10 SET T=$ORDER(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"TC",0))
IF 'T
QUIT
Begin DoDot:2
+11 SET RATECH=$PIECE(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"TC",T,0),U)
+12 IF $ORDER(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"TC",T))
SET RATECH=RATECH_"(+)"
End DoDot:2
+13 DO SET
End DoDot:1
+14 QUIT
SET ;
+1 ;---> GET DIVISION SUBSCRIPT.
+2 SET RADIV=$SELECT($DATA(^RA(79,+$PIECE(RAD0,"^",3),0)):+$PIECE(RAD0,"^",3),1:9999)
+3 ;---> GET ROOM SUBSCRIPT.
+4 SET RAROOM=$PIECE(^RA(78.6,$PIECE(RAP0,U,18),0),U)_" - "_$PIECE(^(0),U,2)
+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 SET X=$PIECE(RAP0,U)_U_$$HRCN^BDGF2(RADFN,DUZ("2"))_U_RATECH
+11 SET ^TMP($JOB,"RA",RADIV,RAROOM,RAPRC,RANAME,RADTE)=X
+12 QUIT
