source: WorldVistAEHR/trunk/r/AUTOMATED_INFO_COLLECTION_SYS-IBD/IBDFC2.m@ 1608

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

initial load of WorldVistAEHR

File size: 5.1 KB
Line 
1IBDFC2 ;ALB/CJM - ENCOUNTER FORM - converts a form for scanning ;MAR 3, 1995
2 ;;3.0;AUTOMATED INFO COLLECTION SYS;;APR 24, 1997
3 ;
4CONVERT(OLDFORM) ;
5 N IBCNVRT,IBFORM,IBDASK
6 S (IBCNVRT,IBFORM)=""
7 S IBCNVRT("BLOCK OFFSET")=0
8 ;S IBDASK("ADDOTHER")=$$ASKOTH^IBDFC2B G:IBDASK("ADDOTHER")<0 CONVQ
9 ;S IBDASK("AUTOCHG")=$$ASKAUTO^IBDFC2B G:IBDASK("AUTOCHG")<0 CONVQ
10 D COPYFORM(OLDFORM,.IBFORM,.IBCNVRT)
11 G:('IBFORM)!('IBCNVRT) CONVQ
12 D FILE357
13 G:'$$FORMDSCR^IBDFU1C(.IBFORM) CONVQ
14 D BLOCKS
15 D COMPILE^IBDF19
16 D PAGEINFO
17 ;
18CONVQ Q IBFORM
19 ;
20PAGEINFO ;determines what pages must be scanned
21 N PG,FORMTYPE,LN,TOP,BOT,IEN,NODE
22 S FORMTYPE=$P($G(^IBE(357,IBFORM,0)),"^",13) Q:'FORMTYPE
23 F PG=1:1:IBFORM("PAGES") D
24 .S TOP=(PG-1)*IBFORM("PAGE_HT"),BOT=TOP+IBFORM("PAGE_HT")
25 .S LN=$O(^IBD(357.95,FORMTYPE,1,"B",TOP-1))
26 .I 'LN!(LN>BOT) S LN=$O(^IBD(357.95,FORMTYPE,2,"B",TOP-1)) Q:'LN!(LN>BOT)
27 .;the page should be in file 357
28 .S IEN=$O(^IBE(357,IBFORM,2,"B",PG,0)) I 'IEN D
29 ..S NODE=$G(^IBE(357,IBFORM,2,0))
30 ..F IEN=+$P(NODE,"^",3)+1:1:1 Q:'$D(^IBE(357,IBFORM,2,IEN))
31 ..S $P(^IBE(357,IBFORM,2,IEN,0),"^")=PG
32 ..S ^IBE(357,IBFORM,2,"B",PG,IEN)=""
33 ..S $P(NODE,"^",2)="357.02I",$P(NODE,"^",4)=$P(NODE,"^",4)+1,$P(NODE,"^",3)=IEN,^IBE(357,IBFORM,2,0)=NODE
34 .S $P(^IBE(357,IBFORM,2,IEN,0),"^",2)=1
35 .;
36 .;the page should also be in file 357.95 (form definition)
37 .S IEN=$O(^IBD(357.95,FORMTYPE,3,"B",PG,0)) I 'IEN D
38 ..S NODE=$G(^IBD(357.95,FORMTYPE,3,0))
39 ..F IEN=+$P(NODE,"^",3)+1:1:1 Q:'$D(^IBD(357.95,FORMTYPE,3,IEN))
40 ..S $P(^IBD(357.95,FORMTYPE,3,IEN,0),"^")=PG
41 ..S ^IBD(357.95,FORMTYPE,3,"B",PG,IEN)=""
42 ..S $P(NODE,"^",2)=357.953,$P(NODE,"^",4)=$P(NODE,"^",4)+1,$P(NODE,"^",3)=IEN,^IBD(357.95,FORMTYPE,3,0)=NODE
43 .S $P(^IBD(357.95,FORMTYPE,3,IEN,0),"^",2)=1
44 Q
45 ;
46FILE357 ;
47 N NODE,FIELD,LENGTH
48 S NODE=$G(^IBE(357,IBFORM,0))
49 ;check right margin
50 S FIELD=$P(NODE,"^",9) I FIELD'=133 S $P(NODE,"^",9)=133 D:FIELD'=132 WARNING("RIGHT MARGIN CHANGED TO 133 FROM "_FIELD)
51 S (LENGTH,FIELD)=$P(NODE,"^",10) I FIELD'=80 D WARNING("PAGE LENGTH CHANGED TO 80 FROM "_LENGTH) D
52 .S $P(NODE,"^",10)=80
53 .I LENGTH<80 S IBCNVRT("BLOCK OFFSET")=80-LENGTH
54 .I LENGTH>80 S FIELD=$P(NODE,"^",11),LENGTH=(LENGTH*FIELD)+79,LENGTH=LENGTH\80 I LENGTH'=FIELD D WARNING("THE NUMBER OF PAGES CHANGED TO "_LENGTH_" FROM "_FIELD) S $P(NODE,"^",11)=LENGTH
55 S $P(NODE,"^",6)=1
56 S $P(NODE,"^",12)=1
57 S $P(NODE,"^",14)=1
58 S $P(NODE,"^",15)="p"
59 S $P(NODE,"^",16)=1
60 S $P(NODE,"^",17)=+$G(^DD(357,0,"VR")) S:$P(NODE,"^",17)<2.1 $P(NODE,"^",17)="3.0"
61 S ^IBE(357,IBFORM,0)=NODE
62 Q
63COPYFORM(OLDFORM,NEWFORM,IBCNVRT) ;
64 ;copies OLDFORM->NEWFORM and creates an entry in file 359=IBCNVRT
65 N NEWNAME,OLDNAME
66 S OLDNAME=$P($G(^IBE(357,OLDFORM,0)),"^")
67 S NEWNAME="CNV."_$E(OLDNAME,1,41)
68 S NEWFORM=$$COPYFORM^IBDFU2C(OLDFORM,357,357,NEWNAME,0)
69 S IBCNVRT=$$ADDTO359(NEWFORM,OLDFORM,OLDNAME)
70 Q
71 ;
72ADDTO359(NEWFORM,OLDFORM,OLDNAME) ;
73 ;create an entry in file 359, Converted Forms
74 N IBCNVRT,DIC
75 K DIC,DO,DA,DINUM
76 S DIC="^IBD(359,",X=NEWFORM,DIC(0)=""
77 D FILE^DICN K DIC,DIE,DA,DINUM
78 S IBCNVRT=+Y
79 Q:IBCNVRT<0 0
80 S NODE=NEWFORM_"^"_OLDFORM_"^"_OLDNAME_"^"_DT
81 S ^IBD(359,IBCNVRT,0)=NODE
82 S ^IBD(359,IBCNVRT,1,0)="^^0^0^^"
83 S DIK="^IBD(359,",DA=IBCNVRT D IX1^DIK
84 Q IBCNVRT
85 ;
86WARNING(WARNING) ;
87 ;adds the warning to file 359, entry=IBCNVRT
88 N CNT,NUM,NODE
89 S NODE=$G(^IBD(359,IBCNVRT,1,0))
90 S CNT=$P(NODE,"^",4),NUM=$P(NODE,"^",3)
91 S CNT=CNT+1,NUM=NUM+1
92 S WARNING(1)=NUM_") "_$E(WARNING,1,77-$L(CNT))
93 S WARNING(2)=$E(WARNING,77-$L(CNT),245)
94 I WARNING(2)]"" S WARNING(1)=WARNING(1)_"-",WARNING(2)=" "_WARNING(2)
95 S ^IBD(359,IBCNVRT,1,CNT,0)=WARNING(1)
96 I WARNING(2)]"" S CNT=CNT+1,^IBD(359,IBCNVRT,1,CNT,0)=WARNING(2)
97 S $P(NODE,"^",4)=CNT,$P(NODE,"^",3)=NUM,^IBD(359,IBCNVRT,1,0)=NODE
98 Q
99 ;
100BLOCKS ;loops through the blocks
101 N IBBLK,NODE,PAGE,IBLIST
102 S IBBLK=0 F S IBBLK=$O(^IBE(357.1,"C",IBFORM,IBBLK)) Q:'IBBLK D
103 .Q:$$BLKDESCR^IBDFU1B(.IBBLK)
104 .I IBBLK("NAME")="FORM NUMBER" D DLTBLK^IBDFU3(IBBLK,IBFORM,357.1) Q
105 .D UNCMPBLK^IBDF19(IBBLK)
106 .S NODE=$G(^IBE(357.1,IBBLK,0))
107 .;
108 .;if the page is bigger, shift the blocks down
109 .I IBCNVRT("BLOCK OFFSET") D
110 ..N Y
111 ..S Y=IBBLK("Y")+(IBCNVRT("BLOCK OFFSET")*IBBLK("PAGE"))
112 ..S PAGE=1+(Y\IBFORM("PAGE_HT"))
113 ..Q:PAGE'>1
114 ..S Y=IBBLK("Y")+(IBCNVRT("BLOCK OFFSET")*(PAGE-1))
115 ..S PAGE=1+(Y\IBFORM("PAGE_HT"))
116 ..S $P(NODE,"^",4)=Y,IBBLK("Y")=Y,IBBLK("PAGE")=PAGE
117 .;
118 .;does the block overlap page boundry?
119 .S PAGE=1+((IBBLK("Y")+IBBLK("H")-1)\IBFORM("PAGE_HT"))
120 .I PAGE'=IBBLK("PAGE") D WARNING("THE BLOCK '"_IBBLK("NAME")_"' OVERLAPS PAGE BOUNDRIES")
121 .;
122 .I IBBLK("X")+IBBLK("W")>133 D WARNING("THE BLOCK '"_IBBLK("NAME")_"' EXTENDS PAST THE RIGHT MARGIN")
123 .;
124 .;use reverse printing for block headers - it's new and looks good
125 .I IBBLK("BOX")=1,IBBLK("HDR")'="",IBBLK("HDISP")["U",IBBLK("HDISP")["C",IBBLK("HDISP")'["R" S $P(NODE,"^",12)="RC"
126 .
127 .S ^IBE(357.1,IBBLK,0)=NODE
128 .K NODE,PAGE,Y
129 .;
130 .;handle the selection lists
131 .S IBLIST=0 F S IBLIST=$O(^IBE(357.2,"C",IBBLK,IBLIST)) Q:'IBLIST D
132 ..Q:$$LSTDESCR^IBDFU1(.IBLIST)
133 ..I $G(IBDASK("ADDOHTER")) D ADDOTHER^IBDFC2B
134 ..D CHKVISIT^IBDFC2B
135 ..D BUBBLES^IBDFC2A(.IBLIST)
136 ..Q:$$LSTDESCR^IBDFU1(.IBLIST)
137 ..D CKVALUES^IBDFC2B
138 Q
Note: See TracBrowser for help on using the repository browser.