CIAUHFS ;MSC/IND/DKM - Host IO Support ;04-May-2006 08:19;DKM
;;1.2;CIA UTILITIES;;Mar 20, 2007
;;Copyright 2000-2006, Medsphere Systems Corporation
;=================================================================
; Capture output to HFS and optionally redirect to global
; EXEC = Code to execute
; ROOT = Global root to receive output (or null to leave in HFS)
; RM = Right margin setting (defaults to 80)
CAPTURE(EXEC,ROOT,RM) ;EP
N UFN,HNDL,TMP,IOM,IOSL,IOST,IOF,IOT,IOS,$ET
S $ET="",UFN=$$UFN^CIAU,TMP=$$DEFDIR^CIAUOS,HNDL="CIAUHFS",@$$TRAP^CIAUOS("ERR^CIAUHFS")
S:$L($G(ROOT)) ROOT=$NA(@ROOT)
D OPEN^%ZISH(HNDL,TMP,UFN,"W")
D:'POP IOVAR(.RM),EXEC,HFSCLOSE(HNDL,UFN)
Q:$Q TMP_UFN
Q
EXEC X EXEC
Q
; Error trap
ERR D @^%ZOSF("ERRTN"),HFSCLOSE(HNDL,UFN,1)
Q:$Q ""
Q
; Setup IO variables based on IO Device
IOVAR(XIOM,XIO,XIOSL,XIOST,XIOF,XIOT) ;
N X
S ION=$G(XIO,"CIAU HFS DEVICE"),IOS=+$O(^%ZIS(1,"B",ION,0)),IOM=80,IOSL=62,IOST=$G(XIOST,"P-OTHER"),IOF=$G(XIOF,""""""),IOT=$G(XIOT,"HFS")
S:$D(^%ZIS(1,IOS,0)) IOST(0)=+$G(^("SUBTYPE")),IOT=$G(^("TYPE"),IOT),IOST=$P($G(^%ZIS(2,IOST(0),0),IOST),U)
S X=$O(^%ZIS(2,"B",IOST,0))
S:X IOST(0)=X,X=$G(^%ZIS(2,X,1)),IOM=$P(X,U),IOF=$P(X,U,2),IOSL=$P(X,U,3)
S:$G(XIOM) IOM=XIOM
S:$G(XIOSL) IOSL=XIOSL
U IO
Q
; Move HFS data to global (if ROOT specified) and cleanup
HFSCLOSE(HNDL,UFN,BAD) ;
N DEL
D GETDEV^%ZISUTL(HNDL)
I IOT="HFS" D
.D CLOSE^%ZISH(HNDL)
E D RMDEV^%ZISUTL(HNDL)
Q:'$L($G(ROOT))
K @ROOT
I '$G(BAD),$$FTG^%ZISH($$DEFDIR^CIAUOS,UFN,$NA(@ROOT@(1)),$QL(ROOT)+1) D STRIP
S DEL(UFN)=""
I $$DEL^%ZISH($$DEFDIR^CIAUOS,"DEL")
Q
; Strip off control chars and remove leading/trailing blank lines
STRIP N I,J,K,X
S (I,J)=0
F S I=$O(@ROOT@(I)) Q:'I S X=@ROOT@(I) D S @ROOT@(I)=X
.I X[$C(8),$L(X,$C(8))=$L(X,$C(95)) S X=$TR(X,$C(7,8,12,95))
.E S X=$TR(X,$C(7,8,12))
.S:$L(X) J=I,K=$G(K,J)
I $D(K) F S I=$O(@ROOT@(I)) Q:I=K K @ROOT@(I)
F S J=$O(@ROOT@(J)) Q:'J K @ROOT@(J)
Q
CIAUHFS ;MSC/IND/DKM - Host IO Support ;04-May-2006 08:19;DKM
+1 ;;1.2;CIA UTILITIES;;Mar 20, 2007
+2 ;;Copyright 2000-2006, Medsphere Systems Corporation
+3 ;=================================================================
+4 ; Capture output to HFS and optionally redirect to global
+5 ; EXEC = Code to execute
+6 ; ROOT = Global root to receive output (or null to leave in HFS)
+7 ; RM = Right margin setting (defaults to 80)
CAPTURE(EXEC,ROOT,RM) ;EP
+1 NEW UFN,HNDL,TMP,IOM,IOSL,IOST,IOF,IOT,IOS,$ETRAP
+2 SET $ETRAP=""
SET UFN=$$UFN^CIAU
SET TMP=$$DEFDIR^CIAUOS
SET HNDL="CIAUHFS"
SET @$$TRAP^CIAUOS("ERR^CIAUHFS")
+3 IF $LENGTH($GET(ROOT))
SET ROOT=$NAME(@ROOT)
+4 DO OPEN^%ZISH(HNDL,TMP,UFN,"W")
+5 IF 'POP
DO IOVAR(.RM)
DO EXEC
DO HFSCLOSE(HNDL,UFN)
+6 IF $QUIT
QUIT TMP_UFN
+7 QUIT
EXEC XECUTE EXEC
+1 QUIT
+2 ; Error trap
ERR DO @^%ZOSF("ERRTN")
DO HFSCLOSE(HNDL,UFN,1)
+1 IF $QUIT
QUIT ""
+2 QUIT
+3 ; Setup IO variables based on IO Device
IOVAR(XIOM,XIO,XIOSL,XIOST,XIOF,XIOT) ;
+1 NEW X
+2 SET ION=$GET(XIO,"CIAU HFS DEVICE")
SET IOS=+$ORDER(^%ZIS(1,"B",ION,0))
SET IOM=80
SET IOSL=62
SET IOST=$GET(XIOST,"P-OTHER")
SET IOF=$GET(XIOF,"""""")
SET IOT=$GET(XIOT,"HFS")
+3 IF $DATA(^%ZIS(1,IOS,0))
SET IOST(0)=+$GET(^("SUBTYPE"))
SET IOT=$GET(^("TYPE"),IOT)
SET IOST=$PIECE($GET(^%ZIS(2,IOST(0),0),IOST),U)
+4 SET X=$ORDER(^%ZIS(2,"B",IOST,0))
+5 IF X
SET IOST(0)=X
SET X=$GET(^%ZIS(2,X,1))
SET IOM=$PIECE(X,U)
SET IOF=$PIECE(X,U,2)
SET IOSL=$PIECE(X,U,3)
+6 IF $GET(XIOM)
SET IOM=XIOM
+7 IF $GET(XIOSL)
SET IOSL=XIOSL
+8 USE IO
+9 QUIT
+10 ; Move HFS data to global (if ROOT specified) and cleanup
HFSCLOSE(HNDL,UFN,BAD) ;
+1 NEW DEL
+2 DO GETDEV^%ZISUTL(HNDL)
+3 IF IOT="HFS"
Begin DoDot:1
+4 DO CLOSE^%ZISH(HNDL)
End DoDot:1
+5 IF '$TEST
DO RMDEV^%ZISUTL(HNDL)
+6 IF '$LENGTH($GET(ROOT))
QUIT
+7 KILL @ROOT
+8 IF '$GET(BAD)
IF $$FTG^%ZISH($$DEFDIR^CIAUOS,UFN,$NAME(@ROOT@(1)),$QLENGTH(ROOT)+1)
DO STRIP
+9 SET DEL(UFN)=""
+10 IF $$DEL^%ZISH($$DEFDIR^CIAUOS,"DEL")
+11 QUIT
+12 ; Strip off control chars and remove leading/trailing blank lines
STRIP NEW I,J,K,X
+1 SET (I,J)=0
+2 FOR
SET I=$ORDER(@ROOT@(I))
IF 'I
QUIT
SET X=@ROOT@(I)
Begin DoDot:1
+3 IF X[$CHAR(8)
IF $LENGTH(X,$CHAR(8))=$LENGTH(X,$CHAR(95))
SET X=$TRANSLATE(X,$CHAR(7,8,12,95))
+4 IF '$TEST
SET X=$TRANSLATE(X,$CHAR(7,8,12))
+5 IF $LENGTH(X)
SET J=I
SET K=$GET(K,J)
End DoDot:1
SET @ROOT@(I)=X
+6 IF $DATA(K)
FOR
SET I=$ORDER(@ROOT@(I))
IF I=K
QUIT
KILL @ROOT@(I)
+7 FOR
SET J=$ORDER(@ROOT@(J))
IF 'J
QUIT
KILL @ROOT@(J)
+8 QUIT
