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

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

initial load of WorldVistAEHR

File size: 4.1 KB
RevLine 
[613]1VADPT31 ;ALB/MRL/MJK - PATIENT VARIABLES [IN5], CONT.; 12 DEC 1988
2 ;;5.3;Registration;**498,509**;Aug 13, 1993
3 ;Inpatient variables [Version 5.0 and above]
4EN N VAINDT,VAMV,VAMV0
5 S VAMV=+E,VAMV0=^DGPM(VAMV,0),VAX("CA")=+$P(VAMV0,"^",14) G ENQ:'$D(^DGPM(+VAX("CA"),0))
6 I $D(VAIP("M")) D CE G ENQ:'$D(^DGPM(+E,0)) S VAMV=+E,VAMV0=^(0)
7 S @VAV@($P(VAS,"^",1))=E
8 S Y=$P(VAMV0,"^",2),@VAV@($P(VAS,"^",2))=Y_"^"_$S($D(^DG(405.3,+Y,0)):$P(^(0),"^"),1:"")
9 S Y=$S(+VAMV0:+VAMV0,1:"") X:Y ^DD("DD") S @VAV@($P(VAS,"^",3))=+VAMV0_"^"_Y
10 S Y=$P(VAMV0,"^",18),@VAV@($P(VAS,"^",4))=Y_"^"_$S($D(^DG(405.2,+Y,0)):$P(^(0),"^"),1:"")
11 S Y=+$P(^DGPM(VAX("CA"),0),"^",16) S:Y @VAV@($P(VAS,"^",12))=Y
12 ;
13 S VATD=VAX("DT") D FIND
14 S @VAV@($P(VAS,"^",5))=VAWD,@VAV@($P(VAS,"^",6))=VARM,@VAV@($P(VAS,"^",7))=VAPP,@VAV@($P(VAS,"^",8))=VATS,@VAV@($P(VAS,"^",9))=VADX,@VAV@($P(VAS,"^",18))=VAAP
15 ;
16 S VANODE=$G(^DGPM(VAX("CA"),0)) I $P(VANODE,"^",2)=1 D
17 .N DCD
18 .S DCD=+$P(VANODE,"^",17) I DCD S DCD=+$G(^DGPM(DCD,0))
19 .S VANODE=$G(^DGPM(VAX("CA"),"DIR"))
20 .S Y=$P(VANODE,"^",1)
21 .I Y="" S Y=$S('DCD:1,(DCD<3030414.999999):"",1:1) Q:Y=""
22 .S @VAV@($P(VAS,"^",19),1)=Y_"^"_$$EXTERNAL^DILFD(405,41,,Y)
23 .S Y=$P(VANODE,"^",2) S @VAV@($P(VAS,"^",19),2)=Y_"^"_$$EXTERNAL^DILFD(405,42,,Y)
24 .S Y=$P(VANODE,"^",3) S @VAV@($P(VAS,"^",19),3)=Y_"^"_$$EXTERNAL^DILFD(405,43,,Y)
25 ;
26 S VAINDT=+VAMV0 D IB^VADPT2 S @VAV@($P(VAS,"^",10))=+VAZ
27 I 'VAZ,$D(VAZ(2)),VAZ(2)?7N!(VAZ(2)?7N1".".N) S Y=VAZ(2) X ^DD("DD") S @VAV@($P(VAS,"^",11))=VAZ(2)_"^"_Y
28 ;
29 I $D(VAIP("M")) S VASET=$S(VAIP("M"):14,1:13),VASET(VASET)="",VANODE=$P(VAS,"^",VASET) D COPY ; last or adm
30 I '$D(VAIP("M")),$D(VAIP("D")),"^l^L^"[("^"_$E(VAIP("D"))_"^") S VASET(14)="",VANODE=$P(VAS,"^",14) D COPY ; last
31 I "^3^5^"[("^"_$P(VAMV0,"^",2)_"^") S VASET(17)="",VANODE=$P(VAS,"^",17) D COPY ; d/c
32 I '$D(VASET(13)) S VAMV=VAX("CA"),VAMV0=^DGPM(VAMV,0),VANODE=$P(VAS,"^",13) D STORE ; adm
33 D BLD^VADPT32 G ENQ:'$D(^UTILITY("VADPTZ",$J,DFN))
34 S VAXE=$S($D(^UTILITY("VADPTZ",$J,DFN,1)):^(1),1:""),VAMV0=$P(VAXE,"||",2),VAMV=+VAXE
35 I VAMV,"^3^5^"[("^"_$P(VAMV0,"^",2)_"^"),'$D(VASET(17)) S VANODE=$P(VAS,"^",17) D STORE ; d/c
36 I VAMV,'$D(VASET(14)) S VANODE=$P(VAS,"^",14) D STORE ;last
37 I $S('VANN:1,'$D(^UTILITY("VADPTZ",$J,DFN,+VANN)):1,1:0) G ENQ
38 I $D(^UTILITY("VADPTZ",$J,DFN,VANN-1)) S VAXE=^(VANN-1),VAMV=+VAXE,VAMV0=$P(VAXE,"||",2) I VAMV S VANODE=$P(VAS,"^",16) D STORE ; following
39 I $D(^UTILITY("VADPTZ",$J,DFN,VANN+1)) S VAXE=^(VANN+1),VAMV=+VAXE,VAMV0=$P(VAXE,"||",2) I VAMV S VANODE=$P(VAS,"^",15) D STORE ; prior
40 ;
41ENQ K VAMVX,VANODE,VAMCC,VAXE,VANN D KVAR^VADPT30 Q
42 ;
43FIND ;
44 S VAMVX=VAMV,VAMV0X=VAMV0
45 S (VAWD,VATS,VAMV,VARM,VAPP,VAAP,VADX)=""
46 I $P(VAMV0,"^",2)=4!($P(VAMV0,"^",2)=5) D LODGER G FINDQ
47 S VATD=9999999.999999-VATD,(VACN,VAPRC,VAPRT)=1 D GET^VADPT30
48FINDQ S VAMV=VAMVX,VAMV0=VAMV0X K VAMVX,VAMV0X
49 Q
50 ;
51CE I 'VAIP("M") S E=+VAX("CA") Q
52 S E=$O(^DGPM("APMV",DFN,+VAX("CA"),0)) Q:E'>0 S E=$O(^DGPM("APMV",DFN,+VAX("CA"),E,0)) Q
53 ;
54STORE ; store 'other nodes'
55 S @VAV@(VANODE)=+VAMV
56 S Y=+VAMV0 X:Y ^DD("DD") S @VAV@(VANODE,1)=+VAMV0_"^"_Y
57 S Y=$P(VAMV0,"^",2),@VAV@(VANODE,2)=Y_"^"_$S($D(^DG(405.3,+Y,0)):$P(^(0),"^"),1:"")
58 S Y=$P(VAMV0,"^",18),@VAV@(VANODE,3)=Y_"^"_$S($D(^DG(405.2,+Y,0)):$P(^(0),"^"),1:"")
59 S VATD=+VAMV0 D FIND
60 S @VAV@(VANODE,4)=VAWD,@VAV@(VANODE,5)=VAPP,@VAV@(VANODE,6)=VATS,@VAV@(VANODE,7)=VADX
61 Q
62 ;
63COPY ; copy from primary to other nodes
64 S @VAV@(VANODE)=VAMV
65 ; 1-mvt d/t ; 2-transaction type ; 3-mvt type
66 S @VAV@(VANODE,1)=@VAV@($P(VAS,"^",3)),@VAV@(VANODE,2)=@VAV@($P(VAS,"^",2)),@VAV@(VANODE,3)=@VAV@($P(VAS,"^",4))
67 ; 4-ward ; 5-doc ; 6-treat spec ; 7-dx
68 S @VAV@(VANODE,4)=@VAV@($P(VAS,"^",5)),@VAV@(VANODE,5)=@VAV@($P(VAS,"^",7)),@VAV@(VANODE,6)=@VAV@($P(VAS,"^",8)),@VAV@(VANODE,7)=@VAV@($P(VAS,"^",9))
69 Q
70 ;
71LODGER ; -- get lodger data
72 S VAWD=$S($P(VAMV0,"^",2)=4:$P(VAMV0,"^",6),$D(^DGPM(+$P(VAMV0,"^",14),0)):$P(^(0),"^",6),1:"")
73 S VAWD=$S($D(^DIC(42,+VAWD,0)):VAWD_"^"_$P(^(0),"^"),1:"")
74 S VARM=$S($P(VAMV0,"^",2)=4:$P(VAMV0,"^",7),$D(^DGPM(+$P(VAMV0,"^",14),0)):$P(^(0),"^",7),1:"")
75 S VARM=$S($D(^DG(405.4,+VARM,0)):VARM_"^"_$P(^(0),"^"),1:"")
76 Q
Note: See TracBrowser for help on using the repository browser.