source: WorldVistAEHR/trunk/r/SCHEDULING-SD-SC/SCRPBK1.m@ 1147

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

initial load of WorldVistAEHR

File size: 3.8 KB
Line 
1SCRPBK1 ;MJK/ALB - RPC Broker Utilities ; 27 FEB 96
2 ;;5.3;Scheduling;**41,177**;AUG 13, 1993
3 ;
4GETDATA(SCDATA,SCTYPE,SCRPTID,SCRPTN,SCTEXT,SCSELS) ;
5 ; -- get file type entries for Selections form
6 ;
7 ; output: SCDATA(1..n) := info about entity. NOTE this is now in a
8 ; global location rather than an array for this RPC.
9 ;
10 ; -- SEE BOTTOM OF SCRPBK FOR MORE VARIABLE DEFINITIONS
11 ;
12 ; Related RPC: SCRP SELECTION SOURCE
13 ;
14 S SCDATA=$NA(^TMP($J,"PCMM","SCDATA"))
15 ;
16 IF SCTYPE="DIVISION" D DIV G GETDATAQ
17 ;
18 IF SCTYPE="TEAM" D TEAM G GETDATAQ
19 ;
20 IF SCTYPE="PRACTITIONER" D PRAC G GETDATAQ
21 ;
22 IF SCTYPE="ROLE" D ROLE G GETDATAQ
23 ;
24 IF SCTYPE="CLINIC" D CLIN G GETDATAQ
25 ;
26 IF SCTYPE="USERCLASS" D USER G GETDATAQ
27 ;
28GETDATAQ Q
29 ;
30CHK(SCX,SCLEN) ; -- check if text matches user input
31 Q SCX=""!($E(SCX,1,SCLEN)'=SCTEXT)
32 ;
33BACK(X) ; -- backup one char for scanning
34 Q $S(X="":"",$L(X)=1:$C($A(X)-1)_$C(122),1:$E(X,1,$L(X)-1)_$C($A($E(X,$L(X)))-1)_$C(122))
35 ;
36DIV ; -- get institution file entries
37 N SCI,Y,SCX,SCLEN,SCINC
38 S SCI=0,SCINC=0,SCX=$$BACK(SCTEXT),SCLEN=$L(SCTEXT)
39 F S SCI=$O(^SCTM(404.51,"AINST",SCI)) Q:'SCI D
40 . S Y=SCI,SC0=$G(^DIC(4,Y,0))
41 . Q:$$CHK($P(SC0,U),SCLEN)
42 . D SET($P(SC0,U)_U_SCTYPE_U_SCI,.SCINC,SCDATA)
43 Q
44 ;
45TEAM ; -- get team file entries
46 N SCI,Y,SCX,SCLEN,SCINC,VAUTD
47 S SCI=0,SCINC=0,SCX=$$BACK(SCTEXT),SCLEN=$L(SCTEXT)
48 D VAUTD(.SCSELS,.VAUTD)
49 F S SCX=$O(^SCTM(404.51,"B",SCX)) Q:$$CHK(SCX,SCLEN) D
50 . F S SCI=$O(^SCTM(404.51,"B",SCX,SCI)) Q:'SCI D
51 . . S Y=SCI,SC0=$G(^SCTM(404.51,Y,0))
52 . . IF $D(VAUTD(+$P(^(0),U,7))) D SET($P(SC0,U)_U_SCTYPE_U_SCI,.SCINC,SCDATA)
53 Q
54 ;
55PRAC ; -- get practitioner entries
56 N SCI,Y,SCX,SCLEN,SCINC,VAUTT
57 S SCI=0,SCINC=0,SCX=$$BACK(SCTEXT),SCLEN=$L(SCTEXT)
58 D VAUTT(.SCSELS,.VAUTT)
59 F S SCX=$O(^VA(200,"B",SCX)) Q:$$CHK(SCX,SCLEN) D
60 . F S SCI=$O(^VA(200,"B",SCX,SCI)) Q:'SCI D
61 . . S Y=SCI,SC0=$G(^VA(200,Y,0))
62 . . IF $D(VAUTT),$$PRACS^SCRPU1() D SET($P(SC0,U)_U_SCTYPE_U_SCI,.SCINC,SCDATA)
63 Q
64 ;
65ROLE ; -- get standard role file entries
66 N SCI,Y,SCX,SCLEN,SCINC,VAUTT
67 S SCI=0,SCINC=0,SCX=$$BACK(SCTEXT),SCLEN=$L(SCTEXT)
68 D VAUTT(.SCSELS,.VAUTT)
69 F S SCX=$O(^SD(403.46,"B",SCX)) Q:$$CHK(SCX,SCLEN) D
70 . F S SCI=$O(^SD(403.46,"B",SCX,SCI)) Q:'SCI D
71 . . S Y=SCI,SC0=$G(^SD(403.46,SCI,0))
72 . . IF $D(VAUTT),$$RL^SCRPU1() D SET($P(SC0,U)_U_SCTYPE_U_SCI,.SCINC,SCDATA)
73 Q
74 ;
75CLIN ; -- get clinic entries
76 N SCI,Y,SCX,SCLEN,SCINC,VAUTD,VAUTT,SCLIN
77 S SCLIN="^TMP($J,""PCMM"",""SCLIN"")"
78 K @SCLIN
79 S SCI=0,SCINC=0,SCLEN=$L(SCTEXT)
80 IF SCRPTID=2 D
81 . Q
82 ELSE D
83 . D VAUTT(.SCSELS,.VAUTT)
84 F SCXREF="B","C","TEAMS" S SCX=$$BACK(SCTEXT) D Q:SCTEXT=""
85 . F S SCX=$O(^SC(SCXREF,SCX)) Q:$$CHK(SCX,SCLEN) D
86 . . F S SCI=$O(^SC(SCXREF,SCX,SCI)) Q:'SCI IF '$D(@SCLIN@(SCI)) D
87 . . . S Y=SCI,SC0=$G(^SC(Y,0))
88 . . . IF SCRPTID=2,$$CLSC2^SCRPU1() D SET($P(SC0,U)_U_SCTYPE_U_SCI,.SCINC,SCDATA) S @SCLIN@(SCI)=""
89 . . . IF SCRPTID'=2,$D(VAUTT),$$CLSC^SCRPU1() D SET($P(SC0,U)_U_SCTYPE_U_SCI,.SCINC,SCDATA)
90 K @SCLIN
91 Q
92 ;
93USER ; -- get user class file entries
94 N SCI,Y,SCX,SCLEN,SCINC,VAUTT
95 S SCI=0,SCINC=0,SCX=$$BACK(SCTEXT),SCLEN=$L(SCTEXT)
96 D VAUTT(.SCSELS,.VAUTT)
97 F S SCX=$O(^USR(8930,"B",SCX)) Q:$$CHK(SCX,SCLEN) D
98 . F S SCI=$O(^USR(8930,"B",SCX,SCI)) Q:'SCI D
99 . . S Y=SCI,SC0=$G(^USR(8930,SCI,0))
100 . . IF $D(VAUTT),$$USRCL^SCRPU1() D SET($P(SC0,U)_U_SCTYPE_U_SCI,.SCINC,SCDATA)
101 Q
102 ;
103VAUTD(SCSELS,VAUTD) ; -- build division util array
104 N I,X
105 F I=1:1 S X=$G(SCSELS(I)) Q:X="" IF $P(X,U,2)="DIVISION" S VAUTD(+$P(X,U,3))=$P(X,U)
106 S:$D(VAUTD) VAUTD=0
107 Q
108 ;
109VAUTT(SCSELS,VAUTT) ; -- build team util array
110 N I,X
111 IF SCRPTID=3 S VAUTT=1 G VAUTTQ
112 F I=1:1 S X=$G(SCSELS(I)) Q:X="" IF $P(X,U,2)="TEAM" S VAUTT(+$P(X,U,3))=$P(X,U)
113 S:$D(VAUTT) VAUTT=0
114VAUTTQ Q
115 ;
116SET(X,INC,SCDATA) ; -- set value in return array
117 S INC=$G(INC)+1,@SCDATA@(INC)=X
118 Q
119 ;
Note: See TracBrowser for help on using the repository browser.