- 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 Feb 18, 2025@23:59:16 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