source: FOIAVistA/trunk/r/ZZREGIONAL-A1C-A5C-CRHD-RGED-RGUT-RGWB-RG/CRHD2.m@ 1288

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

initial load of FOIAVistA 6/30/08 version
File size: 8.5 KB
Line 
1CRHD2 ; CAIRO/CLC - GET DATA ITEMS FOR CHANGEOVER LIST ;08-Apr-2008 08:03;CLC
2 ;;1.0;CRHD;****;Jan 28, 2008;Build 19
3 ;=================================================================
4CODESTS(CRHDRTN,CRHDSTR) ;CODE STATUS -using orders, try to find and orderable item for DNR, if not found look for a text order
5 ; by the name of DNRTITLE, title also set up as a p
6 ;DFN - patient internal entry number to Patient file
7 ;DNRTITLE - DNR order title if not defined by a parameter
8 ;DIVISION - the division user logged into
9 ;LEN - length of text to return for each line, default:18
10 ;DTFLG - return the start date and stop date for order default:yes
11 ;
12 N CRHDDFN,CRHDDNRT,CRHDDIV,CRHDLEN,CRHDX,CRHDY,CRHDCT,CRHDMDNR,CRHDQQFG
13 N CRHDDTFG,CRHDOCT,CRHDSR,CRHDO,CRHDT,CRHDQ,CRHDQ1,CRHDQX,CRHDTMP,CRHDQY,CRHDFLG
14 K CRHDRTN
15 S CRHDDFN=+CRHDSTR
16 S CRHDDNRT=$P(CRHDSTR,U,2)
17 S CRHDDIV=$P(CRHDSTR,U,3)
18 S CRHDLEN=$P(CRHDSTR,U,4)
19 I 'CRHDLEN S CRHDLEN=18
20 S CRHDDTFG=$P(CRHDSTR,U,5)
21 I CRHDDTFG="" S CRHDDTFG=1
22 S CRHDMDNR=+$P(CRHDSTR,U,6)
23 D ENT^CRHDDR(.CRHDO,CRHDDFN,.CRHDDNRT,.CRHDDIV,CRHDMDNR)
24 D ENT^CRHDDNR(.CRHDT,CRHDDFN,.CRHDDNRT,.CRHDDIV,CRHDMDNR)
25 S CRHDQ=0 F S CRHDQ=$O(CRHDO(CRHDQ)) Q:'CRHDQ I $P(CRHDO(CRHDQ),"~",1)&(CRHDO(CRHDQ)["~") S CRHDTMP($P(CRHDO(CRHDQ),"~",1),$P(CRHDO(CRHDQ),"~",2))="CRHDO^"_CRHDQ
26 S CRHDQ=0 F S CRHDQ=$O(CRHDT(CRHDQ)) Q:'CRHDQ I $P(CRHDT(CRHDQ),"~",1)&(CRHDT(CRHDQ)["~") S CRHDTMP($P(CRHDT(CRHDQ),"~",1),$P(CRHDT(CRHDQ),"~",2))="CRHDT^"_CRHDQ
27 S (CRHDCT,CRHDQQFG)=0
28 S CRHDQ=0 F CRHDI=1:1 S CRHDQ=$O(CRHDTMP(CRHDQ)) Q:'CRHDQ!(CRHDQQFG) S CRHDQ1=0 F S CRHDQ1=$O(CRHDTMP(CRHDQ,CRHDQ1)) Q:'CRHDQ1 D
29 .S CRHDQFLG=0
30 .I 'CRHDMDNR S CRHDQQFG=1
31 .S CRHDQX=$P(CRHDTMP(CRHDQ,CRHDQ1),"^",1),CRHDQY=$P(CRHDTMP(CRHDQ,CRHDQ1),"^",2)
32 .S CRHDQ2=CRHDQY-1,CRHDQFLG=0 F S CRHDQ2=$O(@CRHDQX@(CRHDQ2)) Q:'CRHDQ2!(CRHDQFLG) D
33 ..I (CRHDQ2'=CRHDQY)&(@CRHDQX@(CRHDQ2)["~") S CRHDQFLG=1 S:('CRHDMDNR)&(CRHDI>1) CRHDQQFG=1 Q
34 ..I (CRHDQ2'=CRHDQY)&(@CRHDQX@(CRHDQ2)["~") S CRHDQFLG=1 Q
35 ..S CRHDCT=CRHDCT+1
36 ..I @CRHDQX@(CRHDQ2)["~" S CRHDRTN(CRHDCT)=$P(@CRHDQX@(CRHDQ2),"~",3)
37 ..E S CRHDRTN(CRHDCT)=@CRHDQX@(CRHDQ2)
38 I $D(CRHDRTN) D
39 .S CRHDX=0,CRHDCT=1
40 .F S CRHDX=$O(CRHDRTN(CRHDX)) Q:'CRHDX D
41 ..I $L(CRHDRTN(CRHDX))>CRHDLEN D
42 ...F Q:$L(CRHDRTN(CRHDX))=0 S CRHDCT=CRHDCT+1,CRHDY(CRHDCT)=$E(CRHDRTN(CRHDX),1,CRHDLEN),CRHDRTN(CRHDX)=$E(CRHDRTN(CRHDX),CRHDLEN+1,9999)
43 ..E D
44 ...I CRHDRTN(CRHDX)["Stop Date" S CRHDY(CRHDCT)=CRHDY(CRHDCT)_" "_CRHDRTN(CRHDX) D
45 ....I $L(CRHDY(CRHDCT))>CRHDLEN S CRHDOCT=CRHDCT,CRHDSR=CRHDY(CRHDCT) F Q:$L(CRHDSR)=0 S CRHDY(CRHDCT)=$E(CRHDSR,1,CRHDLEN),CRHDSR=$E(CRHDSR,CRHDLEN+1,9999),CRHDOCT=CRHDOCT+1
46 ...E S CRHDCT=CRHDCT+1,CRHDY(CRHDCT)=CRHDRTN(CRHDX)
47 K CRHDRTN
48 M CRHDRTN=CRHDY
49 I CRHDCT>1 S CRHDRTN(1)=CRHDCT-1
50 I $G(CRHDRTN(2))="" S CRHDRTN(1)=1,CRHDRTN(2)="Code Status Not Found"
51 Q
52NODETAM(CRHDY,CRHDDFN,CRHDCAT) ;GET ACTIVE MEDS WITHOUT THE DETAILS, FOR ACTIVE MEDS WITH DETAILS USE CRHDAM
53 ;CRHDCAT :I - inpatient
54 ; O - outpatient
55 N CRHDP1,CRHDP2,CRHDPP1,CRHDPP2,CRHDCT,CRHDN2,CRHDN3,CRHDRTN,CRHDSORT
56 N CRHDN
57 S CRHDCT=0
58 D COVER^ORWPS(.CRHDRTN,CRHDDFN)
59 I '$D(CRHDRTN) Q
60 S CRHDN=0
61 F S CRHDN=$O(CRHDRTN(CRHDN)) Q:'CRHDN D
62 .S CRHDP1=$P(CRHDRTN(CRHDN),"^",1)
63 .S CRHDPP1=$P(CRHDP1,";",1)
64 .S CRHDPP2=$P(CRHDP1,";",2)
65 .I CRHDCAT="O"&(CRHDPP2="O") D SORT
66 .I CRHDCAT="I"&(CRHDPP2="I") D SORT
67 D OUTPUT Q
68 Q
69SORT ;
70 I $P(CRHDRTN(CRHDN),"^",4)'["ACTIVE" Q
71 S CRHDSORT($E(CRHDPP1,$L(CRHDPP1)),$P(CRHDRTN(CRHDN),"^",2),CRHDPP1)=""
72 Q
73OUTPUT ;
74 S CRHDN=""
75 F S CRHDN=$O(CRHDSORT(CRHDN)) Q:CRHDN="" D
76 .S CRHDN2="" F S CRHDN2=$O(CRHDSORT(CRHDN,CRHDN2)) Q:CRHDN2="" D
77 ..S CRHDN3="" F S CRHDN3=$O(CRHDSORT(CRHDN,CRHDN2,CRHDN3)) Q:CRHDN3="" D
78 ...S CRHDCT=CRHDCT+1
79 ...I CRHDCAT="O"&(CRHDN="N") S CRHDY(CRHDN,CRHDCT)="NON-VA "_CRHDN2 Q
80 ...S CRHDY(CRHDN,CRHDCT)=CRHDN2
81 S CRHDY(0)=CRHDCT_"^"_CRHDCAT_$S(CRHDCAT="O":"UT",1:"N")_"PATIENT"
82 Q
83TEMPDATA(CRHDRTN,CRHDFLDN,CRHDUSER,CRHDDFN,CRHDTXT) ;TEMPORARY DATA, DATA ONLY USE FOR A SHORT TIME FRAME
84 ;CRHDFLD - TEMP FIELD NAME
85 ;CRHDUSER - AUTHOR OF THE NOTE
86 ;if fld already has the author then this is 'WHO LAST EDITED'
87 ;CRHDDFN - Patient
88 ;TEXT - Text to be stored
89 N CRHDFDA,CRHDOUT,CRHDERR,CRHDFN,CRHDUPZ,CRHDUPZZ,CRHDPZZZ
90 K CRHDRTN,CRHDUPY
91 S CRHDFLDN=$$UP^XLFSTR(CRHDFLDN)
92 S CRHDUPY=$$CHK(CRHDFLDN,CRHDUSER,CRHDDFN)
93 S CRHDUPZ=$P(CRHDUPY,"^",2)
94 I CRHDUPZ="+1," S CRHDUPZZ="?+1,",CRHDPZZZ="?+2,"
95 E S CRHDUPZZ="?+2,"
96 I CRHDUPZ="+1," S CRHDUPZ=CRHDUPZZ,CRHDUPZZ=CRHDPZZZ D NEW
97 E D UPDATE(CRHDFLDN,CRHDUSER,CRHDDFN,.CRHDTXT)
98 I $D(CRHDERR) D Q
99 .S ^CRHDER($$NOW^XLFDT,"ERROR-UPDATING DATA")=CRHDFLDN_U_CRHDUSER_U_CRHDDFN
100 .M ^CRHDER($$NOW^XLFDT,"ERROR-UPDATING DATA")=CRHDTXT Q
101 .K CRHDERR,CRHDOUT,CRHDFDA
102 .S CRHDRTN(1)=0_"^ERROR SAVING DATA..."
103 E S CRHDRTN(1)=1_"^SAVE SUCCESSFUL..."
104 Q
105NEW S CRHDFDA(183.21,CRHDUPZZ_CRHDUPZ,1)=CRHDUSER
106 S CRHDFDA(183.21,CRHDUPZZ_CRHDUPZ,2)=$$NOW^XLFDT
107 S CRHDFDA(183.21,CRHDUPZZ_CRHDUPZ,5)=0
108 D UPDATE(CRHDFLDN,CRHDUSER,CRHDDFN,.CRHDTXT)
109 I $D(CRHDERR) D
110 .S ^CRHDER($$NOW^XLFDT,"ERROR-ADDING DATA")=CRHDFLDN_U_CRHDUSER_U_CRHDDFN
111 .M ^CRHDER($$NOW^XLFDT,"ERROR-ADDING DATA")=CRHDTXT Q
112 .K CRHDERR,CRHDOUT,CRHDFDA
113 Q
114UPDATE(CRHDFLD,CRHDUSER,CRHDDFN,CRHDTXT) ;
115 ;SEE NEWDATA
116 S CRHDFDA(183.2,"?+1,",.01)=CRHDFLD
117 S CRHDFDA(183.21,CRHDUPZZ_CRHDUPZ,.01)=CRHDDFN
118 S CRHDFDA(183.21,CRHDUPZZ_CRHDUPZ,3)=CRHDUSER
119 S CRHDFDA(183.21,CRHDUPZZ_CRHDUPZ,4)=$$NOW^XLFDT
120 D UPDATE^DIE("","CRHDFDA","CRHDOUT","CRHDERR")
121 S CRHDIEN=$G(CRHDOUT(1)),CRHDMIEN=$G(CRHDOUT(2))
122 L +^CRHD(183.2,CRHDIEN,1,CRHDMIEN):1 I '$T Q
123 I '$D(CRHDERR) D STORETXT(CRHDIEN,CRHDMIEN,.CRHDTXT)
124 L -^CRHD(183.2,CRHDIEN,1,CRHDMIEN)
125 Q
126STORETXT(CRHDIEN,CRHDMIEN,CRHDTARY) ;store text to file
127 N CRHDTRG,CRHDFG,CRHDX,CRHDCT,CRHDLINE
128 Q:'CRHDIEN&('CRHDMIEN)
129 S CRHDTRG="CRHDTARY"
130 Q:'$D(@CRHDTRG)
131 ;D SAVEOLD(CRHDIEN,CRHDMIEN)
132 K ^CRHD(183.2,CRHDIEN,1,CRHDMIEN,"TEXT")
133 S ^CRHD(183.2,CRHDIEN,1,CRHDMIEN,"TEXT",0)="^^^^"_$$DT^XLFDT
134 S CRHDX=0 F CRHDLINE=0:1 S CRHDX=$O(@CRHDTRG@(CRHDX)) Q:'CRHDX
135 S (CRHDFG,CRHDX,CRHDCT)=0
136 F S CRHDX=$O(@CRHDTRG@(CRHDX)) Q:'CRHDX!(CRHDFG) D
137 .I $D(@CRHDTRG@(CRHDX,0)) D Q
138 ..M ^CRHD(183.2,CRHDIEN,1,CRHDMIEN,"TEXT")=@CRHDTRG
139 ..S $P(^CRHD(183.2,CRHDIEN,1,CRHDMIEN,"TEXT",0),"^",3,4)=CRHDLINE_"^"_CRHDLINE
140 ..S CRHDFG=1
141 .I $G(@CRHDTRG@(CRHDX))'="" D
142 ..S CRHDCT=CRHDCT+1
143 ..S ^CRHD(183.2,CRHDIEN,1,CRHDMIEN,"TEXT",CRHDCT,0)=@CRHDTRG@(CRHDX)
144 ..S $P(^CRHD(183.2,CRHDIEN,1,CRHDMIEN,"TEXT",0),"^",3,4)=CRHDCT_"^"_CRHDCT
145 Q
146SAVEOLD(CRHDIEN,CRHDMIEN) ;
147 I $D(^CRHD(183.2,CRHDIEN,1,CRHDMIEN,"TEXT")) D
148 .K ^CRHD(183.2,CRHDIEN,1,CRHDMIEN,"ZOLD_TEXT")
149 .M ^CRHD(183.2,CRHDIEN,1,CRHDMIEN,"ZOLD_TEXT")=^CRHD(183.2,CRHDIEN,1,CRHDMIEN,"TEXT")
150 Q
151CHK(CRHDFLDN,CRHDUSER,CRHDDFN) ;
152 N CRHDFLG,CRHDX,CRHDP ;FLG = 1 if record already exist
153 S CRHDFLG=0
154 S CRHDFN=183.2
155 S CRHDFLD=$O(^CRHD(CRHDFN,"B",CRHDFLDN,0))
156 I $D(^CRHD(CRHDFN,"C",+CRHDDFN,+CRHDFLD)) D
157 .S:CRHDFLD CRHDFLG=1
158 I CRHDFLG S CRHDFLG=CRHDFLG_"^"_CRHDFLD_","
159 E S CRHDFLG=CRHDFLG_"^"_"+1,"
160 Q CRHDFLG
161XREF(CRHDIEN,CRHDMIEN) ;SET THE XREF FOR SPECIALTY AND TEAM
162 N CRHDTM,CRHDTSP,CRHDAUTH,CRHDPAT
163 S CRHDAUTH=$P($G(^CRHD(183.2,CRHDIEN,1,CRHDMIEN,0)),"^",2)
164 Q:'CRHDAUTH
165 S CRHDPAT=$P($G(^CRHD(183.2,CRHDIEN,1,CRHDMIEN,0)),"^",1)
166 ;do not set up reference if a private note
167 Q:+$P($G(^CRHD(183.2,CRHDIEN,1,CRHDMIEN,0)),"^",6)
168 S CRHDTM=$$GET^XPAR("USR.`"_CRHDAUTH,"ORLP DEFAULT TEAM",1,"I")
169 S CRHDTSP=$$GET^XPAR("USR.`"_CRHDAUTH,"ORLP DEFAULT SPECIALTY",1,"I")
170 S:+CRHDTM ^CRHD(183.2,"AC","TM",CRHDTM,CRHDPAT,CRHDIEN,CRHDMIEN)=""
171 S:+CRHDTSP ^CRHD(183.2,"AC","TSP",CRHDTSP,CRHDPAT,CRHDIEN,CRHDMIEN)=""
172 Q
173KILXREF(CRHDIEN,CRHDMIEN) ;KILL XREF FOR SPECIALTY AND TEAM
174 N CRHDTM,CRHDTSP,CRHDAUTH,CRHDPAT
175 S CRHDAUTH=$P($G(^CRHD(183.2,CRHDIEN,1,CRHDMIEN,0)),"^",2)
176 Q:'CRHDAUTH
177 S CRHDPAT=$P($G(^CRHD(183.2,CRHDIEN,1,CRHDMIEN,0)),"^",1)
178 S CRHDTM=$$GET^XPAR("USR.`"_CRHDAUTH,"ORLP DEFAULT TEAM",1,"I")
179 S CRHDTSP=$$GET^XPAR("USR.`"_CRHDAUTH,"ORLP DEFAULT SPECIALTY",1,"I")
180 K:+CRHDTM ^CRHD(183.2,"AC","TM",CRHDTM,CRHDPAT,CRHDIEN,CRHDMIEN)
181 K:+CRHDTSP ^CRHD(183.2,"AC","TSP",CRHDTSP,CRHDPAT,CRHDIEN,CRHDMIEN)
182 Q
183ONOFFPRV(CRHDPRIV,CRHDIEN,CRHDMIEN) ;ON/OFF PRIVATE NOTE
184 I 'CRHDPRIV D XREF(CRHDIEN,CRHDMIEN)
185 I +CRHDPRIV D KILXREF(CRHDIEN,CRHDMIEN)
186 Q
187LOCK(CRHDRTN,CRHDDFN,CRHDFLDM) ;
188 N CRHDIEN,CRHDMIEN
189 S CRHDRTN=0
190 S CRHDFLDM=$$UP^XLFSTR(CRHDFLDM)
191 S CRHDIEN=$O(^CRHD(183.2,"B",CRHDFLDM,0))
192 S CRHDMIEN=$O(^CRHD(183.2,"C",+CRHDDFN,+CRHDIEN,0))
193 Q:'CRHDMIEN
194 L +^CRHD(183.2,CRHDIEN,1,CRHDMIEN):10 I '$T S CRHDRTN=1 ;_"^0^Another user is editing this task"
195 L -^CRHD(183.2,CRHDIEN,1,CRHDMIEN)
196 Q
Note: See TracBrowser for help on using the repository browser.