TIUXRC5.m

TIUXRC5 ; COMPILED XREF FOR FILE #8925 ; 09/22/15

 ; 

 I X'="" I +$P($G(^TIU(8925,+DA,0)),U),+$P($G(^TIU(8925,+DA,12)),U,8),+$P($G(^TIU(8925,+DA,0)),U,5) S ^TIU(8925,"ASUP",+$P(^TIU(8925,+DA,12),U,8),+$P(^TIU(8925,+DA,0),U),+X,(9999999-+$P(^TIU(8925,+DA,13),U)),+DA)=""

 S X=$P($G(DIKZ(0)),U,5)

 I X'="" I +$P($G(^TIU(8925,+DA,0)),U),+$P($G(^TIU(8925,+DA,12)),U,2),+$P($G(^TIU(8925,+DA,13)),U) S ^TIU(8925,"AAU",+$P(^TIU(8925,+DA,12),U,2),+$P(^TIU(8925,+DA,0),U),+X,(9999999-$P(^TIU(8925,+DA,13),U)),+DA)=""

 S X=$P($G(DIKZ(0)),U,5)

 I X'="" I +$P($G(^TIU(8925,+DA,0)),U),+$P($G(^TIU(8925,+DA,0)),U,2),+$P($G(^TIU(8925,+DA,13)),U) S ^TIU(8925,"APT",+$P(^TIU(8925,+DA,0),U,2),+$P(^TIU(8925,+DA,0),U),+X,(9999999-$P(^TIU(8925,+DA,13),U)),+DA)=""

 S X=$P($G(DIKZ(0)),U,5)

 I X'="" I +$P($G(^TIU(8925,+DA,0)),U),+$P($G(^TIU(8925,+DA,13)),U,2),+$P($G(^TIU(8925,+DA,13)),U) S ^TIU(8925,"ATC",+$P($G(^TIU(8925,+DA,13)),U,2),+$P(^TIU(8925,+DA,0),U),+X,(9999999-$P($G(^TIU(8925,+DA,13)),U)),DA)=""

 S X=$P($G(DIKZ(0)),U,5)

 I X'="" I +$P($G(^TIU(8925,+DA,0)),U),+$P($G(^TIU(8925,+DA,14)),U,2),+$P($G(^TIU(8925,+DA,13)),U) S ^TIU(8925,"ATS",+$P($G(^TIU(8925,+DA,14)),U,2),+$P(^TIU(8925,+DA,0),U),+X,(9999999-$P($G(^TIU(8925,+DA,13)),U)),DA)=""

 S X=$P($G(DIKZ(0)),U,5)

 I X'="" I +$P($G(^TIU(8925,+DA,0)),U),+$P($G(^TIU(8925,+DA,13)),U) S ^TIU(8925,"ALL","ANY",+$P(^TIU(8925,+DA,0),U),+X,(9999999-$P(^TIU(8925,+DA,13),U)),+DA)=""

 S X=$P($G(DIKZ(0)),U,5)

 I X'="" I +$P($G(^TIU(8925,+DA,0)),U),$L($P($G(^TIU(8925,+DA,17)),U)),+$P($G(^TIU(8925,+DA,13)),U) D ASUBS^TIUDD($P($G(^TIU(8925,+DA,17)),U),+$G(^TIU(8925,+DA,0)),+X,(9999999-+$G(^TIU(8925,+DA,13))),DA)

 S X=$P($G(DIKZ(0)),U,5)

 I X'="" I +$P($G(^TIU(8925,+DA,0)),U),+$P($G(^TIU(8925,+DA,14)),U,4),+$P($G(^TIU(8925,+DA,13)),U) S ^TIU(8925,"ASVC",+$P($G(^TIU(8925,+DA,14)),U,4),+$P(^TIU(8925,+DA,0),U),+X,(9999999-$P($G(^TIU(8925,+DA,13)),U)),DA)=""

 S X=$P($G(DIKZ(0)),U,5)

 I X'="" I +$P($G(^TIU(8925,+DA,12)),U,5),+$P($G(^TIU(8925,+DA,13)),U),+$P($G(^TIU(8925,+DA,0)),U) S ^TIU(8925,"ALOC",+$P($G(^TIU(8925,+DA,12)),U,5),+$P($G(^TIU(8925,+DA,0)),U),+X,(9999999-$P($G(^TIU(8925,+DA,13)),U)),DA)=""

 S X=$P($G(DIKZ(0)),U,5)

 I X'="" I +$P($G(^TIU(8925,+DA,0)),U),+$P($G(^TIU(8925,+DA,13)),U),+$O(^TIU(8925.9,"B",+DA,0)) D APRBS^TIUDD(+$G(^TIU(8925,+DA,0)),+X,(9999999-+$G(^TIU(8925,+DA,13))),DA)

 S X=$P($G(DIKZ(0)),U,5)

 I X'="" I +$P($G(^TIU(8925,+DA,0)),U),+$P($G(^TIU(8925,+DA,0)),U,3),+$P($G(^TIU(8925,+DA,13)),U) S ^TIU(8925,"AVSIT",+$P(^TIU(8925,+DA,0),U,3),+$P(^TIU(8925,+DA,0),U),+X,(9999999-$P(^TIU(8925,+DA,13),U)),+DA)=""

 S X=$P($G(DIKZ(0)),U,5)

 I X'="" I +$P($G(^TIU(8925,+DA,0)),U,2),+$P($G(^TIU(8925,+DA,13)),U),+$P($G(^TIU(8925,+DA,0)),U,4) S ^TIU(8925,"ADCPT",+$P(^TIU(8925,+DA,0),U,2),+$P(^TIU(8925,+DA,0),U,4),+X,(9999999-$P(^TIU(8925,+DA,13),U)),DA)=""

 S X=$P($G(DIKZ(0)),U,5)

 I X'="" D SACLPT^TIUDD0(.05,X)

 S X=$P($G(DIKZ(0)),U,5)

 I X'="" D SACLEC^TIUDD0(.05,X)

 S X=$P($G(DIKZ(0)),U,5)

 I X'="" D SACLAU^TIUDD0(.05,X),SACLAU1^TIUDD0(.05,X)

 S X=$P($G(DIKZ(0)),U,5)

 I X'="" D AIHS13A^BTIUXREF

 S X=$P($G(DIKZ(0)),U,6)

 I X'="" S ^TIU(8925,"DAD",$E(X,1,30),DA)=""

 S X=$P($G(DIKZ(0)),U,7)

 I X'="" D SAPTLD^TIUDD0(.07,X)

 S X=$P($G(DIKZ(0)),U,12)

 I X'="" S ^TIU(8925,"FIX",$E(X,1,30),DA)=""

 S X=$P($G(DIKZ(0)),U,13)

 I X'="" D SAPTLD^TIUDD0(.13,X)

 S DIKZ(12)=$G(^TIU(8925,DA,12))

 S X=$P($G(DIKZ(12)),U,1)

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

 S X=$P($G(DIKZ(12)),U,2)

 I X'="" S ^TIU(8925,"CA",$E(X,1,30),DA)=""

 S X=$P($G(DIKZ(12)),U,2)

 I X'="" I +$P($G(^TIU(8925,+DA,0)),U),+$P($G(^TIU(8925,+DA,13)),U),+$P($G(^TIU(8925,+DA,0)),U,5) S ^TIU(8925,"AAU",+X,+$P(^TIU(8925,+DA,0),U),+$P(^TIU(8925,+DA,0),U,5),(9999999-$P(^TIU(8925,+DA,13),U)),+DA)=""

 S X=$P($G(DIKZ(12)),U,2)

 I X'="" I +$$AAUP^TIULX(+DA),+$P($G(^TIU(8925,+DA,15)),U) S ^TIU(8925,"AAUP",+X,+$P($G(^TIU(8925,+DA,15)),U),+DA)=""

 S X=$P($G(DIKZ(12)),U,2)

 I X'="" D SACLAU^TIUDD0(1202,X)

 S X=$P($G(DIKZ(12)),U,2)

 I X'="" D

 .N DIK,DIV,DIU,DIN

 .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X I '+$$ISDS^TIULX(+$G(^TIU(8925,+DA,0))) I X S X=DIV S Y(1)=$S($D(^TIU(8925,D0,14)):^(14),1:"") S X=$P(Y(1),U,4),X=X S DIU=X K Y X ^DD(8925,1202,1,5,1.1) X ^DD(8925,1202,1,5,1.4)

 S DIKZ(12)=$G(^TIU(8925,DA,12))

 S X=$P($G(DIKZ(12)),U,5)

 I X'="" I +$P($G(^TIU(8925,+DA,0)),U),+$P($G(^TIU(8925,+DA,13)),U),+$P($G(^TIU(8925,+DA,0)),U,5) S ^TIU(8925,"ALOC",+X,+$P($G(^TIU(8925,+DA,0)),U),+$P($G(^TIU(8925,+DA,0)),U,5),(9999999-$P($G(^TIU(8925,+DA,13)),U)),DA)=""

 S X=$P($G(DIKZ(12)),U,5)

 I X'="" I +$$ALOCP^TIULX(+DA),+$P($G(^TIU(8925,+DA,15)),U) S ^TIU(8925,"ALOCP",+X,+$P($G(^TIU(8925,+DA,15)),U),+DA)=""

 S X=$P($G(DIKZ(12)),U,7)

 I X'="" ;D:$D(^AUPNVSIT(+X)) ADD^AUPNVSIT

 S X=$P($G(DIKZ(12)),U,8)

 I X'="" S ^TIU(8925,"CS",$E(X,1,30),DA)=""

 S X=$P($G(DIKZ(12)),U,8)

 I X'="" I +$P($G(^TIU(8925,+DA,0)),U),+$P($G(^TIU(8925,+DA,13)),U),+$P($G(^TIU(8925,+DA,0)),U,5) S ^TIU(8925,"ASUP",+X,+$P(^TIU(8925,+DA,0),U),+$P(^TIU(8925,+DA,0),U,5),(9999999-$P($G(^TIU(8925,+DA,13)),U)),DA)=""

 S X=$P($G(DIKZ(12)),U,8)

 I X'="" D SACLEC^TIUDD0(1208,X)

 S X=$P($G(DIKZ(12)),U,11)

 I X'="" D SAPTLD^TIUDD0(1211,X)

 S DIKZ(13)=$G(^TIU(8925,DA,13))

 S X=$P($G(DIKZ(13)),U,1)

 I X'="" I +$P($G(^TIU(8925,+DA,0)),U),+$P($G(^TIU(8925,+DA,12)),U,2),+$P($G(^TIU(8925,+DA,0)),U,5) S ^TIU(8925,"AAU",+$P(^TIU(8925,+DA,12),U,2),+$P(^TIU(8925,+DA,0),U),+$P(^TIU(8925,+DA,0),U,5),(9999999-X),+DA)=""

 S X=$P($G(DIKZ(13)),U,1)

 I X'="" I +$P($G(^TIU(8925,+DA,0)),U),+$P($G(^TIU(8925,+DA,12)),U,8),+$P($G(^TIU(8925,+DA,0)),U,5) S ^TIU(8925,"ASUP",+$P(^TIU(8925,+DA,12),U,8),+$P(^TIU(8925,+DA,0),U),+$P(^TIU(8925,+DA,0),U,5),(9999999-X),+DA)=""

 S X=$P($G(DIKZ(13)),U,1)

 I X'="" I +$P($G(^TIU(8925,+DA,0)),U),+$P($G(^TIU(8925,+DA,0)),U,2),+$P($G(^TIU(8925,+DA,0)),U,5) S ^TIU(8925,"APT",+$P(^TIU(8925,+DA,0),U,2),+$P(^TIU(8925,+DA,0),U),+$P(^TIU(8925,+DA,0),U,5),(9999999-X),+DA)=""

 S X=$P($G(DIKZ(13)),U,1)

 I X'="" I +$P($G(^TIU(8925,+DA,0)),U),+$P($G(^TIU(8925,+DA,14)),U,2),+$P($G(^TIU(8925,+DA,0)),U,5) S ^TIU(8925,"ATS",+$P(^TIU(8925,+DA,14),U,2),+$P(^TIU(8925,+DA,0),U),+$P(^TIU(8925,+DA,0),U,5),(9999999-X),+DA)=""

 S X=$P($G(DIKZ(13)),U,1)

 I X'="" I +$P($G(^TIU(8925,+DA,0)),U),+$P($G(^TIU(8925,+DA,13)),U,2),+$P($G(^TIU(8925,+DA,0)),U,5) S ^TIU(8925,"ATC",+$P(^TIU(8925,+DA,13),U,2),+$P(^TIU(8925,+DA,0),U),+$P(^TIU(8925,+DA,0),U,5),(9999999-X),+DA)=""

 S X=$P($G(DIKZ(13)),U,1)

 I X'="" I +$P($G(^TIU(8925,+DA,0)),U),+$P($G(^TIU(8925,+DA,0)),U,5) S ^TIU(8925,"ALL","ANY",+$P(^TIU(8925,+DA,0),U),+$P(^TIU(8925,+DA,0),U,5),(9999999-X),+DA)=""

 S X=$P($G(DIKZ(13)),U,1)

 I X'="" I +$P($G(^TIU(8925,+DA,0)),U),+$P($G(^TIU(8925,+DA,0)),U,5),$L($P($G(^TIU(8925,+DA,17)),U)) D ASUBS^TIUDD($P($G(^TIU(8925,+DA,17)),U),+$G(^TIU(8925,+DA,0)),+$P($G(^TIU(8925,+DA,0)),U,5),(9999999-+X),DA)

 S X=$P($G(DIKZ(13)),U,1)

 I X'="" I +$P($G(^TIU(8925,+DA,0)),U),+$P($G(^TIU(8925,+DA,14)),U,4),+$P($G(^TIU(8925,+DA,0)),U,5) S ^TIU(8925,"ASVC",+$P(^TIU(8925,+DA,14),U,4),+$P(^TIU(8925,+DA,0),U),+$P(^TIU(8925,+DA,0),U,5),(9999999-X),+DA)=""

 S X=$P($G(DIKZ(13)),U,1)

 I X'="" I +$P($G(^TIU(8925,+DA,0)),U),+$P($G(^TIU(8925,+DA,0)),U,5),+$O(^TIU(8925.9,"B",+DA,0)) D APRBS^TIUDD(+$G(^TIU(8925,+DA,0)),+$P($G(^TIU(8925,+DA,0)),U,5),(9999999-+X),DA)

 S X=$P($G(DIKZ(13)),U,1)

 I X'="" I +$P($G(^TIU(8925,+DA,0)),U),+$P($G(^TIU(8925,+DA,0)),U,3),+$P($G(^TIU(8925,+DA,0)),U,5) S ^TIU(8925,"AVSIT",+$P(^TIU(8925,+DA,0),U,3),+$P(^TIU(8925,+DA,0),U),+$P(^TIU(8925,+DA,0),U,5),(9999999-X),DA)=""

 S X=$P($G(DIKZ(13)),U,1)

 I X'="" I +$P($G(^TIU(8925,+DA,0)),U,4),+$P($G(^TIU(8925,+DA,0)),U,2),+$P($G(^TIU(8925,+DA,0)),U,5) S ^TIU(8925,"ADCPT",+$P(^TIU(8925,+DA,0),U,2),+$P(^TIU(8925,+DA,0),U,4),+$P(^TIU(8925,+DA,0),U,5),(9999999-X),DA)=""

 S X=$P($G(DIKZ(13)),U,1)

 I X'="" S ^TIU(8925,"D",$E(X,1,30),DA)=""

 S X=$P($G(DIKZ(13)),U,1)

END G ^TIUXRC6

TIUXRC5   ; COMPILED XREF FOR FILE #8925 ; 09/22/15

 +1       ; 

 +2        IF X'=""

               IF +$PIECE($GET(^TIU(8925,+DA,0)),U)

                   IF +$PIECE($GET(^TIU(8925,+DA,12)),U,8)

                       IF +$PIECE($GET(^TIU(8925,+DA,0)),U,5)

                           SET ^TIU(8925,"ASUP",+$PIECE(^TIU(8925,+DA,12),U,8),+$PIECE(^TIU(8925,+DA,0),U),+X,(9999999-+$PIECE(^TIU(8925,+DA,13),U)),+DA)=""

 +3        SET X=$PIECE($GET(DIKZ(0)),U,5)

 +4        IF X'=""

               IF +$PIECE($GET(^TIU(8925,+DA,0)),U)

                   IF +$PIECE($GET(^TIU(8925,+DA,12)),U,2)

                       IF +$PIECE($GET(^TIU(8925,+DA,13)),U)

                           SET ^TIU(8925,"AAU",+$PIECE(^TIU(8925,+DA,12),U,2),+$PIECE(^TIU(8925,+DA,0),U),+X,(9999999-$PIECE(^TIU(8925,+DA,13),U)),+DA)=""

 +5        SET X=$PIECE($GET(DIKZ(0)),U,5)

 +6        IF X'=""

               IF +$PIECE($GET(^TIU(8925,+DA,0)),U)

                   IF +$PIECE($GET(^TIU(8925,+DA,0)),U,2)

                       IF +$PIECE($GET(^TIU(8925,+DA,13)),U)

                           SET ^TIU(8925,"APT",+$PIECE(^TIU(8925,+DA,0),U,2),+$PIECE(^TIU(8925,+DA,0),U),+X,(9999999-$PIECE(^TIU(8925,+DA,13),U)),+DA)=""

 +7        SET X=$PIECE($GET(DIKZ(0)),U,5)

 +8        IF X'=""

               IF +$PIECE($GET(^TIU(8925,+DA,0)),U)

                   IF +$PIECE($GET(^TIU(8925,+DA,13)),U,2)

                       IF +$PIECE($GET(^TIU(8925,+DA,13)),U)

                           SET ^TIU(8925,"ATC",+$PIECE($GET(^TIU(8925,+DA,13)),U,2),+$PIECE(^TIU(8925,+DA,0),U),+X,(9999999-$PIECE($GET(^TIU(8925,+DA,13)),U)),DA)=""

 +9        SET X=$PIECE($GET(DIKZ(0)),U,5)

 +10       IF X'=""

               IF +$PIECE($GET(^TIU(8925,+DA,0)),U)

                   IF +$PIECE($GET(^TIU(8925,+DA,14)),U,2)

                       IF +$PIECE($GET(^TIU(8925,+DA,13)),U)

                           SET ^TIU(8925,"ATS",+$PIECE($GET(^TIU(8925,+DA,14)),U,2),+$PIECE(^TIU(8925,+DA,0),U),+X,(9999999-$PIECE($GET(^TIU(8925,+DA,13)),U)),DA)=""

 +11       SET X=$PIECE($GET(DIKZ(0)),U,5)

 +12       IF X'=""

               IF +$PIECE($GET(^TIU(8925,+DA,0)),U)

                   IF +$PIECE($GET(^TIU(8925,+DA,13)),U)

                       SET ^TIU(8925,"ALL","ANY",+$PIECE(^TIU(8925,+DA,0),U),+X,(9999999-$PIECE(^TIU(8925,+DA,13),U)),+DA)=""

 +13       SET X=$PIECE($GET(DIKZ(0)),U,5)

 +14       IF X'=""

               IF +$PIECE($GET(^TIU(8925,+DA,0)),U)

                   IF $LENGTH($PIECE($GET(^TIU(8925,+DA,17)),U))

                       IF +$PIECE($GET(^TIU(8925,+DA,13)),U)

                           DO ASUBS^TIUDD($PIECE($GET(^TIU(8925,+DA,17)),U),+$GET(^TIU(8925,+DA,0)),+X,(9999999-+$GET(^TIU(8925,+DA,13))),DA)

 +15       SET X=$PIECE($GET(DIKZ(0)),U,5)

 +16       IF X'=""

               IF +$PIECE($GET(^TIU(8925,+DA,0)),U)

                   IF +$PIECE($GET(^TIU(8925,+DA,14)),U,4)

                       IF +$PIECE($GET(^TIU(8925,+DA,13)),U)

                           SET ^TIU(8925,"ASVC",+$PIECE($GET(^TIU(8925,+DA,14)),U,4),+$PIECE(^TIU(8925,+DA,0),U),+X,(9999999-$PIECE($GET(^TIU(8925,+DA,13)),U)),DA)=""

 +17       SET X=$PIECE($GET(DIKZ(0)),U,5)

 +18       IF X'=""

               IF +$PIECE($GET(^TIU(8925,+DA,12)),U,5)

                   IF +$PIECE($GET(^TIU(8925,+DA,13)),U)

                       IF +$PIECE($GET(^TIU(8925,+DA,0)),U)

                           SET ^TIU(8925,"ALOC",+$PIECE($GET(^TIU(8925,+DA,12)),U,5),+$PIECE($GET(^TIU(8925,+DA,0)),U),+X,(9999999-$PIECE($GET(^TIU(8925,+DA,13)),U)),DA)=""

 +19       SET X=$PIECE($GET(DIKZ(0)),U,5)

 +20       IF X'=""

               IF +$PIECE($GET(^TIU(8925,+DA,0)),U)

                   IF +$PIECE($GET(^TIU(8925,+DA,13)),U)

                       IF +$ORDER(^TIU(8925.9,"B",+DA,0))

                           DO APRBS^TIUDD(+$GET(^TIU(8925,+DA,0)),+X,(9999999-+$GET(^TIU(8925,+DA,13))),DA)

 +21       SET X=$PIECE($GET(DIKZ(0)),U,5)

 +22       IF X'=""

               IF +$PIECE($GET(^TIU(8925,+DA,0)),U)

                   IF +$PIECE($GET(^TIU(8925,+DA,0)),U,3)

                       IF +$PIECE($GET(^TIU(8925,+DA,13)),U)

                           SET ^TIU(8925,"AVSIT",+$PIECE(^TIU(8925,+DA,0),U,3),+$PIECE(^TIU(8925,+DA,0),U),+X,(9999999-$PIECE(^TIU(8925,+DA,13),U)),+DA)=""

 +23       SET X=$PIECE($GET(DIKZ(0)),U,5)

 +24       IF X'=""

               IF +$PIECE($GET(^TIU(8925,+DA,0)),U,2)

                   IF +$PIECE($GET(^TIU(8925,+DA,13)),U)

                       IF +$PIECE($GET(^TIU(8925,+DA,0)),U,4)

                           SET ^TIU(8925,"ADCPT",+$PIECE(^TIU(8925,+DA,0),U,2),+$PIECE(^TIU(8925,+DA,0),U,4),+X,(9999999-$PIECE(^TIU(8925,+DA,13),U)),DA)=""

 +25       SET X=$PIECE($GET(DIKZ(0)),U,5)

 +26       IF X'=""

               DO SACLPT^TIUDD0(.05,X)

 +27       SET X=$PIECE($GET(DIKZ(0)),U,5)

 +28       IF X'=""

               DO SACLEC^TIUDD0(.05,X)

 +29       SET X=$PIECE($GET(DIKZ(0)),U,5)

 +30       IF X'=""

               DO SACLAU^TIUDD0(.05,X)

               DO SACLAU1^TIUDD0(.05,X)

 +31       SET X=$PIECE($GET(DIKZ(0)),U,5)

 +32       IF X'=""

               DO AIHS13A^BTIUXREF

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

 +34       IF X'=""

               SET ^TIU(8925,"DAD",$EXTRACT(X,1,30),DA)=""

 +35       SET X=$PIECE($GET(DIKZ(0)),U,7)

 +36       IF X'=""

               DO SAPTLD^TIUDD0(.07,X)

 +37       SET X=$PIECE($GET(DIKZ(0)),U,12)

 +38       IF X'=""

               SET ^TIU(8925,"FIX",$EXTRACT(X,1,30),DA)=""

 +39       SET X=$PIECE($GET(DIKZ(0)),U,13)

 +40       IF X'=""

               DO SAPTLD^TIUDD0(.13,X)

 +41       SET DIKZ(12)=$GET(^TIU(8925,DA,12))

 +42       SET X=$PIECE($GET(DIKZ(12)),U,1)

 +43       IF X'=""

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

 +44       SET X=$PIECE($GET(DIKZ(12)),U,2)

 +45       IF X'=""

               SET ^TIU(8925,"CA",$EXTRACT(X,1,30),DA)=""

 +46       SET X=$PIECE($GET(DIKZ(12)),U,2)

 +47       IF X'=""

               IF +$PIECE($GET(^TIU(8925,+DA,0)),U)

                   IF +$PIECE($GET(^TIU(8925,+DA,13)),U)

                       IF +$PIECE($GET(^TIU(8925,+DA,0)),U,5)

                           SET ^TIU(8925,"AAU",+X,+$PIECE(^TIU(8925,+DA,0),U),+$PIECE(^TIU(8925,+DA,0),U,5),(9999999-$PIECE(^TIU(8925,+DA,13),U)),+DA)=""

 +48       SET X=$PIECE($GET(DIKZ(12)),U,2)

 +49       IF X'=""

               IF +$$AAUP^TIULX(+DA)

                   IF +$PIECE($GET(^TIU(8925,+DA,15)),U)

                       SET ^TIU(8925,"AAUP",+X,+$PIECE($GET(^TIU(8925,+DA,15)),U),+DA)=""

 +50       SET X=$PIECE($GET(DIKZ(12)),U,2)

 +51       IF X'=""

               DO SACLAU^TIUDD0(1202,X)

 +52       SET X=$PIECE($GET(DIKZ(12)),U,2)

 +53       IF X'=""

               Begin DoDot:1

 +54               NEW DIK,DIV,DIU,DIN

 +55               KILL DIV

                   SET DIV=X

                   SET D0=DA

                   SET DIV(0)=D0

                   SET Y(0)=X

                   IF '+$$ISDS^TIULX(+$GET(^TIU(8925,+DA,0)))

                       IF X

                           SET X=DIV

                           SET Y(1)=$SELECT($DATA(^TIU(8925,D0,14)):^(14),1:"")

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

                           SET X=X

                           SET DIU=X

                           KILL Y

                           XECUTE ^DD(8925,1202,1,5,1.1)

                           XECUTE ^DD(8925,1202,1,5,1.4)

               End DoDot:1

 +56       SET DIKZ(12)=$GET(^TIU(8925,DA,12))

 +57       SET X=$PIECE($GET(DIKZ(12)),U,5)

 +58       IF X'=""

               IF +$PIECE($GET(^TIU(8925,+DA,0)),U)

                   IF +$PIECE($GET(^TIU(8925,+DA,13)),U)

                       IF +$PIECE($GET(^TIU(8925,+DA,0)),U,5)

                           SET ^TIU(8925,"ALOC",+X,+$PIECE($GET(^TIU(8925,+DA,0)),U),+$PIECE($GET(^TIU(8925,+DA,0)),U,5),(9999999-$PIECE($GET(^TIU(8925,+DA,13)),U)),DA)=""

 +59       SET X=$PIECE($GET(DIKZ(12)),U,5)

 +60       IF X'=""

               IF +$$ALOCP^TIULX(+DA)

                   IF +$PIECE($GET(^TIU(8925,+DA,15)),U)

                       SET ^TIU(8925,"ALOCP",+X,+$PIECE($GET(^TIU(8925,+DA,15)),U),+DA)=""

 +61       SET X=$PIECE($GET(DIKZ(12)),U,7)

 +62      ;D:$D(^AUPNVSIT(+X)) ADD^AUPNVSIT

           IF X'=""

 +63       SET X=$PIECE($GET(DIKZ(12)),U,8)

 +64       IF X'=""

               SET ^TIU(8925,"CS",$EXTRACT(X,1,30),DA)=""

 +65       SET X=$PIECE($GET(DIKZ(12)),U,8)

 +66       IF X'=""

               IF +$PIECE($GET(^TIU(8925,+DA,0)),U)

                   IF +$PIECE($GET(^TIU(8925,+DA,13)),U)

                       IF +$PIECE($GET(^TIU(8925,+DA,0)),U,5)

                           SET ^TIU(8925,"ASUP",+X,+$PIECE(^TIU(8925,+DA,0),U),+$PIECE(^TIU(8925,+DA,0),U,5),(9999999-$PIECE($GET(^TIU(8925,+DA,13)),U)),DA)=""

 +67       SET X=$PIECE($GET(DIKZ(12)),U,8)

 +68       IF X'=""

               DO SACLEC^TIUDD0(1208,X)

 +69       SET X=$PIECE($GET(DIKZ(12)),U,11)

 +70       IF X'=""

               DO SAPTLD^TIUDD0(1211,X)

 +71       SET DIKZ(13)=$GET(^TIU(8925,DA,13))

 +72       SET X=$PIECE($GET(DIKZ(13)),U,1)

 +73       IF X'=""

               IF +$PIECE($GET(^TIU(8925,+DA,0)),U)