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

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

initial load of WorldVistAEHR

File size: 3.6 KB
Line 
1DGPMV31 ;ALB/MIR - CONTINUE ADMIT PROCESS ; 12 SEP 89 @12
2 ;;5.3;Registration;**43,114,418**;Aug 13, 1993
3 I '$P(DGPMA,"^",6)!(DGPMN&DGPMOUT) D KILL G DQ
4 S Y=DGPMDA_"^1" I 'DGPMOUT S:DGPMN DIE("NO^")="" D SPEC^DGPMV36 I '$D(^DGPM("APHY",DGPMDA)) D KILL G DQ
5 I $D(DGPMSVC) S DGPMDER=0 ;FOR DISPO^DGPMV - from disposition
6 I DGPMN,$D(^DGS(41.1,+DGPMSA,0)) S DA=DGPMSA,DR="17////"_DGPMDA,DIE="^DGS(41.1," D ^DIE
7 I DGPMN D ^DGPMVBUL,CK^DGBLRV
8 I 'DGPMN,($P(DGPMP,"^",6,7)'=$P(DGPMA,"^",6,7)),DGPMABL S DGPMND=DGPMA D AB^DGPMV32
9 D SA
10UP I $P(DGPMA,"^",21)&$S(+DGPMA'=+DGPMP:1,$P(DGPMA,"^",6,7)'=$P(DGPMP,"^",6,7):1,1:0) D ASIH
11 G:'$P(DGPMA,"^",6) PTF S X=$O(^DGWAIT("C",DFN,0)),Y=$O(^(+X,0)) G PTF:('X!'Y)
12 W !!,"This patient has the following waiting list entries on file:"
13 F I=0:0 S I=$O(^DGWAIT("C",DFN,I)) Q:'I D
14 . F J=0:0 S J=$O(^DGWAIT("C",DFN,I,J)) Q:'J D
15 . . S X=$G(^DGWAIT(I,"P",J,0)) I X']"" Q
16 . . W !?5,"TO: ",$S($D(^DG(40.8,+^DGWAIT(I,0),0)):$E($P(^(0),"^",1),1,20),1:"")
17 . . W ?32,"APPLIED: ",$$FMTE^XLFDT($P(X,"^",2)),?63,"BEDSECTION: ",$P(X,"^",5)
18 W !!,"Please delete from the waiting list if necessary.",!
19PTF S PTF=$P(DGPMA,"^",16)
20 N DGELA
21 S DGELA=+$P($G(^DGPT(+PTF,101)),U,8)
22 S DR="",DIE="^DGPT(" S:$S('$D(^DGPT(+PTF,0)):0,$P(^(0),"^",2)'=+DGPMA:1,1:0) DR=DR_"2////"_+DGPMA_";" S DR=DR_"20;20.1////^S X=$$ELIG^DGUTL3(DFN,2,DGELA)",DA=PTF I $D(^DGPT(+DA,0)) K DQ,DG D ^DIE G DQ
23 ;
24 G DQ:'DGPMN S Y=+DGPMA D CREATE^DGPTFCR
25 S PTF=Y
26 S DIE="^DGPM(",DA=DGPMDA,DR=".16////"_+Y K DQ,DG D ^DIE
27 ;
28 ;-- update admitting elig
29 S DR="",DIE="^DGPT("
30 S DR=DR_"20.1////^S X=$$ELIG^DGUTL3(DFN,2,DGELA)",DA=PTF
31 D ^DIE
32 ;
33 D ADM^DGPMVODS
34DQ I DGPMA'=DGPMP W !,"Patient Admi",$S($P(DGPMP,"^",4)']"":"tted",1:"ssion Updated"),!
35 Q
36DICS S DGER=0 I DGPMTYP=40 S DGER=1 Q ;no TO ASIH!
37 I $P(^DGPM(DA,0),"^",18)=40 S DGER=1 Q ;don't let them change from TO ASIH!
38 Q:DGPMTYP'=18
39 S DGX1=9999999.9999999-+^DGPM(DA,0)
40 F DGX=1:1:2 S DGX1=$O(^DGPM("ATID1",DFN,DGX1)) Q:'DGX1 S DGY=$O(^(DGX1,0)) I $D(^DGPM(+DGY,0)) G:($P(^(0),"^",18)=40) DICSQ S DGY=$P(^(0),"^",6) I $D(^DIC(42,+DGY,0)),("^NH^D^"[("^"_$P(^(0),"^",3)_"^"))!($P(^(0),"^",17)=1) G DICSQ ;p-418
41 S DGER=1 Q
42DICSQ S DGER=0 Q
43ASIH ;update corresponding transfer and NHCU/DOM discharge episodes
44 W !,"Updating corresponding NHCU/DOM movements"
45 S DIE="^DGPM(",DA=$P(DGPMA,"^",21),DR=".01///"_+DGPMA_";.06////"_$P(DGPMA,"^",6)_";.07////"_$P(DGPMA,"^",7)
46 I $D(^DGPM(+DA,0)) S ^UTILITY("DGPM",$J,2,DA,"P")=$S($D(^UTILITY("DGPM",$J,2,DA,"P")):^("P"),1:^DGPM(DA,0)) K DQ,DG D ^DIE S ^UTILITY("DGPM",$J,2,DA,"A")=^DGPM(DA,0)
47 Q:+DGPMP=+DGPMA S DGX=$S($D(^DGPM(+$P(DGPMA,"^",21),0)):^(0),1:0),DGX2=$S('$D(^DGPM(+$P(DGX,"^",14),0)):0,$D(^DGPM(+$P(^(0),"^",17),0)):+^(0),1:0),X1=+DGPMP,X2=30 Q:'X1!'DGX2 D C^%DTC Q:X'=+DGX2
48 K DGX2 S X1=+DGPMA,X2=30 D C^%DTC S DA=$S($D(^DGPM(+$P(DGX,"^",14),0)):$P(^(0),"^",17),1:"")
49 S DIE="^DGPM(",DR=".01///"_X I $D(^DGPM(+DA,0)) S ^UTILITY("DGPM",$J,3,DA,"P")=$S($D(^UTILITY("DGPM",$J,3,DA,"P")):^("P"),1:^DGPM(DA,0)) K DQ,DG D ^DIE S ^UTILITY("DGPM",$J,3,DA,"A")=^DGPM(DA,0)
50 Q
51KILL S DIK="^DGPM(",DA=DGPMDA W !,"Incomplete admission...Deleted" D ^DIK K DIK S DGPMA="" Q
52 ;
53SA Q:'$D(^DGS(41.1,"B",DFN)) S DGCT=0
54 F DGI=0:0 S DGI=$O(^DGS(41.1,"B",DFN,DGI)) Q:'DGI S J=$S($D(^DGS(41.1,DGI,0)):^(0),1:0),Y=$P(J,"^",2) I Y X ^DD("DD") I '$P(J,"^",13),'$P(J,"^",17) S DGCT=DGCT+1 D WR
55 K DGCT,DGI,J,Y Q
56 ;
57WR I DGCT=1 W !,"This patient has the following scheduled admissions on file:"
58 W !?5,Y,?25,$S($P(J,"^",10)="W":"WARD: "_$S($D(^DIC(42,+$P(J,"^",8),0)):$P(^(0),"^",1),1:""),$P(J,"^",10)="T":"FACILITY TREATING SPECIALTY: "_$S($D(^DIC(45.7,+$P(J,"^",9),0)):$P(^(0),"^",1),1:""),1:"")
59 Q
Note: See TracBrowser for help on using the repository browser.