source: WorldVistAEHR/trunk/r/CLINICAL_REMINDERS-PXRM/PXRMEXFI.m@ 1006

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

revised back to 6/30/08 version

File size: 3.4 KB
Line 
1PXRMEXFI ; SLC/PKR/PJH - Exchange utilities for file entries.;12/21/2004
2 ;;2.0;CLINICAL REMINDERS;;Feb 04, 2005
3 ;==============================================
4DELALL(FILENUM,NAME) ;Delete all file entries named NAME.
5 N IEN,IND,LIST,MSG
6 D FIND^DIC(FILENUM,"","@","K",NAME,"*","","","","LIST","MSG")
7 I $P(LIST("DILIST",0),U,1)=0 Q
8 S IND=0
9 F S IND=$O(LIST("DILIST",2,IND)) Q:IND="" D
10 . S IEN=LIST("DILIST",2,IND)
11 . D DELETE(FILENUM,IEN)
12 Q
13 ;
14 ;==============================================
15DELETE(FILENUM,DA) ;Delete a file entry.
16 N DIK
17 S DIK=$$ROOT^DILFD(FILENUM)
18 D ^DIK
19 Q
20 ;
21 ;==============================================
22FOKTI(FILENUM) ;Check if it is ok to install/transport this FILE.
23 ;
24 ;Drugs not allowed.
25 I FILENUM=50 Q 0
26 ;
27 ;VA Generic not allowed.
28 I FILENUM=50.6 Q 0
29 ;
30 ;VA Drug Class not allowed.
31 I FILENUM=50.605 Q 0
32 ;
33 ;Lab tests not allowed.
34 I FILENUM=60 Q 0
35 ;
36 ;Radiology procedures not allowed.
37 I FILENUM=71 Q 0
38 ;
39 ;ICD9 (used in Dialogs) not allowed.
40 I FILENUM=80 Q 0
41 ;
42 ;ICD0 not allowed.
43 I FILENUM=80.1 Q 0
44 ;
45 ;CPT (used in Dialogs) not allowed.
46 I FILENUM=81 Q 0
47 ;
48 ;Order Dialogs not allowed.
49 I FILENUM=101.41 Q 0
50 ;
51 ;Orderable Items not allowed.
52 I FILENUM=101.43 Q 0
53 ;
54 ;Sites cannot create entries in GMRV VITAL TYPE.
55 I FILENUM=120.51 Q 0
56 ;
57 ;Mental Health Instruments not allowed.
58 I FILENUM=601 Q 0
59 ;
60 I FILENUM=790.404 Q 0
61 ;
62 ;If control gets to here then it is an allowed file type.
63 Q 1
64 ;
65 ;==============================================
66GETFACT(PT01,ATTR,NEWPT01,NAMECHG,EXISTS) ;Get the action for a file.
67 N ACTION,CHOICES,DIR,FILENUM,MSG,RESULT,X,Y
68 ;See if this entry is already defined.
69CHK ;
70 S NEWPT01=""
71 S (ATTR("NAME"),ATTR("PT01"))=PT01
72 S FILENUM=ATTR("FILE NUMBER")
73 I EXISTS="" S EXISTS=$$EXISTS^PXRMEXIU(FILENUM,PT01)
74 ;Check for identical file entry can be made here.
75 I EXISTS D
76 . W !!,ATTR("FILE NAME")," entry ",PT01," already EXISTS,"
77 . W !,"what do you want to do?"
78 . S CHOICES=$S(FILENUM=801.41:"CMOQS",FILENUM=811.5:"CMOQS",1:"COQS")
79 . S DIR("B")="S"
80 . S ACTION=$$GETACT^PXRMEXIU(CHOICES,.DIR)
81 E D
82 . W !!,ATTR("FILE NAME")," entry ",PT01," is NEW,"
83 . W !,"what do you want to do?"
84 . S CHOICES="CIQS"
85 . S DIR("B")="I"
86 . S ACTION=$$GETACT^PXRMEXIU(CHOICES,.DIR)
87 ;
88 I ACTION="Q" Q ACTION
89 I ACTION="C" D
90 . S NEWPT01=$$GETUNAME^PXRMEXIU(.ATTR)
91 .;Make sure the NEW .01 passes any input transforms.
92 . I NEWPT01="" S ACTION="S"
93 . E D CHK^DIE(ATTR("FILE NUMBER"),.01,"",NEWPT01,.RESULT,"MSG")
94 I $G(RESULT)="^" D G CHK
95 . D AWRITE^PXRMUTIL("MSG")
96 . K RESULT
97 ;
98 I ACTION="O" D
99 .;If the action is overwrite double check that is what the user
100 .;really wants to do.
101 . N DIROUT,DIRUT,DTOUT,DUOUT
102 . K DIR
103 . S DIR(0)="Y"_U_"A"
104 . S DIR("A")="Are you sure you want to overwrite"
105 . S DIR("B")="N"
106 . D ^DIR
107 . I $D(DIROUT)!$D(DIRUT) S Y=0
108 . I $D(DTOUT)!$D(DUOUT) S Y=0
109 . S ACTION=$S(Y:"O",1:"S")
110 ;
111 I ACTION="P" D
112 . N DIC,Y
113 . S DIC=ATTR("FILE NUMBER")
114 . S DIC(0)="AEMQ"
115 . D ^DIC
116 . I Y=-1 S ACTION="S"
117 . E S NEWPT01=$P(Y,U,2)
118 ;
119 I NEWPT01'="" S NAMECHG(ATTR("FILE NUMBER"),PT01)=NEWPT01
120 Q ACTION
121 ;
122 ;==============================================
123SETATTR(ATTR,FILE) ;Set the file attributes for the file FILE.
124 N MSG
125 S ATTR("FILE NUMBER")=FILE
126 S ATTR("FILE NAME")=$$GET1^DID(FILE,"","","NAME","","MSG")
127 ;This call gets the field length.
128 D FIELD^DID(FILE,.01,"","FIELD LENGTH","ATTR","MSG")
129 S ATTR("MIN FIELD LENGTH")=3
130 Q
131 ;
Note: See TracBrowser for help on using the repository browser.