- ACRCR1 ; COMPILED XREF FOR FILE #9002189 ; 09/30/09
- ;
- S DIKZK=2
- S DIKZ(0)=$G(^ACROBL(DA,0))
- S X=$P(DIKZ(0),U,2)
- I X'="" K ^ACROBL("C",$E(X,1,30),DA)
- S X=$P(DIKZ(0),U,3)
- I X'="" K ^ACROBL("D",$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(^ACROBL(D0,0)):^(0),1:"") S X=$P(Y(1),U,12),X=X S DIU=X K Y X ^DD(9002189,.03,1,3,2.1) X ^DD(9002189,.03,1,3,2.4)
- 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 X ^DD(9002189,.03,1,4,89.2) S X=$P(Y(101),U,2) S D0=I(0,0) S DIU=X K Y X ^DD(9002189,.03,1,4,2.1) X ^DD(9002189,.03,1,4,2.4)
- 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(^ACROBL(D0,0)):^(0),1:"") S X=$P(Y(1),U,13),X=X S DIU=X K Y X ^DD(9002189,.03,1,5,2.1) X ^DD(9002189,.03,1,5,2.4)
- S DIKZ(0)=$G(^ACROBL(DA,0))
- S X=$P(DIKZ(0),U,4)
- I X'="" K ^ACROBL("CAN",$E(X,1,30),DA)
- S X=$P(DIKZ(0),U,7)
- I X'="" D
- .N DIK,DIV,DIU,DIN
- .K DIV S DIV=X,D0=DA,DIV(0)=D0 X ^DD(9002189,.07,1,1,89.2) S X=$P(Y(101),U,2) S D0=I(0,0) S DIU=X K Y X ^DD(9002189,.07,1,1,2.1) X ^DD(9002189,.07,1,1,2.4)
- S X=$P(DIKZ(0),U,7)
- I X'="" D
- .N DIK,DIV,DIU,DIN
- .K DIV S DIV=X,D0=DA,DIV(0)=D0 X ^DD(9002189,.07,1,2,89.2) S X=$P(Y(101),U,3) S D0=I(0,0) S DIU=X K Y X ^DD(9002189,.07,1,2,2.1) X ^DD(9002189,.07,1,2,2.4)
- S DIKZ(0)=$G(^ACROBL(DA,0))
- S X=$P(DIKZ(0),U,9)
- I X'="" D
- .N DIK,DIV,DIU,DIN
- .K DIV S DIV=X,D0=DA,DIV(0)=D0 X ^DD(9002189,.09,1,1,89.2) S X=$P(Y(101),U,2) S D0=I(0,0) S DIU=X K Y X ^DD(9002189,.09,1,1,2.1) X ^DD(9002189,.09,1,1,2.4)
- S X=$P(DIKZ(0),U,9)
- I X'="" D
- .N DIK,DIV,DIU,DIN
- .K DIV S DIV=X,D0=DA,DIV(0)=D0 X ^DD(9002189,.09,1,2,89.2) S X=$P(Y(101),U,3) S D0=I(0,0) S DIU=X K Y X ^DD(9002189,.09,1,2,2.1) X ^DD(9002189,.09,1,2,2.4)
- S DIKZ(0)=$G(^ACROBL(DA,0))
- S X=$P(DIKZ(0),U,12)
- I X'="" K ^ACROBL("LOT",$E(X,1,30),DA)
- S X=$P(DIKZ(0),U,13)
- I X'="" K ^ACROBL("PROP",$E(X,1,30),DA)
- S DIKZ("DT")=$G(^ACROBL(DA,"DT"))
- S X=$P(DIKZ("DT"),U,1)
- I X'="" K ^ACROBL("DOC",$E(X,1,30),DA)
- S X=$P(DIKZ("DT"),U,3)
- I X'="" K ^ACROBL("OC",$E(X,1,30),DA)
- S DIKZ("VND")=$G(^ACROBL(DA,"VND"))
- S X=$P(DIKZ("VND"),U,1)
- I X'="" K ^ACROBL("VND",$E(X,1,30),DA)
- S DIKZ("APV")=$G(^ACROBL(DA,"APV"))
- S X=$P(DIKZ("APV"),U,1)
- I X'="" K ^ACRDOC("RL",+$G(^ACRDOC(DA,"POST")),DA)
- S DIKZ("CONV")=$G(^ACROBL(DA,"CONV"))
- S X=$P(DIKZ("CONV"),U,1)
- I X'="" I $D(^ACROBL(DA,"CONV")),$P(^("CONV"),U)["Y" K ^ACROBL("ACONV",$P(^ACROBL(DA,0),U,3),$P(^("CONV"),U),DA)
- S X=$P(DIKZ("APV"),U,4)
- I X'="" D
- .N DIK,DIV,DIU,DIN
- .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^ACROBL(D0,"APV")):^("APV"),1:"") S X=$P(Y(1),U,7),X=X S DIU=X K Y X ^DD(9002189,907,1,1,2.1) X ^DD(9002189,907,1,1,2.4)
- S X=$P(DIKZ("APV"),U,4)
- I X'="" D
- .N DIK,DIV,DIU,DIN
- .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^ACROBL(D0,0)):^(0),1:"") S X=$P(Y(1),U,10),X=X S DIU=X K Y X ^DD(9002189,907,1,2,2.1) X ^DD(9002189,907,1,2,2.4)
- S DIKZ("APV")=$G(^ACROBL(DA,"APV"))
- S X=$P(DIKZ("APV"),U,6)
- I X'="" K ^ACRDOC("RL",+$G(^ACRDOC(DA,"POST")),DA)
- S X=$P(DIKZ("APV"),U,7)
- I X'="" K ^ACROBL("TV",$E(X,1,30),DA)
- S X=$P(DIKZ("APV"),U,8)
- I X'="" I X]"",$P($G(^ACRDOC(DA,0)),U,8),+$G(^("REQ")) S ^ACRDOC("PO",+$P(^(0),U,8),"A",DA)=""
- S X=$P(DIKZ("APV"),U,8)
- I X'="" I X]"",+$G(^ACRDOC(DA,"PA")) S ^ACRDOC("P",+^("PA"),"A",DA)=""
- END G ^ACRCR2
- ACRCR1 ; COMPILED XREF FOR FILE #9002189 ; 09/30/09
- +1 ;
- +2 SET DIKZK=2
- +3 SET DIKZ(0)=$GET(^ACROBL(DA,0))
- +4 SET X=$PIECE(DIKZ(0),U,2)
- +5 IF X'=""
- KILL ^ACROBL("C",$EXTRACT(X,1,30),DA)
- +6 SET X=$PIECE(DIKZ(0),U,3)
- +7 IF X'=""
- KILL ^ACROBL("D",$EXTRACT(X,1,30),DA)
- +8 SET X=$PIECE(DIKZ(0),U,3)
- +9 IF X'=""
- Begin DoDot:1
- +10 NEW DIK,DIV,DIU,DIN
- +11 KILL DIV
- SET DIV=X
- SET D0=DA
- SET DIV(0)=D0
- SET Y(1)=$SELECT($DATA(^ACROBL(D0,0)):^(0),1:"")
- SET X=$PIECE(Y(1),U,12)
- SET X=X
- SET DIU=X
- KILL Y
- XECUTE ^DD(9002189,.03,1,3,2.1)
- XECUTE ^DD(9002189,.03,1,3,2.4)
- End DoDot:1
- +12 SET X=$PIECE(DIKZ(0),U,3)
- +13 IF X'=""
- Begin DoDot:1
- +14 NEW DIK,DIV,DIU,DIN
- +15 KILL DIV
- SET DIV=X
- SET D0=DA
- SET DIV(0)=D0
- XECUTE ^DD(9002189,.03,1,4,89.2)
- SET X=$PIECE(Y(101),U,2)
- SET D0=I(0,0)
- SET DIU=X
- KILL Y
- XECUTE ^DD(9002189,.03,1,4,2.1)
- XECUTE ^DD(9002189,.03,1,4,2.4)
- End DoDot:1
- +16 SET X=$PIECE(DIKZ(0),U,3)
- +17 IF X'=""
- Begin DoDot:1
- +18 NEW DIK,DIV,DIU,DIN
- +19 KILL DIV
- SET DIV=X
- SET D0=DA
- SET DIV(0)=D0
- SET Y(1)=$SELECT($DATA(^ACROBL(D0,0)):^(0),1:"")
- SET X=$PIECE(Y(1),U,13)
- SET X=X
- SET DIU=X
- KILL Y
- XECUTE ^DD(9002189,.03,1,5,2.1)
- XECUTE ^DD(9002189,.03,1,5,2.4)
- End DoDot:1
- +20 SET DIKZ(0)=$GET(^ACROBL(DA,0))
- +21 SET X=$PIECE(DIKZ(0),U,4)
- +22 IF X'=""
- KILL ^ACROBL("CAN",$EXTRACT(X,1,30),DA)
- +23 SET X=$PIECE(DIKZ(0),U,7)
- +24 IF X'=""
- Begin DoDot:1
- +25 NEW DIK,DIV,DIU,DIN
- +26 KILL DIV
- SET DIV=X
- SET D0=DA
- SET DIV(0)=D0
- XECUTE ^DD(9002189,.07,1,1,89.2)
- SET X=$PIECE(Y(101),U,2)
- SET D0=I(0,0)
- SET DIU=X
- KILL Y
- XECUTE ^DD(9002189,.07,1,1,2.1)
- XECUTE ^DD(9002189,.07,1,1,2.4)
- End DoDot:1
- +27 SET X=$PIECE(DIKZ(0),U,7)
- +28 IF X'=""
- Begin DoDot:1
- +29 NEW DIK,DIV,DIU,DIN
- +30 KILL DIV
- SET DIV=X
- SET D0=DA
- SET DIV(0)=D0
- XECUTE ^DD(9002189,.07,1,2,89.2)
- SET X=$PIECE(Y(101),U,3)
- SET D0=I(0,0)
- SET DIU=X
- KILL Y
- XECUTE ^DD(9002189,.07,1,2,2.1)
- XECUTE ^DD(9002189,.07,1,2,2.4)
- End DoDot:1
- +31 SET DIKZ(0)=$GET(^ACROBL(DA,0))
- +32 SET X=$PIECE(DIKZ(0),U,9)
- +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
- XECUTE ^DD(9002189,.09,1,1,89.2)
- SET X=$PIECE(Y(101),U,2)
- SET D0=I(0,0)
- SET DIU=X
- KILL Y
- XECUTE ^DD(9002189,.09,1,1,2.1)
- XECUTE ^DD(9002189,.09,1,1,2.4)
- End DoDot:1
- +36 SET X=$PIECE(DIKZ(0),U,9)
- +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
- XECUTE ^DD(9002189,.09,1,2,89.2)
- SET X=$PIECE(Y(101),U,3)
- SET D0=I(0,0)
- SET DIU=X
- KILL Y
- XECUTE ^DD(9002189,.09,1,2,2.1)
- XECUTE ^DD(9002189,.09,1,2,2.4)
- End DoDot:1
- +40 SET DIKZ(0)=$GET(^ACROBL(DA,0))
- +41 SET X=$PIECE(DIKZ(0),U,12)
- +42 IF X'=""
- KILL ^ACROBL("LOT",$EXTRACT(X,1,30),DA)
- +43 SET X=$PIECE(DIKZ(0),U,13)
- +44 IF X'=""
- KILL ^ACROBL("PROP",$EXTRACT(X,1,30),DA)
- +45 SET DIKZ("DT")=$GET(^ACROBL(DA,"DT"))
- +46 SET X=$PIECE(DIKZ("DT"),U,1)
- +47 IF X'=""
- KILL ^ACROBL("DOC",$EXTRACT(X,1,30),DA)
- +48 SET X=$PIECE(DIKZ("DT"),U,3)
- +49 IF X'=""
- KILL ^ACROBL("OC",$EXTRACT(X,1,30),DA)
- +50 SET DIKZ("VND")=$GET(^ACROBL(DA,"VND"))
- +51 SET X=$PIECE(DIKZ("VND"),U,1)
- +52 IF X'=""
- KILL ^ACROBL("VND",$EXTRACT(X,1,30),DA)
- +53 SET DIKZ("APV")=$GET(^ACROBL(DA,"APV"))
- +54 SET X=$PIECE(DIKZ("APV"),U,1)
- +55 IF X'=""
- KILL ^ACRDOC("RL",+$GET(^ACRDOC(DA,"POST")),DA)
- +56 SET DIKZ("CONV")=$GET(^ACROBL(DA,"CONV"))
- +57 SET X=$PIECE(DIKZ("CONV"),U,1)
- +58 IF X'=""
- IF $DATA(^ACROBL(DA,"CONV"))
- IF $PIECE(^("CONV"),U)["Y"
- KILL ^ACROBL("ACONV",$PIECE(^ACROBL(DA,0),U,3),$PIECE(^("CONV"),U),DA)
- +59 SET X=$PIECE(DIKZ("APV"),U,4)
- +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(1)=$SELECT($DATA(^ACROBL(D0,"APV")):^("APV"),1:"")
- SET X=$PIECE(Y(1),U,7)
- SET X=X
- SET DIU=X
- KILL Y
- XECUTE ^DD(9002189,907,1,1,2.1)
- XECUTE ^DD(9002189,907,1,1,2.4)
- End DoDot:1
- +63 SET X=$PIECE(DIKZ("APV"),U,4)
- +64 IF X'=""
- Begin DoDot:1
- +65 NEW DIK,DIV,DIU,DIN
- +66 KILL DIV
- SET DIV=X
- SET D0=DA
- SET DIV(0)=D0
- SET Y(1)=$SELECT($DATA(^ACROBL(D0,0)):^(0),1:"")
- SET X=$PIECE(Y(1),U,10)
- SET X=X
- SET DIU=X
- KILL Y
- XECUTE ^DD(9002189,907,1,2,2.1)
- XECUTE ^DD(9002189,907,1,2,2.4)
- End DoDot:1
- +67 SET DIKZ("APV")=$GET(^ACROBL(DA,"APV"))
- +68 SET X=$PIECE(DIKZ("APV"),U,6)
- +69 IF X'=""
- KILL ^ACRDOC("RL",+$GET(^ACRDOC(DA,"POST")),DA)
- +70 SET X=$PIECE(DIKZ("APV"),U,7)
- +71 IF X'=""
- KILL ^ACROBL("TV",$EXTRACT(X,1,30),DA)
- +72 SET X=$PIECE(DIKZ("APV"),U,8)
- +73 IF X'=""
- IF X]""
- IF $PIECE($GET(^ACRDOC(DA,0)),U,8)
- IF +$GET(^("REQ"))
- SET ^ACRDOC("PO",+$PIECE(^(0),U,8),"A",DA)=""
- +74 SET X=$PIECE(DIKZ("APV"),U,8)
- +75 IF X'=""
- IF X]""
- IF +$GET(^ACRDOC(DA,"PA"))
- SET ^ACRDOC("P",+^("PA"),"A",DA)=""
- END GOTO ^ACRCR2