DIO2 ;SFISC/GFT,TKW-PRINT ;15JAN2004
;;22.2;VA FileMan;;Jan 05, 2016;Build 42
;;Per VA Directive 6402, this routine should not be modified.
;;Submitted to OSEHRA 5 January 2015 by the VISTA Expertise Network.
;;Based on Medsphere Systems Corporation's MSC FileMan 1051.
;;Licensed under the terms of the Apache License, Version 2.0.
;
S (DISTP,DILCT)=0
I '$D(DICMX) S DICMX="D M^DIO2"
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))
TRAIL S:$D(DIOT) DIOT("D0")=$G(D0)
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 !,$$EZBLD^DIALOG(1519,$$KSP^XUPARAM("SPOOL LINES")),!! ;**CCO/NI SPOOL LINE MESSAGE ON OUTPUT
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
TASKSTOP W:$G(IO)]"" !,$$EZBLD^DIALOG($D(DPQ)>0+1528,ZTSK),!! S ZTSTOP=1,DN=0 Q ;**CCO/NI 'TASK HAS BEEN STOPPED'
;
DT I $G(DDXPDATE) D DT^DDXP4 W DDXPY K DDXPY Q
I $G(DUZ("LANG"))>1,Y W $$OUT^DIALOGU(Y,"DD") Q
X ^DD("DD") ;**CCO/NI
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
;
DITTO(C,Y) D D Q Y
D I Y=$G(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))
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDIO2 2197 printed Oct 16, 2024@18:52:59 Page 2
DIO2 ;SFISC/GFT,TKW-PRINT ;15JAN2004
+1 ;;22.2;VA FileMan;;Jan 05, 2016;Build 42
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;;Submitted to OSEHRA 5 January 2015 by the VISTA Expertise Network.
+4 ;;Based on Medsphere Systems Corporation's MSC FileMan 1051.
+5 ;;Licensed under the terms of the Apache License, Version 2.0.
+6 ;
+7 SET (DISTP,DILCT)=0
+8 IF '$DATA(DICMX)
SET DICMX="D M^DIO2"
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))
TRAIL if $DATA(DIOT)
SET DIOT("D0")=$GET(D0)
+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 ;**CCO/NI SPOOL LINE MESSAGE ON OUTPUT
WRITE !,$$EZBLD^DIALOG(1519,$$KSP^XUPARAM("SPOOL LINES")),!!
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
TASKSTOP ;**CCO/NI 'TASK HAS BEEN STOPPED'
if $GET(IO)]""
WRITE !,$$EZBLD^DIALOG($DATA(DPQ)>0+1528,ZTSK),!!
SET ZTSTOP=1
SET DN=0
QUIT
+1 ;
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 ;**CCO/NI
XECUTE ^DD("DD")
+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
+1 ;
DITTO(C,Y) DO D
QUIT Y
D IF Y=$GET(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))
