| 1 | IBDF9B ;ALB/CJM - ENCOUNTER FORM - (edit,delete,add data fields) ;FEB 1,1993
|
|---|
| 2 | ;;3.0;AUTOMATED INFO COLLECTION SYS;;APR 24, 1997
|
|---|
| 3 | ;
|
|---|
| 4 | FIELD ;Create, Edit, or Delete a data field from the form
|
|---|
| 5 | S VALMBCK="R"
|
|---|
| 6 | D FULL^VALM1
|
|---|
| 7 | K DIR S DIR("?",1)="A DISPLAY FIELD outputs data from VISTA, MULTIPLE CHOICE FIELDS",DIR("?")="and HAND PRINT FIELDS allow input of data, LABELS are for fixed text fields"
|
|---|
| 8 | W !,DIR("?",1),!,DIR("?"),!!
|
|---|
| 9 | S DIR("B")="D",DIR(0)="SB^D:Display Field;M:Multiple Choice Field;H:Hand Print;L:Label Only",DIR("A")="Edit fields for: [D]isplay, [M]ultiple Choice, [H]and Print, [L]abel only"
|
|---|
| 10 | D ^DIR K DIR I $D(DIRUT)!(Y<0) Q
|
|---|
| 11 | I Y="M" D MFIELD^IBDF9B2 Q
|
|---|
| 12 | I Y="H" D HFIELD^IBDF9B4 Q
|
|---|
| 13 | I Y="L" D LABELS^IBDF9B3 Q
|
|---|
| 14 | ;
|
|---|
| 15 | N IBVALMBG,QUIT
|
|---|
| 16 | S QUIT=0
|
|---|
| 17 | S IBVALMBG=VALMBG
|
|---|
| 18 | S VALMBCK="R"
|
|---|
| 19 | ;
|
|---|
| 20 | F D Q:QUIT
|
|---|
| 21 | .D FULL^VALM1
|
|---|
| 22 | .K DIR S DIR("?",1)="You can Create, Edit, or Delete a data field, Shift all of the data fields",DIR("?")="within a range up or down, or List their locations ."
|
|---|
| 23 | .W !!,DIR("?",1),!,DIR("?"),!
|
|---|
| 24 | .S DIR("B")="C",DIR(0)="SB^C:Create;E:Edit;D:Delete;S:Shift;L:List;Q:Quit",DIR("A")="[C]reate, [D]elete, [E]dit, [S]hift, [L]ocations, [Q]uit"
|
|---|
| 25 | .D ^DIR K DIR I $D(DIRUT)!(Y<0) S QUIT=1 Q
|
|---|
| 26 | .I Y="Q" S QUIT=1 Q
|
|---|
| 27 | .D @$S(Y="C":"NEWFLD",Y="E":"EDITFLD",Y="D":"DLTFLD",Y="S":"SHIFT",Y="L":"^IBDF9B1",1:"")
|
|---|
| 28 | .D RE^VALM4
|
|---|
| 29 | S VALMBCK="R",VALMBG=IBVALMBG
|
|---|
| 30 | Q
|
|---|
| 31 | SHIFT ;expects IBBLK to be defined - shifts all fields within range supplied by user
|
|---|
| 32 | D SHIFT^IBDF10("D")
|
|---|
| 33 | D UNCMPBLK^IBDF19(IBBLK),IDXBLOCK^IBDFU4
|
|---|
| 34 | Q
|
|---|
| 35 | EDITFLD ;expects IBBLK to be defined
|
|---|
| 36 | N IBFIELD,RTN,NODE
|
|---|
| 37 | N IBMF,IBWP,IBLIST,IBI,IBOLD,IBX,IBY,IBW,IBP,IBLEN,IBDELETE ;these are used in the input template
|
|---|
| 38 | ;IBMF=1 if display interface returns records,IBWP=1 display interface returns a word processing field
|
|---|
| 39 | D SELECT
|
|---|
| 40 | I IBFIELD D
|
|---|
| 41 | .D RE^VALM4
|
|---|
| 42 | .S (IBMF,IBLIST,IBWP)=0,IBOLD=1,(IBX,IBY)=""
|
|---|
| 43 | .S RTN=$P($G(^IBE(357.5,IBFIELD,0)),"^",3)
|
|---|
| 44 | .I RTN D DATATYPE(RTN)
|
|---|
| 45 | .K DR,DIE,DA S DIE=357.5,DA=IBFIELD,DR="[IBDF EDIT DATA FIELD]",DIE("NO^")="BACKOUTOK" D ^DIE K DIE,DR,DA
|
|---|
| 46 | .D UNCMPBLK^IBDF19(IBBLK),IDXBLOCK^IBDFU4
|
|---|
| 47 | Q
|
|---|
| 48 | SELECT ;
|
|---|
| 49 | S IBFIELD=0
|
|---|
| 50 | Q:'$G(IBBLK)
|
|---|
| 51 | I '$O(^IBE(357.5,"C",IBBLK,0)) W !,"There is no data field!" D PAUSE^IBDFU5 Q
|
|---|
| 52 | AGAIN K DIC S DIC="^IBE(357.5,",DIC(0)="EFQ",DIC("B")="",D="C",X=IBBLK
|
|---|
| 53 | S DIC("S")="I $P(^(0),U,2)=IBBLK,+$P(^(0),U,3)>0"
|
|---|
| 54 | D IX^DIC K DIC
|
|---|
| 55 | S:+Y>0 IBFIELD=+Y
|
|---|
| 56 | I 'IBFIELD,'$D(DTOUT),'$D(DUOUT) K DIR S DIR(0)="Y",DIR("A")="No data field selected! Try again",DIR("B")="YES" D ^DIR K DIR I '$D(DIRUT),Y=1 G AGAIN
|
|---|
| 57 | Q
|
|---|
| 58 | DLTFLD ;expects IBBLK to be defined
|
|---|
| 59 | N IBFIELD
|
|---|
| 60 | D SELECT
|
|---|
| 61 | I IBFIELD D
|
|---|
| 62 | .Q:'$$RUSURE^IBDFU5($P($G(^IBE(357.5,IBFIELD,0)),"^"))
|
|---|
| 63 | .D DLTFLD^IBDFU3(357.5,IBBLK,IBFIELD)
|
|---|
| 64 | .D UNCMPBLK^IBDF19(IBBLK),IDXBLOCK^IBDFU4
|
|---|
| 65 | Q
|
|---|
| 66 | NEWFLD ;adds a new field, expects IBBLK to be defined
|
|---|
| 67 | N NAME,FIELD,NODE,IBRTN,DLAYGO
|
|---|
| 68 | N IBX,IBY,IBLIST,IBLEN,IBWP,IBMF,IBW,IBP,IBDELETE,IBOLD ;these are used in the input template
|
|---|
| 69 | S NAME=$$NEWNAME Q:NAME=-1
|
|---|
| 70 | S IBRTN=$$LOOKUP Q:'IBRTN
|
|---|
| 71 | S IBOLD=0,(IBX,IBY)=""
|
|---|
| 72 | K DIC,DIE,DD,DO,DINUM S DIC="^IBE(357.5,",DIC(0)="FL",X=NAME,DLAYGO=357.5
|
|---|
| 73 | D FILE^DICN K DIC,DIE,DA
|
|---|
| 74 | S FIELD=$S(+Y<0:"",1:+Y)
|
|---|
| 75 | I 'FIELD D
|
|---|
| 76 | .W !,"Unable to create a new data field!" D PAUSE^IBDFU5
|
|---|
| 77 | I FIELD D
|
|---|
| 78 | .S IBDELETE=1
|
|---|
| 79 | .K DIE,DA,DR S DIE=357.5,DA=FIELD,DR="[IBDF EDIT DATA FIELD]",DIE("NO^")="BACKOUTOK" D ^DIE K DIE,DR,DA,DIC
|
|---|
| 80 | .I IBDELETE K DA S DIK="^IBE(357.5,",DA=FIELD D ^DIK K DIK,DA Q
|
|---|
| 81 | .D UNCMPBLK^IBDF19(IBBLK),IDXBLOCK^IBDFU4
|
|---|
| 82 | Q
|
|---|
| 83 | NEWNAME() ;
|
|---|
| 84 | K DIR S DIR(0)="357.5,.01A",DIR("A")="New Field Name: ",DIR("B")=""
|
|---|
| 85 | D ^DIR K DIR I $D(DIRUT) Q -1
|
|---|
| 86 | Q Y
|
|---|
| 87 | ;
|
|---|
| 88 | DATATYPE(RTN) ;
|
|---|
| 89 | ;INPUT - RTN is a ptr to the package interface file
|
|---|
| 90 | ;
|
|---|
| 91 | ;OUTPUT - IBLEN() stores the lengths of the pieces of the record returned by the package interface
|
|---|
| 92 | ;IBLIST=1 if list,IBMF=1 if record, IBWP=1 if word processing
|
|---|
| 93 | ;
|
|---|
| 94 | N IBSUB,NODE,DATATYPE
|
|---|
| 95 | S (IBMF,IBWP,IBLIST)=0
|
|---|
| 96 | Q:'$G(RTN)
|
|---|
| 97 | S DATATYPE=$P($G(^IBE(357.6,RTN,0)),"^",7) S:DATATYPE=5 IBWP=1 S:(DATATYPE=2)!(DATATYPE=4) IBMF=1 S:(DATATYPE=3)!(DATATYPE=4) IBLIST=1
|
|---|
| 98 | I 'IBWP D
|
|---|
| 99 | .N IEN
|
|---|
| 100 | .S IEN=0 F S IEN=$O(^IBE(357.6,RTN,15,"C",IEN)) Q:'IEN S NODE=$G(^IBE(357.6,RTN,15,IEN,0)) I $P(NODE,"^",3) S IBLEN($P(NODE,"^",3))=+$P(NODE,"^",2)
|
|---|
| 101 | .S IBLEN(1)=$P($G(^IBE(357.6,RTN,2)),"^",2)
|
|---|
| 102 | Q
|
|---|
| 103 | ;
|
|---|
| 104 | LOOKUP() ;does a lookup on the package interface file using the E cross-reference, which uses the name with the prefix=namespace removed
|
|---|
| 105 | K DIC S DIC("S")="I $P(^(0),U,6)=2,$P(^(0),U,9)=1"
|
|---|
| 106 | S DIC="^IBE(357.6,",DIC(0)="MQEA",D="E^D^B",DIC("A")="Select the TYPE OF DATA that should be displayed:" D MIX^DIC1 K DIC,DA,D
|
|---|
| 107 | Q $S((Y<0)!$D(DTOUT)!$D(DUOUT):0,1:+Y)
|
|---|
| 108 | ;
|
|---|
