source: WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPMEX.m@ 724

Last change on this file since 724 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR

File size: 2.6 KB
Line 
1DGPMEX ;ALB/MIR - EXTENDED BED CONTROL ; 02 APR 90 @8:00
2 ;;5.3;Registration;**40,59**;Aug 13, 1993
3 ;
4 S DGPMEX=1
5EN D Q1 K ^UTILITY("DGPMVN",$J),^UTILITY("DGPMVD",$J)
6 W ! D LO^DGUTL S DIC="^DPT(",DIC(0)="AZEQM" D ^DIC G Q:Y'>0 S DFN=+Y
7 I '$D(^DGPM("APTT1",DFN)) W !,"No admissions on file",! G EN
8EN1 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
9 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
10 G EN:DGER I DGI#5 D BREAK G EN:DGER
11 S DGPMCA=+^UTILITY("DGPMVN",$J,DGOK),DGPMAN=$S($D(^DGPM(+DGPMCA,0)):^(0),1:""),^DISV(DUZ,"DGPMEX",DFN)=DGPMCA
12 I $D(DGPMEX) D PTF^DGPMV21 I $G(DGPME)]"" K DGPME G EN
13 K DGPME D ENEX^DGPMV20 I '$D(DGPMEX) G EN
14 I DGFL=2 G Q
15ASK K ^UTILITY("DGPMVN",$J),^UTILITY("DGPMVD",$J)
16 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
17 S Z="^1 ADMIT PATIENT^2 TRANSFER PATIENT^3 DISCHARGE PATIENT^ADMIT PATIENT^TRANSFER PATIENT^DISCHARGE PATIENT^" D IN^DGHELP
18 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
19 S DGPMT=$S(X="A":1,X="T":2,X="D":3,1:X) I DGPMT'=1 D CA^DGPMV
20 I DGPMT=1 D
21 .L +^DGPM("C",DFN):0 I '$T D Q
22 ..W !!," ** This patient's inpatient or lodger activity is being **",!," ** edited by another employee. Please try again later. **",!
23 .D PTF^DGPMV22(DFN,DGPMCA,.DGPME,DGPMCA) I $G(DGPME)]"" W !,DGPME,! Q
24 .S (DGPMY,DGPMHY)=+DGPMAN,(DGPMN,DGPM1X,DGPMOUT)=0,DGPMDA=DGPMCA D UC^DGPMV,DT^DGPMV3
25 .L -^DGPM("C",DFN)
26 G EN
27Q K DGPMEX
28Q1 K DIC,DFN,DGER,DGFL,DGI,DGPMAN,DGPMCA,DGPMN,DGPMDA,DGPMOUT,DGPMT,DGPMUC,DGX D Q^DGPMV3,Q^DGPMV2,Q^DGPMV1
29 Q
30BREAK 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
31 I X="" Q
32 I X=" ",$D(^DISV(DUZ,"DGPMEX",DFN)) S DGX=^(DFN) I $D(^UTILITY("DGPMVDA",$J,+DGX)) S DGOK=^(+DGX) Q
33 I X'=+X!'$D(^UTILITY("DGPMVN",$J,+X)) W !!,*7,"INVALID RESPONSE",! G BREAK
34 S DGOK=X Q
35W1 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))
36 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:"")
Note: See TracBrowser for help on using the repository browser.