cABIEMSD ; Export/Import SET DEVICE FOR OUTPUT ;%ABIE; [ 02/06/01  11:44 AM ]
 ;
 S $ZT="ERR^%ABIEMSD" N INTSDEV
OUT ;NEW (%DEV,%DEVDLM,%DEVMODE,%DEVNMOD,%DEVTYPE,%DEVVTYP,%DEVOARG,QUIT,%FN,%KANJIN,%KANJOUT,%HSPLLP,%devmode)
 S %IO=" output ",%IN=0 G DFLT
IN ;NEW (%DEV,%DEVDLM,%DEVMODE,%DEVNMOD,%DEVTYPE,%DEVVTYP,%DEVOARG,QUIT,%FN,%KANJIN,%KANJOUT,%devmode)
 S %IO=" input ",%IN=1
DFLT S %T=$G(%DEVVTYP)
 I %T'="" S %DFLT=$P(%T,";"),%DFLT=$S(%DFLT="TRM":$I,%DFLT="MTD":"MTD",%DFLT="SBP":"SBP",1:"HFS")
 E  S %DFLT="HFS"
START K QUIT S $ZT="ERR^%ABIEMSD"
P1 ;
 S %T="(%DEV=1)!(%DEV>2&(%DEV<20))!(%DEV>63&(%DEV<200))!(%DEV>255)^(%DEV'<51&(%DEV'>54))^(%DEV'<47&(%DEV'>50))^(%DEV=55)^(%DEV'<59&(%DEV'>62))",%A=$G(%DEVVTYP),%RANGE=""
 I %A="" S %RANGE=$TR(%T,"^","!")
 E  F %I=1:1:$L(%A,";") S %B=$P(%A,";",%I),%RANGE=%RANGE_$S(%RANGE'="":"!",1:"")_$P(%T,"^",$S(%B="TRM":1,%B="HFS":2,%B="MTD":3,%B="HOSTSPOOL":4,1:5))
 ;W !!,"Enter",%IO,"device <",%DFLT,">: " R %DEV
 S %DEV="" S:%DEV="" %DEV=$S(%DFLT="":"?",1:%DFLT) S:%DEV=0 %DEV=$I
 I $E(%DEV,1,$L(%DEV))=$E("HFS",1,$L(%DEV)) S %DEV=51
 I @("'("_%RANGE_")") W *7,!!,"Invalid port number." G P1
 G NONSBP:%DEV<59!(%DEV>62) C %DEV
QUIT ;
 S QUIT=""
EXIT ;
 U 0 Q
NONSBP ;
 I %DEV<51!(%DEV>54) G NONHFS
 S %DEVTYPE="HFS" G HFS1:'$D(%DEVNMOD)
 D GETHFS G:%DEV EXIT
 W !,"All Host File Server (HFS) devices are busy." S QUIT=1 G EXIT
HFS1 G HFSVM^%SDEV1:$ZB($V(0,-4,2),#F,1)=0
 S %FN=TRFIL
 I $ZB($V(0,-4,2),#F,1)=8 S %DS=$TR(%FN,"ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789!#$%&'()-./:@[\]^_`~") I %DS'="" W *7,"   ...Invalid character: ",%DS,! G HFS1
 I $ZB($V(0,-4,2),#F,1)=3 S %DS=$TR(%FN,"ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789!-.@%{}:_[],/") I %DS'="" W *7,"   ...Invalid character: ",%DS,! G HFS1
 D GETHFS I '%DEV U 0 W !!,"All Host File Server (HFS) devices are busy" G P1
 G:%IN OPENHFS
 O %DEV:%FN U %DEV G:$ZA OPENHFS C %DEV
HFS2 I 'quiet U 0 R !,"File exists.  Do you want to overwrite it? <NO> ",X
 I quiet S X="YES"
 G:X="" QUIT D yn G HFS2:QF=1,EXIT:QF=2,HFS1:'X
OPENHFS ;
 S %DEVOARG="%DEV:(%FN:"_$S(%IN:"""R""",1:"""W""")_$S('$D(%DEVDLM):"",1:"::::%DEVDLM")_")"
 O @%DEVOARG
 U %DEV S %ZA=$ZA U 0 I %ZA<0 W !,?5,"Open Failed on Device ",%DEV," for file ",%FN,*7 C %DEV S QUIT=1
 G EXIT
ERR ;
 I $E($ZE,1,3)="<DK" C:%DEV'=0&(%DEV'=$I) %DEV
 I $F($ZE,"<NODEV>") U 0 W !,"Device not available" G START
 I $F($ZE,"<INTERRUPT>") ZQ:$D(INTSDEV) 1 U 0 W !!,"...Aborted." S QUIT=1,$EC="" Q
 ZQ 1
DIR NEW (%X) G CALL^%SDEV2
GETHFS ;Search for unused HFS device. Return %DEV
 F %DEV=51:1:54 I '$$INUSE(%DEV) O %DEV::0 I $T Q
 E  S %DEV=0
 Q
INUSE(DEV,J) ; Is HFS device already in use by job J?
 S $ZT="INUSERR"
 V 44:$J:$ZB($V(44,$J,2),#1,7):2 ; not preemptible
 ; returns 0 if not in use, or DDB address of first inuse hfs ctrl blk
 NEW DDB S:'$D(J) J=$J S J=J-$V(272,-4,4)
 S DDB=$V(4*DEV+$V(7,-5),-3,0)
 F  S DDB=$V(DDB+12,-3,0) Q:'DDB  Q:J=$V(DDB+16,-3,2)
 V 44:$J:$ZB($V(44,$J,2),#1,2):2 ; no-preempt flag off
 Q DDB
INUSERR V 44:$J:$ZB($V(44,$J,2),#1,2):2 ZQ 1
INT ;
 N INTSDEV S INTSDEV=0 G OUT
yn ;
 d yn^%msc
 q