source: WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCEFG.m@ 1076

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

initial load of WorldVistAEHR
File size: 6.5 KB
RevLine 
[613]1IBCEFG ;ALB/TMP - OUTPUT FORMATTER EXTRACT ;17-JAN-96
2 ;;2.0;INTEGRATED BILLING;**52,51**;21-MAR-94
3 ;
4EXTRACT(IBXFORM,IBXIEN,IBXREC,IBXPARM) ; Extract entry into global by rec #/pg/ln/col
5 ; IBXFORM (required) Form id pointer to file #353
6 ; IBXIEN (required) entry # in form's base file to output
7 ; IBXREC (optional) record # in extract file - if not defined - 1 used
8 ; IBXPARM (optional) array used to pass in specific search variables
9 ; that can be used to customize the determination
10 ; of the form field definition to use for each
11 ; form field to be extracted
12 ; IBXPARM(1) should contain a code to identify the
13 ; type of form being processed (see $$ELE^IBCEFG0 function)
14 ; Returns total # of bytes of data extracted if extract successful
15 ; or 0 if extract not successful
16 ;
17 N IBXPG,IBXLN,IBXCOL,IBXERR,IBXF,IBXFILE,IBX2,IBXSIZE
18 S IBXERR="" S:$G(IBXREC)="" IBXREC=1
19 I $G(IBXFORM)=""!($G(IBXIEN)="") S IBXERR="Missing Parameters" G EXTQ
20 K ^TMP("IBXDATA",$J,IBXREC),^TMP("DIERR",$J,1),^TMP("IBXEDIT",$J)
21 ;
22 S IBX2=$G(^IBE(353,IBXFORM,2)),IBXFILE=+IBX2
23 I 'IBXFILE S IBXERR="No base file found for form "_IBXFORM G EXTQ
24 S IBXF=$S($P(IBX2,U,5):$P(IBX2,U,5),1:IBXFORM)
25 ;
26 I $G(^IBE(353,IBXFORM,"PRE"))'="" X ^("PRE") ;Entry pre-proc
27 I $G(^IBE(353,IBXFORM,"PRE"))="",$G(^IBE(353,IBXF,"PRE"))'="" X ^("PRE") ;Entry pre-proc - parent
28 G:$G(IBXERR)'="" EXTQ
29 ;
30 S IBXPG=""
31 F S IBXPG=$O(^IBA(364.6,"ASEQ",IBXF,IBXPG)) Q:IBXPG="" S IBXLN="" F S IBXLN=$O(^IBA(364.6,"ASEQ",IBXF,IBXPG,IBXLN)) Q:IBXLN="" S IBXCOL="" D G:$G(IBXERR)'="" EXTQ
32 .F S IBXCOL=$O(^IBA(364.6,"ASEQ",IBXF,IBXPG,IBXLN,IBXCOL)) Q:IBXCOL="" D Q:$G(IBXERR)'=""
33 ..S IBXDA=$O(^IBA(364.6,"ASEQ",IBXF,IBXPG,IBXLN,IBXCOL,""))
34 ..Q:'IBXDA
35 ..D DATA(IBXPG,IBXLN,IBXCOL,IBXIEN,IBXFORM,IBXDA,.IBXPARM,.IBXERR)
36 .. I $G(IBXERR)'="" S IBXERR=IBXERR_" Field: "_$P($G(^IBA(364.6,IBXDA,0)),U,10)
37 ;
38EXTQ ;
39 I $G(^IBE(353,IBXFORM,"POST"))'="" X ^("POST") ;Entry post-proc - assoc form or parent if not associated
40 I $G(^IBE(353,IBXFORM,"POST"))="",$G(^IBE(353,IBXF,"POST"))'="" X ^("POST") ;Entry post-proc - parent of associated form
41 ;
42 K IBXMAX,IBX0,IBX00,IBXARRAY,IBXDA,IBXDATA,IBXFF,IBZ,IBZ0,IBZ1
43 S:$G(IBXERR)'="" IBXSIZE=0
44 Q +$G(IBXSIZE)
45 ;
46DATA(IBXPG,IBXLN,IBXCOL,IBXIEN,IBXFORM,IBXDA,IBXPARM,IBXERR) ; Extract/Format Data Element
47 ;IBXPG,IBXLN,IBXCOL = page,line,column to extract
48 ;IBXIEN = internal entry # of entity to extract
49 ;IBXFORM = internal entry # of FORM (file 353) to use to extract data
50 ;IBXDA = ien of IB FORM SKELETON file entry to use (file 364.6)
51 ; to use to extract the data
52 ;IBXPARM = passed by reference. Array that optionally contains the
53 ; parameters to use to screen
54 ;IBXERR = passed by reference. Returned = error message if error
55 ; condition found
56 ;
57 ; If associated form fld - get 'local' fld override
58 S:'$D(IBXREC) IBXREC=1
59 S:'$D(IBXFILE) IBXFILE=+$G(^IBE(353,IBXFORM,2))
60 N IBXFF,IBX0,IBXELE,IBXARRAY,IBXZ,IBXMAX,IBXLEN,IBZ,IBZ0,IBZ1,IBX00,IBXDA0
61 S IBXFF=$$ELE^IBCEFG0(IBXDA,.IBXPARM,IBXFORM) ;Form field entry to use
62 Q:'IBXFF ;no form field definition found
63 S IBX0=$G(^IBA(364.7,IBXFF,0)) ;Form field 0-node
64 ;
65 S IBXELE=$P(IBX0,U,3) ;data element def entry to use
66 Q:'$D(^IBA(364.5,+IBXELE,0)) S IBX00=$G(^(0))
67 ;
68 S IBXARRAY=$S($G(^IBA(364.5,IBXELE,2))="":"IBXDATA",1:^(2))
69 K:IBXARRAY?1A.E!(IBXARRAY?1"^"1A.E) @IBXARRAY
70 S @IBXARRAY=$$DATA^IBCEFG0(IBXELE,IBX00,IBXFILE,IBXIEN,IBXARRAY,.IBXERR)
71 Q:$G(IBXERR)'=""
72 ;
73 I $G(^IBA(364.7,IBXFF,1))'="" S IBXZ=^(1) D Q:$G(IBXERR)'=""
74 . N IBXFF,IBXLOOP,Z
75 . F Z="IBXDA","IBXPG","IBXLN","IBXCOL","IBX0" S IBXLOOP(Z)=@Z ;Protect loop variables
76 . X IBXZ
77 . F Z="IBXDA","IBXPG","IBXLN","IBXCOL","IBX0" K @Z S @Z=IBXLOOP(Z)
78 S IBXDA0=$G(^IBA(364.6,IBXDA,0))
79 ; Check for required field
80 I $P(IBXDA0,U,13),'$G(IBXNOREQ) D Q:$G(IBXERR)'=""
81 . I $G(@IBXARRAY)="" N Z S Z=0 F S Z=$O(@IBXARRAY@(Z)) S:'Z IBXERR="No data found for required field " Q:$S('Z:1,1:$G(@IBXARRAY@(Z))'="")
82 D:'$G(IBXNOREQ) NULLCHEK
83 K IBXNOREQ
84 Q:$P(IBXDA0,U,11)!($P(IBXDA0,U,8)[".")!('$D(@IBXARRAY)) ;data no longer exists or fld not an output fld
85 ;
86 S IBXMAX=$O(@IBXARRAY@(""),-1),IBXLEN=$P(IBXDA0,U,9)
87 I IBXMAX,$P(IBXDA0,U,6),IBXMAX>$P(IBXDA0,U,6) S IBXERR="Max # lines or occurrences exceeded ("_IBXMAX_" > "_$P(IBXDA0,U,6)_") - "_$P(IBXDA0,U,10) Q:$G(IBXERR)'=""
88 I 'IBXMAX D Q
89 . D SETGBL(IBXPG,IBXLN,IBXCOL,$$FORMAT($G(@IBXARRAY),IBXLEN,$P(^IBA(364.7,IBXFF,0),U,7),IBX0),.IBXSIZE)
90 . D:$P($G(^IBE(353,IBXFORM,2)),U,2)="S" SETEDIT(IBXFORM,IBX0)
91 ;
92 S IBZ=IBXARRAY,IBZ0=$E(IBZ,1,$L(IBZ)-$S($E(IBZ,$L(IBZ))=")":1,1:0))
93 S:IBZ0["("&($P(IBZ0,"(",2)'="") IBZ0=IBZ0_"," S:IBZ0'["(" IBZ0=IBZ0_"("
94 F S IBZ=$Q(@IBZ) Q:IBZ'[IBZ0 I $QS(IBZ,$QL(IBZ)) D
95 . S IBZ1=IBXLN+$P(IBZ,IBZ0,2)-1
96 . D SETGBL(IBXPG,IBZ1,IBXCOL,$$FORMAT(@IBZ,IBXLEN,$P(^IBA(364.7,IBXFF,0),U,7),IBX0,+$P(IBZ,"(",2)),.IBXSIZE)
97 . D:$P($G(^IBE(353,IBXFORM,2)),U,2)="S" SETEDIT(IBXFORM,IBX0)
98 Q
99 ;
100FORMAT(DATA,IBXLEN,IBXPAD,IBX0,MULTI) ; Adjust length on data for field def,add prompt
101 ; DATA = the data to be output
102 ; IBXLEN = the max length of the data
103 ; IBXPAD = code for pad character
104 ; IBX0 = the 0-node of the entry in file 364.7 being formatted
105 ; MULTI = (optional)
106 ; 0 or null if a single occurrence of the data
107 ; > 0 if multiple ocurrences of the data being processed (group data)
108 ;
109 N Z
110 S Z="",$P(Z,$S($E(IBXPAD)="Z":"0",1:" "),IBXLEN+1)=""
111 S Z=$S($E(IBXPAD)="N":$E(DATA,1,IBXLEN),$E(IBXPAD,2)="L":$E(Z,1,IBXLEN-$L(DATA))_DATA,1:$E(DATA_Z,1,IBXLEN))
112 I $P(IBX0,U,4)'="" D
113 .I $S('$G(MULTI):1,1:MULTI=1) S Z=$P(IBX0,U,4)_Z Q ;Add prompt to data
114 .S Z=$J("",$L($P(IBX0,U,4)))_Z
115 I $P(IBX0,U,10),$P(IBX0,U,9)="E" S Z="["_$P(IBX0,U,10)_"] "_Z
116 Q Z
117 ;
118SETGBL(IBXPG,IBXLN,IBXCOL,VAL,IBXSIZE) ; Sets the output global
119 ;IBXPG = Form page IBXLN = Form line IBXCOL = form column
120 ;VAL = value to place at PG/LINE/COL IBXSIZE = size counter (optional)
121 ;
122 S ^TMP("IBXDATA",$J,IBXREC,IBXPG,IBXLN,IBXCOL)=VAL,IBXSIZE=$G(IBXSIZE)+$L(VAL)
123 Q
124 ;
125SETEDIT(IBFORM,IBX0) ;
126 N Z,Z0
127 Q:$P(IBX0,U,9)="D"!'$P(IBX0,U,10)
128 S Z0=$P($G(^IBA(364.5,+$P(IBX0,U,3),0)),U,6)
129 Q:Z0="" S Z0=$O(^DD(+$G(^IBE(353,IBXFORM,2)),"B",Z0,""))
130 Q:Z0=""
131 S Z=$O(^TMP("IBXEDIT",$J,$P(IBX0,U,10),""),-1)+1
132 S ^TMP("IBXEDIT",$J,$P(IBX0,U,10),Z)=Z0
133 Q
134 ;
135NULLCHEK ; Checks for no output if null, deletes variable if appropriate
136 ; Check for no output if transmit and null
137 I $P($G(^IBA(364.6,+IBXDA,0)),U,12),$P($G(^IBE(353,IBXFORM,2)),U,2)="T" D
138 . I $D(@IBXARRAY)=1 K:$G(@IBXARRAY)="" @IBXARRAY Q
139 . I $D(@IBXARRAY)>9 D
140 .. N Z
141 .. S Z=0 F S Z=$O(@IBXARRAY@(Z)) Q:'Z I $G(@IBXARRAY@(Z))="" K @IBXARRAY@(Z)
142 Q
143 ;
Note: See TracBrowser for help on using the repository browser.