source: FOIAVistA/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORCMEDT4.m@ 1535

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

initial load of FOIAVistA 6/30/08 version

File size: 8.1 KB
Line 
1ORCMEDT4 ;SLC/MKB-Prompt Editor ;6/19/01 15:05
2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**8,46,95,245**;Dec 17, 1997;Build 2
3EN ; -- Enter/edit prompts
4 N PRMT F S PRMT=+$$PROMPT Q:PRMT'>0 D W !
5 . I $P($G(^ORD(101.41,PRMT,0)),U,7)=$O(^DIC(9.4,"C","OR",0)) D Q
6 . . N DIC,DA S DIC="^ORD(101.41,",DA=PRMT D EN^DIQ
7 . . W !,"This prompt is not editable!"
8 . D EDIT(PRMT)
9 Q
10 ;
11EDIT(DA) ; -- Edit prompt DA
12 N DR,DIE,NAME,TEXT,TYPE,DOMAIN,OR0,OR1,ORP
13 Q:'$G(DA) S OR0=$G(^ORD(101.41,DA,0)),OR1=$G(^(1)),ORP=DA
14 S NAME=$$NAME(DA) Q:(NAME="@")!(NAME="^") ;deleted or quit
15 S TEXT=$$DTEXT($P(OR0,U,2)) Q:TEXT="^"
16 S TYPE=$$DATATYPE($P(OR1,U)) Q:TYPE="^" S DOMAIN=$P(OR1,U,2)
17 D @$S(TYPE="D"!(TYPE="R"):"DATE",TYPE="F":"TEXT",TYPE="N":"NMBR",TYPE="P":"PTR",TYPE="S":"SET",1:"OTHER") Q:DOMAIN="^"
18 S $P(^ORD(101.41,DA,1),U,1,2)=TYPE_U_DOMAIN,DIE="^ORD(101.41,"
19 S DR=$S(NAME'=$P(OR0,U):".01///^S X=NAME;",1:"")_$S(TEXT'=$P(OR0,U,2):"2///^S X=TEXT;",1:"")_"20"_";13" D ^DIE ;95
20 Q
21 ;
22PROMPT() ; -- Find prompt in #101.41
23 N X,Y,DIC,DLAYGO
24 S DIC="^ORD(101.41,",DIC(0)="AEQLM",DLAYGO=101.41
25 S DIC("A")="Select PROMPT: ",DIC("S")="I $P(^(0),U,4)=""P"""
26 S DIC("DR")="4////P" D ^DIC
27 Q Y
28 ;
29NAME(IFN) ; -- Edit .01 name of dialog IFN
30 N X,Y,DIR,OLDNAME,ISPQO,NODELETE,DA,DIK,TYPE
31 S DIR(0)="FAO^3:63",DIR("A")="NAME: "
32 S OLDNAME=$P($G(^ORD(101.41,IFN,0)),U),ISPQO=0,NODELETE=1
33 S TYPE=$P($G(^ORD(101.41,IFN,0)),U,4)
34 I TYPE="Q",$E(OLDNAME,1,6)="ORWDQ " S ISPQO=1
35 I ISPQO!(TYPE="P") S NODELETE=0 ; OK to delete personal quick orders and prompts
36 S DIR("B")=OLDNAME
37 S DIR("?")="Enter a unique name, up to 63 characters in length."
38NM I $L($P($G(^ORD(101.41,IFN,0)),U,3))>0 W !,!,"(This "_$$GETITM(IFN)_" has been disabled)"
39 D ^DIR S:$D(DTOUT)!(X["^") Y="^"
40 I X="@" D G NM:X=""
41 . I $D(^ORD(101.41,"AD",IFN)) W $C(7),!,"Cannot delete - currently in use!",! S X="" Q
42 . I $$INUSE^ORCMEDT5(IFN) W $C(7),!,"Cannot delete - currently an Add Orders Menu!",! S X="" Q
43 . I NODELETE D DISABLE(IFN) S X="" Q
44 . I '$$SURE(IFN) S X="" Q ;reask
45 . N IDX1,IDX2 S IDX1=0
46 . F S IDX1=$O(^ORD(101.44,"C",IFN,IDX1)) Q:'IDX1 D
47 . . S IDX2=0
48 . . F S IDX2=$O(^ORD(101.44,"C",IFN,IDX1,IDX2)) Q:'IDX2 D
49 . . . S DA=IDX2,DA(1)=IDX1,DIK="^ORD(101.44,"_IDX1_",10," D ^DIK
50 . K DA S DA=IFN,DIK="^ORD(101.41," D ^DIK W " ...deleted." S (X,Y)="@"
51 I ISPQO,Y'="^",X'="@",Y'=OLDNAME D G NM
52 . W $C(7),!,"Cannot rename a personal quick order",!
53 Q Y
54 ;
55GETITM(DLG) ;
56 N ITM
57 S ITM=$P($G(^ORD(101.41,DLG,0)),U,4)
58 I ITM="Q",$E($P($G(^ORD(101.41,IFN,0)),U),1,6)="ORWDQ " Q "personal quick order"
59 S ITM=$S(ITM="P":"prompt",ITM="D":"dialog",ITM="Q":"quick order",ITM="O":"order set",ITM="A":"action",ITM="M":"menu",1:"item")
60 Q ITM
61 ;
62SURE(DLG) ; -- Are you sure?
63 N X,Y,DIR,ITM,DA
64 S ITM=$$GETITM(DLG)
65 S DIR(0)="YA",DIR("A")="Are you sure you want to delete this "_ITM_"? "
66 S DIR("?")="Enter YES if you want to delete this "_ITM_" from the file, or NO to quit."
67 D ^DIR
68 Q +Y
69 ;
70DISABLE(DLG) ; Disable item - return true if disabled
71 N DIR,X,Y,ITM,DA,DR,DIE,DIDEL,DISABLED
72 W $C(7),!,!,"Deletion not allowed outside of FileMan."
73 S ITM=$$GETITM(DLG)
74 S DISABLED=$L($P($G(^ORD(101.41,IFN,0)),U,3))>0
75 S DIR(0)="YA"
76 I DISABLED D I 1
77 . S DIR("A",1)="This "_ITM_" is already disabled."
78 . S DIR("A")="Would you like to edit the disable message? "
79 . S DIR("?")="Enter YES if you want to edit the disabled message, or NO to quit."
80 . S DIR("B")="NO"
81 E D
82 . S DIR("A")="Would you like to disable this "_ITM_"? "
83 . S DIR("?")="Enter YES if you want to disable this "_ITM_", or NO to quit."
84 . S DIR("B")="YES"
85 D ^DIR
86 I '+Y Q
87 W !,"Enter disable message:"
88 S DA=DLG,DR="3",DIE="^ORD(101.41,"
89 D ^DIE
90 Q
91 ;
92DTEXT(X) ; -- Enter/edit display text of prompt
93 N Y,DIR
94 S DIR(0)="FA^3:63",DIR("A")="TEXT OF PROMPT: " S:$L($G(X)) DIR("B")=X
95 S DIR("?")="Enter the text of this prompt, including any punctuation and spaces"
96 D ^DIR S:$D(DTOUT) Y="^"
97 Q Y
98 ;
99DATATYPE(X) ; -- Returns desired datatype for prompt
100 N DIR,Y S DIR("A")="TYPE OF PROMPT: "
101 S DIR(0)="SAM^D:date/time;R:relative date/time;F:free text;N:numeric;S:set of codes;P:pointer to a file;Y:yes/no;W:word processing;"
102 S:$L($G(X)) DIR("B")=$P($P(DIR(0),X_":",2),";")
103 S DIR("?")="Select the type of data to be entered at this prompt"
104 D ^DIR S:$D(DTOUT) Y="^"
105 Q Y
106 ;
107DATE ; -- date parameters
108 N X,Y,DIR,ORX,ORT,ORS,ORR
109 S X=$P(DOMAIN,":",3),ORX=X["X",ORT=X["T",ORS=X["S",ORR=X["R",DIR(0)="YA"
110 ; Still need to handle Earliest and Latest dates allowed
111 S DIR("A")="CAN DATE BE IMPRECISE? ",DIR("B")=$S(ORX:"NO",1:"YES")
112 D ^DIR S ORX='Y I $D(DUOUT)!($D(DTOUT)) S DOMAIN="^" Q
113 S DIR("A")="CAN TIME OF DAY BE ENTERED? ",DIR("B")=$S(ORT:"YES",1:"NO")
114 D ^DIR I $D(DUOUT)!($D(DTOUT)) S DOMAIN="^" Q
115 S ORT=Y I 'Y S (ORS,ORR)=0 G DQ
116 S DIR("A")="CAN SECONDS BE ENTERED? ",DIR("B")=$S(ORS:"YES",1:"NO")
117 D ^DIR S ORS=Y I $D(DUOUT)!($D(DTOUT)) S DOMAIN="^" Q
118 S DIR("A")="IS TIME REQUIRED? ",DIR("B")=$S(ORR:"YES",1:"NO")
119 D ^DIR S ORR=Y I $D(DUOUT)!($D(DTOUT)) S DOMAIN="^" Q
120DQ S DOMAIN="::E"_$S(ORX:"X",1:"")_$S(ORT:"T",1:"")_$S(ORS:"S",1:"")_$S(ORR:"R",1:"")
121 Q
122 ;
123TEXT ; -- free text
124 N X,Y,DIR
125 S DIR(0)="NAO^1:245",DIR("A")="MINIMUM LENGTH: "
126 S:+DOMAIN DIR("B")=+DOMAIN
127 D ^DIR I $D(DTOUT)!($D(DUOUT)) S DOMAIN="^" Q
128 S $P(DOMAIN,":")=Y,DIR("A")="MAXIMUM LENGTH: " K DIR("B")
129 S:$P(DOMAIN,":",2) DIR("B")=$P(DOMAIN,":",2)
130 D ^DIR I $D(DUOUT)!($D(DTOUT)) S DOMAIN="^" Q
131 S $P(DOMAIN,":",2)=Y
132 ; Opt pattern match ??
133 Q
134 ;
135NMBR ; -- numeric
136 N X,Y,DIR,STR
137 S DIR(0)="NAO^::"_+$P(DOMAIN,":",3),DIR("A")="INCLUSIVE LOWER BOUND: ",DIR("B")=+DOMAIN ;95
138 D ^DIR I $D(DTOUT)!($D(DUOUT)) S DOMAIN="^" Q
139 S STR=Y,DIR(0)="NAO^"_Y_"::"_+$P(DOMAIN,":",3),DIR("A")="INCLUSIVE UPPER BOUND: ",DIR("B")=+$P(DOMAIN,":",2) ;95
140 D ^DIR I $D(DTOUT)!($D(DUOUT)) S DOMAIN="^" Q
141 S STR=STR_":"_Y,DIR(0)="NAO",DIR("A")="MAXIMUM NUMBER OF FRACTIONAL DIGITS: ",DIR("B")=+$P(DOMAIN,":",3) ;95
142 D ^DIR I $D(DUOUT)!($D(DTOUT)) S DOMAIN="^" Q
143 S DOMAIN=STR_":"_Y
144 Q
145 ;
146PTR ; -- pointer
147 I DUZ(0)="@"!($L(DOMAIN)&'DOMAIN) D ROOT Q ; allow file root
148 N X,Y,DIR,DIE,DR,FILE,STR,SCR
149 S DIR(0)="PA^1:AEQM",DIR("A")="POINT TO WHICH FILE: "
150 S:$L(DOMAIN) DIR("B")=$$FILENAME(+DOMAIN)
151 D ^DIR I $D(DUOUT)!($D(DTOUT)) S DOMAIN="^" Q
152 S FILE=+Y,STR=$P(DOMAIN,":",2) S:'$L(STR) STR="EQ"
153 S DOMAIN=FILE_":"_STR
154 Q
155 ;
156ROOT ; -- pointer via file root
157 N X,Y,DIR,STR
158 S DIR(0)="FA^1:100",DIR("A")="POINT TO WHICH FILE: "
159 S DIR("?")="Enter the file or subfile by name, file number, or global root (without the leading '^')."
160 S:$L(DOMAIN) DIR("B")=$S(+DOMAIN:$$FILENAME(+DOMAIN),1:$P(DOMAIN,":"))
161RT1 D ^DIR I $D(DTOUT)!$D(DUOUT) S DOMAIN="^" Q
162 I $L(DOMAIN),$L(X),X=$G(DIR("B")) S Y=$P(DOMAIN,":") G RTQ ; default
163 I +Y=Y S X=$$FILENAME(+Y) I $L(X) W " "_X G RTQ ; valid file number
164 I $L(Y),+Y'=Y D G:$D(Y) RTQ ; valid root or name
165 . I "(,"[$E(Y,$L(Y)) Q:$D(@(U_Y_"0)")) ; valid file root
166 . S DIC=1,DIC(0)="EQ",X=Y D ^DIC S:Y>0 Y=+Y K:Y'>0 Y
167 W $C(7),!,"Invalid file!" G RT1
168RTQ S STR=$P(DOMAIN,":",2),DOMAIN=Y_":"_$S($L(STR):STR,1:"EQ")
169 Q
170 ;
171SET ; -- set of codes
172 N I,ORI,ORJ,ITEM,X,Y,ORQUIT,NEWLNG S ORJ=0
173 F I=1:1:$L(DOMAIN,";") S:$P(DOMAIN,";",I)'="" ITEM(I)=$P(DOMAIN,";",I)
174 S ORI=0 F S ORI=$O(ITEM(ORI)) Q:ORI'>0 D SETEDIT Q:$G(ORQUIT)!(Y="")
175 I $G(ORQUIT) S DOMAIN="^" Q
176 S ORI=ORJ F S ORI=ORI+1 D SETEDIT Q:$G(ORQUIT)!(Y="") ; new codes
177 I $G(ORQUIT) S DOMAIN="^" Q
178 ; now done editing, rebuild DOMAIN
179 S I=0,DOMAIN="" F S I=$O(ITEM(I)) Q:I'>0 S NEWLNG=$L(DOMAIN)+$L(ITEM(I))+1 S:NEWLNG'>235 DOMAIN=DOMAIN_ITEM(I)_";" I NEWLNG>235 W $C(7),!,"Domain too long - unable to store all codes." H 2 Q
180 Q
181SETEDIT ; -- edit each item in DOMAIN
182 N DIR,TEXT,CODE S DIR(0)="FAO^1:5",DIR("A")="INTERNALLY-STORED CODE: "
183 S CODE=$P($G(ITEM(ORI)),":"),TEXT=$P($G(ITEM(ORI)),":",2),ORJ=ORI
184 S:$L(CODE) DIR("B")=CODE
185 D ^DIR S:$D(DUOUT)!($D(DTOUT)) ORQUIT=1 Q:$G(ORQUIT)!(X="")
186 I X="@" K ITEM(ORI) Q
187 S CODE=X W " WILL STAND FOR: " W:$L(TEXT) TEXT_"// "
188SE1 R Y:DTIME I '$T!(Y["^") S ORQUIT=1 Q
189 S:Y="" Y=TEXT I "@"[Y W $C(7),!," Required value!",!,"'"_CODE_"' WILL STAND FOR: " W:$L(TEXT) TEXT_"// " G SE1
190 S TEXT=Y,ITEM(ORI)=CODE_":"_TEXT
191 Q
192 ;
193OTHER ; -- no parameters needed
194 S DOMAIN=""
195 Q
196 ;
197FILENAME(FNUM) ; -- Returns name of file FNUM
198 N ORY,Y D:$G(FNUM) FILE^DID(+FNUM,,"NAME","ORY")
199 S Y=$G(ORY("NAME"))
200 Q Y
Note: See TracBrowser for help on using the repository browser.