DGRUGTG ;ALB/MLI - TEST RUG-II GROUPER ; 29 DEC 87 9:00
;;5.3;Registration;**173**;Aug 13, 1993
;
ASK 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
I DGNO=58,'DGED,%=1 S DGNO=62 F DGI=59:1:62 S $P(DGINFO,"^",DGI)=1
Q
YN D ASK Q:%<0 D:%Y["?" QR G:%Y["?" YN S $P(DGINFO,"^",DGNO)=% Q
EDIT 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
G CH
MAIN 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."
W !,"Do you wish to continue" S %=1 D YN^DICN G MAIN:%Y["?",QUIT:%'=1
DT 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
MR 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
I $D(I),I<2870000 W !,"THERE ARE NO WWU VALUES IN YOUR RUG-II FILE" G QUIT
S DGPAF="" F DGNO=10:1:20 D ASK G:%<0 QUIT S $P(DGINFO,"^",DGNO)=%
DB F DGNO=21,23 D CHK G QUIT:X=U S $P(DGINFO,"^",DGNO)=X
F DGNO=24:1:28,32:1:35 D ASK G:%<0 QUIT S $P(DGINFO,"^",DGNO)=%
F DGNO=40:1:57 D CHK G:X=U QUIT
CV S DGNO=58 D ASK G:%<0 QUIT S $P(DGINFO,"^",DGNO)=%
I DGNO<59 F DGNO=59:1:62 D CHK G:X=U QUIT
CH F DGI=1:1:6 D @(DGI_"^"_"DGRUG1") G:$D(DGFLAG) EDIT
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
G CVD^DGRUG1
QUIT 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
QR D RESYN W !," ANSWER 'Y'ES OR 'N'O" Q
RES 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)
W !
RESYN F I=0:0 S I=$O(^DD(45.9,DGNO,21,I)) Q:I'>0 W !,^(I,0)
Q
CHK W !,$P(^DD(45.9,DGNO,0),U),": " R X:DTIME S:'$T X=U Q:X=U G:X="" CHK
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)
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)
I G=1 D HM^DGRUGC1 I '$D(X) G CHK
I (X'["?")&(X'="")&((X<DGMIN)!(X>DGMAX)!(X'?.N)) W !,*7," INVALID RESPONSE--TRY AGAIN" G CHK
I X["?",(G>1),(G'=107) D RES G CHK
I X["?",(G=1) D RESYN G CHK
I X["?",(G=107) W !,^DD(45.9,DGNO,3) G CHK
S $P(DGINFO,"^",$S(DGNO'[".":DGNO,1:DGNO+9.5+(57-$P(DGNO,".")/2)))=X
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
I G=107 Q:DGED S DGNO=DGNO+.5 G CHK
S:'DGED&(DGNO[".") DGNO=DGNO-.5 Q
FYH W !,"Enter fiscal year of RUG-II WWU values you want to use. Must not precede 1987." G DT
FYH2 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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGRUGTG 3241 printed Nov 22, 2024@18:08:34 Page 2
DGRUGTG ;ALB/MLI - TEST RUG-II GROUPER ; 29 DEC 87 9:00
+1 ;;5.3;Registration;**173**;Aug 13, 1993
+2 ;
ASK WRITE !,$PIECE(^DD(45.9,DGNO,0),U)
SET %=0
DO YN^DICN
SET %=$SELECT(%=2:1,%=1:2,1:%)
if %<0
QUIT
IF '%
DO QR
GOTO ASK
+1 IF DGNO=58
IF 'DGED
IF %=1
SET DGNO=62
FOR DGI=59:1:62
SET $PIECE(DGINFO,"^",DGI)=1
+2 QUIT
YN DO ASK
if %<0
QUIT
if %Y["?"
DO QR
if %Y["?"
GOTO YN
SET $PIECE(DGINFO,"^",DGNO)=%
QUIT
EDIT SET DGED=1
FOR DGNO=0:0
SET DGNO=$ORDER(A(DGNO))
if (DGNO<1)
GOTO CH
if (DGNO<21)!((DGNO>23)&(DGNO<36))!(DGNO=58)
DO YN
if %<0
GOTO QUIT
if '((DGNO<21)!((DGNO>23)&(DGNO<36))!(DGNO=58))
DO CHK
if X=U
GOTO QUIT
+1 GOTO CH
MAIN SET (DGFLAG,DGED)=0
SET U="^"
WRITE !,"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."
+1 WRITE !,"Do you wish to continue"
SET %=1
DO YN^DICN
if %Y["?"
GOTO MAIN
if %'=1
GOTO QUIT
DT WRITE !!!,"Enter fiscal year (4 digits): "
READ X:DTIME
if X["?"
GOTO FYH
if X=U!('$TEST)!(X="")
GOTO QUIT
if X'?4N
GOTO DT
SET %DT="E"
SET %DT(0)=2870000
DO ^%DT
if Y'>0
GOTO DT
MR KILL I
SET DGFY=Y
SET DGYR=$EXTRACT(Y,1,3)
IF '$DATA(^DG(45.91,1,"FY",DGFY))
WRITE !,"WWU values unavailable. Want most recent ones"
SET %=0
DO YN^DICN
if %Y["?"
GOTO FYH2
if %=2!'%
GOTO DT
if %'>0
GOTO QUIT
FOR I=DGFY:-10000:2860000
SET DGFY=I
IF $DATA(^DG(45.91,1,"FY",DGFY))
QUIT
+1 IF $DATA(I)
IF I<2870000
WRITE !,"THERE ARE NO WWU VALUES IN YOUR RUG-II FILE"
GOTO QUIT
+2 SET DGPAF=""
FOR DGNO=10:1:20
DO ASK
if %<0
GOTO QUIT
SET $PIECE(DGINFO,"^",DGNO)=%
DB FOR DGNO=21,23
DO CHK
if X=U
GOTO QUIT
SET $PIECE(DGINFO,"^",DGNO)=X
+1 FOR DGNO=24:1:28,32:1:35
DO ASK
if %<0
GOTO QUIT
SET $PIECE(DGINFO,"^",DGNO)=%
+2 FOR DGNO=40:1:57
DO CHK
if X=U
GOTO QUIT
CV SET DGNO=58
DO ASK
if %<0
GOTO QUIT
SET $PIECE(DGINFO,"^",DGNO)=%
+1 IF DGNO<59
FOR DGNO=59:1:62
DO CHK
if X=U
GOTO QUIT
CH FOR DGI=1:1:6
DO @(DGI_"^"_"DGRUG1")
if $DATA(DGFLAG)
GOTO EDIT
+1 SET E=$PIECE(DGINFO,"^",40)
SET E=$SELECT(E<3:1,E=3:2,E=4:3,1:4)
SET T=$PIECE(DGINFO,"^",42)
SET T=$SELECT(T<3:1,T=3:2,1:3)
SET J=$PIECE(DGINFO,"^",43)
SET J=$SELECT(J<3:1,J<5:2,1:3)
SET DGSUM=E+T+J
+2 GOTO CVD^DGRUG1
QUIT KILL %,%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
QUIT
QR DO RESYN
WRITE !," ANSWER 'Y'ES OR 'N'O"
QUIT
RES WRITE !
FOR I=2:1:(N+1)
WRITE !
if (N=6)
WRITE I-2,">"
if (N=3)
WRITE I-1,">"
WRITE $PIECE($PIECE($PIECE(^DD(45.9,DGNO,0),U,3),":",I),";",1)
+1 WRITE !
RESYN FOR I=0:0
SET I=$ORDER(^DD(45.9,DGNO,21,I))
if I'>0
QUIT
WRITE !,^(I,0)
+1 QUIT
CHK WRITE !,$PIECE(^DD(45.9,DGNO,0),U),": "
READ X:DTIME
if '$TEST
SET X=U
if X=U
QUIT
if X=""
GOTO CHK
+1 KILL N,DGMIN,DGMAX,G
SET DGFL=0
SET G=$SELECT(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)
+2 if G=1
SET DGMIN=0
SET DGMAX=5059
SET N=1
IF G>1
SET N=$EXTRACT(G,1)
SET DGMIN=$EXTRACT(G,2)
SET DGMAX=$EXTRACT(G,3)
+3 IF G=1
DO HM^DGRUGC1
IF '$DATA(X)
GOTO CHK
+4 IF (X'["?")&(X'="")&((X<DGMIN)!(X>DGMAX)!(X'?.N))
WRITE !,*7," INVALID RESPONSE--TRY AGAIN"
GOTO CHK
+5 IF X["?"
IF (G>1)
IF (G'=107)
DO RES
GOTO CHK
+6 IF X["?"
IF (G=1)
DO RESYN
GOTO CHK
+7 IF X["?"
IF (G=107)
WRITE !,^DD(45.9,DGNO,3)
GOTO CHK
+8 SET $PIECE(DGINFO,"^",$SELECT(DGNO'[".":DGNO,1:DGNO+9.5+(57-$PIECE(DGNO,".")/2)))=X
+9 IF N=4
IF (DGNO<61)
if DGED
QUIT
SET DGNO=DGNO+1
if X=1
SET $PIECE(DGINFO,"^",DGNO)=0
SET $PIECE(DGINFO,"^",DGNO+10+(57-DGNO/2))=0
IF X'=1
GOTO CHK
+10 IF G=107
if DGED
QUIT
SET DGNO=DGNO+.5
GOTO CHK
+11 if 'DGED&(DGNO[".")
SET DGNO=DGNO-.5
QUIT
FYH WRITE !,"Enter fiscal year of RUG-II WWU values you want to use. Must not precede 1987."
GOTO DT
FYH2 WRITE !,"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"
GOTO MR
