DGDIS1.m

DGDIS1 ;ALB/XAK-MRL - DISPOSITION PROCESSING ; 02/15/2004

 ;;5.3;Registration;**151,568,1015**;Aug 13, 1993;Build 21

1 ;HOSPITAL, NHCU OR DOM ADMISSION

A D DISPO^DGPMV K DGPMDER

 Q

 ;

2 ;"SCHEDULE ADMISSION FOR WARD

 K %DT S DLAYGO=41.1,DIC(0)="L" I $D(^DGS(41.1,"B",DFN)) S DIC(0)="LEQ" K DLAYGO W !?7,*7,"SCHEDULED ADMISSION ALREADY ON FILE.",! F I=0:0 S I=$O(^DGS(41.1,"B",DFN,I)) Q:'I  S DA=I,DIC="^DGS(41.1,",DR=0 D EN^DIQ

REASK S DIC=41.1,X=$S('$D(DLAYGO):DFN,1:$P(^DPT(DFN,0),U,1)),D="B" S:$D(DLAYGO) DIC(0)=DIC(0)_"MZ" D @($S(X=DFN:"IX",1:"")_"^DIC") I Y<0,$D(DLAYGO) S X=$E(^DPT(DFN,0),1)_$E($P(^(0),U,9),6,9) D ^DIC

 I $D(%Y),%Y["?" W !,"ENTER 'Y'ES OR 'N'O",! G REASK

22 Q:Y'>0  S DGSKIP="",DGSCH=+Y S:$P(Y,"^",3) DGNEW=1 D EN^DGSCHAD K DGSKIP Q

 ;Q:Y'>0  S DA=+Y,DR="[DGSCHADMIT]",DIE="^DGS(41.1,",DGSKIP=1 D ^DIE K DGSKIP Q

 ;

3 ;WAITING LIST

DIV W !,"Waiting List Entry",! S DIC="^DGWAIT(",DIC(0)="ZL",X=$S($D(^DG(40.8,+DIV,0)):$P(^(0),"^",1),1:"") D ^DIC G Q:Y'>0 S DIV=+Y

 ;

PAT S:'($D(^DGWAIT(+DIV,"P",0))\10) ^DGWAIT(DIV,"P",0)="^42.51PA^^" S D="B",DA(1)=DIV,DIC="^DGWAIT("_DIV_",""P"",",DIC(0)="ZL",DP=42.51,X=$P(^DPT(DFN,0),"^",1) D IX^DIC G Q:Y'>0 S DGWAIT=0 D EDIT^DGWAIT Q

 ;

Q Q

4 ;FUTURE APPOINTMENT

 W !,"APPOINTMENTS CAN NO LONGER BE MADE USING THIS OPTION."

 Q

 ;

CO(DFN,SDDT,SDISHDL,SDISDEL) ; -- ask check out questions

 N DA,DFN1,DGDFN,DGDFN1,DGCO,DIE,DGODSND,SDCOQUIT,SDOE,Y

 S SDISDEL=0

 S SDOE=$$GETDISP^SDVSIT2(DFN,SDDT) G COQ:'SDOE

 I '$$SCE^DGSDU(+SDOE,7,0) D INT^SDCO6(SDOE,.SDCOQUIT)

 I '$D(SDCOQUIT),$$ASK^SDCO6 D EN^SDCO(SDOE,SDISHDL,1)

 I '$$SCE^DGSDU(+SDOE,7,0) W !!,*7,"This disposition must be checked out to continue." S SDISDEL=1

COQ Q

DGDIS1    ;ALB/XAK-MRL - DISPOSITION PROCESSING ; 02/15/2004

 +1       ;;5.3;Registration;**151,568,1015**;Aug 13, 1993;Build 21

1         ;HOSPITAL, NHCU OR DOM ADMISSION

A          DO DISPO^DGPMV

           KILL DGPMDER

 +1        QUIT 

 +2       ;

2         ;"SCHEDULE ADMISSION FOR WARD

 +1        KILL %DT

           SET DLAYGO=41.1

           SET DIC(0)="L"

           IF $DATA(^DGS(41.1,"B",DFN))

               SET DIC(0)="LEQ"

               KILL DLAYGO

               WRITE !?7,*7,"SCHEDULED ADMISSION ALREADY ON FILE.",!

               FOR I=0:0

                   SET I=$ORDER(^DGS(41.1,"B",DFN,I))

                   IF 'I

                       QUIT 

                   SET DA=I

                   SET DIC="^DGS(41.1,"

                   SET DR=0

                   DO EN^DIQ

REASK      SET DIC=41.1

           SET X=$SELECT('$DATA(DLAYGO):DFN,1:$PIECE(^DPT(DFN,0),U,1))

           SET D="B"

           IF $DATA(DLAYGO)

               SET DIC(0)=DIC(0)_"MZ"

           DO @($SELECT(X=DFN:"IX",1:"")_"^DIC")

           IF Y<0

               IF $DATA(DLAYGO)

                   SET X=$EXTRACT(^DPT(DFN,0),1)_$EXTRACT($PIECE(^(0),U,9),6,9)

                   DO ^DIC

 +1        IF $DATA(%Y)

               IF %Y["?"

                   WRITE !,"ENTER 'Y'ES OR 'N'O",!

                   GOTO REASK

22         IF Y'>0

               QUIT 

           SET DGSKIP=""

           SET DGSCH=+Y

           IF $PIECE(Y,"^",3)

               SET DGNEW=1

           DO EN^DGSCHAD

           KILL DGSKIP

           QUIT 

 +1       ;Q:Y'>0  S DA=+Y,DR="[DGSCHADMIT]",DIE="^DGS(41.1,",DGSKIP=1 D ^DIE K DGSKIP Q

 +2       ;

3         ;WAITING LIST

DIV        WRITE !,"Waiting List Entry",!

           SET DIC="^DGWAIT("

           SET DIC(0)="ZL"

           SET X=$SELECT($DATA(^DG(40.8,+DIV,0)):$PIECE(^(0),"^",1),1:"")

           DO ^DIC

           IF Y'>0

               GOTO Q

           SET DIV=+Y

 +1       ;

PAT        IF '($DATA(^DGWAIT(+DIV,"P",0))\10)

               SET ^DGWAIT(DIV,"P",0)="^42.51PA^^"

           SET D="B"

           SET DA(1)=DIV

           SET DIC="^DGWAIT("_DIV_",""P"","

           SET DIC(0)="ZL"

           SET DP=42.51

           SET X=$PIECE(^DPT(DFN,0),"^",1)

           DO IX^DIC

           IF Y'>0

               GOTO Q

           SET DGWAIT=0

           DO EDIT^DGWAIT

           QUIT 

 +1       ;

Q          QUIT 

4         ;FUTURE APPOINTMENT

 +1        WRITE !,"APPOINTMENTS CAN NO LONGER BE MADE USING THIS OPTION."

 +2        QUIT 

 +3       ;

CO(DFN,SDDT,SDISHDL,SDISDEL) ; -- ask check out questions

 +1        NEW DA,DFN1,DGDFN,DGDFN1,DGCO,DIE,DGODSND,SDCOQUIT,SDOE,Y

 +2        SET SDISDEL=0

 +3        SET SDOE=$$GETDISP^SDVSIT2(DFN,SDDT)

           IF 'SDOE

               GOTO COQ

 +4        IF '$$SCE^DGSDU(+SDOE,7,0)

               DO INT^SDCO6(SDOE,.SDCOQUIT)

 +5        IF '$DATA(SDCOQUIT)

               IF $$ASK^SDCO6

                   DO EN^SDCO(SDOE,SDISHDL,1)

 +6        IF '$$SCE^DGSDU(+SDOE,7,0)

               WRITE !!,*7,"This disposition must be checked out to continue."

               SET SDISDEL=1

COQ        QUIT