IBXST2 ; ;10/29/04
S X=DG(DQ),DIC=DIE
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 S X=DT X ^DD(399,12,1,1,1.4)
S X=DG(DQ),DIC=DIE
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=DG(DQ),DIC=DIE
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=DG(DQ),DIC=DIE
S ^DGCR(399,"AP",$E(X,1,30),DA)=""
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBXST2 804 printed Dec 13, 2024@02:32:42 Page 2
IBXST2 ; ;10/29/04
+1 SET X=DG(DQ)
SET DIC=DIE
+2 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
SET X=DT
XECUTE ^DD(399,12,1,1,1.4)
+3 SET X=DG(DQ)
SET DIC=DIE
+4 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
+5 SET X=DG(DQ)
SET DIC=DIE
+6 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
+7 SET X=DG(DQ)
SET DIC=DIE
+8 SET ^DGCR(399,"AP",$EXTRACT(X,1,30),DA)=""
