ACRCD1 ; COMPILED XREF FOR FILE #9002196 ; 09/30/09
;
S DIKZK=2
S DIKZ("X")=$G(^ACRDOC(DA,"X"))
S X=$P(DIKZ("X"),U,1)
I X'="" I $D(^ACRDOC("B",$E(X,1,30),DA)),^(DA) K ^(DA)
S DIKZ(0)=$G(^ACRDOC(DA,0))
S X=$P(DIKZ(0),U,2)
I X'="" K ^ACRDOC("C",$E(X,1,30),DA)
S X=$P(DIKZ(0),U,2)
I X'="" D
.N DIK,DIV,DIU,DIN
.K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^ACRDOC(D0,"X")):^("X"),1:"") S X=$P(Y(1),U,1),X=X S DIU=X K Y S X=DIV S X=$$EXPDN^ACRFUTL(D0) S DIH=$G(^ACRDOC(DIV(0),"X")),DIV=X S $P(^("X"),U,1)=DIV,DIH=9002196,DIG=.011 D ^DICR
S DIKZ(0)=$G(^ACRDOC(DA,0))
S X=$P(DIKZ(0),U,3)
I X'="" K ^ACRDOC("DT",$E(X,1,30),DA)
S X=$P(DIKZ(0),U,4)
I X'="" K ^ACRDOC("D",$E(X,1,30),DA)
S X=$P(DIKZ(0),U,5)
I X'="" K ^ACRDOC("E",$E(X,1,30),DA)
S X=$P(DIKZ(0),U,8)
I X'="" K ^ACRDOC("PO",$E(X,1,30),DA)
S X=$P(DIKZ(0),U,8)
I X'="" K:X ^ACRDOC("PO",X,"A",DA)
S X=$P(DIKZ(0),U,13)
I X'="" K ^ACRDOC("REF",$E(X,1,30),DA)
S X=$P(DIKZ(0),U,14)
I X'="" K ^ACRDOC("G",$E(X,1,30),DA)
S X=$P(DIKZ(0),U,15)
I X'="" K ^ACRDOC("MOD",$E(X,1,30),DA)
S X=$P(DIKZ(0),U,17)
I X'="" K ^ACRDOC("O",$E(X,1,30),DA)
S X=$P(DIKZ(0),U,17)
I X'="" D
.N DIK,DIV,DIU,DIN
.K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^ACRDOC(D0,"X")):^("X"),1:"") S X=$P(Y(1),U,1),X=X S DIU=X K Y S X=DIV S X=$$ORN17^ACRFTRIG(D0) S DIH=$G(^ACRDOC(DIV(0),"X")),DIV=X S $P(^("X"),U,1)=DIV,DIH=9002196,DIG=.011 D ^DICR
S DIKZ(0)=$G(^ACRDOC(DA,0))
S X=$P(DIKZ(0),U,18)
I X'="" K ^ACRDOC("T",DA,DA)
S X=$P(DIKZ(0),U,19)
I X'="" K ^ACRDOC("BPA",$E(X,1,30),DA)
S DIKZ("PA")=$G(^ACRDOC(DA,"PA"))
S X=$P(DIKZ("PA"),U,1)
I X'="" K ^ACRDOC("PA",$E(X,1,30),DA)
S X=$P(DIKZ("PA"),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(^ACRDOC(D0,"PA")):^("PA"),1:"") S X=$P(Y(1),U,2),X=X S DIU=X K Y S X="" X ^DD(9002196,.2,1,2,2.4)
S X=$P(DIKZ("PA"),U,1)
I X'="" K:X ^ACRDOC("PA",X,"A",DA)
S DIKZ(0)=$G(^ACRDOC(DA,0))
S X=$P(DIKZ(0),U,26)
I X'="" K ^ACRDOC("FS","FS"_$E(X,1,30),DA)
S X=$P(DIKZ(0),U,27)
I X'="" K ^ACRDOC("FS",$E(X,1,30),DA)
S DIKZ("PA")=$G(^ACRDOC(DA,"PA"))
S X=$P(DIKZ("PA"),U,3)
I X'="" K ^ACRDOC("PS",$E(X,1,30),DA)
S DIKZ(18)=$G(^ACRDOC(DA,18))
S X=$P(DIKZ(18),U,1)
I X'="" K ^ACRDOC("P","SC"_$E(X,1,30),DA)
S DIKZ("PO")=$G(^ACRDOC(DA,"PO"))
S X=$P(DIKZ("PO"),U,1)
I X'="" K ^ACRDOC("S",$E(X,1,30),DA)
S DIKZ("POST")=$G(^ACRDOC(DA,"POST"))
S X=$P(DIKZ("POST"),U,1)
I X'="" I $D(DA),DA,$D(^ACRDOC(DA,"PO")),$P(^("PO"),U,12) K ^ACRDOC("DI",$E(X,1,30),$P(^("PO"),U,12),DA)
S X=$P(DIKZ("POST"),U,1)
I X'="" K ^ACRDOC("RL",$E(X,1,30),DA)
S X=$P(DIKZ("PO"),U,5)
I X'="" K ^ACRDOC("I",$E(X,1,30),DA)
S X=$P(DIKZ("PO"),U,12)
I X'="" I $D(DA),DA,$D(^ACRDOC(DA,"POST")),+^("POST") K ^ACRDOC("DI",+^("POST"),$E(X,1,30),DA)
S X=$P(DIKZ("PO"),U,16)
I X'="" K ^ACRDOC("L",$E(X,1,30),DA)
S DIKZ(5)=$G(^ACRDOC(DA,5))
S X=$P(DIKZ(5),U,5)
I X'="" K ^ACRDOC("I",$E(X,1,30),DA)
S X=$P(DIKZ(5),U,3)
I X'="" K ^ACRDOC("J",$E(X,1,30),DA)
S DIKZ("REQ")=$G(^ACRDOC(DA,"REQ"))
S X=$P(DIKZ("REQ"),U,10)
I X'="" D
.N DIK,DIV,DIU,DIN
.K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^ACRDOC(D0,"REQ1")):^("REQ1"),1:"") S X=$P(Y(1),U,10),X=X S DIU=X K Y X ^DD(9002196,113100,1,36,2.1) X ^DD(9002196,113100,1,36,2.4)
S X=$P(DIKZ("REQ"),U,10)
I X'="" D
.N DIK,DIV,DIU,DIN
.K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^ACRDOC(D0,"REQ2")):^("REQ2"),1:"") S X=$P(Y(1),U,4),X=X S DIU=X K Y S X="" X ^DD(9002196,113100,1,37,2.4)
S DIKZ("REQ2")=$G(^ACRDOC(DA,"REQ2"))
S X=$P(DIKZ("REQ2"),U,13)
I X'="" K ^ACRDOC("PVEN",$E(X,1,30),DA)
S DIKZ("TO")=$G(^ACRDOC(DA,"TO"))
S X=$P(DIKZ("TO"),U,20)
I X'="" K ^ACRDOC("K",$E(X,1,30),DA)
S X=$P(DIKZ("TO"),U,9)
I X'="" K ^ACRDOC("N",$E(X,1,30),DA)
S X=$P(DIKZ("TO"),U,12)
I X'="" K ^ACRDOC("TDEPT",$E(X,1,30),DA)
S X=$P(DIKZ("TO"),U,14)
I X'="" K ^ACRDOC("DD",$E(X,1,30),DA)
S X=$P(DIKZ("TO"),U,19)
I X'="" I $E(X)'="Y" S $P(^ACRDOC(+$G(DA),"TO"),U,25)=""
S X=$P(DIKZ("TO"),U,18)
I X'="" D
.N DIK,DIV,DIU,DIN
.K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^ACRDOC(D0,"REQ")):^("REQ"),1:"") S X=$P(Y(1),U,12),X=X S DIU=X K Y X ^DD(9002196,130150,1,1,2.1) X ^DD(9002196,130150,1,1,2.4)
S DIKZ("TOAU")=$G(^ACRDOC(DA,"TOAU"))
S X=$P(DIKZ("TOAU"),U,2)
I X'="" D
.N DIK,DIV,DIU,DIN
.K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^ACRDOC(D0,"AU")):^("AU"),1:"") S X=$P(Y(1),U,1),X=X S DIU=X K Y X ^DD(9002196,130154,1,1,2.1) X ^DD(9002196,130154,1,1,2.4)
S DIKZ("TO")=$G(^ACRDOC(DA,"TO"))
S X=$P(DIKZ("TO"),U,22)
I X'="" D
.N DIK,DIV,DIU,DIN
.K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S Y(1)=$S($D(^ACRDOC(D0,"TO")):^("TO"),1:"") S X=$P(Y(1),U,22),X=X S X=X=0 I X S X=DIV S Y(1)=$S($D(^ACRDOC(D0,"TOAU")):^("TOAU"),1:"") S X=$P(Y(1),U,8),X=X S DIU=X K Y S X="" X ^DD(9002196,130157,1,1,2.4)
S DIKZ("TOAU")=$G(^ACRDOC(DA,"TOAU"))
S X=$P(DIKZ("TOAU"),U,8)
I X'="" D
.N DIK,DIV,DIU,DIN
.K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^ACRDOC(D0,"TO")):^("TO"),1:"") S X=$P(Y(1),U,26),X=X S DIU=X K Y X ^DD(9002196,130177,1,1,2.1) X ^DD(9002196,130177,1,1,2.4)
S DIKZ("TOAU")=$G(^ACRDOC(DA,"TOAU"))
S X=$P(DIKZ("TOAU"),U,9)
I X'="" K ^ACRDOC("Q",$E(X,1,30),DA)
S DIKZ("TRNG")=$G(^ACRDOC(DA,"TRNG"))
S X=$P(DIKZ("TRNG"),U,2)
I X'="" K ^ACRDOC("F",$E(X,1,30),DA)
S X=$P(DIKZ("TRNG"),U,3)
I X'="" K ^ACRDOC("M",$E(X,1,30),DA)
S X=$P(DIKZ("TRNG"),U,4)
I X'="" D
.N DIK,DIV,DIU,DIN
.K DIV S DIV=X,D0=DA,DIV(0)=D0 X ^DD(9002196,148050,1,1,89.2) S X=$P(Y(101),U,1) S D0=I(0,0) S DIU=X K Y X ^DD(9002196,148050,1,1,2.1) X ^DD(9002196,148050,1,1,2.4)
S DIKZ("TRNG3")=$G(^ACRDOC(DA,"TRNG3"))
S X=$P(DIKZ("TRNG3"),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(^ACRDOC(D0,"TRNG3")):^("TRNG3"),1:"") S X=$P(Y(1),U,4),X=X S DIU=X K Y X ^DD(9002196,148181,1,1,2.1) X ^DD(9002196,148181,1,1,2.4)
S X=$P(DIKZ("TRNG3"),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(^ACRDOC(D0,"TRNG3")):^("TRNG3"),1:"") S X=$P(Y(1),U,2),X=X S DIU=X K Y X ^DD(9002196,148181,1,2,2.1) X ^DD(9002196,148181,1,2,2.4)
S X=$P(DIKZ("TRNG3"),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(^ACRDOC(D0,"TRNG3")):^("TRNG3"),1:"") S X=$P(Y(1),U,3),X=X S DIU=X K Y X ^DD(9002196,148181,1,3,2.1) X ^DD(9002196,148181,1,3,2.4)
S X=$P(DIKZ("TRNG3"),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(^ACRDOC(D0,"TRNG3")):^("TRNG3"),1:"") S X=$P(Y(1),U,5),X=X S DIU=X K Y X ^DD(9002196,148181,1,4,2.1) X ^DD(9002196,148181,1,4,2.4)
S X=$P(DIKZ("TRNG3"),U,1)
I X'="" D
.N DIK,DIV,DIU,DIN
.K DIV S DIV=X,D0=DA,DIV(0)=D0 X ^DD(9002196,148181,1,5,89.2) S X=$S('$D(^AUTTVNDR(+$P(Y(101),U,1),0)):"",1:$P(^(0),U,1)) S D0=I(0,0) S DIU=X K Y X ^DD(9002196,148181,1,5,2.1) X ^DD(9002196,148181,1,5,2.4)
S X=$P(DIKZ("TRNG3"),U,1)
I X'="" K ^ACRDOC("I",$E(X,1,30),DA)
S DIKZ("TRNG4")=$G(^ACRDOC(DA,"TRNG4"))
S X=$P(DIKZ("TRNG4"),U,5)
I X'="" D
.N DIK,DIV,DIU,DIN
.K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^ACRDOC(D0,"AU")):^("AU"),1:"") S X=$P(Y(1),U,1),X=X S DIU=X K Y X ^DD(9002196,148310,1,1,2.1) X ^DD(9002196,148310,1,1,2.4)
S DIKZ("TRNG4")=$G(^ACRDOC(DA,"TRNG4"))
S X=$P(DIKZ("TRNG4"),U,13)
I X'="" K ^ACRDOC("R",$E(X,1,30),DA)
S DIKZ("PR")=$G(^ACRDOC(DA,"PR"))
S X=$P(DIKZ("PR"),U,1)
I X'="" D
.N DIK,DIV,DIU,DIN
.X ^DD(9002196,999010,1,1,2.3) I X S X=DIV S Y(1)=$S($D(^ACRDOC(D0,"TRNG")):^("TRNG"),1:"") S X=$P(Y(1),U,4),X=X S DIU=X K Y X ^DD(9002196,999010,1,1,2.1) X ^DD(9002196,999010,1,1,2.4)
S X=$P(DIKZ("PR"),U,1)
I X'="" K ^ACRDOC("PR",$E(X,1,30),DA)
S DIKZ(0)=$G(^ACRDOC(DA,0))
S X=$P(DIKZ(0),U,1)
I X'="" K ^ACRDOC("B",$E(X,1,30),DA)
END G ^ACRCD2
ACRCD1 ; COMPILED XREF FOR FILE #9002196 ; 09/30/09
+1 ;
+2 SET DIKZK=2
+3 SET DIKZ("X")=$GET(^ACRDOC(DA,"X"))
+4 SET X=$PIECE(DIKZ("X"),U,1)
+5 IF X'=""
IF $DATA(^ACRDOC("B",$EXTRACT(X,1,30),DA))
IF ^(DA)
KILL ^(DA)
+6 SET DIKZ(0)=$GET(^ACRDOC(DA,0))
+7 SET X=$PIECE(DIKZ(0),U,2)
+8 IF X'=""
KILL ^ACRDOC("C",$EXTRACT(X,1,30),DA)
+9 SET X=$PIECE(DIKZ(0),U,2)
+10 IF X'=""
Begin DoDot:1
+11 NEW DIK,DIV,DIU,DIN
+12 KILL DIV
SET DIV=X
SET D0=DA
SET DIV(0)=D0
SET Y(1)=$SELECT($DATA(^ACRDOC(D0,"X")):^("X"),1:"")
SET X=$PIECE(Y(1),U,1)
SET X=X
SET DIU=X
KILL Y
SET X=DIV
SET X=$$EXPDN^ACRFUTL(D0)
SET DIH=$GET(^ACRDOC(DIV(0),"X"))
SET DIV=X
SET $PIECE(^("X"),U,1)=DIV
SET DIH=9002196
SET DIG=.011
DO ^DICR
End DoDot:1
+13 SET DIKZ(0)=$GET(^ACRDOC(DA,0))
+14 SET X=$PIECE(DIKZ(0),U,3)
+15 IF X'=""
KILL ^ACRDOC("DT",$EXTRACT(X,1,30),DA)
+16 SET X=$PIECE(DIKZ(0),U,4)
+17 IF X'=""
KILL ^ACRDOC("D",$EXTRACT(X,1,30),DA)
+18 SET X=$PIECE(DIKZ(0),U,5)
+19 IF X'=""
KILL ^ACRDOC("E",$EXTRACT(X,1,30),DA)
+20 SET X=$PIECE(DIKZ(0),U,8)
+21 IF X'=""
KILL ^ACRDOC("PO",$EXTRACT(X,1,30),DA)
+22 SET X=$PIECE(DIKZ(0),U,8)
+23 IF X'=""
IF X
KILL ^ACRDOC("PO",X,"A",DA)
+24 SET X=$PIECE(DIKZ(0),U,13)
+25 IF X'=""
KILL ^ACRDOC("REF",$EXTRACT(X,1,30),DA)
+26 SET X=$PIECE(DIKZ(0),U,14)
+27 IF X'=""
KILL ^ACRDOC("G",$EXTRACT(X,1,30),DA)
+28 SET X=$PIECE(DIKZ(0),U,15)
+29 IF X'=""
KILL ^ACRDOC("MOD",$EXTRACT(X,1,30),DA)
+30 SET X=$PIECE(DIKZ(0),U,17)
+31 IF X'=""
KILL ^ACRDOC("O",$EXTRACT(X,1,30),DA)
+32 SET X=$PIECE(DIKZ(0),U,17)
+33 IF X'=""
Begin DoDot:1
+34 NEW DIK,DIV,DIU,DIN
+35 KILL DIV
SET DIV=X
SET D0=DA
SET DIV(0)=D0
SET Y(1)=$SELECT($DATA(^ACRDOC(D0,"X")):^("X"),1:"")
SET X=$PIECE(Y(1),U,1)
SET X=X
SET DIU=X
KILL Y
SET X=DIV
SET X=$$ORN17^ACRFTRIG(D0)
SET DIH=$GET(^ACRDOC(DIV(0),"X"))
SET DIV=X
SET $PIECE(^("X"),U,1)=DIV
SET DIH=9002196
SET DIG=.011
DO ^DICR
End DoDot:1
+36 SET DIKZ(0)=$GET(^ACRDOC(DA,0))
+37 SET X=$PIECE(DIKZ(0),U,18)
+38 IF X'=""
KILL ^ACRDOC("T",DA,DA)
+39 SET X=$PIECE(DIKZ(0),U,19)
+40 IF X'=""
KILL ^ACRDOC("BPA",$EXTRACT(X,1,30),DA)
+41 SET DIKZ("PA")=$GET(^ACRDOC(DA,"PA"))
+42 SET X=$PIECE(DIKZ("PA"),U,1)
+43 IF X'=""
KILL ^ACRDOC("PA",$EXTRACT(X,1,30),DA)
+44 SET X=$PIECE(DIKZ("PA"),U,1)
+45 IF X'=""
Begin DoDot:1
+46 NEW DIK,DIV,DIU,DIN
+47 KILL DIV
SET DIV=X
SET D0=DA
SET DIV(0)=D0
SET Y(1)=$SELECT($DATA(^ACRDOC(D0,"PA")):^("PA"),1:"")
SET X=$PIECE(Y(1),U,2)
SET X=X
SET DIU=X
KILL Y
SET X=""
XECUTE ^DD(9002196,.2,1,2,2.4)
End DoDot:1
+48 SET X=$PIECE(DIKZ("PA"),U,1)
+49 IF X'=""
IF X
KILL ^ACRDOC("PA",X,"A",DA)
+50 SET DIKZ(0)=$GET(^ACRDOC(DA,0))
+51 SET X=$PIECE(DIKZ(0),U,26)
+52 IF X'=""
KILL ^ACRDOC("FS","FS"_$EXTRACT(X,1,30),DA)
+53 SET X=$PIECE(DIKZ(0),U,27)
+54 IF X'=""
KILL ^ACRDOC("FS",$EXTRACT(X,1,30),DA)
+55 SET DIKZ("PA")=$GET(^ACRDOC(DA,"PA"))
+56 SET X=$PIECE(DIKZ("PA"),U,3)
+57 IF X'=""
KILL ^ACRDOC("PS",$EXTRACT(X,1,30),DA)
+58 SET DIKZ(18)=$GET(^ACRDOC(DA,18))
+59 SET X=$PIECE(DIKZ(18),U,1)
+60 IF X'=""
KILL ^ACRDOC("P","SC"_$EXTRACT(X,1,30),DA)
+61 SET DIKZ("PO")=$GET(^ACRDOC(DA,"PO"))
+62 SET X=$PIECE(DIKZ("PO"),U,1)
+63 IF X'=""
KILL ^ACRDOC("S",$EXTRACT(X,1,30),DA)
+64 SET DIKZ("POST")=$GET(^ACRDOC(DA,"POST"))
+65 SET X=$PIECE(DIKZ("POST"),U,1)
+66 IF X'=""
IF $DATA(DA)
IF DA
IF $DATA(^ACRDOC(DA,"PO"))
IF $PIECE(^("PO"),U,12)
KILL ^ACRDOC("DI",$EXTRACT(X,1,30),$PIECE(^("PO"),U,12),DA)
+67 SET X=$PIECE(DIKZ("POST"),U,1)
+68 IF X'=""
KILL ^ACRDOC("RL",$EXTRACT(X,1,30),DA)
+69 SET X=$PIECE(DIKZ("PO"),U,5)
+70 IF X'=""
KILL ^ACRDOC("I",$EXTRACT(X,1,30),DA)
+71 SET X=$PIECE(DIKZ("PO"),U,12)
+72 IF X'=""
IF $DATA(DA)
IF DA
IF $DATA(^ACRDOC(DA,"POST"))
IF +^("POST")
KILL ^ACRDOC("DI",+^("POST"),$EXTRACT(X,1,30),DA)
+73 SET X=$PIECE(DIKZ("PO"),U,16)
+74 IF X'=""
KILL ^ACRDOC("L",$EXTRACT(X,1,30),DA)
+75 SET DIKZ(5)=$GET(^ACRDOC(DA,5))
+76 SET X=$PIECE(DIKZ(5),U,5)
+77 IF X'=""
KILL ^ACRDOC("I",$EXTRACT(X,1,30),DA)
+78 SET X=$PIECE(DIKZ(5),U,3)
+79 IF X'=""
KILL ^ACRDOC("J",$EXTRACT(X,1,30),DA)
+80 SET DIKZ("REQ")=$GET(^ACRDOC(DA,"REQ"))
+81 SET X=$PIECE(DIKZ("REQ"),U,10)
+82 IF X'=""
Begin DoDot:1
+83 NEW DIK,DIV,DIU,DIN
+84 KILL DIV
SET DIV=X
SET D0=DA
SET DIV(0)=D0
SET Y(1)=$SELECT($DATA(^ACRDOC(D0,"REQ1")):^("REQ1"),1:"")
SET X=$PIECE(Y(1),U,10)
SET X=X
SET DIU=X
KILL Y
XECUTE ^DD(9002196,113100,1,36,2.1)
XECUTE ^DD(9002196,113100,1,36,2.4)
End DoDot:1
+85 SET X=$PIECE(DIKZ("REQ"),U,10)
+86 IF X'=""
Begin DoDot:1
+87 NEW DIK,DIV,DIU,DIN
+88 KILL DIV
SET DIV=X
SET D0=DA
SET DIV(0)=D0
SET Y(1)=$SELECT($DATA(^ACRDOC(D0,"REQ2")):^("REQ2"),1:"")
SET X=$PIECE(Y(1),U,4)
SET X=X
SET DIU=X
KILL Y
SET X=""
XECUTE ^DD(9002196,113100,1,37,2.4)
End DoDot:1
+89 SET DIKZ("REQ2")=$GET(^ACRDOC(DA,"REQ2"))
+90 SET X=$PIECE(DIKZ("REQ2"),U,13)
+91 IF X'=""
KILL ^ACRDOC("PVEN",$EXTRACT(X,1,30),DA)
+92 SET DIKZ("TO")=$GET(^ACRDOC(DA,"TO"))
+93 SET X=$PIECE(DIKZ("TO"),U,20)
+94 IF X'=""
KILL ^ACRDOC("K",$EXTRACT(X,1,30),DA)
+95 SET X=$PIECE(DIKZ("TO"),U,9)
+96 IF X'=""
KILL ^ACRDOC("N",$EXTRACT(X,1,30),DA)
+97 SET X=$PIECE(DIKZ("TO"),U,12)
+98 IF X'=""
KILL ^ACRDOC("TDEPT",$EXTRACT(X,1,30),DA)
+99 SET X=$PIECE(DIKZ("TO"),U,14)
+100 IF X'=""
KILL ^ACRDOC("DD",$EXTRACT(X,1,30),DA)
+101 SET X=$PIECE(DIKZ("TO"),U,19)
+102 IF X'=""
IF $EXTRACT(X)'="Y"
SET $PIECE(^ACRDOC(+$GET(DA),"TO"),U,25)=""
+103 SET X=$PIECE(DIKZ("TO"),U,18)
+104 IF X'=""
Begin DoDot:1
+105 NEW DIK,DIV,DIU,DIN
+106 KILL DIV
SET DIV=X
SET D0=DA
SET DIV(0)=D0
SET Y(1)=$SELECT($DATA(^ACRDOC(D0,"REQ")):^("REQ"),1:"")
SET X=$PIECE(Y(1),U,12)
SET X=X
SET DIU=X
KILL Y
XECUTE ^DD(9002196,130150,1,1,2.1)
XECUTE ^DD(9002196,130150,1,1,2.4)
End DoDot:1
+107 SET DIKZ("TOAU")=$GET(^ACRDOC(DA,"TOAU"))
+108 SET X=$PIECE(DIKZ("TOAU"),U,2)
+109 IF X'=""
Begin DoDot:1
+110 NEW DIK,DIV,DIU,DIN
+111 KILL DIV
SET DIV=X
SET D0=DA
SET DIV(0)=D0
SET Y(1)=$SELECT($DATA(^ACRDOC(D0,"AU")):^("AU"),1:"")
SET X=$PIECE(Y(1),U,1)
SET X=X
SET DIU=X
KILL Y
XECUTE ^DD(9002196,130154,1,1,2.1)
XECUTE ^DD(9002196,130154,1,1,2.4)
End DoDot:1
+112 SET DIKZ("TO")=$GET(^ACRDOC(DA,"TO"))
+113 SET X=$PIECE(DIKZ("TO"),U,22)
+114 IF X'=""
Begin DoDot:1
+115 NEW DIK,DIV,DIU,DIN
+116 KILL DIV
SET DIV=X
SET D0=DA
SET DIV(0)=D0
SET Y(0)=X
SET Y(1)=$SELECT($DATA(^ACRDOC(D0,"TO")):^("TO"),1:"")
SET X=$PIECE(Y(1),U,22)
SET X=X
SET X=X=0
IF X
SET X=DIV
SET Y(1)=$SELECT($DATA(^ACRDOC(D0,"TOAU")):^("TOAU"),1:"")
SET X=$PIECE(Y(1),U,8)
SET X=X
SET DIU=X
KILL Y
SET X=""
XECUTE ^DD(9002196,130157,1,1,2.4)
End DoDot:1
+117 SET DIKZ("TOAU")=$GET(^ACRDOC(DA,"TOAU"))
+118 SET X=$PIECE(DIKZ("TOAU"),U,8)
+119 IF X'=""
Begin DoDot:1
+120 NEW DIK,DIV,DIU,DIN
+121 KILL DIV
SET DIV=X
SET D0=DA
SET DIV(0)=D0
SET Y(1)=$SELECT($DATA(^ACRDOC(D0,"TO")):^("TO"),1:"")
SET X=$PIECE(Y(1),U,26)
SET X=X
SET DIU=X
KILL Y
XECUTE ^DD(9002196,130177,1,1,2.1)
XECUTE ^DD(9002196,130177,1,1,2.4)
End DoDot:1
+122 SET DIKZ("TOAU")=$GET(^ACRDOC(DA,"TOAU"))
+123 SET X=$PIECE(DIKZ("TOAU"),U,9)
+124 IF X'=""
KILL ^ACRDOC("Q",$EXTRACT(X,1,30),DA)
+125 SET DIKZ("TRNG")=$GET(^ACRDOC(DA,"TRNG"))
+126 SET X=$PIECE(DIKZ("TRNG"),U,2)
+127 IF X'=""
KILL ^ACRDOC("F",$EXTRACT(X,1,30),DA)
+128 SET X=$PIECE(DIKZ("TRNG"),U,3)
+129 IF X'=""
KILL ^ACRDOC("M",$EXTRACT(X,1,30),DA)
+130 SET X=$PIECE(DIKZ("TRNG"),U,4)
+131 IF X'=""
Begin DoDot:1
+132 NEW DIK,DIV,DIU,DIN
+133 KILL DIV
SET DIV=X
SET D0=DA
SET DIV(0)=D0
XECUTE ^DD(9002196,148050,1,1,89.2)
SET X=$PIECE(Y(101),U,1)
SET D0=I(0,0)
SET DIU=X
KILL Y
XECUTE ^DD(9002196,148050,1,1,2.1)
XECUTE ^DD(9002196,148050,1,1,2.4)
End DoDot:1
+134 SET DIKZ("TRNG3")=$GET(^ACRDOC(DA,"TRNG3"))
+135 SET X=$PIECE(DIKZ("TRNG3"),U,1)
+136 IF X'=""
Begin DoDot:1
+137 NEW DIK,DIV,DIU,DIN
+138 KILL DIV
SET DIV=X
SET D0=DA
SET DIV(0)=D0
SET Y(1)=$SELECT($DATA(^ACRDOC(D0,"TRNG3")):^("TRNG3"),1:"")
SET X=$PIECE(Y(1),U,4)
SET X=X
SET DIU=X
KILL Y
XECUTE ^DD(9002196,148181,1,1,2.1)
XECUTE ^DD(9002196,148181,1,1,2.4)
End DoDot:1
+139 SET X=$PIECE(DIKZ("TRNG3"),U,1)
+140 IF X'=""
Begin DoDot:1
+141 NEW DIK,DIV,DIU,DIN
+142 KILL DIV
SET DIV=X
SET D0=DA
SET DIV(0)=D0
SET Y(1)=$SELECT($DATA(^ACRDOC(D0,"TRNG3")):^("TRNG3"),1:"")
SET X=$PIECE(Y(1),U,2)
SET X=X
SET DIU=X
KILL Y
XECUTE ^DD(9002196,148181,1,2,2.1)
XECUTE ^DD(9002196,148181,1,2,2.4)
End DoDot:1
+143 SET X=$PIECE(DIKZ("TRNG3"),U,1)
+144 IF X'=""
Begin DoDot:1
+145 NEW DIK,DIV,DIU,DIN
+146 KILL DIV
SET DIV=X
SET D0=DA
SET DIV(0)=D0
SET Y(1)=$SELECT($DATA(^ACRDOC(D0,"TRNG3")):^("TRNG3"),1:"")
SET X=$PIECE(Y(1),U,3)
SET X=X
SET DIU=X
KILL Y
XECUTE ^DD(9002196,148181,1,3,2.1)
XECUTE ^DD(9002196,148181,1,3,2.4)
End DoDot:1
+147 SET X=$PIECE(DIKZ("TRNG3"),U,1)
+148 IF X'=""
Begin DoDot:1
+149 NEW DIK,DIV,DIU,DIN
+150 KILL DIV
SET DIV=X
SET D0=DA
SET DIV(0)=D0
SET Y(1)=$SELECT($DATA(^ACRDOC(D0,"TRNG3")):^("TRNG3"),1:"")
SET X=$PIECE(Y(1),U,5)
SET X=X
SET DIU=X
KILL Y
XECUTE ^DD(9002196,148181,1,4,2.1)
XECUTE ^DD(9002196,148181,1,4,2.4)
End DoDot:1
+151 SET X=$PIECE(DIKZ("TRNG3"),U,1)
+152 IF X'=""
Begin DoDot:1
+153 NEW DIK,DIV,DIU,DIN
+154 KILL DIV
SET DIV=X
SET D0=DA
SET DIV(0)=D0
XECUTE ^DD(9002196,148181,1,5,89.2)
SET X=$SELECT('$DATA(^AUTTVNDR(+$PIECE(Y(101),U,1),0)):"",1:$PIECE(^(0),U,1))
SET D0=I(0,0)
SET DIU=X
KILL Y
XECUTE ^DD(9002196,148181,1,5,2.1)
XECUTE ^DD(9002196,148181,1,5,2.4)
End DoDot:1
+155 SET X=$PIECE(DIKZ("TRNG3"),U,1)
+156 IF X'=""
KILL ^ACRDOC("I",$EXTRACT(X,1,30),DA)
+157 SET DIKZ("TRNG4")=$GET(^ACRDOC(DA,"TRNG4"))
+158 SET X=$PIECE(DIKZ("TRNG4"),U,5)
+159 IF X'=""
Begin DoDot:1
+160 NEW DIK,DIV,DIU,DIN
+161 KILL DIV
SET DIV=X
SET D0=DA
SET DIV(0)=D0
SET Y(1)=$SELECT($DATA(^ACRDOC(D0,"AU")):^("AU"),1:"")
SET X=$PIECE(Y(1),U,1)
SET X=X
SET DIU=X
KILL Y
XECUTE ^DD(9002196,148310,1,1,2.1)
XECUTE ^DD(9002196,148310,1,1,2.4)
End DoDot:1
+162 SET DIKZ("TRNG4")=$GET(^ACRDOC(DA,"TRNG4"))
+163 SET X=$PIECE(DIKZ("TRNG4"),U,13)
+164 IF X'=""
KILL ^ACRDOC("R",$EXTRACT(X,1,30),DA)
+165 SET DIKZ("PR")=$GET(^ACRDOC(DA,"PR"))
+166 SET X=$PIECE(DIKZ("PR"),U,1)
+167 IF X'=""
Begin DoDot:1
+168 NEW DIK,DIV,DIU,DIN
+169 XECUTE ^DD(9002196,999010,1,1,2.3)
IF X
SET X=DIV
SET Y(1)=$SELECT($DATA(^ACRDOC(D0,"TRNG")):^("TRNG"),1:"")
SET X=$PIECE(Y(1),U,4)
SET X=X
SET DIU=X
KILL Y
XECUTE ^DD(9002196,999010,1,1,2.1)
XECUTE ^DD(9002196,999010,1,1,2.4)
End DoDot:1
+170 SET X=$PIECE(DIKZ("PR"),U,1)
+171 IF X'=""
KILL ^ACRDOC("PR",$EXTRACT(X,1,30),DA)
+172 SET DIKZ(0)=$GET(^ACRDOC(DA,0))
+173 SET X=$PIECE(DIKZ(0),U,1)
+174 IF X'=""
KILL ^ACRDOC("B",$EXTRACT(X,1,30),DA)
END GOTO ^ACRCD2
