- 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
