Changeset 623 for WorldVistAEHR/trunk/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/_ZIS4.m
- Timestamp:
- Dec 4, 2009, 12:11:15 AM (14 years ago)
- File:
-
- 1 edited
Legend:
- Unmodified
- Added
- Removed
-
WorldVistAEHR/trunk/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/_ZIS4.m
r613 r623 1 %ZIS4 ;ISF/RWF,DW - DEVICE HANDLER SPECIFIC CODE (GT.M for Unix/VMS) ;1/24/08 16:08 2 ;;8.0;KERNEL;**275,425,440**;Jul 10, 1995;Build 13 3 ;Per VHA Directive 2004-038, this routine should not be modified 4 OPEN ;From %ZIS3 for TRM 5 G OPN2:$D(IO(1,IO)) 6 S POP=0 D OP1 G NOPEN:'$D(IO(1,IO)) 7 OPN2 ; 8 I $D(%ZISHP),'$D(IOP) W !,*7," Routing to device "_$P(^%ZIS(1,%E,0),"^",1)_$S($D(^(1)):" "_$P(^(1),"^",1)_" ",1:"") 9 Q 10 NOPEN I %IS'["D",$D(%ZISHP)!(%ZISHG]"") S POP=1 Q 11 I '$D(IOP) W *7," [BUSY]" W " ... RETRY" S %=2,U="^" D YN^%ZIS1 G OPEN:%=1 12 S POP=1 Q 13 Q 14 ;Why no open paraneters??? 15 OP1 N $ET S $ET="G OPNERR^%ZIS4" 16 I $D(%ZISLOCK) L +@%ZISLOCK:5 E S POP=1 Q 17 O IO::%ZISTO S:$T IO(1,IO)="" S:'$T POP=1 18 Q 19 OPNERR ;Open Error 20 S POP=1,IO("LASTERR")=$G(IO("ERROR")),IO("ERROR")=$$EC^%ZOSV,$EC="" 21 Q 22 ; 23 O ;From %ZIS6 for all types. 24 D:%IS["L" ZIO 25 I $D(IO("S")),$D(^%ZIS(2,IO("S"),10)),^(10)]"" U IO(0) D X10^ZISX ;Open Printer Port 26 OPAR I $D(IOP),%ZTYPE="HFS",$D(%IS("HFSIO")),$D(%IS("IOPAR")),%IS("HFSIO")]"" S IO=%IS("HFSIO"),%ZISOPAR=%IS("IOPAR") 27 I %ZTYPE="CHAN" D TCPIP Q:POP G OXECUTE^%ZIS6 28 S %A=%ZISOPAR_$S(%ZISOPAR["):":"",1:":"_%ZISTO) 29 N % S %(IO)="",%=$P($P($NA(%(IO)),"(",2),")") 30 S %A=%_$E(":",%A]"")_%A 31 D O1 I POP D Q 32 .I %ZTYPE="HFS",'$D(IOP),$G(IO("ERROR"))["file not found" W !,?5,*7,"[File Not Found]" Q 33 .W:'$D(IOP) !,?5,*7,"[DEVICE IS BUSY]" Q 34 ;S IO(1,IO)="" U IO S:'(IO=IO(0)&'$D(IO("S"))&'$D(ZTQUEUED)) $X=0,$Y=0 I %ZTYPE["TRM" U IO:(WIDTH=+%Z91) 35 U IO S $X=0,$Y=0 I %ZTYPE["TRM" U IO:(WIDTH=+%Z91) 36 I %ZISUPAR]"" S %A1=""""_IO_""":"_%ZISUPAR U @%A1 37 ;U:%IS'[0 IO(0) 38 G OXECUTE^%ZIS6 39 ; 40 O1 N $ES,$ET S $ET="G OPNERR^%ZIS4" 41 I $D(%ZISLOCK) L +@%ZISLOCK:5 E S POP=1 Q 42 O @%A S:'$T&(%A?.E1":".N) POP=1 S:'POP IO(1,IO)="" 43 S IO("ERROR")="" Q 44 ; 45 ;Need to find out how to get IP address 46 ZIO N %,%1 S (%,%1)=$ZIO 47 I $ZV["VMS",%["_TNA" D 48 . S (%,%1)=$ZGETDVI($I,"TT_ACCPORNAM") 49 . S %=$S(%["Host:":$P($P(%,"Host: ",2)," ")_":"_$P(%,"Port: ",2),1:%) S:%[" " %=$TR(%," ") 50 I $ZV'["VMS" D 51 . S (%,%1)=$ZTRNLNM("REMOTEHOST") S:$L(%) %1="Host:"_% S:'$L(%) %=$ZIO 52 S IO("ZIO")=% S:(%1["Host:")&'$D(IO("IP")) IO("IP")=$P(%,":") 53 Q 54 ; 55 TCPIP ;For TCP/IP devices, should use ^%ZISTCP 56 N %S 57 S %ZISTO=$G(%ZISTO,3) 58 S %A="IO:"_$S($E(%ZISOPAR)="(":"",1:"(")_%ZISOPAR_$S($E(%ZISOPAR,$L(%ZISOPAR))=")":"",1:")")_":%ZISTO:""SOCKET""" 59 ;U $P W !,"%A=",%A 60 O @%A I '$T S POP=1 Q ;D O1 ;Do the open. 61 U IO:(WIDTH=512:NOWRAP:EXCEPT="G OPNERR^%ZIS4") S %S=$KEY 62 U $P ;W !,"$KEY=",%S 63 Q 64 ; 65 SPOOL ;%ZDA=pointer to ^XMB(3.51, %ZFN=spool file name. 66 I $D(ZISDA) W:'$D(IOP) !?5,*7,"You may not Spool the printing of a Spool document" G N 67 I $D(DUZ)[0 W:'$D(IOP) !,"Must be a valid user." G N 68 R S %ZY=-1 D NEWDOC^ZISPL1 G N:%ZY'>0 69 S %ZDA=+%ZY,%ZFN=$P(%ZY(0),U,2),IO("DOC")=$P(%ZY(0),U,1) G OK:$D(IO("Q")) 70 G:'%ZISB OK I '$P(%ZY,"^",3),$L(%ZFN) O %ZFN:(append:nowrap):2 G DOC 71 S %ZFN=IO_"SPOOL_no_"_%ZDA_".TMP" D SPL2 G:%ZFN']"" N S $P(^XMB(3.51,%ZDA,0),U,2)=%ZFN,^XMB(3.51,"C",%ZFN,%ZDA)="" 72 DOC S IO=%ZFN,IO("SPOOL")=%ZDA,^XUTL("XQ",$J,"SPOOL")=%ZDA,IOF="#" 73 I $D(^%ZIS(1,%ZISIOS,1)),$P(^(1),"^",8),$O(^("SPL",0)) S ^XUTL("XQ",$J,"ADSPL")=%ZISIOS,ZISPLAD=%ZISIOS 74 OK K %ZDA,%ZFN Q 75 N K %ZDA,%ZFN,IO("DOC") S POP=1 Q 76 ; 77 SPL2 ;Open for write 78 O %ZFN:(newversion:noreadonly:nowrap:exception="G SPL4"):2 G:$ZA<0 SPL4 S IO(1,%ZFN)="" Q 79 ; 80 SPL3 ;Open for Read 81 O %ZFN:(readonly:exception="G SPL4"):2 S:'$T ZISPLQ=1 G:'$T SPL4 S IO(1,%ZFN)="" Q 82 SPL4 W:'$D(IOP)&'$D(ZTQUEUED) !?5,*7,"Couldn't open the spool file." S %ZFN="" Q 83 ; 84 CLOSE ;Close out the spool 85 N %,%1,%Z1,%ZFN,%ZS,%ZDA,XS,%Y,%X 86 I $L(IO) C IO K IO(1,IO) 87 D FILE^ZISPL1 I %ZDA'>0 K ZISPLAD Q 88 S %ZFN=$P(%ZS,"^",2) D SPL3 Q:%ZFN']"" S %ZCR=$C(13),%Y="" 89 S %Z1=+$G(^XTV(8989.3,1,"SPL")),%=0 90 U %ZFN F R %X#255:5 Q:$ZEOF S %2=%X D CL2 Q:%Z1<% 91 SPLEX C %ZFN:(DELETE) K:%ZFN]"" IO(1,%ZFN) D CLOSE^ZISPL1 K %Y,%X,%1,%ZFN Q 92 ; 93 CL2 S %=%+1 I %Z1<% S ^XMBS(3.519,XS,2,%,0)="*** INCOMPLETE REPORT -- SPOOL DOCUMENT LINE LIMIT EXCEEDED ***",$P(^XMB(3.51,%ZDA,0),"^",11)=1 Q 94 I %2[$C(12) S ^XMBS(3.519,XS,2,%,0)="|TOP|" Q 95 S ^XMBS(3.519,XS,2,%,0)=%2 Q 96 ; 97 HFS G HFS^%ZISF 98 REWMT(IO,IOPAR) ;Rewind Magtape 99 S X="REWERR^%ZIS4",@^%ZOSF("TRAP") 100 U IO W *5 101 Q 1 102 REWSDP(IO,IOPAR) ;Rewind SDP 103 G REW1 104 REWHFS(IO,IOPAR) ;Rewind Host File. 105 REW1 S X="REWERR^%ZIS4",@^%ZOSF("TRAP") 106 U IO:(REWIND) 107 Q 1 108 REWERR ;Error encountered 109 Q 0 1 %ZIS4 ;ISF/RWF,DW - DEVICE HANDLER SPECIFIC CODE (GT.M for Unix/VMS) ;03/07/2007 2 ;;8.0;KERNEL;**275,425**;Jul 10, 1995;Build 18 3 ; 4 OPEN ;From %ZIS3 for TRM 5 G OPN2:$D(IO(1,IO)) 6 S POP=0 D OP1 G NOPEN:'$D(IO(1,IO)) 7 OPN2 ; 8 I $D(%ZISHP),'$D(IOP) W !,*7," Routing to device "_$P(^%ZIS(1,%E,0),"^",1)_$S($D(^(1)):" "_$P(^(1),"^",1)_" ",1:"") 9 Q 10 NOPEN I %IS'["D",$D(%ZISHP)!(%ZISHG]"") S POP=1 Q 11 I '$D(IOP) W *7," [BUSY]" W " ... RETRY" S %=2,U="^" D YN^%ZIS1 G OPEN:%=1 12 S POP=1 Q 13 Q 14 ;Why no open paraneters??? 15 OP1 N $ES,$ET S $ET="G OPNERR^%ZIS4" 16 L:$D(%ZISLOCK) +@%ZISLOCK:60 17 O IO::%ZISTO S:$T IO(1,IO)="" S:'$T POP=1 L:$D(%ZISLOCK) -@%ZISLOCK 18 Q 19 OPNERR ;Open Error 20 S POP=1,IO("LASTERR")=$G(IO("ERROR")),IO("ERROR")=$$EC^%ZOSV,$EC="" Q 21 ; 22 O ;From %ZIS6 for other types. 23 D:%IS["L" ZIO 24 LCKGBL ;Lock Global 25 I %ZTYPE="CHAN" N % S %=$G(^%ZIS(1,+%E,"GBL")) I $L(%) L @("+^"_%_":0") S:'$T POP=1 I POP W:'$D(IOP) !,?5,*7,"[DEVICE IS BUSY]" Q 26 I $D(IO("S")),$D(^%ZIS(2,IO("S"),10)),^(10)]"" U IO(0) D X10^ZISX 27 OPAR I $D(IOP),%ZTYPE="HFS",$D(%IS("HFSIO")),$D(%IS("IOPAR")),%IS("HFSIO")]"" S IO=%IS("HFSIO"),%ZISOPAR=%IS("IOPAR") 28 I %ZTYPE="CHAN" D TCPIP Q:POP G OXECUTE^%ZIS6 29 S %A=%ZISOPAR_$S(%ZISOPAR["):":"",%ZTYPE["CHAN"&($P(%ZTIME,"^",3)="n"):"",1:":"_%ZISTO) 30 N % S %(IO)="",%=$P($P($NA(%(IO)),"(",2),")") 31 S %A=%_$E(":",%A]"")_%A 32 D O1 I POP D Q 33 .I %ZTYPE="HFS",'$D(IOP),$G(IO("ERROR"))["file not found" W !,?5,*7,"[File Not Found]" Q 34 .W:'$D(IOP) !,?5,*7,"[DEVICE IS BUSY]" Q 35 ;S IO(1,IO)="" U IO S:'(IO=IO(0)&'$D(IO("S"))&'$D(ZTQUEUED)) $X=0,$Y=0 I %ZTYPE["TRM" U IO:(WIDTH=+%Z91) 36 U IO S $X=0,$Y=0 I %ZTYPE["TRM" U IO:(WIDTH=+%Z91) 37 I %ZISUPAR]"" S %A1=""""_IO_""":"_%ZISUPAR U @%A1 38 ;U:%IS'[0 IO(0) 39 G OXECUTE^%ZIS6 40 ; 41 O1 N $ES,$ET S $ET="G OPNERR^%ZIS4" 42 L:$D(%ZISLOCK) +@%ZISLOCK:60 43 O @%A S:'$T&(%A?.E1":".N) POP=1 S:'POP IO(1,IO)="" L:$D(%ZISLOCK) -@%ZISLOCK 44 S IO("ERROR")="" Q 45 ; 46 ;Need to find out how to get IP address 47 ZIO N %,%1 S (%,%1)=$ZIO 48 I $ZV["VMS",%["_TNA" D 49 . S (%,%1)=$ZGETDVI($I,"TT_ACCPORNAM") 50 . S %=$S(%["Host:":$P($P(%,"Host: ",2)," ")_":"_$P(%,"Port: ",2),1:%) S:%[" " %=$TR(%," ") 51 I $ZV'["VMS" D 52 . S (%,%1)=$ZTRNLNM("REMOTEHOST") S:$L(%) %1="Host:"_% S:'$L(%) %=$ZIO 53 S IO("ZIO")=% S:(%1["Host:")&'$D(IO("IP")) IO("IP")=$P(%,":") 54 Q 55 ; 56 TCPIP ;For TCP/IP devices 57 N %S 58 S %ZISTO=$G(%ZISTO,3) 59 S %A="IO:"_$S($E(%ZISOPAR)="(":"",1:"(")_%ZISOPAR_$S($E(%ZISOPAR,$L(%ZISOPAR))=")":"",1:")")_":%ZISTO:""SOCKET""" 60 ;U $P W !,"%A=",%A 61 O @%A I '$T S POP=1 Q ;D O1 ;Do the open. 62 U IO:(WIDTH=512:NOWRAP:EXCEPT="G OPNERR^%ZIS4") S %S=$KEY 63 U $P ;W !,"$KEY=",%S 64 Q 65 ; 66 SPOOL ;%ZDA=pointer to ^XMB(3.51, %ZFN=spool file name. 67 I $D(ZISDA) W:'$D(IOP) !?5,*7,"You may not Spool the printing of a Spool document" G N 68 I $D(DUZ)[0 W:'$D(IOP) !,"Must be a valid user." G N 69 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) G OK:$D(IO("Q")) 70 G:'%ZISB OK I '$P(%ZY,"^",3),%ZFN]"" D SPL3 G N:%ZFN']"",DOC 71 S %ZFN=IO_"SPOOL_no_"_%ZDA_".TMP" D SPL2 G:%ZFN']"" N S $P(^XMB(3.51,%ZDA,0),U,2)=%ZFN,^XMB(3.51,"C",%ZFN,%ZDA)="" 72 DOC S IO=%ZFN,IO("SPOOL")=%ZDA,^XUTL("XQ",$J,"SPOOL")=%ZDA,IOF="#" 73 I $D(^%ZIS(1,%ZISIOS,1)),$P(^(1),"^",8),$O(^("SPL",0)) S ^XUTL("XQ",$J,"ADSPL")=%ZISIOS,ZISPLAD=%ZISIOS 74 OK K %ZDA,%ZFN Q 75 N K %ZDA,%ZFN,IO("DOC") S POP=1 Q 76 SPL2 O %ZFN:(NEWVERSION:WORLD=RWD) G:$ZA<0 SPL4 S IO(1,%ZFN)="" Q 77 SPL3 N X S X="SPL4^%ZIS4",@^%ZOSF("TRAP") 78 O %ZFN:READONLY:1 S:'$T ZISPLQ=1 G:$ZA<0!('$T) SPL4 S IO(1,%ZFN)="" Q 79 SPL4 W:'$D(IOP)&'$D(ZTQUEUED) !?5,*7,"Couldn't open the spool file." S %ZFN="" Q 80 CLOSE N %Z1 C:IO]"" IO K:IO]"" IO(1,IO) D FILE^ZISPL1 I %ZDA'>0 K ZISPLAD Q 81 S %ZFN=$P(%ZS,"^",2) D SPL3 Q:%ZFN']"" U %ZFN S %ZCR=$C(13),%Y="",X="SPLEOF^%ZIS4",@^%ZOSF("TRAP") 82 S %Z1=+$G(^XTV(8989.3,1,"SPL")) 83 F %=0:0 R %X#255:5 Q:$ZA<0 S %2=%X D CL2 G:%Z1<% SPLEX 84 SPLEOF I $ZE'["ENDO" Q ;Send error up 85 SPLEX C %ZFN:(DELETE) K:%ZFN]"" IO(1,%ZFN) D CLOSE^ZISPL1 K %Y,%X,%1,%ZFN Q 86 ; 87 CL2 S %=%+1 I %Z1<% S ^XMBS(3.519,XS,2,%,0)="*** INCOMPLETE REPORT -- SPOOL DOCUMENT LINE LIMIT EXCEEDED ***",$P(^XMB(3.51,%ZDA,0),"^",11)=1 Q 88 I %2[$C(12) S ^XMBS(3.519,XS,2,%,0)="|TOP|" Q 89 S ^XMBS(3.519,XS,2,%,0)=%2 Q 90 ; 91 HFS G HFS^%ZISF 92 REWMT(IO,IOPAR) ;Rewind Magtape 93 S X="REWERR^%ZIS4",@^%ZOSF("TRAP") 94 U IO W *5 95 Q 1 96 REWSDP(IO,IOPAR) ;Rewind SDP 97 G REW1 98 REWHFS(IO,IOPAR) ;Rewind Host File. 99 REW1 S X="REWERR^%ZIS4",@^%ZOSF("TRAP") 100 U IO:(REWIND) 101 Q 1 102 REWERR ;Error encountered 103 Q 0
Note:
See TracChangeset
for help on using the changeset viewer.