- ORD18 ; COMPILED XREF FOR FILE #101.01 ; 04/16/99
- ;
- S DA(1)=DA S DA=0
- A1 ;
- I $D(DISET) K DIKLM S:$D(DA(1)) DIKLM=1 G:$D(DA(1)) 1 S DA(1)=DA,DA=0 G @DIKM1
- 0 ;
- A S DA=$O(^ORD(101,DA(1),10,DA)) I DA'>0 S DA=0 G END
- 1 ;
- S DIKZ(0)=$G(^ORD(101,DA(1),10,DA,0))
- S X=$P(DIKZ(0),U,1)
- I X'="" S ^ORD(101,DA(1),10,"B",$E(X,1,30),DA)=""
- S X=$P(DIKZ(0),U,1)
- I X'="" D REDOX^ORDD101
- S X=$P(DIKZ(0),U,1)
- I X'="" S ^ORD(101,"AD",$E(X,1,30),DA(1),DA)=""
- S X=$P(DIKZ(0),U,1)
- I X'="" D
- .N DIK,DIV,DIU,DIN
- .X ^DD(101.01,.01,1,4,1.3) I X S X=DIV S Y(1)=$S($D(^ORD(101,D0,10,D1,1)):^(1),1:"") S X=$P(Y(1),U,1),X=X S DIU=X K Y X ^DD(101.01,.01,1,4,1.1) X ^DD(101.01,.01,1,4,1.4)
- S X=$P(DIKZ(0),U,1)
- I X'="" D
- .N DIK,DIV,DIU,DIN
- .X ^DD(101.01,.01,1,5,1.3) I X S X=DIV S Y(1)=$S($D(^ORD(101,D0,10,D1,1)):^(1),1:"") S X=$P(Y(1),U,2),X=X S DIU=X K Y X ^DD(101.01,.01,1,5,1.1) X ^DD(101.01,.01,1,5,1.4)
- S X=$P(DIKZ(0),U,1)
- I X'="" D
- .N DIK,DIV,DIU,DIN
- .X ^DD(101.01,.01,1,6,1.3) I X S X=DIV S Y(1)=$S($D(^ORD(101,D0,10,D1,1)):^(1),1:"") S X=$P(Y(1),U,3),X=X S DIU=X K Y X ^DD(101.01,.01,1,6,1.1) X ^DD(101.01,.01,1,6,1.4)
- S X=$P(DIKZ(0),U,2)
- I X'="" D REDOX^ORDD101
- S X=$P(DIKZ(0),U,3)
- I X'="" D REDOX^ORDD101
- S X=$P(DIKZ(0),U,5)
- I X'="" D REDOX^ORDD101
- S X=$P(DIKZ(0),U,6)
- I X'="" D REDOX^ORDD101
- G:'$D(DIKLM) A Q:$D(DISET)
- END G ^ORD19
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HORD18 1378 printed Dec 13, 2024@02:29:23 Page 2
- ORD18 ; COMPILED XREF FOR FILE #101.01 ; 04/16/99
- +1 ;
- +2 SET DA(1)=DA
- SET DA=0
- A1 ;
- +1 IF $DATA(DISET)
- KILL DIKLM
- if $DATA(DA(1))
- SET DIKLM=1
- if $DATA(DA(1))
- GOTO 1
- SET DA(1)=DA
- SET DA=0
- GOTO @DIKM1
- 0 ;
- A SET DA=$ORDER(^ORD(101,DA(1),10,DA))
- IF DA'>0
- SET DA=0
- GOTO END
- 1 ;
- +1 SET DIKZ(0)=$GET(^ORD(101,DA(1),10,DA,0))
- +2 SET X=$PIECE(DIKZ(0),U,1)
- +3 IF X'=""
- SET ^ORD(101,DA(1),10,"B",$EXTRACT(X,1,30),DA)=""
- +4 SET X=$PIECE(DIKZ(0),U,1)
- +5 IF X'=""
- DO REDOX^ORDD101
- +6 SET X=$PIECE(DIKZ(0),U,1)
- +7 IF X'=""
- SET ^ORD(101,"AD",$EXTRACT(X,1,30),DA(1),DA)=""
- +8 SET X=$PIECE(DIKZ(0),U,1)
- +9 IF X'=""
- Begin DoDot:1
- +10 NEW DIK,DIV,DIU,DIN
- +11 XECUTE ^DD(101.01,.01,1,4,1.3)
- IF X
- SET X=DIV
- SET Y(1)=$SELECT($DATA(^ORD(101,D0,10,D1,1)):^(1),1:"")
- SET X=$PIECE(Y(1),U,1)
- SET X=X
- SET DIU=X
- KILL Y
- XECUTE ^DD(101.01,.01,1,4,1.1)
- XECUTE ^DD(101.01,.01,1,4,1.4)
- End DoDot:1
- +12 SET X=$PIECE(DIKZ(0),U,1)
- +13 IF X'=""
- Begin DoDot:1
- +14 NEW DIK,DIV,DIU,DIN
- +15 XECUTE ^DD(101.01,.01,1,5,1.3)
- IF X
- SET X=DIV
- SET Y(1)=$SELECT($DATA(^ORD(101,D0,10,D1,1)):^(1),1:"")
- SET X=$PIECE(Y(1),U,2)
- SET X=X
- SET DIU=X
- KILL Y
- XECUTE ^DD(101.01,.01,1,5,1.1)
- XECUTE ^DD(101.01,.01,1,5,1.4)
- End DoDot:1
- +16 SET X=$PIECE(DIKZ(0),U,1)
- +17 IF X'=""
- Begin DoDot:1
- +18 NEW DIK,DIV,DIU,DIN
- +19 XECUTE ^DD(101.01,.01,1,6,1.3)
- IF X
- SET X=DIV
- SET Y(1)=$SELECT($DATA(^ORD(101,D0,10,D1,1)):^(1),1:"")
- SET X=$PIECE(Y(1),U,3)
- SET X=X
- SET DIU=X
- KILL Y
- XECUTE ^DD(101.01,.01,1,6,1.1)
- XECUTE ^DD(101.01,.01,1,6,1.4)
- End DoDot:1
- +20 SET X=$PIECE(DIKZ(0),U,2)
- +21 IF X'=""
- DO REDOX^ORDD101
- +22 SET X=$PIECE(DIKZ(0),U,3)
- +23 IF X'=""
- DO REDOX^ORDD101
- +24 SET X=$PIECE(DIKZ(0),U,5)
- +25 IF X'=""
- DO REDOX^ORDD101
- +26 SET X=$PIECE(DIKZ(0),U,6)
- +27 IF X'=""
- DO REDOX^ORDD101
- +28 if '$DATA(DIKLM)
- GOTO A
- if $DATA(DISET)
- QUIT
- END GOTO ^ORD19