ACRCST4.m

ACRCST4 ; COMPILED XREF FOR FILE #9002195 ; 09/29/09

 ; 

 S DIKZK=1

 S DIKZ(0)=$G(^ACRITEM(DA,0))

 S X=$P(DIKZ(0),U,1)

 I X'="" S ^ACRITEM("B",$E(X,1,30),DA)=""

 S X=$P(DIKZ(0),U,2)

 I X'="" S ^ACRITEM("E",$E(X,1,30),DA)=""

 S DIKZ("DT")=$G(^ACRITEM(DA,"DT"))

 S X=$P(DIKZ("DT"),U,1)

 I X'="" S ^ACRITEM("C",$E(X,1,30),DA)=""

 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(^ACRITEM(D0,"DT")):^("DT"),1:"") S X=$P(Y(1),U,12),X=X S DIU=X K Y S X=DIV S X=DIV,X=X X ^DD(9002195,3,1,1,1.4)

 S DIKZ("DT")=$G(^ACRITEM(DA,"DT"))

 S X=$P(DIKZ("DT"),U,4)

 I X'="" S ^ACRITEM("NSN",$E(X,1,30),DA)=""

 S X=$P(DIKZ("DT"),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(^ACRITEM(D0,"DT")):^("DT"),1:"") S X=$P(Y(1),U,5),X=X S DIU=X K Y X ^DD(9002195,6,1,1,1.1) X ^DD(9002195,6,1,1,1.4)

 S DIKZ("DT")=$G(^ACRITEM(DA,"DT"))

 S X=$P(DIKZ("DT"),U,7)

 I X'="" D

 .N DIK,DIV,DIU,DIN

 .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^ACRITEM(D0,"DT")):^("DT"),1:"") S X=$P(Y(1),U,6),X=X S DIU=X K Y X ^DD(9002195,7,1,1,1.1) X ^DD(9002195,7,1,1,1.4)

 S DIKZ("DT")=$G(^ACRITEM(DA,"DT"))

 S X=$P(DIKZ("DT"),U,15)

 I X'="" S ^ACRITEM("G",$E(X,1,30),DA)=""

 S DIKZ("DT1")=$G(^ACRITEM(DA,"DT1"))

 S X=$P(DIKZ("DT1"),U,1)

 I X'="" S ^ACRITEM("F",$E(X,1,30),DA)=""

 S X=$P(DIKZ("DT1"),U,2)

 I X'="" S ^ACRITEM("VON",$E(X,1,30),DA)=""

 S X=$P(DIKZ("DT1"),U,4)

 I X'="" S ^ACRITEM("NDC",$E(X,1,30),DA)=""

END G ^ACRCST5

ACRCST4   ; COMPILED XREF FOR FILE #9002195 ; 09/29/09

 +1       ; 

 +2        SET DIKZK=1

 +3        SET DIKZ(0)=$GET(^ACRITEM(DA,0))

 +4        SET X=$PIECE(DIKZ(0),U,1)

 +5        IF X'=""

               SET ^ACRITEM("B",$EXTRACT(X,1,30),DA)=""

 +6        SET X=$PIECE(DIKZ(0),U,2)

 +7        IF X'=""

               SET ^ACRITEM("E",$EXTRACT(X,1,30),DA)=""

 +8        SET DIKZ("DT")=$GET(^ACRITEM(DA,"DT"))

 +9        SET X=$PIECE(DIKZ("DT"),U,1)

 +10       IF X'=""

               SET ^ACRITEM("C",$EXTRACT(X,1,30),DA)=""

 +11       SET X=$PIECE(DIKZ("DT"),U,3)

 +12       IF X'=""

               Begin DoDot:1

 +13               NEW DIK,DIV,DIU,DIN

 +14               KILL DIV

                   SET DIV=X

                   SET D0=DA

                   SET DIV(0)=D0

                   SET Y(1)=$SELECT($DATA(^ACRITEM(D0,"DT")):^("DT"),1:"")

                   SET X=$PIECE(Y(1),U,12)

                   SET X=X

                   SET DIU=X

                   KILL Y

                   SET X=DIV

                   SET X=DIV

                   SET X=X

                   XECUTE ^DD(9002195,3,1,1,1.4)

               End DoDot:1

 +15       SET DIKZ("DT")=$GET(^ACRITEM(DA,"DT"))

 +16       SET X=$PIECE(DIKZ("DT"),U,4)

 +17       IF X'=""

               SET ^ACRITEM("NSN",$EXTRACT(X,1,30),DA)=""

 +18       SET X=$PIECE(DIKZ("DT"),U,6)

 +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(1)=$SELECT($DATA(^ACRITEM(D0,"DT")):^("DT"),1:"")

                   SET X=$PIECE(Y(1),U,5)

                   SET X=X

                   SET DIU=X

                   KILL Y

                   XECUTE ^DD(9002195,6,1,1,1.1)

                   XECUTE ^DD(9002195,6,1,1,1.4)

               End DoDot:1

 +22       SET DIKZ("DT")=$GET(^ACRITEM(DA,"DT"))

 +23       SET X=$PIECE(DIKZ("DT"),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

                   SET Y(1)=$SELECT($DATA(^ACRITEM(D0,"DT")):^("DT"),1:"")

                   SET X=$PIECE(Y(1),U,6)

                   SET X=X

                   SET DIU=X

                   KILL Y

                   XECUTE ^DD(9002195,7,1,1,1.1)

                   XECUTE ^DD(9002195,7,1,1,1.4)

               End DoDot:1

 +27       SET DIKZ("DT")=$GET(^ACRITEM(DA,"DT"))

 +28       SET X=$PIECE(DIKZ("DT"),U,15)

 +29       IF X'=""

               SET ^ACRITEM("G",$EXTRACT(X,1,30),DA)=""

 +30       SET DIKZ("DT1")=$GET(^ACRITEM(DA,"DT1"))

 +31       SET X=$PIECE(DIKZ("DT1"),U,1)

 +32       IF X'=""

               SET ^ACRITEM("F",$EXTRACT(X,1,30),DA)=""

 +33       SET X=$PIECE(DIKZ("DT1"),U,2)

 +34       IF X'=""

               SET ^ACRITEM("VON",$EXTRACT(X,1,30),DA)=""

 +35       SET X=$PIECE(DIKZ("DT1"),U,4)

 +36       IF X'=""

               SET ^ACRITEM("NDC",$EXTRACT(X,1,30),DA)=""

END        GOTO ^ACRCST5