BGUPMR ; IHS/OIT/MJL - PRINT MUMPS ROUTINES ;
;;1.5;BGU;**1**;SEP 26, 2005
EN(BGUARRAY,BGURTN) ;PEP FROM REMOTE PROCEDURE BGU PMR
CTL ;
S BGUARRAY="^TMP(""BGUPMR"","_$J_")"
I '$D(BGUSEL) K ^TMP("BGURTNS",$J) Q
I '$D(^TMP("BGURTNS",$J,0)) D UCI^%ZOSV S ^TMP("BGURTNS",$J,0)=Y_U D NOW^%DTC S Y=% X ^DD("DD") S ^TMP("BGURTNS",$J,0)=^TMP("BGURTNS",$J,0)_$P(Y,"@",1)_U_$P(Y,"@",2)
S BGURTN=$O(^TMP("BGURTNS",$J,1,0)) I BGURTN="" S BGULCNT=1 D PMRDONE Q
K ^TMP("BGUPMR",$J)
S BGULCNT=1,^TMP("BGUPMR",$J,BGULCNT)=BGURTN_U_^TMP("BGURTNS",$J,0)
F BGULN=1:1 S BGUX=$T(+BGULN^@BGURTN) Q:BGUX="" S BGULCNT=BGULCNT+1,^TMP("BGUPMR",$J,BGULCNT)=BGUX
S ^TMP("BGUPMR",$J,0)=BGULCNT
K ^TMP("BGURTNS",$J,1,BGURTN)
I $O(^TMP("BGURTNS",$J,1,0))="" S BGULCNT=BGULCNT+1 D PMRDONE
Q
;
SEL(BGUARRAY,BGURTN) ;
I '$D(BGUSEL) S BGUSEL=1 K ^TMP("BGURTNS",$J)
S BGUARRAY="^TMP(""BGURTNS"","_$J_",2)",BGUCNT=+$G(^TMP("BGURTNS",$J,1,0))
S BGUADD=1 S:$E(BGURTN)="-" BGUADD=0,BGURTN=$P(BGURTN,"-",2)
I BGURTN["*" S BGUR=BGURTN D WILDSCN,SELDONE Q
S X=BGURTN X ^%ZOSF("TEST") I $T S BGUMRT=BGURTN D MATCH,SELDONE
Q
;
WILDSCN ;
S BGURTNG=U_$P($P(^%ZOSF("TEST"),U,2),"(")
I BGUR="*" D Q
.S BGUMRT="" F S BGUMRT=$O(@(BGURTNG_"("""_BGUMRT_""")")) Q:BGUMRT="" D MATCH
S BGUPMCK="" F BGUN=1:1:$L(BGUR,"*") S BGUX=$P(BGUR,"*",BGUN) S:BGUN>1 BGUPMCK=BGUPMCK_".E" S:BGUX'="" BGUPMCK=BGUPMCK_"1"""_BGUX_""""
I $E(BGUR,1)="*" D Q
.S BGUMRT="" F S BGUMRT=$O(@(BGURTNG_"("""_BGUMRT_""")")) Q:BGUMRT="" D:BGUMRT?@BGUPMCK MATCH
S BGUX=$P(BGUR,"*",1),BGULX=$L(BGUX),BGUST=BGUX,$E(BGUST,BGULX)=$C($A($E(BGUX,BGULX))-1)_"~"
S BGUMRT=BGUST F S BGUMRT=$O(@(BGURTNG_"("""_BGUMRT_""")")) Q:$E(BGUMRT,1,BGULX)'=BGUX D:BGUMRT?@BGUPMCK MATCH
Q
;
MATCH ;
I BGUADD S:'$D(^TMP("BGURTNS",$J,1,BGUMRT)) ^(BGUMRT)=BGUMRT,BGUCNT=BGUCNT+1 Q
I $D(^TMP("BGURTNS",$J,1,BGUMRT)) K ^(BGUMRT) S BGUCNT=BGUCNT-1
Q
;
PMRDONE ;
S ^TMP("BGUPMR",$J,0)=BGULCNT,^(BGULCNT)="***DONE***"
;K BGULCNT,BGULN,BGUN,BGURTN,BGUX,^TMP("BGURTNS",$J)
K BGUCNT,BGULCNT,BGULX,BGUMRT,BGUPMCK,BGUR,BGURTN,BGUST,BGUX,^TMP("BGURTNS",$J)
Q
SELDONE ;
S ^TMP("BGURTNS",$J,1,0)=BGUCNT
K ^TMP("BGURTNS",$J,2)
M ^TMP("BGURTNS",$J,2)=^TMP("BGURTNS",$J,1)
K BGUCNT,BGULN,BGUN,BGURTN,BGUX
K BGUADD,BGUCNT,BGULCNT,BGULX,BGUMRT,BGUPMCK,BGUR,BGURTN,BGURTNG,BGUST,BGUX
Q
BGUPMR ; IHS/OIT/MJL - PRINT MUMPS ROUTINES ;
+1 ;;1.5;BGU;**1**;SEP 26, 2005
EN(BGUARRAY,BGURTN) ;PEP FROM REMOTE PROCEDURE BGU PMR
CTL ;
+1 SET BGUARRAY="^TMP(""BGUPMR"","_$JOB_")"
+2 IF '$DATA(BGUSEL)
KILL ^TMP("BGURTNS",$JOB)
QUIT
+3 IF '$DATA(^TMP("BGURTNS",$JOB,0))
DO UCI^%ZOSV
SET ^TMP("BGURTNS",$JOB,0)=Y_U
DO NOW^%DTC
SET Y=%
XECUTE ^DD("DD")
SET ^TMP("BGURTNS",$JOB,0)=^TMP("BGURTNS",$JOB,0)_$PIECE(Y,"@",1)_U_$PIECE(Y,"@",2)
+4 SET BGURTN=$ORDER(^TMP("BGURTNS",$JOB,1,0))
IF BGURTN=""
SET BGULCNT=1
DO PMRDONE
QUIT
+5 KILL ^TMP("BGUPMR",$JOB)
+6 SET BGULCNT=1
SET ^TMP("BGUPMR",$JOB,BGULCNT)=BGURTN_U_^TMP("BGURTNS",$JOB,0)
+7 FOR BGULN=1:1
SET BGUX=$TEXT(+BGULN^@BGURTN)
IF BGUX=""
QUIT
SET BGULCNT=BGULCNT+1
SET ^TMP("BGUPMR",$JOB,BGULCNT)=BGUX
+8 SET ^TMP("BGUPMR",$JOB,0)=BGULCNT
+9 KILL ^TMP("BGURTNS",$JOB,1,BGURTN)
+10 IF $ORDER(^TMP("BGURTNS",$JOB,1,0))=""
SET BGULCNT=BGULCNT+1
DO PMRDONE
+11 QUIT
+12 ;
SEL(BGUARRAY,BGURTN) ;
+1 IF '$DATA(BGUSEL)
SET BGUSEL=1
KILL ^TMP("BGURTNS",$JOB)
+2 SET BGUARRAY="^TMP(""BGURTNS"","_$JOB_",2)"
SET BGUCNT=+$GET(^TMP("BGURTNS",$JOB,1,0))
+3 SET BGUADD=1
IF $EXTRACT(BGURTN)="-"
SET BGUADD=0
SET BGURTN=$PIECE(BGURTN,"-",2)
+4 IF BGURTN["*"
SET BGUR=BGURTN
DO WILDSCN
DO SELDONE
QUIT
+5 SET X=BGURTN
XECUTE ^%ZOSF("TEST")
IF $TEST
SET BGUMRT=BGURTN
DO MATCH
DO SELDONE
+6 QUIT
+7 ;
WILDSCN ;
+1 SET BGURTNG=U_$PIECE($PIECE(^%ZOSF("TEST"),U,2),"(")
+2 IF BGUR="*"
Begin DoDot:1
+3 SET BGUMRT=""
FOR
SET BGUMRT=$ORDER(@(BGURTNG_"("""_BGUMRT_""")"))
IF BGUMRT=""
QUIT
DO MATCH
End DoDot:1
QUIT
+4 SET BGUPMCK=""
FOR BGUN=1:1:$LENGTH(BGUR,"*")
SET BGUX=$PIECE(BGUR,"*",BGUN)
IF BGUN>1
SET BGUPMCK=BGUPMCK_".E"
IF BGUX'=""
SET BGUPMCK=BGUPMCK_"1"""_BGUX_""""
+5 IF $EXTRACT(BGUR,1)="*"
Begin DoDot:1
+6 SET BGUMRT=""
FOR
SET BGUMRT=$ORDER(@(BGURTNG_"("""_BGUMRT_""")"))
IF BGUMRT=""
QUIT
IF BGUMRT?@BGUPMCK
DO MATCH
End DoDot:1
QUIT
+7 SET BGUX=$PIECE(BGUR,"*",1)
SET BGULX=$LENGTH(BGUX)
SET BGUST=BGUX
SET $EXTRACT(BGUST,BGULX)=$CHAR($ASCII($EXTRACT(BGUX,BGULX))-1)_"~"
+8 SET BGUMRT=BGUST
FOR
SET BGUMRT=$ORDER(@(BGURTNG_"("""_BGUMRT_""")"))
IF $EXTRACT(BGUMRT,1,BGULX)'=BGUX
QUIT
IF BGUMRT?@BGUPMCK
DO MATCH
+9 QUIT
+10 ;
MATCH ;
+1 IF BGUADD
IF '$DATA(^TMP("BGURTNS",$JOB,1,BGUMRT))
SET ^(BGUMRT)=BGUMRT
SET BGUCNT=BGUCNT+1
QUIT
+2 IF $DATA(^TMP("BGURTNS",$JOB,1,BGUMRT))
KILL ^(BGUMRT)
SET BGUCNT=BGUCNT-1
+3 QUIT
+4 ;
PMRDONE ;
+1 SET ^TMP("BGUPMR",$JOB,0)=BGULCNT
SET ^(BGULCNT)="***DONE***"
+2 ;K BGULCNT,BGULN,BGUN,BGURTN,BGUX,^TMP("BGURTNS",$J)
+3 KILL BGUCNT,BGULCNT,BGULX,BGUMRT,BGUPMCK,BGUR,BGURTN,BGUST,BGUX,^TMP("BGURTNS",$JOB)
+4 QUIT
SELDONE ;
+1 SET ^TMP("BGURTNS",$JOB,1,0)=BGUCNT
+2 KILL ^TMP("BGURTNS",$JOB,2)
+3 MERGE ^TMP("BGURTNS",$JOB,2)=^TMP("BGURTNS",$JOB,1)
+4 KILL BGUCNT,BGULN,BGUN,BGURTN,BGUX
+5 KILL BGUADD,BGUCNT,BGULCNT,BGULX,BGUMRT,BGUPMCK,BGUR,BGURTN,BGURTNG,BGUST,BGUX
+6 QUIT
