source: FOIAVistA/tag/r/ZZREGIONAL-A1C-A5C-CRHD-RGED-RGUT-RGWB-RG/CRHD5.m@ 1424

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

initial load of FOIAVistA 6/30/08 version

File size: 2.8 KB
Line 
1CRHD5 ; CAIRO/CLC - MISC ROUTINE FOR CAIRO HAND-OFF TOOL ;20-Mar-2008 13:28;CLC
2 ;;1.0;CRHD;****;Jan 28, 2008;Build 19
3 ;=================================================================
4SRV(CRHDY) ; RETURN LIST OF SERVICES/SECTIONS
5 N CRHDI,CRHDIEN,CRHDNAME
6 S CRHDI=1,CRHDNAME=""
7 F S CRHDNAME=$O(^DIC(49,"B",CRHDNAME)) Q:CRHDNAME="" S CRHDIEN=$O(^(CRHDNAME,0)) D
8 . S CRHDY(CRHDI)=CRHDIEN_"^"_CRHDNAME,CRHDI=CRHDI+1
9 Q
10DIV(CRHDY) ; RETURN LIST OF INSTITUTIONS
11 N CRHDI,CRHDIEN,CRHDNAME,CRHDIVST,CRHDINA
12 S CRHDI=1,CRHDNAME=""
13 F S CRHDNAME=$O(^DIC(4,"B",CRHDNAME)) Q:CRHDNAME="" S CRHDIEN=$O(^(CRHDNAME,0)) D
14 .S CRHDINA=$$GET1^DIQ(4,CRHDIEN_",",101,"I")
15 .S CRHDIVST=$$GET1^DIQ(4,CRHDIEN_",",11,"I")
16 .I 'CRHDINA S CRHDY(CRHDI)=CRHDIEN_"^"_CRHDNAME,CRHDI=CRHDI+1
17 Q
18SET(CRHDENT,CRHDP,CRHDS,CRHDVAL) ;Set the parameter
19 ;D PUT^XPAR("DIV.`583","CRHD DNR ORDER TITLE",2,"Patient DNR Orders")
20 ;CRHDENT=entity
21 ;CRHDP=Parameter name
22 ;CRHDS=Sequence (count)
23 ;CRHDVAL=parameter value
24 N CRHDERR,CRHDFG
25 ;
26 S CRHDFG=1
27 D PUT^XPAR(CRHDENT,CRHDP,+CRHDS,CRHDVAL,.CRHDERR)
28 I CRHDERR>0 S CRHDFG=0
29 Q CRHDFG
30DEL(CRHDENT,CRHDP,CRHDS) ;Delete a parameter value
31 N CRHDERR,CRHDFG
32 S CRHDFG=1
33 D DEL^XPAR(CRHDENT,CRHDP,CRHDS,.CRHDERR)
34 I CRHDERR>0 S CRHDFG=0
35 Q CRHDFG
36GET(CRHDRTN,CRHDENT,CRHDP) ;Get parameters from the parameter file
37 D GETLST^XPAR(.CRHDRTN,CRHDENT,CRHDP,"E")
38 Q
39DELALL(CRHDENT,CRHDP) ;Delete all instances
40 N CRHDERR,CRHDFG
41 S CRHDFG=1
42 D NDEL^XPAR(CRHDENT,CRHDP,.CRHDERR)
43 I CRHDERR>0 S CRHDFG=0
44 Q CRHDFG
45USERDIV(CRHDRTN,CRHDDUZ) ;
46 K CRHDRTN
47 N CRHDX,CRHDR,CRHDC
48 S CRHDC=0
49 D DIV4^XUSER(.CRHDR,CRHDDUZ)
50 S CRHDX=0
51 F S CRHDX=$O(CRHDR(CRHDX)) Q:'CRHDX!($D(CRHDRTN(1))) D
52 .I CRHDR(CRHDX)=1 S CRHDC=CRHDC+1,CRHDRTN(CRHDC)=CRHDX_"^"_$P($G(^DIC(4,+CRHDX,0)),"^",1)_"^1" K CRHDR(CRHDX)
53 S CRHDX=0
54 F S CRHDX=$O(CRHDR(CRHDX)) Q:'CRHDX D
55 .S CRHDC=CRHDC+1
56 .S CRHDRTN(CRHDC)=CRHDX_"^"_$P($G(^DIC(4,+CRHDX,0)),"^",1)_"^0"
57 Q
58DELPREF(CRHDRTN,CRHDE) ;delete a preference
59 N Y,X,CRHDE1,CRHDE2,CRHDE3,CRHDE4,CRHDE5,DA,DR,DIE,CRHDL
60 N CRHDPN
61 S CRHDRTN(1)=0
62 S CRHDE1=+CRHDE
63 S CRHDE2=$P(CRHDE,"^",2)
64 S CRHDL=$L(CRHDE,"^")
65 S CRHDE3=$P(CRHDE,"^",CRHDL)
66 S CRHDE4="DIV.`"_$P($P(CRHDE,"^",CRHDL),"-",2)
67 S CRHDE5=CRHDE1_$S(CRHDE3="USR":";VA(200,",CRHDE3="OTL":";OR(100.21,",CRHDE3="DIV":";DIC(4,",CRHDE3="SRV":";DIC(49,",1:"")
68 I CRHDE5'="" S DA=$O(^CRHD(183,"B",CRHDE5,0))
69 I DA D
70 .K ^CRHD(183,DA)
71 .K ^CRHD(183,"B",CRHDE5)
72 .K ^CRHD(183,"AC",+CRHDE5)
73 .;S DIE=183,DR=".01///@" D ^DIE
74 .I '$D(^CRHD(183,"B",CRHDE5)) S CRHDRTN(1)=1
75 .S CRHDENT=CRHDE3_".`"_CRHDE1
76 .I CRHDE3="DIV" S CRHDPN(1)="CRHD DNR ORDERABLE ITEMS",CRHDPN(2)="CRHD DNR ORDER TITLE"
77 .S CRHDX=0
78 .F S CRHDX=$O(CRHDPN(CRHDX)) Q:'CRHDX D
79 ..D GETLST^XPAR(.CRHDOLST,CRHDENT,CRHDPN(CRHDX),"I")
80 ..I $G(CRHDOLST) S CRHDFG=$$DELALL^CRHD5(CRHDENT,CRHDPN(CRHDX)) K CRHDOLST
81 Q
Note: See TracBrowser for help on using the repository browser.