- %ZIS4 ;SF/GFT,RWF,MVB - DEVICE HANDLER SPOOL SPECIFIC CODE(MSM) ;02/11/97 11:02 [ 04/02/2003 8:29 AM ]
- ;;8.0;KERNEL;**1001,1002,1003,1004,1005,1007**;APR 1, 2003
- ;;8.0;KERNEL;**23,36,49,59**;JUL 03, 1995
- ;THIS ROUTINE CONTAINS AN IHS MODIFICATION BY IHS/HQW/JLB 2/16/99
- ;
- OPEN G OPN2:$D(IO(1,IO))
- S POP=0 D OP1 S:'POP IO(1,IO)="" G NOPEN:'$D(IO(1,IO))
- OPN2 I $D(%ZISHP),'$D(IOP) W !,*7," Routing to device "_$P(^%ZIS(1,%E,0),"^",1)_$S($D(^(1)):" "_$P(^(1),"^",1)_" ",1:"")
- Q
- NOPEN I %IS'["D",$D(%ZISHP)!(%ZISHG]"") S POP=1 Q
- I '$D(IOP) W *7," [BUSY]" W " ... RETRY" S %=2,U="^" D YN^%ZIS1 G OPEN:%=1
- S POP=1 Q
- Q
- OP1 N X S X="OPNERR^%ZIS4",@^%ZOSF("TRAP")
- L:$D(%ZISLOCK) +@%ZISLOCK:60
- O IO::%ZISTO S:'$T POP=1 L:$D(%ZISLOCK) -@%ZISLOCK Q
- OPNERR S POP=1,IO("ERROR")=$ZE,IO("LASTERR")=$ZE Q
- ;
- O I $P($ZV,"Version ",2)'<3 D:%IS["L" ZIO
- ;D:$D(%ZISIOS) ZISLPC^%ZIS Q:'%ZISB ;No longer called in Kernel v8.
- OPRTPORT I $D(IO("S")),$D(^%ZIS(2,IO("S"),10)),^(10)]"" U IO(0) D X10^ZISX
- OPAR I $D(IOP),%ZTYPE="HFS",$D(%IS("HFSIO")),$D(%IS("IOPAR")),%IS("HFSIO")]"" S IO=%IS("HFSIO"),%ZISOPAR=%IS("IOPAR")
- S %A=$S(%ZISOPAR]"":%ZISOPAR,%ZTYPE["TRM":+%Z91,1:"")
- S %A=%A_$S(%A["):":"",%ZTYPE["OTH"&($P(%ZTIME,"^",3)="n"):"",1:":"_%ZISTO),%A=""""_IO_""""_$E(":",%A]"")_%A
- D O1 I POP W:'$D(IOP) !,?5,*7,"[DEVICE IS BUSY]" Q
- S IO(1,IO)=""
- I %ZTYPE="HFS" D Q:POP
- .N % S %=$I
- .U IO S:$ZA<0 POP=1
- .U:'$D(ZTQUEUED) % I POP C:IO]"" IO K:IO]"" IO(1,IO)
- .I POP,'$D(IOP),'$D(ZTQUEUED) W !,?5,*7,"[FILE NOT FOUND]" Q
- N DX,DY S (DX,DY)=0
- U IO X:$D(^%ZOSF("XY"))&'(IO=IO(0)&'$D(ZTQUEUED)&'$D(IO("S"))) ^("XY")
- I %ZISUPAR]"" S %A1=""""_IO_""":"_%ZISUPAR U @%A1
- U:%IS'[0 IO(0)
- G OXECUTE^%ZIS6
- ;
- O1 N X S X="OPNERR^%ZIS4",@^%ZOSF("TRAP")
- L:$D(%ZISLOCK) +@%ZISLOCK:60
- O @%A S:'$T&(%A?.E1":".N) POP=1 L:$D(%ZISLOCK) -@%ZISLOCK
- S IO("ERROR")="" Q
- ;
- ZIO N % S (IO("ZIO"),%)=$ZDEV($I),%=$S(%?1.3N1P.E:$TR(%,"~",":"),1:%)
- S:(%?1.3N1P1.3N1P.E)&'$D(IO("IP")) IO("IP")=$TR(%,"~",":") S:(%?1A.ANP1"~"1.4N)&'$D(IO("CLNM")) IO("CLNM")=$TR($$LOW^%ZIS1(%),"~",":")
- Q
- ;
- SPOOL ;%ZDA=pointer to ^XMB(3.51, %ZFN=spool file name.
- I $D(ZISDA) W:'$D(IOP) !?5,*7,"You may not Spool the printing of a Spool document" G N
- I $D(DUZ)[0 W:'$D(IOP) !,"Must be a valid user." G N
- S ZOSFV=($P($ZV,"Version ",2)'<2)
- R S %ZY=-1 D NEWDOC^ZISPL1 G N:%ZY'>0 S %ZDA=+%ZY,%ZFN=$P(%ZY(0),U,2),IO("DOC")=$P(%ZY(0),U,1) I '%ZISB!$D(IO("Q")) S:'ZOSFV IO=51 G OK
- I '$P(%ZY,"^",3),%ZFN D SPL3 G N:'%ZFN,DOC
- S %ZFN=-1 D SPL2 G:%ZFN<0 N S $P(^XMB(3.51,%ZDA,0),U,2)=%ZFN,^XMB(3.51,"C",%ZFN,%ZDA)=""
- DOC S IO("SPOOL")=%ZDA,^XUTL("XQ",$J,"SPOOL")=%ZDA,IOF="#"
- I $D(^%ZIS(1,%ZISIOS,1)),$P(^(1),"^",8),$O(^("SPL",0)) S ^XUTL("XQ",$J,"ADSPL")=%ZISIOS,ZISPLAD=%ZISIOS
- OK K %ZDA,%ZFN Q
- N K %ZDA,%ZFN,IO("DOC") S POP=1 Q
- ;
- SPL2 O 2:1 G SPL5:$ZA<0,SPL5:$ZC S %ZFN=$ZA#256 S IO(1,2)="",IO(1,2,"%ZFN")=%ZFN Q
- ;
- SPL3 Q:$D(IO(1,2))#2 O 2:%ZFN+256 G:$ZA<0 SPL5:$ZA<0,SPL5:$ZC S IO(1,2)="",IO(1,2,"%ZFN")=%ZFN Q
- SPL4 E G SPL5
- ;U IO S %ZA=$ZA U:%IS'[0 IO(0) I %ZA<0 G SPL5
- Q
- SPL5 W:'$D(IOP)&'$D(ZTQUEUED) !?5,*7,"Couldn't open the spool file." S %ZFN=-1 Q
- ;
- CLOSE N %Z1 S ZOSFV=($P($ZV,"Version ",2)'<2)
- C 2 K IO(1,2)
- D FILE^ZISPL1 I %ZDA'>0 K ZISPLAD Q
- S %Z1=+$G(^XTV(8989.3,1,"SPL"))
- S IO=2,%ZFN=$P(%ZS,"^",2) D SPL3 Q:%ZFN'>0 U IO S %ZCR=$C(13),%Y=""
- G V2CL1^%ZOSV
- Q ;Send error up
- CL2 I %Z1<(%+1) S %=%+1,^XMBS(3.519,XS,2,%,0)="*** INCOMPLETE REPORT -- SPOOL DOCUMENT LINE LIMIT EXCEEDED ***",$P(^XMB(3.51,%ZDA,0),"^",11)=1 Q
- I %2[$C(12) S %=%+1,^XMBS(3.519,XMZ,2,%,0)="|TOP|"
- S %=%+1,^XMBS(3.519,XMZ,2,%,0)=%2 Q
- ;
- HFS G HFS^%ZISF
- REWMT(IO,IOPAR) ;Rewind Magtape
- S X="REWERR^%ZIS4",@^%ZOSF("TRAP")
- U IO W *5
- Q 1
- REWSDP(IO,IOPAR) ;Rewind Sequential Block Processor
- S X="REWERR^%ZIS4",@^%ZOSF("TRAP")
- U IO:IOPAR
- Q 1
- REWHFS(IO,IOPAR) ;Rewind Host File.
- REW1 S X="REWERR^%ZIS4",@^%ZOSF("TRAP")
- ; IHS/HQW/JLB 2/16/99 As of MSM 4.4 the original line from VA works
- ;N FILENAME ;IHS/ANMC/FBD-2/19/97-ADDED LINE-SUPPORT FOR ADDITION 2 LINES BELOW IHS/HQW/JLB 2/16/99 uncomment for MSM 4.3 and below
- U IO:(::0) ;IHS/ANMC/FBD-2/19/97-ORIGINAL LINE-COMMENTED OUT IHS/HQW/JLB 2/16/99 comment out for MSM 4.3 and below
- ;U IO I $$^%FINDFN(.FILENAME) C IO O IO:(FILENAME:"M") ;IHS/ANMC/FBD-2/ LINE-WORKAROUND TO MSM NO-REWIND PROBLEM IHS/HQW/JLB uncomment for MSM 4.3 and below
- Q 1
- REWERR ;Error encountered.
- Q 0
- %ZIS4 ;SF/GFT,RWF,MVB - DEVICE HANDLER SPOOL SPECIFIC CODE(MSM) ;02/11/97 11:02 [ 04/02/2003 8:29 AM ]
- +1 ;;8.0;KERNEL;**1001,1002,1003,1004,1005,1007**;APR 1, 2003
- +2 ;;8.0;KERNEL;**23,36,49,59**;JUL 03, 1995
- +3 ;THIS ROUTINE CONTAINS AN IHS MODIFICATION BY IHS/HQW/JLB 2/16/99
- +4 ;
- OPEN IF $DATA(IO(1,IO))
- GOTO OPN2
- +1 SET POP=0
- DO OP1
- IF 'POP
- SET IO(1,IO)=""
- IF '$DATA(IO(1,IO))
- GOTO NOPEN
- OPN2 IF $DATA(%ZISHP)
- IF '$DATA(IOP)
- WRITE !,*7," Routing to device "_$PIECE(^%ZIS(1,%E,0),"^",1)_$SELECT($DATA(^(1)):" "_$PIECE(^(1),"^",1)_" ",1:"")
- +1 QUIT
- NOPEN IF %IS'["D"
- IF $DATA(%ZISHP)!(%ZISHG]"")
- SET POP=1
- QUIT
- +1 IF '$DATA(IOP)
- WRITE *7," [BUSY]"
- WRITE " ... RETRY"
- SET %=2
- SET U="^"
- DO YN^%ZIS1
- IF %=1
- GOTO OPEN
- +2 SET POP=1
- QUIT
- +3 QUIT
- OP1 NEW X
- SET X="OPNERR^%ZIS4"
- SET @^%ZOSF("TRAP")
- +1 IF $DATA(%ZISLOCK)
- LOCK +@%ZISLOCK:60
- +2 OPEN IO::%ZISTO
- IF '$TEST
- SET POP=1
- IF $DATA(%ZISLOCK)
- LOCK -@%ZISLOCK
- QUIT
- OPNERR SET POP=1
- SET IO("ERROR")=$ZE
- SET IO("LASTERR")=$ZE
- QUIT
- +1 ;
- O IF $PIECE($ZV,"Version ",2)'<3
- IF %IS["L"
- DO ZIO
- +1 ;D:$D(%ZISIOS) ZISLPC^%ZIS Q:'%ZISB ;No longer called in Kernel v8.
- OPRTPORT IF $DATA(IO("S"))
- IF $DATA(^%ZIS(2,IO("S"),10))
- IF ^(10)]""
- USE IO(0)
- DO X10^ZISX
- OPAR IF $DATA(IOP)
- IF %ZTYPE="HFS"
- IF $DATA(%IS("HFSIO"))
- IF $DATA(%IS("IOPAR"))
- IF %IS("HFSIO")]""
- SET IO=%IS("HFSIO")
- SET %ZISOPAR=%IS("IOPAR")
- +1 SET %A=$SELECT(%ZISOPAR]"":%ZISOPAR,%ZTYPE["TRM":+%Z91,1:"")
- +2 SET %A=%A_$SELECT(%A["):":"",%ZTYPE["OTH"&($PIECE(%ZTIME,"^",3)="n"):"",1:":"_%ZISTO)
- SET %A=""""_IO_""""_$EXTRACT(":",%A]"")_%A
- +3 DO O1
- IF POP
- IF '$DATA(IOP)
- WRITE !,?5,*7,"[DEVICE IS BUSY]"
- QUIT
- +4 SET IO(1,IO)=""
- +5 IF %ZTYPE="HFS"
- Begin DoDot:1
- +6 NEW %
- SET %=$IO
- +7 USE IO
- IF $ZA<0
- SET POP=1
- +8 IF '$DATA(ZTQUEUED)
- USE %
- IF POP
- IF IO]""
- CLOSE IO
- IF IO]""
- KILL IO(1,IO)
- +9 IF POP
- IF '$DATA(IOP)
- IF '$DATA(ZTQUEUED)
- WRITE !,?5,*7,"[FILE NOT FOUND]"
- QUIT
- End DoDot:1
- IF POP
- QUIT
- +10 NEW DX,DY
- SET (DX,DY)=0
- +11 USE IO
- IF $DATA(^%ZOSF("XY"))&'(IO=IO(0)&'$DATA(ZTQUEUED)&'$DATA(IO("S")))
- XECUTE ^("XY")
- +12 IF %ZISUPAR]""
- SET %A1=""""_IO_""":"_%ZISUPAR
- USE @%A1
- +13 IF %IS'[0
- USE IO(0)
- +14 GOTO OXECUTE^%ZIS6
- +15 ;
- O1 NEW X
- SET X="OPNERR^%ZIS4"
- SET @^%ZOSF("TRAP")
- +1 IF $DATA(%ZISLOCK)
- LOCK +@%ZISLOCK:60
- +2 OPEN @%A
- IF '$TEST&(%A?.E1"
- SET POP=1
- IF $DATA(%ZISLOCK)
- LOCK -@%ZISLOCK
- +3 SET IO("ERROR")=""
- QUIT
- +4 ;
- ZIO NEW %
- SET (IO("ZIO"),%)=$ZDEV($IO)
- SET %=$SELECT(%?1.3N1P.E:$TRANSLATE(%,"~",":"),1:%)
- +1 IF (%?1.3N1P1.3N1P.E)&'$DATA(IO("IP"))
- SET IO("IP")=$TRANSLATE(%,"~",":")
- IF (%?1A.ANP1"~"1.4N)&'$DATA(IO("CLNM"))
- SET IO("CLNM")=$TRANSLATE($$LOW^%ZIS1(%),"~",":")
- +2 QUIT
- +3 ;
- SPOOL ;%ZDA=pointer to ^XMB(3.51, %ZFN=spool file name.
- +1 IF $DATA(ZISDA)
- IF '$DATA(IOP)
- WRITE !?5,*7,"You may not Spool the printing of a Spool document"
- GOTO N
- +2 IF $DATA(DUZ)[0
- IF '$DATA(IOP)
- WRITE !,"Must be a valid user."
- GOTO N
- +3 SET ZOSFV=($PIECE($ZV,"Version ",2)'<2)
- R SET %ZY=-1
- DO NEWDOC^ZISPL1
- IF %ZY'>0
- GOTO N
- SET %ZDA=+%ZY
- SET %ZFN=$PIECE(%ZY(0),U,2)
- SET IO("DOC")=$PIECE(%ZY(0),U,1)
- IF '%ZISB!$DATA(IO("Q"))
- IF 'ZOSFV
- SET IO=51
- GOTO OK
- +1 IF '$PIECE(%ZY,"^",3)
- IF %ZFN
- DO SPL3
- IF '%ZFN
- GOTO N
- GOTO DOC
- +2 SET %ZFN=-1
- DO SPL2
- IF %ZFN<0
- GOTO N
- SET $PIECE(^XMB(3.51,%ZDA,0),U,2)=%ZFN
- SET ^XMB(3.51,"C",%ZFN,%ZDA)=""
- DOC SET IO("SPOOL")=%ZDA
- SET ^XUTL("XQ",$JOB,"SPOOL")=%ZDA
- SET IOF="#"
- +1 IF $DATA(^%ZIS(1,%ZISIOS,1))
- IF $PIECE(^(1),"^",8)
- IF $ORDER(^("SPL",0))
- SET ^XUTL("XQ",$JOB,"ADSPL")=%ZISIOS
- SET ZISPLAD=%ZISIOS
- OK KILL %ZDA,%ZFN
- QUIT
- N KILL %ZDA,%ZFN,IO("DOC")
- SET POP=1
- QUIT
- +1 ;
- SPL2 OPEN 2:1
- IF $ZA<0
- GOTO SPL5
- IF $ZC
- GOTO SPL5
- SET %ZFN=$ZA#256
- SET IO(1,2)=""
- SET IO(1,2,"%ZFN")=%ZFN
- QUIT
- +1 ;
- SPL3 IF $DATA(IO(1,2))#2
- QUIT
- OPEN 2:%ZFN+256
- IF $ZA<0
- IF $ZA<0
- GOTO SPL5
- IF $ZC
- GOTO SPL5
- SET IO(1,2)=""
- SET IO(1,2,"%ZFN")=%ZFN
- QUIT
- SPL4 IF '$TEST
- GOTO SPL5
- +1 ;U IO S %ZA=$ZA U:%IS'[0 IO(0) I %ZA<0 G SPL5
- +2 QUIT
- SPL5 IF '$DATA(IOP)&'$DATA(ZTQUEUED)
- WRITE !?5,*7,"Couldn't open the spool file."
- SET %ZFN=-1
- QUIT
- +1 ;
- CLOSE NEW %Z1
- SET ZOSFV=($PIECE($ZV,"Version ",2)'<2)
- +1 CLOSE 2
- KILL IO(1,2)
- +2 DO FILE^ZISPL1
- IF %ZDA'>0
- KILL ZISPLAD
- QUIT
- +3 SET %Z1=+$GET(^XTV(8989.3,1,"SPL"))
- +4 SET IO=2
- SET %ZFN=$PIECE(%ZS,"^",2)
- DO SPL3
- IF %ZFN'>0
- QUIT
- USE IO
- SET %ZCR=$CHAR(13)
- SET %Y=""
- +5 GOTO V2CL1^%ZOSV
- +6 ;Send error up
- QUIT
- CL2 IF %Z1<(%+1)
- SET %=%+1
- SET ^XMBS(3.519,XS,2,%,0)="*** INCOMPLETE REPORT -- SPOOL DOCUMENT LINE LIMIT EXCEEDED ***"
- SET $PIECE(^XMB(3.51,%ZDA,0),"^",11)=1
- QUIT
- +1 IF %2[$CHAR(12)
- SET %=%+1
- SET ^XMBS(3.519,XMZ,2,%,0)="|TOP|"
- +2 SET %=%+1
- SET ^XMBS(3.519,XMZ,2,%,0)=%2
- QUIT
- +3 ;
- HFS GOTO HFS^%ZISF
- REWMT(IO,IOPAR) ;Rewind Magtape
- +1 SET X="REWERR^%ZIS4"
- SET @^%ZOSF("TRAP")
- +2 USE IO
- WRITE *5
- +3 QUIT 1
- REWSDP(IO,IOPAR) ;Rewind Sequential Block Processor
- +1 SET X="REWERR^%ZIS4"
- SET @^%ZOSF("TRAP")
- +2 USE IO:IOPAR
- +3 QUIT 1
- REWHFS(IO,IOPAR) ;Rewind Host File.
- REW1 SET X="REWERR^%ZIS4"
- SET @^%ZOSF("TRAP")
- +1 ; IHS/HQW/JLB 2/16/99 As of MSM 4.4 the original line from VA works
- +2 ;N FILENAME ;IHS/ANMC/FBD-2/19/97-ADDED LINE-SUPPORT FOR ADDITION 2 LINES BELOW IHS/HQW/JLB 2/16/99 uncomment for MSM 4.3 and below
- +3 ;IHS/ANMC/FBD-2/19/97-ORIGINAL LINE-COMMENTED OUT IHS/HQW/JLB 2/16/99 comment out for MSM 4.3 and below
- USE IO:(::0)
- +4 ;U IO I $$^%FINDFN(.FILENAME) C IO O IO:(FILENAME:"M") ;IHS/ANMC/FBD-2/ LINE-WORKAROUND TO MSM NO-REWIND PROBLEM IHS/HQW/JLB uncomment for MSM 4.3 and below
- +5 QUIT 1
- REWERR ;Error encountered.
- +1 QUIT 0
