XQORC8 ; COMPILED XREF FOR FILE #101 ; 04/21/09
;
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 DIKZ(0)=$G(^ORD(101,DA,0))
S X=$P(DIKZ(0),U,2)
I X'="" S ORKX=X D UP^XQORDD1 S ^ORD(101,"C",$E(X,1,63),DA)="",X=ORKX K ORKX
S X=$P(DIKZ(0),U,2)
I X'="" D REDO^XQORD101
S X=$P(DIKZ(0),U,2)
I X'="" D K11^XQORDD1
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^XQORD101
S DIKZ(99)=$G(^ORD(101,DA,99))
S X=$P(DIKZ(99),U,1)
I X'="" D SET^XQORD101
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))&($P(HL770,"^",10)) ^ORD(101,"AHL1",X,$P(HL770,"^",3),$P(HL770,"^",4),$P(HL770,"^",10),DA)=""
S X=$P(DIKZ(770),U,1)
I X'="" N HL770 S HL770=$G(^ORD(101,DA,770)) S:$P(HL770,"^",3)&($P(HL770,"^",10)) ^ORD(101,"AHL21",X,$P(HL770,"^",3),$P(HL770,"^",10),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))&($P(HL770,"^",10)) ^ORD(101,"AHL1",$P(HL770,"^"),X,$P(HL770,"^",4),$P(HL770,"^",10),DA)=""
S X=$P(DIKZ(770),U,3)
I X'="" N HL770 S HL770=$G(^ORD(101,DA,770)) S:$P(HL770,"^")&($P(HL770,"^",10)) ^ORD(101,"AHL21",$P(HL770,"^"),X,$P(HL770,"^",10),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))&($P(HL770,"^",10)) ^ORD(101,"AHL1",$P(HL770,"^"),$P(HL770,"^",3),X,$P(HL770,"^",10),DA)=""
S X=$P(DIKZ(770),U,10)
I X'="" N HL770 S HL770=$G(^ORD(101,DA,770)) S:$P(HL770,"^")&($P(HL770,"^",3))&($P(HL770,"^",4)) ^ORD(101,"AHL1",$P(HL770,"^"),$P(HL770,"^",3),$P(HL770,"^",4),X,DA)=""
S X=$P(DIKZ(770),U,10)
I X'="" N HL770 S HL770=$G(^ORD(101,DA,770)) S:$P(HL770,"^")&($P(HL770,"^",3)) ^ORD(101,"AHL21",$P(HL770,"^"),$P(HL770,"^",3),X,DA)=""
END G ^XQORC9
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HXQORC8 2244 printed Dec 13, 2024@02:06:11 Page 2
XQORC8 ; COMPILED XREF FOR FILE #101 ; 04/21/09
+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 DIKZ(0)=$GET(^ORD(101,DA,0))
+11 SET X=$PIECE(DIKZ(0),U,2)
+12 IF X'=""
SET ORKX=X
DO UP^XQORDD1
SET ^ORD(101,"C",$EXTRACT(X,1,63),DA)=""
SET X=ORKX
KILL ORKX
+13 SET X=$PIECE(DIKZ(0),U,2)
+14 IF X'=""
DO REDO^XQORD101
+15 SET X=$PIECE(DIKZ(0),U,2)
+16 IF X'=""
DO K11^XQORDD1
+17 SET DIKZ(5)=$GET(^ORD(101,DA,5))
+18 SET X=$PIECE(DIKZ(5),U,1)
+19 IF X'=""
SET ^ORD(101,"AE",$EXTRACT(X,1,30),DA)=""
+20 SET DIKZ(4)=$GET(^ORD(101,DA,4))
+21 SET X=$PIECE(DIKZ(4),U,1)
+22 IF X'=""
DO REDO^XQORD101
+23 SET DIKZ(99)=$GET(^ORD(101,DA,99))
+24 SET X=$PIECE(DIKZ(99),U,1)
+25 IF X'=""
DO SET^XQORD101
+26 SET DIKZ(770)=$GET(^ORD(101,DA,770))
+27 SET X=$PIECE(DIKZ(770),U,1)
+28 IF X'=""
NEW HL770
SET HL770=$GET(^ORD(101,DA,770))
if $PIECE(HL770,"^",3)&($PIECE(HL770,"^",4))&($PIECE(HL770,"^",10))
SET ^ORD(101,"AHL1",X,$PIECE(HL770,"^",3),$PIECE(HL770,"^",4),$PIECE(HL770,"^",10),DA)=""
+29 SET X=$PIECE(DIKZ(770),U,1)
+30 IF X'=""
NEW HL770
SET HL770=$GET(^ORD(101,DA,770))
if $PIECE(HL770,"^",3)&($PIECE(HL770,"^",10))
SET ^ORD(101,"AHL21",X,$PIECE(HL770,"^",3),$PIECE(HL770,"^",10),DA)=""
+31 SET X=$PIECE(DIKZ(770),U,2)
+32 IF X'=""
SET ^ORD(101,"AHL2",$EXTRACT(X,1,30),DA)=""
+33 SET X=$PIECE(DIKZ(770),U,3)
+34 IF X'=""
NEW HL770
SET HL770=$GET(^ORD(101,DA,770))
if $PIECE(HL770,"^")&($PIECE(HL770,"^",4))&($PIECE(HL770,"^",10))
SET ^ORD(101,"AHL1",$PIECE(HL770,"^"),X,$PIECE(HL770,"^",4),$PIECE(HL770,"^",10),DA)=""
+35 SET X=$PIECE(DIKZ(770),U,3)
+36 IF X'=""
NEW HL770
SET HL770=$GET(^ORD(101,DA,770))
if $PIECE(HL770,"^")&($PIECE(HL770,"^",10))
SET ^ORD(101,"AHL21",$PIECE(HL770,"^"),X,$PIECE(HL770,"^",10),DA)=""
+37 SET X=$PIECE(DIKZ(770),U,4)
+38 IF X'=""
NEW HL770
SET HL770=$GET(^ORD(101,DA,770))
if $PIECE(HL770,"^")&($PIECE(HL770,"^",3))&($PIECE(HL770,"^",10))
SET ^ORD(101,"AHL1",$PIECE(HL770,"^"),$PIECE(HL770,"^",3),X,$PIECE(HL770,"^",10),DA)=""
+39 SET X=$PIECE(DIKZ(770),U,10)
+40 IF X'=""
NEW HL770
SET HL770=$GET(^ORD(101,DA,770))
if $PIECE(HL770,"^")&($PIECE(HL770,"^",3))&($PIECE(HL770,"^",4))
SET ^ORD(101,"AHL1",$PIECE(HL770,"^"),$PIECE(HL770,"^",3),$PIECE(HL770,"^",4),X,DA)=""
+41 SET X=$PIECE(DIKZ(770),U,10)
+42 IF X'=""
NEW HL770
SET HL770=$GET(^ORD(101,DA,770))
if $PIECE(HL770,"^")&($PIECE(HL770,"^",3))
SET ^ORD(101,"AHL21",$PIECE(HL770,"^"),$PIECE(HL770,"^",3),X,DA)=""
END GOTO ^XQORC9
