DGRUGTG.m

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 ---DGRUGTG   3241     printed  Feb 19, 2025@00:24:36                                                                                                                                                                                                     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