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

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

initial load of FOIAVistA 6/30/08 version
File size: 5.3 KB
Line 
1DGPMVDD ;ALB/MIR - MISCELLANEOUS DD CALLS FROM FILE 405 AND 405.1 ; 4/14/04 6:26pm
2 ;;5.3;Registration;**418,593**;Aug 13, 1993
3W ;called from input transform for ward location
4 I '$D(DGPMT) K X,DIC Q
5 S DGPMTYP=$P(^DGPM(DA,0),"^",18),DGPMWD=$P(DGPMP,"^",6) D W1:DGPMT=1,W2:DGPMT=2!($P(^DGPM(DA,0),"^",2)=2) Q
6W1 ;consistency edits for ward location from admit option
7 I $D(DGPMSVC) S DIC("S")=DIC("S")_","_$S(DGPMSVC="H":"""^NH^D^""'[(""^""_$P(^(0),""^"",3)_""^"")",1:"$P(^(0),""^"",3)=DGPMSVC") Q
8 S DGX=$P(DGPMP,"^",17) I DGX,(DGPMTYP=40),$S('$D(^DGPM(+DGX,0)):0,+^(0):1,1:0) S DIC("S")="I +Y=DGPMWD" Q
9 ;S DGX="" I DGPMTYP=18 S DIC("S")=DIC("S")_",""^NH^D^""[(""^""_$P(^(0),""^"",3)_""^"")" Q
10 S DGX="" I DGPMTYP=18 S DIC("S")=DIC("S")_",""^NH^D^""[(""^""_$P(^(0),""^"",3)_""^"")!($P(^(0),""^"",17)=1)" ;p-418
11 ;I (DGPMWD&$S($P(DGPM2,"^",2)=2:1,1:0))!(DGPMTYP=40) S DGX=$S($D(^DIC(42,+DGPMWD,0)):$P(^(0),"^",3),1:""),DGX=$S("^NH^D^"'[("^"_DGX_"^"):"H",1:DGX)
12 ;S DGPMWD="",DGPMTYP=40 ; simulate NOIS REN-0304-60611
13 I (DGPMWD&$S($P(DGPM2,"^",2)=2:1,1:0))!(DGPMTYP=40) S DGX=$S($D(^DIC(42,+DGPMWD,0)):$P($G(^DIC(42,+DGPMWD,0)),U,3),1:""),DGX=$S("^NH^D^"'[("^"_DGX_"^")&($P($G(^DIC(42,+DGPMWD,0)),U,17)'=1):"H",1:DGX) ;p-418/593
14 ;I DGX]"" S DIC("S")=DIC("S")_",("_$S(DGX="NH":"""^NH^:""[",DGX="D":"""^D^""[",1:"""^NH^D^""'[")_"(""^""_$P(^(0),""^"",3)_""^""))"
15ZZ I DGX]"" S DIC("S")=DIC("S")_",("_$S(DGX="NH":"""^NH^:""[",DGX="D":"""^D^""[",1:"""^NH^D^""'[")_"(""^""_$P(^(0),""^"",3)_""^"")&($P(^(0),""^"",17)'=1))" ;p-418
16 I $P(DGPM2,"^",2)=2&$P(DGPM2,"^",6),'DGPMABL S DIC("S")=DIC("S")_",+Y'=$P(DGPM2,""^"",6)"
17 Q
18W2 ;Ward consistency check for transfer. interward transfers not to same ward. unless ASIH mvt, can't go from hospital to NHCU/DOM, vice versa
19 ;I "^13^44^"[("^"_DGPMTYP_"^") S DIC("S")=DIC("S")_",""^NH^D^""'[(""^""_$P(^(0),""^"",3)_""^"")" Q
20 I "^13^44^"[("^"_DGPMTYP_"^") S DIC("S")=DIC("S")_",""^NH^D^""'[(""^""_$P(^(0),""^"",3)_""^"")&($P(^(0),U,17)'=1)" Q ;added p-418
21 S DGX=$S($D(^DGPM(+$P(^DGPM(DA,0),"^",14),0)):$P(^(0),"^",6),1:0),DGX=$S($D(^DIC(42,+DGX,0)):$P(^(0),"^",3),1:"")
22 N DGRAI S DGRAI=$S(DGX="":"",1:$P(^(0),"^",17)) ;added p-418
23 ;I "^14^43^45^"[("^"_DGPMTYP_"^") S DIC("S")=DIC("S")_",DGX=$P(^(0),""^"",3)" Q
24 I "^14^43^45^"[("^"_DGPMTYP_"^") D Q ;added p-418
25 .I DGX="D" S DIC("S")=DIC("S")_",($P(^(0),""^"",3)="""_DGX_""")"
26 .I DGX="NH"!(DGX="I"&(DGRAI=1)) S DIC("S")=DIC("S")_",""^NH^""[(""^""_$P(^(0),""^"",3)_""^"")!(""^I^""[(""^""_$P(^(0),""^"",3)_""^"")&($P(^(0),""^"",17)=1))" ;added p-418
27 S DGX=$S($D(^DIC(42,+$P(DGPM0,"^",6),0)):$P(^(0),"^",3),1:"")
28 S DGRAI=$S(DGX="":"",1:$P(^(0),"^",17)) ;added p-418
29 ;I DGX="D"!(DGX="NH") S DIC("S")=DIC("S")_",($P(^(0),""^"",3)="""_DGX_""")"
30 I DGX="D"!(DGX="NH")!(DGX="I"&(DGRAI=1)) D
31 .I DGX="D" S DIC("S")=DIC("S")_",($P(^(0),""^"",3)="""_DGX_""")"
32 .I DGX="NH"!(DGX="I"&(DGRAI=1)) S DIC("S")=DIC("S")_",""^NH^""[(""^""_$P(^(0),""^"",3)_""^"")!(""^I^""[(""^""_$P(^(0),""^"",3)_""^"")&($P(^(0),""^"",17)=1))" ;added p-418
33 ;I DGX'="D"&(DGX'="NH") S DIC("S")=DIC("S")_",""^NH^D^""'[(""^""_$P(^(0),""^"",3)_""^"")"
34 I DGX'="D"&(DGX'="NH")&(DGX'="I"!(DGRAI'=1)) D
35 .S DIC("S")=DIC("S")_",""^NH^D^""'[(""^""_$P(^(0),""^"",3)_""^"")&((""^I^""'[(""^""_$P(^(0),""^"",3)_""^"")!($P(^(0),""^"",17)'=1)))" ;added p-418
36 I $D(^DG(405.2,+DGPMTYP,"E")),'^("E") S DGX=$S(DGPMABL:0,1:$P(DGPM2,"^",6)),DIC("S")=DIC("S")_",+Y'=DGX,+Y'=$P(DGPM0,""^"",6)"
37 Q
38WARD ;is ward active at time of movement?
39 S DGPMOS=+^DGPM(DA,0) N D0,X S D0=+Y D WIN^DGPMDDCF I X W !,"Ward inactive at time of movement" S DGOOS=1 Q
40 Q
41ROOM ;is room-bed active at time of movement? - called from input transform of .07 in 405
42 S DGPMOS=$S('$D(DGSWITCH):+^DGPM(DA,0),1:DT) N D0,X S D0=+Y D RIN^DGPMDDCF I X W !,"Room-bed inactive at time of movement" S DGOOS=1 Q
43 Q
44 ;
45TROC ;is bed occupied when transferring from 1 or 23 movement?
46 ;called from DGPM TRANSFER edit template
47 ;output variables DGPMOC &/or DGOOS
48 ;DGPMOC = 2 if occupied & no more beds on ward, 1 if occupied, 0 if unoccupied
49 ;DGOOS = 1 if inactive (out-of-service), otherwise = 0
50 S (DGPMOC,DGOOS)=0,DGZ7=$P(DGPM0,"^",7),DGZ6=+$P(DGPM0,"^",6)
51 F DGPMX=0:0 S DGPMX=$O(^DGPM("ARM",+DGZ7,DGPMX)) Q:DGPMX'>0 I $D(^DGPM(DGPMX,0)),$P(DGPM0,"^",3)'=$P(^DGPM(DGPMX,0),"^",3) S DGPMOC=1
52 ;I 'DGPMOC,$S('$D(^DGPM(+DGPMX,0)):0,'$D(^DG(405.4,DGZ7,"W","B",+$P(DGPM0,"^",6))):1,1:0) S DGPMOC=1
53 ;I DGPMOC S DGOCC=0 D TROCWB I DGOCC=DGB S DGPMOC=2
54 I 'DGPMOC S DGPMOS=+DGPM0 N D0,X S D0=+DGZ7 D RIN^DGPMDDCF S:X DGOOS=1
55 K DGB,DGOCC,DGPMX,DGPMOS,I Q
56 Q
57TROCWB ;check if ward still has available beds
58 S I=0 F DGB=0:1 S I=$O(^DG(405.4,"W",DGZ6,I)) Q:I'>0 I $D(^DGPM("ARM",I)) S DGOCC=DGOCC+1
59 ;
60ABSRET ;check absence return date for consistency with movement type
61 S DGPMX=^DGPM(DA,0),DGPMTYP=$P(DGPMX,"^",18),DGPMRD=X
62 I DGPMTYP=1 S X1=$P(+DGPMX,".",1),X2=4 D C^%DTC I DGPMRD>X K X W !,"Must be within 4 days"
63 I DGPMTYP=2 S X1=$P(+DGPMX,".",1),X2=5 D C^%DTC I DGPMRD<X K X W !,"Must be more than 4 days"
64 I $D(X) S X1=$P(+DGPMX,".",1),X2=30 D C^%DTC I DGPMRD>X K X W !,"Must be within 30 days of transfer"
65 S:$D(X) X=DGPMRD K DGPMTYP,DGPMX,DGPMRD
66 Q
67 ;
68UARET ;called from DGPM TRANSFER template...default 30 day return from UA
69 N DGPMX,X,X1,X2,Y
70 S DGPMX=^DGPM(DA,0)
71 I $P(DGPMX,"^",18)'=3 S DGPMRET="" Q
72 S X1=$P(+DGPMX,".",1),X2=30 D C^%DTC S Y=X X ^DD("DD") S DGPMRET=Y
73 Q
Note: See TracBrowser for help on using the repository browser.