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

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"