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

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

initial load of FOIAVistA 6/30/08 version
File size: 4.8 KB
Line 
1CRHD6 ; CAIRO/CLC - MISC ROUTINE FOR CAIRO HAND-OFF TOOL ;04-Mar-2008 16:00;CLC
2 ;;1.0;CRHD;****;Jan 28, 2008;Build 19
3 ;=================================================================
4GETP(CRHDRTN,CRHDE) ;
5 N CRHDPAR,Y,CRHDX,CRHDCT,CRHDMN,CRHDP,CRHDE1,CRHDE2,CRHDE3,CRHDE4
6 N CRHDX2,CRHDRSL,CRHDL,CRHDXCT,CRHDTRSL,CRHDEX,CRHDEE,CRHDXY
7 S Y=-1
8 S CRHDE1=+CRHDE ;internal entry number to file
9 S CRHDE2=$P(CRHDE,"^",2) ;name
10 S CRHDE3=$P(CRHDE,"^",3) ;types
11 ; USR - New Person
12 ; OTL - OE/RR Team
13 ; SRV - Service/Section
14 ; DIV-Institution;
15 ;
16 S CRHDCT=0
17 S CRHDL=$L(CRHDE,"^")
18 S CRHDE4="DIV.`"_$P($P(CRHDE,"^",CRHDL),"-",2) ;User Sign in Division
19 I $P(CRHDE4,"`",2)="" D USERDIV^CRHD5(.CRHDEE,DUZ) S CRHDE4="DIV.`"_$G(CRHDEE(1))
20 S CRHDE3=$P($P(CRHDE,"^",CRHDL),"-",1)
21 S CRHDPAR=CRHDE3_".`"_CRHDE1
22 I CRHDPAR'="" D LOOKUP^XPAREDIT(CRHDPAR,183)
23 I Y>-1 D
24 .S CRHDMN=+Y
25 .S CRHDP=0
26 .F S CRHDP=$O(^CRHD(183,CRHDMN,1,CRHDP)) Q:'CRHDP D
27 ..S CRHDCT=CRHDCT+1
28 ..I $P($G(^CRHD(183,CRHDMN,1,CRHDP,0)),"^",2)="" D
29 ...S CRHDX2=0 F S CRHDX2=$O(^CRHD(183,CRHDMN,1,CRHDP,1,CRHDX2)) Q:'CRHDX2 D
30 ....S CRHDRTN(CRHDCT)=$P($G(^CRHD(183,CRHDMN,1,CRHDP,0)),"^",1)_"^"_$G(^CRHD(183,CRHDMN,1,CRHDP,1,CRHDX2,0))
31 ....S CRHDCT=CRHDCT+1
32 ..E S CRHDRTN(CRHDCT)=$G(^CRHD(183,CRHDMN,1,CRHDP,0))
33 ;get Temp fields expiration days
34 S CRHDEX=$$GET^XPAR(CRHDE4,"CRHD TEMP FLD EXPIRE",1,"I")
35 I 'CRHDEX S CRHDEX=2
36 S CRHDCT=CRHDCT+1,CRHDRTN(CRHDCT)="TEMP_FLD_EXPIRE"_"^"_CRHDEX
37 ;get dnr title and/or text
38 K CRHDRSL D DNRPARM^CRHDDR(.CRHDRSL,DUZ,$P($P(CRHDE,"^",CRHDL),"-",2)) D
39 .I $D(CRHDRSL) D
40 ..S (CRHDXCT,CRHDXY)=0 F S CRHDXY=$O(CRHDRSL(CRHDXY)) Q:'CRHDXY D
41 ...S CRHDXCT=CRHDXCT+1,CRHDTRSL(CRHDXCT)=CRHDXY_"^"_$P($G(^ORD(101.43,+CRHDXY,0)),"^",1)
42 .I $D(CRHDTRSL) K CRHDRSL M CRHDRSL=CRHDTRSL K CRHDTRSL
43 I $D(CRHDRSL) D RTNLST("DNR_Titles") K CRHDRSL
44 D GET^CRHD5(.CRHDRSL,CRHDE4,"CRHD DNR ORDER TITLE")
45 I $D(CRHDRSL) D RTNLST("DNR_Text")
46 Q
47RTNLST(CRHDTT) ;
48 I $D(CRHDRSL) D
49 .S CRHDX=0
50 .I CRHDTT["DNR_Titles" F S CRHDX=$O(CRHDRSL(CRHDX)) Q:'CRHDX S CRHDCT=CRHDCT+1,CRHDRTN(CRHDCT)=CRHDTT_"^"_CRHDRSL(CRHDX)
51 .E F S CRHDX=$O(CRHDRSL(CRHDX)) Q:'CRHDX S CRHDCT=CRHDCT+1,CRHDRTN(CRHDCT)=CRHDTT_"^"_$P(CRHDRSL(CRHDX),"^",2)
52 Q
53 ;
54SAVEP(CRHDRTN,CRHDE,CRHDPN,CRHDV,CRHDVAL) ;
55 N CRHDENT,CRHDX,CRHDX1,CRHDOLST,CRHDFG,CRHDL
56 S CRHDRTN(0)=1
57 I CRHDE="" S CRHDRTN(0)=0_"^Entity data not valid" Q
58 S CRHDL=$L(CRHDE,"^")
59 I +CRHDE S CRHDENT=$P($P(CRHDE,"^",CRHDL),"-",1)_".`"_+CRHDE
60 I CRHDPN="" S CRHDPN="CRHD DNR ORDER TITLE"
61 ;get all Instances of a Parameter
62 D GETLST^XPAR(.CRHDOLST,CRHDENT,CRHDPN,"I")
63 I $D(CRHDOLST) S CRHDFG=$$DELALL^CRHD5(CRHDENT,CRHDPN)
64 I $D(CRHDVAL) D
65 .S CRHDX=0,CRHDCT=0
66 .F S CRHDX=$O(CRHDVAL(CRHDX)) Q:'CRHDX D
67 ..S CRHDCT=CRHDCT+1
68 ..D SET^CRHD5(CRHDENT,CRHDPN,CRHDCT,CRHDVAL(CRHDX))
69 Q
70SAVEP2(CRHDRTN,CRHDE,CRHDPN,CRHDV,CRHDVAL) ;
71 N CRHDENT,CRHDX,CRHDX1,CRHDOLST,CRHDFG,CRHDL
72 S CRHDRTN(0)=1
73 I CRHDE="" S CRHDRTN(0)=0_"^Entity data not valid" Q
74 S CRHDL=$L(CRHDE,"^")
75 I +CRHDE S CRHDENT=$P($P(CRHDE,"^",CRHDL),"-",1)_".`"_+CRHDE
76 I CRHDPN="" S CRHDRTN(0)=0_"^Parameter name not valid" Q ;S PN="CRHD DNR ORDER TITLE"
77 I CRHDV=""&('$D(CRHDVAL)) S CRHDFG=$$DELALL^CRHD5(CRHDENT,CRHDPN) S CRHDRTN(0)=1 Q
78 ;get all Instances of a Parameter
79 D GETLST^XPAR(.CRHDOLST,CRHDENT,CRHDPN,"I")
80 I $G(CRHDOLST) S CRHDFG=$$DELALL^CRHD5(CRHDENT,CRHDPN) K CRHDOLST
81 I $D(CRHDVAL) D
82 .S CRHDX=0,CRHDCT=0
83 .F S CRHDX=$O(CRHDVAL(CRHDX)) Q:'CRHDX D
84 ..S CRHDCT=CRHDCT+1
85 ..I CRHDVAL(CRHDX)'="" D
86 ...I CRHDVAL(CRHDX)?1N.E S CRHDVAL(CRHDX)=+CRHDVAL(CRHDX)
87 ...I CRHDVAL(CRHDX)?1A.E S CRHDVAL(CRHDX)=$P(CRHDVAL(CRHDX),"^",1)
88 ..D SET^CRHD5(CRHDENT,CRHDPN,CRHDCT,CRHDVAL(CRHDX))
89 Q
90GETPAR2(CRHDRTN,CRHDE,CRHDPN) ;
91 ;Get XPAR parameter values
92 N CRHDENT,CRHDX,CRHDX1,CRHDL,CRHDOLST,CRHDPNUM,CRHDFMT,CRHDFG
93 N CRHDI
94 S CRHDRTN(0)=1
95 S CRHDFMT="I"
96 I CRHDE="" S CRHDRTN(0)=0_"^Entity data not valid" Q
97 S CRHDL=$L(CRHDE,"^")
98 I +CRHDE S CRHDENT=$P($P(CRHDE,"^",CRHDL),"-",1)_".`"_+CRHDE
99 I CRHDPN="" S CRHDRTN(0)=0_"^Parameter name not valid" Q ;S PN="CRHD DNR ORDER TITLE"
100 ;get format code
101 S CRHDPNUM=$O(^XTV(8989.51,"B",CRHDPN,0))
102 I CRHDPNUM D
103 .S CRHDFMT=$S(($P($G(^XTV(8989.51,CRHDPNUM,1)),"^",1)="F")!($P($G(^XTV(8989.51,CRHDPNUM,1)),"^",6)="F"):"E",1:"B")
104 ;get all Instances of a Parameter
105 D GETLST^XPAR(.CRHDOLST,CRHDENT,CRHDPN,CRHDFMT)
106 I CRHDFMT="B" D
107 .K CRHDRTN
108 .S CRHDI=0
109 .F S CRHDI=$O(CRHDOLST(CRHDI)) Q:'CRHDI S:$G(CRHDOLST(CRHDI,"V"))'="" CRHDRTN(CRHDI)=$G(CRHDOLST(CRHDI,"V"))
110 E K CRHDRTN D
111 .S CRHDI=0
112 .F S CRHDI=$O(CRHDOLST(CRHDI)) Q:'CRHDI S CRHDRTN(CRHDI)=$P(CRHDOLST(CRHDI),"^",2)
113 Q
Note: See TracBrowser for help on using the repository browser.