DGRUG ;ALB/BOK/MLI - RUG-II GROUPER ; 21 OCT 86 11:00
;;5.3;Registration;**89,173**;Aug 13, 1993
INPUT W ! S DIC="^DG(45.9,",DIC(0)="AEQMN",DIC("S")="D CLOSEOUT^DGRUG I $S($P(^(0),U,2)<DGLCO:0,'$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:21,23:1:28,32:1:35,40:1:62 I $P(DGINFO,U,I)']"" D
.Q:($P(DGINFO,U,6)=3)&(I=9)
.W !,"The field ",$P(^DD(45.9,I,0),U,1)," is missing data." S DGFLAG=1,A(I)=I
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 DGFLAG=1,A(I)=I
G:$D(DGFLAG) 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"))
F DGI=1:1:6 D @(DGI_"^DGRUG1") G:$D(DGFLAG) EDIT
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)&($P($G(^DG(45.9,DGPT,0)),U,6)'=3) 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 G CVD^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)']""),($P(^DG(45.9,DGPT,0),"^",I+1.5)']"") S $P(^(0),"^",I+1)=0,$P(^(0),"^",I+15-(I-48/2))=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
CLOSEOUT ;FIND LAST CLOSEOUT DATE - FOR USE BY ENTER/EDIT,TRANSMISSION
S DGLCO=$S($E(DT,4,7)>1200:$E(DT,1,3)_"1001",$E(DT,4,7)<600:$E(DT,1,3)-1_"1001",1:$E(DT,1,3)_"0401")
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGRUG 2414 printed Nov 22, 2024@18:08:06 Page 2
DGRUG ;ALB/BOK/MLI - RUG-II GROUPER ; 21 OCT 86 11:00
+1 ;;5.3;Registration;**89,173**;Aug 13, 1993
INPUT WRITE !
SET DIC="^DG(45.9,"
SET DIC(0)="AEQMN"
SET DIC("S")="D CLOSEOUT^DGRUG I $S($P(^(0),U,2)<DGLCO:0,'$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
+1 SET DGINFO=^DG(45.9,DA,0)
+2 FOR I=1:1:21,23:1:28,32:1:35,40:1:62
IF $PIECE(DGINFO,U,I)']""
Begin DoDot:1
+3 if ($PIECE(DGINFO,U,6)=3)&(I=9)
QUIT
+4 WRITE !,"The field ",$PIECE(^DD(45.9,I,0),U,1)," is missing data."
SET DGFLAG=1
SET A(I)=I
End DoDot:1
+5 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 DGFLAG=1
SET A(I)=I
+6 if $DATA(DGFLAG)
GOTO ERR
+7 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"))
+8 FOR DGI=1:1:6
DO @(DGI_"^DGRUG1")
if $DATA(DGFLAG)
GOTO EDIT
+9 KILL A,DGFLAG
+10 NEW RIEN
+11 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)&($PIECE($GET(^DG(45.9,DGPT,0)),U,6)'=3)
SET DGFLAG=1
SET A(9)=9
SET A(70)=70
+12 IF $DATA(DGFLAG)
WRITE !,*7,"Service of ward must be the same as bedsection"
GOTO EDIT
+13 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
GOTO CVD^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,"
+1 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)']"")
IF ($PIECE(^DG(45.9,DGPT,0),"^",I+1.5)']"")
SET $PIECE(^(0),"^",I+1)=0
SET $PIECE(^(0),"^",I+15-(I-48/2))=0
SET I=I+1
+2 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
CLOSEOUT ;FIND LAST CLOSEOUT DATE - FOR USE BY ENTER/EDIT,TRANSMISSION
+1 SET DGLCO=$SELECT($EXTRACT(DT,4,7)>1200:$EXTRACT(DT,1,3)_"1001",$EXTRACT(DT,4,7)<600:$EXTRACT(DT,1,3)-1_"1001",1:$EXTRACT(DT,1,3)_"0401")
+2 QUIT
