- TIUXRC3 ; COMPILED XREF FOR FILE #8925 ; 09/22/15
- ;
- I X'="" I +$P($G(^TIU(8925,+DA,13)),U),+$P($G(^TIU(8925,+DA,0)),U,5) K ^TIU(8925,"ALL","ANY",+X,+$P(^TIU(8925,+DA,0),U,5),(9999999-$P($G(^TIU(8925,+DA,13)),U)),DA)
- S X=$P($G(DIKZ(0)),U,1)
- I X'="" I $L($P(^TIU(8925,+DA,0),U,2)),(+$P(^(0),U,3)>0) K ^TIU(8925,"AA",+$P(^(0),U,2),+X,(9999999-$P(+^AUPNVSIT(+$P(^TIU(8925,+DA,0),U,3),0),".")),DA)
- S X=$P($G(DIKZ(0)),U,1)
- I X'="" I $L($P($G(^TIU(8925,+DA,17)),U)),+$P($G(^TIU(8925,+DA,13)),U),+$P($G(^TIU(8925,+DA,0)),U,5) D ASUBK^TIUDD($P($G(^TIU(8925,+DA,17)),U),+X,+$P(^TIU(8925,+DA,0),U,5),(9999999-+$G(^TIU(8925,+DA,13))),DA)
- S X=$P($G(DIKZ(0)),U,1)
- I X'="" I +$P($G(^TIU(8925,+DA,14)),U,4),+$P($G(^TIU(8925,+DA,13)),U),+$P($G(^TIU(8925,+DA,0)),U,5) K ^TIU(8925,"ASVC",+$P($G(^TIU(8925,+DA,14)),U,4),+X,+$P($G(^TIU(8925,+DA,0)),U,5),(9999999-$P($G(^TIU(8925,+DA,13)),U)),DA)
- S X=$P($G(DIKZ(0)),U,1)
- I X'="" I $L($P(^TIU(8925,+DA,0),U)),(+$P(^(0),U,3)>0) K ^TIU(8925,"AE",+$P($G(^TIU(8925,+DA,0)),U,2),(9999999-$P(+^AUPNVSIT(+$P(^TIU(8925,+DA,0),U,3),0),".")),+X,+DA)
- S X=$P($G(DIKZ(0)),U,1)
- 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,5) K ^TIU(8925,"ALOC",+$P($G(^TIU(8925,+DA,12)),U,5),+X,+$P($G(^TIU(8925,+DA,0)),U,5),(9999999-$P($G(^TIU(8925,+DA,13)),U)),DA)
- S X=$P($G(DIKZ(0)),U,1)
- I X'="" I +$P($G(^TIU(8925,+DA,13)),U),+$P($G(^TIU(8925,+DA,0)),U,5),+$O(^TIU(8925.9,"B",+DA,0)) D APRBK^TIUDD(+X,+$P(^TIU(8925,+DA,0),U,5),(9999999-+$G(^TIU(8925,+DA,13))),DA)
- S X=$P($G(DIKZ(0)),U,1)
- I X'="" I +$P(^TIU(8925,+DA,0),U,3),+$P($G(^TIU(8925,+DA,13)),U),+$P($G(^TIU(8925,+DA,0)),U,5) K ^TIU(8925,"AVSIT",+$P(^TIU(8925,+DA,0),U,3),+X,+$P(^TIU(8925,+DA,0),U,5),(9999999-$P(^TIU(8925,+DA,13),U)),DA)
- S X=$P($G(DIKZ(0)),U,1)
- I X'="" I +$P(^TIU(8925,+DA,0),U,2),+$P($G(^TIU(8925,+DA,13)),U) K ^TIU(8925,"APTCL",+$P(^TIU(8925,+DA,0),U,2),+$$CLINDOC^TIULC1(+X,+DA),(9999999-$P(^TIU(8925,+DA,13),U)),DA)
- S X=$P($G(DIKZ(0)),U,1)
- I X'="" I +$P(^TIU(8925,+DA,0),U,2),+$P($G(^TIU(8925,+DA,13)),U) K ^TIU(8925,"APTCL",+$P(^TIU(8925,+DA,0),U,2),38,(9999999-$P(^TIU(8925,+DA,13),U)),DA)
- S X=$P($G(DIKZ(0)),U,1)
- I X'="" D KACLPT^TIUDD01(.01,X)
- S X=$P($G(DIKZ(0)),U,1)
- I X'="" D KACLAU^TIUDD01(.01,X),KACLAU1^TIUDD01(.01,X)
- S X=$P($G(DIKZ(0)),U,1)
- I X'="" D KACLEC^TIUDD01(.01,X)
- S X=$P($G(DIKZ(0)),U,1)
- I X'="" D KACLSB^TIUDD01(.01,X)
- S X=$P($G(DIKZ(0)),U,1)
- I X'="" D KAPTLD^TIUDD01(.01,X)
- S X=$P($G(DIKZ(0)),U,1)
- I X'="" D AIHS12K^BTIUXREF
- 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:$D(DIKIL) (X2,X2(1))=""
- . K ^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:$D(DIKIL) (X2,X2(1),X2(2),X2(3),X2(4))=""
- . K ^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:$D(DIKIL) (X2,X2(1),X2(2))=""
- . K ^TIU(8925,"VBC",$E(X(1),1,14),$E(X(2),1,6),DA)
- CR4 K X
- END Q
- TIUXRC3 ; COMPILED XREF FOR FILE #8925 ; 09/22/15
- +1 ;
- +2 IF X'=""
- IF +$PIECE($GET(^TIU(8925,+DA,13)),U)
- IF +$PIECE($GET(^TIU(8925,+DA,0)),U,5)
- KILL ^TIU(8925,"ALL","ANY",+X,+$PIECE(^TIU(8925,+DA,0),U,5),(9999999-$PIECE($GET(^TIU(8925,+DA,13)),U)),DA)
- +3 SET X=$PIECE($GET(DIKZ(0)),U,1)
- +4 IF X'=""
- IF $LENGTH($PIECE(^TIU(8925,+DA,0),U,2))
- IF (+$PIECE(^(0),U,3)>0)
- KILL ^TIU(8925,"AA",+$PIECE(^(0),U,2),+X,(9999999-$PIECE(+^AUPNVSIT(+$PIECE(^TIU(8925,+DA,0),U,3),0),".")),DA)
- +5 SET X=$PIECE($GET(DIKZ(0)),U,1)
- +6 IF X'=""
- IF $LENGTH($PIECE($GET(^TIU(8925,+DA,17)),U))
- IF +$PIECE($GET(^TIU(8925,+DA,13)),U)
- IF +$PIECE($GET(^TIU(8925,+DA,0)),U,5)
- DO ASUBK^TIUDD($PIECE($GET(^TIU(8925,+DA,17)),U),+X,+$PIECE(^TIU(8925,+DA,0),U,5),(9999999-+$GET(^TIU(8925,+DA,13))),DA)
- +7 SET X=$PIECE($GET(DIKZ(0)),U,1)
- +8 IF X'=""
- IF +$PIECE($GET(^TIU(8925,+DA,14)),U,4)
- IF +$PIECE($GET(^TIU(8925,+DA,13)),U)
- IF +$PIECE($GET(^TIU(8925,+DA,0)),U,5)
- KILL ^TIU(8925,"ASVC",+$PIECE($GET(^TIU(8925,+DA,14)),U,4),+X,+$PIECE($GET(^TIU(8925,+DA,0)),U,5),(9999999-$PIECE($GET(^TIU(8925,+DA,13)),U)),DA)
- +9 SET X=$PIECE($GET(DIKZ(0)),U,1)
- +10 IF X'=""
- IF $LENGTH($PIECE(^TIU(8925,+DA,0),U))
- IF (+$PIECE(^(0),U,3)>0)
- KILL ^TIU(8925,"AE",+$PIECE($GET(^TIU(8925,+DA,0)),U,2),(9999999-$PIECE(+^AUPNVSIT(+$PIECE(^TIU(8925,+DA,0),U,3),0),".")),+X,+DA)
- +11 SET X=$PIECE($GET(DIKZ(0)),U,1)
- +12 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,5)
- KILL ^TIU(8925,"ALOC",+$PIECE($GET(^TIU(8925,+DA,12)),U,5),+X,+$PIECE($GET(^TIU(8925,+DA,0)),U,5),(9999999-$PIECE($GET(^TIU(8925,+DA,13)),U)),DA)
- +13 SET X=$PIECE($GET(DIKZ(0)),U,1)
- +14 IF X'=""
- IF +$PIECE($GET(^TIU(8925,+DA,13)),U)
- IF +$PIECE($GET(^TIU(8925,+DA,0)),U,5)
- IF +$ORDER(^TIU(8925.9,"B",+DA,0))
- DO APRBK^TIUDD(+X,+$PIECE(^TIU(8925,+DA,0),U,5),(9999999-+$GET(^TIU(8925,+DA,13))),DA)
- +15 SET X=$PIECE($GET(DIKZ(0)),U,1)
- +16 IF X'=""
- IF +$PIECE(^TIU(8925,+DA,0),U,3)
- IF +$PIECE($GET(^TIU(8925,+DA,13)),U)
- IF +$PIECE($GET(^TIU(8925,+DA,0)),U,5)
- KILL ^TIU(8925,"AVSIT",+$PIECE(^TIU(8925,+DA,0),U,3),+X,+$PIECE(^TIU(8925,+DA,0),U,5),(9999999-$PIECE(^TIU(8925,+DA,13),U)),DA)
- +17 SET X=$PIECE($GET(DIKZ(0)),U,1)
- +18 IF X'=""
- IF +$PIECE(^TIU(8925,+DA,0),U,2)
- IF +$PIECE($GET(^TIU(8925,+DA,13)),U)
- KILL ^TIU(8925,"APTCL",+$PIECE(^TIU(8925,+DA,0),U,2),+$$CLINDOC^TIULC1(+X,+DA),(9999999-$PIECE(^TIU(8925,+DA,13),U)),DA)
- +19 SET X=$PIECE($GET(DIKZ(0)),U,1)
- +20 IF X'=""
- IF +$PIECE(^TIU(8925,+DA,0),U,2)
- IF +$PIECE($GET(^TIU(8925,+DA,13)),U)
- KILL ^TIU(8925,"APTCL",+$PIECE(^TIU(8925,+DA,0),U,2),38,(9999999-$PIECE(^TIU(8925,+DA,13),U)),DA)
- +21 SET X=$PIECE($GET(DIKZ(0)),U,1)
- +22 IF X'=""
- DO KACLPT^TIUDD01(.01,X)
- +23 SET X=$PIECE($GET(DIKZ(0)),U,1)
- +24 IF X'=""
- DO KACLAU^TIUDD01(.01,X)
- DO KACLAU1^TIUDD01(.01,X)
- +25 SET X=$PIECE($GET(DIKZ(0)),U,1)
- +26 IF X'=""
- DO KACLEC^TIUDD01(.01,X)
- +27 SET X=$PIECE($GET(DIKZ(0)),U,1)
- +28 IF X'=""
- DO KACLSB^TIUDD01(.01,X)
- +29 SET X=$PIECE($GET(DIKZ(0)),U,1)
- +30 IF X'=""
- DO KAPTLD^TIUDD01(.01,X)
- +31 SET X=$PIECE($GET(DIKZ(0)),U,1)
- +32 IF X'=""
- DO AIHS12K^BTIUXREF
- 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 IF $DATA(DIKIL)
- SET (X2,X2(1))=""
- +7 KILL ^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 IF $DATA(DIKIL)
- SET (X2,X2(1),X2(2),X2(3),X2(4))=""
- +15 KILL ^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 IF $DATA(DIKIL)
- SET (X2,X2(1),X2(2))=""
- +10 KILL ^TIU(8925,"VBC",$EXTRACT(X(1),1,14),$EXTRACT(X(2),1,6),DA)
- End DoDot:1
- CR4 KILL X
- END QUIT
