ZISPL2.m

ZISPL2 ;SF/RWF - SPOOLER CLEAN-UP ;12/03/97  14:57 [ 04/02/2003   8:29 AM ]

 ;;8.0;KERNEL;**1001,1002,1003,1004,1005,1007**;APR 1, 2003

 ;;8.0;KERNEL;**23,36,69**;Jul 10, 1995

1 N DA,DIC,DIK,ZIS,ZISPL

 K ^XMB(3.51,"AM") ;Clear X-ref first

 S DIK="^XMB(3.51," D IXALL^DIK ;Re-Index

 S ZISPL=$G(^XTV(8989.3,1,"SPL"),"1^1^999"),ZISDT=$$FMADD^XLFDT(DT,"-"_$P(ZISPL,"^",3))

 F DA=0:0 S DA=$O(^XMB(3.51,DA)) Q:DA'>0  S ZIS=^XMB(3.51,DA,0) I "rpm"[$P(ZIS,"^",3),ZISDT>$S($P(ZIS,"^",6)]"":$P(ZIS,"^",6),$P(ZIS,"^",4)]"":$P(ZIS,"^",4),1:ZISDT) D DELETE

 F DA=0:0 S DA=$O(^XMB(3.51,DA)) Q:DA'>0  S ZIS=^XMB(3.51,DA,0) I "ao"[$P(ZIS,"^",3),ZISDT>$S($P(ZIS,"^",6)]"":$P(ZIS,"^",6),$P(ZIS,"^",4)]"":$P(ZIS,"^",4),1:ZISDT) D CLOSE

 F DA=0:0 S DA=$O(^XMBS(3.519,DA)) Q:DA'>0  I '$D(^XMB(3.51,"AM",DA)) D DSD^ZISPL(DA) ;Remove Spool data w/o Spool entry

 Q

DELETE ;REMOVE SPOOL DOC.

 D DSD^ZISPL($P(ZIS,U,10)) ;Delete Spool Data entry

 S DIK="^XMB(3.51," D ^DIK ;Delete entry

 Q

CLOSE ;Close a SPOOL DOC that has been open too long.

 I $$NEWERR^%ZTER N $ESTACK,$ETRAP S $ETRAP=""

 S X="ET^ZISPL2",@^%ZOSF("TRAP")

 S %ZFN=$P(ZIS,"^",2),IO=%ZFN,IO("SPOOL")=DA

 D SPL3^%ZIS4 I %ZFN="" D DELETE Q

 X "N DA,ZIS D CLOSE^%ZIS4" Q

ET ;TRAP ERROR.

 D DELETE Q

DQP Q:'$D(^XMB(3.51,ZISDA,2,ZISDA2,0))!('$D(ZISPLC))  ;Dequeue print

 S ZISPL0=^XMB(3.51,ZISDA,0),FF="|TOP|",XS=$P(ZISPL0,U,10) Q:XS'>0

 U IO F ZISCNT=ZISPLC:-1:1 S PG=1 D OUT S $P(^(0),U,6)=$P(^XMB(3.51,ZISDA,2,ZISDA2,0),U,6)+1

 W:$Y>3 @IOF D NOW^%DTC S $P(^XMB(3.51,ZISDA,0),"^",3)="p",$P(^(0),"^",7)=%,$P(^XMB(3.51,ZISDA,2,ZISDA2,0),U,3,5)="^^"_%

 D ^%ZISC G EXIT^ZISPL

 ;

OUT ;

 F I=0:0 S I=$O(^XMBS(3.519,XS,2,I)) Q:I'>0  S X=^(I,0),Y=(X=FF) W:Y @IOF W:'Y X,! I Y S PG=PG+1,$P(^XMB(3.51,ZISDA,2,ZISDA2,0),"^",3,4)=PG_"^"_I

 Q

ZISPL2    ;SF/RWF - SPOOLER CLEAN-UP ;12/03/97  14:57 [ 04/02/2003   8:29 AM ]

 +1       ;;8.0;KERNEL;**1001,1002,1003,1004,1005,1007**;APR 1, 2003

 +2       ;;8.0;KERNEL;**23,36,69**;Jul 10, 1995

1          NEW DA,DIC,DIK,ZIS,ZISPL

 +1       ;Clear X-ref first

           KILL ^XMB(3.51,"AM")

 +2       ;Re-Index

           SET DIK="^XMB(3.51,"

           DO IXALL^DIK

 +3        SET ZISPL=$GET(^XTV(8989.3,1,"SPL"),"1^1^999")

           SET ZISDT=$$FMADD^XLFDT(DT,"-"_$PIECE(ZISPL,"^",3))

 +4        FOR DA=0:0

               SET DA=$ORDER(^XMB(3.51,DA))

               IF DA'>0

                   QUIT 

               SET ZIS=^XMB(3.51,DA,0)

               IF "rpm"[$PIECE(ZIS,"^",3)

                   IF ZISDT>$SELECT($PIECE(ZIS,"^",6)]"":$PIECE(ZIS,"^",6),$PIECE(ZIS,"^",4)]"":$PIECE(ZIS,"^",4),1:ZISDT)

                       DO DELETE

 +5        FOR DA=0:0

               SET DA=$ORDER(^XMB(3.51,DA))

               IF DA'>0

                   QUIT 

               SET ZIS=^XMB(3.51,DA,0)

               IF "ao"[$PIECE(ZIS,"^",3)

                   IF ZISDT>$SELECT($PIECE(ZIS,"^",6)]"":$PIECE(ZIS,"^",6),$PIECE(ZIS,"^",4)]"":$PIECE(ZIS,"^",4),1:ZISDT)

                       DO CLOSE

 +6       ;Remove Spool data w/o Spool entry

           FOR DA=0:0

               SET DA=$ORDER(^XMBS(3.519,DA))

               IF DA'>0

                   QUIT 

               IF '$DATA(^XMB(3.51,"AM",DA))

                   DO DSD^ZISPL(DA)

 +7        QUIT 

DELETE    ;REMOVE SPOOL DOC.

 +1       ;Delete Spool Data entry

           DO DSD^ZISPL($PIECE(ZIS,U,10))

 +2       ;Delete entry

           SET DIK="^XMB(3.51,"

           DO ^DIK

 +3        QUIT 

CLOSE     ;Close a SPOOL DOC that has been open too long.

 +1        IF $$NEWERR^%ZTER

               NEW $ESTACK,$ETRAP

               SET $ETRAP=""

 +2        SET X="ET^ZISPL2"

           SET @^%ZOSF("TRAP")

 +3        SET %ZFN=$PIECE(ZIS,"^",2)

           SET IO=%ZFN

           SET IO("SPOOL")=DA

 +4        DO SPL3^%ZIS4

           IF %ZFN=""

               DO DELETE

               QUIT 

 +5        XECUTE "N DA,ZIS D CLOSE^%ZIS4"

           QUIT 

ET        ;TRAP ERROR.

 +1        DO DELETE

           QUIT 

DQP       ;Dequeue print

           IF '$DATA(^XMB(3.51,ZISDA,2,ZISDA2,0))!('$DATA(ZISPLC))

               QUIT 

 +1        SET ZISPL0=^XMB(3.51,ZISDA,0)

           SET FF="|TOP|"

           SET XS=$PIECE(ZISPL0,U,10)

           IF XS'>0

               QUIT 

 +2        USE IO

           FOR ZISCNT=ZISPLC:-1:1

               SET PG=1

               DO OUT

               SET $PIECE(^(0),U,6)=$PIECE(^XMB(3.51,ZISDA,2,ZISDA2,0),U,6)+1

 +3        IF $Y>3

               WRITE @IOF

           DO NOW^%DTC

           SET $PIECE(^XMB(3.51,ZISDA,0),"^",3)="p"

           SET $PIECE(^(0),"^",7)=%

           SET $PIECE(^XMB(3.51,ZISDA,2,ZISDA2,0),U,3,5)="^^"_%

 +4        DO ^%ZISC

           GOTO EXIT^ZISPL

 +5       ;

OUT       ;

 +1        FOR I=0:0

               SET I=$ORDER(^XMBS(3.519,XS,2,I))

               IF I'>0

                   QUIT 

               SET X=^(I,0)

               SET Y=(X=FF)

               IF Y

                   WRITE @IOF

               IF 'Y

                   WRITE X,!

               IF Y

                   SET PG=PG+1

                   SET $PIECE(^XMB(3.51,ZISDA,2,ZISDA2,0),"^",3,4)=PG_"^"_I

 +2        QUIT