- DIO2 ;SFISC/GFT,TKW-PRINT ;9:17 AM 24 Feb 2000 [ 04/02/2003 8:25 AM ]
- ;;22.0;VA FileMan;**1001**;APR 1, 2003
- ;;22.0;VA FileMan;**32**;Mar 30, 1999
- ;Per VHA Directive 10-93-142, this routine should not be modified.
- S (DISTP,DILCT)=0
- XDY I $D(DIBTPGM) D @("EN"_DIBTPGM),ENRLS^DIOZ(+$P(DIBTPGM,"^DISZ",2)) Q
- X DY(DN) G XDY:DN
- Q
- ;
- SEARCH S DISEARCH=1 ; Protect switch SO-2/24/2000
- SCR S DIO("SCR")=1,DE=0 I '$D(DIS(0)) G OR
- X DIS(0) Q:'$T G PASS:'$D(DIS(1))
- OR S DE=DE+1 I '$D(DIS(DE)) Q
- X DIS(DE) E G OR
- PASS S:'$D(DPQ) DIPASS=1
- O F DLP=0:1:DX Q:'DN X $S($D(DPQ):DX(DLP),1:^UTILITY($J,99,DLP))
- Q
- ;
- N W !
- T I $X,IOT'="MT" W !
- I '$D(DIOT(2)),DN,$D(IOSL),$S('$D(DIWF):1,$P(DIWF,"B",2):$P(DIWF,"B",2),1:1)+$Y'<IOSL,$D(^UTILITY($J,1))#2,^(1)?1U1P1E.E X ^(1)
- S DISTP=DISTP+1,DILCT=DILCT+1 D:'(DISTP#100) CSTP
- Q
- ;
- CSTP I $G(IOT)="SPL"!($G(IOT)="HFS") I '$D(DPQ),$$ROUEXIST^DILIBF("XUPARAM"),DILCT>$$KSP^XUPARAM("SPOOL LINES") D Q
- . S DIFMSTOP=1,DN=0 S:$D(ZTQUEUED) ZTSTOP=1
- . W !,"*** JOB STOPPED BECAUSE MAXIMUM SPOOL LINES HAS BEEN EXCEEDED ***",!! Q
- I '$D(ZTQUEUED) K DISTOP Q
- Q:$G(DISTOP)=0 S:$G(DISTOP)="" DISTOP=1
- I DISTOP'=1 X DISTOP K:'$T DISTOP S DISTOP=$T Q:'$T
- Q:'$$S^%ZTLOAD
- W:$G(IO)]"" !,"*** TASK "_ZTSK_" STOPPED BY USER - DURING "_$S($D(DPQ):"SORT",1:"PRINT")_" EXECUTION ***",!! S ZTSTOP=1,DN=0 Q
- ;
- DT I $G(DDXPDATE) D DT^DDXP4 W DDXPY K DDXPY Q
- I $G(DUZ("LANG"))>1,Y W $$OUT^DIALOGU(Y,"DD") Q
- I Y W $P("JAN^FEB^MAR^APR^MAY^JUN^JUL^AUG^SEP^OCT^NOV^DEC",U,$E(Y,4,5))_" " W:Y#100 $J(Y#100\1,2)_"," W Y\10000+1700 W:Y#1 " "_$E(Y_0,9,10)_":"_$E(Y_"000",11,12) Q
- W Y Q
- ;
- C S DQ(C)=Y
- S S Q(C)=Y*Y+Q(C) S:L(C)>Y L(C)=Y S:H(C)<Y H(C)=Y
- P S N(C)=N(C)+1
- A S S(C)=S(C)+Y Q
- D I Y=DITTO(C) S Y="" Q
- S DITTO(C)=Y Q
- ;
- CP S C="" F S C=$O(CP(C)) Q:C="" G DQ:'$D(DQ(C))
- S CP=CP+1 F S C=$O(CP(C)),A="" Q:C="" F S A=$O(CP(A)) S CP(C,A)=DQ(C)*DQ(A)+CP(C,A) Q:A=C
- DQ K DQ Q
- ;
- H F DI=DI:1:DN I $D(^UTILITY($J,"H",DI)) X ^UTILITY($J,"H",DI) W:$X&($G(DIAR)'=4)&($G(DIAR)'=6) !
- Q
- ;
- M X $S($D(DPQ):DX(DIXX),1:^UTILITY($J,99,DIXX))
- DIO2 ;SFISC/GFT,TKW-PRINT ;9:17 AM 24 Feb 2000 [ 04/02/2003 8:25 AM ]
- +1 ;;22.0;VA FileMan;**1001**;APR 1, 2003
- +2 ;;22.0;VA FileMan;**32**;Mar 30, 1999
- +3 ;Per VHA Directive 10-93-142, this routine should not be modified.
- +4 SET (DISTP,DILCT)=0
- XDY IF $DATA(DIBTPGM)
- DO @("EN"_DIBTPGM)
- DO ENRLS^DIOZ(+$PIECE(DIBTPGM,"^DISZ",2))
- QUIT
- +1 XECUTE DY(DN)
- IF DN
- GOTO XDY
- +2 QUIT
- +3 ;
- SEARCH ; Protect switch SO-2/24/2000
- SET DISEARCH=1
- SCR SET DIO("SCR")=1
- SET DE=0
- IF '$DATA(DIS(0))
- GOTO OR
- +1 XECUTE DIS(0)
- IF '$TEST
- QUIT
- IF '$DATA(DIS(1))
- GOTO PASS
- OR SET DE=DE+1
- IF '$DATA(DIS(DE))
- QUIT
- +1 XECUTE DIS(DE)
- IF '$TEST
- GOTO OR
- PASS IF '$DATA(DPQ)
- SET DIPASS=1
- O FOR DLP=0:1:DX
- IF 'DN
- QUIT
- XECUTE $SELECT($DATA(DPQ):DX(DLP),1:^UTILITY($JOB,99,DLP))
- +1 QUIT
- +2 ;
- N WRITE !
- T IF $X
- IF IOT'="MT"
- WRITE !
- +1 IF '$DATA(DIOT(2))
- IF DN
- IF $DATA(IOSL)
- IF $SELECT('$DATA(DIWF):1,$PIECE(DIWF,"B",2):$PIECE(DIWF,"B",2),1:1)+$Y'<IOSL
- IF $DATA(^UTILITY($JOB,1))#2
- IF ^(1)?1U1P1E.E
- XECUTE ^(1)
- +2 SET DISTP=DISTP+1
- SET DILCT=DILCT+1
- IF '(DISTP#100)
- DO CSTP
- +3 QUIT
- +4 ;
- CSTP IF $GET(IOT)="SPL"!($GET(IOT)="HFS")
- IF '$DATA(DPQ)
- IF $$ROUEXIST^DILIBF("XUPARAM")
- IF DILCT>$$KSP^XUPARAM("SPOOL LINES")
- Begin DoDot:1
- +1 SET DIFMSTOP=1
- SET DN=0
- IF $DATA(ZTQUEUED)
- SET ZTSTOP=1
- +2 WRITE !,"*** JOB STOPPED BECAUSE MAXIMUM SPOOL LINES HAS BEEN EXCEEDED ***",!!
- QUIT
- End DoDot:1
- QUIT
- +3 IF '$DATA(ZTQUEUED)
- KILL DISTOP
- QUIT
- +4 IF $GET(DISTOP)=0
- QUIT
- IF $GET(DISTOP)=""
- SET DISTOP=1
- +5 IF DISTOP'=1
- XECUTE DISTOP
- IF '$TEST
- KILL DISTOP
- SET DISTOP=$TEST
- IF '$TEST
- QUIT
- +6 IF '$$S^%ZTLOAD
- QUIT
- +7 IF $GET(IO)]""
- WRITE !,"*** TASK "_ZTSK_" STOPPED BY USER - DURING "_$SELECT($DATA(DPQ):"SORT",1:"PRINT")_" EXECUTION ***",!!
- SET ZTSTOP=1
- SET DN=0
- QUIT
- +8 ;
- DT IF $GET(DDXPDATE)
- DO DT^DDXP4
- WRITE DDXPY
- KILL DDXPY
- QUIT
- +1 IF $GET(DUZ("LANG"))>1
- IF Y
- WRITE $$OUT^DIALOGU(Y,"DD")
- QUIT
- +2 IF Y
- WRITE $PIECE("JAN^FEB^MAR^APR^MAY^JUN^JUL^AUG^SEP^OCT^NOV^DEC",U,$EXTRACT(Y,4,5))_" "
- IF Y#100
- WRITE $JUSTIFY(Y#100\1,2)_","
- WRITE Y\10000+1700
- IF Y#1
- WRITE " "_$EXTRACT(Y_0,9,10)_":"_$EXTRACT(Y_"000",11,12)
- QUIT
- +3 WRITE Y
- QUIT
- +4 ;
- C SET DQ(C)=Y
- S SET Q(C)=Y*Y+Q(C)
- IF L(C)>Y
- SET L(C)=Y
- IF H(C)<Y
- SET H(C)=Y
- P SET N(C)=N(C)+1
- A SET S(C)=S(C)+Y
- QUIT
- D IF Y=DITTO(C)
- SET Y=""
- QUIT
- +1 SET DITTO(C)=Y
- QUIT
- +2 ;
- CP SET C=""
- FOR
- SET C=$ORDER(CP(C))
- IF C=""
- QUIT
- IF '$DATA(DQ(C))
- GOTO DQ
- +1 SET CP=CP+1
- FOR
- SET C=$ORDER(CP(C))
- SET A=""
- IF C=""
- QUIT
- FOR
- SET A=$ORDER(CP(A))
- SET CP(C,A)=DQ(C)*DQ(A)+CP(C,A)
- IF A=C
- QUIT
- DQ KILL DQ
- QUIT
- +1 ;
- H FOR DI=DI:1:DN
- IF $DATA(^UTILITY($JOB,"H",DI))
- XECUTE ^UTILITY($JOB,"H",DI)
- IF $X&($GET(DIAR)'=4)&($GET(DIAR)'=6)
- WRITE !
- +1 QUIT
- +2 ;
- M XECUTE $SELECT($DATA(DPQ):DX(DIXX),1:^UTILITY($JOB,99,DIXX))
