Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: SRSCHD

SRSCHD.m

Go to the documentation of this file.
  1. SRSCHD ;B'HAM ISC/MAM - SCHEDULING UNREQUESTED CASES ; Feb 25, 2002@07:27
  1. ;;3.0;Surgery;**77,100,131,203**;24 Jun 93;Build 7
  1. BEG W @IOF S SRSOUT=0
  1. K SRSDATE W ! S (SRNOREQ,SRSCHD,SRSC1)=1,ST="SCHEDULING"
  1. K %DT S %DT="AEFX",%DT("A")="Schedule a Procedure for which Date ? " D ^%DT I Y<0 W !!,"The schedule cannot be updated without a date.",!! G END
  1. S SRSDATE=+Y I SRSDATE<DT W !!,"Reservations cannot be made for dates in the past. Please select another date.",!!,"Press RETURN to continue " R X:DTIME G BEG
  1. S X=SRSDATE D H^%DTC S SRDAY=%Y+1 S SRDL=$P($G(^SRO(133,SRSITE,2)),"^",SRDAY) S:SRDL="" SRDL=1
  1. I 'SRDL W !!,"Scheduling not allowed for "_$S(SRDAY=1:"SUNDAY",SRDAY=2:"MONDAY",SRDAY=3:"TUESDAY",SRDAY=4:"WEDNESDAY",SRDAY=5:"THURSDAY",SRDAY=6:"FRIDAY",1:"SATURDAY")_" !!",!!!,"Press RETURN to continue " R X:DTIME G BEG
  1. K SRY S DIC=40.5,DR=".01;2",DA=SRSDATE,DIQ="SRY",DIQ(0)="E" D EN^DIQ1 K DA,DIC,DIQ,DR
  1. I $D(SRY(40.5,SRSDATE,.01,"E")),'$D(^SRO(133,SRSITE,3,SRSDATE,0)) W !!,"Scheduling not allowed for "_$G(SRY(40.5,SRSDATE,2,"E"))_" !!",!!!,"Press RETURN to continue " R X:DTIME G BEG
  1. S Y=SRSDATE D D^DIQ S SREQDT=Y
  1. W ! S DIC=2,DIC("A")="Select Patient: ",DIC(0)="QEAMZ" D ^DIC K DIC G:Y<0 END S (DFN,SRSDPT)=+Y D DEM^VADPT S SRNM=VADM(1),SRSSN=VA("PID")
  1. I $D(^DPT(SRSDPT,.35)),$P(^(.35),"^")'="" S Y=$E($P(^(.35),"^"),1,7) D D^DIQ W !!,"The records show that "_SRNM_" died on "_Y_".",! G END
  1. OR ;
  1. D SURG I SRSOUT S SRSOUT=0 G END ;SR203: ask Primary Surgeon before OR, etc
  1. D ^SRSCHOR I SRSOUT W !!,"No surgical case has been scheduled.",! S SRSOUT=0 G END
  1. D ^SRSCHUN I SRSOUT S SRSOUT=0 G END
  1. I $$LOCK^SROUTL(SRTN) D ^SRSCHUN1,UNLOCK^SROUTL(SRTN)
  1. END ;
  1. I 'SRSOUT K DIR S DIR(0)="FOA",DIR("A")=" Press RETURN to continue. " D ^DIR
  1. D ^SRSKILL K SRTN,SRLCK W @IOF
  1. Q
  1. SURG ; surgeon
  1. K DIR S DIR(0)="130,.14",DIR("A")="Primary Surgeon" D ^DIR K DIR I $D(DTOUT)!(X="^") S SRSOUT=1 Q
  1. I Y=""!(X["^") W !!,"To create a surgical case, a surgeon MUST be selected. Enter '^' to exit.",! G SURG
  1. S SRSDOC=+Y
  1. Q