RAPROS ;HISC/GJC AISC/MJK,RMO-Exam Profile (sort) ;6/19/97 09:12
;;5.0;Radiology/Nuclear Medicine;**47**;Mar 16, 1998;Build 21
PAT S DIC(0)="AQEM" D ^RADPA K DIC G Q:Y<0 S RADFN=+Y G Q:'$D(^DPT(RADFN,0)) S RANME=^(0),RASSN=$$SSN^RAUTL,RANME=$P(RANME,"^")
SORT R !!,"Sort by one of the following:",!?10,"P ==> Procedure",!?10,"D ==> Date of Exam",!?30,"Procedure// ",RAXX:DTIME
G Q:'$T!(RAXX["^") S RAXX=$E(RAXX) S:RAXX="" RAXX="P" G SORT:RAXX="?" S RAXX=$$UP^XLFSTR(RAXX) I "PD"'[RAXX W *7," ??" G SORT
I RAXX="D" S RASORT="RADTI" D DATE^RAUTL G Q:RAPOP S BEG=9999999-ENDDATE,END=9999999.9999-BEGDATE G ZIS
ASKSRT S RASORT="RAPRI"
W ! K DIR S DIR(0)="YA",DIR("B")="Yes"
S DIR("?")="Enter 'Y' to select a specific procedure, or 'No' not to."
S DIR("A")="Do you wish to look for a specific procedure? "
D ^DIR K DIR G:$D(DIRUT) Q
S:'+Y BEG=0,END=999999 D:+Y PROC G:+Y=-1 Q
ZIS ; Device selection
W ! S RAPRT=1,ZTRTN="START^RAPROS" F RASV="RANME","RASSN","BEG","END","RADFN","RASORT","RAPRT","^TMP($J,""RA I-TYPE"",","RAXX" S ZTSAVE(RASV)=""
S ZTDESC="Rad/Nuc Med Exam Profile" D ZIS^RAUTL G Q:RAPOP
S:IO=IO(0) RAPRT=0
START S RAX="" K ^TMP($J,"RASORT"),^("RASEQ") S (RAPAG,RASEQ)=0
F RADTI=0:0 S RADTI=$O(^RADPT(RADFN,"DT",RADTI)) Q:RADTI'>0 D
. I $D(^RADPT(RADFN,"DT",RADTI,0)) S RAZERO=$G(^(0)) D
.. S RAELOC=$P($G(^SC(+$P($G(^RA(79.1,+$P($G(^RADPT(RADFN,"DT",RADTI,0)),U,4),0)),U),0)),U)
.. S RADTPRT=+$P(RAZERO,U),RADTPRT=$E(RADTPRT,4,5)_"/"_$E(RADTPRT,6,7)_"/"_$E(RADTPRT,2,3)
.. S (RADTE,Y)=+$P(RAZERO,"^") D D^RAUTL S RADATE=Y
.. D RACN
.. Q
. Q
I '$D(^TMP($J,"RASORT")) W !!?5,"For the above criteria, no registered exams filed for patient...",!?30,"...",RANME," ",RASSN,".",! G Q1
U IO D PRT D CLOSE^RAUTL I RAX'=""!(RAPRT) D Q G ST2
ST1 W !,"CHOOSE FROM 1-",RASEQ,": " R RAX:DTIME I RAX["?" D HLP G ST1
I RAX,'$D(^TMP($J,"RASEQ",RAX)) W !,*7,"You may only select one exam at a time. Choose a number between 1 and ",RASEQ,"." G ST1
ST2 G Q1:'RAX S Y=^TMP($J,"RASEQ",RAX) F I=1:1:11 S @$P("RACN^RAPRC^RADATE^RAST^RADFN^RADTI^RACNI^RANME^RASSN^RADTE^RARPT","^",I)=$P(Y,"^",I)
S Y(0)=^RADPT(RADFN,"DT",RADTI,"P",RACNI,0) D ^RAPROD D Q1 G PAT
Q1 K RAX,^TMP($J,"RASORT"),^("RASEQ")
Q ; Kill and quit
K %,%W,%Y,%Y1,BEG,BEGDATE,C,DIROUT,DIRUT,DTOUT,DUOUT,END,ENDDATE,POP
K RAPOP,RAA,RACN,RACNI,RADATE,RADFN,RADTE,RADTI,RAI,RAII,RANME,RASSN
K RAPRC,RAPRT,RARPT,RASEQ,RASORT,RAST,RAPAG,RAZERO,RAXX,RAY,RAPRI,RASV
K RADTPRT,RAELOC,X,Y,ZTDESC,ZTRTN,ZTSAVE
K RAXIT,RAMES
Q
RACN ; Get the case numbers.
F RACNI=0:0 S RACNI=$O(^RADPT(RADFN,"DT",RADTI,"P",RACNI)) Q:RACNI'>0 I $D(^(RACNI,0)) S Y=^(0) D STORE
Q
STORE ; Store data in the ^TMP global
S RAPRI=+$P(Y,"^",2),RAPRC=99 S:$D(^RAMIS(71,RAPRI,0)) RAPRC=$P(^(0),"^")
S RAST=+$P(Y,"^",3),RACN=+Y,RARPT=+$P(Y,"^",17)
I @RASORT>BEG,@RASORT<END F RAI=1:1 I '$D(^TMP($J,"RASORT",$S(RAXX="P":RAPRC,1:@RASORT),RAI)) S ^(RAI)=RACN_"^"_RAPRC_"^"_RADATE_"^"_RAST_"^"_RADFN_"^"_RADTI_"^"_RACNI_"^"_RANME_"^"_RASSN_"^"_RADTE_"^"_RARPT_"^"_RADTPRT_"^"_RAELOC Q
Q
PRT ; Begin output
S RAA="" D HD F RAI=0:0 Q:RAX["^"!(RAX>0) S RAA=$O(^TMP($J,"RASORT",RAA)) Q:RAA="" F RAII=0:0 S RAII=$O(^TMP($J,"RASORT",RAA,RAII)) Q:RAII'>0 S RAY=^(RAII) D PRT1 Q:RAX="^"!(RAX>0)
Q
PRT1 G PRT2:RAPRT!(RASEQ#15)!('RASEQ) I '(RASEQ#15) W !,"Type '^' to STOP, or",!,"CHOOSE FROM 1-",RASEQ,": " R RAX:DTIME G PRT3:RAX="" Q:RAX["^" I RAX["?" D HLP G PRT1
I '$D(^TMP($J,"RASEQ",RAX)) W !,*7,"You may only select one exam at a time. Choose a number between 1 and ",RASEQ,"." G PRT1
S RAX=+RAX Q
PRT2 I ($Y+4)>IOSL,RAPRT D HD
PRT3 S RASEQ=RASEQ+1,^TMP($J,"RASEQ",RASEQ)=RAY
N RADFN,RADTI,RACNI
S RADFN=$P(RAY,"^",5),RADTI=$P(RAY,"^",6),RACNI=$P(RAY,"^",7)
N RAPRTSET,RAMEMLOW D EN1^RAUTL20
N RASSAN,RACNDSP S RASSAN=$$SSANVAL^RAHLRU1(RADFN,RADTI,RACNI)
S RACNDSP=$S((RASSAN'=""):RASSAN,1:$P(RAY,"^"))
I $$USESSAN^RAHLRU1() D
.W !,RASEQ W:RASORT="RADTI" ?4,$S(RAMEMLOW:"+",RAPRTSET:".",1:" ")
.W ?5,RACNDSP,?10,$$IMGDISP^RAPTLU(+$P(RAY,"^",11))
.W ?22,$E($P(RAY,"^",2),1,26),?49,$P(RAY,U,12)
.W ?58,$S($D(^RA(72,$P(RAY,"^",4),0)):$E($P(^(0),"^"),1,11),1:"Unknown")
.W ?70,$E($P(RAY,U,13),1,10)
I '$$USESSAN^RAHLRU1() D
.W !,RASEQ W:RASORT="RADTI" ?5,$S(RAMEMLOW:"+",RAPRTSET:".",1:" ")
.W ?6,$P(RAY,"^"),?11,$$IMGDISP^RAPTLU(+$P(RAY,"^",11))
.W ?13,$E($P(RAY,"^",2),1,26),?41,$P(RAY,U,12)
.W ?52,$S($D(^RA(72,$P(RAY,"^",4),0)):$E($P(^(0),"^"),1,16),1:"Unknown")
.W ?69,$E($P(RAY,U,13),1,11)
Q
HD ; Generic header output
W:$E(IOST,1,2)="C-"!(RAPAG) @IOF
W "Profile for ",RANME," ",RASSN,?55,"Run Date: " S Y=DT D DT^DIO2 W !!,?20,"***** Registered Exams Profile *****"
I $$USESSAN^RAHLRU1() W !?4,"Case No.",?22,"Procedure",?49,"Exam Dt",?58,"Exam Status",?70,"Img Loc",!?4,"-----------------",?22,"-------------",?49,"--------",?58,"-----------",?70,"----------" Q
I '$$USESSAN^RAHLRU1() W !?3,"Case No.",?13,"Procedure",?41,"Exam Date",?52,"Status of Exam",?69,"Imaging Loc",!?3,"--------",?13,"-------------",?41,"---------",?52,"------------",?69,"-----------" Q
HLP ; Generic help
W !!?3,"Enter the number corresponding to the exam you wish to select.",!
Q
PROC ; Select Procedure
N %,%Y,C,DA,DDH,DIC,X
S DIC="^RAMIS(71,",DIC(0)="QEAMZ",DIC("A")="Select Procedure: "
W !! D ^DIC
S:+Y>0 BEG=Y-1,END=Y+1
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRAPROS 5383 printed Apr 09, 2024@21:39:16 Page 2
RAPROS ;HISC/GJC AISC/MJK,RMO-Exam Profile (sort) ;6/19/97 09:12
+1 ;;5.0;Radiology/Nuclear Medicine;**47**;Mar 16, 1998;Build 21
PAT SET DIC(0)="AQEM"
DO ^RADPA
KILL DIC
if Y<0
GOTO Q
SET RADFN=+Y
if '$DATA(^DPT(RADFN,0))
GOTO Q
SET RANME=^(0)
SET RASSN=$$SSN^RAUTL
SET RANME=$PIECE(RANME,"^")
SORT READ !!,"Sort by one of the following:",!?10,"P ==> Procedure",!?10,"D ==> Date of Exam",!?30,"Procedure// ",RAXX:DTIME
+1 if '$TEST!(RAXX["^")
GOTO Q
SET RAXX=$EXTRACT(RAXX)
if RAXX=""
SET RAXX="P"
if RAXX="?"
GOTO SORT
SET RAXX=$$UP^XLFSTR(RAXX)
IF "PD"'[RAXX
WRITE *7," ??"
GOTO SORT
+2 IF RAXX="D"
SET RASORT="RADTI"
DO DATE^RAUTL
if RAPOP
GOTO Q
SET BEG=9999999-ENDDATE
SET END=9999999.9999-BEGDATE
GOTO ZIS
ASKSRT SET RASORT="RAPRI"
+1 WRITE !
KILL DIR
SET DIR(0)="YA"
SET DIR("B")="Yes"
+2 SET DIR("?")="Enter 'Y' to select a specific procedure, or 'No' not to."
+3 SET DIR("A")="Do you wish to look for a specific procedure? "
+4 DO ^DIR
KILL DIR
if $DATA(DIRUT)
GOTO Q
+5 if '+Y
SET BEG=0
SET END=999999
if +Y
DO PROC
if +Y=-1
GOTO Q
ZIS ; Device selection
+1 WRITE !
SET RAPRT=1
SET ZTRTN="START^RAPROS"
FOR RASV="RANME","RASSN","BEG","END","RADFN","RASORT","RAPRT","^TMP($J,""RA I-TYPE"",","RAXX"
SET ZTSAVE(RASV)=""
+2 SET ZTDESC="Rad/Nuc Med Exam Profile"
DO ZIS^RAUTL
if RAPOP
GOTO Q
+3 if IO=IO(0)
SET RAPRT=0
START SET RAX=""
KILL ^TMP($JOB,"RASORT"),^("RASEQ")
SET (RAPAG,RASEQ)=0
+1 FOR RADTI=0:0
SET RADTI=$ORDER(^RADPT(RADFN,"DT",RADTI))
if RADTI'>0
QUIT
Begin DoDot:1
+2 IF $DATA(^RADPT(RADFN,"DT",RADTI,0))
SET RAZERO=$GET(^(0))
Begin DoDot:2
+3 SET RAELOC=$PIECE($GET(^SC(+$PIECE($GET(^RA(79.1,+$PIECE($GET(^RADPT(RADFN,"DT",RADTI,0)),U,4),0)),U),0)),U)
+4 SET RADTPRT=+$PIECE(RAZERO,U)
SET RADTPRT=$EXTRACT(RADTPRT,4,5)_"/"_$EXTRACT(RADTPRT,6,7)_"/"_$EXTRACT(RADTPRT,2,3)
+5 SET (RADTE,Y)=+$PIECE(RAZERO,"^")
DO D^RAUTL
SET RADATE=Y
+6 DO RACN
+7 QUIT
End DoDot:2
+8 QUIT
End DoDot:1
+9 IF '$DATA(^TMP($JOB,"RASORT"))
WRITE !!?5,"For the above criteria, no registered exams filed for patient...",!?30,"...",RANME," ",RASSN,".",!
GOTO Q1
+10 USE IO
DO PRT
DO CLOSE^RAUTL
IF RAX'=""!(RAPRT)
DO Q
GOTO ST2
ST1 WRITE !,"CHOOSE FROM 1-",RASEQ,": "
READ RAX:DTIME
IF RAX["?"
DO HLP
GOTO ST1
+1 IF RAX
IF '$DATA(^TMP($JOB,"RASEQ",RAX))
WRITE !,*7,"You may only select one exam at a time. Choose a number between 1 and ",RASEQ,"."
GOTO ST1
ST2 if 'RAX
GOTO Q1
SET Y=^TMP($JOB,"RASEQ",RAX)
FOR I=1:1:11
SET @$PIECE("RACN^RAPRC^RADATE^RAST^RADFN^RADTI^RACNI^RANME^RASSN^RADTE^RARPT","^",I)=$PIECE(Y,"^",I)
+1 SET Y(0)=^RADPT(RADFN,"DT",RADTI,"P",RACNI,0)
DO ^RAPROD
DO Q1
GOTO PAT
Q1 KILL RAX,^TMP($JOB,"RASORT"),^("RASEQ")
Q ; Kill and quit
+1 KILL %,%W,%Y,%Y1,BEG,BEGDATE,C,DIROUT,DIRUT,DTOUT,DUOUT,END,ENDDATE,POP
+2 KILL RAPOP,RAA,RACN,RACNI,RADATE,RADFN,RADTE,RADTI,RAI,RAII,RANME,RASSN
+3 KILL RAPRC,RAPRT,RARPT,RASEQ,RASORT,RAST,RAPAG,RAZERO,RAXX,RAY,RAPRI,RASV
+4 KILL RADTPRT,RAELOC,X,Y,ZTDESC,ZTRTN,ZTSAVE
+5 KILL RAXIT,RAMES
+6 QUIT
RACN ; Get the case numbers.
+1 FOR RACNI=0:0
SET RACNI=$ORDER(^RADPT(RADFN,"DT",RADTI,"P",RACNI))
if RACNI'>0
QUIT
IF $DATA(^(RACNI,0))
SET Y=^(0)
DO STORE
+2 QUIT
STORE ; Store data in the ^TMP global
+1 SET RAPRI=+$PIECE(Y,"^",2)
SET RAPRC=99
if $DATA(^RAMIS(71,RAPRI,0))
SET RAPRC=$PIECE(^(0),"^")
+2 SET RAST=+$PIECE(Y,"^",3)
SET RACN=+Y
SET RARPT=+$PIECE(Y,"^",17)
+3 IF @RASORT>BEG
IF @RASORT<END
FOR RAI=1:1
IF '$DATA(^TMP($JOB,"RASORT",$SELECT(RAXX="P":RAPRC,1:@RASORT),RAI))
SET ^(RAI)=RACN_"^"_RAPRC_"^"_RADATE_"^"_RAST_"^"_RADFN_"^"_RADTI_"^"_RACNI_"^"_RANME_"^"_RASSN_"^"_RADTE_"^"_RARPT_"^"_RADTPRT_"^"_RAELOC
QUIT
+4 QUIT
PRT ; Begin output
+1 SET RAA=""
DO HD
FOR RAI=0:0
if RAX["^"!(RAX>0)
QUIT
SET RAA=$ORDER(^TMP($JOB,"RASORT",RAA))
if RAA=""
QUIT
FOR RAII=0:0
SET RAII=$ORDER(^TMP($JOB,"RASORT",RAA,RAII))
if RAII'>0
QUIT
SET RAY=^(RAII)
DO PRT1
if RAX="^"!(RAX>0)
QUIT
+2 QUIT
PRT1 if RAPRT!(RASEQ#15)!('RASEQ)
GOTO PRT2
IF '(RASEQ#15)
WRITE !,"Type '^' to STOP, or",!,"CHOOSE FROM 1-",RASEQ,": "
READ RAX:DTIME
if RAX=""
GOTO PRT3
if RAX["^"
QUIT
IF RAX["?"
DO HLP
GOTO PRT1
+1 IF '$DATA(^TMP($JOB,"RASEQ",RAX))
WRITE !,*7,"You may only select one exam at a time. Choose a number between 1 and ",RASEQ,"."
GOTO PRT1
+2 SET RAX=+RAX
QUIT
PRT2 IF ($Y+4)>IOSL
IF RAPRT
DO HD
PRT3 SET RASEQ=RASEQ+1
SET ^TMP($JOB,"RASEQ",RASEQ)=RAY
+1 NEW RADFN,RADTI,RACNI
+2 SET RADFN=$PIECE(RAY,"^",5)
SET RADTI=$PIECE(RAY,"^",6)
SET RACNI=$PIECE(RAY,"^",7)
+3 NEW RAPRTSET,RAMEMLOW
DO EN1^RAUTL20
+4 NEW RASSAN,RACNDSP
SET RASSAN=$$SSANVAL^RAHLRU1(RADFN,RADTI,RACNI)
+5 SET RACNDSP=$SELECT((RASSAN'=""):RASSAN,1:$PIECE(RAY,"^"))
+6 IF $$USESSAN^RAHLRU1()
Begin DoDot:1
+7 WRITE !,RASEQ
if RASORT="RADTI"
WRITE ?4,$SELECT(RAMEMLOW:"+",RAPRTSET:".",1:" ")
+8 WRITE ?5,RACNDSP,?10,$$IMGDISP^RAPTLU(+$PIECE(RAY,"^",11))
+9 WRITE ?22,$EXTRACT($PIECE(RAY,"^",2),1,26),?49,$PIECE(RAY,U,12)
+10 WRITE ?58,$SELECT($DATA(^RA(72,$PIECE(RAY,"^",4),0)):$EXTRACT($PIECE(^(0),"^"),1,11),1:"Unknown")
+11 WRITE ?70,$EXTRACT($PIECE(RAY,U,13),1,10)
End DoDot:1
+12 IF '$$USESSAN^RAHLRU1()
Begin DoDot:1
+13 WRITE !,RASEQ
if RASORT="RADTI"
WRITE ?5,$SELECT(RAMEMLOW:"+",RAPRTSET:".",1:" ")
+14 WRITE ?6,$PIECE(RAY,"^"),?11,$$IMGDISP^RAPTLU(+$PIECE(RAY,"^",11))
+15 WRITE ?13,$EXTRACT($PIECE(RAY,"^",2),1,26),?41,$PIECE(RAY,U,12)
+16 WRITE ?52,$SELECT($DATA(^RA(72,$PIECE(RAY,"^",4),0)):$EXTRACT($PIECE(^(0),"^"),1,16),1:"Unknown")
+17 WRITE ?69,$EXTRACT($PIECE(RAY,U,13),1,11)
End DoDot:1
+18 QUIT
HD ; Generic header output
+1 if $EXTRACT(IOST,1,2)="C-"!(RAPAG)
WRITE @IOF
+2 WRITE "Profile for ",RANME," ",RASSN,?55,"Run Date: "
SET Y=DT
DO DT^DIO2
WRITE !!,?20,"***** Registered Exams Profile *****"
+3 IF $$USESSAN^RAHLRU1()
WRITE !?4,"Case No.",?22,"Procedure",?49,"Exam Dt",?58,"Exam Status",?70,"Img Loc",!?4,"-----------------",?22,"-------------",?49,"--------",?58,"-----------",?70,"----------"
QUIT
+4 IF '$$USESSAN^RAHLRU1()
WRITE !?3,"Case No.",?13,"Procedure",?41,"Exam Date",?52,"Status of Exam",?69,"Imaging Loc",!?3,"--------",?13,"-------------",?41,"---------",?52,"------------",?69,"-----------"
QUIT
HLP ; Generic help
+1 WRITE !!?3,"Enter the number corresponding to the exam you wish to select.",!
+2 QUIT
PROC ; Select Procedure
+1 NEW %,%Y,C,DA,DDH,DIC,X
+2 SET DIC="^RAMIS(71,"
SET DIC(0)="QEAMZ"
SET DIC("A")="Select Procedure: "
+3 WRITE !!
DO ^DIC
+4 if +Y>0
SET BEG=Y-1
SET END=Y+1
+5 QUIT
