IBXX ; DRIVER FOR COMPILED XREFS FOR FILE #399 ; 10/03/23
;
N DH,DU,DIKILL,DISET,DIKJ,DIKZ,DIKYR,DIKZA,DIK0Z,DIKZK,DIKDP,DIKM1,DIKUP,DIKUM,DV,DIIX,DIKF,DIAU,DIKNM,DIKDA,DIKLK,DIKLM,DIKY,DIXR,DIKCOND,DIKSVDA,DIKPUSH,X1,X2
I '$D(DIKSAT) S DIKLK=DIK_DA_")" L +@DIKLK:10 K:'$T DIKLK
D DI I '$D(DIKSAT),$D(DIKLK) L -@DIKLK
G Q
DI S DIKM1=0,DIKUM=0,DA(0)="",DV=0 F S DV=$O(DA(DV)) Q:DV'>0 S DIKUM=DIKUM+1,DIKUP(DV)=DA(DV)
S:DV="" DV=-1 S DH(1)=399,DIKUP=DA
I $D(DIKKS) D:DIKZ1=DH(1) ^IBXX1 S DA=DIKUP D:DIKZ1=DH(1) ^IBXX19 D:DIKZ1'=DH(1) KILL D:DIKZ1'=DH(1) DA D:DIKZ1'=DH(1) SET D DA Q
I $D(DIKIL) D:DIKZ1=DH(1) ^IBXX1 S:DIKZ1=DH(1) DIKM1=1 D:DIKZ1'=DH(1) KILL S DA=DIKUP D:DIKM1>0 KIL1 D DA Q
I $D(DIKST) D:DIKZ1=DH(1) ^IBXX19 D:DIKZ1'=DH(1) SET D DA Q
I $D(DIKSAT) D SET1 D DA Q
Q
DA K DA F DV=1:1 Q:'$D(DIKUP(DV)) S DA(DV)=DIKUP(DV)
S DA=DIKUP Q
SET1 S (DA,DCNT)=0
S DU=$E(DIK,1,$L(DIK)-1),DIKLK=$S(DIK[",":DU_")",1:DU) L +@DIKLK:10 K:'$T DIKLK
C I @("$O("_DIK_"DA))'>0") S DA=$$C1(DA),^(0)=$P(@(DIK_"0)"),U,1,2)_U_DA_U_DCNT K DCNT L:$D(DIKLK) -@DIKLK Q
S (DIKY,DA)=$O(^(DA)) G C:$P($G(^(DA,0)),U)']"" S DU=1,DCNT=DCNT+1 S:DA="" (DIKY,DA)=-1 D:DIKZ1=DH(1) ^IBXX19 D:DIKZ1'=DH(1) SET D:DIKZ1'=DH(1) DA K DB(0) S DA=DIKY G C
Q
C1(A) Q:$P($G(@(DIK_"A,0)")),U)]"" A
F S @("A=+$O("_DIK_"A),-1)") Q:$P($G(@(DIK_"A,0)")),U)]""!(A'>0)
Q A
KILL S DIKILL=1,DIKZK=2
I DIKZ1=399.0222,DIKUM'<1 S DIKM1=1 D A1^IBXX2 Q
I DIKZ1=399.0292,DIKUM'<1 S DIKM1=1 D A1^IBXX3 Q
I DIKZ1=399.0304,DIKUM'<1 S DIKM1=1 D A1^IBXX4,A1^IBXX16,A1^IBXX17,A1^IBXX18 Q
I DIKZ1=399.0404,DIKUM'<2 S DIKM1=2 D A1^IBXX16 Q
I DIKZ1=399.041,DIKUM'<1 S DIKM1=1 D A1^IBXX5 Q
I DIKZ1=399.042,DIKUM'<1 S DIKM1=1 D A1^IBXX6 Q
I DIKZ1=399.043,DIKUM'<1 S DIKM1=1 D A1^IBXX7 Q
I DIKZ1=399.044,DIKUM'<1 S DIKM1=1 D A1^IBXX8 Q
I DIKZ1=399.045,DIKUM'<1 S DIKM1=1 D A1^IBXX9 Q
I DIKZ1=399.046,DIKUM'<1 S DIKM1=1 D A1^IBXX10 Q
I DIKZ1=399.047,DIKUM'<1 S DIKM1=1 D A1^IBXX11 Q
I DIKZ1=399.048,DIKUM'<1 S DIKM1=1 D A1^IBXX12 Q
I DIKZ1=399.077,DIKUM'<1 S DIKM1=1 D A1^IBXX13 Q
I DIKZ1=399.078,DIKUM'<1 S DIKM1=1 D A1^IBXX14 Q
I DIKZ1=399.096,DIKUM'<1 S DIKM1=1 D A1^IBXX15 Q
I DIKZ1=399.30416,DIKUM'<2 S DIKM1=2 D A1^IBXX17 Q
I DIKZ1=399.30491,DIKUM'<2 S DIKM1=2 D A1^IBXX18 Q
Q
SET S DISET=1,DIKZK=1 K DIKPUSH
I DIKZ1=399.0222,DIKUM'<1 S DIKM1=1 D A1^IBXX21 Q
I DIKZ1=399.0292,DIKUM'<1 S DIKM1=1 D A1^IBXX22 Q
I DIKZ1=399.0304,DIKUM'<1 S DIKM1=1 D A1^IBXX23,A1^IBXX35,A1^IBXX36,A1^IBXX37 Q
I DIKZ1=399.0404,DIKUM'<2 S DIKM1=2 D A1^IBXX35 Q
I DIKZ1=399.041,DIKUM'<1 S DIKM1=1 D A1^IBXX24 Q
I DIKZ1=399.042,DIKUM'<1 S DIKM1=1 D A1^IBXX25 Q
I DIKZ1=399.043,DIKUM'<1 S DIKM1=1 D A1^IBXX26 Q
I DIKZ1=399.044,DIKUM'<1 S DIKM1=1 D A1^IBXX27 Q
I DIKZ1=399.045,DIKUM'<1 S DIKM1=1 D A1^IBXX28 Q
I DIKZ1=399.046,DIKUM'<1 S DIKM1=1 D A1^IBXX29 Q
I DIKZ1=399.047,DIKUM'<1 S DIKM1=1 D A1^IBXX30 Q
I DIKZ1=399.048,DIKUM'<1 S DIKM1=1 D A1^IBXX31 Q
I DIKZ1=399.077,DIKUM'<1 S DIKM1=1 D A1^IBXX32 Q
I DIKZ1=399.078,DIKUM'<1 S DIKM1=1 D A1^IBXX33 Q
I DIKZ1=399.096,DIKUM'<1 S DIKM1=1 D A1^IBXX34 Q
I DIKZ1=399.30416,DIKUM'<2 S DIKM1=2 D A1^IBXX36 Q
I DIKZ1=399.30491,DIKUM'<2 S DIKM1=2 D A1^IBXX37 Q
Q
KIL1 K @(DIK_"DA)") Q:'$D(^(0))
S Y=^(0),DH=$S($O(^(0))'>0:0,1:$P(Y,U,4)-1),X=$P($P(Y,U,3),U,DH>0) D 3:X=DA
S ^(0)=$P(Y,U,1,2)_U_X_U_DH
Q
Q K DIKGP,DIKZ1 Q
;
3 I X>1,$D(^(X-1)) S X=X-1 Q
S DV=1 F X=X:1 S X=X+DV,DV=DV+1 I $O(^(X))'>0 S DU=X-2,DV=1 Q
L S X=$O(^(DU)) Q:X>0 S DU=DU-DV,DV=DV+1 S:DU<0 DU=0 G L
Q
BUL S DIKOZ=1,DIKZA=$P("CREA^DELE",U,DIKZK)_"TE VALUE"
I $D(^DD(DIKZ1,DIKZZ,1,DIKZR,DIKZA)) W "...(`",^(DIKZA),"` BULLETIN WILL NOT BE TRIGGERED) " Q
END Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBXX 3727 printed Dec 13, 2024@02:32:47 Page 2
IBXX ; DRIVER FOR COMPILED XREFS FOR FILE #399 ; 10/03/23
+1 ;
+2 NEW DH,DU,DIKILL,DISET,DIKJ,DIKZ,DIKYR,DIKZA,DIK0Z,DIKZK,DIKDP,DIKM1,DIKUP,DIKUM,DV,DIIX,DIKF,DIAU,DIKNM,DIKDA,DIKLK,DIKLM,DIKY,DIXR,DIKCOND,DIKSVDA,DIKPUSH,X1,X2
+3 IF '$DATA(DIKSAT)
SET DIKLK=DIK_DA_")"
LOCK +@DIKLK:10
if '$TEST
KILL DIKLK
+4 DO DI
IF '$DATA(DIKSAT)
IF $DATA(DIKLK)
LOCK -@DIKLK
+5 GOTO Q
DI SET DIKM1=0
SET DIKUM=0
SET DA(0)=""
SET DV=0
FOR
SET DV=$ORDER(DA(DV))
if DV'>0
QUIT
SET DIKUM=DIKUM+1
SET DIKUP(DV)=DA(DV)
+1 if DV=""
SET DV=-1
SET DH(1)=399
SET DIKUP=DA
+2 IF $DATA(DIKKS)
if DIKZ1=DH(1)
DO ^IBXX1
SET DA=DIKUP
if DIKZ1=DH(1)
DO ^IBXX19
if DIKZ1'=DH(1)
DO KILL
if DIKZ1'=DH(1)
DO DA
if DIKZ1'=DH(1)
DO SET
DO DA
QUIT
+3 IF $DATA(DIKIL)
if DIKZ1=DH(1)
DO ^IBXX1
if DIKZ1=DH(1)
SET DIKM1=1
if DIKZ1'=DH(1)
DO KILL
SET DA=DIKUP
if DIKM1>0
DO KIL1
DO DA
QUIT
+4 IF $DATA(DIKST)
if DIKZ1=DH(1)
DO ^IBXX19
if DIKZ1'=DH(1)
DO SET
DO DA
QUIT
+5 IF $DATA(DIKSAT)
DO SET1
DO DA
QUIT
+6 QUIT
DA KILL DA
FOR DV=1:1
if '$DATA(DIKUP(DV))
QUIT
SET DA(DV)=DIKUP(DV)
+1 SET DA=DIKUP
QUIT
SET1 SET (DA,DCNT)=0
+1 SET DU=$EXTRACT(DIK,1,$LENGTH(DIK)-1)
SET DIKLK=$SELECT(DIK[",":DU_")",1:DU)
LOCK +@DIKLK:10
if '$TEST
KILL DIKLK
C IF @("$O("_DIK_"DA))'>0")
SET DA=$$C1(DA)
SET ^(0)=$PIECE(@(DIK_"0)"),U,1,2)_U_DA_U_DCNT
KILL DCNT
if $DATA(DIKLK)
LOCK -@DIKLK
QUIT
+1 SET (DIKY,DA)=$ORDER(^(DA))
if $PIECE($GET(^(DA,0)),U)']""
GOTO C
SET DU=1
SET DCNT=DCNT+1
if DA=""
SET (DIKY,DA)=-1
if DIKZ1=DH(1)
DO ^IBXX19
if DIKZ1'=DH(1)
DO SET
if DIKZ1'=DH(1)
DO DA
KILL DB(0)
SET DA=DIKY
GOTO C
+2 QUIT
C1(A) if $PIECE($GET(@(DIK_"A,0)")),U)]""
QUIT A
+1 FOR
SET @("A=+$O("_DIK_"A),-1)")
if $PIECE($GET(@(DIK_"A,0)")),U)]""!(A'>0)
QUIT
+2 QUIT A
KILL SET DIKILL=1
SET DIKZK=2
+1 IF DIKZ1=399.0222
IF DIKUM'<1
SET DIKM1=1
DO A1^IBXX2
QUIT
+2 IF DIKZ1=399.0292
IF DIKUM'<1
SET DIKM1=1
DO A1^IBXX3
QUIT
+3 IF DIKZ1=399.0304
IF DIKUM'<1
SET DIKM1=1
DO A1^IBXX4
DO A1^IBXX16
DO A1^IBXX17
DO A1^IBXX18
QUIT
+4 IF DIKZ1=399.0404
IF DIKUM'<2
SET DIKM1=2
DO A1^IBXX16
QUIT
+5 IF DIKZ1=399.041
IF DIKUM'<1
SET DIKM1=1
DO A1^IBXX5
QUIT
+6 IF DIKZ1=399.042
IF DIKUM'<1
SET DIKM1=1
DO A1^IBXX6
QUIT
+7 IF DIKZ1=399.043
IF DIKUM'<1
SET DIKM1=1
DO A1^IBXX7
QUIT
+8 IF DIKZ1=399.044
IF DIKUM'<1
SET DIKM1=1
DO A1^IBXX8
QUIT
+9 IF DIKZ1=399.045
IF DIKUM'<1
SET DIKM1=1
DO A1^IBXX9
QUIT
+10 IF DIKZ1=399.046
IF DIKUM'<1
SET DIKM1=1
DO A1^IBXX10
QUIT
+11 IF DIKZ1=399.047
IF DIKUM'<1
SET DIKM1=1
DO A1^IBXX11
QUIT
+12 IF DIKZ1=399.048
IF DIKUM'<1
SET DIKM1=1
DO A1^IBXX12
QUIT
+13 IF DIKZ1=399.077
IF DIKUM'<1
SET DIKM1=1
DO A1^IBXX13
QUIT
+14 IF DIKZ1=399.078
IF DIKUM'<1
SET DIKM1=1
DO A1^IBXX14
QUIT
+15 IF DIKZ1=399.096
IF DIKUM'<1
SET DIKM1=1
DO A1^IBXX15
QUIT
+16 IF DIKZ1=399.30416
IF DIKUM'<2
SET DIKM1=2
DO A1^IBXX17
QUIT
+17 IF DIKZ1=399.30491
IF DIKUM'<2
SET DIKM1=2
DO A1^IBXX18
QUIT
+18 QUIT
SET SET DISET=1
SET DIKZK=1
KILL DIKPUSH
+1 IF DIKZ1=399.0222
IF DIKUM'<1
SET DIKM1=1
DO A1^IBXX21
QUIT
+2 IF DIKZ1=399.0292
IF DIKUM'<1
SET DIKM1=1
DO A1^IBXX22
QUIT
+3 IF DIKZ1=399.0304
IF DIKUM'<1
SET DIKM1=1
DO A1^IBXX23
DO A1^IBXX35
DO A1^IBXX36
DO A1^IBXX37
QUIT
+4 IF DIKZ1=399.0404
IF DIKUM'<2
SET DIKM1=2
DO A1^IBXX35
QUIT
+5 IF DIKZ1=399.041
IF DIKUM'<1
SET DIKM1=1
DO A1^IBXX24
QUIT
+6 IF DIKZ1=399.042
IF DIKUM'<1
SET DIKM1=1
DO A1^IBXX25
QUIT
+7 IF DIKZ1=399.043
IF DIKUM'<1
SET DIKM1=1
DO A1^IBXX26
QUIT
+8 IF DIKZ1=399.044
IF DIKUM'<1
SET DIKM1=1
DO A1^IBXX27
QUIT
+9 IF DIKZ1=399.045
IF DIKUM'<1
SET DIKM1=1
DO A1^IBXX28
QUIT
+10 IF DIKZ1=399.046
IF DIKUM'<1
SET DIKM1=1
DO A1^IBXX29
QUIT
+11 IF DIKZ1=399.047
IF DIKUM'<1
SET DIKM1=1
DO A1^IBXX30
QUIT
+12 IF DIKZ1=399.048
IF DIKUM'<1
SET DIKM1=1
DO A1^IBXX31
QUIT
+13 IF DIKZ1=399.077
IF DIKUM'<1
SET DIKM1=1
DO A1^IBXX32
QUIT
+14 IF DIKZ1=399.078
IF DIKUM'<1
SET DIKM1=1
DO A1^IBXX33
QUIT
+15 IF DIKZ1=399.096
IF DIKUM'<1
SET DIKM1=1
DO A1^IBXX34
QUIT
+16 IF DIKZ1=399.30416
IF DIKUM'<2
SET DIKM1=2
DO A1^IBXX36
QUIT
+17 IF DIKZ1=399.30491
IF DIKUM'<2
SET DIKM1=2
DO A1^IBXX37
QUIT
+18 QUIT
KIL1 KILL @(DIK_"DA)")
if '$DATA(^(0))
QUIT
+1 SET Y=^(0)
SET DH=$SELECT($ORDER(^(0))'>0:0,1:$PIECE(Y,U,4)-1)
SET X=$PIECE($PIECE(Y,U,3),U,DH>0)
if X=DA
DO 3
+2 SET ^(0)=$PIECE(Y,U,1,2)_U_X_U_DH
+3 QUIT
Q KILL DIKGP,DIKZ1
QUIT
+1 ;
3 IF X>1
IF $DATA(^(X-1))
SET X=X-1
QUIT
+1 SET DV=1
FOR X=X:1
SET X=X+DV
SET DV=DV+1
IF $ORDER(^(X))'>0
SET DU=X-2
SET DV=1
QUIT
L SET X=$ORDER(^(DU))
if X>0
QUIT
SET DU=DU-DV
SET DV=DV+1
if DU<0
SET DU=0
GOTO L
+1 QUIT
BUL SET DIKOZ=1
SET DIKZA=$PIECE("CREA^DELE",U,DIKZK)_"TE VALUE"
+1 IF $DATA(^DD(DIKZ1,DIKZZ,1,DIKZR,DIKZA))
WRITE "...(`",^(DIKZA),"` BULLETIN WILL NOT BE TRIGGERED) "
QUIT
END QUIT
