- DIO ;SFISC/GFT,TKW-CALL SORT, ACTUAL OUTPUT ;7:15 AM 27 May 1999
- ;;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 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)
- 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
- GO ;
- 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,%
- S DCC=U_$P(DJ,U,3),@("DD=$P("_DCC_"0),U,2)"),DP=+DD
- I '$D(DIBTPGM),+$G(DIBT1),$G(^DIBT(DIBT1,"ROU"))]"",DPQ S DIBTPGM=^("ROU") D
- . N DRN,DIERR D NXTNO^DIOZ(.DRN) I $G(DIERR) D QSV^DIOZ Q
- . S DIBTPGM=DIBTPGM_$E("000",1,(4-$L(DRN)))_DRN
- . Q
- K:$G(DIBTPGM)="" DIBTPGM
- I '$D(DSC),'$G(DIO("SCR"))=1,DD["s",$D(^DD(DP,0,"SCR")) D SCR
- 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
- I $G(ZTSTOP)=1!($G(DIFMSTOP)) G IXK
- I $D(DIBTPGM) D
- .S (DICNT,DICP,DICDX,DICOV)=1 K DISAVX,DISETP,DISETQ,^TMP("DIBTC",$J)
- .I '$D(DSC),'$G(DIO("SCR")),$D(DIS)>9 D SVSCR
- DIOO1 F Z=1:1:DD-1 S @DL="",DL="DIOO"_Z,DN=DL_","_DN N @DL
- S @DL=$S($D(DPP(DJK,"F"))&$D(DPP(DJK,"IX")):$P(DPP(DJK,"F"),U),DD>1:"",1:0),Z=0 D ^DIO0
- I DPQ G ^DIOS
- 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
- 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
- I $D(DIWL),DIWL=1 S ^(1)="S DIWF=""W"" "_^UTILITY($J,99,1)
- IXK K DPP,DPQ,DJ,M,DISMIN,DISH
- I $G(ZTSTOP)=1!($G(DIFMSTOP)) I $G(DIBTPGM)]"" D
- .N % S %=+$P(DIBTPGM,"^DISZ",2) D:% ENRLS^DIOZ(%) K DIBTPGM Q
- D 2 S:'$D(Y) Y=1 G ^DIO4
- ;
- 2 ;
- I $D(DIBTPGM) D
- .I '$D(DPQ),$D(DX(0)) N %,X S %="D O^DIO2",(%(1),%(2))="DX",X=0 D SETU^DIOS
- .D ENC^DIOZ K ^UTILITY($J,0) Q
- 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
- I $G(ZTSTOP)=1!($G(DIFMSTOP))!($G(DIERR)) S (DJ,DIO)=0 Q
- S X=1 X ^DD("FUNC",18,1)
- I $D(DIOBEG) X DIOBEG K DIOBEG
- S I(0)=DCC,J(0)=DP,DI=99,(DN,X)=1,(DJ,DE,DIO,IOX,IOY)=0
- G ^DIO2
- ;
- 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
- S DIS("SCR")=DD,DIS(0)=$S($D(DIBTPGM):"D DISCR",1:"X DIS(""SCR"")")_" I "_DIS(0)
- Q
- SVSCR ;SAVE DIS ARRAY INTO ^TMP FOR LATER COMPILATION
- N %,I,J,K S %=.0000001
- I $D(DIS)'=11 S ^TMP("DIBTC",$J,%,DICNT)="SEARCH S DIO=1",DICNT=DICNT+1
- S ^TMP("DIBTC",$J,%,DICNT)="SCR S DIO(""SCR"")=1",DICNT=DICNT+1
- S I="" I $D(DIS(0)) S ^(DICNT)=" "_DIS(0),I=" Q:'$T ",DICNT=DICNT+1
- S:$O(DIS(0)) I=I_" D S1 Q:'$T " I I]"" S ^(DICNT)=I,DICNT=DICNT+1
- S ^(DICNT)="PASS S:'$D(DPQ) DIPASS=1",^(DICNT+1)=" G O",DICNT=DICNT+2
- I $O(DIS(0)) S K=0 D
- .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
- .S ^(DICNT)=" Q",DICNT=DICNT+1 Q
- I $G(DIS("SCR"))]"" S ^TMP("DIBTC",$J,%,DICNT)="DISCR "_DIS("SCR"),^(DICNT+1)=" Q",DICNT=DICNT+2
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDIO 3397 printed Feb 19, 2025@00:18:38 Page 2
- DIO ;SFISC/GFT,TKW-CALL SORT, ACTUAL OUTPUT ;7:15 AM 27 May 1999
- +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 Y=-1
- if $DATA(DCL)>9
- KILL ^DOSV(0,IO(0))
- FOR Z=0:1
- SET Y=$ORDER(DCL(Y))
- if Y=""
- QUIT
- SET V=DCL(Y)
- SET ^DOSV(0,IO(0),"F",+V)=Y_U_$PIECE($GET(^DD(+Y,+$PIECE(Y,U,2),0)),U,1,2)
- +8 IF $GET(DIOEND)["M^DIAU"!($GET(DIOEND)["L^DIDC")
- SET %X="DPP("
- SET %Y="DIPP("
- DO %XY^%RCR
- SET DIJS=DJ
- SET DIPQ=DPQ
- SET DIMS=M
- SET DIPP=DPP
- GO ;
- +1 KILL 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,%
- +2 SET DCC=U_$PIECE(DJ,U,3)
- SET @("DD=$P("_DCC_"0),U,2)")
- SET DP=+DD
- +3 IF '$DATA(DIBTPGM)
- IF +$GET(DIBT1)
- IF $GET(^DIBT(DIBT1,"ROU"))]""
- IF DPQ
- SET DIBTPGM=^("ROU")
- Begin DoDot:1
- +4 NEW DRN,DIERR
- DO NXTNO^DIOZ(.DRN)
- IF $GET(DIERR)
- DO QSV^DIOZ
- QUIT
- +5 SET DIBTPGM=DIBTPGM_$EXTRACT("000",1,(4-$LENGTH(DRN)))_DRN
- +6 QUIT
- End DoDot:1
- +7 if $GET(DIBTPGM)=""
- KILL DIBTPGM
- +8 IF '$DATA(DSC)
- IF '$GET(DIO("SCR"))=1
- IF DD["s"
- IF $DATA(^DD(DP,0,"SCR"))
- DO SCR
- +9 SET DD=$PIECE(DJ,U,4)
- SET DL="D0"
- SET DN=DL
- SET DI=$SELECT('$DATA(BY(0)):U,$EXTRACT(BY(0))=U:U,1:"")_$PIECE(DJ,U,2)
- SET A=1
- +10 IF $GET(ZTSTOP)=1!($GET(DIFMSTOP))
- GOTO IXK
- +11 IF $DATA(DIBTPGM)
- Begin DoDot:1
- +12 SET (DICNT,DICP,DICDX,DICOV)=1
- KILL DISAVX,DISETP,DISETQ,^TMP("DIBTC",$JOB)
- +13 IF '$DATA(DSC)
- IF '$GET(DIO("SCR"))
- IF $DATA(DIS)>9
- DO SVSCR
- End DoDot:1
- DIOO1 FOR Z=1:1:DD-1
- SET @DL=""
- SET DL="DIOO"_Z
- SET DN=DL_","_DN
- NEW @DL
- +1 SET @DL=$SELECT($DATA(DPP(DJK,"F"))&$DATA(DPP(DJK,"IX")):$PIECE(DPP(DJK,"F"),U),DD>1:"",1:0)
- SET Z=0
- DO ^DIO0
- +2 IF DPQ
- GOTO ^DIOS
- IX IF $DATA(DPP(DJK,"IX"))
- IF $ORDER(^UTILITY($JOB,99,99))>99
- IF DPP(DJK)-DP
- IF '$DATA(DSC)
- IF DD>1
- SET X="I $D("_$PIECE(DPP(DJK,"IX"),U,1,2)_DN
- FOR %=1:1
- SET X=X_",D"_%
- IF %+1=DD
- SET DSC(+DPP(DJK))=X_"))"
- QUIT
- +1 IF $DATA(CP)
- SET C=""
- SET CP=0
- FOR X=0:0
- SET C=$ORDER(CP(C))
- SET A=""
- if C=""
- QUIT
- KILL CP(C)
- SET CP(C,C)=0
- FOR Y=0:0
- SET A=$ORDER(CP(A))
- if A=C
- QUIT
- SET CP(C,A)=0
- +2 IF $DATA(DIWL)
- IF DIWL=1
- SET ^(1)="S DIWF=""W"" "_^UTILITY($JOB,99,1)
- IXK KILL DPP,DPQ,DJ,M,DISMIN,DISH
- +1 IF $GET(ZTSTOP)=1!($GET(DIFMSTOP))
- IF $GET(DIBTPGM)]""
- Begin DoDot:1
- +2 NEW %
- SET %=+$PIECE(DIBTPGM,"^DISZ",2)
- if %
- DO ENRLS^DIOZ(%)
- KILL DIBTPGM
- QUIT
- End DoDot:1
- +3 DO 2
- if '$DATA(Y)
- SET Y=1
- GOTO ^DIO4
- +4 ;
- 2 ;
- +1 IF $DATA(DIBTPGM)
- Begin DoDot:1
- +2 IF '$DATA(DPQ)
- IF $DATA(DX(0))
- NEW %,X
- SET %="D O^DIO2"
- SET (%(1),%(2))="DX"
- SET X=0
- DO SETU^DIOS
- +3 DO ENC^DIOZ
- KILL ^UTILITY($JOB,0)
- QUIT
- End DoDot:1
- +4 KILL DLN,DL,F,I,J,V,W,X,Y,Z,DE,DRJ,DICP,DICDX,DICOV,DICNT,DISAVX,DISETP,DISETQ,^TMP("DIBTC",$JOB)
- if '$DATA(DISYS)
- DO OS^DII
- +5 IF $GET(ZTSTOP)=1!($GET(DIFMSTOP))!($GET(DIERR))
- SET (DJ,DIO)=0
- QUIT
- +6 SET X=1
- XECUTE ^DD("FUNC",18,1)
- +7 IF $DATA(DIOBEG)
- XECUTE DIOBEG
- KILL DIOBEG
- +8 SET I(0)=DCC
- SET J(0)=DP
- SET DI=99
- SET (DN,X)=1
- SET (DJ,DE,DIO,IOX,IOY)=0
- +9 GOTO ^DIO2
- +10 ;
- SCR SET DD="S Y=D0 I $D("_DCC_"Y,0)) "_^("SCR")
- IF '$DATA(DIS(0))
- if '$DATA(DIS)
- SET DIS=1
- SET DIS(0)=DD
- QUIT
- +1 SET DIS("SCR")=DD
- SET DIS(0)=$SELECT($DATA(DIBTPGM):"D DISCR",1:"X DIS(""SCR"")")_" I "_DIS(0)
- +2 QUIT
- SVSCR ;SAVE DIS ARRAY INTO ^TMP FOR LATER COMPILATION
- +1 NEW %,I,J,K
- SET %=.0000001
- +2 IF $DATA(DIS)'=11
- SET ^TMP("DIBTC",$JOB,%,DICNT)="SEARCH S DIO=1"
- SET DICNT=DICNT+1
- +3 SET ^TMP("DIBTC",$JOB,%,DICNT)="SCR S DIO(""SCR"")=1"
- SET DICNT=DICNT+1
- +4 SET I=""
- IF $DATA(DIS(0))
- SET ^(DICNT)=" "_DIS(0)
- SET I=" Q:'$T "
- SET DICNT=DICNT+1
- +5 if $ORDER(DIS(0))
- SET I=I_" D S1 Q:'$T "
- IF I]""
- SET ^(DICNT)=I
- SET DICNT=DICNT+1
- +6 SET ^(DICNT)="PASS S:'$D(DPQ) DIPASS=1"
- SET ^(DICNT+1)=" G O"
- SET DICNT=DICNT+2
- +7 IF $ORDER(DIS(0))
- SET K=0
- Begin DoDot:1
- +8 FOR J=1:1
- if '$DATA(DIS(J))
- QUIT
- if K
- SET ^TMP("DIBTC",$JOB,%,DICNT)=" Q:$T"
- SET DICNT=DICNT+1
- SET ^(DICNT)=$PIECE("S1 ^ ",U,K+1)_DIS(J)
- SET DICNT=DICNT+1
- SET K=1
- +9 SET ^(DICNT)=" Q"
- SET DICNT=DICNT+1
- QUIT
- End DoDot:1
- +10 IF $GET(DIS("SCR"))]""
- SET ^TMP("DIBTC",$JOB,%,DICNT)="DISCR "_DIS("SCR")
- SET ^(DICNT+1)=" Q"
- SET DICNT=DICNT+2
- +11 QUIT