DGPMXX1 ; COMPILED XREF FOR FILE #405 ; 06/01/18
;
S DIKZK=2
S DIKZ(0)=$G(^DGPM(DA,0))
S X=$P($G(DIKZ(0)),U,2)
I X'="" S DGPMDDF=2 D ^DGPMDD2
S X=$P($G(DIKZ(0)),U,3)
I X'="" K ^DGPM("C",$E(X,1,30),DA)
S X=$P($G(DIKZ(0)),U,3)
I X'="" S DGPMDDF=3 D ^DGPMDD2
S X=$P($G(DIKZ(0)),U,3)
I X'="" K ^DGPM("ADFN"_X,+^DGPM(DA,0),DA)
S X=$P($G(DIKZ(0)),U,4)
I X'="" D
.N DIK,DIV,DIU,DIN
.K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGPM(D0,0)):^(0),1:"") S X=$P(Y(1),U,18),X=X S DIU=X K Y S X="" S DIH=$G(^DGPM(DIV(0),0)),DIV=X S $P(^(0),U,18)=DIV,DIH=405,DIG=.18 D ^DICR
S DIKZ(0)=$G(^DGPM(DA,0))
S X=$P($G(DIKZ(0)),U,5)
I X'="" I $P(^DGPM(DA,0),"^",2)=3 S A1B2TAG="ADM" D ^A1B2XFR
S X=$P($G(DIKZ(0)),U,6)
I X'="" S DGPMDDF=6,DGPMDDT=0 D ^DGPMDDCN
S X=$P($G(DIKZ(0)),U,6)
I X'="" S Y=^DGPM(DA,0) I +Y,Y<DT,X'=$P(Y,U,6) S Y=$P(Y,U,2) I Y<3 S DGOWD=$S($D(^DIC(42,+X,0)):$P(^(0),U),1:"") K DGIDX
S X=$P($G(DIKZ(0)),U,7)
I X'="" S DGPMDDF=7,DGPMDDT=0 D ^DGPMDDCN
S X=$P($G(DIKZ(0)),U,8)
I X'="" S DGPMDDF=8,DGPMDDT=0 D ^DGPMDDCN
S X=$P($G(DIKZ(0)),U,9)
I X'="" S DGPMDDF=9 D ^DGPMDD2
S X=$P($G(DIKZ(0)),U,9)
I X'="" S DGPMDDF=9,DGPMDDT=0 D ^DGPMDDCN
S X=$P($G(DIKZ(0)),U,9)
I X'="" I $D(^DGPM(+$P(^DGPM(DA,0),"^",24),0)),($P(^(0),"^",2)=1) S A1B2TAG="ADM1" D ^A1B2XFR
S X=$P($G(DIKZ(0)),U,9)
I X'="" S Y=^DGPM(DA,0) I +Y,Y<DT S Y=$P(Y,U,2) I Y=6,X'=$P(Y,U,9) S DGHNYT=14 D ^DGPMGLC
S X=$P($G(DIKZ(0)),U,9)
I X'="" D:($T(ADGRU^DGRUDD01)'="") ADGRU^DGRUDD01($$GET1^DIQ(405,DA,.03,"I"))
S X=$P($G(DIKZ(0)),U,9)
I X'="" S DH=405,DV=.09,DU=1 S DIIX=2 D:$G(DIK(0))'["A" AUDIT^DIK1
S X=$P($G(DIKZ(0)),U,14)
I X'="" S DGPMDDF=14 D ^DGPMDD2
S X=$P($G(DIKZ(0)),U,14)
I X'="" K ^DGPM("CA",$E(X,1,30),DA)
S X=$P($G(DIKZ(0)),U,14)
I X'="" D
.N DIK,DIV,DIU,DIN
.K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X I "^3^5^"[("^"_$P(^DGPM(DA,0),"^",2)_"^") I X S X=DIV X ^DD(405,.14,1,3,89.2) S X=$P($G(^DGPM(+$P(Y(101),U,17),0)),U) S D0=I(0,0) S DIU=X K Y S X="" X ^DD(405,.14,1,3,2.4)
S DIKZ(0)=$G(^DGPM(DA,0))
S X=$P($G(DIKZ(0)),U,16)
I X'="" K ^DGPM("APTF",$E(X,1,30),DA)
S X=$P($G(DIKZ(0)),U,17)
I X'="" D XREF^DGPMDDCN
S X=$P($G(DIKZ(0)),U,18)
I X'="" D
.N DIK,DIV,DIU,DIN
.K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S X=$S('$D(^DG(405.2,+X,0)):"",1:$P(^(0),U,1))["DEATH" I X S X=DIV X ^DD(405,.18,1,2,89.2) S X=$P(Y(101),U,1) S D0=I(0,0) S DIU=X K Y S X="" X ^DD(405,.18,1,2,2.4)
S X=$P($G(DIKZ(0)),U,18)
I X'="" S Y=^DGPM(DA,0) I +Y,Y<DT S Y=$P(Y,U,2) I Y<4 S DGOTY=$S($D(^DG(405.2,+X,0)):$P(^(0),U),1:"") K DGIDX
S X=$P($G(DIKZ(0)),U,18)
I X'="" I $P(^DGPM(DA,0),"^",2)=3 S A1B2TAG="ADM" D ^A1B2XFR
S DIKZ(0)=$G(^DGPM(DA,0))
S X=$P($G(DIKZ(0)),U,19)
I X'="" S DGPMDDF=19,DGPMDDT=0 D ^DGPMDDCN
S X=$P($G(DIKZ(0)),U,22)
I X'="" S DGPMDDF=22 D ^DGPMDD2
S X=$P($G(DIKZ(0)),U,23)
I X'="" S DGPMDDF=23 D ^DGPMDD2
S X=$P($G(DIKZ(0)),U,24)
I X'="" K ^DGPM("APHY",$E(X,1,30),DA)
S X=$P($G(DIKZ(0)),U,27)
I X'="" K ^DGPM("AVISIT",$E(X,1,30),DA)
S X=$P($G(DIKZ(0)),U,27)
I X'="" K:$P(^DGPM(DA,0),U,3) ^DGPM("AVST",$P(^DGPM(DA,0),U,3),X,DA)
S DIKZ("DIR")=$G(^DGPM(DA,"DIR"))
S X=$P($G(DIKZ("DIR")),U,1)
I X'="" D
.N DIK,DIV,DIU,DIN
.K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGPM(D0,"DIR")):^("DIR"),1:"") S X=$P(Y(1),U,2),X=X S DIU=X K Y S X="" S DIH=$G(^DGPM(DIV(0),"DIR")),DIV=X S $P(^("DIR"),U,2)=DIV,DIH=405,DIG=42 D ^DICR
S X=$P($G(DIKZ("DIR")),U,1)
I X'="" D
.N DIK,DIV,DIU,DIN
.K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGPM(D0,"DIR")):^("DIR"),1:"") S X=$P(Y(1),U,3),X=X S DIU=X K Y S X="" S DIH=$G(^DGPM(DIV(0),"DIR")),DIV=X S $P(^("DIR"),U,3)=DIV,DIH=405,DIG=43 D ^DICR
S X=$P($G(DIKZ("DIR")),U,1)
I X'="" S DGPMDDF=41,DGPMDDT=0 D ^DGPMDDCN
S DIKZ("ODS")=$G(^DGPM(DA,"ODS"))
S X=$P($G(DIKZ("ODS")),U,2)
I X'="" S A1B2TAG="ADM" D ^A1B2XFR
S X=$P($G(DIKZ("ODS")),U,4)
I X'="" K ^DGPM("AODSA",$E(X,1,30),DA)
S X=$P($G(DIKZ("ODS")),U,6)
I X'="" S A1B2TAG="ADM" D ^A1B2XFR
S X=$P($G(DIKZ("ODS")),U,7)
I X'="" K ^DGPM("AODSD",$E(X,1,30),DA)
S DIKZ(0)=$G(^DGPM(DA,0))
S X=$P($G(DIKZ(0)),U,1)
I X'="" K ^DGPM("B",$E(X,1,30),DA)
S X=$P($G(DIKZ(0)),U,1)
I X'="" S DGPMDDF=1 D ^DGPMDD2
S X=$P($G(DIKZ(0)),U,1)
I X'="" K:$P(^DGPM(DA,0),U,3) ^DGPM("ADFN"_$P(^(0),U,3),X,DA)
S X=$P($G(DIKZ(0)),U,1)
I X'="" S Y=$P(^DGPM(DA,0),U,2) I Y,Y'=4,Y'=5,X,X<DT S DGHNYT=$S(Y=1:2,Y=2:5,Y=3:8,1:14) D ^DGPMGLC
S X=$P($G(DIKZ(0)),U,1)
I X'="" I "^1^3^"[("^"_$P(^DGPM(DA,0),"^",2)_"^") S A1B2TAG="ADM" D ^A1B2XFR
CR1 S DIXR=1515
K X
S X(1)=$P(DIKZ(0),U,1)
S X(2)=$P(DIKZ(0),U,2)
S X(3)=$P(DIKZ(0),U,3)
S X=$G(X(1))
I $G(X(1))]"",$G(X(2))]"",$G(X(3))]"" D
. K X1,X2 M X1=X,X2=X
. S:$D(DIKIL) (X2,X2(1),X2(2),X2(3))=""
. K ^DGPM("AC",X(1),X(2),X(3),DA)
CR2 S DIXR=1516
K X
S DIKZ("USR")=$G(^DGPM(DA,"USR"))
S X(1)=$P(DIKZ("USR"),U,2)
S X=$G(X(1))
I $G(X(1))]"" D
. K X1,X2 M X1=X,X2=X
. S:$D(DIKIL) (X2,X2(1))=""
. K ^DGPM("AD",$E(X,1,30),DA)
CR3 K X
END Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGPMXX1 5039 printed Sep 23, 2025@20:26:37 Page 2
DGPMXX1 ; COMPILED XREF FOR FILE #405 ; 06/01/18
+1 ;
+2 SET DIKZK=2
+3 SET DIKZ(0)=$GET(^DGPM(DA,0))
+4 SET X=$PIECE($GET(DIKZ(0)),U,2)
+5 IF X'=""
SET DGPMDDF=2
DO ^DGPMDD2
+6 SET X=$PIECE($GET(DIKZ(0)),U,3)
+7 IF X'=""
KILL ^DGPM("C",$EXTRACT(X,1,30),DA)
+8 SET X=$PIECE($GET(DIKZ(0)),U,3)
+9 IF X'=""
SET DGPMDDF=3
DO ^DGPMDD2
+10 SET X=$PIECE($GET(DIKZ(0)),U,3)
+11 IF X'=""
KILL ^DGPM("ADFN"_X,+^DGPM(DA,0),DA)
+12 SET X=$PIECE($GET(DIKZ(0)),U,4)
+13 IF X'=""
Begin DoDot:1
+14 NEW DIK,DIV,DIU,DIN
+15 KILL DIV
SET DIV=X
SET D0=DA
SET DIV(0)=D0
SET Y(1)=$SELECT($DATA(^DGPM(D0,0)):^(0),1:"")
SET X=$PIECE(Y(1),U,18)
SET X=X
SET DIU=X
KILL Y
SET X=""
SET DIH=$GET(^DGPM(DIV(0),0))
SET DIV=X
SET $PIECE(^(0),U,18)=DIV
SET DIH=405
SET DIG=.18
DO ^DICR
End DoDot:1
+16 SET DIKZ(0)=$GET(^DGPM(DA,0))
+17 SET X=$PIECE($GET(DIKZ(0)),U,5)
+18 IF X'=""
IF $PIECE(^DGPM(DA,0),"^",2)=3
SET A1B2TAG="ADM"
DO ^A1B2XFR
+19 SET X=$PIECE($GET(DIKZ(0)),U,6)
+20 IF X'=""
SET DGPMDDF=6
SET DGPMDDT=0
DO ^DGPMDDCN
+21 SET X=$PIECE($GET(DIKZ(0)),U,6)
+22 IF X'=""
SET Y=^DGPM(DA,0)
IF +Y
IF Y<DT
IF X'=$PIECE(Y,U,6)
SET Y=$PIECE(Y,U,2)
IF Y<3
SET DGOWD=$SELECT($DATA(^DIC(42,+X,0)):$PIECE(^(0),U),1:"")
KILL DGIDX
+23 SET X=$PIECE($GET(DIKZ(0)),U,7)
+24 IF X'=""
SET DGPMDDF=7
SET DGPMDDT=0
DO ^DGPMDDCN
+25 SET X=$PIECE($GET(DIKZ(0)),U,8)
+26 IF X'=""
SET DGPMDDF=8
SET DGPMDDT=0
DO ^DGPMDDCN
+27 SET X=$PIECE($GET(DIKZ(0)),U,9)
+28 IF X'=""
SET DGPMDDF=9
DO ^DGPMDD2
+29 SET X=$PIECE($GET(DIKZ(0)),U,9)
+30 IF X'=""
SET DGPMDDF=9
SET DGPMDDT=0
DO ^DGPMDDCN
+31 SET X=$PIECE($GET(DIKZ(0)),U,9)
+32 IF X'=""
IF $DATA(^DGPM(+$PIECE(^DGPM(DA,0),"^",24),0))
IF ($PIECE(^(0),"^",2)=1)
SET A1B2TAG="ADM1"
DO ^A1B2XFR
+33 SET X=$PIECE($GET(DIKZ(0)),U,9)
+34 IF X'=""
SET Y=^DGPM(DA,0)
IF +Y
IF Y<DT
SET Y=$PIECE(Y,U,2)
IF Y=6
IF X'=$PIECE(Y,U,9)
SET DGHNYT=14
DO ^DGPMGLC
+35 SET X=$PIECE($GET(DIKZ(0)),U,9)
+36 IF X'=""
if ($TEXT(ADGRU^DGRUDD01)'="")
DO ADGRU^DGRUDD01($$GET1^DIQ(405,DA,.03,"I"))
+37 SET X=$PIECE($GET(DIKZ(0)),U,9)
+38 IF X'=""
SET DH=405
SET DV=.09
SET DU=1
SET DIIX=2
if $GET(DIK(0))'["A"
DO AUDIT^DIK1
+39 SET X=$PIECE($GET(DIKZ(0)),U,14)
+40 IF X'=""
SET DGPMDDF=14
DO ^DGPMDD2
+41 SET X=$PIECE($GET(DIKZ(0)),U,14)
+42 IF X'=""
KILL ^DGPM("CA",$EXTRACT(X,1,30),DA)
+43 SET X=$PIECE($GET(DIKZ(0)),U,14)
+44 IF X'=""
Begin DoDot:1
+45 NEW DIK,DIV,DIU,DIN
+46 KILL DIV
SET DIV=X
SET D0=DA
SET DIV(0)=D0
SET Y(0)=X
IF "^3^5^"[("^"_$PIECE(^DGPM(DA,0),"^",2)_"^")
IF X
SET X=DIV
XECUTE ^DD(405,.14,1,3,89.2)
SET X=$PIECE($GET(^DGPM(+$PIECE(Y(101),U,17),0)),U)
SET D0=I(0,0)
SET DIU=X
KILL Y
SET X=""
XECUTE ^DD(405,.14,1,3,2.4)
End DoDot:1
+47 SET DIKZ(0)=$GET(^DGPM(DA,0))
+48 SET X=$PIECE($GET(DIKZ(0)),U,16)
+49 IF X'=""
KILL ^DGPM("APTF",$EXTRACT(X,1,30),DA)
+50 SET X=$PIECE($GET(DIKZ(0)),U,17)
+51 IF X'=""
DO XREF^DGPMDDCN
+52 SET X=$PIECE($GET(DIKZ(0)),U,18)
+53 IF X'=""
Begin DoDot:1
+54 NEW DIK,DIV,DIU,DIN
+55 KILL DIV
SET DIV=X
SET D0=DA
SET DIV(0)=D0
SET Y(0)=X
SET X=$SELECT('$DATA(^DG(405.2,+X,0)):"",1:$PIECE(^(0),U,1))["DEATH"
IF X
SET X=DIV
XECUTE ^DD(405,.18,1,2,89.2)
SET X=$PIECE(Y(101),U,1)
SET D0=I(0,0)
SET DIU=X
KILL Y
SET X=""
XECUTE ^DD(405,.18,1,2,2.4)
End DoDot:1
+56 SET X=$PIECE($GET(DIKZ(0)),U,18)
+57 IF X'=""
SET Y=^DGPM(DA,0)
IF +Y
IF Y<DT
SET Y=$PIECE(Y,U,2)
IF Y<4
SET DGOTY=$SELECT($DATA(^DG(405.2,+X,0)):$PIECE(^(0),U),1:"")
KILL DGIDX
+58 SET X=$PIECE($GET(DIKZ(0)),U,18)
+59 IF X'=""
IF $PIECE(^DGPM(DA,0),"^",2)=3
SET A1B2TAG="ADM"
DO ^A1B2XFR
+60 SET DIKZ(0)=$GET(^DGPM(DA,0))
+61 SET X=$PIECE($GET(DIKZ(0)),U,19)
+62 IF X'=""
SET DGPMDDF=19
SET DGPMDDT=0
DO ^DGPMDDCN
+63 SET X=$PIECE($GET(DIKZ(0)),U,22)
+64 IF X'=""
SET DGPMDDF=22
DO ^DGPMDD2
+65 SET X=$PIECE($GET(DIKZ(0)),U,23)
+66 IF X'=""
SET DGPMDDF=23
DO ^DGPMDD2
+67 SET X=$PIECE($GET(DIKZ(0)),U,24)
+68 IF X'=""
KILL ^DGPM("APHY",$EXTRACT(X,1,30),DA)
+69 SET X=$PIECE($GET(DIKZ(0)),U,27)
+70 IF X'=""
KILL ^DGPM("AVISIT",$EXTRACT(X,1,30),DA)
+71 SET X=$PIECE($GET(DIKZ(0)),U,27)
+72 IF X'=""
if $PIECE(^DGPM(DA,0),U,3)
KILL ^DGPM("AVST",$PIECE(^DGPM(DA,0),U,3),X,DA)
+73 SET DIKZ("DIR")=$GET(^DGPM(DA,"DIR"))
+74 SET X=$PIECE($GET(DIKZ("DIR")),U,1)
+75 IF X'=""
Begin DoDot:1
+76 NEW DIK,DIV,DIU,DIN
+77 KILL DIV
SET DIV=X
SET D0=DA
SET DIV(0)=D0
SET Y(1)=$SELECT($DATA(^DGPM(D0,"DIR")):^("DIR"),1:"")
SET X=$PIECE(Y(1),U,2)
SET X=X
SET DIU=X
KILL Y
SET X=""
SET DIH=$GET(^DGPM(DIV(0),"DIR"))
SET DIV=X
SET $PIECE(^("DIR"),U,2)=DIV
SET DIH=405
SET DIG=42
DO ^DICR
End DoDot:1
+78 SET X=$PIECE($GET(DIKZ("DIR")),U,1)
+79 IF X'=""
Begin DoDot:1
+80 NEW DIK,DIV,DIU,DIN
+81 KILL DIV
SET DIV=X
SET D0=DA
SET DIV(0)=D0
SET Y(1)=$SELECT($DATA(^DGPM(D0,"DIR")):^("DIR"),1:"")
SET X=$PIECE(Y(1),U,3)
SET X=X
SET DIU=X
KILL Y
SET X=""
SET DIH=$GET(^DGPM(DIV(0),"DIR"))
SET DIV=X
SET $PIECE(^("DIR"),U,3)=DIV
SET DIH=405
SET DIG=43
DO ^DICR
End DoDot:1
+82 SET X=$PIECE($GET(DIKZ("DIR")),U,1)
+83 IF X'=""
SET DGPMDDF=41
SET DGPMDDT=0
DO ^DGPMDDCN
+84 SET DIKZ("ODS")=$GET(^DGPM(DA,"ODS"))
+85 SET X=$PIECE($GET(DIKZ("ODS")),U,2)
+86 IF X'=""
SET A1B2TAG="ADM"
DO ^A1B2XFR
+87 SET X=$PIECE($GET(DIKZ("ODS")),U,4)
+88 IF X'=""
KILL ^DGPM("AODSA",$EXTRACT(X,1,30),DA)
+89 SET X=$PIECE($GET(DIKZ("ODS")),U,6)
+90 IF X'=""
SET A1B2TAG="ADM"
DO ^A1B2XFR
+91 SET X=$PIECE($GET(DIKZ("ODS")),U,7)
+92 IF X'=""
KILL ^DGPM("AODSD",$EXTRACT(X,1,30),DA)
+93 SET DIKZ(0)=$GET(^DGPM(DA,0))
+94 SET X=$PIECE($GET(DIKZ(0)),U,1)
+95 IF X'=""
KILL ^DGPM("B",$EXTRACT(X,1,30),DA)
+96 SET X=$PIECE($GET(DIKZ(0)),U,1)
+97 IF X'=""
SET DGPMDDF=1
DO ^DGPMDD2
+98 SET X=$PIECE($GET(DIKZ(0)),U,1)
+99 IF X'=""
if $PIECE(^DGPM(DA,0),U,3)
KILL ^DGPM("ADFN"_$PIECE(^(0),U,3),X,DA)
+100 SET X=$PIECE($GET(DIKZ(0)),U,1)
+101 IF X'=""
SET Y=$PIECE(^DGPM(DA,0),U,2)
IF Y
IF Y'=4
IF Y'=5
IF X
IF X<DT
SET DGHNYT=$SELECT(Y=1:2,Y=2:5,Y=3:8,1:14)
DO ^DGPMGLC
+102 SET X=$PIECE($GET(DIKZ(0)),U,1)
+103 IF X'=""
IF "^1^3^"[("^"_$PIECE(^DGPM(DA,0),"^",2)_"^")
SET A1B2TAG="ADM"
DO ^A1B2XFR
CR1 SET DIXR=1515
+1 KILL X
+2 SET X(1)=$PIECE(DIKZ(0),U,1)
+3 SET X(2)=$PIECE(DIKZ(0),U,2)
+4 SET X(3)=$PIECE(DIKZ(0),U,3)
+5 SET X=$GET(X(1))
+6 IF $GET(X(1))]""
IF $GET(X(2))]""
IF $GET(X(3))]""
Begin DoDot:1
+7 KILL X1,X2
MERGE X1=X,X2=X
+8 if $DATA(DIKIL)
SET (X2,X2(1),X2(2),X2(3))=""
+9 KILL ^DGPM("AC",X(1),X(2),X(3),DA)
End DoDot:1
CR2 SET DIXR=1516
+1 KILL X
+2 SET DIKZ("USR")=$GET(^DGPM(DA,"USR"))
+3 SET X(1)=$PIECE(DIKZ("USR"),U,2)
+4 SET X=$GET(X(1))
+5 IF $GET(X(1))]""
Begin DoDot:1
+6 KILL X1,X2
MERGE X1=X,X2=X
+7 if $DATA(DIKIL)
SET (X2,X2(1))=""
+8 KILL ^DGPM("AD",$EXTRACT(X,1,30),DA)
End DoDot:1
CR3 KILL X
END QUIT
