- PSSJXR ; DRIVER FOR COMPILED XREFS FOR FILE #55 ; 10/05/22
- ;
- 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)=55,DIKUP=DA
- I $D(DIKKS) D:DIKZ1=DH(1) ^PSSJXR1 S DA=DIKUP D:DIKZ1=DH(1) ^PSSJXR22 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) ^PSSJXR1 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) ^PSSJXR22 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) ^PSSJXR22 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^PSSJXR2,A1^PSSJXR10,A1^PSSJXR15,A1^PSSJXR16,A1^PSSJXR17 Q
- I DIKZ1=55.0105,DIKUM'<1 S DIKM1=1 D A1^PSSJXR3 Q
- I DIKZ1=55.0108,DIKUM'<1 S DIKM1=1 D A1^PSSJXR4 Q
- I DIKZ1=55.0109,DIKUM'<1 S DIKM1=1 D A1^PSSJXR5 Q
- I DIKZ1=55.02,DIKUM'<2 S DIKM1=2 D A1^PSSJXR10 Q
- I DIKZ1=55.03,DIKUM'<1 S DIKM1=1 D A1^PSSJXR6 Q
- I DIKZ1=55.05,DIKUM'<1 S DIKM1=1 D A1^PSSJXR7,A1^PSSJXR11,A1^PSSJXR19 Q
- I DIKZ1=55.051,DIKUM'<2 S DIKM1=2 D A1^PSSJXR11 Q
- I DIKZ1=55.06,DIKUM'<1 S DIKM1=1 D A1^PSSJXR8,A1^PSSJXR12,A1^PSSJXR13,A1^PSSJXR14,A1^PSSJXR20,A1^PSSJXR21 Q
- I DIKZ1=55.0611,DIKUM'<2 S DIKM1=2 D A1^PSSJXR12 Q
- I DIKZ1=55.07,DIKUM'<2 S DIKM1=2 D A1^PSSJXR13 Q
- I DIKZ1=55.09,DIKUM'<2 S DIKM1=2 D A1^PSSJXR14 Q
- I DIKZ1=55.11,DIKUM'<2 S DIKM1=2 D A1^PSSJXR15 Q
- I DIKZ1=55.1138,DIKUM'<2 S DIKM1=2 D A1^PSSJXR16 Q
- I DIKZ1=55.1153,DIKUM'<2 S DIKM1=2 D A1^PSSJXR17 Q
- I DIKZ1=55.17,DIKUM'<1 S DIKM1=1 D A1^PSSJXR9,A1^PSSJXR18 Q
- I DIKZ1=55.174,DIKUM'<2 S DIKM1=2 D A1^PSSJXR18 Q
- I DIKZ1=55.516,DIKUM'<2 S DIKM1=2 D A1^PSSJXR19 Q
- I DIKZ1=55.6114,DIKUM'<2 S DIKM1=2 D A1^PSSJXR20 Q
- I DIKZ1=55.6132,DIKUM'<2 S DIKM1=2 D A1^PSSJXR21 Q
- Q
- SET S DISET=1,DIKZK=1 K DIKPUSH
- I DIKZ1=55.01,DIKUM'<1 S DIKM1=1 D A1^PSSJXR23,A1^PSSJXR31,A1^PSSJXR36,A1^PSSJXR37,A1^PSSJXR38 Q
- I DIKZ1=55.0105,DIKUM'<1 S DIKM1=1 D A1^PSSJXR24 Q
- I DIKZ1=55.0108,DIKUM'<1 S DIKM1=1 D A1^PSSJXR25 Q
- I DIKZ1=55.0109,DIKUM'<1 S DIKM1=1 D A1^PSSJXR26 Q
- I DIKZ1=55.02,DIKUM'<2 S DIKM1=2 D A1^PSSJXR31 Q
- I DIKZ1=55.03,DIKUM'<1 S DIKM1=1 D A1^PSSJXR27 Q
- I DIKZ1=55.05,DIKUM'<1 S DIKM1=1 D A1^PSSJXR28,A1^PSSJXR32,A1^PSSJXR40 Q
- I DIKZ1=55.051,DIKUM'<2 S DIKM1=2 D A1^PSSJXR32 Q
- I DIKZ1=55.06,DIKUM'<1 S DIKM1=1 D A1^PSSJXR29,A1^PSSJXR33,A1^PSSJXR34,A1^PSSJXR35,A1^PSSJXR41,A1^PSSJXR42 Q
- I DIKZ1=55.0611,DIKUM'<2 S DIKM1=2 D A1^PSSJXR33 Q
- I DIKZ1=55.07,DIKUM'<2 S DIKM1=2 D A1^PSSJXR34 Q
- I DIKZ1=55.09,DIKUM'<2 S DIKM1=2 D A1^PSSJXR35 Q
- I DIKZ1=55.11,DIKUM'<2 S DIKM1=2 D A1^PSSJXR36 Q
- I DIKZ1=55.1138,DIKUM'<2 S DIKM1=2 D A1^PSSJXR37 Q
- I DIKZ1=55.1153,DIKUM'<2 S DIKM1=2 D A1^PSSJXR38 Q
- I DIKZ1=55.17,DIKUM'<1 S DIKM1=1 D A1^PSSJXR30,A1^PSSJXR39 Q
- I DIKZ1=55.174,DIKUM'<2 S DIKM1=2 D A1^PSSJXR39 Q
- I DIKZ1=55.516,DIKUM'<2 S DIKM1=2 D A1^PSSJXR40 Q
- I DIKZ1=55.6114,DIKUM'<2 S DIKM1=2 D A1^PSSJXR41 Q
- I DIKZ1=55.6132,DIKUM'<2 S DIKM1=2 D A1^PSSJXR42 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[HPSSJXR 4293 printed Mar 13, 2025@21:36:41 Page 2
- PSSJXR ; DRIVER FOR COMPILED XREFS FOR FILE #55 ; 10/05/22
- +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)=55
- SET DIKUP=DA
- +2 IF $DATA(DIKKS)
- if DIKZ1=DH(1)
- DO ^PSSJXR1
- SET DA=DIKUP
- if DIKZ1=DH(1)
- DO ^PSSJXR22
- 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 ^PSSJXR1
- 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 ^PSSJXR22
- 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 ^PSSJXR22
- 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^PSSJXR2
- DO A1^PSSJXR10
- DO A1^PSSJXR15
- DO A1^PSSJXR16
- DO A1^PSSJXR17
- QUIT
- +2 IF DIKZ1=55.0105
- IF DIKUM'<1
- SET DIKM1=1
- DO A1^PSSJXR3
- QUIT
- +3 IF DIKZ1=55.0108
- IF DIKUM'<1
- SET DIKM1=1
- DO A1^PSSJXR4
- QUIT
- +4 IF DIKZ1=55.0109
- IF DIKUM'<1
- SET DIKM1=1
- DO A1^PSSJXR5
- QUIT
- +5 IF DIKZ1=55.02
- IF DIKUM'<2
- SET DIKM1=2
- DO A1^PSSJXR10
- QUIT
- +6 IF DIKZ1=55.03
- IF DIKUM'<1
- SET DIKM1=1
- DO A1^PSSJXR6
- QUIT
- +7 IF DIKZ1=55.05
- IF DIKUM'<1
- SET DIKM1=1
- DO A1^PSSJXR7
- DO A1^PSSJXR11
- DO A1^PSSJXR19
- QUIT
- +8 IF DIKZ1=55.051
- IF DIKUM'<2
- SET DIKM1=2
- DO A1^PSSJXR11
- QUIT
- +9 IF DIKZ1=55.06
- IF DIKUM'<1
- SET DIKM1=1
- DO A1^PSSJXR8
- DO A1^PSSJXR12
- DO A1^PSSJXR13
- DO A1^PSSJXR14
- DO A1^PSSJXR20
- DO A1^PSSJXR21
- QUIT
- +10 IF DIKZ1=55.0611
- IF DIKUM'<2
- SET DIKM1=2
- DO A1^PSSJXR12
- QUIT
- +11 IF DIKZ1=55.07
- IF DIKUM'<2
- SET DIKM1=2
- DO A1^PSSJXR13
- QUIT
- +12 IF DIKZ1=55.09
- IF DIKUM'<2
- SET DIKM1=2
- DO A1^PSSJXR14
- QUIT
- +13 IF DIKZ1=55.11
- IF DIKUM'<2
- SET DIKM1=2
- DO A1^PSSJXR15
- QUIT
- +14 IF DIKZ1=55.1138
- IF DIKUM'<2
- SET DIKM1=2
- DO A1^PSSJXR16
- QUIT
- +15 IF DIKZ1=55.1153
- IF DIKUM'<2
- SET DIKM1=2
- DO A1^PSSJXR17
- QUIT
- +16 IF DIKZ1=55.17
- IF DIKUM'<1
- SET DIKM1=1
- DO A1^PSSJXR9
- DO A1^PSSJXR18
- QUIT
- +17 IF DIKZ1=55.174
- IF DIKUM'<2
- SET DIKM1=2
- DO A1^PSSJXR18
- QUIT
- +18 IF DIKZ1=55.516
- IF DIKUM'<2
- SET DIKM1=2
- DO A1^PSSJXR19
- QUIT
- +19 IF DIKZ1=55.6114
- IF DIKUM'<2
- SET DIKM1=2
- DO A1^PSSJXR20
- QUIT
- +20 IF DIKZ1=55.6132
- IF DIKUM'<2
- SET DIKM1=2
- DO A1^PSSJXR21
- QUIT
- +21 QUIT
- SET SET DISET=1
- SET DIKZK=1
- KILL DIKPUSH
- +1 IF DIKZ1=55.01
- IF DIKUM'<1
- SET DIKM1=1
- DO A1^PSSJXR23
- DO A1^PSSJXR31
- DO A1^PSSJXR36
- DO A1^PSSJXR37
- DO A1^PSSJXR38
- QUIT
- +2 IF DIKZ1=55.0105
- IF DIKUM'<1
- SET DIKM1=1
- DO A1^PSSJXR24
- QUIT
- +3 IF DIKZ1=55.0108
- IF DIKUM'<1
- SET DIKM1=1
- DO A1^PSSJXR25
- QUIT
- +4 IF DIKZ1=55.0109
- IF DIKUM'<1
- SET DIKM1=1
- DO A1^PSSJXR26
- QUIT
- +5 IF DIKZ1=55.02
- IF DIKUM'<2
- SET DIKM1=2
- DO A1^PSSJXR31
- QUIT
- +6 IF DIKZ1=55.03
- IF DIKUM'<1
- SET DIKM1=1
- DO A1^PSSJXR27
- QUIT
- +7 IF DIKZ1=55.05
- IF DIKUM'<1
- SET DIKM1=1
- DO A1^PSSJXR28
- DO A1^PSSJXR32
- DO A1^PSSJXR40
- QUIT
- +8 IF DIKZ1=55.051
- IF DIKUM'<2
- SET DIKM1=2
- DO A1^PSSJXR32
- QUIT
- +9 IF DIKZ1=55.06
- IF DIKUM'<1
- SET DIKM1=1
- DO A1^PSSJXR29
- DO A1^PSSJXR33
- DO A1^PSSJXR34
- DO A1^PSSJXR35
- DO A1^PSSJXR41
- DO A1^PSSJXR42
- QUIT
- +10 IF DIKZ1=55.0611
- IF DIKUM'<2
- SET DIKM1=2
- DO A1^PSSJXR33
- QUIT
- +11 IF DIKZ1=55.07
- IF DIKUM'<2
- SET DIKM1=2
- DO A1^PSSJXR34
- QUIT
- +12 IF DIKZ1=55.09
- IF DIKUM'<2
- SET DIKM1=2
- DO A1^PSSJXR35
- QUIT
- +13 IF DIKZ1=55.11
- IF DIKUM'<2
- SET DIKM1=2
- DO A1^PSSJXR36
- QUIT
- +14 IF DIKZ1=55.1138
- IF DIKUM'<2
- SET DIKM1=2
- DO A1^PSSJXR37
- QUIT
- +15 IF DIKZ1=55.1153
- IF DIKUM'<2
- SET DIKM1=2
- DO A1^PSSJXR38
- QUIT
- +16 IF DIKZ1=55.17
- IF DIKUM'<1
- SET DIKM1=1
- DO A1^PSSJXR30
- DO A1^PSSJXR39
- QUIT
- +17 IF DIKZ1=55.174
- IF DIKUM'<2
- SET DIKM1=2
- DO A1^PSSJXR39
- QUIT
- +18 IF DIKZ1=55.516
- IF DIKUM'<2
- SET DIKM1=2
- DO A1^PSSJXR40
- QUIT
- +19 IF DIKZ1=55.6114
- IF DIKUM'<2
- SET DIKM1=2
- DO A1^PSSJXR41
- QUIT
- +20 IF DIKZ1=55.6132
- IF DIKUM'<2
- SET DIKM1=2
- DO A1^PSSJXR42
- QUIT
- +21 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
