SROQ2 ;BIR/ADM - SUMMARY REPORT ;07/18/07
;;3.0; Surgery ;**38,62,70,50,95,123,129,134,153,160,163**;24 Jun 93;Build 2
;** NOTICE: This routine is part of an implementation of a nationally
;** controlled procedure. Local modifications to this routine
;** are prohibited.
;
S SRSOUT=0 W @IOF,!,"SUMMARY REPORT FOR SURGICAL SERVICE"
W !!,"Enter date range for data to be included on report."
SDATE ; enter starting date
W !,"Start with date: " R X:DTIME I '$T!(X["^")!(X="") S SRSOUT=1 G END
I X["?" W !,"Enter the EARLIEST date for data to be included in this report." S X="?",%DT="EX" D ^%DT G SDATE
S %DT="EXP" D ^%DT G SDATE:Y<1 S SRSTART=Y
I SRSTART>DT W !!,"Cannot report on operations for future dates !",! G SDATE
S SRAC=$O(^SRF("AC",0)) I SRSTART<SRAC S Y=SRAC D DD^%DT S SRAC1=$E(Y,1,12) W !!,"NOTE: ",$S(SRAC:"No surgical case data exists before "_SRAC1_".",1:"There are no surgical cases on record !")
EDATE ; enter ending date
W !!,"End with date: " R X:DTIME I '$T!(X["^")!(X="") S SRSOUT=1 G END
I X["?" W !,"Enter the LATEST date for data to be included in this report." S X="?",%DT="EX" D ^%DT G EDATE
S %DT="EXP" D ^%DT G EDATE:Y<1 S SREND=Y
I SRSTART>SREND W !!,"The ENDING date must be later than the BEGINNING date. Please try again.",! G SDATE
I SREND>DT W !!,"Cannot report on operations for future dates !",! G EDATE
S SRFLG=0
N SRINSTP S SRINST=$$INST^SROUTL0() G:SRINST="^" END S SRINSTP=$P(SRINST,U),SRINST=$S(SRINST["ALL DIVISIONS":SRINST,1:$P(SRINST,U,2))
IO W ! K %ZIS,IO("Q"),POP S %ZIS("A")="Print report on which Device: ",%ZIS="Q" D ^%ZIS I POP S SRSOUT=1 G END
I $D(IO("Q")) K IO("Q") S ZTDESC="Summary Report - Surgical Service",(ZTSAVE("SRSTART"),ZTSAVE("SRINSTP"),ZTSAVE("SREND"),ZTSAVE("SRFLG"))="",ZTRTN="EN^SROQ2" D ^%ZTLOAD S SRSOUT=1 G END
EN ; entry point when queued
D SET,^SROQ1,END
Q
SET ; collect data
S SRSD=SRSTART-.0001,SRED=SREND+.9999 D ZERO
N SRXX S SRXX=$$SITE^SROVAR
I SRFLG=1 D
.I SRMULT D Q
..S:'SRIEN SRINST=$P(SRXX,"^",2),SRSTATN=$P(SRXX,"^",3)
..S:'$D(SRINSTP) SRINSTP="ALL DIVISIONS",SRINST=SRINST_" - ALL DIVISIONS"
.S SRINSTP=$P(SRXX,"^"),SRINST=$P(SRXX,"^",2),SRSTATN=+$P(SRXX,"^",3)
I 'SRFLG D
.I SRINSTP["ALL DIV" S SRINST=$P(SRXX,"^",2)_" - ALL DIVISIONS",SRSTATN=$P(SRXX,"^",3) Q
.S SRINST=$$GET1^DIQ(4,SRINSTP,.01),SRSTATN=$$GET1^DIQ(4,SRINSTP,99)
F S SRSD=$O(^SRF("AC",SRSD)) Q:SRSD>SRED!('SRSD) S SRTN=0 F S SRTN=$O(^SRF("AC",SRSD,SRTN)) Q:'SRTN I $D(^SRF(SRTN,0)),$$MANDIV^SROUTL0(SRINSTP,SRTN) D CASE
D MORT^SROQ1A,DEATH S Y=SRSTART D DD^%DT S SRSD=$E(Y,1,12) S Y=SREND D DD^%DT S SRED=$E(Y,1,12),SRYR=$E(Y,9,12) I SRFLG,$E(SRSTART,4,5)=10 S SRYR=SRYR+1
Q
END W ! I 'SRSOUT,$E(IOST,1,2)="C-" W !!,"Press <RET> to continue " R X:DTIME
D KTMP W:$E(IOST)="P" @IOF I $D(ZTQUEUED) Q:$G(ZTSTOP) S ZTREQ="@" Q
D ^SRSKILL
K SR14,SR71,SR72,SR73,SRADMT,SRHAIR,SRHOSP,SRICNR,SRICNE,SRICNO,SRICY,SRIDP,SRINSTP,SRINV,SRIOSTAT,SRTN,SRTONE,SRTONO,SRTOV,SRVER,SRSCY,SRSCNR,SRSCNO,SRSCNE
D ^%ZISC W @IOF
Q
KTMP F I="SRDEATH","SRDPT","SRDREL","SRDTH","SREXP","SRINOUT","SRIOD","SRP","SRPROC","SRREL","SRSP","SRSS","SRTN" K ^TMP(I,$J)
Q
CASE ; examine case
Q:$P($G(^SRF(SRTN,30)),"^")!'$P($G(^SRF(SRTN,.2)),"^",12)!($P($G(^SRF(SRTN,"NON")),"^")="Y")
S SRCASES=SRCASES+1 D ^SROQ0
Q
ZERO ; set counters to 0
S (SRTOV,SRTONO,SRTONE,SRICY,SRICNO,SRICNR,SRICNE,SRSCY,SRSCNR,SRSCNO,SRSCNE)=0
D KTMP S (SR60,SRADMT,SRCASES,SRCOMP,SRDPT,SREMERG,SRIN,SRINPAT,SRIX,SRMAJOR,SRMORT,SROPD,SRSOUT,SRWC)=0 F I=1:1:7 S SRASA(I)=0
S SRSS=0 F I=48:1:62,78 S SRSPEC(I)=I,^TMP("SRSS",$J,I)="0^0^0^0",SREXP(I)=0
S ^TMP("SRSS",$J,"ZZ")="0^0^0^0",SREXP("ZZ")=0
K SRATT F I=9:1:14,99 S (SRATT(I),SRATT("J",I),SRATT("N",I))=0
F SRPROC=1:1:12 S ^TMP("SRPROC",$J,SRPROC)="0^0",SRDEATH(SRPROC)=0
S (SRINV("I"),SRINV("O"))=0 F I=1:1:38 S SRC(I)=0
F I="C","D","N","P","S","U","O","ZZ" S SRHAIR(I)=0
Q
DEATH ; tabulate deaths
S SRED=SREND+.9999,SRSD=SRSTART-.0001,DFN=0 F S DFN=$O(^TMP("SREXP",$J,DFN)) Q:'DFN D SPEC
S SRSS=0 F S SRSS=$O(SREXP(SRSS)) Q:SRSS="" S ^TMP("SRSS",$J,SRSS)=^TMP("SRSS",$J,SRSS)_"^"_SREXP(SRSS)
S DFN=0 F S DFN=$O(^TMP("SRDEATH",$J,DFN)) Q:'DFN D IP
F J=1:1:12 S ^TMP("SRPROC",$J,J)=^TMP("SRPROC",$J,J)_"^"_SRDEATH(J)
S DFN=0 F S DFN=$O(^TMP("SRIOD",$J,DFN)) Q:'DFN D INOUT
Q
SPEC ; determine related specialty
I $O(^TMP("SRSP",$J,DFN,0))="" S Y=^TMP("SREXP",$J,DFN),SRTN=$P(Y,"^"),SRSS=$P(Y,"^",2),SRDT=$P(^SRF(SRTN,0),"^",9) Q:SRDT>SRED!(SRDT<SRSD) S SREXP(SRSS)=SREXP(SRSS)+1,SRMORT=SRMORT+1 Q
S SRDT=$O(^TMP("SRSP",$J,DFN,0)) I (9999999-SRDT)'>SRED&((9999999-SRDT)'<SRSD) S SRSS=^TMP("SRSP",$J,DFN,SRDT),SREXP(SRSS)=SREXP(SRSS)+1,SRMORT=SRMORT+1
Q
IP ; determine related index procedure (if any)
I $O(^TMP("SRP",$J,DFN,0))="" S Y=^TMP("SRDEATH",$J,DFN),SRTN=$P(Y,"^"),SRPROC=$P(Y,"^",2),SRDT=$P(^SRF(SRTN,0),"^",9) Q:SRDT>SRED!(SRDT<SRSD) S SRDEATH(SRPROC)=SRDEATH(SRPROC)+1 Q
S SRDT=$O(^TMP("SRP",$J,DFN,0)) I (9999999-SRDT)'>SRED&((9999999-SRDT)'<SRSD) S SRPROC=^TMP("SRP",$J,DFN,SRDT),SRDEATH(SRPROC)=SRDEATH(SRPROC)+1
Q
INOUT ; decide if death is in or out-pat surgery death
S SRIOSTAT="" I $O(^TMP("SRINOUT",$J,DFN,0))="" S Y=^TMP("SRIOD",$J,DFN),SRTN=$P(Y,"^"),SRIOSTAT=$P(Y,"^",2),SRDT=$P(^SRF(SRTN,0),"^",9) Q:SRDT>SRED!(SRDT<SRSD)!(SRIOSTAT'="O") S SROPD=SROPD+1 Q
S SRDT=$O(^TMP("SRINOUT",$J,DFN,0)) S SRIOSTAT=^TMP("SRINOUT",$J,DFN,SRDT) I (9999999-SRDT)'>SRED&((9999999-SRDT)'<SRSD)&(SRIOSTAT="O") S SROPD=SROPD+1
Q
SROQ2 ;BIR/ADM - SUMMARY REPORT ;07/18/07
+1 ;;3.0; Surgery ;**38,62,70,50,95,123,129,134,153,160,163**;24 Jun 93;Build 2
+2 ;** NOTICE: This routine is part of an implementation of a nationally
+3 ;** controlled procedure. Local modifications to this routine
+4 ;** are prohibited.
+5 ;
+6 SET SRSOUT=0
WRITE @IOF,!,"SUMMARY REPORT FOR SURGICAL SERVICE"
+7 WRITE !!,"Enter date range for data to be included on report."
SDATE ; enter starting date
+1 WRITE !,"Start with date: "
READ X:DTIME
IF '$TEST!(X["^")!(X="")
SET SRSOUT=1
GOTO END
+2 IF X["?"
WRITE !,"Enter the EARLIEST date for data to be included in this report."
SET X="?"
SET %DT="EX"
DO ^%DT
GOTO SDATE
+3 SET %DT="EXP"
DO ^%DT
IF Y<1
GOTO SDATE
SET SRSTART=Y
+4 IF SRSTART>DT
WRITE !!,"Cannot report on operations for future dates !",!
GOTO SDATE
+5 SET SRAC=$ORDER(^SRF("AC",0))
IF SRSTART<SRAC
SET Y=SRAC
DO DD^%DT
SET SRAC1=$EXTRACT(Y,1,12)
WRITE !!,"NOTE: ",$SELECT(SRAC:"No surgical case data exists before "_SRAC1_".",1:"There are no surgical cases on record !")
EDATE ; enter ending date
+1 WRITE !!,"End with date: "
READ X:DTIME
IF '$TEST!(X["^")!(X="")
SET SRSOUT=1
GOTO END
+2 IF X["?"
WRITE !,"Enter the LATEST date for data to be included in this report."
SET X="?"
SET %DT="EX"
DO ^%DT
GOTO EDATE
+3 SET %DT="EXP"
DO ^%DT
IF Y<1
GOTO EDATE
SET SREND=Y
+4 IF SRSTART>SREND
WRITE !!,"The ENDING date must be later than the BEGINNING date. Please try again.",!
GOTO SDATE
+5 IF SREND>DT
WRITE !!,"Cannot report on operations for future dates !",!
GOTO EDATE
+6 SET SRFLG=0
+7 NEW SRINSTP
SET SRINST=$$INST^SROUTL0()
IF SRINST="^"
GOTO END
SET SRINSTP=$PIECE(SRINST,U)
SET SRINST=$SELECT(SRINST["ALL DIVISIONS":SRINST,1:$PIECE(SRINST,U,2))
IO WRITE !
KILL %ZIS,IO("Q"),POP
SET %ZIS("A")="Print report on which Device: "
SET %ZIS="Q"
DO ^%ZIS
IF POP
SET SRSOUT=1
GOTO END
+1 IF $DATA(IO("Q"))
KILL IO("Q")
SET ZTDESC="Summary Report - Surgical Service"
SET (ZTSAVE("SRSTART"),ZTSAVE("SRINSTP"),ZTSAVE("SREND"),ZTSAVE("SRFLG"))=""
SET ZTRTN="EN^SROQ2"
DO ^%ZTLOAD
SET SRSOUT=1
GOTO END
EN ; entry point when queued
+1 DO SET
DO ^SROQ1
DO END
+2 QUIT
SET ; collect data
+1 SET SRSD=SRSTART-.0001
SET SRED=SREND+.9999
DO ZERO
+2 NEW SRXX
SET SRXX=$$SITE^SROVAR
+3 IF SRFLG=1
Begin DoDot:1
+4 IF SRMULT
Begin DoDot:2
+5 IF 'SRIEN
SET SRINST=$PIECE(SRXX,"^",2)
SET SRSTATN=$PIECE(SRXX,"^",3)
+6 IF '$DATA(SRINSTP)
SET SRINSTP="ALL DIVISIONS"
SET SRINST=SRINST_" - ALL DIVISIONS"
End DoDot:2
QUIT
+7 SET SRINSTP=$PIECE(SRXX,"^")
SET SRINST=$PIECE(SRXX,"^",2)
SET SRSTATN=+$PIECE(SRXX,"^",3)
End DoDot:1
+8 IF 'SRFLG
Begin DoDot:1
+9 IF SRINSTP["ALL DIV"
SET SRINST=$PIECE(SRXX,"^",2)_" - ALL DIVISIONS"
SET SRSTATN=$PIECE(SRXX,"^",3)
QUIT
+10 SET SRINST=$$GET1^DIQ(4,SRINSTP,.01)
SET SRSTATN=$$GET1^DIQ(4,SRINSTP,99)
End DoDot:1
+11 FOR
SET SRSD=$ORDER(^SRF("AC",SRSD))
IF SRSD>SRED!('SRSD)
QUIT
SET SRTN=0
FOR
SET SRTN=$ORDER(^SRF("AC",SRSD,SRTN))
IF 'SRTN
QUIT
IF $DATA(^SRF(SRTN,0))
IF $$MANDIV^SROUTL0(SRINSTP,SRTN)
DO CASE
+12 DO MORT^SROQ1A
DO DEATH
SET Y=SRSTART
DO DD^%DT
SET SRSD=$EXTRACT(Y,1,12)
SET Y=SREND
DO DD^%DT
SET SRED=$EXTRACT(Y,1,12)
SET SRYR=$EXTRACT(Y,9,12)
IF SRFLG
IF $EXTRACT(SRSTART,4,5)=10
SET SRYR=SRYR+1
+13 QUIT
END WRITE !
IF 'SRSOUT
IF $EXTRACT(IOST,1,2)="C-"
WRITE !!,"Press <RET> to continue "
READ X:DTIME
+1 DO KTMP
IF $EXTRACT(IOST)="P"
WRITE @IOF
IF $DATA(ZTQUEUED)
IF $GET(ZTSTOP)
QUIT
SET ZTREQ="@"
QUIT
+2 DO ^SRSKILL
+3 KILL SR14,SR71,SR72,SR73,SRADMT,SRHAIR,SRHOSP,SRICNR,SRICNE,SRICNO,SRICY,SRIDP,SRINSTP,SRINV,SRIOSTAT,SRTN,SRTONE,SRTONO,SRTOV,SRVER,SRSCY,SRSCNR,SRSCNO,SRSCNE
+4 DO ^%ZISC
WRITE @IOF
+5 QUIT
KTMP FOR I="SRDEATH","SRDPT","SRDREL","SRDTH","SREXP","SRINOUT","SRIOD","SRP","SRPROC","SRREL","SRSP","SRSS","SRTN"
KILL ^TMP(I,$JOB)
+1 QUIT
CASE ; examine case
+1 IF $PIECE($GET(^SRF(SRTN,30)),"^")!'$PIECE($GET(^SRF(SRTN,.2)),"^",12)!($PIECE($GET(^SRF(SRTN,"NON")),"^")="Y")
QUIT
+2 SET SRCASES=SRCASES+1
DO ^SROQ0
+3 QUIT
ZERO ; set counters to 0
+1 SET (SRTOV,SRTONO,SRTONE,SRICY,SRICNO,SRICNR,SRICNE,SRSCY,SRSCNR,SRSCNO,SRSCNE)=0
+2 DO KTMP
SET (SR60,SRADMT,SRCASES,SRCOMP,SRDPT,SREMERG,SRIN,SRINPAT,SRIX,SRMAJOR,SRMORT,SROPD,SRSOUT,SRWC)=0
FOR I=1:1:7
SET SRASA(I)=0
+3 SET SRSS=0
FOR I=48:1:62,78
SET SRSPEC(I)=I
SET ^TMP("SRSS",$JOB,I)="0^0^0^0"
SET SREXP(I)=0
+4 SET ^TMP("SRSS",$JOB,"ZZ")="0^0^0^0"
SET SREXP("ZZ")=0
+5 KILL SRATT
FOR I=9:1:14,99
SET (SRATT(I),SRATT("J",I),SRATT("N",I))=0
+6 FOR SRPROC=1:1:12
SET ^TMP("SRPROC",$JOB,SRPROC)="0^0"
SET SRDEATH(SRPROC)=0
+7 SET (SRINV("I"),SRINV("O"))=0
FOR I=1:1:38
SET SRC(I)=0
+8 FOR I="C","D","N","P","S","U","O","ZZ"
SET SRHAIR(I)=0
+9 QUIT
DEATH ; tabulate deaths
+1 SET SRED=SREND+.9999
SET SRSD=SRSTART-.0001
SET DFN=0
FOR
SET DFN=$ORDER(^TMP("SREXP",$JOB,DFN))
IF 'DFN
QUIT
DO SPEC
+2 SET SRSS=0
FOR
SET SRSS=$ORDER(SREXP(SRSS))
IF SRSS=""
QUIT
SET ^TMP("SRSS",$JOB,SRSS)=^TMP("SRSS",$JOB,SRSS)_"^"_SREXP(SRSS)
+3 SET DFN=0
FOR
SET DFN=$ORDER(^TMP("SRDEATH",$JOB,DFN))
IF 'DFN
QUIT
DO IP
+4 FOR J=1:1:12
SET ^TMP("SRPROC",$JOB,J)=^TMP("SRPROC",$JOB,J)_"^"_SRDEATH(J)
+5 SET DFN=0
FOR
SET DFN=$ORDER(^TMP("SRIOD",$JOB,DFN))
IF 'DFN
QUIT
DO INOUT
+6 QUIT
SPEC ; determine related specialty
+1 IF $ORDER(^TMP("SRSP",$JOB,DFN,0))=""
SET Y=^TMP("SREXP",$JOB,DFN)
SET SRTN=$PIECE(Y,"^")
SET SRSS=$PIECE(Y,"^",2)
SET SRDT=$PIECE(^SRF(SRTN,0),"^",9)
IF SRDT>SRED!(SRDT<SRSD)
QUIT
SET SREXP(SRSS)=SREXP(SRSS)+1
SET SRMORT=SRMORT+1
QUIT
+2 SET SRDT=$ORDER(^TMP("SRSP",$JOB,DFN,0))
IF (9999999-SRDT)'>SRED&((9999999-SRDT)'<SRSD)
SET SRSS=^TMP("SRSP",$JOB,DFN,SRDT)
SET SREXP(SRSS)=SREXP(SRSS)+1
SET SRMORT=SRMORT+1
+3 QUIT
IP ; determine related index procedure (if any)
+1 IF $ORDER(^TMP("SRP",$JOB,DFN,0))=""
SET Y=^TMP("SRDEATH",$JOB,DFN)
SET SRTN=$PIECE(Y,"^")
SET SRPROC=$PIECE(Y,"^",2)
SET SRDT=$PIECE(^SRF(SRTN,0),"^",9)
IF SRDT>SRED!(SRDT<SRSD)
QUIT
SET SRDEATH(SRPROC)=SRDEATH(SRPROC)+1
QUIT
+2 SET SRDT=$ORDER(^TMP("SRP",$JOB,DFN,0))
IF (9999999-SRDT)'>SRED&((9999999-SRDT)'<SRSD)
SET SRPROC=^TMP("SRP",$JOB,DFN,SRDT)
SET SRDEATH(SRPROC)=SRDEATH(SRPROC)+1
+3 QUIT
INOUT ; decide if death is in or out-pat surgery death
+1 SET SRIOSTAT=""
IF $ORDER(^TMP("SRINOUT",$JOB,DFN,0))=""
SET Y=^TMP("SRIOD",$JOB,DFN)
SET SRTN=$PIECE(Y,"^")
SET SRIOSTAT=$PIECE(Y,"^",2)
SET SRDT=$PIECE(^SRF(SRTN,0),"^",9)
IF SRDT>SRED!(SRDT<SRSD)!(SRIOSTAT'="O")
QUIT
SET SROPD=SROPD+1
QUIT
+2 SET SRDT=$ORDER(^TMP("SRINOUT",$JOB,DFN,0))
SET SRIOSTAT=^TMP("SRINOUT",$JOB,DFN,SRDT)
IF (9999999-SRDT)'>SRED&((9999999-SRDT)'<SRSD)&(SRIOSTAT="O")
SET SROPD=SROPD+1
+3 QUIT
