source: WorldVistAEHR/trunk/r/CLINICAL_REMINDERS-PXRM/PXRMLCR.m@ 1800

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

revised back to 6/30/08 version

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