source: cprs/branches/tmg-cprs/m_files/TMGDIS2.m@ 1548

Last change on this file since 1548 was 796, checked in by Kevin Toppenberg, 14 years ago

Initial upload

File size: 4.8 KB
Line 
1TMGDIS2 ;TMG/kst/Custom version of DIS2 ;03/25/06 ; 5/18/10 7:52am
2 ;;1.0;TMG-LIB;**1**;01/01/06
3 ;"---- Prior header below ----------
4 ;SFISC/GFT-SEARCH, TEMPLATES & COMPUTED FIELDS;4JUN2005
5 ;;22.0;VA FileMan;**6,144**;Mar 30, 1999;Build 5
6 ;
7DIS2 ;
8 ;"Purpose:
9 ;"Input: ...
10 ;"Output: TMGRESULT is set
11 ;"Results: none
12 KILL DISV
13 ;"GOTO G:'DUZ
140 IF 1=0 D
15 . N DIS,DIS0,DA,DC,DE,DJ,DL
16 . D S3^DIBT1 Q
17 IF 1=0 KILL DIRUT,DIROUT
18 IF 1=0 IF $D(DTOUT)!($D(DUOUT)) GOTO Q
19 ;"Get SORT TEMPLATE to store search into.
20 IF 1=1 SET Y=$$PREPTMPL()
21 IF +TMGRESULT=-1 GOTO TMGDONE ;"Quit from there
22 SET TMGSORTT=Y
23 IF X="",'$D(DIAR) GOTO G
24 IF Y<0,X=U GOTO TMGDONE ;"WAS Q
25 ;"IF Y<0 GOTO 0
26 IF $D(DIARU),DIARU-Y=0 DO GOTO TMGDONE ;WAS 0
27 . ;"WRITE $C(7),!,"Archivers must not store results in the default template"
28 . SET TMGRESULT="-1^""Archivers must not store results in the default template"
29 SET (DIARI,DISV)=+Y
30 SET A=$D(^DIBT(DISV,"DL"))
31 IF $D(DIS0)#2 SET ^("DL")=DIS0
32 IF $D(DA)#2 SET ^("DA")=DA
33 IF $D(DJ)#2 SET ^("DJ")=DJ
34 IF $D(DIAR),'$D(DIARU) SET $P(^DIAR(1.11,DIARC,0),U,3)=DISV
35 SET Z=-1
36 SET DIS0="^DIBT(+Y,"
37 FOR P="DIS","DA","DC","DE","DJ","DL" DO
38 . SET %Y=DIS0_""""_P_""","
39 . SET %X=P_"("
40 . DO %XY^%RCR
41 SET %X="^UTILITY($J,",%Y="^DIBT(DISV,""O"","
42 SET @(%X_"0)=U")
43 DO %XY^%RCR
44G NEW DISTXT
45 SET %X="^UTILITY($J,"
46 SET %Y="DISTXT("
47 DO %XY^%RCR
48 ;"WRITE !
49 SET Y=DI
50 DO Q
51 SET DIC=Y
52 ;Just quit. Important screening code stored in SORT TEMPLATE in 'DIS' node
53 GOTO TMGDONE ;"//kt added
54 ;
55 IF $D(SF)!$D(L)&'$D(DIAR) GOTO EN1^DIP
56 GOTO EN^DIP
57 ;
58 ;"==========================================
59TEM GOTO TEMP^TMGDIS ;"-- MOVED TO TMGDIS
60COMP GOTO COMP^TMGDIS ;"-- MOVED TO TMGDIS
61XA GOTO XA^TMGDIS ;"-- MOVED TO TMGDIS
62COLON GOTO COLON^TMGDIS ;"-- MOVED TO TMGDIS
63Q GOTO Q^TMGDIS ;"-- MOVED TO TMGDIS
64 ;"==========================================
65 ;
66 ;"X KILL O(DC)
67 ;" GOTO X^TMGDIS
68 ;
69DIS ;PUT SET LOGIC INTO DIS FOR SUBFILE
70 SET %X=""
71 FOR %Y=1:1 SET %X=$O(DIS(%X)) Q:'%X DO
72 . SET %=$S($D(DIAR(DIARF,%X)):DIAR(DIARF,%X),1:DIS(%X))
73 . IF %["X DIS(" SET %=$P(%,"X DIS(")_"X DIFG("_DIARF_","_$P(%,"X DIS(",2)
74 . SET ^DIAR(1.11,DIARC,"S",%Y,0)=%X
75 . SET ^(1)=%
76 IF %Y>1 DO
77 . SET %Y=%Y-1
78 . SET ^DIAR(1.11,DIARC,"S",0)="^1.1132^"_%Y_U_%Y
79 GOTO DIS2 ;"quit will occur there.
80 ;
81PREPTMPL() ;
82 ;"//kt added
83 ;"Purpose: Return IEN of a SORT TEMPLATE ready for use.
84 ;"Returns -1 if problem, or IEN^NAME. ALSO, X is set to NAME (or "" if unsuccessful)
85 ;"Get SORT TEMPLATE to store search into.
86 NEW TMGTMPL SET TMGTMPL=-1
87 NEW Y SET Y=+$GET(INFO("SORT IEN"))
88 IF (Y'>0)!($DATA(^DIBT(Y))=0) DO ;"Get a new record
89 . NEW DIC,X
90 . SET DIC=.401,DIC(0)="L"
91 . SET X="TMG SRCH "_$J
92 . DO ^DIC ;"Create now, or get pre-existing
93 . IF +Y'>0 DO QUIT
94 . . SET TMGRESULT="-1^Error getting SORT TEMPLATE for use."
95 IF +Y>0,$DATA(^DIBT(+Y)) DO ;"Edit existing record
96 . NEW TMGFDA,TMGMSG,TMGIEN,TMGIENS,DA,DIE
97 . SET TMGTMPL=Y
98 . NEW I SET I=0
99 . ;"Kill all but zero node of record
100 . FOR SET I=$ORDER(^DIBT(+Y,I)) QUIT:I="" KILL ^DIBT(+Y,I)
101 . NEW % DO NOW^%DTC
102 . SET DIE=.401
103 . SET DA=+Y
104 . SET DR="2///"_%_";3///"_DUZ(0)_";4///"_+TMGFILE_";5///"_DUZ_";6///"_DUZ(0)
105 . DO ^DIE
106 . ;"SET IENS=+Y_","
107 . ;"SET TMGFDA(.401,IENS,2)=%
108 . ;"SET TMGFDA(.401,IENS,3)=DUZ(0)
109 . ;"SET TMGFDA(.401,IENS,4)=+TMGFILE
110 . ;"SET TMGFDA(.401,IENS,5)=DUZ
111 . ;"SET TMGFDA(.401,IENS,6)=DUZ(0)
112 . ;"Set back new field data
113 . ;"DO FILE^DIE("K","TMGFDA","TMGMSG")
114 . ;"IF $DATA(TMGMSG("DIERROR")) DO QUIT
115 . ;". SET TMGRESULT="-1^Error editing SORT TEMPLATE: '"_$GET(TMGMSG("DIERR",1,"TEXT",1))_"'"
116 . ;". SET Y=-1
117 SET X=$PIECE(TMGTMPL,U,2)
118 QUIT TMGTMPL
119 ;
120TMGDONE QUIT
121 ;
122DELTEMPL(TMGIEN) ;
123 ;"Purpose: To delete the SORT TEMPLATE in TMGIEN
124 ;"Input: TMGIEN -- the IEN in file .401 to be deleted
125 ;"Results: 1 if success, -1 if failure
126 NEW DIE,DA,DR
127 SET DIE=.401 ;DIE="^DIBT(" ;"FILE .401
128 SET DA=TMGIEN
129 SET DR=".01///@"
130 DO ^DIE
131 QUIT ($DATA(DA)=0)
132 ;
Note: See TracBrowser for help on using the repository browser.