- 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 Feb 18, 2025@23:59:15 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