DGPMV0 ;ALB/MRL/MIR - SPECIAL LOOK-UP FOR LODGERS; 10 MAR 89
;;5.3;Registration;;Aug 13, 1993
SPCLU ;Special (quick) look-up for check-out lodgers
S DGER=0,DIC="^DPT(",DIC(0)="EQMZ" R !,"Check-out PATIENT: ",X:DTIME I '$T!(X["^")!(X="") S DGER=1 Q
I X["?" D COHELP G SPCLU
D ^DIC I Y'>0 G SPCLU
I '$D(^DGPM("APTT4",+Y)) W !?5,"Patient was never a lodger ??" G SPCLU
S DFN=+Y
Q
COHELP ;help for check-out lodgers...list patients to choose from
W !," ANSWER WITH PATIENT, OR SOCIAL SECURITY NUMBER, OR WARD LOCATION, OR",!," ROOM-BED",!,"CHOOSE FROM:"
S (DGCT,DGFL)=0
F DFN=0:0 S DFN=$O(^DGPM("APTT4",DFN)) Q:'DFN I $D(^DPT(DFN,0)) D DEM^VADPT I VADM(1)]"" S DGCT=DGCT+1 D WRITE Q:DGFL
D KVAR^VADPT K DGCT,DGFL,DFN,DIR,X,Y Q
WRITE ;write out identifiers
I DGCT>(IOSL-4) S DIR(0)="E" D ^DIR I 'Y S DGFL=1 Q
W !?4,VADM(1)," ",VA("PID")," " I VADM(3) W $E(VADM(3),4,5),"-",$E(VADM(3),6,7),"-",$E(VADM(3),2,3)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGPMV0 948 printed Sep 23, 2025@20:25:58 Page 2
DGPMV0 ;ALB/MRL/MIR - SPECIAL LOOK-UP FOR LODGERS; 10 MAR 89
+1 ;;5.3;Registration;;Aug 13, 1993
SPCLU ;Special (quick) look-up for check-out lodgers
+1 SET DGER=0
SET DIC="^DPT("
SET DIC(0)="EQMZ"
READ !,"Check-out PATIENT: ",X:DTIME
IF '$TEST!(X["^")!(X="")
SET DGER=1
QUIT
+2 IF X["?"
DO COHELP
GOTO SPCLU
+3 DO ^DIC
IF Y'>0
GOTO SPCLU
+4 IF '$DATA(^DGPM("APTT4",+Y))
WRITE !?5,"Patient was never a lodger ??"
GOTO SPCLU
+5 SET DFN=+Y
+6 QUIT
COHELP ;help for check-out lodgers...list patients to choose from
+1 WRITE !," ANSWER WITH PATIENT, OR SOCIAL SECURITY NUMBER, OR WARD LOCATION, OR",!," ROOM-BED",!,"CHOOSE FROM:"
+2 SET (DGCT,DGFL)=0
+3 FOR DFN=0:0
SET DFN=$ORDER(^DGPM("APTT4",DFN))
if 'DFN
QUIT
IF $DATA(^DPT(DFN,0))
DO DEM^VADPT
IF VADM(1)]""
SET DGCT=DGCT+1
DO WRITE
if DGFL
QUIT
+4 DO KVAR^VADPT
KILL DGCT,DGFL,DFN,DIR,X,Y
QUIT
WRITE ;write out identifiers
+1 IF DGCT>(IOSL-4)
SET DIR(0)="E"
DO ^DIR
IF 'Y
SET DGFL=1
QUIT
+2 WRITE !?4,VADM(1)," ",VA("PID")," "
IF VADM(3)
WRITE $EXTRACT(VADM(3),4,5),"-",$EXTRACT(VADM(3),6,7),"-",$EXTRACT(VADM(3),2,3)
+3 QUIT
