source: WorldVistAEHR/trunk/r/SCHEDULING-SD-SC/SCDXPRN2.m@ 1005

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

initial load of WorldVistAEHR
File size: 7.0 KB
RevLine 
[613]1SCDXPRN2 ;ALB/JRP - HISTORY FILE REPORTS;21-JUL-1997
2 ;;5.3;Scheduling;**128,135,405**;AUG 13, 1993
3 ;
4FULLHIST ;Print full transmission history report
5 ; - Report based within the ACRP Transmission History file (#409.77)
6 ; - User prompted for selection criteria
7 ; Division (one/many/all) Clinic (o/m/a) Patient (o/m/a)
8 ; - User prompted for transmission date range
9 ; - Report formatted for 80 columns (allows output to screen)
10 ;
11 ;Declare variables
12 N VAUTSTR,VAUTNI,VAUTVB,VAUTNALL,VAUTD,VAUTC,VAUTN
13 N SCDXBEG,SCDXEND,SCDXGLO,X,Y,SCDXH,SCDXLOCK
14 ;SD*5.3*405 lock user from running multiple times in same session
15 I $D(^TMP("RPT-LOCK",$J,DUZ)) W !!,"Sorry, you either have this report already running or queued to run.",!,"Please try again later.",!! Q
16 ;Initialize selection global
17 S SCDXGLO=$NA(^TMP("SCDXPRN2",$J,"SELECT"))
18 K @SCDXGLO
19 ;Get division(s) - default to 'ALL' if single division
20 S VAUTD=1 I ($P($G(^DG(43,1,"GL")),"^",2)) D DIVISION^VAUTOMA Q:(Y<0)
21 ;Copy into global location [for tasking]
22 ; Local array not deleted - it's required input for clinic selection
23 M @SCDXGLO@("VAUTD")=VAUTD
24 ;Get clinic(s)
25 S VAUTNI=2 D CLINIC^VAUTOMA Q:(Y<0)
26 ;Copy into global location [for tasking] and delete local array
27 M @SCDXGLO@("VAUTC")=VAUTC
28 K VAUTC
29 ;Delete local array of selected divisions
30 K VAUTD
31 ;Get patient(s)
32 S VAUTNI=2 D PATIENT^VAUTOMA Q:(Y<0)
33 ;Copy into global location [for tasking] and delete array
34 M @SCDXGLO@("VAUTN")=VAUTN
35 K VAUTN
36 ;Set allowable date range
37 S SCDXBEG=2961001
38 S SCDXEND=$$DT^XLFDT()
39 ;Begin date help text
40 S SCDXH("B",1)="Enter transmission date to begin search from"
41 S SCDXH("B",2)=" "
42 S SCDXH("B",3)=$$FMTE^XLFDT(SCDXBEG)_" is the earliest date allowed"
43 S SCDXH("B",4)=$$FMTE^XLFDT(SCDXEND)_" will be the latest date allowed"
44 S SCDXH("B",5)=" "
45 S SCDXH("B",6)="Note: Encounter date does not always match date of"
46 S SCDXH("B")=" transmission to the National Patient Care Database"
47 ; End date help text
48 S SCDXH("E",1)="Enter transmission date to end search at"
49 S SCDXH("E",2)=" "
50 S SCDXH("E",3)=$$FMTE^XLFDT(SCDXEND)_" is the latest date allowed"
51 S SCDXH("E",4)=$$FMTE^XLFDT(SCDXBEG)_" was the earliest date allowed"
52 S SCDXH("E",5)=" "
53 S SCDXH("E",6)="Note: Encounter date does not always match date of"
54 S SCDXH("E")=" transmission to the National Patient Care Database"
55 S X=$$GETDTRNG^SCDXUTL1(SCDXBEG,SCDXEND,$NA(SCDXH("B")),$NA(SCDXH("E")))
56 Q:(X<0)
57 K SCDXH
58 S SCDXBEG=+$P(X,"^",1)
59 S SCDXEND=+$P(X,"^",2)
60 S SCDXLOCK=$J_U_DUZ ;SD*5.3*405 lock variable for when report is queued
61 S ^TMP("RPT-LOCK",$J,DUZ)="" ;SD*5.3*405 set lock for current user
62 ;Queue/run
63 W !!
64 S ZTDESC="ACRP TRANSMISSION HISTORY REPORT"
65 S ZTSAVE("SCDXBEG")=""
66 S ZTSAVE("SCDXEND")=""
67 S ZTSAVE("SCDXGLO")=""
68 S ZTSAVE("SCDXLOCK")="" ;SD*5.3*405
69 S ZTSAVE($$OREF^DILF(SCDXGLO))=""
70 S IOP="Q"
71 D EN^XUTMDEVQ("PRINT^SCDXPRN2",ZTDESC,.ZTSAVE)
72 ;Done - reset IO variables (safety measure) and quit
73 I POP K ^TMP("RPT-LOCK",$J,DUZ)
74 I $D(X) I X="^" K ^TMP("RPT-LOCK",$J,DUZ)
75 D HOME^%ZIS
76 Q
77 ;
78PRINT ;Print report
79 ;Input : SCDXBEG - Begin date (FileMan)
80 ; - Refers to date/time of transmission (not encounter)
81 ; SCDXEND - End date (FileMan)
82 ; - Refers to date/time of transmission (not encounter)
83 ; SCDXGLO - Global containing selection criteria
84 ; SCDXLOCK- Equals user's DUZ and locks the same user from
85 ; queueing the report more than once at the same time
86 ; This was output of calls to VAUTOMA for division,
87 ; clinic, and patient (full global reference)
88 ; Divisions selected Clinics selected Patients selected
89 ; SCDXGLO("VAUTD") SCDXGLO("VAUTC") SCDXGLO("VAUTN")
90 ; SCDXGLO("VAUTD",x) SCDXGLO("VAUTC",x) SCDXGLO("VAUTN",x)
91 ;Output : None
92 ;Notes : All input is REQUIRED - report will not be generated if
93 ; any of the variables are not defined
94 ; : All input (including global location) will be deleted on exit
95 ; : User will be prompted for device except on queued entry
96 ;
97 ;Declare variables
98 N DIC,L,BY,FR,TO,DHD,FLDS,DISPAR,DIOBEG,DIOEND,IOP,SCDXSLVE,DOLJ
99 ;Define sort criteria
100 S DIC="^SD(409.77,"
101 S L=0
102 ;Define sort array
103 S BY(0)="^TMP(""SCDXPRN2"",$J,""SORT"","
104 S L(0)=6
105 ;Make FileMan think sort already done (set fake value into array)
106 S ^TMP("SCDXPRN2",$J,"SORT",1,2,3,4,5,6)=""
107 ;Define sort routine
108 S DIOBEG="D SORT^SCDXPRN2"
109 ;Define post-report action
110 S DIOEND="K ^TMP(""SCDXPRN2"",$J,""SORT"")"
111 ;Form feed for each clinic
112 S DISPAR(0,2)="#^;"
113 ;Define print fields
114 S FLDS="[SCDX XMIT HIST FULL PRINT]"
115 ;Define header & footer
116 S DHD="[SCDX XMIT HIST FULL HEADER]-[SCDX XMIT HIST FULL FOOTER]"
117 ;Use current device
118 S IOP=IO
119 ;Remember IO("S")
120 S SCDXSLVE=+$G(IO("S"))
121 ;Print report
122 D EN1^DIP
123 ;Reset IO("S")
124 S:(SCDXSLVE) IO("S")=SCDXSLVE
125 ;Delete input array & variables
126 K @SCDXGLO
127 K SCDXBEG,SCDXEND,SCDXGLO
128 ;If queued, purge task
129 S:($D(ZTQUEUED)) ZTREQ="@"
130 ;SD*5.3*405 remove lock for current user
131 K ^TMP("RPT-LOCK",$P(SCDXLOCK,U,1),$P(SCDXLOCK,U,2))
132 Q
133 ;
134SORT ;Sort routine
135 ;Input : See TASK entry point
136 ;Output : Global containing sorted entries for printing
137 ; ^TMP("SCDXPRN2",$J,"SORT",Div,Clin,Pat,EncDate,VID,DA)
138 ; Div = Division name Clin = Clinic name
139 ; Pat = Patient name EncDate = Encounter date [no time]
140 ; VID = Visit ID DA = Pointer to entry in 409.77
141 ;Notes : ^TMP("SCDXPRN2",$J,"SORT") will be initialized upon entry
142 ; : Existance & validity of input is assumed
143 ;
144 ;Declare variables
145 N HISTPTR,NODE,DATE,NAME,CLINIC,DIVISION,VID
146 N BEGDATE,ENDDATE,TMP,VAUTD,VAUTC,VAUTN
147 ;Make begin and end dates opposing midnights
148 S BEGDATE=$$FMADD^XLFDT($P(SCDXBEG,".",1),-1,23,59,59)
149 S ENDDATE=$$FMADD^XLFDT($P(SCDXEND,".",1),0,23,59,59)
150 ;All divisions selected ?
151 S VAUTD=+$G(@SCDXGLO@("VAUTD"))
152 ;All clinics selected ?
153 S VAUTC=+$G(@SCDXGLO@("VAUTC"))
154 ;All patients selected ?
155 S VAUTN=+$G(@SCDXGLO@("VAUTN"))
156 ;Initialize sort array
157 K ^TMP("SCDXPRN2",$J,"SORT")
158 ;Sort/screen
159 F S BEGDATE=+$O(^SD(409.77,"AXMIT",BEGDATE)) Q:(('BEGDATE)!(BEGDATE>ENDDATE)) D Q:($$S^%ZTLOAD())
160 .S HISTPTR=0
161 .F S HISTPTR=+$O(^SD(409.77,"AXMIT",BEGDATE,HISTPTR)) Q:('HISTPTR) D Q:($$S^%ZTLOAD())
162 ..;Grab zero node of entry
163 ..S NODE=$G(^SD(409.77,HISTPTR,0))
164 ..;Get encounter date (strip time)
165 ..S TMP=+$P(NODE,"^",2)
166 ..S DATE=$P(TMP,".",1)
167 ..;Get patient
168 ..S TMP=+$P(NODE,"^",3)
169 ..S NAME=$P($G(^DPT(TMP,0),"UNKNOWN"),"^",1)
170 ..;Patient selection screen
171 ..I ('VAUTN) Q:('$D(@SCDXGLO@("VAUTN",TMP)))
172 ..;Get clinic
173 ..S TMP=+$P(NODE,"^",4)
174 ..S CLINIC=$P($G(^SC(TMP,0),"UNKNOWN"),"^",1)
175 ..;Clinic selection screen
176 ..I ('VAUTC) Q:('$D(@SCDXGLO@("VAUTC",TMP)))
177 ..;Get division
178 ..S TMP=+$P(NODE,"^",5)
179 ..S DIVISION=$P($G(^DG(40.8,TMP,0),"UNKNOWN"),"^",1)
180 ..;Division selection screen
181 ..I ('VAUTD) Q:('$D(@SCDXGLO@("VAUTD",TMP)))
182 ..;Get visit ID
183 ..S VID=+$P(NODE,"^",6)
184 ..;Store in pre-sort array
185 ..S ^TMP("SCDXPRN2",$J,"SORT",DIVISION,CLINIC,NAME,DATE,VID,HISTPTR)=""
186 ;Done
187 Q
Note: See TracBrowser for help on using the repository browser.