DGRUG1 ;ALB/MLI - RUG-II GROUPER ; 23 NOV 88@1600
;;5.3;Registration;;Aug 13, 1993
CVD I $P(DGINFO,U,58)=2 S DGRUG=17,G=2 G PRT
REHAB S (DGD,DGHM)=0 F E=48:2:56 I $P(DGINFO,U,E)=3 S T=$P(DGINFO,U,E+15-(E-48/2)),DGHM=DGHM+$S(T<100:T,T<1000:$E(T,1,1)*60+$E(T,2,3),1:$E(T,1,2)*60+$E(T,3,4)),DGD=DGD+$P(DGINFO,U,E+1) I DGD>4,(DGHM>149) G GROUPR
SPECIAL I DGSUM>4&($P(DGINFO,U,23)=4) G GROUPS
I DGSUM>4 F E=11,14,15,24,32,33 I $S(E'=14&($P(DGINFO,U,E)=2):1,E=14&($P(DGINFO,U,14)=2)&($P(DGINFO,U,21)'=7):1,1:0) G GROUPS
CLINIC I DGSUM<5&($P(DGINFO,U,23)=4) G GROUPC
I DGSUM<5 F E=11,14,15,24,32,33 I $S(E'=14&($P(DGINFO,U,E)=2):1,E=14&($P(DGINFO,U,14)=2)&($P(DGINFO,U,21)'=7):1,1:0) G GROUPC
F E=12,16,17,18,19,20,25,26,27,28,34,35 I $P(DGINFO,U,E)=2 G GROUPC
BEHAVE I $P(DGINFO,U,47)=2 G GROUPB
F E=44,45,46 I $P(DGINFO,U,E)=4 G GROUPB
PHYS S DGRUG=$S(DGSUM=3:12,DGSUM=4:13,DGSUM<8:14,DGSUM=8:15,1:16),G=5 G PRT
QUIT K %,%Y,A,DA,DGD,DGFLAG,DGFY,DGHM,DGI,DGINFO,DGLCO,DGPAF,DGPT,DGRUG,DGSER,DGSUM,DIC,DIE,DIV,DR,E,G,I,J,T,Y Q
GROUPR S DGRUG=$S(DGSUM<5:1,1:2),G=1 G PRT
GROUPS S DGRUG=$S(DGSUM<8:3,1:4),G=2 G PRT
GROUPC S DGRUG=$S(DGSUM<4:5,DGSUM<7:6,DGSUM<9:7,1:8),G=3 G PRT
GROUPB S DGRUG=$S(DGSUM<4:9,DGSUM<8:10,1:11),G=4 G PRT
PRT W !!,?3,"RUG-II GROUP: ",DGRUG,!!,"HIERARCHY GROUP: ",G," - ",$S(G=1:"HEAVY REHABILITATION",G=2:"SPECIAL CARE",G=3:"CLINICAL COMPLEX",G=5:"PHYSICAL",1:"BEHAVIORAL"),!?8,"ADL SUM: ",DGSUM,!
W ?4,"RUG-II WWUs: ",$S($D(^DG(45.91,+DGRUG,"FY",DGFY,0)):$P(^(0),U,2),1:"")
G:$D(DGPAF) DT^DGRUGTG G:$D(DGGRP) QUIT^DGRUGGR
S DA=DGPT,DIE="^DG(45.9,",DR="71///"_DGRUG_";72///"_DGSUM_";74///"_G_";80///1" D ^DIE
C G QUIT:'$D(^XUSEC("DG RUG CLOSE PAI",DUZ))!$S('$D(^DG(45.9,DGPT,"C")):1,+^("C")'<2:1,1:0) W !!!,"Close this record now" S %=2 D YN^DICN I '%!(%Y["?") D YN^DGRUGC G C
I %=1 S DR="80///2;81///"_DT_";82////"_DUZ,DIE="^DG(45.9," D ^DIE W !!,"*CLOSED*"
G QUIT
1 K A,DGFLAG I $S($P(DGINFO,U,14)=2:1,$P(DGINFO,U,15)=2:1,1:0)&($P(DGINFO,U,40)<5) W !,*7,"If 'TUBE FEEDING' or 'PARENTERAL FEEDING' ",!," is marked 'Y'es then question 'EATING' must be marked '5'.",! F I=14,15,40 S A(I)=I S DGFLAG=1
I $P(DGINFO,U,14)=1&($P(DGINFO,U,15)=1)&($P(DGINFO,U,40)=5) W !,*7,"If 'TUBE FEEDING' and 'PARENTERAL FEEDING' ",!," are marked 'N'o then question 'EATING' must not be marked '5'.",! F I=14,15,40 S A(I)=I S DGFLAG=1
Q
2 K A,DGFLAG I $P(DGINFO,U,14)=2&($P(DGINFO,U,21)=1) W !,*7,"If 'TUBE FEEDING' ",!," is marked 'Y'es then question 'TUBE FEEDING ROUTE' must not be marked '1'.",! F I=14,21 S A(I)=I S DGFLAG=1
Q
3 K DGFLAG,A I $P(DGINFO,U,58)=1 F I=59:1:62 I $P(DGINFO,U,I)>1 S DGFLAG=1
I $D(DGFLAG) W !,*7,"If 'CHRONIC VENTILATOR DEP. (CVD)' is marked 'N'o then all CVD related",!,"questions must be marked '1'.",!
I $D(DGFLAG) F I=58:1:62 S A(I)=I
Q
4 K DGFLAG,A F I=48:2:56 S DGHM=I+15-(I-48/2) I $P(DGINFO,U,I)=1&(($P(DGINFO,U,I+1)'=0)!($P(DGINFO,U,DGHM)'=0)) S A(I)=I,A(I+1)=I+1,A(I+1.5)=I+1.5,DGFLAG=1
I $D(DGFLAG) W !,*7,"For each of the therapy questions,'DAYS PER WEEK' and 'HOURS PER WEEK' must be '0' if level is '1'.",!
Q
5 K DGFLAG,A F I=48:2:56 S DGHM=I+15-(I-48/2) I $P(DGINFO,U,I)'=1&(($P(DGINFO,U,I+1)=0)!($P(DGINFO,U,DGHM)<30)) S A(I)=I,A(I+1)=I+1,A(I+1.5)=I+1.5,DGFLAG=1
I $D(DGFLAG) W !,*7,"For each of the therapy questions,'DAYS PER WEEK' must be greater than 0",!,"and 'HOURS/MINUTES PER WEEK' must be greater than 29 minutes if level is",!,"greater than '1'.",!
Q
6 K DGFLAG,A F I=48:2:56 I $P(DGINFO,U,I)'=1 S DGHM=I+15-(I-48/2) I $P(DGINFO,U,DGHM)>(1000*$P(DGINFO,U,I+1)) S A(I+1.5)=I+1.5,A(I+1)=I+1,DGFLAG=1
I $D(DGFLAG) W !,*7,"Can not have more than 10 hours of therapy per day"
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGRUG1 3698 printed Dec 13, 2024@02:58:07 Page 2
DGRUG1 ;ALB/MLI - RUG-II GROUPER ; 23 NOV 88@1600
+1 ;;5.3;Registration;;Aug 13, 1993
CVD IF $PIECE(DGINFO,U,58)=2
SET DGRUG=17
SET G=2
GOTO PRT
REHAB SET (DGD,DGHM)=0
FOR E=48:2:56
IF $PIECE(DGINFO,U,E)=3
SET T=$PIECE(DGINFO,U,E+15-(E-48/2))
SET DGHM=DGHM+$SELECT(T<100:T,T<1000:$EXTRACT(T,1,1)*60+$EXTRACT(T,2,3),1:$EXTRACT(T,1,2)*60+$EXTRACT(T,3,4))
SET DGD=DGD+$PIECE(DGINFO,U,E+1)
IF DGD>4
IF (DGHM>149)
GOTO GROUPR
SPECIAL IF DGSUM>4&($PIECE(DGINFO,U,23)=4)
GOTO GROUPS
+1 IF DGSUM>4
FOR E=11,14,15,24,32,33
IF $SELECT(E'=14&($PIECE(DGINFO,U,E)=2):1,E=14&($PIECE(DGINFO,U,14)=2)&($PIECE(DGINFO,U,21)'=7):1,1:0)
GOTO GROUPS
CLINIC IF DGSUM<5&($PIECE(DGINFO,U,23)=4)
GOTO GROUPC
+1 IF DGSUM<5
FOR E=11,14,15,24,32,33
IF $SELECT(E'=14&($PIECE(DGINFO,U,E)=2):1,E=14&($PIECE(DGINFO,U,14)=2)&($PIECE(DGINFO,U,21)'=7):1,1:0)
GOTO GROUPC
+2 FOR E=12,16,17,18,19,20,25,26,27,28,34,35
IF $PIECE(DGINFO,U,E)=2
GOTO GROUPC
BEHAVE IF $PIECE(DGINFO,U,47)=2
GOTO GROUPB
+1 FOR E=44,45,46
IF $PIECE(DGINFO,U,E)=4
GOTO GROUPB
PHYS SET DGRUG=$SELECT(DGSUM=3:12,DGSUM=4:13,DGSUM<8:14,DGSUM=8:15,1:16)
SET G=5
GOTO PRT
QUIT KILL %,%Y,A,DA,DGD,DGFLAG,DGFY,DGHM,DGI,DGINFO,DGLCO,DGPAF,DGPT,DGRUG,DGSER,DGSUM,DIC,DIE,DIV,DR,E,G,I,J,T,Y
QUIT
GROUPR SET DGRUG=$SELECT(DGSUM<5:1,1:2)
SET G=1
GOTO PRT
GROUPS SET DGRUG=$SELECT(DGSUM<8:3,1:4)
SET G=2
GOTO PRT
GROUPC SET DGRUG=$SELECT(DGSUM<4:5,DGSUM<7:6,DGSUM<9:7,1:8)
SET G=3
GOTO PRT
GROUPB SET DGRUG=$SELECT(DGSUM<4:9,DGSUM<8:10,1:11)
SET G=4
GOTO PRT
PRT WRITE !!,?3,"RUG-II GROUP: ",DGRUG,!!,"HIERARCHY GROUP: ",G," - ",$SELECT(G=1:"HEAVY REHABILITATION",G=2:"SPECIAL CARE",G=3:"CLINICAL COMPLEX",G=5:"PHYSICAL",1:"BEHAVIORAL"),!?8,"ADL SUM: ",DGSUM,!
+1 WRITE ?4,"RUG-II WWUs: ",$SELECT($DATA(^DG(45.91,+DGRUG,"FY",DGFY,0)):$PIECE(^(0),U,2),1:"")
+2 if $DATA(DGPAF)
GOTO DT^DGRUGTG
if $DATA(DGGRP)
GOTO QUIT^DGRUGGR
+3 SET DA=DGPT
SET DIE="^DG(45.9,"
SET DR="71///"_DGRUG_";72///"_DGSUM_";74///"_G_";80///1"
DO ^DIE
C if '$DATA(^XUSEC("DG RUG CLOSE PAI",DUZ))!$SELECT('$DATA(^DG(45.9,DGPT,"C")):1,+^("C")'<2:1,1:0)
GOTO QUIT
WRITE !!!,"Close this record now"
SET %=2
DO YN^DICN
IF '%!(%Y["?")
DO YN^DGRUGC
GOTO C
+1 IF %=1
SET DR="80///2;81///"_DT_";82////"_DUZ
SET DIE="^DG(45.9,"
DO ^DIE
WRITE !!,"*CLOSED*"
+2 GOTO QUIT
1 KILL A,DGFLAG
IF $SELECT($PIECE(DGINFO,U,14)=2:1,$PIECE(DGINFO,U,15)=2:1,1:0)&($PIECE(DGINFO,U,40)<5)
WRITE !,*7,"If 'TUBE FEEDING' or 'PARENTERAL FEEDING' ",!," is marked 'Y'es then question 'EATING' must be marked '5'.",!
FOR I=14,15,40
SET A(I)=I
SET DGFLAG=1
+1 IF $PIECE(DGINFO,U,14)=1&($PIECE(DGINFO,U,15)=1)&($PIECE(DGINFO,U,40)=5)
WRITE !,*7,"If 'TUBE FEEDING' and 'PARENTERAL FEEDING' ",!," are marked 'N'o then question 'EATING' must not be marked '5'.",!
FOR I=14,15,40
SET A(I)=I
SET DGFLAG=1
+2 QUIT
2 KILL A,DGFLAG
IF $PIECE(DGINFO,U,14)=2&($PIECE(DGINFO,U,21)=1)
WRITE !,*7,"If 'TUBE FEEDING' ",!," is marked 'Y'es then question 'TUBE FEEDING ROUTE' must not be marked '1'.",!
FOR I=14,21
SET A(I)=I
SET DGFLAG=1
+1 QUIT
3 KILL DGFLAG,A
IF $PIECE(DGINFO,U,58)=1
FOR I=59:1:62
IF $PIECE(DGINFO,U,I)>1
SET DGFLAG=1
+1 IF $DATA(DGFLAG)
WRITE !,*7,"If 'CHRONIC VENTILATOR DEP. (CVD)' is marked 'N'o then all CVD related",!,"questions must be marked '1'.",!
+2 IF $DATA(DGFLAG)
FOR I=58:1:62
SET A(I)=I
+3 QUIT
4 KILL DGFLAG,A
FOR I=48:2:56
SET DGHM=I+15-(I-48/2)
IF $PIECE(DGINFO,U,I)=1&(($PIECE(DGINFO,U,I+1)'=0)!($PIECE(DGINFO,U,DGHM)'=0))
SET A(I)=I
SET A(I+1)=I+1
SET A(I+1.5)=I+1.5
SET DGFLAG=1
+1 IF $DATA(DGFLAG)
WRITE !,*7,"For each of the therapy questions,'DAYS PER WEEK' and 'HOURS PER WEEK' must be '0' if level is '1'.",!
+2 QUIT
5 KILL DGFLAG,A
FOR I=48:2:56
SET DGHM=I+15-(I-48/2)
IF $PIECE(DGINFO,U,I)'=1&(($PIECE(DGINFO,U,I+1)=0)!($PIECE(DGINFO,U,DGHM)<30))
SET A(I)=I
SET A(I+1)=I+1
SET A(I+1.5)=I+1.5
SET DGFLAG=1
+1 IF $DATA(DGFLAG)
WRITE !,*7,"For each of the therapy questions,'DAYS PER WEEK' must be greater than 0",!,"and 'HOURS/MINUTES PER WEEK' must be greater than 29 minutes if level is",!,"greater than '1'.",!
+2 QUIT
6 KILL DGFLAG,A
FOR I=48:2:56
IF $PIECE(DGINFO,U,I)'=1
SET DGHM=I+15-(I-48/2)
IF $PIECE(DGINFO,U,DGHM)>(1000*$PIECE(DGINFO,U,I+1))
SET A(I+1.5)=I+1.5
SET A(I+1)=I+1
SET DGFLAG=1
+1 IF $DATA(DGFLAG)
WRITE !,*7,"Can not have more than 10 hours of therapy per day"
