- 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
- 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
