IBXX1 ; COMPILED XREF FOR FILE #399 ; 10/03/23
;
S DIKZK=2
S DIKZ(0)=$G(^DGCR(399,DA,0))
S X=$P($G(DIKZ(0)),U,2)
I X'="" K ^DGCR(399,"C",$E(X,1,30),DA)
S X=$P($G(DIKZ(0)),U,3)
I X'="" K ^DGCR(399,"D",$E(X,1,30),DA)
S X=$P($G(DIKZ(0)),U,3)
I X'="" S IBN=$P(^DGCR(399,DA,0),"^",2) I $D(IBN) K ^DGCR(399,"APDT",IBN,DA,9999999-X),IBN
S X=$P($G(DIKZ(0)),U,3)
I X'="" K ^DGCR(399,"ABNDT",DA,9999999-X)
S X=$P($G(DIKZ(0)),U,5)
I X'="" K ^DGCR(399,"ABT",$E(X,1,30),DA)
S X=$P($G(DIKZ(0)),U,7)
I X'="" D
.N DIK,DIV,DIU,DIN
.X ^DD(399,.07,1,1,2.3) I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"U")):^("U"),1:"") S X=$P(Y(1),U,6),X=X S DIU=X K Y S X=DIV S X=0 X ^DD(399,.07,1,1,2.4)
S X=$P($G(DIKZ(0)),U,7)
I X'="" K ^DGCR(399,"AD",$E(X,1,30),DA)
S DIKZ(0)=$G(^DGCR(399,DA,0))
S X=$P($G(DIKZ(0)),U,8)
I X'="" D
.N DIK,DIV,DIU,DIN
.K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399,D0,"U")):^("U"),1:"") S X=$P(Y(1),U,12),X=X S DIU=X K Y S X="" X ^DD(399,.08,1,4,2.4)
S X=$P($G(DIKZ(0)),U,8)
I X'="" K ^DGCR(399,"APTF",$E(X,1,30),DA)
S DIKZ(0)=$G(^DGCR(399,DA,0))
S X=$P($G(DIKZ(0)),U,11)
I X'="" D DEL^IBCU5
S X=$P($G(DIKZ(0)),U,11)
I X'="" S DGRVRCAL=2
S X=$P($G(DIKZ(0)),U,11)
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($P(^DGCR(399,DA,0),U,11)'="i":1,"PST"'[$P(^DGCR(399,DA,0),U,21):1,1:0) I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,0)):^(0),1:"") S X=$P(Y(1),U,21),X=X S DIU=X K Y S X="" X ^DD(399,.11,1,4,2.4)
S DIKZ(0)=$G(^DGCR(399,DA,0))
S X=$P($G(DIKZ(0)),U,13)
I X'="" I $P(^DGCR(399,DA,0),U,2) K ^DGCR(399,"AOP",$P(^(0),U,2),DA)
S X=$P($G(DIKZ(0)),U,13)
I X'="" K ^DGCR(399,"AST",+X,DA)
S X=$P($G(DIKZ(0)),U,13)
I X'="" D
.N DIK,DIV,DIU,DIN
.X ^DD(399,.13,1,4,2.3) I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"TX")):^("TX"),1:"") S X=$P(Y(1),U,5),X=X S DIU=X K Y S X=DIV S X="0" S DIH=$G(^DGCR(399,DIV(0),"TX")),DIV=X S $P(^("TX"),U,5)=DIV,DIH=399,DIG=24 D ^DICR
S DIKZ(0)=$G(^DGCR(399,DA,0))
S X=$P($G(DIKZ(0)),U,17)
I X'="" K ^DGCR(399,"AC",$E(X,1,30),DA)
S X=$P($G(DIKZ(0)),U,19)
I X'="" S DGRVRCAL=2
S X=$P($G(DIKZ(0)),U,19)
I X'="" D ALLID^IBCEP3(DA,.19,2)
S X=$P($G(DIKZ(0)),U,19)
I X'="" D
.N DIK,DIV,DIU,DIN
.K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399,D0,"M2")):^("M2"),1:"") S X=$P(Y(1),U,1),X=X S DIU=X K Y S X="" S DIH=$G(^DGCR(399,DIV(0),"M2")),DIV=X S $P(^("M2"),U,1)=DIV,DIH=399,DIG=140 D ^DICR
S X=$P($G(DIKZ(0)),U,19)
I X'="" D ATTREND^IBCU1(DA,"","")
S X=$P($G(DIKZ(0)),U,19)
I X'="" D
.N DIK,DIV,DIU,DIN
.K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399,D0,"M2")):^("M2"),1:"") S X=$P(Y(1),U,2),X=X S DIU=X K Y S X="" S DIH=$G(^DGCR(399,DIV(0),"M2")),DIV=X S $P(^("M2"),U,2)=DIV,DIH=399,DIG=141 D ^DICR
S X=$P($G(DIKZ(0)),U,19)
I X'="" D
.N DIK,DIV,DIU,DIN
.K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399,D0,"M2")):^("M2"),1:"") S X=$P(Y(1),U,3),X=X S DIU=X K Y S X="" S DIH=$G(^DGCR(399,DIV(0),"M2")),DIV=X S $P(^("M2"),U,3)=DIV,DIH=399,DIG=142 D ^DICR
S X=$P($G(DIKZ(0)),U,19)
I X'="" D
.N DIK,DIV,DIU,DIN
.K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399,D0,"M2")):^("M2"),1:"") S X=$P(Y(1),U,4),X=X S DIU=X K Y S X="" S DIH=$G(^DGCR(399,DIV(0),"M2")),DIV=X S $P(^("M2"),U,4)=DIV,DIH=399,DIG=143 D ^DICR
S X=$P($G(DIKZ(0)),U,19)
I X'="" D
.N DIK,DIV,DIU,DIN
.K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399,D0,"M2")):^("M2"),1:"") S X=$P(Y(1),U,5),X=X S DIU=X K Y S X="" S DIH=$G(^DGCR(399,DIV(0),"M2")),DIV=X S $P(^("M2"),U,5)=DIV,DIH=399,DIG=144 D ^DICR
S X=$P($G(DIKZ(0)),U,19)
I X'="" D
.N DIK,DIV,DIU,DIN
.K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399,D0,"M2")):^("M2"),1:"") S X=$P(Y(1),U,6),X=X S DIU=X K Y S X="" S DIH=$G(^DGCR(399,DIV(0),"M2")),DIV=X S $P(^("M2"),U,6)=DIV,DIH=399,DIG=145 D ^DICR
S DIKZ(0)=$G(^DGCR(399,DA,0))
S X=$P($G(DIKZ(0)),U,21)
I X'="" D
.N DIK,DIV,DIU,DIN
.K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399,D0,"MP")):^("MP"),1:"") S X=$P(Y(1),U,2),X=X S DIU=X K Y S X="" X ^DD(399,.21,1,1,2.4)
S X=$P($G(DIKZ(0)),U,21)
I X'="" D
.N DIK,DIV,DIU,DIN
.K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S X=('$$REQMRA^IBEFUNC(DA)&$$NEEDMRA^IBEFUNC(DA)) I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"TX")):^("TX"),1:"") S X=$P(Y(1),U,5),X=X S DIU=X K Y S X="" X ^DD(399,.21,1,2,2.4)
S X=$P($G(DIKZ(0)),U,21)
I X'="" D
.N DIK,DIV,DIU,DIN
.K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S X=$$DELETE^IBCEF84(DA) I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"TX")):^("TX"),1:"") S X=$P(Y(1),U,8),X=X S DIU=X K Y S X="" X ^DD(399,.21,1,4,2.4)
S DIKZ(0)=$G(^DGCR(399,DA,0))
S X=$P($G(DIKZ(0)),U,25)
I X'="" D ALLID^IBCEP3(DA,.25,2)
S DIKZ("S")=$G(^DGCR(399,DA,"S"))
S X=$P($G(DIKZ("S")),U,1)
I X'="" K ^DGCR(399,"APD",$E(X,1,30),DA)
S X=$P($G(DIKZ("S")),U,7)
I X'="" K ^DGCR(399,"APM",$E(X,1,30),DA)
S X=$P($G(DIKZ("S")),U,10)
I X'="" K ^DGCR(399,"APD3",$E(X,1,30),DA)
S X=$P($G(DIKZ("S")),U,12)
I X'="" K ^DGCR(399,"AP",$E(X,1,30),DA)
S DIKZ("TX")=$G(^DGCR(399,DA,"TX"))
S X=$P($G(DIKZ("TX")),U,2)
I X'="" K ^DGCR(399,"ALEX",$E(X,1,30),DA)
S DIKZ("S1")=$G(^DGCR(399,DA,"S1"))
S X=$P($G(DIKZ("S1")),U,7)
I X'="" K ^DGCR(399,"CAP",$E(X,1,30),DA)
S DIKZ("M")=$G(^DGCR(399,DA,"M"))
S X=$P($G(DIKZ("M")),U,1)
I X'="" D
.N DIK,DIV,DIU,DIN
.K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X I $$COBN^IBCEF(DA)=1 I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"TX")):^("TX"),1:"") S X=$P(Y(1),U,5),X=X S DIU=X K Y S X="" X ^DD(399,101,1,2,2.4)
S X=$P($G(DIKZ("M")),U,1)
I X'="" D
.N DIK,DIV,DIU,DIN
.K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S X=$$DELETE^IBCEF84(DA) I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"TX")):^("TX"),1:"") S X=$P(Y(1),U,8),X=X S DIU=X K Y S X="" X ^DD(399,101,1,5,2.4)
S X=$P($G(DIKZ("M")),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(^DGCR(399,D0,"M2")):^("M2"),1:"") S X=$P(Y(1),U,1),X=X S DIU=X K Y S X="" S DIH=$G(^DGCR(399,DIV(0),"M2")),DIV=X S $P(^("M2"),U,1)=DIV,DIH=399,DIG=140 D ^DICR
S X=$P($G(DIKZ("M")),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(^DGCR(399,D0,"M2")):^("M2"),1:"") S X=$P(Y(1),U,2),X=X S DIU=X K Y S X="" S DIH=$G(^DGCR(399,DIV(0),"M2")),DIV=X S $P(^("M2"),U,2)=DIV,DIH=399,DIG=141 D ^DICR
S DIKZ("M")=$G(^DGCR(399,DA,"M"))
S X=$P($G(DIKZ("M")),U,2)
I X'="" D
.N DIK,DIV,DIU,DIN
.K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X I $$COBN^IBCEF(DA)=2 I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"TX")):^("TX"),1:"") S X=$P(Y(1),U,5),X=X S DIU=X K Y S X="" X ^DD(399,102,1,3,2.4)
S X=$P($G(DIKZ("M")),U,2)
I X'="" D
.N DIK,DIV,DIU,DIN
.K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399,D0,"M2")):^("M2"),1:"") S X=$P(Y(1),U,3),X=X S DIU=X K Y S X="" S DIH=$G(^DGCR(399,DIV(0),"M2")),DIV=X S $P(^("M2"),U,3)=DIV,DIH=399,DIG=142 D ^DICR
S X=$P($G(DIKZ("M")),U,2)
I X'="" D
.N DIK,DIV,DIU,DIN
.K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399,D0,"M2")):^("M2"),1:"") S X=$P(Y(1),U,4),X=X S DIU=X K Y S X="" S DIH=$G(^DGCR(399,DIV(0),"M2")),DIV=X S $P(^("M2"),U,4)=DIV,DIH=399,DIG=143 D ^DICR
S DIKZ("M")=$G(^DGCR(399,DA,"M"))
S X=$P($G(DIKZ("M")),U,3)
I X'="" D
.N DIK,DIV,DIU,DIN
.K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399,D0,"M2")):^("M2"),1:"") S X=$P(Y(1),U,6),X=X S DIU=X K Y S X="" S DIH=$G(^DGCR(399,DIV(0),"M2")),DIV=X S $P(^("M2"),U,6)=DIV,DIH=399,DIG=145 D ^DICR
S X=$P($G(DIKZ("M")),U,3)
I X'="" D
.N DIK,DIV,DIU,DIN
.K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399,D0,"M2")):^("M2"),1:"") S X=$P(Y(1),U,5),X=X S DIU=X K Y S X="" S DIH=$G(^DGCR(399,DIV(0),"M2")),DIV=X S $P(^("M2"),U,5)=DIV,DIH=399,DIG=144 D ^DICR
S DIKZ("M")=$G(^DGCR(399,DA,"M"))
S X=$P($G(DIKZ("M")),U,11)
I X'="" D DEL^IBCU5
S X=$P($G(DIKZ("M")),U,11)
I X'="" S DGRVRCAL=2
S X=$P($G(DIKZ("M")),U,12)
I X'="" D
.N DIK,DIV,DIU,DIN
.K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399,D0,"M")):^("M"),1:"") S X=$P(Y(1),U,1),X=X S DIU=X K Y S X="" X ^DD(399,112,1,1,2.4)
S X=$P($G(DIKZ("M")),U,12)
I X'="" D KIX^IBCNS2(DA,"I1")
S X=$P($G(DIKZ("M")),U,12)
I X'="" D
.N DIK,DIV,DIU,DIN
.X ^DD(399,112,1,3,2.3) I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"MP")):^("MP"),1:"") S X=$P(Y(1),U,2),X=X S DIU=X K Y S X="" X ^DD(399,112,1,3,2.4)
S X=$P($G(DIKZ("M")),U,12)
I X'="" D
.N DIK,DIV,DIU,DIN
.K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399,D0,"U")):^("U"),1:"") S X=$P(Y(1),U,13),X=X S DIU=X K Y S X="" S DIH=$G(^DGCR(399,DIV(0),"U")),DIV=X S $P(^("U"),U,13)=DIV,DIH=399,DIG=163 D ^DICR
S X=$P($G(DIKZ("M")),U,12)
I X'="" D
.N DIK,DIV,DIU,DIN
.K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399,D0,"UF32")):^("UF32"),1:"") S X=$P(Y(1),U,1),X=X S DIU=X K Y S X="" S DIH=$G(^DGCR(399,DIV(0),"UF32")),DIV=X S $P(^("UF32"),U,1)=DIV,DIH=399,DIG=253 D ^DICR
S DIKZ("M")=$G(^DGCR(399,DA,"M"))
S X=$P($G(DIKZ("M")),U,13)
I X'="" D
.N DIK,DIV,DIU,DIN
.K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399,D0,"M")):^("M"),1:"") S X=$P(Y(1),U,2),X=X S DIU=X K Y S X="" X ^DD(399,113,1,1,2.4)
S X=$P($G(DIKZ("M")),U,13)
I X'="" D KIX^IBCNS2(DA,"I2")
S X=$P($G(DIKZ("M")),U,13)
I X'="" D
.N DIK,DIV,DIU,DIN
.X ^DD(399,113,1,3,2.3) I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"MP")):^("MP"),1:"") S X=$P(Y(1),U,2),X=X S DIU=X K Y S X="" X ^DD(399,113,1,3,2.4)
S X=$P($G(DIKZ("M")),U,13)
I X'="" D
.N DIK,DIV,DIU,DIN
.K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399,D0,"U2")):^("U2"),1:"") S X=$P(Y(1),U,8),X=X S DIU=X K Y S X="" S DIH=$G(^DGCR(399,DIV(0),"U2")),DIV=X S $P(^("U2"),U,8)=DIV,DIH=399,DIG=230 D ^DICR
S X=$P($G(DIKZ("M")),U,13)
I X'="" D
.N DIK,DIV,DIU,DIN
.K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399,D0,"UF32")):^("UF32"),1:"") S X=$P(Y(1),U,2),X=X S DIU=X K Y S X="" S DIH=$G(^DGCR(399,DIV(0),"UF32")),DIV=X S $P(^("UF32"),U,2)=DIV,DIH=399,DIG=254 D ^DICR
S DIKZ("M")=$G(^DGCR(399,DA,"M"))
S X=$P($G(DIKZ("M")),U,14)
I X'="" D
.N DIK,DIV,DIU,DIN
.K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399,D0,"M")):^("M"),1:"") S X=$P(Y(1),U,3),X=X S DIU=X K Y S X="" X ^DD(399,114,1,1,2.4)
S X=$P($G(DIKZ("M")),U,14)
I X'="" D KIX^IBCNS2(DA,"I3")
S X=$P($G(DIKZ("M")),U,14)
I X'="" D
.N DIK,DIV,DIU,DIN
.X ^DD(399,114,1,3,2.3) I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"MP")):^("MP"),1:"") S X=$P(Y(1),U,2),X=X S DIU=X K Y S X="" X ^DD(399,114,1,3,2.4)
S X=$P($G(DIKZ("M")),U,14)
I X'="" D
.N DIK,DIV,DIU,DIN
.K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399,D0,"U2")):^("U2"),1:"") S X=$P(Y(1),U,9),X=X S DIU=X K Y S X="" S DIH=$G(^DGCR(399,DIV(0),"U2")),DIV=X S $P(^("U2"),U,9)=DIV,DIH=399,DIG=231 D ^DICR
S X=$P($G(DIKZ("M")),U,14)
I X'="" D
.N DIK,DIV,DIU,DIN
.K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399,D0,"UF32")):^("UF32"),1:"") S X=$P(Y(1),U,3),X=X S DIU=X K Y S X="" S DIH=$G(^DGCR(399,DIV(0),"UF32")),DIV=X S $P(^("UF32"),U,3)=DIV,DIH=399,DIG=255 D ^DICR
S DIKZ("M1")=$G(^DGCR(399,DA,"M1"))
S X=$P($G(DIKZ("M1")),U,2)
I X'="" D
.N DIK,DIV,DIU,DIN
.K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S Y(1)=$S($D(^DGCR(399,D0,"M1")):^("M1"),1:"") S X=$P(Y(1),U,2)="" I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"M1")):^("M1"),1:"") S X=$P(Y(1),U,10),X=X S DIU=X K Y S X="" X ^DD(399,122,1,1,2.4)
S DIKZ("M1")=$G(^DGCR(399,DA,"M1"))
S X=$P($G(DIKZ("M1")),U,3)
I X'="" D
.N DIK,DIV,DIU,DIN
.K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S Y(1)=$S($D(^DGCR(399,D0,"M1")):^("M1"),1:"") S X=$P(Y(1),U,3)="" I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"M1")):^("M1"),1:"") S X=$P(Y(1),U,11),X=X S DIU=X K Y S X="" X ^DD(399,123,1,1,2.4)
S DIKZ("M1")=$G(^DGCR(399,DA,"M1"))
S X=$P($G(DIKZ("M1")),U,4)
I X'="" D
.N DIK,DIV,DIU,DIN
.K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S Y(1)=$S($D(^DGCR(399,D0,"M1")):^("M1"),1:"") S X=$P(Y(1),U,4)="" I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"M1")):^("M1"),1:"") S X=$P(Y(1),U,12),X=X S DIU=X K Y S X="" X ^DD(399,124,1,1,2.4)
S DIKZ("MP")=$G(^DGCR(399,DA,"MP"))
S X=$P($G(DIKZ("MP")),U,1)
I X'="" D DEL^IBCU5
S X=$P($G(DIKZ("MP")),U,1)
I X'="" S DGRVRCAL=2
S X=$P($G(DIKZ("MP")),U,2)
I X'="" D
.N DIK,DIV,DIU,DIN
.K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399,D0,"MP")):^("MP"),1:"") S X=$P(Y(1),U,1),X=X S DIU=X K Y S X="" X ^DD(399,136,1,1,2.4)
S DIKZ("M2")=$G(^DGCR(399,DA,"M2"))
S X=$P($G(DIKZ("M2")),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(^DGCR(399,D0,"M2")):^("M2"),1:"") S X=$P(Y(1),U,2),X=X S DIU=X K Y S X="" S DIH=$G(^DGCR(399,DIV(0),"M2")),DIV=X S $P(^("M2"),U,2)=DIV,DIH=399,DIG=141 D ^DICR
S DIKZ("M2")=$G(^DGCR(399,DA,"M2"))
S X=$P($G(DIKZ("M2")),U,3)
I X'="" D
.N DIK,DIV,DIU,DIN
.K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399,D0,"M2")):^("M2"),1:"") S X=$P(Y(1),U,4),X=X S DIU=X K Y S X="" S DIH=$G(^DGCR(399,DIV(0),"M2")),DIV=X S $P(^("M2"),U,4)=DIV,DIH=399,DIG=143 D ^DICR
S DIKZ("M2")=$G(^DGCR(399,DA,"M2"))
S X=$P($G(DIKZ("M2")),U,5)
I X'="" D
.N DIK,DIV,DIU,DIN
.K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399,D0,"M2")):^("M2"),1:"") S X=$P(Y(1),U,6),X=X S DIU=X K Y S X="" S DIH=$G(^DGCR(399,DIV(0),"M2")),DIV=X S $P(^("M2"),U,6)=DIV,DIH=399,DIG=145 D ^DICR
S DIKZ("U")=$G(^DGCR(399,DA,"U"))
S X=$P($G(DIKZ("U")),U,1)
I X'="" S DGRVRCAL=2
S X=$P($G(DIKZ("U")),U,1)
I X'="" K:$P(^DGCR(399,DA,0),"^",2) ^DGCR(399,"APDS",$P(^(0),U,2),-X,DA)
S X=$P($G(DIKZ("U")),U,2)
I X'="" S DGRVRCAL=2
S DIKZ("U1")=$G(^DGCR(399,DA,"U1"))
S X=$P($G(DIKZ("U1")),U,2)
I X'="" D
.N DIK,DIV,DIU,DIN
.X ^DD(399,202,1,1,2.3) I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"U1")):^("U1"),1:"") S X=$P(Y(1),U,3),X=X S DIU=X K Y S X="" S DIH=$G(^DGCR(399,DIV(0),"U1")),DIV=X S $P(^("U1"),U,3)=DIV,DIH=399,DIG=203 D ^DICR
S DIKZ("U2")=$G(^DGCR(399,DA,"U2"))
S X=$P($G(DIKZ("U2")),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(^DGCR(399,D0,"U1")):^("U1"),1:"") S X=$P(Y(1),U,2),X=X S DIU=X K Y S X=DIV S X=DIU-X X ^DD(399,218,1,1,2.4)
S DIKZ("U2")=$G(^DGCR(399,DA,"U2"))
S X=$P($G(DIKZ("U2")),U,5)
I X'="" D
.N DIK,DIV,DIU,DIN
.K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399,D0,"U1")):^("U1"),1:"") S X=$P(Y(1),U,2),X=X S DIU=X K Y S X=DIV S X=DIU-X X ^DD(399,219,1,1,2.4)
S DIKZ("U2")=$G(^DGCR(399,DA,"U2"))
S X=$P($G(DIKZ("U2")),U,6)
I X'="" D
.N DIK,DIV,DIU,DIN
.K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399,D0,"U1")):^("U1"),1:"") S X=$P(Y(1),U,2),X=X S DIU=X K Y S X=DIV S X=DIU-X X ^DD(399,220,1,1,2.4)
S DIKZ("U2")=$G(^DGCR(399,DA,"U2"))
S X=$P($G(DIKZ("U2")),U,10)
I X'="" D
.N DIK,DIV,DIU,DIN
.K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399,D0,"U2")):^("U2"),1:"") S X=$P(Y(1),U,12),X=X S DIU=X K Y S X="" X ^DD(399,232,1,1,2.4)
S X=$P($G(DIKZ("U2")),U,10)
I X'="" D
.N DIK,DIV,DIU,DIN
.K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399,D0,"U2")):^("U2"),1:"") S X=$P(Y(1),U,11),X=X S DIU=X K Y S X="" X ^DD(399,232,1,2,2.4)
S X=$P($G(DIKZ("U2")),U,10)
I X'="" D
.N DIK,DIV,DIU,DIN
.K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S X=$$CLIAREQ^IBCEP8A(DA) I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"U2")):^("U2"),1:"") S X=$P(Y(1),U,13),X=X S DIU=X K Y S X=DIV S X=$$CLIA^IBCEP8A(DA) X ^DD(399,232,1,3,2.4)
S X=$P($G(DIKZ("U2")),U,10)
I X'="" D
.N DIK,DIV,DIU,DIN
.K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399,D0,"U3")):^("U3"),1:"") S X=$P(Y(1),U,3),X=X S DIU=X K Y S X="" S DIH=$G(^DGCR(399,DIV(0),"U3")),DIV=X S $P(^("U3"),U,3)=DIV,DIH=399,DIG=244 D ^DICR
S DIKZ("M1")=$G(^DGCR(399,DA,"M1"))
S X=$P($G(DIKZ("M1")),U,8)
I X'="" K ^DGCR(399,"AG",$E(X,1,30),DA)
S DIKZ("MP")=$G(^DGCR(399,DA,"MP"))
S X=$P($G(DIKZ("MP")),U,3)
I X'="" K ^DGCR(399,"E",$E(X,1,30),DA)
S X=$P($G(DIKZ("MP")),U,5)
I X'="" K ^DGCR(399,"F",$E(X,1,30),DA)
S X=$P($G(DIKZ("MP")),U,7)
I X'="" K ^DGCR(399,"G",$E(X,1,30),DA)
S DIKZ(0)=$G(^DGCR(399,DA,0))
S X=$P($G(DIKZ(0)),U,1)
I X'="" K ^DGCR(399,"B",$E(X,1,30),DA)
CR1 S DIXR=139
K X
S DIKZ("M")=$G(^DGCR(399,DA,"M"))
S X(1)=$P(DIKZ("M"),U,1)
S X(2)=$P(DIKZ("M"),U,2)
S X(3)=$P(DIKZ("M"),U,3)
S X(4)=$P(DIKZ("M"),U,13)
S X(5)=$P(DIKZ("M"),U,12)
S X(6)=$P(DIKZ("M"),U,14)
S X=$G(X(1))
D
. K X1,X2 M X1=X,X2=X
. S:$D(DIKIL) (X2,X2(1),X2(2),X2(3),X2(4),X2(5),X2(6))=""
. N DIKXARR M DIKXARR=X S DIKCOND=1
. S X=$S($O(^DGCR(399,DA,"PRV",0)):1,1:0)
. S DIKCOND=$G(X) K X M X=DIKXARR
. Q:'DIKCOND
. D:X1(1)'=X2(1)!(X1(5)'=X2(5)) DELID^IBCEP3(DA,1) D:X1(2)'=X2(2)!(X1(4)'=X2(4)) DELID^IBCEP3(DA,2) D:X1(3)'=X2(3)!(X1(6)'=X2(6)) DELID^IBCEP3(DA,3)
CR2 S DIXR=477
K X
S DIKZ("M")=$G(^DGCR(399,DA,"M"))
S X(1)=$P(DIKZ("M"),U,1)
S X(2)=$P(DIKZ("M"),U,2)
S X(3)=$P(DIKZ("M"),U,3)
S DIKZ(0)=$G(^DGCR(399,DA,0))
S X(4)=$P(DIKZ(0),U,2)
S X=$G(X(1))
D
. K X1,X2 M X1=X,X2=X
. S:$D(DIKIL) (X2,X2(1),X2(2),X2(3),X2(4))=""
. N G I $G(X(4)) F G=1,2,3 I $G(X(G)) K ^DGCR(399,"AE",X(4),X(G),DA)
CR3 S DIXR=820
K X
S DIKZ(0)=$G(^DGCR(399,DA,0))
S X(1)=$P(DIKZ(0),U,22)
S DIKZ("U2")=$G(^DGCR(399,DA,"U2"))
S X(2)=$P(DIKZ("U2"),U,10)
S DIKZ("MP")=$G(^DGCR(399,DA,"MP"))
S X(3)=$P(DIKZ("MP"),U,2)
S X(4)=$P(DIKZ(0),U,19)
S X=$G(X(1))
D
. K X1,X2 M X1=X,X2=X
. S:$D(DIKIL) (X2,X2(1),X2(2),X2(3),X2(4))=""
. D TAX^IBCEF79(DA)
CR4 S DIXR=989
K X
S DIKZ(0)=$G(^DGCR(399,DA,0))
S X(1)=$P(DIKZ(0),U,27)
S X=$G(X(1))
I $G(X(1))]"" D
. K X1,X2 M X1=X,X2=X
. S:$D(DIKIL) (X2,X2(1))=""
. D CMAEDALL^IBCU9(DA)
CR5 K X
END G ^IBXX2
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBXX1 17493 printed Sep 15, 2024@21:56:48 Page 2
IBXX1 ; COMPILED XREF FOR FILE #399 ; 10/03/23
+1 ;
+2 SET DIKZK=2
+3 SET DIKZ(0)=$GET(^DGCR(399,DA,0))
+4 SET X=$PIECE($GET(DIKZ(0)),U,2)
+5 IF X'=""
KILL ^DGCR(399,"C",$EXTRACT(X,1,30),DA)
+6 SET X=$PIECE($GET(DIKZ(0)),U,3)
+7 IF X'=""
KILL ^DGCR(399,"D",$EXTRACT(X,1,30),DA)
+8 SET X=$PIECE($GET(DIKZ(0)),U,3)
+9 IF X'=""
SET IBN=$PIECE(^DGCR(399,DA,0),"^",2)
IF $DATA(IBN)
KILL ^DGCR(399,"APDT",IBN,DA,9999999-X),IBN
+10 SET X=$PIECE($GET(DIKZ(0)),U,3)
+11 IF X'=""
KILL ^DGCR(399,"ABNDT",DA,9999999-X)
+12 SET X=$PIECE($GET(DIKZ(0)),U,5)
+13 IF X'=""
KILL ^DGCR(399,"ABT",$EXTRACT(X,1,30),DA)
+14 SET X=$PIECE($GET(DIKZ(0)),U,7)
+15 IF X'=""
Begin DoDot:1
+16 NEW DIK,DIV,DIU,DIN
+17 XECUTE ^DD(399,.07,1,1,2.3)
IF X
SET X=DIV
SET Y(1)=$SELECT($DATA(^DGCR(399,D0,"U")):^("U"),1:"")
SET X=$PIECE(Y(1),U,6)
SET X=X
SET DIU=X
KILL Y
SET X=DIV
SET X=0
XECUTE ^DD(399,.07,1,1,2.4)
End DoDot:1
+18 SET X=$PIECE($GET(DIKZ(0)),U,7)
+19 IF X'=""
KILL ^DGCR(399,"AD",$EXTRACT(X,1,30),DA)
+20 SET DIKZ(0)=$GET(^DGCR(399,DA,0))
+21 SET X=$PIECE($GET(DIKZ(0)),U,8)
+22 IF X'=""
Begin DoDot:1
+23 NEW DIK,DIV,DIU,DIN
+24 KILL DIV
SET DIV=X
SET D0=DA
SET DIV(0)=D0
SET Y(1)=$SELECT($DATA(^DGCR(399,D0,"U")):^("U"),1:"")
SET X=$PIECE(Y(1),U,12)
SET X=X
SET DIU=X
KILL Y
SET X=""
XECUTE ^DD(399,.08,1,4,2.4)
End DoDot:1
+25 SET X=$PIECE($GET(DIKZ(0)),U,8)
+26 IF X'=""
KILL ^DGCR(399,"APTF",$EXTRACT(X,1,30),DA)
+27 SET DIKZ(0)=$GET(^DGCR(399,DA,0))
+28 SET X=$PIECE($GET(DIKZ(0)),U,11)
+29 IF X'=""
DO DEL^IBCU5
+30 SET X=$PIECE($GET(DIKZ(0)),U,11)
+31 IF X'=""
SET DGRVRCAL=2
+32 SET X=$PIECE($GET(DIKZ(0)),U,11)
+33 IF X'=""
Begin DoDot:1
+34 NEW DIK,DIV,DIU,DIN
+35 KILL DIV
SET DIV=X
SET D0=DA
SET DIV(0)=D0
SET Y(0)=X
SET X=$SELECT($PIECE(^DGCR(399,DA,0),U,11)'="i":1,"PST"'[$PIECE(^DGCR(399,DA,0),U,21):1,1:0)
IF X
SET X=DIV
SET Y(1)=$SELECT($DATA(^DGCR(399,D0,0)):^(0),1:"")
SET X=$PIECE(Y(1),U,21)
SET X=X
SET DIU=X
KILL Y
SET X=""
XECUTE ^DD(399,.11,1,4,2.4)
End DoDot:1
+36 SET DIKZ(0)=$GET(^DGCR(399,DA,0))
+37 SET X=$PIECE($GET(DIKZ(0)),U,13)
+38 IF X'=""
IF $PIECE(^DGCR(399,DA,0),U,2)
KILL ^DGCR(399,"AOP",$PIECE(^(0),U,2),DA)
+39 SET X=$PIECE($GET(DIKZ(0)),U,13)
+40 IF X'=""
KILL ^DGCR(399,"AST",+X,DA)
+41 SET X=$PIECE($GET(DIKZ(0)),U,13)
+42 IF X'=""
Begin DoDot:1
+43 NEW DIK,DIV,DIU,DIN
+44 XECUTE ^DD(399,.13,1,4,2.3)
IF X
SET X=DIV
SET Y(1)=$SELECT($DATA(^DGCR(399,D0,"TX")):^("TX"),1:"")
SET X=$PIECE(Y(1),U,5)
SET X=X
SET DIU=X
KILL Y
SET X=DIV
SET X="0"
SET DIH=$GET(^DGCR(399,DIV(0),"TX"))
SET DIV=X
SET $PIECE(^("TX"),U,5)=DIV
SET DIH=399
SET DIG=24
DO ^DICR
End DoDot:1
+45 SET DIKZ(0)=$GET(^DGCR(399,DA,0))
+46 SET X=$PIECE($GET(DIKZ(0)),U,17)
+47 IF X'=""
KILL ^DGCR(399,"AC",$EXTRACT(X,1,30),DA)
+48 SET X=$PIECE($GET(DIKZ(0)),U,19)
+49 IF X'=""
SET DGRVRCAL=2
+50 SET X=$PIECE($GET(DIKZ(0)),U,19)
+51 IF X'=""
DO ALLID^IBCEP3(DA,.19,2)
+52 SET X=$PIECE($GET(DIKZ(0)),U,19)
+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(1)=$SELECT($DATA(^DGCR(399,D0,"M2")):^("M2"),1:"")
SET X=$PIECE(Y(1),U,1)
SET X=X
SET DIU=X
KILL Y
SET X=""
SET DIH=$GET(^DGCR(399,DIV(0),"M2"))
SET DIV=X
SET $PIECE(^("M2"),U,1)=DIV
SET DIH=399
SET DIG=140
DO ^DICR
End DoDot:1
+56 SET X=$PIECE($GET(DIKZ(0)),U,19)
+57 IF X'=""
DO ATTREND^IBCU1(DA,"","")
+58 SET X=$PIECE($GET(DIKZ(0)),U,19)
+59 IF X'=""
Begin DoDot:1
+60 NEW DIK,DIV,DIU,DIN
+61 KILL DIV
SET DIV=X
SET D0=DA
SET DIV(0)=D0
SET Y(1)=$SELECT($DATA(^DGCR(399,D0,"M2")):^("M2"),1:"")
SET X=$PIECE(Y(1),U,2)
SET X=X
SET DIU=X
KILL Y
SET X=""
SET DIH=$GET(^DGCR(399,DIV(0),"M2"))
SET DIV=X
SET $PIECE(^("M2"),U,2)=DIV
SET DIH=399
SET DIG=141
DO ^DICR
End DoDot:1
+62 SET X=$PIECE($GET(DIKZ(0)),U,19)
+63 IF X'=""
Begin DoDot:1
+64 NEW DIK,DIV,DIU,DIN
+65 KILL DIV
SET DIV=X
SET D0=DA
SET DIV(0)=D0
SET Y(1)=$SELECT($DATA(^DGCR(399,D0,"M2")):^("M2"),1:"")
SET X=$PIECE(Y(1),U,3)
SET X=X
SET DIU=X
KILL Y
SET X=""
SET DIH=$GET(^DGCR(399,DIV(0),"M2"))
SET DIV=X
SET $PIECE(^("M2"),U,3)=DIV
SET DIH=399
SET DIG=142
DO ^DICR
End DoDot:1
+66 SET X=$PIECE($GET(DIKZ(0)),U,19)
+67 IF X'=""
Begin DoDot:1
+68 NEW DIK,DIV,DIU,DIN
+69 KILL DIV
SET DIV=X
SET D0=DA
SET DIV(0)=D0
SET Y(1)=$SELECT($DATA(^DGCR(399,D0,"M2")):^("M2"),1:"")
SET X=$PIECE(Y(1),U,4)
SET X=X
SET DIU=X
KILL Y
SET X=""
SET DIH=$GET(^DGCR(399,DIV(0),"M2"))
SET DIV=X
SET $PIECE(^("M2"),U,4)=DIV
SET DIH=399
SET DIG=143
DO ^DICR
End DoDot:1
+70 SET X=$PIECE($GET(DIKZ(0)),U,19)
+71 IF X'=""
Begin DoDot:1
+72 NEW DIK,DIV,DIU,DIN
+73 KILL DIV
SET DIV=X
SET D0=DA
SET DIV(0)=D0
SET Y(1)=$SELECT($DATA(^DGCR(399,D0,"M2")):^("M2"),1:"")
SET X=$PIECE(Y(1),U,5)
SET X=X
SET DIU=X
KILL Y
SET X=""
SET DIH=$GET(^DGCR(399,DIV(0),"M2"))
SET DIV=X
SET $PIECE(^("M2"),U,5)=DIV
SET DIH=399
SET DIG=144
DO ^DICR
End DoDot:1
+74 SET X=$PIECE($GET(DIKZ(0)),U,19)
+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(^DGCR(399,D0,"M2")):^("M2"),1:"")
SET X=$PIECE(Y(1),U,6)
SET X=X
SET DIU=X
KILL Y
SET X=""
SET DIH=$GET(^DGCR(399,DIV(0),"M2"))
SET DIV=X
SET $PIECE(^("M2"),U,6)=DIV
SET DIH=399
SET DIG=145
DO ^DICR
End DoDot:1
+78 SET DIKZ(0)=$GET(^DGCR(399,DA,0))
+79 SET X=$PIECE($GET(DIKZ(0)),U,21)
+80 IF X'=""
Begin DoDot:1
+81 NEW DIK,DIV,DIU,DIN
+82 KILL DIV
SET DIV=X
SET D0=DA
SET DIV(0)=D0
SET Y(1)=$SELECT($DATA(^DGCR(399,D0,"MP")):^("MP"),1:"")
SET X=$PIECE(Y(1),U,2)
SET X=X
SET DIU=X
KILL Y
SET X=""
XECUTE ^DD(399,.21,1,1,2.4)
End DoDot:1
+83 SET X=$PIECE($GET(DIKZ(0)),U,21)
+84 IF X'=""
Begin DoDot:1
+85 NEW DIK,DIV,DIU,DIN
+86 KILL DIV
SET DIV=X
SET D0=DA
SET DIV(0)=D0
SET Y(0)=X
SET X=('$$REQMRA^IBEFUNC(DA)&$$NEEDMRA^IBEFUNC(DA))
IF X
SET X=DIV
SET Y(1)=$SELECT($DATA(^DGCR(399,D0,"TX")):^("TX"),1:"")
SET X=$PIECE(Y(1),U,5)
SET X=X
SET DIU=X
KILL Y
SET X=""
XECUTE ^DD(399,.21,1,2,2.4)
End DoDot:1
+87 SET X=$PIECE($GET(DIKZ(0)),U,21)
+88 IF X'=""
Begin DoDot:1
+89 NEW DIK,DIV,DIU,DIN
+90 KILL DIV
SET DIV=X
SET D0=DA
SET DIV(0)=D0
SET Y(0)=X
SET X=$$DELETE^IBCEF84(DA)
IF X
SET X=DIV
SET Y(1)=$SELECT($DATA(^DGCR(399,D0,"TX")):^("TX"),1:"")
SET X=$PIECE(Y(1),U,8)
SET X=X
SET DIU=X
KILL Y
SET X=""
XECUTE ^DD(399,.21,1,4,2.4)
End DoDot:1
+91 SET DIKZ(0)=$GET(^DGCR(399,DA,0))
+92 SET X=$PIECE($GET(DIKZ(0)),U,25)
+93 IF X'=""
DO ALLID^IBCEP3(DA,.25,2)
+94 SET DIKZ("S")=$GET(^DGCR(399,DA,"S"))
+95 SET X=$PIECE($GET(DIKZ("S")),U,1)
+96 IF X'=""
KILL ^DGCR(399,"APD",$EXTRACT(X,1,30),DA)
+97 SET X=$PIECE($GET(DIKZ("S")),U,7)
+98 IF X'=""
KILL ^DGCR(399,"APM",$EXTRACT(X,1,30),DA)
+99 SET X=$PIECE($GET(DIKZ("S")),U,10)
+100 IF X'=""
KILL ^DGCR(399,"APD3",$EXTRACT(X,1,30),DA)
+101 SET X=$PIECE($GET(DIKZ("S")),U,12)
+102 IF X'=""
KILL ^DGCR(399,"AP",$EXTRACT(X,1,30),DA)
+103 SET DIKZ("TX")=$GET(^DGCR(399,DA,"TX"))
+104 SET X=$PIECE($GET(DIKZ("TX")),U,2)
+105 IF X'=""
KILL ^DGCR(399,"ALEX",$EXTRACT(X,1,30),DA)
+106 SET DIKZ("S1")=$GET(^DGCR(399,DA,"S1"))
+107 SET X=$PIECE($GET(DIKZ("S1")),U,7)
+108 IF X'=""
KILL ^DGCR(399,"CAP",$EXTRACT(X,1,30),DA)
+109 SET DIKZ("M")=$GET(^DGCR(399,DA,"M"))
+110 SET X=$PIECE($GET(DIKZ("M")),U,1)
+111 IF X'=""
Begin DoDot:1
+112 NEW DIK,DIV,DIU,DIN
+113 KILL DIV
SET DIV=X
SET D0=DA
SET DIV(0)=D0
SET Y(0)=X
IF $$COBN^IBCEF(DA)=1
IF X
SET X=DIV
SET Y(1)=$SELECT($DATA(^DGCR(399,D0,"TX")):^("TX"),1:"")
SET X=$PIECE(Y(1),U,5)
SET X=X
SET DIU=X
KILL Y
SET X=""
XECUTE ^DD(399,101,1,2,2.4)
End DoDot:1
+114 SET X=$PIECE($GET(DIKZ("M")),U,1)
+115 IF X'=""
Begin DoDot:1
+116 NEW DIK,DIV,DIU,DIN
+117 KILL DIV
SET DIV=X
SET D0=DA
SET DIV(0)=D0
SET Y(0)=X
SET X=$$DELETE^IBCEF84(DA)
IF X
SET X=DIV
SET Y(1)=$SELECT($DATA(^DGCR(399,D0,"TX")):^("TX"),1:"")
SET X=$PIECE(Y(1),U,8)
SET X=X
SET DIU=X
KILL Y
SET X=""
XECUTE ^DD(399,101,1,5,2.4)
End DoDot:1
+118 SET X=$PIECE($GET(DIKZ("M")),U,1)
+119 IF X'=""
Begin DoDot:1
+120 NEW DIK,DIV,DIU,DIN
+121 KILL DIV
SET DIV=X
SET D0=DA
SET DIV(0)=D0
SET Y(1)=$SELECT($DATA(^DGCR(399,D0,"M2")):^("M2"),1:"")
SET X=$PIECE(Y(1),U,1)
SET X=X
SET DIU=X
KILL Y
SET X=""
SET DIH=$GET(^DGCR(399,DIV(0),"M2"))
SET DIV=X
SET $PIECE(^("M2"),U,1)=DIV
SET DIH=399
SET DIG=140
DO ^DICR
End DoDot:1
+122 SET X=$PIECE($GET(DIKZ("M")),U,1)
+123 IF X'=""
Begin DoDot:1
+124 NEW DIK,DIV,DIU,DIN
+125 KILL DIV
SET DIV=X
SET D0=DA
SET DIV(0)=D0
SET Y(1)=$SELECT($DATA(^DGCR(399,D0,"M2")):^("M2"),1:"")
SET X=$PIECE(Y(1),U,2)
SET X=X
SET DIU=X
KILL Y
SET X=""
SET DIH=$GET(^DGCR(399,DIV(0),"M2"))
SET DIV=X
SET $PIECE(^("M2"),U,2)=DIV
SET DIH=399
SET DIG=141
DO ^DICR
End DoDot:1
+126 SET DIKZ("M")=$GET(^DGCR(399,DA,"M"))
+127 SET X=$PIECE($GET(DIKZ("M")),U,2)
+128 IF X'=""
Begin DoDot:1
+129 NEW DIK,DIV,DIU,DIN
+130 KILL DIV
SET DIV=X
SET D0=DA
SET DIV(0)=D0
SET Y(0)=X
IF $$COBN^IBCEF(DA)=2
IF X
SET X=DIV
SET Y(1)=$SELECT($DATA(^DGCR(399,D0,"TX")):^("TX"),1:"")
SET X=$PIECE(Y(1),U,5)
SET X=X
SET DIU=X
KILL Y
SET X=""
XECUTE ^DD(399,102,1,3,2.4)
End DoDot:1
+131 SET X=$PIECE($GET(DIKZ("M")),U,2)
+132 IF X'=""
Begin DoDot:1
+133 NEW DIK,DIV,DIU,DIN
+134 KILL DIV
SET DIV=X
SET D0=DA
SET DIV(0)=D0
SET Y(1)=$SELECT($DATA(^DGCR(399,D0,"M2")):^("M2"),1:"")
SET X=$PIECE(Y(1),U,3)
SET X=X
SET DIU=X
KILL Y
SET X=""
SET DIH=$GET(^DGCR(399,DIV(0),"M2"))
SET DIV=X
SET $PIECE(^("M2"),U,3)=DIV
SET DIH=399
SET DIG=142
DO ^DICR
End DoDot:1
+135 SET X=$PIECE($GET(DIKZ("M")),U,2)
+136 IF X'=""
Begin DoDot:1
+137 NEW DIK,DIV,DIU,DIN
+138 KILL DIV
SET DIV=X
SET D0=DA
SET DIV(0)=D0
SET Y(1)=$SELECT($DATA(^DGCR(399,D0,"M2")):^("M2"),1:"")
SET X=$PIECE(Y(1),U,4)
SET X=X
SET DIU=X
KILL Y
SET X=""
SET DIH=$GET(^DGCR(399,DIV(0),"M2"))
SET DIV=X
SET $PIECE(^("M2"),U,4)=DIV
SET DIH=399
SET DIG=143
DO ^DICR
End DoDot:1
+139 SET DIKZ("M")=$GET(^DGCR(399,DA,"M"))
+140 SET X=$PIECE($GET(DIKZ("M")),U,3)
+141 IF X'=""
Begin DoDot:1
+142 NEW DIK,DIV,DIU,DIN
+143 KILL DIV
SET DIV=X
SET D0=DA
SET DIV(0)=D0
SET Y(1)=$SELECT($DATA(^DGCR(399,D0,"M2")):^("M2"),1:"")
SET X=$PIECE(Y(1),U,6)
SET X=X
SET DIU=X
KILL Y
SET X=""
SET DIH=$GET(^DGCR(399,DIV(0),"M2"))
SET DIV=X
SET $PIECE(^("M2"),U,6)=DIV
SET DIH=399
SET DIG=145
DO ^DICR
End DoDot:1
+144 SET X=$PIECE($GET(DIKZ("M")),U,3)
+145 IF X'=""
Begin DoDot:1
+146 NEW DIK,DIV,DIU,DIN
+147 KILL DIV
SET DIV=X
SET D0=DA
SET DIV(0)=D0
SET Y(1)=$SELECT($DATA(^DGCR(399,D0,"M2")):^("M2"),1:"")
SET X=$PIECE(Y(1),U,5)
SET X=X
SET DIU=X
KILL Y
SET X=""
SET DIH=$GET(^DGCR(399,DIV(0),"M2"))
SET DIV=X
SET $PIECE(^("M2"),U,5)=DIV
SET DIH=399
SET DIG=144
DO ^DICR
End DoDot:1
+148 SET DIKZ("M")=$GET(^DGCR(399,DA,"M"))
+149 SET X=$PIECE($GET(DIKZ("M")),U,11)
+150 IF X'=""
DO DEL^IBCU5
+151 SET X=$PIECE($GET(DIKZ("M")),U,11)
+152 IF X'=""
SET DGRVRCAL=2
+153 SET X=$PIECE($GET(DIKZ("M")),U,12)
+154 IF X'=""
Begin DoDot:1
+155 NEW DIK,DIV,DIU,DIN
+156 KILL DIV
SET DIV=X
SET D0=DA
SET DIV(0)=D0
SET Y(1)=$SELECT($DATA(^DGCR(399,D0,"M")):^("M"),1:"")
SET X=$PIECE(Y(1),U,1)
SET X=X
SET DIU=X
KILL Y
SET X=""
XECUTE ^DD(399,112,1,1,2.4)
End DoDot:1
+157 SET X=$PIECE($GET(DIKZ("M")),U,12)
+158 IF X'=""
DO KIX^IBCNS2(DA,"I1")
+159 SET X=$PIECE($GET(DIKZ("M")),U,12)
+160 IF X'=""
Begin DoDot:1
+161 NEW DIK,DIV,DIU,DIN
+162 XECUTE ^DD(399,112,1,3,2.3)
IF X
SET X=DIV
SET Y(1)=$SELECT($DATA(^DGCR(399,D0,"MP")):^("MP"),1:"")
SET X=$PIECE(Y(1),U,2)
SET X=X
SET DIU=X
KILL Y
SET X=""
XECUTE ^DD(399,112,1,3,2.4)
End DoDot:1
+163 SET X=$PIECE($GET(DIKZ("M")),U,12)
+164 IF X'=""
Begin DoDot:1
+165 NEW DIK,DIV,DIU,DIN
+166 KILL DIV
SET DIV=X
SET D0=DA
SET DIV(0)=D0
SET Y(1)=$SELECT($DATA(^DGCR(399,D0,"U")):^("U"),1:"")
SET X=$PIECE(Y(1),U,13)
SET X=X
SET DIU=X
KILL Y
SET X=""
SET DIH=$GET(^DGCR(399,DIV(0),"U"))
SET DIV=X
SET $PIECE(^("U"),U,13)=DIV
SET DIH=399
SET DIG=163
DO ^DICR
End DoDot:1
+167 SET X=$PIECE($GET(DIKZ("M")),U,12)
+168 IF X'=""
Begin DoDot:1
+169 NEW DIK,DIV,DIU,DIN
+170 KILL DIV
SET DIV=X
SET D0=DA
SET DIV(0)=D0
SET Y(1)=$SELECT($DATA(^DGCR(399,D0,"UF32")):^("UF32"),1:"")
SET X=$PIECE(Y(1),U,1)
SET X=X
SET DIU=X
KILL Y
SET X=""
SET DIH=$GET(^DGCR(399,DIV(0),"UF32"))
SET DIV=X
SET $PIECE(^("UF32"),U,1)=DIV
SET DIH=399
SET DIG=253
DO ^DICR
End DoDot:1
+171 SET DIKZ("M")=$GET(^DGCR(399,DA,"M"))
+172 SET X=$PIECE($GET(DIKZ("M")),U,13)
+173 IF X'=""
Begin DoDot:1
+174 NEW DIK,DIV,DIU,DIN
+175 KILL DIV
SET DIV=X
SET D0=DA
SET DIV(0)=D0
SET Y(1)=$SELECT($DATA(^DGCR(399,D0,"M")):^("M"),1:"")
SET X=$PIECE(Y(1),U,2)
SET X=X
SET DIU=X
KILL Y
SET X=""
XECUTE ^DD(399,113,1,1,2.4)
End DoDot:1
+176 SET X=$PIECE($GET(DIKZ("M")),U,13)
+177 IF X'=""
DO KIX^IBCNS2(DA,"I2")
+178 SET X=$PIECE($GET(DIKZ("M")),U,13)
+179 IF X'=""
Begin DoDot:1
+180 NEW DIK,DIV,DIU,DIN
+181 XECUTE ^DD(399,113,1,3,2.3)
IF X
SET X=DIV
SET Y(1)=$SELECT($DATA(^DGCR(399,D0,"MP")):^("MP"),1:"")
SET X=$PIECE(Y(1),U,2)
SET X=X
SET DIU=X
KILL Y
SET X=""
XECUTE ^DD(399,113,1,3,2.4)
End DoDot:1
+182 SET X=$PIECE($GET(DIKZ("M")),U,13)
+183 IF X'=""
Begin DoDot:1
+184 NEW DIK,DIV,DIU,DIN
+185 KILL DIV
SET DIV=X
SET D0=DA
SET DIV(0)=D0
SET Y(1)=$SELECT($DATA(^DGCR(399,D0,"U2")):^("U2"),1:"")
SET X=$PIECE(Y(1),U,8)
SET X=X
SET DIU=X
KILL Y
SET X=""
SET DIH=$GET(^DGCR(399,DIV(0),"U2"))
SET DIV=X
SET $PIECE(^("U2"),U,8)=DIV
SET DIH=399
SET DIG=230
DO ^DICR
End DoDot:1
+186 SET X=$PIECE($GET(DIKZ("M")),U,13)
+187 IF X'=""
Begin DoDot:1
+188 NEW DIK,DIV,DIU,DIN
+189 KILL DIV
SET DIV=X
SET D0=DA
SET DIV(0)=D0
SET Y(1)=$SELECT($DATA(^DGCR(399,D0,"UF32")):^("UF32"),1:"")
SET X=$PIECE(Y(1),U,2)
SET X=X
SET DIU=X
KILL Y
SET X=""
SET DIH=$GET(^DGCR(399,DIV(0),"UF32"))
SET DIV=X
SET $PIECE(^("UF32"),U,2)=DIV
SET DIH=399
SET DIG=254
DO ^DICR
End DoDot:1
+190 SET DIKZ("M")=$GET(^DGCR(399,DA,"M"))
+191 SET X=$PIECE($GET(DIKZ("M")),U,14)
+192 IF X'=""
Begin DoDot:1
+193 NEW DIK,DIV,DIU,DIN
+194 KILL DIV
SET DIV=X
SET D0=DA
SET DIV(0)=D0
SET Y(1)=$SELECT($DATA(^DGCR(399,D0,"M")):^("M"),1:"")
SET X=$PIECE(Y(1),U,3)
SET X=X
SET DIU=X
KILL Y
SET X=""
XECUTE ^DD(399,114,1,1,2.4)
End DoDot:1
+195 SET X=$PIECE($GET(DIKZ("M")),U,14)
+196 IF X'=""
DO KIX^IBCNS2(DA,"I3")
+197 SET X=$PIECE($GET(DIKZ("M")),U,14)
+198 IF X'=""
Begin DoDot:1
+199 NEW DIK,DIV,DIU,DIN
+200 XECUTE ^DD(399,114,1,3,2.3)
IF X
SET X=DIV
SET Y(1)=$SELECT($DATA(^DGCR(399,D0,"MP")):^("MP"),1:"")
SET X=$PIECE(Y(1),U,2)
SET X=X
SET DIU=X
KILL Y
SET X=""
XECUTE ^DD(399,114,1,3,2.4)
End DoDot:1
+201 SET X=$PIECE($GET(DIKZ("M")),U,14)
+202 IF X'=""
Begin DoDot:1
+203 NEW DIK,DIV,DIU,DIN
+204 KILL DIV
SET DIV=X
SET D0=DA
SET DIV(0)=D0
SET Y(1)=$SELECT($DATA(^DGCR(399,D0,"U2")):^("U2"),1:"")
SET X=$PIECE(Y(1),U,9)
SET X=X
SET DIU=X
KILL Y
SET X=""
SET DIH=$GET(^DGCR(399,DIV(0),"U2"))
SET DIV=X
SET $PIECE(^("U2"),U,9)=DIV
SET DIH=399
SET DIG=231
DO ^DICR
End DoDot:1
+205 SET X=$PIECE($GET(DIKZ("M")),U,14)
+206 IF X'=""
Begin DoDot:1
+207 NEW DIK,DIV,DIU,DIN
+208 KILL DIV
SET DIV=X
SET D0=DA
SET DIV(0)=D0
SET Y(1)=$SELECT($DATA(^DGCR(399,D0,"UF32")):^("UF32"),1:"")
SET X=$PIECE(Y(1),U,3)
SET X=X
SET DIU=X
KILL Y
SET X=""
SET DIH=$GET(^DGCR(399,DIV(0),"UF32"))
SET DIV=X
SET $PIECE(^("UF32"),U,3)=DIV
SET DIH=399
SET DIG=255
DO ^DICR
End DoDot:1
+209 SET DIKZ("M1")=$GET(^DGCR(399,DA,"M1"))
+210 SET X=$PIECE($GET(DIKZ("M1")),U,2)
+211 IF X'=""
Begin DoDot:1
+212 NEW DIK,DIV,DIU,DIN
+213 KILL DIV
SET DIV=X
SET D0=DA
SET DIV(0)=D0
SET Y(0)=X
SET Y(1)=$SELECT($DATA(^DGCR(399,D0,"M1")):^("M1"),1:"")
SET X=$PIECE(Y(1),U,2)=""
IF X
SET X=DIV
SET Y(1)=$SELECT($DATA(^DGCR(399,D0,"M1")):^("M1"),1:"")
SET X=$PIECE(Y(1),U,10)
SET X=X
SET DIU=X
KILL Y
SET X=""
XECUTE ^DD(399,122,1,1,2.4)
End DoDot:1
+214 SET DIKZ("M1")=$GET(^DGCR(399,DA,"M1"))
+215 SET X=$PIECE($GET(DIKZ("M1")),U,3)
+216 IF X'=""
Begin DoDot:1
+217 NEW DIK,DIV,DIU,DIN
+218 KILL DIV
SET DIV=X
SET D0=DA
SET DIV(0)=D0
SET Y(0)=X
SET Y(1)=$SELECT($DATA(^DGCR(399,D0,"M1")):^("M1"),1:"")
SET X=$PIECE(Y(1),U,3)=""
IF X
SET X=DIV
SET Y(1)=$SELECT($DATA(^DGCR(399,D0,"M1")):^("M1"),1:"")
SET X=$PIECE(Y(1),U,11)
SET X=X
SET DIU=X
KILL Y
SET X=""
XECUTE ^DD(399,123,1,1,2.4)
End DoDot:1
+219 SET DIKZ("M1")=$GET(^DGCR(399,DA,"M1"))
+220 SET X=$PIECE($GET(DIKZ("M1")),U,4)
+221 IF X'=""
Begin DoDot:1
+222 NEW DIK,DIV,DIU,DIN
+223 KILL DIV
SET DIV=X
SET D0=DA
SET DIV(0)=D0
SET Y(0)=X
SET Y(1)=$SELECT($DATA(^DGCR(399,D0,"M1")):^("M1"),1:"")
SET X=$PIECE(Y(1),U,4)=""
IF X
SET X=DIV
SET Y(1)=$SELECT($DATA(^DGCR(399,D0,"M1")):^("M1"),1:"")
SET X=$PIECE(Y(1),U,12)
SET X=X
SET DIU=X
KILL Y
SET X=""
XECUTE ^DD(399,124,1,1,2.4)
End DoDot:1
+224 SET DIKZ("MP")=$GET(^DGCR(399,DA,"MP"))
+225 SET X=$PIECE($GET(DIKZ("MP")),U,1)
+226 IF X'=""
DO DEL^IBCU5
+227 SET X=$PIECE($GET(DIKZ("MP")),U,1)
+228 IF X'=""
SET DGRVRCAL=2
+229 SET X=$PIECE($GET(DIKZ("MP")),U,2)
+230 IF X'=""
Begin DoDot:1
+231 NEW DIK,DIV,DIU,DIN
+232 KILL DIV
SET DIV=X
SET D0=DA
SET DIV(0)=D0
SET Y(1)=$SELECT($DATA(^DGCR(399,D0,"MP")):^("MP"),1:"")
SET X=$PIECE(Y(1),U,1)
SET X=X
SET DIU=X
KILL Y
SET X=""
XECUTE ^DD(399,136,1,1,2.4)
End DoDot:1
+233 SET DIKZ("M2")=$GET(^DGCR(399,DA,"M2"))
+234 SET X=$PIECE($GET(DIKZ("M2")),U,1)
+235 IF X'=""
Begin DoDot:1
+236 NEW DIK,DIV,DIU,DIN
+237 KILL DIV
SET DIV=X
SET D0=DA
SET DIV(0)=D0
SET Y(1)=$SELECT($DATA(^DGCR(399,D0,"M2")):^("M2"),1:"")
SET X=$PIECE(Y(1),U,2)
SET X=X
SET DIU=X
KILL Y
SET X=""
SET DIH=$GET(^DGCR(399,DIV(0),"M2"))
SET DIV=X
SET $PIECE(^("M2"),U,2)=DIV
SET DIH=399
SET DIG=141
DO ^DICR
End DoDot:1
+238 SET DIKZ("M2")=$GET(^DGCR(399,DA,"M2"))
+239 SET X=$PIECE($GET(DIKZ("M2")),U,3)
+240 IF X'=""
Begin DoDot:1
+241 NEW DIK,DIV,DIU,DIN
+242 KILL DIV
SET DIV=X
SET D0=DA
SET DIV(0)=D0
SET Y(1)=$SELECT($DATA(^DGCR(399,D0,"M2")):^("M2"),1:"")
SET X=$PIECE(Y(1),U,4)
SET X=X
SET DIU=X
KILL Y
SET X=""
SET DIH=$GET(^DGCR(399,DIV(0),"M2"))
SET DIV=X
SET $PIECE(^("M2"),U,4)=DIV
SET DIH=399
SET DIG=143
DO ^DICR
End DoDot:1
+243 SET DIKZ("M2")=$GET(^DGCR(399,DA,"M2"))
+244 SET X=$PIECE($GET(DIKZ("M2")),U,5)
+245 IF X'=""
Begin DoDot:1
+246 NEW DIK,DIV,DIU,DIN
+247 KILL DIV
SET DIV=X
SET D0=DA
SET DIV(0)=D0
SET Y(1)=$SELECT($DATA(^DGCR(399,D0,"M2")):^("M2"),1:"")
SET X=$PIECE(Y(1),U,6)
SET X=X
SET DIU=X
KILL Y
SET X=""
SET DIH=$GET(^DGCR(399,DIV(0),"M2"))
SET DIV=X
SET $PIECE(^("M2"),U,6)=DIV
SET DIH=399
SET DIG=145
DO ^DICR
End DoDot:1
+248 SET DIKZ("U")=$GET(^DGCR(399,DA,"U"))
+249 SET X=$PIECE($GET(DIKZ("U")),U,1)
+250 IF X'=""
SET DGRVRCAL=2
+251 SET X=$PIECE($GET(DIKZ("U")),U,1)
+252 IF X'=""
if $PIECE(^DGCR(399,DA,0),"^",2)
KILL ^DGCR(399,"APDS",$PIECE(^(0),U,2),-X,DA)
+253 SET X=$PIECE($GET(DIKZ("U")),U,2)
+254 IF X'=""
SET DGRVRCAL=2
+255 SET DIKZ("U1")=$GET(^DGCR(399,DA,"U1"))
+256 SET X=$PIECE($GET(DIKZ("U1")),U,2)
+257 IF X'=""
Begin DoDot:1
+258 NEW DIK,DIV,DIU,DIN
+259 XECUTE ^DD(399,202,1,1,2.3)
IF X
SET X=DIV
SET Y(1)=$SELECT($DATA(^DGCR(399,D0,"U1")):^("U1"),1:"")
SET X=$PIECE(Y(1),U,3)
SET X=X
SET DIU=X
KILL Y
SET X=""
SET DIH=$GET(^DGCR(399,DIV(0),"U1"))
SET DIV=X
SET $PIECE(^("U1"),U,3)=DIV
SET DIH=399
SET DIG=203
DO ^DICR
End DoDot:1
+260 SET DIKZ("U2")=$GET(^DGCR(399,DA,"U2"))
+261 SET X=$PIECE($GET(DIKZ("U2")),U,4)
+262 IF X'=""
Begin DoDot:1
+263 NEW DIK,DIV,DIU,DIN
+264 KILL DIV
SET DIV=X
SET D0=DA
SET DIV(0)=D0
SET Y(1)=$SELECT($DATA(^DGCR(399,D0,"U1")):^("U1"),1:"")
SET X=$PIECE(Y(1),U,2)
SET X=X
SET DIU=X
KILL Y
SET X=DIV
SET X=DIU-X
XECUTE ^DD(399,218,1,1,2.4)
End DoDot:1
+265 SET DIKZ("U2")=$GET(^DGCR(399,DA,"U2"))
+266 SET X=$PIECE($GET(DIKZ("U2")),U,5)
+267 IF X'=""
Begin DoDot:1
+268 NEW DIK,DIV,DIU,DIN
+269 KILL DIV
SET DIV=X
SET D0=DA
SET DIV(0)=D0
SET Y(1)=$SELECT($DATA(^DGCR(399,D0,"U1")):^("U1"),1:"")
SET X=$PIECE(Y(1),U,2)
SET X=X
SET DIU=X
KILL Y
SET X=DIV
SET X=DIU-X
XECUTE ^DD(399,219,1,1,2.4)
End DoDot:1
+270 SET DIKZ("U2")=$GET(^DGCR(399,DA,"U2"))
+271 SET X=$PIECE($GET(DIKZ("U2")),U,6)
+272 IF X'=""
Begin DoDot:1
+273 NEW DIK,DIV,DIU,DIN
+274 KILL DIV
SET DIV=X
SET D0=DA
SET DIV(0)=D0
SET Y(1)=$SELECT($DATA(^DGCR(399,D0,"U1")):^("U1"),1:"")
SET X=$PIECE(Y(1),U,2)
SET X=X
SET DIU=X
KILL Y
SET X=DIV
SET X=DIU-X
XECUTE ^DD(399,220,1,1,2.4)
End DoDot:1
+275 SET DIKZ("U2")=$GET(^DGCR(399,DA,"U2"))
+276 SET X=$PIECE($GET(DIKZ("U2")),U,10)
+277 IF X'=""
Begin DoDot:1
+278 NEW DIK,DIV,DIU,DIN
+279 KILL DIV
SET DIV=X
SET D0=DA
SET DIV(0)=D0
SET Y(1)=$SELECT($DATA(^DGCR(399,D0,"U2")):^("U2"),1:"")
SET X=$PIECE(Y(1),U,12)
SET X=X
SET DIU=X
KILL Y
SET X=""
XECUTE ^DD(399,232,1,1,2.4)
End DoDot:1
+280 SET X=$PIECE($GET(DIKZ("U2")),U,10)
+281 IF X'=""
Begin DoDot:1
+282 NEW DIK,DIV,DIU,DIN
+283 KILL DIV
SET DIV=X
SET D0=DA
SET DIV(0)=D0
SET Y(1)=$SELECT($DATA(^DGCR(399,D0,"U2")):^("U2"),1:"")
SET X=$PIECE(Y(1),U,11)
SET X=X
SET DIU=X
KILL Y
SET X=""
XECUTE ^DD(399,232,1,2,2.4)
End DoDot:1
+284 SET X=$PIECE($GET(DIKZ("U2")),U,10)
+285 IF X'=""
Begin DoDot:1
+286 NEW DIK,DIV,DIU,DIN
+287 KILL DIV
SET DIV=X
SET D0=DA
SET DIV(0)=D0
SET Y(0)=X
SET X=$$CLIAREQ^IBCEP8A(DA)
IF X
SET X=DIV
SET Y(1)=$SELECT($DATA(^DGCR(399,D0,"U2")):^("U2"),1:"")
SET X=$PIECE(Y(1),U,13)
SET X=X
SET DIU=X
KILL Y
SET X=DIV
SET X=$$CLIA^IBCEP8A(DA)
XECUTE ^DD(399,232,1,3,2.4)
End DoDot:1
+288 SET X=$PIECE($GET(DIKZ("U2")),U,10)
+289 IF X'=""
Begin DoDot:1
+290 NEW DIK,DIV,DIU,DIN
+291 KILL DIV
SET DIV=X
SET D0=DA
SET DIV(0)=D0
SET Y(1)=$SELECT($DATA(^DGCR(399,D0,"U3")):^("U3"),1:"")
SET X=$PIECE(Y(1),U,3)
SET X=X
SET DIU=X
KILL Y
SET X=""
SET DIH=$GET(^DGCR(399,DIV(0),"U3"))
SET DIV=X
SET $PIECE(^("U3"),U,3)=DIV
SET DIH=399
SET DIG=244
DO ^DICR
End DoDot:1
+292 SET DIKZ("M1")=$GET(^DGCR(399,DA,"M1"))
+293 SET X=$PIECE($GET(DIKZ("M1")),U,8)
+294 IF X'=""
KILL ^DGCR(399,"AG",$EXTRACT(X,1,30),DA)
+295 SET DIKZ("MP")=$GET(^DGCR(399,DA,"MP"))
+296 SET X=$PIECE($GET(DIKZ("MP")),U,3)
+297 IF X'=""
KILL ^DGCR(399,"E",$EXTRACT(X,1,30),DA)
+298 SET X=$PIECE($GET(DIKZ("MP")),U,5)
+299 IF X'=""
KILL ^DGCR(399,"F",$EXTRACT(X,1,30),DA)
+300 SET X=$PIECE($GET(DIKZ("MP")),U,7)
+301 IF X'=""
KILL ^DGCR(399,"G",$EXTRACT(X,1,30),DA)
+302 SET DIKZ(0)=$GET(^DGCR(399,DA,0))
+303 SET X=$PIECE($GET(DIKZ(0)),U,1)
+304 IF X'=""
KILL ^DGCR(399,"B",$EXTRACT(X,1,30),DA)
CR1 SET DIXR=139
+1 KILL X
+2 SET DIKZ("M")=$GET(^DGCR(399,DA,"M"))
+3 SET X(1)=$PIECE(DIKZ("M"),U,1)
+4 SET X(2)=$PIECE(DIKZ("M"),U,2)
+5 SET X(3)=$PIECE(DIKZ("M"),U,3)
+6 SET X(4)=$PIECE(DIKZ("M"),U,13)
+7 SET X(5)=$PIECE(DIKZ("M"),U,12)
+8 SET X(6)=$PIECE(DIKZ("M"),U,14)
+9 SET X=$GET(X(1))
+10 Begin DoDot:1
+11 KILL X1,X2
MERGE X1=X,X2=X
+12 if $DATA(DIKIL)
SET (X2,X2(1),X2(2),X2(3),X2(4),X2(5),X2(6))=""
+13 NEW DIKXARR
MERGE DIKXARR=X
SET DIKCOND=1
+14 SET X=$SELECT($ORDER(^DGCR(399,DA,"PRV",0)):1,1:0)
+15 SET DIKCOND=$GET(X)
KILL X
MERGE X=DIKXARR
+16 if 'DIKCOND
QUIT
+17 if X1(1)'=X2(1)!(X1(5)'=X2(5))
DO DELID^IBCEP3(DA,1)
if X1(2)'=X2(2)!(X1(4)'=X2(4))
DO DELID^IBCEP3(DA,2)
if X1(3)'=X2(3)!(X1(6)'=X2(6))
DO DELID^IBCEP3(DA,3)
End DoDot:1
CR2 SET DIXR=477
+1 KILL X
+2 SET DIKZ("M")=$GET(^DGCR(399,DA,"M"))
+3 SET X(1)=$PIECE(DIKZ("M"),U,1)
+4 SET X(2)=$PIECE(DIKZ("M"),U,2)
+5 SET X(3)=$PIECE(DIKZ("M"),U,3)
+6 SET DIKZ(0)=$GET(^DGCR(399,DA,0))
+7 SET X(4)=$PIECE(DIKZ(0),U,2)
+8 SET X=$GET(X(1))
+9 Begin DoDot:1
+10 KILL X1,X2
MERGE X1=X,X2=X
+11 if $DATA(DIKIL)
SET (X2,X2(1),X2(2),X2(3),X2(4))=""
+12 NEW G
IF $GET(X(4))
FOR G=1,2,3
IF $GET(X(G))
KILL ^DGCR(399,"AE",X(4),X(G),DA)
End DoDot:1
CR3 SET DIXR=820
+1 KILL X
+2 SET DIKZ(0)=$GET(^DGCR(399,DA,0))
+3 SET X(1)=$PIECE(DIKZ(0),U,22)
+4 SET DIKZ("U2")=$GET(^DGCR(399,DA,"U2"))
+5 SET X(2)=$PIECE(DIKZ("U2"),U,10)
+6 SET DIKZ("MP")=$GET(^DGCR(399,DA,"MP"))
+7 SET X(3)=$PIECE(DIKZ("MP"),U,2)
+8 SET X(4)=$PIECE(DIKZ(0),U,19)
+9 SET X=$GET(X(1))
+10 Begin DoDot:1
+11 KILL X1,X2
MERGE X1=X,X2=X
+12 if $DATA(DIKIL)
SET (X2,X2(1),X2(2),X2(3),X2(4))=""
+13 DO TAX^IBCEF79(DA)
End DoDot:1
CR4 SET DIXR=989
+1 KILL X
+2 SET DIKZ(0)=$GET(^DGCR(399,DA,0))
+3 SET X(1)=$PIECE(DIKZ(0),U,27)
+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 DO CMAEDALL^IBCU9(DA)
End DoDot:1
CR5 KILL X
END GOTO ^IBXX2
