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

IBDFQEA.m

Go to the documentation of this file.
  1. IBDFQEA ;ALB/CJM/MAF - ENCOUNTER FORM - BUILD FORM(editing action for group's selections list) ;06/16/95
  1. ;;3.0;AUTOMATED INFO COLLECTION SYS;**15,38,63**;APR 24, 1997;Build 80
  1. ;
  1. ;
  1. EDIT ;allows editing of an existing selection
  1. D FULL^VALM1
  1. N SEL,SUB,SLCTN,SC,NODE,OQTY,NQTY
  1. D EN^VALM2($G(XQORNOD(0)),"S")
  1. S SEL="" F S SEL=$O(VALMY(SEL)) Q:'SEL D
  1. .W !,"Editing Entry #",SEL
  1. .S SLCTN=$P($G(^TMP("SELIDX",$J,SEL)),"^",3) Q:'SLCTN
  1. .S NODE=$G(^IBE(357.3,SLCTN,0))
  1. .S IBGRP=$P(NODE,"^",4),ORD=$P(NODE,"^",5)
  1. .;re-index the record, to insure it is good
  1. .K DIK,DA S DIK="^IBE(357.3,",DA=SLCTN D IX^DIK K DIK
  1. .;edit the order of the selection - also, for placeholders, the text, then quit
  1. .I $P(NODE,"^",2) S DA=SLCTN,DIE=357.3,DR="[IBDF EDIT PLACE HOLDER]" D ^DIE K DIE,DA,DR Q
  1. .S DA=SLCTN,DIE=357.3,DR=".05;I '$P($G(^IBE(357.6,$P($G(^IBE(357.2,+IBLIST,0)),""^"",11),16)),""^"",8) S Y=""@99"";S OQTY=$P(^IBE(357.3,DA,0),""^"",9);.09;S NQTY=X;@99;S CONT=1" S CONT=0 D ^DIE K DIE,DA,DR
  1. .D CODES^IBDF4A W !
  1. .D ADD^IBDF4C W !
  1. .;add any missing subcolumns
  1. .S SC=0 F SC=1:1:8 I $G(IBLIST("SCTYPE",SC))=1 I '$D(^IBE(357.3,SLCTN,1,"B",SC)) D
  1. ..K DA,DO,DINUM,DIC
  1. ..N DLAYGO
  1. ..S DIC="^IBE(357.3,"_SLCTN_",1,",DA(1)=SLCTN,X=SC,DIC(0)="L",DLAYGO=357.3 D FILE^DICN
  1. .;now allow the user to edit editable subcolumns - CONT=0 means the user up-arrowed out, so stop
  1. .I CONT S SUB=0 F S SUB=$O(^IBE(357.3,SLCTN,1,SUB)) Q:'SUB D
  1. ..S SC=+$G(^IBE(357.3,SLCTN,1,SUB,0)) I $G(IBLIST("SCTYPE",SC))=1,$G(IBLIST("SCPIECE",SC)),$G(IBLIST("SCEDITABLE",SC)) D
  1. ...I $G(^IBE(357.3,SLCTN,1,0))="" S ^IBE(357.3,SLCTN,1,0)="^357.31IA^"
  1. ...S DIE="^IBE(357.3,"_SLCTN_",1,",DA(1)=SLCTN,DA=SUB,DR=".02;S CONT=1",CONT=0 W !!,"Editing Subcolumn "_SC_": Header="_IBLIST("SCHDR",SC)
  1. ...S IBVAL=$P($G(^IBE(357.3,SLCTN,1,SUB,0)),"^",2)
  1. ...I $G(OQTY)'=$G(NQTY) D
  1. ....S IBVAL=$P(IBVAL," x "_OQTY)_$S(NQTY>1:" x "_NQTY,1:""),DR=".02////^S X=IBVAL;I;"_DR
  1. ...I $P($G(^IBE(357.3,SLCTN,3,0)),"^",4)>0 D
  1. ....S IBVAL=$P($G(^IBE(357.3,SLCTN,1,SUB,0)),"^",2)
  1. ....S:IBVAL'["w/ mod" IBVAL=IBVAL_" w/ mod"
  1. ....S DR=".02////^S X=IBVAL;I;"_DR
  1. ...D ^DIE K DIE,DA,DR,IBVAL I 'CONT Q
  1. .D NARR^IBDF4 W !
  1. .D TERM^IBDF4 W !
  1. ;
  1. EDITEXIT ;
  1. G EXIT
  1. DELETE ;allows the user to select selections to delete
  1. D FULL^VALM1
  1. N SEL
  1. D EN^VALM2($G(XQORNOD(0)))
  1. K DA
  1. S SEL="" F S SEL=$O(VALMY(SEL)) Q:'SEL D
  1. .S DIK="^IBE(357.3,",DA=$P($G(^TMP("SELIDX",$J,SEL)),"^",3) Q:'DA
  1. .S NODE=$G(^IBE(357.3,DA,0))
  1. .S IBGRP=$P(NODE,"^",4),ORD=$P(NODE,"^",5)
  1. .Q:'$$RUSURE^IBDFU5("Selection #"_SEL)
  1. .D ^DIK
  1. .D KILL^VALM10(SEL)
  1. .I '$D(^TMP("IBDF ADDSLCTN",$J)) S ^TMP("IBDF DELETE SELECTION OPTION",$J)=1
  1. K DIK,DA
  1. G EXIT
  1. ADDSLCTN ;allows the user to add a selection to the selection group
  1. N QUIT,SUB,IBDSLCTN,IBGRP
  1. ;
  1. D FULL^VALM1
  1. S IBRTN=IBLIST("RTN")
  1. I $G(IBLIST("CLRM")) S IBLIST("EDITING CLRM")=1
  1. D RTNDSCR^IBDFU1B(.IBRTN)
  1. I IBRTN("ACTION")'=3 D NOGOOD^IBDF4 G ADDEXIT
  1. S ^TMP("IBDF ADDSLCTN",$J)=0 ;Track if the user added a selection but did not save changes. Needed for form history fields.
  1. K @IBRTN("DATA_LOCATION")
  1. S QUIT=0 F D G:QUIT EXIT W !,"Now for another!",!
  1. .I '$$DORTN^IBDFU1B(.IBRTN) S QUIT=1 D NOGOOD^IBDF4 Q
  1. .I '$D(@IBRTN("DATA_LOCATION")) S QUIT=1 Q
  1. .S DIC="^IBE(357.4,",DIC(0)="AEMN",DIC("S")="I $P(^IBE(357.4,+Y,0),""^"",3)=IBLIST" D ^DIC K DIC S:X="^" QUIT=1 Q:QUIT S IBGRP=+Y I Y<0 D Q:QUIT=1
  1. ..W !!,"A SELECTION GROUP HEADER IS REQUIRED.... The selection will not be added if none is provided....Enter '??' for a list of choices.",!!
  1. ..S DIC="^IBE(357.4,",DIC(0)="AEMN",DIC("S")="I $P(^IBE(357.4,+Y,0),""^"",3)=IBLIST" D ^DIC K DIC S IBGRP=+Y I Y<0 S QUIT=1 Q
  1. .D ADDREC^IBDF4(.QUIT,"",.IBDSLCTN) ;edits and adds the selection
  1. .I QUIT=1 D:$D(IBDSLCTN) KILL3573(IBDSLCTN)
  1. .K @IBRTN("DATA_LOCATION")
  1. ADDEXIT ;
  1. G EXIT
  1. ADDBLANK ;allows the user to add a dummy selection to the selection group
  1. ;i.e., a place holder that will not actually print a selection
  1. ;
  1. ;
  1. N IBGRP
  1. D FULL^VALM1
  1. K DIC S DIC="^IBE(357.4,",DIC(0)="AEMN",DIC("S")="I $D(^IBE(357.3,""APO"",IBLIST,+Y))" D ^DIC S IBGRP=+Y K DIC
  1. I ('$D(DIRUT))&(Y>0) D ADD^IBDF4A
  1. D INIT^IBDFQSL1
  1. S VALMBCK="R"
  1. Q
  1. ;To kill incomplete entries in ^IBE(357.3
  1. KILL3573(IBDSEL) ;
  1. N DA,DIK
  1. S DA=IBDSEL,DIK="^IBE(357.3," D ^DIK K DIK ;D BLKCHNG^IBDF19(IBFORM,IBBLK)
  1. Q
  1. FORMAT ;allows the user to format all of the selections in the group in mass
  1. ;
  1. D FORMAT^IBDF9A1
  1. G EXIT
  1. ;
  1. GRPDEL ; -- Group Delete
  1. N GRP,IBDSEL
  1. D FULL^VALM1
  1. S IBDSEL=0
  1. I $O(^IBE(357.3,"C",IBLIST,"")) S IBDSEL=1 ;Group has selections.
  1. S DIC="^IBE(357.4,",DIC(0)="AEMN",DIC("S")="I $P(^IBE(357.4,+Y,0),""^"",3)=IBLIST" D ^DIC K DIC S IBGRP=+Y I Y<0 G EXIT
  1. S GRP=+Y
  1. Q:'$$RUSURE^IBDFU5($P($G(^IBE(357.4,GRP,0)),"^"))
  1. I GRP D DELSLCTN^IBDF3 K DA S DIK="^IBE(357.4,",DA=GRP D ^DIK K DIK
  1. D IDXGRP^IBDF3
  1. I IBDSEL,'$G(^TMP("IBDF ADDSLCTN",$J)) S ^TMP("IBDF DELETE SELECTION OPTION",$J)=1 ;User deleted a group that had selections.
  1. S VALMBCK="R"
  1. D EXIT Q
  1. ;
  1. GROUPADD ; -- Add a new group to the selection list and to file 357.4.
  1. D FULL^VALM1
  1. N NAME,QUIT,GRP
  1. S QUIT=0
  1. F D D IDXGRP^IBDF3 G:QUIT EXIT
  1. .K DIR S DIR(0)="357.4,.01O",DIR("B")="" D ^DIR K DIR I $D(DIRUT) S QUIT=1 Q
  1. .S NAME=Y
  1. .K DIC,DD,DO,DINUM S DIC="^IBE(357.4,",X=NAME,DIC(0)=""
  1. .D FILE^DICN K DIC,DIE,DA
  1. .I +Y<0 W !,"Unable to create a new record!" D PAUSE^VALM1 S QUIT=1 Q
  1. .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
  1. .W !,"Now Another!",!
  1. G EXIT
  1. ;
  1. GRPEDIT ;
  1. D FULL^VALM1
  1. N DIC,DIE,DA,DR,GRP
  1. S DIC="^IBE(357.4,",DIC(0)="AEMN",DIC("S")="I $P(^IBE(357.4,+Y,0),""^"",3)=IBLIST" D ^DIC K DIC S IBGRP=+Y I Y<0 G EXIT
  1. S GRP=+Y
  1. S (DIC,DIE)="^IBE(357.4,",DA=GRP,DR=".01;.02;.04" D ^DIE
  1. I '$D(DA) D DELSLCTN^IBDF3
  1. D IDXGRP^IBDF3
  1. S VALMBCK="R"
  1. D EXIT Q
  1. Q
  1. ;
  1. EXIT D INIT^IBDFQSL1 S VALMBCK="R" I $D(^TMP("IBDF ADDSLCTN",$J)) S ^TMP("IBDF ADDSLCTN",$J)=1
  1. Q
  1. GRPRESEQ ; -- Resequence numerically or alphabetically a group
  1. ; within a block.
  1. D FULL^VALM1
  1. N DIC,GRP,IBGRP,IBGRUP
  1. Q:$$LSTDSCR2^IBDFU1(.IBLIST) 1
  1. GRP1 S DIC="^IBE(357.4,",DIC(0)="AEMN",DIC("S")="I $P(^IBE(357.4,+Y,0),""^"",3)=IBLIST" D ^DIC K DIC S IBGRUP(+Y)=+Y
  1. I Y<0&($D(IBGRUP)) D SEQUENCE^IBDF4,EXIT Q
  1. I Y<0&('$D(IBGRUP)) G EXIT
  1. G GRP1
  1. GRPRSEQ1 ; -- Resequence all groups chosen
  1. N IBGROUP,IBFLAG
  1. S IBGROUP=0,IBFLAG=1
  1. F S IBGROUP=$O(IBGRP(IBGROUP)) Q:'IBGROUP D SEQUENCE^IBDF4
  1. Q