SROPSN.m

SROPSN ;B'HAM ISC/MAM - SELECT CASE ; [ 06/19/03  3:22 PM ]

 ;;3.0; Surgery ;**121**;24 Jun 93

 N SROPZ S SROPZ=SROP D HDR I $D(DUZ("SAV")) K SRNEWOP

 ;;;I $D(SRCASE(1)) S SRTN=+SRCASE(1) Q

ADT W ! S (SRDT,CNT)=0 F  S SRDT=$O(^SRF("ADT",DFN,SRDT)) Q:'SRDT!SRSOUT!$D(SRTN)  S SROP=0 F  S SROP=$O(^SRF("ADT",DFN,SRDT,SROP)) Q:'SROP!$D(SRTN)!SRSOUT  I SROPZ=SROP D LIST

 G:'$D(SRNEWOP)&SRSOUT END D:SRSOUT HDR I $D(SRTN) G FUTURE

 I '$D(SRNEWOP),'$D(SRCASE(1)) D  W !!,"Press RETURN to continue  " R X:DTIME G END

 .W !!,$S($P($G(^SRF(SROPZ,"NON")),"^")="Y":"Case #"_SROPZ_" is not an O.R. surgical procedure.",1:"Case #"_SROPZ_" is not marked for exclusion from assessment.")

 S SRTN=+SRCASE(1)

 Q

FUTURE ; is this a future case? if so, OK to proceed?

 Q:$D(PRCP("I"))  ; quit if called from Inventory

 S SROP=SRTN,SRSDATE=$P(^SRF(SRTN,0),"^",9) I $E(SRSDATE,1,7)'>DT Q

 D HDR W !,?1 D CASE W !,$C(7) K DIR

 S DIR("A",1)=">>> The case you have selected has a future date.",DIR("A")="    Are you sure you have selected the correct case ? ",DIR("B")="NO",DIR(0)="YA" D ^DIR K DIR I $D(DTOUT)!$D(DUOUT) G END

 I 'Y K SRTN D HDR G ADT

 Q

LIST ; list cases

 I '$D(SRNONOR),$P($G(^SRF(SROP,"NON")),"^")="Y" Q

 S SRSCAN=1 I $D(^SRF(SROP,.2)),$P(^(.2),"^",12)'="" K SRSCAN

 I $D(SRSCAN),$D(^SRF(SROP,30)),$P(^(30),"^") Q

 I $D(SRSCAN),$D(^SRF(SROP,31)),$P(^(31),"^",8) Q

 I $D(^SRF(SROP,37)),$P(^(37),"^") Q

 S CNT=CNT+1,SRSDATE=$P(^SRF(SROP,0),"^",9) W !

CASE W $E(SRSDATE,4,5)_"-"_$E(SRSDATE,6,7)_"-"_$E(SRSDATE,2,3)

 S SROPER=$P(^SRF(SROP,"OP"),"^") I $O(^SRF(SROP,13,0)) S SROTHER=0 F I=0:0 S SROTHER=$O(^SRF(SROP,13,SROTHER)) Q:'SROTHER  D OTHER

 D ^SROP1,LOCK 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 ?14,SROPS(1) I $D(SROPS(2)) W !,?14,SROPS(2) I $D(SROPS(3)) W !,?14,SROPS(3) W:$D(SROPS(4)) !,?14,SROPS(4)

 W ! S SRCASE(CNT)=SROP_"^"_SRDT

 Q

LOCK ; case locked?

 I $D(SRTN),$P($G(^SRF(SRTN,"LOCK")),"^") S SROPER=SROPER_" **LOCKED**"

 Q

OTHER ; other operations

 S SRLONG=1 I $L(SROPER)+$L($P(^SRF(SROP,13,SROTHER,0),"^"))>235 S SRLONG=0,SROTHER=999,SROPERS=" ..."

 I SRLONG S SROPERS=$P(^SRF(SROP,13,SROTHER,0),"^")

 S SROPER=SROPER_$S(SROPERS=" ...":SROPERS,1:", "_SROPERS)

 Q

LOOP ; break procedure

 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

END K SRTN D ^SRSKILL W @IOF

 Q

HDR ; print heading

 W @IOF,!,?1,VADM(1)_"   "_VA("PID") S X=$P($G(VADM(6)),"^") W:X "        * DIED "_$E(X,4,5)_"/"_$E(X,6,7)_"/"_$E(X,2,3)_" *" W !

 Q

SROPSN    ;B'HAM ISC/MAM - SELECT CASE ; [ 06/19/03  3:22 PM ]

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

 +2        NEW SROPZ

           SET SROPZ=SROP

           DO HDR

           IF $DATA(DUZ("SAV"))

               KILL SRNEWOP

 +3       ;;;I $D(SRCASE(1)) S SRTN=+SRCASE(1) Q

ADT        WRITE !

           SET (SRDT,CNT)=0

           FOR 

               SET SRDT=$ORDER(^SRF("ADT",DFN,SRDT))

               IF 'SRDT!SRSOUT!$DATA(SRTN)

                   QUIT 

               SET SROP=0

               FOR 

                   SET SROP=$ORDER(^SRF("ADT",DFN,SRDT,SROP))

                   IF 'SROP!$DATA(SRTN)!SRSOUT

                       QUIT 

                   IF SROPZ=SROP

                       DO LIST

 +1        IF '$DATA(SRNEWOP)&SRSOUT

               GOTO END

           IF SRSOUT

               DO HDR

           IF $DATA(SRTN)

               GOTO FUTURE

 +2        IF '$DATA(SRNEWOP)

               IF '$DATA(SRCASE(1))

                   Begin DoDot:1

 +3                    WRITE !!,$SELECT($PIECE($GET(^SRF(SROPZ,"NON")),"^")="Y":"Case #"_SROPZ_" is not an O.R. surgical procedure.",1:"Case #"_SROPZ_" is not marked for exclusion from assessment.")

                   End DoDot:1

                   WRITE !!,"Press RETURN to continue  "

                   READ X:DTIME

                   GOTO END

 +4        SET SRTN=+SRCASE(1)

 +5        QUIT 

FUTURE    ; is this a future case? if so, OK to proceed?

 +1       ; quit if called from Inventory

           IF $DATA(PRCP("I"))

               QUIT 

 +2        SET SROP=SRTN

           SET SRSDATE=$PIECE(^SRF(SRTN,0),"^",9)

           IF $EXTRACT(SRSDATE,1,7)'>DT

               QUIT 

 +3        DO HDR

           WRITE !,?1

           DO CASE

           WRITE !,$CHAR(7)

           KILL DIR

 +4        SET DIR("A",1)=">>> The case you have selected has a future date."

           SET DIR("A")="    Are you sure you have selected the correct case ? "

           SET DIR("B")="NO"

           SET DIR(0)="YA"

           DO ^DIR

           KILL DIR

           IF $DATA(DTOUT)!$DATA(DUOUT)

               GOTO END

 +5        IF 'Y

               KILL SRTN

               DO HDR

               GOTO ADT

 +6        QUIT 

LIST      ; list cases

 +1        IF '$DATA(SRNONOR)

               IF $PIECE($GET(^SRF(SROP,"NON")),"^")="Y"

                   QUIT 

 +2        SET SRSCAN=1

           IF $DATA(^SRF(SROP,.2))

               IF $PIECE(^(.2),"^",12)'=""

                   KILL SRSCAN

 +3        IF $DATA(SRSCAN)

               IF $DATA(^SRF(SROP,30))

                   IF $PIECE(^(30),"^")

                       QUIT 

 +4        IF $DATA(SRSCAN)

               IF $DATA(^SRF(SROP,31))

                   IF $PIECE(^(31),"^",8)

                       QUIT 

 +5        IF $DATA(^SRF(SROP,37))

               IF $PIECE(^(37),"^")

                   QUIT 

 +6        SET CNT=CNT+1

           SET SRSDATE=$PIECE(^SRF(SROP,0),"^",9)

           WRITE !

CASE       WRITE $EXTRACT(SRSDATE,4,5)_"-"_$EXTRACT(SRSDATE,6,7)_"-"_$EXTRACT(SRSDATE,2,3)

 +1        SET SROPER=$PIECE(^SRF(SROP,"OP"),"^")

           IF $ORDER(^SRF(SROP,13,0))

               SET SROTHER=0

               FOR I=0:0

                   SET SROTHER=$ORDER(^SRF(SROP,13,SROTHER))

                   IF 'SROTHER

                       QUIT 

                   DO OTHER

 +2        DO ^SROP1

           DO LOCK

           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 ?14,SROPS(1)

           IF $DATA(SROPS(2))

               WRITE !,?14,SROPS(2)

               IF $DATA(SROPS(3))

                   WRITE !,?14,SROPS(3)

                   IF $DATA(SROPS(4))

                       WRITE !,?14,SROPS(4)

 +4        WRITE !

           SET SRCASE(CNT)=SROP_"^"_SRDT

 +5        QUIT 

LOCK      ; case locked?

 +1        IF $DATA(SRTN)

               IF $PIECE($GET(^SRF(SRTN,"LOCK")),"^")

                   SET SROPER=SROPER_" **LOCKED**"

 +2        QUIT 

OTHER     ; other operations

 +1        SET SRLONG=1

           IF $LENGTH(SROPER)+$LENGTH($PIECE(^SRF(SROP,13,SROTHER,0),"^"))>235

               SET SRLONG=0

               SET SROTHER=999

               SET SROPERS=" ..."

 +2        IF SRLONG

               SET SROPERS=$PIECE(^SRF(SROP,13,SROTHER,0),"^")

 +3        SET SROPER=SROPER_$SELECT(SROPERS=" ...":SROPERS,1:", "_SROPERS)

 +4        QUIT 

LOOP      ; break procedure

 +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 

END        KILL SRTN

           DO ^SRSKILL

           WRITE @IOF

 +1        QUIT 

HDR       ; print heading

 +1        WRITE @IOF,!,?1,VADM(1)_"   "_VA("PID")

           SET X=$PIECE($GET(VADM(6)),"^")

           IF X

               WRITE "        * DIED "_$EXTRACT(X,4,5)_"/"_$EXTRACT(X,6,7)_"/"_$EXTRACT(X,2,3)_" *"

           WRITE !

 +2        QUIT