IBXX20 ; COMPILED XREF FOR FILE #399.0222 ; 10/03/23
;
I X'="" D
.N DIK,DIV,DIU,DIN
.X ^DD(399,112,1,3,1.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=DIV S X=$$BPP^IBCNS2(DA,1) X ^DD(399,112,1,3,1.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=DIV S X=$$AUTH^IBCNS4(D0,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=DIV S X=$$REF^IBCNS4(D0,X) X ^DD(399,112,1,5,1.4)
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 X ^DD(399,113,1,1,1.1) X ^DD(399,113,1,1,1.4)
S X=$P($G(DIKZ("M")),U,13)
I X'="" D IX^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,1.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=DIV S X=$$BPP^IBCNS2(DA,1) X ^DD(399,113,1,3,1.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=DIV S X=$$AUTH^IBCNS4(D0,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=DIV S X=$$REF^IBCNS4(D0,X) X ^DD(399,113,1,5,1.4)
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 X ^DD(399,114,1,1,1.1) X ^DD(399,114,1,1,1.4)
S X=$P($G(DIKZ("M")),U,14)
I X'="" D IX^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,1.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=DIV S X=$$BPP^IBCNS2(DA) X ^DD(399,114,1,3,1.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=DIV S X=$$AUTH^IBCNS4(D0,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=DIV S X=$$REF^IBCNS4(D0,X) X ^DD(399,114,1,5,1.4)
S DIKZ("MP")=$G(^DGCR(399,DA,"MP"))
S X=$P($G(DIKZ("MP")),U,1)
I X'="" D MAILA^IBCU5
S X=$P($G(DIKZ("MP")),U,1)
I X'="" S DGRVRCAL=1
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(0)=X S X='$$WNRBILL^IBEFUNC(DA) I X S X=DIV 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 X ^DD(399,136,1,1,1.1) X ^DD(399,136,1,1,1.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
.X ^DD(399,140,1,1,1.3) I X S X=DIV 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=DIV S X=$$ACIDD^IBCU(DA,1,X) X ^DD(399,140,1,1,1.4)
S DIKZ("M2")=$G(^DGCR(399,DA,"M2"))
S X=$P($G(DIKZ("M2")),U,3)
I X'="" D
.N DIK,DIV,DIU,DIN
.X ^DD(399,142,1,1,1.3) I X S X=DIV 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=DIV S X=$$ACIDD^IBCU(DA,2,X) X ^DD(399,142,1,1,1.4)
S DIKZ("M2")=$G(^DGCR(399,DA,"M2"))
S X=$P($G(DIKZ("M2")),U,5)
I X'="" D
.N DIK,DIV,DIU,DIN
.X ^DD(399,144,1,1,1.3) I X S X=DIV 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=DIV S X=$$ACIDD^IBCU(DA,3,X) X ^DD(399,144,1,1,1.4)
S DIKZ("U")=$G(^DGCR(399,DA,"U"))
S X=$P($G(DIKZ("U")),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 $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,151,1,1,1.4)
S X=$P($G(DIKZ("U")),U,1)
I X'="" S DGRVRCAL=1
S X=$P($G(DIKZ("U")),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 +$G(^DGCR(399,DA,"U1"))=0 I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"U1")):^("U1"),1:"") S X=$P(Y(1),U,1),X=X S DIU=X K Y S X=DIV S X=0 X ^DD(399,151,1,3,1.4)
S X=$P($G(DIKZ("U")),U,1)
I X'="" S:$P(^DGCR(399,DA,0),"^",2) ^DGCR(399,"APDS",$P(^(0),U,2),-X,DA)=""
S DIKZ("U")=$G(^DGCR(399,DA,"U"))
S X=$P($G(DIKZ("U")),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 $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,152,1,1,1.4)
S X=$P($G(DIKZ("U")),U,2)
I X'="" S DGRVRCAL=1
S DIKZ("U")=$G(^DGCR(399,DA,"U"))
S X=$P($G(DIKZ("U")),U,11)
I X'="" D
.N DIK,DIV,DIU,DIN
.X ^DD(399,161,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,12),X=X S DIU=X K Y S X=DIV D DIS^IBCU S X=X S DIH=$G(^DGCR(399,DIV(0),"U")),DIV=X S $P(^("U"),U,12)=DIV,DIH=399,DIG=162 D ^DICR
S DIKZ("U")=$G(^DGCR(399,DA,"U"))
S X=$P($G(DIKZ("U")),U,15)
I X'="" D
.N DIK,DIV,DIU,DIN
.K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S X=($P($G(^DGCR(399,DA,"U2")),U,2)=""&$$INPAT^IBCEF(DA,1)) I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"U2")):^("U2"),1:"") S X=$P(Y(1),U,2),X=X S DIU=X K Y S X=DIV S X=DIV X ^DD(399,165,1,1,1.4)
S X=$P($G(DIKZ("U")),U,15)
I X'="" D
.N DIK,DIV,DIU,DIN
.X ^DD(399,165,1,2,1.3) I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"U2")):^("U2"),1:"") S X=$P(Y(1),U,3),X=X S DIU=X K Y S X=DIV N Z S X=$$LOS1^IBCU64(DA,.Z),X=+$G(Z) X ^DD(399,165,1,2,1.4)
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+DIV X ^DD(399,218,1,1,1.4)
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,3),X=X S DIU=X K Y S X=DIV S X="PRIOR PAYMENT(S)" X ^DD(399,218,1,2,1.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+DIV X ^DD(399,219,1,1,1.4)
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,3),X=X S DIU=X K Y S X=DIV S X="PRIOR PAYMENT(S)" X ^DD(399,219,1,2,1.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+DIV X ^DD(399,220,1,1,1.4)
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,3),X=X S DIU=X K Y S X=DIV S X="PRIOR PAYMENT(S)" X ^DD(399,220,1,2,1.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 X ^DD(399,232,1,1,1.1) X ^DD(399,232,1,1,1.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,1.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=DIV S X=$P($$TAXGET^IBCEP81(X),U,2) X ^DD(399,232,1,4,1.4)
S DIKZ("M1")=$G(^DGCR(399,DA,"M1"))
S X=$P($G(DIKZ("M1")),U,8)
I X'="" S ^DGCR(399,"AG",$E(X,1,30),DA)=""
S X=$P($G(DIKZ("M1")),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,"MP")):^("MP"),1:"") S X=$P(Y(1),U,3),X=X S DIU=X K Y S X=DIV N %I,%H,% D NOW^%DTC S X=% X ^DD(399,471,1,1,1.4)
S X=$P($G(DIKZ("M1")),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,"MP")):^("MP"),1:"") S X=$P(Y(1),U,4),X=X S DIU=X K Y S X=DIV S X=$S(($D(DUZ)#2):DUZ,1:"") X ^DD(399,471,1,2,1.4)
S DIKZ("M1")=$G(^DGCR(399,DA,"M1"))
S X=$P($G(DIKZ("M1")),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,"MP")):^("MP"),1:"") S X=$P(Y(1),U,5),X=X S DIU=X K Y S X=DIV N %I,%H,% D NOW^%DTC S X=% X ^DD(399,472,1,1,1.4)
S X=$P($G(DIKZ("M1")),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,"MP")):^("MP"),1:"") S X=$P(Y(1),U,6),X=X S DIU=X K Y S X=DIV S X=$S(($D(DUZ)#2):DUZ,1:"") X ^DD(399,472,1,2,1.4)
S DIKZ("M1")=$G(^DGCR(399,DA,"M1"))
S X=$P($G(DIKZ("M1")),U,15)
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,7),X=X S DIU=X K Y S X=DIV N %I,%H,% D NOW^%DTC S X=% X ^DD(399,473,1,1,1.4)
S X=$P($G(DIKZ("M1")),U,15)
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,8),X=X S DIU=X K Y S X=DIV S X=$S(($D(DUZ)#2):DUZ,1:"") X ^DD(399,473,1,2,1.4)
S DIKZ("MP")=$G(^DGCR(399,DA,"MP"))
S X=$P($G(DIKZ("MP")),U,3)
I X'="" S ^DGCR(399,"E",$E(X,1,30),DA)=""
S X=$P($G(DIKZ("MP")),U,5)
I X'="" S ^DGCR(399,"F",$E(X,1,30),DA)=""
S X=$P($G(DIKZ("MP")),U,7)
I X'="" S ^DGCR(399,"G",$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
. 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)) SETID^IBCEP3(DA,1) D:X1(2)'=X2(2)!(X1(4)'=X2(4)) SETID^IBCEP3(DA,2) D:X1(3)'=X2(3)!(X1(6)'=X2(6)) SETID^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
. N CURR S CURR=+$$COBN^IBCEF(DA) I $G(X(4)),$G(X(CURR)) S ^DGCR(399,"AE",X(4),X(CURR),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
. D TAX^IBCEF79(DA)
CR4 S DIXR=984
K X
S DIKZ(0)=$G(^DGCR(399,DA,0))
S X(1)=$P(DIKZ(0),U,19)
S X=$G(X(1))
D
. K X1,X2 M X1=X,X2=X
. N IBLNPRV I $$LNPRVFT^IBCEU7(X,.IBLNPRV) D FILE^DIE("E","IBLNPRV") Q
CR5 S DIXR=985
K X
S DIKZ(0)=$G(^DGCR(399,DA,0))
S X(1)=$P(DIKZ(0),U,19)
S X=$G(X(1))
D
. K X1,X2 M X1=X,X2=X
. N DIKXARR M DIKXARR=X S DIKCOND=1
. S X=X(1)=3
. S DIKCOND=$G(X) K X M X=DIKXARR
. Q:'DIKCOND
. D REMOVE^IBCEU7(DA,X(1))
CR6 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
. D CMAEDALL^IBCU9(DA)
CR7 K X
END G ^IBXX21
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBXX20 12076 printed Dec 13, 2024@02:32:59 Page 2
IBXX20 ; COMPILED XREF FOR FILE #399.0222 ; 10/03/23
+1 ;
+2 IF X'=""
Begin DoDot:1
+3 NEW DIK,DIV,DIU,DIN
+4 XECUTE ^DD(399,112,1,3,1.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=DIV
SET X=$$BPP^IBCNS2(DA,1)
XECUTE ^DD(399,112,1,3,1.4)
End DoDot:1
+5 SET X=$PIECE($GET(DIKZ("M")),U,12)
+6 IF X'=""
Begin DoDot:1
+7 NEW DIK,DIV,DIU,DIN
+8 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=DIV
SET X=$$AUTH^IBCNS4(D0,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
+9 SET X=$PIECE($GET(DIKZ("M")),U,12)
+10 IF X'=""
Begin DoDot:1
+11 NEW DIK,DIV,DIU,DIN
+12 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=DIV
SET X=$$REF^IBCNS4(D0,X)
XECUTE ^DD(399,112,1,5,1.4)
End DoDot:1
+13 SET DIKZ("M")=$GET(^DGCR(399,DA,"M"))
+14 SET X=$PIECE($GET(DIKZ("M")),U,13)
+15 IF X'=""
Begin DoDot:1
+16 NEW DIK,DIV,DIU,DIN
+17 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
XECUTE ^DD(399,113,1,1,1.1)
XECUTE ^DD(399,113,1,1,1.4)
End DoDot:1
+18 SET X=$PIECE($GET(DIKZ("M")),U,13)
+19 IF X'=""
DO IX^IBCNS2(DA,"I2")
+20 SET X=$PIECE($GET(DIKZ("M")),U,13)
+21 IF X'=""
Begin DoDot:1
+22 NEW DIK,DIV,DIU,DIN
+23 XECUTE ^DD(399,113,1,3,1.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=DIV
SET X=$$BPP^IBCNS2(DA,1)
XECUTE ^DD(399,113,1,3,1.4)
End DoDot:1
+24 SET X=$PIECE($GET(DIKZ("M")),U,13)
+25 IF X'=""
Begin DoDot:1
+26 NEW DIK,DIV,DIU,DIN
+27 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=DIV
SET X=$$AUTH^IBCNS4(D0,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
+28 SET X=$PIECE($GET(DIKZ("M")),U,13)
+29 IF X'=""
Begin DoDot:1
+30 NEW DIK,DIV,DIU,DIN
+31 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=DIV
SET X=$$REF^IBCNS4(D0,X)
XECUTE ^DD(399,113,1,5,1.4)
End DoDot:1
+32 SET DIKZ("M")=$GET(^DGCR(399,DA,"M"))
+33 SET X=$PIECE($GET(DIKZ("M")),U,14)
+34 IF X'=""
Begin DoDot:1
+35 NEW DIK,DIV,DIU,DIN
+36 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
XECUTE ^DD(399,114,1,1,1.1)
XECUTE ^DD(399,114,1,1,1.4)
End DoDot:1
+37 SET X=$PIECE($GET(DIKZ("M")),U,14)
+38 IF X'=""
DO IX^IBCNS2(DA,"I3")
+39 SET X=$PIECE($GET(DIKZ("M")),U,14)
+40 IF X'=""
Begin DoDot:1
+41 NEW DIK,DIV,DIU,DIN
+42 XECUTE ^DD(399,114,1,3,1.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=DIV
SET X=$$BPP^IBCNS2(DA)
XECUTE ^DD(399,114,1,3,1.4)
End DoDot:1
+43 SET X=$PIECE($GET(DIKZ("M")),U,14)
+44 IF X'=""
Begin DoDot:1
+45 NEW DIK,DIV,DIU,DIN
+46 KILL DIV
SET DIV=X
SET D0=DA
SET DIV(0)=D0
SET Y(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=DIV
SET X=$$AUTH^IBCNS4(D0,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
+47 SET X=$PIECE($GET(DIKZ("M")),U,14)
+48 IF X'=""
Begin DoDot:1
+49 NEW DIK,DIV,DIU,DIN
+50 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=DIV
SET X=$$REF^IBCNS4(D0,X)
XECUTE ^DD(399,114,1,5,1.4)
End DoDot:1
+51 SET DIKZ("MP")=$GET(^DGCR(399,DA,"MP"))
+52 SET X=$PIECE($GET(DIKZ("MP")),U,1)
+53 IF X'=""
DO MAILA^IBCU5
+54 SET X=$PIECE($GET(DIKZ("MP")),U,1)
+55 IF X'=""
SET DGRVRCAL=1
+56 SET X=$PIECE($GET(DIKZ("MP")),U,2)
+57 IF X'=""
Begin DoDot:1
+58 NEW DIK,DIV,DIU,DIN
+59 KILL DIV
SET DIV=X
SET D0=DA
SET DIV(0)=D0
SET Y(0)=X
SET X='$$WNRBILL^IBEFUNC(DA)
IF X
SET X=DIV
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
XECUTE ^DD(399,136,1,1,1.1)
XECUTE ^DD(399,136,1,1,1.4)
End DoDot:1
+60 SET DIKZ("M2")=$GET(^DGCR(399,DA,"M2"))
+61 SET X=$PIECE($GET(DIKZ("M2")),U,1)
+62 IF X'=""
Begin DoDot:1
+63 NEW DIK,DIV,DIU,DIN
+64 XECUTE ^DD(399,140,1,1,1.3)
IF X
SET X=DIV
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=DIV
SET X=$$ACIDD^IBCU(DA,1,X)
XECUTE ^DD(399,140,1,1,1.4)
End DoDot:1
+65 SET DIKZ("M2")=$GET(^DGCR(399,DA,"M2"))
+66 SET X=$PIECE($GET(DIKZ("M2")),U,3)
+67 IF X'=""
Begin DoDot:1
+68 NEW DIK,DIV,DIU,DIN
+69 XECUTE ^DD(399,142,1,1,1.3)
IF X
SET X=DIV
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=DIV
SET X=$$ACIDD^IBCU(DA,2,X)
XECUTE ^DD(399,142,1,1,1.4)
End DoDot:1
+70 SET DIKZ("M2")=$GET(^DGCR(399,DA,"M2"))
+71 SET X=$PIECE($GET(DIKZ("M2")),U,5)
+72 IF X'=""
Begin DoDot:1
+73 NEW DIK,DIV,DIU,DIN
+74 XECUTE ^DD(399,144,1,1,1.3)
IF X
SET X=DIV
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=DIV
SET X=$$ACIDD^IBCU(DA,3,X)
XECUTE ^DD(399,144,1,1,1.4)
End DoDot:1
+75 SET DIKZ("U")=$GET(^DGCR(399,DA,"U"))
+76 SET X=$PIECE($GET(DIKZ("U")),U,1)
+77 IF X'=""
Begin DoDot:1
+78 NEW DIK,DIV,DIU,DIN
+79 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,151,1,1,1.4)
End DoDot:1
+80 SET X=$PIECE($GET(DIKZ("U")),U,1)
+81 IF X'=""
SET DGRVRCAL=1
+82 SET X=$PIECE($GET(DIKZ("U")),U,1)
+83 IF X'=""
Begin DoDot:1
+84 NEW DIK,DIV,DIU,DIN
+85 KILL DIV
SET DIV=X
SET D0=DA
SET DIV(0)=D0
SET Y(0)=X
IF +$GET(^DGCR(399,DA,"U1"))=0
IF X
SET X=DIV
SET Y(1)=$SELECT($DATA(^DGCR(399,D0,"U1")):^("U1"),1:"")
SET X=$PIECE(Y(1),U,1)
SET X=X
SET DIU=X
KILL Y
SET X=DIV
SET X=0
XECUTE ^DD(399,151,1,3,1.4)
End DoDot:1
+86 SET X=$PIECE($GET(DIKZ("U")),U,1)
+87 IF X'=""
if $PIECE(^DGCR(399,DA,0),"^",2)
SET ^DGCR(399,"APDS",$PIECE(^(0),U,2),-X,DA)=""
+88 SET DIKZ("U")=$GET(^DGCR(399,DA,"U"))
+89 SET X=$PIECE($GET(DIKZ("U")),U,2)
+90 IF X'=""
Begin DoDot:1
+91 NEW DIK,DIV,DIU,DIN
+92 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,152,1,1,1.4)
End DoDot:1
+93 SET X=$PIECE($GET(DIKZ("U")),U,2)
+94 IF X'=""
SET DGRVRCAL=1
+95 SET DIKZ("U")=$GET(^DGCR(399,DA,"U"))
+96 SET X=$PIECE($GET(DIKZ("U")),U,11)
+97 IF X'=""
Begin DoDot:1
+98 NEW DIK,DIV,DIU,DIN
+99 XECUTE ^DD(399,161,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,12)
SET X=X
SET DIU=X
KILL Y
SET X=DIV
DO DIS^IBCU
SET X=X
SET DIH=$GET(^DGCR(399,DIV(0),"U"))
SET DIV=X
SET $PIECE(^("U"),U,12)=DIV
SET DIH=399
SET DIG=162
DO ^DICR
End DoDot:1
+100 SET DIKZ("U")=$GET(^DGCR(399,DA,"U"))
+101 SET X=$PIECE($GET(DIKZ("U")),U,15)
+102 IF X'=""
Begin DoDot:1
+103 NEW DIK,DIV,DIU,DIN
+104 KILL DIV
SET DIV=X
SET D0=DA
SET DIV(0)=D0
SET Y(0)=X
SET X=($PIECE($GET(^DGCR(399,DA,"U2")),U,2)=""&$$INPAT^IBCEF(DA,1))
IF X
SET X=DIV
SET Y(1)=$SELECT($DATA(^DGCR(399,D0,"U2")):^("U2"),1:"")
SET X=$PIECE(Y(1),U,2)
SET X=X
SET DIU=X
KILL Y
SET X=DIV
SET X=DIV
XECUTE ^DD(399,165,1,1,1.4)
End DoDot:1
+105 SET X=$PIECE($GET(DIKZ("U")),U,15)
+106 IF X'=""
Begin DoDot:1
+107 NEW DIK,DIV,DIU,DIN
+108 XECUTE ^DD(399,165,1,2,1.3)
IF X
SET X=DIV
SET Y(1)=$SELECT($DATA(^DGCR(399,D0,"U2")):^("U2"),1:"")
SET X=$PIECE(Y(1),U,3)
SET X=X
SET DIU=X
KILL Y
SET X=DIV
NEW Z
SET X=$$LOS1^IBCU64(DA,.Z)
SET X=+$GET(Z)
XECUTE ^DD(399,165,1,2,1.4)
End DoDot:1
+109 SET DIKZ("U2")=$GET(^DGCR(399,DA,"U2"))
+110 SET X=$PIECE($GET(DIKZ("U2")),U,4)
+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(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+DIV
XECUTE ^DD(399,218,1,1,1.4)
End DoDot:1
+114 SET X=$PIECE($GET(DIKZ("U2")),U,4)
+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(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=DIV
SET X="PRIOR PAYMENT(S)"
XECUTE ^DD(399,218,1,2,1.4)
End DoDot:1
+118 SET DIKZ("U2")=$GET(^DGCR(399,DA,"U2"))
+119 SET X=$PIECE($GET(DIKZ("U2")),U,5)
+120 IF X'=""
Begin DoDot:1
+121 NEW DIK,DIV,DIU,DIN
+122 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+DIV
XECUTE ^DD(399,219,1,1,1.4)
End DoDot:1
+123 SET X=$PIECE($GET(DIKZ("U2")),U,5)
+124 IF X'=""
Begin DoDot:1
+125 NEW DIK,DIV,DIU,DIN
+126 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,3)
SET X=X
SET DIU=X
KILL Y
SET X=DIV
SET X="PRIOR PAYMENT(S)"
XECUTE ^DD(399,219,1,2,1.4)
End DoDot:1
+127 SET DIKZ("U2")=$GET(^DGCR(399,DA,"U2"))
+128 SET X=$PIECE($GET(DIKZ("U2")),U,6)
+129 IF X'=""
Begin DoDot:1
+130 NEW DIK,DIV,DIU,DIN
+131 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+DIV
XECUTE ^DD(399,220,1,1,1.4)
End DoDot:1
+132 SET X=$PIECE($GET(DIKZ("U2")),U,6)
+133 IF X'=""
Begin DoDot:1
+134 NEW DIK,DIV,DIU,DIN
+135 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,3)
SET X=X
SET DIU=X
KILL Y
SET X=DIV
SET X="PRIOR PAYMENT(S)"
XECUTE ^DD(399,220,1,2,1.4)
End DoDot:1
+136 SET DIKZ("U2")=$GET(^DGCR(399,DA,"U2"))
+137 SET X=$PIECE($GET(DIKZ("U2")),U,10)
+138 IF X'=""
Begin DoDot:1
+139 NEW DIK,DIV,DIU,DIN
+140 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
XECUTE ^DD(399,232,1,1,1.1)
XECUTE ^DD(399,232,1,1,1.4)
End DoDot:1
+141 SET X=$PIECE($GET(DIKZ("U2")),U,10)
+142 IF X'=""
Begin DoDot:1
+143 NEW DIK,DIV,DIU,DIN
+144 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,1.4)
End DoDot:1
+145 SET X=$PIECE($GET(DIKZ("U2")),U,10)
+146 IF X'=""
Begin DoDot:1
+147 NEW DIK,DIV,DIU,DIN
+148 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=DIV
SET X=$PIECE($$TAXGET^IBCEP81(X),U,2)
XECUTE ^DD(399,232,1,4,1.4)
End DoDot:1
+149 SET DIKZ("M1")=$GET(^DGCR(399,DA,"M1"))
+150 SET X=$PIECE($GET(DIKZ("M1")),U,8)
+151 IF X'=""
SET ^DGCR(399,"AG",$EXTRACT(X,1,30),DA)=""
+152 SET X=$PIECE($GET(DIKZ("M1")),U,13)
+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(1)=$SELECT($DATA(^DGCR(399,D0,"MP")):^("MP"),1:"")
SET X=$PIECE(Y(1),U,3)
SET X=X
SET DIU=X
KILL Y
SET X=DIV
NEW %I,%H,%
DO NOW^%DTC
SET X=%
XECUTE ^DD(399,471,1,1,1.4)
End DoDot:1
+156 SET X=$PIECE($GET(DIKZ("M1")),U,13)
+157 IF X'=""
Begin DoDot:1
+158 NEW DIK,DIV,DIU,DIN
+159 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,4)
SET X=X
SET DIU=X
KILL Y
SET X=DIV
SET X=$SELECT(($DATA(DUZ)#2):DUZ,1:"")
XECUTE ^DD(399,471,1,2,1.4)
End DoDot:1
+160 SET DIKZ("M1")=$GET(^DGCR(399,DA,"M1"))
+161 SET X=$PIECE($GET(DIKZ("M1")),U,14)
+162 IF X'=""
Begin DoDot:1
+163 NEW DIK,DIV,DIU,DIN
+164 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,5)
SET X=X
SET DIU=X
KILL Y
SET X=DIV
NEW %I,%H,%
DO NOW^%DTC
SET X=%
XECUTE ^DD(399,472,1,1,1.4)
End DoDot:1
+165 SET X=$PIECE($GET(DIKZ("M1")),U,14)
+166 IF X'=""
Begin DoDot:1
+167 NEW DIK,DIV,DIU,DIN
+168 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,6)
SET X=X
SET DIU=X
KILL Y
SET X=DIV
SET X=$SELECT(($DATA(DUZ)#2):DUZ,1:"")
XECUTE ^DD(399,472,1,2,1.4)
End DoDot:1
+169 SET DIKZ("M1")=$GET(^DGCR(399,DA,"M1"))
+170 SET X=$PIECE($GET(DIKZ("M1")),U,15)
+171 IF X'=""
Begin DoDot:1
+172 NEW DIK,DIV,DIU,DIN
+173 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,7)
SET X=X
SET DIU=X
KILL Y
SET X=DIV
NEW %I,%H,%
DO NOW^%DTC
SET X=%
XECUTE ^DD(399,473,1,1,1.4)
End DoDot:1
+174 SET X=$PIECE($GET(DIKZ("M1")),U,15)
+175 IF X'=""
Begin DoDot:1
+176 NEW DIK,DIV,DIU,DIN
+177 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,8)
SET X=X
SET DIU=X
KILL Y
SET X=DIV
SET X=$SELECT(($DATA(DUZ)#2):DUZ,1:"")
XECUTE ^DD(399,473,1,2,1.4)
End DoDot:1
+178 SET DIKZ("MP")=$GET(^DGCR(399,DA,"MP"))
+179 SET X=$PIECE($GET(DIKZ("MP")),U,3)
+180 IF X'=""
SET ^DGCR(399,"E",$EXTRACT(X,1,30),DA)=""
+181 SET X=$PIECE($GET(DIKZ("MP")),U,5)
+182 IF X'=""
SET ^DGCR(399,"F",$EXTRACT(X,1,30),DA)=""
+183 SET X=$PIECE($GET(DIKZ("MP")),U,7)
+184 IF X'=""
SET ^DGCR(399,"G",$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 NEW DIKXARR
MERGE DIKXARR=X
SET DIKCOND=1
+13 SET X=$SELECT($ORDER(^DGCR(399,DA,"PRV",0)):1,1:0)
+14 SET DIKCOND=$GET(X)
KILL X
MERGE X=DIKXARR
+15 if 'DIKCOND
QUIT
+16 if X1(1)'=X2(1)!(X1(5)'=X2(5))
DO SETID^IBCEP3(DA,1)
if X1(2)'=X2(2)!(X1(4)'=X2(4))
DO SETID^IBCEP3(DA,2)
if X1(3)'=X2(3)!(X1(6)'=X2(6))
DO SETID^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 NEW CURR
SET CURR=+$$COBN^IBCEF(DA)
IF $GET(X(4))
IF $GET(X(CURR))
SET ^DGCR(399,"AE",X(4),X(CURR),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 DO TAX^IBCEF79(DA)
End DoDot:1
CR4 SET DIXR=984
+1 KILL X
+2 SET DIKZ(0)=$GET(^DGCR(399,DA,0))
+3 SET X(1)=$PIECE(DIKZ(0),U,19)
+4 SET X=$GET(X(1))
+5 Begin DoDot:1
+6 KILL X1,X2
MERGE X1=X,X2=X
+7 NEW IBLNPRV
IF $$LNPRVFT^IBCEU7(X,.IBLNPRV)
DO FILE^DIE("E","IBLNPRV")
QUIT
End DoDot:1
CR5 SET DIXR=985
+1 KILL X
+2 SET DIKZ(0)=$GET(^DGCR(399,DA,0))
+3 SET X(1)=$PIECE(DIKZ(0),U,19)
+4 SET X=$GET(X(1))
+5 Begin DoDot:1
+6 KILL X1,X2
MERGE X1=X,X2=X
+7 NEW DIKXARR
MERGE DIKXARR=X
SET DIKCOND=1
+8 SET X=X(1)=3
+9 SET DIKCOND=$GET(X)
KILL X
MERGE X=DIKXARR
+10 if 'DIKCOND
QUIT
+11 DO REMOVE^IBCEU7(DA,X(1))
End DoDot:1
CR6 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 DO CMAEDALL^IBCU9(DA)
End DoDot:1
CR7 KILL X
END GOTO ^IBXX21
