IBXA1 ; COMPILED XREF FOR FILE #350 ; 02/28/23
;
S DIKZK=2
S DIKZ(0)=$G(^IB(DA,0))
S X=$P($G(DIKZ(0)),U,2)
I X'="" K ^IB("C",$E(X,1,30),DA)
S X=$P($G(DIKZ(0)),U,2)
I X'="" I $D(^IB(DA,0)),$P(^(0),"^",17) K ^IB("AFDT",X,-$P(^(0),"^",17),DA)
S X=$P($G(DIKZ(0)),U,2)
I X'="" I $D(^IB(DA,1)),$P(^(1),"^",2) K ^IB("APTDT",X,$P(^(1),"^",2),DA)
S X=$P($G(DIKZ(0)),U,2)
I X'="" I $D(^IB(DA,0)),$P(^(0),U,5)=8 K ^IB("AH",X,DA)
S X=$P($G(DIKZ(0)),U,2)
I X'="" I $D(^IB(DA,0)),$P(^(0),U,5)=99 K ^IB("AI",X,DA)
S X=$P($G(DIKZ(0)),U,2)
I X'="" I X,$D(^IB(DA,1)),$P(^(1),"^",5) K ^IB("ACVA",X,$P(^(1),"^",5),DA)
S X=$P($G(DIKZ(0)),U,2)
I X'="" K ^IB("AJ",X,DA)
S X=$P($G(DIKZ(0)),U,2)
I X'="" I $D(^IB(DA,1)),$P(^IB(DA,1),U,6) K ^IB("AHDT",X,+$P(^IB(DA,0),U,5),$P(^IB(DA,1),U,6),DA)
S X=$P($G(DIKZ(0)),U,3)
I X'="" K ^IB("AE",$E(X,1,30),DA)
S X=$P($G(DIKZ(0)),U,5)
I X'="" K ^IB("AC",$E(X,1,30),DA)
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(1)=$S($D(^IB(D0,1)):^(1),1:"") S X=$P(Y(1),U,3),X=X S DIU=X K Y S X=DIV S X=$S($D(IBDUZ):IBDUZ,$D(DUZ):DUZ,1:.5) S DIH=$G(^IB(DIV(0),1)),DIV=X S $P(^(1),U,3)=DIV,DIH=350,DIG=13 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(1)=$S($D(^IB(D0,1)):^(1),1:"") S X=$P(Y(1),U,4),X=X S DIU=X K Y S X=DIV N %I,%H,% D NOW^%DTC S X=% X ^DD(350,.05,1,3,2.4)
S X=$P($G(DIKZ(0)),U,5)
I X'="" I $D(^IB(DA,0)),$P(^(0),"^",16) K ^IB("ACT",$P(^(0),"^",16),DA)
S X=$P($G(DIKZ(0)),U,5)
I X'="" I $P(^IB(DA,0),U,2) K ^IB("AH",$P(^IB(DA,0),U,2),DA)
S X=$P($G(DIKZ(0)),U,5)
I X'="" I $P(^IB(DA,0),U,2) K ^IB("AI",$P(^IB(DA,0),U,2),DA)
S X=$P($G(DIKZ(0)),U,5)
I X'="" I $P(^IB(DA,0),U,2) K ^IB("AJ",$P(^IB(DA,0),U,2),DA)
S X=$P($G(DIKZ(0)),U,5)
I X'="" I $D(^IB(DA,1)),$P(^IB(DA,1),U,6) K ^IB("AHDT",+$P(^IB(DA,0),U,2),X,$P(^IB(DA,1),U,6),DA)
S DIKZ(0)=$G(^IB(DA,0))
S X=$P($G(DIKZ(0)),U,9)
I X'="" K ^IB("AD",$E(X,1,30),DA)
S X=$P($G(DIKZ(0)),U,9)
I X'="" I $D(^IB(DA,1)),$P(^(1),"^",2) K ^IB("APDT",$E(X,1,30),-$P(^(1),"^",2),DA)
S X=$P($G(DIKZ(0)),U,11)
I X'="" K ^IB("ABIL",$E(X,1,30),DA)
S X=$P($G(DIKZ(0)),U,12)
I X'="" K ^IB("AT",$E(X,1,30),DA)
S X=$P($G(DIKZ(0)),U,16)
I X'="" K ^IB("AF",$E(X,1,30),DA)
S X=$P($G(DIKZ(0)),U,16)
I X'="" K ^IB("ACT",X,DA)
S X=$P($G(DIKZ(0)),U,17)
I X'="" I $D(^IB(DA,0)),$P(^(0),"^",2) K ^IB("AFDT",$P(^(0),"^",2),-X,DA)
S DIKZ(1)=$G(^IB(DA,1))
S X=$P($G(DIKZ(1)),U,2)
I X'="" K ^IB("D",$E(X,1,30),DA)
S X=$P($G(DIKZ(1)),U,2)
I X'="" I $P(^IB(DA,0),"^",9) K ^IB("APDT",$P(^(0),"^",9),-X,DA)
S X=$P($G(DIKZ(1)),U,2)
I X'="" I $D(^IB(DA,0)),$P(^(0),"^",2) K ^IB("APTDT",$P(^(0),"^",2),X,DA)
S X=$P($G(DIKZ(1)),U,5)
I X'="" I X,$D(^IB(DA,0)),$P(^(0),"^",2) K ^IB("ACVA",$P(^(0),"^",2),X,DA)
S X=$P($G(DIKZ(1)),U,6)
I X'="" I $D(^IB(DA,1)),$P(^IB(DA,1),U,6) K ^IB("AHDT",+$P(^IB(DA,0),U,2),+$P(^IB(DA,0),U,5),X,DA)
S X=$P($G(DIKZ(0)),U,1)
I X'="" K ^IB("B",$E(X,1,30),DA)
CR1 S DIXR=1717
K X
S X(1)=$P(DIKZ(0),U,2)
S X(2)=$P(DIKZ(0),U,17)
S X(3)=$P(DIKZ(0),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))=""
. D KACHDT^IBAUTL10
CR2 K X
END Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBXA1 3269 printed Dec 13, 2024@02:29:27 Page 2
IBXA1 ; COMPILED XREF FOR FILE #350 ; 02/28/23
+1 ;
+2 SET DIKZK=2
+3 SET DIKZ(0)=$GET(^IB(DA,0))
+4 SET X=$PIECE($GET(DIKZ(0)),U,2)
+5 IF X'=""
KILL ^IB("C",$EXTRACT(X,1,30),DA)
+6 SET X=$PIECE($GET(DIKZ(0)),U,2)
+7 IF X'=""
IF $DATA(^IB(DA,0))
IF $PIECE(^(0),"^",17)
KILL ^IB("AFDT",X,-$PIECE(^(0),"^",17),DA)
+8 SET X=$PIECE($GET(DIKZ(0)),U,2)
+9 IF X'=""
IF $DATA(^IB(DA,1))
IF $PIECE(^(1),"^",2)
KILL ^IB("APTDT",X,$PIECE(^(1),"^",2),DA)
+10 SET X=$PIECE($GET(DIKZ(0)),U,2)
+11 IF X'=""
IF $DATA(^IB(DA,0))
IF $PIECE(^(0),U,5)=8
KILL ^IB("AH",X,DA)
+12 SET X=$PIECE($GET(DIKZ(0)),U,2)
+13 IF X'=""
IF $DATA(^IB(DA,0))
IF $PIECE(^(0),U,5)=99
KILL ^IB("AI",X,DA)
+14 SET X=$PIECE($GET(DIKZ(0)),U,2)
+15 IF X'=""
IF X
IF $DATA(^IB(DA,1))
IF $PIECE(^(1),"^",5)
KILL ^IB("ACVA",X,$PIECE(^(1),"^",5),DA)
+16 SET X=$PIECE($GET(DIKZ(0)),U,2)
+17 IF X'=""
KILL ^IB("AJ",X,DA)
+18 SET X=$PIECE($GET(DIKZ(0)),U,2)
+19 IF X'=""
IF $DATA(^IB(DA,1))
IF $PIECE(^IB(DA,1),U,6)
KILL ^IB("AHDT",X,+$PIECE(^IB(DA,0),U,5),$PIECE(^IB(DA,1),U,6),DA)
+20 SET X=$PIECE($GET(DIKZ(0)),U,3)
+21 IF X'=""
KILL ^IB("AE",$EXTRACT(X,1,30),DA)
+22 SET X=$PIECE($GET(DIKZ(0)),U,5)
+23 IF X'=""
KILL ^IB("AC",$EXTRACT(X,1,30),DA)
+24 SET X=$PIECE($GET(DIKZ(0)),U,5)
+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(^IB(D0,1)):^(1),1:"")
SET X=$PIECE(Y(1),U,3)
SET X=X
SET DIU=X
KILL Y
SET X=DIV
SET X=$SELECT($DATA(IBDUZ):IBDUZ,$DATA(DUZ):DUZ,1:.5)
SET DIH=$GET(^IB(DIV(0),1))
SET DIV=X
SET $PIECE(^(1),U,3)=DIV
SET DIH=350
SET DIG=13
DO ^DICR
End DoDot:1
+28 SET X=$PIECE($GET(DIKZ(0)),U,5)
+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(^IB(D0,1)):^(1),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
SET X=%
XECUTE ^DD(350,.05,1,3,2.4)
End DoDot:1
+32 SET X=$PIECE($GET(DIKZ(0)),U,5)
+33 IF X'=""
IF $DATA(^IB(DA,0))
IF $PIECE(^(0),"^",16)
KILL ^IB("ACT",$PIECE(^(0),"^",16),DA)
+34 SET X=$PIECE($GET(DIKZ(0)),U,5)
+35 IF X'=""
IF $PIECE(^IB(DA,0),U,2)
KILL ^IB("AH",$PIECE(^IB(DA,0),U,2),DA)
+36 SET X=$PIECE($GET(DIKZ(0)),U,5)
+37 IF X'=""
IF $PIECE(^IB(DA,0),U,2)
KILL ^IB("AI",$PIECE(^IB(DA,0),U,2),DA)
+38 SET X=$PIECE($GET(DIKZ(0)),U,5)
+39 IF X'=""
IF $PIECE(^IB(DA,0),U,2)
KILL ^IB("AJ",$PIECE(^IB(DA,0),U,2),DA)
+40 SET X=$PIECE($GET(DIKZ(0)),U,5)
+41 IF X'=""
IF $DATA(^IB(DA,1))
IF $PIECE(^IB(DA,1),U,6)
KILL ^IB("AHDT",+$PIECE(^IB(DA,0),U,2),X,$PIECE(^IB(DA,1),U,6),DA)
+42 SET DIKZ(0)=$GET(^IB(DA,0))
+43 SET X=$PIECE($GET(DIKZ(0)),U,9)
+44 IF X'=""
KILL ^IB("AD",$EXTRACT(X,1,30),DA)
+45 SET X=$PIECE($GET(DIKZ(0)),U,9)
+46 IF X'=""
IF $DATA(^IB(DA,1))
IF $PIECE(^(1),"^",2)
KILL ^IB("APDT",$EXTRACT(X,1,30),-$PIECE(^(1),"^",2),DA)
+47 SET X=$PIECE($GET(DIKZ(0)),U,11)
+48 IF X'=""
KILL ^IB("ABIL",$EXTRACT(X,1,30),DA)
+49 SET X=$PIECE($GET(DIKZ(0)),U,12)
+50 IF X'=""
KILL ^IB("AT",$EXTRACT(X,1,30),DA)
+51 SET X=$PIECE($GET(DIKZ(0)),U,16)
+52 IF X'=""
KILL ^IB("AF",$EXTRACT(X,1,30),DA)
+53 SET X=$PIECE($GET(DIKZ(0)),U,16)
+54 IF X'=""
KILL ^IB("ACT",X,DA)
+55 SET X=$PIECE($GET(DIKZ(0)),U,17)
+56 IF X'=""
IF $DATA(^IB(DA,0))
IF $PIECE(^(0),"^",2)
KILL ^IB("AFDT",$PIECE(^(0),"^",2),-X,DA)
+57 SET DIKZ(1)=$GET(^IB(DA,1))
+58 SET X=$PIECE($GET(DIKZ(1)),U,2)
+59 IF X'=""
KILL ^IB("D",$EXTRACT(X,1,30),DA)
+60 SET X=$PIECE($GET(DIKZ(1)),U,2)
+61 IF X'=""
IF $PIECE(^IB(DA,0),"^",9)
KILL ^IB("APDT",$PIECE(^(0),"^",9),-X,DA)
+62 SET X=$PIECE($GET(DIKZ(1)),U,2)
+63 IF X'=""
IF $DATA(^IB(DA,0))
IF $PIECE(^(0),"^",2)
KILL ^IB("APTDT",$PIECE(^(0),"^",2),X,DA)
+64 SET X=$PIECE($GET(DIKZ(1)),U,5)
+65 IF X'=""
IF X
IF $DATA(^IB(DA,0))
IF $PIECE(^(0),"^",2)
KILL ^IB("ACVA",$PIECE(^(0),"^",2),X,DA)
+66 SET X=$PIECE($GET(DIKZ(1)),U,6)
+67 IF X'=""
IF $DATA(^IB(DA,1))
IF $PIECE(^IB(DA,1),U,6)
KILL ^IB("AHDT",+$PIECE(^IB(DA,0),U,2),+$PIECE(^IB(DA,0),U,5),X,DA)
+68 SET X=$PIECE($GET(DIKZ(0)),U,1)
+69 IF X'=""
KILL ^IB("B",$EXTRACT(X,1,30),DA)
CR1 SET DIXR=1717
+1 KILL X
+2 SET X(1)=$PIECE(DIKZ(0),U,2)
+3 SET X(2)=$PIECE(DIKZ(0),U,17)
+4 SET X(3)=$PIECE(DIKZ(0),U,14)
+5 SET X=$GET(X(1))
+6 Begin DoDot:1
+7 KILL X1,X2
MERGE X1=X,X2=X
+8 if $DATA(DIKIL)
SET (X2,X2(1),X2(2),X2(3))=""
+9 DO KACHDT^IBAUTL10
End DoDot:1
CR2 KILL X
END QUIT
