SRSCAN2 ;BIR/MAM - MAKE NEW REQUEST WHEN CANCELLED ;08/10/2011
;;3.0;Surgery;**3,16,34,67,77,88,92,103,144,176**;24 Jun 93;Build 8
START W !!,"Do you want to create a new request for this cancelled case ?? YES// " R SRYN:DTIME I '$T!(SRYN["^") Q
S SRYN=$E(SRYN) S:SRYN="" SRYN="Y"
I "YyNn"'[SRYN W !!,"Enter 'YES' to automatically move the information contained in this scheduled",!,"case to a new request, or 'NO' to not create a new request." G START
I "Yy"'[SRYN Q
D NEWDT
DATE W ! K %DT S %DT="AEFX",%DT("A")="Make the new request for which Date ? ",%DT("B")=SRY D ^%DT I Y<0 S OK=1 D HELP Q:'OK G DATE
S SRX=+Y D CHK G:$D(SRLATE) DATE S SRNEWDT=SRX W !!,"Creating the new request..."
K DA,DIC,DD,DO,DINUM S X=SRSDPT,DIC="^SRF(",DIC(0)="L",DLAYGO=130 D FILE^DICN K DD,DO,DIC,DLAYGO S SRTNEW=+Y
S %X="^SRF("_SRTOLD_",",%Y="^SRF("_SRTNEW_"," D %XY^%RCR K ^SRF(SRTNEW,"PFSS")
S SRSOP=$P(^SRF(SRTNEW,"OP"),"^"),SRSCPT=$P(^SRF(SRTNEW,"OP"),"^",2),SRSDOC=$S($D(^SRF(SRTNEW,.1)):$P(^(.1),"^",4),1:"")
K ^SRF(SRTNEW,31),^SRF(SRTNEW,30) S $P(^SRF(SRTNEW,0),"^",2)=""
N SREQ D NOW^%DTC S SREQ(130,SRTNEW_",",1.098)=+$E(%,1,12),SREQ(130,SRTNEW_",",1.099)=DUZ D FILE^DIE("","SREQ","^TMP(""SR"",$J)")
S DR="36////1;Q;.09////"_SRNEWDT_";26////"_SRSOP_";614///@;615///@;617///@",DA=SRTNEW,DIE=130 D ^DIE
K DR,DA S DR="[SRO-NOCOMP]",DA=SRTNEW,DIE=130 D ^DIE K DR
K DR S DIE=130,DA=SRTNEW,DR="68////"_SRSOP_";78////"_SRTOLD D ^DIE K DR
S SRATT=$P($G(^SRF(SRTN,.1)),"^",13)
K DIE,DR,DA S DIE=130,DA=SRTNEW,DR=".14////"_SRSDOC_";.164////"_SRATT_";.04////"_$P(^SRF(SRTN,0),"^",4) D ^DIE K DR S SRTN=SRTNEW D ^SROXRET
I $D(^SRF(SRTNEW,"CON")) S DA=SRTNEW,DIE=130,DR="35///@" D ^DIE K DR,DA
D NOW^%DTC S SRCAN=+$E(%,1,12),DA=SRTOLD,DIE=130,DR=".02///@;17////"_SRCAN_";79////"_SRTNEW D ^DIE K DR
S $P(^SRF(SRTOLD,31),"^",4)="",$P(^(31),"^",5)=""
S SRTN=SRTNEW D ^SROERR S SRTN=SRTOLD
Q
HELP W !!,"To make a new request, you must select a future date. Do you want to select",!,"another date ? YES// " R X:DTIME I '$T!(X["^") S OK=0 Q
S X=$E(X) I "YyNn"'[X W !!,"Enter 'YES' to select another date, or 'NO' to bypass making a new request." G HELP
I "Yy"'[X S OK=0
Q
NEWDT ; get six month default date for new request
S SRX1=$E($P(^SRF(SRTOLD,0),"^",9),1,7),SRX2=182 K SRCHK D DAY S Y=SRX D D^DIQ S SRY=Y
Q
CHK ; check for valid request date
N SRSDATE S SRSDATE=SRX K SRLATE D LATE^SRSREQ
Q
DAY ; get valid default request date
S X1=SRX1,X2=SRX2 D C^%DTC I X<DT S SRX1=DT,SRX2=1 G DAY
S SRX=X K DIC S DIC=40.5,DIC(0)="XM" D ^DIC K DIC
I Y'=-1,'$D(^SRO(133,SRSITE,3,X,0)) S SRX2=SRX2+1 G DAY
S X=SRX D H^%DTC S SRDAY=%Y+1 S SRDL=$P($G(^SRO(133,SRSITE,2)),"^",SRDAY) S:SRDL="" SRDL=1 I 'SRDL S SRX2=SRX2+1 G DAY
Q:'$D(SRSITE("REQ")) S X1=SRX,X2=-SRDL D C^%DTC S SRDTL=X S DIC=40.5,DIC(0)="XM" D ^DIC K DIC I Y'=-1,'$D(^SRO(133,SRSITE,3,X,0)) S SRX2=SRX2+1 G DAY
S SRTCHK=SRDTL_"."_SRSITE("REQ") D NOW^%DTC I %>SRTCHK S SRX2=SRX2+1 G DAY
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSRSCAN2 2998 printed Dec 13, 2024@02:47 Page 2
SRSCAN2 ;BIR/MAM - MAKE NEW REQUEST WHEN CANCELLED ;08/10/2011
+1 ;;3.0;Surgery;**3,16,34,67,77,88,92,103,144,176**;24 Jun 93;Build 8
START WRITE !!,"Do you want to create a new request for this cancelled case ?? YES// "
READ SRYN:DTIME
IF '$TEST!(SRYN["^")
QUIT
+1 SET SRYN=$EXTRACT(SRYN)
if SRYN=""
SET SRYN="Y"
+2 IF "YyNn"'[SRYN
WRITE !!,"Enter 'YES' to automatically move the information contained in this scheduled",!,"case to a new request, or 'NO' to not create a new request."
GOTO START
+3 IF "Yy"'[SRYN
QUIT
+4 DO NEWDT
DATE WRITE !
KILL %DT
SET %DT="AEFX"
SET %DT("A")="Make the new request for which Date ? "
SET %DT("B")=SRY
DO ^%DT
IF Y<0
SET OK=1
DO HELP
if 'OK
QUIT
GOTO DATE
+1 SET SRX=+Y
DO CHK
if $DATA(SRLATE)
GOTO DATE
SET SRNEWDT=SRX
WRITE !!,"Creating the new request..."
+2 KILL DA,DIC,DD,DO,DINUM
SET X=SRSDPT
SET DIC="^SRF("
SET DIC(0)="L"
SET DLAYGO=130
DO FILE^DICN
KILL DD,DO,DIC,DLAYGO
SET SRTNEW=+Y
+3 SET %X="^SRF("_SRTOLD_","
SET %Y="^SRF("_SRTNEW_","
DO %XY^%RCR
KILL ^SRF(SRTNEW,"PFSS")
+4 SET SRSOP=$PIECE(^SRF(SRTNEW,"OP"),"^")
SET SRSCPT=$PIECE(^SRF(SRTNEW,"OP"),"^",2)
SET SRSDOC=$SELECT($DATA(^SRF(SRTNEW,.1)):$PIECE(^(.1),"^",4),1:"")
+5 KILL ^SRF(SRTNEW,31),^SRF(SRTNEW,30)
SET $PIECE(^SRF(SRTNEW,0),"^",2)=""
+6 NEW SREQ
DO NOW^%DTC
SET SREQ(130,SRTNEW_",",1.098)=+$EXTRACT(%,1,12)
SET SREQ(130,SRTNEW_",",1.099)=DUZ
DO FILE^DIE("","SREQ","^TMP(""SR"",$J)")
+7 SET DR="36////1;Q;.09////"_SRNEWDT_";26////"_SRSOP_";614///@;615///@;617///@"
SET DA=SRTNEW
SET DIE=130
DO ^DIE
+8 KILL DR,DA
SET DR="[SRO-NOCOMP]"
SET DA=SRTNEW
SET DIE=130
DO ^DIE
KILL DR
+9 KILL DR
SET DIE=130
SET DA=SRTNEW
SET DR="68////"_SRSOP_";78////"_SRTOLD
DO ^DIE
KILL DR
+10 SET SRATT=$PIECE($GET(^SRF(SRTN,.1)),"^",13)
+11 KILL DIE,DR,DA
SET DIE=130
SET DA=SRTNEW
SET DR=".14////"_SRSDOC_";.164////"_SRATT_";.04////"_$PIECE(^SRF(SRTN,0),"^",4)
DO ^DIE
KILL DR
SET SRTN=SRTNEW
DO ^SROXRET
+12 IF $DATA(^SRF(SRTNEW,"CON"))
SET DA=SRTNEW
SET DIE=130
SET DR="35///@"
DO ^DIE
KILL DR,DA
+13 DO NOW^%DTC
SET SRCAN=+$EXTRACT(%,1,12)
SET DA=SRTOLD
SET DIE=130
SET DR=".02///@;17////"_SRCAN_";79////"_SRTNEW
DO ^DIE
KILL DR
+14 SET $PIECE(^SRF(SRTOLD,31),"^",4)=""
SET $PIECE(^(31),"^",5)=""
+15 SET SRTN=SRTNEW
DO ^SROERR
SET SRTN=SRTOLD
+16 QUIT
HELP WRITE !!,"To make a new request, you must select a future date. Do you want to select",!,"another date ? YES// "
READ X:DTIME
IF '$TEST!(X["^")
SET OK=0
QUIT
+1 SET X=$EXTRACT(X)
IF "YyNn"'[X
WRITE !!,"Enter 'YES' to select another date, or 'NO' to bypass making a new request."
GOTO HELP
+2 IF "Yy"'[X
SET OK=0
+3 QUIT
NEWDT ; get six month default date for new request
+1 SET SRX1=$EXTRACT($PIECE(^SRF(SRTOLD,0),"^",9),1,7)
SET SRX2=182
KILL SRCHK
DO DAY
SET Y=SRX
DO D^DIQ
SET SRY=Y
+2 QUIT
CHK ; check for valid request date
+1 NEW SRSDATE
SET SRSDATE=SRX
KILL SRLATE
DO LATE^SRSREQ
+2 QUIT
DAY ; get valid default request date
+1 SET X1=SRX1
SET X2=SRX2
DO C^%DTC
IF X<DT
SET SRX1=DT
SET SRX2=1
GOTO DAY
+2 SET SRX=X
KILL DIC
SET DIC=40.5
SET DIC(0)="XM"
DO ^DIC
KILL DIC
+3 IF Y'=-1
IF '$DATA(^SRO(133,SRSITE,3,X,0))
SET SRX2=SRX2+1
GOTO DAY
+4 SET X=SRX
DO H^%DTC
SET SRDAY=%Y+1
SET SRDL=$PIECE($GET(^SRO(133,SRSITE,2)),"^",SRDAY)
if SRDL=""
SET SRDL=1
IF 'SRDL
SET SRX2=SRX2+1
GOTO DAY
+5 if '$DATA(SRSITE("REQ"))
QUIT
SET X1=SRX
SET X2=-SRDL
DO C^%DTC
SET SRDTL=X
SET DIC=40.5
SET DIC(0)="XM"
DO ^DIC
KILL DIC
IF Y'=-1
IF '$DATA(^SRO(133,SRSITE,3,X,0))
SET SRX2=SRX2+1
GOTO DAY
+6 SET SRTCHK=SRDTL_"."_SRSITE("REQ")
DO NOW^%DTC
IF %>SRTCHK
SET SRX2=SRX2+1
GOTO DAY
+7 QUIT
