source: WorldVistAEHR/trunk/r/AUTOMATED_INFO_COLLECTION_SYS-IBD/IBDF9A3.m@ 1279

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

initial load of WorldVistAEHR

File size: 3.3 KB
Line 
1IBDF9A3 ;ALB/CJM - ENCOUNTER FORM - (create,edit,delete selection list - continued) ;NOV 5,1994
2 ;;3.0;AUTOMATED INFO COLLECTION SYS;;APR 24, 1997
3 ;
4GETSC(ARY,LIST) ;makes a list of subcolumns having text
5 N SC,NODE
6 S SC=0 F S SC=$O(^IBE(357.2,LIST,2,SC)) Q:'SC S NODE=$G(^IBE(357.2,LIST,2,SC,0)) I $P(NODE,"^",4)=1 S ARY(+NODE)=$P(NODE,"^",5)
7 Q
8DELSC(LIST,SC) ;delete subcolumn=SC for selections on LIST
9 N SLCTN,SCIEN
10 K DA,DIK
11 S SLCTN=0 F S SLCTN=$O(^IBE(357.3,"C",LIST,SLCTN)) Q:'SLCTN S SCIEN=0 F S SCIEN=$O(^IBE(357.3,SLCTN,1,"B",SC,SCIEN)) Q:'SCIEN D
12 .I $P($G(^IBE(357.3,SLCTN,1,SCIEN,0)),"^")=SC D
13 ..S DIK="^IBE(357.3,"_SLCTN_",1,",DA(1)=SLCTN,DA=SCIEN D ^DIK
14 .E D
15 ..K ^IBE(357.3,SLCTN,1,"B",SC,SCIEN)
16 ..S DIK="^IBE(357.3,SLCTN,1,",DA(1)=SLCTN,DA=SCIEN D IX^DIK
17 K DIK,DA
18 Q
19ADDSC(LIST,SC) ;ADD subcolumn=SC for selections on LIST if not already there, else set to blank
20 N SLCTN,SCIEN ;,IBNEWSC,IBFLG
21 ;S IBNEWSC=IBSCNEW(SC)
22 ;S IBTHERE=0
23 ;F S IBTHERE=$O(IBSCOLD(IBTHERE)) Q:'IBTHERE D Q:$D(IBFLG)
24 ;.;I IBNEWSC=IBTHERE S IBFLG=1 Q
25 ;.;I IBNEWSC=3,IBTHERE=2 S IBFLG=1 Q
26 ;I $D(IBFLG) D
27 ;.;I IBTHERE=IBNEWSC W !!,"The new subcolum "_IBNEWSC_" contains the same
28 ;.;I IBTHERE=IBNEWSC W !!,"The new subcolum "_IBNEWSC_" contains the samedata as the the new subcolumn.",!,"**New subcolumn deleted**"
29 ;W "The new subcolum "_IBNEWSC_" contains the samedata as the the new subcolumn, but different subcolumn width. ** Change subcolumn width**",!,"**New subcolumn deleted**"
30 S SLCTN=0 F S SLCTN=$O(^IBE(357.3,"C",LIST,SLCTN)) Q:'SLCTN D
31 .;re-index the record, to insure it is good
32 .K DIK,DA S DIK="^IBE(357.3,",DA=SLCTN D IX^DIK
33 .S SCIEN=$O(^IBE(357.3,SLCTN,1,"B",SC,0))
34 .;
35 .;should be empty if it already exists
36 .I SCIEN S $P(^IBE(357.3,SLCTN,1,SCIEN,0),"^",2)="" Q
37 .;
38 .;it doesnt already exist, so create it
39 .K DA,DIC,DO,DINUM
40 .S DIC="^IBE(357.3,"_SLCTN_",1,",DA(1)=SLCTN,X=SC,DIC(0)="" D FILE^DICN
41 K DIC,DO,DA,DIK
42 Q
43 ;
44OTHER ;
45 N INPUT,NODE
46 S NODE=$G(^IBE(357.6,16,0))
47 S INPUT("NARRATIVE")=$P(NODE,"^"),INPUT("NARRATIVE","NAME")=$P(NODE,"^",2),INPUT("NARRATIVE","DATATYPE")=$P(NODE,"^",3),INPUT("CODE")=$P(NODE,"^",4),INPUT("CODE","NAME")=$P(NODE,"^",6),INPUT("CODE","DATATYPE")=$P(NODE,"^",7)
48 Q
49SCLOOP ; -- Looping thru the subc setting up array(type of data)=subcolumn
50 S (IBSC3,IBSC4)=0
51 F S IBSC3=$O(^IBE(357.2,IBLIST,2,"B",IBSC3)) Q:'IBSC3 F S IBSC4=$O(^IBE(357.2,IBLIST,2,"B",IBSC3,IBSC4)) Q:'IBSC4 I $P($G(^IBE(357.2,IBLIST,2,IBSC4,0)),"^",5)]"" D
52 .S IBSCRAY($P($G(^IBE(357.2,IBLIST,2,IBSC4,0)),"^",5))=$P($G(^IBE(357.2,IBLIST,2,IBSC4,0)),"^",1)
53 Q
54SCDEL ; -- Deletes the new subcolumn if there is already a column for that
55 ; type of data.
56 N DA,DIK
57 I "^1^2^3^"'[X Q
58 I IBSC1(IBSC1)'="^",X'=$P(IBSC1(IBSC1),"^",2) S X=$P(IBSC1(IBSC1),"^",2) S $P(^IBE(357.2,D0,2,D1,0),"^",5)=X D MSG1 Q
59 Q:IBSC1(IBSC1)'="^"
60 ;S DIK="^IBE(357.2,",DA=IBSC1
61 I "^1^2^3^"[X I $D(IBSCRAY(X)) D DIK Q
62 ;I X=2 I $D(IBSCRAY(3)) D DIK Q
63 ;I X=3 I $D(IBSCRAY(2)) D DIK Q
64 ;K DA,DIK Q
65 Q
66DIK ; -- KILL SUBCOLUMN GLOBAL
67 W !!,"*** SUBCOUMN "_IBSC1_" DELETED ***",!,"This data already exists in subcolumn "_IBSCRAY(X)_". Go in and edit its subcolumn number.",!!
68 S DIK="^IBE(357.2,"_D0_",2,",DA(1)=D0,DA=D1 D ^DIK
69 S IBDFFLG=1
70 ;K DA,DIK Q
71 Q
72MSG1 ;
73 W !!,"*** PREVENTING LOSS OF DATA - THIS FIELD CAN NOT BE EDITED ***",!,"You will need to add a new subcolumn to update this information",!!
74 Q
Note: See TracBrowser for help on using the repository browser.