ACRCD1.m

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)