- PSJXR5 ; DRIVER FOR COMPILED XREFS FOR FILE #55 ; 10/28/97
- ;
- N DH,DU,DIKILL,DISET,DIKJ,DIKZ,DIKYR,DIKZA,DIK0Z,DIKZK,DIKDP,DIKM1,DIKUP,DIKUM,DV,DIIX,DIKF,DIAU,DIKNM,DIKDA,DIKLK,DIKLM,DIKY
- S DIKLK=DIK_DA_")" L @("+"_DIKLK) D DI 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)=55,DIKUP=DA
- I $D(DIKKS) D:DIKZ1=DH(1) ^PSJXR51 S DA=DIKUP D:DIKZ1=DH(1) ^PSJXR511 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) ^PSJXR51 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) ^PSJXR511 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)
- C I @("$O("_DIK_"DA))'>0") S DA=$$C1(DA),^(0)=$P(@(DIK_"0)"),U,1,2)_U_DA_U_DCNT K DCNT L @("-"_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) ^PSJXR511 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=55.01,DIKUM'<1 S DIKM1=1 D A1^PSJXR52,A1^PSJXR56,A1^PSJXR510 Q
- I DIKZ1=55.02,DIKUM'<2 S DIKM1=2 D A1^PSJXR56 Q
- I DIKZ1=55.03,DIKUM'<1 S DIKM1=1 D A1^PSJXR53 Q
- I DIKZ1=55.06,DIKUM'<1 S DIKM1=1 D A1^PSJXR54,A1^PSJXR57,A1^PSJXR58,A1^PSJXR59 Q
- I DIKZ1=55.0611,DIKUM'<2 S DIKM1=2 D A1^PSJXR57 Q
- I DIKZ1=55.07,DIKUM'<2 S DIKM1=2 D A1^PSJXR58 Q
- I DIKZ1=55.09,DIKUM'<2 S DIKM1=2 D A1^PSJXR59 Q
- I DIKZ1=55.11,DIKUM'<2 S DIKM1=2 D A1^PSJXR510 Q
- Q
- SET S DISET=1,DIKZK=1
- I DIKZ1=55.01,DIKUM'<1 S DIKM1=1 D A1^PSJXR512,A1^PSJXR516,A1^PSJXR520 Q
- I DIKZ1=55.02,DIKUM'<2 S DIKM1=2 D A1^PSJXR516 Q
- I DIKZ1=55.03,DIKUM'<1 S DIKM1=1 D A1^PSJXR513 Q
- I DIKZ1=55.06,DIKUM'<1 S DIKM1=1 D A1^PSJXR514,A1^PSJXR517,A1^PSJXR518,A1^PSJXR519 Q
- I DIKZ1=55.0611,DIKUM'<2 S DIKM1=2 D A1^PSJXR517 Q
- I DIKZ1=55.07,DIKUM'<2 S DIKM1=2 D A1^PSJXR518 Q
- I DIKZ1=55.09,DIKUM'<2 S DIKM1=2 D A1^PSJXR519 Q
- I DIKZ1=55.11,DIKUM'<2 S DIKM1=2 D A1^PSJXR520 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[HPSJXR5 2757 printed Mar 13, 2025@21:14:09 Page 2
- PSJXR5 ; DRIVER FOR COMPILED XREFS FOR FILE #55 ; 10/28/97
- +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
- +3 SET DIKLK=DIK_DA_")"
- LOCK @("+"_DIKLK)
- DO DI
- LOCK @("-"_DIKLK)
- 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)=55
- SET DIKUP=DA
- +2 IF $DATA(DIKKS)
- if DIKZ1=DH(1)
- DO ^PSJXR51
- SET DA=DIKUP
- if DIKZ1=DH(1)
- DO ^PSJXR511
- 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 ^PSJXR51
- 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 ^PSJXR511
- 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)
- C IF @("$O("_DIK_"DA))'>0")
- SET DA=$$C1(DA)
- SET ^(0)=$PIECE(@(DIK_"0)"),U,1,2)_U_DA_U_DCNT
- KILL DCNT
- 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 ^PSJXR511
- 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=55.01
- IF DIKUM'<1
- SET DIKM1=1
- DO A1^PSJXR52
- DO A1^PSJXR56
- DO A1^PSJXR510
- QUIT
- +2 IF DIKZ1=55.02
- IF DIKUM'<2
- SET DIKM1=2
- DO A1^PSJXR56
- QUIT
- +3 IF DIKZ1=55.03
- IF DIKUM'<1
- SET DIKM1=1
- DO A1^PSJXR53
- QUIT
- +4 IF DIKZ1=55.06
- IF DIKUM'<1
- SET DIKM1=1
- DO A1^PSJXR54
- DO A1^PSJXR57
- DO A1^PSJXR58
- DO A1^PSJXR59
- QUIT
- +5 IF DIKZ1=55.0611
- IF DIKUM'<2
- SET DIKM1=2
- DO A1^PSJXR57
- QUIT
- +6 IF DIKZ1=55.07
- IF DIKUM'<2
- SET DIKM1=2
- DO A1^PSJXR58
- QUIT
- +7 IF DIKZ1=55.09
- IF DIKUM'<2
- SET DIKM1=2
- DO A1^PSJXR59
- QUIT
- +8 IF DIKZ1=55.11
- IF DIKUM'<2
- SET DIKM1=2
- DO A1^PSJXR510
- QUIT
- +9 QUIT
- SET SET DISET=1
- SET DIKZK=1
- +1 IF DIKZ1=55.01
- IF DIKUM'<1
- SET DIKM1=1
- DO A1^PSJXR512
- DO A1^PSJXR516
- DO A1^PSJXR520
- QUIT
- +2 IF DIKZ1=55.02
- IF DIKUM'<2
- SET DIKM1=2
- DO A1^PSJXR516
- QUIT
- +3 IF DIKZ1=55.03
- IF DIKUM'<1
- SET DIKM1=1
- DO A1^PSJXR513
- QUIT
- +4 IF DIKZ1=55.06
- IF DIKUM'<1
- SET DIKM1=1
- DO A1^PSJXR514
- DO A1^PSJXR517
- DO A1^PSJXR518
- DO A1^PSJXR519
- QUIT
- +5 IF DIKZ1=55.0611
- IF DIKUM'<2
- SET DIKM1=2
- DO A1^PSJXR517
- QUIT
- +6 IF DIKZ1=55.07
- IF DIKUM'<2
- SET DIKM1=2
- DO A1^PSJXR518
- QUIT
- +7 IF DIKZ1=55.09
- IF DIKUM'<2
- SET DIKM1=2
- DO A1^PSJXR519
- QUIT
- +8 IF DIKZ1=55.11
- IF DIKUM'<2
- SET DIKM1=2
- DO A1^PSJXR520
- QUIT
- +9 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
