DGRUGGR.m

DGRUGGR ;ALB/BOK - RUG-II GROUPER FOR A PATIENT ; 14 MAY 87  09:00

 ;;5.3;Registration;**89,173,1015**;Aug 13, 1993;Build 21

 ;

EN I '$D(DGCNH),$D(^XUSEC("DG RUG SUPERVISOR",DUZ)) S (DGFCNH,DGCNH)=""

 S DIC="^DG(45.9,",DIC(0)="AEQM",DIC("S")="I $$PTSCREEN^DGRUGU1()"

 D ^DIC G QUIT:Y'>0 S (DGPT,DA)=+Y

SET 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

 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=""

 G GO:$P(DGINFO,"^",2)<DGCON

 W !

 K DGFLG,A,I

 S DGINFO=^DG(45.9,DA,0)

 F I=1:1:21,23:1:28,32:1:35,40:1:62 D

 .Q:(I=9)&($P($G(^DG(45.9,DA,0)),"^",6)=3)

 .I $P(DGINFO,U,I)']"" W !,"The field ",$P(^DD(45.9,I,0),U,1)," is missing data." S DGFLG=""

 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=""

GO G:$D(DGFLG) ERR

 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"))

 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

 S DGGRP="" G REHAB^DGRUG16:$P(DGINFO,"^",2)<DGCON,^DGRUG1

QUIT K A,DA,DFN,DGCON,DGFLG,DGFY,DGGRP,DGINFO,DGPT,DGRUG,DGSUM,DIC,DIE,DR,E,G,I,J,T,Y

 I $D(DGFCNH) K DGFCNH,DGCNH

 Q

ERR W !!,"A RUG-II GROUP CAN NOT BE DETERMINED ON THIS PATIENT ",! G QUIT

DGRUGGR   ;ALB/BOK - RUG-II GROUPER FOR A PATIENT ; 14 MAY 87  09:00

 +1       ;;5.3;Registration;**89,173,1015**;Aug 13, 1993;Build 21

 +2       ;

EN         IF '$DATA(DGCNH)

               IF $DATA(^XUSEC("DG RUG SUPERVISOR",DUZ))

                   SET (DGFCNH,DGCNH)=""

 +1        SET DIC="^DG(45.9,"

           SET DIC(0)="AEQM"

           SET DIC("S")="I $$PTSCREEN^DGRUGU1()"

 +2        DO ^DIC

           IF Y'>0

               GOTO QUIT

           SET (DGPT,DA)=+Y

SET        WRITE !

           SET DGCON=$SELECT('$DATA(^DG(43,1,"RUG")):2891002,$PIECE(^("RUG"),"^",2):$PIECE(^("RUG"),"^",2),1:2891002)

           SET DGINFO=^DG(45.9,DA,0)

           KILL DGFLG,A,I

 +1        IF $PIECE(DGINFO,"^",2)<DGCON

               FOR I=1:1:20,23:1:28,32:1:35,40:1:57

                   IF $PIECE(DGINFO,U,I)']""

                       WRITE !,"The field ",$PIECE(^DD(45.9,I,0),U,1)," is missing data."

                       SET DGFLG=""

 +2        IF $PIECE(DGINFO,"^",2)<DGCON

               GOTO GO

 +3        WRITE !

 +4        KILL DGFLG,A,I

 +5        SET DGINFO=^DG(45.9,DA,0)

 +6        FOR I=1:1:21,23:1:28,32:1:35,40:1:62

               Begin DoDot:1

 +7                IF (I=9)&($PIECE($GET(^DG(45.9,DA,0)),"^",6)=3)

                       QUIT 

 +8                IF $PIECE(DGINFO,U,I)']""

                       WRITE !,"The field ",$PIECE(^DD(45.9,I,0),U,1)," is missing data."

                       SET DGFLG=""

               End DoDot:1

 +9        FOR I=49.5:2:57.5

               IF $PIECE(DGINFO,U,I+13.5-(I-49.5/2))']""

                   WRITE !,"The field ",$PIECE(^DD(45.9,I,0),U,1)," is missing data."

                   SET DGFLG=""

GO         IF $DATA(DGFLG)

               GOTO ERR

 +1        IF $PIECE(DGINFO,U,2)

               SET DGFY=$SELECT($EXTRACT($PIECE(DGINFO,U,2),4,5)<10:($EXTRACT($PIECE(DGINFO,U,2),1,3)_"0000"),1:($EXTRACT($PIECE(DGINFO,U,2),1,3)+1_"0000"))

 +2        SET E=$PIECE(DGINFO,U,40)

           SET E=$SELECT(E<3:1,E=3:2,E=4:3,1:4)

           SET T=$PIECE(DGINFO,U,42)

           SET T=$SELECT(T<3:1,T=3:2,1:3)

           SET J=$PIECE(DGINFO,U,43)

           SET J=$SELECT(J<3:1,J<5:2,1:3)

           SET DGSUM=E+T+J

 +3        SET DGGRP=""

           IF $PIECE(DGINFO,"^",2)<DGCON

               GOTO REHAB^DGRUG16

           GOTO ^DGRUG1

QUIT       KILL A,DA,DFN,DGCON,DGFLG,DGFY,DGGRP,DGINFO,DGPT,DGRUG,DGSUM,DIC,DIE,DR,E,G,I,J,T,Y

 +1        IF $DATA(DGFCNH)

               KILL DGFCNH,DGCNH

 +2        QUIT 

ERR        WRITE !!,"A RUG-II GROUP CAN NOT BE DETERMINED ON THIS PATIENT ",!

           GOTO QUIT