ACRCSS1 ; COMPILED XREF FOR FILE #9002193 ; 09/30/09
;
S DIKZK=2
S DIKZ(0)=$G(^ACRSS(DA,0))
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(^ACRSS(D0,0)):^(0),1:"") S X=$P(Y(1),U,6),X=X S DIU=X K Y X ^DD(9002193,.02,1,1,2.1) X ^DD(9002193,.02,1,1,2.4)
S X=$P(DIKZ(0),U,2)
I X'="" K ^ACRSS("D",$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(^ACRSS(D0,0)):^(0),1:"") S X=$P(Y(1),U,10),X=X S DIU=X K Y X ^DD(9002193,.02,1,4,2.1) X ^DD(9002193,.02,1,4,2.4)
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(0)=X S Y(1)=$S($D(^ACRSS(D0,"DT")):^("DT"),1:"") S X=$P(Y(1),U,4)'="" I X S X=DIV X ^DD(9002193,.02,1,6,89.2) S X=$P(Y(101),U,1) S D0=I(0,0) S DIU=X K Y X ^DD(9002193,.02,1,6,2.1) X ^DD(9002193,.02,1,6,2.4)
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(0)=X S Y(1)=$S($D(^ACRSS(D0,"DT")):^("DT"),1:"") S X=$P(Y(1),U,9)'="" I X S X=DIV X ^DD(9002193,.02,1,7,89.2) S X=$P(Y(101),U,4) S D0=I(0,0) S DIU=X K Y X ^DD(9002193,.02,1,7,2.1) X ^DD(9002193,.02,1,7,2.4)
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(0)=X S Y(1)=$S($D(^ACRSS(D0,"DT")):^("DT"),1:"") S X=$P(Y(1),U,7)'="" I X S X=DIV X ^DD(9002193,.02,1,8,89.2) S X=$P(Y(101),U,2) S D0=I(0,0) S DIU=X K Y X ^DD(9002193,.02,1,8,2.1) X ^DD(9002193,.02,1,8,2.4)
S DIKZ(0)=$G(^ACRSS(DA,0))
S X=$P(DIKZ(0),U,3)
I X'="" K ^ACRSS("C",$E(X,1,30),DA)
S X=$P(DIKZ(0),U,3)
I X'="" D
.N DIK,DIV,DIU,DIN
.K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^ACRSS(D0,"PO")):^("PO"),1:"") S X=$P(Y(1),U,1),X=X S DIU=X K Y S X="" X ^DD(9002193,.03,1,2,2.4)
S DIKZ(0)=$G(^ACRSS(DA,0))
S X=$P(DIKZ(0),U,5)
I X'="" K ^ACRSS("CAN",$E(X,1,30),DA)
S X=$P(DIKZ(0),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(^ACRSS(D0,0)):^(0),1:"") S X=$P(Y(1),U,11),X=X S DIU=X K Y X ^DD(9002193,.05,1,2,2.1) X ^DD(9002193,.05,1,2,2.4)
S DIKZ(0)=$G(^ACRSS(DA,0))
S X=$P(DIKZ(0),U,6)
I X'="" K ^ACRSS("F",$E(X,1,30),DA)
S X=$P(DIKZ(0),U,6)
I X'="" D
.N DIK,DIV,DIU,DIN
.K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^ACRSS(D0,0)):^(0),1:"") S X=$P(Y(1),U,8),X=X S DIU=X K Y S X="" S DIH=$S($D(^ACRSS(DIV(0),0)):^(0),1:""),DIV=X S $P(^(0),U,8)=DIV,DIH=9002193,DIG=.08 D ^DICR:$O(^DD(DIH,DIG,1,0))>0
S X=$P(DIKZ(0),U,6)
I X'="" D
.N DIK,DIV,DIU,DIN
.K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^ACRSS(D0,0)):^(0),1:"") S X=$P(Y(1),U,9),X=X S DIU=X K Y S X="" S DIH=$S($D(^ACRSS(DIV(0),0)):^(0),1:""),DIV=X S $P(^(0),U,9)=DIV,DIH=9002193,DIG=.09 D ^DICR:$O(^DD(DIH,DIG,1,0))>0
S X=$P(DIKZ(0),U,6)
I X'="" D
.N DIK,DIV,DIU,DIN
.K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(101)=$S($D(^ACRLOCB(DIV,"BA")):^("BA"),1:"") S X=$P(Y(101),U,2) S DIU=X K Y X ^DD(9002193,.06,1,4,2.1) X ^DD(9002193,.06,1,4,2.4)
S X=$P(DIKZ(0),U,6)
I X'="" D
.N DIK,DIV,DIU,DIN
.K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(101)=$S($D(^ACRLOCB(DIV,"BA")):^("BA"),1:"") S X=$P(Y(101),U,5) S DIU=X K Y X ^DD(9002193,.06,1,5,2.1) X ^DD(9002193,.06,1,5,2.4)
S X=$P(DIKZ(0),U,6)
I X'="" D
.N DIK,DIV,DIU,DIN
.K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(101)=$S($D(^ACRLOCB(DIV,"BA")):^("BA"),1:"") S X=$P(Y(101),U,3) S DIU=X K Y X ^DD(9002193,.06,1,6,2.1) X ^DD(9002193,.06,1,6,2.4)
S DIKZ(0)=$G(^ACRSS(DA,0))
S X=$P(DIKZ(0),U,7)
I X'="" K ^ACRSS("E",$E(X,1,30),$P(^ACRSS(DA,0),U),DA)
S X=$P(DIKZ(0),U,8)
I X'="" K ^ACRSS("G",$E(X,1,30),DA)
S X=$P(DIKZ(0),U,9)
I X'="" K ^ACRSS("H",$E(X,1,30),DA)
S X=$P(DIKZ(0),U,11)
I X'="" K ^ACRSS("AREA",$E(X,1,30),DA)
S X=$P(DIKZ(0),U,12)
I X'="" D
.N DIK,DIV,DIU,DIN
.K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^ACRSS(D0,"DESC")):^("DESC"),1:"") S X=$P(Y(1),U,1),X=X S DIU=X K Y S X="" X ^DD(9002193,.12,1,1,2.4)
S X=$P(DIKZ(0),U,12)
I X'="" D
.N DIK,DIV,DIU,DIN
.K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^ACRSS(D0,"DESC")):^("DESC"),1:"") S X=$P(Y(1),U,2),X=X S DIU=X K Y S X="" X ^DD(9002193,.12,1,2,2.4)
S DIKZ(0)=$G(^ACRSS(DA,0))
S X=$P(DIKZ(0),U,13)
I X'="" K ^ACRSS("I",$E(X,1,30),DA)
S X=$P(DIKZ(0),U,13)
I X'="" I $P($G(^ACRSS(+$G(DA),"NMS")),U)]"",$P($G(^(0)),U,17) K ^ACRSS("PR",X,$P(^("NMS"),U),$P(^(0),U,17),DA)
S X=$P(DIKZ(0),U,15)
I X'="" K ^ACRSS("LCOD",$E(X,1,30),DA)
S X=$P(DIKZ(0),U,17)
I X'="" I $P($G(^ACRSS(+$G(DA),"NMS")),U)]"",$P(^(0),U,13) K ^ACRSS("PR",$P(^("NMS"),U),$P(^(0),U,13),X,DA)
S DIKZ("PO")=$G(^ACRSS(DA,"PO"))
S X=$P(DIKZ("PO"),U,1)
I X'="" K ^ACRSS("J",$E(X,1,30),DA)
S DIKZ("NMS")=$G(^ACRSS(DA,"NMS"))
S X=$P(DIKZ("NMS"),U,1)
I X'="" I $P($G(^ACRSS(+$G(DA),0)),U,13)]"",$P(^(0),U,17) K ^ACRSS("PR",$P(^(0),U,13),X,$P(^(0),U,17),DA)
S DIKZ("DT")=$G(^ACRSS(DA,"DT"))
S X=$P(DIKZ("DT"),U,3)
I X'="" D
.N DIK,DIV,DIU,DIN
.K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^ACRSS(D0,"DT")):^("DT"),1:"") S X=$P(Y(1),U,4),X=X S DIU=X K Y S X="" X ^DD(9002193,12,1,1,2.4)
S DIKZ("DT")=$G(^ACRSS(DA,"DT"))
S X=$P(DIKZ("DT"),U,4)
I X'="" D
.N DIK,DIV,DIU,DIN
.K DIV S DIV=X,D0=DA,DIV(0)=D0 X ^DD(9002193,13,1,1,89.2) S X=$P(Y(101),U,2) S D0=I(0,0) S DIU=X K Y S X=DIV S X=DIU-X X ^DD(9002193,13,1,1,2.4)
S X=$P(DIKZ("DT"),U,4)
I X'="" D
.N DIK,DIV,DIU,DIN
.K DIV S DIV=X,D0=DA,DIV(0)=D0 X ^DD(9002193,13,1,2,89.2) S X=$P(Y(101),U,2) S D0=I(0,0) S DIU=X K Y S X=DIV S X=DIU-X X ^DD(9002193,13,1,2,2.4)
S X=$P(DIKZ("DT"),U,4)
I X'="" D
.N DIK,DIV,DIU,DIN
.K DIV S DIV=X,D0=DA,DIV(0)=D0 X ^DD(9002193,13,1,3,89.2) S X=$P(Y(101),U,2) S D0=I(0,0) S DIU=X K Y S X=DIV S X=DIU-X X ^DD(9002193,13,1,3,2.4)
S X=$P(DIKZ("DT"),U,4)
I X'="" D
.N DIK,DIV,DIU,DIN
.K DIV S DIV=X,D0=DA,DIV(0)=D0 X ^DD(9002193,13,1,4,89.2) S X=$P(Y(101),U,1) S D0=I(0,0) S DIU=X K Y S X=DIV S X=DIU-X X ^DD(9002193,13,1,4,2.4)
S DIKZ("DT")=$G(^ACRSS(DA,"DT"))
S X=$P(DIKZ("DT"),U,21)
I X'="" D
.N DIK,DIV,DIU,DIN
.K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S X=X'=0 I X S X=DIV X ^DD(9002193,16.1,1,1,89.2) S X=$P(Y(101),U,2) S D0=I(0,0) S DIU=X K Y S X=DIV S X=DIU-X X ^DD(9002193,16.1,1,1,2.4)
S X=$P(DIKZ("DT"),U,21)
I X'="" D
.N DIK,DIV,DIU,DIN
.K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S X=X'=0 I X S X=DIV X ^DD(9002193,16.1,1,2,89.2) S X=$P(Y(101),U,3) S D0=I(0,0) S DIU=X K Y S X=DIV S X=DIU-X X ^DD(9002193,16.1,1,2,2.4)
S X=$P(DIKZ("DT"),U,21)
I X'="" D
.N DIK,DIV,DIU,DIN
.K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S X=X'=0 I X S X=DIV X ^DD(9002193,16.1,1,3,89.2) S X=$P(Y(101),U,3) S D0=I(0,0) S DIU=X K Y S X=DIV S X=DIU-X X ^DD(9002193,16.1,1,3,2.4)
S X=$P(DIKZ("DT"),U,21)
I X'="" D
.N DIK,DIV,DIU,DIN
.K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S X=X'=0 I X S X=DIV X ^DD(9002193,16.1,1,4,89.2) S X=$P(Y(101),U,3) S D0=I(0,0) S DIU=X K Y S X=DIV S X=DIU-X X ^DD(9002193,16.1,1,4,2.4)
S DIKZ("DT")=$G(^ACRSS(DA,"DT"))
S X=$P(DIKZ("DT"),U,9)
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(^ACRSS(D0,"DT")):^("DT"),1:"") S X=$P(Y(1),U,9)'="" I X S X=DIV X ^DD(9002193,18,1,1,89.2) S X=$P(Y(101),U,4) S D0=I(0,0) S DIU=X K Y S X=DIV S X=DIU-X X ^DD(9002193,18,1,1,2.4)
S X=$P(DIKZ("DT"),U,9)
I X'="" D
.N DIK,DIV,DIU,DIN
.K DIV S DIV=X,D0=DA,DIV(0)=D0 X ^DD(9002193,18,1,2,89.2) S X=$P(Y(101),U,5) S D0=I(0,0) S DIU=X K Y S X=DIV S X=DIU-X X ^DD(9002193,18,1,2,2.4)
S X=$P(DIKZ("DT"),U,9)
I X'="" D
.N DIK,DIV,DIU,DIN
.K DIV S DIV=X,D0=DA,DIV(0)=D0 X ^DD(9002193,18,1,3,89.2) S X=$P(Y(101),U,5) S D0=I(0,0) S DIU=X K Y S X=DIV S X=DIU-X X ^DD(9002193,18,1,3,2.4)
S X=$P(DIKZ("DT"),U,9)
I X'="" D
.N DIK,DIV,DIU,DIN
.K DIV S DIV=X,D0=DA,DIV(0)=D0 X ^DD(9002193,18,1,4,89.2) S X=$P(Y(101),U,5) S D0=I(0,0) S DIU=X K Y S X=DIV S X=DIU-X X ^DD(9002193,18,1,4,2.4)
S DIKZ("VND")=$G(^ACRSS(DA,"VND"))
S X=$P(DIKZ("VND"),U,1)
I X'="" K ^ACRSS("VND",$E(X,1,30),DA)
S DIKZ(0)=$G(^ACRSS(DA,0))
S X=$P(DIKZ(0),U,1)
END G ^ACRCSS2
ACRCSS1 ; COMPILED XREF FOR FILE #9002193 ; 09/30/09
+1 ;
+2 SET DIKZK=2
+3 SET DIKZ(0)=$GET(^ACRSS(DA,0))
+4 SET X=$PIECE(DIKZ(0),U,2)
+5 IF X'=""
Begin DoDot:1
+6 NEW DIK,DIV,DIU,DIN
+7 KILL DIV
SET DIV=X
SET D0=DA
SET DIV(0)=D0
SET Y(1)=$SELECT($DATA(^ACRSS(D0,0)):^(0),1:"")
SET X=$PIECE(Y(1),U,6)
SET X=X
SET DIU=X
KILL Y
XECUTE ^DD(9002193,.02,1,1,2.1)
XECUTE ^DD(9002193,.02,1,1,2.4)
End DoDot:1
+8 SET X=$PIECE(DIKZ(0),U,2)
+9 IF X'=""
KILL ^ACRSS("D",$EXTRACT(X,1,30),DA)
+10 SET X=$PIECE(DIKZ(0),U,2)
+11 IF X'=""
Begin DoDot:1
+12 NEW DIK,DIV,DIU,DIN
+13 KILL DIV
SET DIV=X
SET D0=DA
SET DIV(0)=D0
SET Y(1)=$SELECT($DATA(^ACRSS(D0,0)):^(0),1:"")
SET X=$PIECE(Y(1),U,10)
SET X=X
SET DIU=X
KILL Y
XECUTE ^DD(9002193,.02,1,4,2.1)
XECUTE ^DD(9002193,.02,1,4,2.4)
End DoDot:1
+14 SET X=$PIECE(DIKZ(0),U,2)
+15 IF X'=""
Begin DoDot:1
+16 NEW DIK,DIV,DIU,DIN
+17 KILL DIV
SET DIV=X
SET D0=DA
SET DIV(0)=D0
SET Y(0)=X
SET Y(1)=$SELECT($DATA(^ACRSS(D0,"DT")):^("DT"),1:"")
SET X=$PIECE(Y(1),U,4)'=""
IF X
SET X=DIV
XECUTE ^DD(9002193,.02,1,6,89.2)
SET X=$PIECE(Y(101),U,1)
SET D0=I(0,0)
SET DIU=X
KILL Y
XECUTE ^DD(9002193,.02,1,6,2.1)
XECUTE ^DD(9002193,.02,1,6,2.4)
End DoDot:1
+18 SET X=$PIECE(DIKZ(0),U,2)
+19 IF X'=""
Begin DoDot:1
+20 NEW DIK,DIV,DIU,DIN
+21 KILL DIV
SET DIV=X
SET D0=DA
SET DIV(0)=D0
SET Y(0)=X
SET Y(1)=$SELECT($DATA(^ACRSS(D0,"DT")):^("DT"),1:"")
SET X=$PIECE(Y(1),U,9)'=""
IF X
SET X=DIV
XECUTE ^DD(9002193,.02,1,7,89.2)
SET X=$PIECE(Y(101),U,4)
SET D0=I(0,0)
SET DIU=X
KILL Y
XECUTE ^DD(9002193,.02,1,7,2.1)
XECUTE ^DD(9002193,.02,1,7,2.4)
End DoDot:1
+22 SET X=$PIECE(DIKZ(0),U,2)
+23 IF X'=""
Begin DoDot:1
+24 NEW DIK,DIV,DIU,DIN
+25 KILL DIV
SET DIV=X
SET D0=DA
SET DIV(0)=D0
SET Y(0)=X
SET Y(1)=$SELECT($DATA(^ACRSS(D0,"DT")):^("DT"),1:"")
SET X=$PIECE(Y(1),U,7)'=""
IF X
SET X=DIV
XECUTE ^DD(9002193,.02,1,8,89.2)
SET X=$PIECE(Y(101),U,2)
SET D0=I(0,0)
SET DIU=X
KILL Y
XECUTE ^DD(9002193,.02,1,8,2.1)
XECUTE ^DD(9002193,.02,1,8,2.4)
End DoDot:1
+26 SET DIKZ(0)=$GET(^ACRSS(DA,0))
+27 SET X=$PIECE(DIKZ(0),U,3)
+28 IF X'=""
KILL ^ACRSS("C",$EXTRACT(X,1,30),DA)
+29 SET X=$PIECE(DIKZ(0),U,3)
+30 IF X'=""
Begin DoDot:1
+31 NEW DIK,DIV,DIU,DIN
+32 KILL DIV
SET DIV=X
SET D0=DA
SET DIV(0)=D0
SET Y(1)=$SELECT($DATA(^ACRSS(D0,"PO")):^("PO"),1:"")
SET X=$PIECE(Y(1),U,1)
SET X=X
SET DIU=X
KILL Y
SET X=""
XECUTE ^DD(9002193,.03,1,2,2.4)
End DoDot:1
+33 SET DIKZ(0)=$GET(^ACRSS(DA,0))
+34 SET X=$PIECE(DIKZ(0),U,5)
+35 IF X'=""
KILL ^ACRSS("CAN",$EXTRACT(X,1,30),DA)
+36 SET X=$PIECE(DIKZ(0),U,5)
+37 IF X'=""
Begin DoDot:1
+38 NEW DIK,DIV,DIU,DIN
+39 KILL DIV
SET DIV=X
SET D0=DA
SET DIV(0)=D0
SET Y(1)=$SELECT($DATA(^ACRSS(D0,0)):^(0),1:"")
SET X=$PIECE(Y(1),U,11)
SET X=X
SET DIU=X
KILL Y
XECUTE ^DD(9002193,.05,1,2,2.1)
XECUTE ^DD(9002193,.05,1,2,2.4)
End DoDot:1
+40 SET DIKZ(0)=$GET(^ACRSS(DA,0))
+41 SET X=$PIECE(DIKZ(0),U,6)
+42 IF X'=""
KILL ^ACRSS("F",$EXTRACT(X,1,30),DA)
+43 SET X=$PIECE(DIKZ(0),U,6)
+44 IF X'=""
Begin DoDot:1
+45 NEW DIK,DIV,DIU,DIN
+46 KILL DIV
SET DIV=X
SET D0=DA
SET DIV(0)=D0
SET Y(1)=$SELECT($DATA(^ACRSS(D0,0)):^(0),1:"")
SET X=$PIECE(Y(1),U,8)
SET X=X
SET DIU=X
KILL Y
SET X=""
SET DIH=$SELECT($DATA(^ACRSS(DIV(0),0)):^(0),1:"")
SET DIV=X
SET $PIECE(^(0),U,8)=DIV
SET DIH=9002193
SET DIG=.08
IF $ORDER(^DD(DIH,DIG,1,0))>0
DO ^DICR
End DoDot:1
+47 SET X=$PIECE(DIKZ(0),U,6)
+48 IF X'=""
Begin DoDot:1
+49 NEW DIK,DIV,DIU,DIN
+50 KILL DIV
SET DIV=X
SET D0=DA
SET DIV(0)=D0
SET Y(1)=$SELECT($DATA(^ACRSS(D0,0)):^(0),1:"")
SET X=$PIECE(Y(1),U,9)
SET X=X
SET DIU=X
KILL Y
SET X=""
SET DIH=$SELECT($DATA(^ACRSS(DIV(0),0)):^(0),1:"")
SET DIV=X
SET $PIECE(^(0),U,9)=DIV
SET DIH=9002193
SET DIG=.09
IF $ORDER(^DD(DIH,DIG,1,0))>0
DO ^DICR
End DoDot:1
+51 SET X=$PIECE(DIKZ(0),U,6)
+52 IF X'=""
Begin DoDot:1
+53 NEW DIK,DIV,DIU,DIN
+54 KILL DIV
SET DIV=X
SET D0=DA
SET DIV(0)=D0
SET Y(101)=$SELECT($DATA(^ACRLOCB(DIV,"BA")):^("BA"),1:"")
SET X=$PIECE(Y(101),U,2)
SET DIU=X
KILL Y
XECUTE ^DD(9002193,.06,1,4,2.1)
XECUTE ^DD(9002193,.06,1,4,2.4)
End DoDot:1
+55 SET X=$PIECE(DIKZ(0),U,6)
+56 IF X'=""
Begin DoDot:1
+57 NEW DIK,DIV,DIU,DIN
+58 KILL DIV
SET DIV=X
SET D0=DA
SET DIV(0)=D0
SET Y(101)=$SELECT($DATA(^ACRLOCB(DIV,"BA")):^("BA"),1:"")
SET X=$PIECE(Y(101),U,5)
SET DIU=X
KILL Y
XECUTE ^DD(9002193,.06,1,5,2.1)
XECUTE ^DD(9002193,.06,1,5,2.4)
End DoDot:1
+59 SET X=$PIECE(DIKZ(0),U,6)
+60 IF X'=""
Begin DoDot:1
+61 NEW DIK,DIV,DIU,DIN
+62 KILL DIV
SET DIV=X
SET D0=DA
SET DIV(0)=D0
SET Y(101)=$SELECT($DATA(^ACRLOCB(DIV,"BA")):^("BA"),1:"")
SET X=$PIECE(Y(101),U,3)
SET DIU=X
KILL Y
XECUTE ^DD(9002193,.06,1,6,2.1)
XECUTE ^DD(9002193,.06,1,6,2.4)
End DoDot:1
+63 SET DIKZ(0)=$GET(^ACRSS(DA,0))
+64 SET X=$PIECE(DIKZ(0),U,7)
+65 IF X'=""
KILL ^ACRSS("E",$EXTRACT(X,1,30),$PIECE(^ACRSS(DA,0),U),DA)
+66 SET X=$PIECE(DIKZ(0),U,8)
+67 IF X'=""
KILL ^ACRSS("G",$EXTRACT(X,1,30),DA)
+68 SET X=$PIECE(DIKZ(0),U,9)
+69 IF X'=""
KILL ^ACRSS("H",$EXTRACT(X,1,30),DA)
+70 SET X=$PIECE(DIKZ(0),U,11)
+71 IF X'=""
KILL ^ACRSS("AREA",$EXTRACT(X,1,30),DA)
+72 SET X=$PIECE(DIKZ(0),U,12)
+73 IF X'=""
Begin DoDot:1
+74 NEW DIK,DIV,DIU,DIN
+75 KILL DIV
SET DIV=X
SET D0=DA
SET DIV(0)=D0
SET Y(1)=$SELECT($DATA(^ACRSS(D0,"DESC")):^("DESC"),1:"")
SET X=$PIECE(Y(1),U,1)
SET X=X
SET DIU=X
KILL Y
SET X=""
XECUTE ^DD(9002193,.12,1,1,2.4)
End DoDot:1
+76 SET X=$PIECE(DIKZ(0),U,12)
+77 IF X'=""
Begin DoDot:1
+78 NEW DIK,DIV,DIU,DIN
+79 KILL DIV
SET DIV=X
SET D0=DA
SET DIV(0)=D0
SET Y(1)=$SELECT($DATA(^ACRSS(D0,"DESC")):^("DESC"),1:"")
SET X=$PIECE(Y(1),U,2)
SET X=X
SET DIU=X
KILL Y
SET X=""
XECUTE ^DD(9002193,.12,1,2,2.4)
End DoDot:1
+80 SET DIKZ(0)=$GET(^ACRSS(DA,0))
+81 SET X=$PIECE(DIKZ(0),U,13)
+82 IF X'=""
KILL ^ACRSS("I",$EXTRACT(X,1,30),DA)
+83 SET X=$PIECE(DIKZ(0),U,13)
+84 IF X'=""
IF $PIECE($GET(^ACRSS(+$GET(DA),"NMS")),U)]""
IF $PIECE($GET(^(0)),U,17)
KILL ^ACRSS("PR",X,$PIECE(^("NMS"),U),$PIECE(^(0),U,17),DA)
+85 SET X=$PIECE(DIKZ(0),U,15)
+86 IF X'=""
KILL ^ACRSS("LCOD",$EXTRACT(X,1,30),DA)
+87 SET X=$PIECE(DIKZ(0),U,17)
+88 IF X'=""
IF $PIECE($GET(^ACRSS(+$GET(DA),"NMS")),U)]""
IF $PIECE(^(0),U,13)
KILL ^ACRSS("PR",$PIECE(^("NMS"),U),$PIECE(^(0),U,13),X,DA)
+89 SET DIKZ("PO")=$GET(^ACRSS(DA,"PO"))
+90 SET X=$PIECE(DIKZ("PO"),U,1)
+91 IF X'=""
KILL ^ACRSS("J",$EXTRACT(X,1,30),DA)
+92 SET DIKZ("NMS")=$GET(^ACRSS(DA,"NMS"))
+93 SET X=$PIECE(DIKZ("NMS"),U,1)
+94 IF X'=""
IF $PIECE($GET(^ACRSS(+$GET(DA),0)),U,13)]""
IF $PIECE(^(0),U,17)
KILL ^ACRSS("PR",$PIECE(^(0),U,13),X,$PIECE(^(0),U,17),DA)
+95 SET DIKZ("DT")=$GET(^ACRSS(DA,"DT"))
+96 SET X=$PIECE(DIKZ("DT"),U,3)
+97 IF X'=""
Begin DoDot:1
+98 NEW DIK,DIV,DIU,DIN
+99 KILL DIV
SET DIV=X
SET D0=DA
SET DIV(0)=D0
SET Y(1)=$SELECT($DATA(^ACRSS(D0,"DT")):^("DT"),1:"")
SET X=$PIECE(Y(1),U,4)
SET X=X
SET DIU=X
KILL Y
SET X=""
XECUTE ^DD(9002193,12,1,1,2.4)
End DoDot:1
+100 SET DIKZ("DT")=$GET(^ACRSS(DA,"DT"))
+101 SET X=$PIECE(DIKZ("DT"),U,4)
+102 IF X'=""
Begin DoDot:1
+103 NEW DIK,DIV,DIU,DIN
+104 KILL DIV
SET DIV=X
SET D0=DA
SET DIV(0)=D0
XECUTE ^DD(9002193,13,1,1,89.2)
SET X=$PIECE(Y(101),U,2)
SET D0=I(0,0)
SET DIU=X
KILL Y
SET X=DIV
SET X=DIU-X
XECUTE ^DD(9002193,13,1,1,2.4)
End DoDot:1
+105 SET X=$PIECE(DIKZ("DT"),U,4)
+106 IF X'=""
Begin DoDot:1
+107 NEW DIK,DIV,DIU,DIN
+108 KILL DIV
SET DIV=X
SET D0=DA
SET DIV(0)=D0
XECUTE ^DD(9002193,13,1,2,89.2)
SET X=$PIECE(Y(101),U,2)
SET D0=I(0,0)
SET DIU=X
KILL Y
SET X=DIV
SET X=DIU-X
XECUTE ^DD(9002193,13,1,2,2.4)
End DoDot:1
+109 SET X=$PIECE(DIKZ("DT"),U,4)
+110 IF X'=""
Begin DoDot:1
+111 NEW DIK,DIV,DIU,DIN
+112 KILL DIV
SET DIV=X
SET D0=DA
SET DIV(0)=D0
XECUTE ^DD(9002193,13,1,3,89.2)
SET X=$PIECE(Y(101),U,2)
SET D0=I(0,0)
SET DIU=X
KILL Y
SET X=DIV
SET X=DIU-X
XECUTE ^DD(9002193,13,1,3,2.4)
End DoDot:1
+113 SET X=$PIECE(DIKZ("DT"),U,4)
+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
XECUTE ^DD(9002193,13,1,4,89.2)
SET X=$PIECE(Y(101),U,1)
SET D0=I(0,0)
SET DIU=X
KILL Y
SET X=DIV
SET X=DIU-X
XECUTE ^DD(9002193,13,1,4,2.4)
End DoDot:1
+117 SET DIKZ("DT")=$GET(^ACRSS(DA,"DT"))
+118 SET X=$PIECE(DIKZ("DT"),U,21)
+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(0)=X
SET X=X'=0
IF X
SET X=DIV
XECUTE ^DD(9002193,16.1,1,1,89.2)
SET X=$PIECE(Y(101),U,2)
SET D0=I(0,0)
SET DIU=X
KILL Y
SET X=DIV
SET X=DIU-X
XECUTE ^DD(9002193,16.1,1,1,2.4)
End DoDot:1
+122 SET X=$PIECE(DIKZ("DT"),U,21)
+123 IF X'=""
Begin DoDot:1
+124 NEW DIK,DIV,DIU,DIN
+125 KILL DIV
SET DIV=X
SET D0=DA
SET DIV(0)=D0
SET Y(0)=X
SET X=X'=0
IF X
SET X=DIV
XECUTE ^DD(9002193,16.1,1,2,89.2)
SET X=$PIECE(Y(101),U,3)
SET D0=I(0,0)
SET DIU=X
KILL Y
SET X=DIV
SET X=DIU-X
XECUTE ^DD(9002193,16.1,1,2,2.4)
End DoDot:1
+126 SET X=$PIECE(DIKZ("DT"),U,21)
+127 IF X'=""
Begin DoDot:1
+128 NEW DIK,DIV,DIU,DIN
+129 KILL DIV
SET DIV=X
SET D0=DA
SET DIV(0)=D0
SET Y(0)=X
SET X=X'=0
IF X
SET X=DIV
XECUTE ^DD(9002193,16.1,1,3,89.2)
SET X=$PIECE(Y(101),U,3)
SET D0=I(0,0)
SET DIU=X
KILL Y
SET X=DIV
SET X=DIU-X
XECUTE ^DD(9002193,16.1,1,3,2.4)
End DoDot:1
+130 SET X=$PIECE(DIKZ("DT"),U,21)
+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
SET Y(0)=X
SET X=X'=0
IF X
SET X=DIV
XECUTE ^DD(9002193,16.1,1,4,89.2)
SET X=$PIECE(Y(101),U,3)
SET D0=I(0,0)
SET DIU=X
KILL Y
SET X=DIV
SET X=DIU-X
XECUTE ^DD(9002193,16.1,1,4,2.4)
End DoDot:1
+134 SET DIKZ("DT")=$GET(^ACRSS(DA,"DT"))
+135 SET X=$PIECE(DIKZ("DT"),U,9)
+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(0)=X
SET Y(1)=$SELECT($DATA(^ACRSS(D0,"DT")):^("DT"),1:"")
SET X=$PIECE(Y(1),U,9)'=""
IF X
SET X=DIV
XECUTE ^DD(9002193,18,1,1,89.2)
SET X=$PIECE(Y(101),U,4)
SET D0=I(0,0)
SET DIU=X
KILL Y
SET X=DIV
SET X=DIU-X
XECUTE ^DD(9002193,18,1,1,2.4)
End DoDot:1
+139 SET X=$PIECE(DIKZ("DT"),U,9)
+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
XECUTE ^DD(9002193,18,1,2,89.2)
SET X=$PIECE(Y(101),U,5)
SET D0=I(0,0)
SET DIU=X
KILL Y
SET X=DIV
SET X=DIU-X
XECUTE ^DD(9002193,18,1,2,2.4)
End DoDot:1
+143 SET X=$PIECE(DIKZ("DT"),U,9)
+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
XECUTE ^DD(9002193,18,1,3,89.2)
SET X=$PIECE(Y(101),U,5)
SET D0=I(0,0)
SET DIU=X
KILL Y
SET X=DIV
SET X=DIU-X
XECUTE ^DD(9002193,18,1,3,2.4)
End DoDot:1
+147 SET X=$PIECE(DIKZ("DT"),U,9)
+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
XECUTE ^DD(9002193,18,1,4,89.2)
SET X=$PIECE(Y(101),U,5)
SET D0=I(0,0)
SET DIU=X
KILL Y
SET X=DIV
SET X=DIU-X
XECUTE ^DD(9002193,18,1,4,2.4)
End DoDot:1
+151 SET DIKZ("VND")=$GET(^ACRSS(DA,"VND"))
+152 SET X=$PIECE(DIKZ("VND"),U,1)
+153 IF X'=""
KILL ^ACRSS("VND",$EXTRACT(X,1,30),DA)
+154 SET DIKZ(0)=$GET(^ACRSS(DA,0))
+155 SET X=$PIECE(DIKZ(0),U,1)
END GOTO ^ACRCSS2
