- DIO4 ;SFISC/GFT,XAK,TKW-FINISH OUTPUT, CLOSE DEVICE ;9JAN2004
- ;;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.
- ;
- K DIXX,DIWT,DIW,DIP,DSC,DRK,DIO("SCR") D:'$D(DISYS) OS^DII
- G:$G(DIFIXPT)=1 K1
- I $G(DIBTPGM)]"" D
- .N % S %=+$P(DIBTPGM,"^DISZ",2) D:% ENRLS^DIOZ(%) K DIBTPGM Q
- I ($G(ZTSTOP)=1!($G(DIFMSTOP))!($G(DIERR)))&'$D(DIAR) K:$G(ZTQUEUED) DIERR,^TMP("DIERR",$J) D FF G STOP
- I $G(S)'=0!(IO'=$P),$G(DISTP)'<1,$D(^UTILITY($J,"T")) S A=0 D ^DIO3 ;DO TOTALS UNLESS USER HAS ABORTED MIDWAY
- MATCHES I L!($D(DISTEMP)),DISEARCH,'DISUPNO D:'DJ&('DC)&($D(^UTILITY($J,2))) HDR W !!!?25,$S('DJ:$$EZBLD^DIALOG(8006.1),$G(DUZ("LANG"))>1:$$EZBLD^DIALOG(8006.2,DJ),1:DJ_" MATCH"_$P("ES",U,DJ'=1)_" FOUND.") W:IOST?1"C".E $C(7) ;**
- I DISEARCH,$G(DISV),$D(^DIBT(DISV)) D NOW^%DTC S ^DIBT(DISV,"QR")=%_U_+DJ
- NO I $G(DISTP)<1,'DIO,'DISUPNO,'DC D:$D(^UTILITY($J,2)) HDR W !!!!,?10,$$EZBLD^DIALOG(8007.1) ;**NO RECORDS TO PRINT
- I $D(DIAR) D UPDATE^DIARU
- I $D(CP) S X=-1,^DOSV(0,IO(0),"CP")=CP F S X=$O(CP(X)),Z=-1 Q:X="" F S Z=$O(CP(X,Z)) Q:Z="" S ^DOSV(0,IO(0),"CP",X,Z)=CP(X,Z) Q:X=Z
- I $D(DIOT),$D(Y),Y'=U S DY(1)="X DIOT S DN=0",DN=1 D ^DIO2
- D FF
- I $D(DCOPIES),$D(DOUT),$D(^DD("OS",DISYS,"SDPEND")) D SDP
- G:$G(DIOEND)="G M^DIAU" M^DIAU G:$G(DIOEND)="G L^DIDC" L^DIDC
- X:$D(DIOEND) DIOEND K DIOEND
- STOP I $G(ZTSTOP)=1,$G(DISTOP("C"))]"" X DISTOP("C")
- D CLOSE I DUZ(0)'="@" S X=0 X ^DD("FUNC",18,1)
- K ;S:$D(ZTSK) ZTREQ="@"
- I $D(ZTQUEUED) D
- . S ZTREQ="@"
- . I $G(DDXPTMDL),$D(DDXPXTNO) N DA,DIK S DIK="^DIPT(",DA=DDXPXTNO D ^DIK
- K1 K ^UTILITY($J),^(U,$J),^UTILITY("DIP2",$J),FLDS,DIOT,DQI,A,B,C,D,E,H,I,J,M,N,L,P,Q,S,V,W,X,Y,Z,DITTO,DIP,DIPA,BY
- K %,%H,%I,%A,%B,%DT,%Q,%X,%Y,%Z,FR,CP,DA,DD,DIO,DL,DM,DN,DI,DE,D9,D5,D4,D3,D2,D1,DCOPIES,DIFF,DIASKHD,DISTOP,DISTP,DILCT,DISV,DISX,DIAC,DIFILE
- K DIS,SF,DIPDT,DIPR,DICMX,DHT,DIWL,DIWR,DIPASS,DICSS,DIONOSUB,DIOSUBHD
- K DIRUT,DIROUT,DUOUT,DTOUT,DIHELP,DIMSG,^TMP("DIHELP",$J),^TMP("DIMSG",$J)
- I '$G(DIQUIET) K ^TMP("DIERR",$J),DIERR
- K DIBT,DIBT1,DIBT2,DX,DY,DNP,DC,DXS,DINS,DIPT,IOP,DCC,DQ,DJ,DJK,DIOP,DIOSL,DLP,DILIOSL,DHIT,DIJ,DPR,DP,DISUPNO,DIPCRIT,DIBTOLD,DITYP,DISTXT,DISEARCH Q
- ;
- FF W:IOST?1"P".E&$Y&L @IOF
- Q
- ;
- SDP Q:'DCOPIES W ! X ^DD("OS",DISYS,"SDPEND")
- S DIO=IO,DLP=IOPAR,IOP=DOUT,A=IO(0) D ^%ZIS S IO(0)=A Q:POP
- F A=1:1:DCOPIES W:IOST?1"P".E&$Y @IOF X ^DD("OS",DISYS,"SDP") U IO
- I IO'=IO(0) S X=IO X ^DD("FUNC",7,1) K IO(1,IO)
- S IO=DIO Q
- ;
- CLOSE ;
- S DIOP=IO X $G(^%ZIS("C"))
- O $P::2 E H ;I $P(IO(0),DIOP)]"" S IOP=IO(0) D ^%ZIS H:POP S X=DIOP X ^DD("FUNC",7,1) K IO(1,IO) U IO(0)
- K DIOP Q
- HDR N DN S DN=1 X ^UTILITY($J,1) Q
- N G N^DIO2
- T G T^DIO2
- CSTP G CSTP^DIO2
- DT G DT^DIO2 Q
- C G C^DIO2
- S G S^DIO2
- P G P^DIO2
- A G A^DIO2
- D G D^DIO2
- CP G CP^DIO2
- H G H^DIO2
- M G M^DIO2
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDIO4 3054 printed Feb 19, 2025@00:18:43 Page 2
- DIO4 ;SFISC/GFT,XAK,TKW-FINISH OUTPUT, CLOSE DEVICE ;9JAN2004
- +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 KILL DIXX,DIWT,DIW,DIP,DSC,DRK,DIO("SCR")
- if '$DATA(DISYS)
- DO OS^DII
- +8 if $GET(DIFIXPT)=1
- GOTO K1
- +9 IF $GET(DIBTPGM)]""
- Begin DoDot:1
- +10 NEW %
- SET %=+$PIECE(DIBTPGM,"^DISZ",2)
- if %
- DO ENRLS^DIOZ(%)
- KILL DIBTPGM
- QUIT
- End DoDot:1
- +11 IF ($GET(ZTSTOP)=1!($GET(DIFMSTOP))!($GET(DIERR)))&'$DATA(DIAR)
- if $GET(ZTQUEUED)
- KILL DIERR,^TMP("DIERR",$JOB)
- DO FF
- GOTO STOP
- +12 ;DO TOTALS UNLESS USER HAS ABORTED MIDWAY
- IF $GET(S)'=0!(IO'=$PRINCIPAL)
- IF $GET(DISTP)'<1
- IF $DATA(^UTILITY($JOB,"T"))
- SET A=0
- DO ^DIO3
- MATCHES ;**
- IF L!($DATA(DISTEMP))
- IF DISEARCH
- IF 'DISUPNO
- if 'DJ&('DC)&($DATA(^UTILITY($JOB,2)))
- DO HDR
- WRITE !!!?25,$SELECT('DJ:$$EZBLD^DIALOG(8006.1),$GET(DUZ("LANG"))>1:$$EZBLD^DIALOG(8006.2,DJ),1:DJ_" MATCH"_$PIECE("ES",U,DJ'=1)_" FOUND.")
- if IOST?1"C".E
- WRITE $CHAR(7)
- +1 IF DISEARCH
- IF $GET(DISV)
- IF $DATA(^DIBT(DISV))
- DO NOW^%DTC
- SET ^DIBT(DISV,"QR")=%_U_+DJ
- NO ;**NO RECORDS TO PRINT
- IF $GET(DISTP)<1
- IF 'DIO
- IF 'DISUPNO
- IF 'DC
- if $DATA(^UTILITY($JOB,2))
- DO HDR
- WRITE !!!!,?10,$$EZBLD^DIALOG(8007.1)
- +1 IF $DATA(DIAR)
- DO UPDATE^DIARU
- +2 IF $DATA(CP)
- SET X=-1
- SET ^DOSV(0,IO(0),"CP")=CP
- FOR
- SET X=$ORDER(CP(X))
- SET Z=-1
- if X=""
- QUIT
- FOR
- SET Z=$ORDER(CP(X,Z))
- if Z=""
- QUIT
- SET ^DOSV(0,IO(0),"CP",X,Z)=CP(X,Z)
- if X=Z
- QUIT
- +3 IF $DATA(DIOT)
- IF $DATA(Y)
- IF Y'=U
- SET DY(1)="X DIOT S DN=0"
- SET DN=1
- DO ^DIO2
- +4 DO FF
- +5 IF $DATA(DCOPIES)
- IF $DATA(DOUT)
- IF $DATA(^DD("OS",DISYS,"SDPEND"))
- DO SDP
- +6 if $GET(DIOEND)="G M^DIAU"
- GOTO M^DIAU
- if $GET(DIOEND)="G L^DIDC"
- GOTO L^DIDC
- +7 if $DATA(DIOEND)
- XECUTE DIOEND
- KILL DIOEND
- STOP IF $GET(ZTSTOP)=1
- IF $GET(DISTOP("C"))]""
- XECUTE DISTOP("C")
- +1 DO CLOSE
- IF DUZ(0)'="@"
- SET X=0
- XECUTE ^DD("FUNC",18,1)
- K ;S:$D(ZTSK) ZTREQ="@"
- +1 IF $DATA(ZTQUEUED)
- Begin DoDot:1
- +2 SET ZTREQ="@"
- +3 IF $GET(DDXPTMDL)
- IF $DATA(DDXPXTNO)
- NEW DA,DIK
- SET DIK="^DIPT("
- SET DA=DDXPXTNO
- DO ^DIK
- End DoDot:1
- K1 KILL ^UTILITY($JOB),^(U,$JOB),^UTILITY("DIP2",$JOB),FLDS,DIOT,DQI,A,B,C,D,E,H,I,J,M,N,L,P,Q,S,V,W,X,Y,Z,DITTO,DIP,DIPA,BY
- +1 KILL %,%H,%I,%A,%B,%DT,%Q,%X,%Y,%Z,FR,CP,DA,DD,DIO,DL,DM,DN,DI,DE,D9,D5,D4,D3,D2,D1,DCOPIES,DIFF,DIASKHD,DISTOP,DISTP,DILCT,DISV,DISX,DIAC,DIFILE
- +2 KILL DIS,SF,DIPDT,DIPR,DICMX,DHT,DIWL,DIWR,DIPASS,DICSS,DIONOSUB,DIOSUBHD
- +3 KILL DIRUT,DIROUT,DUOUT,DTOUT,DIHELP,DIMSG,^TMP("DIHELP",$JOB),^TMP("DIMSG",$JOB)
- +4 IF '$GET(DIQUIET)
- KILL ^TMP("DIERR",$JOB),DIERR
- +5 KILL DIBT,DIBT1,DIBT2,DX,DY,DNP,DC,DXS,DINS,DIPT,IOP,DCC,DQ,DJ,DJK,DIOP,DIOSL,DLP,DILIOSL,DHIT,DIJ,DPR,DP,DISUPNO,DIPCRIT,DIBTOLD,DITYP,DISTXT,DISEARCH
- QUIT
- +6 ;
- FF if IOST?1"P".E&$Y&L
- WRITE @IOF
- +1 QUIT
- +2 ;
- SDP if 'DCOPIES
- QUIT
- WRITE !
- XECUTE ^DD("OS",DISYS,"SDPEND")
- +1 SET DIO=IO
- SET DLP=IOPAR
- SET IOP=DOUT
- SET A=IO(0)
- DO ^%ZIS
- SET IO(0)=A
- if POP
- QUIT
- +2 FOR A=1:1:DCOPIES
- if IOST?1"P".E&$Y
- WRITE @IOF
- XECUTE ^DD("OS",DISYS,"SDP")
- USE IO
- +3 IF IO'=IO(0)
- SET X=IO
- XECUTE ^DD("FUNC",7,1)
- KILL IO(1,IO)
- +4 SET IO=DIO
- QUIT
- +5 ;
- CLOSE ;
- +1 SET DIOP=IO
- XECUTE $GET(^%ZIS("C"))
- +2 ;I $P(IO(0),DIOP)]"" S IOP=IO(0) D ^%ZIS H:POP S X=DIOP X ^DD("FUNC",7,1) K IO(1,IO) U IO(0)
- OPEN $PRINCIPAL::2
- IF '$TEST
- HANG
- +3 KILL DIOP
- QUIT
- HDR NEW DN
- SET DN=1
- XECUTE ^UTILITY($JOB,1)
- QUIT
- N GOTO N^DIO2
- T GOTO T^DIO2
- CSTP GOTO CSTP^DIO2
- DT GOTO DT^DIO2
- QUIT
- C GOTO C^DIO2
- S GOTO S^DIO2
- P GOTO P^DIO2
- A GOTO A^DIO2
- D GOTO D^DIO2
- CP GOTO CP^DIO2
- H GOTO H^DIO2
- M GOTO M^DIO2