- 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
