Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: IBDFGRP

IBDFGRP.m

Go to the documentation of this file.
  1. IBDFGRP ;ALB/MAF - GROUP COPY - 7/25/95
  1. ;;3.0;AUTOMATED INFO COLLECTION SYS;;APR 24, 1997
  1. N NEWLIST,NEWBLOCK
  1. S NEWLIST=IBLIST,NEWBLOCK=IBBLK
  1. N IBBLK,TOP,BOT,IBLIST,IBFORM
  1. S VALMBCK="R"
  1. S IBBLK=$$SELECT2()
  1. Q:'IBBLK
  1. ;
  1. S DIC("S")="I $P(^(0),U,11)=$P($G(^IBE(357.2,+NEWLIST,0)),U,11)" D SELECT^IBDF3 K DIC
  1. ;
  1. 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
  1. ;
  1. I IBLIST D EN^VALM("IBDF QUICK GRP COPY")
  1. Q
  1. ;
  1. INIT ; -- init variables and list array
  1. N IBDCNT,IBDCNT1
  1. K ^TMP("GRP",$J),^TMP("GRPIDX",$J),IBDFHDR D KILL^VALM10()
  1. ;
  1. ; -- Set up arrays for new and old selection list definitions in
  1. ; in file 357.2. Used to match data with the right subcolum #
  1. ; when copying selection lists to a form.
  1. ;
  1. ; - IBDFNEW(SUBCOLUM #) = TYPE OF DATA ..5th piece (text or code)
  1. ; - IBDFOLD(SUBCOLUM #) = TYPE OF DATA..5th piece (text or code)
  1. D
  1. .N K,NODE
  1. .S (IBDFNEW,IBDFOLD)=0
  1. .I $D(IBLIST) S K=0 D
  1. ..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)
  1. ..Q
  1. .I $D(NEWLIST) S NODE="",K=0 D
  1. ..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)
  1. ..Q
  1. S (IBDCNT,IBDCNT1,VALMCNT)=0
  1. S IBDLSTNM=$P(^IBE(357.2,IBLIST,0),"^",1) D INTER D
  1. .S IBLSNODE=$G(^IBE(357.2,IBLIST,0))
  1. .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
  1. Q:$$LSTDESCR^IBDFU1(.IBLIST) 1
  1. S IBRTN=IBLIST("RTN")
  1. D RTNDSCR^IBDFU1B(.IBRTN)
  1. Q
  1. ;
  1. SETARR ; -- Set up Listman array
  1. N IBDFNODE
  1. S IBDFNODE=IBDFARR
  1. S IBDFSEL=$P(IBDFNODE,"^",4)
  1. S IBDCNT=IBDCNT+1,VALMCNT=VALMCNT+1
  1. S X=""
  1. S IBDFVAL=$P(IBDFNODE,"^",1)
  1. S X=$$SETSTR^VALM1(IBDFVAL,X,7,7)
  1. S IBDFVAL=$P(IBDFNODE,"^",6)
  1. S X=$$SETSTR^VALM1(IBDFVAL,X,16,5)
  1. S IBDFVAL=$P(IBDFNODE,"^",2)
  1. S X=$$SETSTR^VALM1(IBDFVAL,X,23,40)
  1. S IBDFVAL=$P(^IBE(357.4,$P(IBDFNODE,"^",5),0),"^",1)
  1. S X=$$SETSTR^VALM1(IBDFVAL,X,64,15)
  1. TMP ; -- Set up TMP Array
  1. S ^TMP("GRP",$J,IBDCNT,0)=X,^TMP("GRP",$J,"IDX",VALMCNT,IBDCNT1)=IBDFSEL
  1. 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)
  1. Q
  1. S IBDCNT1=IBDCNT1+1
  1. S IBDCNT=IBDCNT+1,VALMCNT=VALMCNT+1
  1. S X=""
  1. S IBDVAL=$S($P(IBDFARR,"^",2)]"":$P(IBDFARR,"^",2),1:"BLANK")
  1. S IBDFHDR(IBDVAL)=IBDCNT1_"^"_$P(IBDFARR,"^",5)
  1. S IBDFSEL=$P(IBDFARR,"^",5)
  1. S X=$$SETSTR^VALM1(IBDCNT1_")",X,1,5) D TMP
  1. S X="",IBDCNT=IBDCNT+1,VALMCNT=VALMCNT+1
  1. S IBDVAL=$P(IBDFARR,"^",6)
  1. S X=$$SETSTR^VALM1(IBDVAL,X,16,5)
  1. S IBDVAL=$P(IBDFARR,"^",2)
  1. S IBDVAL1=$L(IBDVAL) S IBDVAL1=(80-IBDVAL1)/2 S IBDVAL1=IBDVAL1\1 S X=$$SETSTR^VALM1(" ",X,22,IBDVAL1)
  1. S X=$$SETSTR^VALM1(IBDVAL,X,IBDVAL1,25) D TMP,CNTRL^VALM10(VALMCNT,1,80,IOINHI,IOINORM,0)
  1. S X="",IBDCNT=IBDCNT+1,VALMCNT=VALMCNT+1
  1. S X=$$SETSTR^VALM1(" ",X,1,3) D TMP
  1. Q
  1. INTER ; -- Find Package interface for selection list
  1. 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)
  1. Q
  1. HELP ; -- help code
  1. S X="?" D DISP^XQORM1 W !!
  1. Q
  1. ;
  1. EXIT ; -- exit code
  1. K IBARRY,IBDFAR,IBDFARR,IBDFHDR,IBDFINT,IBDFSEL,IBDFVAL,IBDFX,IBDLSTNM,IBDVAL,IBDVAL1,IBLIST,IBRTN,IEN,IBLSNODE,DIC,IBGRP,NODE,IBDFNEW,IBDFOLD
  1. K ^TMP("SEL",$J),^TMP("SELIDX",$J)
  1. Q
  1. ;
  1. EXPND ; -- expand code
  1. Q
  1. ;
  1. GRPCOPY ; -- COPY GROUP
  1. N IBDVALM,GRP,VALMY,FROM,TO,IBDFCPYE
  1. S IBDFCPYF=1
  1. S (FROM,TO)="357.4"
  1. S VALMBCK=""
  1. D EN^VALM2($G(XQORNOD(0)))
  1. I $O(VALMY(0)) D
  1. .S IBDVALM=0
  1. .D FULL^VALM1 S VALMBCK="R"
  1. .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)
  1. K IBDFCPYF
  1. Q
  1. SELECT2() ;allows the user to select a form, then a block from it
  1. S IBBLK=""
  1. S IBFORM=$$SLCTFORM^IBDFU4(0)
  1. I IBFORM D
  1. .W !!,"NOW CHOOSE THE BLOCK TO COPY!",!
  1. .S IBBLK=$$SLCTBLK^IBDFU8(IBFORM,IOSL)
  1. Q IBBLK