SROCAN0 ;BIR/MAM - REPORT OF CANCELLATIONS (CONT.) ;08/08/2011
;;3.0;Surgery;**14,94,176,182**;24 Jun 93;Build 49
U IO K ^TMP("SR",$J),SRSPEC S SRD=SRSD-.0001,SRE=SRED+.9999,(SRHDR,SRQ)=0,PAGE=1
S Y=DT D D^DIQ S SRPRINT=$E(Y,1,12)
N SRNME,SROPP
F S SRD=$O(^SRF("AC",SRD)) Q:SRQ!(SRD>SRE)!('SRD) S SRTN=0 F S SRTN=$O(^SRF("AC",SRD,SRTN)) Q:SRQ!('SRTN) I $D(^SRF(SRTN,0)),$P($G(^SRF(SRTN,30)),"^")'="",$$MANDIV^SROUTL0(SRINSTP,SRTN) D SET
D HDR S SRSS="" F S SRSS=$O(^TMP("SR",$J,SRSS)) Q:SRSS=""!(SRQ) D SRSP S SRNME="" F S SRNME=$O(^TMP("SR",$J,SRSS,SRNME)) Q:SRNME=""!(SRQ) D
.S SROPP="" F S SROPP=$O(^TMP("SR",$J,SRSS,SRNME,SROPP)) Q:SROPP=""!(SRQ) S SRTN=0 F S SRTN=$O(^TMP("SR",$J,SRSS,SRNME,SROPP,SRTN)) Q:'SRTN!(SRQ) D CASE
I SRSP S SRSS="" F S SRSS=$O(SRSP(SRSS)) Q:'SRSS!SRQ I '$D(^TMP("SR",$J,SRSS)) D SRSP D:$Y+4>IOSL HDR Q:SRQ W !,"No data for selected date range."
I 'SRSP,'$D(^TMP("SR",$J)) W !!,"No data for selected date range."
D END
Q
SRSP S SRSPEC=$S(SRSS:$P(^SRO(137.45,SRSS,0),"^"),1:"NO SPECIALTY ENTERED"),SRSPEC=">> SURGICAL SPECIALTY: "_SRSPEC_" <<" D SUB
Q
SET ; set up ^TMP
Q:$P($G(^SRF(SRTN,"NON")),"^")="Y" S SRSS=$P(^SRF(SRTN,0),"^",4) S:SRSS="" SRSS="ZZ" I SRSP,'$D(SRSP(SRSS)) Q
S DFN=$P(^SRF(SRTN,0),"^") D DEM^VADPT
S ^TMP("SR",$J,SRSS,VADM(1),$P(^SRF(SRTN,"OP"),"^"),SRTN)=""
Q
CASE ; print individual case
I $Y+6>IOSL D HDR Q:SRQ
S S(0)=^SRF(SRTN,0),DFN=$P(S(0),"^") D DEM^VADPT S SRNM=VADM(1),SRSSN=VA("PID"),Y=$P(S(0),"^",9) D D^DIQ S SROD=$E(Y,1,12)
S SRCR=$P($G(^SRF(SRTN,31)),"^",8) S:SRCR'="" SRCR=$P(^SRO(135,SRCR,0),"^")
S Y=$P(^SRF(SRTN,30),"^") D:Y D^DIQ S SRCD=$P(Y,"@")_" "_$E($P(Y,"@",2),1,5)
K ABORT S ABORT=$P($G(^SRF(SRTN,.2)),"^",10)
OPS S SROPER=$S(ABORT:"* ",1:"")_$P(^SRF(SRTN,"OP"),"^"),OPER=0 F S OPER=$O(^SRF(SRTN,13,OPER)) Q:OPER="" D OTHER
K SROPS,MM,MMM S:$L(SROPER)<50 SROPS(1)=SROPER I $L(SROPER)>49 S SROPER=SROPER_" " F M=1:1 D LOOP Q:MMM=""
PRINT ;
W !!,SROD,?15,$E(SRNM,1,28),?44,SROPS(1),?95,SRCD,!,SRTN,?15,VA("PID") W:$D(SROPS(2)) ?44,SROPS(2) W ?95,SRCR
I $D(SROPS(3)) W !,?44,SROPS(3) I $D(SROPS(4)) W !,?44,SROPS(4) I $D(SROPS(5)) W !,?44,SROPS(5) I $D(SROPS(6)) W !,?44,SROPS(6)
Q
END W:$E(IOST)="P" @IOF I $D(ZTQUEUED) K ^TMP("SR",$J) Q:$G(ZTSTOP) S ZTREQ="@" Q
I 'SRQ,$E(IOST)'="P" W !!,"Press RETURN to continue " R X:DTIME
D ^SRSKILL K SRTN D ^%ZISC W @IOF
Q
OTHER ; other operations
S SRLONG=1 I $L(SROPER)+$L($P(^SRF(SRTN,13,OPER,0),"^"))>250 S SRLONG=0,OPER=999,SROPERS=" ..."
I SRLONG S SROPERS=$P(^SRF(SRTN,13,OPER,0),"^")
S SROPER=SROPER_$S(SROPERS=" ...":SROPERS,1:", "_SROPERS)
Q
LOOP ; break procedure if greater than 55 characters
S SROPS(M)="" F LOOP=1:1 S MM=$P(SROPER," "),MMM=$P(SROPER," ",2,200) Q:MMM="" Q:$L(SROPS(M))+$L(MM)'<50 S SROPS(M)=SROPS(M)_MM_" ",SROPER=MMM
Q
HDR ; print heading
I $D(ZTQUEUED) D ^SROSTOP I SRHALT S SRQ=1 Q
I SRHDR,$E(IOST)'="P" W !!,"Press RETURN to continue, or '^' to quit: " R X:DTIME I '$T!(X["^") S SRQ=1 Q
W:$Y @IOF W !,?(132-$L(SRINST)\2),SRINST,?115,"PAGE: "_PAGE,!,?55,"REPORT OF CANCELLATIONS",?100,"REVIEWED BY:"
W !,"PRINTED: ",SRPRINT,?53,"FROM ",$E(SRSD,4,5),"/",$E(SRSD,6,7),"/",$E(SRSD,2,3)," TO ",$E(SRED,4,5),"/",$E(SRED,6,7),"/",$E(SRED,2,3),?100,"DATE REVIEWED:"
W !!,"DATE",?15,"PATIENT",?44,"OPERATION(S)",?95,"CANCEL DATE",!,"CASE #",?15,"ID#",?95,"PRIMARY REASON",! F I=1:1:IOM W "="
S (SRHDR,SRPAGE)=1,PAGE=PAGE+1 D:$D(SRSPEC) SUB1
Q
SUB ; print specialty sub-heading
I $Y+8>IOSL D HDR I SRQ!('SRPAGE) Q
I 'SRPAGE W !! F LINE=1:1:132 W "-"
SUB1 W !,?(132-$L(SRSPEC)\2),SRSPEC S SRPAGE=0
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSROCAN0 3663 printed Apr 09, 2024@21:44:07 Page 2
SROCAN0 ;BIR/MAM - REPORT OF CANCELLATIONS (CONT.) ;08/08/2011
+1 ;;3.0;Surgery;**14,94,176,182**;24 Jun 93;Build 49
+2 USE IO
KILL ^TMP("SR",$JOB),SRSPEC
SET SRD=SRSD-.0001
SET SRE=SRED+.9999
SET (SRHDR,SRQ)=0
SET PAGE=1
+3 SET Y=DT
DO D^DIQ
SET SRPRINT=$EXTRACT(Y,1,12)
+4 NEW SRNME,SROPP
+5 FOR
SET SRD=$ORDER(^SRF("AC",SRD))
if SRQ!(SRD>SRE)!('SRD)
QUIT
SET SRTN=0
FOR
SET SRTN=$ORDER(^SRF("AC",SRD,SRTN))
if SRQ!('SRTN)
QUIT
IF $DATA(^SRF(SRTN,0))
IF $PIECE($GET(^SRF(SRTN,30)),"^")'=""
IF $$MANDIV^SROUTL0(SRINSTP,SRTN)
DO SET
+6 DO HDR
SET SRSS=""
FOR
SET SRSS=$ORDER(^TMP("SR",$JOB,SRSS))
if SRSS=""!(SRQ)
QUIT
DO SRSP
SET SRNME=""
FOR
SET SRNME=$ORDER(^TMP("SR",$JOB,SRSS,SRNME))
if SRNME=""!(SRQ)
QUIT
Begin DoDot:1
+7 SET SROPP=""
FOR
SET SROPP=$ORDER(^TMP("SR",$JOB,SRSS,SRNME,SROPP))
if SROPP=""!(SRQ)
QUIT
SET SRTN=0
FOR
SET SRTN=$ORDER(^TMP("SR",$JOB,SRSS,SRNME,SROPP,SRTN))
if 'SRTN!(SRQ)
QUIT
DO CASE
End DoDot:1
+8 IF SRSP
SET SRSS=""
FOR
SET SRSS=$ORDER(SRSP(SRSS))
if 'SRSS!SRQ
QUIT
IF '$DATA(^TMP("SR",$JOB,SRSS))
DO SRSP
if $Y+4>IOSL
DO HDR
if SRQ
QUIT
WRITE !,"No data for selected date range."
+9 IF 'SRSP
IF '$DATA(^TMP("SR",$JOB))
WRITE !!,"No data for selected date range."
+10 DO END
+11 QUIT
SRSP SET SRSPEC=$SELECT(SRSS:$PIECE(^SRO(137.45,SRSS,0),"^"),1:"NO SPECIALTY ENTERED")
SET SRSPEC=">> SURGICAL SPECIALTY: "_SRSPEC_" <<"
DO SUB
+1 QUIT
SET ; set up ^TMP
+1 if $PIECE($GET(^SRF(SRTN,"NON")),"^")="Y"
QUIT
SET SRSS=$PIECE(^SRF(SRTN,0),"^",4)
if SRSS=""
SET SRSS="ZZ"
IF SRSP
IF '$DATA(SRSP(SRSS))
QUIT
+2 SET DFN=$PIECE(^SRF(SRTN,0),"^")
DO DEM^VADPT
+3 SET ^TMP("SR",$JOB,SRSS,VADM(1),$PIECE(^SRF(SRTN,"OP"),"^"),SRTN)=""
+4 QUIT
CASE ; print individual case
+1 IF $Y+6>IOSL
DO HDR
if SRQ
QUIT
+2 SET S(0)=^SRF(SRTN,0)
SET DFN=$PIECE(S(0),"^")
DO DEM^VADPT
SET SRNM=VADM(1)
SET SRSSN=VA("PID")
SET Y=$PIECE(S(0),"^",9)
DO D^DIQ
SET SROD=$EXTRACT(Y,1,12)
+3 SET SRCR=$PIECE($GET(^SRF(SRTN,31)),"^",8)
if SRCR'=""
SET SRCR=$PIECE(^SRO(135,SRCR,0),"^")
+4 SET Y=$PIECE(^SRF(SRTN,30),"^")
if Y
DO D^DIQ
SET SRCD=$PIECE(Y,"@")_" "_$EXTRACT($PIECE(Y,"@",2),1,5)
+5 KILL ABORT
SET ABORT=$PIECE($GET(^SRF(SRTN,.2)),"^",10)
OPS SET SROPER=$SELECT(ABORT:"* ",1:"")_$PIECE(^SRF(SRTN,"OP"),"^")
SET OPER=0
FOR
SET OPER=$ORDER(^SRF(SRTN,13,OPER))
if OPER=""
QUIT
DO OTHER
+1 KILL SROPS,MM,MMM
if $LENGTH(SROPER)<50
SET SROPS(1)=SROPER
IF $LENGTH(SROPER)>49
SET SROPER=SROPER_" "
FOR M=1:1
DO LOOP
if MMM=""
QUIT
PRINT ;
+1 WRITE !!,SROD,?15,$EXTRACT(SRNM,1,28),?44,SROPS(1),?95,SRCD,!,SRTN,?15,VA("PID")
if $DATA(SROPS(2))
WRITE ?44,SROPS(2)
WRITE ?95,SRCR
+2 IF $DATA(SROPS(3))
WRITE !,?44,SROPS(3)
IF $DATA(SROPS(4))
WRITE !,?44,SROPS(4)
IF $DATA(SROPS(5))
WRITE !,?44,SROPS(5)
IF $DATA(SROPS(6))
WRITE !,?44,SROPS(6)
+3 QUIT
END if $EXTRACT(IOST)="P"
WRITE @IOF
IF $DATA(ZTQUEUED)
KILL ^TMP("SR",$JOB)
if $GET(ZTSTOP)
QUIT
SET ZTREQ="@"
QUIT
+1 IF 'SRQ
IF $EXTRACT(IOST)'="P"
WRITE !!,"Press RETURN to continue "
READ X:DTIME
+2 DO ^SRSKILL
KILL SRTN
DO ^%ZISC
WRITE @IOF
+3 QUIT
OTHER ; other operations
+1 SET SRLONG=1
IF $LENGTH(SROPER)+$LENGTH($PIECE(^SRF(SRTN,13,OPER,0),"^"))>250
SET SRLONG=0
SET OPER=999
SET SROPERS=" ..."
+2 IF SRLONG
SET SROPERS=$PIECE(^SRF(SRTN,13,OPER,0),"^")
+3 SET SROPER=SROPER_$SELECT(SROPERS=" ...":SROPERS,1:", "_SROPERS)
+4 QUIT
LOOP ; break procedure if greater than 55 characters
+1 SET SROPS(M)=""
FOR LOOP=1:1
SET MM=$PIECE(SROPER," ")
SET MMM=$PIECE(SROPER," ",2,200)
if MMM=""
QUIT
if $LENGTH(SROPS(M))+$LENGTH(MM)'<50
QUIT
SET SROPS(M)=SROPS(M)_MM_" "
SET SROPER=MMM
+2 QUIT
HDR ; print heading
+1 IF $DATA(ZTQUEUED)
DO ^SROSTOP
IF SRHALT
SET SRQ=1
QUIT
+2 IF SRHDR
IF $EXTRACT(IOST)'="P"
WRITE !!,"Press RETURN to continue, or '^' to quit: "
READ X:DTIME
IF '$TEST!(X["^")
SET SRQ=1
QUIT
+3 if $Y
WRITE @IOF
WRITE !,?(132-$LENGTH(SRINST)\2),SRINST,?115,"PAGE: "_PAGE,!,?55,"REPORT OF CANCELLATIONS",?100,"REVIEWED BY:"
+4 WRITE !,"PRINTED: ",SRPRINT,?53,"FROM ",$EXTRACT(SRSD,4,5),"/",$EXTRACT(SRSD,6,7),"/",$EXTRACT(SRSD,2,3)," TO ",$EXTRACT(SRED,4,5),"/",$EXTRACT(SRED,6,7),"/",$EXTRACT(SRED,2,3),?100,"DATE REVIEWED:"
+5 WRITE !!,"DATE",?15,"PATIENT",?44,"OPERATION(S)",?95,"CANCEL DATE",!,"CASE #",?15,"ID#",?95,"PRIMARY REASON",!
FOR I=1:1:IOM
WRITE "="
+6 SET (SRHDR,SRPAGE)=1
SET PAGE=PAGE+1
if $DATA(SRSPEC)
DO SUB1
+7 QUIT
SUB ; print specialty sub-heading
+1 IF $Y+8>IOSL
DO HDR
IF SRQ!('SRPAGE)
QUIT
+2 IF 'SRPAGE
WRITE !!
FOR LINE=1:1:132
WRITE "-"
SUB1 WRITE !,?(132-$LENGTH(SRSPEC)\2),SRSPEC
SET SRPAGE=0
+1 QUIT
