DGRUG16 ;ALB/BOK/MLI - RUG-II GROUPER ; 21 OCT 86 11:00
;;5.3;Registration;**89**;Aug 13, 1993
INPUT W ! S DIC="^DG(45.9,",DIC(0)="AEQMN",DIC("S")="I $S('$D(^DG(45.9,+Y,""C"")):1,$D(^DG(45.9,+Y,""C""))&(+^DG(45.9,+Y,""C"")=1!(+^(""C"")=5)):1,1:0)" D ^DIC K DIC G QUIT^DGRUG1:Y'>0
S DIE="^DG(45.9,",DR="[DGRUG]",(DGPT,DA)=+Y,DGD=$P(^DG(45.9,DA,0),U,7) D ^DIE
G:'$D(DA) QUIT^DGRUG1
SET W ! K DGFLAG,A,I S DGINFO=^DG(45.9,DA,0) 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 DGFLAG=1,A(I)=I
G:$D(DGFLAG) ERR
I $P(DGINFO,U,14)=2&($P(DGINFO,U,40)<5) W !,*7,"If 'NASAL OR ENTERIC FEEDING' ",!," is marked 'Y'es then question 'EATING' must be marked '5'.",! F I=14,40 S A(I)=I S DGFLAG=1
G:$D(DGFLAG) EDIT
I $P(DGINFO,U,2) S DGFY=$S($E($P(DGINFO,U,2),4,5)<10:$E($P(DGINFO,U,2),2,3),1:$E($P(DGINFO,U,2),2,3)+1)
K DGFLAG,A F I=48:2:56 I $P(DGINFO,U,I)=1&($P(DGINFO,U,I+1)'=0) S A(I)=I,A(I+1)=I+1,DGFLAG=1
I $D(DGFLAG) W !,*7,"For each of the therapy questions,'DAYS PER WEEK' must be '0' if level is '1'.",! G EDIT
K DGFLAG,A F I=48:2:56 I $P(DGINFO,U,I)'=1&($P(DGINFO,U,I+1)=0) S A(I)=I,A(I+1)=I+1,DGFLAG=1
I $D(DGFLAG) W !,*7,"For each of the therapy questions,'DAYS PER WEEK' must be greater than '0'",!,"if level is greater than '1'.",! G EDIT
;;changes 4/18/96 cmm
K A,DGFLAG
N RIEN
I $D(^DG(45.9,DGPT,"R")),$P(^("R"),U)]"" S RIEN=$P($P(^("R"),U),";") S DGSER=$S($D(^DIC(42,RIEN,0)):$P(^(0),U,3),1:0) I $E(DGSER)'=$P(DGINFO,U,9) S DGFLAG=1,A(9)=9,A(70)=70
I $D(DGFLAG) W !,*7,"Service of ward must be the same as bedsection" G EDIT
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
REHAB F E=48:2:56 I $P(DGINFO,U,E)=3&($P(DGINFO,U,E+1)>4) G GROUPR^DGRUG1
G SPECIAL^DGRUG1
ERR W !!,"A RUG-II GROUP CAN NOT BE DETERMINED ON THIS PATIENT ",!
ERR1 W !,"Do you wish to edit now" S %=1 D YN^DICN G EDIT:%=1,INCOMP:%=-1!(%=2),HELP:%=0
Q
EDIT S DIC="^DG(45.9,"_DA,DIC(0)="AEQMZ",DIE="^DG(45.9," F I=0:0 S I=$O(A(I)) Q:I'>0 S DR=I D ^DIE G ERR1:$D(Y) I X=1,(I>47),(I<57),'(I#2),$P(^DG(45.9,DGPT,0),"^",I+1)']"" S $P(^(0),"^",I+1)=0,I=I+1
K A,DGFLAG,I G SET
EN S DIC="^DG(45.9,",DIC(0)="AEQM" D ^DIC G QUIT^DGRUG1:Y'>0 S (DGPT,DA)=+Y G SET
HELP W !,"There are fields missing data for this patient. The PAI will",!," not be complete until all data is entered. You can",!," complete the PAI at this time by responding 'Y'es.",! G ERR1
INCOMP S DA=DGPT,DIE="^DG(45.9,",DR="80///5" D ^DIE G QUIT^DGRUG1
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGRUG16 2598 printed Nov 22, 2024@18:08:07 Page 2
DGRUG16 ;ALB/BOK/MLI - RUG-II GROUPER ; 21 OCT 86 11:00
+1 ;;5.3;Registration;**89**;Aug 13, 1993
INPUT WRITE !
SET DIC="^DG(45.9,"
SET DIC(0)="AEQMN"
SET DIC("S")="I $S('$D(^DG(45.9,+Y,""C"")):1,$D(^DG(45.9,+Y,""C""))&(+^DG(45.9,+Y,""C"")=1!(+^(""C"")=5)):1,1:0)"
DO ^DIC
KILL DIC
if Y'>0
GOTO QUIT^DGRUG1
+1 SET DIE="^DG(45.9,"
SET DR="[DGRUG]"
SET (DGPT,DA)=+Y
SET DGD=$PIECE(^DG(45.9,DA,0),U,7)
DO ^DIE
+2 if '$DATA(DA)
GOTO QUIT^DGRUG1
SET WRITE !
KILL DGFLAG,A,I
SET DGINFO=^DG(45.9,DA,0)
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 DGFLAG=1
SET A(I)=I
+1 if $DATA(DGFLAG)
GOTO ERR
+2 IF $PIECE(DGINFO,U,14)=2&($PIECE(DGINFO,U,40)<5)
WRITE !,*7,"If 'NASAL OR ENTERIC FEEDING' ",!," is marked 'Y'es then question 'EATING' must be marked '5'.",!
FOR I=14,40
SET A(I)=I
SET DGFLAG=1
+3 if $DATA(DGFLAG)
GOTO EDIT
+4 IF $PIECE(DGINFO,U,2)
SET DGFY=$SELECT($EXTRACT($PIECE(DGINFO,U,2),4,5)<10:$EXTRACT($PIECE(DGINFO,U,2),2,3),1:$EXTRACT($PIECE(DGINFO,U,2),2,3)+1)
+5 KILL DGFLAG,A
FOR I=48:2:56
IF $PIECE(DGINFO,U,I)=1&($PIECE(DGINFO,U,I+1)'=0)
SET A(I)=I
SET A(I+1)=I+1
SET DGFLAG=1
+6 IF $DATA(DGFLAG)
WRITE !,*7,"For each of the therapy questions,'DAYS PER WEEK' must be '0' if level is '1'.",!
GOTO EDIT
+7 KILL DGFLAG,A
FOR I=48:2:56
IF $PIECE(DGINFO,U,I)'=1&($PIECE(DGINFO,U,I+1)=0)
SET A(I)=I
SET A(I+1)=I+1
SET DGFLAG=1
+8 IF $DATA(DGFLAG)
WRITE !,*7,"For each of the therapy questions,'DAYS PER WEEK' must be greater than '0'",!,"if level is greater than '1'.",!
GOTO EDIT
+9 ;;changes 4/18/96 cmm
+10 KILL A,DGFLAG
+11 NEW RIEN
+12 IF $DATA(^DG(45.9,DGPT,"R"))
IF $PIECE(^("R"),U)]""
SET RIEN=$PIECE($PIECE(^("R"),U),";")
SET DGSER=$SELECT($DATA(^DIC(42,RIEN,0)):$PIECE(^(0),U,3),1:0)
IF $EXTRACT(DGSER)'=$PIECE(DGINFO,U,9)
SET DGFLAG=1
SET A(9)=9
SET A(70)=70
+13 IF $DATA(DGFLAG)
WRITE !,*7,"Service of ward must be the same as bedsection"
GOTO EDIT
+14 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
REHAB FOR E=48:2:56
IF $PIECE(DGINFO,U,E)=3&($PIECE(DGINFO,U,E+1)>4)
GOTO GROUPR^DGRUG1
+1 GOTO SPECIAL^DGRUG1
ERR WRITE !!,"A RUG-II GROUP CAN NOT BE DETERMINED ON THIS PATIENT ",!
ERR1 WRITE !,"Do you wish to edit now"
SET %=1
DO YN^DICN
if %=1
GOTO EDIT
if %=-1!(%=2)
GOTO INCOMP
if %=0
GOTO HELP
+1 QUIT
EDIT SET DIC="^DG(45.9,"_DA
SET DIC(0)="AEQMZ"
SET DIE="^DG(45.9,"
FOR I=0:0
SET I=$ORDER(A(I))
if I'>0
QUIT
SET DR=I
DO ^DIE
if $DATA(Y)
GOTO ERR1
IF X=1
IF (I>47)
IF (I<57)
IF '(I#2)
IF $PIECE(^DG(45.9,DGPT,0),"^",I+1)']""
SET $PIECE(^(0),"^",I+1)=0
SET I=I+1
+1 KILL A,DGFLAG,I
GOTO SET
EN SET DIC="^DG(45.9,"
SET DIC(0)="AEQM"
DO ^DIC
if Y'>0
GOTO QUIT^DGRUG1
SET (DGPT,DA)=+Y
GOTO SET
HELP WRITE !,"There are fields missing data for this patient. The PAI will",!," not be complete until all data is entered. You can",!," complete the PAI at this time by responding 'Y'es.",!
GOTO ERR1
INCOMP SET DA=DGPT
SET DIE="^DG(45.9,"
SET DR="80///5"
DO ^DIE
GOTO QUIT^DGRUG1
