source: cprs/branches/tmg-cprs/m_files/TMGDIS3.m@ 1742

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

Initial upload

File size: 1.4 KB
RevLine 
[796]1TMGDIS3 ;TMG/kst/Custom version of DIS3 ;03/25/06 ; 5/15/10 6:04pm
2 ;;1.0;TMG-LIB;**1**;01/01/06
3 ;"---- Prior header below --------
4DIS3 ;SFISC/SEARCH - PROGRAMMER ENTRY POINT ;12/16/93 13:16
5 ;;22.0;VA FileMan;;Mar 30, 1999
6 ;Per VHA Directive 10-93-142, this routine should not be modified.
7EN ;
8 new DIQUIET,DIFM
9 set L=$G(L)
10 set DIFM=+L
11 do CLEAN^DIEFU,INIT^DIP
12 set:$G(DIC) DIC=$G(^DIC(DIC,0,"GL"))
13 goto QER1:$G(DIC)=""
14 new DK
15 set DK=+$P($G(@(DIC_"0)")),U,2)
16 goto QER1:'DK
17 new DISV,Y
18 do
19 . new DIC,X,DIS
20 . set Y=-1,DIS=$G(DISTEMP)
21 . quit:DIS=""
22 . set X=$S($E(DIS)="[":$P($E(DIS,2,99),"]"),1:DIS)
23 . set DIC="^DIBT("
24 . set DIC(0)="Q"
25 . set DIC("S")="I '$P(^(0),U,8),$P(^(0),U,4)=DK,$P(^(0),U,5)=DUZ!'$P(^(0),U,5),$D(^(""DIS""))"
26 . do ^DIC
27 . Q
28 set DISV=+Y
29 if Y<0 set DIC="DISTEMP" goto QER
30 new DISTXT
31 set %X="^DIBT(DISV,""DIS"",",%Y="DIS("
32 do %XY^%RCR
33 set %X="^DIBT(DISV,""O"",",%Y="DISTXT("
34 do %XY^%RCR
35 kill ^DIBT(DISV,1)
36 do EN1^DIP
37 goto EXIT
38 ;"==========================================
39QER1 set DIC="DIC"
40QER do BLD^DIALOG(201,DIC)
41 do:'$G(DIQUIET) MSG^DIALOG()
42 do Q^DIP
43EXIT kill DIC,DISTEMP
44 Q
45 ;"DIALOG #201 'The input variable...is missing or invalid.'
Note: See TracBrowser for help on using the repository browser.