VADPT31 ;ALB/MRL/MJK - PATIENT VARIABLES [IN5], CONT.; 12 DEC 1988
;;5.3;Registration;**498,509,1004**;Aug 13, 1993
;Inpatient variables [Version 5.0 and above]
;IHS/ANMC/LJF 2/22/2001 Added setting of admitting provider
;IHS/OIT/LJF 11/10/2005 PATCH 1004 included for sites where it has been overwritten
;
EN N VAINDT,VAMV,VAMV0
S VAMV=+E,VAMV0=^DGPM(VAMV,0),VAX("CA")=+$P(VAMV0,"^",14) G ENQ:'$D(^DGPM(+VAX("CA"),0))
I $D(VAIP("M")) D CE G ENQ:'$D(^DGPM(+E,0)) S VAMV=+E,VAMV0=^(0)
S @VAV@($P(VAS,"^",1))=E
S Y=$P(VAMV0,"^",2),@VAV@($P(VAS,"^",2))=Y_"^"_$S($D(^DG(405.3,+Y,0)):$P(^(0),"^"),1:"")
S Y=$S(+VAMV0:+VAMV0,1:"") X:Y ^DD("DD") S @VAV@($P(VAS,"^",3))=+VAMV0_"^"_Y
S Y=$P(VAMV0,"^",18),@VAV@($P(VAS,"^",4))=Y_"^"_$S($D(^DG(405.2,+Y,0)):$P(^(0),"^"),1:"")
S Y=+$P(^DGPM(VAX("CA"),0),"^",16) S:Y @VAV@($P(VAS,"^",12))=Y
;
S VATD=VAX("DT") D FIND
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
S @VAV@(9999999.02)=IHSADM ;IHS/ANMC/LJF 2/22/2001
;
S VANODE=$G(^DGPM(VAX("CA"),0)) I $P(VANODE,"^",2)=1 D
.N DCD
.S DCD=+$P(VANODE,"^",17) I DCD S DCD=+$G(^DGPM(DCD,0))
.S VANODE=$G(^DGPM(VAX("CA"),"DIR"))
.S Y=$P(VANODE,"^",1)
.I Y="" S Y=$S('DCD:1,(DCD<3030414.999999):"",1:1) Q:Y=""
.S @VAV@($P(VAS,"^",19),1)=Y_"^"_$$EXTERNAL^DILFD(405,41,,Y)
.S Y=$P(VANODE,"^",2) S @VAV@($P(VAS,"^",19),2)=Y_"^"_$$EXTERNAL^DILFD(405,42,,Y)
.S Y=$P(VANODE,"^",3) S @VAV@($P(VAS,"^",19),3)=Y_"^"_$$EXTERNAL^DILFD(405,43,,Y)
;
S VAINDT=+VAMV0 D IB^VADPT2 S @VAV@($P(VAS,"^",10))=+VAZ
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
;
I $D(VAIP("M")) S VASET=$S(VAIP("M"):14,1:13),VASET(VASET)="",VANODE=$P(VAS,"^",VASET) D COPY ; last or adm
I '$D(VAIP("M")),$D(VAIP("D")),"^l^L^"[("^"_$E(VAIP("D"))_"^") S VASET(14)="",VANODE=$P(VAS,"^",14) D COPY ; last
I "^3^5^"[("^"_$P(VAMV0,"^",2)_"^") S VASET(17)="",VANODE=$P(VAS,"^",17) D COPY ; d/c
I '$D(VASET(13)) S VAMV=VAX("CA"),VAMV0=^DGPM(VAMV,0),VANODE=$P(VAS,"^",13) D STORE ; adm
D BLD^VADPT32 G ENQ:'$D(^UTILITY("VADPTZ",$J,DFN))
S VAXE=$S($D(^UTILITY("VADPTZ",$J,DFN,1)):^(1),1:""),VAMV0=$P(VAXE,"||",2),VAMV=+VAXE
I VAMV,"^3^5^"[("^"_$P(VAMV0,"^",2)_"^"),'$D(VASET(17)) S VANODE=$P(VAS,"^",17) D STORE ; d/c
I VAMV,'$D(VASET(14)) S VANODE=$P(VAS,"^",14) D STORE ;last
I $S('VANN:1,'$D(^UTILITY("VADPTZ",$J,DFN,+VANN)):1,1:0) G ENQ
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
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
;
ENQ K VAMVX,VANODE,VAMCC,VAXE,VANN D KVAR^VADPT30 Q
;
FIND ;
S VAMVX=VAMV,VAMV0X=VAMV0
S (VAWD,VATS,VAMV,VARM,VAPP,VAAP,VADX)=""
;
S IHSADM="" ;IHS/ANMC/LJF 2/22/2001
;
I $P(VAMV0,"^",2)=4!($P(VAMV0,"^",2)=5) D LODGER G FINDQ
S VATD=9999999.999999-VATD,(VACN,VAPRC,VAPRT)=1 D GET^VADPT30
FINDQ S VAMV=VAMVX,VAMV0=VAMV0X K VAMVX,VAMV0X
Q
;
CE I 'VAIP("M") S E=+VAX("CA") Q
S E=$O(^DGPM("APMV",DFN,+VAX("CA"),0)) Q:E'>0 S E=$O(^DGPM("APMV",DFN,+VAX("CA"),E,0)) Q
;
STORE ; store 'other nodes'
S @VAV@(VANODE)=+VAMV
S Y=+VAMV0 X:Y ^DD("DD") S @VAV@(VANODE,1)=+VAMV0_"^"_Y
S Y=$P(VAMV0,"^",2),@VAV@(VANODE,2)=Y_"^"_$S($D(^DG(405.3,+Y,0)):$P(^(0),"^"),1:"")
S Y=$P(VAMV0,"^",18),@VAV@(VANODE,3)=Y_"^"_$S($D(^DG(405.2,+Y,0)):$P(^(0),"^"),1:"")
S VATD=+VAMV0 D FIND
S @VAV@(VANODE,4)=VAWD,@VAV@(VANODE,5)=VAPP,@VAV@(VANODE,6)=VATS,@VAV@(VANODE,7)=VADX
Q
;
COPY ; copy from primary to other nodes
S @VAV@(VANODE)=VAMV
; 1-mvt d/t ; 2-transaction type ; 3-mvt type
S @VAV@(VANODE,1)=@VAV@($P(VAS,"^",3)),@VAV@(VANODE,2)=@VAV@($P(VAS,"^",2)),@VAV@(VANODE,3)=@VAV@($P(VAS,"^",4))
; 4-ward ; 5-doc ; 6-treat spec ; 7-dx
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))
Q
;
LODGER ; -- get lodger data
S VAWD=$S($P(VAMV0,"^",2)=4:$P(VAMV0,"^",6),$D(^DGPM(+$P(VAMV0,"^",14),0)):$P(^(0),"^",6),1:"")
S VAWD=$S($D(^DIC(42,+VAWD,0)):VAWD_"^"_$P(^(0),"^"),1:"")
S VARM=$S($P(VAMV0,"^",2)=4:$P(VAMV0,"^",7),$D(^DGPM(+$P(VAMV0,"^",14),0)):$P(^(0),"^",7),1:"")
S VARM=$S($D(^DG(405.4,+VARM,0)):VARM_"^"_$P(^(0),"^"),1:"")
Q
VADPT31 ;ALB/MRL/MJK - PATIENT VARIABLES [IN5], CONT.; 12 DEC 1988
+1 ;;5.3;Registration;**498,509,1004**;Aug 13, 1993
+2 ;Inpatient variables [Version 5.0 and above]
+3 ;IHS/ANMC/LJF 2/22/2001 Added setting of admitting provider
+4 ;IHS/OIT/LJF 11/10/2005 PATCH 1004 included for sites where it has been overwritten
+5 ;
EN NEW VAINDT,VAMV,VAMV0
+1 SET VAMV=+E
SET VAMV0=^DGPM(VAMV,0)
SET VAX("CA")=+$PIECE(VAMV0,"^",14)
IF '$DATA(^DGPM(+VAX("CA"),0))
GOTO ENQ
+2 IF $DATA(VAIP("M"))
DO CE
IF '$DATA(^DGPM(+E,0))
GOTO ENQ
SET VAMV=+E
SET VAMV0=^(0)
+3 SET @VAV@($PIECE(VAS,"^",1))=E
+4 SET Y=$PIECE(VAMV0,"^",2)
SET @VAV@($PIECE(VAS,"^",2))=Y_"^"_$SELECT($DATA(^DG(405.3,+Y,0)):$PIECE(^(0),"^"),1:"")
+5 SET Y=$SELECT(+VAMV0:+VAMV0,1:"")
IF Y
XECUTE ^DD("DD")
SET @VAV@($PIECE(VAS,"^",3))=+VAMV0_"^"_Y
+6 SET Y=$PIECE(VAMV0,"^",18)
SET @VAV@($PIECE(VAS,"^",4))=Y_"^"_$SELECT($DATA(^DG(405.2,+Y,0)):$PIECE(^(0),"^"),1:"")
+7 SET Y=+$PIECE(^DGPM(VAX("CA"),0),"^",16)
IF Y
SET @VAV@($PIECE(VAS,"^",12))=Y
+8 ;
+9 SET VATD=VAX("DT")
DO FIND
+10 SET @VAV@($PIECE(VAS,"^",5))=VAWD
SET @VAV@($PIECE(VAS,"^",6))=VARM
SET @VAV@($PIECE(VAS,"^",7))=VAPP
SET @VAV@($PIECE(VAS,"^",8))=VATS
SET @VAV@($PIECE(VAS,"^",9))=VADX
SET @VAV@($PIECE(VAS,"^",18))=VAAP
+11 ;IHS/ANMC/LJF 2/22/2001
SET @VAV@(9999999.02)=IHSADM
+12 ;
+13 SET VANODE=$GET(^DGPM(VAX("CA"),0))
IF $PIECE(VANODE,"^",2)=1
Begin DoDot:1
+14 NEW DCD
+15 SET DCD=+$PIECE(VANODE,"^",17)
IF DCD
SET DCD=+$GET(^DGPM(DCD,0))
+16 SET VANODE=$GET(^DGPM(VAX("CA"),"DIR"))
+17 SET Y=$PIECE(VANODE,"^",1)
+18 IF Y=""
SET Y=$SELECT('DCD:1,(DCD<3030414.999999):"",1:1)
IF Y=""
QUIT
+19 SET @VAV@($PIECE(VAS,"^",19),1)=Y_"^"_$$EXTERNAL^DILFD(405,41,,Y)
+20 SET Y=$PIECE(VANODE,"^",2)
SET @VAV@($PIECE(VAS,"^",19),2)=Y_"^"_$$EXTERNAL^DILFD(405,42,,Y)
+21 SET Y=$PIECE(VANODE,"^",3)
SET @VAV@($PIECE(VAS,"^",19),3)=Y_"^"_$$EXTERNAL^DILFD(405,43,,Y)
End DoDot:1
+22 ;
+23 SET VAINDT=+VAMV0
DO IB^VADPT2
SET @VAV@($PIECE(VAS,"^",10))=+VAZ
+24 IF 'VAZ
IF $DATA(VAZ(2))
IF VAZ(2)?7N!(VAZ(2)?7N1".".N)
SET Y=VAZ(2)
XECUTE ^DD("DD")
SET @VAV@($PIECE(VAS,"^",11))=VAZ(2)_"^"_Y
+25 ;
+26 ; last or adm
IF $DATA(VAIP("M"))
SET VASET=$SELECT(VAIP("M"):14,1:13)
SET VASET(VASET)=""
SET VANODE=$PIECE(VAS,"^",VASET)
DO COPY
+27 ; last
IF '$DATA(VAIP("M"))
IF $DATA(VAIP("D"))
IF "^l^L^"[("^"_$EXTRACT(VAIP("D"))_"^")
SET VASET(14)=""
SET VANODE=$PIECE(VAS,"^",14)
DO COPY
+28 ; d/c
IF "^3^5^"[("^"_$PIECE(VAMV0,"^",2)_"^")
SET VASET(17)=""
SET VANODE=$PIECE(VAS,"^",17)
DO COPY
+29 ; adm
IF '$DATA(VASET(13))
SET VAMV=VAX("CA")
SET VAMV0=^DGPM(VAMV,0)
SET VANODE=$PIECE(VAS,"^",13)
DO STORE
+30 DO BLD^VADPT32
IF '$DATA(^UTILITY("VADPTZ",$JOB,DFN))
GOTO ENQ
+31 SET VAXE=$SELECT($DATA(^UTILITY("VADPTZ",$JOB,DFN,1)):^(1),1:"")
SET VAMV0=$PIECE(VAXE,"||",2)
SET VAMV=+VAXE
+32 ; d/c
IF VAMV
IF "^3^5^"[("^"_$PIECE(VAMV0,"^",2)_"^")
IF '$DATA(VASET(17))
SET VANODE=$PIECE(VAS,"^",17)
DO STORE
+33 ;last
IF VAMV
IF '$DATA(VASET(14))
SET VANODE=$PIECE(VAS,"^",14)
DO STORE
+34 IF $SELECT('VANN:1,'$DATA(^UTILITY("VADPTZ",$JOB,DFN,+VANN)):1,1:0)
GOTO ENQ
+35 ; following
IF $DATA(^UTILITY("VADPTZ",$JOB,DFN,VANN-1))
SET VAXE=^(VANN-1)
SET VAMV=+VAXE
SET VAMV0=$PIECE(VAXE,"||",2)
IF VAMV
SET VANODE=$PIECE(VAS,"^",16)
DO STORE
+36 ; prior
IF $DATA(^UTILITY("VADPTZ",$JOB,DFN,VANN+1))
SET VAXE=^(VANN+1)
SET VAMV=+VAXE
SET VAMV0=$PIECE(VAXE,"||",2)
IF VAMV
SET VANODE=$PIECE(VAS,"^",15)
DO STORE
+37 ;
ENQ KILL VAMVX,VANODE,VAMCC,VAXE,VANN
DO KVAR^VADPT30
QUIT
+1 ;
FIND ;
+1 SET VAMVX=VAMV
SET VAMV0X=VAMV0
+2 SET (VAWD,VATS,VAMV,VARM,VAPP,VAAP,VADX)=""
+3 ;
+4 ;IHS/ANMC/LJF 2/22/2001
SET IHSADM=""
+5 ;
+6 IF $PIECE(VAMV0,"^",2)=4!($PIECE(VAMV0,"^",2)=5)
DO LODGER
GOTO FINDQ
+7 SET VATD=9999999.999999-VATD
SET (VACN,VAPRC,VAPRT)=1
DO GET^VADPT30
FINDQ SET VAMV=VAMVX
SET VAMV0=VAMV0X
KILL VAMVX,VAMV0X
+1 QUIT
+2 ;
CE IF 'VAIP("M")
SET E=+VAX("CA")
QUIT
+1 SET E=$ORDER(^DGPM("APMV",DFN,+VAX("CA"),0))
IF E'>0
QUIT
SET E=$ORDER(^DGPM("APMV",DFN,+VAX("CA"),E,0))
QUIT
+2 ;
STORE ; store 'other nodes'
+1 SET @VAV@(VANODE)=+VAMV
+2 SET Y=+VAMV0
IF Y
XECUTE ^DD("DD")
SET @VAV@(VANODE,1)=+VAMV0_"^"_Y
+3 SET Y=$PIECE(VAMV0,"^",2)
SET @VAV@(VANODE,2)=Y_"^"_$SELECT($DATA(^DG(405.3,+Y,0)):$PIECE(^(0),"^"),1:"")
+4 SET Y=$PIECE(VAMV0,"^",18)
SET @VAV@(VANODE,3)=Y_"^"_$SELECT($DATA(^DG(405.2,+Y,0)):$PIECE(^(0),"^"),1:"")
+5 SET VATD=+VAMV0
DO FIND
+6 SET @VAV@(VANODE,4)=VAWD
SET @VAV@(VANODE,5)=VAPP
SET @VAV@(VANODE,6)=VATS
SET @VAV@(VANODE,7)=VADX
+7 QUIT
+8 ;
COPY ; copy from primary to other nodes
+1 SET @VAV@(VANODE)=VAMV
+2 ; 1-mvt d/t ; 2-transaction type ; 3-mvt type
+3 SET @VAV@(VANODE,1)=@VAV@($PIECE(VAS,"^",3))
SET @VAV@(VANODE,2)=@VAV@($PIECE(VAS,"^",2))
SET @VAV@(VANODE,3)=@VAV@($PIECE(VAS,"^",4))
+4 ; 4-ward ; 5-doc ; 6-treat spec ; 7-dx
+5 SET @VAV@(VANODE,4)=@VAV@($PIECE(VAS,"^",5))
SET @VAV@(VANODE,5)=@VAV@($PIECE(VAS,"^",7))
SET @VAV@(VANODE,6)=@VAV@($PIECE(VAS,"^",8))
SET @VAV@(VANODE,7)=@VAV@($PIECE(VAS,"^",9))
+6 QUIT
+7 ;
LODGER ; -- get lodger data
+1 SET VAWD=$SELECT($PIECE(VAMV0,"^",2)=4:$PIECE(VAMV0,"^",6),$DATA(^DGPM(+$PIECE(VAMV0,"^",14),0)):$PIECE(^(0),"^",6),1:"")
+2 SET VAWD=$SELECT($DATA(^DIC(42,+VAWD,0)):VAWD_"^"_$PIECE(^(0),"^"),1:"")
+3 SET VARM=$SELECT($PIECE(VAMV0,"^",2)=4:$PIECE(VAMV0,"^",7),$DATA(^DGPM(+$PIECE(VAMV0,"^",14),0)):$PIECE(^(0),"^",7),1:"")
+4 SET VARM=$SELECT($DATA(^DG(405.4,+VARM,0)):VARM_"^"_$PIECE(^(0),"^"),1:"")
+5 QUIT
