source: FOIAVistA/trunk/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIUPUTD.m@ 811

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

initial load of FOIAVistA 6/30/08 version

File size: 3.8 KB
Line 
1TIUPUTD ; SLC/JER - Document filer - delimited header ;5/18/94 10:21
2 ;;1.0;TEXT INTEGRATION UTILITIES;;Jun 20, 1997
3MAIN ; Controls branching
4 N TIUDA,TIUBGN,TIUI,TIUHSIG,TIULIM,TIULCNT,TIULINE,TIUREC
5 I '$D(TIUPRM0)!'$D(TIUPRM1) D SETPARM^TIULE
6 S TIUHSIG=$P(TIUPRM0,U,10),TIUBGN=$P(TIUPRM0,U,12)
7 I TIUHSIG']"" D MAIN^TIUPEVNT(DA,1) Q
8 S TIULIM=$P(TIUPRM0,U,13)
9 I TIULIM']"" D MAIN^TIUPEVNT(DA,2) Q
10 S TIUI=0 F S TIUI=$O(^TIU(8925.2,+DA,"TEXT",TIUI)) Q:+TIUI'>0 D
11 . N TIUFRST
12 . S TIULINE=$G(^TIU(8925.2,+DA,"TEXT",TIUI,0))
13 . I TIULINE[TIUHSIG D
14 . . S TIUFRST=TIUI
15 . . I +$G(TIULCNT),$D(TIUREC("TROOT")),$D(@(TIUREC("TROOT")_"0)")) D
16 . . . D SETROOT(TIULCNT,.TIUREC)
17 . . . D:$G(TIUREC("FILE"))=8925 RELEASE^TIUT(TIUREC("#"),1),UPDTIRT^TIUDIRT(.TIU,TIUREC("#"))
18 . . K TIUREC,TIU D GETREC(TIULINE,.TIUREC)
19 . . I +$G(TIUREC("#"))'>0!($G(TIUREC("ROOT"))']"") Q
20 . . D STUFREC(TIULINE,.TIUREC)
21 . . S TIUREC("TROOT")=TIUREC("ROOT")_TIUREC("#")_","_TIUREC("TEXT")_","
22 . . S:'$D(@(TIUREC("TROOT")_"0)")) @(TIUREC("TROOT")_"0)")="^^^^^"
23 . . S TIULCNT=+$P(@(TIUREC("TROOT")_"0)"),U,4)
24 . . K ^TIU(8925.2,+DA,"TEXT",TIUI,0) ; Delete header line once filed
25 . I TIULINE'[TIUHSIG,(TIULINE'[TIUBGN),$D(TIUREC("TROOT")),$D(@(TIUREC("TROOT")_"0)")) D
26 . . S TIULCNT=+$G(TIULCNT)+1,@(TIUREC("TROOT")_TIULCNT_",0)")=TIULINE
27 . . K ^TIU(8925.2,+DA,"TEXT",TIUI,0) ; Delete buffer line once xferred
28 . I TIULINE'[TIUHSIG,(TIULINE'[TIUBGN),'$D(TIUREC("TROOT")),($G(TIUREC("#"))'=-1) K ^TIU(8925.2,+DA,"TEXT",TIUI,0) ; Remove leading garbage
29 . I TIULINE[TIUBGN K ^TIU(8925.2,+DA,"TEXT",TIUI,0)
30 I +$G(TIULCNT),$D(TIUREC("TROOT")),$D(@(TIUREC("TROOT")_"0)")) D
31 . D SETROOT(TIULCNT,.TIUREC)
32 . D:$G(TIUREC("FILE"))=8925 RELEASE^TIUT(TIUREC("#"),1),UPDTIRT^TIUDIRT(.TIU,TIUREC("#"))
33 I '+$O(^TIU(8925.2,+DA,"TEXT",0)) D BUFPURGE(DA)
34 Q
35GETREC(HEADER,RECORD) ; Look-up or create record (if LAYGO allowed)
36 N DIC,DLAYGO,TIUKEY,X,Y,TIUFPRIV S TIUFPRIV=1
37 S X=$P(HEADER,TIULIM,2),DIC=8925.1,DIC(0)="MZ" D ^DIC
38 I +Y'>0 D MAIN^TIUPEVNT(DA,3) Q
39 S RECORD("TYPE")=+Y,RECORD("FILE")=$P(Y(0),U,5)
40 I RECORD("FILE")']"" D MAIN^TIUPEVNT(DA,4) Q
41 S RECORD("ROOT")=$G(^DIC(+RECORD("FILE"),0,"GL"))
42 I $P(Y(0),U,6)']"" D MAIN^TIUPEVNT(DA,5) Q
43 I $P(Y(0),U,6)]"" D
44 . S RECORD("TEXT")=$P($P(Y(0),U,6),";",2) ; Subscript of TEXT field
45 . I RECORD("TEXT")]"",'+RECORD("TEXT") S RECORD("TEXT")=""""_RECORD("TEXT")_""""
46 S:+$P(Y(0),U,3) DLAYGO=RECORD("FILE")
47 ; If a LOOKUP ROUTINE is defined for a given report type, then call it
48 I $P(Y(0),U,8)]"" D Q
49 . N TIUI,TIUVAR,TIUVPC S TIUVAR=""
50 . F S TIUVAR=$O(^TIU(8925.1,+RECORD("TYPE"),"ITEM","E",TIUVAR)) Q:TIUVAR="" D
51 . . S TIUI=+$G(TIUI)+1,TIUVAR(TIUI)=TIUVAR
52 . . S TIUVPC=$O(^TIU(8925.1,+RECORD("TYPE"),"ITEM","E",TIUVAR,0))
53 . . S @TIUVAR=$P(HEADER,TIULIM,TIUVPC)
54 . D @$P(Y(0),U,7,8) S RECORD("#")=Y I +Y'>0 D MAIN^TIUPEVNT(DA,6)
55 . S TIUI=0 F S TIUI=$O(TIUVAR(TIUI)) Q:+TIUI'>0 K @TIUVAR(TIUI)
56 ; Otherwise set-up for ^DIC call
57 S DIC=RECORD("FILE"),DIC(0)="MX"
58 S:+$P(Y(0),U,3) DIC(0)=DIC(0)_"L"
59 S TIUKEY=+$O(^TIU(8925.1,+RECORD("TYPE"),"ITEM","D",.001,0))
60 S:TIUKEY DIC(0)=DIC(0)_"N"
61 S:'TIUKEY TIUKEY=+$O(^TIU(8925.1,+RECORD("TYPE"),"ITEM","D",.01,0))
62 S X=$S(DIC(0)["N":"`",1:"")_$P(HEADER,TIULIM,TIUKEY) D ^DIC
63 S RECORD("#")=+Y I +Y'>0 D MAIN^TIUPEVNT(DA,6)
64 Q
65STUFREC(HEADER,RECORD) ; Stuffs record with known fixed fields
66 N D0,DA,DR,DIE,TIUI,TIUPC
67 S DIE=+RECORD("FILE"),DA=+RECORD("#")
68 ; Set up DR-string
69 S TIUI=0
70 F S TIUI=$O(^TIU(8925.1,+RECORD("TYPE"),"ITEM","D",TIUI)) Q:+TIUI'>0 D
71 . S TIUPC=$O(^TIU(8925.1,+RECORD("TYPE"),"ITEM","D",TIUI,0)) Q:+TIUPC'>0
72 . S:TIUI'=.001 DR=$G(DR)_$S($L($G(DR)):";",1:"")_TIUI_"///"_$P(HEADER,TIULIM,TIUPC)
73 D ^DIE
74 Q
75SETROOT(LINECNT,RECORD) ; Sets root of WP field
76 S @(RECORD("TROOT")_"0)")="^^"_LINECNT_"^"_LINECNT_"^"_DT_"^^"
77 Q
78BUFPURGE(DA) ; Call ^DIK to purge buffer record when all's well
79 N DIK S DIK="^TIU(8925.2," D ^DIK
80 Q
Note: See TracBrowser for help on using the repository browser.