- 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 Feb 19, 2025@00:24:26 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
