source: WorldVistAEHR/trunk/r/WOMENS_HEALTH-WV/WVPURP.m@ 1042

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

initial load of WorldVistAEHR

File size: 5.6 KB
Line 
1WVPURP ;HIOFO/FT,JR-NOTIFICATION TABLES MAINTENANC; ;8/28/03 16:38
2 ;;1.0;WOMEN'S HEALTH;**4,9,16**;Sep 30, 1998
3 ;; Original routine created by IHS/ANMC/MWR
4 ;;* MICHAEL REMILLARD, DDS * ALASKA NATIVE MEDICAL CENTER *
5 ;; ADD/EDIT/PRINT NOTIFICATION PURPOSE FILE ENTRIES, EDIT PCD DAYS,
6 ;; EDIT NOTIFICATION TYPE SYNONYMS, ADD/EDIT NOTIFICATION OUTCOMES.
7 ;
8 ; This routine uses the following IAs:
9 ; #10089 - ^%ZISC call (supported)
10 ; #10103 - ^XLFDT calls (supported)
11 ; #10104 - ^XLFSTR calls (supported)
12 ;
13PRINTPUR ; Called by option "WV PRINT NOTIF PURPOSE&LETTER"
14 D SETVARS^WVUTL5
15 D DEVICE
16 I WVPOP D KILL Q
17PRINT ; Print purpose and letter entries
18 U IO
19 S WVNAME="",(WVPAGE,WVPOP)=0
20 S WVDATE=$$FMTE^XLFDT($$NOW^XLFDT(),"1P") ;current date/time
21 S WVDASH=$$REPEAT^XLFSTR("-",79) ;line of dashes
22 ; loop thru File 790.404 (B x-ref)
23 F S WVNAME=$O(^WV(790.404,"B",WVNAME)) Q:WVNAME=""!(WVPOP) S WVIEN=0 F S WVIEN=$O(^WV(790.404,"B",WVNAME,WVIEN)) Q:'WVIEN!(WVPOP) D
24 .S WVNODE=$G(^WV(790.404,WVIEN,0)) Q:WVNODE=""
25 .D HEADER
26 .D RESOLVE
27 .W !!?3,"PURPOSE: "_$P(WVNODE,U,1),?55,"SYNONYM: "_$P(WVNODE,U,3)
28 .W !?2,"PRIORITY: "_$G(WVARRAY(790.404,WVIEN_",",.02,"E")),?56,"ACTIVE: "_$G(WVARRAY(790.404,WVIEN_",",.04,"E"))
29 .W !?2,"BR or CX: "_$G(WVARRAY(790.404,WVIEN_",",.05,"E"))
30 .W !?4,"LETTER: "_$G(WVARRAY(790.404,WVIEN_",",.06,"E"))
31 .W !,"BR TX NEED: "_$G(WVARRAY(790.404,WVIEN_",",.07,"E"))
32 .S WVDUE=$$DMY($G(WVARRAY(790.404,WVIEN_",",.08,"E")))
33 .W ?48,"BR TX DUE DATE: "_WVDUE
34 .W !,"CX TX NEED: "_$G(WVARRAY(790.404,WVIEN_",",.09,"E"))
35 .S WVDUE=$$DMY($G(WVARRAY(790.404,WVIEN_",",.1,"E")))
36 .W ?48,"CX TX DUE DATE: "_WVDUE,!!
37 .S WVLINE=0
38 .F S WVLINE=$O(^WV(790.404,WVIEN,1,WVLINE)) Q:'WVLINE!(WVPOP) D
39 ..I ($Y+4)>IOSL D:$E(IOST)="C" DIRZ^WVUTL3 Q:WVPOP D HEADER
40 ..W !,$G(^WV(790.404,WVIEN,1,WVLINE,0))
41 ..Q
42 .Q:WVPOP
43 .I $E(IOST)="C" D DIRZ^WVUTL3
44 .Q
45 I $D(ZTQUEUED) S ZTREQ="@"
46KILL ; Kill variables
47 K WVARRAY,WVDASH,WVDATE,WVDUE,WVIEN,WVLINE
48 K WVNAME,WVNODE,WVPAGE,WVPOP,X,Y
49 D ^%ZISC
50 Q
51HEADER ; Report header
52 W:$Y>0 @IOF
53 S WVPAGE=WVPAGE+1
54 W "NOTIFICATION PURPOSE & LETTER LIST",?45,WVDATE,?70,"PAGE: "_WVPAGE
55 W !,WVDASH
56 Q
57RESOLVE ; Resolve data to external values
58 K WVARRAY
59 D CLEAN^DILF
60 D GETS^DIQ(790.404,WVIEN_",",".02;.04:.1","E","WVARRAY")
61 Q
62DEVICE ; Get device and possibly queue to taskman
63 N ZTRTN
64 S ZTRTN="DEQUEUE^WVPURP"
65 D ZIS^WVUTL2(.WVPOP,1,"HOME")
66 Q
67DEQUEUE ; Taskman queue of printout
68 D PRINT
69 Q
70 ;
71EDITPUR ;EP
72 ;---> CALLED BY OPTION "WV EDIT NOTIF PURPOSE&LETTER".
73 D SETVARS^WVUTL5
74 ;---> DISPLAY MENU TITLE FROM WV MENU OPTIONS.
75 F D Q:$G(Y)<0
76 .D TITLE^WVUTL5("EDIT NOTIFICATION PURPOSE & LETTER FILE")
77 .D DIC^WVFMAN(790.404,"QEMAL",.Y)
78 .Q:Y<0
79 .S DA=+Y
80 .D:$P(Y,U,3) ADDLET
81 .D:'$P(Y,U,3) REPLACE
82 .Q:WVPOP
83 .;---> EDIT WITH SCREENMAN.
84 .S DR="[WV NOTIFPURPOSE-FORM-1]"
85 .D DDS^WVFMAN(790.404,DR,DA,"","",.WVPOP)
86 D KILLALL^WVUTL8
87 Q
88 ;
89 ;
90ADDLET ;EP
91 ;---> CALLED BY OPTION "WV ADD NOTIF PURPOSE&LETTER".
92 K ^WV(790.404,DA,1)
93 N N S N=0
94 F S N=$O(^WV(790.6,1,1,N)) Q:'N D
95 .S ^WV(790.404,DA,1,N,0)=^WV(790.6,1,1,N,0)
96 S ^WV(790.404,DA,1,0)=^WV(790.6,1,1,0)
97 Q
98 ;
99REPLACE ;EP
100 ;---> REPLACE OLD LETTER FOR THIS NOTIF PURPOSE WITH GENERIC SAMPLE.
101 N DIR,DIRUT,Y
102 W !!?3,"Do you wish to delete the old letter for this Purpose of "
103 W "Notification",!?3,"and replace it with the generic sample letter?"
104 S DIR(0)="YA",DIR("B")="NO"
105 S DIR("A")=" Enter Yes or No: " D HELP1
106 D ^DIR W !
107 S:$D(DIRUT) WVPOP=1
108 I Y D ADDLET
109 Q
110 ;
111HELP1 ;EP
112 ;;Enter YES to delete the old letter for this Purpose of Notification
113 ;;and to begin with a fresh copy of the generic sample letter.
114 S WVTAB=5,WVLINL="HELP1" D HELPTX
115 Q
116 ;
117HELPTX ;EP
118 N I,T,X S T=$$REPEAT^XLFSTR(" ",WVTAB)
119 F I=1:1 S X=$T(@WVLINL+I) Q:X'[";;" S DIR("?",I)=T_$P(X,";;",2)
120 S DIR("?")=DIR("?",I-1) K DIR("?",I-1)
121 Q
122 ;
123TYPE ;EP
124 ;---> EDIT SYNONYMS FOR NOTIFICATION TYPES.
125 D SETVARS^WVUTL5
126 F D Q:$G(Y)<0
127 .D TITLE^WVUTL5("EDIT SYNONYMS FOR NOTIFICATION TYPES") D TEXT1
128 .N A S A=" Select NOTIFICATION TYPE: "
129 .D DIC^WVFMAN(790.403,"QEMA",.Y,A)
130 .Q:Y<0
131 .D DIE^WVFMAN(790.403,.03,+Y,.WVPOP)
132 W @IOF
133 D KILLALL^WVUTL8
134 Q
135 ;
136OUTCOME ;EP
137 ;---> ADD/EDIT NOTIFICATION OUTCOME FILE.
138 D SETVARS^WVUTL5
139 F D Q:$G(Y)<0
140 .D TITLE^WVUTL5("ADD/EDIT NOTIFICATION OUTCOME FILE")
141 .D DIC^WVFMAN(790.405,"QEMAL",.Y," Select OUTCOME: ")
142 .Q:Y<0
143 .D DIE^WVFMAN(790.405,.02,+Y,.WVPOP)
144 W @IOF
145 D KILLALL^WVUTL8
146 Q
147 ;
148TEXT1 ;EP
149 ;;You may enter a synonym for each Notification Type. The synonym will
150 ;;allow the Notification Type to be called up by typing only a few
151 ;;characters. Synonyms should be unique and less than 4 characters.
152 ;;
153 ;;For example, "L1" might be used for LETTER,FIRST; "L2" for
154 ;;LETTER,SECOND; "L3" for LETTER,THIRD, and so on.
155 ;;
156 ;;
157 S WVTAB=5,WVLINL="TEXT1" D PRINTX
158 Q
159 ;
160PRINTX ;EP
161 N I,T,X S T=$$REPEAT^XLFSTR(" ",WVTAB)
162 F I=1:1 S X=$T(@WVLINL+I) Q:X'[";;" W !,T,$P(X,";;",2)
163 Q
164 ;
165GENSTUFF ;EP
166 ;---> STUFF THE GENERIC SAMPLE LETTER INTO ALL PURPOSES OF NOTIF.
167 N DA
168 S DA=0
169 F S DA=$O(^WV(790.404,DA)) Q:'DA W !,DA D ADDLET^WVPURP
170 Q
171DMY(WVDUE) ; Spell out Days, Months or Years
172 N WVDUE1,WVDUE2
173 I WVDUE="" Q ""
174 I '$S(WVDUE["D":1,WVDUE["M":1,WVDUE["Y":1,1:0) Q WVDUE
175 S WVDUE1=+WVDUE
176 S WVDUE2=$S(WVDUE["D":"Day",WVDUE["M":"Month",WVDUE["Y":"Year",1:"")
177 S:WVDUE1>1 WVDUE2=WVDUE2_"s"
178 S:WVDUE2="s" WVDUE2=""
179 S WVDUE=WVDUE1_" "_WVDUE2
180 Q WVDUE
181 ;
182DMYCHECK ; Called from ^DD(790.404,.8,0) - BR TX DUE DATE
183 ; and ^DD(790.404,.1,0) - CX TX DUE DATE
184 ; Check X to see if it is a date offset (e.g., 365D, 12M or 1Y).
185 ; Returns -1 if not an exceptable value
186 Q:'$D(X)
187 I $L(X)>4!($L(X)<2) S X=-1 Q
188 S X=$$UP^XLFSTR(X)
189 I X'?1.3N1"D",X'?1.3N1"M",X'?1.3N1"Y" S X=-1
190 Q
Note: See TracBrowser for help on using the repository browser.