- TIUEDS1 ; ;02/28/13
- 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
- TIUEDS1 ; ;02/28/13
- +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
