| [613] | 1 | DGDIS1 ;ALB/XAK-MRL - DISPOSITION PROCESSING ; 02/15/2004
|
|---|
| 2 | ;;5.3;Registration;**151,568**;Aug 13, 1993
|
|---|
| 3 | 1 ;HOSPITAL, NHCU OR DOM ADMISSION
|
|---|
| 4 | A D DISPO^DGPMV K DGPMDER
|
|---|
| 5 | Q
|
|---|
| 6 | ;
|
|---|
| 7 | 2 ;"SCHEDULE ADMISSION FOR WARD
|
|---|
| 8 | 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
|
|---|
| 9 | 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
|
|---|
| 10 | I $D(%Y),%Y["?" W !,"ENTER 'Y'ES OR 'N'O",! G REASK
|
|---|
| 11 | 22 Q:Y'>0 S DGSKIP="",DGSCH=+Y S:$P(Y,"^",3) DGNEW=1 D EN^DGSCHAD K DGSKIP Q
|
|---|
| 12 | ;Q:Y'>0 S DA=+Y,DR="[DGSCHADMIT]",DIE="^DGS(41.1,",DGSKIP=1 D ^DIE K DGSKIP Q
|
|---|
| 13 | ;
|
|---|
| 14 | 3 ;WAITING LIST
|
|---|
| 15 | 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
|
|---|
| 16 | ;
|
|---|
| 17 | 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
|
|---|
| 18 | ;
|
|---|
| 19 | Q Q
|
|---|
| 20 | 4 ;FUTURE APPOINTMENT
|
|---|
| 21 | W !,"APPOINTMENTS CAN NO LONGER BE MADE USING THIS OPTION."
|
|---|
| 22 | Q
|
|---|
| 23 | ;
|
|---|
| 24 | CO(DFN,SDDT,SDISHDL,SDISDEL) ; -- ask check out questions
|
|---|
| 25 | N DA,DFN1,DGDFN,DGDFN1,DGCO,DIE,DGODSND,SDCOQUIT,SDOE,Y
|
|---|
| 26 | S SDISDEL=0
|
|---|
| 27 | S SDOE=$$GETDISP^SDVSIT2(DFN,SDDT) G COQ:'SDOE
|
|---|
| 28 | I '$$SCE^DGSDU(+SDOE,7,0) D INT^SDCO6(SDOE,.SDCOQUIT)
|
|---|
| 29 | I '$D(SDCOQUIT),$$ASK^SDCO6 D EN^SDCO(SDOE,SDISHDL,1)
|
|---|
| 30 | I '$$SCE^DGSDU(+SDOE,7,0) W !!,*7,"This disposition must be checked out to continue." S SDISDEL=1
|
|---|
| 31 | COQ Q
|
|---|
