IBXA2 ; COMPILED XREF FOR FILE #350 ; 02/13/06
;
S DIKZK=1
S DIKZ(0)=$G(^IB(DA,0))
S X=$P(DIKZ(0),U,1)
I X'="" S ^IB("B",$E(X,1,30),DA)=""
S X=$P(DIKZ(0),U,2)
I X'="" S ^IB("C",$E(X,1,30),DA)=""
S X=$P(DIKZ(0),U,2)
I X'="" I $D(^IB(DA,0)),$P(^(0),"^",17) S ^IB("AFDT",X,-$P(^(0),"^",17),DA)=""
S X=$P(DIKZ(0),U,2)
I X'="" I $D(^IB(DA,1)),$P(^(1),"^",2) S ^IB("APTDT",X,$P(^(1),"^",2),DA)=""
S X=$P(DIKZ(0),U,2)
I X'="" I $D(^IB(DA,0)),$P(^(0),U,5)=8 S ^IB("AH",X,DA)=""
S X=$P(DIKZ(0),U,2)
I X'="" I $D(^IB(DA,0)),$P(^(0),U,5)=99 S ^IB("AI",X,DA)=""
S X=$P(DIKZ(0),U,2)
I X'="" I X,$D(^IB(DA,1)),$P(^(1),"^",5) S ^IB("ACVA",X,$P(^(1),"^",5),DA)=""
S X=$P(DIKZ(0),U,3)
I X'="" S ^IB("AE",$E(X,1,30),DA)=""
S X=$P(DIKZ(0),U,5)
I X'="" S ^IB("AC",$E(X,1,30),DA)=""
S X=$P(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) X ^DD(350,.05,1,2,1.4)
S X=$P(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 X ^DD(350,.05,1,3,1.1) X ^DD(350,.05,1,3,1.4)
S X=$P(DIKZ(0),U,5)
I X'="" I X=1,$D(^IB(DA,0)),$P($G(^IBE(350.1,+$P(^(0),"^",3),0)),"^")'["ADMISSION",$P(^IB(DA,0),"^",16) S ^IB("ACT",$P(^(0),"^",16),DA)=""
S X=$P(DIKZ(0),U,5)
I X'="" I X=8,$P(^IB(DA,0),U,2) S ^IB("AH",$P(^IB(DA,0),U,2),DA)=""
S X=$P(DIKZ(0),U,5)
I X'="" I X=99,$P(^IB(DA,0),U,2) S ^IB("AI",$P(^IB(DA,0),U,2),DA)=""
S DIKZ(0)=$G(^IB(DA,0))
S X=$P(DIKZ(0),U,9)
I X'="" S ^IB("AD",$E(X,1,30),DA)=""
S X=$P(DIKZ(0),U,9)
I X'="" I $D(^IB(DA,1)),$P(^(1),"^",2) S ^IB("APDT",$E(X,1,30),-$P(^(1),"^",2),DA)=""
S X=$P(DIKZ(0),U,11)
I X'="" S ^IB("ABIL",$E(X,1,30),DA)=""
S X=$P(DIKZ(0),U,12)
I X'="" S ^IB("AT",$E(X,1,30),DA)=""
S X=$P(DIKZ(0),U,16)
I X'="" S ^IB("AF",$E(X,1,30),DA)=""
S X=$P(DIKZ(0),U,16)
I X'="" I $D(^IB(DA,0)),$P(^(0),"^",5)=1,$P($G(^IBE(350.1,+$P(^(0),"^",3),0)),"^")'["ADMISSION" S ^IB("ACT",X,DA)=""
S X=$P(DIKZ(0),U,17)
I X'="" I $D(^IB(DA,0)),$P(^(0),"^",2) S ^IB("AFDT",$P(^(0),"^",2),-X,DA)=""
S DIKZ(1)=$G(^IB(DA,1))
S X=$P(DIKZ(1),U,2)
I X'="" S ^IB("D",$E(X,1,30),DA)=""
S X=$P(DIKZ(1),U,2)
I X'="" I $P(^IB(DA,0),"^",9) S ^IB("APDT",$P(^(0),"^",9),-X,DA)=""
S X=$P(DIKZ(1),U,2)
I X'="" I $D(^IB(DA,0)),$P(^(0),"^",2) S ^IB("APTDT",$P(^(0),"^",2),X,DA)=""
S X=$P(DIKZ(1),U,5)
I X'="" I X,$D(^IB(DA,0)),$P(^(0),"^",2) S ^IB("ACVA",$P(^(0),"^",2),X,DA)=""
END Q
IBXA2 ; COMPILED XREF FOR FILE #350 ; 02/13/06
+1 ;
+2 SET DIKZK=1
+3 SET DIKZ(0)=$GET(^IB(DA,0))
+4 SET X=$PIECE(DIKZ(0),U,1)
+5 IF X'=""
SET ^IB("B",$EXTRACT(X,1,30),DA)=""
+6 SET X=$PIECE(DIKZ(0),U,2)
+7 IF X'=""
SET ^IB("C",$EXTRACT(X,1,30),DA)=""
+8 SET X=$PIECE(DIKZ(0),U,2)
+9 IF X'=""
IF $DATA(^IB(DA,0))
IF $PIECE(^(0),"^",17)
SET ^IB("AFDT",X,-$PIECE(^(0),"^",17),DA)=""
+10 SET X=$PIECE(DIKZ(0),U,2)
+11 IF X'=""
IF $DATA(^IB(DA,1))
IF $PIECE(^(1),"^",2)
SET ^IB("APTDT",X,$PIECE(^(1),"^",2),DA)=""
+12 SET X=$PIECE(DIKZ(0),U,2)
+13 IF X'=""
IF $DATA(^IB(DA,0))
IF $PIECE(^(0),U,5)=8
SET ^IB("AH",X,DA)=""
+14 SET X=$PIECE(DIKZ(0),U,2)
+15 IF X'=""
IF $DATA(^IB(DA,0))
IF $PIECE(^(0),U,5)=99
SET ^IB("AI",X,DA)=""
+16 SET X=$PIECE(DIKZ(0),U,2)
+17 IF X'=""
IF X
IF $DATA(^IB(DA,1))
IF $PIECE(^(1),"^",5)
SET ^IB("ACVA",X,$PIECE(^(1),"^",5),DA)=""
+18 SET X=$PIECE(DIKZ(0),U,3)
+19 IF X'=""
SET ^IB("AE",$EXTRACT(X,1,30),DA)=""
+20 SET X=$PIECE(DIKZ(0),U,5)
+21 IF X'=""
SET ^IB("AC",$EXTRACT(X,1,30),DA)=""
+22 SET X=$PIECE(DIKZ(0),U,5)
+23 IF X'=""
Begin DoDot:1
+24 NEW DIK,DIV,DIU,DIN
+25 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)
XECUTE ^DD(350,.05,1,2,1.4)
End DoDot:1
+26 SET X=$PIECE(DIKZ(0),U,5)
+27 IF X'=""
Begin DoDot:1
+28 NEW DIK,DIV,DIU,DIN
+29 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
XECUTE ^DD(350,.05,1,3,1.1)
XECUTE ^DD(350,.05,1,3,1.4)
End DoDot:1
+30 SET X=$PIECE(DIKZ(0),U,5)
+31 IF X'=""
IF X=1
IF $DATA(^IB(DA,0))
IF $PIECE($GET(^IBE(350.1,+$PIECE(^(0),"^",3),0)),"^")'["ADMISSION"
IF $PIECE(^IB(DA,0),"^",16)
SET ^IB("ACT",$PIECE(^(0),"^",16),DA)=""
+32 SET X=$PIECE(DIKZ(0),U,5)
+33 IF X'=""
IF X=8
IF $PIECE(^IB(DA,0),U,2)
SET ^IB("AH",$PIECE(^IB(DA,0),U,2),DA)=""
+34 SET X=$PIECE(DIKZ(0),U,5)
+35 IF X'=""
IF X=99
IF $PIECE(^IB(DA,0),U,2)
SET ^IB("AI",$PIECE(^IB(DA,0),U,2),DA)=""
+36 SET DIKZ(0)=$GET(^IB(DA,0))
+37 SET X=$PIECE(DIKZ(0),U,9)
+38 IF X'=""
SET ^IB("AD",$EXTRACT(X,1,30),DA)=""
+39 SET X=$PIECE(DIKZ(0),U,9)
+40 IF X'=""
IF $DATA(^IB(DA,1))
IF $PIECE(^(1),"^",2)
SET ^IB("APDT",$EXTRACT(X,1,30),-$PIECE(^(1),"^",2),DA)=""
+41 SET X=$PIECE(DIKZ(0),U,11)
+42 IF X'=""
SET ^IB("ABIL",$EXTRACT(X,1,30),DA)=""
+43 SET X=$PIECE(DIKZ(0),U,12)
+44 IF X'=""
SET ^IB("AT",$EXTRACT(X,1,30),DA)=""
+45 SET X=$PIECE(DIKZ(0),U,16)
+46 IF X'=""
SET ^IB("AF",$EXTRACT(X,1,30),DA)=""
+47 SET X=$PIECE(DIKZ(0),U,16)
+48 IF X'=""
IF $DATA(^IB(DA,0))
IF $PIECE(^(0),"^",5)=1
IF $PIECE($GET(^IBE(350.1,+$PIECE(^(0),"^",3),0)),"^")'["ADMISSION"
SET ^IB("ACT",X,DA)=""
+49 SET X=$PIECE(DIKZ(0),U,17)
+50 IF X'=""
IF $DATA(^IB(DA,0))
IF $PIECE(^(0),"^",2)
SET ^IB("AFDT",$PIECE(^(0),"^",2),-X,DA)=""
+51 SET DIKZ(1)=$GET(^IB(DA,1))
+52 SET X=$PIECE(DIKZ(1),U,2)
+53 IF X'=""
SET ^IB("D",$EXTRACT(X,1,30),DA)=""
+54 SET X=$PIECE(DIKZ(1),U,2)
+55 IF X'=""
IF $PIECE(^IB(DA,0),"^",9)
SET ^IB("APDT",$PIECE(^(0),"^",9),-X,DA)=""
+56 SET X=$PIECE(DIKZ(1),U,2)
+57 IF X'=""
IF $DATA(^IB(DA,0))
IF $PIECE(^(0),"^",2)
SET ^IB("APTDT",$PIECE(^(0),"^",2),X,DA)=""
+58 SET X=$PIECE(DIKZ(1),U,5)
+59 IF X'=""
IF X
IF $DATA(^IB(DA,0))
IF $PIECE(^(0),"^",2)
SET ^IB("ACVA",$PIECE(^(0),"^",2),X,DA)=""
END QUIT
