BRARPT1 ; IHS/ADC/PDW - Radiology Exam Roster by Proc, Rad, Diag Code. ;
;;5.0;Radiology/Nuclear Medicine;;Feb 20, 2004
;
D ^XBKVAR K BRADIC
PROMPT ;
;S:'$D(IOF) IOF="!!" ;CMTD OUT IHS/ISD/EDE 04/01/97
;W @IOF,!?10 F I=1:1:62 W "-"
W !!,?10 F I=1:1:62 W "-" ; REPLACED W @IOF WITH W !!
W !?10,"| *** EXAM ROSTER BY RADIOLOGIST, PROCEDURE, DIAG CODE *** |"
W !?10 F I=1:1:62 W "-"
;
;---> GET DATE RANGE, RETURNS "RABEGDT" AND "RAENDDT".
D DATE^RAUTL G:RAPOP EXIT
S RABEGDT=BEGDATE,RAENDDT=ENDDATE
;
S BRAY=0
PROC ;---> SELECT PROCEDURES.
S BRADIR="procedure",BRADIC=71
S BRAVAR="RAPRC",BRAGBL="^RAMIS(71,"
D SELECT
G:'BRAY EXIT
;
RAD ;---> SELECT RADIOLOGISTS.
S BRADIR="radiologist",BRAVAR="RARAD",BRAGBL="^VA(200,"
S BRADIC=200,BRADIC("S")="I $D(^VA(200,""ARC"",""S"",Y))"
D SELECT K BRADIC("S")
G:'BRAY EXIT
;
DIAG ;---> SELECT DIAGNOSTIC CODES.
S BRADIR="diagnostic code",BRADIC=78.3
S BRAVAR="RADIAG",BRAGBL="^RA(78.3,"
D SELECT
G:'BRAY EXIT
;
TASKMAN ;---> TASKMAN STUFF.
S ZTRTN="START^BRARPT1"
F RASV="RABEGDT","RAENDDT","RAPRC(","RARAD(","RADIAG(" 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 ^BRARPT2
;
EXIT ;
K DIC,DIR,DIRUT,I,N,O,P,RAPOP,Q,R,RABEGDT,RACNI,RAD0,RADFN,RADIAG,RADTE
K RADTI,RAEND,RAENDDT,RAMES,RANAME,RAP0,RAPAGE,RAPRC,RARAD,RASV,BRADIC
K BRADIR,BRAGBL,BRAVAR,BRAY,^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)))
.;---> IF NOT ALL RADIOLOGISTS, THEN QUIT IF NOT ONE OF THE SELECTED.
.I '$D(RARAD("ALL")) Q:'$P(RAP0,U,15) Q:'$D(RARAD($P(RAP0,U,15)))
.;---> IF NOT ALL DIAG CODES, THEN QUIT IF NOT ONE OF THE SELECTED.
.I '$D(RADIAG("ALL")) Q:'$P(RAP0,U,13) Q:'$D(RADIAG($P(RAP0,U,13)))
.D SET
Q
SET ;
;---> GET DIVISION SUBSCRIPT.
S RADIV=$S($D(^RA(79,+$P(RAD0,"^",3),0)):+$P(RAD0,"^",3),1:9999)
;---> GET RADIOLOGIST SUBSCRIPT.
S RARAD="UNKNOWN"
I $P(RAP0,U,15)]"",$D(^VA(200,$P(RAP0,U,15),0)) S RARAD=$P(^(0),U)
S RARAD=$E(RARAD,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#^EXAM STATUS^DIAG CODE
S X=$P(RAP0,U)_U_$$HRCN^BDGF2(RADFN,DUZ("2"))_U_$P(^RA(72,$P(RAP0,U,3),0),U)
I $P(RAP0,U,13) S X=X_U_$P(^RA(78.3,$P(RAP0,U,13),0),U)
S ^TMP($J,"RA",RADIV,RARAD,RAPRC,RANAME,RADTE)=X
Q
;
;
SELECT ;EP---> SELECT PROCEDURE(S), RADIOLOGIST(S), DIAGNOSTIC CODE(S).
K @BRAVAR N DIC,DIR
W ! S DIR("A")="Include ALL "_BRADIR_"s in this report"
S DIR(0)="Y",DIR("B")="Y"
S DIR("?",1)="Answer ""YES"" to print exams for ALL "_BRADIR_"s;"
S DIR("?")="Answer ""NO"" to select one or more "_BRADIR_"s."
D ^DIR K DIR
I $D(DIRUT) S BRAY=0 Q
;---> IF ALL ARE SELECTED, QUIT HERE.
I Y S @(BRAVAR_"(""ALL"")")="",BRAY=1 Q
;
W !!,"Select the "_BRADIR_"(s) you wish to include in this report."
S DIC(0)="QEMA",DIC=BRADIC
S DIC("A")="Select "_BRADIR_": "
S:$D(BRADIC("S")) DIC("S")=BRADIC("S")
F D ^DIC Q:Y<0 S @(BRAVAR_"(+Y)")=""
I '$D(@BRAVAR) W !,"No ",BRADIR,"s selected.",! S BRAY=0 Q
W !!,"The following ",BRADIR,"s will be included in this report:"
W ! F I=1:1:48+$L(BRADIR) W "-"
S N=0 F S N=$O(@(BRAVAR_"(N)")) Q:'N D
.W !?5,$P(@(BRAGBL_"N,0)"),U)
.I BRAVAR="RAROOM" W " - ",$P(@(BRAGBL_"N,0)"),U,2)
W ! S DIR(0)="Y",DIR("A")="Is this correct",DIR("B")="Y"
D ^DIR I $D(DIRUT) S BRAY=0 Q
I 'Y K @BRAVAR D G SELECT
.W " All ",BRADIR,"s deleted. Please begin again."
S BRAY=1
Q
BRARPT1 ; IHS/ADC/PDW - Radiology Exam Roster by Proc, Rad, Diag Code. ;
+1 ;;5.0;Radiology/Nuclear Medicine;;Feb 20, 2004
+2 ;
+3 DO ^XBKVAR
KILL BRADIC
PROMPT ;
+1 ;S:'$D(IOF) IOF="!!" ;CMTD OUT IHS/ISD/EDE 04/01/97
+2 ;W @IOF,!?10 F I=1:1:62 W "-"
+3 ; REPLACED W @IOF WITH W !!
WRITE !!,?10
FOR I=1:1:62
WRITE "-"
+4 WRITE !?10,"| *** EXAM ROSTER BY RADIOLOGIST, PROCEDURE, DIAG CODE *** |"
+5 WRITE !?10
FOR I=1:1:62
WRITE "-"
+6 ;
+7 ;---> GET DATE RANGE, RETURNS "RABEGDT" AND "RAENDDT".
+8 DO DATE^RAUTL
IF RAPOP
GOTO EXIT
+9 SET RABEGDT=BEGDATE
SET RAENDDT=ENDDATE
+10 ;
+11 SET BRAY=0
PROC ;---> SELECT PROCEDURES.
+1 SET BRADIR="procedure"
SET BRADIC=71
+2 SET BRAVAR="RAPRC"
SET BRAGBL="^RAMIS(71,"
+3 DO SELECT
+4 IF 'BRAY
GOTO EXIT
+5 ;
RAD ;---> SELECT RADIOLOGISTS.
+1 SET BRADIR="radiologist"
SET BRAVAR="RARAD"
SET BRAGBL="^VA(200,"
+2 SET BRADIC=200
SET BRADIC("S")="I $D(^VA(200,""ARC"",""S"",Y))"
+3 DO SELECT
KILL BRADIC("S")
+4 IF 'BRAY
GOTO EXIT
+5 ;
DIAG ;---> SELECT DIAGNOSTIC CODES.
+1 SET BRADIR="diagnostic code"
SET BRADIC=78.3
+2 SET BRAVAR="RADIAG"
SET BRAGBL="^RA(78.3,"
+3 DO SELECT
+4 IF 'BRAY
GOTO EXIT
+5 ;
TASKMAN ;---> TASKMAN STUFF.
+1 SET ZTRTN="START^BRARPT1"
+2 FOR RASV="RABEGDT","RAENDDT","RAPRC(","RARAD(","RADIAG("
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 ^BRARPT2
+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,RAMES,RANAME,RAP0,RAPAGE,RAPRC,RARAD,RASV,BRADIC
+3 KILL BRADIR,BRAGBL,BRAVAR,BRAY,^TMP($JOB,"RA"),X,Y,ZTDESC,ZTRTN,ZTSAVE
+4 QUIT
+5 ;
+6 ;
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 ;---> IF NOT ALL RADIOLOGISTS, THEN QUIT IF NOT ONE OF THE SELECTED.
+8 IF '$DATA(RARAD("ALL"))
IF '$PIECE(RAP0,U,15)
QUIT
IF '$DATA(RARAD($PIECE(RAP0,U,15)))
QUIT
+9 ;---> IF NOT ALL DIAG CODES, THEN QUIT IF NOT ONE OF THE SELECTED.
+10 IF '$DATA(RADIAG("ALL"))
IF '$PIECE(RAP0,U,13)
QUIT
IF '$DATA(RADIAG($PIECE(RAP0,U,13)))
QUIT
+11 DO SET
End DoDot:1
+12 QUIT
SET ;
+1 ;---> GET DIVISION SUBSCRIPT.
+2 SET RADIV=$SELECT($DATA(^RA(79,+$PIECE(RAD0,"^",3),0)):+$PIECE(RAD0,"^",3),1:9999)
+3 ;---> GET RADIOLOGIST SUBSCRIPT.
+4 SET RARAD="UNKNOWN"
+5 IF $PIECE(RAP0,U,15)]""
IF $DATA(^VA(200,$PIECE(RAP0,U,15),0))
SET RARAD=$PIECE(^(0),U)
+6 SET RARAD=$EXTRACT(RARAD,1,30)
+7 ;---> GET PROCEDURE SUBSCRIPT.
+8 SET RAPRC=$EXTRACT($PIECE(^RAMIS(71,$PIECE(RAP0,U,2),0),U),1,29)
+9 ;---> GET PATIENT NAME SUBSCRIPT.
+10 SET RANAME=$PIECE(^DPT(RADFN,0),U)
+11 ;---> SET ^TMP(NODE=CASE#^CHART#^EXAM STATUS^DIAG CODE
+12 SET X=$PIECE(RAP0,U)_U_$$HRCN^BDGF2(RADFN,DUZ("2"))_U_$PIECE(^RA(72,$PIECE(RAP0,U,3),0),U)
+13 IF $PIECE(RAP0,U,13)
SET X=X_U_$PIECE(^RA(78.3,$PIECE(RAP0,U,13),0),U)
+14 SET ^TMP($JOB,"RA",RADIV,RARAD,RAPRC,RANAME,RADTE)=X
+15 QUIT
+16 ;
+17 ;
SELECT ;EP---> SELECT PROCEDURE(S), RADIOLOGIST(S), DIAGNOSTIC CODE(S).
+1 KILL @BRAVAR
NEW DIC,DIR
+2 WRITE !
SET DIR("A")="Include ALL "_BRADIR_"s in this report"
+3 SET DIR(0)="Y"
SET DIR("B")="Y"
+4 SET DIR("?",1)="Answer ""YES"" to print exams for ALL "_BRADIR_"s;"
+5 SET DIR("?")="Answer ""NO"" to select one or more "_BRADIR_"s."
+6 DO ^DIR
KILL DIR
+7 IF $DATA(DIRUT)
SET BRAY=0
QUIT
+8 ;---> IF ALL ARE SELECTED, QUIT HERE.
+9 IF Y
SET @(BRAVAR_"(""ALL"")")=""
SET BRAY=1
QUIT
+10 ;
+11 WRITE !!,"Select the "_BRADIR_"(s) you wish to include in this report."
+12 SET DIC(0)="QEMA"
SET DIC=BRADIC
+13 SET DIC("A")="Select "_BRADIR_": "
+14 IF $DATA(BRADIC("S"))
SET DIC("S")=BRADIC("S")
+15 FOR
DO ^DIC
IF Y<0
QUIT
SET @(BRAVAR_"(+Y)")=""
+16 IF '$DATA(@BRAVAR)
WRITE !,"No ",BRADIR,"s selected.",!
SET BRAY=0
QUIT
+17 WRITE !!,"The following ",BRADIR,"s will be included in this report:"
+18 WRITE !
FOR I=1:1:48+$LENGTH(BRADIR)
WRITE "-"
+19 SET N=0
FOR
SET N=$ORDER(@(BRAVAR_"(N)"))
IF 'N
QUIT
Begin DoDot:1
+20 WRITE !?5,$PIECE(@(BRAGBL_"N,0)"),U)
+21 IF BRAVAR="RAROOM"
WRITE " - ",$PIECE(@(BRAGBL_"N,0)"),U,2)
End DoDot:1
+22 WRITE !
SET DIR(0)="Y"
SET DIR("A")="Is this correct"
SET DIR("B")="Y"
+23 DO ^DIR
IF $DATA(DIRUT)
SET BRAY=0
QUIT
+24 IF 'Y
KILL @BRAVAR
Begin DoDot:1
+25 WRITE " All ",BRADIR,"s deleted. Please begin again."
End DoDot:1
GOTO SELECT
+26 SET BRAY=1
+27 QUIT
