SRSCAN0 ;B'HAM ISC/MAM - CANCEL SCHEDULED OPERATIONS (CONT) ;03/21/02 10:24 PM
;;3.0; Surgery ;**34,42,67,103,107,114,100,144**;24 Jun 93
;
; Reference to ^TMP("CSLSUR1" supported by DBIA #3498
;
CUT S X1=SRSDATE,X2=-1 D C^%DTC S SRSDT=X,X=$P($G(^SRO(133,SRSITE,0)),"^",12) S SRTIME=SRSDT_"."_$S(X'="":X,1:1500)
S SRTYPE=$P(^SRF(SRTN,0),"^",10) I SRTYPE="S" W !!,"Case schedule type is STANDBY. "
D NOW^%DTC S SRN=+$E(%,1,12) I SRTYPE'="S",SRN'<SRTIME G SWAP
S SRBOTH=0 I $P($G(^SRF(SRTN,"CON")),"^") S SRBOTH=1
REQ I 'SRBOTH D ^SRSCG
S SRSCHST=$P($G(^SRF(SRTN,31)),"^",4) K:SRSCHST&SRSOR ^SRF("AMM",SRSOR,SRSCHST,SRTN)
S $P(^SRF(SRTN,31),"^",4)="",$P(^SRF(SRTN,31),"^",5)="",^SRF(SRTN,"REQ")=1,^SRF("AR",SRSDATE,DFN,SRTN)="",^TMP("SRPFSS",$J)=""
K DR S DA=SRTN,DR=".02///@",DIE=130 D ^DIE K DR D OERR
I '$P($G(^SRF(SRTN,"1.0")),"^",11) D
.N SREQ
.S SREQ(130,SRTN_",",1.098)=+SRN,SREQ(130,SRTN_",",1.099)=DUZ
.D FILE^DIE("","SREQ","^TMP(""SR"",$J)")
W !!,"Case #"_SRTN_" has been removed from the schedule and changed to a request."
I SRBOTH G ASK
PRESS W ! K DIR S DIR(0)="E" D ^DIR
Q
ASK S SRBOTH=0 W !!,"There is a concurrent case associated with this operation. Do you want to",!,"remove it from the schedule also ? YES// " R SRYN:DTIME I '$T!(SRYN["^") S SRYN="N"
S SRYN=$E(SRYN) S:SRYN="" SRYN="Y"
I "YyNn"'[SRYN W !!,"If you want to remove both cases from the schedule, enter 'YES'. If you",!,"answer 'NO', the cases will no longer be associated with each other." G ASK
I "Yy"[SRYN S SRTN=$P(^SRF(SRTN,"CON"),"^") G REQ
NOCC ; no longer concurrent cases
S DA=$P(^SRF(SRTN,"CON"),"^"),DIE=130,DR="35///@" D ^DIE S SROERR=DA D ^SROERR0 S DA=SRTN D ^DIE,OERR,UNLOCK^SROUTL(DA)
Q
SWAP ; move data into a new entry and set up the cancel date in the old
W ! K DIR S DIR(0)="130,18",DIR("A")="Cancellation Reason" D ^DIR S SRSCAN=$P(Y,"^") I $D(DIRUT) W !!,"Case NOT cancelled." D PRESS G END
K DR S SRCON=0,DA=SRTN,DR=".02///@;102///@;235///@;284///@;323///@;18////"_SRSCAN_";67T;70////"_DUZ,DIE=130 D ^DIE S:$D(DTOUT)!$D(DUOUT) SRSOUT=1
S SRSCHST=$P($G(^SRF(SRTN,31)),"^",4),AVOID=$P(^(30),"^",2)
I '$P($G(^SRF(SRTN,"CON")),"^") D ^SRSCG
S SRSDPT=$P(^SRF(SRTN,0),"^"),SRSOP=$P(^SRF(SRTN,"OP"),"^")
S SRSSET=$P(^SRF(SRTN,31),"^",5),$P(^SRF(SRTN,31),"^",4)="",$P(^SRF(SRTN,31),"^",5)=""
SWAP2 K:SRSCHST&SRSOR ^SRF("AMM",SRSOR,SRSCHST,SRTN) D NOW^%DTC S $P(^SRF(SRTN,30),"^")=$E(%,1,12)
I '$P($G(^SRF(SRTN,"CON")),"^") D OERR
I SRSCAN'="" G:$P(^SRO(135,SRSCAN,0),"^",2)="D" CON
D:'SRSOUT ^SRSCAN2
CON I '$D(SRSCC),$D(^SRF(SRTN,"CON")),$P(^("CON"),"^")'="" D CANCC^SRSUTL2 Q:SRBOTH="^"!SRSOUT I SRBOTH=1 G CON1
I SRCON'=0,SRTNEW'=SRCON K DR S DA=SRTNEW,DIE=130,DR="35////"_SRCON D ^DIE S DA=SRCON,DR="35////"_SRTNEW D ^DIE K DR S SROERR=SRCON D ^SROERR0
I $G(SRDEAD)=0,$G(SRBOTH)=1,$G(SRSCC)=1 S SROERR=$P(^SRF(SRTN,"CON"),"^") D ^SROERR0 S SROERR=SRTN,^TMP("CSLSUR1",$J)="" D ^SROERR0
END D UNLOCK^SROUTL(SRTN),^SRSKILL K SRTN W @IOF
Q
CON1 I SRDEAD=0 G SWAP2
K DR S DA=SRTN,DR=".02///@;102///@;235///@;284///@;323///@;18///"_$P(^SRO(135,SRSCAN,0),"^")_";67///"_AVOID_";70////"_DUZ,DIE=130 D ^DIE
D NOW^%DTC S $P(^SRF(SRTN,30),"^")=$E(%,1,12),$P(^SRF(SRTN,31),"^",4)="",$P(^SRF(SRTN,31),"^",5)=""
OERR ; update ORDER file (100)
S SROERR=SRTN K SRTX D ^SROERR0
Q
SRSCAN0 ;B'HAM ISC/MAM - CANCEL SCHEDULED OPERATIONS (CONT) ;03/21/02 10:24 PM
+1 ;;3.0; Surgery ;**34,42,67,103,107,114,100,144**;24 Jun 93
+2 ;
+3 ; Reference to ^TMP("CSLSUR1" supported by DBIA #3498
+4 ;
CUT SET X1=SRSDATE
SET X2=-1
DO C^%DTC
SET SRSDT=X
SET X=$PIECE($GET(^SRO(133,SRSITE,0)),"^",12)
SET SRTIME=SRSDT_"."_$SELECT(X'="":X,1:1500)
+1 SET SRTYPE=$PIECE(^SRF(SRTN,0),"^",10)
IF SRTYPE="S"
WRITE !!,"Case schedule type is STANDBY. "
+2 DO NOW^%DTC
SET SRN=+$EXTRACT(%,1,12)
IF SRTYPE'="S"
IF SRN'<SRTIME
GOTO SWAP
+3 SET SRBOTH=0
IF $PIECE($GET(^SRF(SRTN,"CON")),"^")
SET SRBOTH=1
REQ IF 'SRBOTH
DO ^SRSCG
+1 SET SRSCHST=$PIECE($GET(^SRF(SRTN,31)),"^",4)
IF SRSCHST&SRSOR
KILL ^SRF("AMM",SRSOR,SRSCHST,SRTN)
+2 SET $PIECE(^SRF(SRTN,31),"^",4)=""
SET $PIECE(^SRF(SRTN,31),"^",5)=""
SET ^SRF(SRTN,"REQ")=1
SET ^SRF("AR",SRSDATE,DFN,SRTN)=""
SET ^TMP("SRPFSS",$JOB)=""
+3 KILL DR
SET DA=SRTN
SET DR=".02///@"
SET DIE=130
DO ^DIE
KILL DR
DO OERR
+4 IF '$PIECE($GET(^SRF(SRTN,"1.0")),"^",11)
Begin DoDot:1
+5 NEW SREQ
+6 SET SREQ(130,SRTN_",",1.098)=+SRN
SET SREQ(130,SRTN_",",1.099)=DUZ
+7 DO FILE^DIE("","SREQ","^TMP(""SR"",$J)")
End DoDot:1
+8 WRITE !!,"Case #"_SRTN_" has been removed from the schedule and changed to a request."
+9 IF SRBOTH
GOTO ASK
PRESS WRITE !
KILL DIR
SET DIR(0)="E"
DO ^DIR
+1 QUIT
ASK SET SRBOTH=0
WRITE !!,"There is a concurrent case associated with this operation. Do you want to",!,"remove it from the schedule also ? YES// "
READ SRYN:DTIME
IF '$TEST!(SRYN["^")
SET SRYN="N"
+1 SET SRYN=$EXTRACT(SRYN)
IF SRYN=""
SET SRYN="Y"
+2 IF "YyNn"'[SRYN
WRITE !!,"If you want to remove both cases from the schedule, enter 'YES'. If you",!,"answer 'NO', the cases will no longer be associated with each other."
GOTO ASK
+3 IF "Yy"[SRYN
SET SRTN=$PIECE(^SRF(SRTN,"CON"),"^")
GOTO REQ
NOCC ; no longer concurrent cases
+1 SET DA=$PIECE(^SRF(SRTN,"CON"),"^")
SET DIE=130
SET DR="35///@"
DO ^DIE
SET SROERR=DA
DO ^SROERR0
SET DA=SRTN
DO ^DIE
DO OERR
DO UNLOCK^SROUTL(DA)
+2 QUIT
SWAP ; move data into a new entry and set up the cancel date in the old
+1 WRITE !
KILL DIR
SET DIR(0)="130,18"
SET DIR("A")="Cancellation Reason"
DO ^DIR
SET SRSCAN=$PIECE(Y,"^")
IF $DATA(DIRUT)
WRITE !!,"Case NOT cancelled."
DO PRESS
GOTO END
+2 KILL DR
SET SRCON=0
SET DA=SRTN
SET DR=".02///@;102///@;235///@;284///@;323///@;18////"_SRSCAN_";67T;70////"_DUZ
SET DIE=130
DO ^DIE
IF $DATA(DTOUT)!$DATA(DUOUT)
SET SRSOUT=1
+3 SET SRSCHST=$PIECE($GET(^SRF(SRTN,31)),"^",4)
SET AVOID=$PIECE(^(30),"^",2)
+4 IF '$PIECE($GET(^SRF(SRTN,"CON")),"^")
DO ^SRSCG
+5 SET SRSDPT=$PIECE(^SRF(SRTN,0),"^")
SET SRSOP=$PIECE(^SRF(SRTN,"OP"),"^")
+6 SET SRSSET=$PIECE(^SRF(SRTN,31),"^",5)
SET $PIECE(^SRF(SRTN,31),"^",4)=""
SET $PIECE(^SRF(SRTN,31),"^",5)=""
SWAP2 IF SRSCHST&SRSOR
KILL ^SRF("AMM",SRSOR,SRSCHST,SRTN)
DO NOW^%DTC
SET $PIECE(^SRF(SRTN,30),"^")=$EXTRACT(%,1,12)
+1 IF '$PIECE($GET(^SRF(SRTN,"CON")),"^")
DO OERR
+2 IF SRSCAN'=""
IF $PIECE(^SRO(135,SRSCAN,0),"^",2)="D"
GOTO CON
+3 IF 'SRSOUT
DO ^SRSCAN2
CON IF '$DATA(SRSCC)
IF $DATA(^SRF(SRTN,"CON"))
IF $PIECE(^("CON"),"^")'=""
DO CANCC^SRSUTL2
IF SRBOTH="^"!SRSOUT
QUIT
IF SRBOTH=1
GOTO CON1
+1 IF SRCON'=0
IF SRTNEW'=SRCON
KILL DR
SET DA=SRTNEW
SET DIE=130
SET DR="35////"_SRCON
DO ^DIE
SET DA=SRCON
SET DR="35////"_SRTNEW
DO ^DIE
KILL DR
SET SROERR=SRCON
DO ^SROERR0
+2 IF $GET(SRDEAD)=0
IF $GET(SRBOTH)=1
IF $GET(SRSCC)=1
SET SROERR=$PIECE(^SRF(SRTN,"CON"),"^")
DO ^SROERR0
SET SROERR=SRTN
SET ^TMP("CSLSUR1",$JOB)=""
DO ^SROERR0
END DO UNLOCK^SROUTL(SRTN)
DO ^SRSKILL
KILL SRTN
WRITE @IOF
+1 QUIT
CON1 IF SRDEAD=0
GOTO SWAP2
+1 KILL DR
SET DA=SRTN
SET DR=".02///@;102///@;235///@;284///@;323///@;18///"_$PIECE(^SRO(135,SRSCAN,0),"^")_";67///"_AVOID_";70////"_DUZ
SET DIE=130
DO ^DIE
+2 DO NOW^%DTC
SET $PIECE(^SRF(SRTN,30),"^")=$EXTRACT(%,1,12)
SET $PIECE(^SRF(SRTN,31),"^",4)=""
SET $PIECE(^SRF(SRTN,31),"^",5)=""
OERR ; update ORDER file (100)
+1 SET SROERR=SRTN
KILL SRTX
DO ^SROERR0
+2 QUIT
