- 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 Jan 18, 2025@03:50:06 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