- 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 Feb 19, 2025@00:19:06 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