source: FOIAVistA/tag/r/SCHEDULING-SD-SC/SCAPMCU3.m@ 1185

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

initial load of FOIAVistA 6/30/08 version

File size: 5.4 KB
Line 
1SCAPMCU3 ;MJK/ALB - AUTOLINK API ; 8/10/99 4:09pm
2 ;;5.3;Scheduling;**41,45,177,204**;AUG 13, 1993
3 ;
4GETREC(SCDATA,SCTEAM) ; -- get team record with autolink data
5 ; input : SCTEAM := ien of team
6 ; output : SCDATA is the return array
7 ; SCDATA(0) := 0th node of Team
8 ; (1..n) := autolink name ^ autolink type ^ ien of entity
9 ;
10 N SC,X
11 ; -- get 0th node of team
12 S X=$$GETEAM(SCTEAM)
13 ; -- add to return array
14 D SET(X,0,.SCDATA)
15 ; -- find all autolinks for team
16 D SCAN(SCTEAM,.SC)
17 ; -- build autolink string and add to return array
18 D BUILD(.SC,.SCDATA)
19 Q
20 ;
21BUILD(SC,SCDATA) ; -- build string to send and add to return array
22 N SCLINK,SCINC,X,SCGLB,SCTYPE
23 S SCINC=1
24 S SCLINK=""
25 F S SCLINK=$O(SC(SCLINK)) Q:SCLINK="" D
26 . S X=SCLINK
27 . IF X["DIC(42," S SCGLB="^DIC(42)",SCTYPE="WARD"
28 . IF X["DIC(45.7," S SCGLB="^DIC(45.7)",SCTYPE="SPECIALTY"
29 . IF X["VA(200," S SCGLB="^VA(200)",SCTYPE="PRACTITIONER"
30 . IF X["DG(405.4," S SCGLB="^DG(405.4)",SCTYPE="ROOM"
31 . IF X["SC(" S SCGLB="^SC",SCTYPE="CLINIC"
32 . ; - add data to return array
33 . IF $D(@SCGLB@(+SCLINK,0)) D SET($P(^(0),U)_U_SCTYPE_U_+SCLINK,.SCINC,.SCDATA)
34 Q
35 ;
36SET(X,INC,SCDATA) ; -- set value in return array
37 S INC=$G(INC)+1,SCDATA(INC)=X
38 Q
39 ;
40SETREC(SCOK,SCTEAM,SC) ; -- add/edit autolink data to Team record
41 ; input : SCTEAM := ien of team
42 ; output : SC is the input array
43 ; SC(1..n) := autolink name ^ autolink type ^ ien of entity
44 ;
45 N SCTYPE,SCROOT,SCGLB,SCLINK,SCLINKI,SCI,SCOLD,SCNEW
46 ; -- build array of current autolink assignments
47 D SCAN(SCTEAM,.SCOLD)
48 ;
49 ; -- compare current with input and add autolinks if in
50 ; input array but not in current array
51 S SCI=0 F S SCI=$O(SC(SCI)) Q:'SCI S SCX=SC(SCI) D
52 . S SCTYPE=$P(SCX,U,2)
53 . D ROOT(SCTYPE,.SCROOT,.SCGLB)
54 . S SCLINK=+$P(SCX,U,3)_";"_SCROOT
55 . S SCNEW(SCLINK)=""
56 . IF '$D(SCOLD(SCLINK)),SCGLB]"",$D(@SCGLB@(+SCLINK,0)) D ADD(SCTEAM,SCLINK)
57 ;
58 ; -- compare current with input and delete autolinks if not
59 ; in input array but in current array
60 S SCLINK=""
61 F S SCLINK=$O(SCOLD(SCLINK)) Q:'SCLINK IF '$D(SCNEW(SCLINK)) D
62 . S SCLINKI=+SCOLD(SCLINK)
63 . IF SCLINKI D DELETE(SCLINKI)
64 S SCOK=1
65 Q
66 ;
67ADD(SCTEAM,SCLINK) ; -- add an autolink to a Team
68 N DIC,DD,DO,DLAYGO
69 S DIC="^SCTM(404.56,",DLAYGO=404.56,DIC(0)="L",X=SCTEAM,DIC("DR")=".02////^S X=SCLINK"
70 D FILE^DICN
71 Q
72 ;
73DELETE(SCLINKI) ; -- delete an autolink from a Team
74 N DIK,DA
75 IF $D(^SCTM(404.56,SCLINKI,0)) D
76 . S DIK="^SCTM(404.56,",DA=SCLINKI D ^DIK
77 Q
78 ;
79GETEAM(SCTEAM) ; -- retrieve Team demographics
80 Q $G(^SCTM(404.51,+$G(SCTEAM),0))
81 ;
82SCAN(SCTEAM,SC) ; -- build an array of current autolink assignments
83 N SCLINK
84 S SCLINK=""
85 F S SCLINK=$O(^SCTM(404.56,"APRIMARY",+$G(SCTEAM),SCLINK)) Q:SCLINK="" S SC(SCLINK)=+$O(^(SCLINK,0))
86 Q
87 ;
88ROOT(SCTYPE,SCROOT,SCGLB) ; -- determine global root of autolink type
89 S (SCROOT,SCGLB)=""
90 IF SCTYPE="WARD" S SCROOT="DIC(42,",SCGLB="^DIC(42)"
91 IF SCTYPE="SPECIALTY" S SCROOT="DIC(45.7,",SCGLB="^DIC(45.7)"
92 IF SCTYPE="PRACTITIONER" S SCROOT="VA(200,",SCGLB="^VA(200)"
93 IF SCTYPE="ROOM" S SCROOT="DG(405.4,",SCGLB="^DG(405.4)"
94 IF SCTYPE="CLINIC" S SCROOT="SC(",SCGLB="^SC"
95 Q
96 ;
97GETLINK(SC,SCTYPE,SCIEN) ; -- get autolink entity data
98 ; input: SCTYPE := type of autolink (WARD, SPECIALTY, ectc.)
99 ; SCIEN := ien of entity
100 ; output: SC(1..n) := list of Team names autolinked to entity
101 ;
102 ;
103 N SCTEAM,SCROOT,SCGLB,SCINC,SCLINK
104 ; -- deterine global root for autolink entity
105 D ROOT(SCTYPE,.SCROOT,.SCGLB)
106 ; -- set variable pointer value for autolink entity
107 S SCLINK=+SCIEN_";"_$G(SCROOT)
108 ; -- find Teams with autolinks to this entity
109 S (SCINC,SCTEAM)=0
110 IF $O(^SCTM(404.56,"AC",SCLINK,SCTEAM)) D
111 . F S SCTEAM=$O(^SCTM(404.56,"AC",SCLINK,SCTEAM)) Q:'SCTEAM D
112 . . S SCINC=SCINC+1
113 . . S SC(SCINC)=$P($G(^SCTM(404.51,SCTEAM,0)),U)
114 ELSE D
115 . S SCINC=SCINC+1
116 . S SC(SCINC)="No links found."
117 Q
118 ;
119PCPROV(SCTP,DATE,PCAP) ;returns ien & name of practitioner filling position
120 ;Input: SCTP=team position ifn of primary care position assignment
121 ;Input: DATE=relevant date
122 ;Input: PCAP= '1' for pc provider
123 ; '2' for attending provider
124 ; '3' for pc associate provider
125 ;
126 ; Returned [Error or None Found:"", Else: sc200^practname]
127 ;
128 N X,SCPRDTS,SCPR,SCPP,ERR,SCI,SCII,SCPRX,SCSUB,SCX,SCY
129 S SCPP=0,DATE=$G(DATE,DT),SCPRDTS("INCL")=0
130 S (SCPRDTS("BEGIN"),SCPRDTS("END"))=DATE
131 ;bp/cmf 204 original code next line [SCALLHIS param not needed]
132 ;S X=$$PRTPC^SCAPMC(SCTP,"SCPRDTS","SCPR","ERR",1,0)
133 ;bp/cmf 204 change code next line
134 S X=$$PRTPC^SCAPMC(SCTP,"SCPRDTS","SCPR","ERR",0,0)
135 ;regroup providers
136 S SCI=0 F S SCI=$O(SCPR(SCI)) Q:'SCI D
137 .S SCSUB="" F S SCSUB=$O(SCPR(SCI,SCSUB)) Q:SCSUB="" D
138 ..I SCSUB="PREC" S SCPP=1 Q:PCAP=3 ;precepted position flag
139 ..S SCII="" F S SCII=$O(SCPR(SCI,SCSUB,SCII)) Q:SCII="" D
140 ...S SCX=$P(SCPR(SCI,SCSUB,SCII),U,1,2) Q:'SCX
141 ...S SCY=$S(PCAP=2:$P(SCSUB,"-"),1:SCSUB)
142 ...S SCPRX(SCY)=$G(SCPRX(SCY))+1,SCPRX(SCY,SCPRX(SCY))=SCX
143 ...Q
144 ..Q
145 .Q
146 ;return preceptor pc provider
147 I PCAP=1,SCPP,$G(SCPRX("PREC"))=1 Q SCPRX("PREC",1)
148 ;return non-preceptor pc provider
149 I PCAP=1,'SCPP,$G(SCPRX("PROV-U"))=1 Q SCPRX("PROV-U",1)
150 ;return attending provider
151 I PCAP=2,$G(SCPRX("PROV"))=1 Q SCPRX("PROV",1)
152 ;return associate provider
153 I PCAP=3,SCPP,$G(SCPRX("PROV-P"))=1 Q SCPRX("PROV-P",1)
154 ;bp/cmf 204 original code next line [-1 busts documented output]
155 ;Q -1
156 ;bp/cmf 204 change code next line ["" is documented output]
157 Q ""
Note: See TracBrowser for help on using the repository browser.