source: FOIAVistA/trunk/r/CLINICAL_REMINDERS-PXRM/PXRMLCR.m@ 1553

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

initial load of FOIAVistA 6/30/08 version

File size: 5.6 KB
Line 
1PXRMLCR ; SLC/PJH - Create Patient List from individual finding rule; 10/18/2007
2 ;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123
3 ;
4 ; Called from PXRM PATIENT LIST CREATE protocol
5 ;
6START N BEG,DUOUT,DTOUT,END,LIT,PXRMDPAT,PXRMLIST,PXRMNODE,PXRMRULE,PXRMTPAT
7 N TEXT
8 ;Initialise
9 K ^TMP("PXRMLCR",$J)
10 ;Node for ^TMP lists created in PXRMRULE
11 S PXRMNODE="PXRMRULE",LIT="Patient List"
12 ;Reset screen mode
13 W IORESET
14 ;Set prompt text
15 S TEXT="Select PATIENT LIST name: "
16 ;Select Patient List
17LIST D PLIST(.PXRMLIST,TEXT,"") I $D(DUOUT)!$D(DTOUT) D Q
18 . I $G(PXRMLIST)="" Q
19 . I $P($G(^PXRMXP(810.5,PXRMLIST,0)),U,4)'="" Q
20 . S DA=PXRMLIST,DIK="^PXRMXP(810.5," D ^DIK
21 ;
22SECURE ;option to secure the list
23 K PATCREAT
24 I $D(PATCREAT)=0 S PATCREAT="N" D ASK^PXRMXD(.PATCREAT,"Secure list?: ",2) Q:$D(DTOUT) G:$D(DUOUT) START
25 ;
26PURGE ;Option to purge the list
27 K PLISTPUG
28 S PLISTPUG="N" D ASK^PXRMXD(.PLISTPUG,"Purge Patient List after 5 years?: ",5) Q:$D(DTOUT) G:$D(DUOUT) SECURE
29 ;Select rule set.
30RULE D LRULE(.PXRMRULE) Q:$D(DTOUT) G:$D(DUOUT) LIST
31 ;Select Date Range
32DATE D DATES^PXRMEUT(.BEG,.END,LIT) Q:$D(DTOUT) G:$D(DUOUT) RULE
33 ;
34 ;Ask whether to include deceased and test patients.
35DPAT S PXRMDPAT=$$ASKYN^PXRMEUT("N","Include deceased patients on the list")
36 Q:$D(DTOUT) G:$D(DUOUT) DATE
37TPAT S PXRMTPAT=$$ASKYN^PXRMEUT("N","Include test patients on the list")
38 Q:$D(DTOUT) G:$D(DUOUT) DPAT
39 I $G(PXRMDEBG) D RUN^PXRMLCR(PXRMRULE,PXRMLIST,PXRMNODE,BEG,END,PXRMDPAT,PXRMTPAT) Q
40 ;Build patient list in background
41 N ZTDESC,ZTDTH,ZTIO,ZTRTN,ZTSAVE
42 S ZTDESC="CREATE PATIENT LIST"
43 S ZTRTN="RUN^PXRMLCR(PXRMRULE,PXRMLIST,PXRMNODE,BEG,END,PXRMDPAT,PXRMTPAT)"
44 S ZTSAVE("BEG")=""
45 S ZTSAVE("END")=""
46 S ZTSAVE("PATCREAT")=""
47 S ZTSAVE("PXRMDPAT")=""
48 S ZTSAVE("PXRMLIST")=""
49 S ZTSAVE("PXRMNODE")=""
50 S ZTSAVE("PXRMRULE")=""
51 S ZTSAVE("PXRMTPAT")=""
52 S ZTSAVE("PLISTPUG")=""
53 S ZTIO=""
54 ;
55 ;Select and verify start date/time for task
56 N DIR,DTOUT,DUOUT,MINDT,SDTIME,STIME,X,Y
57 S MINDT=$$NOW^XLFDT
58 W !,"Queue the "_ZTDESC_" for "_$P($G(^PXRMXP(810.5,PXRMLIST,0)),U)_": "
59 S DIR("A",1)="Enter the date and time you want the job to start."
60 S DIR("A",2)="It must be after "_$$FMTE^XLFDT(MINDT,"5Z")
61 S DIR("A")="Start the task at: "
62 S DIR(0)="DAU"_U_MINDT_"::RSX"
63 D ^DIR
64 I $D(DTOUT)!$D(DUOUT) Q
65 S SDTIME=Y
66 ;
67 ;Put the task into the queue.
68 S ZTDTH=SDTIME
69 D ^%ZTLOAD
70 W !,"Task number ",ZTSK," queued." H 2
71EXIT Q
72 ;
73HELP(CALL) ;General help text routine
74 N HTEXT
75 I CALL=1 D
76 .S HTEXT(1)="Enter 'Y' to overwrite this existing list. Enter 'N' to"
77 .S HTEXT(2)="use a different patient list name."
78 ;
79 I CALL=2 D
80 .S HTEXT(1)="Enter 'Y' to make the list private or 'N' to make it public."
81 .S HTEXT(2)="You can give other users access to your private lists in the Patient List Menu screens."
82 ;
83 I CALL=3 D
84 .S HTEXT(1)="Enter Y to save the patient to a Reminder Patient List. Enter N to not save the output."
85 ;
86 I CALL=4 D
87 .S HTEXT(1)="Enter Y to turn on debug output."
88 .S HTEXT(2)="The debug output will send a series of MailMan messages to the requestor of the report"
89 .S HTEXT(3)="-**WARNING**- the reminder report will take longer to run if you turn on this option!"
90 D HELP^PXRMEUT(.HTEXT)
91 Q
92 ;
93PLIST(LIST,TEXT,IENO) ;Select Patient List
94 N X,Y,DIC,DLAYGO
95PL1 S DIC=810.5,DLAYGO=DIC,DIC(0)="QAEMZL"
96 S DIC("A")=TEXT
97 S DIC("S")="I $P($G(^(100)),U)'=""N"""
98 ;If this is a new entry save the creator, make the TYPE public and
99 ;CLASS local.
100 S DIC("DR")=".07///`"_DUZ_";.08///PUB;100///L"
101 W !
102 D ^DIC
103 I X="" W !,"A patient list name must be entered" G PL1
104 I X=(U_U) S DTOUT=1
105 I Y=-1 S DUOUT=1
106 I $D(DTOUT)!$D(DUOUT) Q
107 ;
108 ;I copy mode dissallow copy to same list
109 I IENO=$P(Y,U) W !,"A patient list cannot be copied to itself." G PL1
110 ;
111 I ($P(Y,U,3)=1) S LIST=$P(Y,U) Q
112 ;Check if OK to overwrite
113 N OWRITE
114 S OWRITE=$$ASKYN^PXRMEUT("N","Okay to overwite "_$P(Y,U,2),"PXRMLCR",1)
115 Q:$D(DTOUT) G:$D(DUOUT)!('OWRITE) PL1
116 S OWRITE=$$LDELOK^PXRMEUT($P(Y,U,1))
117 I 'OWRITE D G PL1
118 . W !,"In order to overwrite a list you must be the creator or a Reminder Manager!"
119 ;Return list ien
120 S LIST=$P(Y,U)
121 Q
122 ;
123LRULE(RULE) ;Select List Rule
124 N X,Y,DIC
125LR1 S DIC=810.4,DIC(0)="QAEMZ"
126 S DIC("A")="Select LIST RULE SET: "
127 ;Only allow rule sets with components
128 S DIC("S")="I $P(^(0),U,3)=3"
129 W !
130 D ^DIC
131 I X="" W !,"A list rule set name must be entered" G LR1
132 I X=(U_U) S DTOUT=1
133 I Y=-1 S DUOUT=1
134 I $D(DTOUT)!$D(DUOUT) Q
135 ;Return rule ien
136 S RULE=$P(Y,U)
137 ;Check that rule set is valid
138 N ERROR,LR,LRTYPE,NL,OP,SEQ,SUB,TEMP,TEXT
139 S SUB=$O(^PXRM(810.4,RULE,30,0))
140 I SUB="" W !,"Rule set has no component rules" G LR1
141 S (ERROR,SUB)=0,NL=1
142 F S SUB=$O(^PXRM(810.4,RULE,30,SUB)) Q:'SUB D Q:ERROR
143 .S TEMP=$G(^PXRM(810.4,RULE,30,SUB,0))
144 .S SEQ=$P(TEMP,U,1),LR=$P(TEMP,U,2),OP=$P(TEMP,U,3)
145 .I SEQ="" S NL=NL+1,TEXT(NL)=" Sequence is missing.",ERROR=1
146 .I LR="" S NL=NL+1,TEXT(NL)=" List rule is missing.",ERROR=1
147 .I OP="" S NL=NL+1,TEXT(NL)=" Operation is missing.",ERROR=1
148 .;The Insert operation can only be used with finding rules.
149 .I OP="F",LR'="" D
150 ..S LRTYPE=$P(^PXRM(810.4,LR,0),U,3)
151 ..I LRTYPE'=1 S NL=NL+1,TEXT(NL)=" Insert operation can only be used with finding rules.",ERROR=1
152 I ERROR D G LR1
153 .S TEXT(1)="The rule set is incomplete or incorrect:"
154 .D EN^DDIOL(.TEXT)
155 Q
156 ;
157 ;Build list and clear ^TMP files
158RUN(PXRMRULE,PXRMLIST,PXRMNODE,BEG,END,PXRMDPAT,PXRMTPAT) ;
159 ;Process rule set and update final patient list
160 D START^PXRMRULE(PXRMRULE,PXRMLIST,PXRMNODE,BEG,END,"","","",PXRMDPAT,PXRMTPAT,"")
161 ;Clear ^TMP lists created for rule
162 D CLEAR^PXRMRULE(PXRMRULE,PXRMNODE)
163 Q
164 ;
165REMOVE(IEN) ;
166 S $P(^PXRM(810.4,IEN,0),U,10)=""
167 Q "@1"
168 ;
Note: See TracBrowser for help on using the repository browser.