source: FOIAVistA/trunk/r/AUTOMATED_INFO_COLLECTION_SYS-IBD/IBDFM1.m@ 1765

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

initial load of FOIAVistA 6/30/08 version
File size: 6.9 KB
Line 
1IBDFM1 ;ALB/CJM - Compiling bubbles and hand print fields;3/1/93
2 ;;3.0;AUTOMATED INFO COLLECTION SYS;**13,25,38**;APR 24, 1997
3 ;
4DRWBBL(ROW,COL,PI,VALUE,FNAME,FID,ALLOWED,DISPLAY,HDR,QLFR,DYN,CNT,SUBHDR,QTY,ND2,SLCTN) ;
5 ;returns "" if no bubble created, else the ien
6 ;
7 N BUBBLE
8 S DISPLAY=$E(DISPLAY,1,80),HDR=$E(HDR,1,40)
9 S DISPLAY=$TR(DISPLAY,"""\","``")
10 S DYN=+$G(DYN),CNT=+$G(CNT)
11 ;
12 ;don't want to associate a value with the bubble if there is no input interface for the type of data
13 I 'PI S VALUE=""
14 ;
15 ;compiling blocks?
16 I IBPRINT("COMPILING_BLOCKS") D CMPBBL Q:'IBPRINT("WRITE_IF_COMPILING")
17 ;
18 ;don't draw a bubble if in the list processor
19 Q:IBDEVICE("LISTMAN")
20 ;
21 ;add the offsets for the block to position
22 S ROW=ROW+IBBLK("Y"),COL=COL+IBBLK("X")
23 ;
24 ;might not be creating a FORM DEFINITION TABLE - case of toolkit form
25 I IBFORM("TOOLKIT") S @IBARRAY("BUBBLES")@(ROW,COL)="" Q
26 ;
27 ;case of FORM DEFINITION TABLE being created - all forms but toolkit
28 Q:IBFORM("COMPILED")="F" ;something already went wrong
29 I IBFORM("TYPE") I $D(^IBD(357.95,IBFORM("TYPE"),0))
30 E S IBFORM("TYPE")=$$NEWTABLE(.IBFORM)
31 I 'IBFORM("TYPE") D UNCMPL^IBDF19(.IBFORM,1) Q
32 ;
33 ;add the bubble to the table
34 K DIC,D0,DINUM,DD S DIC="^IBD(357.95,"_IBFORM("TYPE")_",1,",X=ROW,DA(1)=IBFORM("TYPE"),DIC(0)=""
35 D FILE^DICN K DIC,DIE,DA
36 S BUBBLE=$S(+Y<0:"",1:+Y)
37 I 'BUBBLE D UNCMPL^IBDF19(.IBFORM,1) Q
38 I BUBBLE D
39 .D INPUT^IBDFU91(PI,.VALUE) I '$D(VALUE) S VALUE=""
40 .S ^IBD(357.95,IBFORM("TYPE"),1,BUBBLE,0)=ROW_"^"_COL_"^"_PI_"^"_VALUE_"^"_$G(FNAME)_"^"_FID_"^"_ALLOWED_"^"_DISPLAY_"^"_HDR_"^"_QLFR_"^"_DYN_"^"_CNT_"^"_$G(QTY)_"^"_$G(SLCTN)
41 .I $L($G(SUBHDR)) S ^IBD(357.95,IBFORM("TYPE"),1,BUBBLE,1)=$E(SUBHDR,1,250)
42 .I $L($G(ND2)) D
43 ..; -- change external format of 2nd & 3rd codes to internal format
44 ..N IBJ,IBVAL F IBJ=3,4 S IBVAL=$P(ND2,"^",IBJ) I IBVAL]"" D INPUT^IBDFU91(PI,.IBVAL) S $P(ND2,"^",IBJ)=$S($D(IBVAL):IBVAL,1:"")
45 ..S ^IBD(357.95,IBFORM("TYPE"),1,BUBBLE,2)=ND2
46 .K DIK,DA S DIK="^IBD(357.95,"_IBFORM("TYPE")_",1,",DA=BUBBLE,DA(1)=IBFORM("TYPE") D IX1^DIK K DIK,DA
47 Q
48 ;
49NEWTABLE(IBFORM) ;creates a new FORM DEFINITION table
50 ;returns the ien of the table created, "" if not created
51 N NODE,SUB,CNT
52 S IBFORM("TYPE")=$$FORMTYPE^IBDF18D(1)
53 Q:'IBFORM("TYPE")
54 S NODE=$G(^IBE(357,IBFORM,0))
55 S $P(^IBD(357.95,IBFORM("TYPE"),0),"^",9,19)=$P(NODE,"^",9,19) ;not all 19 pieces may exist
56 S $P(^IBD(357.95,IBFORM("TYPE"),0),"^",20,21)=DT_"^"_IBFORM
57 S $P(^IBE(357,IBFORM,0),"^",13)=IBFORM("TYPE")
58 S (CNT,SUB)=0 F S SUB=$O(^IBE(357,IBFORM,2,SUB)) Q:'SUB S NODE=$G(^IBE(357,IBFORM,2,SUB,0)) Q:('+NODE)!('$P(NODE,"^",2)) S CNT=CNT+1,^IBD(357.95,IBFORM("TYPE"),3,CNT,0)=+NODE_"^1",^IBD(357.95,IBFORM("TYPE"),3,"B",+NODE,CNT)=""
59 S $P(^IBD(357.95,IBFORM("TYPE"),3,0),"^",3,4)=CNT_"^"_CNT
60 Q IBFORM("TYPE")
61 ;
62CMPBBL ;save compiled bubbles for the block
63 S IBWRTCNT("B")=IBWRTCNT("B")+1
64 S ^IBE(357.1,IBBLK,"B",IBWRTCNT("B"),0)=ROW_"^"_COL_"^"_PI_"^"_VALUE_"^"_FNAME_"^"_FID_"^"_ALLOWED_"^"_DISPLAY_"^"_HDR_"^"_QLFR_"^"_DYN_"^"_CNT_"^"_$G(QTY)_"^"_$G(SLCTN)
65 I $L($G(SUBHDR)) S ^IBE(357.1,IBBLK,"B",IBWRTCNT("B"),1)=$E(SUBHDR,1,250)
66 I $L($G(ND2)) S ^IBE(357.1,IBBLK,"B",IBWRTCNT("B"),2)=ND2
67 Q
68 ;
69CMPHAND ;save compiled hand print fields for the block
70 S IBWRTCNT("H")=IBWRTCNT("H")+1
71 S ^IBE(357.1,IBBLK,"H",IBWRTCNT("H"),0)=ROW_"^"_COL_"^"_WIDTH_"^"_PI_"^^"_LINES_"^"_FID_"^"_FNAME_"^"_HDR_"^"_QLFR_"^^"_ITEM_"^^"_PRINT_"^"_READ_"^^"_TYPEDATA
72 Q
73 ;
74DRWHAND(ROW,COL,WIDTH,PI,LINES,FID,FNAME,HDR,QLFR,ITEM,PRINT,READ,TYPEDATA) ;creates hand print field
75 N NODE
76 S NODE=""
77 ;
78 S ITEM=$G(ITEM),PRINT=$G(PRINT),READ=$G(READ),TYPEDATA=$G(TYPEDATA)
79 ;returns "" if no hand print field created, else the ien
80 Q:('$D(ROW))!('$D(COL))
81 N HANDPRNT
82 S HDR=$E(HDR,1,40)
83 ;
84 ;compiling blocks?
85 I IBPRINT("COMPILING_BLOCKS") D CMPHAND Q:'IBPRINT("WRITE_IF_COMPILING")
86 ;
87 ;don't draw hand print field if in the list processor
88 Q:IBDEVICE("LISTMAN")
89 ;
90 ;add the offsets for the block to position
91 S ROW=ROW+IBBLK("Y"),COL=COL+IBBLK("X")
92 ;
93 ;might not be creating a FORM DEFINITION TABLE - case of toolkit form
94 I IBFORM("TOOLKIT") D Q
95 .N CNT S CNT=+$G(@IBARRAY("HAND_PRINT"))+1
96 .S @IBARRAY("HAND_PRINT")@(ROW,COL,CNT)=ROW_"^"_COL_"^"_WIDTH_"^"_PI_"^"_FNAME_"^"_LINES_"^^"_FID_"^"_HDR_"^"_QLFR_"^^"_ITEM_"^^"_PRINT_"^"_READ_"^^"_TYPEDATA
97 ;
98 ;case of FORM DEFINITION TABLE being created - all forms but toolkit
99 Q:IBFORM("COMPILED")="F" ;something already went wrong
100 I IBFORM("TYPE") I $D(^IBD(357.95,IBFORM("TYPE"),0))
101 E S IBFORM("TYPE")=$$NEWTABLE(.IBFORM)
102 ;if 'IBFORM("TYPE") want to recompile this next time around
103 I 'IBFORM("TYPE") D UNCMPL^IBDF19(.IBFORM,1) Q
104 ;
105 ;add the handprint field to the table
106 K DIC,D0,DINUM,DD S DIC="^IBD(357.95,"_IBFORM("TYPE")_",2,",X=ROW,DA(1)=IBFORM("TYPE"),DIC(0)=""
107 D FILE^DICN K DIC,DIE,DA
108 S HANDPRNT=$S(+Y<0:"",1:+Y)
109 I 'HANDPRNT D UNCMPL^IBDF19(.IBFORM,1) Q
110 I HANDPRNT D
111 .S ^IBD(357.95,IBFORM("TYPE"),2,HANDPRNT,0)=ROW_"^"_COL_"^"_WIDTH_"^"_PI_"^"_FNAME_"^"_LINES_"^^"_FID_"^"_HDR_"^"_QLFR_"^^"_ITEM_"^^"_PRINT_"^"_READ_"^^"_TYPEDATA
112 .K DIK,DA S DIK="^IBD(357.95,"_IBFORM("TYPE")_",2,",DA=HANDPRNT,DA(1)=IBFORM("TYPE") D IX1^DIK K DIK,DA
113 Q
114 ;
115TRACKBBL(FID,COUNT,QLFR,PI,DISPLAY,VALUE) ;
116 ;IBPFID, the id in form tracking, should be defined
117 ;
118 ; -- do not re-file dynamic data if reprint
119 Q:$G(REPRINT)
120 ;N SUB,NODE
121 ;S NODE=$G(^IBD(357.96,IBPFID,1,0))
122 ;S SUB=$P(NODE,"^",3)
123 ;S SUB=SUB+1,$P(NODE,"^",3,4)=SUB_"^"_SUB
124 ;D INPUT^IBDFU91(PI,.VALUE) I '$D(VALUE) S VALUE=""
125 ;S ^IBD(357.96,IBPFID,1,SUB,0)=COUNT_"^^"_PI_"^"_VALUE_"^^"_FID_"^^"_DISPLAY_"^^"_QLFR
126 ;S ^IBD(357.96,IBPFID,1,0)=NODE
127 ;K DIK,DA S DIK="^IBD(357.96,IBPFID,1,",DA=SUB,DA(1)=IBPFID D IX^DIK K DIK,DA
128 ;
129 ; -- for problem list, move the narrative to one piece for storing
130 S DISPLAY=$$DISP(DISPLAY)
131 ;
132 D INPUT^IBDFU91(PI,.VALUE) I '$D(VALUE) S VALUE=""
133 S X=COUNT
134 S DLAYGO=357.96
135 S DIC="^IBD(357.96,IBPFID,1,"
136 S DIC(0)="L"
137 S DIC("P")=$P(^DD(357.96,1,0),"^",2)
138 S DA(1)=IBPFID
139 S DIC("DR")=".03////^S X=PI;.04////^S X=VALUE;.06////^S X=FID;.08////^S X=$E(DISPLAY,1,80);.1////^S X=QLFR"
140 K DD,DO D FILE^DICN K DIC,DA,DLAYGO,DD,DO
141 Q
142 ;
143DISP(DIS) ; -- display narrative :: piece
144 N I,J
145 S DIS=$E($G(DIS),1,80)
146 G:DIS="" DISPQ
147 G:DIS'[" :: " DISPQ
148 I $P(DIS," :: ",2,99)="" S DIS=$P(DIS," :: ",1) G DISPQ
149 ;
150 F I=1:1 D Q:$P(DIS," :: ",2,99)=""
151 . ;
152 . ; -- sometimes the string contains "nnnnn :: :: :: narrative"
153 . I $E(DIS,1,4)=" :: " S DIS=$E(DIS,5,80) Q
154 . ;
155 . ; -- get rid of leading spaces
156 . F J=1:1 Q:$E(DIS)'=" " S DIS=$E(DIS,2,80)
157 . ;
158 . ; -- get rid of piece one if Numeric code
159 . I +DIS>0 S DIS=$P(DIS," :: ",2,99) Q
160 . ;
161 . ; -- get rid of piece one if alpha numeric (cpt) code
162 . I +DIS=0,$P(DIS," :: ",1)?1U4N S DIS=$P(DIS," :: ",2,99) Q
163 . ;
164 . ; -- get rid of piece one if alpha numeric icd code
165 . I +DIS=0,$P(DIS," :: ",1)?1U2.3N.1".".2N S DIS=$P(DIS," :: ",2,99) Q
166 . ;
167 . ; -- must be text in piece one, use it as text
168 . I +DIS=0 S DIS=$P(DIS," :: ",1) Q
169DISPQ I DIS=" :: " S DIS="Unknown"
170 Q DIS
Note: See TracBrowser for help on using the repository browser.