IBDFGRP ;ALB/MAF - GROUP COPY - 7/25/95
;;3.0;AUTOMATED INFO COLLECTION SYS;;APR 24, 1997
N NEWLIST,NEWBLOCK
S NEWLIST=IBLIST,NEWBLOCK=IBBLK
N IBBLK,TOP,BOT,IBLIST,IBFORM
S VALMBCK="R"
S IBBLK=$$SELECT2()
Q:'IBBLK
;
S DIC("S")="I $P(^(0),U,11)=$P($G(^IBE(357.2,+NEWLIST,0)),U,11)" D SELECT^IBDF3 K DIC
;
I '$G(IBLIST) W !!,"Block does not contain same type of selection list '"_$P($G(^IBE(357.6,+$P($G(^IBE(357.2,+NEWLIST,0)),U,11),0)),U)_"'.",! D PAUSE^IBDFU5
;
I IBLIST D EN^VALM("IBDF QUICK GRP COPY")
Q
;
INIT ; -- init variables and list array
N IBDCNT,IBDCNT1
K ^TMP("GRP",$J),^TMP("GRPIDX",$J),IBDFHDR D KILL^VALM10()
;
; -- Set up arrays for new and old selection list definitions in
; in file 357.2. Used to match data with the right subcolum #
; when copying selection lists to a form.
;
; - IBDFNEW(SUBCOLUM #) = TYPE OF DATA ..5th piece (text or code)
; - IBDFOLD(SUBCOLUM #) = TYPE OF DATA..5th piece (text or code)
D
.N K,NODE
.S (IBDFNEW,IBDFOLD)=0
.I $D(IBLIST) S K=0 D
..F S K=$O(^IBE(357.2,IBLIST,2,K)) Q:'K S NODE=$G(^IBE(357.2,IBLIST,2,K,0)),IBDFOLD(+NODE)=+$P(NODE,"^",5)
..Q
.I $D(NEWLIST) S NODE="",K=0 D
..F S K=$O(^IBE(357.2,NEWLIST,2,K)) Q:'K S NODE=$G(^IBE(357.2,NEWLIST,2,K,0)),IBDFNEW(+NODE)=+$P(NODE,"^",5)
..Q
S (IBDCNT,IBDCNT1,VALMCNT)=0
S IBDLSTNM=$P(^IBE(357.2,IBLIST,0),"^",1) D INTER D
.S IBLSNODE=$G(^IBE(357.2,IBLIST,0))
.I $D(IBDFAR) F IBDFX=0:0 S IBDFX=$O(@(IBDFAR_"("_IBDFX_")")) Q:'IBDFX S IBDFARR=$G(@(IBDFAR_"("_IBDFX_")")) D:$P(IBDFARR,"^",1)="" HEADER D:$P(IBDFARR,"^",1)]"" SETARR
Q:$$LSTDESCR^IBDFU1(.IBLIST) 1
S IBRTN=IBLIST("RTN")
D RTNDSCR^IBDFU1B(.IBRTN)
Q
;
SETARR ; -- Set up Listman array
N IBDFNODE
S IBDFNODE=IBDFARR
S IBDFSEL=$P(IBDFNODE,"^",4)
S IBDCNT=IBDCNT+1,VALMCNT=VALMCNT+1
S X=""
S IBDFVAL=$P(IBDFNODE,"^",1)
S X=$$SETSTR^VALM1(IBDFVAL,X,7,7)
S IBDFVAL=$P(IBDFNODE,"^",6)
S X=$$SETSTR^VALM1(IBDFVAL,X,16,5)
S IBDFVAL=$P(IBDFNODE,"^",2)
S X=$$SETSTR^VALM1(IBDFVAL,X,23,40)
S IBDFVAL=$P(^IBE(357.4,$P(IBDFNODE,"^",5),0),"^",1)
S X=$$SETSTR^VALM1(IBDFVAL,X,64,15)
TMP ; -- Set up TMP Array
S ^TMP("GRP",$J,IBDCNT,0)=X,^TMP("GRP",$J,"IDX",VALMCNT,IBDCNT1)=IBDFSEL
S ^TMP("GRPIDX",$J,IBDCNT1)=VALMCNT_"^"_$P(IBDFARR,"^",3)_"^"_$P(IBDFARR,"^",4)_"^"_$P(IBDFARR,"^",5) ;_"^"_IBDFX_"^"_$P(IBDFTMP,"^",4)_"^"_$P(IBDFTMP,"^",5)_"^"_$P(IBDFTMP,"^",1)_"^"_$P(IBDFTMP,"^",2)
Q
S IBDCNT1=IBDCNT1+1
S IBDCNT=IBDCNT+1,VALMCNT=VALMCNT+1
S X=""
S IBDVAL=$S($P(IBDFARR,"^",2)]"":$P(IBDFARR,"^",2),1:"BLANK")
S IBDFHDR(IBDVAL)=IBDCNT1_"^"_$P(IBDFARR,"^",5)
S IBDFSEL=$P(IBDFARR,"^",5)
S X=$$SETSTR^VALM1(IBDCNT1_")",X,1,5) D TMP
S X="",IBDCNT=IBDCNT+1,VALMCNT=VALMCNT+1
S IBDVAL=$P(IBDFARR,"^",6)
S X=$$SETSTR^VALM1(IBDVAL,X,16,5)
S IBDVAL=$P(IBDFARR,"^",2)
S IBDVAL1=$L(IBDVAL) S IBDVAL1=(80-IBDVAL1)/2 S IBDVAL1=IBDVAL1\1 S X=$$SETSTR^VALM1(" ",X,22,IBDVAL1)
S X=$$SETSTR^VALM1(IBDVAL,X,IBDVAL1,25) D TMP,CNTRL^VALM10(VALMCNT,1,80,IOINHI,IOINORM,0)
S X="",IBDCNT=IBDCNT+1,VALMCNT=VALMCNT+1
S X=$$SETSTR^VALM1(" ",X,1,3) D TMP
Q
INTER ; -- Find Package interface for selection list
K IBARRY S IBDFAR="IBARRY",IBDFINT=$P($G(^IBE(357.2,IBLIST,0)),"^",11),IBDFINT(1)=$P(^IBE(357.6,IBDFINT,0),"^",1) D GETLST^IBDFQSL2(IBFORM,IBBLK,IBLIST,.IBDFINT,"IBARRY",1)
Q
HELP ; -- help code
S X="?" D DISP^XQORM1 W !!
Q
;
EXIT ; -- exit code
K IBARRY,IBDFAR,IBDFARR,IBDFHDR,IBDFINT,IBDFSEL,IBDFVAL,IBDFX,IBDLSTNM,IBDVAL,IBDVAL1,IBLIST,IBRTN,IEN,IBLSNODE,DIC,IBGRP,NODE,IBDFNEW,IBDFOLD
K ^TMP("SEL",$J),^TMP("SELIDX",$J)
Q
;
EXPND ; -- expand code
Q
;
GRPCOPY ; -- COPY GROUP
N IBDVALM,GRP,VALMY,FROM,TO,IBDFCPYE
S IBDFCPYF=1
S (FROM,TO)="357.4"
S VALMBCK=""
D EN^VALM2($G(XQORNOD(0)))
I $O(VALMY(0)) D
.S IBDVALM=0
.D FULL^VALM1 S VALMBCK="R"
.F IBDVALM=0:0 S IBDVALM=$O(VALMY(IBDVALM)) Q:'IBDVALM S (DA,GRP)=$P($G(^TMP("GRPIDX",$J,IBDVALM)),"^",4) D COPYGRP^IBDFU2A(GRP,IBLIST,NEWLIST,NEWBLOCK,FROM,TO)
K IBDFCPYF
Q
SELECT2() ;allows the user to select a form, then a block from it
S IBBLK=""
S IBFORM=$$SLCTFORM^IBDFU4(0)
I IBFORM D
.W !!,"NOW CHOOSE THE BLOCK TO COPY!",!
.S IBBLK=$$SLCTBLK^IBDFU8(IBFORM,IOSL)
Q IBBLK
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBDFGRP 4353 printed Dec 13, 2024@02:52:41 Page 2
IBDFGRP ;ALB/MAF - GROUP COPY - 7/25/95
+1 ;;3.0;AUTOMATED INFO COLLECTION SYS;;APR 24, 1997
+2 NEW NEWLIST,NEWBLOCK
+3 SET NEWLIST=IBLIST
SET NEWBLOCK=IBBLK
+4 NEW IBBLK,TOP,BOT,IBLIST,IBFORM
+5 SET VALMBCK="R"
+6 SET IBBLK=$$SELECT2()
+7 if 'IBBLK
QUIT
+8 ;
+9 SET DIC("S")="I $P(^(0),U,11)=$P($G(^IBE(357.2,+NEWLIST,0)),U,11)"
DO SELECT^IBDF3
KILL DIC
+10 ;
+11 IF '$GET(IBLIST)
WRITE !!,"Block does not contain same type of selection list '"_$PIECE($GET(^IBE(357.6,+$PIECE($GET(^IBE(357.2,+NEWLIST,0)),U,11),0)),U)_"'.",!
DO PAUSE^IBDFU5
+12 ;
+13 IF IBLIST
DO EN^VALM("IBDF QUICK GRP COPY")
+14 QUIT
+15 ;
INIT ; -- init variables and list array
+1 NEW IBDCNT,IBDCNT1
+2 KILL ^TMP("GRP",$JOB),^TMP("GRPIDX",$JOB),IBDFHDR
DO KILL^VALM10()
+3 ;
+4 ; -- Set up arrays for new and old selection list definitions in
+5 ; in file 357.2. Used to match data with the right subcolum #
+6 ; when copying selection lists to a form.
+7 ;
+8 ; - IBDFNEW(SUBCOLUM #) = TYPE OF DATA ..5th piece (text or code)
+9 ; - IBDFOLD(SUBCOLUM #) = TYPE OF DATA..5th piece (text or code)
+10 Begin DoDot:1
+11 NEW K,NODE
+12 SET (IBDFNEW,IBDFOLD)=0
+13 IF $DATA(IBLIST)
SET K=0
Begin DoDot:2
+14 FOR
SET K=$ORDER(^IBE(357.2,IBLIST,2,K))
if 'K
QUIT
SET NODE=$GET(^IBE(357.2,IBLIST,2,K,0))
SET IBDFOLD(+NODE)=+$PIECE(NODE,"^",5)
+15 QUIT
End DoDot:2
+16 IF $DATA(NEWLIST)
SET NODE=""
SET K=0
Begin DoDot:2
+17 FOR
SET K=$ORDER(^IBE(357.2,NEWLIST,2,K))
if 'K
QUIT
SET NODE=$GET(^IBE(357.2,NEWLIST,2,K,0))
SET IBDFNEW(+NODE)=+$PIECE(NODE,"^",5)
+18 QUIT
End DoDot:2
End DoDot:1
+19 SET (IBDCNT,IBDCNT1,VALMCNT)=0
+20 SET IBDLSTNM=$PIECE(^IBE(357.2,IBLIST,0),"^",1)
DO INTER
Begin DoDot:1
+21 SET IBLSNODE=$GET(^IBE(357.2,IBLIST,0))
+22 IF $DATA(IBDFAR)
FOR IBDFX=0:0
SET IBDFX=$ORDER(@(IBDFAR_"("_IBDFX_")"))
if 'IBDFX
QUIT
SET IBDFARR=$GET(@(IBDFAR_"("_IBDFX_")"))
if $PIECE(IBDFARR,"^",1)=""
DO HEADER
if $PIECE(IBDFARR,"^",1)]""
DO SETARR
End DoDot:1
+23 if $$LSTDESCR^IBDFU1(.IBLIST)
QUIT 1
+24 SET IBRTN=IBLIST("RTN")
+25 DO RTNDSCR^IBDFU1B(.IBRTN)
+26 QUIT
+27 ;
SETARR ; -- Set up Listman array
+1 NEW IBDFNODE
+2 SET IBDFNODE=IBDFARR
+3 SET IBDFSEL=$PIECE(IBDFNODE,"^",4)
+4 SET IBDCNT=IBDCNT+1
SET VALMCNT=VALMCNT+1
+5 SET X=""
+6 SET IBDFVAL=$PIECE(IBDFNODE,"^",1)
+7 SET X=$$SETSTR^VALM1(IBDFVAL,X,7,7)
+8 SET IBDFVAL=$PIECE(IBDFNODE,"^",6)
+9 SET X=$$SETSTR^VALM1(IBDFVAL,X,16,5)
+10 SET IBDFVAL=$PIECE(IBDFNODE,"^",2)
+11 SET X=$$SETSTR^VALM1(IBDFVAL,X,23,40)
+12 SET IBDFVAL=$PIECE(^IBE(357.4,$PIECE(IBDFNODE,"^",5),0),"^",1)
+13 SET X=$$SETSTR^VALM1(IBDFVAL,X,64,15)
TMP ; -- Set up TMP Array
+1 SET ^TMP("GRP",$JOB,IBDCNT,0)=X
SET ^TMP("GRP",$JOB,"IDX",VALMCNT,IBDCNT1)=IBDFSEL
+2 ;_"^"_IBDFX_"^"_$P(IBDFTMP,"^",4)_"^"_$P(IBDFTMP,"^",5)_"^"_$P(IBDFTMP,"^",1)_"^"_$P(IBDFTMP,"^",2)
SET ^TMP("GRPIDX",$JOB,IBDCNT1)=VALMCNT_"^"_$PIECE(IBDFARR,"^",3)_"^"_$PIECE(IBDFARR,"^",4)_"^"_$PIECE(IBDFARR,"^",5)
+3 QUIT
+1 SET IBDCNT1=IBDCNT1+1
+2 SET IBDCNT=IBDCNT+1
SET VALMCNT=VALMCNT+1
+3 SET X=""
+4 SET IBDVAL=$SELECT($PIECE(IBDFARR,"^",2)]"":$PIECE(IBDFARR,"^",2),1:"BLANK")
+5 SET IBDFHDR(IBDVAL)=IBDCNT1_"^"_$PIECE(IBDFARR,"^",5)
+6 SET IBDFSEL=$PIECE(IBDFARR,"^",5)
+7 SET X=$$SETSTR^VALM1(IBDCNT1_")",X,1,5)
DO TMP
+8 SET X=""
SET IBDCNT=IBDCNT+1
SET VALMCNT=VALMCNT+1
+9 SET IBDVAL=$PIECE(IBDFARR,"^",6)
+10 SET X=$$SETSTR^VALM1(IBDVAL,X,16,5)
+11 SET IBDVAL=$PIECE(IBDFARR,"^",2)
+12 SET IBDVAL1=$LENGTH(IBDVAL)
SET IBDVAL1=(80-IBDVAL1)/2
SET IBDVAL1=IBDVAL1\1
SET X=$$SETSTR^VALM1(" ",X,22,IBDVAL1)
+13 SET X=$$SETSTR^VALM1(IBDVAL,X,IBDVAL1,25)
DO TMP
DO CNTRL^VALM10(VALMCNT,1,80,IOINHI,IOINORM,0)
+14 SET X=""
SET IBDCNT=IBDCNT+1
SET VALMCNT=VALMCNT+1
+15 SET X=$$SETSTR^VALM1(" ",X,1,3)
DO TMP
+16 QUIT
INTER ; -- Find Package interface for selection list
+1 KILL IBARRY
SET IBDFAR="IBARRY"
SET IBDFINT=$PIECE($GET(^IBE(357.2,IBLIST,0)),"^",11)
SET IBDFINT(1)=$PIECE(^IBE(357.6,IBDFINT,0),"^",1)
DO GETLST^IBDFQSL2(IBFORM,IBBLK,IBLIST,.IBDFINT,"IBARRY",1)
+2 QUIT
HELP ; -- help code
+1 SET X="?"
DO DISP^XQORM1
WRITE !!
+2 QUIT
+3 ;
EXIT ; -- exit code
+1 KILL IBARRY,IBDFAR,IBDFARR,IBDFHDR,IBDFINT,IBDFSEL,IBDFVAL,IBDFX,IBDLSTNM,IBDVAL,IBDVAL1,IBLIST,IBRTN,IEN,IBLSNODE,DIC,IBGRP,NODE,IBDFNEW,IBDFOLD
+2 KILL ^TMP("SEL",$JOB),^TMP("SELIDX",$JOB)
+3 QUIT
+4 ;
EXPND ; -- expand code
+1 QUIT
+2 ;
GRPCOPY ; -- COPY GROUP
+1 NEW IBDVALM,GRP,VALMY,FROM,TO,IBDFCPYE
+2 SET IBDFCPYF=1
+3 SET (FROM,TO)="357.4"
+4 SET VALMBCK=""
+5 DO EN^VALM2($GET(XQORNOD(0)))
+6 IF $ORDER(VALMY(0))
Begin DoDot:1
+7 SET IBDVALM=0
+8 DO FULL^VALM1
SET VALMBCK="R"
+9 FOR IBDVALM=0:0
SET IBDVALM=$ORDER(VALMY(IBDVALM))
if 'IBDVALM
QUIT
SET (DA,GRP)=$PIECE($GET(^TMP("GRPIDX",$JOB,IBDVALM)),"^",4)
DO COPYGRP^IBDFU2A(GRP,IBLIST,NEWLIST,NEWBLOCK,FROM,TO)
End DoDot:1
+10 KILL IBDFCPYF
+11 QUIT
SELECT2() ;allows the user to select a form, then a block from it
+1 SET IBBLK=""
+2 SET IBFORM=$$SLCTFORM^IBDFU4(0)
+3 IF IBFORM
Begin DoDot:1
+4 WRITE !!,"NOW CHOOSE THE BLOCK TO COPY!",!
+5 SET IBBLK=$$SLCTBLK^IBDFU8(IBFORM,IOSL)
End DoDot:1
+6 QUIT IBBLK
