- 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
