source: FOIAVistA/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRUGTG.m@ 794

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

initial load of FOIAVistA 6/30/08 version
File size: 3.1 KB
Line 
1DGRUGTG ;ALB/MLI - TEST RUG-II GROUPER ; 29 DEC 87 9:00
2 ;;5.3;Registration;**173**;Aug 13, 1993
3 ;
4ASK W !,$P(^DD(45.9,DGNO,0),U) S %=0 D YN^DICN S %=$S(%=2:1,%=1:2,1:%) Q:%<0 I '% D QR G ASK
5 I DGNO=58,'DGED,%=1 S DGNO=62 F DGI=59:1:62 S $P(DGINFO,"^",DGI)=1
6 Q
7YN D ASK Q:%<0 D:%Y["?" QR G:%Y["?" YN S $P(DGINFO,"^",DGNO)=% Q
8EDIT S DGED=1 F DGNO=0:0 S DGNO=$O(A(DGNO)) G:(DGNO<1) CH D:(DGNO<21)!((DGNO>23)&(DGNO<36))!(DGNO=58) YN G QUIT:%<0 D:'((DGNO<21)!((DGNO>23)&(DGNO<36))!(DGNO=58)) CHK G:X=U QUIT
9 G CH
10MAIN S (DGFLAG,DGED)=0,U="^" W !,"The information you are about to enter will be used to determine a TEST ",!,"RUG-II Grouper. The values you enter will not be saved and will not ",!," be able to be retrieved for later use."
11 W !,"Do you wish to continue" S %=1 D YN^DICN G MAIN:%Y["?",QUIT:%'=1
12DT W !!!,"Enter fiscal year (4 digits): " R X:DTIME G FYH:X["?",QUIT:X=U!('$T)!(X=""),DT:X'?4N S %DT="E",%DT(0)=2870000 D ^%DT G:Y'>0 DT
13MR K I S DGFY=Y,DGYR=$E(Y,1,3) I '$D(^DG(45.91,1,"FY",DGFY)) W !,"WWU values unavailable. Want most recent ones" S %=0 D YN^DICN G FYH2:%Y["?",DT:%=2!'%,QUIT:%'>0 F I=DGFY:-10000:2860000 S DGFY=I I $D(^DG(45.91,1,"FY",DGFY)) Q
14 I $D(I),I<2870000 W !,"THERE ARE NO WWU VALUES IN YOUR RUG-II FILE" G QUIT
15 S DGPAF="" F DGNO=10:1:20 D ASK G:%<0 QUIT S $P(DGINFO,"^",DGNO)=%
16DB F DGNO=21,23 D CHK G QUIT:X=U S $P(DGINFO,"^",DGNO)=X
17 F DGNO=24:1:28,32:1:35 D ASK G:%<0 QUIT S $P(DGINFO,"^",DGNO)=%
18 F DGNO=40:1:57 D CHK G:X=U QUIT
19CV S DGNO=58 D ASK G:%<0 QUIT S $P(DGINFO,"^",DGNO)=%
20 I DGNO<59 F DGNO=59:1:62 D CHK G:X=U QUIT
21CH F DGI=1:1:6 D @(DGI_"^"_"DGRUG1") G:$D(DGFLAG) EDIT
22 S E=$P(DGINFO,"^",40),E=$S(E<3:1,E=3:2,E=4:3,1:4),T=$P(DGINFO,"^",42),T=$S(T<3:1,T=3:2,1:3),J=$P(DGINFO,"^",43),J=$S(J<3:1,J<5:2,1:3),DGSUM=E+T+J
23 G CVD^DGRUG1
24QUIT K %,%DT,%Y,A,D,DGED,DGFL,DGFLAG,DGHM,DGI,DGINFO,DGFY,DGMAX,DGMIN,DGNO,DGPAF,DGRUG,DGSUM,DGYR,E,G,I,J,N,T,X,Y Q
25QR D RESYN W !," ANSWER 'Y'ES OR 'N'O" Q
26RES W ! F I=2:1:(N+1) W ! W:(N=6) I-2,">" W:(N=3) I-1,">" W $P($P($P(^DD(45.9,DGNO,0),U,3),":",I),";",1)
27 W !
28RESYN F I=0:0 S I=$O(^DD(45.9,DGNO,21,I)) Q:I'>0 W !,^(I,0)
29 Q
30CHK W !,$P(^DD(45.9,DGNO,0),U),": " R X:DTIME S:'$T X=U Q:X=U G:X="" CHK
31 K N,DGMIN,DGMAX,G S DGFL=0,G=$S(DGNO=21:717,DGNO=23:605,DGNO<47!(DGNO=59)!(DGNO=60):515,DGNO=47:313,DGNO=61:414,DGNO=62:919,DGNO[".5":1,'(DGNO#2):414,1:107)
32 S:G=1 DGMIN=0,DGMAX=5059,N=1 I G>1 S N=$E(G,1),DGMIN=$E(G,2),DGMAX=$E(G,3)
33 I G=1 D HM^DGRUGC1 I '$D(X) G CHK
34 I (X'["?")&(X'="")&((X<DGMIN)!(X>DGMAX)!(X'?.N)) W !,*7," INVALID RESPONSE--TRY AGAIN" G CHK
35 I X["?",(G>1),(G'=107) D RES G CHK
36 I X["?",(G=1) D RESYN G CHK
37 I X["?",(G=107) W !,^DD(45.9,DGNO,3) G CHK
38 S $P(DGINFO,"^",$S(DGNO'[".":DGNO,1:DGNO+9.5+(57-$P(DGNO,".")/2)))=X
39 I N=4,(DGNO<61) Q:DGED S DGNO=DGNO+1 S:X=1 $P(DGINFO,"^",DGNO)=0,$P(DGINFO,"^",DGNO+10+(57-DGNO/2))=0 I X'=1 G CHK
40 I G=107 Q:DGED S DGNO=DGNO+.5 G CHK
41 S:'DGED&(DGNO[".") DGNO=DGNO-.5 Q
42FYH W !,"Enter fiscal year of RUG-II WWU values you want to use. Must not precede 1987." G DT
43FYH2 W !,"Fiscal year RUG-II WWU values not available for the year requested",!,"Enter 'Y'es to accept most recent values in file or 'N'o",!,"to choose another year" G MR
Note: See TracBrowser for help on using the repository browser.