TIUXRC6 ; COMPILED XREF FOR FILE #8925 ; 09/22/15
;
I X'="" I +$P(^TIU(8925,+DA,0),U),+$P($G(^TIU(8925,+DA,0)),U,2) S ^TIU(8925,"APTCL",+$P(^TIU(8925,+DA,0),U,2),+$$CLINDOC^TIULC1(+$P(^TIU(8925,+DA,0),U),+DA),(9999999-X),DA)=""
S X=$P($G(DIKZ(13)),U,1)
I X'="" I +$P(^TIU(8925,+DA,0),U),+$P($G(^TIU(8925,+DA,0)),U,2) S ^TIU(8925,"APTCL",+$P(^TIU(8925,+DA,0),U,2),38,(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,5),+$P($G(^TIU(8925,+DA,0)),U,5) S ^TIU(8925,"ALOC",+$P(^TIU(8925,+DA,12),U,5),+$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'="" D SACLPT^TIUDD0(1301,X)
S X=$P($G(DIKZ(13)),U,1)
I X'="" D SACLAU^TIUDD0(1301,X),SACLAU1^TIUDD0(1301,X)
S X=$P($G(DIKZ(13)),U,1)
I X'="" D SACLEC^TIUDD0(1301,X)
S X=$P($G(DIKZ(13)),U,1)
I X'="" D SACLSB^TIUDD0(1301,X)
S X=$P($G(DIKZ(13)),U,2)
I X'="" S ^TIU(8925,"TC",$E(X,1,30),DA)=""
S X=$P($G(DIKZ(13)),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,"ATC",+X,+$P($G(^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(13)),U,2)
I X'="" D SACLAU1^TIUDD0(1302,X)
S X=$P($G(DIKZ(13)),U,4)
I X'="" S ^TIU(8925,"E",$E(X,1,30),DA)=""
S DIKZ(14)=$G(^TIU(8925,DA,14))
S X=$P($G(DIKZ(14)),U,2)
I X'="" S ^TIU(8925,"TS",$E(X,1,30),DA)=""
S X=$P($G(DIKZ(14)),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,"ATS",+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(14)),U,4)
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,"ASVC",+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(14)),U,4)
I X'="" S ^TIU(8925,"SVC",$E(X,1,30),DA)=""
S X=$P($G(DIKZ(14)),U,5)
I X'="" S ^TIU(8925,"G",$E(X,1,30),DA)=""
S DIKZ(15)=$G(^TIU(8925,DA,15))
S X=$P($G(DIKZ(15)),U,1)
I X'="" I +$$ALOCP^TIULX(+DA),+$P($G(^TIU(8925,+DA,12)),U,5) S ^TIU(8925,"ALOCP",+$P($G(^TIU(8925,+DA,12)),U,5),+X,+DA)=""
S X=$P($G(DIKZ(15)),U,1)
I X'="" I +$$APTP^TIULX(+DA),+$P($G(^TIU(8925,+DA,0)),U,2) S ^TIU(8925,"APTP",+$P($G(^TIU(8925,+DA,0)),U,2),+X,+DA)=""
S X=$P($G(DIKZ(15)),U,1)
I X'="" I +$$AAUP^TIULX(+DA),+$P($G(^TIU(8925,+DA,12)),U,2) S ^TIU(8925,"AAUP",+$P($G(^TIU(8925,+DA,12)),U,2),+X,+DA)=""
S X=$P($G(DIKZ(15)),U,1)
I X'="" D SACLPT^TIUDD0(1501,X)
S X=$P($G(DIKZ(15)),U,1)
I X'="" D SACLEC^TIUDD0(1501,X)
S X=$P($G(DIKZ(15)),U,1)
I X'="" D KACLAU^TIUDD01(1501,X),KACLAU1^TIUDD01(1501,X)
S X=$P($G(DIKZ(15)),U,2)
I X'="" D SACLSB^TIUDD0(1502,X)
S X=$P($G(DIKZ(15)),U,7)
I X'="" D KACLEC^TIUDD01(1507,X)
S X=$P($G(DIKZ(15)),U,7)
I X'="" D SACLPT^TIUDD0(1507,X)
S DIKZ(17)=$G(^TIU(8925,DA,17))
S X=$P($G(DIKZ(17)),U,1)
I X'="" I +$P($G(^TIU(8925,+DA,0)),U),+$P($G(^TIU(8925,+DA,0)),U,5),+$P($G(^TIU(8925,+DA,13)),U) D ASUBS^TIUDD($G(X),+$G(^TIU(8925,+DA,0)),+$P(^TIU(8925,+DA,0),U,5),(9999999-+$G(^TIU(8925,+DA,13))),DA)
S DIKZ(21)=$G(^TIU(8925,DA,21))
S X=$P($G(DIKZ(21)),U,1)
I X'="" S ^TIU(8925,"GDAD",$E(X,1,30),DA)=""
S DIKZ(150)=$G(^TIU(8925,DA,150))
S X=$P($G(DIKZ(150)),U,1)
I X'="" S ^TIU(8925,"VID",$E(X,1,30),DA)=""
CR1 S DIXR=245
K X
S X(1)=$P(DIKZ(12),U,7)
S X=$G(X(1))
I $G(X(1))]"" D
. K X1,X2 M X1=X,X2=X
. S ^TIU(8925,"VS",X,DA)=""
CR2 S DIXR=307
K X
S DIKZ(12)=$G(^TIU(8925,DA,12))
S X(1)=$P(DIKZ(12),U,12)
S DIKZ(0)=$G(^TIU(8925,DA,0))
S X(2)=$P(DIKZ(0),U,1)
S X(3)=$P(DIKZ(0),U,5)
S DIKZ(13)=$G(^TIU(8925,DA,13))
S X=$P(DIKZ(13),U,1)
I $G(X)]"" S X=9999999-X
S:$D(X)#2 X(4)=X
S X=$G(X(1))
I $G(X(1))]"",$G(X(2))]"",$G(X(3))]"",$G(X(4))]"" D
. K X1,X2 M X1=X,X2=X
. S ^TIU(8925,"ADIV",X(1),X(2),X(3),X(4),DA)=""
CR3 S DIXR=578
K X
S DIKZ(12)=$G(^TIU(8925,DA,12))
S X(1)=$P(DIKZ(12),U,1)
S DIKZ(18)=$G(^TIU(8925,DA,18))
S X(2)=$P(DIKZ(18),U,1)
S X=$G(X(1))
I $G(X(1))]"",$G(X(2))]"" D
. K X1,X2 M X1=X,X2=X
. S ^TIU(8925,"VBC",$E(X(1),1,14),$E(X(2),1,6),DA)=""
CR4 K X
END Q
TIUXRC6 ; COMPILED XREF FOR FILE #8925 ; 09/22/15
+1 ;
+2 IF X'=""
IF +$PIECE(^TIU(8925,+DA,0),U)
IF +$PIECE($GET(^TIU(8925,+DA,0)),U,2)
SET ^TIU(8925,"APTCL",+$PIECE(^TIU(8925,+DA,0),U,2),+$$CLINDOC^TIULC1(+$PIECE(^TIU(8925,+DA,0),U),+DA),(9999999-X),DA)=""
+3 SET X=$PIECE($GET(DIKZ(13)),U,1)
+4 IF X'=""
IF +$PIECE(^TIU(8925,+DA,0),U)
IF +$PIECE($GET(^TIU(8925,+DA,0)),U,2)
SET ^TIU(8925,"APTCL",+$PIECE(^TIU(8925,+DA,0),U,2),38,(9999999-X),DA)=""
+5 SET X=$PIECE($GET(DIKZ(13)),U,1)
+6 IF X'=""
IF +$PIECE($GET(^TIU(8925,+DA,0)),U)
IF +$PIECE($GET(^TIU(8925,+DA,12)),U,5)
IF +$PIECE($GET(^TIU(8925,+DA,0)),U,5)
SET ^TIU(8925,"ALOC",+$PIECE(^TIU(8925,+DA,12),U,5),+$PIECE(^TIU(8925,+DA,0),U),+$PIECE(^TIU(8925,+DA,0),U,5),(9999999-X),+DA)=""
+7 SET X=$PIECE($GET(DIKZ(13)),U,1)
+8 IF X'=""
DO SACLPT^TIUDD0(1301,X)
+9 SET X=$PIECE($GET(DIKZ(13)),U,1)
+10 IF X'=""
DO SACLAU^TIUDD0(1301,X)
DO SACLAU1^TIUDD0(1301,X)
+11 SET X=$PIECE($GET(DIKZ(13)),U,1)
+12 IF X'=""
DO SACLEC^TIUDD0(1301,X)
+13 SET X=$PIECE($GET(DIKZ(13)),U,1)
+14 IF X'=""
DO SACLSB^TIUDD0(1301,X)
+15 SET X=$PIECE($GET(DIKZ(13)),U,2)
+16 IF X'=""
SET ^TIU(8925,"TC",$EXTRACT(X,1,30),DA)=""
+17 SET X=$PIECE($GET(DIKZ(13)),U,2)
+18 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,"ATC",+X,+$PIECE($GET(^TIU(8925,+DA,0)),U),+$PIECE(^TIU(8925,+DA,0),U,5),(9999999-$PIECE($GET(^TIU(8925,+DA,13)),U)),DA)=""
+19 SET X=$PIECE($GET(DIKZ(13)),U,2)
+20 IF X'=""
DO SACLAU1^TIUDD0(1302,X)
+21 SET X=$PIECE($GET(DIKZ(13)),U,4)
+22 IF X'=""
SET ^TIU(8925,"E",$EXTRACT(X,1,30),DA)=""
+23 SET DIKZ(14)=$GET(^TIU(8925,DA,14))
+24 SET X=$PIECE($GET(DIKZ(14)),U,2)
+25 IF X'=""
SET ^TIU(8925,"TS",$EXTRACT(X,1,30),DA)=""
+26 SET X=$PIECE($GET(DIKZ(14)),U,2)
+27 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,"ATS",+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)=""
+28 SET X=$PIECE($GET(DIKZ(14)),U,4)
+29 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,"ASVC",+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)=""
+30 SET X=$PIECE($GET(DIKZ(14)),U,4)
+31 IF X'=""
SET ^TIU(8925,"SVC",$EXTRACT(X,1,30),DA)=""
+32 SET X=$PIECE($GET(DIKZ(14)),U,5)
+33 IF X'=""
SET ^TIU(8925,"G",$EXTRACT(X,1,30),DA)=""
+34 SET DIKZ(15)=$GET(^TIU(8925,DA,15))
+35 SET X=$PIECE($GET(DIKZ(15)),U,1)
+36 IF X'=""
IF +$$ALOCP^TIULX(+DA)
IF +$PIECE($GET(^TIU(8925,+DA,12)),U,5)
SET ^TIU(8925,"ALOCP",+$PIECE($GET(^TIU(8925,+DA,12)),U,5),+X,+DA)=""
+37 SET X=$PIECE($GET(DIKZ(15)),U,1)
+38 IF X'=""
IF +$$APTP^TIULX(+DA)
IF +$PIECE($GET(^TIU(8925,+DA,0)),U,2)
SET ^TIU(8925,"APTP",+$PIECE($GET(^TIU(8925,+DA,0)),U,2),+X,+DA)=""
+39 SET X=$PIECE($GET(DIKZ(15)),U,1)
+40 IF X'=""
IF +$$AAUP^TIULX(+DA)
IF +$PIECE($GET(^TIU(8925,+DA,12)),U,2)
SET ^TIU(8925,"AAUP",+$PIECE($GET(^TIU(8925,+DA,12)),U,2),+X,+DA)=""
+41 SET X=$PIECE($GET(DIKZ(15)),U,1)
+42 IF X'=""
DO SACLPT^TIUDD0(1501,X)
+43 SET X=$PIECE($GET(DIKZ(15)),U,1)
+44 IF X'=""
DO SACLEC^TIUDD0(1501,X)
+45 SET X=$PIECE($GET(DIKZ(15)),U,1)
+46 IF X'=""
DO KACLAU^TIUDD01(1501,X)
DO KACLAU1^TIUDD01(1501,X)
+47 SET X=$PIECE($GET(DIKZ(15)),U,2)
+48 IF X'=""
DO SACLSB^TIUDD0(1502,X)
+49 SET X=$PIECE($GET(DIKZ(15)),U,7)
+50 IF X'=""
DO KACLEC^TIUDD01(1507,X)
+51 SET X=$PIECE($GET(DIKZ(15)),U,7)
+52 IF X'=""
DO SACLPT^TIUDD0(1507,X)
+53 SET DIKZ(17)=$GET(^TIU(8925,DA,17))
+54 SET X=$PIECE($GET(DIKZ(17)),U,1)
+55 IF X'=""
IF +$PIECE($GET(^TIU(8925,+DA,0)),U)
IF +$PIECE($GET(^TIU(8925,+DA,0)),U,5)
IF +$PIECE($GET(^TIU(8925,+DA,13)),U)
DO ASUBS^TIUDD($GET(X),+$GET(^TIU(8925,+DA,0)),+$PIECE(^TIU(8925,+DA,0),U,5),(9999999-+$GET(^TIU(8925,+DA,13))),DA)
+56 SET DIKZ(21)=$GET(^TIU(8925,DA,21))
+57 SET X=$PIECE($GET(DIKZ(21)),U,1)
+58 IF X'=""
SET ^TIU(8925,"GDAD",$EXTRACT(X,1,30),DA)=""
+59 SET DIKZ(150)=$GET(^TIU(8925,DA,150))
+60 SET X=$PIECE($GET(DIKZ(150)),U,1)
+61 IF X'=""
SET ^TIU(8925,"VID",$EXTRACT(X,1,30),DA)=""
CR1 SET DIXR=245
+1 KILL X
+2 SET X(1)=$PIECE(DIKZ(12),U,7)
+3 SET X=$GET(X(1))
+4 IF $GET(X(1))]""
Begin DoDot:1
+5 KILL X1,X2
MERGE X1=X,X2=X
+6 SET ^TIU(8925,"VS",X,DA)=""
End DoDot:1
CR2 SET DIXR=307
+1 KILL X
+2 SET DIKZ(12)=$GET(^TIU(8925,DA,12))
+3 SET X(1)=$PIECE(DIKZ(12),U,12)
+4 SET DIKZ(0)=$GET(^TIU(8925,DA,0))
+5 SET X(2)=$PIECE(DIKZ(0),U,1)
+6 SET X(3)=$PIECE(DIKZ(0),U,5)
+7 SET DIKZ(13)=$GET(^TIU(8925,DA,13))
+8 SET X=$PIECE(DIKZ(13),U,1)
+9 IF $GET(X)]""
SET X=9999999-X
+10 IF $DATA(X)#2
SET X(4)=X
+11 SET X=$GET(X(1))
+12 IF $GET(X(1))]""
IF $GET(X(2))]""
IF $GET(X(3))]""
IF $GET(X(4))]""
Begin DoDot:1
+13 KILL X1,X2
MERGE X1=X,X2=X
+14 SET ^TIU(8925,"ADIV",X(1),X(2),X(3),X(4),DA)=""
End DoDot:1
CR3 SET DIXR=578
+1 KILL X
+2 SET DIKZ(12)=$GET(^TIU(8925,DA,12))
+3 SET X(1)=$PIECE(DIKZ(12),U,1)
+4 SET DIKZ(18)=$GET(^TIU(8925,DA,18))
+5 SET X(2)=$PIECE(DIKZ(18),U,1)
+6 SET X=$GET(X(1))
+7 IF $GET(X(1))]""
IF $GET(X(2))]""
Begin DoDot:1
+8 KILL X1,X2
MERGE X1=X,X2=X
+9 SET ^TIU(8925,"VBC",$EXTRACT(X(1),1,14),$EXTRACT(X(2),1,6),DA)=""
End DoDot:1
CR4 KILL X
END QUIT
