ORD17 ; COMPILED XREF FOR FILE #101 ; 04/16/99
;
S DIKZK=1
S DIKZ(0)=$G(^ORD(101,DA,0))
S X=$P(DIKZ(0),U,1)
I X'="" S ^ORD(101,"B",$E(X,1,63),DA)=""
S X=$P(DIKZ(0),U,1)
I X'="" D
.N DIK,DIV,DIU,DIN
.K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^ORD(101,D0,0)):^(0),1:"") S X=$P(Y(1),U,5),X=X S DIU=X K Y S X=DIV S X=DUZ X ^DD(101,.01,1,2,1.4)
S X=$P(DIKZ(0),U,2)
I X'="" S ORKX=X D UP^ORDD1 S ^ORD(101,"C",$E(X,1,63),DA)="",X=ORKX K ORKX
S X=$P(DIKZ(0),U,2)
I X'="" D REDO^ORDD101
S X=$P(DIKZ(0),U,2)
I X'="" D K11^ORDD1
S DIKZ(5)=$G(^ORD(101,DA,5))
S X=$P(DIKZ(5),U,1)
I X'="" S ^ORD(101,"AE",$E(X,1,30),DA)=""
S DIKZ(4)=$G(^ORD(101,DA,4))
S X=$P(DIKZ(4),U,1)
I X'="" D REDO^ORDD101
S DIKZ(99)=$G(^ORD(101,DA,99))
S X=$P(DIKZ(99),U,1)
I X'="" D SET^ORDD101
S DIKZ(770)=$G(^ORD(101,DA,770))
S X=$P(DIKZ(770),U,1)
I X'="" N HL770 S HL770=$G(^ORD(101,DA,770)) S:$P(HL770,"^",3)&($P(HL770,"^",4)) ^ORD(101,"AHL1",X,$P(HL770,"^",3),$P(HL770,"^",4),DA)=""
S X=$P(DIKZ(770),U,2)
I X'="" S ^ORD(101,"AHL2",$E(X,1,30),DA)=""
S X=$P(DIKZ(770),U,3)
I X'="" N HL770 S HL770=$G(^ORD(101,DA,770)) S:$P(HL770,"^")&($P(HL770,"^",4)) ^ORD(101,"AHL1",$P(HL770,"^"),X,$P(HL770,"^",4),DA)=""
S X=$P(DIKZ(770),U,4)
I X'="" N HL770 S HL770=$G(^ORD(101,DA,770)) S:$P(HL770,"^")&($P(HL770,"^",3)) ^ORD(101,"AHL1",$P(HL770,"^"),$P(HL770,"^",3),X,DA)=""
END G ^ORD18
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HORD17 1409 printed Dec 13, 2024@02:29:22 Page 2
ORD17 ; COMPILED XREF FOR FILE #101 ; 04/16/99
+1 ;
+2 SET DIKZK=1
+3 SET DIKZ(0)=$GET(^ORD(101,DA,0))
+4 SET X=$PIECE(DIKZ(0),U,1)
+5 IF X'=""
SET ^ORD(101,"B",$EXTRACT(X,1,63),DA)=""
+6 SET X=$PIECE(DIKZ(0),U,1)
+7 IF X'=""
Begin DoDot:1
+8 NEW DIK,DIV,DIU,DIN
+9 KILL DIV
SET DIV=X
SET D0=DA
SET DIV(0)=D0
SET Y(1)=$SELECT($DATA(^ORD(101,D0,0)):^(0),1:"")
SET X=$PIECE(Y(1),U,5)
SET X=X
SET DIU=X
KILL Y
SET X=DIV
SET X=DUZ
XECUTE ^DD(101,.01,1,2,1.4)
End DoDot:1
+10 SET X=$PIECE(DIKZ(0),U,2)
+11 IF X'=""
SET ORKX=X
DO UP^ORDD1
SET ^ORD(101,"C",$EXTRACT(X,1,63),DA)=""
SET X=ORKX
KILL ORKX
+12 SET X=$PIECE(DIKZ(0),U,2)
+13 IF X'=""
DO REDO^ORDD101
+14 SET X=$PIECE(DIKZ(0),U,2)
+15 IF X'=""
DO K11^ORDD1
+16 SET DIKZ(5)=$GET(^ORD(101,DA,5))
+17 SET X=$PIECE(DIKZ(5),U,1)
+18 IF X'=""
SET ^ORD(101,"AE",$EXTRACT(X,1,30),DA)=""
+19 SET DIKZ(4)=$GET(^ORD(101,DA,4))
+20 SET X=$PIECE(DIKZ(4),U,1)
+21 IF X'=""
DO REDO^ORDD101
+22 SET DIKZ(99)=$GET(^ORD(101,DA,99))
+23 SET X=$PIECE(DIKZ(99),U,1)
+24 IF X'=""
DO SET^ORDD101
+25 SET DIKZ(770)=$GET(^ORD(101,DA,770))
+26 SET X=$PIECE(DIKZ(770),U,1)
+27 IF X'=""
NEW HL770
SET HL770=$GET(^ORD(101,DA,770))
if $PIECE(HL770,"^",3)&($PIECE(HL770,"^",4))
SET ^ORD(101,"AHL1",X,$PIECE(HL770,"^",3),$PIECE(HL770,"^",4),DA)=""
+28 SET X=$PIECE(DIKZ(770),U,2)
+29 IF X'=""
SET ^ORD(101,"AHL2",$EXTRACT(X,1,30),DA)=""
+30 SET X=$PIECE(DIKZ(770),U,3)
+31 IF X'=""
NEW HL770
SET HL770=$GET(^ORD(101,DA,770))
if $PIECE(HL770,"^")&($PIECE(HL770,"^",4))
SET ^ORD(101,"AHL1",$PIECE(HL770,"^"),X,$PIECE(HL770,"^",4),DA)=""
+32 SET X=$PIECE(DIKZ(770),U,4)
+33 IF X'=""
NEW HL770
SET HL770=$GET(^ORD(101,DA,770))
if $PIECE(HL770,"^")&($PIECE(HL770,"^",3))
SET ^ORD(101,"AHL1",$PIECE(HL770,"^"),$PIECE(HL770,"^",3),X,DA)=""
END GOTO ^ORD18
