RASTRPT2 ;HISC/SS-Status Tracking Statistics Report ;4/28/00 10:00
;;5.0;Radiology/Nuclear Medicine;**20,24**;Mar 16, 1998
;Last Modifications by SS on Aug 3,2000 for patch P24
;Select Division, if exists
;Requires RACCESS "DIV" elements. Prompts user to select division(s).
;Creates ^TMP($J,"RA D-TYPE",Division name,Division IEN)="" which
;contains all divisions selected.
SELREQ() ;P20 by SS Select requesting location prompt
N RAINP,RAUTIL,RADIC,RA11A,RAQQHLP
N RA ;push previous to stack
S RAQQHLP=""
S RAUTIL="RA REQ-LOC"
K ^TMP($J,RAUTIL)
ASK2 W !,!,"Select all requesting locations? Y/N: " R RAINP:DTIME I '$T W $C(7)," Timed out...." Q -2
Q:RAINP="^" "-1^NON"
S RAQQHLP="Enter YES to obtain a report for all requesting locations.^Enter NO to select one or more requesting location(s)."
S RAINP=$$YESNO(RAINP,RAQQHLP)
I RAINP="0" G ASK2
I RAINP="Y" Q "0^ALL"
I RAINP="N" D
.S RADIC("A")="Select requesting location: "
.S RADIC="^SC(",RADIC(0)="QEAMZ",X="A",RADIC("B")=""
.D EN1^RASELCT(.RADIC,RAUTIL) K %W,%Y1,DIC,X,Y
.Q
N RA20A,RA20B,RA20C,RA20D S (RA20A,RA20B,RA20C)=0
F S RA20A=$O(^TMP($J,RAUTIL,RA20A)) Q:RA20A="" S RA20C=RA20A,RA20B=RA20B+1
G:RA20B=0 ASK2
I RA20B=1 Q "1^"_RA20C_"^"_$O(^TMP($J,RAUTIL,RA20C,0))
Q RA20B_"^MULTI"
;
SELPROC(RAIMGTP) ;P20 Select procedure prompt
N RAINP,RAUTIL,RADIC,RA11A,RAQQHLP
N RA ;push previous to stack
ASK W !,!,"Select all procedures? Y/N: " R RAINP:DTIME I '$T W $C(7)," Timed out...." Q -2
Q:RAINP="^" -1
S RAQQHLP="Enter YES to select all procedures^or NO to select a single procedure."
S RAINP=$$YESNO(RAINP,RAQQHLP)
I RAINP="0" G ASK
I RAINP="Y" Q 0
I RAINP="N" S DIC="^RAMIS(71,",DIC(0)="QAEMZI" D ^DIC S RA11A=Y K %W,%Y1,DIC,X,Y
Q RA11A
;
SETTMP ;P20 by SS update data in ^TMP for RASTAT in new format
N X,Y,RARQLOC,RA11,RA11A S RA11=$G(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0)) Q:RA11=""
S RA11A=$P(RA11,"^",22) I RA11A="" S RARQLOC=$P(RA11,"^",9)
S RARQLOC=$S(RA11A="":"Unknown",1:$E($P(^SC(RA11A,0),"^",1),1,200))
S $P(RACURREC("L"),"^",2)=RARQLOC
;set PROC
I '$D(^TMP($J,"RAST",RAIMAGE,RADV,RARQLOC,"PROC",RAFR,RATO,RAPRC)) S ^(RAPRC)=Y1_"^^"_Y1_"^^1^"_Y1
E S:+Y1>+$P(^(RAPRC),"^",1) $P(^(RAPRC),"^",1)=Y1 S:+Y1<+$P(^(RAPRC),"^",3) $P(^(RAPRC),"^",3)=Y1 S $P(^(RAPRC),"^",6)=+$P(^(RAPRC),"^",6)+Y1,$P(^(RAPRC),"^",5)=+$P(^(RAPRC),"^",5)+1
S X=+$P(^(RAPRC),"^",1) I X'<0 D MINUTS^RAUTL1 S $P(^(RAPRC),"^",2)=Y
S X=+$P(^(RAPRC),"^",3) I X'<0 D MINUTS^RAUTL1 S $P(^(RAPRC),"^",4)=Y
;Set SUM
I '$D(^TMP($J,"RAST",RAIMAGE,RADV,RARQLOC,"SUM",RAFR,RATO)) S ^(RATO)=Y1_"^^"_Y1_"^^1^"_Y1
E S:+Y1>+$P(^(RATO),"^",1) $P(^(RATO),"^",1)=Y1 S:+Y1<+$P(^(RATO),"^",3) $P(^(RATO),"^",3)=Y1 S $P(^(RATO),"^",6)=+$P(^(RATO),"^",6)+Y1,$P(^(RATO),"^",5)=+$P(^(RATO),"^",5)+1
S X=+$P(^(RATO),"^",1) I X'<0 D MINUTS^RAUTL1 S $P(^(RATO),"^",2)=Y
S X=+$P(^(RATO),"^",3) I X'<0 D MINUTS^RAUTL1 S $P(^(RATO),"^",4)=Y
;Set COMPLETE
I '$D(^TMP($J,"RAST",RAIMAGE,RADV,RARQLOC,"COMPLETE")) S ^("COMPLETE")=Y1_"^^"_Y1_"^^1^"_Y1
E S:+Y1>+$P(^("COMPLETE"),"^",1) $P(^("COMPLETE"),"^",1)=Y1 S:+Y1<+$P(^("COMPLETE"),"^",3) $P(^("COMPLETE"),"^",3)=Y1 S $P(^("COMPLETE"),"^",6)=+$P(^("COMPLETE"),"^",6)+Y1,$P(^("COMPLETE"),"^",5)=+$P(^("COMPLETE"),"^",5)+1
S X=+$P(^("COMPLETE"),"^",1) I X'<0 D MINUTS^RAUTL1 S $P(^("COMPLETE"),"^",2)=Y
S X=+$P(^("COMPLETE"),"^",3) I X'<0 D MINUTS^RAUTL1 S $P(^("COMPLETE"),"^",4)=Y
Q
;
YESNO(RAYN,RAQQMRK) ;
N RA20,RA20A S RA20=""
S RAYN=$$UP^XLFSTR(RAYN)
I RAYN="Y"!(RAYN="YE")!(RAYN="YES") Q "Y"
I RAYN="N"!(RAYN="NO") Q "N"
I RAYN="?" W !,"Answer with either: YES or NO" Q 0
I RAYN="??" F RA20A=1:1:5 S RA20=$P(RAQQMRK,"^",RA20A) Q:RA20="" W !,RA20
Q "0"
ISLOCOK(RA20A,RA20J) ;if it isn't selected location
N RA20C,RA20D,RA20FL
S (RA20C,RA20FL)=0
F S RA20C=$O(^TMP(RA20J,"RA REQ-LOC",RA20C)) Q:RA20C="" D
.S RA20D=$O(^TMP(RA20J,"RA REQ-LOC",RA20C,0))
.S:RA20D=RA20A RA20FL=1 Q
.Q
Q RA20FL
;
;Generic Yes/No prompt
;Arguments: text of question,retval for Yes, for No, for ^, treat as "N" or "Y" if empty, help text for ??
ASKYN(RAQUEST,RARETYES,RARETNO,RARETUPA,RARETEMP,RAHLP2QM) ;P24
ASKAGAN W !,!,RAQUEST R RAINP:DTIME I '$T W $C(7)," Timed out...." Q RARETUPA
Q:RAINP="^" RARETUPA
S:RAINP="" RAINP=RARETEMP
S RAINP=$$YESNO(RAINP,RAHLP2QM)
I RAINP="0" G ASKAGAN
Q:RAINP="N" RARETNO
Q RARETYES
ASKDTRPT() ;P24
N RAYNQST
S RAYNQST="Do you wish to print detailed reports? No// "
N RAQQHLP
S RAQQHLP="Enter YES to obtain detailed reports 'Procedure Detail by Requesting locations'^and 'Division Summary Requesting Location Details '.^Enter NO to skip the reports."
Q $$ASKYN(RAYNQST,1,0,-1,"N",RAQQHLP)
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRASTRPT2 4758 printed Jan 18, 2025@03:40:59 Page 2
RASTRPT2 ;HISC/SS-Status Tracking Statistics Report ;4/28/00 10:00
+1 ;;5.0;Radiology/Nuclear Medicine;**20,24**;Mar 16, 1998
+2 ;Last Modifications by SS on Aug 3,2000 for patch P24
+3 ;Select Division, if exists
+4 ;Requires RACCESS "DIV" elements. Prompts user to select division(s).
+5 ;Creates ^TMP($J,"RA D-TYPE",Division name,Division IEN)="" which
+6 ;contains all divisions selected.
SELREQ() ;P20 by SS Select requesting location prompt
+1 NEW RAINP,RAUTIL,RADIC,RA11A,RAQQHLP
+2 ;push previous to stack
NEW RA
+3 SET RAQQHLP=""
+4 SET RAUTIL="RA REQ-LOC"
+5 KILL ^TMP($JOB,RAUTIL)
ASK2 WRITE !,!,"Select all requesting locations? Y/N: "
READ RAINP:DTIME
IF '$TEST
WRITE $CHAR(7)," Timed out...."
QUIT -2
+1 if RAINP="^"
QUIT "-1^NON"
+2 SET RAQQHLP="Enter YES to obtain a report for all requesting locations.^Enter NO to select one or more requesting location(s)."
+3 SET RAINP=$$YESNO(RAINP,RAQQHLP)
+4 IF RAINP="0"
GOTO ASK2
+5 IF RAINP="Y"
QUIT "0^ALL"
+6 IF RAINP="N"
Begin DoDot:1
+7 SET RADIC("A")="Select requesting location: "
+8 SET RADIC="^SC("
SET RADIC(0)="QEAMZ"
SET X="A"
SET RADIC("B")=""
+9 DO EN1^RASELCT(.RADIC,RAUTIL)
KILL %W,%Y1,DIC,X,Y
+10 QUIT
End DoDot:1
+11 NEW RA20A,RA20B,RA20C,RA20D
SET (RA20A,RA20B,RA20C)=0
+12 FOR
SET RA20A=$ORDER(^TMP($JOB,RAUTIL,RA20A))
if RA20A=""
QUIT
SET RA20C=RA20A
SET RA20B=RA20B+1
+13 if RA20B=0
GOTO ASK2
+14 IF RA20B=1
QUIT "1^"_RA20C_"^"_$ORDER(^TMP($JOB,RAUTIL,RA20C,0))
+15 QUIT RA20B_"^MULTI"
+16 ;
SELPROC(RAIMGTP) ;P20 Select procedure prompt
+1 NEW RAINP,RAUTIL,RADIC,RA11A,RAQQHLP
+2 ;push previous to stack
NEW RA
ASK WRITE !,!,"Select all procedures? Y/N: "
READ RAINP:DTIME
IF '$TEST
WRITE $CHAR(7)," Timed out...."
QUIT -2
+1 if RAINP="^"
QUIT -1
+2 SET RAQQHLP="Enter YES to select all procedures^or NO to select a single procedure."
+3 SET RAINP=$$YESNO(RAINP,RAQQHLP)
+4 IF RAINP="0"
GOTO ASK
+5 IF RAINP="Y"
QUIT 0
+6 IF RAINP="N"
SET DIC="^RAMIS(71,"
SET DIC(0)="QAEMZI"
DO ^DIC
SET RA11A=Y
KILL %W,%Y1,DIC,X,Y
+7 QUIT RA11A
+8 ;
SETTMP ;P20 by SS update data in ^TMP for RASTAT in new format
+1 NEW X,Y,RARQLOC,RA11,RA11A
SET RA11=$GET(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0))
if RA11=""
QUIT
+2 SET RA11A=$PIECE(RA11,"^",22)
IF RA11A=""
SET RARQLOC=$PIECE(RA11,"^",9)
+3 SET RARQLOC=$SELECT(RA11A="":"Unknown",1:$EXTRACT($PIECE(^SC(RA11A,0),"^",1),1,200))
+4 SET $PIECE(RACURREC("L"),"^",2)=RARQLOC
+5 ;set PROC
+6 IF '$DATA(^TMP($JOB,"RAST",RAIMAGE,RADV,RARQLOC,"PROC",RAFR,RATO,RAPRC))
SET ^(RAPRC)=Y1_"^^"_Y1_"^^1^"_Y1
+7 IF '$TEST
if +Y1>+$PIECE(^(RAPRC),"^",1)
SET $PIECE(^(RAPRC),"^",1)=Y1
if +Y1<+$PIECE(^(RAPRC),"^",3)
SET $PIECE(^(RAPRC),"^",3)=Y1
SET $PIECE(^(RAPRC),"^",6)=+$PIECE(^(RAPRC),"^",6)+Y1
SET $PIECE(^(RAPRC),"^",5)=+$PIECE(^(RAPRC),"^",5)+1
+8 SET X=+$PIECE(^(RAPRC),"^",1)
IF X'<0
DO MINUTS^RAUTL1
SET $PIECE(^(RAPRC),"^",2)=Y
+9 SET X=+$PIECE(^(RAPRC),"^",3)
IF X'<0
DO MINUTS^RAUTL1
SET $PIECE(^(RAPRC),"^",4)=Y
+10 ;Set SUM
+11 IF '$DATA(^TMP($JOB,"RAST",RAIMAGE,RADV,RARQLOC,"SUM",RAFR,RATO))
SET ^(RATO)=Y1_"^^"_Y1_"^^1^"_Y1
+12 IF '$TEST
if +Y1>+$PIECE(^(RATO),"^",1)
SET $PIECE(^(RATO),"^",1)=Y1
if +Y1<+$PIECE(^(RATO),"^",3)
SET $PIECE(^(RATO),"^",3)=Y1
SET $PIECE(^(RATO),"^",6)=+$PIECE(^(RATO),"^",6)+Y1
SET $PIECE(^(RATO),"^",5)=+$PIECE(^(RATO),"^",5)+1
+13 SET X=+$PIECE(^(RATO),"^",1)
IF X'<0
DO MINUTS^RAUTL1
SET $PIECE(^(RATO),"^",2)=Y
+14 SET X=+$PIECE(^(RATO),"^",3)
IF X'<0
DO MINUTS^RAUTL1
SET $PIECE(^(RATO),"^",4)=Y
+15 ;Set COMPLETE
+16 IF '$DATA(^TMP($JOB,"RAST",RAIMAGE,RADV,RARQLOC,"COMPLETE"))
SET ^("COMPLETE")=Y1_"^^"_Y1_"^^1^"_Y1
+17 IF '$TEST
if +Y1>+$PIECE(^("COMPLETE"),"^",1)
SET $PIECE(^("COMPLETE"),"^",1)=Y1
if +Y1<+$PIECE(^("COMPLETE"),"^",3)
SET $PIECE(^("COMPLETE"),"^",3)=Y1
SET $PIECE(^("COMPLETE"),"^",6)=+$PIECE(^("COMPLETE"),"^",6)+Y1
SET $PIECE(^("COMPLETE"),"^",5)=+$PIECE(^("COMPLETE"),"^",5)+1
+18 SET X=+$PIECE(^("COMPLETE"),"^",1)
IF X'<0
DO MINUTS^RAUTL1
SET $PIECE(^("COMPLETE"),"^",2)=Y
+19 SET X=+$PIECE(^("COMPLETE"),"^",3)
IF X'<0
DO MINUTS^RAUTL1
SET $PIECE(^("COMPLETE"),"^",4)=Y
+20 QUIT
+21 ;
YESNO(RAYN,RAQQMRK) ;
+1 NEW RA20,RA20A
SET RA20=""
+2 SET RAYN=$$UP^XLFSTR(RAYN)
+3 IF RAYN="Y"!(RAYN="YE")!(RAYN="YES")
QUIT "Y"
+4 IF RAYN="N"!(RAYN="NO")
QUIT "N"
+5 IF RAYN="?"
WRITE !,"Answer with either: YES or NO"
QUIT 0
+6 IF RAYN="??"
FOR RA20A=1:1:5
SET RA20=$PIECE(RAQQMRK,"^",RA20A)
if RA20=""
QUIT
WRITE !,RA20
+7 QUIT "0"
ISLOCOK(RA20A,RA20J) ;if it isn't selected location
+1 NEW RA20C,RA20D,RA20FL
+2 SET (RA20C,RA20FL)=0
+3 FOR
SET RA20C=$ORDER(^TMP(RA20J,"RA REQ-LOC",RA20C))
if RA20C=""
QUIT
Begin DoDot:1
+4 SET RA20D=$ORDER(^TMP(RA20J,"RA REQ-LOC",RA20C,0))
+5 if RA20D=RA20A
SET RA20FL=1
QUIT
+6 QUIT
End DoDot:1
+7 QUIT RA20FL
+8 ;
+9 ;Generic Yes/No prompt
+10 ;Arguments: text of question,retval for Yes, for No, for ^, treat as "N" or "Y" if empty, help text for ??
ASKYN(RAQUEST,RARETYES,RARETNO,RARETUPA,RARETEMP,RAHLP2QM) ;P24
ASKAGAN WRITE !,!,RAQUEST
READ RAINP:DTIME
IF '$TEST
WRITE $CHAR(7)," Timed out...."
QUIT RARETUPA
+1 if RAINP="^"
QUIT RARETUPA
+2 if RAINP=""
SET RAINP=RARETEMP
+3 SET RAINP=$$YESNO(RAINP,RAHLP2QM)
+4 IF RAINP="0"
GOTO ASKAGAN
+5 if RAINP="N"
QUIT RARETNO
+6 QUIT RARETYES
ASKDTRPT() ;P24
+1 NEW RAYNQST
+2 SET RAYNQST="Do you wish to print detailed reports? No// "
+3 NEW RAQQHLP
+4 SET RAQQHLP="Enter YES to obtain detailed reports 'Procedure Detail by Requesting locations'^and 'Division Summary Requesting Location Details '.^Enter NO to skip the reports."
+5 QUIT $$ASKYN(RAYNQST,1,0,-1,"N",RAQQHLP)
