- 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
