source: WorldVistAEHR/trunk/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIUPS139.m@ 1766

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

initial load of WorldVistAEHR

File size: 8.2 KB
Line 
1TIUPS139 ; SLC/AJB - Cleanup for TIU*1*138 ; August 2, 2002
2 ;;1.0;TEXT INTEGRATION UTILITIES;**139**;Jun 20, 1997
3 ;
4 Q
5CLEAN ; control segment
6 ;
7 N ANS,HDR,RPT,RECS,TMP
8 ;
9 W @IOF
10 ;
11 D MKWSDEV Q:$G(ANS("EXIT"))="YES"
12 ;
13 D ASKUSER(.ANS) Q:$G(ANS("EXIT"))="YES"
14 ;
15 I ANS("PRINT")="YES" D Q
16 . K POP N POP,ZTDESC,ZTRTN
17 . S ZTDESC="TIUPS139 Cleanup Routine",ZTRTN="REPORT^TIUPS139",ZTSAVE("*")=""
18 . D EN^XUTMDEVQ(ZTRTN,ZTDESC,.ZTSAVE)
19 ;
20 W !,"Searching..."
21 D REPORT
22 W !!
23 D OUTPUT
24EXIT ;
25 Q
26REPORT ;
27 ;
28 N DA,DR,DIE,ELAPSED,ENTRYDT,POP,SPACER,START,STOP,TIUDA,TIUDT
29 ;
30 S (RECS("CHK"),RECS("FOUND"),RECS("SEARCHED"),RECS("TOTAL"))=0
31 ;
32 S START=$$NOW^XLFDT,TIUDA="",TIUDT=ANS("BEGDT")
33 F S TIUDT=$O(^TIU(8925,"F",TIUDT)) Q:TIUDT=""!(TIUDT>ANS("ENDDT")) F S TIUDA=$O(^TIU(8925,"F",TIUDT,TIUDA)) Q:TIUDA="" S RECS("SEARCHED")=RECS("SEARCHED")+1 I $P($G(^TIU(8925,TIUDA,0)),U,5)=6,$P($G(^TIU(8925,TIUDA,12)),U,8)="" D
34 . S ENTRYDT=TIUDT
35 . I +$$REQCOSIG($P($G(^TIU(8925,TIUDA,0)),U),TIUDA,$P($G(^TIU(8925,TIUDA,12)),U,2))=1 D Q
36 .. S RECS("CHK")=RECS("CHK")+1 S:RECS("CHK")<10 RECS("CHK")="0"_RECS("CHK") S:RECS("CHK")<100 RECS("CHK")="0"_RECS("CHK")
37 .. S TMP(RECS("CHK")_"C",TIUDA)="",RECS("CHK")=+RECS("CHK")
38 . S RECS("FOUND")=RECS("FOUND")+1,TMP(RECS("FOUND"),TIUDA)=""
39 . S DA=TIUDA,DIE="^TIU(8925,",DR=".05////7;1506////0"
40 . I ANS("UPDATE")="YES" D ^DIE
41 S RECS("TOTAL")=RECS("FOUND")+RECS("CHK")
42 S STOP=$$NOW^XLFDT,ELAPSED=$FN($$FMDIFF^XLFDT(START,STOP,2)/60,"-")
43 ;
44 S HDR(1)="Elapsed Time: "_(ELAPSED\1)_" minute(s) "_($FN((ELAPSED#1)*60,"-",0))_" second(s)"
45 S HDR(2)="# of Records: "_"Searched "_RECS("SEARCHED")
46 S SPACER="",$P(SPACER," ",(8-$L(RECS("TOTAL"))))=" "
47 S HDR(3)=" Found "_RECS("TOTAL")_SPACER_"(STATUS=UNCOSIGNED, EXPECTED COSIGNER="""")"
48 S SPACER="",$P(SPACER," ",(8-$L(RECS("FOUND"))))=" "
49 S:ANS("UPDATE")="YES" HDR(4)=" Corrected "_RECS("FOUND")_SPACER_"(COSIGNATURE REQUIRED=NO)"
50 S:ANS("UPDATE")="NO" HDR(4)=" Unchanged "_RECS("FOUND")_SPACER_"(COSIGNATURE REQUIRED=NO)"
51 S SPACER="",$P(SPACER," ",(8-$L(RECS("CHK"))))=" "
52 S:RECS("CHK")>0 HDR(5)=" Unchanged* "_RECS("CHK")_SPACER_"(COSIGNATURE REQUIRED=YES)"
53 S:RECS("CHK")>0 HDR(6)="",HDR(7)=" * co-signer requirement should be verified"
54 S HDR(8)=""
55 S HDR(9)=" Host File Path: "_ANS("PATH")_"TIUPS139.TXT"
56 S HDR(10)=""
57 S RPT(1)="Current User: "_($$GET1^DIQ(200,+DUZ,.01))
58 S RPT(2)="Current Date: "_($$HTE^XLFDT($H))
59 S RPT(3)="Date range searched: "_($$FMTE^XLFDT(ANS("BEGDT"),"D"))_" - "_($$FMTE^XLFDT(ANS("ENDDT"),"D"))
60 S RPT(4)=""
61 S RPT(5)="Count Entry Date/Time"
62 S RPT(6)="Doc # Title Author/Dictator"
63 S RPT(7)="----- ----- ---------------"
64 ;
65 I RECS("TOTAL")=0 S RPT(8)="<NO RECORDS FOUND>",RPT(9)=""
66 ;
67 N AUTHOR,CNT,NUM,TITLE
68 ;
69 S CNT=7,RECS=0,(NUM,TIUDA)=""
70 F S NUM=$O(TMP(NUM)) Q:NUM="" F S TIUDA=$O(TMP(NUM,TIUDA)) Q:TIUDA="" D
71 . I RECS("FOUND")=0,NUM="001C" S CNT=CNT+1,RPT(CNT)="<NO RECORDS FOUND>",CNT=CNT+1,RPT(CNT)=""
72 . I NUM="001C" S CNT=CNT+1,RPT(CNT)="** The following records are STATUS=UNCOSIGNED COSIGNATURE REQUIRED=YES **",CNT=CNT+1,RPT(CNT)=""
73 . S CNT=CNT+1,RECS=RECS+1
74 . S SPACER="",$P(SPACER," ",(11-$L(RECS)))=" "
75 . S RPT(CNT)="#"_RECS_SPACER_$$FMTE^XLFDT($P(^TIU(8925,TIUDA,12),U))
76 . S CNT=CNT+1,TITLE=$E($$GET1^DIQ(8925,TIUDA_",",.01),1,36),AUTHOR=$E($$GET1^DIQ(8925,TIUDA_",",1202),1,28)
77 . S SPACER="",$P(SPACER," ",(11-$L(TIUDA)))=" "
78 . S:NUM["C" RPT(CNT)=TIUDA_"*"_SPACER_TITLE
79 . S:NUM'["C" RPT(CNT)=TIUDA_" "_SPACER_TITLE
80 . S SPACER="",$P(SPACER," ",(50-$L(RPT(CNT))))=" "
81 . S RPT(CNT)=RPT(CNT)_SPACER_AUTHOR,CNT=CNT+1,RPT(CNT)=""
82 ;
83 D:ANS("PRINT")="YES" OUTPUT,^%ZISC
84 ;
85 D OPEN^%ZISH("TIUPS139",ANS("PATH"),"TIUPS139.TXT","A") Q:POP>0
86 U IO D OUTPUT
87 D CLOSE^%ZISH("TIUPS139")
88 ;
89 S XQA(DUZ)="",XQAMSG="TIUPS139 has finished."
90 D SETUP^XQALERT
91 Q
92OUTPUT ;
93 N NUM
94 S NUM=""
95 F S NUM=$O(HDR(NUM)) Q:NUM="" W HDR(NUM),!
96 F S NUM=$O(RPT(NUM)) Q:NUM="" W RPT(NUM),!
97 S $P(NUM,"-",80)="-" W NUM
98 Q
99 ;
100ASKUSER(ANS) ;
101 ;
102 N DIR,POP,X,Y
103 ;
104 ; delete the host file and quit?
105 ;
106 N DELHFS
107 S DIR(0)="Y"
108 S DIR("A")="Delete the host file TIUPS139.TXT and QUIT"
109 S DIR("B")="NO"
110 S DIR("?")="Entering 'NO' will not delete the host file TIUPS139.TXT and continue."
111 S DIR("?",1)="Entering 'YES' will delete the host file TIUPS139.TXT and QUIT."
112 D ^DIR
113 I $D(DUOUT)!($D(DTOUT)) S ANS("EXIT")="YES" Q
114 S ANS("DELHFS")=Y(0) W !
115 I ANS("DELHFS")="YES" D Q
116 . S DELHFS("TIUPS139.TXT")=""
117 . S Y=$$DEL^%ZISH(ANS("PATH"),$NA(DELHFS))
118 . W !,"TIUPS139.TXT has been deleted.",!
119 . S ANS("EXIT")="YES" ;
120 ;
121 ; date range?
122 ;
123 N %DT,CNT
124 S %DT="AE"
125 F CNT=1:1:2 D
126 . S %DT("A")=$S(CNT=1:"START WITH REFERENCE DATE: ",CNT=2:" GO TO REFERENCE DATE: ")
127 . S %DT("B")=$S(CNT=1:"Jan 01, 2001",CNT=2:$P($$HTE^XLFDT($H),"@"))
128 . D ^%DT
129 . I Y=-1 S CNT=2,ANS("EXIT")="YES" Q
130 . I CNT=1 S ANS("BEGDT")=Y
131 . I CNT=2 S ANS("ENDDT")=Y_".24"
132 W !
133 Q:$G(ANS("EXIT"))="YES"
134 ;
135 ; update the documents?
136 ;
137 S DIR(0)="Y"
138 S DIR("A")="Update the records at this time"
139 S DIR("B")="NO"
140 S DIR("?",1)="Entering 'YES' will find and update the records."
141 S DIR("?",2)="STATUS will be changed from 'UNCOSIGNED' to 'COMPLETED' and"
142 S DIR("?",3)="COSIGNATURE NEEDED will be changed to 'NO'."
143 S DIR("?",4)=""
144 S DIR("?")="Entering 'NO' will find and report the records without making any changes."
145 D ^DIR
146 I $D(DUOUT)!($D(DTOUT)) S ANS("EXIT")="YES" Q
147 S ANS("UPDATE")=Y(0) W !
148 ;
149 ; print the results?
150 ;
151 S DIR(0)="Y"
152 S DIR("A")="Would you like to print or queue the search"
153 S DIR("B")="YES"
154 S DIR("?",1)="Entering 'YES' will send the search results to the selected device."
155 S DIR("?",2)="It will also allow the search to be queued and run at a later time if desired."
156 S DIR("?",3)=""
157 S DIR("?",4)="Entering 'NO' will not allow printing or queuing of the search results."
158 S DIR("?")="The search results will be displayed on the current device."
159 D ^DIR
160 I $D(DUOUT)!($D(DTOUT)) S ANS("EXIT")="YES" Q
161 S ANS("PRINT")=Y(0) W !
162 ;
163 Q
164 ;
165REQCOSIG(TIUTYP,TIUDA,USER) ; Evaluate whether user requires cosignature
166 N TIUI,TIUY,TIUDPRM S USER=$S(+$G(USER):+$G(USER),1:+$G(DUZ))
167 D DOCPRM^TIULC1(TIUTYP,.TIUDPRM,+$G(TIUDA))
168 I $G(TIUDPRM(5))="" G REQCOSX
169 F TIUI=1:1:$L(TIUDPRM(5),U) D Q:+TIUY>0
170 . S TIUY=+$$ISA(+USER,+$P(TIUDPRM(5),U,TIUI))
171REQCOSX Q +$G(TIUY)
172 ;
173ISA(USER,CLASS,ERR) ; Boolean - Is USER a Member of CLASS?
174 N USRY,USRI
175 I $S(CLASS="USER":1,CLASS=+$O(^USR(8930,"B","USER",0)):1,1:0) S USRY=1 G ISAX
176 I '+USER S USER=+$O(^VA(200,"B",USER,0))
177 I +USER'>0 S ERR="INVALID USER" Q 0
178 I '+CLASS S CLASS=+$O(^USR(8930,"B",CLASS,0))
179 I +CLASS'>0 S ERR="INVALID USER CLASS" Q 0
180 ; If USER is a member of CLASS return true
181 S USRY=0
182 I +$D(^USR(8930.3,"AUC",USER,CLASS)) D
183 . N USRMDA
184 . S USRMDA=0
185 . F S USRMDA=+$O(^USR(8930.3,"AUC",USER,CLASS,USRMDA)) Q:((+USRMDA'>0)!(USRY)) D
186 .. S USRY=+$$CURRENT(USRMDA)
187 I USRY Q USRY
188 ; Otherwise, check to see if user is a member of any subclass of CLASS
189 S USRI=0
190 F S USRI=$O(^USR(8930,+CLASS,1,USRI)) Q:+USRI'>0!+$G(USRY) D
191 . N USRSUB S USRSUB=+$G(^USR(8930,+CLASS,1,USRI,0)) Q:+USRSUB'>0
192 . S USRY=$$ISA(USER,USRSUB) ; Recurs to find members of subclass
193ISAX Q +$G(USRY)
194 ;
195CURRENT(MEMBER) ; Boolean - Is Membership current?
196 N USRIN,USROUT,USRY
197 S USRIN=+$P($G(^USR(8930.3,+MEMBER,0)),U,3)
198 S USROUT=+$P($G(^USR(8930.3,+MEMBER,0)),U,4)
199 I USRIN'>ENTRYDT,$S(USROUT>0&(USROUT'<ENTRYDT):1,USROUT=0:1,1:0) S USRY=1
200 E S USRY=0
201 Q USRY
202 ;
203MKWSDEV ;
204 ;
205 I +$$FIND1^DIC(3.5,"","MX","TIUPS139 WORKSTATION")>0 S ANS("PATH")=$$PWD^%ZISH Q
206 ;
207 N FDA,FDAIEN,MSG
208 S FDA(3.5,"+1,",.01)="TIUPS139 WORKSTATION"
209 S FDA(3.5,"+1,",.02)="TIUPS139 Workstation HFS Device" ; location
210 S FDA(3.5,"+1,",1)="TIUPS139.DAT" ;$I
211 S FDA(3.5,"+1,",1.95)=0 ; sign-on/system device
212 S FDA(3.5,"+1,",2)="HFS" ; type
213 S FDA(3.5,"+1,",3)=$$FIND1^DIC(3.2,"","MX","P-OTHER") ; subtype
214 S FDA(3.5,"+1,",4)=0 ; ask device
215 S FDA(3.5,"+1,",5)=0 ; ask parameters
216 S FDA(3.5,"+1,",5.1)=0 ; ask host file
217 S FDA(3.5,"+1,",5.2)=0 ; ask hfs i/o operation
218 D UPDATE^DIE("","FDA","FDAIEN","MSG")
219 I $D(MSG) D Q
220 . W !,"Workstation device creation failed."
221 . S ANS("EXIT")="YES"
222 S ANS("PATH")=$$PWD^%ZISH
223 Q
Note: See TracBrowser for help on using the repository browser.