TIUXRC4 ; COMPILED XREF FOR FILE #8925 ; 05/09/23
;
I X'="" S DH=8925,DV=1504,DU=1 S DIIX=3 D:$G(DIK(0))'["A" AUDIT^DIK1
S X=$P($G(DIKZ(15)),U,6)
I X'="" S DH=8925,DV=1506,DU=1 S DIIX=3 D:$G(DIK(0))'["A" AUDIT^DIK1
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 X=$P($G(DIKZ(15)),U,7)
I X'="" S DH=8925,DV=1507,DU=1 S DIIX=3 D:$G(DIK(0))'["A" AUDIT^DIK1
S X=$P($G(DIKZ(15)),U,8)
I X'="" S DH=8925,DV=1508,DU=1 S DIIX=3 D:$G(DIK(0))'["A" AUDIT^DIK1
S X=$P($G(DIKZ(15)),U,9)
I X'="" S DH=8925,DV=1509,DU=1 S DIIX=3 D:$G(DIK(0))'["A" AUDIT^DIK1
S X=$P($G(DIKZ(15)),U,10)
I X'="" S DH=8925,DV=1510,DU=1 S DIIX=3 D:$G(DIK(0))'["A" AUDIT^DIK1
S X=$P($G(DIKZ(15)),U,12)
I X'="" S DH=8925,DV=1512,DU=1 S DIIX=3 D:$G(DIK(0))'["A" AUDIT^DIK1
S X=$P($G(DIKZ(15)),U,13)
I X'="" S DH=8925,DV=1513,DU=1 S DIIX=3 D:$G(DIK(0))'["A" AUDIT^DIK1
S DIKZ(16)=$G(^TIU(8925,DA,16))
S X=$P($G(DIKZ(16)),U,1)
I X'="" S DH=8925,DV=1601,DU=1 S DIIX=3 D:$G(DIK(0))'["A" AUDIT^DIK1
S X=$P($G(DIKZ(16)),U,2)
I X'="" S DH=8925,DV=1602,DU=1 S DIIX=3 D:$G(DIK(0))'["A" AUDIT^DIK1
S X=$P($G(DIKZ(16)),U,3)
I X'="" S DH=8925,DV=1603,DU=1 S DIIX=3 D:$G(DIK(0))'["A" AUDIT^DIK1
S X=$P($G(DIKZ(16)),U,4)
I X'="" S DH=8925,DV=1604,DU=1 S DIIX=3 D:$G(DIK(0))'["A" AUDIT^DIK1
S X=$P($G(DIKZ(16)),U,5)
I X'="" S DH=8925,DV=1605,DU=1 S DIIX=3 D:$G(DIK(0))'["A" AUDIT^DIK1
S X=$P($G(DIKZ(16)),U,10)
I X'="" S DH=8925,DV=1610,DU=1 S DIIX=3 D:$G(DIK(0))'["A" AUDIT^DIK1
S X=$P($G(DIKZ(16)),U,11)
I X'="" S DH=8925,DV=1611,DU=1 S DIIX=3 D:$G(DIK(0))'["A" AUDIT^DIK1
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=247
K X
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 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)=""
CR2 S DIXR=557
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)=""
CR3 S DIXR=1329
K X
S DIKZ(0)=$G(^TIU(8925,DA,0))
S X(1)=$P(DIKZ(0),U,1)
S X(2)=$P(DIKZ(0),U,5)
S X(3)=$P(DIKZ(0),U,6)
S X(4)=$P(DIKZ(0),U,7)
S X(5)=$P(DIKZ(0),U,8)
S DIKZ(12)=$G(^TIU(8925,DA,12))
S X(6)=$P(DIKZ(12),U,2)
S X(7)=$P(DIKZ(12),U,5)
S DIKZ(13)=$G(^TIU(8925,DA,13))
S X(8)=$P(DIKZ(13),U,1)
S DIKZ(14)=$G(^TIU(8925,DA,14))
S X(9)=$P(DIKZ(14),U,5)
S DIKZ(17)=$G(^TIU(8925,DA,17))
S X(10)=$P(DIKZ(17),U,1)
S DIKZ(21)=$G(^TIU(8925,DA,21))
S X(11)=$P(DIKZ(21),U,1)
S X(12)=$P(DIKZ(0),U,2)
S X=$G(X(1))
D
. K X1,X2 M X1=X,X2=X
. N DIKXARR M DIKXARR=X S DIKCOND=1
. S X=(X2(12)'="")
. S DIKCOND=$G(X) K X M X=DIKXARR
. Q:'DIKCOND
. D DOC^TIUDDX
CR4 S DIXR=1571
K X
S DIKZ(12)=$G(^TIU(8925,DA,12))
S X(1)=$P(DIKZ(12),U,2)
S DIKZ(13)=$G(^TIU(8925,DA,13))
S X(2)=$P(DIKZ(13),U,2)
S X(3)=$P(DIKZ(13),U,1)
S X=$G(X(1))
D
. K X1,X2 M X1=X,X2=X
. D SAADT^TIUDD0(.X)
CR5 S DIXR=1696
K X
S DIKZ(12)=$G(^TIU(8925,DA,12))
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)=""
CR6 K X
END Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HTIUXRC4 3879 printed Nov 22, 2024@17:56:33 Page 2
TIUXRC4 ; COMPILED XREF FOR FILE #8925 ; 05/09/23
+1 ;
+2 IF X'=""
SET DH=8925
SET DV=1504
SET DU=1
SET DIIX=3
if $GET(DIK(0))'["A"
DO AUDIT^DIK1
+3 SET X=$PIECE($GET(DIKZ(15)),U,6)
+4 IF X'=""
SET DH=8925
SET DV=1506
SET DU=1
SET DIIX=3
if $GET(DIK(0))'["A"
DO AUDIT^DIK1
+5 SET X=$PIECE($GET(DIKZ(15)),U,7)
+6 IF X'=""
DO KACLEC^TIUDD01(1507,X)
+7 SET X=$PIECE($GET(DIKZ(15)),U,7)
+8 IF X'=""
DO SACLPT^TIUDD0(1507,X)
+9 SET X=$PIECE($GET(DIKZ(15)),U,7)
+10 IF X'=""
SET DH=8925
SET DV=1507
SET DU=1
SET DIIX=3
if $GET(DIK(0))'["A"
DO AUDIT^DIK1
+11 SET X=$PIECE($GET(DIKZ(15)),U,8)
+12 IF X'=""
SET DH=8925
SET DV=1508
SET DU=1
SET DIIX=3
if $GET(DIK(0))'["A"
DO AUDIT^DIK1
+13 SET X=$PIECE($GET(DIKZ(15)),U,9)
+14 IF X'=""
SET DH=8925
SET DV=1509
SET DU=1
SET DIIX=3
if $GET(DIK(0))'["A"
DO AUDIT^DIK1
+15 SET X=$PIECE($GET(DIKZ(15)),U,10)
+16 IF X'=""
SET DH=8925
SET DV=1510
SET DU=1
SET DIIX=3
if $GET(DIK(0))'["A"
DO AUDIT^DIK1
+17 SET X=$PIECE($GET(DIKZ(15)),U,12)
+18 IF X'=""
SET DH=8925
SET DV=1512
SET DU=1
SET DIIX=3
if $GET(DIK(0))'["A"
DO AUDIT^DIK1
+19 SET X=$PIECE($GET(DIKZ(15)),U,13)
+20 IF X'=""
SET DH=8925
SET DV=1513
SET DU=1
SET DIIX=3
if $GET(DIK(0))'["A"
DO AUDIT^DIK1
+21 SET DIKZ(16)=$GET(^TIU(8925,DA,16))
+22 SET X=$PIECE($GET(DIKZ(16)),U,1)
+23 IF X'=""
SET DH=8925
SET DV=1601
SET DU=1
SET DIIX=3
if $GET(DIK(0))'["A"
DO AUDIT^DIK1
+24 SET X=$PIECE($GET(DIKZ(16)),U,2)
+25 IF X'=""
SET DH=8925
SET DV=1602
SET DU=1
SET DIIX=3
if $GET(DIK(0))'["A"
DO AUDIT^DIK1
+26 SET X=$PIECE($GET(DIKZ(16)),U,3)
+27 IF X'=""
SET DH=8925
SET DV=1603
SET DU=1
SET DIIX=3
if $GET(DIK(0))'["A"
DO AUDIT^DIK1
+28 SET X=$PIECE($GET(DIKZ(16)),U,4)
+29 IF X'=""
SET DH=8925
SET DV=1604
SET DU=1
SET DIIX=3
if $GET(DIK(0))'["A"
DO AUDIT^DIK1
+30 SET X=$PIECE($GET(DIKZ(16)),U,5)
+31 IF X'=""
SET DH=8925
SET DV=1605
SET DU=1
SET DIIX=3
if $GET(DIK(0))'["A"
DO AUDIT^DIK1
+32 SET X=$PIECE($GET(DIKZ(16)),U,10)
+33 IF X'=""
SET DH=8925
SET DV=1610
SET DU=1
SET DIIX=3
if $GET(DIK(0))'["A"
DO AUDIT^DIK1
+34 SET X=$PIECE($GET(DIKZ(16)),U,11)
+35 IF X'=""
SET DH=8925
SET DV=1611
SET DU=1
SET DIIX=3
if $GET(DIK(0))'["A"
DO AUDIT^DIK1
+36 SET DIKZ(17)=$GET(^TIU(8925,DA,17))
+37 SET X=$PIECE($GET(DIKZ(17)),U,1)
+38 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)
+39 SET DIKZ(21)=$GET(^TIU(8925,DA,21))
+40 SET X=$PIECE($GET(DIKZ(21)),U,1)
+41 IF X'=""
SET ^TIU(8925,"GDAD",$EXTRACT(X,1,30),DA)=""
+42 SET DIKZ(150)=$GET(^TIU(8925,DA,150))
+43 SET X=$PIECE($GET(DIKZ(150)),U,1)
+44 IF X'=""
SET ^TIU(8925,"VID",$EXTRACT(X,1,30),DA)=""
CR1 SET DIXR=247
+1 KILL X
+2 SET X(1)=$PIECE(DIKZ(12),U,12)
+3 SET DIKZ(0)=$GET(^TIU(8925,DA,0))
+4 SET X(2)=$PIECE(DIKZ(0),U,1)
+5 SET X(3)=$PIECE(DIKZ(0),U,5)
+6 SET X=$PIECE(DIKZ(13),U,1)
+7 IF $GET(X)]""
SET X=9999999-X
+8 if $DATA(X)#2
SET X(4)=X
+9 SET X=$GET(X(1))
+10 IF $GET(X(1))]""
IF $GET(X(2))]""
IF $GET(X(3))]""
IF $GET(X(4))]""
Begin DoDot:1
+11 KILL X1,X2
MERGE X1=X,X2=X
+12 SET ^TIU(8925,"ADIV",X(1),X(2),X(3),X(4),DA)=""
End DoDot:1
CR2 SET DIXR=557
+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
CR3 SET DIXR=1329
+1 KILL X
+2 SET DIKZ(0)=$GET(^TIU(8925,DA,0))
+3 SET X(1)=$PIECE(DIKZ(0),U,1)
+4 SET X(2)=$PIECE(DIKZ(0),U,5)
+5 SET X(3)=$PIECE(DIKZ(0),U,6)
+6 SET X(4)=$PIECE(DIKZ(0),U,7)
+7 SET X(5)=$PIECE(DIKZ(0),U,8)
+8 SET DIKZ(12)=$GET(^TIU(8925,DA,12))
+9 SET X(6)=$PIECE(DIKZ(12),U,2)
+10 SET X(7)=$PIECE(DIKZ(12),U,5)
+11 SET DIKZ(13)=$GET(^TIU(8925,DA,13))
+12 SET X(8)=$PIECE(DIKZ(13),U,1)
+13 SET DIKZ(14)=$GET(^TIU(8925,DA,14))
+14 SET X(9)=$PIECE(DIKZ(14),U,5)
+15 SET DIKZ(17)=$GET(^TIU(8925,DA,17))
+16 SET X(10)=$PIECE(DIKZ(17),U,1)
+17 SET DIKZ(21)=$GET(^TIU(8925,DA,21))
+18 SET X(11)=$PIECE(DIKZ(21),U,1)
+19 SET X(12)=$PIECE(DIKZ(0),U,2)
+20 SET X=$GET(X(1))
+21 Begin DoDot:1
+22 KILL X1,X2
MERGE X1=X,X2=X
+23 NEW DIKXARR
MERGE DIKXARR=X
SET DIKCOND=1
+24 SET X=(X2(12)'="")
+25 SET DIKCOND=$GET(X)
KILL X
MERGE X=DIKXARR
+26 if 'DIKCOND
QUIT
+27 DO DOC^TIUDDX
End DoDot:1
CR4 SET DIXR=1571
+1 KILL X
+2 SET DIKZ(12)=$GET(^TIU(8925,DA,12))
+3 SET X(1)=$PIECE(DIKZ(12),U,2)
+4 SET DIKZ(13)=$GET(^TIU(8925,DA,13))
+5 SET X(2)=$PIECE(DIKZ(13),U,2)
+6 SET X(3)=$PIECE(DIKZ(13),U,1)
+7 SET X=$GET(X(1))
+8 Begin DoDot:1
+9 KILL X1,X2
MERGE X1=X,X2=X
+10 DO SAADT^TIUDD0(.X)
End DoDot:1
CR5 SET DIXR=1696
+1 KILL X
+2 SET DIKZ(12)=$GET(^TIU(8925,DA,12))
+3 SET X(1)=$PIECE(DIKZ(12),U,7)
+4 SET X=$GET(X(1))
+5 IF $GET(X(1))]""
Begin DoDot:1
+6 KILL X1,X2
MERGE X1=X,X2=X
+7 SET ^TIU(8925,"VS",X,DA)=""
End DoDot:1
CR6 KILL X
END QUIT
