| 1 | DIO ;SFISC/GFT,TKW-CALL SORT, ACTUAL OUTPUT ;7:15 AM 27 May 1999
|
|---|
| 2 | ;;22.0;VA FileMan;**2**;Mar 30, 1999
|
|---|
| 3 | ;Per VHA Directive 10-93-142, this routine should not be modified.
|
|---|
| 4 | S Y=-1 K:$D(DCL)>9 ^DOSV(0,IO(0)) F Z=0:1 S Y=$O(DCL(Y)) Q:Y="" S V=DCL(Y),^DOSV(0,IO(0),"F",+V)=Y_U_$P($G(^DD(+Y,+$P(Y,U,2),0)),U,1,2)
|
|---|
| 5 | I $G(DIOEND)["M^DIAU"!($G(DIOEND)["L^DIDC") S %X="DPP(",%Y="DIPP(" D %XY^%RCR S DIJS=DJ,DIPQ=DPQ,DIMS=M,DIPP=DPP
|
|---|
| 6 | GO ;
|
|---|
| 7 | K DCL,DIASKHD,DIPT,DIPZ,DIL,DIL0,R,DOP,DHD,DD,DE,DG,DI,DIC,DK,DL,DN,DM,DU,DV,DW,DP,DY,POP,D,O,X,Y,V,DICS,TO,%X,%Y,DQ,%
|
|---|
| 8 | S DCC=U_$P(DJ,U,3),@("DD=$P("_DCC_"0),U,2)"),DP=+DD
|
|---|
| 9 | I '$D(DIBTPGM),+$G(DIBT1),$G(^DIBT(DIBT1,"ROU"))]"",DPQ S DIBTPGM=^("ROU") D
|
|---|
| 10 | . N DRN,DIERR D NXTNO^DIOZ(.DRN) I $G(DIERR) D QSV^DIOZ Q
|
|---|
| 11 | . S DIBTPGM=DIBTPGM_$E("000",1,(4-$L(DRN)))_DRN
|
|---|
| 12 | . Q
|
|---|
| 13 | K:$G(DIBTPGM)="" DIBTPGM
|
|---|
| 14 | I '$D(DSC),'$G(DIO("SCR"))=1,DD["s",$D(^DD(DP,0,"SCR")) D SCR
|
|---|
| 15 | S DD=$P(DJ,U,4),DL="D0",DN=DL,DI=$S('$D(BY(0)):U,$E(BY(0))=U:U,1:"")_$P(DJ,U,2),A=1
|
|---|
| 16 | I $G(ZTSTOP)=1!($G(DIFMSTOP)) G IXK
|
|---|
| 17 | I $D(DIBTPGM) D
|
|---|
| 18 | .S (DICNT,DICP,DICDX,DICOV)=1 K DISAVX,DISETP,DISETQ,^TMP("DIBTC",$J)
|
|---|
| 19 | .I '$D(DSC),'$G(DIO("SCR")),$D(DIS)>9 D SVSCR
|
|---|
| 20 | DIOO1 F Z=1:1:DD-1 S @DL="",DL="DIOO"_Z,DN=DL_","_DN N @DL
|
|---|
| 21 | S @DL=$S($D(DPP(DJK,"F"))&$D(DPP(DJK,"IX")):$P(DPP(DJK,"F"),U),DD>1:"",1:0),Z=0 D ^DIO0
|
|---|
| 22 | I DPQ G ^DIOS
|
|---|
| 23 | IX I $D(DPP(DJK,"IX")),$O(^UTILITY($J,99,99))>99,DPP(DJK)-DP,'$D(DSC),DD>1 S X="I $D("_$P(DPP(DJK,"IX"),U,1,2)_DN F %=1:1 S X=X_",D"_% I %+1=DD S DSC(+DPP(DJK))=X_"))" Q
|
|---|
| 24 | I $D(CP) S C="",CP=0 F X=0:0 S C=$O(CP(C)),A="" Q:C="" K CP(C) S CP(C,C)=0 F Y=0:0 S A=$O(CP(A)) Q:A=C S CP(C,A)=0
|
|---|
| 25 | I $D(DIWL),DIWL=1 S ^(1)="S DIWF=""W"" "_^UTILITY($J,99,1)
|
|---|
| 26 | IXK K DPP,DPQ,DJ,M,DISMIN,DISH
|
|---|
| 27 | I $G(ZTSTOP)=1!($G(DIFMSTOP)) I $G(DIBTPGM)]"" D
|
|---|
| 28 | .N % S %=+$P(DIBTPGM,"^DISZ",2) D:% ENRLS^DIOZ(%) K DIBTPGM Q
|
|---|
| 29 | D 2 S:'$D(Y) Y=1 G ^DIO4
|
|---|
| 30 | ;
|
|---|
| 31 | 2 ;
|
|---|
| 32 | I $D(DIBTPGM) D
|
|---|
| 33 | .I '$D(DPQ),$D(DX(0)) N %,X S %="D O^DIO2",(%(1),%(2))="DX",X=0 D SETU^DIOS
|
|---|
| 34 | .D ENC^DIOZ K ^UTILITY($J,0) Q
|
|---|
| 35 | K DLN,DL,F,I,J,V,W,X,Y,Z,DE,DRJ,DICP,DICDX,DICOV,DICNT,DISAVX,DISETP,DISETQ,^TMP("DIBTC",$J) D:'$D(DISYS) OS^DII
|
|---|
| 36 | I $G(ZTSTOP)=1!($G(DIFMSTOP))!($G(DIERR)) S (DJ,DIO)=0 Q
|
|---|
| 37 | S X=1 X ^DD("FUNC",18,1)
|
|---|
| 38 | I $D(DIOBEG) X DIOBEG K DIOBEG
|
|---|
| 39 | S I(0)=DCC,J(0)=DP,DI=99,(DN,X)=1,(DJ,DE,DIO,IOX,IOY)=0
|
|---|
| 40 | G ^DIO2
|
|---|
| 41 | ;
|
|---|
| 42 | SCR S DD="S Y=D0 I $D("_DCC_"Y,0)) "_^("SCR") I '$D(DIS(0)) S:'$D(DIS) DIS=1 S DIS(0)=DD Q
|
|---|
| 43 | S DIS("SCR")=DD,DIS(0)=$S($D(DIBTPGM):"D DISCR",1:"X DIS(""SCR"")")_" I "_DIS(0)
|
|---|
| 44 | Q
|
|---|
| 45 | SVSCR ;SAVE DIS ARRAY INTO ^TMP FOR LATER COMPILATION
|
|---|
| 46 | N %,I,J,K S %=.0000001
|
|---|
| 47 | I $D(DIS)'=11 S ^TMP("DIBTC",$J,%,DICNT)="SEARCH S DIO=1",DICNT=DICNT+1
|
|---|
| 48 | S ^TMP("DIBTC",$J,%,DICNT)="SCR S DIO(""SCR"")=1",DICNT=DICNT+1
|
|---|
| 49 | S I="" I $D(DIS(0)) S ^(DICNT)=" "_DIS(0),I=" Q:'$T ",DICNT=DICNT+1
|
|---|
| 50 | S:$O(DIS(0)) I=I_" D S1 Q:'$T " I I]"" S ^(DICNT)=I,DICNT=DICNT+1
|
|---|
| 51 | S ^(DICNT)="PASS S:'$D(DPQ) DIPASS=1",^(DICNT+1)=" G O",DICNT=DICNT+2
|
|---|
| 52 | I $O(DIS(0)) S K=0 D
|
|---|
| 53 | .F J=1:1 Q:'$D(DIS(J)) S:K ^TMP("DIBTC",$J,%,DICNT)=" Q:$T",DICNT=DICNT+1 S ^(DICNT)=$P("S1 ^ ",U,K+1)_DIS(J),DICNT=DICNT+1,K=1
|
|---|
| 54 | .S ^(DICNT)=" Q",DICNT=DICNT+1 Q
|
|---|
| 55 | I $G(DIS("SCR"))]"" S ^TMP("DIBTC",$J,%,DICNT)="DISCR "_DIS("SCR"),^(DICNT+1)=" Q",DICNT=DICNT+2
|
|---|
| 56 | Q
|
|---|
