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

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

initial load of FOIAVistA 6/30/08 version

File size: 3.6 KB
Line 
1DGRUG1 ;ALB/MLI - RUG-II GROUPER ; 23 NOV 88@1600
2 ;;5.3;Registration;;Aug 13, 1993
3CVD I $P(DGINFO,U,58)=2 S DGRUG=17,G=2 G PRT
4REHAB 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
5SPECIAL I DGSUM>4&($P(DGINFO,U,23)=4) G GROUPS
6 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
7CLINIC I DGSUM<5&($P(DGINFO,U,23)=4) G GROUPC
8 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
9 F E=12,16,17,18,19,20,25,26,27,28,34,35 I $P(DGINFO,U,E)=2 G GROUPC
10BEHAVE I $P(DGINFO,U,47)=2 G GROUPB
11 F E=44,45,46 I $P(DGINFO,U,E)=4 G GROUPB
12PHYS S DGRUG=$S(DGSUM=3:12,DGSUM=4:13,DGSUM<8:14,DGSUM=8:15,1:16),G=5 G PRT
13QUIT 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
14GROUPR S DGRUG=$S(DGSUM<5:1,1:2),G=1 G PRT
15GROUPS S DGRUG=$S(DGSUM<8:3,1:4),G=2 G PRT
16GROUPC S DGRUG=$S(DGSUM<4:5,DGSUM<7:6,DGSUM<9:7,1:8),G=3 G PRT
17GROUPB S DGRUG=$S(DGSUM<4:9,DGSUM<8:10,1:11),G=4 G PRT
18PRT 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,!
19 W ?4,"RUG-II WWUs: ",$S($D(^DG(45.91,+DGRUG,"FY",DGFY,0)):$P(^(0),U,2),1:"")
20 G:$D(DGPAF) DT^DGRUGTG G:$D(DGGRP) QUIT^DGRUGGR
21 S DA=DGPT,DIE="^DG(45.9,",DR="71///"_DGRUG_";72///"_DGSUM_";74///"_G_";80///1" D ^DIE
22C 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
23 I %=1 S DR="80///2;81///"_DT_";82////"_DUZ,DIE="^DG(45.9," D ^DIE W !!,"*CLOSED*"
24 G QUIT
251 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
26 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
27 Q
282 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
29 Q
303 K DGFLAG,A I $P(DGINFO,U,58)=1 F I=59:1:62 I $P(DGINFO,U,I)>1 S DGFLAG=1
31 I $D(DGFLAG) W !,*7,"If 'CHRONIC VENTILATOR DEP. (CVD)' is marked 'N'o then all CVD related",!,"questions must be marked '1'.",!
32 I $D(DGFLAG) F I=58:1:62 S A(I)=I
33 Q
344 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
35 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'.",!
36 Q
375 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
38 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'.",!
39 Q
406 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
41 I $D(DGFLAG) W !,*7,"Can not have more than 10 hours of therapy per day"
Note: See TracBrowser for help on using the repository browser.