SCAPMC8P ;bp/cmf - preceptor sub-array for practitioner list ; 8/10/99 1:19pm
;;5.3;Scheduling;**177,212**;AUG 13, 1993
;;1.0
;
PRCTP ; preceptor practitioners for position
;
ST N SCDATES1,SCN1,SCEFF1,SCPAH1,SCACT1,SCINDT1,SCNODE1,SCPRTP1
N SCDATES2,SCN2,SCPTP,SCX,SCXA,SCXE,SCNA,SCNE,SCPRCLST,SCPRCPTR
N SCP1P11,SCP12,SCP13,SCP14P16,SCR
N SCLIST1,SCLIST2,SCN3,SCN4,SCPS,SCPSX,SCPSXA,SCPSXE,SCVALHIS
;
S @SCLIST@("PR","CH")=$$VALHIST^SCAPMCU5(404.53,SCTP,"SCVALHIS")
G:'$$ACTHIST^SCAPMCU5("SCVALHIS","SCDATES") PRECQ
G:'$D(SCVALHIS) PRECQ
;
LOOP1 ; build list of preceptor assignments
S SCEFF1=-(SCEND+.000001)
S (SCN1,SCLIST1(0))=0
F S SCEFF1=$O(^SCTM(404.53,"AIDT",SCTP,1,SCEFF1)) Q:'SCEFF1 D
. ;Q:'$$ACTHIST^SCAPMCU2(404.53,SCTP,SCDATES,.SCERR,"SCPRTP1")
. S SCPAH1=""
. F S SCPAH1=$O(^SCTM(404.53,"AIDT",SCTP,1,SCEFF1,SCPAH1),-1) Q:'SCPAH1 D
. . Q:'$D(SCVALHIS("I",SCPAH1))
. . N SCACT1,SCI
. . S SCNODE1=^SCTM(404.53,SCPAH1,0)
. . S SCI=$O(SCVALHIS("I",SCPAH1,0))
. . S SCACT1=$O(SCVALHIS(SCI,0))
. . S SCPTP=+$P(SCNODE1,U,6)
. . Q:$D(SCLIST1("SCPR",SCACT1,SCPTP))
. . S SCINDT1=$P(SCVALHIS(SCI,SCACT1,SCPAH1),U)
. . Q:'$$DTCHK^SCAPU1(SCBEGIN,SCEND,SCINCL,SCACT1,SCINDT1)
. . S SCN1=SCN1+1
. . S SCLIST1(0)=SCN1
. . S SCLIST1(SCN1)=SCPTP_U_SCACT1_U_SCINDT1_U_SCPAH1
. . S SCLIST1("SCPR",SCACT1,SCPTP,SCN1)=""
. . Q
. Q
;
LOOP2 ; get preceptors for preceptor assignments
G:SCLIST1(0)<1 PRECQ
S SCLIST2(0)=SCLIST1(0)
F SCN2=1:1:SCLIST2(0) D
. S SCX=SCLIST1(SCN2)
. ; bp/cmf 212 begin
. ; OLD CODE BELOW
. ;S SCPTP=$P(SCX,U)
. ;K SCPRCLST
. ;Q:'$$PRTP^SCAPMC8(SCPTP,"SCDATES","SCPRCLST",SCERR,0)
. ; OLD CODE ABOVE
. ; NEW CODE BELOW
. S SCPTP=$P(SCX,U)
. S SCDATES1("BEGIN")=$P(SCX,U,2)
. S SCDATES1("END")=$P(SCX,U,3)
. S SCDATES1("INCL")=0
. K SCPRCLST
. Q:'$$PRTP^SCAPMC8(SCPTP,"SCDATES1","SCPRCLST",SCERR,0)
. ; NEW CODE ABOVE
. ; bp/cmf 212 end
. Q:'$D(SCPRCLST(0))
. S SCLIST2(SCN2,0)=SCPRCLST(0)
. F SCN3=1:1:SCPRCLST(0) D
. . S SCLIST2(SCN2,SCN3)=SCPRCLST(SCN3)
. Q
;
LOOP3 ; add preceptor sub-array to sclist
G:SCLIST2(0)<1 PRECQ
F SCN1=1:1:@SCLIST@(0) D
. S SCXA=$P(@SCLIST@(SCN1),U,9) ;asgn actdt
. S SCXE=$P(@SCLIST@(SCN1),U,10)
. S SCXE=$S(+SCXE:SCXE,1:9999999) ;asgn enddt
. S SCNA=SCXE
. S SCN4=0
. F S SCNA=$O(SCLIST1("SCPR",SCNA),-1) Q:'SCNA D ;prec actdt
. . S SCPTP=$O(SCLIST1("SCPR",SCNA,0)) ;prec tpien
. . S SCN2=$O(SCLIST1("SCPR",SCNA,SCPTP,0))
. . Q:'$D(SCLIST2(SCN2))
. . S SCP14P16=$P(SCLIST1(SCN2),U,2,4) ;prec string
. . S SCNE=$P(SCLIST1(SCN2),U,3)
. . S SCNE=$S(+SCNE:SCNE,1:9999999) ;prec enddt
. . Q:SCNE<SCXA
. . F SCN3=1:1:SCLIST2(SCN2,0) D
. . . ; bp/cmf 212 begin
. . . ; old code below
. . . ;S SCN4=SCN4+1
. . . ;S SCPSX=SCLIST2(SCN2,SCN3) ;asgn string
. . . ;S SCP1P11=$P(SCPSX,U,1,11) ;pos string
. . . ;S SCP12=$P(SCPSX,U,12) ;should be ""
. . . ;S SCP13=$P(SCPSX,U,13) ;should be ""
. . . ;S SCR=SCP1P11_U_SCP12_U_SCP13_U_SCP14P16 ;rtrn string
. . . ; old code above
. . . ; new code below
. . . S SCPSX=SCLIST2(SCN2,SCN3) ;asgn string
. . . Q:'$$DTCHK^SCAPU1(SCXA,SCXE,0,$P(SCPSX,U,9),$P(SCPSX,U,10))
. . . S SCN4=SCN4+1
. . . S SCP1P11=$P(SCPSX,U,1,11) ;pos string
. . . S SCP12=$P(SCPSX,U,12) ;should be ""
. . . S SCP13=$P(SCPSX,U,13) ;should be ""
. . . S SCR=SCP1P11_U_SCP12_U_SCP13_U_SCP14P16 ;rtrn string
. . . ; new code above
. . . ; bp/cmf 212 end
. . . S @SCLIST@(SCN1,"PR",SCN4)=SCR
. . . S @SCLIST@(SCN1,"PR",0)=SCN4
. . . S @SCLIST@(SCN1,"SCPR",$P(SCR,U),$P(SCR,U,3),$P(SCR,U,14),SCN4)=""
. . . Q
. . Q
. Q
;
PRECQ I +SCALLHIS D TPALL^SCAPMC8A(404.53)
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSCAPMC8P 4074 printed Sep 23, 2025@20:14:35 Page 2
SCAPMC8P ;bp/cmf - preceptor sub-array for practitioner list ; 8/10/99 1:19pm
+1 ;;5.3;Scheduling;**177,212**;AUG 13, 1993
+2 ;;1.0
+3 ;
PRCTP ; preceptor practitioners for position
+1 ;
ST NEW SCDATES1,SCN1,SCEFF1,SCPAH1,SCACT1,SCINDT1,SCNODE1,SCPRTP1
+1 NEW SCDATES2,SCN2,SCPTP,SCX,SCXA,SCXE,SCNA,SCNE,SCPRCLST,SCPRCPTR
+2 NEW SCP1P11,SCP12,SCP13,SCP14P16,SCR
+3 NEW SCLIST1,SCLIST2,SCN3,SCN4,SCPS,SCPSX,SCPSXA,SCPSXE,SCVALHIS
+4 ;
+5 SET @SCLIST@("PR","CH")=$$VALHIST^SCAPMCU5(404.53,SCTP,"SCVALHIS")
+6 if '$$ACTHIST^SCAPMCU5("SCVALHIS","SCDATES")
GOTO PRECQ
+7 if '$DATA(SCVALHIS)
GOTO PRECQ
+8 ;
LOOP1 ; build list of preceptor assignments
+1 SET SCEFF1=-(SCEND+.000001)
+2 SET (SCN1,SCLIST1(0))=0
+3 FOR
SET SCEFF1=$ORDER(^SCTM(404.53,"AIDT",SCTP,1,SCEFF1))
if 'SCEFF1
QUIT
Begin DoDot:1
+4 ;Q:'$$ACTHIST^SCAPMCU2(404.53,SCTP,SCDATES,.SCERR,"SCPRTP1")
+5 SET SCPAH1=""
+6 FOR
SET SCPAH1=$ORDER(^SCTM(404.53,"AIDT",SCTP,1,SCEFF1,SCPAH1),-1)
if 'SCPAH1
QUIT
Begin DoDot:2
+7 if '$DATA(SCVALHIS("I",SCPAH1))
QUIT
+8 NEW SCACT1,SCI
+9 SET SCNODE1=^SCTM(404.53,SCPAH1,0)
+10 SET SCI=$ORDER(SCVALHIS("I",SCPAH1,0))
+11 SET SCACT1=$ORDER(SCVALHIS(SCI,0))
+12 SET SCPTP=+$PIECE(SCNODE1,U,6)
+13 if $DATA(SCLIST1("SCPR",SCACT1,SCPTP))
QUIT
+14 SET SCINDT1=$PIECE(SCVALHIS(SCI,SCACT1,SCPAH1),U)
+15 if '$$DTCHK^SCAPU1(SCBEGIN,SCEND,SCINCL,SCACT1,SCINDT1)
QUIT
+16 SET SCN1=SCN1+1
+17 SET SCLIST1(0)=SCN1
+18 SET SCLIST1(SCN1)=SCPTP_U_SCACT1_U_SCINDT1_U_SCPAH1
+19 SET SCLIST1("SCPR",SCACT1,SCPTP,SCN1)=""
+20 QUIT
End DoDot:2
+21 QUIT
End DoDot:1
+22 ;
LOOP2 ; get preceptors for preceptor assignments
+1 if SCLIST1(0)<1
GOTO PRECQ
+2 SET SCLIST2(0)=SCLIST1(0)
+3 FOR SCN2=1:1:SCLIST2(0)
Begin DoDot:1
+4 SET SCX=SCLIST1(SCN2)
+5 ; bp/cmf 212 begin
+6 ; OLD CODE BELOW
+7 ;S SCPTP=$P(SCX,U)
+8 ;K SCPRCLST
+9 ;Q:'$$PRTP^SCAPMC8(SCPTP,"SCDATES","SCPRCLST",SCERR,0)
+10 ; OLD CODE ABOVE
+11 ; NEW CODE BELOW
+12 SET SCPTP=$PIECE(SCX,U)
+13 SET SCDATES1("BEGIN")=$PIECE(SCX,U,2)
+14 SET SCDATES1("END")=$PIECE(SCX,U,3)
+15 SET SCDATES1("INCL")=0
+16 KILL SCPRCLST
+17 if '$$PRTP^SCAPMC8(SCPTP,"SCDATES1","SCPRCLST",SCERR,0)
QUIT
+18 ; NEW CODE ABOVE
+19 ; bp/cmf 212 end
+20 if '$DATA(SCPRCLST(0))
QUIT
+21 SET SCLIST2(SCN2,0)=SCPRCLST(0)
+22 FOR SCN3=1:1:SCPRCLST(0)
Begin DoDot:2
+23 SET SCLIST2(SCN2,SCN3)=SCPRCLST(SCN3)
End DoDot:2
+24 QUIT
End DoDot:1
+25 ;
LOOP3 ; add preceptor sub-array to sclist
+1 if SCLIST2(0)<1
GOTO PRECQ
+2 FOR SCN1=1:1:@SCLIST@(0)
Begin DoDot:1
+3 ;asgn actdt
SET SCXA=$PIECE(@SCLIST@(SCN1),U,9)
+4 SET SCXE=$PIECE(@SCLIST@(SCN1),U,10)
+5 ;asgn enddt
SET SCXE=$SELECT(+SCXE:SCXE,1:9999999)
+6 SET SCNA=SCXE
+7 SET SCN4=0
+8 ;prec actdt
FOR
SET SCNA=$ORDER(SCLIST1("SCPR",SCNA),-1)
if 'SCNA
QUIT
Begin DoDot:2
+9 ;prec tpien
SET SCPTP=$ORDER(SCLIST1("SCPR",SCNA,0))
+10 SET SCN2=$ORDER(SCLIST1("SCPR",SCNA,SCPTP,0))
+11 if '$DATA(SCLIST2(SCN2))
QUIT
+12 ;prec string
SET SCP14P16=$PIECE(SCLIST1(SCN2),U,2,4)
+13 SET SCNE=$PIECE(SCLIST1(SCN2),U,3)
+14 ;prec enddt
SET SCNE=$SELECT(+SCNE:SCNE,1:9999999)
+15 if SCNE<SCXA
QUIT
+16 FOR SCN3=1:1:SCLIST2(SCN2,0)
Begin DoDot:3
+17 ; bp/cmf 212 begin
+18 ; old code below
+19 ;S SCN4=SCN4+1
+20 ;S SCPSX=SCLIST2(SCN2,SCN3) ;asgn string
+21 ;S SCP1P11=$P(SCPSX,U,1,11) ;pos string
+22 ;S SCP12=$P(SCPSX,U,12) ;should be ""
+23 ;S SCP13=$P(SCPSX,U,13) ;should be ""
+24 ;S SCR=SCP1P11_U_SCP12_U_SCP13_U_SCP14P16 ;rtrn string
+25 ; old code above
+26 ; new code below
+27 ;asgn string
SET SCPSX=SCLIST2(SCN2,SCN3)
+28 if '$$DTCHK^SCAPU1(SCXA,SCXE,0,$PIECE(SCPSX,U,9),$PIECE(SCPSX,U,10))
QUIT
+29 SET SCN4=SCN4+1
+30 ;pos string
SET SCP1P11=$PIECE(SCPSX,U,1,11)
+31 ;should be ""
SET SCP12=$PIECE(SCPSX,U,12)
+32 ;should be ""
SET SCP13=$PIECE(SCPSX,U,13)
+33 ;rtrn string
SET SCR=SCP1P11_U_SCP12_U_SCP13_U_SCP14P16
+34 ; new code above
+35 ; bp/cmf 212 end
+36 SET @SCLIST@(SCN1,"PR",SCN4)=SCR
+37 SET @SCLIST@(SCN1,"PR",0)=SCN4
+38 SET @SCLIST@(SCN1,"SCPR",$PIECE(SCR,U),$PIECE(SCR,U,3),$PIECE(SCR,U,14),SCN4)=""
+39 QUIT
End DoDot:3
+40 QUIT
End DoDot:2
+41 QUIT
End DoDot:1
+42 ;
PRECQ IF +SCALLHIS
DO TPALL^SCAPMC8A(404.53)
+1 QUIT
+2 ;
