DGPMEX ;ALB/MIR - EXTENDED BED CONTROL ; 02 APR 90 @8:00
;;5.3;Registration;**40,59**;Aug 13, 1993
;
S DGPMEX=1
EN D Q1 K ^UTILITY("DGPMVN",$J),^UTILITY("DGPMVD",$J)
W ! D LO^DGUTL S DIC="^DPT(",DIC(0)="AZEQM" D ^DIC G Q:Y'>0 S DFN=+Y
I '$D(^DGPM("APTT1",DFN)) W !,"No admissions on file",! G EN
EN1 S C=0 F I=0:0 S I=$O(^DGPM("ATID1",DFN,I)) Q:'I S N=$O(^(I,0)) I $D(^DGPM(+N,0)) S D=^(0),C=C+1,^UTILITY("DGPMVN",$J,C)=N_"^"_D,^UTILITY("DGPMVD",$J,+D)=N,^UTILITY("DGPMVDA",$J,N)=C
S (DGER,DGOK)=0 W !,"CHOOSE FROM:" F I=0:0 S I=$O(^UTILITY("DGPMVN",$J,I)) Q:'I S DGI=I,DGX=$P(^(I),"^",2,20) D W1 I '(I#5) D BREAK Q:DGER!DGOK
G EN:DGER I DGI#5 D BREAK G EN:DGER
S DGPMCA=+^UTILITY("DGPMVN",$J,DGOK),DGPMAN=$S($D(^DGPM(+DGPMCA,0)):^(0),1:""),^DISV(DUZ,"DGPMEX",DFN)=DGPMCA
I $D(DGPMEX) D PTF^DGPMV21 I $G(DGPME)]"" K DGPME G EN
K DGPME D ENEX^DGPMV20 I '$D(DGPMEX) G EN
I DGFL=2 G Q
ASK K ^UTILITY("DGPMVN",$J),^UTILITY("DGPMVD",$J)
W !!?10,"CHOOSE FROM:",!?15,"1 - Admit Patient",!?15,"2 - Transfer Patient",!?15,"3 - Discharge Patient",!?10,"Select Option: " R X:DTIME G:X["^"!'$T!(X="") EN
S Z="^1 ADMIT PATIENT^2 TRANSFER PATIENT^3 DISCHARGE PATIENT^ADMIT PATIENT^TRANSFER PATIENT^DISCHARGE PATIENT^" D IN^DGHELP
I %=-1 W !?5,"Enter:",!?10,"1 or A to edit admission",!?10,"2 or T to enter/edit a transfer",!?10,"3 or D to enter/edit the discharge" G ASK
S DGPMT=$S(X="A":1,X="T":2,X="D":3,1:X) I DGPMT'=1 D CA^DGPMV
I DGPMT=1 D
.L +^DGPM("C",DFN):0 I '$T D Q
..W !!," ** This patient's inpatient or lodger activity is being **",!," ** edited by another employee. Please try again later. **",!
.D PTF^DGPMV22(DFN,DGPMCA,.DGPME,DGPMCA) I $G(DGPME)]"" W !,DGPME,! Q
.S (DGPMY,DGPMHY)=+DGPMAN,(DGPMN,DGPM1X,DGPMOUT)=0,DGPMDA=DGPMCA D UC^DGPMV,DT^DGPMV3
.L -^DGPM("C",DFN)
G EN
Q K DGPMEX
Q1 K DIC,DFN,DGER,DGFL,DGI,DGPMAN,DGPMCA,DGPMN,DGPMDA,DGPMOUT,DGPMT,DGPMUC,DGX D Q^DGPMV3,Q^DGPMV2,Q^DGPMV1
Q
BREAK W !,"CHOOSE 1-",DGI W:$D(^UTILITY("DGPMVN",$J,DGI+1)) !,"<RETURN> TO CONTINUE",!,"OR '^' TO QUIT" W ": " R X:DTIME I $S('$T!(X["^"):1,X=""&'$D(^UTILITY("DGPMVN",$J,DGI+1)):1,1:0) S DGER=1 Q
I X="" Q
I X=" ",$D(^DISV(DUZ,"DGPMEX",DFN)) S DGX=^(DFN) I $D(^UTILITY("DGPMVDA",$J,+DGX)) S DGOK=^(+DGX) Q
I X'=+X!'$D(^UTILITY("DGPMVN",$J,+X)) W !!,*7,"INVALID RESPONSE",! G BREAK
S DGOK=X Q
W1 W !,$J(I,4),"> " S Y=+DGX X ^DD("DD") W Y,?30,$S('$D(^DG(405.1,+$P(DGX,"^",4),0)):"",$P(^(0),"^",7)]"":$P(^(0),"^",7),1:$E($P(^(0),"^",1),1,20))
W ?55,"TO: ",$S($D(^DIC(42,+$P(DGX,"^",6),0)):$E($P(^(0),"^",1),1,18),1:"") I $P(DGX,"^",18)=9 W !?23,"FROM: ",$S($D(^DIC(4,+$P(DGX,"^",5),0)):$P(^(0),"^",1),1:"")
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGPMEX 2680 printed Dec 13, 2024@02:49:31 Page 2
DGPMEX ;ALB/MIR - EXTENDED BED CONTROL ; 02 APR 90 @8:00
+1 ;;5.3;Registration;**40,59**;Aug 13, 1993
+2 ;
+3 SET DGPMEX=1
EN DO Q1
KILL ^UTILITY("DGPMVN",$JOB),^UTILITY("DGPMVD",$JOB)
+1 WRITE !
DO LO^DGUTL
SET DIC="^DPT("
SET DIC(0)="AZEQM"
DO ^DIC
if Y'>0
GOTO Q
SET DFN=+Y
+2 IF '$DATA(^DGPM("APTT1",DFN))
WRITE !,"No admissions on file",!
GOTO EN
EN1 SET C=0
FOR I=0:0
SET I=$ORDER(^DGPM("ATID1",DFN,I))
if 'I
QUIT
SET N=$ORDER(^(I,0))
IF $DATA(^DGPM(+N,0))
SET D=^(0)
SET C=C+1
SET ^UTILITY("DGPMVN",$JOB,C)=N_"^"_D
SET ^UTILITY("DGPMVD",$JOB,+D)=N
SET ^UTILITY("DGPMVDA",$JOB,N)=C
+1 SET (DGER,DGOK)=0
WRITE !,"CHOOSE FROM:"
FOR I=0:0
SET I=$ORDER(^UTILITY("DGPMVN",$JOB,I))
if 'I
QUIT
SET DGI=I
SET DGX=$PIECE(^(I),"^",2,20)
DO W1
IF '(I#5)
DO BREAK
if DGER!DGOK
QUIT
+2 if DGER
GOTO EN
IF DGI#5
DO BREAK
if DGER
GOTO EN
+3 SET DGPMCA=+^UTILITY("DGPMVN",$JOB,DGOK)
SET DGPMAN=$SELECT($DATA(^DGPM(+DGPMCA,0)):^(0),1:"")
SET ^DISV(DUZ,"DGPMEX",DFN)=DGPMCA
+4 IF $DATA(DGPMEX)
DO PTF^DGPMV21
IF $GET(DGPME)]""
KILL DGPME
GOTO EN
+5 KILL DGPME
DO ENEX^DGPMV20
IF '$DATA(DGPMEX)
GOTO EN
+6 IF DGFL=2
GOTO Q
ASK KILL ^UTILITY("DGPMVN",$JOB),^UTILITY("DGPMVD",$JOB)
+1 WRITE !!?10,"CHOOSE FROM:",!?15,"1 - Admit Patient",!?15,"2 - Transfer Patient",!?15,"3 - Discharge Patient",!?10,"Select Option: "
READ X:DTIME
if X["^"!'$TEST!(X="")
GOTO EN
+2 SET Z="^1 ADMIT PATIENT^2 TRANSFER PATIENT^3 DISCHARGE PATIENT^ADMIT PATIENT^TRANSFER PATIENT^DISCHARGE PATIENT^"
DO IN^DGHELP
+3 IF %=-1
WRITE !?5,"Enter:",!?10,"1 or A to edit admission",!?10,"2 or T to enter/edit a transfer",!?10,"3 or D to enter/edit the discharge"
GOTO ASK
+4 SET DGPMT=$SELECT(X="A":1,X="T":2,X="D":3,1:X)
IF DGPMT'=1
DO CA^DGPMV
+5 IF DGPMT=1
Begin DoDot:1
+6 LOCK +^DGPM("C",DFN):0
IF '$TEST
Begin DoDot:2
+7 WRITE !!," ** This patient's inpatient or lodger activity is being **",!," ** edited by another employee. Please try again later. **",!
End DoDot:2
QUIT
+8 DO PTF^DGPMV22(DFN,DGPMCA,.DGPME,DGPMCA)
IF $GET(DGPME)]""
WRITE !,DGPME,!
QUIT
+9 SET (DGPMY,DGPMHY)=+DGPMAN
SET (DGPMN,DGPM1X,DGPMOUT)=0
SET DGPMDA=DGPMCA
DO UC^DGPMV
DO DT^DGPMV3
+10 LOCK -^DGPM("C",DFN)
End DoDot:1
+11 GOTO EN
Q KILL DGPMEX
Q1 KILL DIC,DFN,DGER,DGFL,DGI,DGPMAN,DGPMCA,DGPMN,DGPMDA,DGPMOUT,DGPMT,DGPMUC,DGX
DO Q^DGPMV3
DO Q^DGPMV2
DO Q^DGPMV1
+1 QUIT
BREAK WRITE !,"CHOOSE 1-",DGI
if $DATA(^UTILITY("DGPMVN",$JOB,DGI+1))
WRITE !,"<RETURN> TO CONTINUE",!,"OR '^' TO QUIT"
WRITE ": "
READ X:DTIME
IF $SELECT('$TEST!(X["^"):1,X=""&'$DATA(^UTILITY("DGPMVN",$JOB,DGI+1)):1,1:0)
SET DGER=1
QUIT
+1 IF X=""
QUIT
+2 IF X=" "
IF $DATA(^DISV(DUZ,"DGPMEX",DFN))
SET DGX=^(DFN)
IF $DATA(^UTILITY("DGPMVDA",$JOB,+DGX))
SET DGOK=^(+DGX)
QUIT
+3 IF X'=+X!'$DATA(^UTILITY("DGPMVN",$JOB,+X))
WRITE !!,*7,"INVALID RESPONSE",!
GOTO BREAK
+4 SET DGOK=X
QUIT
W1 WRITE !,$JUSTIFY(I,4),"> "
SET Y=+DGX
XECUTE ^DD("DD")
WRITE Y,?30,$SELECT('$DATA(^DG(405.1,+$PIECE(DGX,"^",4),0)):"",$PIECE(^(0),"^",7)]"":$PIECE(^(0),"^",7),1:$EXTRACT($PIECE(^(0),"^",1),1,20))
+1 WRITE ?55,"TO: ",$SELECT($DATA(^DIC(42,+$PIECE(DGX,"^",6),0)):$EXTRACT($PIECE(^(0),"^",1),1,18),1:"")
IF $PIECE(DGX,"^",18)=9
WRITE !?23,"FROM: ",$SELECT($DATA(^DIC(4,+$PIECE(DGX,"^",5),0)):$PIECE(^(0),"^",1),1:"")
