- 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 Feb 19, 2025@00:09 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