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

Last change on this file since 1800 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR

File size: 1.4 KB
RevLine 
[613]1DGRUGGR ;ALB/BOK - RUG-II GROUPER FOR A PATIENT ; 14 MAY 87 09:00
2 ;;5.3;Registration;**89,173**;Aug 13, 1993
3 ;
4EN I '$D(DGCNH),$D(^XUSEC("DG RUG SUPERVISOR",DUZ)) S (DGFCNH,DGCNH)=""
5 S DIC="^DG(45.9,",DIC(0)="AEQM",DIC("S")="I $$PTSCREEN^DGRUGU1()"
6 D ^DIC G QUIT:Y'>0 S (DGPT,DA)=+Y
7SET W ! S DGCON=$S('$D(^DG(43,1,"RUG")):2891002,$P(^("RUG"),"^",2):$P(^("RUG"),"^",2),1:2891002),DGINFO=^DG(45.9,DA,0) K DGFLG,A,I
8 I $P(DGINFO,"^",2)<DGCON F I=1:1:20,23:1:28,32:1:35,40:1:57 I $P(DGINFO,U,I)']"" W !,"The field ",$P(^DD(45.9,I,0),U,1)," is missing data." S DGFLG=""
9 G GO:$P(DGINFO,"^",2)<DGCON
10 W !
11 K DGFLG,A,I
12 S DGINFO=^DG(45.9,DA,0)
13 F I=1:1:21,23:1:28,32:1:35,40:1:62 D
14 .Q:(I=9)&($P($G(^DG(45.9,DA,0)),"^",6)=3)
15 .I $P(DGINFO,U,I)']"" W !,"The field ",$P(^DD(45.9,I,0),U,1)," is missing data." S DGFLG=""
16 F I=49.5:2:57.5 I $P(DGINFO,U,I+13.5-(I-49.5/2))']"" W !,"The field ",$P(^DD(45.9,I,0),U,1)," is missing data." S DGFLG=""
17GO G:$D(DGFLG) ERR
18 I $P(DGINFO,U,2) S DGFY=$S($E($P(DGINFO,U,2),4,5)<10:($E($P(DGINFO,U,2),1,3)_"0000"),1:($E($P(DGINFO,U,2),1,3)+1_"0000"))
19 S E=$P(DGINFO,U,40),E=$S(E<3:1,E=3:2,E=4:3,1:4),T=$P(DGINFO,U,42),T=$S(T<3:1,T=3:2,1:3),J=$P(DGINFO,U,43),J=$S(J<3:1,J<5:2,1:3),DGSUM=E+T+J
20 S DGGRP="" G REHAB^DGRUG16:$P(DGINFO,"^",2)<DGCON,^DGRUG1
21QUIT K A,DA,DFN,DGCON,DGFLG,DGFY,DGGRP,DGINFO,DGPT,DGRUG,DGSUM,DIC,DIE,DR,E,G,I,J,T,Y
22 I $D(DGFCNH) K DGFCNH,DGCNH
23 Q
24ERR W !!,"A RUG-II GROUP CAN NOT BE DETERMINED ON THIS PATIENT ",! G QUIT
Note: See TracBrowser for help on using the repository browser.