TIUEPN1 ; ;11/17/04
S X=DG(DQ),DIC=DIE
I $P($$DOCTYPE^TIULF(+DA),U)="DOC",$L($P(^TIU(8925,+DA,0),U)),(+$P(^(0),U,3)>0) S ^TIU(8925,"AA",+X,+^TIU(8925,+DA,0),(9999999-$P(+^AUPNVSIT($P(^TIU(8925,+DA,0),U,3),0),".")),+DA)=""
S X=DG(DQ),DIC=DIE
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,"APT",+X,+$P(^TIU(8925,+DA,0),U),+$P(^TIU(8925,+DA,0),U,5),(9999999-$P(^TIU(8925,+DA,13),U)),DA)=""
S X=DG(DQ),DIC=DIE
I $P($$DOCTYPE^TIULF(+DA),U)="DOC",$L($P(^TIU(8925,+DA,0),U)),(+$P(^(0),U,3)>0) S ^TIU(8925,"AE",+X,(9999999-$P(+^AUPNVSIT($P(^TIU(8925,+DA,0),U,3),0),".")),+^TIU(8925,+DA,0),+DA)=""
S X=DG(DQ),DIC=DIE
S ^TIU(8925,"C",$E(X,1,30),DA)=""
S X=DG(DQ),DIC=DIE
I $P($$DOCTYPE^TIULF(+DA),U)="DOC",+$P($G(^TIU(8925,+DA,0)),U),+$P($G(^(0)),U,3) S ^TIU(8925,"AV",+X,+$P(^TIU(8925,+DA,0),U),+$P(^TIU(8925,+DA,0),U,3),+DA)=""
S X=DG(DQ),DIC=DIE
I +$$APTP^TIULX(+DA),+$P($G(^TIU(8925,+DA,15)),U) S ^TIU(8925,"APTP",+X,+$P($G(^TIU(8925,+DA,15)),U),+DA)=""
S X=DG(DQ),DIC=DIE
I +$P($G(^TIU(8925,+DA,0)),U,4),+$P($G(^TIU(8925,+DA,13)),U),+$P($G(^TIU(8925,+DA,0)),U,5) S ^TIU(8925,"ADCPT",+X,+$P(^TIU(8925,+DA,0),U,4),+$P(^TIU(8925,+DA,0),U,5),(9999999-$P(^TIU(8925,+DA,13),U)),DA)=""
S X=DG(DQ),DIC=DIE
I +$P(^TIU(8925,+DA,0),U),+$P($G(^TIU(8925,+DA,13)),U) S ^TIU(8925,"APTCL",+X,+$$CLINDOC^TIULC1(+$P(^TIU(8925,+DA,0),U),+DA),(9999999-$P(^TIU(8925,+DA,13),U)),DA)=""
S X=DG(DQ),DIC=DIE
I +$P(^TIU(8925,+DA,0),U),+$P($G(^TIU(8925,+DA,13)),U) S ^TIU(8925,"APTCL",+X,38,(9999999-$P(^TIU(8925,+DA,13),U)),DA)=""
S X=DG(DQ),DIC=DIE
D SACLPT^TIUDD0(.02,X)
S X=DG(DQ),DIC=DIE
D SACLAU^TIUDD0(.02,X),SACLAU1^TIUDD0(.02,X)
S X=DG(DQ),DIC=DIE
D SACLEC^TIUDD0(.02,X)
S X=DG(DQ),DIC=DIE
D SACLSB^TIUDD0(.02,X)
S X=DG(DQ),DIC=DIE
D SAPTLD^TIUDD0(.02,X)
S X=DG(DQ),DIC=DIE
D AIHS1A^BTIUXREF
TIUEPN1 ; ;11/17/04
+1 SET X=DG(DQ)
SET DIC=DIE
+2 IF $PIECE($$DOCTYPE^TIULF(+DA),U)="DOC"
IF $LENGTH($PIECE(^TIU(8925,+DA,0),U))
IF (+$PIECE(^(0),U,3)>0)
SET ^TIU(8925,"AA",+X,+^TIU(8925,+DA,0),(9999999-$PIECE(+^AUPNVSIT($PIECE(^TIU(8925,+DA,0),U,3),0),".")),+DA)=""
+3 SET X=DG(DQ)
SET DIC=DIE
+4 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,"APT",+X,+$PIECE(^TIU(8925,+DA,0),U),+$PIECE(^TIU(8925,+DA,0),U,5),(9999999-$PIECE(^TIU(8925,+DA,13),U)),DA)=""
+5 SET X=DG(DQ)
SET DIC=DIE
+6 IF $PIECE($$DOCTYPE^TIULF(+DA),U)="DOC"
IF $LENGTH($PIECE(^TIU(8925,+DA,0),U))
IF (+$PIECE(^(0),U,3)>0)
SET ^TIU(8925,"AE",+X,(9999999-$PIECE(+^AUPNVSIT($PIECE(^TIU(8925,+DA,0),U,3),0),".")),+^TIU(8925,+DA,0),+DA)=""
+7 SET X=DG(DQ)
SET DIC=DIE
+8 SET ^TIU(8925,"C",$EXTRACT(X,1,30),DA)=""
+9 SET X=DG(DQ)
SET DIC=DIE
+10 IF $PIECE($$DOCTYPE^TIULF(+DA),U)="DOC"
IF +$PIECE($GET(^TIU(8925,+DA,0)),U)
IF +$PIECE($GET(^(0)),U,3)
SET ^TIU(8925,"AV",+X,+$PIECE(^TIU(8925,+DA,0),U),+$PIECE(^TIU(8925,+DA,0),U,3),+DA)=""
+11 SET X=DG(DQ)
SET DIC=DIE
+12 IF +$$APTP^TIULX(+DA)
IF +$PIECE($GET(^TIU(8925,+DA,15)),U)
SET ^TIU(8925,"APTP",+X,+$PIECE($GET(^TIU(8925,+DA,15)),U),+DA)=""
+13 SET X=DG(DQ)
SET DIC=DIE
+14 IF +$PIECE($GET(^TIU(8925,+DA,0)),U,4)
IF +$PIECE($GET(^TIU(8925,+DA,13)),U)
IF +$PIECE($GET(^TIU(8925,+DA,0)),U,5)
SET ^TIU(8925,"ADCPT",+X,+$PIECE(^TIU(8925,+DA,0),U,4),+$PIECE(^TIU(8925,+DA,0),U,5),(9999999-$PIECE(^TIU(8925,+DA,13),U)),DA)=""
+15 SET X=DG(DQ)
SET DIC=DIE
+16 IF +$PIECE(^TIU(8925,+DA,0),U)
IF +$PIECE($GET(^TIU(8925,+DA,13)),U)
SET ^TIU(8925,"APTCL",+X,+$$CLINDOC^TIULC1(+$PIECE(^TIU(8925,+DA,0),U),+DA),(9999999-$PIECE(^TIU(8925,+DA,13),U)),DA)=""
+17 SET X=DG(DQ)
SET DIC=DIE
+18 IF +$PIECE(^TIU(8925,+DA,0),U)
IF +$PIECE($GET(^TIU(8925,+DA,13)),U)
SET ^TIU(8925,"APTCL",+X,38,(9999999-$PIECE(^TIU(8925,+DA,13),U)),DA)=""
+19 SET X=DG(DQ)
SET DIC=DIE
+20 DO SACLPT^TIUDD0(.02,X)
+21 SET X=DG(DQ)
SET DIC=DIE
+22 DO SACLAU^TIUDD0(.02,X)
DO SACLAU1^TIUDD0(.02,X)
+23 SET X=DG(DQ)
SET DIC=DIE
+24 DO SACLEC^TIUDD0(.02,X)
+25 SET X=DG(DQ)
SET DIC=DIE
+26 DO SACLSB^TIUDD0(.02,X)
+27 SET X=DG(DQ)
SET DIC=DIE
+28 DO SAPTLD^TIUDD0(.02,X)
+29 SET X=DG(DQ)
SET DIC=DIE
+30 DO AIHS1A^BTIUXREF
