DGRUGGR ;ALB/BOK - RUG-II GROUPER FOR A PATIENT ; 14 MAY 87 09:00
;;5.3;Registration;**89,173**;Aug 13, 1993
;
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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGRUGGR 1499 printed Nov 22, 2024@18:08:23 Page 2
DGRUGGR ;ALB/BOK - RUG-II GROUPER FOR A PATIENT ; 14 MAY 87 09:00
+1 ;;5.3;Registration;**89,173**;Aug 13, 1993
+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
