Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: DGPMDDCN

DGPMDDCN.m

Go to the documentation of this file.
  1. DGPMDDCN ;ALB/MRL - DETERMINE INPATIENT X-REF'S ;3/04/08 8:54am
  1. ;;5.3;Registration;**54,498,671,812**;Aug 13, 1993;Build 19
  1. ;
  1. 1 ;
  1. I $S($D(DGPMT):1,('$D(DA)#2):1,'$D(DGPMDDF):1,'$D(DGPMDDT):1,1:0) G KX
  1. N DFN S DFN=+$P(^DGPM(+DA,0),"^",3) I '$D(^DPT(DFN,0)) G KX
  1. I 'DGPMDDT D @("K"_+DGPMDDF) G Q
  1. D INPTCK
  1. I $S('VAWD:1,1:$P(VAWD,"^",2)="") D G Q
  1. . N DGWD
  1. . D FIND^DGPMDDLD
  1. . I DGWD,($P(DGWD,"^",2)]"") D EN^DGPMDDLD Q
  1. . K X
  1. D @("S"_+DGPMDDF) G Q
  1. ;
  1. KX K X
  1. Q D KVAR^VADPT30 K DGPMX,DGPMX1,DGFLD,DGPMDD,DGPMDDF,DGPMDDT,I Q
  1. ;
  1. S6 ; -- ward x-ref
  1. S DGFLD=.1 I $D(^DPT(DFN,.1)) S DGPMX=^(.1) K:$D(^(.105)) ^DGPM("CN",DGPMX,+^(.105)) D KILL
  1. S DGPMX=$P(VAWD,"^",2),^DGPM("CN",DGPMX,+$P(^DGPM(+VAMV,0),"^",14))=""
  1. D SET
  1. S DGFLD=.102 I $D(^DPT(DFN,.102)) S DGPMX=^(.102) D KILL
  1. S DGPMX=+VAMV D SET:DGPMX
  1. S DGFLD=.105 I $D(^DPT(DFN,.105)) S DGPMX=^(.105) D KILL
  1. S DGPMX=+$P(^DGPM(+VAMV,0),"^",14) D SET:DGPMX
  1. Q
  1. ;
  1. K6 ;
  1. I X S W=$S($D(^DIC(42,+X,0)):$P(^(0),"^",1),1:"") I W]"" K ^DGPM("CN",W,+$P(^DGPM(DA,0),"^",14)) I $D(^DPT(DFN,.1)),^(.1)=W S DGPMX=W,DGFLD=.1 D KILL
  1. K W
  1. I $D(^DPT(DFN,.102)),^(.102)=DA S DGPMX=DA,DGFLD=.102 D KILL
  1. I $D(^DPT(DFN,.105)),^(.105)=$P(^DGPM(DA,0),"^",14) S DGPMX=$P(^DGPM(DA,0),"^",14),DGFLD=.105 D KILL
  1. Q
  1. ;
  1. S7 ; -- room-bed x-ref
  1. I $D(^DPT(DFN,.108)) S DGPMX=^(.108),DGFLD=.108 D KILL F DGPMX1=0:0 S DGPMX1=+$O(^DGPM("ARM",DGPMX,DGPMX1)) D CHK I $T K ^DGPM("ARM",DGPMX,DGPMX1) Q
  1. S DGFLD=.101 I $D(^DPT(DFN,.101)) S DGPMX=^(.101) D KILL
  1. S DGPMX=$P(VARM,"^",2) D SET
  1. I +VARM S DGFLD=.108,DGPMX=+VARM,^DGPM("ARM",DGPMX,VAWDA)=0 D SET
  1. Q
  1. ;
  1. K7 ;
  1. I $D(^DPT(DFN,.108)),X=+^(.108) S DGPMX=X I $D(^DGPM("ARM",DGPMX,DA)) K ^(DA) S DGFLD=.108 D KILL
  1. I X S R=$S($D(^DG(405.4,+X,0)):$P(^(0),"^",1),1:"") I R]"",$D(^DPT(DFN,.101)),^(.101)=R S DGPMX=R,DGFLD=.101 D KILL
  1. Q
  1. ;
  1. CHK ;
  1. I '$D(^DGPM(DGPMX1,0)) Q
  1. I $P(^DGPM(DGPMX1,0),"^",3)=DFN Q
  1. Q
  1. ;
  1. S8 ; -- doc x-ref
  1. S DGFLD=.104 I $D(^DPT(DFN,.104)) S DGPMX=+^(.104) D KILL
  1. S DGPMX=+VAPP I DGPMX D
  1. . ;DG*5.3*812 changing ^DIE to UPDATE^DIE to avoid recursive error
  1. . N DGFDA,ERR
  1. . S DGFDA(2,DFN_",",.104)=DGPMX
  1. . D UPDATE^DIE("","DGFDA","")
  1. Q
  1. ;
  1. K8 ;
  1. I X,$D(^DPT(DFN,.104)),^(.104)=X S DGPMX=X,DGFLD=.104 D KILL
  1. Q
  1. ;
  1. S9 ; -- tr. spec x-ref
  1. S DGFLD=.103 I $D(^DPT(DFN,.103)) S DGPMX=+^(.103) D KILL
  1. S DGPMX=+VATS D SET:DGPMX
  1. Q
  1. ;
  1. K9 ;
  1. I X,$D(^DPT(DFN,.103)),^(.103)=X S DGPMX=X,DGFLD=.103 D KILL
  1. Q
  1. ;
  1. S19 ; -- attend x-ref
  1. S DGFLD=.1041 I $D(^DPT(DFN,.1041)) S DGPMX=+^(.1041) D KILL
  1. S DGPMX=+VAAP D SET:DGPMX
  1. Q
  1. ;
  1. K19 ;
  1. I X,$D(^DPT(DFN,.1041)),^(.1041)=X S DGPMX=X,DGFLD=.1041 D KILL
  1. Q
  1. ;
  1. S41 ; -- fac dir x-ref (AFD)
  1. S DGFLD=.109 S DGPMX=$P($G(^DPT(DFN,.109)),"^",1) D KILL:(DGPMX'="")
  1. S DGPMX=$P(VAFD,"^",1) D SET:(DGPMX'="")
  1. Q
  1. ;
  1. K41 ;
  1. I X'="",$P($G(^DPT(DFN,.109)),"^",1)=X S DGPMX=X,DGFLD=.109 D KILL
  1. Q
  1. ;
  1. SET ; -- generic set x-ref logic
  1. Q:DGPMX']""
  1. N X,DA S DA=DFN,(^DPT(DA,DGFLD),X)=DGPMX
  1. F DGIX=0:0 S DGIX=$O(^DD(2,DGFLD,1,DGIX)) Q:'DGIX X ^(DGIX,1) S X=DGPMX
  1. K DGIX Q
  1. ;
  1. KILL ; -- generic kill x-ref logic
  1. Q:DGPMX']""
  1. N X,DA S DA=DFN,X=DGPMX
  1. F DGIX=0:0 S DGIX=$O(^DD(2,DGFLD,1,DGIX)) Q:'DGIX X ^(DGIX,2) S X=DGPMX
  1. K DGIX,^DPT(DA,DGFLD) Q
  1. ;
  1. CN ; -- set "CN" x-ref for file #2 equal to corresp adm mv
  1. N DFN,VAMV0,VAMV,VAMT,VAID,DGX
  1. S DGX=X D NOW^%DTC S VAID=9999999.999999-%,DFN=DA D MV^VADPT30
  1. I $P(VAMV0,U,2),$P(VAMV0,U,2)'=3 S ^DPT("CN",DGX,DA)=$P(VAMV0,"^",14)
  1. Q
  1. ;
  1. RESET ; -- reset ^DPT nodes and x-refs
  1. ; input: DFN
  1. ;
  1. ; -- kill data and x-refs
  1. I $D(^DPT(DFN,.105)),$D(^(.1)),^(.1)]"" K ^DGPM("CN",^(.1),+^(.105))
  1. I $D(^DPT(DFN,.108)) S DGPMX=^(.108),DGFLD=.108 D KILL F DGPMX1=0:0 S DGPMX1=+$O(^DGPM("ARM",DGPMX,DGPMX1)) D CHK I $T K ^DGPM("ARM",DGPMX,DGPMX1) Q
  1. F DGFLD=.1,.101,.102,.103,.104,.1041,.105,.109 I $D(^DPT(DFN,DGFLD)) S DGPMX=^(DGFLD) D KILL
  1. ; -- reset data and x-refs
  1. D INPTCK
  1. I $S('VAWD:1,1:$P(VAWD,"^",2)="") D G RESETQ
  1. . N DGWD
  1. . D FIND^DGPMDDLD
  1. . I DGWD,($P(DGWD,"^",2)]"") D RESET^DGPMDDLD
  1. D SETALL
  1. RESETQ D KVAR^VADPT30 K DGPMX,DGPMX1,DGFLD,I Q
  1. ;
  1. SETALL D S6,S7,S8,S9,S19,S41 Q
  1. ;
  1. XREF I $D(^DGPM(DA,0)),$P(^(0),"^",2)=4!($P(^(0),"^",2)=5) G XREF^DGPMDDLD
  1. Q:$D(DGPMT)
  1. I $D(^DGPM(DA,0)) N DFN S DFN=+$P(^(0),U,3) D RESET
  1. Q
  1. ;
  1. INPTCK ; check to see if patient is current inpatient
  1. D NOW^%DTC S VAPRT=0,VATD=9999999.999999-%,(VACN,VAPRC)=1
  1. S VA200="" D VAR^VADPT30 K VA200
  1. Q