IBDF3.m

IBDF3 ;ALB/CJM - ENCOUNTER FORM - EDIT SELECTION LIST ;NOV 16,1992

 ;;3.0;AUTOMATED INFO COLLECTION SYS;;APR 24, 1997

 ;

EDITLIST ;expects IBBLK to be defined

 N IBLIST,IBVALMBG

 S IBVALMBG=VALMBG,VALMBCK="R"

 D SELECT

 I IBLIST D

 .Q:$$LSTDSCR2^IBDFU1(.IBLIST)

 .I IBLIST("DYNAMIC") W !,"You can not edit the contents of this list - it is determined at print time!" D PAUSE^IBDFU5 Q

 .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

IBDF3     ;ALB/CJM - ENCOUNTER FORM - EDIT SELECTION LIST ;NOV 16,1992

 +1       ;;3.0;AUTOMATED INFO COLLECTION SYS;;APR 24, 1997

 +2       ;

EDITLIST  ;expects IBBLK to be defined

 +1        NEW IBLIST,IBVALMBG

 +2        SET IBVALMBG=VALMBG

           SET VALMBCK="R"

 +3        DO SELECT

 +4        IF IBLIST

               Begin DoDot:1

 +5                IF $$LSTDSCR2^IBDFU1(.IBLIST)

                       QUIT 

 +6                IF IBLIST("DYNAMIC")

                       WRITE !,"You can not edit the contents of this list - it is determined at print time!"

                       DO PAUSE^IBDFU5

                       QUIT 

 +7                DO EN^VALM("IBDF DISPLAY GROUPS FOR EDIT")

 +8                KILL IBLIST

 +9                DO UNCMPBLK^IBDF19(IBBLK)

 +10               IF '$GET(IBFASTXT)

                       Begin DoDot:2

 +11                       DO IDXBLOCK^IBDFU4

 +12                       SET VALMBCK="R"

                           SET VALMBG=IBVALMBG

                       End DoDot:2

               End DoDot:1

 +13       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

 +2        SET VALMBCK="R"

 +3        DO EN^VALM2($GET(XQORNOD(0)))

 +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 '$$RUSURE^IBDFU5($PIECE($GET(^IBE(357.4,GRP,0)),"^"))

                       QUIT 

 +7                IF GRP

                       DO DELSLCTN

                       KILL DA

                       SET DIK="^IBE(357.4,"

                       SET DA=GRP

                       DO ^DIK

                       KILL DIK

               End DoDot:1

 +8        DO IDXGRP

 +9        SET VALMBCK="R"

 +10       QUIT