source: FOIAVistA/tag/r/AUTOMATED_INFO_COLLECTION_SYS-IBD/IBDF3.m@ 636

IBDF3 ;ALB/CJM - Edit Selection List ;NOV 16,1992
 ;;3.0;AUTOMATED INFO COLLECTION SYS;**15**;APR 24, 1997
 ;
EDITLIST ;expects IBBLK to be defined
 N IBLIST,IBVALMBG
 D FULL^VALM1
 S IBVALMBG=VALMBG,VALMBCK="R"
 D SELECT
 I IBLIST D
 .Q:$$LSTDSCR2^IBDFU1(.IBLIST)
 .;I IBLIST("DYNAMIC"),$G(IBLIST("CLRM")) D SEL^IBDFN15(.IBLIST)
 .I IBLIST("DYNAMIC"),'$G(IBLIST("CLRM")) W !,"You can not edit the contents of this list - it is determined at print time!" D PAUSE^IBDFU5 Q
 .;I '$G(IBLIST("CLRM")) D EN^VALM("IBDF DISPLAY GROUPS FOR EDIT")
 .I $G(IBLIST("CLRM")) S IBLIST("EDITING CLRM")=1
 .D EN^VALM("IBDF DISPLAY GROUPS FOR EDIT")
 .K IBLIST
 .D UNCMPBLK^IBDF19(IBBLK)
 .I '$G(IBFASTXT) D
 ..D IDXBLOCK^IBDFU4
 ..S VALMBCK="R",VALMBG=IBVALMBG
 Q
ONENTRY ;
 D IDXGRP
 Q
ONEXIT ;
 K @VALMAR
 Q
SELECT ; 
 ; -- dic("s") passed in from ibdfgrp
 S IBLIST=""
 Q:'$G(IBBLK)
 S DIC="^IBE(357.2,",DIC(0)="EQ",D="C",X=IBBLK
 D IX^DIC K DIC
 S:+Y>0 IBLIST=+Y
 Q
ADDBLANK() ;
 N IGRP
 S GRP="" F  S GRP=$O(^IBE(357.4,"D",IBLIST,GRP)) Q:'GRP  Q:$P(^IBE(357.4,GRP,0),"^")="BLANK"
 I 'GRP D
 .K DIC,DD,DO,DINUM S DIC="^IBE(357.4,",DIC(0)="",X="BLANK",DIC(0)=""
 .D FILE^DICN K DIC
 .S GRP=$S(+Y<0:"",1:+Y)
 I GRP K DA,DIE S DA=GRP,DIE="^IBE(357.4,",DR=".02////0;.03////"_IBLIST D ^DIE K DIE,DA,DR
 Q GRP
IDXGRP ;build an index of groups in print order for list processor
 N GRP,GRPODR
 K @VALMAR
 S VALMCNT=0
 S GRPODR="" F  S GRPODR=$O(^IBE(357.4,"APO",IBLIST,GRPODR)) Q:GRPODR=""  D
 .S GRP="" F  S GRP=$O(^IBE(357.4,"APO",IBLIST,GRPODR,GRP)) Q:'GRP  D
 ..;
 ..;make sure the index is correct
 ..I $P($G(^IBE(357.4,GRP,0)),"^",3)'=IBLIST K DIK,DA S DIK="^IBE(357.4,",DA=GRP D IX^DIK K DIK,DA,^IBE(357.4,"APO",IBLIST,GRPODR,GRP) Q
 ..;
 ..S VALMCNT=VALMCNT+1
 ..S @VALMAR@(VALMCNT,0)=$$DISPLAY(GRP,VALMCNT),@VALMAR@("IDX",VALMCNT,VALMCNT)=GRP
 ..D FLDCTRL^VALM10(VALMCNT,"ID") ;set video for ID column
 Q
LMGRPHDR ;sets the screen hdr
 S VALMHDR(1)="PRINT GROUPS CURRENTLY DEFINED FOR '"_$$LISTNAME_"' SELECTION LIST"
 Q
DISPLAY(GRP,ROW) ;
 N NODE0,NAME,INV
 S NODE0=$G(^IBE(357.4,GRP,0)),NAME=$P(NODE0,"^"),INV=$P(NODE0,"^",4)
 I NAME="BLANK" S NAME="*i  BLANK (Not Displayed)"
 I NAME'="BLANK",INV="I" S NAME="*i  "_NAME
 I NAME'="BLANK",INV'="I" S NAME="    "_NAME
 Q $$PADRIGHT^IBDFU(ROW,6)_$J($P(NODE0,"^",2),6)_$J("",3)_$$PADRIGHT^IBDFU(NAME,40)_$J($$SLCTNCNT(GRP),6)_" selection(s)"
SLCTNCNT(GRP) ;
 N CNT,SLCTN
 S CNT=0,SLCTN=""
 F  S SLCTN=$O(^IBE(357.3,"D",GRP,SLCTN)) Q:'SLCTN  S CNT=CNT+1
 Q CNT
LISTNAME() ;
 Q $P($G(^IBE(357.2,IBLIST,0)),"^",1)
ADDGRP ;
 N NAME,QUIT,GRP
 S QUIT=0
 F  D  Q:QUIT
 .K DIR S DIR(0)="357.4,.01O",DIR("B")="" D ^DIR K DIR I $D(DIRUT) S QUIT=1 Q
 .S NAME=Y
 .K DIC,DD,DO,DINUM S DIC="^IBE(357.4,",X=NAME,DIC(0)=""
 .D FILE^DICN K DIC,DIE,DA
 .I +Y<0 W !,"Unable to create a new record!" D PAUSE^VALM1 S QUIT=1 Q
 .I +Y>0 K DA S DA=+Y,DIE="^IBE(357.4,",DIE("NO^")="Any value",DR=".02;.04;.03////"_IBLIST D ^DIE K DIC,DIE,DR,DA
 .W !,"Now Another!",!
 D IDXGRP
 S VALMBCK="R"
 Q
 ;
ADDEMPTY ;adds a blank group - a place holder that takes up space on the form
 ;
 N ORDER,QUIT,GRP
 S QUIT=0
 F  D  Q:QUIT
 .K DIR S DIR(0)="357.4,.02O",DIR("B")="" D ^DIR K DIR I (Y="")!$D(DIRUT) S QUIT=1 Q
 .S ORDER=Y
 .K DIC,DD,DO,DINUM S DIC="^IBE(357.4,",X=" ",DIC(0)=""
 .D FILE^DICN K DIC,DIE,DA
 .I +Y<0 W !,"Unable to create a new group record!" D PAUSE^VALM1 S QUIT=1 Q
 .I +Y>0 K DA S DA=+Y,DIE="^IBE(357.4,",DIE("NO^")="Any value",DR=".02////"_ORDER_";.03////"_IBLIST D ^DIE K DIC,DIE,DR,DA
 .W !,"Now Another!",!
 D IDXGRP
 S VALMBCK="R"
 Q
EDTSLCTN ;
 N SEL,IBGRP S SEL=""
 I $G(VALMCNT) D
 .D EN^VALM2($G(XQORNOD(0)),"S")
 .S SEL=$O(VALMY(""))
 I SEL="" D
 .S IBGRP=$$ADDBLANK Q:'IBGRP
 E  S IBGRP=$G(@VALMAR@("IDX",SEL,SEL))
 D:IBGRP SLCTNS^IBDF4,IDXGRP
 S VALMBCK="R"
 Q
EDITGRP ;
 N SEL,GRP
 S VALMBCK="R"
 D EN^VALM2($G(XQORNOD(0)),"S")
 S SEL="" F  S SEL=$O(VALMY(SEL)) Q:'SEL  D
 .S GRP=$G(@VALMAR@("IDX",SEL,SEL))
 .D:GRP
 ..K DIE,DA S DIE=357.4,DA=GRP,DR=".01;.02;.04" D ^DIE
 ..I '$D(DA) D DELSLCTN
 ..K DIE,DA,DR,DIC
 D IDXGRP
 S VALMBCK="R"
 Q
DELSLCTN ;deletes a group's selections
 N SLCTN
 S SLCTN="",DIK="^IBE(357.3,"
 F  S SLCTN=$O(^IBE(357.3,"D",GRP,SLCTN)) Q:'SLCTN  I $P($G(^IBE(357.3,SLCTN,0)),"^",4)=GRP K DA S DA=SLCTN D ^DIK
 K DIK,DA
 Q
DELGRP ;delete a group and all of its selections
 N SEL,GRP
 S VALMBCK="R"
 D EN^VALM2($G(XQORNOD(0)))
 S SEL="" F  S SEL=$O(VALMY(SEL)) Q:'SEL  D
 .S GRP=$G(@VALMAR@("IDX",SEL,SEL))
 .Q:'$$RUSURE^IBDFU5($P($G(^IBE(357.4,GRP,0)),"^"))
 .I GRP D DELSLCTN K DA S DIK="^IBE(357.4,",DA=GRP D ^DIK K DIK
 D IDXGRP
 S VALMBCK="R"
 Q