source: WorldVistAEHR/trunk/r/SCHEDULING-SD-SC/SCAPMC8P.m@ 623

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

initial load of WorldVistAEHR

File size: 3.9 KB
Line 
1SCAPMC8P ;bp/cmf - preceptor sub-array for practitioner list ; 8/10/99 1:19pm
2 ;;5.3;Scheduling;**177,212**;AUG 13, 1993
3 ;;1.0
4 ;
5PRCTP ; preceptor practitioners for position
6 ;
7ST N SCDATES1,SCN1,SCEFF1,SCPAH1,SCACT1,SCINDT1,SCNODE1,SCPRTP1
8 N SCDATES2,SCN2,SCPTP,SCX,SCXA,SCXE,SCNA,SCNE,SCPRCLST,SCPRCPTR
9 N SCP1P11,SCP12,SCP13,SCP14P16,SCR
10 N SCLIST1,SCLIST2,SCN3,SCN4,SCPS,SCPSX,SCPSXA,SCPSXE,SCVALHIS
11 ;
12 S @SCLIST@("PR","CH")=$$VALHIST^SCAPMCU5(404.53,SCTP,"SCVALHIS")
13 G:'$$ACTHIST^SCAPMCU5("SCVALHIS","SCDATES") PRECQ
14 G:'$D(SCVALHIS) PRECQ
15 ;
16LOOP1 ; build list of preceptor assignments
17 S SCEFF1=-(SCEND+.000001)
18 S (SCN1,SCLIST1(0))=0
19 F S SCEFF1=$O(^SCTM(404.53,"AIDT",SCTP,1,SCEFF1)) Q:'SCEFF1 D
20 . ;Q:'$$ACTHIST^SCAPMCU2(404.53,SCTP,SCDATES,.SCERR,"SCPRTP1")
21 . S SCPAH1=""
22 . F S SCPAH1=$O(^SCTM(404.53,"AIDT",SCTP,1,SCEFF1,SCPAH1),-1) Q:'SCPAH1 D
23 . . Q:'$D(SCVALHIS("I",SCPAH1))
24 . . N SCACT1,SCI
25 . . S SCNODE1=^SCTM(404.53,SCPAH1,0)
26 . . S SCI=$O(SCVALHIS("I",SCPAH1,0))
27 . . S SCACT1=$O(SCVALHIS(SCI,0))
28 . . S SCPTP=+$P(SCNODE1,U,6)
29 . . Q:$D(SCLIST1("SCPR",SCACT1,SCPTP))
30 . . S SCINDT1=$P(SCVALHIS(SCI,SCACT1,SCPAH1),U)
31 . . Q:'$$DTCHK^SCAPU1(SCBEGIN,SCEND,SCINCL,SCACT1,SCINDT1)
32 . . S SCN1=SCN1+1
33 . . S SCLIST1(0)=SCN1
34 . . S SCLIST1(SCN1)=SCPTP_U_SCACT1_U_SCINDT1_U_SCPAH1
35 . . S SCLIST1("SCPR",SCACT1,SCPTP,SCN1)=""
36 . . Q
37 . Q
38 ;
39LOOP2 ; get preceptors for preceptor assignments
40 G:SCLIST1(0)<1 PRECQ
41 S SCLIST2(0)=SCLIST1(0)
42 F SCN2=1:1:SCLIST2(0) D
43 . S SCX=SCLIST1(SCN2)
44 . ; bp/cmf 212 begin
45 . ; OLD CODE BELOW
46 . ;S SCPTP=$P(SCX,U)
47 . ;K SCPRCLST
48 . ;Q:'$$PRTP^SCAPMC8(SCPTP,"SCDATES","SCPRCLST",SCERR,0)
49 . ; OLD CODE ABOVE
50 . ; NEW CODE BELOW
51 . S SCPTP=$P(SCX,U)
52 . S SCDATES1("BEGIN")=$P(SCX,U,2)
53 . S SCDATES1("END")=$P(SCX,U,3)
54 . S SCDATES1("INCL")=0
55 . K SCPRCLST
56 . Q:'$$PRTP^SCAPMC8(SCPTP,"SCDATES1","SCPRCLST",SCERR,0)
57 . ; NEW CODE ABOVE
58 . ; bp/cmf 212 end
59 . Q:'$D(SCPRCLST(0))
60 . S SCLIST2(SCN2,0)=SCPRCLST(0)
61 . F SCN3=1:1:SCPRCLST(0) D
62 . . S SCLIST2(SCN2,SCN3)=SCPRCLST(SCN3)
63 . Q
64 ;
65LOOP3 ; add preceptor sub-array to sclist
66 G:SCLIST2(0)<1 PRECQ
67 F SCN1=1:1:@SCLIST@(0) D
68 . S SCXA=$P(@SCLIST@(SCN1),U,9) ;asgn actdt
69 . S SCXE=$P(@SCLIST@(SCN1),U,10)
70 . S SCXE=$S(+SCXE:SCXE,1:9999999) ;asgn enddt
71 . S SCNA=SCXE
72 . S SCN4=0
73 . F S SCNA=$O(SCLIST1("SCPR",SCNA),-1) Q:'SCNA D ;prec actdt
74 . . S SCPTP=$O(SCLIST1("SCPR",SCNA,0)) ;prec tpien
75 . . S SCN2=$O(SCLIST1("SCPR",SCNA,SCPTP,0))
76 . . Q:'$D(SCLIST2(SCN2))
77 . . S SCP14P16=$P(SCLIST1(SCN2),U,2,4) ;prec string
78 . . S SCNE=$P(SCLIST1(SCN2),U,3)
79 . . S SCNE=$S(+SCNE:SCNE,1:9999999) ;prec enddt
80 . . Q:SCNE<SCXA
81 . . F SCN3=1:1:SCLIST2(SCN2,0) D
82 . . . ; bp/cmf 212 begin
83 . . . ; old code below
84 . . . ;S SCN4=SCN4+1
85 . . . ;S SCPSX=SCLIST2(SCN2,SCN3) ;asgn string
86 . . . ;S SCP1P11=$P(SCPSX,U,1,11) ;pos string
87 . . . ;S SCP12=$P(SCPSX,U,12) ;should be ""
88 . . . ;S SCP13=$P(SCPSX,U,13) ;should be ""
89 . . . ;S SCR=SCP1P11_U_SCP12_U_SCP13_U_SCP14P16 ;rtrn string
90 . . . ; old code above
91 . . . ; new code below
92 . . . S SCPSX=SCLIST2(SCN2,SCN3) ;asgn string
93 . . . Q:'$$DTCHK^SCAPU1(SCXA,SCXE,0,$P(SCPSX,U,9),$P(SCPSX,U,10))
94 . . . S SCN4=SCN4+1
95 . . . S SCP1P11=$P(SCPSX,U,1,11) ;pos string
96 . . . S SCP12=$P(SCPSX,U,12) ;should be ""
97 . . . S SCP13=$P(SCPSX,U,13) ;should be ""
98 . . . S SCR=SCP1P11_U_SCP12_U_SCP13_U_SCP14P16 ;rtrn string
99 . . . ; new code above
100 . . . ; bp/cmf 212 end
101 . . . S @SCLIST@(SCN1,"PR",SCN4)=SCR
102 . . . S @SCLIST@(SCN1,"PR",0)=SCN4
103 . . . S @SCLIST@(SCN1,"SCPR",$P(SCR,U),$P(SCR,U,3),$P(SCR,U,14),SCN4)=""
104 . . . Q
105 . . Q
106 . Q
107 ;
108PRECQ I +SCALLHIS D TPALL^SCAPMC8A(404.53)
109 Q
110 ;
Note: See TracBrowser for help on using the repository browser.