DGPMDDCN ;ALB/MRL - DETERMINE INPATIENT X-REF'S ;3/04/08 8:54am
;;5.3;Registration;**54,498,671,812**;Aug 13, 1993;Build 19
;
1 ;
I $S($D(DGPMT):1,('$D(DA)#2):1,'$D(DGPMDDF):1,'$D(DGPMDDT):1,1:0) G KX
N DFN S DFN=+$P(^DGPM(+DA,0),"^",3) I '$D(^DPT(DFN,0)) G KX
I 'DGPMDDT D @("K"_+DGPMDDF) G Q
D INPTCK
I $S('VAWD:1,1:$P(VAWD,"^",2)="") D G Q
. N DGWD
. D FIND^DGPMDDLD
. I DGWD,($P(DGWD,"^",2)]"") D EN^DGPMDDLD Q
. K X
D @("S"_+DGPMDDF) G Q
;
KX K X
Q D KVAR^VADPT30 K DGPMX,DGPMX1,DGFLD,DGPMDD,DGPMDDF,DGPMDDT,I Q
;
S6 ; -- ward x-ref
S DGFLD=.1 I $D(^DPT(DFN,.1)) S DGPMX=^(.1) K:$D(^(.105)) ^DGPM("CN",DGPMX,+^(.105)) D KILL
S DGPMX=$P(VAWD,"^",2),^DGPM("CN",DGPMX,+$P(^DGPM(+VAMV,0),"^",14))=""
D SET
S DGFLD=.102 I $D(^DPT(DFN,.102)) S DGPMX=^(.102) D KILL
S DGPMX=+VAMV D SET:DGPMX
S DGFLD=.105 I $D(^DPT(DFN,.105)) S DGPMX=^(.105) D KILL
S DGPMX=+$P(^DGPM(+VAMV,0),"^",14) D SET:DGPMX
Q
;
K6 ;
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
K W
I $D(^DPT(DFN,.102)),^(.102)=DA S DGPMX=DA,DGFLD=.102 D KILL
I $D(^DPT(DFN,.105)),^(.105)=$P(^DGPM(DA,0),"^",14) S DGPMX=$P(^DGPM(DA,0),"^",14),DGFLD=.105 D KILL
Q
;
S7 ; -- room-bed x-ref
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
S DGFLD=.101 I $D(^DPT(DFN,.101)) S DGPMX=^(.101) D KILL
S DGPMX=$P(VARM,"^",2) D SET
I +VARM S DGFLD=.108,DGPMX=+VARM,^DGPM("ARM",DGPMX,VAWDA)=0 D SET
Q
;
K7 ;
I $D(^DPT(DFN,.108)),X=+^(.108) S DGPMX=X I $D(^DGPM("ARM",DGPMX,DA)) K ^(DA) S DGFLD=.108 D KILL
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
Q
;
CHK ;
I '$D(^DGPM(DGPMX1,0)) Q
I $P(^DGPM(DGPMX1,0),"^",3)=DFN Q
Q
;
S8 ; -- doc x-ref
S DGFLD=.104 I $D(^DPT(DFN,.104)) S DGPMX=+^(.104) D KILL
S DGPMX=+VAPP I DGPMX D
. ;DG*5.3*812 changing ^DIE to UPDATE^DIE to avoid recursive error
. N DGFDA,ERR
. S DGFDA(2,DFN_",",.104)=DGPMX
. D UPDATE^DIE("","DGFDA","")
Q
;
K8 ;
I X,$D(^DPT(DFN,.104)),^(.104)=X S DGPMX=X,DGFLD=.104 D KILL
Q
;
S9 ; -- tr. spec x-ref
S DGFLD=.103 I $D(^DPT(DFN,.103)) S DGPMX=+^(.103) D KILL
S DGPMX=+VATS D SET:DGPMX
Q
;
K9 ;
I X,$D(^DPT(DFN,.103)),^(.103)=X S DGPMX=X,DGFLD=.103 D KILL
Q
;
S19 ; -- attend x-ref
S DGFLD=.1041 I $D(^DPT(DFN,.1041)) S DGPMX=+^(.1041) D KILL
S DGPMX=+VAAP D SET:DGPMX
Q
;
K19 ;
I X,$D(^DPT(DFN,.1041)),^(.1041)=X S DGPMX=X,DGFLD=.1041 D KILL
Q
;
S41 ; -- fac dir x-ref (AFD)
S DGFLD=.109 S DGPMX=$P($G(^DPT(DFN,.109)),"^",1) D KILL:(DGPMX'="")
S DGPMX=$P(VAFD,"^",1) D SET:(DGPMX'="")
Q
;
K41 ;
I X'="",$P($G(^DPT(DFN,.109)),"^",1)=X S DGPMX=X,DGFLD=.109 D KILL
Q
;
SET ; -- generic set x-ref logic
Q:DGPMX']""
N X,DA S DA=DFN,(^DPT(DA,DGFLD),X)=DGPMX
F DGIX=0:0 S DGIX=$O(^DD(2,DGFLD,1,DGIX)) Q:'DGIX X ^(DGIX,1) S X=DGPMX
K DGIX Q
;
KILL ; -- generic kill x-ref logic
Q:DGPMX']""
N X,DA S DA=DFN,X=DGPMX
F DGIX=0:0 S DGIX=$O(^DD(2,DGFLD,1,DGIX)) Q:'DGIX X ^(DGIX,2) S X=DGPMX
K DGIX,^DPT(DA,DGFLD) Q
;
CN ; -- set "CN" x-ref for file #2 equal to corresp adm mv
N DFN,VAMV0,VAMV,VAMT,VAID,DGX
S DGX=X D NOW^%DTC S VAID=9999999.999999-%,DFN=DA D MV^VADPT30
I $P(VAMV0,U,2),$P(VAMV0,U,2)'=3 S ^DPT("CN",DGX,DA)=$P(VAMV0,"^",14)
Q
;
RESET ; -- reset ^DPT nodes and x-refs
; input: DFN
;
; -- kill data and x-refs
I $D(^DPT(DFN,.105)),$D(^(.1)),^(.1)]"" K ^DGPM("CN",^(.1),+^(.105))
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
F DGFLD=.1,.101,.102,.103,.104,.1041,.105,.109 I $D(^DPT(DFN,DGFLD)) S DGPMX=^(DGFLD) D KILL
; -- reset data and x-refs
D INPTCK
I $S('VAWD:1,1:$P(VAWD,"^",2)="") D G RESETQ
. N DGWD
. D FIND^DGPMDDLD
. I DGWD,($P(DGWD,"^",2)]"") D RESET^DGPMDDLD
D SETALL
RESETQ D KVAR^VADPT30 K DGPMX,DGPMX1,DGFLD,I Q
;
SETALL D S6,S7,S8,S9,S19,S41 Q
;
XREF I $D(^DGPM(DA,0)),$P(^(0),"^",2)=4!($P(^(0),"^",2)=5) G XREF^DGPMDDLD
Q:$D(DGPMT)
I $D(^DGPM(DA,0)) N DFN S DFN=+$P(^(0),U,3) D RESET
Q
;
INPTCK ; check to see if patient is current inpatient
D NOW^%DTC S VAPRT=0,VATD=9999999.999999-%,(VACN,VAPRC)=1
S VA200="" D VAR^VADPT30 K VA200
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGPMDDCN 4496 printed Jun 11, 2024@22:42:34 Page 2
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
+2 ;
1 ;
+1 IF $SELECT($DATA(DGPMT):1,('$DATA(DA)#2):1,'$DATA(DGPMDDF):1,'$DATA(DGPMDDT):1,1:0)
GOTO KX
+2 NEW DFN
SET DFN=+$PIECE(^DGPM(+DA,0),"^",3)
IF '$DATA(^DPT(DFN,0))
GOTO KX
+3 IF 'DGPMDDT
DO @("K"_+DGPMDDF)
GOTO Q
+4 DO INPTCK
+5 IF $SELECT('VAWD:1,1:$PIECE(VAWD,"^",2)="")
Begin DoDot:1
+6 NEW DGWD
+7 DO FIND^DGPMDDLD
+8 IF DGWD
IF ($PIECE(DGWD,"^",2)]"")
DO EN^DGPMDDLD
QUIT
+9 KILL X
End DoDot:1
GOTO Q
+10 DO @("S"_+DGPMDDF)
GOTO Q
+11 ;
KX KILL X
Q DO KVAR^VADPT30
KILL DGPMX,DGPMX1,DGFLD,DGPMDD,DGPMDDF,DGPMDDT,I
QUIT
+1 ;
S6 ; -- ward x-ref
+1 SET DGFLD=.1
IF $DATA(^DPT(DFN,.1))
SET DGPMX=^(.1)
if $DATA(^(.105))
KILL ^DGPM("CN",DGPMX,+^(.105))
DO KILL
+2 SET DGPMX=$PIECE(VAWD,"^",2)
SET ^DGPM("CN",DGPMX,+$PIECE(^DGPM(+VAMV,0),"^",14))=""
+3 DO SET
+4 SET DGFLD=.102
IF $DATA(^DPT(DFN,.102))
SET DGPMX=^(.102)
DO KILL
+5 SET DGPMX=+VAMV
if DGPMX
DO SET
+6 SET DGFLD=.105
IF $DATA(^DPT(DFN,.105))
SET DGPMX=^(.105)
DO KILL
+7 SET DGPMX=+$PIECE(^DGPM(+VAMV,0),"^",14)
if DGPMX
DO SET
+8 QUIT
+9 ;
K6 ;
+1 IF X
SET W=$SELECT($DATA(^DIC(42,+X,0)):$PIECE(^(0),"^",1),1:"")
IF W]""
KILL ^DGPM("CN",W,+$PIECE(^DGPM(DA,0),"^",14))
IF $DATA(^DPT(DFN,.1))
IF ^(.1)=W
SET DGPMX=W
SET DGFLD=.1
DO KILL
+2 KILL W
+3 IF $DATA(^DPT(DFN,.102))
IF ^(.102)=DA
SET DGPMX=DA
SET DGFLD=.102
DO KILL
+4 IF $DATA(^DPT(DFN,.105))
IF ^(.105)=$PIECE(^DGPM(DA,0),"^",14)
SET DGPMX=$PIECE(^DGPM(DA,0),"^",14)
SET DGFLD=.105
DO KILL
+5 QUIT
+6 ;
S7 ; -- room-bed x-ref
+1 IF $DATA(^DPT(DFN,.108))
SET DGPMX=^(.108)
SET DGFLD=.108
DO KILL
FOR DGPMX1=0:0
SET DGPMX1=+$ORDER(^DGPM("ARM",DGPMX,DGPMX1))
DO CHK
IF $TEST
KILL ^DGPM("ARM",DGPMX,DGPMX1)
QUIT
+2 SET DGFLD=.101
IF $DATA(^DPT(DFN,.101))
SET DGPMX=^(.101)
DO KILL
+3 SET DGPMX=$PIECE(VARM,"^",2)
DO SET
+4 IF +VARM
SET DGFLD=.108
SET DGPMX=+VARM
SET ^DGPM("ARM",DGPMX,VAWDA)=0
DO SET
+5 QUIT
+6 ;
K7 ;
+1 IF $DATA(^DPT(DFN,.108))
IF X=+^(.108)
SET DGPMX=X
IF $DATA(^DGPM("ARM",DGPMX,DA))
KILL ^(DA)
SET DGFLD=.108
DO KILL
+2 IF X
SET R=$SELECT($DATA(^DG(405.4,+X,0)):$PIECE(^(0),"^",1),1:"")
IF R]""
IF $DATA(^DPT(DFN,.101))
IF ^(.101)=R
SET DGPMX=R
SET DGFLD=.101
DO KILL
+3 QUIT
+4 ;
CHK ;
+1 IF '$DATA(^DGPM(DGPMX1,0))
QUIT
+2 IF $PIECE(^DGPM(DGPMX1,0),"^",3)=DFN
QUIT
+3 QUIT
+4 ;
S8 ; -- doc x-ref
+1 SET DGFLD=.104
IF $DATA(^DPT(DFN,.104))
SET DGPMX=+^(.104)
DO KILL
+2 SET DGPMX=+VAPP
IF DGPMX
Begin DoDot:1
+3 ;DG*5.3*812 changing ^DIE to UPDATE^DIE to avoid recursive error
+4 NEW DGFDA,ERR
+5 SET DGFDA(2,DFN_",",.104)=DGPMX
+6 DO UPDATE^DIE("","DGFDA","")
End DoDot:1
+7 QUIT
+8 ;
K8 ;
+1 IF X
IF $DATA(^DPT(DFN,.104))
IF ^(.104)=X
SET DGPMX=X
SET DGFLD=.104
DO KILL
+2 QUIT
+3 ;
S9 ; -- tr. spec x-ref
+1 SET DGFLD=.103
IF $DATA(^DPT(DFN,.103))
SET DGPMX=+^(.103)
DO KILL
+2 SET DGPMX=+VATS
if DGPMX
DO SET
+3 QUIT
+4 ;
K9 ;
+1 IF X
IF $DATA(^DPT(DFN,.103))
IF ^(.103)=X
SET DGPMX=X
SET DGFLD=.103
DO KILL
+2 QUIT
+3 ;
S19 ; -- attend x-ref
+1 SET DGFLD=.1041
IF $DATA(^DPT(DFN,.1041))
SET DGPMX=+^(.1041)
DO KILL
+2 SET DGPMX=+VAAP
if DGPMX
DO SET
+3 QUIT
+4 ;
K19 ;
+1 IF X
IF $DATA(^DPT(DFN,.1041))
IF ^(.1041)=X
SET DGPMX=X
SET DGFLD=.1041
DO KILL
+2 QUIT
+3 ;
S41 ; -- fac dir x-ref (AFD)
+1 SET DGFLD=.109
SET DGPMX=$PIECE($GET(^DPT(DFN,.109)),"^",1)
if (DGPMX'="")
DO KILL
+2 SET DGPMX=$PIECE(VAFD,"^",1)
if (DGPMX'="")
DO SET
+3 QUIT
+4 ;
K41 ;
+1 IF X'=""
IF $PIECE($GET(^DPT(DFN,.109)),"^",1)=X
SET DGPMX=X
SET DGFLD=.109
DO KILL
+2 QUIT
+3 ;
SET ; -- generic set x-ref logic
+1 if DGPMX']""
QUIT
+2 NEW X,DA
SET DA=DFN
SET (^DPT(DA,DGFLD),X)=DGPMX
+3 FOR DGIX=0:0
SET DGIX=$ORDER(^DD(2,DGFLD,1,DGIX))
if 'DGIX
QUIT
XECUTE ^(DGIX,1)
SET X=DGPMX
+4 KILL DGIX
QUIT
+5 ;
KILL ; -- generic kill x-ref logic
+1 if DGPMX']""
QUIT
+2 NEW X,DA
SET DA=DFN
SET X=DGPMX
+3 FOR DGIX=0:0
SET DGIX=$ORDER(^DD(2,DGFLD,1,DGIX))
if 'DGIX
QUIT
XECUTE ^(DGIX,2)
SET X=DGPMX
+4 KILL DGIX,^DPT(DA,DGFLD)
QUIT
+5 ;
CN ; -- set "CN" x-ref for file #2 equal to corresp adm mv
+1 NEW DFN,VAMV0,VAMV,VAMT,VAID,DGX
+2 SET DGX=X
DO NOW^%DTC
SET VAID=9999999.999999-%
SET DFN=DA
DO MV^VADPT30
+3 IF $PIECE(VAMV0,U,2)
IF $PIECE(VAMV0,U,2)'=3
SET ^DPT("CN",DGX,DA)=$PIECE(VAMV0,"^",14)
+4 QUIT
+5 ;
RESET ; -- reset ^DPT nodes and x-refs
+1 ; input: DFN
+2 ;
+3 ; -- kill data and x-refs
+4 IF $DATA(^DPT(DFN,.105))
IF $DATA(^(.1))
IF ^(.1)]""
KILL ^DGPM("CN",^(.1),+^(.105))
+5 IF $DATA(^DPT(DFN,.108))
SET DGPMX=^(.108)
SET DGFLD=.108
DO KILL
FOR DGPMX1=0:0
SET DGPMX1=+$ORDER(^DGPM("ARM",DGPMX,DGPMX1))
DO CHK
IF $TEST
KILL ^DGPM("ARM",DGPMX,DGPMX1)
QUIT
+6 FOR DGFLD=.1,.101,.102,.103,.104,.1041,.105,.109
IF $DATA(^DPT(DFN,DGFLD))
SET DGPMX=^(DGFLD)
DO KILL
+7 ; -- reset data and x-refs
+8 DO INPTCK
+9 IF $SELECT('VAWD:1,1:$PIECE(VAWD,"^",2)="")
Begin DoDot:1
+10 NEW DGWD
+11 DO FIND^DGPMDDLD
+12 IF DGWD
IF ($PIECE(DGWD,"^",2)]"")
DO RESET^DGPMDDLD
End DoDot:1
GOTO RESETQ
+13 DO SETALL
RESETQ DO KVAR^VADPT30
KILL DGPMX,DGPMX1,DGFLD,I
QUIT
+1 ;
SETALL DO S6
DO S7
DO S8
DO S9
DO S19
DO S41
QUIT
+1 ;
XREF IF $DATA(^DGPM(DA,0))
IF $PIECE(^(0),"^",2)=4!($PIECE(^(0),"^",2)=5)
GOTO XREF^DGPMDDLD
+1 if $DATA(DGPMT)
QUIT
+2 IF $DATA(^DGPM(DA,0))
NEW DFN
SET DFN=+$PIECE(^(0),U,3)
DO RESET
+3 QUIT
+4 ;
INPTCK ; check to see if patient is current inpatient
+1 DO NOW^%DTC
SET VAPRT=0
SET VATD=9999999.999999-%
SET (VACN,VAPRC)=1
+2 SET VA200=""
DO VAR^VADPT30
KILL VA200
+3 QUIT
