source: WorldVistAEHR/trunk/r/AUTOMATED_INFO_COLLECTION_SYS-IBD/IBDF9B4.m@ 1311

Last change on this file since 1311 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR

File size: 2.8 KB
Line 
1IBDF9B4 ;ALB/CJM - ENCOUNTER FORM - (edit,delete,add Hand Print fields) ;JUL 20,1994
2 ;;3.0;AUTOMATED INFO COLLECTION SYS;;APR 24, 1997
3 ;
4HFIELD ;Create, Edit, or Delete a Hand Print field from the form
5 ;
6 N IBVALMBG,QUIT
7 S IBVALMBG=VALMBG
8 S QUIT=0
9 S VALMBCK="R"
10 ;
11 F D Q:QUIT
12 .D FULL^VALM1
13 .K DIR S DIR("?",1)="You can Create, Edit, or Delete an hand print field, or Shift all of the hand print fields",DIR("?")="within a definable range either up or down."
14 .W !!,DIR("?",1),!,DIR("?"),!
15 .S DIR("B")="C",DIR(0)="SB^C:Create;E:Edit;D:Delete;S:Shift;Q:Quit",DIR("A")="[C]reate, [D]elete, [E]dit, [S]hift, [Q]uit"
16 .D ^DIR K DIR I $D(DIRUT)!(Y<0) S QUIT=1 Q
17 .I Y="Q" S QUIT=1 Q
18 .D @$S(Y="C":"NEWFLD",Y="E":"EDITFLD",Y="D":"DLTFLD",Y="S":"SHIFT",1:"")
19 .D RE^VALM4
20 S VALMBCK="R",VALMBG=IBVALMBG
21 Q
22SHIFT ;expects IBBLK to be defined - shifts all hand print fields within range supplied by user
23 D SHIFT^IBDF10("H")
24 D UNCMPBLK^IBDF19(IBBLK),IDXBLOCK^IBDFU4
25 Q
26EDITFLD ;expects IBBLK to be defined
27 N IBFIELD,RTN,NODE
28 N IBOLD,IBDELETE,IBX,IBY,IBLEN,IBTYPE ;these are used in the input template
29 D SELECT
30 I IBFIELD D
31 .D RE^VALM4
32 .S (IBX,IBY,IBLEN)=0
33 .S IBOLD=1,IBTYPE=$P($G(^IBE(359.94,IBFIELD,0)),"^",5)
34 .K DR,DIE,DA S DIE=359.94,DA=IBFIELD,DR="[IBDF EDIT HAND PRINT FIELD]",DIE("NO^")="BACKOUTOK" D ^DIE K DIE,DR,DA
35 .D UNCMPBLK^IBDF19(IBBLK),IDXBLOCK^IBDFU4
36 Q
37SELECT ;
38 S IBFIELD=0
39 Q:'$G(IBBLK)
40 I '$O(^IBE(359.94,"C",IBBLK,0)) W !,"There is no hand print field!" D PAUSE^IBDFU5 Q
41AGAIN K DIC S DIC="^IBE(359.94,",DIC(0)="EFQ",DIC("B")="",D="C",X=IBBLK
42 S DIC("S")="I $P($G(^(0)),U,8)=IBBLK"
43 D IX^DIC K DIC
44 S:+Y>0 IBFIELD=+Y
45 I 'IBFIELD,'$D(DTOUT),'$D(DUOUT) K DIR S DIR(0)="Y",DIR("A")="No hand print field selected! Try again",DIR("B")="YES" D ^DIR K DIR I '$D(DIRUT),Y=1 G AGAIN
46 Q
47DLTFLD ;expects IBBLK to be defined
48 N IBFIELD
49 D SELECT
50 I IBFIELD D
51 .Q:'$$RUSURE^IBDFU5($P($G(^IBE(359.94,IBFIELD,0)),"^"))
52 .D DLTHFLD^IBDFU3(359.94,IBBLK,IBFIELD)
53 .D UNCMPBLK^IBDF19(IBBLK),IDXBLOCK^IBDFU4
54 Q
55NEWFLD ;adds a new field, expects IBBLK to be defined
56 N NAME,FIELD,NODE,IBRTN,DLAYGO
57 N IBX,IBY,IBLEN,IBDELETE,IBOLD,IBTYPE ;these are used in the input template
58 S NAME=$$NEWNAME^IBDF9B Q:NAME=-1
59 S IBOLD=0,(IBX,IBY,IBLEN)=""
60 K DIC,DIE,DD,DO,DINUM S DIC="^IBE(359.94,",DIC(0)="FL",X=NAME,DLAYGO=359.94
61 D FILE^DICN K DIC,DIE,DA
62 S FIELD=$S(+Y<0:"",1:+Y)
63 I 'FIELD D
64 .W !,"Unable to create a new hand print field!" D PAUSE^IBDFU5
65 I FIELD D
66 .S IBDELETE=1
67 .K DIE,DA,DR S DIE=359.94,DA=FIELD,DR="[IBDF EDIT HAND PRINT FIELD]",DIE("NO^")="BACKOUTOK" D ^DIE K DIE,DR,DA,DIC
68 .I IBDELETE K DA S DIK="^IBE(359.94,",DA=FIELD D ^DIK K DIK,DA Q
69 .D UNCMPBLK^IBDF19(IBBLK),IDXBLOCK^IBDFU4
70 Q
71 ;
72LENGTHDT(TYPE) ;
73 Q:'$G(TYPE) 0
74 N NODE,LEN
75 S NODE=$G(^IBE(359.1,TYPE,0))
76 S LEN=$L($P(NODE,"^",11))
77 S:LEN LEN=LEN+1
78 S LEN=LEN+(4*$P(NODE,"^",6))
79 Q LEN
Note: See TracBrowser for help on using the repository browser.