source: WorldVistAEHR/trunk/r/CLINICAL_REMINDERS-PXRM/PXRMGECJ.m@ 1261

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

initial load of WorldVistAEHR
File size: 9.1 KB
RevLine 
[613]1PXRMGECJ ;SLC/AGP,JVS - Restore Func ;7/14/05 10:42
2 ;;2.0;CLINICAL REMINDERS;**4**;Feb 04, 2005;Build 21
3 ;Restore GEC Referral to open status
4 Q
5 ;
6EN ;Starting point
7 N DIR,DA,DFN,STATUS,NAME,STAMP,CNT,FIRST,SECOND,DIRUT
8 K ^TMP("PXRMGEC_CK1",$J),DIR(0),^TMP("PXRMGEC_CK2",$J)
9 D PAT
10 I $D(DIRUT) Q
11 ;
12DISP ;Display referrals and data
13 N LOC,DIV,SSN,AGE
14 S NAME=$P(^DPT(DFN,0),"^",1)
15 S LOC=$S($D(^DPT(DFN,.1)):"INPATIENT",1:"OUTPATIENT")
16 S DIV=$$GET1^DIQ(2,DFN,.19) I DIV="" S DIV="Unknown"
17 S SSN=$$GET1^DIQ(2,DFN,.09)
18 S AGE=$$GET1^DIQ(2,DFN,.033)
19 S STATUS=$$CK1(DFN)_"^"_$$CK2(DFN)
20 ;
21 ;
22 W !,"================================================================================"
23 W !,NAME," (",SSN,") "," AGE:",AGE," ",LOC," ",DIV," Division",!
24 W !,?5,"Current Open Referral::"
25 I +STATUS=0 W !,?10,"< N O N E >"
26 I +STATUS=1 D
27 .N I,DATE,DIALOG,USER,STAMP
28 .S I=0 F S I=$O(^TMP("PXRMGEC_CK1",$J,I)) Q:I="" D
29 ..S J=0 F S J=$O(^TMP("PXRMGEC_CK1",$J,I,J)) Q:J="" D
30 ...S STAMP=$P(^TMP("PXRMGEC_CK1",$J,I,J),"^",2) I STAMP'="" S STAMP=$$FMTE^XLFDT(STAMP,"1P")
31 ...S DIALOG=$$DIALOG($P(^TMP("PXRMGEC_CK1",$J,I,J),"^",3))
32 ...S USER=$P(^TMP("PXRMGEC_CK1",$J,I,J),"^",5) I USER'="" S USER=$P(^VA(200,USER,0),"^",1)
33 ...S DATE=$P(^TMP("PXRMGEC_CK1",$J,I,J),"^",6) I DATE'="" S DATE=$$FMTE^XLFDT(DATE,"1P")
34 ...I J=1 W !,$O(^TMP("PXRMGEC_CK1",$J,0)),?10,STAMP_" (start date)"
35 ...W !,?15,DIALOG,?35," by: ",USER," ",?62," On: ",DATE
36 ;
37 W !!,?5,"Historical Referral(s)::"
38 I $P(STATUS,"^",2)=0 D
39 .W !,?10,"< N O N E >"
40 I $P(STATUS,"^",2)=1 D
41 .N J,K,STAMP,STAMPB,DIALOG,USER,DATE,I,DAX,COUNT
42 .S STAMPB=1,J=1,K=0,COUNT=$S($D(LOOP):5,1:0)
43 .S I=1 F S I=$O(^TMP("PXRMGEC_CK2",$J,I)),COUNT=COUNT+1 Q:I="" Q:COUNT=3 D
44 ..W !
45 ..S K=0 F S K=$O(^TMP("PXRMGEC_CK2",$J,I,K)) Q:K="" D
46 ...S DAX=0 F S DAX=$O(^TMP("PXRMGEC_CK2",$J,I,K,DAX)) Q:DAX="" D
47 ....S STAMP=$P(^TMP("PXRMGEC_CK2",$J,I,K,DAX),"^",2)
48 ....I STAMP'=STAMPB S J=J+1,CNT=I
49 ....S CNTA=$O(^TMP("PXRMGEC_CK2",$J,0)),CNTB=CNTA+2
50 ....S STAMP=$$FMTE^XLFDT(STAMP,"1P")
51 ....S DIALOG=$$DIALOG($P(^TMP("PXRMGEC_CK2",$J,I,K,DAX),"^",3))
52 ....S USER=$P(^TMP("PXRMGEC_CK2",$J,I,K,DAX),"^",5) I USER'="" S USER=$P(^VA(200,USER,0),"^",1)
53 ....S DATE=$P(^TMP("PXRMGEC_CK2",$J,I,K,DAX),"^",6) I DATE'="" S DATE=$$FMTE^XLFDT(DATE,"1P")
54 ....I STAMP'=STAMPB W !,I,?10,STAMP_" (start date)"
55 ....W !,?15,DIALOG," ",?35," by: ",USER," ",?62," On: ",DATE
56 ....S STAMPB=STAMP
57 ;
58ASK ;Ask the User what they want to do.
59 N DIR,Y,X,MODE,ROPNNUM
60 K DIR(0),DIR("A")
61 I STATUS="0^1",CNT=2,'$D(LOOP) S DIR(0)="S^R:Re-open 1 Referral;V:View All Historical Referrals;P:New Patient;Q:Quit"
62 I STATUS="0^1",CNT=2,$D(LOOP) S DIR(0)="S^R:Re-open 1 Referral;D:Display Last 2 Referrals Only;P:New Patient;Q:Quit"
63 I STATUS="0^1",CNT>2,'$D(LOOP) S DIR(0)="S^R:Re-open 1 Referral;M:Merge 2 Referrals;V:View All Historical Referrals;P:New Patient;Q:Quit"
64 I STATUS="0^1",CNT>2,$D(LOOP) S DIR(0)="S^R:Re-open 1 Referral;M:Merge 2 Referrals;D:Display Last 2 Referrals Only;P:New Patient;Q:Quit"
65 I STATUS="1^1",'$D(LOOP) S DIR(0)="S^C:CLOSE Open Referral;M:Merge 2 Referrals;V:View ALL Historical Referrals;P:New Patient;Q:Quit"
66 I STATUS="1^1",$D(LOOP) S DIR(0)="S^C:CLOSE Open Referral;M:Merge 2 Referrals;D:Display Last 2 Referrals Only;P:New Patient;Q:Quit"
67 I STATUS="1^0"!(STATUS="0^0") S DIR(0)="S^C:CLOSE Open Referral;P:New Patient;Q:Quit"
68 D ^DIR S MODE=Y W !
69 I MODE="R" D
70 .S DIR(0)="NO^"_$O(^TMP("PXRMGEC_CK2",$J,0))_":"_CNT_":0"
71 .S DIR("A")="Enter the number on the Left side of the screen next to the Historical Referral that you want to re-open."
72 .D ^DIR
73 .S ROPNNUM=Y
74 I MODE="M" D I $D(DIRUT) G ASK
75MRG .I STATUS="0^1" S DIR(0)="NO^"_CNTA_":"_$S($D(LOOP):CNT,1:CNTB)_":0"
76 .I STATUS="1^1" S DIR(0)="NO^"_$O(^TMP("PXRMGEC_CK1",$J,0))_":"_CNT_":0"
77 .S DIR("A")="First Referral Record"
78 .D ^DIR Q:$D(DIRUT) S FIRST=Y D Q:$D(DIRUT)
79 ..I STATUS="0^1" S DIR(0)="NO^"_CNTA_":"_$S($D(LOOP):CNT,1:CNTB)_":0"
80 ..I STATUS="1^1" S DIR(0)="NO^"_$O(^TMP("PXRMGEC_CK1",$J,0))_":"_CNT_":0"
81 ..S DIR("A")="Second Referral Record"
82 ..D ^DIR Q:$D(DIRUT) S SECOND=Y
83 .I +FIRST>0,+SECOND>0,FIRST=SECOND W !,"Try again.." G MRG
84 I MODE="Q" D EXIT
85 I MODE="R" D REOPEN^PXRMGECL(ROPNNUM) G DISP
86 I MODE="M" D MERGE(FIRST,SECOND,DFN) G DISP
87 I MODE="V" S LOOP=1 G DISP
88 I MODE="D" K LOOP G DISP
89 I MODE="P" G EN
90 I MODE="C" D FINISHED^PXRMGECU(DFN,1) G DISP
91 Q
92 ;
93MERGE(FIR,SEC,DFN) ;Merge 2 Referrals
94 Q:FIR=""
95 Q:SEC=""
96 Q:DFN=""
97 N DATE1,DATE2,OLDDT,OLD,SRCHDT
98 W !,"DO MERGE",!
99 ;Get Date to use for setting and to be changed.
100 I $D(^TMP("PXRMGEC_CK1",$J,FIR,1)) S DATE(FIR)=$P($G(^TMP("PXRMGEC_CK1",$J,FIR,1)),"^",2)
101 I $D(^TMP("PXRMGEC_CK1",$J,SEC,1)) S DATE(SEC)=$P($G(^TMP("PXRMGEC_CK1",$J,SEC,1)),"^",2)
102 I $D(^TMP("PXRMGEC_CK2",$J,FIR)) D
103 .N SUB3,SUBDA
104 .S SUB3=$O(^TMP("PXRMGEC_CK2",$J,FIR,0))
105 .S SUBDA=$O(^TMP("PXRMGEC_CK2",$J,FIR,SUB3,0))
106 .S DATE(FIR)=$P($G(^TMP("PXRMGEC_CK2",$J,FIR,SUB3,SUBDA)),"^",2)
107 I $D(^TMP("PXRMGEC_CK2",$J,SEC)) D
108 .N SUB3,SUBDA
109 .S SUB3=$O(^TMP("PXRMGEC_CK2",$J,SEC,0))
110 .S SUBDA=$O(^TMP("PXRMGEC_CK2",$J,SEC,SUB3,0))
111 .S DATE(SEC)=$P($G(^TMP("PXRMGEC_CK2",$J,SEC,SUB3,SUBDA)),"^",2)
112 S OLD(DATE(FIR))=FIR
113 S OLD(DATE(SEC))=SEC
114 S OLDDT=$O(OLD(0))
115 S SRCHDT=$O(OLD(OLDDT))
116 ;
117 ;List of Health Factors DA's to change
118 N DATE,ARY,GEC,DA,VISIT,ROOT,PKG,SOURCE
119 N HF0,HF12,HF801,HF812,ARY1
120 S ARY="^AUPNVHF(""AED"","_SRCHDT_","_DFN_")"
121 S GEC="" F S GEC=$O(@ARY@(GEC)) Q:GEC="" D
122 .S DA=0 F S DA=$O(@ARY@(GEC,DA)) Q:DA="" D
123 ..S VISIT=$P($G(^AUPNVHF(DA,0)),"^",3)
124 ..S ^TMP("PXRMGECMRG",$J,VISIT,DA,SRCHDT)=""
125 ;
126 ;Change HF with DATA2PCE
127 S I=0
128 S ROOT="^TMP(""PXRMGECMRGPCE"",$J)"
129 S SOURCE="Geriatric Extended Care Merge"
130 ;
131 S ARY1="^TMP(""PXRMGECMRG"",$J)"
132 S VISIT=0 F S VISIT=$O(@ARY1@(VISIT)) Q:VISIT="" D
133 .S DA=0 F S DA=$O(@ARY1@(VISIT,DA)) Q:DA="" D
134 ..I $D(^AUPNVHF(DA)) D
135 ...S HF0=$G(^AUPNVHF(DA,0))
136 ...S HF12=$G(^AUPNVHF(DA,12))
137 ...S HF812=$G(^AUPNVHF(DA,812))
138 ...;
139 ...S PKG=$P(HF812,"^",2)
140 ...S SOURCE=$P(HF812,"^",3)
141 ...S USER=DUZ
142 ...S @ROOT@("HEALTH FACTOR",DA,"HEALTH FACTOR")=$P(HF0,"^",1)
143 ...S @ROOT@("HEALTH FACTOR",DA,"LEVEL/SEVERITY")=$P(HF0,"^",4)
144 ...S @ROOT@("HEALTH FACTOR",DA,"ENC PROVIDER")=$P(HF12,"^",4)
145 ...S @ROOT@("HEALTH FACTOR",DA,"EVENT D/T")=OLDDT
146 .I $D(^TMP("PXRMGECMRGPCE",$J)) D
147 ..N NOEVT
148 ..S NOEVT="PXKNOEVT"
149 ..S @NOEVT=1
150 ..S OK=$$DATA2PCE^PXAPI(ROOT,PKG,SOURCE,.VISIT,USER,"","","")
151 ;
152 ;Change 801.55
153 N GEC,DA,GECX,GECM
154 ;
155 S GEC="" F S GEC=$O(^PXRMD(801.55,"AC",DFN,SRCHDT,GEC)) Q:GEC="" D
156 .S DA=0 F S DA=$O(^PXRMD(801.55,"AC",DFN,SRCHDT,GEC,DA)) Q:DA="" D
157 ..S GECX(1,801.55,DA_",",.02)=OLDDT
158 ..D FILE^DIE("","GECX(1)") K GECX
159 ..;
160 ..I FIR=$O(^TMP("PXRMGEC_CK1",$J,0)) D
161 ...;I FIR=1!(SEC=1) D
162 ...I '$D(^PXRMD(801.5,"AC",DFN,SRCHDT,GEC)) D
163 ....S GECM(1,801.5,"+1,",.01)=$P($G(^PXRMD(801.55,DA,0)),"^",1)
164 ....S GECM(1,801.5,"+1,",.02)=$P($G(^PXRMD(801.55,DA,0)),"^",2)
165 ....S GECM(1,801.5,"+1,",.03)=$P($G(^PXRMD(801.55,DA,0)),"^",3)
166 ....S GECM(1,801.5,"+1,",.04)=$P($G(^PXRMD(801.55,DA,0)),"^",4)
167 ....S GECM(1,801.5,"+1,",.05)=$P($G(^PXRMD(801.55,DA,0)),"^",5)
168 ....S GECM(1,801.5,"+1,",.06)=$P($G(^PXRMD(801.55,DA,0)),"^",6)
169 ....D UPDATE^DIE("","GECM(1)")
170 ;
171 ;
172 ;Change 801.5
173 N GEC,DA,GECX
174 ;
175 S GEC="" F S GEC=$O(^PXRMD(801.5,"AC",DFN,SRCHDT,GEC)) Q:GEC="" D
176 .S DA=0 F S DA=$O(^PXRMD(801.5,"AC",DFN,SRCHDT,GEC,DA)) Q:DA="" D
177 ..S GECX(1,801.5,DA_",",.02)=OLDDT
178 ..D FILE^DIE("","GECX(1)") K GECX
179 ;EXIT
180 K ^TMP("PXRMGECMRG",$J)
181 K ^TMP("PXRMGECMRGPCE",$J)
182 Q
183 ;
184 ;
185PAT ;LOOK UP ALL PATIENTS
186 W @IOF,!
187 S DIR(0)="801.55,.01"
188 D ^DIR
189 S DFN=+Y
190 K Y,Y(0),Y(0,0)
191 Q
192 ;
193CK1(DFN) ;Check for current open referral
194 Q:DFN'>0
195 N STATUS,I,Z
196 K ^TMP("PXRMGEC_CK1",$J)
197 S STATUS=0,I=1,J=0
198 ;S Z=$$CK2(DFN) S I=$O(^TMP("PXRMGEC_CK2",$J,0))-1
199 I $D(^PXRMD(801.5,"B",DFN)) D
200 .S DA=0 F S DA=$O(^PXRMD(801.5,"B",DFN,DA)) Q:DA="" S J=J+1 D
201 ..S ^TMP("PXRMGEC_CK1",$J,I,J)=$G(^PXRMD(801.5,DA,0))
202 .S STATUS=1
203 Q STATUS
204 ;
205CK2(DFN) ;Check for entries in History file 801.55
206 Q:DFN'>0
207 N STATUS,I,CURRENT,DATE,DIA,DA,J
208 K ^TMP("PXRMGEC_CK2",$J)
209 S STATUS=0,I=1000,J=0
210 I $D(^TMP("PXRMGEC_CK1",$J)) S CURRENT=$P($G(^TMP("PXRMGEC_CK1",$J,$O(^TMP("PXRMGEC_CK1",$J,0)),1)),"^",2)
211 I $D(^PXRMD(801.55,"B",DFN)) D
212 .S DATE="" F S DATE=$O(^PXRMD(801.55,"AC",DFN,DATE)) Q:DATE="" D
213 ..Q:$G(CURRENT)=DATE
214 ..S I=I-1
215 ..S DIA="" F S DIA=$O(^PXRMD(801.55,"AC",DFN,DATE,DIA)) Q:DIA="" D
216 ...S J=J+1
217 ...S DA=0 F S DA=$O(^PXRMD(801.55,"AC",DFN,DATE,DIA,DA)) Q:DA="" D
218 ....S ^TMP("PXRMGEC_CK2",$J,I,J,DA)=$G(^PXRMD(801.55,DA,0))
219 ....S STATUS=1
220 ;RENUMBER ARRAY
221 I $D(^TMP("PXRMGEC_CK2",$J)) D
222 .N OLD,NEW,J,DA,DATA
223 .S NEW=1
224 .S OLD=0 F S OLD=$O(^TMP("PXRMGEC_CK2",$J,OLD)) Q:OLD="" D
225 ..S NEW=NEW+1
226 ..S J=0 F S J=$O(^TMP("PXRMGEC_CK2",$J,OLD,J)) Q:J="" D
227 ...S DA=0 F S DA=$O(^TMP("PXRMGEC_CK2",$J,OLD,J,DA)) Q:DA="" D
228 ....S DATA=$G(^TMP("PXRMGEC_CK2",$J,OLD,J,DA))
229 ....S ^TMP("PXRMGEC_CK2",$J,NEW,J,DA)=DATA
230 ....K ^TMP("PXRMGEC_CK2",$J,OLD,J,DA)
231 Q STATUS
232 ;
233DIALOG(DIA) ;Returns expanded name of dialog
234 N NAME
235 S NAME=""
236 I DIA="GEC1" S NAME="Social Services"
237 I DIA="GEC2" S NAME="Nursing Assessment"
238 I DIA="GEC3" S NAME="Care Recommendation"
239 I DIA="GECF" S NAME="Care Coordination"
240 Q NAME
241 ;
242EXIT ;CLEAN UP
243 K CK2,LOOP,X,CNTA,CNTB,ROPNNUM
244 K ^TMP("PXRMGEC_CK1",$J),^TMP("PXRMGEC_CK2",$J)
245 Q
246 ;
Note: See TracBrowser for help on using the repository browser.