IBXA2 ; COMPILED XREF FOR FILE #350 ; 02/28/23
;
S DIKZK=1
S DIKZ(0)=$G(^IB(DA,0))
S X=$P($G(DIKZ(0)),U,1)
I X'="" S ^IB("B",$E(X,1,30),DA)=""
S X=$P($G(DIKZ(0)),U,2)
I X'="" S ^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) S ^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) S ^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 S ^IB("AH",X,DA)=""
S X=$P($G(DIKZ(0)),U,2)
I X'="" I $D(^IB(DA,0)),$P(^(0),U,5)=99 S ^IB("AI",X,DA)=""
S X=$P($G(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($G(DIKZ(0)),U,2)
I X'="" I $D(^IB(DA,0)),$P(^(0),U,5)=21 S ^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) S ^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'="" S ^IB("AE",$E(X,1,30),DA)=""
S X=$P($G(DIKZ(0)),U,5)
I X'="" S ^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,1.4)
S X=$P($G(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($G(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($G(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 X=$P($G(DIKZ(0)),U,5)
I X'="" I X=21,$P(^IB(DA,0),U,2) S ^IB("AJ",$P(^IB(DA,0),U,2),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(0)=X I X=8 I X S X=DIV S Y(1)=$S($D(^IB(D0,1)):^(1),1:"") S X=$P(Y(1),U,6),X=X S DIU=X K Y S X=DIV N %I,%H,% D NOW^%DTC X ^DD(350,.05,1,8,1.4)
S X=$P($G(DIKZ(0)),U,5)
I X'="" I $D(^IB(DA,1)),$P(^IB(DA,1),U,6) S ^IB("AHDT",+$P(^IB(DA,0),U,2),X,$P(^IB(DA,1),U,6),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(0)=X S X=$P($G(^IBE(350.21,+Y(0),0)),U)="HOLD - REVIEW" I X S X=DIV S Y(1)=$S($D(^IB(D0,1)):^(1),1:"") S X=$P(Y(1),U,7),X=X S DIU=X K Y S X=DIV N %I,%H,% D NOW^%DTC X ^DD(350,.05,1,10,1.4)
S DIKZ(0)=$G(^IB(DA,0))
S X=$P($G(DIKZ(0)),U,9)
I X'="" S ^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) S ^IB("APDT",$E(X,1,30),-$P(^(1),"^",2),DA)=""
S X=$P($G(DIKZ(0)),U,11)
I X'="" S ^IB("ABIL",$E(X,1,30),DA)=""
S X=$P($G(DIKZ(0)),U,12)
I X'="" S ^IB("AT",$E(X,1,30),DA)=""
S X=$P($G(DIKZ(0)),U,16)
I X'="" S ^IB("AF",$E(X,1,30),DA)=""
S X=$P($G(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($G(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($G(DIKZ(1)),U,2)
I X'="" S ^IB("D",$E(X,1,30),DA)=""
S X=$P($G(DIKZ(1)),U,2)
I X'="" I $P(^IB(DA,0),"^",9) S ^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) S ^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) S ^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) S ^IB("AHDT",+$P(^IB(DA,0),U,2),+$P(^IB(DA,0),U,5),X,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
. D SACHDT^IBAUTL10
CR2 K X
END Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBXA2 4033 printed Dec 13, 2024@02:29:28 Page 2
IBXA2 ; COMPILED XREF FOR FILE #350 ; 02/28/23
+1 ;
+2 SET DIKZK=1
+3 SET DIKZ(0)=$GET(^IB(DA,0))
+4 SET X=$PIECE($GET(DIKZ(0)),U,1)
+5 IF X'=""
SET ^IB("B",$EXTRACT(X,1,30),DA)=""
+6 SET X=$PIECE($GET(DIKZ(0)),U,2)
+7 IF X'=""
SET ^IB("C",$EXTRACT(X,1,30),DA)=""
+8 SET X=$PIECE($GET(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($GET(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($GET(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($GET(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($GET(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($GET(DIKZ(0)),U,2)
+19 IF X'=""
IF $DATA(^IB(DA,0))
IF $PIECE(^(0),U,5)=21
SET ^IB("AJ",X,DA)=""
+20 SET X=$PIECE($GET(DIKZ(0)),U,2)
+21 IF X'=""
IF $DATA(^IB(DA,1))
IF $PIECE(^IB(DA,1),U,6)
SET ^IB("AHDT",X,+$PIECE(^IB(DA,0),U,5),$PIECE(^IB(DA,1),U,6),DA)=""
+22 SET X=$PIECE($GET(DIKZ(0)),U,3)
+23 IF X'=""
SET ^IB("AE",$EXTRACT(X,1,30),DA)=""
+24 SET X=$PIECE($GET(DIKZ(0)),U,5)
+25 IF X'=""
SET ^IB("AC",$EXTRACT(X,1,30),DA)=""
+26 SET X=$PIECE($GET(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,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
+30 SET X=$PIECE($GET(DIKZ(0)),U,5)
+31 IF X'=""
Begin DoDot:1
+32 NEW DIK,DIV,DIU,DIN
+33 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,1.4)
End DoDot:1
+34 SET X=$PIECE($GET(DIKZ(0)),U,5)
+35 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)=""
+36 SET X=$PIECE($GET(DIKZ(0)),U,5)
+37 IF X'=""
IF X=8
IF $PIECE(^IB(DA,0),U,2)
SET ^IB("AH",$PIECE(^IB(DA,0),U,2),DA)=""
+38 SET X=$PIECE($GET(DIKZ(0)),U,5)
+39 IF X'=""
IF X=99
IF $PIECE(^IB(DA,0),U,2)
SET ^IB("AI",$PIECE(^IB(DA,0),U,2),DA)=""
+40 SET X=$PIECE($GET(DIKZ(0)),U,5)
+41 IF X'=""
IF X=21
IF $PIECE(^IB(DA,0),U,2)
SET ^IB("AJ",$PIECE(^IB(DA,0),U,2),DA)=""
+42 SET X=$PIECE($GET(DIKZ(0)),U,5)
+43 IF X'=""
Begin DoDot:1
+44 NEW DIK,DIV,DIU,DIN
+45 KILL DIV
SET DIV=X
SET D0=DA
SET DIV(0)=D0
SET Y(0)=X
IF X=8
IF X
SET X=DIV
SET Y(1)=$SELECT($DATA(^IB(D0,1)):^(1),1:"")
SET X=$PIECE(Y(1),U,6)
SET X=X
SET DIU=X
KILL Y
SET X=DIV
NEW %I,%H,%
DO NOW^%DTC
XECUTE ^DD(350,.05,1,8,1.4)
End DoDot:1
+46 SET X=$PIECE($GET(DIKZ(0)),U,5)
+47 IF X'=""
IF $DATA(^IB(DA,1))
IF $PIECE(^IB(DA,1),U,6)
SET ^IB("AHDT",+$PIECE(^IB(DA,0),U,2),X,$PIECE(^IB(DA,1),U,6),DA)=""
+48 SET X=$PIECE($GET(DIKZ(0)),U,5)
+49 IF X'=""
Begin DoDot:1
+50 NEW DIK,DIV,DIU,DIN
+51 KILL DIV
SET DIV=X
SET D0=DA
SET DIV(0)=D0
SET Y(0)=X
SET X=$PIECE($GET(^IBE(350.21,+Y(0),0)),U)="HOLD - REVIEW"
IF X
SET X=DIV
SET Y(1)=$SELECT($DATA(^IB(D0,1)):^(1),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
XECUTE ^DD(350,.05,1,10,1.4)
End DoDot:1
+52 SET DIKZ(0)=$GET(^IB(DA,0))
+53 SET X=$PIECE($GET(DIKZ(0)),U,9)
+54 IF X'=""
SET ^IB("AD",$EXTRACT(X,1,30),DA)=""
+55 SET X=$PIECE($GET(DIKZ(0)),U,9)
+56 IF X'=""
IF $DATA(^IB(DA,1))
IF $PIECE(^(1),"^",2)
SET ^IB("APDT",$EXTRACT(X,1,30),-$PIECE(^(1),"^",2),DA)=""
+57 SET X=$PIECE($GET(DIKZ(0)),U,11)
+58 IF X'=""
SET ^IB("ABIL",$EXTRACT(X,1,30),DA)=""
+59 SET X=$PIECE($GET(DIKZ(0)),U,12)
+60 IF X'=""
SET ^IB("AT",$EXTRACT(X,1,30),DA)=""
+61 SET X=$PIECE($GET(DIKZ(0)),U,16)
+62 IF X'=""
SET ^IB("AF",$EXTRACT(X,1,30),DA)=""
+63 SET X=$PIECE($GET(DIKZ(0)),U,16)
+64 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)=""
+65 SET X=$PIECE($GET(DIKZ(0)),U,17)
+66 IF X'=""
IF $DATA(^IB(DA,0))
IF $PIECE(^(0),"^",2)
SET ^IB("AFDT",$PIECE(^(0),"^",2),-X,DA)=""
+67 SET DIKZ(1)=$GET(^IB(DA,1))
+68 SET X=$PIECE($GET(DIKZ(1)),U,2)
+69 IF X'=""
SET ^IB("D",$EXTRACT(X,1,30),DA)=""
+70 SET X=$PIECE($GET(DIKZ(1)),U,2)
+71 IF X'=""
IF $PIECE(^IB(DA,0),"^",9)
SET ^IB("APDT",$PIECE(^(0),"^",9),-X,DA)=""
+72 SET X=$PIECE($GET(DIKZ(1)),U,2)
+73 IF X'=""
IF $DATA(^IB(DA,0))
IF $PIECE(^(0),"^",2)
SET ^IB("APTDT",$PIECE(^(0),"^",2),X,DA)=""
+74 SET X=$PIECE($GET(DIKZ(1)),U,5)
+75 IF X'=""
IF X
IF $DATA(^IB(DA,0))
IF $PIECE(^(0),"^",2)
SET ^IB("ACVA",$PIECE(^(0),"^",2),X,DA)=""
+76 SET X=$PIECE($GET(DIKZ(1)),U,6)
+77 IF X'=""
IF $DATA(^IB(DA,1))
IF $PIECE(^IB(DA,1),U,6)
SET ^IB("AHDT",+$PIECE(^IB(DA,0),U,2),+$PIECE(^IB(DA,0),U,5),X,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 DO SACHDT^IBAUTL10
End DoDot:1
CR2 KILL X
END QUIT
