IBXX19 ; COMPILED XREF FOR FILE #399 ; 10/03/23
;
S DIKZK=1
S DIKZ(0)=$G(^DGCR(399,DA,0))
S X=$P($G(DIKZ(0)),U,1)
I X'="" S ^DGCR(399,"B",$E(X,1,30),DA)=""
S X=$P($G(DIKZ(0)),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 Y(1)=$S($D(^DGCR(399,D0,"S")):^("S"),1:"") S X=$P(Y(1),U,1)="" I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"S")):^("S"),1:"") S X=$P(Y(1),U,1),X=X S DIU=X K Y S X=DIV N %I,%H,% D NOW^%DTC X ^DD(399,.01,1,3,1.4)
S X=$P($G(DIKZ(0)),U,1)
I X'="" D
.N DIK,DIV,DIU,DIN
.X ^DD(399,.01,1,4,1.3) I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"S")):^("S"),1:"") S X=$P(Y(1),U,2),X=X S DIU=X K Y S X=DIV S X=$S(($D(DUZ)#2):DUZ,1:"") X ^DD(399,.01,1,4,1.4)
S X=$P($G(DIKZ(0)),U,1)
I X'="" D
.N DIK,DIV,DIU,DIN
.X ^DD(399,.01,1,5,1.3) I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"U")):^("U"),1:"") S X=$P(Y(1),U,14),X=X S DIU=X K Y S X=DIV S X=$S($D(^IBE(350.9,1,1)):$P(^(1),U,6),1:"") X ^DD(399,.01,1,5,1.4)
S X=$P($G(DIKZ(0)),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,0)):^(0),1:"") S X=$P(Y(1),U,13),X=X S DIU=X K Y S X=DIV S X=1 S DIH=$G(^DGCR(399,DIV(0),0)),DIV=X S $P(^(0),U,13)=DIV,DIH=399,DIG=.13 D ^DICR
S X=$P($G(DIKZ(0)),U,1)
I X'="" D
.N DIK,DIV,DIU,DIN
.X ^DD(399,.01,1,7,1.3) I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,0)):^(0),1:"") S X=$P(Y(1),U,19),X=X S DIU=X K Y S X=DIV S X=3 S DIH=$G(^DGCR(399,DIV(0),0)),DIV=X S $P(^(0),U,19)=DIV,DIH=399,DIG=.19 D ^DICR
S DIKZ(0)=$G(^DGCR(399,DA,0))
S X=$P($G(DIKZ(0)),U,2)
I X'="" S ^DGCR(399,"C",$E(X,1,30),DA)=""
S X=$P($G(DIKZ(0)),U,3)
I X'="" S ^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) S:$D(IBN) ^DGCR(399,"APDT",IBN,DA,9999999-X)="" K IBN
S X=$P($G(DIKZ(0)),U,3)
I X'="" S ^DGCR(399,"ABNDT",DA,9999999-X)=""
S X=$P($G(DIKZ(0)),U,4)
I X'="" D
.N DIK,DIV,DIU,DIN
.X ^DD(399,.04,1,1,1.3) I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,0)):^(0),1:"") S X=$P(Y(1),U,24),X=X S DIU=X K Y S X=DIV S X=DIV,X=X S DIH=$G(^DGCR(399,DIV(0),0)),DIV=X S $P(^(0),U,24)=DIV,DIH=399,DIG=.24 D ^DICR
S DIKZ(0)=$G(^DGCR(399,DA,0))
S X=$P($G(DIKZ(0)),U,5)
I X'="" S ^DGCR(399,"ABT",$E(X,1,30),DA)=""
S X=$P($G(DIKZ(0)),U,5)
I X'="" D
.N DIK,DIV,DIU,DIN
.X ^DD(399,.05,1,2,1.3) I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,0)):^(0),1:"") S X=$P(Y(1),U,25),X=X S DIU=X K Y S X=DIV S X=$$TRIG05^IBCU4(X,D0) S DIH=$G(^DGCR(399,DIV(0),0)),DIV=X S $P(^(0),U,25)=DIV,DIH=399,DIG=.25 D ^DICR
S X=$P($G(DIKZ(0)),U,5)
I X'="" D
.N DIK,DIV,DIU,DIN
.K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X X ^DD(399,.05,1,3,69.3) S Y(7)=$G(X) S X=Y(0),X=X S X=X=3,Y=X,X=Y(6),X=X&Y I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"U")):^("U"),1:"") S X=$P(Y(1),U,8),X=X S DIU=X K Y S X=DIV S X=3 X ^DD(399,.05,1,3,1.4)
S DIKZ(0)=$G(^DGCR(399,DA,0))
S X=$P($G(DIKZ(0)),U,6)
I X'="" D
.N DIK,DIV,DIU,DIN
.X ^DD(399,.06,1,1,1.3) I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,0)):^(0),1:"") S X=$P(Y(1),U,26),X=X S DIU=X K Y S X=DIV S X=DIV,X=X S DIH=$G(^DGCR(399,DIV(0),0)),DIV=X S $P(^(0),U,26)=DIV,DIH=399,DIG=.26 D ^DICR
S DIKZ(0)=$G(^DGCR(399,DA,0))
S X=$P($G(DIKZ(0)),U,7)
I X'="" D
.N DIK,DIV,DIU,DIN
.X ^DD(399,.07,1,1,1.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=1 X ^DD(399,.07,1,1,1.4)
S X=$P($G(DIKZ(0)),U,7)
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,0)):^(0),1:"") S X=$P(Y(1),U,11),X=X S DIU=X K Y S X=DIV S X=$P(^DGCR(399.3,$P(^DGCR(399,DA,0),U,7),0),U,7) X ^DD(399,.07,1,2,1.4)
S X=$P($G(DIKZ(0)),U,7)
I X'="" S ^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
.X ^DD(399,.08,1,1,1.3) I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"U")):^("U"),1:"") S X=$P(Y(1),U,9),X=X S DIU=X K Y S X=DIV S X=2 X ^DD(399,.08,1,1,1.4)
S X=$P($G(DIKZ(0)),U,8)
I X'="" D
.N DIK,DIV,DIU,DIN
.X ^DD(399,.08,1,2,1.3) I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"U")):^("U"),1:"") S X=$P(Y(1),U,8),X=X S DIU=X K Y S X=DIV S X=2 X ^DD(399,.08,1,2,1.4)
S X=$P($G(DIKZ(0)),U,8)
I X'="" D
.N DIK,DIV,DIU,DIN
.X ^DD(399,.08,1,4,1.3) I X S X=DIV 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=DIV D DIS^IBCU S X=X X ^DD(399,.08,1,4,1.4)
S X=$P($G(DIKZ(0)),U,8)
I X'="" S ^DGCR(399,"APTF",$E(X,1,30),DA)=""
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(0)=X I $P(^DGCR(399,DA,0),U,5)<3 I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"U")):^("U"),1:"") S X=$P(Y(1),U,15),X=X S DIU=X K Y S X=DIV S X=+$$LOS1^IBCU64(DA) X ^DD(399,.08,1,6,1.4)
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(0)=X S X=$$PPSC^IBCU64(DA) I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"U1")):^("U1"),1:"") S X=$P(Y(1),U,15),X=X S DIU=X K Y S X=DIV S X=$$PPS^IBCU64(DA,X) X ^DD(399,.08,1,7,1.4)
S DIKZ(0)=$G(^DGCR(399,DA,0))
S X=$P($G(DIKZ(0)),U,11)
I X'="" D
.N DIK,DIV,DIU,DIN
.X ^DD(399,.11,1,1,1.3) I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"M")):^("M"),1:"") S X=$P(Y(1),U,12),X=X S DIU=X K Y S X=DIV D EN1^IBCU5 X ^DD(399,.11,1,1,1.4)
S X=$P($G(DIKZ(0)),U,11)
I X'="" D EN^IBCU5
S X=$P($G(DIKZ(0)),U,11)
I X'="" S DGRVRCAL=1
S X=$P($G(DIKZ(0)),U,11)
I X'="" D
.N DIK,DIV,DIU,DIN
.X ^DD(399,.11,1,4,1.3) 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 X ^DD(399,.11,1,4,1.1) X ^DD(399,.11,1,4,1.4)
S DIKZ(0)=$G(^DGCR(399,DA,0))
S X=$P($G(DIKZ(0)),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,0)):^(0),1:"") S X=$P(Y(1),U,14),X=X S DIU=X K Y S X=DIV N %I,%H,% D NOW^%DTC X ^DD(399,.13,1,1,1.4)
S X=$P($G(DIKZ(0)),U,13)
I X'="" I X>0,X<3,$P(^DGCR(399,DA,0),U,2) S ^DGCR(399,"AOP",$P(^(0),U,2),DA)=""
S X=$P($G(DIKZ(0)),U,13)
I X'="" I +X=3 S ^DGCR(399,"AST",+X,DA)=""
S X=$P($G(DIKZ(0)),U,13)
I X'="" D
.N DIK,DIV,DIU,DIN
.K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S X=Y(0),X=X S X=X=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=DIV S X="1N" X ^DD(399,.13,1,4,1.4)
S DIKZ(0)=$G(^DGCR(399,DA,0))
S X=$P($G(DIKZ(0)),U,14)
I X'="" D BC^IBJVDEQ
S X=$P($G(DIKZ(0)),U,17)
I X'="" S ^DGCR(399,"AC",$E(X,1,30),DA)=""
S X=$P($G(DIKZ(0)),U,19)
I X'="" D
.N DIK,DIV,DIU,DIN
.X ^DD(399,.19,1,1,1.3) I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,0)):^(0),1:"") S X=$P(Y(1),U,9),X=X S DIU=X K Y S X=DIV S X=5 S DIH=$G(^DGCR(399,DIV(0),0)),DIV=X S $P(^(0),U,9)=DIV,DIH=399,DIG=.09 D ^DICR
S X=$P($G(DIKZ(0)),U,19)
I X'="" S DGRVRCAL=1
S X=$P($G(DIKZ(0)),U,19)
I X'="" D ALLID^IBCEP3(DA,.19,1)
S X=$P($G(DIKZ(0)),U,19)
I X'="" D ATTREND^IBCU1(DA,"","")
S DIKZ(0)=$G(^DGCR(399,DA,0))
S X=$P($G(DIKZ(0)),U,20)
I X'="" D
.N DIK,DIV,DIU,DIN
.X ^DD(399,.2,1,1,1.3) I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"S")):^("S"),1:"") S X=$P(Y(1),U,2),X=X S DIU=X K Y S X=DIV S X=.5 X ^DD(399,.2,1,1,1.4)
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=DIV S X=$$BPP^IBCNS2(DA) X ^DD(399,.21,1,1,1.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=DIV S X=0 X ^DD(399,.21,1,2,1.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=$S($$WNRBILL^IBEFUNC(DA,X):1,1:0) 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,3,1.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=$$CREATE^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=DIV S X=1 X ^DD(399,.21,1,4,1.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=Y(0),X=X S X=X="P" I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"M1")):^("M1"),1:"") S X=$P(Y(1),U,5),X=X S DIU=X K Y S X="" X ^DD(399,.21,1,5,1.4)
S X=$P($G(DIKZ(0)),U,21)
I X'="" D
.N DIK,DIV,DIU,DIN
.X ^DD(399,.21,1,6,1.3) I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"M1")):^("M1"),1:"") S X=$P(Y(1),U,6),X=X S DIU=X K Y S X="" S DIH=$G(^DGCR(399,DIV(0),"M1")),DIV=X S $P(^("M1"),U,6)=DIV,DIH=399,DIG=126 D ^DICR
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,"M1")):^("M1"),1:"") S X=$P(Y(1),U,7),X=X S DIU=X K Y S X="" S DIH=$G(^DGCR(399,DIV(0),"M1")),DIV=X S $P(^("M1"),U,7)=DIV,DIH=399,DIG=127 D ^DICR
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=Y(0),X=X S X=X="P" I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"U2")):^("U2"),1:"") S X=$P(Y(1),U,4),X=X S DIU=X K Y S X="" X ^DD(399,.21,1,8,1.4)
S X=$P($G(DIKZ(0)),U,21)
I X'="" D
.N DIK,DIV,DIU,DIN
.X ^DD(399,.21,1,9,1.3) I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"U2")):^("U2"),1:"") S X=$P(Y(1),U,5),X=X S DIU=X K Y S X="" S DIH=$G(^DGCR(399,DIV(0),"U2")),DIV=X S $P(^("U2"),U,5)=DIV,DIH=399,DIG=219 D ^DICR
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,"U2")):^("U2"),1:"") S X=$P(Y(1),U,6),X=X S DIU=X K Y S X="" S DIH=$G(^DGCR(399,DIV(0),"U2")),DIV=X S $P(^("U2"),U,6)=DIV,DIH=399,DIG=220 D ^DICR
S DIKZ(0)=$G(^DGCR(399,DA,0))
S X=$P($G(DIKZ(0)),U,22)
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,.22,1,7,1.4)
S DIKZ(0)=$G(^DGCR(399,DA,0))
S X=$P($G(DIKZ(0)),U,25)
I X'="" D ALLID^IBCEP3(DA,.25,1)
S X=$P($G(DIKZ(0)),U,26)
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,0)):^(0),1:"") S X=$P(Y(1),U,6),X=X S DIU=X K Y S X=DIV S X=DIV,X=X S DIH=$G(^DGCR(399,DIV(0),0)),DIV=X S $P(^(0),U,6)=DIV,DIH=399,DIG=.06 D ^DICR
S DIKZ(0)=$G(^DGCR(399,DA,0))
S X=$P($G(DIKZ(0)),U,27)
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,0)):^(0),1:"") S X=$P(Y(1),U,19),X=X S DIU=X K Y S X=DIV S X=$$FT^IBCU3(DA,1) X ^DD(399,.27,1,1,1.4)
S X=$P($G(DIKZ(0)),U,27)
I X'="" D
.N DIK,DIV,DIU,DIN
.X ^DD(399,.27,1,2,1.3) I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"U")):^("U"),1:"") S X=$P(Y(1),U,8),X=X S DIU=X K Y S X=DIV S X=3 S DIH=$G(^DGCR(399,DIV(0),"U")),DIV=X S $P(^("U"),U,8)=DIV,DIH=399,DIG=158 D ^DICR
S DIKZ("S")=$G(^DGCR(399,DA,"S"))
S X=$P($G(DIKZ("S")),U,1)
I X'="" S ^DGCR(399,"APD",$E(X,1,30),DA)=""
S X=$P($G(DIKZ("S")),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,"S")):^("S"),1:"") S X=$P(Y(1),U,4)="" I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"S")):^("S"),1:"") S X=$P(Y(1),U,4),X=X S DIU=X K Y S X=DIV N %I,%H,% D NOW^%DTC X ^DD(399,3,1,1,1.4)
S X=$P($G(DIKZ("S")),U,3)
I X'="" D
.N DIK,DIV,DIU,DIN
.X ^DD(399,3,1,2,1.3) I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"S")):^("S"),1:"") S X=$P(Y(1),U,5),X=X S DIU=X K Y S X=DIV S X=DUZ X ^DD(399,3,1,2,1.4)
S DIKZ("S")=$G(^DGCR(399,DA,"S"))
S X=$P($G(DIKZ("S")),U,7)
I X'="" S ^DGCR(399,"APM",$E(X,1,30),DA)=""
S X=$P($G(DIKZ("S")),U,9)
I X'="" D
.N DIK,DIV,DIU,DIN
.X ^DD(399,9,1,1,1.3) I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"S")):^("S"),1:"") S X=$P(Y(1),U,10),X=X S DIU=X K Y S X=DIV N %I,%H,% D NOW^%DTC X ^DD(399,9,1,1,1.4)
S X=$P($G(DIKZ("S")),U,9)
I X'="" D
.N DIK,DIV,DIU,DIN
.K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X X ^DD(399,9,1,2,69.2) S X=X="YES",Y=X,X=Y(2),X=X&Y I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"S")):^("S"),1:"") S X=$P(Y(1),U,11),X=X S DIU=X K Y S X=DIV S X=DUZ X ^DD(399,9,1,2,1.4)
S X=$P($G(DIKZ("S")),U,9)
I X'="" D
.N DIK,DIV,DIU,DIN
.K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S Y=Y(0) X:$D(^DD(399,9,2)) ^(2) S X=Y="YES" I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,0)):^(0),1:"") S X=$P(Y(1),U,13),X=X S DIU=X K Y S X=DIV S X=3 X ^DD(399,9,1,3,1.4)
S X=$P($G(DIKZ("S")),U,9)
I X'="" D
.N DIK,DIV,DIU,DIN
.K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S X=$$EXTERNAL^DIDU(399,9,"",Y(0))="YES" I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"TX")):^("TX"),1:"") S X=$P(Y(1),U,6),X=X S DIU=X K Y S X="" X ^DD(399,9,1,4,1.4)
S DIKZ("S")=$G(^DGCR(399,DA,"S"))
S X=$P($G(DIKZ("S")),U,10)
I X'="" S ^DGCR(399,"APD3",$E(X,1,30),DA)=""
S X=$P($G(DIKZ("S")),U,12)
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,"S")):^("S"),1:"") S X=$P(Y(1),U,14)="" I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"S")):^("S"),1:"") S X=$P(Y(1),U,14),X=X S DIU=X K Y S X=DIV N %I,%H,% D NOW^%DTC X ^DD(399,12,1,1,1.4)
S X=$P($G(DIKZ("S")),U,12)
I X'="" D
.N DIK,DIV,DIU,DIN
.X ^DD(399,12,1,2,1.3) I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"S")):^("S"),1:"") S X=$P(Y(1),U,15),X=X S DIU=X K Y S X=DIV S X=DUZ S DIH=$G(^DGCR(399,DIV(0),"S")),DIV=X S $P(^("S"),U,15)=DIV,DIH=399,DIG=15 D ^DICR
S X=$P($G(DIKZ("S")),U,12)
I X'="" D
.N DIK,DIV,DIU,DIN
.X ^DD(399,12,1,3,1.3) I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"S")):^("S"),1:"") S X=$P(Y(1),U,13),X=X S DIU=X K Y S X=DIV S X=DUZ S DIH=$G(^DGCR(399,DIV(0),"S")),DIV=X S $P(^("S"),U,13)=DIV,DIH=399,DIG=13 D ^DICR
S X=$P($G(DIKZ("S")),U,12)
I X'="" S ^DGCR(399,"AP",$E(X,1,30),DA)=""
S DIKZ("S")=$G(^DGCR(399,DA,"S"))
S X=$P($G(DIKZ("S")),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,0)):^(0),1:"") S X=$P(Y(1),U,13),X=X S DIU=X K Y S X=DIV S X=4 S DIH=$G(^DGCR(399,DIV(0),0)),DIV=X S $P(^(0),U,13)=DIV,DIH=399,DIG=.13 D ^DICR
S X=$P($G(DIKZ("S")),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,"S")):^("S"),1:"") S X=$P(Y(1),U,15),X=X S DIU=X K Y S X=DIV S X=DUZ S DIH=$G(^DGCR(399,DIV(0),"S")),DIV=X S $P(^("S"),U,15)=DIV,DIH=399,DIG=15 D ^DICR
S DIKZ("S")=$G(^DGCR(399,DA,"S"))
S X=$P($G(DIKZ("S")),U,16)
I X'="" D
.N DIK,DIV,DIU,DIN
.K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S X=$$EXTERNAL^DIDU(399,16,"",Y(0))="YES" I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"S")):^("S"),1:"") S X=$P(Y(1),U,17),X=X S DIU=X K Y S X=DIV N %I,%H,% D NOW^%DTC X ^DD(399,16,1,1,1.4)
S X=$P($G(DIKZ("S")),U,16)
I X'="" D
.N DIK,DIV,DIU,DIN
.K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S X=$$EXTERNAL^DIDU(399,16,"",Y(0))="YES" I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"S")):^("S"),1:"") S X=$P(Y(1),U,18),X=X S DIU=X K Y S X=DIV S X=DUZ X ^DD(399,16,1,2,1.4)
S DIKZ("S")=$G(^DGCR(399,DA,"S"))
S X=$P($G(DIKZ("S")),U,17)
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,"S")):^("S"),1:"") S X=$P(Y(1),U,16),X=X S X=X=1 I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,0)):^(0),1:"") S X=$P(Y(1),U,13),X=X S DIU=X K Y S X=DIV S X=7 X ^DD(399,17,1,1,1.4)
S DIKZ("TX")=$G(^DGCR(399,DA,"TX"))
S X=$P($G(DIKZ("TX")),U,2)
I X'="" S ^DGCR(399,"ALEX",$E(X,1,30),DA)=""
S X=$P($G(DIKZ("TX")),U,5)
I X'="" D
.N DIK,DIV,DIU,DIN
.X ^DD(399,24,1,1,1.3) I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"TX")):^("TX"),1:"") S X=$P(Y(1),U,3),X=X S DIU=X K Y S X=DIV S X=DT X ^DD(399,24,1,1,1.4)
S DIKZ("TX")=$G(^DGCR(399,DA,"TX"))
S X=$P($G(DIKZ("TX")),U,6)
I X'="" D
.N DIK,DIV,DIU,DIN
.K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S X=Y(0),X=X S X=X=1 I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,0)):^(0),1:"") S X=$P(Y(1),U,13),X=X S DIU=X K Y S X=DIV S X=2 X ^DD(399,25,1,1,1.4)
S X=$P($G(DIKZ("TX")),U,6)
I X'="" D
.N DIK,DIV,DIU,DIN
.K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X X ^DD(399,25,1,2,69.2) S X=X S X=X="",Y=X,X=Y(2),X=X&Y I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"S")):^("S"),1:"") S X=$P(Y(1),U,8),X=X S DIU=X K Y S X=DIV S X=DUZ X ^DD(399,25,1,2,1.4)
S X=$P($G(DIKZ("TX")),U,6)
I X'="" D
.N DIK,DIV,DIU,DIN
.K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X X ^DD(399,25,1,3,69.2) S X=X S X=X="",Y=X,X=Y(2),X=X&Y I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"S")):^("S"),1:"") S X=$P(Y(1),U,7),X=X S DIU=X K Y S X=DIV S X=DT X ^DD(399,25,1,3,1.4)
S DIKZ("S1")=$G(^DGCR(399,DA,"S1"))
S X=$P($G(DIKZ("S1")),U,7)
I X'="" S ^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(1)=$S($D(^DGCR(399,D0,"M1")):^("M1"),1:"") S X=$P(Y(1),U,2),X=X S DIU=X K Y S X=DIV S X=$$PRVNUM^IBCU(DA,X,1) X ^DD(399,101,1,1,1.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 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 X ^DD(399,101,1,2,1.1) X ^DD(399,101,1,2,1.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=$S($$MCRWNR^IBEFUNC(X):$$COBN^IBCEF(DA)=1,1:0) 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,3,1.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,"M1")):^("M1"),1:"") S X=$P(Y(1),U,10),X=X S DIU=X K Y S X=DIV S X=$$PRVQUAL^IBCU(DA,X,1) X ^DD(399,101,1,4,1.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=$$CREATE^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=DIV S X=1 X ^DD(399,101,1,5,1.4)
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(1)=$S($D(^DGCR(399,D0,"M1")):^("M1"),1:"") S X=$P(Y(1),U,3),X=X S DIU=X K Y S X=DIV S X=$$PRVNUM^IBCU(DA,X,2) X ^DD(399,102,1,2,1.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(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 X ^DD(399,102,1,3,1.1) X ^DD(399,102,1,3,1.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(0)=X S X=$S($$MCRWNR^IBEFUNC(X):$$COBN^IBCEF(DA)=2,1:0) 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,102,1,4,1.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,"M1")):^("M1"),1:"") S X=$P(Y(1),U,11),X=X S DIU=X K Y S X=DIV S X=$$PRVQUAL^IBCU(DA,X,2) X ^DD(399,102,1,5,1.4)
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,"M1")):^("M1"),1:"") S X=$P(Y(1),U,4),X=X S DIU=X K Y S X=DIV S X=$$PRVNUM^IBCU(DA,X,3) X ^DD(399,103,1,2,1.4)
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,"M1")):^("M1"),1:"") S X=$P(Y(1),U,12),X=X S DIU=X K Y S X=DIV S X=$$PRVQUAL^IBCU(DA,X,3) X ^DD(399,103,1,3,1.4)
S DIKZ("M")=$G(^DGCR(399,DA,"M"))
S X=$P($G(DIKZ("M")),U,11)
I X'="" D MAILIN^IBCU5
S X=$P($G(DIKZ("M")),U,11)
I X'="" S DGRVRCAL=1
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 X ^DD(399,112,1,1,1.1) X ^DD(399,112,1,1,1.4)
S X=$P($G(DIKZ("M")),U,12)
I X'="" D IX^IBCNS2(DA,"I1")
S X=$P($G(DIKZ("M")),U,12)
END G ^IBXX20
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBXX19 19838 printed Dec 13, 2024@02:32:57 Page 2
IBXX19 ; COMPILED XREF FOR FILE #399 ; 10/03/23
+1 ;
+2 SET DIKZK=1
+3 SET DIKZ(0)=$GET(^DGCR(399,DA,0))
+4 SET X=$PIECE($GET(DIKZ(0)),U,1)
+5 IF X'=""
SET ^DGCR(399,"B",$EXTRACT(X,1,30),DA)=""
+6 SET X=$PIECE($GET(DIKZ(0)),U,1)
+7 IF X'=""
Begin DoDot:1
+8 NEW DIK,DIV,DIU,DIN
+9 KILL DIV
SET DIV=X
SET D0=DA
SET DIV(0)=D0
SET Y(0)=X
SET Y(1)=$SELECT($DATA(^DGCR(399,D0,"S")):^("S"),1:"")
SET X=$PIECE(Y(1),U,1)=""
IF X
SET X=DIV
SET Y(1)=$SELECT($DATA(^DGCR(399,D0,"S")):^("S"),1:"")
SET X=$PIECE(Y(1),U,1)
SET X=X
SET DIU=X
KILL Y
SET X=DIV
NEW %I,%H,%
DO NOW^%DTC
XECUTE ^DD(399,.01,1,3,1.4)
End DoDot:1
+10 SET X=$PIECE($GET(DIKZ(0)),U,1)
+11 IF X'=""
Begin DoDot:1
+12 NEW DIK,DIV,DIU,DIN
+13 XECUTE ^DD(399,.01,1,4,1.3)
IF X
SET X=DIV
SET Y(1)=$SELECT($DATA(^DGCR(399,D0,"S")):^("S"),1:"")
SET X=$PIECE(Y(1),U,2)
SET X=X
SET DIU=X
KILL Y
SET X=DIV
SET X=$SELECT(($DATA(DUZ)#2):DUZ,1:"")
XECUTE ^DD(399,.01,1,4,1.4)
End DoDot:1
+14 SET X=$PIECE($GET(DIKZ(0)),U,1)
+15 IF X'=""
Begin DoDot:1
+16 NEW DIK,DIV,DIU,DIN
+17 XECUTE ^DD(399,.01,1,5,1.3)
IF X
SET X=DIV
SET Y(1)=$SELECT($DATA(^DGCR(399,D0,"U")):^("U"),1:"")
SET X=$PIECE(Y(1),U,14)
SET X=X
SET DIU=X
KILL Y
SET X=DIV
SET X=$SELECT($DATA(^IBE(350.9,1,1)):$PIECE(^(1),U,6),1:"")
XECUTE ^DD(399,.01,1,5,1.4)
End DoDot:1
+18 SET X=$PIECE($GET(DIKZ(0)),U,1)
+19 IF X'=""
Begin DoDot:1
+20 NEW DIK,DIV,DIU,DIN
+21 KILL DIV
SET DIV=X
SET D0=DA
SET DIV(0)=D0
SET Y(1)=$SELECT($DATA(^DGCR(399,D0,0)):^(0),1:"")
SET X=$PIECE(Y(1),U,13)
SET X=X
SET DIU=X
KILL Y
SET X=DIV
SET X=1
SET DIH=$GET(^DGCR(399,DIV(0),0))
SET DIV=X
SET $PIECE(^(0),U,13)=DIV
SET DIH=399
SET DIG=.13
DO ^DICR
End DoDot:1
+22 SET X=$PIECE($GET(DIKZ(0)),U,1)
+23 IF X'=""
Begin DoDot:1
+24 NEW DIK,DIV,DIU,DIN
+25 XECUTE ^DD(399,.01,1,7,1.3)
IF X
SET X=DIV
SET Y(1)=$SELECT($DATA(^DGCR(399,D0,0)):^(0),1:"")
SET X=$PIECE(Y(1),U,19)
SET X=X
SET DIU=X
KILL Y
SET X=DIV
SET X=3
SET DIH=$GET(^DGCR(399,DIV(0),0))
SET DIV=X
SET $PIECE(^(0),U,19)=DIV
SET DIH=399
SET DIG=.19
DO ^DICR
End DoDot:1
+26 SET DIKZ(0)=$GET(^DGCR(399,DA,0))
+27 SET X=$PIECE($GET(DIKZ(0)),U,2)
+28 IF X'=""
SET ^DGCR(399,"C",$EXTRACT(X,1,30),DA)=""
+29 SET X=$PIECE($GET(DIKZ(0)),U,3)
+30 IF X'=""
SET ^DGCR(399,"D",$EXTRACT(X,1,30),DA)=""
+31 SET X=$PIECE($GET(DIKZ(0)),U,3)
+32 IF X'=""
SET IBN=$PIECE(^DGCR(399,DA,0),"^",2)
if $DATA(IBN)
SET ^DGCR(399,"APDT",IBN,DA,9999999-X)=""
KILL IBN
+33 SET X=$PIECE($GET(DIKZ(0)),U,3)
+34 IF X'=""
SET ^DGCR(399,"ABNDT",DA,9999999-X)=""
+35 SET X=$PIECE($GET(DIKZ(0)),U,4)
+36 IF X'=""
Begin DoDot:1
+37 NEW DIK,DIV,DIU,DIN
+38 XECUTE ^DD(399,.04,1,1,1.3)
IF X
SET X=DIV
SET Y(1)=$SELECT($DATA(^DGCR(399,D0,0)):^(0),1:"")
SET X=$PIECE(Y(1),U,24)
SET X=X
SET DIU=X
KILL Y
SET X=DIV
SET X=DIV
SET X=X
SET DIH=$GET(^DGCR(399,DIV(0),0))
SET DIV=X
SET $PIECE(^(0),U,24)=DIV
SET DIH=399
SET DIG=.24
DO ^DICR
End DoDot:1
+39 SET DIKZ(0)=$GET(^DGCR(399,DA,0))
+40 SET X=$PIECE($GET(DIKZ(0)),U,5)
+41 IF X'=""
SET ^DGCR(399,"ABT",$EXTRACT(X,1,30),DA)=""
+42 SET X=$PIECE($GET(DIKZ(0)),U,5)
+43 IF X'=""
Begin DoDot:1
+44 NEW DIK,DIV,DIU,DIN
+45 XECUTE ^DD(399,.05,1,2,1.3)
IF X
SET X=DIV
SET Y(1)=$SELECT($DATA(^DGCR(399,D0,0)):^(0),1:"")
SET X=$PIECE(Y(1),U,25)
SET X=X
SET DIU=X
KILL Y
SET X=DIV
SET X=$$TRIG05^IBCU4(X,D0)
SET DIH=$GET(^DGCR(399,DIV(0),0))
SET DIV=X
SET $PIECE(^(0),U,25)=DIV
SET DIH=399
SET DIG=.25
DO ^DICR
End DoDot:1
+46 SET X=$PIECE($GET(DIKZ(0)),U,5)
+47 IF X'=""
Begin DoDot:1
+48 NEW DIK,DIV,DIU,DIN
+49 KILL DIV
SET DIV=X
SET D0=DA
SET DIV(0)=D0
SET Y(0)=X
XECUTE ^DD(399,.05,1,3,69.3)
SET Y(7)=$GET(X)
SET X=Y(0)
SET X=X
SET X=X=3
SET Y=X
SET X=Y(6)
SET X=X&Y
IF X
SET X=DIV
SET Y(1)=$SELECT($DATA(^DGCR(399,D0,"U")):^("U"),1:"")
SET X=$PIECE(Y(1),U,8)
SET X=X
SET DIU=X
KILL Y
SET X=DIV
SET X=3
XECUTE ^DD(399,.05,1,3,1.4)
End DoDot:1
+50 SET DIKZ(0)=$GET(^DGCR(399,DA,0))
+51 SET X=$PIECE($GET(DIKZ(0)),U,6)
+52 IF X'=""
Begin DoDot:1
+53 NEW DIK,DIV,DIU,DIN
+54 XECUTE ^DD(399,.06,1,1,1.3)
IF X
SET X=DIV
SET Y(1)=$SELECT($DATA(^DGCR(399,D0,0)):^(0),1:"")
SET X=$PIECE(Y(1),U,26)
SET X=X
SET DIU=X
KILL Y
SET X=DIV
SET X=DIV
SET X=X
SET DIH=$GET(^DGCR(399,DIV(0),0))
SET DIV=X
SET $PIECE(^(0),U,26)=DIV
SET DIH=399
SET DIG=.26
DO ^DICR
End DoDot:1
+55 SET DIKZ(0)=$GET(^DGCR(399,DA,0))
+56 SET X=$PIECE($GET(DIKZ(0)),U,7)
+57 IF X'=""
Begin DoDot:1
+58 NEW DIK,DIV,DIU,DIN
+59 XECUTE ^DD(399,.07,1,1,1.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=1
XECUTE ^DD(399,.07,1,1,1.4)
End DoDot:1
+60 SET X=$PIECE($GET(DIKZ(0)),U,7)
+61 IF X'=""
Begin DoDot:1
+62 NEW DIK,DIV,DIU,DIN
+63 KILL DIV
SET DIV=X
SET D0=DA
SET DIV(0)=D0
SET Y(1)=$SELECT($DATA(^DGCR(399,D0,0)):^(0),1:"")
SET X=$PIECE(Y(1),U,11)
SET X=X
SET DIU=X
KILL Y
SET X=DIV
SET X=$PIECE(^DGCR(399.3,$PIECE(^DGCR(399,DA,0),U,7),0),U,7)
XECUTE ^DD(399,.07,1,2,1.4)
End DoDot:1
+64 SET X=$PIECE($GET(DIKZ(0)),U,7)
+65 IF X'=""
SET ^DGCR(399,"AD",$EXTRACT(X,1,30),DA)=""
+66 SET DIKZ(0)=$GET(^DGCR(399,DA,0))
+67 SET X=$PIECE($GET(DIKZ(0)),U,8)
+68 IF X'=""
Begin DoDot:1
+69 NEW DIK,DIV,DIU,DIN
+70 XECUTE ^DD(399,.08,1,1,1.3)
IF X
SET X=DIV
SET Y(1)=$SELECT($DATA(^DGCR(399,D0,"U")):^("U"),1:"")
SET X=$PIECE(Y(1),U,9)
SET X=X
SET DIU=X
KILL Y
SET X=DIV
SET X=2
XECUTE ^DD(399,.08,1,1,1.4)
End DoDot:1
+71 SET X=$PIECE($GET(DIKZ(0)),U,8)
+72 IF X'=""
Begin DoDot:1
+73 NEW DIK,DIV,DIU,DIN
+74 XECUTE ^DD(399,.08,1,2,1.3)
IF X
SET X=DIV
SET Y(1)=$SELECT($DATA(^DGCR(399,D0,"U")):^("U"),1:"")
SET X=$PIECE(Y(1),U,8)
SET X=X
SET DIU=X
KILL Y
SET X=DIV
SET X=2
XECUTE ^DD(399,.08,1,2,1.4)
End DoDot:1
+75 SET X=$PIECE($GET(DIKZ(0)),U,8)
+76 IF X'=""
Begin DoDot:1
+77 NEW DIK,DIV,DIU,DIN
+78 XECUTE ^DD(399,.08,1,4,1.3)
IF X
SET X=DIV
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=DIV
DO DIS^IBCU
SET X=X
XECUTE ^DD(399,.08,1,4,1.4)
End DoDot:1
+79 SET X=$PIECE($GET(DIKZ(0)),U,8)
+80 IF X'=""
SET ^DGCR(399,"APTF",$EXTRACT(X,1,30),DA)=""
+81 SET X=$PIECE($GET(DIKZ(0)),U,8)
+82 IF X'=""
Begin DoDot:1
+83 NEW DIK,DIV,DIU,DIN
+84 KILL DIV
SET DIV=X
SET D0=DA
SET DIV(0)=D0
SET Y(0)=X
IF $PIECE(^DGCR(399,DA,0),U,5)<3
IF X
SET X=DIV
SET Y(1)=$SELECT($DATA(^DGCR(399,D0,"U")):^("U"),1:"")
SET X=$PIECE(Y(1),U,15)
SET X=X
SET DIU=X
KILL Y
SET X=DIV
SET X=+$$LOS1^IBCU64(DA)
XECUTE ^DD(399,.08,1,6,1.4)
End DoDot:1
+85 SET X=$PIECE($GET(DIKZ(0)),U,8)
+86 IF X'=""
Begin DoDot:1
+87 NEW DIK,DIV,DIU,DIN
+88 KILL DIV
SET DIV=X
SET D0=DA
SET DIV(0)=D0
SET Y(0)=X
SET X=$$PPSC^IBCU64(DA)
IF X
SET X=DIV
SET Y(1)=$SELECT($DATA(^DGCR(399,D0,"U1")):^("U1"),1:"")
SET X=$PIECE(Y(1),U,15)
SET X=X
SET DIU=X
KILL Y
SET X=DIV
SET X=$$PPS^IBCU64(DA,X)
XECUTE ^DD(399,.08,1,7,1.4)
End DoDot:1
+89 SET DIKZ(0)=$GET(^DGCR(399,DA,0))
+90 SET X=$PIECE($GET(DIKZ(0)),U,11)
+91 IF X'=""
Begin DoDot:1
+92 NEW DIK,DIV,DIU,DIN
+93 XECUTE ^DD(399,.11,1,1,1.3)
IF X
SET X=DIV
SET Y(1)=$SELECT($DATA(^DGCR(399,D0,"M")):^("M"),1:"")
SET X=$PIECE(Y(1),U,12)
SET X=X
SET DIU=X
KILL Y
SET X=DIV
DO EN1^IBCU5
XECUTE ^DD(399,.11,1,1,1.4)
End DoDot:1
+94 SET X=$PIECE($GET(DIKZ(0)),U,11)
+95 IF X'=""
DO EN^IBCU5
+96 SET X=$PIECE($GET(DIKZ(0)),U,11)
+97 IF X'=""
SET DGRVRCAL=1
+98 SET X=$PIECE($GET(DIKZ(0)),U,11)
+99 IF X'=""
Begin DoDot:1
+100 NEW DIK,DIV,DIU,DIN
+101 XECUTE ^DD(399,.11,1,4,1.3)
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
XECUTE ^DD(399,.11,1,4,1.1)
XECUTE ^DD(399,.11,1,4,1.4)
End DoDot:1
+102 SET DIKZ(0)=$GET(^DGCR(399,DA,0))
+103 SET X=$PIECE($GET(DIKZ(0)),U,13)
+104 IF X'=""
Begin DoDot:1
+105 NEW DIK,DIV,DIU,DIN
+106 KILL DIV
SET DIV=X
SET D0=DA
SET DIV(0)=D0
SET Y(1)=$SELECT($DATA(^DGCR(399,D0,0)):^(0),1:"")
SET X=$PIECE(Y(1),U,14)
SET X=X
SET DIU=X
KILL Y
SET X=DIV
NEW %I,%H,%
DO NOW^%DTC
XECUTE ^DD(399,.13,1,1,1.4)
End DoDot:1
+107 SET X=$PIECE($GET(DIKZ(0)),U,13)
+108 IF X'=""
IF X>0
IF X<3
IF $PIECE(^DGCR(399,DA,0),U,2)
SET ^DGCR(399,"AOP",$PIECE(^(0),U,2),DA)=""
+109 SET X=$PIECE($GET(DIKZ(0)),U,13)
+110 IF X'=""
IF +X=3
SET ^DGCR(399,"AST",+X,DA)=""
+111 SET X=$PIECE($GET(DIKZ(0)),U,13)
+112 IF X'=""
Begin DoDot:1
+113 NEW DIK,DIV,DIU,DIN
+114 KILL DIV
SET DIV=X
SET D0=DA
SET DIV(0)=D0
SET Y(0)=X
SET X=Y(0)
SET X=X
SET X=X=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=DIV
SET X="1N"
XECUTE ^DD(399,.13,1,4,1.4)
End DoDot:1
+115 SET DIKZ(0)=$GET(^DGCR(399,DA,0))
+116 SET X=$PIECE($GET(DIKZ(0)),U,14)
+117 IF X'=""
DO BC^IBJVDEQ
+118 SET X=$PIECE($GET(DIKZ(0)),U,17)
+119 IF X'=""
SET ^DGCR(399,"AC",$EXTRACT(X,1,30),DA)=""
+120 SET X=$PIECE($GET(DIKZ(0)),U,19)
+121 IF X'=""
Begin DoDot:1
+122 NEW DIK,DIV,DIU,DIN
+123 XECUTE ^DD(399,.19,1,1,1.3)
IF X
SET X=DIV
SET Y(1)=$SELECT($DATA(^DGCR(399,D0,0)):^(0),1:"")
SET X=$PIECE(Y(1),U,9)
SET X=X
SET DIU=X
KILL Y
SET X=DIV
SET X=5
SET DIH=$GET(^DGCR(399,DIV(0),0))
SET DIV=X
SET $PIECE(^(0),U,9)=DIV
SET DIH=399
SET DIG=.09
DO ^DICR
End DoDot:1
+124 SET X=$PIECE($GET(DIKZ(0)),U,19)
+125 IF X'=""
SET DGRVRCAL=1
+126 SET X=$PIECE($GET(DIKZ(0)),U,19)
+127 IF X'=""
DO ALLID^IBCEP3(DA,.19,1)
+128 SET X=$PIECE($GET(DIKZ(0)),U,19)
+129 IF X'=""
DO ATTREND^IBCU1(DA,"","")
+130 SET DIKZ(0)=$GET(^DGCR(399,DA,0))
+131 SET X=$PIECE($GET(DIKZ(0)),U,20)
+132 IF X'=""
Begin DoDot:1
+133 NEW DIK,DIV,DIU,DIN
+134 XECUTE ^DD(399,.2,1,1,1.3)
IF X
SET X=DIV
SET Y(1)=$SELECT($DATA(^DGCR(399,D0,"S")):^("S"),1:"")
SET X=$PIECE(Y(1),U,2)
SET X=X
SET DIU=X
KILL Y
SET X=DIV
SET X=.5
XECUTE ^DD(399,.2,1,1,1.4)
End DoDot:1
+135 SET DIKZ(0)=$GET(^DGCR(399,DA,0))
+136 SET X=$PIECE($GET(DIKZ(0)),U,21)
+137 IF X'=""
Begin DoDot:1
+138 NEW DIK,DIV,DIU,DIN
+139 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=DIV
SET X=$$BPP^IBCNS2(DA)
XECUTE ^DD(399,.21,1,1,1.4)
End DoDot:1
+140 SET X=$PIECE($GET(DIKZ(0)),U,21)
+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(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=DIV
SET X=0
XECUTE ^DD(399,.21,1,2,1.4)
End DoDot:1
+144 SET X=$PIECE($GET(DIKZ(0)),U,21)
+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(0)=X
SET X=$SELECT($$WNRBILL^IBEFUNC(DA,X):1,1:0)
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,3,1.4)
End DoDot:1
+148 SET X=$PIECE($GET(DIKZ(0)),U,21)
+149 IF X'=""
Begin DoDot:1
+150 NEW DIK,DIV,DIU,DIN
+151 KILL DIV
SET DIV=X
SET D0=DA
SET DIV(0)=D0
SET Y(0)=X
SET X=$$CREATE^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=DIV
SET X=1
XECUTE ^DD(399,.21,1,4,1.4)
End DoDot:1
+152 SET X=$PIECE($GET(DIKZ(0)),U,21)
+153 IF X'=""
Begin DoDot:1
+154 NEW DIK,DIV,DIU,DIN
+155 KILL DIV
SET DIV=X
SET D0=DA
SET DIV(0)=D0
SET Y(0)=X
SET X=Y(0)
SET X=X
SET X=X="P"
IF X
SET X=DIV
SET Y(1)=$SELECT($DATA(^DGCR(399,D0,"M1")):^("M1"),1:"")
SET X=$PIECE(Y(1),U,5)
SET X=X
SET DIU=X
KILL Y
SET X=""
XECUTE ^DD(399,.21,1,5,1.4)
End DoDot:1
+156 SET X=$PIECE($GET(DIKZ(0)),U,21)
+157 IF X'=""
Begin DoDot:1
+158 NEW DIK,DIV,DIU,DIN
+159 XECUTE ^DD(399,.21,1,6,1.3)
IF X
SET X=DIV
SET Y(1)=$SELECT($DATA(^DGCR(399,D0,"M1")):^("M1"),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),"M1"))
SET DIV=X
SET $PIECE(^("M1"),U,6)=DIV
SET DIH=399
SET DIG=126
DO ^DICR
End DoDot:1
+160 SET X=$PIECE($GET(DIKZ(0)),U,21)
+161 IF X'=""
Begin DoDot:1
+162 NEW DIK,DIV,DIU,DIN
+163 KILL DIV
SET DIV=X
SET D0=DA
SET DIV(0)=D0
SET Y(1)=$SELECT($DATA(^DGCR(399,D0,"M1")):^("M1"),1:"")
SET X=$PIECE(Y(1),U,7)
SET X=X
SET DIU=X
KILL Y
SET X=""
SET DIH=$GET(^DGCR(399,DIV(0),"M1"))
SET DIV=X
SET $PIECE(^("M1"),U,7)=DIV
SET DIH=399
SET DIG=127
DO ^DICR
End DoDot:1
+164 SET X=$PIECE($GET(DIKZ(0)),U,21)
+165 IF X'=""
Begin DoDot:1
+166 NEW DIK,DIV,DIU,DIN
+167 KILL DIV
SET DIV=X
SET D0=DA
SET DIV(0)=D0
SET Y(0)=X
SET X=Y(0)
SET X=X
SET X=X="P"
IF X
SET X=DIV
SET Y(1)=$SELECT($DATA(^DGCR(399,D0,"U2")):^("U2"),1:"")
SET X=$PIECE(Y(1),U,4)
SET X=X
SET DIU=X
KILL Y
SET X=""
XECUTE ^DD(399,.21,1,8,1.4)
End DoDot:1
+168 SET X=$PIECE($GET(DIKZ(0)),U,21)
+169 IF X'=""
Begin DoDot:1
+170 NEW DIK,DIV,DIU,DIN
+171 XECUTE ^DD(399,.21,1,9,1.3)
IF X
SET X=DIV
SET Y(1)=$SELECT($DATA(^DGCR(399,D0,"U2")):^("U2"),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),"U2"))
SET DIV=X
SET $PIECE(^("U2"),U,5)=DIV
SET DIH=399
SET DIG=219
DO ^DICR
End DoDot:1
+172 SET X=$PIECE($GET(DIKZ(0)),U,21)
+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,"U2")):^("U2"),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),"U2"))
SET DIV=X
SET $PIECE(^("U2"),U,6)=DIV
SET DIH=399
SET DIG=220
DO ^DICR
End DoDot:1
+176 SET DIKZ(0)=$GET(^DGCR(399,DA,0))
+177 SET X=$PIECE($GET(DIKZ(0)),U,22)
+178 IF X'=""
Begin DoDot:1
+179 NEW DIK,DIV,DIU,DIN
+180 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,.22,1,7,1.4)
End DoDot:1
+181 SET DIKZ(0)=$GET(^DGCR(399,DA,0))
+182 SET X=$PIECE($GET(DIKZ(0)),U,25)
+183 IF X'=""
DO ALLID^IBCEP3(DA,.25,1)
+184 SET X=$PIECE($GET(DIKZ(0)),U,26)
+185 IF X'=""
Begin DoDot:1
+186 NEW DIK,DIV,DIU,DIN
+187 KILL DIV
SET DIV=X
SET D0=DA
SET DIV(0)=D0
SET Y(1)=$SELECT($DATA(^DGCR(399,D0,0)):^(0),1:"")
SET X=$PIECE(Y(1),U,6)
SET X=X
SET DIU=X
KILL Y
SET X=DIV
SET X=DIV
SET X=X
SET DIH=$GET(^DGCR(399,DIV(0),0))
SET DIV=X
SET $PIECE(^(0),U,6)=DIV
SET DIH=399
SET DIG=.06
DO ^DICR
End DoDot:1
+188 SET DIKZ(0)=$GET(^DGCR(399,DA,0))
+189 SET X=$PIECE($GET(DIKZ(0)),U,27)
+190 IF X'=""
Begin DoDot:1
+191 NEW DIK,DIV,DIU,DIN
+192 KILL DIV
SET DIV=X
SET D0=DA
SET DIV(0)=D0
SET Y(1)=$SELECT($DATA(^DGCR(399,D0,0)):^(0),1:"")
SET X=$PIECE(Y(1),U,19)
SET X=X
SET DIU=X
KILL Y
SET X=DIV
SET X=$$FT^IBCU3(DA,1)
XECUTE ^DD(399,.27,1,1,1.4)
End DoDot:1
+193 SET X=$PIECE($GET(DIKZ(0)),U,27)
+194 IF X'=""
Begin DoDot:1
+195 NEW DIK,DIV,DIU,DIN
+196 XECUTE ^DD(399,.27,1,2,1.3)
IF X
SET X=DIV
SET Y(1)=$SELECT($DATA(^DGCR(399,D0,"U")):^("U"),1:"")
SET X=$PIECE(Y(1),U,8)
SET X=X
SET DIU=X
KILL Y
SET X=DIV
SET X=3
SET DIH=$GET(^DGCR(399,DIV(0),"U"))
SET DIV=X
SET $PIECE(^("U"),U,8)=DIV
SET DIH=399
SET DIG=158
DO ^DICR
End DoDot:1
+197 SET DIKZ("S")=$GET(^DGCR(399,DA,"S"))
+198 SET X=$PIECE($GET(DIKZ("S")),U,1)
+199 IF X'=""
SET ^DGCR(399,"APD",$EXTRACT(X,1,30),DA)=""
+200 SET X=$PIECE($GET(DIKZ("S")),U,3)
+201 IF X'=""
Begin DoDot:1
+202 NEW DIK,DIV,DIU,DIN
+203 KILL DIV
SET DIV=X
SET D0=DA
SET DIV(0)=D0
SET Y(0)=X
SET Y(1)=$SELECT($DATA(^DGCR(399,D0,"S")):^("S"),1:"")
SET X=$PIECE(Y(1),U,4)=""
IF X
SET X=DIV
SET Y(1)=$SELECT($DATA(^DGCR(399,D0,"S")):^("S"),1:"")
SET X=$PIECE(Y(1),U,4)
SET X=X
SET DIU=X
KILL Y
SET X=DIV
NEW %I,%H,%
DO NOW^%DTC
XECUTE ^DD(399,3,1,1,1.4)
End DoDot:1
+204 SET X=$PIECE($GET(DIKZ("S")),U,3)
+205 IF X'=""
Begin DoDot:1
+206 NEW DIK,DIV,DIU,DIN
+207 XECUTE ^DD(399,3,1,2,1.3)
IF X
SET X=DIV
SET Y(1)=$SELECT($DATA(^DGCR(399,D0,"S")):^("S"),1:"")
SET X=$PIECE(Y(1),U,5)
SET X=X
SET DIU=X
KILL Y
SET X=DIV
SET X=DUZ
XECUTE ^DD(399,3,1,2,1.4)
End DoDot:1
+208 SET DIKZ("S")=$GET(^DGCR(399,DA,"S"))
+209 SET X=$PIECE($GET(DIKZ("S")),U,7)
+210 IF X'=""
SET ^DGCR(399,"APM",$EXTRACT(X,1,30),DA)=""
+211 SET X=$PIECE($GET(DIKZ("S")),U,9)
+212 IF X'=""
Begin DoDot:1
+213 NEW DIK,DIV,DIU,DIN
+214 XECUTE ^DD(399,9,1,1,1.3)
IF X
SET X=DIV
SET Y(1)=$SELECT($DATA(^DGCR(399,D0,"S")):^("S"),1:"")
SET X=$PIECE(Y(1),U,10)
SET X=X
SET DIU=X
KILL Y
SET X=DIV
NEW %I,%H,%
DO NOW^%DTC
XECUTE ^DD(399,9,1,1,1.4)
End DoDot:1
+215 SET X=$PIECE($GET(DIKZ("S")),U,9)
+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
XECUTE ^DD(399,9,1,2,69.2)
SET X=X="YES"
SET Y=X
SET X=Y(2)
SET X=X&Y
IF X
SET X=DIV
SET Y(1)=$SELECT($DATA(^DGCR(399,D0,"S")):^("S"),1:"")
SET X=$PIECE(Y(1),U,11)
SET X=X
SET DIU=X
KILL Y
SET X=DIV
SET X=DUZ
XECUTE ^DD(399,9,1,2,1.4)
End DoDot:1
+219 SET X=$PIECE($GET(DIKZ("S")),U,9)
+220 IF X'=""
Begin DoDot:1
+221 NEW DIK,DIV,DIU,DIN
+222 KILL DIV
SET DIV=X
SET D0=DA
SET DIV(0)=D0
SET Y(0)=X
SET Y=Y(0)
if $DATA(^DD(399,9,2))
XECUTE ^(2)
SET X=Y="YES"
IF X
SET X=DIV
SET Y(1)=$SELECT($DATA(^DGCR(399,D0,0)):^(0),1:"")
SET X=$PIECE(Y(1),U,13)
SET X=X
SET DIU=X
KILL Y
SET X=DIV
SET X=3
XECUTE ^DD(399,9,1,3,1.4)
End DoDot:1
+223 SET X=$PIECE($GET(DIKZ("S")),U,9)
+224 IF X'=""
Begin DoDot:1
+225 NEW DIK,DIV,DIU,DIN
+226 KILL DIV
SET DIV=X
SET D0=DA
SET DIV(0)=D0
SET Y(0)=X
SET X=$$EXTERNAL^DIDU(399,9,"",Y(0))="YES"
IF X
SET X=DIV
SET Y(1)=$SELECT($DATA(^DGCR(399,D0,"TX")):^("TX"),1:"")
SET X=$PIECE(Y(1),U,6)
SET X=X
SET DIU=X
KILL Y
SET X=""
XECUTE ^DD(399,9,1,4,1.4)
End DoDot:1
+227 SET DIKZ("S")=$GET(^DGCR(399,DA,"S"))
+228 SET X=$PIECE($GET(DIKZ("S")),U,10)
+229 IF X'=""
SET ^DGCR(399,"APD3",$EXTRACT(X,1,30),DA)=""
+230 SET X=$PIECE($GET(DIKZ("S")),U,12)
+231 IF X'=""
Begin DoDot:1
+232 NEW DIK,DIV,DIU,DIN
+233 KILL DIV
SET DIV=X
SET D0=DA
SET DIV(0)=D0
SET Y(0)=X
SET Y(1)=$SELECT($DATA(^DGCR(399,D0,"S")):^("S"),1:"")
SET X=$PIECE(Y(1),U,14)=""
IF X
SET X=DIV
SET Y(1)=$SELECT($DATA(^DGCR(399,D0,"S")):^("S"),1:"")
SET X=$PIECE(Y(1),U,14)
SET X=X
SET DIU=X
KILL Y
SET X=DIV
NEW %I,%H,%
DO NOW^%DTC
XECUTE ^DD(399,12,1,1,1.4)
End DoDot:1
+234 SET X=$PIECE($GET(DIKZ("S")),U,12)
+235 IF X'=""
Begin DoDot:1
+236 NEW DIK,DIV,DIU,DIN
+237 XECUTE ^DD(399,12,1,2,1.3)
IF X
SET X=DIV
SET Y(1)=$SELECT($DATA(^DGCR(399,D0,"S")):^("S"),1:"")
SET X=$PIECE(Y(1),U,15)
SET X=X
SET DIU=X
KILL Y
SET X=DIV
SET X=DUZ
SET DIH=$GET(^DGCR(399,DIV(0),"S"))
SET DIV=X
SET $PIECE(^("S"),U,15)=DIV
SET DIH=399
SET DIG=15
DO ^DICR
End DoDot:1
+238 SET X=$PIECE($GET(DIKZ("S")),U,12)
+239 IF X'=""
Begin DoDot:1
+240 NEW DIK,DIV,DIU,DIN
+241 XECUTE ^DD(399,12,1,3,1.3)
IF X
SET X=DIV
SET Y(1)=$SELECT($DATA(^DGCR(399,D0,"S")):^("S"),1:"")
SET X=$PIECE(Y(1),U,13)
SET X=X
SET DIU=X
KILL Y
SET X=DIV
SET X=DUZ
SET DIH=$GET(^DGCR(399,DIV(0),"S"))
SET DIV=X
SET $PIECE(^("S"),U,13)=DIV
SET DIH=399
SET DIG=13
DO ^DICR
End DoDot:1
+242 SET X=$PIECE($GET(DIKZ("S")),U,12)
+243 IF X'=""
SET ^DGCR(399,"AP",$EXTRACT(X,1,30),DA)=""
+244 SET DIKZ("S")=$GET(^DGCR(399,DA,"S"))
+245 SET X=$PIECE($GET(DIKZ("S")),U,14)
+246 IF X'=""
Begin DoDot:1
+247 NEW DIK,DIV,DIU,DIN
+248 KILL DIV
SET DIV=X
SET D0=DA
SET DIV(0)=D0
SET Y(1)=$SELECT($DATA(^DGCR(399,D0,0)):^(0),1:"")
SET X=$PIECE(Y(1),U,13)
SET X=X
SET DIU=X
KILL Y
SET X=DIV
SET X=4
SET DIH=$GET(^DGCR(399,DIV(0),0))
SET DIV=X
SET $PIECE(^(0),U,13)=DIV
SET DIH=399
SET DIG=.13
DO ^DICR
End DoDot:1
+249 SET X=$PIECE($GET(DIKZ("S")),U,14)
+250 IF X'=""
Begin DoDot:1
+251 NEW DIK,DIV,DIU,DIN
+252 KILL DIV
SET DIV=X
SET D0=DA
SET DIV(0)=D0
SET Y(1)=$SELECT($DATA(^DGCR(399,D0,"S")):^("S"),1:"")
SET X=$PIECE(Y(1),U,15)
SET X=X
SET DIU=X
KILL Y
SET X=DIV
SET X=DUZ
SET DIH=$GET(^DGCR(399,DIV(0),"S"))
SET DIV=X
SET $PIECE(^("S"),U,15)=DIV
SET DIH=399
SET DIG=15
DO ^DICR
End DoDot:1
+253 SET DIKZ("S")=$GET(^DGCR(399,DA,"S"))
+254 SET X=$PIECE($GET(DIKZ("S")),U,16)
+255 IF X'=""
Begin DoDot:1
+256 NEW DIK,DIV,DIU,DIN
+257 KILL DIV
SET DIV=X
SET D0=DA
SET DIV(0)=D0
SET Y(0)=X
SET X=$$EXTERNAL^DIDU(399,16,"",Y(0))="YES"
IF X
SET X=DIV
SET Y(1)=$SELECT($DATA(^DGCR(399,D0,"S")):^("S"),1:"")
SET X=$PIECE(Y(1),U,17)
SET X=X
SET DIU=X
KILL Y
SET X=DIV
NEW %I,%H,%
DO NOW^%DTC
XECUTE ^DD(399,16,1,1,1.4)
End DoDot:1
+258 SET X=$PIECE($GET(DIKZ("S")),U,16)
+259 IF X'=""
Begin DoDot:1
+260 NEW DIK,DIV,DIU,DIN
+261 KILL DIV
SET DIV=X
SET D0=DA
SET DIV(0)=D0
SET Y(0)=X
SET X=$$EXTERNAL^DIDU(399,16,"",Y(0))="YES"
IF X
SET X=DIV
SET Y(1)=$SELECT($DATA(^DGCR(399,D0,"S")):^("S"),1:"")
SET X=$PIECE(Y(1),U,18)
SET X=X
SET DIU=X
KILL Y
SET X=DIV
SET X=DUZ
XECUTE ^DD(399,16,1,2,1.4)
End DoDot:1
+262 SET DIKZ("S")=$GET(^DGCR(399,DA,"S"))
+263 SET X=$PIECE($GET(DIKZ("S")),U,17)
+264 IF X'=""
Begin DoDot:1
+265 NEW DIK,DIV,DIU,DIN
+266 KILL DIV
SET DIV=X
SET D0=DA
SET DIV(0)=D0
SET Y(0)=X
SET Y(1)=$SELECT($DATA(^DGCR(399,D0,"S")):^("S"),1:"")
SET X=$PIECE(Y(1),U,16)
SET X=X
SET X=X=1
IF X
SET X=DIV
SET Y(1)=$SELECT($DATA(^DGCR(399,D0,0)):^(0),1:"")
SET X=$PIECE(Y(1),U,13)
SET X=X
SET DIU=X
KILL Y
SET X=DIV
SET X=7
XECUTE ^DD(399,17,1,1,1.4)
End DoDot:1
+267 SET DIKZ("TX")=$GET(^DGCR(399,DA,"TX"))
+268 SET X=$PIECE($GET(DIKZ("TX")),U,2)
+269 IF X'=""
SET ^DGCR(399,"ALEX",$EXTRACT(X,1,30),DA)=""
+270 SET X=$PIECE($GET(DIKZ("TX")),U,5)
+271 IF X'=""
Begin DoDot:1
+272 NEW DIK,DIV,DIU,DIN
+273 XECUTE ^DD(399,24,1,1,1.3)
IF X
SET X=DIV
SET Y(1)=$SELECT($DATA(^DGCR(399,D0,"TX")):^("TX"),1:"")
SET X=$PIECE(Y(1),U,3)
SET X=X
SET DIU=X
KILL Y
SET X=DIV
SET X=DT
XECUTE ^DD(399,24,1,1,1.4)
End DoDot:1
+274 SET DIKZ("TX")=$GET(^DGCR(399,DA,"TX"))
+275 SET X=$PIECE($GET(DIKZ("TX")),U,6)
+276 IF X'=""
Begin DoDot:1
+277 NEW DIK,DIV,DIU,DIN
+278 KILL DIV
SET DIV=X
SET D0=DA
SET DIV(0)=D0
SET Y(0)=X
SET X=Y(0)
SET X=X
SET X=X=1
IF X
SET X=DIV
SET Y(1)=$SELECT($DATA(^DGCR(399,D0,0)):^(0),1:"")
SET X=$PIECE(Y(1),U,13)
SET X=X
SET DIU=X
KILL Y
SET X=DIV
SET X=2
XECUTE ^DD(399,25,1,1,1.4)
End DoDot:1
+279 SET X=$PIECE($GET(DIKZ("TX")),U,6)
+280 IF X'=""
Begin DoDot:1
+281 NEW DIK,DIV,DIU,DIN
+282 KILL DIV
SET DIV=X
SET D0=DA
SET DIV(0)=D0
SET Y(0)=X
XECUTE ^DD(399,25,1,2,69.2)
SET X=X
SET X=X=""
SET Y=X
SET X=Y(2)
SET X=X&Y
IF X
SET X=DIV
SET Y(1)=$SELECT($DATA(^DGCR(399,D0,"S")):^("S"),1:"")
SET X=$PIECE(Y(1),U,8)
SET X=X
SET DIU=X
KILL Y
SET X=DIV
SET X=DUZ
XECUTE ^DD(399,25,1,2,1.4)
End DoDot:1
+283 SET X=$PIECE($GET(DIKZ("TX")),U,6)
+284 IF X'=""
Begin DoDot:1
+285 NEW DIK,DIV,DIU,DIN
+286 KILL DIV
SET DIV=X
SET D0=DA
SET DIV(0)=D0
SET Y(0)=X
XECUTE ^DD(399,25,1,3,69.2)
SET X=X
SET X=X=""
SET Y=X
SET X=Y(2)
SET X=X&Y
IF X
SET X=DIV
SET Y(1)=$SELECT($DATA(^DGCR(399,D0,"S")):^("S"),1:"")
SET X=$PIECE(Y(1),U,7)
SET X=X
SET DIU=X
KILL Y
SET X=DIV
SET X=DT
XECUTE ^DD(399,25,1,3,1.4)
End DoDot:1
+287 SET DIKZ("S1")=$GET(^DGCR(399,DA,"S1"))
+288 SET X=$PIECE($GET(DIKZ("S1")),U,7)
+289 IF X'=""
SET ^DGCR(399,"CAP",$EXTRACT(X,1,30),DA)=""
+290 SET DIKZ("M")=$GET(^DGCR(399,DA,"M"))
+291 SET X=$PIECE($GET(DIKZ("M")),U,1)
+292 IF X'=""
Begin DoDot:1
+293 NEW DIK,DIV,DIU,DIN
+294 KILL DIV
SET DIV=X
SET D0=DA
SET DIV(0)=D0
SET Y(1)=$SELECT($DATA(^DGCR(399,D0,"M1")):^("M1"),1:"")
SET X=$PIECE(Y(1),U,2)
SET X=X
SET DIU=X
KILL Y
SET X=DIV
SET X=$$PRVNUM^IBCU(DA,X,1)
XECUTE ^DD(399,101,1,1,1.4)
End DoDot:1
+295 SET X=$PIECE($GET(DIKZ("M")),U,1)
+296 IF X'=""
Begin DoDot:1
+297 NEW DIK,DIV,DIU,DIN
+298 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
XECUTE ^DD(399,101,1,2,1.1)
XECUTE ^DD(399,101,1,2,1.4)
End DoDot:1
+299 SET X=$PIECE($GET(DIKZ("M")),U,1)
+300 IF X'=""
Begin DoDot:1
+301 NEW DIK,DIV,DIU,DIN
+302 KILL DIV
SET DIV=X
SET D0=DA
SET DIV(0)=D0
SET Y(0)=X
SET X=$SELECT($$MCRWNR^IBEFUNC(X):$$COBN^IBCEF(DA)=1,1:0)
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,3,1.4)
End DoDot:1
+303 SET X=$PIECE($GET(DIKZ("M")),U,1)
+304 IF X'=""
Begin DoDot:1
+305 NEW DIK,DIV,DIU,DIN
+306 KILL DIV
SET DIV=X
SET D0=DA
SET DIV(0)=D0
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=DIV
SET X=$$PRVQUAL^IBCU(DA,X,1)
XECUTE ^DD(399,101,1,4,1.4)
End DoDot:1
+307 SET X=$PIECE($GET(DIKZ("M")),U,1)
+308 IF X'=""
Begin DoDot:1
+309 NEW DIK,DIV,DIU,DIN
+310 KILL DIV
SET DIV=X
SET D0=DA
SET DIV(0)=D0
SET Y(0)=X
SET X=$$CREATE^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=DIV
SET X=1
XECUTE ^DD(399,101,1,5,1.4)
End DoDot:1
+311 SET DIKZ("M")=$GET(^DGCR(399,DA,"M"))
+312 SET X=$PIECE($GET(DIKZ("M")),U,2)
+313 IF X'=""
Begin DoDot:1
+314 NEW DIK,DIV,DIU,DIN
+315 KILL DIV
SET DIV=X
SET D0=DA
SET DIV(0)=D0
SET Y(1)=$SELECT($DATA(^DGCR(399,D0,"M1")):^("M1"),1:"")
SET X=$PIECE(Y(1),U,3)
SET X=X
SET DIU=X
KILL Y
SET X=DIV
SET X=$$PRVNUM^IBCU(DA,X,2)
XECUTE ^DD(399,102,1,2,1.4)
End DoDot:1
+316 SET X=$PIECE($GET(DIKZ("M")),U,2)
+317 IF X'=""
Begin DoDot:1
+318 NEW DIK,DIV,DIU,DIN
+319 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
XECUTE ^DD(399,102,1,3,1.1)
XECUTE ^DD(399,102,1,3,1.4)
End DoDot:1
+320 SET X=$PIECE($GET(DIKZ("M")),U,2)
+321 IF X'=""
Begin DoDot:1
+322 NEW DIK,DIV,DIU,DIN
+323 KILL DIV
SET DIV=X
SET D0=DA
SET DIV(0)=D0
SET Y(0)=X
SET X=$SELECT($$MCRWNR^IBEFUNC(X):$$COBN^IBCEF(DA)=2,1:0)
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,102,1,4,1.4)
End DoDot:1
+324 SET X=$PIECE($GET(DIKZ("M")),U,2)
+325 IF X'=""
Begin DoDot:1
+326 NEW DIK,DIV,DIU,DIN
+327 KILL DIV
SET DIV=X
SET D0=DA
SET DIV(0)=D0
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=DIV
SET X=$$PRVQUAL^IBCU(DA,X,2)
XECUTE ^DD(399,102,1,5,1.4)
End DoDot:1
+328 SET DIKZ("M")=$GET(^DGCR(399,DA,"M"))
+329 SET X=$PIECE($GET(DIKZ("M")),U,3)
+330 IF X'=""
Begin DoDot:1
+331 NEW DIK,DIV,DIU,DIN
+332 KILL DIV
SET DIV=X
SET D0=DA
SET DIV(0)=D0
SET Y(1)=$SELECT($DATA(^DGCR(399,D0,"M1")):^("M1"),1:"")
SET X=$PIECE(Y(1),U,4)
SET X=X
SET DIU=X
KILL Y
SET X=DIV
SET X=$$PRVNUM^IBCU(DA,X,3)
XECUTE ^DD(399,103,1,2,1.4)
End DoDot:1
+333 SET X=$PIECE($GET(DIKZ("M")),U,3)
+334 IF X'=""
Begin DoDot:1
+335 NEW DIK,DIV,DIU,DIN
+336 KILL DIV
SET DIV=X
SET D0=DA
SET DIV(0)=D0
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=DIV
SET X=$$PRVQUAL^IBCU(DA,X,3)
XECUTE ^DD(399,103,1,3,1.4)
End DoDot:1
+337 SET DIKZ("M")=$GET(^DGCR(399,DA,"M"))
+338 SET X=$PIECE($GET(DIKZ("M")),U,11)
+339 IF X'=""
DO MAILIN^IBCU5
+340 SET X=$PIECE($GET(DIKZ("M")),U,11)
+341 IF X'=""
SET DGRVRCAL=1
+342 SET X=$PIECE($GET(DIKZ("M")),U,12)
+343 IF X'=""
Begin DoDot:1
+344 NEW DIK,DIV,DIU,DIN
+345 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
XECUTE ^DD(399,112,1,1,1.1)
XECUTE ^DD(399,112,1,1,1.4)
End DoDot:1
+346 SET X=$PIECE($GET(DIKZ("M")),U,12)
+347 IF X'=""
DO IX^IBCNS2(DA,"I1")
+348 SET X=$PIECE($GET(DIKZ("M")),U,12)
END GOTO ^IBXX20
