- CIANBASY ;MSC/IND/DKM - Asynchronous RPC calls ;29-Jun-2012 15:50;PLS
- ;;1.1;CIA NETWORK COMPONENTS;**001007,001009**;Sep 18, 2007
- ;;Copyright 2000-2012, Medsphere Systems Corporation
- ;=================================================================
- ; Background task for executing an asynchronous RPC
- TASK N CIAD,TGT,$ET,$ES
- S $ET="D ERROR^CIANBASY",ZTREQ="@"
- K ^XTMP("CIA",CIA("UID"),"T",ZTSK)
- Q:$$S^%ZTLOAD
- S ^XTMP("CIA",CIA("UID"),"T",ZTSK)=0,TGT=$NA(^(ZTSK,0))
- S:XWBPTYPE=4 CIAD=TGT
- D DORPC^CIANBACT
- I XWBPTYPE=1 S @TGT@(0)=CIAD
- E I XWBPTYPE>1,XWBPTYPE<4 M @TGT=CIAD S:XWBPTYPE=2 XWBWRAP=1
- E I XWBPTYPE=4,$L(CIAD),CIAD'=TGT M @TGT=@CIAD K @CIAD
- E I XWBPTYPE=5 S @TGT@(0)=$G(@CIAD)
- E I XWBPTYPE="H" D
- .N X,Y,FIL,DIR
- .S X=$E($$DIRDLM^CIAUOS,3),Y=$L(CIAD,X),DIR=$P(CIAD,X,1,Y-1),FIL=$P(CIAD,X,Y)
- .I '$$FTG^%ZISH(DIR,FIL,$NA(@TGT@(0)),$QL(TGT)+1)
- .D DELETE^CIAUOS(CIAD)
- I $$S^%ZTLOAD K ^XTMP("CIA",CIA("UID"),"T",ZTSK)
- E S ^XTMP("CIA",CIA("UID"),"T",ZTSK)=ZTSK_"^0^"_XWBWRAP
- Q
- ERROR D SETERR(-1,$$EC^%ZOSV)
- D ^%ZTER,UNWIND^%ZTER
- Q
- ; Retrieve specified routine line
- RTNTEXT(RTN) ;
- N TAG
- S TAG=$P(RTN,U),RTN=$P(RTN,U,2)
- Q $S('$L(RTN):$T(^@TAG),$L(TAG):$T(@TAG^@RTN),1:$T(^@RTN))
- ; Set error info to return to client
- SETERR(CODE,TEXT) ;
- K ^XTMP("CIA",CIA("UID"),"T",ZTSK) M ^(ZTSK,0,0)=TEXT
- S ^XTMP("CIA",CIA("UID"),"T",ZTSK)=ZTSK_U_CODE_"^1"
- Q
- ; RPC to check for completed tasks
- ; Results[0] at the client end will contain the TaskMan ID of the
- ; completed RPC. The remainder of the Result will be the data
- ; returned by the RPC.
- ASYCHK() N ZTSK,CIAD,X
- S ZTSK=0
- F S ZTSK=+$O(^XTMP("CIA",CIA("UID"),"T",ZTSK)) Q:'ZTSK S X=$G(^(ZTSK)),CIAD=$NA(^(ZTSK,0)) I X D Q
- .D TCPUSE^CIANBLIS
- .W $C(2),X,$C(13),!
- .D OUT^CIANBACT(CIAD,$P(X,U,3))
- .K ^XTMP("CIA",CIA("UID"),"T",ZTSK)
- Q ZTSK
- ; RPC: Stop a task
- ; Signals to a backround task that it should stop running. Cleans up
- ; any output generated by completed tasks.
- STOP(CIAD,ZTSK) ;
- S CIAD=''$D(^XTMP("CIA",CIA("UID"),"T",ZTSK)) K:CIAD ^(ZTSK)
- Q:'$D(^%ZTSK(ZTSK))
- S $P(^%ZTSK(ZTSK,.1),U,10)=$P($G(^VA(200,DUZ,0)),U)
- D DQ^%ZTLOAD
- I $G(ZTSK(0)) D KILL^%ZTLOAD
- Q
- ; Stop all tasks in task list
- STOPALL N ZTSK
- S ZTSK=0
- F S ZTSK=$O(^XTMP("CIA",CIA("UID"),"T",ZTSK)) Q:'ZTSK D STOP(,ZTSK)
- K ^XTMP("CIA",CIA("UID"),"T")
- Q
- CIANBASY ;MSC/IND/DKM - Asynchronous RPC calls ;29-Jun-2012 15:50;PLS
- +1 ;;1.1;CIA NETWORK COMPONENTS;**001007,001009**;Sep 18, 2007
- +2 ;;Copyright 2000-2012, Medsphere Systems Corporation
- +3 ;=================================================================
- +4 ; Background task for executing an asynchronous RPC
- TASK NEW CIAD,TGT,$ETRAP,$ESTACK
- +1 SET $ETRAP="D ERROR^CIANBASY"
- SET ZTREQ="@"
- +2 KILL ^XTMP("CIA",CIA("UID"),"T",ZTSK)
- +3 IF $$S^%ZTLOAD
- QUIT
- +4 SET ^XTMP("CIA",CIA("UID"),"T",ZTSK)=0
- SET TGT=$NAME(^(ZTSK,0))
- +5 IF XWBPTYPE=4
- SET CIAD=TGT
- +6 DO DORPC^CIANBACT
- +7 IF XWBPTYPE=1
- SET @TGT@(0)=CIAD
- +8 IF '$TEST
- IF XWBPTYPE>1
- IF XWBPTYPE<4
- MERGE @TGT=CIAD
- IF XWBPTYPE=2
- SET XWBWRAP=1
- +9 IF '$TEST
- IF XWBPTYPE=4
- IF $LENGTH(CIAD)
- IF CIAD'=TGT
- MERGE @TGT=@CIAD
- KILL @CIAD
- +10 IF '$TEST
- IF XWBPTYPE=5
- SET @TGT@(0)=$GET(@CIAD)
- +11 IF '$TEST
- IF XWBPTYPE="H"
- Begin DoDot:1
- +12 NEW X,Y,FIL,DIR
- +13 SET X=$EXTRACT($$DIRDLM^CIAUOS,3)
- SET Y=$LENGTH(CIAD,X)
- SET DIR=$PIECE(CIAD,X,1,Y-1)
- SET FIL=$PIECE(CIAD,X,Y)
- +14 IF '$$FTG^%ZISH(DIR,FIL,$NAME(@TGT@(0)),$QLENGTH(TGT)+1)
- +15 DO DELETE^CIAUOS(CIAD)
- End DoDot:1
- +16 IF $$S^%ZTLOAD
- KILL ^XTMP("CIA",CIA("UID"),"T",ZTSK)
- +17 IF '$TEST
- SET ^XTMP("CIA",CIA("UID"),"T",ZTSK)=ZTSK_"^0^"_XWBWRAP
- +18 QUIT
- ERROR DO SETERR(-1,$$EC^%ZOSV)
- +1 DO ^%ZTER
- DO UNWIND^%ZTER
- +2 QUIT
- +3 ; Retrieve specified routine line
- RTNTEXT(RTN) ;
- +1 NEW TAG
- +2 SET TAG=$PIECE(RTN,U)
- SET RTN=$PIECE(RTN,U,2)
- +3 QUIT $SELECT('$LENGTH(RTN):$TEXT(^@TAG),$LENGTH(TAG):$TEXT(@TAG^@RTN),1:$TEXT(^@RTN))
- +4 ; Set error info to return to client
- SETERR(CODE,TEXT) ;
- +1 KILL ^XTMP("CIA",CIA("UID"),"T",ZTSK)
- MERGE ^(ZTSK,0,0)=TEXT
- +2 SET ^XTMP("CIA",CIA("UID"),"T",ZTSK)=ZTSK_U_CODE_"^1"
- +3 QUIT
- +4 ; RPC to check for completed tasks
- +5 ; Results[0] at the client end will contain the TaskMan ID of the
- +6 ; completed RPC. The remainder of the Result will be the data
- +7 ; returned by the RPC.
- ASYCHK() NEW ZTSK,CIAD,X
- +1 SET ZTSK=0
- +2 FOR
- SET ZTSK=+$ORDER(^XTMP("CIA",CIA("UID"),"T",ZTSK))
- IF 'ZTSK
- QUIT
- SET X=$GET(^(ZTSK))
- SET CIAD=$NAME(^(ZTSK,0))
- IF X
- Begin DoDot:1
- +3 DO TCPUSE^CIANBLIS
- +4 WRITE $CHAR(2),X,$CHAR(13),!
- +5 DO OUT^CIANBACT(CIAD,$PIECE(X,U,3))
- +6 KILL ^XTMP("CIA",CIA("UID"),"T",ZTSK)
- End DoDot:1
- QUIT
- +7 QUIT ZTSK
- +8 ; RPC: Stop a task
- +9 ; Signals to a backround task that it should stop running. Cleans up
- +10 ; any output generated by completed tasks.
- STOP(CIAD,ZTSK) ;
- +1 SET CIAD=''$DATA(^XTMP("CIA",CIA("UID"),"T",ZTSK))
- IF CIAD
- KILL ^(ZTSK)
- +2 IF '$DATA(^%ZTSK(ZTSK))
- QUIT
- +3 SET $PIECE(^%ZTSK(ZTSK,.1),U,10)=$PIECE($GET(^VA(200,DUZ,0)),U)
- +4 DO DQ^%ZTLOAD
- +5 IF $GET(ZTSK(0))
- DO KILL^%ZTLOAD
- +6 QUIT
- +7 ; Stop all tasks in task list
- STOPALL NEW ZTSK
- +1 SET ZTSK=0
- +2 FOR
- SET ZTSK=$ORDER(^XTMP("CIA",CIA("UID"),"T",ZTSK))
- IF 'ZTSK
- QUIT
- DO STOP(,ZTSK)
- +3 KILL ^XTMP("CIA",CIA("UID"),"T")
- +4 QUIT
