- DGRUG ;ALB/BOK/MLI - RUG-II GROUPER ; 21 OCT 86 11:00
- ;;5.3;Registration;**89,173,1015**;Aug 13, 1993;Build 21
- 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
- DGRUG ;ALB/BOK/MLI - RUG-II GROUPER ; 21 OCT 86 11:00
- +1 ;;5.3;Registration;**89,173,1015**;Aug 13, 1993;Build 21
- 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
