RAESO ;HISC/CAH,GJC AISC/SAW-Override Exam Status to Complete ;4/28/97 08:00 [ 12/05/2011 10:27 AM ]
;;5.0;Radiology/Nuclear Medicine;**47,1004**;Mar 16, 1998;Build 21
;Mass override exam status to complete
D SET^RAPSET1 I $D(XQUIT) K XQUIT,POP Q
N RAXIT,RASAVDR S RAXIT=0 D CZECH Q:RAXIT
W !,"Your sign-on imaging type is ",RAIMGTY,", so only exams",!,"of imaging type ",RAIMGTY," will be changed to complete.",!
K DIR S DIR(0)="Y",DIR("A")="Are you sure you want to proceed" D ^DIR I Y'=1 G EXIT
K DIR,X,Y
ASK K DIC S DIC(0)="AEQM",DIC="^RA(72,"
;
;IHS/CMI/DAY - Patch 1004 - Don't allow override to complete from waiting for exam
;Patch 1004 - Continue Chris Saddler Patch from 2004
;S DIC("S")="I $P(^(0),U,3)'=9,($P(^(0),U,3)'=0),($P(^(0),U,7)=+$O(^RA(79.2,""B"",RAIMGTY,0)))"
S DIC("S")="I $P(^(0),U,3)'=9,($P(^(0),U,3)'=1),($P(^(0),U,3)'=0),($P(^(0),U,7)=+$O(^RA(79.2,""B"",RAIMGTY,0)))"
;End Patch
;
D ^DIC G EXIT:$D(DUOUT)!($D(DTOUT)) I Y'<0 S RASTIEN(+Y)="" G ASK
G EXIT:'$D(RASTIEN) K DIC W !!,"Enter a cutoff date that is at least sixty days prior to today."
;
;IHS/CMI/DAY - Patch 1004 - Allow Override without 60 day cutoff
;Patch 1004 - Continue Chris Saddler Patch from 2004
;S X1=DT,X2=-60 D C^%DTC S DIR(0)="D^:"_X D ^DIR G EXIT:$D(DIRUT) S RAECDTI=9999999-Y D DD^%DT S RAECDTE=Y
S X1=DT,X2=-0 D C^%DTC S DIR(0)="D^:"_X D ^DIR G EXIT:$D(DIRUT) S RAECDTI=9999999-Y D DD^%DT S RAECDTE=Y
;End Patch
;
;Following line commented out for v 4.5 - setting the 10th piece to 0 was preventing update of subfld 75, Exam Status Times. These are now updated.
W ! S IOP="Q",ZTRTN="DQ^RAESO"
S ZTSAVE("RAI*")="",ZTSAVE("RAM*")="",ZTSAVE("RAE*")=""
S ZTSAVE("RASTIEN(")=""
S ZTDESC="Rad/Nuc Med Mass Override of Exam Status to Complete",RAMES="W !,?5,""Output Queued.""",RAZIS=1 D ZIS^RAUTL K IOP
G EXIT
DQ U IO S PG=0 S RAIMGTYI=$O(^RA(79.2,"B",RAIMGTY,0))
F RAST=0:0 S RAST=$O(RASTIEN(RAST)) Q:RAST'>0 F RADFN=0:0 S RADFN=$O(^RADPT("AS",RAST,RADFN)) Q:RADFN'>0 F RADTI=RAECDTI:0 S RADTI=$O(^RADPT("AS",RAST,RADFN,RADTI)) Q:RADTI'>0 D L1
I '$D(RAF4) D HD W !!,"There were no exams with the statuses selected in the time frame specified that",!,"needed to be overridden to complete."
EXIT D CLOSE^RAUTL
K DA,DIC,DIE,DIR,DIRUT,DIROUT,DUOUT,DTOUT,DR,PG,POP
K RA,RACN,RACNI,RADFN,RADTE,RADTI,RAECDTE,RAECDTI,RAF1,RAF4,RAIMGTYI,RAMES,RAPOP,RAST,RASTIEN,RAZMDV,RAZIS
K X,X1,X2,XQUIT,Y,ZTDESC,ZTRTN,ZTSAVE,I,POP,DISYS,C Q
L1 F RACNI=0:0 S RACNI=$O(^RADPT("AS",RAST,RADFN,RADTI,RACNI)) Q:RACNI'>0 I $P($G(^RADPT(RADFN,"DT",RADTI,0)),U,2)=RAIMGTYI I $D(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0)) S RA(0)=^(0) D SET
Q
SET S RACN=$P(RA(0),"^"),RADTE=9999999.9999-RADTI,DA=RADFN,DIE="^RADPT(",DR="[RA OVERRIDE]",RASAVDR=DR D ^DIE K DE,DQ,DIE,DR
D:'$D(RAF1) HD D:$Y-(IOSL-11)>0 HD W !,$E($P(^DPT(RADFN,0),"^"),1,25),?28 S Y=RADTE D DD^%DT W Y,?49,RACN,?57,$S($D(^RA(72,RAST,0)):$E($P(^(0),"^"),1,20),1:"Unknown") S RAF4=1
D ^RAORDC Q
HD S PG=PG+1 W:$Y>0 @IOF,!!,?(IOM\2-26),"Report on Mass Override of Exam Statuses to Complete",?(IOM-8),"PAGE ",PG
W !,?(IOM\2-22),"Cutoff Date for this Report is: ",RAECDTE,!,?(IOM\2-17),"Date Report was Run: " S Y=DT D DD^%DT W Y
W !!!,"Patient Name",?28,"Exam Date",?49,"Case #",?57,"Status Before Override",! S RAF1=1 Q
SINGLE ;Override Single Exam Status to 'COMPLETE'
D SET^RAPSET1 I $D(XQUIT) K XQUIT Q
N RAXIT,RASAVDR S RAXIT=0 D CZECH Q:RAXIT
S RAVW="" D ^RACNLU G EXIT1:"^"[X W ! S I="",$P(I,"-",80)="" W I
N RASSAN,RACNDSP S RASSAN=$$SSANVAL^RAHLRU1(RADFN,RADTI,RACNI)
S RACNDSP=$S((RASSAN'=""):RASSAN,1:RACN)
I $$USESSAN^RAHLRU1() W !?1,"Name : ",$E(RANME,1,25),?40,"Pt ID : ",RASSN,!?1,"Case No. : ",RACNDSP,?40,"Procedure : ",$E(RAPRC,1,25)
I '$$USESSAN^RAHLRU1() W !?1,"Name : ",$E(RANME,1,25),?40,"Pt ID : ",RASSN,!?1,"Case No. : ",RACN,?40,"Procedure : ",$E(RAPRC,1,25)
W !?1,"Exam Date: ",RADATE,?40,"Technologist: " I $O(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"TC",0))>0,$D(^VA(200,+^($O(^(0)),0),0)) W $E($P(^(0),"^"),1,25)
W !?40,"Req Phys : ",$E($S($D(^VA(200,+$P(Y(0),"^",14),0)):$P(^(0),"^"),1:""),1,25),! S I="",$P(I,"-",80)="" W I
I $P($G(^RADPT(RADFN,"DT",RADTI,0)),U,2)'=$O(^RA(79.2,"B",RAIMGTY,0)) W !,"Sorry, your sign-on imaging type, ",RAIMGTY,!,"doesn't match the imaging type of this exam.",! G SINGLE
I $D(^RA(72,"AA",RAIMGTY,0,+RAST)) W !!?3,*7,"...exam 'cancelled' therefore override is not allowed." G SINGLE
I $D(^RA(72,"AA",RAIMGTY,9,+RAST)) W !!?3,*7,"...exam is already 'complete'." G SINGLE
ASKOVR R !!,"Are you sure? No// ",X:DTIME S:'$T!(X="")!(X["^") X="N" G SINGLE:"Nn"[$E(X) I "Yy"'[$E(X) W:X'["?" *7 W !!?3,"Enter 'YES' to override exam status to 'COMPLETE', or 'NO' not to." G ASKOVR
W !?3,"...will now attempt override..." S DA=RADFN,DIE="^RADPT(",DR="[RA OVERRIDE]",RASAVDR=DR D ^DIE K DE,DQ,DIE,DR I '$D(Y) W !?6,"...exam status is now '",$P(^RA(72,$O(^RA(72,"AA",RAIMGTY,9,0)),0),"^"),"'.",! D ^RAORDC K DR
G SINGLE
EXIT1 K %,%DT,%I,%X,%Y,D,D0,D1,D2,D3,DA,DI,DIC,J,POP,RADFN,RADIV,RADTI,RACNI
K RANME,RASSN,RADATE,RADTE,RACN,RAHEAD,RAI,RAPRC,RAPIFN,RARPT,RAST,RAVW
K W,X,XQUIT,Y,^TMP($J,"RAEX")
Q
CZECH ; Check for a 'Complete' exam status for a particular imaging type
I '+$O(^RA(72,"AA",RAIMGTY,9,0)) D
. S RAXIT=1
. W !?5,"An Examination Status of 'Complete' must be defined for an"
. W !?5,"Imaging Type of: "_RAIMGTY_". Please contact your"
. W !?5,"Radiology/Nuclear Medicine ADPAC for further assistance.",$C(7)
. Q
Q
RAESO ;HISC/CAH,GJC AISC/SAW-Override Exam Status to Complete ;4/28/97 08:00 [ 12/05/2011 10:27 AM ]
+1 ;;5.0;Radiology/Nuclear Medicine;**47,1004**;Mar 16, 1998;Build 21
+2 ;Mass override exam status to complete
+3 DO SET^RAPSET1
IF $DATA(XQUIT)
KILL XQUIT,POP
QUIT
+4 NEW RAXIT,RASAVDR
SET RAXIT=0
DO CZECH
IF RAXIT
QUIT
+5 WRITE !,"Your sign-on imaging type is ",RAIMGTY,", so only exams",!,"of imaging type ",RAIMGTY," will be changed to complete.",!
+6 KILL DIR
SET DIR(0)="Y"
SET DIR("A")="Are you sure you want to proceed"
DO ^DIR
IF Y'=1
GOTO EXIT
+7 KILL DIR,X,Y
ASK KILL DIC
SET DIC(0)="AEQM"
SET DIC="^RA(72,"
+1 ;
+2 ;IHS/CMI/DAY - Patch 1004 - Don't allow override to complete from waiting for exam
+3 ;Patch 1004 - Continue Chris Saddler Patch from 2004
+4 ;S DIC("S")="I $P(^(0),U,3)'=9,($P(^(0),U,3)'=0),($P(^(0),U,7)=+$O(^RA(79.2,""B"",RAIMGTY,0)))"
+5 SET DIC("S")="I $P(^(0),U,3)'=9,($P(^(0),U,3)'=1),($P(^(0),U,3)'=0),($P(^(0),U,7)=+$O(^RA(79.2,""B"",RAIMGTY,0)))"
+6 ;End Patch
+7 ;
+8 DO ^DIC
IF $DATA(DUOUT)!($DATA(DTOUT))
GOTO EXIT
IF Y'<0
SET RASTIEN(+Y)=""
GOTO ASK
+9 IF '$DATA(RASTIEN)
GOTO EXIT
KILL DIC
WRITE !!,"Enter a cutoff date that is at least sixty days prior to today."
+10 ;
+11 ;IHS/CMI/DAY - Patch 1004 - Allow Override without 60 day cutoff
+12 ;Patch 1004 - Continue Chris Saddler Patch from 2004
+13 ;S X1=DT,X2=-60 D C^%DTC S DIR(0)="D^:"_X D ^DIR G EXIT:$D(DIRUT) S RAECDTI=9999999-Y D DD^%DT S RAECDTE=Y
+14 SET X1=DT
SET X2=-0
DO C^%DTC
SET DIR(0)="D^:"_X
DO ^DIR
IF $DATA(DIRUT)
GOTO EXIT
SET RAECDTI=9999999-Y
DO DD^%DT
SET RAECDTE=Y
+15 ;End Patch
+16 ;
+17 ;Following line commented out for v 4.5 - setting the 10th piece to 0 was preventing update of subfld 75, Exam Status Times. These are now updated.
+18 WRITE !
SET IOP="Q"
SET ZTRTN="DQ^RAESO"
+19 SET ZTSAVE("RAI*")=""
SET ZTSAVE("RAM*")=""
SET ZTSAVE("RAE*")=""
+20 SET ZTSAVE("RASTIEN(")=""
+21 SET ZTDESC="Rad/Nuc Med Mass Override of Exam Status to Complete"
SET RAMES="W !,?5,""Output Queued."""
SET RAZIS=1
DO ZIS^RAUTL
KILL IOP
+22 GOTO EXIT
DQ USE IO
SET PG=0
SET RAIMGTYI=$ORDER(^RA(79.2,"B",RAIMGTY,0))
+1 FOR RAST=0:0
SET RAST=$ORDER(RASTIEN(RAST))
IF RAST'>0
QUIT
FOR RADFN=0:0
SET RADFN=$ORDER(^RADPT("AS",RAST,RADFN))
IF RADFN'>0
QUIT
FOR RADTI=RAECDTI:0
SET RADTI=$ORDER(^RADPT("AS",RAST,RADFN,RADTI))
IF RADTI'>0
QUIT
DO L1
+2 IF '$DATA(RAF4)
DO HD
WRITE !!,"There were no exams with the statuses selected in the time frame specified that",!,"needed to be overridden to complete."
EXIT DO CLOSE^RAUTL
+1 KILL DA,DIC,DIE,DIR,DIRUT,DIROUT,DUOUT,DTOUT,DR,PG,POP
+2 KILL RA,RACN,RACNI,RADFN,RADTE,RADTI,RAECDTE,RAECDTI,RAF1,RAF4,RAIMGTYI,RAMES,RAPOP,RAST,RASTIEN,RAZMDV,RAZIS
+3 KILL X,X1,X2,XQUIT,Y,ZTDESC,ZTRTN,ZTSAVE,I,POP,DISYS,C
QUIT
L1 FOR RACNI=0:0
SET RACNI=$ORDER(^RADPT("AS",RAST,RADFN,RADTI,RACNI))
IF RACNI'>0
QUIT
IF $PIECE($GET(^RADPT(RADFN,"DT",RADTI,0)),U,2)=RAIMGTYI
IF $DATA(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0))
SET RA(0)=^(0)
DO SET
+1 QUIT
SET SET RACN=$PIECE(RA(0),"^")
SET RADTE=9999999.9999-RADTI
SET DA=RADFN
SET DIE="^RADPT("
SET DR="[RA OVERRIDE]"
SET RASAVDR=DR
DO ^DIE
KILL DE,DQ,DIE,DR
+1 IF '$DATA(RAF1)
DO HD
IF $Y-(IOSL-11)>0
DO HD
WRITE !,$EXTRACT($PIECE(^DPT(RADFN,0),"^"),1,25),?28
SET Y=RADTE
DO DD^%DT
WRITE Y,?49,RACN,?57,$SELECT($DATA(^RA(72,RAST,0)):$EXTRACT($PIECE(^(0),"^"),1,20),1:"Unknown")
SET RAF4=1
+2 DO ^RAORDC
QUIT
HD SET PG=PG+1
IF $Y>0
WRITE @IOF,!!,?(IOM\2-26),"Report on Mass Override of Exam Statuses to Complete",?(IOM-8),"PAGE ",PG
+1 WRITE !,?(IOM\2-22),"Cutoff Date for this Report is: ",RAECDTE,!,?(IOM\2-17),"Date Report was Run: "
SET Y=DT
DO DD^%DT
WRITE Y
+2 WRITE !!!,"Patient Name",?28,"Exam Date",?49,"Case #",?57,"Status Before Override",!
SET RAF1=1
QUIT
SINGLE ;Override Single Exam Status to 'COMPLETE'
+1 DO SET^RAPSET1
IF $DATA(XQUIT)
KILL XQUIT
QUIT
+2 NEW RAXIT,RASAVDR
SET RAXIT=0
DO CZECH
IF RAXIT
QUIT
+3 SET RAVW=""
DO ^RACNLU
IF "^"[X
GOTO EXIT1
WRITE !
SET I=""
SET $PIECE(I,"-",80)=""
WRITE I
+4 NEW RASSAN,RACNDSP
SET RASSAN=$$SSANVAL^RAHLRU1(RADFN,RADTI,RACNI)
+5 SET RACNDSP=$SELECT((RASSAN'=""):RASSAN,1:RACN)
+6 IF $$USESSAN^RAHLRU1()
WRITE !?1,"Name : ",$EXTRACT(RANME,1,25),?40,"Pt ID : ",RASSN,!?1,"Case No. : ",RACNDSP,?40,"Procedure : ",$EXTRACT(RAPRC,1,25)
+7 IF '$$USESSAN^RAHLRU1()
WRITE !?1,"Name : ",$EXTRACT(RANME,1,25),?40,"Pt ID : ",RASSN,!?1,"Case No. : ",RACN,?40,"Procedure : ",$EXTRACT(RAPRC,1,25)
+8 WRITE !?1,"Exam Date: ",RADATE,?40,"Technologist: "
IF $ORDER(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"TC",0))>0
IF $DATA(^VA(200,+^($ORDER(^(0)),0),0))
WRITE $EXTRACT($PIECE(^(0),"^"),1,25)
+9 WRITE !?40,"Req Phys : ",$EXTRACT($SELECT($DATA(^VA(200,+$PIECE(Y(0),"^",14),0)):$PIECE(^(0),"^"),1:""),1,25),!
SET I=""
SET $PIECE(I,"-",80)=""
WRITE I
+10 IF $PIECE($GET(^RADPT(RADFN,"DT",RADTI,0)),U,2)'=$ORDER(^RA(79.2,"B",RAIMGTY,0))
WRITE !,"Sorry, your sign-on imaging type, ",RAIMGTY,!,"doesn't match the imaging type of this exam.",!
GOTO SINGLE
+11 IF $DATA(^RA(72,"AA",RAIMGTY,0,+RAST))
WRITE !!?3,*7,"...exam 'cancelled' therefore override is not allowed."
GOTO SINGLE
+12 IF $DATA(^RA(72,"AA",RAIMGTY,9,+RAST))
WRITE !!?3,*7,"...exam is already 'complete'."
GOTO SINGLE
ASKOVR READ !!,"Are you sure? No// ",X:DTIME
IF '$TEST!(X="")!(X["^")
SET X="N"
IF "Nn"[$EXTRACT(X)
GOTO SINGLE
IF "Yy"'[$EXTRACT(X)
IF X'["?"
WRITE *7
WRITE !!?3,"Enter 'YES' to override exam status to 'COMPLETE', or 'NO' not to."
GOTO ASKOVR
+1 WRITE !?3,"...will now attempt override..."
SET DA=RADFN
SET DIE="^RADPT("
SET DR="[RA OVERRIDE]"
SET RASAVDR=DR
DO ^DIE
KILL DE,DQ,DIE,DR
IF '$DATA(Y)
WRITE !?6,"...exam status is now '",$PIECE(^RA(72,$ORDER(^RA(72,"AA",RAIMGTY,9,0)),0),"^"),"'.",!
DO ^RAORDC
KILL DR
+2 GOTO SINGLE
EXIT1 KILL %,%DT,%I,%X,%Y,D,D0,D1,D2,D3,DA,DI,DIC,J,POP,RADFN,RADIV,RADTI,RACNI
+1 KILL RANME,RASSN,RADATE,RADTE,RACN,RAHEAD,RAI,RAPRC,RAPIFN,RARPT,RAST,RAVW
+2 KILL W,X,XQUIT,Y,^TMP($JOB,"RAEX")
+3 QUIT
CZECH ; Check for a 'Complete' exam status for a particular imaging type
+1 IF '+$ORDER(^RA(72,"AA",RAIMGTY,9,0))
Begin DoDot:1
+2 SET RAXIT=1
+3 WRITE !?5,"An Examination Status of 'Complete' must be defined for an"
+4 WRITE !?5,"Imaging Type of: "_RAIMGTY_". Please contact your"
+5 WRITE !?5,"Radiology/Nuclear Medicine ADPAC for further assistance.",$CHAR(7)
+6 QUIT
End DoDot:1
+7 QUIT
