source: WorldVistAEHR/trunk/r/SCHEDULING-SD-SC/SCAPMCA1.m@ 724

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

initial load of WorldVistAEHR

File size: 4.6 KB
Line 
1SCAPMCA1 ;BP-CIOFO/KEITH - Get all assignment info. (cont.) ; 30 Jul 99 3:29 PM
2 ;;5.3;Scheduling;**177**;AUG 13, 1993
3 ;
4GETDAT ;Get assignment data
5 ;
6GETTM ;Get team information
7 S SCI=$$TMPT^SCAPMC(DFN,.SCDT,,SCRATCH1)
8 S SCI=0 F S SCI=$O(^TMP("SCRATCH1",$J,SCI)) Q:'SCI D
9 .S SCTMD=^TMP("SCRATCH1",$J,SCI),SCTM=+SCTMD,SCPTA=+$P(SCTMD,U,3)
10 .Q:SCTM'>0 ;invalid TEAM ifn
11 .Q:SCPTA'>0 ;invalid PATIENT TEAM ASSIGNMENT ifn
12 .S @SCARR@(DFN,"TM",SCTM,SCPTA)=SCTMD
13 .Q
14 K @SCRATCH1
15 ;
16GETPOS ;Get position information
17 S SCI=$$TPPT^SCAPMC(DFN,.SCDT,,,,,,SCRATCH1)
18 S SCI=0 F S SCI=$O(^TMP("SCRATCH1",$J,SCI)) Q:'SCI D
19 .S SCPOSD=^TMP("SCRATCH1",$J,SCI)
20 .S SCTM=$P(SCPOSD,U,3),SCPTPA=$P(SCPOSD,U,4),SCPOS=+SCPOSD
21 .Q:SCPOS'>0 ;invalid TEAM POSITION ifn
22 .Q:SCTM'>0 ;invalid TEAM ifn
23 .Q:SCPTPA'>0 ;invalid PATIENT TEAM POSITION ASSIGNMENT ifn
24 .S SCPTPA0=$G(^SCPT(404.43,SCPTPA,0))
25 .S SCPTA=+SCPTPA0,SCPCPOSF=$P(SCPTPA0,U,5)
26 .Q:SCPTA'>0 ;invalid PATIENT TEAM ASSIGNMENT ifn
27 .S @SCARR@(DFN,"TM",SCTM,SCPTA,"POS",SCPTPA)=SCPOSD
28 .D SETF(SCPCPOSF,"POS",SCPOSD)
29 .S SCADT=$P(SCPOSD,U,5) ;position activate date
30 .S:'SCADT SCADT=SCDT("BEGIN")
31 .S SCIDT=$P(SCPOSD,U,6) ;position inactivate date
32 .S:'SCIDT SCIDT=SCDT("END")
33 .;xref team pc position assignments
34 .I SCPCPOSF S @SCARR@(DFN,"TM",SCTM,SCPTA,"PC",SCADT,SCIDT)=""
35 .K SCDT2 D DTRADJ(SCADT,SCIDT,.SCDT,.SCDT2)
36 .;
37 .;Get provider information
38 .K @SCRATCH2
39 .S SCII=$$PRTPC^SCAPMC(SCPOS,.SCDT2,SCRATCH2,"ERR",1,1),SCII=0
40 .F S SCII=$O(^TMP("SCRATCH2",$J,SCII)) Q:'SCII D
41 ..F SCSUB="PROV-U","PROV-P" S SCIII="" D
42 ...F S SCIII=$O(^TMP("SCRATCH2",$J,SCII,SCSUB,SCIII)) Q:SCIII="" D
43 ....S SCPRD=^TMP("SCRATCH2",$J,SCII,SCSUB,SCIII)
44 ....S SCPAH=+$P(SCPRD,U,11) ;position assignment history ifn
45 ....S @SCARR@(DFN,"TM",SCTM,SCPTA,"POS",SCPTPA,"PROV",SCPAH)=SCPRD
46 ....D SETF(SCPCPOSF,$S(SCSUB="PROV-P"&SCPCPOSF:"AP",1:"PR"),SCPRD)
47 ....Q
48 ...Q
49 ..S SCIII=""
50 ..F S SCIII=$O(^TMP("SCRATCH2",$J,SCII,"PREC",SCIII)) Q:SCIII="" D
51 ...S SCPRD=^TMP("SCRATCH2",$J,SCII,"PREC",SCIII)
52 ...S SCPPOS=+$P(SCPRD,U,3),SCPPOSD=$$PPOS(SCPRD,SCPPOS)
53 ...S @SCARR@(DFN,"TM",SCTM,SCPTA,"POS",SCPTPA,"PPOS",SCPPOS)=SCPPOSD
54 ...D SETF(SCPCPOSF,"PPOS",SCPPOSD) S SCPAH=+$P(SCPRD,U,11)
55 ...S @SCARR@(DFN,"TM",SCTM,SCPTA,"POS",SCPTPA,"PPOS",SCPPOS,"PPROV",SCPAH)=SCPRD
56 ...D SETF(SCPCPOSF,$S(SCPCPOSF:"PR",1:"PPR"),SCPRD)
57 ...Q
58 ..Q
59 .Q
60 ;Set team "flat" nodes
61 S SCTM=0 F S SCTM=$O(@SCARR@(DFN,"TM",SCTM)) Q:'SCTM S SCPTA=0 D
62 .F S SCPTA=$O(@SCARR@(DFN,"TM",SCTM,SCPTA)) Q:'SCPTA D
63 ..S SCTMD=$G(@SCARR@(DFN,"TM",SCTM,SCPTA)) Q:'$L(SCTMD)
64 ..D SETF($P(SCTMD,U,8)=1,"TM",SCTMD)
65 ..Q
66 .Q
67 Q
68 ;
69GAP(SCTAC,SCTINAC,SCADT,SCIDT) ;Determine if a gap exists in pc assignments
70 N GAP
71 S GAP=0 D G1(SCADT,SCIDT)
72 Q GAP
73 ;
74G1(SCADT,SCIDT) ;Loop through position assignments
75 N X1,X2,X
76 S SCADT=$O(@SCARR@(DFN,"TM",SCTM,SCPTA,"PC",SCIDT-1))
77 I 'SCADT S GAP=(SCIDT<SCTINAC) Q
78 S X1=SCADT,X2=SCIDT D ^%DTC I X>1 S GAP=1 Q
79 S SCIDT=$O(@SCARR@(DFN,"TM",SCTM,SCPTA,"PC",SCADT,""),-1)
80 I SCIDT'<SCTINAC Q
81 D G1(SCADT,SCIDT) Q
82 ;
83PPOS(SCSTR,SCPPOS) ;Get preceptor position information
84 ;Input: SCSTR=preceptor data string from PRTP^SCAPMC
85 ;Input: SCPPOS=preceptor TEAM POSITION ifn
86 ;Output: position information data string as defined in ^SCAPMCA
87 ;
88 N SCX,SCI,SCPPOS0
89 S SCPPOS0=$G(^SCTM(404.57,+SCPPOS,0))
90 Q:'$L(SCPPOS0) ""
91 S SCX(1)=SCPPOS ;position ifn
92 S SCX(2)=$P(SCPPOS0,U) ;position name
93 S SCX(3)=$P(SCPPOS0,U,2) ;team ifn
94 S SCX(4)=$P(SCPOSD,U,4) ;patient team position assignment ifn
95 S SCX(5)=$P(SCSTR,U,5) ;effective date
96 S SCX(6)=$P(SCSTR,U,6) ;inactive date
97 S SCX(7)=$P(SCPPOS0,U,3) ;role ifn
98 S SCX(8)=$P($G(^SD(403.46,+SCX(7),0)),U) ;role name
99 S SCX(9)=$P(SCPPOS0,U,13) ;user class ifn
100 S SCX(10)=$P($G(^USR(8930,+SCX(9),0)),U) ;user class name
101 S SCX(11)=$P(SCPOSD,U,11) ;patient team assignment ifn
102 S SCX(12)="" ;preceptor position
103 S SCX="" F SCI=1:1:12 S $P(SCX,U,SCI)=SCX(SCI)
104 Q SCX
105 ;
106DTRADJ(ADT,IDT,SCDT,SCDT2) ;Adjust dates for provider information
107 ;Input: ADT=activate date for patient team position assignment
108 ;Input: IDT=inactivate date for patient team position assignment
109 ;Input: SCDT=array of dates from calling program (pass by reference)
110 ;Input: SCDT2=array to return adjusted dates (pass by reference)
111 ;
112 S SCDT2("BEGIN")=$S(SCADT>SCDT("BEGIN"):SCADT,1:SCDT("BEGIN"))
113 S SCDT2("END")=$S('SCIDT:SCDT("END"),SCIDT<SCDT("END"):SCIDT,1:SCDT("END"))
114 S SCDT2("INCL")=SCDT("INCL"),SCDT2="SCDT2"
115 Q
116 ;
117SETF(SCPC,SUB,DATA) ;Set "flat" array node
118 ;Input: SCPC=PC/NPC flag
119 ;Input: SUB=subscript value
120 ;Input: DATA=data string
121 N X,CT
122 S X=$S(SCPC>0:"PC",1:"NPC"),SUB=X_SUB
123 S @SCARR@(DFN,SUB,0)=@SCARR@(DFN,SUB,0)+1
124 S CT=@SCARR@(DFN,SUB,0),@SCARR@(DFN,SUB,CT)=DATA
125 Q
Note: See TracBrowser for help on using the repository browser.