source: FOIAVistA/trunk/r/CLINICAL_REMINDERS-PXRM/PXRMV2ID.m@ 794

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

initial load of FOIAVistA 6/30/08 version

File size: 5.0 KB
Line 
1PXRMV2ID ; SLC/PKR - Version 2.0 init routine (dates). ;07/01/2003
2 ;;2.0;CLINICAL REMINDERS;;Feb 04, 2005
3 ;
4 Q
5 ;
6 ;===============================================================
7CEDATE ;Find all reminder and term findings that have an ending date.
8 ;Ask the user if it should be moved to a beginning date.
9 N BDATE,DIR,DIROUT,DTOUT,DUOUT,EDATE,IEN,IND,FINDING,FNAME
10 N RNAME,TEMP,TEXT,X,Y
11 W !,"Checking reminder definitions for ending dates."
12 S IEN=0
13 F S IEN=+$O(^PXD(811.9,IEN)) Q:IEN=0 D
14 . S RNAME=$P(^PXD(811.9,IEN,0),U,1)
15 . S IND=0
16 . F S IND=+$O(^PXD(811.9,IEN,20,IND)) Q:IND=0 D
17 .. S TEMP=^PXD(811.9,IEN,20,IND,0)
18 .. S EDATE=$P(TEMP,U,11)
19 .. I EDATE'="" D
20 ... S BDATE=$P(TEMP,U,8)
21 ... S FINDING=$P(TEMP,U,1)
22 ... S TEMP="^"_$P(FINDING,";",2)_$P(FINDING,";",1)_",0)"
23 ... S FNAME=$P(@TEMP,U,1)
24 ... W !!,"Reminder ",RNAME
25 ... W !," Finding ",FNAME," has an ending date."
26 ... W !," The ending date is ",EDATE
27 ... S TEXT=$S(BDATE="":"NULL",1:BDATE)
28 ... W !," The beginning date is ",TEXT
29 ... W !," Move the ending date to the beginning date and delete the ending date?"
30 ... S DIR(0)="Y"_U_"AO",DIR("B")="NO"
31 ... D ^DIR
32 ... I Y D
33 .... S $P(^PXD(811.9,IEN,20,IND,0),U,8)=$$COTN^PXRMDATE(EDATE)
34 .... S $P(^PXD(811.9,IEN,20,IND,0),U,11)=""
35 ;
36 W !!,"Checking reminder terms for ending dates."
37 S IEN=0
38 F S IEN=+$O(^PXRMD(811.5,IEN)) Q:IEN=0 D
39 . S RNAME=$P(^PXRMD(811.5,IEN,0),U,1)
40 . S IND=0
41 . F S IND=+$O(^PXRMD(811.5,IEN,20,IND)) Q:IND=0 D
42 .. S TEMP=^PXRMD(811.5,IEN,20,IND,0)
43 .. S EDATE=$P(TEMP,U,11)
44 .. I EDATE'="" D
45 ... S BDATE=$P(TEMP,U,8)
46 ... S FINDING=$P(TEMP,U,1)
47 ... S TEMP="^"_$P(FINDING,";",2)_$P(FINDING,";",1)_",0)"
48 ... S FNAME=$P(@TEMP,U,1)
49 ... W !!,"Reminder ",RNAME
50 ... W !," Finding ",FNAME," has an ending date."
51 ... W !," The ending date is ",EDATE
52 ... S TEXT=$S(BDATE="":"NULL",1:BDATE)
53 ... W !," The beginning date is ",TEXT
54 ... W !," Move the ending date to the beginning date and delete the ending date?"
55 ... S DIR(0)="Y"_U_"AO",DIR("B")="NO"
56 ... D ^DIR
57 ... I Y D
58 .... S $P(^PXRMD(811.5,IEN,20,IND,0),U,8)=$$COTN^PXRMDATE(EDATE)
59 .... S $P(^PXRMD(811.5,IEN,20,IND,0),U,11)=""
60 W !," DONE"
61 Q
62 ;
63 ;===============================================================
64CEFFDATE ;Convert effective dates to beginning dates.
65 N EDATE,IEN,IND,FINDING,FNAME,RNAME,TEMP,TEXT
66 ;Only do this once.
67 I $$VERSION^XPDUTL("PXRM")["2.0" Q
68 D BMES^XPDUTL("Converting Effective Dates to Beginning Dates")
69 S IEN=0
70 F S IEN=+$O(^PXD(811.9,IEN)) Q:IEN=0 D
71 . S RNAME=$P(^PXD(811.9,IEN,0),U,1)
72 . S TEXT=" Working on reminder "_IEN
73 . D BMES^XPDUTL(TEXT)
74 . S IND=0
75 . F S IND=+$O(^PXD(811.9,IEN,20,IND)) Q:IND=0 D
76 .. S TEMP=^PXD(811.9,IEN,20,IND,0)
77 .. S EDATE=$P(TEMP,U,11)
78 .. I EDATE'="" D
79 ... S FINDING=$P(TEMP,U,1)
80 ... S TEMP="^"_$P(FINDING,";",2)_$P(FINDING,";",1)_",0)"
81 ... S FNAME=$P(@TEMP,U,1)
82 ... S TEXT="Moving Effective Date to Beginning Date for reminder "_RNAME
83 ... D BMES^XPDUTL(TEXT)
84 ... S TEXT=" finding "_FNAME
85 ... D BMES^XPDUTL(TEXT)
86 ... S $P(^PXD(811.9,IEN,20,IND,0),U,8)=$$COTN^PXRMDATE(EDATE)
87 ... S $P(^PXD(811.9,IEN,20,IND,0),U,11)=""
88 ;
89 S IEN=0
90 F S IEN=+$O(^PXRMD(811.5,IEN)) Q:IEN=0 D
91 . S TEXT=" Working on term "_IEN
92 . D BMES^XPDUTL(TEXT)
93 . S RNAME=$P(^PXRMD(811.5,IEN,0),U,1)
94 . S IND=0
95 . F S IND=+$O(^PXRMD(811.5,IEN,20,IND)) Q:IND=0 D
96 .. S TEMP=^PXRMD(811.5,IEN,20,IND,0)
97 .. S EDATE=$P(TEMP,U,11)
98 .. I EDATE'="" D
99 ... S FINDING=$P(TEMP,U,1)
100 ... S TEMP="^"_$P(FINDING,";",2)_$P(FINDING,";",1)_",0)"
101 ... S FNAME=$P(@TEMP,U,1)
102 ... S TEXT="Moving Effective Date to Beginning Date for term "_RNAME
103 ... D BMES^XPDUTL(TEXT)
104 ... S TEXT=" finding "_FNAME
105 ... D BMES^XPDUTL(TEXT)
106 ... S $P(^PXRMD(811.5,IEN,20,IND,0),U,8)=$$COTN^PXRMDATE(EDATE)
107 ... S $P(^PXRMD(811.5,IEN,20,IND,0),U,11)=""
108 D BMES^XPDUTL(" DONE")
109 Q
110 ;
111 ;===============================================================
112CFDATE ;Convert the beginning and ending dates in the finding multiple
113 ;to the new format.
114 N IEN,IND,NEWDATE,OLDDATE,TEMP,TEXT
115 D BMES^XPDUTL("Setting finding dates to new format.")
116 S IEN=0
117 F S IEN=+$O(^PXD(811.9,IEN)) Q:IEN=0 D
118 . S TEXT=" Working on reminder "_IEN
119 . D BMES^XPDUTL(TEXT)
120 . S IND=0
121 . F S IND=+$O(^PXD(811.9,IEN,20,IND)) Q:IND=0 D
122 .. S TEMP=^PXD(811.9,IEN,20,IND,0)
123 .. S OLDDATE=$P(TEMP,U,8)
124 .. I OLDDATE'="" D
125 ... S NEWDATE=$$COTN^PXRMDATE(OLDDATE)
126 ... S $P(^PXD(811.9,IEN,20,IND,0),U,8)=NEWDATE
127 .. S OLDDATE=$P(TEMP,U,11)
128 .. I OLDDATE'="" D
129 ... S NEWDATE=$$COTN^PXRMDATE(OLDDATE)
130 ... S $P(^PXD(811.9,IEN,20,IND,0),U,11)=NEWDATE
131 ;
132 S IEN=0
133 F S IEN=+$O(^PXRMD(811.5,IEN)) Q:IEN=0 D
134 . S TEXT=" Working on term "_IEN
135 . D BMES^XPDUTL(TEXT)
136 . S IND=0
137 . F S IND=+$O(^PXRMD(811.5,IEN,20,IND)) Q:IND=0 D
138 .. S TEMP=^PXRMD(811.5,IEN,20,IND,0)
139 .. S OLDDATE=$P(TEMP,U,8)
140 .. I OLDDATE'="" D
141 ... S NEWDATE=$$COTN^PXRMDATE(OLDDATE)
142 ... S $P(^PXRMD(811.5,IEN,20,IND,0),U,8)=NEWDATE
143 .. S OLDDATE=$P(TEMP,U,11)
144 .. I OLDDATE'="" D
145 ... S NEWDATE=$$COTN^PXRMDATE(OLDDATE)
146 ... S $P(^PXRMD(811.5,IEN,20,IND,0),U,11)=NEWDATE
147 D BMES^XPDUTL(" DONE")
148 Q
149 ;
Note: See TracBrowser for help on using the repository browser.