- 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 Feb 19, 2025@00:16:24 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