DGPMV35 ;ALB/MIR - CHECK-OUT LODGERS ; MAR 12 1990
;;5.3;Registration;**111**;Aug 13, 1993
;
I '$P(DGPMA,"^",4) W !,"Incomplete Check-Out Movement" S DIK="^DGPM(",DA=DGPMDA D ^DIK W " deleted" S DGPMA="" G Q
;D ADM^DGPMV33
Q Q
ONLY ;determine if this is the only CHECK-OUT movement type
N C,I S C=0
F I=0:0 S I=$O(^DG(405.1,"AT",5,I)) Q:'I I $D(^DG(405.1,I,0)),$P(^(0),"^",4) S C=C+1,DGPMCO=I I C>1 K DGPMCO Q
Q
REAS ;called from enter/edit reasons for lodging option
S (DIC,DIE)="^DG(406.41,",DIC(0)="AELQMZ",DLAYGO=406.41 D ^DIC G REASQ:Y<0,REAS:'Y!$P(Y,"^",3)
I '$P(Y,"^",3) S DR=.01,DA=+Y D ^DIE I '$D(Y) G REAS
REASQ K DA,DIC,DIE,DLAYGO,DR,X,Y Q
Q
DICS S DGX=$P(DGPMAN,"^",4) I $S('$D(^DG(405.1,+DGX,0)):0,'$D(^DG(405.1,+Y,"F",+DGX)):1,1:0) S DGER=1 Q
S DGER=0
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGPMV35 801 printed Dec 13, 2024@02:50:22 Page 2
DGPMV35 ;ALB/MIR - CHECK-OUT LODGERS ; MAR 12 1990
+1 ;;5.3;Registration;**111**;Aug 13, 1993
+2 ;
+3 IF '$PIECE(DGPMA,"^",4)
WRITE !,"Incomplete Check-Out Movement"
SET DIK="^DGPM("
SET DA=DGPMDA
DO ^DIK
WRITE " deleted"
SET DGPMA=""
GOTO Q
+4 ;D ADM^DGPMV33
Q QUIT
ONLY ;determine if this is the only CHECK-OUT movement type
+1 NEW C,I
SET C=0
+2 FOR I=0:0
SET I=$ORDER(^DG(405.1,"AT",5,I))
if 'I
QUIT
IF $DATA(^DG(405.1,I,0))
IF $PIECE(^(0),"^",4)
SET C=C+1
SET DGPMCO=I
IF C>1
KILL DGPMCO
QUIT
+3 QUIT
REAS ;called from enter/edit reasons for lodging option
+1 SET (DIC,DIE)="^DG(406.41,"
SET DIC(0)="AELQMZ"
SET DLAYGO=406.41
DO ^DIC
if Y<0
GOTO REASQ
if 'Y!$PIECE(Y,"^",3)
GOTO REAS
+2 IF '$PIECE(Y,"^",3)
SET DR=.01
SET DA=+Y
DO ^DIE
IF '$DATA(Y)
GOTO REAS
REASQ KILL DA,DIC,DIE,DLAYGO,DR,X,Y
QUIT
+1 QUIT
DICS SET DGX=$PIECE(DGPMAN,"^",4)
IF $SELECT('$DATA(^DG(405.1,+DGX,0)):0,'$DATA(^DG(405.1,+Y,"F",+DGX)):1,1:0)
SET DGER=1
QUIT
+1 SET DGER=0
+2 QUIT
