source: FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DG737PST.m@ 1590

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

initial load of FOIAVistA 6/30/08 version

File size: 5.7 KB
Line 
1DG737PST ;BAY/JAT ;file #45 cleanup
2 ;;5.3;Registration;**737**;Aug 13, 1993;Build 8
3 Q
4 ; loosely based on PXRMINDD routine released in PX*2*4
5CHECK ;Driver for making index date checks & stripping trailing zeros
6 N GBL,LIST,ROUTINE
7 W !,"Queue the Clinical Reminders Index date check and update."
8 S GBL(4)=45
9 S LIST="4,"
10 S ROUTINE(45)="CNTPTF^DG737PST"
11 D TASKIT(LIST,.GBL,.ROUTINE)
12 Q
13 ;
14CNTPTF(FILENUM,NSD) ;Check for string dates for PTF indexes where the
15 ;date is at subscript 7. Works for file numbers:
16 ;45
17 K ^TMP($J,"SDATE"),^TMP("PXRMXMZ",$J)
18 N DAS,DATE,DFN,IND,ITEM,NODE,TYPE
19 I '$D(ZTQUEUED) W !,"Checking file number "_FILENUM
20 S IND=0
21 ; only procedure codes affected (file 80.1) therefore only
22 ; sub-file 45.01 or 45.05 are involved
23 F TYPE="ICD0" D
24 . S DFN=""
25 . F S DFN=$O(^PXRMINDX(FILENUM,TYPE,"PNI",DFN)) Q:DFN="" D
26 .. S IND=IND+1
27 .. I '$D(ZTQUEUED),(IND#10000=0) W "."
28 .. S NODE=""
29 .. F S NODE=$O(^PXRMINDX(FILENUM,TYPE,"PNI",DFN,NODE)) Q:NODE="" D
30 ... S ITEM=""
31 ... F S ITEM=$O(^PXRMINDX(FILENUM,TYPE,"PNI",DFN,NODE,ITEM)) Q:ITEM="" D
32 .... S DATE=""
33 .... F S DATE=$O(^PXRMINDX(FILENUM,TYPE,"PNI",DFN,NODE,ITEM,DATE)) Q:DATE="" D
34 ..... I +DATE=DATE Q
35 ..... S DAS=""
36 ..... F S DAS=$O(^PXRMINDX(FILENUM,TYPE,"PNI",DFN,NODE,ITEM,DATE,DAS)) Q:DAS="" D
37 ...... S NSD=NSD+1
38 ...... S ^TMP($J,"SDATE",NSD)="^PXRMINDX("_FILENUM_","_TYPE_",""PNI"","_DFN_","_NODE_","_ITEM_","""_DATE_""","_DAS_")"
39 ...... D UPDATE
40 Q
41 ;
42UPDATE ; strip trailing zeros from date,e.g., 3031005.1340 or 3010816.134050
43 N DGNEWDT,DGFILE,DGDA,DGIENS,FDA
44 S DGNEWDT=+DATE
45 S DGFILE=$P(DAS,";",2)
46 I DGFILE'="P"&(DGFILE'="S") Q
47 I DGFILE="P" S DGFILE=45.05
48 I DGFILE="S" S DGFILE=45.01
49 ; below patterned after UPD^DGENDBS
50 S DGDA=$P(DAS,";",3)
51 S DGDA(1)=+DAS
52 S DGIENS=$$IENS^DILF(.DGDA)
53 S FDA(DGFILE,DGIENS,.01)=DGNEWDT
54 D FILE^DIE("K","FDA")
55 Q
56 ;
57 ;========================================================
58MESSAGE(FILENUM,NSD,START,END) ;Build the MailMan message giving the
59 ;list of entries with string dates.
60 N IND,NAME,NL,TEXT,XMSUB
61 K ^TMP("PXRMXMZ",$J)
62 S XMSUB="CR Index string date check for file #"_FILENUM
63 S NAME=$$GET1^DID(FILENUM,"","","NAME")_", file #"_FILENUM
64 I NSD=0 S TEXT="No string dates were found for "_NAME_"."
65 I NSD>0 S TEXT="A total of "_NSD_" string dates were found for "_NAME_"."
66 S ^TMP("PXRMXMZ",$J,1,0)=TEXT
67 S ^TMP("PXRMXMZ",$J,2,0)="Check finished at "_$$FMTE^XLFDT($$NOW^XLFDT,"5Z")
68 S ^TMP("PXRMXMZ",$J,3,0)=$$ETIME^DG737PST(START,END)
69 S ^TMP("PXRMXMZ",$J,4,0)=" "
70 I NSD=0,'$D(^PXRMINDX(FILENUM)) D
71 . S ^TMP("PXRMXMZ",$J,5,0)="The index for file number "_FILENUM_" does not exist."
72 . S ^TMP("PXRMXMZ",$J,6,0)=" "
73 I NSD>0 D
74 . S ^TMP("PXRMXMZ",$J,5,0)="The following entries with string dates were found:"
75 . S NL=5
76 . F IND=1:1:NSD D
77 .. S NL=NL+1
78 .. S ^TMP("PXRMXMZ",$J,NL,0)=" "_^TMP($J,"SDATE",IND)
79 . S NL=NL+1,^TMP("PXRMXMZ",$J,NL,0)=" "
80 D SEND^DG737PST(XMSUB,DUZ)
81 ;K ^TMP($J,"SDATE"),^TMP("PXRMXMZ",$J)
82 Q
83 ;
84 ;===============================================================
85RUNNOW(LIST,GBL) ;Run the routine now.
86 N END,FN,IND,LI,NSD,NUM,ROUTINE,RTN,START,TOTAL
87 K ^TMP($J,"SDATE")
88 S ROUTINE(45)="CNTPTF^DG737PST"
89 S NUM=$L(LIST,",")-1
90 F IND=1:1:NUM D
91 . S LI=$P(LIST,",",IND)
92 . S NSD=0
93 . S FN=GBL(LI)
94 . S RTN=ROUTINE(FN)
95 . S RTN=RTN_"("_FN_",.NSD)"
96 . S START=$H
97 . I $D(^PXRMINDX(FN)) D @RTN
98 . S END=$H
99 . D MESSAGE(FN,NSD,START,END)
100 Q
101 ;
102 ;===============================================================
103TASKIT(LIST,GBL,ROUTINE) ;Check the indexes as a tasked job.
104 N DIR,DIROUT,DIRUT,DTOUT,DUOUT,MINDT,SDTIME,X,Y
105 S MINDT=$$NOW^XLFDT
106 S DIR("A",1)="Enter the date and time you want the job to start."
107 S DIR("A",2)="It must be after "_$$FMTE^XLFDT(MINDT,"5Z")
108 S DIR("A")="Start the task at: "
109 S DIR(0)="DAU"_U_MINDT_"::RSX"
110 D ^DIR
111 I $D(DIROUT)!$D(DIRUT) Q
112 I $D(DTOUT)!$D(DUOUT) Q
113 S SDTIME=Y
114 K DIR
115 ;Put the task into the queue.
116 K ZTSAVE
117 S ZTSAVE("LIST")=""
118 S ZTSAVE("GBL(")=""
119 S ZTRTN="TASKJOB^DG737PST"
120 S ZTDESC="Clinical Reminders Index string date check and update"
121 S ZTDTH=SDTIME
122 S ZTIO=""
123 D ^%ZTLOAD
124 W !,"Task number ",ZTSK," queued."
125 Q
126 ;
127 ;===============================================================
128TASKJOB ;Execute as tasked job. LIST and GBL come through ZTSAVE.
129 N IND,LI,NUM
130 S ZTREQ="@"
131 S ZTSTOP=0
132 S NUM=$L(LIST,",")-1
133 F IND=1:1:NUM D
134 .;Check to see if the task has had a stop request
135 . I $$S^%ZTLOAD S ZTSTOP=1,IND=NUM Q
136 . S LI=$P(LIST,",",IND)_","
137 . D RUNNOW^DG737PST(LI,.GBL)
138 Q
139 ;
140ETIME(START,END) ;Calculate and format the elapsed time.
141 ;START and END are $H times.
142 N ETIME,TEXT
143 S ETIME=$$HDIFF^XLFDT(END,START,2)
144 I ETIME>90 D
145 . S ETIME=$$HDIFF^XLFDT(END,START,3)
146 . S TEXT="Elapsed time: "_ETIME
147 E S TEXT="Elapsed time: "_ETIME_" secs"
148 Q TEXT
149SEND(XMSUB,USER) ;Send a MailMan message to the user. The text of the message is in
150 ;^TMP("PXRMXMZ",$J,N,0), where there are N lines of text. The subject
151 ;is the string XMSUB.
152 N MGIEN,MGROUP,NL,REF,XMDUZ,XMY,XMZ
153 ;If this is a test run write out the message.
154 ;I $G(PXRMDEBG) D
155 ;. S REF="^TMP(""PXRMXMZ"",$J)"
156 ;. D AWRITE^PXRMUTIL(REF)
157 ;Make sure the subject does not exceed 64 characters.
158 S XMSUB=$E(XMSUB,1,64)
159 ;Make the sender the Postmaster.
160 S XMDUZ=0.5
161RETRY ;Get the message number.
162 D XMZ^XMA2
163 I XMZ<1 G RETRY
164 ;Load the message
165 M ^XMB(3.9,XMZ,2)=^TMP("PXRMXMZ",$J)
166 K ^TMP("PXRMXMZ",$J)
167 S NL=$O(^XMB(3.9,XMZ,2,""),-1)
168 S ^XMB(3.9,XMZ,2,0)="^3.92^"_+NL_U_+NL_U_DT
169 ;Send message to requestor if USER is defined
170 I $G(USER)'="" S XMY(DUZ)="" D ENT1^XMD Q
171 ;Send the message to the site defined mail group or the user if
172 ;there is no mail group.
173 ;S MGIEN=$G(^PXRM(800,1,"MGFE"))
174 ;I MGIEN'="" D
175 ;. S MGROUP="G."_$$GET1^DIQ(3.8,MGIEN,.01)
176 ;. S XMY(MGROUP)=""
177 ;E S XMY(DUZ)=""
178 ;D ENT1^XMD
179 Q
Note: See TracBrowser for help on using the repository browser.