source: WorldVistAEHR/trunk/r/SURGERY-SR/SRSREQ.m@ 1006

Last change on this file since 1006 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR

File size: 3.2 KB
Line 
1SRSREQ ;BIR/MAM - MAKE REQUESTS ; [ 01/20/00 9:42 AM ]
2 ;;3.0; Surgery ;**8,12,23,30,37,92,131,154**;24 Jun 93
3LOOP ; break procedure if greater than 70 characters
4 S SROPS(M)="" F LOOP=1:1 S MM=$P(SROPER," "),MMM=$P(SROPER," ",2,200) Q:MMM="" Q:$L(SROPS(M))+$L(MM)'<70 S SROPS(M)=SROPS(M)_MM_" ",SROPER=MMM
5 Q
6CONCUR ; check for concurrent case
7 S (SRSCC,SRSCON)=0 F S SRSCC=$O(^SRF("AC",SRSDATE,SRSCC)) Q:'SRSCC I ^(SRSCC)=SRSDPT,$D(^SRF(SRSCC,"REQ")),$P(^("REQ"),"^")=1 S SRSCON=1 Q
8 Q:SRSCON=0
9CC K SROPS,MM,MMM S SRCTN=SRSCC,SROPER=$P(^SRF(SRCTN,"OP"),"^") S:$L(SROPER)<70 SROPS(1)=SROPER I $L(SROPER)>69 S SROPER=SROPER_" " F M=1:1 D LOOP Q:MMM=""
10 S DFN=SRSDPT D DEM^VADPT W !!,VADM(1)_" has the following procedure already entered for this",!,"date: ",!!,"CASE #"_SRCTN_" "_SROPS(1) I $D(SROPS(2)) W !,?9,SROPS(2) I $D(SROPS(3)) W !,?9,SROPS(3)
11ASKCC K DIR W ! S DIR("A")="Will this be a concurrent procedure ",DIR("B")="NO",DIR(0)="Y",DIR("?",1)="If these procedures will be scheduled at the same time, in the same operating",DIR("?")="room, answer 'YES'."
12 D ^DIR S SRSC=Y K DIR Q:$D(DUOUT)!$D(DTOUT) I 'Y K SRCTN Q
13 ;if concurrent and the case is locked
14 I Y,$D(^XTMP("SRLOCK-"_SRCTN)) D MSG^SRSUPRQ S SRSC=0 K SRCTN Q
15 S SRSCON(SRSCON,"OP")=$P(^SRF(SRCTN,"OP"),"^"),SRSCON(SRSCON,"DOC")=$P(^VA(200,$P(^SRF(SRCTN,.1),"^",4),0),"^"),SRSCON(SRSCON,"SS")=$P(^SRO(137.45,$P(^SRF(SRCTN,0),"^",4),0),"^"),SRSCON(SRSCON)=SRCTN
16 Q
17AVG ; update estimated case length
18 S SRAVG="",SRSPEC=$P(^SRF(SRTN,0),"^",4),SRSCPT=$P(^SRF(SRTN,"OP"),"^",2) D ^SRSAVG S SRLNTH=$P($G(^SRF(SRTN,.4)),"^") I SRLNTH="" S SRLNTH=SRAVG
19 W ! K DIR S DIR("A")="How long is this procedure ? (HOURS:MINUTES) ",DIR("B")=SRLNTH,DIR(0)="130,37A" D ^DIR I $D(DUOUT)!$D(DTOUT) Q
20 G:X["^" AVG I X="@" S Y="@"
21 S SRLNTH1=Y,DR="37///"_SRLNTH1,DIE=130,DA=SRTN D ^DIE K DR
22 Q
23LATE ; check too see if it is too late to request
24 I $D(^XUSEC("SR REQ OVERRIDE",DUZ)) Q
25 N SRHOL,SRXDT S SRHOL="",(SRXDT,X)=SRSDATE D H^%DTC S SRDAY=%Y+1 S SRDL=$P($G(^SRO(133,SRSITE,2)),"^",SRDAY) S:SRDL="" SRDL=1
26 I 'SRDL W !!,"Surgery requests not allowed for "_$S(SRDAY=1:"SUN",SRDAY=2:"MON",SRDAY=3:"TUES",SRDAY=4:"WEDNES",SRDAY=5:"THURS",SRDAY=6:"FRI",1:"SATUR")_"DAY !!",! D PRESS S SRLATE=1 Q
27 K DIC S DIC=40.5,DIC(0)="XM",X=SRSDATE D ^DIC K DIC S SRHOL=$P(Y,"^") I SRHOL>0,'$D(^SRO(133,SRSITE,3,SRSDATE,0)) D S SRLATE=1 D PRESS Q
28 .S DIC=40.5,DR="2",DA=SRHOL,DIQ="SRY",DIQ(0)="E" D EN^DIQ1 K DA,DIC,DIQ,DR
29 .W !!,"Surgery requests not allowed for "_SRY(40.5,SRHOL,2,"E")_" !!"
30 I '$D(SRSITE("REQ")) Q
31 F S X1=SRXDT,X2=-SRDL D C^%DTC S SRDTL=X D Q:SRHOL'>0!$D(^SRO(133,SRSITE,3,X,0)) D NEXT
32 .K DIC S DIC=40.5,DIC(0)="XM" D ^DIC K DIC S SRHOL=$P(Y,"^")
33 S SRTCHK=SRDTL_"."_SRSITE("REQ") D NOW^%DTC I %>SRTCHK S SRLATE=1
34 I $D(SRLATE) D MESS
35 Q
36NEXT ; find request cutoff for previous day
37 S X1=SRXDT,X2=-1 D C^%DTC S SRXDT=X D H^%DTC S SRDAY=%Y+1 S SRDL=$P($G(^SRO(133,SRSITE,2)),"^",SRDAY) S:SRDL="" SRDL=1 I SRDL=0 D NEXT
38 Q
39MESS ; print message
40 W !!,"I'm sorry, but it is too late to make a request. If this case must",!,"be entered, use the option 'Schedule Unrequested Operations' under",!,"the 'Schedule Operations Menu'.",!!
41PRESS W ! K DIR S DIR(0)="FOA",DIR("A")="Press RETURN to continue " D ^DIR K DIR
42 Q
Note: See TracBrowser for help on using the repository browser.