IBDF3 ;ALB/CJM - Edit Selection List ;11/16/92
;;3.0;AUTOMATED INFO COLLECTION SYS;**15,63**;APR 24, 1997;Build 80
;
;
EDITLIST ;expects IBBLK to be defined
N IBLIST,IBVALMBG
D FULL^VALM1
S IBVALMBG=VALMBG,VALMBCK="R"
D SELECT
I '$D(^TMP("IBDF DELETE SELECTION OPTION",$J)) S ^TMP("IBDF DELETE SELECTION OPTION",$J)=0
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 cannot 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")
.I ^TMP("IBDF DELETE SELECTION OPTION",$J)=1,'$O(^IBE(357.3,"C",IBLIST,"")) D ;Deleted all selections from Delete Group (DG) option.
..S ^TMP("IBDF DELETED ALL SELECTIONS",$J)=1
.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,IBDSEL
S VALMBCK="R"
D EN^VALM2($G(XQORNOD(0)))
S IBDSEL=0
I $O(^IBE(357.3,"C",IBLIST,"")) S IBDSEL=1 ;Check to see if block contains selection list. Needed for updating form history fields.
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
.I IBDSEL,'$G(^TMP("IBDF ADDSLCTN",$J)) S ^TMP("IBDF DELETE SELECTION OPTION",$J)=1
D IDXGRP
S VALMBCK="R"
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBDF3 5287 printed Nov 22, 2024@18:01:36 Page 2
IBDF3 ;ALB/CJM - Edit Selection List ;11/16/92
+1 ;;3.0;AUTOMATED INFO COLLECTION SYS;**15,63**;APR 24, 1997;Build 80
+2 ;
+3 ;
EDITLIST ;expects IBBLK to be defined
+1 NEW IBLIST,IBVALMBG
+2 DO FULL^VALM1
+3 SET IBVALMBG=VALMBG
SET VALMBCK="R"
+4 DO SELECT
+5 IF '$DATA(^TMP("IBDF DELETE SELECTION OPTION",$JOB))
SET ^TMP("IBDF DELETE SELECTION OPTION",$JOB)=0
+6 IF IBLIST
Begin DoDot:1
+7 if $$LSTDSCR2^IBDFU1(.IBLIST)
QUIT
+8 ;I IBLIST("DYNAMIC"),$G(IBLIST("CLRM")) D SEL^IBDFN15(.IBLIST)
+9 IF IBLIST("DYNAMIC")
IF '$GET(IBLIST("CLRM"))
WRITE !,"You cannot edit the contents of this list - it is determined at print time!"
DO PAUSE^IBDFU5
QUIT
+10 ;I '$G(IBLIST("CLRM")) D EN^VALM("IBDF DISPLAY GROUPS FOR EDIT")
+11 IF $GET(IBLIST("CLRM"))
SET IBLIST("EDITING CLRM")=1
+12 DO EN^VALM("IBDF DISPLAY GROUPS FOR EDIT")
+13 ;Deleted all selections from Delete Group (DG) option.
IF ^TMP("IBDF DELETE SELECTION OPTION",$JOB)=1
IF '$ORDER(^IBE(357.3,"C",IBLIST,""))
Begin DoDot:2
+14 SET ^TMP("IBDF DELETED ALL SELECTIONS",$JOB)=1
End DoDot:2
+15 KILL IBLIST
+16 DO UNCMPBLK^IBDF19(IBBLK)
+17 IF '$GET(IBFASTXT)
Begin DoDot:2
+18 DO IDXBLOCK^IBDFU4
+19 SET VALMBCK="R"
SET VALMBG=IBVALMBG
End DoDot:2
End DoDot:1
+20 QUIT
ONENTRY ;
+1 DO IDXGRP
+2 QUIT
ONEXIT ;
+1 KILL @VALMAR
+2 QUIT
SELECT ;
+1 ; -- dic("s") passed in from ibdfgrp
+2 SET IBLIST=""
+3 if '$GET(IBBLK)
QUIT
+4 SET DIC="^IBE(357.2,"
SET DIC(0)="EQ"
SET D="C"
SET X=IBBLK
+5 DO IX^DIC
KILL DIC
+6 if +Y>0
SET IBLIST=+Y
+7 QUIT
ADDBLANK() ;
+1 NEW IGRP
+2 SET GRP=""
FOR
SET GRP=$ORDER(^IBE(357.4,"D",IBLIST,GRP))
if 'GRP
QUIT
if $PIECE(^IBE(357.4,GRP,0),"^")="BLANK"
QUIT
+3 IF 'GRP
Begin DoDot:1
+4 KILL DIC,DD,DO,DINUM
SET DIC="^IBE(357.4,"
SET DIC(0)=""
SET X="BLANK"
SET DIC(0)=""
+5 DO FILE^DICN
KILL DIC
+6 SET GRP=$SELECT(+Y<0:"",1:+Y)
End DoDot:1
+7 IF GRP
KILL DA,DIE
SET DA=GRP
SET DIE="^IBE(357.4,"
SET DR=".02////0;.03////"_IBLIST
DO ^DIE
KILL DIE,DA,DR
+8 QUIT GRP
IDXGRP ;build an index of groups in print order for list processor
+1 NEW GRP,GRPODR
+2 KILL @VALMAR
+3 SET VALMCNT=0
+4 SET GRPODR=""
FOR
SET GRPODR=$ORDER(^IBE(357.4,"APO",IBLIST,GRPODR))
if GRPODR=""
QUIT
Begin DoDot:1
+5 SET GRP=""
FOR
SET GRP=$ORDER(^IBE(357.4,"APO",IBLIST,GRPODR,GRP))
if 'GRP
QUIT
Begin DoDot:2
+6 ;
+7 ;make sure the index is correct
+8 IF $PIECE($GET(^IBE(357.4,GRP,0)),"^",3)'=IBLIST
KILL DIK,DA
SET DIK="^IBE(357.4,"
SET DA=GRP
DO IX^DIK
KILL DIK,DA,^IBE(357.4,"APO",IBLIST,GRPODR,GRP)
QUIT
+9 ;
+10 SET VALMCNT=VALMCNT+1
+11 SET @VALMAR@(VALMCNT,0)=$$DISPLAY(GRP,VALMCNT)
SET @VALMAR@("IDX",VALMCNT,VALMCNT)=GRP
+12 ;set video for ID column
DO FLDCTRL^VALM10(VALMCNT,"ID")
End DoDot:2
End DoDot:1
+13 QUIT
LMGRPHDR ;sets the screen hdr
+1 SET VALMHDR(1)="PRINT GROUPS CURRENTLY DEFINED FOR '"_$$LISTNAME_"' SELECTION LIST"
+2 QUIT
DISPLAY(GRP,ROW) ;
+1 NEW NODE0,NAME,INV
+2 SET NODE0=$GET(^IBE(357.4,GRP,0))
SET NAME=$PIECE(NODE0,"^")
SET INV=$PIECE(NODE0,"^",4)
+3 IF NAME="BLANK"
SET NAME="*i BLANK (Not Displayed)"
+4 IF NAME'="BLANK"
IF INV="I"
SET NAME="*i "_NAME
+5 IF NAME'="BLANK"
IF INV'="I"
SET NAME=" "_NAME
+6 QUIT $$PADRIGHT^IBDFU(ROW,6)_$JUSTIFY($PIECE(NODE0,"^",2),6)_$JUSTIFY("",3)_$$PADRIGHT^IBDFU(NAME,40)_$JUSTIFY($$SLCTNCNT(GRP),6)_" selection(s)"
SLCTNCNT(GRP) ;
+1 NEW CNT,SLCTN
+2 SET CNT=0
SET SLCTN=""
+3 FOR
SET SLCTN=$ORDER(^IBE(357.3,"D",GRP,SLCTN))
if 'SLCTN
QUIT
SET CNT=CNT+1
+4 QUIT CNT
LISTNAME() ;
+1 QUIT $PIECE($GET(^IBE(357.2,IBLIST,0)),"^",1)
ADDGRP ;
+1 NEW NAME,QUIT,GRP
+2 SET QUIT=0
+3 FOR
Begin DoDot:1
+4 KILL DIR
SET DIR(0)="357.4,.01O"
SET DIR("B")=""
DO ^DIR
KILL DIR
IF $DATA(DIRUT)
SET QUIT=1
QUIT
+5 SET NAME=Y
+6 KILL DIC,DD,DO,DINUM
SET DIC="^IBE(357.4,"
SET X=NAME
SET DIC(0)=""
+7 DO FILE^DICN
KILL DIC,DIE,DA
+8 IF +Y<0
WRITE !,"Unable to create a new record!"
DO PAUSE^VALM1
SET QUIT=1
QUIT
+9 IF +Y>0
KILL DA
SET DA=+Y
SET DIE="^IBE(357.4,"
SET DIE("NO^")="Any value"
SET DR=".02;.04;.03////"_IBLIST
DO ^DIE
KILL DIC,DIE,DR,DA
+10 WRITE !,"Now Another!",!
End DoDot:1
if QUIT
QUIT
+11 DO IDXGRP
+12 SET VALMBCK="R"
+13 QUIT
+14 ;
ADDEMPTY ;adds a blank group - a place holder that takes up space on the form
+1 ;
+2 NEW ORDER,QUIT,GRP
+3 SET QUIT=0
+4 FOR
Begin DoDot:1
+5 KILL DIR
SET DIR(0)="357.4,.02O"
SET DIR("B")=""
DO ^DIR
KILL DIR
IF (Y="")!$DATA(DIRUT)
SET QUIT=1
QUIT
+6 SET ORDER=Y
+7 KILL DIC,DD,DO,DINUM
SET DIC="^IBE(357.4,"
SET X=" "
SET DIC(0)=""
+8 DO FILE^DICN
KILL DIC,DIE,DA
+9 IF +Y<0
WRITE !,"Unable to create a new group record!"
DO PAUSE^VALM1
SET QUIT=1
QUIT
+10 IF +Y>0
KILL DA
SET DA=+Y
SET DIE="^IBE(357.4,"
SET DIE("NO^")="Any value"
SET DR=".02////"_ORDER_";.03////"_IBLIST
DO ^DIE
KILL DIC,DIE,DR,DA
+11 WRITE !,"Now Another!",!
End DoDot:1
if QUIT
QUIT
+12 DO IDXGRP
+13 SET VALMBCK="R"
+14 QUIT
EDTSLCTN ;
+1 NEW SEL,IBGRP
SET SEL=""
+2 IF $GET(VALMCNT)
Begin DoDot:1
+3 DO EN^VALM2($GET(XQORNOD(0)),"S")
+4 SET SEL=$ORDER(VALMY(""))
End DoDot:1
+5 IF SEL=""
Begin DoDot:1
+6 SET IBGRP=$$ADDBLANK
if 'IBGRP
QUIT
End DoDot:1
+7 IF '$TEST
SET IBGRP=$GET(@VALMAR@("IDX",SEL,SEL))
+8 if IBGRP
DO SLCTNS^IBDF4
DO IDXGRP
+9 SET VALMBCK="R"
+10 QUIT
EDITGRP ;
+1 NEW SEL,GRP
+2 SET VALMBCK="R"
+3 DO EN^VALM2($GET(XQORNOD(0)),"S")
+4 SET SEL=""
FOR
SET SEL=$ORDER(VALMY(SEL))
if 'SEL
QUIT
Begin DoDot:1
+5 SET GRP=$GET(@VALMAR@("IDX",SEL,SEL))
+6 if GRP
Begin DoDot:2
+7 KILL DIE,DA
SET DIE=357.4
SET DA=GRP
SET DR=".01;.02;.04"
DO ^DIE
+8 IF '$DATA(DA)
DO DELSLCTN
+9 KILL DIE,DA,DR,DIC
End DoDot:2
End DoDot:1
+10 DO IDXGRP
+11 SET VALMBCK="R"
+12 QUIT
DELSLCTN ;deletes a group's selections
+1 NEW SLCTN
+2 SET SLCTN=""
SET DIK="^IBE(357.3,"
+3 FOR
SET SLCTN=$ORDER(^IBE(357.3,"D",GRP,SLCTN))
if 'SLCTN
QUIT
IF $PIECE($GET(^IBE(357.3,SLCTN,0)),"^",4)=GRP
KILL DA
SET DA=SLCTN
DO ^DIK
+4 KILL DIK,DA
+5 QUIT
DELGRP ;delete a group and all of its selections
+1 NEW SEL,GRP,IBDSEL
+2 SET VALMBCK="R"
+3 DO EN^VALM2($GET(XQORNOD(0)))
+4 SET IBDSEL=0
+5 ;Check to see if block contains selection list. Needed for updating form history fields.
IF $ORDER(^IBE(357.3,"C",IBLIST,""))
SET IBDSEL=1
+6 SET SEL=""
FOR
SET SEL=$ORDER(VALMY(SEL))
if 'SEL
QUIT
Begin DoDot:1
+7 SET GRP=$GET(@VALMAR@("IDX",SEL,SEL))
+8 if '$$RUSURE^IBDFU5($PIECE($GET(^IBE(357.4,GRP,0)),"^"))
QUIT
+9 IF GRP
DO DELSLCTN
KILL DA
SET DIK="^IBE(357.4,"
SET DA=GRP
DO ^DIK
KILL DIK
+10 IF IBDSEL
IF '$GET(^TMP("IBDF ADDSLCTN",$JOB))
SET ^TMP("IBDF DELETE SELECTION OPTION",$JOB)=1
End DoDot:1
+11 DO IDXGRP
+12 SET VALMBCK="R"
+13 QUIT
