source: WorldVistAEHR/trunk/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSWX1.m@ 1800

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

initial load of WorldVistAEHR

File size: 1.2 KB
Line 
1YSWX1 ;ALB/ASF-WAIT LIST CONT ; 10/7/88 16:06 ;
2 ;;5.01;MENTAL HEALTH;;Dec 30, 1994
3 ;
4 ; Called from the top by MENU option YSWAITCR
5 ;
6 K DIC S DIC="^YSG(""WAIT"",",DIC(0)="AELQ",DLAYGO=617 D ^DIC Q:Y<1
7 S N=+Y,DA=+Y,DIE=DIC,DIE("NO^")=1,DR="0:1;1.5" L +^YSG("WAIT",DA) D ^DIE S ^YSG("WAIT",N,1,0)="^617.01P^^" K DIC,DIE,X,Y
8 I '$D(^YSG("WAIT",N,0)) K ^YSG("WAIT",N,1,0)
9 L -^YSG("WAIT",N) S YSTOUT=$D(DTOUT),YSUOUT=$O(Y(""))]""
10 Q
11SHUF ; Called by routine YSWX
12 S YSELIG=$P(^YSG("WAIT",N,0),U,3)
13 S E1=^YSG("WAIT",N,1,N1,0),S1=$P(E1,U,7),S2=$P(E1,U,8) S:YSELIG="N" S1=0
14RETRY ;
15 S H1="" R !,"Move patient to which numeric position on the wait list = ",W2:DTIME S YSTOUT='$T,YSUOUT=W2["^" Q:YSTOUT!YSUOUT G:(W2?1"?"."?")!(W2'?1N.N)!(W2=0) ERR
16 S (W3,H1)="" F W4=1:1:W2 S W3=$O(^UTILITY($J,S1,W3)) Q:'W3 S ^UTILITY($J,W4)=W3
17 G ERR:W2>W4 G ERR:'$D(^UTILITY($J,W2)) S H1=^UTILITY($J,W2) Q:H1=S2 I S2<H1 S H1=H1+.00000001 S:$D(^UTILITY($J,S1,H1)) H1=H1+.00000001 Q
18 E S H1=H1-.00000001 S:$D(^UTILITY($J,S1,H1)) H1=H1-.00000001 Q
19ERR ;
20 W !!,$C(7),"YOU MUST ENTER A NUMBER BETWEEN 1 AND THE LAST NUMBER ON THE WAIT LIST"
21 W !," (INCLUSIVE) OR (^) TO EXIT." G RETRY
22 Q
Note: See TracBrowser for help on using the repository browser.