- IBDX4 ; DRIVER FOR COMPILED XREFS FOR FILE #357.4 ; 10/15/04
- ;
- 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)=357.4,DIKUP=DA
- I $D(DIKKS) D:DIKZ1=DH(1) ^IBDX41 S DA=DIKUP D:DIKZ1=DH(1) ^IBDX42 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) ^IBDX41 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) ^IBDX42 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) ^IBDX42 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
- Q
- SET S DISET=1,DIKZK=1 K DIKPUSH
- 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[HIBDX4 1932 printed Jan 18, 2025@03:55:46 Page 2
- IBDX4 ; DRIVER FOR COMPILED XREFS FOR FILE #357.4 ; 10/15/04
- +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)=357.4
- SET DIKUP=DA
- +2 IF $DATA(DIKKS)
- if DIKZ1=DH(1)
- DO ^IBDX41
- SET DA=DIKUP
- if DIKZ1=DH(1)
- DO ^IBDX42
- 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 ^IBDX41
- 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 ^IBDX42
- 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 ^IBDX42
- 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 QUIT
- SET SET DISET=1
- SET DIKZK=1
- KILL DIKPUSH
- +1 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