- DIO4 ;SFISC/GFT,XAK,TKW-FINISH OUTPUT, CLOSE DEVICE ;9:57 AM 30 Dec 2003
- ;;22.0;VA FileMan;**2,32,45,136**;Mar 30, 1999
- ;Per VHA Directive 10-93-142, this routine should not be modified.
- 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(DISTP)'<1,$D(^UTILITY($J,"T")) S A=0 D ^DIO3
- I L!($D(DISTEMP)),DISEARCH,'DISUPNO D:'DJ&('DC)&($D(^UTILITY($J,2))) HDR W !!!?25,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
- I $G(DISTP)<1,'DIO,'DISUPNO,'DC D:$D(^UTILITY($J,2)) HDR W !!!!,?10,"*** 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
- 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
- ;VistA Close Logic 22*136
- I $G(^%ZIS("C"))="G ^%ZISC" X ^%ZIS("C") K DIOP Q
- ;Stand Alone Close Logic
- I $P(IO(0),DIOP)]"" S IOP="HOME" 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
- DIO4 ;SFISC/GFT,XAK,TKW-FINISH OUTPUT, CLOSE DEVICE ;9:57 AM 30 Dec 2003
- +1 ;;22.0;VA FileMan;**2,32,45,136**;Mar 30, 1999
- +2 ;Per VHA Directive 10-93-142, this routine should not be modified.
- +3 KILL DIXX,DIWT,DIW,DIP,DSC,DRK,DIO("SCR")
- IF '$DATA(DISYS)
- DO OS^DII
- +4 IF $GET(DIFIXPT)=1
- GOTO K1
- +5 IF $GET(DIBTPGM)]""
- Begin DoDot:1
- +6 NEW %
- SET %=+$PIECE(DIBTPGM,"^DISZ",2)
- IF %
- DO ENRLS^DIOZ(%)
- KILL DIBTPGM
- QUIT
- End DoDot:1
- +7 IF ($GET(ZTSTOP)=1!($GET(DIFMSTOP))!($GET(DIERR)))&'$DATA(DIAR)
- IF $GET(ZTQUEUED)
- KILL DIERR,^TMP("DIERR",$JOB)
- DO FF
- GOTO STOP
- +8 IF $GET(DISTP)'<1
- IF $DATA(^UTILITY($JOB,"T"))
- SET A=0
- DO ^DIO3
- +9 IF L!($DATA(DISTEMP))
- IF DISEARCH
- IF 'DISUPNO
- IF 'DJ&('DC)&($DATA(^UTILITY($JOB,2)))
- DO HDR
- WRITE !!!?25,DJ," MATCH",$PIECE("ES",U,DJ'=1)," FOUND."
- IF IOST?1"C".E
- WRITE $CHAR(7)
- +10 IF DISEARCH
- IF $GET(DISV)
- IF $DATA(^DIBT(DISV))
- DO NOW^%DTC
- SET ^DIBT(DISV,"QR")=%_U_+DJ
- +11 IF $GET(DISTP)<1
- IF 'DIO
- IF 'DISUPNO
- IF 'DC
- IF $DATA(^UTILITY($JOB,2))
- DO HDR
- WRITE !!!!,?10,"*** NO RECORDS TO PRINT ***"
- +12 IF $DATA(DIAR)
- DO UPDATE^DIARU
- +13 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
- +14 IF $DATA(DIOT)
- IF $DATA(Y)
- IF Y'=U
- SET DY(1)="X DIOT S DN=0"
- SET DN=1
- DO ^DIO2
- +15 DO FF
- +16 IF $DATA(DCOPIES)
- IF $DATA(DOUT)
- IF $DATA(^DD("OS",DISYS,"SDPEND"))
- DO SDP
- +17 IF $GET(DIOEND)="G M^DIAU"
- GOTO M^DIAU
- IF $GET(DIOEND)="G L^DIDC"
- GOTO L^DIDC
- +18 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
- +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
- +2 ;VistA Close Logic 22*136
- +3 IF $GET(^%ZIS("C"))="G ^%ZISC"
- XECUTE ^%ZIS("C")
- KILL DIOP
- QUIT
- +4 ;Stand Alone Close Logic
- +5 IF $PIECE(IO(0),DIOP)]""
- SET IOP="HOME"
- DO ^%ZIS
- IF POP
- HANG
- SET X=DIOP
- XECUTE ^DD("FUNC",7,1)
- KILL IO(1,IO)
- USE IO(0)
- +6 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