DGDIS1 ;ALB/XAK-MRL - DISPOSITION PROCESSING ; 02/15/2004
;;5.3;Registration;**151,568**;Aug 13, 1993
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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGDIS1 1700 printed Oct 16, 2024@18:42:43 Page 2
DGDIS1 ;ALB/XAK-MRL - DISPOSITION PROCESSING ; 02/15/2004
+1 ;;5.3;Registration;**151,568**;Aug 13, 1993
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
