SROQ2.m

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