BGUTRACS ; IHS/OIT/MJL - REMOTE PROCEDURE TESTING ROUTINE ;
;;1.5;BGU;;MAY 26, 2005
D INIT
F D MAIN Q:BGUDONE
D END
Q
;
MAIN ; -- main message processing loop
S (BGUMSG,X)="",DIC(0)="AQEM" D ASKRPC I Y<0 S BGUDONE=1 D KILL Q
S DIR(0)="FO" F BGUN=1:1 S DIR("A")="PARAMETER-"_BGUN D ^DIR Q:$D(DIROUT) Q:X="^" D:X=" " USELST S BGUM(BGUN)=X,BGUMSG=BGUMSG_U_X,^TMP("BGUTRACS",$J,"PARAMS",BGUN)=X
I BGUN=1 S BGUDONE=1 D KILL Q
S (BGUMSG1,BGUSTR)="" F BGUN=1:1:BGUN-1 S:BGUN>1 BGUMSG1=BGUMSG1_",",BGUSTR=BGUSTR_"," S BGUMSG1=BGUMSG1_"BGUM("_BGUN_")",BGUSTR=BGUSTR_""""_BGUM(BGUN)_""""
; -- set up for routine call
ENT ;
K X,Y,BGUDATA N DIQUIET
S BGUREF=^XWB(8994,BGUIEN,0)
S BGUTRTN=$P(BGUREF,"^",2,3),BGUTYPE=$P(BGUREF,U,4),BGURTN1=BGUTRTN,BGUTRTN=BGUTRTN_"(.BGUDATA,"_BGUMSG1_")"
S BGUSTR=BGURTN1_"(.BGUDATA,"_BGUSTR_")"
S DIQUIET=1 D @BGUTRTN
; Same line of code used in ^BGUTCPH :
D:$S($P(BGUMSG,"TRACE=",2)'="":1,$D(BGUTRACE):1,$P(^BGUSP(1,0),"^",2)="Y":1,1:$D(^BGUSP(1,1,"B",$J))) ^BGUTRACE
D KILL
Q
;
INIT ;
S U="^",BGUAPID="OE-2",BGUDONE=0
Q
;
ASKRPC ; Ask for Remote procedure call
;
S DIC="^XWB(8994," D ^DIC Q:+Y<0 S BGUIEN=+Y S:BGUMSG="" BGUMSG=$P(Y,U,2)
Q
;
USELST ; Use the last value entered for this prompt
;
S X=$G(^TMP("BGUTRACS",$J,"PARAMS",BGUN))
W:X'="" *8,X
Q
;
TEST ;
D INIT
I '$D(^TMP("BGUTEST",$J,"PRMS")) D Q
.S BGUMSG=^TMP("BGUTEST",$J),BGUIEN=$O(^XWB(8994,"B",$P(BGUMSG,U),"")),BGUMSG=$P(BGUMSG,U,2,999)
.I $D(^TMP("BGUTEST",$J,1)) F BGUN=1:1 Q:'$D(^TMP("BGUTEST",$J,BGUN)) S BGUMSG=BGUMSG_^(BGUN)
.S BGUSTR="" F BGUN=1:1:$L(BGUMSG,U) S BGUMSG2=$P(BGUMSG,U,BGUN) S:BGUN>1 BGUSTR=BGUSTR_"," S BGUSTR=BGUSTR_""""_BGUMSG2_""""
.S BGUMSG1=BGUSTR,^TMP("BGUTEST",$J,"PRMS")=$E(BGUMSG1,1,250) D:$L(BGUMSG1)>250 S ^TMP("BGUTEST",$J,"IEN")=BGUIEN D ENT
..F BGUN1=1:1:($L(BGUMSG1)\250-1+($L(BGUMSG1)#250>0)) S ^TMP("BGUTEST",$J,"PRMS",BGUN1)=$E(BGUMSG1,BGUN1*250+1,BGUN1*250*2)
S BGUMSG=$P(^TMP("BGUTEST",$J),U,2),BGUMSG1=^TMP("BGUTEST",$J,"PRMS"),BGUSTR=BGUMSG1,BGUIEN=^("IEN")
I $D(^TMP("BGUTEST",$J,1)) F BGUN=1:1 Q:'$D(^TMP("BGUTEST",$J,BGUN)) S BGUMSG=BGUMSG_^(BGUN)
I $D(^TMP("BGUTEST",$J,"PRMS",1)) F BGUN=1:1 Q:'$D(^TMP("BGUTEST",$J,"PRMS",BGUN)) S BGUMSG1=BGUMSG1_^(BGUN)
D ENT
Q
;
KILL ;
K BGUDATA,BGUDTA,BGUFLGS,BGUFDA,BGUFN,BGUIEN,BGUM,BGUMSG,BGUMSG1,BGUMSG2,BGUN,BGUN1,BGUN2,BGUQ,BGUREF,BGURTN1,BGUSTR,BGUTCK,BGUTCK1,BGUTRTN,BGUY,BGUY1,BGUYLN,BGUWMSG,BGUWPD,DIC,DIR
Q
;
END ;
D KILL
K BGUAPID,BGUDONE,BGUHIT,BGUTRACE,^TMP("BGUTRACS",$J)
Q
BGUTRACS ; IHS/OIT/MJL - REMOTE PROCEDURE TESTING ROUTINE ;
+1 ;;1.5;BGU;;MAY 26, 2005
+2 DO INIT
+3 FOR
DO MAIN
IF BGUDONE
QUIT
+4 DO END
+5 QUIT
+6 ;
MAIN ; -- main message processing loop
+1 SET (BGUMSG,X)=""
SET DIC(0)="AQEM"
DO ASKRPC
IF Y<0
SET BGUDONE=1
DO KILL
QUIT
+2 SET DIR(0)="FO"
FOR BGUN=1:1
SET DIR("A")="PARAMETER-"_BGUN
DO ^DIR
IF $DATA(DIROUT)
QUIT
IF X="^"
QUIT
IF X=" "
DO USELST
SET BGUM(BGUN)=X
SET BGUMSG=BGUMSG_U_X
SET ^TMP("BGUTRACS",$JOB,"PARAMS",BGUN)=X
+3 IF BGUN=1
SET BGUDONE=1
DO KILL
QUIT
+4 SET (BGUMSG1,BGUSTR)=""
FOR BGUN=1:1:BGUN-1
IF BGUN>1
SET BGUMSG1=BGUMSG1_","
SET BGUSTR=BGUSTR_","
SET BGUMSG1=BGUMSG1_"BGUM("_BGUN_")"
SET BGUSTR=BGUSTR_""""_BGUM(BGUN)_""""
+5 ; -- set up for routine call
ENT ;
+1 KILL X,Y,BGUDATA
NEW DIQUIET
+2 SET BGUREF=^XWB(8994,BGUIEN,0)
+3 SET BGUTRTN=$PIECE(BGUREF,"^",2,3)
SET BGUTYPE=$PIECE(BGUREF,U,4)
SET BGURTN1=BGUTRTN
SET BGUTRTN=BGUTRTN_"(.BGUDATA,"_BGUMSG1_")"
+4 SET BGUSTR=BGURTN1_"(.BGUDATA,"_BGUSTR_")"
+5 SET DIQUIET=1
DO @BGUTRTN
+6 ; Same line of code used in ^BGUTCPH :
+7 IF $SELECT($PIECE(BGUMSG,"TRACE=",2)'=""
DO ^BGUTRACE
+8 DO KILL
+9 QUIT
+10 ;
INIT ;
+1 SET U="^"
SET BGUAPID="OE-2"
SET BGUDONE=0
+2 QUIT
+3 ;
ASKRPC ; Ask for Remote procedure call
+1 ;
+2 SET DIC="^XWB(8994,"
DO ^DIC
IF +Y<0
QUIT
SET BGUIEN=+Y
IF BGUMSG=""
SET BGUMSG=$PIECE(Y,U,2)
+3 QUIT
+4 ;
USELST ; Use the last value entered for this prompt
+1 ;
+2 SET X=$GET(^TMP("BGUTRACS",$JOB,"PARAMS",BGUN))
+3 IF X'=""
WRITE *8,X
+4 QUIT
+5 ;
TEST ;
+1 DO INIT
+2 IF '$DATA(^TMP("BGUTEST",$JOB,"PRMS"))
Begin DoDot:1
+3 SET BGUMSG=^TMP("BGUTEST",$JOB)
SET BGUIEN=$ORDER(^XWB(8994,"B",$PIECE(BGUMSG,U),""))
SET BGUMSG=$PIECE(BGUMSG,U,2,999)
+4 IF $DATA(^TMP("BGUTEST",$JOB,1))
FOR BGUN=1:1
IF '$DATA(^TMP("BGUTEST",$JOB,BGUN))
QUIT
SET BGUMSG=BGUMSG_^(BGUN)
+5 SET BGUSTR=""
FOR BGUN=1:1:$LENGTH(BGUMSG,U)
SET BGUMSG2=$PIECE(BGUMSG,U,BGUN)
IF BGUN>1
SET BGUSTR=BGUSTR_","
SET BGUSTR=BGUSTR_""""_BGUMSG2_""""
+6 SET BGUMSG1=BGUSTR
SET ^TMP("BGUTEST",$JOB,"PRMS")=$EXTRACT(BGUMSG1,1,250)
IF $LENGTH(BGUMSG1)>250
Begin DoDot:2
+7 FOR BGUN1=1:1:($LENGTH(BGUMSG1)\250-1+($LENGTH(BGUMSG1)#250>0))
SET ^TMP("BGUTEST",$JOB,"PRMS",BGUN1)=$EXTRACT(BGUMSG1,BGUN1*250+1,BGUN1*250*2)
End DoDot:2
SET ^TMP("BGUTEST",$JOB,"IEN")=BGUIEN
DO ENT
End DoDot:1
QUIT
+8 SET BGUMSG=$PIECE(^TMP("BGUTEST",$JOB),U,2)
SET BGUMSG1=^TMP("BGUTEST",$JOB,"PRMS")
SET BGUSTR=BGUMSG1
SET BGUIEN=^("IEN")
+9 IF $DATA(^TMP("BGUTEST",$JOB,1))
FOR BGUN=1:1
IF '$DATA(^TMP("BGUTEST",$JOB,BGUN))
QUIT
SET BGUMSG=BGUMSG_^(BGUN)
+10 IF $DATA(^TMP("BGUTEST",$JOB,"PRMS",1))
FOR BGUN=1:1
IF '$DATA(^TMP("BGUTEST",$JOB,"PRMS",BGUN))
QUIT
SET BGUMSG1=BGUMSG1_^(BGUN)
+11 DO ENT
+12 QUIT
+13 ;
KILL ;
+1 KILL BGUDATA,BGUDTA,BGUFLGS,BGUFDA,BGUFN,BGUIEN,BGUM,BGUMSG,BGUMSG1,BGUMSG2,BGUN,BGUN1,BGUN2,BGUQ,BGUREF,BGURTN1,BGUSTR,BGUTCK,BGUTCK1,BGUTRTN,BGUY,BGUY1,BGUYLN,BGUWMSG,BGUWPD,DIC,DIR
+2 QUIT
+3 ;
END ;
+1 DO KILL
+2 KILL BGUAPID,BGUDONE,BGUHIT,BGUTRACE,^TMP("BGUTRACS",$JOB)
+3 QUIT
