DGPMEX ;ALB/MIR - EXTENDED BED CONTROL ; [ 03/23/2004 9:49 AM ]
;;5.3;Registration;**40,59,1005,1015**;Aug 13, 1993;Build 21
;IHS/ANMC/LJF 03/02/2001 added kill of patient variables
; removed calls to PTF code
; 01/09/2002 fixed code to see duplicate admissions
;IHS/ITSC/WAR 03/11/04 Changed ^DIC(4 to using $$GET1^DIQ
;IHS/OIT/LJF 04/06/2006 PATCH 1005 don't ask name if called by CODE option
;
S DGPMEX=1
EN D Q1 K ^UTILITY("DGPMVN",$J),^UTILITY("DGPMVD",$J)
;
;IHS/OIT/LJF 04/06/2006 PATCH 1005 don't ask name again if called by CODE
;W ! D LO^DGUTL S DIC="^DPT(",DIC(0)="AZEQM" D ^DIC G Q:Y'>0 S DFN=+Y
W ! D LO^DGUTL G Q:$G(BDGCODE) 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 ;IHS/ANMC/LJF 1/09/2002
S C=0 F I=0:0 S I=$O(^DGPM("ATID1",DFN,I)) Q:'I S N=0 F S N=$O(^DGPM("ATID1",DFN,I,N)) Q:'N 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 ;IHS/ANMC/LJF 1/09/2002
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 ;IHS/ANMC/LJF 3/02/2001
K DGPME D ENEX^DGPMV20 I '$D(DGPMEX) G EN
I DGFL=2 G Q
ASK K ^UTILITY("DGPMVN",$J),^UTILITY("DGPMVD",$J)
;
;IHS/ANMC/LJF 3/02/2001 added lines below to check lockout parameter
I $$LOCKED^BDGPAR(BDGDIV,+^DGPM(DGPMCA,0)) D G Q
. W !!?10,"*** CAN'T EDIT A MOVEMENT OLDER THAN LOCK OUT DATE. ***"
. W !?18,"*** CONTACT APPLICATION COORDINATOR ***" D PAUSE^BDGF
;IHS/ANMC/LJF 3/02/2001 end of new code
;
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
D KILL^AUPNPAT ;IHS/ANMC/LJF 3/02/2001
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))
;IHS/ITSC/WAR 03/11/04 Changed to $$GET1^DIQ
;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:"")
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: ",$$GET1^DIQ(405,+$P(^UTILITY("DGPMVN",$J,I),U,1),.05)
DGPMEX ;ALB/MIR - EXTENDED BED CONTROL ; [ 03/23/2004 9:49 AM ]
+1 ;;5.3;Registration;**40,59,1005,1015**;Aug 13, 1993;Build 21
+2 ;IHS/ANMC/LJF 03/02/2001 added kill of patient variables
+3 ; removed calls to PTF code
+4 ; 01/09/2002 fixed code to see duplicate admissions
+5 ;IHS/ITSC/WAR 03/11/04 Changed ^DIC(4 to using $$GET1^DIQ
+6 ;IHS/OIT/LJF 04/06/2006 PATCH 1005 don't ask name if called by CODE option
+7 ;
+8 SET DGPMEX=1
EN DO Q1
KILL ^UTILITY("DGPMVN",$JOB),^UTILITY("DGPMVD",$JOB)
+1 ;
+2 ;IHS/OIT/LJF 04/06/2006 PATCH 1005 don't ask name again if called by CODE
+3 ;W ! D LO^DGUTL S DIC="^DPT(",DIC(0)="AZEQM" D ^DIC G Q:Y'>0 S DFN=+Y
+4 WRITE !
DO LO^DGUTL
IF $GET(BDGCODE)
GOTO Q
SET DIC="^DPT("
SET DIC(0)="AZEQM"
DO ^DIC
IF Y'>0
GOTO Q
SET DFN=+Y
+5 ;
+6 IF '$DATA(^DGPM("APTT1",DFN))
WRITE !,"No admissions on file",!
GOTO 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 ;IHS/ANMC/LJF 1/09/2002
+1 ;IHS/ANMC/LJF 1/09/2002
SET C=0
FOR I=0:0
SET I=$ORDER(^DGPM("ATID1",DFN,I))
IF 'I
QUIT
SET N=0
FOR
SET N=$ORDER(^DGPM("ATID1",DFN,I,N))
IF 'N
QUIT
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
+2 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
+3 IF DGER
GOTO EN
IF DGI#5
DO BREAK
IF DGER
GOTO EN
+4 SET DGPMCA=+^UTILITY("DGPMVN",$JOB,DGOK)
SET DGPMAN=$SELECT($DATA(^DGPM(+DGPMCA,0)):^(0),1:"")
SET ^DISV(DUZ,"DGPMEX",DFN)=DGPMCA
+5 ;I $D(DGPMEX) D PTF^DGPMV21 I $G(DGPME)]"" K DGPME G EN ;IHS/ANMC/LJF 3/02/2001
+6 KILL DGPME
DO ENEX^DGPMV20
IF '$DATA(DGPMEX)
GOTO EN
+7 IF DGFL=2
GOTO Q
ASK KILL ^UTILITY("DGPMVN",$JOB),^UTILITY("DGPMVD",$JOB)
+1 ;
+2 ;IHS/ANMC/LJF 3/02/2001 added lines below to check lockout parameter
+3 IF $$LOCKED^BDGPAR(BDGDIV,+^DGPM(DGPMCA,0))
Begin DoDot:1
+4 WRITE !!?10,"*** CAN'T EDIT A MOVEMENT OLDER THAN LOCK OUT DATE. ***"
+5 WRITE !?18,"*** CONTACT APPLICATION COORDINATOR ***"
DO PAUSE^BDGF
End DoDot:1
GOTO Q
+6 ;IHS/ANMC/LJF 3/02/2001 end of new code
+7 ;
+8 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
+9 SET Z="^1 ADMIT PATIENT^2 TRANSFER PATIENT^3 DISCHARGE PATIENT^ADMIT PATIENT^TRANSFER PATIENT^DISCHARGE PATIENT^"
DO IN^DGHELP
+10 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
+11 SET DGPMT=$SELECT(X="A":1,X="T":2,X="D":3,1:X)
IF DGPMT'=1
DO CA^DGPMV
+12 IF DGPMT=1
Begin DoDot:1
+13 LOCK +^DGPM("C",DFN):0
IF '$TEST
Begin DoDot:2
+14 WRITE !!," ** This patient's inpatient or lodger activity is being **",!," ** edited by another employee. Please try again later. **",!
End DoDot:2
QUIT
+15 DO PTF^DGPMV22(DFN,DGPMCA,.DGPME,DGPMCA)
IF $GET(DGPME)]""
WRITE !,DGPME,!
QUIT
+16 SET (DGPMY,DGPMHY)=+DGPMAN
SET (DGPMN,DGPM1X,DGPMOUT)=0
SET DGPMDA=DGPMCA
DO UC^DGPMV
DO DT^DGPMV3
+17 LOCK -^DGPM("C",DFN)
End DoDot:1
+18 GOTO EN
Q KILL DGPMEX
+1 ;IHS/ANMC/LJF 3/02/2001
DO KILL^AUPNPAT
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 ;IHS/ITSC/WAR 03/11/04 Changed to $$GET1^DIQ
+2 ;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:"")
+3 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: ",$$GET1^DIQ(405,+$PIECE(^UTILITY("DGPMVN",$JOB,I),U,1),.05)
