SRSRBS.m

SRSRBS ;B'HAM ISC/MAM - REQUESTS BY SERVICE ; [ 07/27/98   2:33 PM ]

 ;;3.0; Surgery ;**50**;24 Jun 93

A W !!,"List requests by SPECIALTY or WARD ?  SPECIALTY// " R X:DTIME S:'$T X="^" S:X="" X="S"

 Q:X["^"  S X=$E(X) I "SsWw"'[X W !!,"Enter RETURN if you would like to sort requests by SURGICAL SPECIALTY, or ",!,"'WARD' to sort by the WARD location." G A

 I "Ww"[X G ^SRSRBW

BEG W !!,"Do you want requests for all surgical specialties ? YES// " R X:DTIME S:'$T X="^" S:X="" X="Y" G:X["^" END

 S X=$E(X) I "YyNn"'[X W !!,"Enter RETURN if you would like a list of requests for all surgical specialties,",!,"or 'NO' to list the requests for a specific specialty.",! G BEG

 I "Yy"[X G ^SRSRBS1

 W ! K DIC S DIC("S")="I '$P(^(0),""^"",3)",DIC=137.45,DIC("A")="List Requests for which Specialty ? ",DIC(0)="QEAMZ" D ^DIC K DIC G:Y<0 END S SRS=+Y,SRS("N")=$P(Y(0),"^"),SRS("C")=$P(Y(0),"^",2)

 W ! K IOP,%ZIS,POP,IO("Q") S %ZIS("A")="Print the Report on which Device: ",%ZIS="Q" D ^%ZIS G:POP END

 I $D(IO("Q")) K IO("Q") S ZTDESC="Requests by Service",ZTRTN="SER^SRSRBS",(ZTSAVE("DT"),ZTSAVE("SRS"),ZTSAVE("SRS(""N"")"),ZTSAVE("SRSITE*"))="" D ^%ZTLOAD G END

SER ; entry when queued

 S X="T-1" D ^%DT S SRSDATE=Y,(DFN,SRTN,SRQ)=0 K ^TMP("SR",$J)

 F  S SRSDATE=$O(^SRF("AR",SRSDATE)) Q:'SRSDATE  F  S DFN=$O(^SRF("AR",SRSDATE,DFN)) Q:'DFN  F  S SRTN=$O(^SRF("AR",SRSDATE,DFN,SRTN)) Q:'SRTN  I $$DIV^SROUTL0(SRTN),$P(^SRF(SRTN,0),"^",4)=SRS D SETUTL

WLIST ; get waiting list patients

 S (COUNT,SRSDATE)=0

 S SRSS=$O(^SRO(133.8,"B",SRS,0)) I SRSS F  S SRSDATE=$O(^SRO(133.8,"AWL",SRSS,SRSDATE)) Q:'SRSDATE  S SRWL=0 F  S SRWL=$O(^SRO(133.8,"AWL",SRSS,SRSDATE,SRWL)) Q:'SRWL  D SETUTL1

UTL ; loop through ^TMP("SR",$J) and print data

 U IO D HDR S (SRSDATE,SRTN)=0 F  S SRSDATE=$O(^TMP("SR",$J,SRSDATE)) Q:SRSDATE=""!SRQ  F  S SRTN=$O(^TMP("SR",$J,SRSDATE,SRTN)) Q:SRTN=""!SRQ  D PRINT

 I 'SRQ,$E(IOST)'="P" W !!,"Press RETURN to continue  " R X:DTIME

END W:$E(IOST)="P" @IOF I $D(ZTQUEUED) K ^TMP("SR",$J) Q:$G(ZTSTOP)  S ZTREQ="@" Q

 D ^SRSKILL K SRTN D ^%ZISC W @IOF

 Q

LOOP ; break procedure if greater than 65 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)'<65  S SROPS(M)=SROPS(M)_MM_" ",SROPER=MMM

 Q

SETUTL ; set ^TMP("SR",$J)

 D DEM^VADPT S SRNM=VADM(1),SRSSN=VA("PID"),SRSOP=$P(^SRF(SRTN,"OP"),"^"),SRWARD=$S($D(^DPT(DFN,.1)):$P(^(.1),"^"),1:""),Y=SRSDATE D D^DIQ S SRDATE=Y

 I SRWARD="" D WARD

 S ^TMP("SR",$J,SRSDATE,SRTN)=SRDATE_"^"_SRNM_"^"_SRWARD_"^"_SRSOP_"^"_SRSSN

 Q

SETUTL1 ; set ^TMP("SR",$J) with waiting list info

 S DFN=+^SRO(133.8,SRSS,1,SRWL,0),SRSOP=$P(^(0),"^",2)

 S SRWARD=$S($D(^DPT(DFN,.1)):$P(^(.1),"^"),1:"") D DEM^VADPT S SRNM=VADM(1),SRSSN=VA("PID"),COUNT=COUNT+1

 I SRWARD="" D WARD

 S ^TMP("SR",$J,"WL","WL"_COUNT)="WAITING LIST^"_SRNM_"^"_SRWARD_"^"_SRSOP_"^"_SRSSN

 Q

PRINT ; print information

 I $Y+6>IOSL D PAGE Q:SRQ  D HDR Q:SRQ

 S STBY=^TMP("SR",$J,SRSDATE,SRTN),SROPER=$P(STBY,"^",4) K SROPS,MM,MMM S:$L(SROPER)<65 SROPS(1)=SROPER I $L(SROPER)>64 S SROPER=SROPER_"  " F M=1:1 D LOOP Q:MMM=""

 W !,$P(STBY,"^"),?14,$P(STBY,"^",2),?45,$P(STBY,"^",3),!,SRTN,?14,$P(STBY,"^",5),!,?14,SROPS(1) I $D(SROPS(2)) W !,?14,SROPS(2) I $D(SROPS(3)) W !,?14,SROPS(3)

 W ! F LINE=1:1:80 W "-"

 Q

HDR ; print heading

 I $D(ZTQUEUED) D ^SROSTOP I SRHALT S SRQ=1 Q

 W:$Y @IOF W !,?5,"Operative Requests for "_SRS("N"),!!,"Date",?14,"Patient",?45,"Ward Location",!,"Case Number",?14,"ID #",!,?14,"Operative Procedure",! F LINE=1:1:80 W "="

 Q

PAGE ; end of screen

 I $E(IOST,1)'="P" W !!,"Press RETURN to continue or '^' to quit.  " R X:DTIME I '$T!(X="^") S SRQ=1

 Q

WARD ; check for scheduled admission

 S (X,PEND)=0 F  S PEND=$O(^DGS(41.1,"B",DFN,PEND)) Q:'PEND  S PDATE=$P(^DGS(41.1,PEND,0),"^",2) I PDATE>DT S SRWARD="ADM. PENDING",X=1

 Q:X=1  S SRWARD="OUTPATIENT"

 Q

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---SRSRBS   3912     printed  Feb 19, 2025@00:14:07                                                                                                                                                                                                      Page 2

SRSRBS    ;B'HAM ISC/MAM - REQUESTS BY SERVICE ; [ 07/27/98   2:33 PM ]

 +1       ;;3.0; Surgery ;**50**;24 Jun 93

A          WRITE !!,"List requests by SPECIALTY or WARD ?  SPECIALTY// "

           READ X:DTIME

           if '$TEST

               SET X="^"

           if X=""

               SET X="S"

 +1        if X["^"

               QUIT 

           SET X=$EXTRACT(X)

           IF "SsWw"'[X

               WRITE !!,"Enter RETURN if you would like to sort requests by SURGICAL SPECIALTY, or ",!,"'WARD' to sort by the WARD location."

               GOTO A

 +2        IF "Ww"[X

               GOTO ^SRSRBW

BEG        WRITE !!,"Do you want requests for all surgical specialties ? YES// "

           READ X:DTIME

           if '$TEST

               SET X="^"

           if X=""

               SET X="Y"

           if X["^"

               GOTO END

 +1        SET X=$EXTRACT(X)

           IF "YyNn"'[X

               WRITE !!,"Enter RETURN if you would like a list of requests for all surgical specialties,",!,"or 'NO' to list the requests for a specific specialty.",!

               GOTO BEG

 +2        IF "Yy"[X

               GOTO ^SRSRBS1

 +3        WRITE !

           KILL DIC

           SET DIC("S")="I '$P(^(0),""^"",3)"

           SET DIC=137.45

           SET DIC("A")="List Requests for which Specialty ? "

           SET DIC(0)="QEAMZ"

           DO ^DIC

           KILL DIC

           if Y<0

               GOTO END

           SET SRS=+Y

           SET SRS("N")=$PIECE(Y(0),"^")

           SET SRS("C")=$PIECE(Y(0),"^",2)

 +4        WRITE !

           KILL IOP,%ZIS,POP,IO("Q")

           SET %ZIS("A")="Print the Report on which Device: "

           SET %ZIS="Q"

           DO ^%ZIS

           if POP

               GOTO END

 +5        IF $DATA(IO("Q"))

               KILL IO("Q")

               SET ZTDESC="Requests by Service"

               SET ZTRTN="SER^SRSRBS"

               SET (ZTSAVE("DT"),ZTSAVE("SRS"),ZTSAVE("SRS(""N"")"),ZTSAVE("SRSITE*"))=""

               DO ^%ZTLOAD

               GOTO END

SER       ; entry when queued

 +1        SET X="T-1"

           DO ^%DT

           SET SRSDATE=Y

           SET (DFN,SRTN,SRQ)=0

           KILL ^TMP("SR",$JOB)

 +2        FOR 

               SET SRSDATE=$ORDER(^SRF("AR",SRSDATE))

               if 'SRSDATE

                   QUIT 

               FOR 

                   SET DFN=$ORDER(^SRF("AR",SRSDATE,DFN))

                   if 'DFN

                       QUIT 

                   FOR 

                       SET SRTN=$ORDER(^SRF("AR",SRSDATE,DFN,SRTN))

                       if 'SRTN

                           QUIT 

                       IF $$DIV^SROUTL0(SRTN)

                           IF $PIECE(^SRF(SRTN,0),"^",4)=SRS

                               DO SETUTL

WLIST     ; get waiting list patients

 +1        SET (COUNT,SRSDATE)=0

 +2        SET SRSS=$ORDER(^SRO(133.8,"B",SRS,0))

           IF SRSS

               FOR 

                   SET SRSDATE=$ORDER(^SRO(133.8,"AWL",SRSS,SRSDATE))

                   if 'SRSDATE

                       QUIT 

                   SET SRWL=0

                   FOR 

                       SET SRWL=$ORDER(^SRO(133.8,"AWL",SRSS,SRSDATE,SRWL))

                       if 'SRWL

                           QUIT 

                       DO SETUTL1

UTL       ; loop through ^TMP("SR",$J) and print data

 +1        USE IO

           DO HDR

           SET (SRSDATE,SRTN)=0

           FOR 

               SET SRSDATE=$ORDER(^TMP("SR",$JOB,SRSDATE))

               if SRSDATE=""!SRQ

                   QUIT 

               FOR 

                   SET SRTN=$ORDER(^TMP("SR",$JOB,SRSDATE,SRTN))

                   if SRTN=""!SRQ

                       QUIT 

                   DO PRINT

 +2        IF 'SRQ

               IF $EXTRACT(IOST)'="P"

                   WRITE !!,"Press RETURN to continue  "

                   READ X:DTIME

END        if $EXTRACT(IOST)="P"

               WRITE @IOF

           IF $DATA(ZTQUEUED)

               KILL ^TMP("SR",$JOB)

               if $GET(ZTSTOP)

                   QUIT 

               SET ZTREQ="@"

               QUIT 

 +1        DO ^SRSKILL

           KILL SRTN

           DO ^%ZISC

           WRITE @IOF

 +2        QUIT 

LOOP      ; break procedure if greater than 65 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)'<65

                   QUIT 

               SET SROPS(M)=SROPS(M)_MM_" "

               SET SROPER=MMM

 +2        QUIT 

SETUTL    ; set ^TMP("SR",$J)

 +1        DO DEM^VADPT

           SET SRNM=VADM(1)

           SET SRSSN=VA("PID")

           SET SRSOP=$PIECE(^SRF(SRTN,"OP"),"^")

           SET SRWARD=$SELECT($DATA(^DPT(DFN,.1)):$PIECE(^(.1),"^"),1:"")

           SET Y=SRSDATE

           DO D^DIQ

           SET SRDATE=Y

 +2        IF SRWARD=""

               DO WARD

 +3        SET ^TMP("SR",$JOB,SRSDATE,SRTN)=SRDATE_"^"_SRNM_"^"_SRWARD_"^"_SRSOP_"^"_SRSSN

 +4        QUIT 

SETUTL1   ; set ^TMP("SR",$J) with waiting list info

 +1        SET DFN=+^SRO(133.8,SRSS,1,SRWL,0)

           SET SRSOP=$PIECE(^(0),"^",2)

 +2        SET SRWARD=$SELECT($DATA(^DPT(DFN,.1)):$PIECE(^(.1),"^"),1:"")

           DO DEM^VADPT

           SET SRNM=VADM(1)

           SET SRSSN=VA("PID")

           SET COUNT=COUNT+1

 +3        IF SRWARD=""

               DO WARD

 +4        SET ^TMP("SR",$JOB,"WL","WL"_COUNT)="WAITING LIST^"_SRNM_"^"_SRWARD_"^"_SRSOP_"^"_SRSSN

 +5        QUIT 

PRINT     ; print information

 +1        IF $Y+6>IOSL

               DO PAGE

               if SRQ

                   QUIT 

               DO HDR

               if SRQ

                   QUIT 

 +2        SET STBY=^TMP("SR",$JOB,SRSDATE,SRTN)

           SET SROPER=$PIECE(STBY,"^",4)

           KILL SROPS,MM,MMM

           if $LENGTH(SROPER)<65

               SET SROPS(1)=SROPER

           IF $LENGTH(SROPER)>64

               SET SROPER=SROPER_"  "

               FOR M=1:1

                   DO LOOP

                   if MMM=""

                       QUIT 

 +3        WRITE !,$PIECE(STBY,"^"),?14,$PIECE(STBY,"^",2),?45,$PIECE(STBY,"^",3),!,SRTN,?14,$PIECE(STBY,"^",5),!,?14,SROPS(1)

           IF $DATA(SROPS(2))

               WRITE !,?14,SROPS(2)

               IF $DATA(SROPS(3))

                   WRITE !,?14,SROPS(3)

 +4        WRITE !

           FOR LINE=1:1:80

               WRITE "-"

 +5        QUIT 

HDR       ; print heading

 +1        IF $DATA(ZTQUEUED)

               DO ^SROSTOP

               IF SRHALT

                   SET SRQ=1

                   QUIT 

 +2        if $Y

               WRITE @IOF

           WRITE !,?5,"Operative Requests for "_SRS("N"),!!,"Date",?14,"Patient",?45,"Ward Location",!,"Case Number",?14,"ID #",!,?14,"Operative Procedure",!

           FOR LINE=1:1:80

               WRITE "="

 +3        QUIT 

PAGE      ; end of screen

 +1        IF $EXTRACT(IOST,1)'="P"

               WRITE !!,"Press RETURN to continue or '^' to quit.  "

               READ X:DTIME

               IF '$TEST!(X="^")

                   SET SRQ=1

 +2        QUIT 

WARD      ; check for scheduled admission

 +1        SET (X,PEND)=0

           FOR 

               SET PEND=$ORDER(^DGS(41.1,"B",DFN,PEND))

               if 'PEND

                   QUIT 

               SET PDATE=$PIECE(^DGS(41.1,PEND,0),"^",2)

               IF PDATE>DT

                   SET SRWARD="ADM. PENDING"

                   SET X=1

 +2        if X=1

               QUIT 

           SET SRWARD="OUTPATIENT"

 +3        QUIT